diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,155 @@
+
+0.20.0 to 0.21.0:
+
+  * The code from the @Kernel.Base.UserState@ module has been 
+    moved to the module @Kernel.Drawing.Basis@.
+
+  * Moved @Image@ and @Query@ from @Objects.Basis@ to new module
+    @Objects.Image@. Moved @Chain@, @CtxPicture@ and 
+    @TraceDrawing@ into the new @Drawing@ folder.
+
+  * Added @Wumpus.Basic.Kernel.Drawing.LocDrawing@ module.
+ 
+  * Rationalized the combinators exported by the drawing objects 
+    @Image@, @LocImage@, @LocThetaImage@ and @Connector@.
+ 
+
+0.18.0 to 0.20.0 (no release numbered v0.19.0):
+
+  * Added text advance-vector calculations to @QueryDC@ - 
+    previously they were in Wumpus-Drawing.
+ 
+  * Changed argument order of @run@ functions to follow the usual
+    style - monadic action first and then dependent parameters 
+    (initial state, reader environment etc.).
+ 
+  * Changed representation of Chains to a monadic type with an 
+    explicit operation for next position.
+
+  * Removed @PrimW@ type - pairs are now used instead. 
+
+  * Removed transformer version of @TraceDrawing@. All operations 
+    in TraceDrawing are now specialized to work only on the 
+    @TraceDrawing@ type. Added @UserState@ to TraceDrawing and
+    other drawing monads to compensate for the loss of
+    expressiveness.
+
+  * Changed the internals of @AdvObject@ and @PosObject@ so they 
+    are more idiomatic - both are now essentially reader-writer 
+    monads. Added PosObject functions for text primitives (moved 
+    from Wumpus-Drawing).
+
+  * Changed the @obliterate@ method of the @Decorate@ class.
+
+  * Removed the Semigroup (OPlus) and Bifunctor classes. They are 
+    no longer so pertinent now that Image, LocImage etc. are 
+    newtypes rather than /ContextFuns/.
+
+  * Changed internals of LocImage, LocThetaImage and  Connector 
+    types so the internal points always have Double (PostScript 
+    point) as the unit. This fixes a bug where otherwise changing
+    the font size for drawings with Em or En units would break the
+    layout.
+
+  * Added @ORIGIN@ to the @RectAddress@ enumeration. I had 
+    overlooked that @BLC /= ORIGIN@.
+
+  * Added underline-position and underline-thickness to the font 
+    metrics read by the font loader.
+
+0.17.0 to 0.18.0:
+ 
+  * Major change - removed @ContextFun@ from @Kernel.Base@. Now 
+    the drawing objects (Image, LocImage, Connector...) are 
+    newtype wrapped Reader-Writer monads rather than aliases to 
+    one of the arity family of ContextFuns. Being newtypes gives
+    a lot better opportunities for overloading.
+
+  * Changed Displacement API - it is smaller, and the function 
+    naming is more uniform.
+  
+  * Changed @DrawingPimitives@ to use @DrawStyle@.
+  
+  * Moved vertices generating functions from @Geometry.Path@ to 
+    @Geometry.Vertices@.
+ 
+0.16.0 to 0.17.0:
+
+  * Changed representation of ContextFuns - context funs are no 
+    longer an arity family of newtypes. The new representation 
+    is simpler, but some of the opportunities for overloading 
+    have been lost.
+
+  * Substantial round of renaming for the @DrawingContext@ types
+    an query and update functions.
+
+  * Re-worked the font metrics and font loader modules. The new
+    names should be more systematic. Removed the need for the 
+    GhostScript font modules to match PostScript names to 
+    GhostScript font files.    
+
+  * Superceded the PointSupplyM class by adding snapping grid 
+    scaling to the DrawingContext. 
+ 
+  * Removed @ScalingContext@ module.
+
+  * Made text colour a distinct property in the DrawingContext. 
+    Text is now drawn with the text colour rather than the stroke 
+    colour.
+
+  * Added FontLoadLog to the DrawingContext - this allows access 
+    to the errors recorded during font loading.
+
+0.15.0 to 0.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 @CF3@, an arity three /ContextFunction/.
+
+  * 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@.
+
+0.14.0 to 0.15.0:
+ 
+  * Split previous @Wumpus-Basic@ package into two packages:
+    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move 
+    to separate the developed (although not yet polished) @Kernel@ 
+    and @FontLoader@ code from the prototypical @Drawing@ code.
+
+  * Renamed the @Drawing@ object to @CtxPicture@. Although 
+    @CtxPicture@ is a less pleasant name, it should be less 
+    confusing. A @CtxPicture@ is the essentially the @Picture@ 
+    type from Wumpus-Core with an implicit context - 
+    @ContextPicture@ is simply too long and @CtxPicture@ is 
+    almost jibberish but the previous unrelated name @Drawing@ 
+    was not helpful.
+
+  * @Kernel.Base.ScalingContext@ has been simplified. 
+    ScalingContexts are no longer manipulated via a custom Reader
+    monad or transformer as the type signatures were too unwieldy.
+
+  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing 
+    can now calculate more appealing bounding boxes for text.
+
 0.13.0 to 0.14.0:
 
   * Re-organised module hierarchy, Wumpus-Basic is now divided 
diff --git a/demo/AltUnits.hs b/demo/AltUnits.hs
new file mode 100644
--- /dev/null
+++ b/demo/AltUnits.hs
@@ -0,0 +1,78 @@
+{-# OPTIONS -Wall #-}
+
+
+module AltUnits where
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Monoid
+import System.Directory
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    let pic1 = runCtxPictureU std_attr drawing01
+    writeEPS "./out/alt_units01.eps" pic1
+    writeSVG "./out/alt_units01.svg" pic1
+
+
+std_attr :: DrawingContext
+std_attr = (stroke_colour firebrick . fill_colour linen) $ standardContext 12
+
+
+drawing01 :: CtxPicture
+drawing01 = drawTracing $ combined
+
+
+mf1 :: TraceDrawing Double ()
+mf1 = do
+    draw $ dblLocGraphic `at` P2 12 0
+
+mf2 :: TraceDrawing Em ()
+mf2 = do
+    draw $ emLocGraphic `at` P2 1 0
+
+combined :: TraceDrawing Double ()
+combined = do 
+    draw $ dblLocGraphic `at` P2 12 108
+    drawl (P2 12 72) $ uconvF emLocGraphic
+    draw $ uconvF $ emLocGraphic `at` P2 1 3
+    drawl (P2 12 0) $ uconvF $ hyperlink haskell_org enLocGraphic
+
+dblLocGraphic :: LocGraphic Double
+dblLocGraphic = rect1 `mappend` rect2  
+  where
+    rect1 = dcRectangle DRAW_FILL_STROKE 36 24 
+    rect2 = moveStart (hvec 36) $ dcRectangle DRAW_FILL_STROKE 60 24 
+
+
+
+emLocGraphic :: LocGraphic Em
+emLocGraphic = localize swap_colours $  rect1 `mappend` rect2  
+  where
+    rect1 = dcRectangle DRAW_FILL_STROKE 3 2 
+    rect2 = moveStart (hvec 3) $ dcRectangle DRAW_FILL_STROKE 5 2 
+
+
+enLocGraphic :: LocGraphic En
+enLocGraphic = localize (fill_colour lemon_chiffon) $ rect1 `mappend` rect2  
+  where
+    rect1 = dcRectangle DRAW_FILL_STROKE 6 4
+    rect2 = moveStart (hvec 6) $ dcRectangle DRAW_FILL_STROKE 10 4
+
+
+haskell_org :: XLink
+haskell_org = xlinkhref "http://www.haskell.org"
+
+firebrick               :: RGBi
+firebrick               = RGBi 0xb2 0x22 0x22
+
+lemon_chiffon           :: RGBi
+lemon_chiffon           = RGBi 0xff 0xfa 0xcd
+
+linen                   :: RGBi
+linen                   = RGBi 0xfa 0xf0 0xe6
+
+
diff --git a/demo/FontDeltaPic.hs b/demo/FontDeltaPic.hs
--- a/demo/FontDeltaPic.hs
+++ b/demo/FontDeltaPic.hs
@@ -16,8 +16,7 @@
 main :: IO ()
 main = do 
     createDirectoryIfMissing True "./out/"
-    putStrLn $ "Note - the SVG optimization that should be used here"
-    putStrLn $ "has bit-rotted and is not currently in use.."
+    putStrLn $ "Check the generated SVG to verify the font attrs are grouped..."
     --
     let pic1 = runCtxPictureU std_attr drawing01
     writeEPS "./out/font_delta01.eps" pic1
@@ -28,23 +27,23 @@
 std_attr = standardContext 24
 
 
-drawing01 :: DCtxPicture
+drawing01 :: CtxPicture
 drawing01 = drawTracing $ mf 
 
 
-mf :: (Floating u, FromPtSize u) => TraceDrawing u ()
-mf = do 
+mf :: TraceDrawing Double ()
+mf = fontDelta $ do
     draw $ line1 `at` (P2 0 100)
     draw $ line2 `at` (P2 0  75)
     draw $ line3 `at` (P2 0  50)
     draw $ line4 `at` (P2 0  25)
     draw $ line5 `at` (P2 0   0) 
   where
-    line1 = textline "All the lines of this drawing" 
-    line2 = textline "should be grouped within a SVG"
-    line3 = textline "g-element, from where they"
-    line4 = textline "inherit the font-family and"
-    line5 = textline "font-size attributes."
+    line1 = dcTextlabel "All the lines of this drawing" 
+    line2 = dcTextlabel "should be grouped within a SVG"
+    line3 = dcTextlabel "g-element, from where they"
+    line4 = dcTextlabel "inherit the font-family and"
+    line5 = dcTextlabel "font-size attributes."
 
 
 
diff --git a/demo/SimpleAdvGraphic.hs b/demo/SimpleAdvGraphic.hs
new file mode 100644
--- /dev/null
+++ b/demo/SimpleAdvGraphic.hs
@@ -0,0 +1,68 @@
+{-# OPTIONS -Wall #-}
+
+
+module SimpleAdvGraphic where
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Control.Applicative
+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 :: CtxPicture
+drawing01 = drawTracing mf 
+
+
+
+-- Although TraceDrawing can be fully unit polymorphic, it seems 
+-- always best to specialize as we are stating concrete values
+-- (and they will be in some unit).
+--
+
+mf :: TraceDrawing Double ()
+mf = do
+    drawl (P2 0 120) $ 
+        runAdvObject $ evenspace (hvec 10) [text01, text02, text01]
+
+    drawl (P2 0 80) $ 
+        runAdvObject $ advances [text01, text02, text01]
+
+    drawl (P2 0 40) $ 
+        runAdvObject (miniDisk `advance` text01 `advance` miniDisk)
+
+    drawl (P2 0 0) $
+        runAdvObject (miniDisk `advance` text02 `advance` miniDisk)
+
+
+-- Normally, text calculate the advance vector from the font 
+-- metrics...
+--
+text01 :: AdvGraphic Double
+text01 = makeAdvObject (pure $ hvec 84) $ dcTextlabel "text01"
+    
+
+text02 :: AdvGraphic Double
+text02 = makeAdvObject (pure $ hvec 210) $ dcTextlabel "text number two"
+
+
+miniDisk :: AdvGraphic Double
+miniDisk = makeAdvObject (pure $ V2 0 0) disk1 
+  where
+    disk1 = localize (fill_colour sienna) $ dcDisk DRAW_FILL 3
+
+
+sienna :: RGBi
+sienna = RGBi 160 82 45
diff --git a/demo/SimplePosObject.hs b/demo/SimplePosObject.hs
new file mode 100644
--- /dev/null
+++ b/demo/SimplePosObject.hs
@@ -0,0 +1,114 @@
+{-# OPTIONS -Wall #-}
+
+
+module SimplePosObject where
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Core.Colour ( red )
+
+import Data.Monoid
+import System.Directory
+
+
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    let pic1 = runCtxPictureU std_ctx drawing01
+    writeEPS "./out/simple_pos_object01.eps" pic1
+    writeSVG "./out/simple_pos_object01.svg" pic1
+
+
+std_ctx :: DrawingContext
+std_ctx = standardContext 24
+
+
+drawing01 :: CtxPicture
+drawing01 = drawTracing $ localize (fill_colour red) $ mf 
+
+
+mf :: TraceDrawing Double ()
+mf = do
+    draw $ testDrawMinor NN     `at` (P2   0 400)
+    draw $ testDrawMinor SS     `at` (P2  75 400)
+    draw $ testDrawMinor EE     `at` (P2 150 400)
+    draw $ testDrawMinor WW     `at` (P2 225 400)
+    draw $ testDrawMinor NE     `at` (P2   0 325)
+    draw $ testDrawMinor SE     `at` (P2  75 325)
+    draw $ testDrawMinor SW     `at` (P2 150 325)
+    draw $ testDrawMinor NW     `at` (P2 225 325)
+    draw $ testDrawMinor CENTER `at` (P2   0 250)
+    draw $ testDrawMinor BLL    `at` (P2  75 250)
+    draw $ testDrawMinor BLC    `at` (P2 150 250)
+    draw $ testDrawMinor BLR    `at` (P2 225 250)
+
+
+    draw $ testDrawBl    NN     `at` (P2   0 150)
+    draw $ testDrawBl    SS     `at` (P2  75 150)
+    draw $ testDrawBl    EE     `at` (P2 150 150)
+    draw $ testDrawBl    WW     `at` (P2 225 150)
+    draw $ testDrawBl    NE     `at` (P2   0 75)
+    draw $ testDrawBl    SE     `at` (P2  75 75)
+    draw $ testDrawBl    SW     `at` (P2 150 75)
+    draw $ testDrawBl    NW     `at` (P2 225 75)
+    draw $ testDrawBl    CENTER `at` (P2   0  0)
+    draw $ testDrawBl    BLL    `at` (P2  75  0)
+    draw $ testDrawBl    BLC    `at` (P2 150  0)
+    draw $ testDrawBl    BLR    `at` (P2 225  0)
+    
+    drawl (P2 300 0) $ runPosObject SW msg
+  where
+    msg = multilinePosText VALIGN_RIGHT "Red dot represents the\nrectangle address."
+
+
+testDrawBl :: RectAddress -> LocGraphic Double
+testDrawBl raddr = dcDisk DRAW_FILL 2 `mappend` rectBl raddr
+
+
+rectBl :: RectAddress -> LocGraphic Double
+rectBl raddr = 
+    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)
+  where
+    w    = 40 
+    h    = 30
+    ortt = Orientation { or_x_minor = 0
+                       , or_x_major = w
+                       , or_y_minor = 0
+                       , or_y_major = h }
+ 
+
+-- start-point - bottom left
+mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u
+mkRectBl w h = dcRectangle DRAW_STROKE w h
+
+
+
+testDrawMinor :: RectAddress -> LocGraphic Double
+testDrawMinor raddr = 
+    dcDisk DRAW_FILL 2 `mappend` (ignoreAns $ rectMinor raddr)
+
+
+rectMinor :: RectAddress -> LocGraphic Double
+rectMinor raddr = 
+    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)
+  where
+    m    = 10
+    w    = 40 
+    h    = 30
+    ortt = Orientation { or_x_minor = m
+                       , or_x_major = (w-m)
+                       , or_y_minor = m
+                       , or_y_major = (h-m) }
+ 
+
+-- start-point - +10 +10
+mkRectMinor :: InterpretUnit u => u -> u -> u -> LocGraphic u
+mkRectMinor m w h = promoteLoc $ \pt -> 
+    let bl = displace (vec (-m) (-m)) pt
+        br = displace (hvec w) bl
+        tr = displace (vvec h) br
+        tl = displace (vvec h) bl
+    in liftQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath DRAW_STROKE
+
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
@@ -12,42 +12,80 @@
 --
 -- Import shim for @Wumpus.Basic.Kernel@ modules.
 --
+-- @Kernel.Base@ - low-level objects, general enumerations, unit 
+-- and @DrawingContext@ support. @DrawingContext@ is comparative 
+-- to the /graphics state/ in PostScript, but it is a read-only
+-- environment (cf. the Reader monad). Like the Reader monad it 
+-- supports branching update through @local@ - here called 
+-- @localize@.
+-- 
+-- @Kernel.Objects@ - \"elementary\" drawing objects, plus some 
+-- catalogues of named, predefined drawing objects 
+-- (DrawingPrimitives) and useful operations (named vectors - 
+-- Displacement).
 --
+-- @Kernel.Drawing@ - \"collective\" drawing objects. @Drawing@ is 
+-- considered a higher layer than @Objects@, so there should be 
+-- dependencies only from @Drawing@ to @Objects@.
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel
   (
-    module Wumpus.Basic.Kernel.Base.Anchors
-  , module Wumpus.Basic.Kernel.Base.BaseDefs
-  , module Wumpus.Basic.Kernel.Base.ContextFun
+    module Wumpus.Basic.Kernel.Base.BaseDefs
   , module Wumpus.Basic.Kernel.Base.DrawingContext
-  , module Wumpus.Basic.Kernel.Base.GlyphMetrics
+  , module Wumpus.Basic.Kernel.Base.FontSupport
   , module Wumpus.Basic.Kernel.Base.QueryDC
-  , module Wumpus.Basic.Kernel.Base.ScalingContext
+  , module Wumpus.Basic.Kernel.Base.Units
   , module Wumpus.Basic.Kernel.Base.UpdateDC
   , module Wumpus.Basic.Kernel.Base.WrappedPrimitive
-  , module Wumpus.Basic.Kernel.Objects.AdvanceGraphic
-  , module Wumpus.Basic.Kernel.Objects.BaseObjects
+  , module Wumpus.Basic.Kernel.Drawing.Basis
+  , module Wumpus.Basic.Kernel.Drawing.Chain
+  , module Wumpus.Basic.Kernel.Drawing.CtxPicture
+  , module Wumpus.Basic.Kernel.Drawing.LocDrawing
+  , module Wumpus.Basic.Kernel.Drawing.LocTrace
+  , module Wumpus.Basic.Kernel.Drawing.PosObject
+  , module Wumpus.Basic.Kernel.Drawing.TraceDrawing
+  , module Wumpus.Basic.Kernel.Objects.AdvObject
+  , module Wumpus.Basic.Kernel.Objects.Anchors
+  , module Wumpus.Basic.Kernel.Objects.Basis
   , module Wumpus.Basic.Kernel.Objects.Bounded
+  , module Wumpus.Basic.Kernel.Objects.Concat
   , module Wumpus.Basic.Kernel.Objects.Connector
-  , module Wumpus.Basic.Kernel.Objects.CtxPicture
-  , module Wumpus.Basic.Kernel.Objects.Graphic
-  , module Wumpus.Basic.Kernel.Objects.TraceDrawing
+  , module Wumpus.Basic.Kernel.Objects.Displacement
+  , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+  , module Wumpus.Basic.Kernel.Objects.Image
+  , module Wumpus.Basic.Kernel.Objects.LocImage
+  , module Wumpus.Basic.Kernel.Objects.LocThetaImage
+  , module Wumpus.Basic.Kernel.Objects.Orientation
+  , module Wumpus.Basic.Kernel.Objects.Trail
+
   ) where
 
-import Wumpus.Basic.Kernel.Base.Anchors
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.DrawingContext
-import Wumpus.Basic.Kernel.Base.GlyphMetrics
+import Wumpus.Basic.Kernel.Base.FontSupport
 import Wumpus.Basic.Kernel.Base.QueryDC
-import Wumpus.Basic.Kernel.Base.ScalingContext
+import Wumpus.Basic.Kernel.Base.Units 
 import Wumpus.Basic.Kernel.Base.UpdateDC
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
-import Wumpus.Basic.Kernel.Objects.AdvanceGraphic
-import Wumpus.Basic.Kernel.Objects.BaseObjects
+import Wumpus.Basic.Kernel.Drawing.Basis
+import Wumpus.Basic.Kernel.Drawing.Chain
+import Wumpus.Basic.Kernel.Drawing.CtxPicture
+import Wumpus.Basic.Kernel.Drawing.LocDrawing
+import Wumpus.Basic.Kernel.Drawing.LocTrace
+import Wumpus.Basic.Kernel.Drawing.PosObject
+import Wumpus.Basic.Kernel.Drawing.TraceDrawing
+import Wumpus.Basic.Kernel.Objects.AdvObject
+import Wumpus.Basic.Kernel.Objects.Anchors
+import Wumpus.Basic.Kernel.Objects.Basis
 import Wumpus.Basic.Kernel.Objects.Bounded
+import Wumpus.Basic.Kernel.Objects.Concat
 import Wumpus.Basic.Kernel.Objects.Connector
-import Wumpus.Basic.Kernel.Objects.CtxPicture
-import Wumpus.Basic.Kernel.Objects.Graphic
-import Wumpus.Basic.Kernel.Objects.TraceDrawing
+import Wumpus.Basic.Kernel.Objects.Displacement
+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Kernel.Objects.LocThetaImage
+import Wumpus.Basic.Kernel.Objects.Orientation
+import Wumpus.Basic.Kernel.Objects.Trail
diff --git a/src/Wumpus/Basic/Kernel/Base/Anchors.hs b/src/Wumpus/Basic/Kernel/Base/Anchors.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Base/Anchors.hs
+++ /dev/null
@@ -1,238 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Base.Anchors
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Anchor points on shapes, bounding boxes, etc.
---
--- Anchors are addressable positions, an examplary use is taking
--- anchors on node shapes to get the start and end points for 
--- connectors in a network (graph) diagram.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Base.Anchors
-  ( 
-
-  -- * Anchors
-    CenterAnchor(..)
-  , CardinalAnchor(..)
-  , CardinalAnchor2(..)
-  , RadialAnchor(..)
-
-  -- * Extended anchor points
-  , northwards
-  , southwards
-  , eastwards
-  , westwards
-  , northeastwards
-  , southeastwards
-  , southwestwards
-  , northwestwards
-
-  , radialConnectorPoints
-
-  ) where
-
-import Wumpus.Core                      -- package: wumpus-core
-
-import Data.AffineSpace                 -- package: vector-space
-
-
--- | Center of an object.
---
-class CenterAnchor t where
-  center :: DUnit t ~ u => t -> Point2 u
-
--- | Cardinal (compass) positions on an object. 
--- 
--- Note - in TikZ cardinal anchors are not necessarily at the
--- equivalent radial position, for instance reactangle north-east
--- is the top-right corner whether or not this is incident at 
--- 45deg.
---
--- Wumpus generally follows the TikZ convention.
---
-class CardinalAnchor t where
-  north :: DUnit t ~ u => t -> Point2 u
-  south :: DUnit t ~ u => t -> Point2 u
-  east  :: DUnit t ~ u => t -> Point2 u
-  west  :: DUnit t ~ u => t -> Point2 u
-
-
--- | 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 
--- classes.
---
-class CardinalAnchor2 t where
-  northeast :: DUnit t ~ u => t -> Point2 u
-  southeast :: DUnit t ~ u => t -> Point2 u
-  southwest :: DUnit t ~ u => t -> Point2 u
-  northwest :: DUnit t ~ u => t -> Point2 u
-
-
--- | Anchor on a border that can be addressed by an angle.
---
--- The angle is counter-clockwise from the right-horizontal, i.e.
--- 0 is /east/.
---
-class RadialAnchor t where
-  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u
-
-
-
-
-extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u
-extendPtDist d p1 p2 = let v   = pvec p1 p2
-                           ang = 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.
---
--- If the distance is positive the anchor outside the object.
---
-northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-              , u ~ DUnit t ) 
-           => u -> t -> Point2 u
-northwards u a = extendPtDist u (center a) (north a)
-
-
--- | 'southwards' : @ dist * object -> Point @
--- 
--- Variant of the function 'northwards', but projecting the line 
--- southwards from the center of the object.
---
-southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-              , u ~ DUnit t ) 
-           => u -> t -> Point2 u
-southwards u a = extendPtDist u (center a) (south a)
-
-
--- | 'eastwards' : @ dist * object -> Point @
--- 
--- 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 @
--- 
--- Variant of the function 'northwards', but projecting the line 
--- westwards from the center of the object.
---
-westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-             , u ~ DUnit t ) 
-          => u -> t -> Point2 u
-westwards u a = extendPtDist u (center a) (west a)
-
-
--- | 'northeastwards' : @ 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 @
--- 
--- 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 @
--- 
--- Variant of the function 'northwards', but projecting the line 
--- southwestwards from the center of the object.
---
-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.
---
-northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
-                  , u ~ DUnit t ) 
-               => u -> t -> Point2 u
-northwestwards u a = extendPtDist u (center a) (northwest a)
-
-
---------------------------------------------------------------------------------
-
--- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @
---
--- Find the radial connectors points for objects @a@ and @b@ along
--- the line joining their centers.
---
-radialConnectorPoints :: ( Real u, Floating u
-                         , CenterAnchor t1, RadialAnchor t1
-                         , CenterAnchor t2, RadialAnchor t2
-                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) 
-                      => t1 -> t2 -> (Point2 u, Point2 u) 
-radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)
-  where
-    theta = vdirection $ pvec (center a) (center b)
-    
-
---------------------------------------------------------------------------------
--- Instances 
-
-instance Fractional u => CenterAnchor (BoundingBox u) where
-  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y 
-     where
-       x = xl+0.5*(xr-xl)
-       y = ylo+0.5*(yhi-ylo)
-       
-
-instance Fractional u => CardinalAnchor (BoundingBox u) where
-  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi
-  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo
-  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))
-  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))
-
-
-instance Fractional u => CardinalAnchor2 (BoundingBox u) where
-  northeast (BBox _ ur)                 = ur
-  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo
-  southwest (BBox ll _)                 = ll
-  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi 
-
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
@@ -1,13 +1,10 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernal.Base.BaseDefs
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2012
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -22,262 +19,540 @@
 module Wumpus.Basic.Kernel.Base.BaseDefs
   (
 
-  -- * A semigroup class
-    OPlus(..)
-  , oconcat
+  -- * Constants
+    quarter_pi
+  , half_pi
+  , two_pi
 
-  -- * A bifunctor class
-  , Bimap(..)
-  , replaceL
-  , replaceR
+  , ang180
+  , ang150
+  , ang120
+  , ang90
+  , ang60
+  , ang45
+  , ang30
+  , ang15
 
+  -- * Unit phantom type
+  , UNil(..)
+  , ureturn
+  , uvoid
+
+  -- * Non-contextual unit conversion.
+  , ScalarUnit(..)
+
+  -- * Unit interpretation with respect to the current Point size
+  , InterpretUnit(..)
+  , dinterpF
+  , normalizeF
+  , uconvert1
+  , uconvertF
+
+  , intraMapPoint
+  , intraMapFunctor
+
+
+  -- * KernChar
+  , KernChar
+
+  -- * Drawing paths and shapes (closed paths)
+  , PathMode(..)
+  , DrawMode(..)
+  , closedMode
+
+  -- * Drawing layers
+  , ZOrder(..)  
+
   -- * Alignment
   , HAlign(..)
   , VAlign(..)  
 
-  -- * Advance vector
-  , AdvanceVec
-  , advanceH
-  , advanceV
+  -- * Text height
+  , TextHeight(..)
 
-  -- * Moving points
-  , PointDisplace
-  , displace
-  , displaceVec
-  , displaceH
-  , displaceV
+  -- * Cardinal (compass) positions
+  , Cardinal(..)
 
-  , ThetaPointDisplace
-  , displaceParallel
-  , displacePerpendicular
+  -- * Direction enumeration
+  , Direction(..)
+  , ClockDirection(..)  
+  , clockDirection
 
+  , HDirection(..)
+  , horizontalDirection
+  , VDirection(..)
+  , verticalDirection
 
-  -- * Monadic drawing
-  , MonUnit
+  -- * Quadrant enumeration
+  , Quadrant(..)
+  , quadrant
 
-  , PointSupplyM(..)
+  -- * Beziers
 
+  , bezierArcPoints  
+  , bezierMinorArc
+  
+
+  -- * Misc
+
+  , both
+  , monPreRepeatPost
+
   ) where
 
 import Wumpus.Core                              -- package: wumpus-core
 
+
 import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
 
-infixr 6 `oplus`
+import Control.Applicative
+import Data.Monoid
 
--- | A Semigroup class.
--- 
--- The perhaps unusual name is the TeX name for the circled plus 
--- glyph. It would be nice if there was a semigroup class in the
--- Haskell Base libraries...  
--- 
-class OPlus t where
-  oplus :: t -> t -> t
 
-oconcat :: OPlus t => t -> [t] -> t
-oconcat t = step t
-  where
-    step ac []     = ac
-    step ac (x:xs) = step (ac `oplus` x) xs
 
 
 
-instance OPlus () where
-  _ `oplus` _ = ()
 
-instance OPlus (UNil u) where
-  _ `oplus` _ = uNil
+quarter_pi      :: Radian
+quarter_pi      = 0.25 * pi
 
-instance Ord u => OPlus (BoundingBox u) where
-  oplus = boundaryUnion
+half_pi         :: Radian
+half_pi         = 0.5 * pi
 
-instance OPlus (Primitive u) where
-  a `oplus` b = primGroup [a,b]
+two_pi          :: Radian
+two_pi          = 2.0 * pi
 
-instance (OPlus a, OPlus b) => OPlus (a,b) where
-  (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b')
 
+ang180          :: Radian
+ang180          = pi
 
-instance OPlus a => OPlus (r -> a) where
-  f `oplus` g = \x -> f x `oplus` g x
+ang150          :: Radian
+ang150          = 5 * ang30
 
--- The functional instance (r -> a) also covers (r1 -> r2 -> a),
--- (r1 -> r2 -> r3 -> a) etc.
+ang120          :: Radian 
+ang120          = 2 * ang60
 
+ang90           :: Radian
+ang90           = pi / 2
+
+ang60           :: Radian
+ang60           = pi / 3
+
+ang45           :: Radian 
+ang45           = pi / 4
+
+ang30           :: Radian
+ang30           = pi / 6
+
+ang15           :: Radian
+ang15           = pi / 12
+
+
+
 --------------------------------------------------------------------------------
+-- Simple objects wrapped with unit phatom type 
 
--- | A Bifunctor class.
+
+-- | The empty data type - i.e. @()@ - wrapped with a phantom unit 
+-- parameter.
+--
+data UNil   u = UNil          deriving (Eq,Ord,Read,Show)
+
+type instance DUnit (UNil u) = u
+
+instance Functor UNil where
+  fmap _ UNil= UNil
+
+
+instance Monoid (UNil u) where
+  mempty        = UNil
+  _ `mappend` _ = UNil
+
+
+
+
+instance Rotate (UNil u) where
+  rotate _              = id
+
+instance RotateAbout (UNil u) where
+  rotateAbout _ _       = id
+
+instance Scale (UNil u) where
+  scale _ _             = id
+
+instance Translate (UNil u) where
+  translate _ _         = id
+
+-- | Return a 'UNil' rather than @()@ at the end of sequence of
+-- monadic commands.
+--
+-- Many Wumpus objects are usefully constructed in the 
+-- @do-notation@, but because Wumpus has to expose the type of 
+-- the @unit@ to the type checker we must finish the do-block 
+-- with:
+--
+-- > ureturn
 -- 
--- Again, it would be nice if there was a Bifunctor class in the
--- Haskell Base libraries...  
+-- or:
 -- 
-class Bimap f where
-  bimap     :: (a -> p) -> (b -> q) -> f a b -> f p q
-  bimapL    :: (a -> p) -> f a b -> f p b
-  bimapR    :: (b -> q) -> f a b -> f a q
+-- > return UNil
+--
+-- rather than:
+--
+-- > return ()
+--
+--
+ureturn :: Monad m => m (UNil u)
+ureturn = return UNil
 
+-- | 'uvoid' runs a monadic computation and returns @UNil@.
+--
+uvoid :: Monad m => m a -> m (UNil u)
+uvoid ma = ma >> return UNil
 
+--------------------------------------------------------------------------------
+-- Non-contextual units
 
-instance Bimap (,) where
-  bimap f g (a,b) = (f a, g b)
-  bimapL f (a,b)  = (f a, b)
-  bimapR g (a,b)  = (a, g b)
+class ScalarUnit a where
+  fromPsPoint :: Double -> a 
+  toPsPoint   :: a -> Double
 
-instance Bimap Either where
-  bimap f _ (Left a)  = Left (f a)
-  bimap _ g (Right b) = Right (g b)
+instance ScalarUnit Double where
+  fromPsPoint = id
+  toPsPoint   = id 
 
-  bimapL f (Left a)  = Left (f a)
-  bimapL _ (Right b) = Right b
 
-  bimapR _ (Left a)  = Left a
-  bimapR g (Right b) = Right (g b)
 
-replaceL :: Bimap f => p -> f a b -> f p b
-replaceL = bimapL . const
+--------------------------------------------------------------------------------
+-- Interpreting units 
 
-replaceR :: Bimap f => q -> f a b -> f a q
-replaceR = bimapR . const
+-- Units may or may not depend on current font size
+--
 
+class (Eq u, Num u) => InterpretUnit u where
+  normalize :: FontSize -> u -> Double
+  dinterp   :: FontSize -> Double -> u
 
---------------------------------------------------------------------------------
+instance InterpretUnit Double where
+  normalize _ = id
+  dinterp   _ = id 
 
--- Alignment
+instance InterpretUnit AfmUnit where
+  normalize sz = afmValue sz 
+  dinterp   sz = afmUnit sz
 
--- | Horizontal alignment - align to the top, center or bottom.
+
+-- | 'dinterp' an object that gives access to its unit at the 
+-- functor position.
 --
-data HAlign = HTop | HCenter | HBottom
-  deriving (Enum,Eq,Ord,Show)
+dinterpF :: (Functor t, InterpretUnit u) => FontSize -> t Double -> t u
+dinterpF sz = fmap (dinterp sz)
 
--- | Vertical alignment - align to the left, center or bottom.
+
+-- | 'normalize' an object that gives access to its unit at the 
+-- functor position.
 --
-data VAlign = VLeft | VCenter | VRight
-  deriving (Enum,Eq,Ord,Show)
+normalizeF :: (Functor t, InterpretUnit u) => FontSize -> t u -> t Double
+normalizeF sz = fmap (normalize sz)
 
 
---------------------------------------------------------------------------------
+-- | Convert a scalar value from one unit to another.
+--
+uconvert1 :: (InterpretUnit u, InterpretUnit u1) => FontSize -> u -> u1
+uconvert1 sz = dinterp sz . normalize sz
 
--- | Advance vectors provide an idiom for drawing consecutive
--- graphics. PostScript uses them to draw left-to-right text - 
--- each character has an advance vector for the width and 
--- as characters are drawn they successively displace the start
--- point for the next character with their advance vector.
+-- | Unit convert an object that gives access to its unit at the
+-- Functor position.
 --
--- Type alias for Vec2.
+-- In practive this will be \*all\* Image answers.
 --
-type AdvanceVec u = Vec2 u
+uconvertF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
+          => FontSize -> t u -> t u1
+uconvertF sz = fmap (uconvert1 sz)
 
 
--- | Extract the horizontal component of an advance vector.
+
+-- Helper for defining Affine instances. This function allows 
+-- scaling etc to be applied on a Point coerced to a Double then
+-- converted back to the original unit. Thus transformations can 
+-- work in contextual units.
 --
--- For left-to-right latin text, the vertical component of an
--- advance vector is expected to be 0. Ingoring it seems 
--- permissible when drawing text.
+intraMapPoint :: InterpretUnit u 
+              => FontSize -> (DPoint2 -> DPoint2) -> Point2 u -> Point2 u
+intraMapPoint sz fn (P2 x y) = 
+    let P2 x' y' = fn $ P2 (normalize sz x) (normalize sz y)
+    in  P2 (dinterp sz x') (dinterp sz y')
+
+
+
+-- Helper for defining Affine instances. This function allows 
+-- scaling etc to be applied on a Point coerced to a Double then
+-- converted back to the original unit. Thus transformations can 
+-- work in contextual units.
 --
-advanceH :: AdvanceVec u -> u
-advanceH (V2 w _)  = w
+intraMapFunctor :: (Functor f, InterpretUnit u)
+                => FontSize -> (f Double -> f Double) -> f u -> f u
+intraMapFunctor sz fn ma = dinterpF sz $ fn $ normalizeF sz ma
 
--- | Extract the verticall component of an advance vector.
+
+--------------------------------------------------------------------------------
+-- KernChar
+
+
+-- | Unit parametric version of KerningChar from Wumpus-Core.
 --
-advanceV :: AdvanceVec u -> u
-advanceV (V2 _ h)  = h
+type KernChar u = (u,EscapedChar)
 
+
 --------------------------------------------------------------------------------
--- Displacing points
+-- Drawing closed paths
 
--- | 'PointDisplace' is a type representing functions 
--- @from Point to Point@.
+
+-- | Draw closed paths. 
+-- 
+-- > OSTROKE - open and stroked
 --
--- 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.
+-- > CSTROKE - closed and stroke
 --
-type PointDisplace u = Point2 u -> Point2 u
+-- > CFILL - closed and filled
+--
+-- > CFILL_STROKE - closed, the path is filled, its edge is stroked.
+--
+data PathMode = OSTROKE | CSTROKE | CFILL | CFILL_STROKE
+  deriving (Bounded,Enum,Eq,Ord,Show)
 
--- | 'displace' : @ x -> y -> PointDisplace @
+
+
+-- | Draw closed paths and shapes. 
+-- 
+-- > DRAW_STROKE - closed and stroked
 --
--- Build a combinator to move @Points@ by the supplied @x@ and 
--- @y@ distances.
+-- > DRAW_FILL - closed and filled
 --
-displace :: Num u => u -> u -> PointDisplace u
-displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
+-- > DRAW_FILL_STROKE - the path is filled, its edge is stroked.
+--
+data DrawMode = DRAW_STROKE | DRAW_FILL | DRAW_FILL_STROKE
+  deriving (Bounded,Enum,Eq,Ord,Show)
 
 
--- | 'displaceV' : @ (V2 x y) -> PointDisplace @
+-- | Interpret a 'DrawMode' for a closed path.
+--
+closedMode :: DrawMode -> PathMode
+closedMode DRAW_STROKE      = CSTROKE 
+closedMode DRAW_FILL        = CFILL 
+closedMode DRAW_FILL_STROKE = CFILL_STROKE
+
+
+
+
+
+-- | Enumerated type for drawing with respect to the z-order.
+--
+data ZOrder = ZBELOW | ZABOVE
+  deriving (Bounded,Enum,Eq,Ord,Show)
+
+
+--------------------------------------------------------------------------------
+
+-- Alignment
+
+-- | Horizontal alignment - align to the top, center or bottom.
+--
+data HAlign = HALIGN_TOP | HALIGN_CENTER | HALIGN_BASE
+  deriving (Enum,Eq,Ord,Show)
+
+-- | Vertical alignment - align to the left, center or bottom.
+--
+data VAlign = VALIGN_LEFT | VALIGN_CENTER | VALIGN_RIGHT
+  deriving (Enum,Eq,Ord,Show)
+
+
+--------------------------------------------------------------------------------
+-- Text height
+
+
+-- | Wumpus distinguishes two use-cases for displaying vertically 
+-- centered text.
 -- 
--- Version of 'displace' where the displacement is supplied as
--- a vector rather than two parameters.
+-- Arbitrary text that is expected to contain lower case letters 
+-- with descenders, show take the vertical center as the mid-point 
+-- between the cap height and the descender depth.
+--
+-- Unfortunately, including the descender depth can produce 
+-- unbalanced results for text which is not expected to have 
+-- descenders (e.g. numbers within a bordered box), visually this 
+-- makes the center too high.
 -- 
-displaceVec :: Num u => Vec2 u -> PointDisplace u
-displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
+data TextHeight = JUST_CAP_HEIGHT | CAP_HEIGHT_PLUS_DESCENDER
+  deriving (Enum,Eq,Ord,Show)
 
 
--- | 'displaceH' : @ x -> PointDisplace @
--- 
--- Build a combinator to move @Points@ by horizontally the 
--- supplied @x@ distance.
+
+--------------------------------------------------------------------------------
+
+-- Compass positions
+
+-- | An enumeratied type representing the compass positions.
 --
-displaceH :: Num u => u -> PointDisplace u
-displaceH dx (P2 x y) = P2 (x+dx) y
+data Cardinal = NORTH | NORTH_EAST | EAST | SOUTH_EAST 
+              | SOUTH | SOUTH_WEST | WEST | NORTH_WEST
+   deriving (Enum,Eq,Ord,Show) 
 
--- | 'displaceV' : @ y -> PointDisplace @
--- 
--- Build a combinator to move @Points@ vertically by the supplied 
--- @y@ distance.
+
+-- | An enumerated type representing horizontal and vertical 
+-- directions.
 --
-displaceV :: Num u => u -> PointDisplace u
-displaceV dy (P2 x y) = P2 x (y+dy)
+data Direction = UP | DOWN | LEFT | RIGHT
+   deriving (Enum,Eq,Ord,Show) 
 
 
--- | 'ThetaPointDisplace' is a type representing functions 
--- @from Radian * Point to Point@.
+-- | An enumerated type representing horizontal direction.
 --
--- It is useful for building arrowheads which are constructed 
--- with an implicit angle representing the direction of the line 
--- at the arrow tip.
+data HDirection = LEFTWARDS | RIGHTWARDS
+   deriving (Enum,Eq,Ord,Show) 
+
+
+horizontalDirection :: Radian -> HDirection
+horizontalDirection = fn . circularModulo
+  where
+    fn a | a <= 0.5*pi || a > 1.5*pi = RIGHTWARDS
+         | otherwise                 = LEFTWARDS
+
+-- | An enumerated type representing vertical direction.
 --
-type ThetaPointDisplace u = Radian -> PointDisplace u
+data VDirection = UPWARDS | DOWNWARDS
+   deriving (Enum,Eq,Ord,Show) 
 
 
+verticalDirection :: Radian -> VDirection
+verticalDirection = fn . circularModulo
+  where
+    fn a | a <= pi   = UPWARDS
+         | otherwise = DOWNWARDS
+  
 
--- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
--- 
--- Build a combinator to move @Points@ in parallel to the 
--- direction of the implicit angle by the supplied distance 
--- @dist@. 
+-- | An enumerated type representing /clock/ directions.
 --
-displaceParallel :: Floating u => u -> ThetaPointDisplace u
-displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
+data ClockDirection = CW | CCW
+   deriving (Enum,Eq,Ord,Show) 
 
 
--- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
--- 
--- Build a combinator to move @Points@ perpendicular to the 
--- direction of the implicit angle by the supplied distance 
--- @dist@. 
+
+-- | Note - behaviour at the continuity (0 deg, 180 deg, ...) is
+-- unspecified.
 --
-displacePerpendicular :: Floating u => u -> ThetaPointDisplace u
-displacePerpendicular d = 
-    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d
+clockDirection :: (Real u, Floating u) 
+               => Vec2 u -> Vec2 u -> ClockDirection
+clockDirection v1 v2 = if a1 < asum then CW else CCW
+  where
+    a1   = r2d $ vdirection v1
+    asum = r2d $ vdirection (v1 ^+^ v2)
 
 
 
+-- | An enumerated type representing quadrants.
+-- 
+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
 
+
+
 --------------------------------------------------------------------------------
--- Monadic drawing
+-- Beziers
 
--- | DUnit is always for fully saturated type constructors, so 
--- (seemingly) an equivalent type family is needed for monads.
+kappa :: Floating u => u
+kappa = 4 * ((sqrt 2 - 1) / 3)
 
-type family MonUnit m :: * 
 
 
--- | A monad that supplies points, e.g. a turtle monad. 
+-- | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @
 --
--- \*\* WARNING \*\* - the idea behind this class is somewhat
--- half-baked. It may be revised or even dropped in subsequent
--- versions of Wumpus-Basic.
+-- > ang should be in the range 0 < ang < 360deg.
 --
-class Monad m => PointSupplyM (m :: * -> *) where
-  position :: MonUnit m ~ u => m (Point2 u)
+-- > 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 (p0,p1,p2,p3) = bezierMinorArc a radius theta pt
+      in [p0,p1,p2,p3]
+
+    wedge2 a = 
+      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt
+          (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt
+      in [ p0,p1,p2,p3, p4,p5,p6 ] 
+
+    wedge3 a = 
+      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt
+          (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt
+          (_ ,p7,p8,p9) = bezierMinorArc a radius (theta+a+a) pt
+      in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] 
+  
+    wedge4 a = 
+      let (p0,p1,p2,p3)    = bezierMinorArc a radius theta pt
+          (_ ,p4,p5,p6)    = bezierMinorArc a radius (theta+a) pt
+          (_ ,p7,p8,p9)    = bezierMinorArc a radius (theta+a+a) pt
+          (_ ,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 
+               -> (Point2 u, Point2 u, Point2 u, Point2 u)
+bezierMinorArc ang radius theta pt = (p0,p1,p2,p3)
+  where
+    kfactor = fromRadian $ ang / (0.5*pi)
+    rl      = kfactor * radius * kappa
+    totang  = circularModulo $ ang + theta
+
+    p0      = pt .+^ orthoVec radius 0 theta
+    p1      = p0 .+^ orthoVec 0 rl theta
+    p2      = p3 .+^ orthoVec 0 (-rl) totang
+    p3      = pt .+^ orthoVec radius 0 totang
+
+
+--------------------------------------------------------------------------------
+
+
+-- | Applicative /both/ - run both computations return the pair
+-- of the the answers.
+--
+both :: Applicative f => f a -> f b -> f (a,b)
+both fa fb = (,) <$> fa <*> fb
+
+
+-- | Monodial scheme - prefix, repeat body n times, suffix.
+--
+monPreRepeatPost :: Monoid a => a -> (Int, a) -> a -> a
+monPreRepeatPost pre (n,body1) post = step pre n
+  where
+    step ac i | i < 1     = ac `mappend` post
+              | otherwise = step (ac `mappend` body1) (i - 1) 
+    
diff --git a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs
+++ /dev/null
@@ -1,550 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Base.ContextFun
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- Function types operating over the DrawingContext as a /static/ 
--- argument. 
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Base.ContextFun
-  (
-
-  -- * /Context functional/ types
-    CF     
-  , CF1
-  , CF2
-
-  , LocCF
-  , LocThetaCF
-  , ConnectorCF
-  , DLocCF
-  , DLocThetaCF
-  , DConnectorCF
-
-
-
-  -- * Run functions
-  , runCF
-  , runCF1 
-  , runCF2
-
-  -- * Lift functions
-  , lift0R1
-  , lift0R2
-  , lift1R2
- 
-  , promoteR1
-  , promoteR2
-
-
-  , apply1R1
-  , apply2R2
-  , apply1R2
-
-  -- * Extractors
-  , drawingCtx
-  , queryCtx
-  , locCtx
-  , locPoint
-  , locThetaCtx
-  , locThetaPoint
-  , locThetaAng
-  , connCtx
-  , connStart
-  , connEnd
-
-  -- * Combinators
-  , at
-  , rot
-  , atRot
-  , connect
-  , chain1
-
-
-  ) where
-
-import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.DrawingContext
-
-import Wumpus.Core                              -- package: wumpus-core
-
-
-import Control.Applicative
-import Data.Monoid
-
-
---------------------------------------------------------------------------------
---
-
--- | Most drawing operations in Wumpus-Basic have an implicit 
--- /graphics state/ the 'DrawingContext', so the most primitive 
--- building block is a function from the DrawingContext to some 
--- polymorphic answer.
--- 
--- This functional type is represented concretely as the initials 
--- @CF@ for /contextual function/.
--- 
--- > CF :: DrawingContext -> a 
---
-newtype CF a            = CF  { unCF :: DrawingContext -> a }
-
-
--- | Variation of 'CF' with one parametric /static argument/.
---
--- The static argument is commonly a point representing the start 
--- point / origin of a drawing.
--- 
--- > CF1 :: DrawingContext -> r1 -> a 
---
-newtype CF1 r1 a        = CF1 { unCF1 :: DrawingContext -> r1 -> a }
-
-
--- | Variation of 'CF' with two parametric /static arguments/.
---
--- The first argument is commonly a point representing the start 
--- point / origin of a drawing. The second argument might 
--- typically be the angle of displacement (for drawing arrowheads) 
--- or an end point (for drawing connectors between two points).
--- 
--- > CF2 :: DrawingContext -> r1 -> r2 -> a 
---
-newtype CF2 r1 r2 a     = CF2 { unCF2 :: DrawingContext -> r1 -> r2 -> a }
-
- 
-
--- | Type specialized verison of 'CF1' where the /static argument/
--- is the /start point/.
--- 
--- > LocCF :: DrawingContext -> Point2 u -> a 
---
-type LocCF          u a = CF1 (Point2 u) a
-
-
--- | Type specialized verison of 'CF2' where the /static arguments/
--- are the /start point/ and the /angle of displacement/.
--- 
--- > LocThetaCF :: DrawingContext -> Point2 u -> Radian -> a 
---
-type LocThetaCF     u a = CF2 (Point2 u) Radian a
-
-
--- | Type specialized verison of 'CF2' where the /static arguments/
--- are the /start point/ and the /end point/.
--- 
--- > ConnectorCF :: DrawingContext -> Point2 u -> Point2 u -> a 
---
-type ConnectorCF    u a = CF2 (Point2 u) (Point2 u) a
-
-
--- | Alias of 'LocCF' where the unit type is specialized to 
--- @Double@.
---
-type DLocCF a           = LocCF       Double a
-
-
--- | Alias of 'LocThetaCF' where the unit type is specialized to 
--- @Double@.
---
-type DLocThetaCF a      = LocThetaCF  Double a
-
--- | Alias of 'ConnectorCF' where the unit type is specialized to 
--- @Double@.
---
-type DConnectorCF a     = ConnectorCF Double a
-
-
-
---------------------------------------------------------------------------------
--- CF instances
-
--- OPlus
-
-instance OPlus a => OPlus (CF a)  where
-  fa `oplus` fb = CF $ \ctx -> unCF fa ctx `oplus` unCF fb ctx
-
-instance OPlus a => OPlus (CF1 r1 a)  where
-  fa `oplus` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `oplus` unCF1 fb ctx r1
-
-instance OPlus a => OPlus (CF2 r1 r2 a)  where
-  fa `oplus` fb = CF2 $ \ctx r1 r2 -> 
-                          unCF2 fa ctx r1 r2 `oplus` unCF2 fb ctx r1 r2
-
-
--- Monoid
- 
--- Nothing is stopping monoid instances, though in practice there
--- might be few useful types (more in Semgigroup / OPlus)...
-
-instance Monoid a => Monoid (CF a) where 
-  mempty          = CF $ \_   -> mempty
-  fa `mappend` fb = CF $ \ctx -> unCF fa ctx `mappend` unCF fb ctx
-
-instance Monoid a => Monoid (CF1 r1 a) where 
-  mempty          = CF1 $ \_   _  -> mempty
-  fa `mappend` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `mappend` unCF1 fb ctx r1
-
-instance Monoid a => Monoid (CF2 r1 r2 a) where 
-  mempty          = CF2 $ \_   _  _  -> mempty
-  fa `mappend` fb = CF2 $ \ctx r1 r2 -> 
-                            unCF2 fa ctx r1 r2 `mappend` unCF2 fb ctx r1 r2
-
-
-
--- Functor
-
-instance Functor CF where
-  fmap f ma = CF $ \ctx -> f $ unCF ma ctx 
-
-
-instance Functor (CF1 r1) where
-  fmap f ma = CF1 $ \ctx r1 -> f $ unCF1 ma ctx r1 
-
-instance Functor (CF2 r1 r2) where
-  fmap f ma = CF2 $ \ctx r1 r2 -> f $ unCF2 ma ctx r1 r2
-
-
-
--- Applicative
-
-instance Applicative CF where
-  pure a    = CF $ \_   -> a
-  mf <*> ma = CF $ \ctx -> let f = unCF mf ctx
-                               a = unCF ma ctx
-                           in f a
-
-
-instance Applicative (CF1 r1) where
-  pure a    = CF1 $ \_   _  -> a
-  mf <*> ma = CF1 $ \ctx r1 -> let f = unCF1 mf ctx r1 
-                                   a = unCF1 ma ctx r1
-                               in f a
-
-
-instance Applicative (CF2 r1 r2) where
-  pure a    = CF2 $ \_   _  _  -> a
-  mf <*> ma = CF2 $ \ctx r1 r2 -> let f = unCF2 mf ctx r1 r2
-                                      a = unCF2 ma ctx r1 r2
-                                  in f a
-
-
-
-
--- Monad 
-
-instance Monad CF where
-  return a  = CF $ \_   -> a
-  ma >>= k  = CF $ \ctx -> let a = unCF ma ctx in (unCF . k) a ctx 
-
-instance Monad (CF1 r1) where
-  return a  = CF1 $ \_   _  -> a
-  ma >>= k  = CF1 $ \ctx r1 -> let a = unCF1 ma ctx  r1 in (unCF1 . k) a ctx r1 
-
-instance Monad (CF2 r1 r2) where
-  return a  = CF2 $ \_   _  _  -> a
-  ma >>= k  = CF2 $ \ctx r1 r2 -> 
-                      let a = unCF2 ma ctx r1 r2 in (unCF2 . k) a ctx r1 r2
-
-
-
--- DrawingCtxM 
-
-instance DrawingCtxM CF where
-  askDC           = CF $ \ctx -> ctx
-  localize upd df = CF $ \ctx -> unCF df (upd ctx)
-  
-
-instance DrawingCtxM (CF1 r1) where
-  askDC           = CF1 $ \ctx _  -> ctx
-  localize upd df = CF1 $ \ctx r1 -> unCF1 df (upd ctx) r1
-
-
-instance DrawingCtxM (CF2 r1 r2) where
-  askDC           = CF2 $ \ctx _  _  -> ctx
-  localize upd df = CF2 $ \ctx r1 r2 -> unCF2 df (upd ctx) r1 r2
-
-
--- Note - there is nothing determining a DUnit for the CF types, 
--- so it seems appropriate not to define affine instances.
---
--- However affine instances can be made for the Image type in 
--- Objects.BaseObjects.
---
-
-
---------------------------------------------------------------------------------
--- Run functions
-
--- | Run a /CF/ (context function) with the supplied 
--- /DrawingContext/.
---
-runCF :: DrawingContext -> CF a -> a
-runCF ctx df = unCF df ctx
-
-
--- | Run a /CF1/ (context function) with the supplied 
--- /DrawingContext/ and static argument.
---
-runCF1 :: DrawingContext -> r1 -> CF1 r1 a -> a
-runCF1 ctx r1 df = unCF1 df ctx r1
-
-
--- | Run a /CF1/ (context function) with the supplied 
--- /DrawingContext/ and two static arguments.
---
-runCF2 :: DrawingContext -> r1 -> r2 -> CF2 r1 r2 a -> a
-runCF2 ctx r1 r2 df = unCF2 df ctx r1 r2
-
-
-
---------------------------------------------------------------------------------
--- lift functions
-
-
--- | Lift a zero-arity context function 'CF' to an arity one 
--- context function 'CF1'.
--- 
-lift0R1             :: CF a -> CF1 r1 a
-lift0R1 mf          = CF1 $ \ctx _ -> unCF mf ctx
-
--- | Lift a zero-arity context function 'CF' to an arity two 
--- context function 'CF2'.
--- 
-lift0R2             :: CF a -> CF2 r1 r2 a
-lift0R2 mf          = CF2 $ \ctx _ _ -> unCF mf ctx
-
--- | Lift an arity one context function 'CF1' to an arity two
--- context function 'CF2'.
--- 
-lift1R2             :: CF1 r1 a -> CF2 r1 r2 a
-lift1R2 mf          = CF2 $ \ctx r1 _ -> unCF1 mf ctx r1
-
-
-
--- | Promote a function @from one argument to a Context Function@ 
--- to an arity one @Context Function@.
---
--- The type signature is as explanatory as a description:
---
--- > promoteR1 :: (r1 -> CF a) -> CF1 r1 a
--- 
-promoteR1           :: (r1 -> CF a) -> CF1 r1 a
-promoteR1 mf        = CF1 $ \ctx r1 -> unCF (mf r1) ctx
-
--- | Promote a function @from two arguments to a Context Function@ 
--- to an arity two @Context Function@.
---
--- The type signature is as explanatory as a description:
---
--- > promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a
--- 
-promoteR2           :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a
-promoteR2 mf        = CF2 $ \ctx r1 r2 -> unCF (mf r1 r2) ctx
-
-
-
--- | Apply an arity-one Context Function to a single argument, 
--- downcasting it by one level, making an arity-zero Context 
--- function. 
--- 
--- The type signature is as explanatory as a description:
---
--- > apply1R1 :: CF1 r1 a -> r1 -> CF a
---
-apply1R1            :: CF1 r1 a -> r1 -> CF a
-apply1R1 mf r1      = CF $ \ctx -> unCF1 mf ctx r1
-
-
--- | Apply an arity-two Context Function to two arguments, 
--- downcasting it by two levels, making an arity-zero Context 
--- function. 
--- 
--- The type signature is as explanatory as a description:
---
--- > apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a
--- 
-apply2R2            :: CF2 r1 r2 a -> r1 -> r2 -> CF a
-apply2R2 mf r1 r2   = CF $ \ctx -> unCF2 mf ctx r1 r2
-
--- | Apply an arity-two Context Function to one argument, 
--- downcasting it by one level, making an arity-one Context 
--- function. 
--- 
--- The type signature is as explanatory as a description:
---
--- > apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a
---
-apply1R2            :: CF2 r1 r2 a -> r2 -> CF1 r1 a
-apply1R2 mf r2      = CF1 $ \ctx r1 -> unCF2 mf ctx r1 r2
-
-
---------------------------------------------------------------------------------
--- extractors 
-
--- | Extract the drawing context from a CtxFun.
---
--- > (ctx -> ctx)
--- 
-drawingCtx      :: CF DrawingContext
-drawingCtx      = CF $ \ctx -> ctx
-
--- | Apply the projection function to the drawing context.
---
--- > (ctx -> a) -> (ctx -> a)
---
-queryCtx        :: (DrawingContext -> a) -> CF a
-queryCtx f      = CF $ \ctx -> f ctx
-
-
--- | Extract the drawing context from a LocCF.
---
--- > (ctx -> pt -> ctx)
---
-locCtx          :: LocCF u DrawingContext
-locCtx          = CF1 $ \ctx _  -> ctx
-
--- | Extract the /start/ point from a LocCF.
---
--- > (ctx -> pt -> pt)
---
-locPoint        :: LocCF u (Point2 u)
-locPoint        = CF1 $ \_ pt -> pt
-
-
--- | Extract the drawing context from a LocThetaCF.
---
--- > (ctx -> pt -> ang -> ctx)
---
-locThetaCtx     :: LocThetaCF u DrawingContext
-locThetaCtx     = CF2 $ \ctx _ _ -> ctx
-
-
--- | Extract the /start/ point from a LocThetaCF.
---
--- > (ctx -> pt -> ang -> pt)
---
-locThetaPoint   :: LocThetaCF u (Point2 u)
-locThetaPoint   = CF2 $ \_ pt _ -> pt
-
--- | Extract the angle from a LocThetaCF.
---
--- > (ctx -> pt -> ang -> ang)
---
-locThetaAng     :: LocThetaCF u Radian
-locThetaAng     = CF2 $ \_ _ ang -> ang
-
--- | Extract the drawing context from a ConnectorCF.
---
--- > (ctx -> pt1 -> pt2 -> ctx)
---
-connCtx         :: ConnectorCF u DrawingContext
-connCtx         = CF2 $ \ctx _ _ -> ctx
-
--- | Extract the start point from a ConnectorCF.
---
--- > (ctx -> pt1 -> pt2 -> pt1)
---
-connStart       :: ConnectorCF u (Point2 u) 
-connStart       = CF2 $ \_ pt _ -> pt
-
--- | Extract the end point from a ConnectorCF.
---
--- > (ctx -> pt1 -> pt2 -> pt2)
---
-connEnd         :: ConnectorCF u (Point2 u) 
-connEnd         = CF2 $ \_ _ pt -> pt
-
-
-
-
-
---------------------------------------------------------------------------------
--- Combinators
-
-
-
-infixr 1 `at`
-
-
--- | Downcast a 'LocCF' function by applying it to the supplied 
--- point, making an arity-zero Context Function. 
--- 
--- Remember a 'LocCF' function is a 'CF1' context function where
--- the /static argument/ is specialized to a start point.
---
-at :: LocCF u a -> Point2 u -> CF a
-at = apply1R1
-
-
-infixr 1 `rot`
-
-
--- | Downcast a 'LocThetaCF' function by applying it to the 
--- supplied angle, making an arity-one Context Function (a 
--- 'LocCF'). 
--- 
-
-rot :: LocThetaCF u a -> Radian -> LocCF u a
-rot = apply1R2
-
-
--- | Downcast a 'LocThetaCF' function by applying it to the 
--- supplied point and angle, making an arity-zero Context 
--- Function (a 'CF'). 
---
-atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a
-atRot = apply2R2
-
-
--- | Downcast a 'ConnectorCF' function by applying it to the 
--- start and end point, making an arity-zero Context Function 
--- (a 'CF'). 
--- 
-connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a
-connect = apply2R2
-
-
-
-infixr 6 `chain1`
-
--- | /Chaining/ combinator - the /answer/ of the 
--- first Context Function is feed to the second Context Function. 
---
--- This contrasts with the usual idiom in @Wumpus-Basic@ where 
--- composite graphics are built by applying both functions to the 
--- same initial /static argument/.
---
--- Desciption:
---
--- Evaluate the first Context Function with the drawing context 
--- and the /initial state/ @st0@. The result of the evaluation is 
--- a new /state/ @st1@ and and answer @a1@. 
---
--- Evaluate the second Context Function with the drawing context 
--- and the new state @st1@, producing a new state @s2@ and an 
--- answer @a2@.
---
--- Return the result of combining the answers with 
--- @op :: (ans -> ans -> ans)@ and the second state @s2@.
---
--- @ (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) @
---
--- This models chaining start points together, which is the model
--- PostScript uses for text output when successively calling the 
--- @show@ operator.
--- 
-chain1 :: OPlus w 
-            => CF1 s1 (s1,w) -> CF1 s1 (s1,w) -> CF1 s1 (s1,w)
-chain1 f g = CF1 $ \ctx s -> let (s1,a1) = unCF1 f ctx s
-                                 (s2,a2) = unCF1 g ctx s1
-                             in (s2, a1 `oplus` a2)
-
-
diff --git a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs
--- a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs
+++ b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs
@@ -4,7 +4,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Base.DrawingContext
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
@@ -24,22 +24,23 @@
 module Wumpus.Basic.Kernel.Base.DrawingContext
   ( 
 
-  -- * Drawing context
+  -- * Drawing context types
     DrawingContext(..)
-  , DrawingContextF
 
+  , DrawingContextF
   , TextMargin(..)
 
+  -- * Construction
   , standardContext
   , metricsContext
+  , addFontTables
 
-  , default_drawing_context
+  , reset_drawing_properties
+  , reset_drawing_metrics
 
   -- * DrawingCtxM (reader) monad
   , DrawingCtxM(..)
-  , asksDC
 
-
   -- * Glyph metrics
   , withFontMetrics
 
@@ -47,13 +48,15 @@
   ) where
 
 
-import Wumpus.Basic.Kernel.Base.GlyphMetrics
+import Wumpus.Basic.Kernel.Base.FontSupport
+import Wumpus.Basic.Kernel.Base.Units
 
 import Wumpus.Core                              -- package: wumpus-core
 import Wumpus.Core.Text.StandardEncoding
 
 import Control.Applicative
 import Data.Maybe
+import Data.Monoid
 
 -- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic. 
 -- DrawingContext is operated on within a Reader monad rather than 
@@ -61,29 +64,30 @@
 -- operation (called @localize@ in Wumpus), rather than permanent
 -- until overridden as per @set@ of a State monad.
 -- 
--- Note - @round_corner_factor@ is only accounted for by some 
--- graphic objects (certain Path objects and Shapes in 
--- Wumpus-Drawing for instance). There many be many objects that 
--- ignore it and are drawn only with angular corners.
--- 
--- Also note - in contrast to most other drawing objects in 
--- Wumpus, none of the measurement values are parameteric - 
--- usually notated with the type variable @u@ in Wumpus. This is 
--- so Wumpus can (potentially) support different units e.g. 
--- centimeters rather than just Doubles (represening printers 
--- points), though adding support for other units has a very low 
--- priority.
--- 
+-- Note - in contrast to most other drawing objects in Wumpus, 
+-- none of the types of measurement values are parameteric  
+-- (usually notated with the type variable @u@ in Wumpus). Types 
+-- are either 'Double' representing PostScript points or Em - a 
+-- contextual size that is interpreted according to the current 
+-- font size.
+--
+-- It is easier to specialize all the measurement types and 
+-- within the 'DrawingContext' and add parametricity to the 
+-- /getters/ and /setters/ instead.
+--
 data DrawingContext = DrawingContext
-      { glyph_tables          :: GlyphMetrics
-      , fallback_metrics      :: MetricsOps
-      , stroke_props          :: StrokeAttr
-      , font_props            :: FontAttr
-      , stroke_colour         :: RGBi      -- also text colour...
-      , fill_colour           :: RGBi      
-      , line_spacing_factor   :: Double
-      , round_corner_factor   :: Double 
-      , text_margin           :: TextMargin
+      { dc_font_metrics_table   :: FontTable
+      , dc_font_load_log        :: FontLoadLog
+      , dc_fallback_metrics     :: FontMetrics
+      , dc_font_face            :: FontFace
+      , dc_font_size            :: !FontSize
+      , dc_snap_grid_factors    :: (Double,Double)
+      , dc_stroke_props         :: StrokeAttr
+      , dc_stroke_colour        :: RGBi
+      , dc_fill_colour          :: RGBi      
+      , dc_text_colour          :: RGBi
+      , dc_line_spacing_factor  :: Double
+      , dc_text_margin          :: TextMargin
       }
 
 -- TODO - what parts of the Drawing Context should be strict? 
@@ -93,43 +97,163 @@
 --
 type DrawingContextF = DrawingContext -> DrawingContext
 
--- | The unit of Margin is always Double representing Points, e.g.
--- 1.0 is 1 Point. Margins are not scaled relative to the current
--- font size.
+-- | The text margin is measured in 'Em' so it is relative to the
+-- current font size.
 -- 
--- The default value is 2 point.
+-- The default value is 0.5.
 --
 data TextMargin = TextMargin
-       { text_margin_x          :: !Double
-       , text_margin_y          :: !Double
+       { text_margin_x          :: !Em
+       , text_margin_y          :: !Em
        }
 
 
 
+-- | 'standardContext' : @ font_size -> DrawingContext @  
+--
+-- Create a 'DrawingContext'.
+-- 
+-- Note - @font_size@ is used for sizing more than just text 
+-- labels. Arrowheads, plot marks and other elements have their
+-- metrics derived from the font size.
+-- 
+-- No real font metrics are present in the 'DrawingContext' 
+-- created by 'standardContext'. Static, hard-coded fallback 
+-- metrics derived from the @Courier@ font are available but
+-- these metrics might not accurately correspond to the 
+-- @Courier@ available to the the final renderer (GhostScript,
+-- an SVG viewer, etc.).
+-- 
+-- Use this constructor for drawings that make primitive use of
+-- text.
+-- 
+-- > font_metrics_table:  empty
+-- > font_load_log:       empty
+-- > fallback_metrics:    monospace_metrics
+-- > font_face:           Courier
+-- > font_size:           @supplied_font_size@
+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. 
+-- > stroke_colour:       black
+-- > fill_colour:         light_gray
+-- > text_colour:         black
+-- > line_spacing_factor: 0.2
+-- > round_corner_factor: 0
+-- > text_margin:         (0.5 em, 0.5 em) 
+--
+--
 standardContext :: FontSize -> DrawingContext
 standardContext sz = 
-    DrawingContext { glyph_tables         = emptyGlyphMetrics
-                   , fallback_metrics     = monospace_metrics
-                   , stroke_props         = default_stroke_attr
-                   , font_props           = FontAttr sz wumpus_courier
-                   , stroke_colour        = wumpus_black
-                   , fill_colour          = wumpus_light_gray
-                   , line_spacing_factor  = 1.2  
-                   , round_corner_factor  = 0
-                   , text_margin          = standardTextMargin
+    DrawingContext { dc_font_metrics_table   = emptyFontTable
+                   , dc_font_load_log        = mempty
+                   , dc_fallback_metrics     = monospace_metrics
+                   , dc_font_face            = wumpus_courier
+                   , dc_font_size            = sz
+                   , dc_stroke_props         = default_stroke_attr
+                   , dc_snap_grid_factors    = (50.0, 50.0)
+                   , dc_stroke_colour        = wumpus_black
+                   , dc_fill_colour          = wumpus_light_gray
+                   , dc_text_colour          = wumpus_black
+                   , dc_line_spacing_factor  = default_line_spacing  
+                   , dc_text_margin          = default_text_margin
                    }
 
-standardTextMargin :: TextMargin
-standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 }
 
--- out-of-date - should be adding loaded fonts, not replacing the 
--- GlyphMetrics Map wholesale.
+-- | 'metricsContext' : @ font_size * font_metrics -> DrawingContext @  
 --
-metricsContext :: FontSize -> GlyphMetrics -> DrawingContext
-metricsContext sz bgm = 
-    let env = standardContext sz in env { glyph_tables = bgm }
+-- Create a 'DrawingContext' with font metrics loaded from the 
+-- file system.
+-- 
+-- Note - @font_size@ is used for sizing more than just text 
+-- labels. Arrowheads, plot marks and other elements have their
+-- metrics derived from the font size.
+-- 
+-- Use this constructor for drawings that make use of the text 
+-- objects provided by @Wumpus-Drawing@ (DocText and RotText).
+-- 
+metricsContext :: FontSize -> FontLoadResult -> DrawingContext
+metricsContext sz res = 
+    let env = standardContext sz 
+    in env { dc_font_metrics_table = loaded_font_table res
+           , dc_font_load_log      = loader_errors res
+           }
 
 
+
+-- | 'addFontTables' : @ font_load_result -> DrawinContextUpdate @
+--
+-- Add the font metrics from the FontLoadResult, if a font with 
+-- the same name alreay exists in the 'DrawingContext' it will be 
+-- replaced. Error and warning messages in the @font_load_result@ 
+-- will be appended to the 'font_load_log'.
+--
+addFontTables :: FontLoadResult -> DrawingContextF
+addFontTables (FontLoadResult table msgs) = 
+    (\s i j -> s { dc_font_metrics_table = i `mappend` table
+                 , dc_font_load_log      = j `mappend` msgs }) 
+      <*> dc_font_metrics_table <*> dc_font_load_log
+
+
+
+-- | 'reset_drawing_properties' : @ DrawingContextF @  
+--
+-- Reset the drawing properties in the 'DrawingContext' to their 
+-- default values. This changes the following fields:
+--
+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. 
+-- > stroke_colour:       black
+-- > fill_colour:         light_gray
+-- > text_colour:         black
+-- > line_spacing_factor: 0.2
+-- > round_corner_factor: 0
+-- > text_margin:         (0.5 em, 0.5 em) 
+--
+reset_drawing_properties :: DrawingContextF 
+reset_drawing_properties dcxt = 
+    dcxt { dc_stroke_props          = default_stroke_attr
+         , dc_stroke_colour         = wumpus_black
+         , dc_fill_colour           = wumpus_light_gray
+         , dc_text_colour           = wumpus_black
+         , dc_line_spacing_factor   = default_line_spacing
+         , dc_text_margin           = default_text_margin
+         }
+
+-- Ideally @reset_drawing_properties@ would be in the UpdateDC 
+-- module, but that would mean exporting @default_line_spacing@ 
+-- etc.
+--
+
+
+
+-- | 'reset_drawing_metrics' : @ DrawingContextF @  
+--
+-- Reset the drawing metrics in the 'DrawingContext' to their 
+-- default values. This is a more limited version of
+-- 'reset_drawing_properties' and changes the following fields:
+--
+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. 
+-- > line_spacing_factor: 0.2
+-- > round_corner_factor: 0
+-- > text_margin:         (0.5 em, 0.5 em) 
+--
+reset_drawing_metrics :: DrawingContextF 
+reset_drawing_metrics dcxt = 
+    dcxt { dc_stroke_props          = default_stroke_attr
+         , dc_line_spacing_factor   = default_line_spacing
+         , dc_text_margin           = default_text_margin
+         }
+
+
+
+-- Helpers - not exported
+
+default_text_margin :: TextMargin
+default_text_margin = TextMargin { text_margin_x = 0.5, text_margin_y = 0.5 }
+
+
+
+default_line_spacing :: Double
+default_line_spacing = 0.2
+
 wumpus_black            :: RGBi
 wumpus_black            = RGBi 0 0 0 
 
@@ -144,26 +268,27 @@
     FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding
 
 
-
-default_drawing_context :: DrawingContext
-default_drawing_context = 
-    standardContext (font_size wumpus_default_font)
-
-
-
 --------------------------------------------------------------------------------
 
-
-class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where
-  askDC    :: m DrawingContext
-  localize :: (DrawingContext -> DrawingContext) -> m a -> m a
-
-
--- | Project a value out of a context.
+-- | 'DrawingCtxM' is equivalent to the to the @MonadReader@ 
+-- class, but the environment type is fixed to 'DrawingContext'.
 --
-asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a
-asksDC f = askDC >>= (return . f)
+-- To avoid name clashes with @mtl@ this scheme is used:
+--
+-- > askDC    = ask
+-- > asksDC   = asks
+-- > localize = local
+--
+-- Note, because the derived operation 'query' (aka @asks@) is
+-- expected to be used more often than queryCtx (aka @ask@) it 
+-- gets the more convenient name.
+--
+class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where
+  askDC     :: m DrawingContext
+  asksDC    :: (DrawingContext -> a) -> m a
+  localize  :: (DrawingContext -> DrawingContext) -> m a -> m a
 
+  asksDC f  = f <$> askDC
 
 
 --------------------------------------------------------------------------------
@@ -173,13 +298,15 @@
 
 
 
-withFontMetrics :: (MetricsOps -> PtSize -> u) -> DrawingContext -> u
-withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = 
-      fn metric_set point_sz
+withFontMetrics :: (FontMetrics -> FontSize -> u) -> DrawingContext -> u
+withFontMetrics fn ctx@(DrawingContext { dc_font_face = fface
+                                       , dc_font_size = ftsize }) = 
+      fn metric_set ftsize
   where 
-    ps_name     = ps_font_name $ font_face font_stats
-    point_sz    = fromIntegral $ font_size font_stats 
-    metric_set  = fromMaybe (fallback_metrics ctx) $ 
-                    lookupFont ps_name (glyph_tables ctx) 
+    ps_name     = ps_font_name fface
+    metric_set  = fromMaybe (dc_fallback_metrics ctx) $ 
+                    lookupFont ps_name (dc_font_metrics_table ctx)
+
+
 
 
diff --git a/src/Wumpus/Basic/Kernel/Base/FontSupport.hs b/src/Wumpus/Basic/Kernel/Base/FontSupport.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Base/FontSupport.hs
@@ -0,0 +1,262 @@
+{-# LANGUAGE RankNTypes                 #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Base.FontSupport
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Data types representing font metrics.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Base.FontSupport
+  ( 
+
+    FontName
+  , CodePoint
+  , FontDef(..)
+  , FontFamily(..)
+  , regularWeight
+  , boldWeight
+  , italicWeight
+  , boldItalicWeight
+
+  , CharWidthLookup
+
+  , FontMetrics(..)
+
+  , FontTable
+  , emptyFontTable
+  , lookupFont
+  , insertFont
+
+  , FontLoadMsg
+  , FontLoadLog
+  , fontLoadMsg
+
+  , FontLoadResult(..)
+  , printLoadErrors
+
+  , monospace_metrics
+
+  
+  ) where
+
+import Wumpus.Basic.Utils.HList
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import qualified Data.Map      as Map
+import Data.Monoid
+
+
+
+type FontName = String
+
+-- | A Unicode code-point.
+--
+type CodePoint = Int
+
+-- | FontDef wraps @FontFace@ from Wumpus-Core with file name
+-- information for the font loaders.
+--
+data FontDef = FontDef
+      { font_def_face   :: FontFace
+      , gs_file_name    :: String
+      , afm_file_name   :: String
+      }
+  deriving (Eq,Ord,Show)
+
+
+
+-- | A family group of FontDefs (regular, bold, italic and 
+-- bold-italic).
+--
+-- It is convenient for some higher-level text objects in Wumpus 
+-- (particularly @Doc@ in Wumpus-Drawing) to treat a font and its
+-- standard weights as the same entity. This allows @Doc@ API to 
+-- provide a @bold@ operation to simply change to the the bold
+-- weight of the current family, rather than use the primitive 
+-- @set_font@ operation to change to an explicitly named font.
+--
+--
+data FontFamily = FontFamily
+      { ff_regular      :: FontDef
+      , ff_bold         :: Maybe FontDef
+      , ff_italic       :: Maybe FontDef
+      , ff_bold_italic  :: Maybe FontDef  
+      }
+
+-- | Extract the regular weight 'FontDef' from a 'FontFamily'.
+--
+regularWeight :: FontFamily -> FontDef
+regularWeight = ff_regular
+
+
+-- | Extract the bold weight 'FontDef' from a 'FontFamily'.
+--
+-- Note - this falls back to the regular weight if the font family 
+-- has no bold weight. To get the bold weight or @Nothing@ if it
+-- is not present use the record selector @ff_bold@.
+--
+boldWeight :: FontFamily -> FontDef
+boldWeight s = maybe (ff_regular s) id $ ff_bold s
+
+
+-- | Extract the @italic@ weight 'FontDef' from a 'FontFamily'.
+--
+-- Note - this falls back to the regular weight if the font family 
+-- has no italic weight. To get the italic weight or @Nothing@ if 
+-- it is not present use the record selector @ff_italic@.
+--
+italicWeight :: FontFamily -> FontDef
+italicWeight s = maybe (ff_regular s) id $ ff_italic s
+
+
+-- | Extract the @bold-italic@ weight 'FontDef' from a 
+-- 'FontFamily'.
+--
+-- Note - this falls back to the regular weight if the font family 
+-- has no bold-italic weight. To get the bold-italic weight or 
+-- @Nothing@ if it is not present use the record selector 
+-- @ff_bold_italic@.
+--
+boldItalicWeight :: FontFamily -> FontDef
+boldItalicWeight s = maybe (ff_regular s) id $ ff_bold_italic s
+
+
+
+-- | A lookup function from code point to /width vector/.
+--
+-- The unit is always stored as a Double representing PostScript
+-- points.
+--
+-- Note - in PostScript terminology a width vector is not obliged
+-- to be left-to-right (writing direction 0). It could be 
+-- top-to-bottom (writing direction 1).
+--
+type CharWidthLookup = CodePoint -> Vec2 Double
+
+
+
+-- | 'FontMetrics' store a subset of the properties available in 
+-- a font file - enough to calculate accurate bounding boxes and
+-- positions for text.
+--
+-- > Bounding box representing the maximum glyph area.
+-- > Width vectors for each character.
+-- > Cap height
+-- > Descender depth.
+--
+-- Because Wumpus always needs font metrics respective to the 
+-- current point size, the actual fields are all functions.
+--
+data FontMetrics = FontMetrics
+    { get_bounding_box          :: FontSize -> BoundingBox Double
+    , get_cw_table              :: FontSize -> CharWidthLookup
+    , get_cap_height            :: FontSize -> Double
+    , get_descender             :: FontSize -> Double
+    , get_underline_position    :: FontSize -> Double
+    , get_underline_thickness   :: FontSize -> Double
+    }
+
+
+-- | A map between a font name and the respective FontMetrics.
+--
+newtype FontTable = FontTable { 
+          getFontTable :: Map.Map FontName FontMetrics }
+
+
+
+instance Monoid FontTable where
+  mempty        = emptyFontTable
+  a `mappend` b = FontTable $ getFontTable a `mappend` getFontTable b
+
+
+emptyFontTable :: FontTable
+emptyFontTable = FontTable $ Map.empty
+
+
+-- | 'FontLoadMsg' - type synonym for String.
+--
+type FontLoadMsg        = String
+
+-- | 'FontLoadLog' is a Hughes list of Strings, so it supports 
+-- efficient append.
+--
+newtype FontLoadLog     = FontLoadLog { getFontLoadLog :: H FontLoadMsg }
+
+
+instance Monoid FontLoadLog where
+  mempty        = FontLoadLog $ emptyH
+  a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b
+
+
+fontLoadMsg :: String -> FontLoadLog 
+fontLoadMsg = FontLoadLog . wrapH
+
+
+-- Need a synonym for @FontLoading@...
+data FontLoadResult = FontLoadResult
+      { loaded_font_table    :: FontTable
+      , loader_errors        :: FontLoadLog
+      }
+
+
+-- | Print the loader errors from the 'FontLoadResult' to std-out.
+--
+printLoadErrors :: FontLoadResult -> IO ()
+printLoadErrors = mapM_ putStrLn . toListH . getFontLoadLog . loader_errors
+
+--------------------------------------------------------------------------------
+
+
+-- | 'lookupFont' : @ name * font_table -> Maybe FontMetrics @ 
+-- 
+-- Lookup a font in the font_table.
+-- 
+lookupFont :: FontName -> FontTable -> Maybe FontMetrics
+lookupFont name = Map.lookup name . getFontTable
+
+-- | 'insertFont' : @ name * font_metrics * font_table -> FontTable @ 
+-- 
+-- Insert a named font into the font_table.
+-- 
+insertFont :: FontName -> FontMetrics -> FontTable -> FontTable
+insertFont name ops = 
+    FontTable . Map.insert name ops . getFontTable
+
+-- | This ignores the Char code lookup and just returns the 
+-- default advance vector.
+--
+monospace_metrics :: FontMetrics
+monospace_metrics = FontMetrics
+    { 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
+    , get_underline_position    = \sz -> upscale sz underline_pos
+    , get_underline_thickness   = \sz -> upscale sz underline_width
+    }
+  where
+    llx             = (-23)  / 1000
+    lly             = (-250) / 1000
+    urx             = 715    / 1000
+    ury             = 805    / 1000
+    width_vec       = 600    / 1000
+    cap_height      = 562    / 1000
+    descender       = (-157) / 1000
+    underline_pos   = (-100) / 1000
+    underline_width = 50     / 1000
+
+    upscale sz d    = d * fromIntegral sz
+    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/GlyphMetrics.hs b/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-{-# LANGUAGE RankNTypes                 #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Base.GlyphMetrics
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Data types representing glyph metrics loaded from font files.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Base.GlyphMetrics
-  ( 
-
-    FontName
-  , CodePoint
-  , CharWidthTable
-  , MetricsOps(..)
-  , FontMetricsOps(..)
-
-  , GlyphMetrics
-  , emptyGlyphMetrics
-  , lookupFont
-  , insertFont
-
-  , monospace_metrics
-
-  
-  ) where
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import qualified Data.Map      as Map
-import Data.Monoid
-
-
-
-type FontName = String
-
--- | A Unicode code-point.
---
-type CodePoint = Int
-
--- | A lookup from code point to /width vector/.
---
--- Note - in PostScript terminology a width vector is not obliged
--- to be left-to-right (writing direction 0). It could be 
--- top-to-bottom (writing direction 1).
---
-type CharWidthTable u = CodePoint -> Vec2 u
-
-
-
--- | Operations on the metrics set of a font.
---
--- The is the internal representation used by Wumpus-Basic after
--- parsing the font file.
---
-data MetricsOps = MetricsOps
-      { 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
-      }
-
--- | 'MetricsOps' tfor a particular named font.
--- 
-data FontMetricsOps = FontMetricsOps FontName MetricsOps
-
-
--- | A map between a font name and MetricsOps.
---
-newtype GlyphMetrics = GlyphMetrics { 
-          getGlyphMetrics :: Map.Map FontName MetricsOps }
-
-instance Monoid GlyphMetrics where
-  mempty        = emptyGlyphMetrics
-  a `mappend` b = GlyphMetrics $ getGlyphMetrics a `mappend` getGlyphMetrics b
-
-
-emptyGlyphMetrics :: GlyphMetrics
-emptyGlyphMetrics = GlyphMetrics $ Map.empty
-
-lookupFont :: FontName -> GlyphMetrics -> Maybe MetricsOps
-lookupFont name = Map.lookup name . getGlyphMetrics
-
-insertFont :: FontMetricsOps -> GlyphMetrics -> GlyphMetrics
-insertFont (FontMetricsOps name ops) = 
-    GlyphMetrics . Map.insert name ops . getGlyphMetrics
-
--- | This ignores the Char code lookup and just returns the 
--- default advance vector.
---
-monospace_metrics :: MetricsOps
-monospace_metrics = MetricsOps
-    { 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
-    }
-  where
-    llx           = (-23)  / 1000
-    lly           = (-250) / 1000
-    urx           = 715    / 1000
-    ury           = 805    / 1000
-    width_vec     = 600    / 1000
-    cap_height    = 562    / 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) 
-
-
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,274 +12,322 @@
 --
 -- 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
   ( 
 
-    
-    textAttr
-  , withTextAttr
+    normalizeCtx
+  , normalizeCtxF
+  , dinterpCtx
+  , dinterpCtxF
 
-  , strokeAttr
-  , withStrokeAttr
+  , uconvertCtx1
+  , uconvertCtxF
 
-  , fillAttr
-  , withFillAttr
+  , pointSize
 
+  , strokeAttr
+  , fillAttr
   , borderedAttr
-  , withBorderedAttr
+  , textAttr
 
-  , getRoundCornerSize
-  , getTextMargin
+  , position
+  , snapmove
 
+  , textMargin
+
   , getLineWidth
   , getFontAttr
   , getFontSize
   , getFontFace
-  , markHeight
-  , markHalfHeight
-  , baselineSpacing
+  , getTextColour
 
+  , textlineSpace
+
   -- * Glyph metrics
   , glyphBoundingBox
-  , glyphHeightRange
-  , glyphHeight
-  , glyphCapHeight
+  , capHeight
+  , descender
+  , underlinePosition
+  , underlineThickness
+  , verticalSpan
+  , heightSpan
 
-  , cwLookupTable
+  -- * Text metrics
+  , escTextVector
+  , escCharVector
+  , hkernVector
 
-  -- * Default monospace metrics
+  , cwLookupTable
 
-  , monoFontPointSize
-  , monoCharWidth
-  , monoTextWidth
-  , monoTextLength
-  , monoCapHeight
-  , monoLowerxHeight
-  , monoDescenderDepth
-  , monoAscenderHeight
-  , monoTextDimensions
-  , monoMultiLineHeight
-  , monoDefaultPadding
-  , monoVecToCenter  
   ) where
 
+import Wumpus.Basic.Kernel.Base.BaseDefs
 import Wumpus.Basic.Kernel.Base.DrawingContext
-import Wumpus.Basic.Kernel.Base.GlyphMetrics
+import Wumpus.Basic.Kernel.Base.FontSupport
 
 import Wumpus.Core                              -- package: wumpus-core
-import qualified Wumpus.Core.FontSize   as FS
+import Wumpus.Core.Text.GlyphIndices
+
+import Data.VectorSpace                         -- package: vector-space
  
 import Control.Applicative
+import Data.Char
+import qualified Data.Map               as Map
+import Data.Maybe 
 
 
-textAttr :: DrawingCtxM m => m (RGBi,FontAttr)
-textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props
-
--- | Because @textAttr@ is so commonly used here is a functional
--- version that avoids tupling.
 --
-withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a
-withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props
+-- NOTE 20.5.11 - The normalize functions are not satisfactory,
+-- point size is too promiscuous for evaluation contextual units.
+--
 
+normalizeCtx :: (DrawingCtxM m, InterpretUnit u) => u -> m Double
+normalizeCtx u = (\sz -> normalize sz u) <$> pointSize
 
-strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)
-strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props
+normalizeCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) 
+             => t u -> m (t Double)
+normalizeCtxF t = (\sz -> fmap (normalize sz) t) <$> pointSize
 
-withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a
-withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props
+dinterpCtx :: (DrawingCtxM m, InterpretUnit u) => Double -> m u
+dinterpCtx u = (\sz -> dinterp sz u) <$> pointSize
 
+dinterpCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) => t Double -> m (t u)
+dinterpCtxF u = (\sz -> fmap (dinterp sz) u) <$> pointSize
 
+uconvertCtx1 :: (DrawingCtxM m, InterpretUnit u, InterpretUnit u1) 
+             => u -> m u1
+uconvertCtx1 t = (\sz -> uconvert1 sz t) <$> pointSize
+
+uconvertCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u, InterpretUnit u1) 
+            => t u -> m (t u1)
+uconvertCtxF t = (\sz -> uconvertF sz t) <$> pointSize
+
+
+pointSize :: DrawingCtxM m => m FontSize
+pointSize = asksDC dc_font_size
+
+strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)
+strokeAttr = (,) <$> asksDC dc_stroke_colour <*> asksDC dc_stroke_props
+
 fillAttr :: DrawingCtxM m => m RGBi
-fillAttr = asksDC fill_colour
+fillAttr = asksDC dc_fill_colour
 
-withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a
-withFillAttr fn = fn <$> asksDC fill_colour
 
 borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi)
-borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props 
-                                           <*> asksDC stroke_colour
+borderedAttr = (,,) <$> asksDC dc_fill_colour 
+                    <*> asksDC dc_stroke_props 
+                    <*> asksDC dc_stroke_colour
 
-withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a
-withBorderedAttr fn = 
-    fn <$> asksDC fill_colour <*> asksDC stroke_props 
-                              <*> asksDC stroke_colour
 
 
+textAttr :: DrawingCtxM m => m (RGBi,FontAttr)
+textAttr = 
+    (\a b c -> (a, FontAttr b c)) 
+      <$> asksDC dc_text_colour <*> asksDC dc_font_size <*> asksDC dc_font_face
 
--- | Vertical distance between baselines of consecutive text 
--- lines.
+
+
+
+-- | Get the Point corresponding the grid coordinates scaled by
+-- the snap-grid scaling factors.
 --
-getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
-getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)
-                    <$> asksDC round_corner_factor
+position :: (DrawingCtxM m, Fractional u) => (Int, Int) -> m (Point2 u)
+position (x,y) = post <$> asksDC dc_snap_grid_factors
+  where
+    post (sx,sy) = P2 (realToFrac $ sx * fromIntegral x) 
+                      (realToFrac $ sy * fromIntegral y)
 
 
 
--- | Vertical distance between baselines of consecutive text 
--- lines.
+
+-- | Scale a vector coordinate by the snap-grid scaling factors.
 --
-getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u)
-getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep))
-                    <$> asksDC text_margin
+-- Absolute units.
+--
+snapmove :: (DrawingCtxM m, Fractional u) => (Int,Int) -> m (Vec2 u)
+snapmove (x,y) = post <$> asksDC dc_snap_grid_factors
   where
-    fn d = (realToFrac d) * fromPtSize 1
+    post (sx,sy) = V2 (realToFrac $ sx * fromIntegral x) 
+                      (realToFrac $ sy * fromIntegral y)
 
 
 
-getLineWidth :: DrawingCtxM m => m Double
-getLineWidth = line_width <$> asksDC stroke_props
+-- | Get the (x,y) margin around text.
+--
+-- Note - not all text operations in Wumpus are drawn with text 
+-- margin. 
+-- 
+textMargin :: (DrawingCtxM m, InterpretUnit u) => m (u,u)
+textMargin = post <$> asksDC dc_font_size <*> asksDC dc_text_margin
+  where
+    post sz (TextMargin xem yem) = (uconvert1 sz xem, uconvert1 sz yem)
 
-getFontAttr :: DrawingCtxM m => m FontAttr
-getFontAttr = asksDC font_props
 
-getFontSize :: DrawingCtxM m => m Int
-getFontSize = font_size <$> asksDC font_props
 
-getFontFace :: DrawingCtxM m => m FontFace
-getFontFace = font_face <$> asksDC font_props
 
 
+getLineWidth :: DrawingCtxM m => m Double
+getLineWidth = line_width <$> asksDC dc_stroke_props
 
+getFontAttr :: DrawingCtxM m => m FontAttr
+getFontAttr = FontAttr <$> asksDC dc_font_size <*> asksDC dc_font_face
 
--- | Vertical distance between baselines of consecutive text 
--- lines.
---
-baselineSpacing :: (DrawingCtxM m, Fractional u) => m u
-baselineSpacing = 
-    (\sz factor -> realToFrac $ factor * fromIntegral sz)
-      <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor
 
--- | The /mark/ height is the height of a lowercase letter in the 
--- current font.
---
--- Arrowheads, dots etc. should generally be drawn at the mark 
--- height.
--- 
-markHeight :: (DrawingCtxM m, FromPtSize u) => m u
-markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props
+getFontSize     :: DrawingCtxM m => m Int
+getFontSize     = asksDC dc_font_size
 
+getFontFace     :: DrawingCtxM m => m FontFace
+getFontFace     = asksDC dc_font_face
 
-markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
-markHalfHeight = (0.5*) <$> markHeight
+getTextColour   :: DrawingCtxM m => m RGBi
+getTextColour   = asksDC dc_text_colour
 
 
--- Note - there are probably enough functions that use just 
--- markHeight to merit a withMarkHeight function.
 
+-- | Vertical distance between descender of a line and the 
+-- cap-height of the line below. 
+-- 
+textlineSpace :: (DrawingCtxM m, Fractional u, InterpretUnit u) => m u
+textlineSpace = 
+    post <$> asksDC dc_font_size <*> asksDC dc_line_spacing_factor
+  where
+    post sz factor = dinterp sz ((fromIntegral sz) * (realToFrac factor))
 
 --------------------------------------------------------------------------------
 
-glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u
+
+glyphQuery :: DrawingCtxM m => (FontMetrics -> FontSize -> a) -> m a
 glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC
 
-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)
+-- | 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 :: (DrawingCtxM m, InterpretUnit u) => m (BoundingBox u)
+glyphBoundingBox = 
+    uconvertF <$> asksDC dc_font_size <*> glyphQuery get_bounding_box
 
 
-glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u
-glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange
 
+-- | Height of a capital letter.
+--
+capHeight :: (DrawingCtxM m, InterpretUnit u) => m u
+capHeight = dinterp <$> asksDC dc_font_size <*> glyphQuery get_cap_height
 
-glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u
-glyphCapHeight = glyphQuery get_cap_height
 
-cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u)
-cwLookupTable = glyphQuery get_cw_table
+-- | Note - descender is expected to be negative.
+--
+descender :: (DrawingCtxM m, InterpretUnit u) => m u
+descender = dinterp <$> asksDC dc_font_size <*> glyphQuery get_descender
 
 
---------------------------------------------------------------------------------
-
-withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u
-withFontSize fn = (fn . font_size) <$> asksDC font_props
+-- | Note - underline_position is expected to be negative.
+--
+underlinePosition :: (DrawingCtxM m, InterpretUnit u) => m u
+underlinePosition = 
+    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_position
 
 
--- NOTE - textHeight in Wumpus-Core should be renamed as it is
--- (probably) more indiactive of Cap height than /font point size/
+-- | Line width of underline line.
 --
+underlineThickness :: (DrawingCtxM m, InterpretUnit u) => m u
+underlineThickness = 
+    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_thickness
 
-monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u
-monoFontPointSize = withFontSize (fromPtSize . fromIntegral)
 
-monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u
-monoCharWidth = withFontSize (fromPtSize . FS.charWidth)
+-- | This is the distance from cap_height to descender.
+--
+verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u
+verticalSpan = 
+    (\ch dd -> ch - dd) <$> capHeight <*> descender
 
 
-monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u
-monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n
 
+-- | Variant of 'verticalSpan' that accounts for the specified
+-- 'TextHeight'.
+--
+-- This returns a pair of @(yminor, ymajor)@.
+-- 
+heightSpan :: (DrawingCtxM m, InterpretUnit u )
+           => TextHeight -> m (u,u)
+heightSpan JUST_CAP_HEIGHT           = (\ymaj -> (0, ymaj)) <$> capHeight
+heightSpan CAP_HEIGHT_PLUS_DESCENDER = 
+    (\ymin ymaj -> (abs ymin, ymaj)) <$> descender <*> capHeight
 
-monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u
-monoTextLength ss = monoTextWidth $ charCount ss
 
 
-monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u
-monoCapHeight = withFontSize (fromPtSize . FS.capHeight)
-
-monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u
-monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight)
+--------------------------------------------------------------------------------
 
 
 
--- | Height of a lower case \'x\' in Courier.
---  
--- \'x\' has no ascenders or descenders. 
+-- | Find the advance vector for the supplied 'EscapedText'.
+--
+-- Note - the text assumed to be a single line.
 -- 
-monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u
-monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight)
+escTextVector :: (DrawingCtxM m, InterpretUnit u) 
+              => EscapedText -> m (Vec2 u)
+escTextVector esc = 
+    cwLookupTable >>= \table -> 
+    pointSize     >>= \sz    -> 
+    let cs = destrEscapedText id esc 
+    in return $ foldr (step sz table) (vec 0 0) cs
+  where
+    step sz table ch v = let cv = escCharWidth sz table ch in v ^+^ cv
 
-monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u
-monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth)
 
-monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u
-monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight)
 
+-- | Find the advance vector for the supplied 'EscapedChar'.
+--
+escCharVector :: (DrawingCtxM m, InterpretUnit u) 
+           => EscapedChar -> m (Vec2 u)
+escCharVector ch = 
+    (\table sz -> escCharWidth sz table ch) <$> cwLookupTable <*> pointSize
 
--- | Query the dimensions of the text using the current font size
--- but using metrics derived from Courier.
+
+-- | This is outside the Drawing context as we don\'t want to get
+-- the @cwLookupTable@ for every char.
 --
--- Note - the width will generally be a over-estimate for 
--- non-monospaced fonts.
--- 
-monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u)
-                   => String -> m (u,u)
-monoTextDimensions ss = 
-    (\sz -> post $ textBounds sz zeroPt ss) 
-      <$> asksDC (font_size . font_props)
+escCharWidth :: InterpretUnit u 
+             => FontSize -> CharWidthLookup -> EscapedChar -> Vec2 u
+escCharWidth sz fn (CharLiteral c) = fmap (dinterp sz) $ fn $ ord c
+escCharWidth sz fn (CharEscInt i)  = fmap (dinterp sz) $ fn i
+escCharWidth sz fn (CharEscName s) = fmap (dinterp sz) $ fn ix
   where
-    post bb = (boundaryWidth bb, boundaryHeight bb)
+    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
 
 
--- | The heigth of @n@ lines of text, which is 
--- @n lines + n-1 line spacers@
---
-monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) 
-                        => Int -> m u
-monoMultiLineHeight n | n < 0   = pure 0
-monoMultiLineHeight n           = 
-    (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf))
-      <$> monoTotalCharHeight <*> asksDC line_spacing_factor
- 
-    -- Note as the height calculation has changed in Wumpus-Core this
-    -- no longer quite works... 
 
- 
 
--- | The default padding is half of the /char width/.
+-- | 'hkernVector' : @ [kerning_char] -> AdvanceVec @
+-- 
+-- 'hkernvector' takes whatever length is paired with the 
+-- EscapedChar for the init of the the list, for the last element 
+-- it takes the charVector.
 --
-monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
-monoDefaultPadding = (0.5*) <$> monoCharWidth
+hkernVector :: (DrawingCtxM m, InterpretUnit u) 
+            => [KernChar u] -> m (Vec2 u)
+hkernVector = go 0
+  where
+    go w []             = return $ V2 w 0
+    go w [(dx,ch)]      = fmap (addWidth $ w + dx) (escCharVector ch)
+    go w ((dx,_ ):xs)   = go (w + dx) xs
+    
+    addWidth w (V2 x y) = V2 (w+x) y
 
--- | Vector from baseline left to center
+
+
+-- | Note the CharWidthLookup is not parameteric on units.
 --
-monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) 
-                => String -> m (Vec2 u)
-monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) 
-                       <$> monoTextDimensions ss <*> monoDescenderDepth
+-- /CharWidth/ is always Double representing PostScript points.
+-- Client code must convert this value accordingly.
+--
+cwLookupTable :: DrawingCtxM m => m CharWidthLookup
+cwLookupTable = glyphQuery get_cw_table
diff --git a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs b/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Base.ScalingContext
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC
---
--- Scaling in X and Y
---
--- \*\* WARNING \*\* - half baked.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Base.ScalingContext
-  (
-
-    ScalingContext(..)
-
-  , scaleX
-  , scaleY
-  , scalePt
-  , scaleVec
-
-  , unitX
-  , unitY
-
-  , uniformScaling
-  , coordinateScaling
-
-  ) where
-
-
-import Wumpus.Core				-- package: wumpus-core
-
-
-
--- | ScalingContext is a dictionary of two functions for scaling 
--- in X and Y.
---
-data ScalingContext ux uy u = ScalingContext
-      { scale_in_x  :: ux -> u
-      , scale_in_y  :: uy -> u
-      }
-
-
-scaleX              :: ScalingContext ux uy u -> ux -> u
-scaleX ctx ux       = (scale_in_x ctx) ux
-
-scaleY              :: ScalingContext ux uy u -> uy -> u
-scaleY ctx uy       = (scale_in_y ctx) uy
-
-
-scalePt             :: ScalingContext ux uy u -> ux -> uy -> Point2 u
-scalePt ctx ux uy   = P2 (scale_in_x ctx ux) (scale_in_y ctx uy)
-
-scaleVec            :: ScalingContext ux uy u -> ux -> uy -> Vec2 u
-scaleVec ctx ux uy  = V2 (scale_in_x ctx ux) (scale_in_y ctx uy)
-
-
-unitX               :: Num ux => ScalingContext ux uy u -> u
-unitX ctx           = scaleX ctx 1
- 
-unitY               :: Num uy => ScalingContext ux uy u -> u
-unitY ctx           = scaleY ctx 1
-
-
-
-
---------------------------------------------------------------------------------
--- constructors for scaling context
-
-
--- | Build a ScalingContext where both X and Y are scaled by the 
--- same uniform step.
---
--- The dimensions (types) of the ScalingContext are unified - the 
--- output type and the input types are all the same.
---
-uniformScaling :: Num u => u -> ScalingContext u u u
-uniformScaling u = ScalingContext
-      { scale_in_x  = (\x -> u*x)
-      , scale_in_y  = (\y -> u*y)
-      }
-
-
-
--- | Build a ScalingContext for scaling Int coordinates.
---
--- The scaling factors in X and Y can be different sizes.
----
-coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u
-coordinateScaling sx sy = ScalingContext
-      { scale_in_x  = (\x -> sx * fromIntegral x)
-      , scale_in_y  = (\y -> sy * fromIntegral y)
-      }
-
-
-
diff --git a/src/Wumpus/Basic/Kernel/Base/Units.hs b/src/Wumpus/Basic/Kernel/Base/Units.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Base/Units.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Base.Units
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Units @cm@, @pica@ and \"contextual\" units - @em@, @en@.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Base.Units
+  (
+
+
+  -- * Centimeter
+    Centimeter
+  , cm
+  , dcm
+
+  -- * Pica
+  , Pica
+  , pica
+  , dpica
+
+  -- * Em
+  , Em
+
+  -- * En
+  , En
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+--------------------------------------------------------------------------------
+
+-- | Wrapped Double representing Centimeter.
+-- 
+newtype Centimeter = Centimeter { getCentimeter :: Double } 
+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
+
+
+instance Show Centimeter where
+  showsPrec p d = showsPrec p (getCentimeter d)
+
+-- | Cast a value in Centimeters to some Fractional type.
+-- 
+-- Note - this casting should only be used for non-contextual
+-- units such as Double.
+--
+cm :: Fractional u => Centimeter -> u 
+cm = realToFrac . (28.45275619 *) . getCentimeter
+
+-- | Convert Double to Centimer.
+-- 
+dcm :: Double -> Centimeter
+dcm = Centimeter . (0.03514598 *)
+
+instance ScalarUnit Centimeter where
+  fromPsPoint = dcm
+  toPsPoint   = cm 
+
+instance InterpretUnit Centimeter where
+  normalize _ = cm 
+  dinterp   _ = dcm
+
+instance Tolerance Centimeter where 
+  eq_tolerance     = 0.001
+  length_tolerance = 0.01
+
+
+
+-- | Wrapped Double /Pica/ unit type.
+-- 
+-- Pica is 12 Points.
+--
+newtype Pica = Pica { getPica :: Double } 
+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
+
+
+instance Show Pica where
+  showsPrec p d = showsPrec p (getPica d)
+
+                            
+-- | Cast a value in Pica to some Fractional type.
+-- 
+-- Note - this casting should only be used for non-contextual
+-- units such as Double.
+--
+pica :: Fractional u => Pica -> u 
+pica = realToFrac . (* 12.0) . getPica
+
+-- | Convert a Double to a Pica.
+--
+dpica :: Double -> Pica
+dpica = Pica . (\x -> x / 12.0)
+
+
+
+instance ScalarUnit Pica where
+  fromPsPoint = dpica
+  toPsPoint   = pica
+
+instance InterpretUnit Pica where
+  normalize _ = pica
+  dinterp   _ = dpica
+
+
+instance Tolerance Pica where 
+  eq_tolerance     = 0.001
+  length_tolerance = 0.01
+
+
+
+--------------------------------------------------------------------------------
+-- Contextual units
+
+-- | Wrapped Double representing an Em. 
+-- 
+newtype Em = Em { getEm :: Double } 
+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
+
+instance Show Em where
+  showsPrec p d = showsPrec p (getEm d)
+
+
+
+instance InterpretUnit Em where
+  normalize sz a = fromIntegral sz * realToFrac a
+  dinterp sz d   = realToFrac d / fromIntegral sz
+
+
+instance Tolerance Em where 
+  eq_tolerance     = 0.001
+  length_tolerance = 0.01
+
+
+-- | Wrapped Double representing an En.
+-- 
+newtype En = En { getEn :: Double } 
+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
+
+instance Show En where
+  showsPrec p d = showsPrec p (getEn d)
+
+
+instance InterpretUnit En where
+  normalize sz a = (realToFrac  a) * 0.5 * fromIntegral sz
+  dinterp sz d   = 2 * (realToFrac d) / (fromIntegral sz)
+
+
+instance Tolerance En where
+  eq_tolerance     = 0.001 
+  length_tolerance = 0.01
+
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
@@ -3,77 +3,105 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Base.UpdateDC
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
 -- Stability   :  highly unstable
 -- Portability :  GHC
 --
--- Customize drawing attributes
---
--- \*\* WARNING \*\* - this module needs systematic naming 
--- schemes both for update functions (primaryColour, ...) and 
--- for synthesized selectors (e.g. lowerxHeight). The current 
--- names will change.
+-- Customize drawing attributes. The functions here are 
+-- @DrawingContext@ modifiers to be run within a the scope of a 
+-- @localize@ block (cf. @local@ of the Reader monad).
 --
+-- By convention, underscore-separated names are used for 
+-- DrawingContext modifiers in this module. This is because the 
+-- modifiers defined here are expected to be used mostly as static 
+-- \"properties\" resembling constants in drawings.
 -- 
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Base.UpdateDC
   ( 
 
-  -- * Modifiers 
-  
-    roundCornerFactor
-  , textMargin
+  -- * Globals
+    snap_grid_factors
 
-  -- ** Line widths
-  , lineWidth
-  , thick
-  , ultrathick
-  , thin
+  -- * Line widths
+  , set_line_width
 
-  -- ** Line caps
-  , capButt
-  , capRound
-  , capSquare
+  , line_default
+  , line_thin
+  , line_thick
+  , line_ultra_thick
+  
+  , contextual_line_width
+  , relative_line_width
 
-  -- ** Line joins
-  , joinMiter
-  , joinRound
-  , joinBevel
+  -- * Line cap
+  , cap_default
+  , cap_butt
+  , cap_round
+  , cap_square
 
-  -- ** Dash Pattern
-  , dashPattern
-  , unit_dash_pattern
-  , phase
-  , dphase
-  , doublegaps
-  , doubledashes
+  -- * Line join
+  , join_default
+  , join_miter
+  , join_round
+  , join_bevel
 
+  -- * Dash pattern
+  , set_dash_pattern
+
+  , solid_line
+  , dotted_line
+  , packed_dotted
+  , loose_dotted
+  
+  , dashed_line
+  , packed_dashed
+  , loose_dashed
+  
   -- * Font properties
-  , fontAttr
-  , fontSize
-  , fontFace
+  , font_attr
+  , set_font
+  , set_font_size
+  , scale_point_size
 
-  -- * Font / mark drawing size
-  , doublesize
-  , halfsize
+  , double_point_size
+  , half_point_size
 
+
+  -- * Text margins
+  , text_margin
+  , text_margin_none
+  , text_margin_tight
+  , text_margin_default
+  , text_margin_loose
+
+
   -- * Colour
-  , swapColours
-  , bothStrokeColour
-  , bothFillColour
-  , strokeColour
-  , fillColour 
+  , stroke_colour
+  , fill_colour 
+  , text_colour
+  , single_colour
 
+  , swap_colours
+  , fill_use_stroke_colour
+  , stroke_use_fill_colour
 
-  
+  , fill_use_text_colour
+  , stroke_use_text_colour
+
+  , text_use_stroke_colour
+  , text_use_fill_colour
+
   ) where
 
 
 import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.FontSupport
+import Wumpus.Basic.Kernel.Base.Units
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -81,180 +109,443 @@
 
 
 --------------------------------------------------------------------------------
+-- helpers 
 
 updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF
-updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props
-
-updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF
-updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props
+updateStrokeProps fn = 
+    (\s i -> s { dc_stroke_props = fn i }) <*> dc_stroke_props
 
 
+withFontSize :: (FontSize -> DrawingContextF) -> DrawingContextF
+withFontSize fn = (\s i -> fn i s) <*> dc_font_size
 
 --------------------------------------------------------------------------------
 
-roundCornerFactor   :: Double -> DrawingContextF
-roundCornerFactor d = (\s -> s { round_corner_factor = d })
 
--- | 'textMargin' : @ xsep * ysep -> DrawingContextF @
+
+-- | 'snap_grid_factors' : @ x_unit * y_unit -> DrawingContextF @
+-- 
+-- Set the @snap grid factors@ - a snap grid is an alternative 
+-- coordinate space, it can be convenient for drawing 
+-- \"box and arrow\" diagrams.
 --
-textMargin   :: Double -> Double -> DrawingContextF
-textMargin xsep ysep = (\s -> s { text_margin = TextMargin xsep ysep })
+snap_grid_factors   :: Double -> Double -> DrawingContextF
+snap_grid_factors xu yu = \s -> s { dc_snap_grid_factors = (xu, yu) }
 
 
 --------------------------------------------------------------------------------
 -- line widths
 
--- Note - some care might be needed if we ever define other unit 
--- types...
 
-lineWidth       :: Double -> DrawingContextF
-lineWidth d      = updateStrokeProps (\s -> s { line_width = d })
+-- | set_line_width : @ width_in_points -> DrawingContextF @
+--
+-- Set the line_width to the supplied point size.
+--
+-- Initially the line width is 1.0.
+--
+-- /Constant/ variations of the function maybe be more 
+-- convenient:
+--
+-- > line_default, line_thin, line_thick, line_ultra_thick
+--
+set_line_width      :: Double -> DrawingContextF
+set_line_width d    = updateStrokeProps (\s -> s { line_width = d })
 
 
--- std_line_width      :: Double
--- std_line_width      = 1.0
+-- | Set the line_width to @default@ - 1.0.
+--
+line_default        :: DrawingContextF
+line_default        = set_line_width 1.0
 
-thick_line          :: Double
-thick_line          = 2.0
 
-ultra_thick_line    :: Double
-ultra_thick_line    = 4.0
+-- | Set the line_width to @thin@ - 0.5.
+--
+line_thin           :: DrawingContextF
+line_thin           = set_line_width 0.5
 
-thin_line           :: Double
-thin_line           = 0.5
 
+-- | Set the line_width to @thick@ - 2.0.
+--
+line_thick          :: DrawingContextF
+line_thick          = set_line_width 2.0
 
--- | Set the line width to a /thick/.
+-- | Set the line_width to @ultra_thick@ - 4.0.
 --
--- Note this context update is /oblivious/ - operationally the 
--- line width is set to exactly @2.0@.
+line_ultra_thick    :: DrawingContextF
+line_ultra_thick    = set_line_width 4.0
+
+
+
+-- | Scale the line width respective to its current value. 
+-- 
+-- The size is calculated with the supplied function.
 --
-thick               :: DrawingContextF
-thick               = lineWidth thick_line
+relative_line_width :: (Double -> Double) -> DrawingContextF
+relative_line_width fn = 
+    updateStrokeProps (\s -> let lw = line_width s in s { line_width = fn lw })
 
-ultrathick          :: DrawingContextF
-ultrathick          = lineWidth ultra_thick_line
 
-thin                :: DrawingContextF
-thin                = lineWidth thin_line
+-- | Set the line width to a size relative to the current font 
+-- size. The size is calculated with the supplied function.
+--
+contextual_line_width :: (FontSize -> Double) -> DrawingContextF
+contextual_line_width fn = 
+    withFontSize $ \sz s -> set_line_width (fn sz) s
 
 
+
 --------------------------------------------------------------------------------
+-- Line props
 
 setLineCap          :: LineCap -> DrawingContextF
 setLineCap d        = updateStrokeProps (\s -> s { line_cap = d })
 
+setLineJoin         :: LineJoin -> DrawingContextF
+setLineJoin d       = updateStrokeProps (\s -> s { line_join = d })
 
-capButt             :: DrawingContextF
-capButt             = setLineCap CapButt
 
-capRound            :: DrawingContextF
-capRound            = setLineCap CapRound
+-- | Set the line_cap to the default which is @butt@.
+--
+-- This is a synonym for 'cap_butt'.
+--
+cap_default         :: DrawingContextF
+cap_default         = cap_butt
 
-capSquare           :: DrawingContextF
-capSquare           = setLineCap CapSquare
+-- | Set the line_cap to @butt@.
+--
+-- Butt chamfers off the stroke, flush to the end point.
+--
+-- This is the default.
+--
+-- >  .-------.
+-- >  |=======|
+-- >  '-------'
+--
+cap_butt            :: DrawingContextF
+cap_butt            = setLineCap CapButt
 
+-- | Set the line_cap to @round@.
+--
+-- This rounds the end of the stroke and the visually the 
+-- rounding slightly extends the length of the line.
+--
+-- >  .-------.
+-- > ( ======= )
+-- >  '-------'
+--
+cap_round           :: DrawingContextF
+cap_round           = setLineCap CapRound
 
-setLineJoin         :: LineJoin -> DrawingContextF
-setLineJoin d       = updateStrokeProps (\s -> s { line_join = d })
 
+-- | Set the line_cap to @square@.
+--
+-- This squares off the end of the stroke, but visual extends the 
+-- stroke by half the line width.
+--
+-- >  .---------.
+-- >  | ======= |
+-- >  '---------'
+--
+cap_square          :: DrawingContextF
+cap_square          = setLineCap CapSquare
 
-joinMiter           :: DrawingContextF
-joinMiter           = setLineJoin JoinMiter
 
-joinRound           :: DrawingContextF
-joinRound           = setLineJoin JoinRound
 
-joinBevel           :: DrawingContextF
-joinBevel           = setLineJoin JoinBevel
+-- | Set the line_join to the default which is @miter@.
+--
+-- This is a synonym for 'join_miter'.
+--
+join_default        :: DrawingContextF
+join_default        = join_miter
 
 
+-- | Set the line_join to @miter@.
+--
+-- This extends the joining line segments to form a sharp miter.
+--
+-- This is the default.
+--
+-- >      /\
+-- >     /..\ 
+-- >    /./\.\
+-- >   /./  \.\
+-- >  /./    \.\
+--
+join_miter          :: DrawingContextF
+join_miter          = setLineJoin JoinMiter
+
+
+-- | Set the line_join to @round@.
+--
+-- This rounds off the corner of the joined line segments.
+--
+-- >  \.\  
+-- >   \.\ 
+-- >    ,.)
+-- >   /./
+-- >  /./
+--
+join_round          :: DrawingContextF
+join_round          = setLineJoin JoinRound
+
+
+-- | Set the line_join to @round@.
+--
+-- This bevels off the corner of the joined line segments with a 
+-- notch.
+--
+-- >      __
+-- >     /..\ 
+-- >    /./\.\
+-- >   /./  \.\
+-- >  /./    \.\
+--
+join_bevel          :: DrawingContextF
+join_bevel          = setLineJoin JoinBevel
+
+
 --------------------------------------------------------------------------------
 
-dashPattern         :: DashPattern -> DrawingContextF
-dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })        
+ 
+-- | Set the dash pattern.
+--
+-- Initially the dash pattern is 'Solid'.
+--
+set_dash_pattern    :: DashPattern -> DrawingContextF
+set_dash_pattern d  = updateStrokeProps (\s -> s { dash_pattern = d })        
 
-unit_dash_pattern   :: DashPattern
-unit_dash_pattern   = Dash 0 [(1,1)]
 
--- oblivious
-phase               :: Int -> DashPattern -> DashPattern
-phase _ Solid       = Solid
-phase i (Dash _ xs) = Dash i xs
+-- | Set the dash_pattern to @solid@ - i.e. no dash pattern.
+--
+-- This is the default.
+--
+solid_line          :: DrawingContextF 
+solid_line          = set_dash_pattern Solid
 
--- non-oblivious
-dphase               :: Int -> DashPattern -> DashPattern
-dphase _ Solid       = Solid
-dphase d (Dash i xs) = Dash (i+d) xs
+-- | Set the dash pattern to draw a dotted line.
+-- 
+-- A dot is actually a square - side length is equal to the line 
+-- width.
+-- 
+-- The spacing between dots is 2 times the dot width.
+--
+dotted_line         :: DrawingContextF 
+dotted_line         = set_dash_pattern $ Dash 0 [(1,2)]
 
-doublegaps              :: DashPattern -> DashPattern
-doublegaps Solid        = Solid
-doublegaps (Dash i xs)  = Dash i (map fn xs)
-  where
-    fn (a,b) = (a,2*b)
+-- | Set the dash pattern to draw a tightly packed dotted line.
+-- 
+-- A dot is actually a square - side length is equal to the line 
+-- width.
+-- 
+-- The spacing between dots is equal to the dot width.
+--
+packed_dotted       :: DrawingContextF 
+packed_dotted       = set_dash_pattern $ Dash 0 [(1,1)]
 
-doubledashes              :: DashPattern -> DashPattern
-doubledashes Solid        = Solid
-doubledashes (Dash i xs)  = Dash i (map fn xs)
-  where
-    fn (a,b) = (a*2,b)
 
+-- | Set the dash pattern to draw a loosely dotted line.
+-- 
+-- A dot is actually a square - side length is equal to the line 
+-- width.
+-- 
+-- The spacing between dots is 4 times the dot width.
+--
+loose_dotted        :: DrawingContextF 
+loose_dotted        = set_dash_pattern $ Dash 0 [(1,4)]
 
---------------------------------------------------------------------------------
 
-fontAttr            :: FontFace -> Int -> DrawingContextF
-fontAttr ff sz      = (\s -> s { font_props = FontAttr sz ff })
 
-fontFace            :: FontFace -> DrawingContextF
-fontFace ff         = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff)
+-- | Set the dash pattern to draw a dashed line.
+-- 
+-- The dash length is 3 times the line width, the spacing is 2
+-- times the line width.
+--
+dashed_line        :: DrawingContextF
+dashed_line        = set_dash_pattern $ Dash 0 [(3,2)]
 
-fontSize            :: Int -> DrawingContextF
-fontSize sz         = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff)
 
+-- | Set the dash pattern to draw a tightly packed, dashed line.
+-- 
+-- The dash length is 3 times the line width, the spacing is 
+-- equal to the line width.
+--
+packed_dashed      :: DrawingContextF
+packed_dashed      = set_dash_pattern $ Dash 0 [(3,1)]
 
+
+-- | Set the dash pattern to draw a loosely dashed line.
+-- 
+-- The dash length is 3 times the line width, the spacing is 4
+-- times the line width.
+--
+loose_dashed      :: DrawingContextF
+loose_dashed      = set_dash_pattern $ Dash 0 [(3,4)]
+
+
+
 --------------------------------------------------------------------------------
 
--- | Set the font size to double the current size, note the font
--- size also controls the size of dots, arrowsheads etc.
+-- | Set the font attributes, point size and font face.
+--
+font_attr               :: FontDef -> Int -> DrawingContextF
+font_attr ft sz         = \s -> s { dc_font_size = sz
+                                  , dc_font_face = font_def_face ft }
+
+-- | Set the font face.
+--
+set_font                :: FontDef -> DrawingContextF
+set_font ft             = \s -> s { dc_font_face = font_def_face ft }
+
+
+-- | Set the point size.
+--
+-- This controls the drawing size of both 
+-- text labels and marks (e.g. dots and arrowheads).
+--
+set_font_size           :: Int -> DrawingContextF
+set_font_size sz        = \s -> s { dc_font_size = sz }
+
+
+-- | Scale the current point size by the supplied ratio.
 -- 
-doublesize          :: DrawingContextF
-doublesize          = (\s sz -> fontSize (sz*2) s) 
-                        <*> (font_size . font_props)
+-- Note - as fonts can only be drawn at integral sizes this 
+-- operation is not exact - for instance scaling 15pt by (1%2) 
+-- results in 7pt.
+-- 
+scale_point_size    :: Double -> DrawingContextF
+scale_point_size a  = (\s sz -> set_font_size (floor $ a * fromIntegral sz) s) 
+                         <*> dc_font_size
 
+-- | Set the point size (font and mark size) to double the current 
+-- size.
+--
+double_point_size   :: DrawingContextF
+double_point_size   = scale_point_size 2 
 
--- | Set the font size to half the current size, note the font
+
+-- | Set the point size to half the current size, note the point
 -- size also controls the size of dots, arrowsheads etc.
 -- 
--- As fontsize is an integer this is not exact - half size of
--- 15pt type is 7pt.
+-- Note - as fonts can only be drawn at integral sizes this 
+-- operation is not exact - half size of 15pt type is 7pt.
 -- 
-halfsize            :: DrawingContextF
-halfsize            = (\s sz -> fontSize (sz `div` 2) s) 
-                        <*> (font_size . font_props)
+half_point_size     :: DrawingContextF
+half_point_size     = scale_point_size 0.5
 
 
+-- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @
+--
+-- Note - this is in @Em@ units.
+--
+text_margin   :: Em -> Em -> DrawingContextF
+text_margin xsep ysep = \s -> 
+    s { dc_text_margin = TextMargin xsep ysep }
+
+
+-- | Set the text margin to (0,0).
+-- 
+-- This produces a tight box around the text vertically measured 
+-- to the cap-height and descender. Therefore some characters may 
+-- extend outside the margin (e.g. accented capitals like 
+-- A-grave).
+--
+text_margin_none    :: DrawingContextF
+text_margin_none    = text_margin 0 0 
+
+
+
+-- | Set the text margin to (0.25 em, 0.25 em).
+-- 
+text_margin_tight       :: DrawingContextF
+text_margin_tight       = text_margin 0.25 0.25
+
+-- | Set the text margin to (0.5 em, 0.5 em).
+-- 
+text_margin_default :: DrawingContextF
+text_margin_default = text_margin 0.5 0.5
+
+-- | Set the text margin to (1.0 em, 1.0 em).
+-- 
+text_margin_loose   :: DrawingContextF
+text_margin_loose = text_margin 1.0 1.0
+
+
 --------------------------------------------------------------------------------
 
-swapColours :: DrawingContextF
-swapColours = 
-    (\s a b -> s { stroke_colour = b, fill_colour = a })
-        <*> stroke_colour <*> fill_colour
+-- | Set the stroke colour.
+--
+stroke_colour :: RGBi -> DrawingContextF
+stroke_colour rgb = \s -> s { dc_stroke_colour = rgb } 
 
-bothStrokeColour :: DrawingContextF
-bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour
 
-bothFillColour :: DrawingContextF
-bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour
+-- | Set the fill colour.
+--
+fill_colour :: RGBi -> DrawingContextF
+fill_colour rgb = \s -> s { dc_fill_colour = rgb } 
 
 
+-- | Set the text colour.
+--
+text_colour          :: RGBi -> DrawingContextF
+text_colour rgb      = (\s -> s { dc_text_colour = rgb})
 
-strokeColour :: RGBi -> DrawingContextF
-strokeColour rgb = \s -> s { stroke_colour = rgb } 
 
 
-fillColour :: RGBi -> DrawingContextF
-fillColour rgb = \s -> s { fill_colour = rgb } 
+-- | Set the stroke, fill and text colours to a single colour.
+--
+single_colour :: RGBi -> DrawingContextF
+single_colour rgb = stroke_colour rgb . fill_colour rgb . text_colour rgb
 
 
+
+-- | Swap the stroke colour and fill colours.
+--
+swap_colours :: DrawingContextF
+swap_colours = 
+    (\s a b -> s { dc_stroke_colour = b, dc_fill_colour = a })
+        <*> dc_stroke_colour <*> dc_fill_colour
+
+
+-- | Set the fill colour to use the current stroke colour.
+--
+fill_use_stroke_colour :: DrawingContextF
+fill_use_stroke_colour = 
+    (\s a -> s { dc_fill_colour = a }) <*> dc_stroke_colour
+
+
+-- | Set the stroke colour to use the current fill colour.
+--
+stroke_use_fill_colour :: DrawingContextF
+stroke_use_fill_colour = 
+    (\s a -> s { dc_stroke_colour = a }) <*> dc_fill_colour
+
+
+-- | Set the fill colour to use the current text colour.
+--
+fill_use_text_colour :: DrawingContextF
+fill_use_text_colour = 
+    (\s a -> s { dc_fill_colour = a }) <*> dc_text_colour
+
+
+-- | Set the stroke colour to use the current fill colour.
+--
+stroke_use_text_colour :: DrawingContextF
+stroke_use_text_colour = 
+    (\s a -> s { dc_stroke_colour = a }) <*> dc_text_colour
+
+
+
+-- | Set the text colour to use the current stroke colour.
+--
+text_use_stroke_colour :: DrawingContextF
+text_use_stroke_colour = 
+    (\s a -> s { dc_text_colour = a }) <*> dc_stroke_colour
+
+
+-- | Set the text colour to use the current fill colour.
+--
+text_use_fill_colour :: DrawingContextF
+text_use_fill_colour = 
+    (\s a -> s { dc_text_colour = a }) <*> dc_fill_colour
 
 
diff --git a/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs
--- a/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs
+++ b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs
@@ -1,43 +1,38 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# LANGUAGE FlexibleInstances          #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Base.WrappedPrimitive
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
 -- Stability   :  highly unstable
 -- Portability :  GHC 
 --
--- Two /warpped/ versions of the Primitive type from Wumpus-Core.
+-- Wrapped versions of the @Primitive@ type from Wumpus-Core.
 --
+-- This file is essentially /internal/ to Wumpus-Basic.
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Base.WrappedPrimitive
   (
 
+
   -- * Primitives
-    HPrim
+    CatPrim
+  , prim1
+  , cpmap
+  , cpmove
+
+  , HPrim
   , hprimToList
   , singleH
 
-  -- * Collect primitives (writer monad) 
-  , TraceM(..)
-
-  , PrimGraphic
-
-  , getPrimGraphic
-  , primGraphic
-  , metamorphPrim
-  , collectH
-
   ) where
 
-import Wumpus.Basic.Kernel.Base.BaseDefs
 import Wumpus.Basic.Utils.HList
 
 import Wumpus.Core                      -- package: wumpus-core
@@ -47,103 +42,117 @@
 
 
 
--- As of version 0.36.0, Wumpus-Core supports grouping primitives
--- together (a common operation in vector drawing editors). 
+-- | A wrapped version of 'Primitive' from Wumpus-Core that 
+-- supports Monoid.
+-- 
+-- Note that CatPrim provides a /single-object/ that can be
+-- hyperlinked or whatever. 
 --
--- For Wumpus-Basic this means e.g. a line with arrowheads can 
--- still be a primitive.
+-- It is different to 'HPrim' which is intended as a list type 
+-- with efficient concatenation to support building of multiple
+-- Primitives in a frame.
 --
--- Still, we wrap Primitive as a newtype...
+-- This type is essentially internal to Wumpus-Basic.
 --
+data CatPrim = CZero
+             | Cat1 Primitive
 
-newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u }
-  deriving (Eq,Show)
+type instance DUnit CatPrim = Double
 
 
-type instance DUnit (PrimGraphic u) = u
 
+instance Monoid CatPrim where
+  mempty                  = CZero
+  CZero  `mappend` b      = b
+  a      `mappend` CZero  = a
+  Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b
 
+  mconcat []      = mempty
+  mconcat (a:as)  = step a as
+    where
+      step ac []     = ac
+      step ac (x:xs) = step (ac `mappend` x) xs
 
---------------------------------------------------------------------------------
--- Lists of primitives...
 
--- | Graphics objects, even simple ones (line, arrow, dot) might 
--- need more than one primitive (path or text label) for their
--- construction. Hence, the primary representation that all the 
--- others are built upon must support /concatenation/ of 
--- primitives. 
---
--- Wumpus-Core has a type Picture - made from one or more 
--- Primitives - but Pictures include support for affine frames. 
--- For drawing many simple graphics (dots, connector lines...) 
--- that do not need individual affine transformations this is a 
--- penalty. A list of Primitives is therefore more suitable 
--- representation, and a Hughes list which supports
--- efficient concatenation is wise.
---
-newtype HPrim u = HPrim { getHPrim :: H (Primitive u) }
 
--- Note - only a Monoid instance for HPrim - they cannot be 
--- shown, fmapped etc.
 
-instance Monoid (HPrim u) where
-  mempty          = HPrim emptyH
-  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb
+--------------------------------------------------------------------------------
 
+instance Rotate CatPrim where
+  rotate _   CZero              = CZero
+  rotate ang (Cat1 a)           = Cat1 $ rotate ang a
 
-hprimToList :: HPrim u -> [Primitive u]
-hprimToList = toListH . getHPrim
+instance RotateAbout CatPrim where
+  rotateAbout _   _  CZero      = CZero
+  rotateAbout ang pt (Cat1 a)   = Cat1 $ rotateAbout ang pt a
 
+instance Scale CatPrim where
+  scale _  _  CZero             = CZero
+  scale sx sy (Cat1 a)          = Cat1 $ scale sx sy a
 
-singleH :: Primitive u -> HPrim u
-singleH = HPrim . wrapH 
+instance Translate CatPrim where
+  translate _  _  CZero         = CZero
+  translate dx dy (Cat1 a)      = Cat1 $ translate dx dy a
 
 
 --------------------------------------------------------------------------------
 
--- | Collect elementary graphics as part of a larger drawing.
---
--- TraceM works much like a writer monad.
---
-class TraceM (m :: * -> *) where
-  trace  :: MonUnit m ~ u => HPrim u -> m ()
+prim1 :: Primitive -> CatPrim 
+prim1 = Cat1
 
 
+-- | Map 
+cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim
+cpmap _ CZero    = CZero
+cpmap f (Cat1 a) = Cat1 $ f a
 
 
+cpmove :: Vec2 Double -> CatPrim -> CatPrim
+cpmove (V2 x y) = translate x y
 
+
 --------------------------------------------------------------------------------
--- instances
+-- Lists of primitives...
 
-instance OPlus (PrimGraphic u) where
-  oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b
 
+-- | Collected primitives - this type is effectively an analogue
+-- to a @Frame@ in Wumpus-Core.
+--
+-- This type is essentially internal to Wumpus-Basic.
+-- 
+newtype HPrim u = HPrim { getHPrim :: H Primitive }
 
--- Affine transformations
+-- Note - only a Monoid instance for HPrim - they cannot be 
+-- shown, fmapped etc.
 
-instance (Real u, Floating u) => Rotate (PrimGraphic u) where
-  rotate ang = PrimGraphic . rotate ang . getPrimGraphic
+instance Monoid (HPrim u) where
+  mempty          = HPrim emptyH
+  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb
 
+  mconcat []      = mempty
+  mconcat (a:as)  = step a as
+    where
+      step ac []     = ac
+      step ac (x:xs) = step (ac `mappend` x) xs
 
-instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where
-  rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic
 
+-- | Extract the internal list of 'Primitive' from a 'HPrim'.
+-- 
+-- The expectation is that this Primitive list will be rendered
+-- by Wumpus-Core as a @frame@.
+--
+hprimToList :: HPrim u -> [Primitive]
+hprimToList = toListH . getHPrim
 
-instance Num u => Scale (PrimGraphic u) where
-  scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic
 
+-- | Form a 'HPrim' from a 'CatPrim'.
+--
+singleH :: CatPrim -> HPrim u
+singleH CZero    = HPrim emptyH
+singleH (Cat1 a) = HPrim $ wrapH a
 
-instance Num u => Translate (PrimGraphic u) where
-  translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic
 
---------------------------------------------------------------------------------
 
-primGraphic :: Primitive u -> PrimGraphic u 
-primGraphic = PrimGraphic
 
-metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u
-metamorphPrim f = primGraphic . f . getPrimGraphic
 
-collectH :: PrimGraphic u -> HPrim u
-collectH = singleH . getPrimGraphic
 
diff --git a/src/Wumpus/Basic/Kernel/Drawing/Basis.hs b/src/Wumpus/Basic/Kernel/Drawing/Basis.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/Basis.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.Basis
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- User state class for Drawing monads.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Drawing.Basis
+  (
+
+    UState
+  , UserStateM(..)
+
+  , InsertlM(..)
+  , LocationM(..)
+  , CursorM(..)
+  , BranchCursorM(..)
+  , hmoveby
+  , vmoveby
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.LocImage
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+type family UState m :: *
+
+
+class (Applicative m, Monad m) => UserStateM (m :: * -> *) where
+  getState    :: st ~ UState (m a) => m st
+  setState    :: st ~ UState (m a) => st -> m ()
+  updateState :: st ~ UState (m a) => (st -> st) -> m ()
+   
+
+
+
+
+-- | Monad that collects a graphic trace, 'insertl' is analogue 
+-- to the Writer monad\'s @tell@.
+--
+class InsertlM (m :: * -> *) where
+  insertl   :: u ~ DUnit (m ()) => LocImage u a -> m a
+  insertl_  :: u ~ DUnit (m ()) => LocImage u a -> m (UNil u)
+
+  insertl_ = insertl . ignoreAns 
+
+
+-- | Monad with notion of location - i.e. the current point.
+--
+class Monad m => LocationM (m :: * -> *) where
+  location  :: u ~ DUnit (m ()) => m (Point2 u)
+
+
+-- | Monad with turtle-like cursor movememnt.
+--
+class LocationM m => CursorM (m :: * -> *) where  
+  moveby    :: u ~ DUnit (m ()) => Vec2 u -> m ()
+
+
+
+-- | Add operations for branching at the current point.
+-- 
+-- Not all drawings that support tracing support branching. For
+-- instance Paths can be built by tracing but they always need 
+-- a cumulative progression of /next point/ they cannot resrt to 
+-- the start point and go in a differnt direction.
+-- 
+class CursorM m => BranchCursorM (m :: * -> *) where
+  -- | Branch is like @local@ in the Reader monad.
+  branchCursor    :: m a -> m a
+
+
+
+--------------------------------------------------------------------------------
+-- Derived operations
+
+
+-- | Move the /cursor/ horizontally.
+--
+hmoveby :: (CursorM m, Num u, u ~ DUnit (m ())) => u -> m ()
+hmoveby dx = moveby (hvec dx)
+
+-- | Move the /cursor/ vertically.
+--
+vmoveby :: (CursorM m, Num u, u ~ DUnit (m ())) => u -> m ()
+vmoveby dx = moveby (vvec dx)
diff --git a/src/Wumpus/Basic/Kernel/Drawing/Chain.hs b/src/Wumpus/Basic/Kernel/Drawing/Chain.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/Chain.hs
@@ -0,0 +1,463 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.Chain
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Chaining LocGraphics.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Drawing.Chain
+  (
+  
+    GenChain
+  , Chain
+  , DChain
+  , ChainScheme(..)
+
+  , runGenChain
+  , evalGenChain
+  , execGenChain
+  , stripGenChain
+
+  , runChain
+  , runChain_
+
+  , chain1
+  , chainSkip_
+  , chainMany
+  , chainReplicate
+  , chainCount
+
+  , iterationScheme
+  , sequenceScheme
+  , catTrailScheme
+  , countingScheme
+
+
+  , horizontalScheme
+  , verticalScheme
+
+
+  , rowwiseTableScheme
+  , columnwiseTableScheme
+  
+
+  , distribRowwiseTable
+  , duplicateRowwiseTable
+  , distribColumnwiseTable
+  , duplicateColumnwiseTable
+
+  , radialChainScheme
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Drawing.Basis
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Displacement
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Kernel.Objects.Trail
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+import Data.Monoid
+
+
+
+newtype GenChain st u a = GenChain
+          { getGenChain :: DrawingContext -> DPoint2 -> ChainSt st u 
+                        -> (a, DPoint2, ChainSt st u, CatPrim) }
+
+
+type instance DUnit (GenChain st u a)   = u
+type instance UState  (GenChain st u a) = st
+
+type Chain u a   = GenChain () u a
+
+type DChain a    = Chain Double a
+
+-- | scheme_start is a function from the origin to state.
+-- 
+-- For instance, we might want to cache the origin - this would
+-- not be possible if start was just a pure @cst@ value. 
+--
+data ChainScheme u = forall cst. ChainScheme 
+      { chain_init      :: Point2 u -> cst
+      , chain_step      :: Point2 u -> cst -> (Point2 u,cst)
+      }
+
+type instance DUnit (ChainScheme u) = u
+
+
+data ChainSt st u = forall cst. ChainSt 
+       { chain_count      :: Int
+       , chain_st         :: cst
+       , chain_next       :: Point2 u -> cst -> (Point2 u,cst) 
+       , chain_user_state :: st
+       }
+
+
+type instance DUnit (ChainSt st u) = u
+
+
+-- Functor 
+
+instance Functor (GenChain st u) where
+  fmap f ma = GenChain $ \ctx pt s -> 
+              let (a,p1,s1,w) = getGenChain ma ctx pt s in (f a, p1, s1, w)
+
+
+
+-- Applicative
+
+instance Applicative (GenChain st u) where
+  pure a    = GenChain $ \_   pt s -> (a, pt, s, mempty)
+  mf <*> ma = GenChain $ \ctx pt s -> 
+                let (f,p1,s1,w1) = getGenChain mf ctx pt s
+                    (a,p2,s2,w2) = getGenChain ma ctx p1 s1
+                in (f a, p2, s2, w1 `mappend` w2)
+
+
+
+-- Monad
+
+instance Monad (GenChain st u) where
+  return a  = GenChain $ \_   pt s -> (a, pt, s, mempty)
+  ma >>= k  = GenChain $ \ctx pt s -> 
+                let (a,p1,s1,w1) = getGenChain ma ctx pt s
+                    (b,p2,s2,w2) = (getGenChain . k) a ctx p1 s1
+                in (b, p2, s2, w1 `mappend` w2)
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (GenChain st u) where
+  askDC           = GenChain $ \ctx pt s -> (ctx, pt, s, mempty)
+  asksDC fn       = GenChain $ \ctx pt s -> (fn ctx, pt, s, mempty)
+  localize upd ma = GenChain $ \ctx pt s -> getGenChain ma (upd ctx) pt s
+
+
+
+-- UserStateM 
+
+instance UserStateM (GenChain st u) where
+  getState        = GenChain $ \_ pt s@(ChainSt _ _ _ ust) -> 
+                      (ust, pt, s, mempty)
+  setState ust    = GenChain $ \_ pt (ChainSt i a b _) -> 
+                      ((), pt, ChainSt i a b ust, mempty)
+  updateState upd = GenChain $ \_ pt (ChainSt i a b ust) -> 
+                      ((), pt, ChainSt i a b (upd ust), mempty)
+
+
+-- LocationM
+
+instance InterpretUnit u => LocationM (GenChain st u) where
+  location = GenChain $ \ctx pt s ->
+      let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty) 
+
+
+
+-- Monoid
+
+instance Monoid a => Monoid (GenChain st u a) where
+  mempty           = GenChain $ \_   pt s -> (mempty, pt, s, mempty)
+  ma `mappend` mb  = GenChain $ \ctx pt s -> 
+                       let (a,p1,s1,w1) = getGenChain ma ctx pt s
+                           (b,p2,s2,w2) = getGenChain mb ctx p1 s1
+                       in (a `mappend` b, p2, s2, w1 `mappend` w2)
+
+--------------------------------------------------------------------------------
+-- Run functions
+
+runGenChain :: InterpretUnit u 
+            => ChainScheme u -> st -> GenChain st u a -> LocImage u (a,st)
+runGenChain (ChainScheme start step) ust ma = promoteLoc $ \pt -> 
+    askDC >>= \ctx ->
+    let st_zero     = ChainSt { chain_count      = 0
+                              , chain_st         = start pt
+                              , chain_next       = step
+                              , chain_user_state = ust }
+        dpt         = normalizeF (dc_font_size ctx) pt
+        (a,_,s1,w1) = getGenChain ma ctx dpt st_zero
+    in replaceAns (a, chain_user_state s1) $ primGraphic w1
+
+
+
+-- | Forget the user state LocImage, just return the /answer/.
+--
+evalGenChain :: InterpretUnit u 
+             => ChainScheme u -> st -> GenChain st u a -> LocImage u a
+evalGenChain cscm st ma = fmap fst $ runGenChain cscm st ma
+
+
+-- | Forget the /answer/, just return the user state.
+--
+execGenChain :: InterpretUnit u 
+             => ChainScheme u -> st -> GenChain st u a -> LocImage u st 
+execGenChain cscm st ma = fmap snd $ runGenChain cscm st ma
+
+
+stripGenChain :: InterpretUnit u 
+              => ChainScheme u -> st -> GenChain st u a -> LocQuery u (a,st)
+stripGenChain cscm st ma = stripLocImage $ runGenChain cscm st ma
+
+
+
+runChain :: InterpretUnit u 
+         => ChainScheme u -> Chain u a -> LocImage u a
+runChain cscm ma = evalGenChain cscm () ma
+
+runChain_ :: InterpretUnit u 
+          => ChainScheme u -> Chain u a -> LocGraphic u
+runChain_ cscm ma = ignoreAns $ runChain cscm ma
+
+
+
+
+--------------------------------------------------------------------------------
+-- Operations
+
+
+-- | Demand a point on the Chain and draw the LocImage
+-- at it.
+--
+chain1 :: InterpretUnit u 
+       => LocImage u a -> GenChain st u a
+chain1 gf  = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) -> 
+    let upt       = dinterpF (dc_font_size ctx) pt
+        (a,w1)    = runImage ctx $ applyLoc gf upt
+        (pt1,st1) = sf upt s0
+        dpt1      = normalizeF (dc_font_size ctx) pt1
+        new_st    = ChainSt { chain_count      = i0 + 1
+                            , chain_st         = st1
+                            , chain_next       = sf
+                            , chain_user_state = ust }
+    in (a, dpt1, new_st, w1)
+
+
+-- | Demand the next position, but draw nothing.
+--
+chainSkip_ :: InterpretUnit u => GenChain st u ()
+chainSkip_ = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) -> 
+    let upt       = dinterpF (dc_font_size ctx) pt
+        (pt1,st1) = sf upt s0
+        dpt1      = normalizeF (dc_font_size ctx) pt1
+        new_st    = ChainSt { chain_count      = i0 + 1
+                            , chain_st         = st1
+                            , chain_next       = sf
+                            , chain_user_state = ust }
+    in ((), dpt1, new_st, mempty)
+
+
+
+-- | Chain a list of images, each demanding a succesive start 
+-- point.
+--
+chainMany :: InterpretUnit u 
+          => [LocImage u a] -> GenChain st u (UNil u)
+chainMany = ignoreAns . mapM_ chain1
+
+
+-- | Replicate a LocImage @n@ times along a Chain.
+--
+chainReplicate :: InterpretUnit u 
+               => Int -> LocImage u a -> GenChain st u (UNil u)
+chainReplicate n = chainMany . replicate n 
+
+
+-- | Return the count of chain steps.
+--
+chainCount :: GenChain st u Int
+chainCount = GenChain $ \_ dpt st@(ChainSt i _ _ _) -> (i, dpt, st, mempty)
+             
+
+
+
+
+--------------------------------------------------------------------------------
+-- Schemes
+
+
+-- | General scheme - iterate the next point with the supplied
+-- function.
+--
+iterationScheme :: (Point2 u -> Point2 u) -> ChainScheme u
+iterationScheme fn = ChainScheme { chain_init = const ()
+                                 , chain_step = \pt _ -> (fn pt, ())
+                                 }
+
+-- | General scheme - displace successively by the elements of the
+-- list of vectors. 
+-- 
+-- Note - the list is cycled to make the chain infinite.
+--
+sequenceScheme :: Num u => [Vec2 u] -> ChainScheme u
+sequenceScheme [] = error "sequenceScheme - empty list."
+sequenceScheme vs = ChainScheme { chain_init = const $ cycle vs
+                                , chain_step = step
+                                }
+  where
+    step _  []     = error "sequenceScheme - unreachable, cycled."
+    step pt (w:ws) = (displace w pt, ws) 
+
+
+-- | Derive a ChainScheme from a CatTrail.
+--
+-- Note - this iterates the control points of curves, it does not
+-- iterate points on the curve.
+--
+catTrailScheme :: Num u => CatTrail u -> ChainScheme u
+catTrailScheme = sequenceScheme . linear . destrCatTrail
+  where
+    linear (TLine v0 :xs)        = v0 : linear xs
+    linear (TCurve v0 v1 v2 :xs) = v0 : v1 : v2 : linear xs
+    linear []                    = []
+
+
+-- | Build an (infinite) ChainScheme for a prefix list of counted 
+-- schemes and a final scheme that runs out to infinity.
+--
+countingScheme :: [(Int, ChainScheme u)] -> ChainScheme u -> ChainScheme u
+countingScheme []     rest = rest
+countingScheme (x:xs) rest = chainPrefix  x (countingScheme xs rest)
+
+
+-- | Helper - complicated...
+--
+chainPrefix :: (Int, ChainScheme u) -> ChainScheme u -> ChainScheme u
+chainPrefix (ntimes, ChainScheme astart astep) rest@(ChainScheme bstart bstep)
+    | ntimes < 1 = rest
+    | otherwise  = ChainScheme { chain_init = start, chain_step = next }
+  where
+    start pt = (astart pt,ntimes, bstart pt)
+
+    next pt (ast,n,bst) 
+        | n > 0     = let (p2,ast1) = astep pt ast in (p2, (ast1,n-1,bst))
+        | n == 0    = let bst1      = bstart pt 
+                          (p2,bst2) = bstep pt bst1 
+                      in (p2, (ast,(-1),bst2))
+        | otherwise = let (p2,bst1) = bstep pt bst in (p2,(ast, (-1), bst1))
+ 
+
+
+
+horizontalScheme :: Num u => u -> ChainScheme u
+horizontalScheme dx = iterationScheme (displace (hvec dx))
+                
+   
+verticalScheme :: Num u => u -> ChainScheme u
+verticalScheme dy = iterationScheme (displace (vvec dy))
+               
+
+
+
+
+-- | Outer and inner steppers.
+--
+scStepper :: PointDisplace u -> Int -> PointDisplace u 
+          -> ChainScheme u
+scStepper outF n innF = 
+    ChainScheme { chain_init = start, chain_step = step }
+  where
+    start pt                      = (pt,1)
+    step  pt (ogin,i) | i <  n    = (innF pt, (ogin, i+1))
+                      | otherwise = let o1 = outF ogin 
+                                    in (o1, (o1,1)) 
+
+
+
+-- | Generate a tabular scheme going rowwise (left-to-right) and
+-- downwards.
+--
+-- TODO - should probably account for the initial position... 
+--
+rowwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u
+rowwiseTableScheme num_cols (col_width,row_height) = 
+    scStepper downF num_cols rightF
+  where
+    downF   = displace $ vvec $ negate row_height
+    rightF  = displace $ hvec col_width
+
+-- | Generate a tabular scheme going columwise (top-to-bottom) 
+-- and rightwards.
+--
+-- TODO - should probably account for the initial position... 
+--
+columnwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u
+columnwiseTableScheme num_rows (col_width,row_height) = 
+    scStepper rightF num_rows downF
+  where
+    downF   = displace $ vvec $ negate row_height
+    rightF  = displace $ hvec col_width
+
+
+
+
+distribRowwiseTable :: (Monoid a, InterpretUnit u)
+                    => Int -> (u,u) -> [LocImage u a] -> LocImage u a
+distribRowwiseTable num_cols dims gs = fmap mconcat $ 
+    runChain (rowwiseTableScheme num_cols dims) $ mapM chain1 gs
+  
+
+duplicateRowwiseTable :: (Monoid a, InterpretUnit u)
+                      => Int -> Int -> (u,u) -> LocImage u a -> LocImage u a
+duplicateRowwiseTable i num_cols dims gf =
+    distribRowwiseTable num_cols dims (replicate i gf) 
+
+
+
+distribColumnwiseTable :: (Monoid a, InterpretUnit u)
+                       => Int -> (u,u) -> [LocImage u a] -> LocImage u a
+distribColumnwiseTable num_rows dims gs = fmap mconcat $ 
+    runChain (columnwiseTableScheme num_rows dims) $ mapM chain1 gs
+  
+
+duplicateColumnwiseTable :: (Monoid a, InterpretUnit u)
+                         => Int -> Int -> (u,u) -> LocImage u a -> LocImage u a
+duplicateColumnwiseTable i num_rows dims gf = 
+    distribColumnwiseTable num_rows dims (replicate i gf) 
+
+
+
+-- | TODO - account for CW CCW or just rely on +ve -ve angles?...
+--
+radialChainScheme :: Floating u 
+                  => u -> Radian -> Radian -> ChainScheme u
+radialChainScheme radius angstart angi = 
+    ChainScheme { chain_init = start, chain_step = step }
+  where
+    start pt           = let ogin = displace (avec angstart (-radius)) pt
+                         in (ogin, angstart)
+    step  _ (ogin,ang) = let ang_next = ang + angi 
+                             pt       = displace (avec ang_next radius) ogin
+                         in (pt, (ogin, ang_next))
+
+    
+
+-- radialChain is convoluted because first point is not the 
+-- circle center but a point on the circumference. Also the next
+-- step iterates the (constant) origin rather than the previous 
+-- point.
+
+
+
+
+    
+    
+
diff --git a/src/Wumpus/Basic/Kernel/Drawing/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Drawing/CtxPicture.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/CtxPicture.hs
@@ -0,0 +1,408 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.CtxPicture
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- A Picture-with-implicit-context object. 
+-- 
+-- This is the corresponding type to Picture in the 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.Drawing.CtxPicture
+  (
+
+    CtxPicture
+  , runCtxPicture
+  , runCtxPictureU
+  , drawTracing
+  , udrawTracing
+
+  , mapCtxPicture
+
+  -- * Composition
+
+  , uniteCenter
+  
+  , centeredAt
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Drawing.TraceDrawing
+import Wumpus.Basic.Kernel.Objects.Anchors
+import Wumpus.Basic.Kernel.Objects.Concat
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AdditiveGroup                       -- package: vector-space
+import Data.AffineSpace
+
+import Data.Monoid
+
+
+
+-- | A /Contextual/ Picture.
+-- 
+-- > CtxPicture = DrawingContext -> Maybe Picture
+-- 
+-- This type corresponds to the 'Picture' type in Wumpus-Core, but
+-- it is embedded with a 'DrawingContext' (for font properties, 
+-- fill colour etc.). The DrawingContext is embedded so that font
+-- metrics - loaded in @IO@ can be passed into the pure world of
+-- 'TraceDrawing'.
+--
+-- Internally a /context picture/ is a function from 
+-- 'DrawingContext' to @(Maybe Picture)@. The @Maybe@ represents
+-- that it is possible to construct empty Pictures, even though
+-- @Wumpus-Core@ cannot render them. Just as the DrawingContext
+-- pushes font-metrics from the IO to the pure world, the Maybe
+-- lifts the problem of unrenderable Pictures into the API where
+-- client code must deal with it explicitly. 
+--
+-- (In practice, it is very unlikely a program will create empty 
+-- pictures and @runCtxPictureU@ can be used without worry).
+-- 
+-- 
+-- Note - pictures are fixed to the unit @Double@ (representing 
+-- PostScript points). Pictures are intentionally unsophisticated,
+-- any fine grained control of units should be delegated to the 
+-- elements that build the picture (Graphics, LocGraphics, etc.). 
+--
+newtype CtxPicture = CtxPicture { 
+          getCtxPicture :: DrawingContext -> Maybe Picture }
+
+type instance DUnit CtxPicture = Double
+
+
+
+
+-- | '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 -> Maybe Picture
+runCtxPicture ctx drw = getCtxPicture drw ctx
+
+
+-- | '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 -> Picture
+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 :: TraceDrawing u a -> CtxPicture
+drawTracing ma = 
+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx ma
+
+-- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @
+--
+-- Variant of 'drawTracing' with a phantom first argument - the 
+-- phantom identifies the unit type of the 'TraceDrawing'. It is 
+-- not scurtinized at the value level.
+--
+--
+udrawTracing :: u -> TraceDrawing u a -> CtxPicture
+udrawTracing _ ma = 
+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx ma
+
+
+-- Note need Gen versions with user state...
+
+
+-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @
+--
+-- Apply a picture transformation function to the 'Picture'
+-- warpped in a 'CtxPicture'.
+--
+mapCtxPicture :: (Picture -> Picture) -> CtxPicture -> CtxPicture
+mapCtxPicture pf pic1 = CtxPicture $ \ctx -> fmap pf $ getCtxPicture pic1 ctx
+
+
+--------------------------------------------------------------------------------
+-- Affine instances
+
+
+instance Rotate CtxPicture where 
+  rotate ang            = mapCtxPicture (rotate ang)
+
+instance RotateAbout CtxPicture where
+  rotateAbout ang pt    = mapCtxPicture (rotateAbout ang pt)
+
+instance Scale CtxPicture where
+  scale sx sy           = mapCtxPicture (scale sx sy)
+
+instance Translate CtxPicture where
+  translate dx dy       = mapCtxPicture (translate dx dy)
+
+
+
+--------------------------------------------------------------------------------
+-- Monoid
+
+-- | Avoid initial mempty for mconcat.
+--
+instance Monoid CtxPicture where
+  mempty  = CtxPicture $ \_ -> Nothing
+  mappend = moveSnd $ \_ _ -> V2 0 0
+
+  mconcat []      = mempty
+  mconcat (a:as)  = step a as
+    where
+      step ac []     = ac
+      step ac (x:xs) = step (ac `mappend` x) xs
+
+
+--------------------------------------------------------------------------------
+-- Extract /planes/.
+
+
+leftEdge        :: BoundingBox Double -> Double
+leftEdge        = point_x . ll_corner
+
+rightEdge       :: BoundingBox Double -> Double
+rightEdge       = point_x . ur_corner
+
+bottomEdge      :: BoundingBox Double -> Double
+bottomEdge      = point_y . ll_corner
+
+
+topEdge         :: BoundingBox Double -> Double
+topEdge         = point_y . ur_corner
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- 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).
+--
+
+
+
+combineP2 :: (Picture -> Picture -> Picture) 
+          -> CtxPicture -> CtxPicture -> CtxPicture
+combineP2 op mf mg = 
+    CtxPicture $ \ctx -> fn (getCtxPicture mf ctx) (getCtxPicture mg ctx)
+  where
+    fn (Just a) (Just b) = Just $ a `op` b
+    fn a        Nothing  = a
+    fn Nothing  b        = b
+
+
+-- Note - the megaCombR operator is in some way an
+-- /anti-combinator/. It seems easier to think about composing 
+-- drawings if we do work on the result Pictures directly rather 
+-- than build combinators to manipulate CtxPictures.
+--
+-- The idea of combining pre- and post- operating combinators
+-- makes me worry about circular programs even though I know 
+-- lazy evaluation allows me to write them (in some cicumstances).
+--
+
+
+moveSnd :: (DBoundingBox -> DBoundingBox -> DVec2) 
+          -> CtxPicture -> CtxPicture
+          -> CtxPicture
+moveSnd mkV = combineP2 fn
+  where
+    fn pl pr = let v1  = mkV (boundary pl) (boundary pr)
+               in pl `picOver` (picMoveBy pr v1)
+
+
+instance ZConcat CtxPicture where
+  superior = mappend
+  anterior = flip mappend
+
+--------------------------------------------------------------------------------
+-- Composition
+
+
+infixr 6 `uniteCenter`
+
+
+
+
+-- | Draw @a@, move @b@ so its center is at the same center as 
+-- @a@, @b@ is drawn over underneath in the zorder.
+--
+-- > a `cxpUniteCenter` b 
+--
+
+uniteCenter :: CtxPicture -> CtxPicture -> CtxPicture
+uniteCenter = moveSnd $ \a b -> center a .-. center b
+--
+-- Are combinator names less ambiguous if they name direction
+-- rather than position?
+--
+
+instance Concat CtxPicture where
+  hconcat = cxpRight
+  vconcat = cxpBelow
+
+
+-- | > a `cxpRight` b
+-- 
+-- Horizontal composition - position picture @b@ to the right of 
+-- picture @a@.
+-- 
+cxpRight :: CtxPicture -> CtxPicture -> CtxPicture
+cxpRight = moveSnd $ \a b -> hvec $ rightEdge a - leftEdge b
+
+
+-- | > a `cxpBelow` b
+--
+-- Vertical composition - position picture @b@ /down/ from picture
+-- @a@.
+--
+cxpBelow :: CtxPicture -> CtxPicture -> CtxPicture
+cxpBelow = moveSnd $ \a b -> vvec $ bottomEdge a - topEdge b
+
+
+-- | Center the picture at the supplied point.
+--
+centeredAt :: CtxPicture -> DPoint2 -> CtxPicture
+centeredAt pic (P2 x y) = mapCtxPicture fn pic
+  where
+    fn p = let bb = boundary p
+               dx = x - (boundaryWidth  bb * 0.5)
+               dy = y - (boundaryHeight bb * 0.5)
+           in p `picMoveBy` vec dx dy
+
+
+
+
+--------------------------------------------------------------------------------
+
+instance CatSpace CtxPicture where
+  hspace = cxpRightSep
+  vspace = cxpDownSep
+
+
+-- | > cxpRightSep n a b
+--
+-- Horizontal composition - move @b@, placing it to the right 
+-- of @a@ with a horizontal gap of @n@ separating the pictures.
+--
+cxpRightSep :: Double -> CtxPicture -> CtxPicture -> CtxPicture
+cxpRightSep n = moveSnd $ \a b -> hvec $ n + (rightEdge a - leftEdge b)
+
+
+
+-- | > cxpDownSep n a b
+--
+-- Vertical composition - move @b@, placing it below @a@ with a
+-- vertical gap of @n@ separating the pictures.
+--
+cxpDownSep :: Double  -> CtxPicture -> CtxPicture -> CtxPicture
+cxpDownSep n = moveSnd $ \a b -> vvec $ bottomEdge a - (topEdge b + n)
+
+
+--------------------------------------------------------------------------------
+-- Aligning pictures
+
+
+instance Align CtxPicture where
+  halign = cxpAlignH
+  valign = cxpAlignV
+
+-- | > 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@.
+-- 
+cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture
+cxpAlignH HALIGN_TOP     = moveSnd $ \a b -> northeast a .-. northwest b
+cxpAlignH HALIGN_CENTER  = moveSnd $ \a b -> east a .-. west b
+cxpAlignH HALIGN_BASE    = moveSnd $ \a b -> southeast a .-. southwest b
+
+
+-- | > cxpAlignV align a b
+-- 
+-- Vertical composition - move @b@, placing it below @a@ 
+-- and align it with the left, center or right of @a@.
+-- 
+cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture
+cxpAlignV VALIGN_LEFT    = moveSnd $ \a b -> southwest a .-. northwest b
+cxpAlignV VALIGN_CENTER  = moveSnd $ \a b -> south a .-. north b
+cxpAlignV VALIGN_RIGHT   = moveSnd $ \a b -> southeast a .-. northeast b
+
+
+
+instance AlignSpace CtxPicture where
+  halignSpace = cxpAlignSpaceH
+  valignSpace = cxpAlignSpaceV
+
+-- | > cxpAlignSpaceH align sep a b
+-- 
+-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ 
+-- separated by @sep@ units, align @b@ according to @align@.
+-- 
+cxpAlignSpaceH :: HAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture
+cxpAlignSpaceH align dx = go align
+  where
+    mv f g           = moveSnd $ \a b -> hvec dx ^+^ (f a .-. g b)
+    go HALIGN_TOP    = mv northeast northwest
+    go HALIGN_CENTER = mv east west 
+    go HALIGN_BASE   = mv southeast southwest
+
+
+-- | > cxpAlignSpaceV align sep a b
+-- 
+-- Spacing version of alignV - move @b@ below @a@ 
+-- separated by @sep@ units, align @b@ according to @align@.
+-- 
+cxpAlignSpaceV :: VAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture
+cxpAlignSpaceV align dy = go align
+  where
+    mv f g           = moveSnd $ \a b -> vvec (-dy) ^+^ (f a .-. g b)
+    go VALIGN_LEFT   = mv southwest northwest 
+    go VALIGN_CENTER = mv south north  
+    go VALIGN_RIGHT  = mv southeast northeast 
+
diff --git a/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs b/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs
@@ -0,0 +1,237 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocDrawing
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Drawing monad with immutable start point.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Drawing.LocDrawing
+  (
+
+  -- * GenLocDrawing monad
+    GenLocDrawing
+  , LocDrawing
+
+  , LocDrawM(..)
+
+  , runGenLocDrawing
+  , evalGenLocDrawing
+  , execGenLocDrawing
+  , stripGenLocDrawing
+
+  , runLocDrawing
+  , runLocDrawing_ 
+
+  )
+
+  where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Drawing.Basis
+import Wumpus.Basic.Kernel.Objects.Anchors
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Connector
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+import Data.Monoid
+
+
+
+
+-- | 'GenLocDrawing' is a reader-writer-state monad, unlike 
+-- 'GenLocTrace' there is no updateable current point, instead 
+-- the start point is supplied when the drawing is run and it 
+-- is translated by the components of the start point.
+--
+-- The writer accumulates a graphical trace.
+--
+-- Essentially, 'GenLocDrawing' is an 'Image' object extended 
+-- with user state.
+--
+newtype GenLocDrawing st u a = GenLocDrawing { 
+    getGenLocDrawing :: DrawingContext -> st -> (a, st, CatPrim)}
+
+type instance DUnit  (GenLocDrawing st u a) = u
+type instance UState (GenLocDrawing st u a) = st
+
+type LocDrawing u a = GenLocDrawing () u a
+
+
+-- Functor
+
+instance Functor (GenLocDrawing st u) where
+  fmap f ma = GenLocDrawing $ \ctx s -> 
+    let (a,s1,o) = getGenLocDrawing ma ctx s in (f a, s1, o)
+
+
+-- Applicative
+
+instance Applicative (GenLocDrawing st u) where
+  pure a    = GenLocDrawing $ \_   s -> (a, s, mempty)
+  mf <*> ma = GenLocDrawing $ \ctx s -> 
+                let (f,s1,o1) = getGenLocDrawing mf ctx s
+                    (a,s2,o2) = getGenLocDrawing ma ctx s1
+                in (f a, s2, o1 `mappend` o2)
+
+
+
+-- Monad
+
+instance Monad (GenLocDrawing st u) where
+  return a  = GenLocDrawing $ \_   s -> (a, s, mempty)
+  ma >>= k  = GenLocDrawing $ \ctx s -> 
+                let (a,s1,o1) = getGenLocDrawing ma ctx s
+                    (b,s2,o2) = (getGenLocDrawing . k) a ctx s1
+                in (b, s2, o1 `mappend` o2)
+
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (GenLocDrawing st u) where
+  askDC           = GenLocDrawing $ \ctx s -> (ctx, s, mempty)
+  asksDC fn       = GenLocDrawing $ \ctx s -> (fn ctx, s, mempty)
+  localize upd ma = GenLocDrawing $ \ctx s -> 
+                      getGenLocDrawing ma (upd ctx) s
+
+
+
+-- UserStateM 
+
+instance UserStateM (GenLocDrawing st u) where
+  getState        = GenLocDrawing $ \_ s -> (s, s, mempty)
+  setState s      = GenLocDrawing $ \_ _ -> ((), s, mempty)
+  updateState upd = GenLocDrawing $ \_ s -> ((), upd s, mempty)
+
+
+-- Monoid
+
+instance Monoid a => Monoid (GenLocDrawing st u a) where
+  mempty           = GenLocDrawing $ \_   s -> (mempty, s, mempty)
+  ma `mappend` mb  = GenLocDrawing $ \ctx s -> 
+                       let (a,s1,w1) = getGenLocDrawing ma ctx s
+                           (b,s2,w2) = getGenLocDrawing mb ctx s1
+                       in (a `mappend` b, s2, w1 `mappend` w2)
+
+
+
+--------------------------------------------------------------------------------
+
+class Monad m => LocDrawM (m :: * -> *) where
+  inserti   :: u ~ DUnit (m ()) => Image u a -> m a
+  inserti_  :: u ~ DUnit (m ()) => Image u a -> m ()
+  insertli  :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m a
+  insertli_ :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m ()
+  insertci  :: u ~ DUnit (m ()) => 
+               Anchor u -> Anchor u -> ConnectorImage u a -> m a
+  insertci_ :: u ~ DUnit (m ()) => 
+               Anchor u -> Anchor u -> ConnectorImage u a -> m ()
+
+  inserti_  gf       = inserti gf >> return ()
+  insertli_ pt gf    = insertli pt gf >> return ()
+  insertci_ p1 p2 gf = insertci p1 p2 gf >> return ()
+
+
+instance InterpretUnit u => LocDrawM (GenLocDrawing st u) where
+  inserti  = insertiImpl
+  insertli = insertliImpl
+  insertci = insertciImpl
+
+ 
+--------------------------------------------------------------------------------
+-- Run functions
+
+
+runGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+                 => st -> GenLocDrawing st u a -> LocImage u (a,st)
+runGenLocDrawing st ma = promoteLoc $ \(P2 x y) -> 
+    askDC >>= \ctx ->
+    let (a,s1,w1) = getGenLocDrawing ma ctx st
+        ans       = translate x y a 
+        dv1       = normalizeF (dc_font_size ctx) (V2 x y)
+    in replaceAns (ans,s1) $ primGraphic $ cpmove dv1 w1
+
+
+
+
+-- | Forget the user state LocImage, just return the /answer/.
+--
+evalGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+                  => st -> GenLocDrawing st u a -> LocImage u a
+evalGenLocDrawing st ma = fmap fst $ runGenLocDrawing st ma
+
+
+-- | Forget the /answer/, just return the user state.
+--
+execGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+                  => st -> GenLocDrawing st u a -> LocImage u st 
+execGenLocDrawing st ma = fmap snd $ runGenLocDrawing st ma
+
+
+stripGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+                   => st -> GenLocDrawing st u a -> LocQuery u (a,st)
+stripGenLocDrawing st ma = stripLocImage $ runGenLocDrawing st ma
+
+
+-- | Simple version of 'runGenLocDrawing' - run a 'LocDrawing' without
+-- user state.
+--
+runLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+              => LocDrawing u a -> LocImage u a
+runLocDrawing ma = evalGenLocDrawing () ma
+
+
+runLocDrawing_ :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+               => LocDrawing u a -> LocGraphic u 
+runLocDrawing_ ma = ignoreAns $ runLocDrawing ma
+
+
+
+--------------------------------------------------------------------------------
+
+insertiImpl :: InterpretUnit u 
+            => Image u a -> GenLocDrawing st u a
+insertiImpl gf = GenLocDrawing $ \ctx s -> 
+    let (a,w1)   = runImage ctx gf in (a,s,w1) 
+
+
+
+
+
+insertliImpl :: InterpretUnit u
+             => Anchor u -> LocImage u a -> GenLocDrawing st u a
+insertliImpl p1 gf = GenLocDrawing $ \ctx s -> 
+    let (a,w1) = runLocImage ctx p1 gf in (a,s,w1) 
+
+
+
+-- This is not right - if I\'ve taken an anchor from an object
+-- within the relative coord system, the anchor points are already
+-- translated respective to the origin. This implementation of 
+-- @insertci@ adds the translation a second time.
+
+
+insertciImpl :: InterpretUnit u 
+             => Anchor u -> Anchor u -> ConnectorImage u a 
+             -> GenLocDrawing st u a
+insertciImpl p1 p2 gf = GenLocDrawing $ \ctx s -> 
+    let (a,w1) = runConnectorImage ctx p1 p2 gf in (a,s,w1) 
diff --git a/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs b/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs
@@ -0,0 +1,213 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocTrace
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Writer monad with imperative /turtle/ style movement to build 
+-- LocGraphics.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Drawing.LocTrace
+  (
+
+  -- * GenLocTrace monad
+    GenLocTrace
+  , LocTrace
+
+  , runGenLocTrace
+  , evalGenLocTrace
+  , execGenLocTrace
+  , stripGenLocTrace
+
+  , runLocTrace
+  , runLocTrace_ 
+
+  )
+
+  where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Drawing.Basis
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Control.Applicative
+import Data.Monoid
+
+
+
+
+-- | GenLocTrace is a reader-writer-state monad.
+--
+-- The writer accumulates a graphical trace and the state is 
+-- the current point.
+--
+newtype GenLocTrace st u a = GenLocTrace { 
+    getGenLocTrace :: DrawingContext -> DPoint2 -> st 
+                   -> (a, DPoint2, st, CatPrim)}
+
+type instance DUnit  (GenLocTrace st u a) = u
+type instance UState (GenLocTrace st u a) = st
+
+type LocTrace u a = GenLocTrace () u a
+
+
+-- Functor
+
+instance Functor (GenLocTrace st u) where
+  fmap f ma = GenLocTrace $ \ctx pt s -> 
+    let (a,p1,s1,o) = getGenLocTrace ma ctx pt s in (f a, p1, s1, o)
+
+
+-- Applicative
+
+instance Applicative (GenLocTrace st u) where
+  pure a    = GenLocTrace $ \_   pt s -> (a, pt, s, mempty)
+  mf <*> ma = GenLocTrace $ \ctx pt s -> 
+                let (f,p1,s1,o1) = getGenLocTrace mf ctx pt s
+                    (a,p2,s2,o2) = getGenLocTrace ma ctx p1 s1
+                in (f a, p2, s2, o1 `mappend` o2)
+
+
+
+-- Monad
+
+instance Monad (GenLocTrace st u) where
+  return a  = GenLocTrace $ \_   pt s -> (a, pt, s, mempty)
+  ma >>= k  = GenLocTrace $ \ctx pt s -> 
+                let (a,p1,s1,o1) = getGenLocTrace ma ctx pt s
+                    (b,p2,s2,o2) = (getGenLocTrace . k) a ctx p1 s1
+                in (b, p2, s2, o1 `mappend` o2)
+
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (GenLocTrace st u) where
+  askDC           = GenLocTrace $ \ctx pt s -> (ctx, pt, s, mempty)
+  asksDC fn       = GenLocTrace $ \ctx pt s -> (fn ctx, pt, s, mempty)
+  localize upd ma = GenLocTrace $ \ctx pt s -> getGenLocTrace ma (upd ctx) pt s
+
+
+
+-- UserStateM 
+
+instance UserStateM (GenLocTrace st u) where
+  getState        = GenLocTrace $ \_ pt s -> (s, pt, s, mempty)
+  setState s      = GenLocTrace $ \_ pt _ -> ((), pt, s, mempty)
+  updateState upd = GenLocTrace $ \_ pt s -> ((), pt, upd s, mempty)
+
+
+-- Monoid
+
+instance Monoid a => Monoid (GenLocTrace st u a) where
+  mempty           = GenLocTrace $ \_   pt s -> (mempty, pt, s, mempty)
+  ma `mappend` mb  = GenLocTrace $ \ctx pt s -> 
+                       let (a,p1,s1,w1) = getGenLocTrace ma ctx pt s
+                           (b,p2,s2,w2) = getGenLocTrace mb ctx p1 s1
+                       in (a `mappend` b, p2, s2, w1 `mappend` w2)
+
+
+-- LocationM
+
+instance InterpretUnit u => LocationM (GenLocTrace st u) where
+  location = GenLocTrace $ \ctx pt s ->
+      let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty) 
+
+
+-- CursorM 
+
+instance InterpretUnit u => InsertlM (GenLocTrace st u) where
+  insertl   = insertlImpl
+
+instance InterpretUnit u => CursorM (GenLocTrace st u) where
+  moveby    = movebyImpl
+
+
+insertlImpl :: InterpretUnit u => LocImage u a -> GenLocTrace st u a
+insertlImpl gf = GenLocTrace $ \ctx pt s ->
+    let upt    = dinterpF (dc_font_size ctx) pt 
+        (a,w1) = runLocImage ctx upt gf
+    in (a,pt,s,w1) 
+
+
+movebyImpl :: InterpretUnit u => Vec2 u -> GenLocTrace st u ()
+movebyImpl v1 = GenLocTrace $ \ctx pt s ->
+    let dv1 = normalizeF (dc_font_size ctx) v1 
+    in ((), pt .+^ dv1, s, mempty) 
+
+
+
+-- BranchCursorM 
+
+instance InterpretUnit u => BranchCursorM (GenLocTrace st u) where
+  branchCursor ma = GenLocTrace $ \ctx pt s ->
+    let (a,_,s1,w1) = getGenLocTrace ma ctx pt s
+    in (a, pt, s1, w1)  -- re-instate pt          
+
+
+
+--------------------------------------------------------------------------------
+-- Run functions
+
+
+runGenLocTrace :: InterpretUnit u 
+               => st -> GenLocTrace st u a -> LocImage u (a,st)
+runGenLocTrace st ma = promoteLoc $ \pt -> 
+    askDC >>= \ctx ->
+    let dpt         = normalizeF (dc_font_size ctx) pt
+        (a,_,s1,w1) = getGenLocTrace ma ctx dpt st
+    in replaceAns (a,s1) $ primGraphic w1
+
+
+
+
+-- | Forget the user state LocImage, just return the /answer/.
+--
+evalGenLocTrace :: InterpretUnit u 
+                => st -> GenLocTrace st u a -> LocImage u a
+evalGenLocTrace st ma = fmap fst $ runGenLocTrace st ma
+
+
+-- | Forget the /answer/, just return the user state.
+--
+execGenLocTrace :: InterpretUnit u 
+                => st -> GenLocTrace st u a -> LocImage u st 
+execGenLocTrace st ma = fmap snd $ runGenLocTrace st ma
+
+
+stripGenLocTrace :: InterpretUnit u 
+                 => st -> GenLocTrace st u a -> LocQuery u (a,st)
+stripGenLocTrace st ma = stripLocImage $ runGenLocTrace st ma
+
+
+-- | Simple version of 'runGenLocTrace' - run a 'LocTrace' without
+-- user state.
+--
+runLocTrace :: InterpretUnit u 
+            => LocTrace u a -> LocImage u a
+runLocTrace ma = evalGenLocTrace () ma
+
+
+runLocTrace_ :: InterpretUnit u 
+             => LocTrace u a -> LocGraphic u 
+runLocTrace_ ma = ignoreAns $ runLocTrace ma
+
diff --git a/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs b/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs
@@ -0,0 +1,668 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.PosObject
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- 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.Drawing.PosObject
+  (
+
+  -- * Positionable image
+    GenPosObject
+  , GenPosGraphic
+
+  , PosObject
+  , DPosObject
+
+  , PosGraphic
+  , DPosGraphic
+
+  -- * Operations
+  , runGenPosObject
+  , evalGenPosObject
+  , execGenPosObject
+  
+  , runPosObject
+
+  , runPosObjectBBox
+
+  , makePosObject
+  , emptyPosObject
+
+  , elaboratePosObject
+  , decoratePosObject
+
+  , extendPosObject
+  , mapOrientation
+
+  , illustratePosObject
+
+  -- * Primitive text PosObjects
+  , posChar
+  , posEscChar 
+  , posCharUpright
+  , posEscCharUpright
+  
+  , posCharPrim
+
+  , posText
+  , posEscText 
+  , posTextUpright
+  , posEscTextUpright
+
+  , posTextPrim
+
+  , multilinePosText
+  , multilinePosEscText
+
+  , rposText
+  , rposEscText
+  , rposChar
+  , rposEscChar
+  
+
+  , posHKernText
+
+  , monospaceText
+  , monospaceEscText
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Base.UpdateDC
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Drawing.Basis
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Concat
+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Kernel.Objects.LocThetaImage
+import Wumpus.Basic.Kernel.Objects.Orientation
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Colour ( red, blue )
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Control.Applicative
+import Data.Monoid
+
+--
+-- Note - PosObject could be in the @Object@ rather than @Drawing@
+-- namespace.
+--
+
+type DOrt = Orientation Double
+
+-- | A positionable \"Object\".
+--
+newtype GenPosObject st u a = GenPosObject { 
+    getGenPosObject :: DrawingContext -> DPoint2 -> st -> (a, st, DOrt, CatPrim) }
+
+type instance DUnit   (GenPosObject st u a) = u
+type instance UState  (GenPosObject st u a) = st
+
+type GenPosGraphic st u = GenPosObject st u (UNil u)
+
+
+-- | Type synonym for @GenPosObject () u a@, a PosObject without
+-- user state.
+--
+type PosObject u a = GenPosObject () u a
+    
+-- | Version of PosObject specialized to Double for the unit type.
+--
+type DPosObject a = PosObject Double a
+
+
+-- | Version of PosObject with answer specialized to UNil.
+--
+type PosGraphic u = PosObject u (UNil u)
+
+-- | Version of PosGraphic specialized to Double for the unit type.
+--
+type DPosGraphic = PosGraphic Double
+
+
+
+
+instance Functor (GenPosObject st u) where
+  fmap f mf = GenPosObject $ \ctx pt s -> 
+              let (a,s1,o1,w1) = getGenPosObject mf ctx pt s in (f a,s1,o1,w1)
+
+
+instance Applicative (GenPosObject st u) where
+  pure a    = GenPosObject $ \_   _  s -> (a,s,mempty,mempty)
+  mf <*> ma = GenPosObject $ \ctx pt s -> 
+              let (f,s1,o1,w1) = getGenPosObject mf ctx pt s
+                  (a,s2,o2,w2) = getGenPosObject ma ctx pt s1
+              in (f a, s2, o1 `mappend` o2, w1 `mappend` w2)
+
+
+
+instance Monad (GenPosObject st u) where
+  return a  = GenPosObject $ \_   _  s  -> (a, s, mempty, mempty)
+  mf >>= k  = GenPosObject $ \ctx pt s -> 
+              let (a,s1,o1,w1) = getGenPosObject mf ctx pt s
+                  (b,s2,o2,w2) = getGenPosObject (k a) ctx pt s1
+              in (b, s2, o1 `mappend` o2, w1 `mappend` w2)
+
+
+instance (Monoid a, InterpretUnit u) => Monoid (GenPosObject st u a) where
+  mempty = GenPosObject $ \_ _ s -> (mempty, s, mempty, mempty)
+  ma `mappend` mb = GenPosObject $ \ctx pt s -> 
+                    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
+                        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1
+                    in (a `mappend` b, s2, o1 `mappend` o2, w1 `mappend` w2)
+
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (GenPosObject st u) where
+  askDC           = GenPosObject $ \ctx _  s -> (ctx, s, mempty, mempty)
+  asksDC fn       = GenPosObject $ \ctx _  s -> (fn ctx, s, mempty, mempty)
+  localize upd ma = GenPosObject $ \ctx pt s -> 
+                      getGenPosObject ma (upd ctx) pt s
+
+instance UserStateM (GenPosObject st u) where
+  getState        = GenPosObject $ \_ _ s -> (s, s, mempty, mempty)
+  setState s      = GenPosObject $ \_ _ _ -> ((), s, mempty, mempty)
+  updateState upd = GenPosObject $ \_ _ s -> ((), upd s, mempty, mempty)
+
+
+
+-- | Running an PosObject produces a LocImage.
+--
+runGenPosObject :: InterpretUnit u 
+                => RectAddress -> st -> GenPosObject st u a -> LocImage u (a,st)
+runGenPosObject addr st ma = promoteLoc $ \ot -> 
+    askDC >>= \ctx -> 
+    let dot          = normalizeF (dc_font_size ctx) ot
+        (a,s1,o1,ca) = getGenPosObject ma ctx dot st
+        v1           = vtoOrigin addr o1
+    in replaceAns (a,s1) $ primGraphic $ cpmove v1 ca
+
+
+evalGenPosObject :: InterpretUnit u 
+                 => RectAddress -> st -> GenPosObject st u a -> LocImage u a
+evalGenPosObject addr st ma = fmap fst $ runGenPosObject addr st ma
+
+execGenPosObject :: InterpretUnit u 
+                 => RectAddress -> st -> GenPosObject st u a -> LocImage u st
+execGenPosObject addr st ma = fmap snd $ runGenPosObject addr st ma
+
+runPosObject :: InterpretUnit u 
+             => RectAddress -> PosObject u a -> LocImage u a
+runPosObject addr ma = fmap fst $ runGenPosObject addr () ma
+
+
+
+
+-- | Run a PosObject producing a LocImage (BoundingBox u).
+--
+runPosObjectBBox :: InterpretUnit u 
+                    => RectAddress -> PosObject u a -> LocImage u (BoundingBox u)
+runPosObjectBBox addr ma = promoteLoc $ \pt -> 
+    askDC >>= \ctx -> 
+    let sz          = dc_font_size ctx 
+        dpt         = normalizeF sz pt
+        (_,_,o1,w1) = getGenPosObject ma ctx dpt ()
+        v1          = vtoOrigin addr o1
+        bb          = dinterpF sz $ orientationBounds o1 (dpt .+^ v1)
+    in replaceAns bb $ primGraphic $ cpmove v1 w1
+
+
+
+
+--------------------------------------------------------------------------------
+
+
+-- | 'makePosObject' : @ object_pos * loc_image -> PosObject @ 
+--
+-- Create a 'PosObject' from an 'Orientation' describing how it
+-- is orientated within a border rectangle and a 'LocImage' that 
+-- draws it.
+--
+-- This is the /primary/ constructor for PosObjects. Because the
+-- PosObject type is considered as a specialized object it does
+-- not have the range of functions of LocImage or LocThetaImage.
+-- 
+makePosObject :: InterpretUnit u
+              => Query u (Orientation u) -> LocImage u a -> GenPosObject st u a
+makePosObject ma gf = GenPosObject $ \ctx pt s -> 
+    let ort1  = runQuery ctx ma
+        dort1 = normalizeF (dc_font_size ctx) ort1
+        upt   = dinterpF (dc_font_size ctx) pt
+        (a,w) = runLocImage ctx upt gf
+    in (a,s,dort1,w)
+
+
+-- | 'emptyPosObject' : @ PosObject @
+--
+-- Build an empty 'PosGraphicObject'.
+--
+emptyPosObject :: (Monoid a, InterpretUnit u) => GenPosObject st u a
+emptyPosObject = mempty
+
+    
+
+--
+-- decorate  - oblivious to /answer/.
+-- elaborate - derives annotation from the /answer/ and makes a 
+--             cumulative graphic.
+--
+
+
+elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)
+                   => ZOrder -> RectAddress -> LocGraphic u 
+                   -> GenPosObject st u a
+                   -> GenPosObject st u a
+elaboratePosObject zo raddr gf ma = decoratePosObject zo fn ma
+  where
+    fn ortt = moveStart (vtoRectAddress ortt raddr) gf
+
+
+
+decoratePosObject :: InterpretUnit u 
+                  => ZOrder -> (Orientation u -> LocGraphic u) 
+                  -> GenPosObject st u a
+                  -> GenPosObject st u a
+decoratePosObject zo fn ma = GenPosObject $ \ctx pt s -> 
+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
+        uortt        = dinterpF (dc_font_size ctx) o1
+        upt          = dinterpF (dc_font_size ctx) pt
+        (_,w2)       = runLocImage ctx upt $ fn uortt
+        wout         = case zo of
+                         ZABOVE -> w1 `mappend` w2
+                         ZBELOW -> w2 `mappend` w1
+    in (a,s1,o1,wout)
+
+
+
+
+-- | Extend the orientation.
+--
+extendPosObject :: InterpretUnit u 
+                => u -> u -> u -> u -> GenPosObject st u a 
+                -> GenPosObject st u a
+extendPosObject x0 x1 y0 y1 ma = GenPosObject $ \ctx pt s ->
+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
+        sz           = dc_font_size ctx        
+        ux0          = normalize sz x0
+        ux1          = normalize sz x1
+        uy0          = normalize sz y0
+        uy1          = normalize sz y1
+        o2           = extendOrientation ux0 ux1 uy0 uy1 o1
+    in (a,s1,o2,w1)
+
+
+-- | Note - this is a bad API, it would be better to have padders
+-- and fillers and not expose the orientation directly.
+-- 
+mapOrientation :: InterpretUnit u
+               => (Orientation u -> Orientation u) 
+               -> GenPosObject st u a -> GenPosObject st u a
+mapOrientation fn mf = GenPosObject $ \ctx pt s -> 
+    let (a,s1,o1,w1) = getGenPosObject mf ctx pt s
+        uort      = fn $ dinterpF (dc_font_size ctx) o1
+        o2        = normalizeF (dc_font_size ctx) uort
+    in (a,s1,o2,w1)
+
+
+--------------------------------------------------------------------------------
+
+
+-- | Illustrate a 'PosObject' by super-imposing its 'Orientation'.
+--
+-- This turns the 'PosObject' into a 'LocImage' drawn at the locus
+-- of the PosObject.
+--
+illustratePosObject :: InterpretUnit u 
+                    => PosObject u a -> LocGraphic u
+illustratePosObject mf  = promoteLoc $ \pt ->   
+    askDC >>= \ctx ->
+    let dpt         = normalizeF (dc_font_size ctx) pt 
+        (_,_,o1,w1) = getGenPosObject mf ctx dpt ()
+        uort        = dinterpF (dc_font_size ctx) o1
+    in decorateBelow (primGraphic w1) (illustrateOrientation uort `at` pt)
+
+
+illustrateOrientation :: InterpretUnit u 
+                      => Orientation u -> LocGraphic u
+illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt -> 
+    dinterpCtx 3 >>= \radius -> 
+    let upd = localize (fill_colour blue . dotted_line)
+        bl  = pt .-^ V2 xmin ymin
+        dot = localize (fill_colour red) $ dcDisk DRAW_FILL radius `at` pt
+        hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin
+        vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin
+        bdr = upd $ dcRectangle DRAW_STROKE (xmin+xmaj) (ymin+ymaj) `at` bl
+    in mconcat [ bdr, hln, vln, dot ]
+
+
+
+--------------------------------------------------------------------------------
+-- Char PosObjects
+
+
+-- Note - because the TextHeight constructors are so long winded,
+-- using them directly makes for a bad API. Instead we have two 
+-- versions for each function.
+
+-- | Note - no margins are added to the containing rectangle.
+-- 
+-- To get a Char with margins, use 'posText' instead:
+--
+-- > posText ['1']
+-- 
+posChar             :: InterpretUnit u 
+                    => Char -> GenPosGraphic st u
+posChar             = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral
+
+posEscChar          :: InterpretUnit u 
+                    => EscapedChar -> GenPosGraphic st u
+posEscChar          = makeCharPO CAP_HEIGHT_PLUS_DESCENDER
+
+posCharUpright      :: InterpretUnit u 
+                    => Char -> GenPosGraphic st u
+posCharUpright      = makeCharPO JUST_CAP_HEIGHT . CharLiteral
+
+posEscCharUpright   :: InterpretUnit u 
+                    => EscapedChar -> GenPosGraphic st u
+posEscCharUpright   = makeCharPO JUST_CAP_HEIGHT
+
+
+-- | Primtive builder that does not add margins.
+--
+posCharPrim         :: InterpretUnit u 
+                    => Either Char EscapedChar -> GenPosGraphic st u
+posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id
+
+
+makeCharPO :: InterpretUnit u 
+           => TextHeight -> EscapedChar -> GenPosGraphic st u
+makeCharPO hspec esc = 
+    makePosObject (charOrientation hspec esc) 
+                  (dcEscapedlabel $ wrapEscChar esc)
+
+
+
+
+-- | Build the Orientation of an EscapedChar.
+-- 
+-- The locus of the Orientation is baseline left - margins are 
+-- added.
+--
+charOrientation :: (DrawingCtxM m, InterpretUnit u)
+                => TextHeight -> EscapedChar -> m (Orientation u)
+charOrientation hspec esc = 
+    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) 
+      <$> escCharVector esc <*> heightSpan hspec
+
+
+--------------------------------------------------------------------------------
+-- Text PosObjects
+
+
+
+posText     :: InterpretUnit u 
+            => String -> GenPosGraphic st u
+posText     = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString
+
+posEscText  :: InterpretUnit u 
+            => EscapedText -> GenPosGraphic st u
+posEscText  = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER
+
+
+posTextUpright      :: InterpretUnit u 
+                    => String -> GenPosGraphic st u
+posTextUpright      = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString
+
+posEscTextUpright   :: InterpretUnit u 
+                    => EscapedText -> GenPosGraphic st u
+posEscTextUpright   = addMargins . makeTextPO JUST_CAP_HEIGHT
+
+-- | Primtive builder that does not add margins.
+--
+posTextPrim         :: InterpretUnit u 
+                    => Either String EscapedText -> GenPosGraphic st u
+posTextPrim = makeTextPO CAP_HEIGHT_PLUS_DESCENDER . either escapeString id
+
+
+multilinePosText :: (Fractional u, InterpretUnit u)
+                 => VAlign -> String -> PosGraphic u
+multilinePosText vspec xs = 
+    multilinePosEscText vspec $ map escapeString $ lines xs
+
+multilinePosEscText :: (Fractional u, InterpretUnit u)
+                    => VAlign -> [EscapedText] -> GenPosGraphic st u
+multilinePosEscText vspec xs = addMargins $ GenPosObject $ \ctx pt s -> 
+      let sep    = runQuery ctx textlineSpace
+      in getGenPosObject (body sep) ctx pt s
+  where
+    body sp = alignColumnSep vspec sp $ 
+                map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs
+
+
+
+-- | Note - this does not add margins.
+--
+makeTextPO :: InterpretUnit u 
+           => TextHeight -> EscapedText -> GenPosGraphic st u
+makeTextPO hspec esc = 
+    makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)
+
+
+addMargins :: InterpretUnit u => GenPosObject st u a -> GenPosObject st u a
+addMargins ma = 
+   textMargin >>= \(xsep,ysep) -> extendPosObject xsep xsep ysep ysep ma
+
+-- | Build the Orientation of a single line of EscapedText - 
+-- writing direction zero (left-to-right).
+-- 
+-- The locus of the Orientation is baseline left - margins are 
+-- added.
+--
+textOrientationZero :: (DrawingCtxM m, InterpretUnit u )
+                    => TextHeight -> EscapedText -> m (Orientation u)
+textOrientationZero hspec esc = 
+    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) 
+      <$> escTextVector esc <*> heightSpan hspec
+
+
+--------------------------------------------------------------------------------
+-- Rotated text
+
+-- | Note - for single line text.
+--
+rposText        :: (Real u, Floating u, InterpretUnit u) 
+                => Radian -> String -> GenPosGraphic st u
+rposText ang    = addMargins . makeRotatedPO ang . escapeString
+
+-- | Note - for single line text.
+--
+rposEscText     :: (Real u, Floating u, InterpretUnit u) 
+                => Radian -> EscapedText -> GenPosGraphic st u
+rposEscText ang = addMargins . makeRotatedPO ang
+
+
+rposChar        :: (Real u, Floating u, InterpretUnit u) 
+                => Radian -> Char -> GenPosGraphic st u
+rposChar ang ch = rposEscText ang $ wrapEscChar $ CharLiteral ch
+
+rposEscChar     :: (Real u, Floating u, InterpretUnit u) 
+                => Radian -> EscapedChar -> GenPosGraphic st u
+rposEscChar ang ch = rposEscText ang $ wrapEscChar ch
+
+
+
+
+makeRotatedPO :: (Real u, Floating u, InterpretUnit u) 
+              => Radian -> EscapedText -> GenPosGraphic st u
+makeRotatedPO ang esc = makePosObject qry body
+  where
+    qry  = rotateOrientation ang <$> 
+             textOrientationZero CAP_HEIGHT_PLUS_DESCENDER esc
+
+    body = incline (dcREscapedlabel esc) ang
+
+
+--------------------------------------------------------------------------------
+-- Kerned text
+
+
+posHKernText :: InterpretUnit u
+            => [KernChar u] -> GenPosGraphic st u
+posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)
+
+-- | The query should retrieve the width of one char.
+--
+monospaceText :: InterpretUnit u 
+              => Query u u -> String -> GenPosGraphic st u
+monospaceText qry = monospaceEscText qry . escapeString
+
+
+-- | The query should retrieve the width of one char.
+--
+monospaceEscText :: InterpretUnit u 
+                 => Query u u -> EscapedText -> GenPosGraphic st u
+monospaceEscText qry esc = GenPosObject $ \ctx pt s ->
+    let upt    = dinterpF (dc_font_size ctx) pt
+        uw     = runQuery ctx qry
+        ks     = monos uw $ destrEscapedText id esc
+        ortt   = runQuery ctx $ hkernOrientationZero ks
+        dort   = normalizeF (dc_font_size ctx) ortt
+        (_,w1) = runLocImage ctx upt $ hkernLine ks
+    in (UNil, s, dort, w1)
+
+
+
+
+
+monos :: Num u => u -> [EscapedChar] -> [KernChar u]
+monos w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs
+monos _  []     = []
+
+
+
+-- | Note - always CAP_HEIGHT_PLUS_DESCENDER for this one.
+--
+hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )
+                     => [KernChar u] -> m (Orientation u)
+hkernOrientationZero xs = 
+    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) 
+      <$> hkernVector xs <*> heightSpan CAP_HEIGHT_PLUS_DESCENDER
+
+ 
+
+--------------------------------------------------------------------------------
+-- Combining PosObject
+
+
+instance (Monoid a, InterpretUnit u) => ZConcat (GenPosObject st u a) where
+  superior = mappend
+  anterior = flip mappend
+
+
+instance Monoid a => Concat (GenPosObject st u a) where
+  hconcat = genMoveAlign spinemoveH spineRight
+  vconcat = genMoveAlign spinemoveV spineBelow
+
+instance (Monoid a, InterpretUnit u) => CatSpace (GenPosObject st u a) where
+  hspace = genMoveSepH spinemoveH spineRight
+  vspace = genMoveSepV spinemoveV spineBelow
+
+
+
+instance Monoid a => Align (GenPosObject st u a) where
+  halign HALIGN_TOP    = genMoveAlign binmoveHTop    halignTopO
+  halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO
+  halign HALIGN_BASE   = genMoveAlign binmoveHBottom halignBottomO
+
+  valign VALIGN_LEFT   = genMoveAlign binmoveVLeft   valignLeftO
+  valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO
+  valign VALIGN_RIGHT  = genMoveAlign binmoveVRight  valignRightO
+
+
+
+genMoveAlign :: Monoid a
+             => (Orientation Double -> Orientation Double -> Vec2 Double) 
+             -> (Orientation Double -> Orientation Double -> Orientation Double) 
+             -> GenPosObject st u a -> GenPosObject st u a -> GenPosObject st u a
+genMoveAlign mkV mkO ma mb = GenPosObject $ \ctx pt s -> 
+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1
+        v1           = mkV o1 o2
+        ortt         = mkO o1 o2
+        w2'          = cpmove v1 w2 
+    in (a `mappend` b, s2, ortt, w1 `mappend` w2')
+
+
+--------------------------------------------------------------------------------
+-- Sep
+
+instance (Monoid a, InterpretUnit u) => AlignSpace (GenPosObject st u a) where
+  halignSpace HALIGN_TOP    = genMoveSepH binmoveHTop    halignTopO
+  halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO
+  halignSpace HALIGN_BASE   = genMoveSepH binmoveHBottom halignBottomO
+
+  valignSpace VALIGN_LEFT   = genMoveSepV binmoveVLeft   valignLeftO
+  valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO
+  valignSpace VALIGN_RIGHT  = genMoveSepV binmoveVRight  valignRightO
+
+
+genMoveSepH :: (Monoid a, InterpretUnit u) 
+            => (Orientation Double -> Orientation Double -> Vec2 Double) 
+            -> (Orientation Double -> Orientation Double -> Orientation Double) 
+            -> u
+            -> GenPosObject st u a -> GenPosObject st u a 
+            -> GenPosObject st u a
+genMoveSepH mkV mkO sep ma mb  = GenPosObject $ \ctx pt s -> 
+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1
+        dsep         = normalize (dc_font_size ctx) sep
+        v1           = hvec dsep ^+^ mkV o1 o2
+        ortt         = extendORight dsep $ mkO o1 o2
+        w2'          = cpmove v1 w2
+    in (a `mappend` b, s2, ortt, w1 `mappend` w2')
+
+
+
+genMoveSepV :: (Monoid a, InterpretUnit u)
+            => (Orientation Double -> Orientation Double -> Vec2 Double) 
+            -> (Orientation Double -> Orientation Double -> Orientation Double) 
+            -> u
+            -> GenPosObject st u a -> GenPosObject st u a 
+            -> GenPosObject st u a
+genMoveSepV mkV mkO sep ma mb = GenPosObject $ \ctx pt s -> 
+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s 
+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1
+        dsep         = normalize (dc_font_size ctx) sep
+        v1           = vvec (-dsep) ^+^ mkV o1 o2
+        ortt         = extendODown dsep $ mkO o1 o2
+        w2'          = cpmove v1 w2
+    in (a `mappend` b, s2, ortt, w1 `mappend` w2')
+
diff --git a/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs b/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs
@@ -0,0 +1,410 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.TraceDrawing
+-- Copyright   :  (c) Stephen Tetley 2010-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Drawing with /trace/ - a Writer like monad collecting 
+-- intermediate graphics - and /drawing context/ - a reader monad
+-- of attributes - font_face, fill_colour etc.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Drawing.TraceDrawing
+  (
+
+  -- * Collect primitives (writer-like monad) 
+    GenTraceDrawing
+  , TraceDrawing
+  , DTraceDrawing
+
+  , runTraceDrawing
+  , execTraceDrawing
+  , evalTraceDrawing
+
+  , runGenTraceDrawing
+
+
+  , liftToPictureU
+  , liftToPictureMb
+  , mbPictureU
+ 
+  , trace
+  , fontDelta
+  , evalQuery
+
+  , draw
+  , drawi
+  , drawl
+  , drawli
+
+  , drawc
+  , drawci
+
+  , node
+  , nodei
+ 
+  , drawrc
+  , drawrci
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Drawing.Basis
+import Wumpus.Basic.Kernel.Objects.Anchors
+import Wumpus.Basic.Kernel.Objects.Connector
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+import Data.Monoid
+
+
+--------------------------------------------------------------------------------
+
+
+
+
+-- Note - TraceDrawing run \once\ - it is supplied with the starting
+-- environment (DrawingContext) and returns a Picture.
+--
+-- Other Wumpus monads (e.g. Turtle) will typically be run inside
+-- the TraceDrawing monad as a local effect, rather than built into a 
+-- transformer stack.
+--
+
+
+newtype GenTraceDrawing st u a   = GenTraceDrawing { 
+          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }
+
+
+type instance DUnit   (GenTraceDrawing st u a) = u
+type instance UState  (GenTraceDrawing st u a) = st
+
+type TraceDrawing u a = GenTraceDrawing () u a
+
+type DTraceDrawing a    = TraceDrawing Double a
+
+
+-- Functor
+
+instance Functor (GenTraceDrawing st u) where
+  fmap f ma = GenTraceDrawing $ \ctx s -> 
+                let (a,s1,w1) = getGenTraceDrawing ma ctx s in (f a,s1,w1)
+
+
+-- Applicative
+
+instance Applicative (GenTraceDrawing st u) where
+  pure a    = GenTraceDrawing $ \_   s -> (a, s, mempty)
+  mf <*> ma = GenTraceDrawing $ \ctx s -> 
+                let (f,s1,w1) = getGenTraceDrawing mf ctx s
+                    (a,s2,w2) = getGenTraceDrawing ma ctx s1
+                in (f a, s2, w1 `mappend` w2)
+
+
+-- Monad
+
+instance Monad (GenTraceDrawing st u) where
+  return a  = GenTraceDrawing $ \_   s -> (a, s, mempty)
+  ma >>= k  = GenTraceDrawing $ \ctx s -> 
+                let (a,s1,w1) = getGenTraceDrawing ma ctx s
+                    (b,s2,w2) = (getGenTraceDrawing . k) a ctx s1
+                in (b,s2,w1 `mappend` w2)
+                               
+
+-- DrawingCtxM
+
+instance DrawingCtxM (GenTraceDrawing st u) where
+  askDC           = GenTraceDrawing $ \ctx s -> (ctx, s, mempty)
+  asksDC f        = GenTraceDrawing $ \ctx s -> (f ctx, s, mempty)
+  localize upd ma = GenTraceDrawing $ \ctx s -> 
+                      getGenTraceDrawing ma (upd ctx) s
+
+
+-- UserStateM 
+
+instance UserStateM (GenTraceDrawing st u) where
+  getState        = GenTraceDrawing $ \_ s -> (s, s, mempty)
+  setState s      = GenTraceDrawing $ \_ _ -> ((), s, mempty)
+  updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)
+ 
+
+
+
+runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)
+runTraceDrawing ctx ma = post $ getGenTraceDrawing ma ctx ()
+  where
+    post (a,_,w1) = (a,w1)
+
+
+
+-- | Run the drawing returning only the output it produces, drop
+-- any answer from the monadic computation.
+--
+execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u
+execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma
+
+-- | Run the drawing ignoring the output it produces, return the 
+-- answer from the monadic computation.
+--
+-- Note - this useful for testing, generally one would want the 
+-- opposite behaviour (return the drawing, ignore than the 
+-- answer).
+-- 
+evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a
+evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma
+
+
+runGenTraceDrawing :: DrawingContext -> st -> GenTraceDrawing st u a 
+                   -> (a,st,HPrim u)
+runGenTraceDrawing ctx st ma = getGenTraceDrawing ma ctx st
+
+
+
+
+
+-- | /Unsafe/ promotion of @HPrim@ to @Picture@.
+--
+-- If the HPrim is empty, a run-time error is thrown.
+-- 
+liftToPictureU :: HPrim u -> Picture
+liftToPictureU hf = 
+    let prims = hprimToList hf in if null prims then errK else frame prims
+  where
+    errK = error "toPictureU - empty prims list."
+
+-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.
+--
+-- If the HPrim is empty, then @Nothing@ is returned.
+-- 
+liftToPictureMb :: HPrim u -> Maybe Picture
+liftToPictureMb hf = let prims = hprimToList hf in 
+    if null prims then Nothing else Just (frame prims)
+
+
+
+-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.
+--
+-- This is equivalent to:
+--
+-- > fromMaybe (error "empty") $ pic
+--
+-- This function is solely a convenience, using it saves one 
+-- import and a few characters.
+--
+-- If the supplied value is @Nothing@ a run-time error is thrown.
+-- 
+mbPictureU :: Maybe Picture -> Picture
+mbPictureU Nothing  = error "mbPictureU - empty picture."
+mbPictureU (Just a) = a
+
+-- Note - need an equivalent to Parsec\`s parseTest that provides
+-- a very simple way to run graphics without concern for return 
+-- type or initial drawing context.
+
+
+
+--------------------------------------------------------------------------------
+
+
+
+-- TraceM 
+--
+-- Note -  @ state `mappend` a @ means the first expression in a 
+-- monadic drawing is the first element in the output file. It is
+-- also \*\* at the back \*\* in the the Z-Order.
+--
+-- Some control over the Z-Order, possibly by adding /layers/ to 
+-- the drawing model would be valuable. 
+-- 
+
+-- | Primitive operation - cf. tell in Reader monad.
+--
+trace     :: HPrim u -> GenTraceDrawing st u ()
+trace a = GenTraceDrawing $ \_ s -> ((), s, a)
+
+
+
+fontDelta :: GenTraceDrawing st u a -> GenTraceDrawing st u a
+fontDelta mf = GenTraceDrawing $ \ctx s -> 
+    let (_,font_attrs) = runQuery ctx textAttr
+        (a,s1,w1)      = getGenTraceDrawing mf ctx s
+        prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList w1
+    in (a, s1, singleH $ prim1 $ prim)
+
+-- Note - this function is in the wrong module....
+--
+evalQuery :: DrawingCtxM m => Query u a -> m a
+evalQuery df = askDC >>= \ctx -> return $ runQuery ctx df
+
+
+
+-- | Draw a Graphic taking the drawing style from the 
+-- /drawing context/. 
+--
+-- This function is the /forgetful/ version of 'drawi'. 
+-- Commonly, it is used to draw 'Graphic' objects which 
+-- have no /answer/.
+-- 
+draw :: Image u a -> GenTraceDrawing st u ()
+draw gf = askDC >>= \ctx -> 
+          let (_,w) = runImage ctx gf
+          in trace (singleH w) >> return ()
+
+
+
+
+-- | Draw an Image taking the drawing style from the 
+-- /drawing context/. 
+--
+-- The graphic representation of the Image is drawn in the Trace 
+-- monad, and the result is returned.
+-- 
+drawi :: Image u a -> GenTraceDrawing st u a
+drawi gf = askDC >>= \ctx -> 
+           let (a,w) = runImage ctx gf
+           in trace (singleH w) >> return a
+            
+
+
+-- | Draw a LocImage at the supplied Anchor taking the drawing 
+-- style from the /drawing context/. 
+--
+-- This function is the /forgetful/ version of 'drawli'. 
+-- Commonly, it is used to draw 'LocGraphic' objects which 
+-- have no /answer/.
+-- 
+drawl :: InterpretUnit u
+      => Anchor u -> LocImage u a -> GenTraceDrawing st u ()
+drawl ancr img = drawli ancr img >> return ()
+
+
+
+-- | Draw a LocImage at the supplied Point taking the drawing 
+-- style from the /drawing context/. 
+--
+-- The graphic representation of the Image is drawn in the Trace 
+-- monad, and the result is returned.
+-- 
+drawli :: InterpretUnit u
+       => Anchor u -> LocImage u a -> GenTraceDrawing st u a
+drawli pt gf = askDC >>= \ctx -> 
+               let (a,w) = runLocImage ctx pt gf
+               in trace (singleH w) >> return a
+
+
+-- Design note - having @drawlti@ for LocThetaImage does not seem 
+-- compelling (at the moment). The thinking is that LocTheta
+-- objects should be downcast to Loc objects before drawing. 
+--
+-- Connectors however are be different. 
+-- 
+-- PosImages would seem to be the same as LocThetaImages.
+--
+
+
+
+-- | Draw a ConnectorGraphic with the supplied Anchors taking the 
+-- drawing style from the /drawing context/. 
+--
+-- This function is the /forgetful/ version of 'drawci'. 
+-- Commonly, it is used to draw 'ConnectorGraphic' objects which 
+-- have no /answer/.
+-- 
+drawc :: InterpretUnit u
+      => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()
+drawc an0 an1 gf = drawci an0 an1 gf >> return () 
+
+
+-- | Draw a ConnectorImage with the supplied Points taking the 
+-- drawing style from the /drawing context/. 
+--
+-- The graphic representation of the Image is drawn in the Trace 
+-- monad, and the result is returned.
+-- 
+drawci :: InterpretUnit u 
+       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a
+drawci p0 p1 gf = drawi (connect gf p0 p1)
+
+
+
+
+
+
+
+
+-- | Draw the object with the supplied grid coordinate. The 
+-- actual position is scaled according to the 
+-- @snap_grid_factors@ in the /drawing context/.
+-- 
+-- This function is the /forgetful/ version of 'nodei'. 
+-- Commonly, it is used to draw 'LocGraphic' objects which 
+-- have no /answer/.
+-- 
+node :: ( Fractional u, InterpretUnit u)
+     => (Int,Int) -> LocImage u a -> GenTraceDrawing st u ()
+node coord gf = nodei coord gf >> return ()
+
+
+-- | Draw the object with the supplied grid coordinate. The 
+-- actual position is scaled according to the 
+-- @snap_grid_factors@ in the /drawing context/.
+-- 
+nodei :: (Fractional u, InterpretUnit u) 
+      => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a
+nodei coord gf = askDC >>= \ctx -> 
+                 position coord >>= \pt ->
+                 let (a,w) = runLocImage ctx pt gf
+                 in trace (singleH w) >> return a
+ 
+
+
+
+
+-- | Draw a connector between two objects. The projection of the
+-- connector line is drawn on the line from center to center of 
+-- the objects, the actual start and end points of the drawn line
+-- are the radial points on the objects borders that cross the 
+-- projected line.
+-- 
+-- This function is the /forgetful/ version of 'drawrci'. 
+-- Commonly, it is used to draw 'LocGraphic' objects which 
+-- have no /answer/.
+-- 
+drawrc :: ( Real u, Floating u, InterpretUnit u
+          , CenterAnchor a1, RadialAnchor a1
+          , CenterAnchor a2, RadialAnchor a2
+          , u ~ DUnit a1, u ~ DUnit a2
+          ) 
+       => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u ()
+drawrc a b gf = drawrci a b gf >> return ()
+
+
+-- | Draw a connector between two objects. The projection of the
+-- connector line is drawn on the line from center to center of 
+-- the objects, the actual start and end points of the drawn line
+-- are the radial points on the objects borders that cross the 
+-- projected line.
+-- 
+drawrci :: ( Real u, Floating u, InterpretUnit u
+           , CenterAnchor a1, RadialAnchor  a1
+           , CenterAnchor a2, RadialAnchor  a2
+           , u ~ DUnit a1, u ~ DUnit a2
+           ) 
+        => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u a
+drawrci a b gf = 
+    let (p0,p1) = radialConnectorPoints a b in drawi (connect gf p0 p1)
diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs b/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs
@@ -0,0 +1,315 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.AdvObject
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Extended Graphic object - an AdvanceGraphic is a Graphic 
+-- twinned with and advance vector.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.AdvObject
+  (
+
+
+  -- * Advance vector
+    AdvanceVec
+  , advanceH
+  , advanceV
+
+
+  -- * Advance-vector object and graphic
+  , AdvObject
+  , DAdvObject
+
+  , AdvGraphic
+  , DAdvGraphic
+  
+  , runAdvObject
+
+  , makeAdvObject
+  , emptyAdvObject
+  , blankAdvObject
+  
+
+  -- * Composition
+  , advance
+  , advances
+  , advspace
+  , evenspace
+
+  , advrepeat
+  , punctuate
+  , advfill
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.VectorSpace                         -- package: vector-space
+
+import Control.Applicative
+import Data.Monoid
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- | Advance vectors provide an idiom for drawing consecutive
+-- graphics. PostScript uses them to draw left-to-right text - 
+-- each character has an advance vector for the width and 
+-- as characters are drawn they successively displace the start
+-- point for the next character with their advance vector.
+--
+-- Type alias for Vec2.
+--
+type AdvanceVec u = Vec2 u
+
+
+-- | Extract the horizontal component of an advance vector.
+--
+-- For left-to-right latin text, the vertical component of an
+-- advance vector is expected to be 0. Ingoring it seems 
+-- permissible when drawing text.
+--
+advanceH :: AdvanceVec u -> u
+advanceH (V2 w _)  = w
+
+-- | Extract the verticall component of an advance vector.
+--
+advanceV :: AdvanceVec u -> u
+advanceV (V2 _ h)  = h
+
+
+--------------------------------------------------------------------------------
+-- AdvObject
+
+-- | Internal newtype wrapper so we can have a monoid instance 
+-- with vector plus (^+^) for mappend.
+--
+newtype DAV = DAV { getDAV :: AdvanceVec Double }
+
+
+instance Monoid DAV where
+  mempty = DAV $ V2 0 0
+  DAV v1 `mappend` DAV v2 = DAV $ v1 ^+^ v2
+
+-- | /Advance vector/ graphic - this partially models the 
+-- PostScript @show@ command which moves the /current point/ by the
+-- advance (width) vector as each character is drawn.
+--
+newtype AdvObject u a = AdvObject 
+          { getAdvObject :: DrawingContext -> DPoint2 -> (a, DAV, CatPrim) }
+
+type instance DUnit (AdvObject u a) = u
+
+type DAdvObject a   = AdvObject Double a
+
+
+type AdvGraphic u = AdvObject u (UNil u)
+type DAdvGraphic  = AdvGraphic Double
+
+
+instance Functor (AdvObject u) where
+  fmap f mf = AdvObject $ \ctx pt -> 
+              let (a,v1,w1) = getAdvObject mf ctx pt in (f a,v1,w1)
+
+
+instance Applicative (AdvObject u) where
+  pure a    = AdvObject $ \_   _  -> (a,mempty,mempty)
+  mf <*> ma = AdvObject $ \ctx pt -> 
+              let (f,v1,w1) = getAdvObject mf ctx pt
+                  (a,v2,w2) = getAdvObject ma ctx pt
+              in (f a, v1 `mappend` v2, w1 `mappend` w2)
+
+
+
+instance Monad (AdvObject u) where
+  return a  = AdvObject $ \_   _  -> (a,mempty,mempty)
+  mf >>= k  = AdvObject $ \ctx pt -> 
+              let (a,v1,w1) = getAdvObject mf ctx pt
+                  (b,v2,w2) = getAdvObject (k a) ctx pt
+              in (b, v1 `mappend` v2, w1 `mappend` w2)
+
+
+
+instance DrawingCtxM (AdvObject u) where
+  askDC           = AdvObject $ \ctx _ -> (ctx, mempty, mempty)
+  asksDC fn       = AdvObject $ \ctx _ -> (fn ctx, mempty, mempty)
+  localize upd ma = AdvObject $ \ctx pt -> getAdvObject ma (upd ctx) pt
+
+
+
+
+instance (Monoid a, InterpretUnit u) => Monoid (AdvObject u a) where
+  mempty = AdvObject $ \_ _ -> (mempty, mempty, mempty)
+  ma `mappend` mb = AdvObject $ \ctx pt -> 
+                    let (a,v1,w1) = getAdvObject ma ctx pt
+                        (b,v2,w2) = getAdvObject mb ctx pt
+                        w2r       = cpmove (getDAV v1) w2
+                    in (a `mappend` b, v1 `mappend` v2, w1 `mappend` w2r)
+
+
+
+-- | Running an AdvObject produces a LocImage.
+--
+runAdvObject :: InterpretUnit u 
+             => AdvObject u a -> LocImage u a
+runAdvObject ma = promoteLoc $ \ot -> 
+    askDC >>= \ctx -> 
+    let dot      = normalizeF (dc_font_size ctx) ot
+        (a,_,ca) = getAdvObject ma ctx dot
+    in replaceAns a $ primGraphic ca
+
+
+
+--------------------------------------------------------------------------------
+
+
+-- | 'makeAdvObject' : @ loc_context_function * image -> AdvObject @
+--
+-- Build an 'AdvObject' from a context function ('CF') that 
+-- generates the answer displacement vector and a 'LocGraphic' 
+-- that draws the 'AdvObject'.
+--
+makeAdvObject :: InterpretUnit u 
+              => Query u (Vec2 u) -> LocImage u a -> AdvObject u a
+makeAdvObject ma gf = AdvObject $ \ctx pt -> 
+    let v1    = runQuery ctx ma
+        dav1  = DAV $ normalizeF (dc_font_size ctx) v1
+        upt   = dinterpF (dc_font_size ctx) pt
+        (a,w) = runLocImage ctx upt gf
+    in (a,dav1,w)
+
+
+
+-- | 'emptyAdvObjectAU' : @ AdvObject @
+--
+-- Build an empty 'AdvObject'.
+-- 
+-- The 'emptyAdvObject' is treated as a /null primitive/ by 
+-- @Wumpus-Core@ and is not drawn, the answer vector generated is
+-- the zero vector @(V2 0 0)@.
+-- 
+emptyAdvObject :: (Monoid a, InterpretUnit u) => AdvObject u a
+emptyAdvObject = mempty
+
+
+
+blankAdvObject :: (Monoid a, InterpretUnit u) 
+               => Vec2 u -> AdvObject u a
+blankAdvObject v1 = AdvObject $ \ctx _ ->
+                    let dav1  = DAV $ normalizeF (dc_font_size ctx) v1
+                    in (mempty, dav1, mempty)
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Combining AdvObjects
+
+
+
+-- Helper for list concatenation.
+-- 
+listcat :: (Monoid a, InterpretUnit u)
+        => (AdvObject u a -> AdvObject u a -> AdvObject u a)
+        -> [AdvObject u a] -> AdvObject u a
+listcat _ []     = mempty
+listcat op (x:xs) = go x xs
+  where
+    go acc []     = acc
+    go acc (b:bs) = go (acc `op` b) bs
+
+
+
+-- AdvObject does not have the same ability to be concatenated
+-- as PosObject - all the advance vector says is \"where to go 
+-- next\". Nothing in the AdvObject tracks the boundary so we
+-- cannot implement the Concat classes.
+
+infixr 6 `advance`
+
+
+-- | Draw the first AdvObject and use the advance vector to 
+-- displace the second AdvObject.
+--
+-- The final answer is the sum of both advance vectors.
+--
+advance :: (Monoid a, InterpretUnit u) 
+        => AdvObject u a -> AdvObject u a -> AdvObject u a
+advance = mappend
+  
+
+-- | Concatenate the list of AdvObjects with 'advance'.
+--
+advances :: (Monoid a, InterpretUnit u) 
+         => [AdvObject u a] -> AdvObject u a
+advances = mconcat
+
+
+-- | Combine the AdvObjects using the answer vector of the 
+-- first object plus the separator to move the start of the second
+-- object. 
+--
+advspace :: (Monoid a, InterpretUnit u) 
+         => Vec2 u -> AdvObject u a -> AdvObject u a -> AdvObject u a
+advspace sep a b = a `mappend` blank `mappend` b
+  where
+    blank = blankAdvObject sep
+
+
+-- | List version of 'nextSpace'.
+--
+evenspace :: (Monoid a, InterpretUnit u) 
+          => Vec2 u -> [AdvObject u a] -> AdvObject u a
+evenspace v = listcat (advspace v)
+
+
+
+-- | Repeat the AdvObject @n@ times, moving each time with 
+-- 'advance'.
+--
+advrepeat :: (Monoid a, InterpretUnit u)
+          => Int -> AdvObject u a -> AdvObject u a
+advrepeat n = advances . replicate n
+
+
+-- | Concatenate the list of AdvObjects, going next and adding
+-- the separator at each step.
+--
+punctuate :: (Monoid a, InterpretUnit u)
+          => AdvObject u a -> [AdvObject u a] -> AdvObject u a
+punctuate sep =  listcat (\a b -> a `advance` sep `advance` b)
+
+
+
+-- | Render the supplied AdvObject, but swap the result advance
+-- for the supplied vector. This function has behaviour analogue 
+-- to @fill@ in the @wl-pprint@ library.
+-- 
+advfill :: InterpretUnit u 
+        => Vec2 u -> AdvObject u a -> AdvObject u a
+advfill sv mf = AdvObject $ \ctx pt -> 
+    let (a,_,ca) = getAdvObject mf ctx pt
+        dav1     = DAV $ normalizeF (dc_font_size ctx) sv 
+    in (a,dav1,ca)
+
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs b/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.AdvanceGraphic
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- Extended Graphic object - an AdvanceGraphic is a Graphic 
--- twinned with and AdvanceV vector.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.AdvanceGraphic
-  (
-
-  -- * Advance-vector graphic
-    AdvGraphic
-  , DAdvGraphic
-
-
-  , makeAdvGraphic
-  , extractLocGraphic
-  , runAdvGraphic
-
-  -- * Composition
-  , advplus
-  , advconcat
-
-  ) 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 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.
---
-type AdvGraphic u      = LocImage u (Point2 u)
-
-type DAdvGraphic       = AdvGraphic Double
-
-
-
---------------------------------------------------------------------------------
-
-
-
--- | Construction is different to intoZZ functions hence the 
--- different name.
---
-makeAdvGraphic :: DrawingInfo (PointDisplace u)
-               -> LocGraphic u 
-               -> AdvGraphic u
-makeAdvGraphic dispf gf = 
-    promoteR1 $ \pt -> dispf >>= \fn -> fmap (replaceL $ fn pt) (gf `at` pt)  
-
-
-
-
-
--- 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
-
-
-
---------------------------------------------------------------------------------
--- composition
-
--- Note there are opportunities for extra composition operators
--- like the /picture language/...
-
-infixr 6 `advplus`
-
-
--- | \*\* WARNING \*\* - pending removal.
---
-advplus :: AdvGraphic u -> AdvGraphic u -> AdvGraphic u
-advplus = chain1
-
-
-advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u
-advconcat []     = makeAdvGraphic (pure id) emptyLocGraphic
-advconcat [x]    = x
-advconcat (x:xs) = x `chain1` advconcat xs 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Anchors.hs b/src/Wumpus/Basic/Kernel/Objects/Anchors.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Anchors.hs
@@ -0,0 +1,230 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Anchors
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Anchor points on shapes, bounding boxes, etc.
+--
+-- Anchors are addressable positions, an examplary use is taking
+-- anchors on node shapes to get the in-bound and out-bound points 
+-- for connectors in a network (graph) diagram.
+-- 
+-- \*\* WARNING \*\* - the API here probably needs some more 
+-- thought.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Anchors
+  ( 
+
+  -- * Anchors
+    Anchor
+
+  -- * Anchor classes
+  , CenterAnchor(..)
+  , ApexAnchor(..)
+  , CardinalAnchor(..)
+  , CardinalAnchor2(..)
+  , RadialAnchor(..)
+  , TopCornerAnchor(..)
+  , BottomCornerAnchor(..)
+  , SideMidpointAnchor(..)
+
+
+  -- * Extended anchor points
+  , projectAnchor
+
+  , radialConnectorPoints
+
+  ) where
+
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Data.AffineSpace                 -- package: vector-space
+
+
+-- | Note an Anchor is just a Point2.
+--
+type Anchor u = Point2 u
+
+
+-- | Center of an object.
+--
+class CenterAnchor a where
+  center :: u ~ DUnit a => a -> Anchor u
+
+
+-- | Apex of an object.
+--
+class ApexAnchor a where
+  apex :: u ~ DUnit a => a -> Anchor u
+
+
+-- | Cardinal (compass) positions on an object. 
+-- 
+-- Cardinal anchors should be at their equivalent radial position.
+-- However, some shapes may not be able to easily define radial 
+-- positions or may be able to provide more efficient definitions 
+-- for the cardinal anchors. Hence the redundancy seems justified. 
+--
+class CardinalAnchor a where
+  north :: u ~ DUnit a => a -> Anchor u
+  south :: u ~ DUnit a => a -> Anchor u
+  east  :: u ~ DUnit a => a -> Anchor u
+  west  :: u ~ DUnit a => a -> Anchor 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
+-- for the diagonal positions. 
+-- 
+-- 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 
+-- problematic, hence the compass points are split into two 
+-- classes.
+--
+class CardinalAnchor2 a where
+  northeast :: u ~ DUnit a => a -> Anchor u
+  southeast :: u ~ DUnit a => a -> Anchor u
+  southwest :: u ~ DUnit a => a -> Anchor u
+  northwest :: u ~ DUnit a => a -> Anchor u
+
+
+-- | Anchor on a border that can be addressed by an angle.
+--
+-- The angle is counter-clockwise from the right-horizontal, i.e.
+-- 0 is /east/.
+--
+class RadialAnchor a where
+  radialAnchor :: Radian -> u ~ DUnit a => a -> Anchor u
+
+
+-- | Anchors at the top left and right corners of a shape.
+--
+-- 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...
+--
+class TopCornerAnchor a where
+  topLeftCorner  :: u ~ DUnit a => a -> Anchor u
+  topRightCorner :: u ~ DUnit a => a -> Anchor u
+
+
+-- | Anchors at the bottom left and right corners of a shape.
+--
+class BottomCornerAnchor a where
+  bottomLeftCorner  :: u ~ DUnit a => a -> Anchor u
+  bottomRightCorner :: u ~ DUnit a => a -> Anchor u
+
+
+-- | Anchors in the center of a side.
+-- 
+-- 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.
+-- 
+-- Implementations are also expected to modulo the side number, 
+-- rather than throw an out-of-bounds error.
+--
+class SideMidpointAnchor a where
+  sideMidpoint :: Int -> u ~ DUnit a => a -> Anchor u
+
+
+
+--------------------------------------------------------------------------------
+
+-- | 'projectAnchor' : @ extract_func * 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@.
+-- 
+-- E.g. take the north of a rectangle and project it 10 units 
+-- further on:
+--  
+-- > projectAnchor north 10 my_rect
+--
+-- If the distance is zero the answer with be whatever point the 
+-- the extraction function produces.
+--
+-- 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, CenterAnchor a, u ~ DUnit a) 
+              => (a -> Anchor u) -> u -> a -> Anchor u
+projectAnchor fn d a = p1 .+^ (avec (vdirection v) d)
+  where
+    p1  = fn a 
+    v   = pvec (center a) p1 
+     
+
+
+--------------------------------------------------------------------------------
+
+-- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @
+--
+-- Find the radial connectors points for objects @a@ and @b@ along
+-- the line joining their centers.
+--
+radialConnectorPoints :: ( Real u, Floating u
+                         , CenterAnchor a, RadialAnchor a
+                         , CenterAnchor b, RadialAnchor b
+                         , u ~ DUnit a, u ~ DUnit b) 
+                      => a -> b -> (Point2 u, Point2 u) 
+radialConnectorPoints a b = (radialAnchor ang a, radialAnchor (ang+pi) b)
+  where
+    ang = vdirection $ pvec (center a) (center b)
+     
+    
+
+--------------------------------------------------------------------------------
+-- Instances 
+
+instance Fractional u => CenterAnchor (BoundingBox u) where
+  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y 
+     where
+       x = xl+0.5*(xr-xl)
+       y = ylo+0.5*(yhi-ylo)
+       
+
+instance Fractional u => CardinalAnchor (BoundingBox u) where
+  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi
+  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo
+  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))
+  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))
+
+
+instance Fractional u => CardinalAnchor2 (BoundingBox u) where
+  northeast (BBox _ ur)                 = ur
+  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo
+  southwest (BBox ll _)                 = ll
+  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi 
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs b/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs
+++ /dev/null
@@ -1,191 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.BaseObjects
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- Aliases for ContextFun types.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.BaseObjects
-  (
-
-  -- * Drawing info
-    DrawingInfo
-  , LocDrawingInfo
-  , LocThetaDrawingInfo
-
-
-  
-  -- * Drawing objects
-  , ImageAns
-  , GraphicAns
-
-  , Image
-  , LocImage
-  , LocThetaImage
-
-  , DImage
-  , DLocImage
-  , DLocThetaImage
-
-  , hyperlink
-
-  ) where
-
-import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Base.WrappedPrimitive
-
-import Wumpus.Core                              -- package: wumpus-core
-
---------------------------------------------------------------------------------
--- DrawingInfo
-
--- | A query on the DrawingContext.
---
--- Alias for 'CF'.
--- 
-type DrawingInfo a      = CF a
-
-
--- | A query on the DrawingContext respective to the supplied
---  point.
---
--- Alias for 'LocCF'.
--- 
-type LocDrawingInfo u a   = LocCF u a
-
-
--- | A query on the DrawingContext respective to the supplied
---  point and angle.
---
--- Alias for 'LocCF'.
--- 
-type LocThetaDrawingInfo u a   = LocThetaCF u a
-
-
-
-
---------------------------------------------------------------------------------
--- Image
-
-
--- | An Image always returns a pair of some polymorphic answer @a@
--- and a PrimGraphic.
---
--- Note a PrimGraphic cannot be empty.
--- 
-type ImageAns u a       = (a, PrimGraphic u)
-
-
-type GraphicAns u       = ImageAns u (UNil u)
-
-
--- | Draw a PrimGraphic repsective to the 'DrawingContext' and 
--- return some answer @a@.
--- 
-type Image u a      = CF (ImageAns u a)
-
-
--- | Draw a PrimGraphic respective to the 'DrawingContext' and 
--- the supplied point, return some answer @a@.
--- 
-type LocImage u a   = LocCF u (ImageAns u a)
-
-
--- | Draw a PrimGraphic respective to the 'DrawingContext' and
--- the supplied point and angle.
--- 
-type LocThetaImage u a   = LocThetaCF u (ImageAns u a)
-
-
-
-type DImage a            = Image Double a
-type DLocImage a         = LocImage Double a
-type DLocThetaImage a    = LocThetaImage Double a
-
-
-type instance DUnit (Image u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u))
-
-type instance DUnit (LocImage u a) = u --  GuardEq (DUnit a) (DUnit (PrimGraphic u))
-
-type instance DUnit (LocThetaImage u a) = u
-
-
-
---------------------------------------------------------------------------------
--- Affine instances
-
--- Note - it seems better to have these instances for Image (even 
--- though Image is a type synonym) rather than more general 
--- instances on a CF.
---
--- There is nothing determining a DUnit for the CF types.
---
--- The downside is these instances are effectively orphan 
--- instances.
---
-
-instance (Real u, Floating u, Rotate a, DUnit a ~ u) => 
-    Rotate (Image u a) where
-  rotate ang = fmap (rotate ang)
-
-
-instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => 
-    RotateAbout (Image u a) where
-  rotateAbout ang pt = fmap (rotateAbout ang pt)
-
-
-instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where
-  scale sx sy = fmap (scale sx sy)
-
-
-instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where
-  translate dx dy = fmap (translate dx dy)
-
-
--- \*\* WARNING \*\* - I am not sure having affine instances for 
--- LocImage makes sense...
---
--- Particularly, what is a rotateAbout on a function from Point to 
--- Graphic? Is it just a post-transformation, or should the start 
--- point be transformed as well.
---
-
-instance (Real u, Floating u, Rotate a, DUnit a ~ u) => 
-    Rotate (LocImage u a) where
-  rotate ang = fmap (rotate ang)
-
-instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => 
-    RotateAbout (LocImage u a) where
-  rotateAbout ang pt = fmap (rotateAbout ang pt)
-
-
-instance (Num u, Scale a, DUnit a ~ u) => Scale (LocImage u a) where
-  scale sx sy = fmap (scale sx sy)
-
-
-instance (Num u, Translate a, DUnit a ~ u) => Translate (LocImage u a) where
-  translate dx dy = fmap (translate dx dy)
-
---------------------------------------------------------------------------------
-
-
-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/Basis.hs b/src/Wumpus/Basic/Kernel/Objects/Basis.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Basis.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Basis
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Common types and operations.
+-- 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Basis
+  (
+
+    PrimResult
+
+  , UConvert(..)
+
+  , ignoreAns
+  , replaceAns
+
+  , Decorate(..)
+  , decorateAbove
+  , decorateBelow
+
+  , elaborateAbove
+  , elaborateBelow
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+type PrimResult u a = (a, CatPrim)
+
+
+
+--------------------------------------------------------------------------------
+
+
+class UConvert (f :: * -> * -> *) where
+  uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
+         => f u (t u) -> f u1 (t u1)
+
+  uconvZ :: (InterpretUnit u, InterpretUnit u1) 
+         => f u a -> f u1 a
+
+
+--------------------------------------------------------------------------------
+
+
+
+-- | Note - the kind of f allows fo unit annotation.
+--
+ignoreAns :: Functor (f u) => f u a -> f u (UNil u)
+ignoreAns = fmap (const UNil)
+
+-- | Replace the answer produced by a graphic object.
+--
+replaceAns :: Functor (f u) => a -> f u z -> f u a
+replaceAns a = fmap (const a)
+
+
+
+
+-- | Decorate an object
+--
+-- oliterate - drops the graphic from the first object replacing 
+-- it with the graphic from the second.
+--
+class Decorate (f :: * -> * -> *) where
+  -- | Should be read as @ decorate (above|below) A with B @
+  decorate    :: ZOrder -> f u a -> f u z -> f u a
+  elaborate   :: ZOrder -> f u a -> (a -> f u z) -> f u a
+  obliterate  :: f u a -> f u a
+  hyperlink   :: XLink -> f u a -> f u a
+  svgId       :: String -> f u a -> f u a
+  svgAnnotate :: [SvgAttr] -> f u a -> f u a
+
+
+
+-- | Decorate (ABOVE) a with b.
+--
+decorateAbove :: Decorate f => f u a -> f u z -> f u a
+decorateAbove = decorate ZABOVE
+
+-- | Decorate (BELOW) a with b.
+--
+decorateBelow :: Decorate f => f u a -> f u z -> f u a
+decorateBelow = decorate ZBELOW
+
+-- | Elaborate (ABOVE) a with b.
+--
+elaborateAbove :: Decorate f => f u a -> (a -> f u z) -> f u a
+elaborateAbove = elaborate ZABOVE
+
+-- | Elaborate (BELOW) a with b.
+--
+elaborateBelow :: Decorate f => f u a -> (a -> f u z) -> f u a
+elaborateBelow = elaborate ZBELOW
+
+
+
+
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
@@ -3,17 +3,15 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Objects.Bounded
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2012
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
 -- Stability   :  highly unstable
 -- Portability :  GHC 
 --
--- Bounded versions of Graphic and LocGraphic.
---
--- Bounded meaning they are actually Images that return the 
--- bounding box of the Graphic.
+-- Helpers for working with Images and LocImages that produce
+-- bounding boxes.
 --
 --------------------------------------------------------------------------------
 
@@ -21,67 +19,53 @@
   (
 
 
-  -- * Bounded graphic / loc graphic
+  -- * Type synonyms
     BoundedGraphic
-  , DBoundedGraphic
   , BoundedLocGraphic
-  , DBoundedLocGraphic
   , BoundedLocThetaGraphic
-  , DBoundedLocThetaGraphic
 
+  -- * Bounding box graphic helpers
+  , centerOrthoBBox
+
+
   , emptyBoundedLocGraphic
+  , emptyBoundedLocThetaGraphic
 
-  , centerOrthoBBox
+
   , illustrateBoundedGraphic
   , illustrateBoundedLocGraphic
   , illustrateBoundedLocThetaGraphic
 
+  , bbrectangle
+
+  , boundedRect
+
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.UpdateDC
-import Wumpus.Basic.Kernel.Objects.BaseObjects
-import Wumpus.Basic.Kernel.Objects.Graphic
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Kernel.Objects.LocThetaImage
 
 import Wumpus.Core                              -- package: wumpus-core
-import Wumpus.Core.Colour ( blue )
 
-import Control.Applicative
+import Data.Monoid
 
 --------------------------------------------------------------------------------
 
--- | Graphic with a bounding box.
--- 
-type BoundedGraphic u      = Image u (BoundingBox u)
 
-type DBoundedGraphic       = BoundedGraphic Double
-
-
-
-
--- | LocGraphic with a bounding box.
---
-type BoundedLocGraphic u      = LocImage u (BoundingBox u)
-
-type DBoundedLocGraphic       = BoundedLocGraphic Double
-
-
--- | LocThetaGraphic with a bounding box.
---
--- Note the size of bounding box for the \"same\" shape will vary 
--- according to the rotation. A bounding box is always 
--- orthonormal (?) to the x- and y-axes.
---
+type BoundedGraphic u           = Image u (BoundingBox u)
+type BoundedLocGraphic u        = LocImage u (BoundingBox u)
 type BoundedLocThetaGraphic u   = LocThetaImage u (BoundingBox u)
 
-type DBoundedLocThetaGraphic    = BoundedLocThetaGraphic Double
 
 
 
-
--- | 'openStroke' : @ theta * bbox -> BBox @
+-- | 'centerOrthoBBox' : @ theta * bbox -> BBox @
 -- 
 -- Rotate a bounding box by @theta@ about its center. Take the 
 -- new bounding box.
@@ -90,51 +74,120 @@
 -- so the dimensions as well as the positions may change under 
 -- rotation. 
 --
-centerOrthoBBox :: (Real u, Floating u) 
+
+centerOrthoBBox :: (Real u, Floating u, Ord u)
                 => Radian -> BoundingBox u -> BoundingBox u
-centerOrthoBBox theta bb = 
-    traceBoundary $ map (rotateAbout theta ctr) ps
+centerOrthoBBox theta bb = traceBoundary $ map (rotateAbout theta ctr) ps
   where
-    ps  = boundaryCornerList bb
     ctr = boundaryCenter bb
+    ps  = boundaryCornerList bb
 
 
-emptyBoundedLocGraphic :: Num u => BoundedLocGraphic u
-emptyBoundedLocGraphic = intoLocImage fn  emptyLocGraphic
-  where
-    fn = promoteR1 $ \pt -> pure (BBox pt pt)
 
+-- | Build an empty 'LocGraphic' returning a bounding box.
+-- 
+-- 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 :: InterpretUnit u => BoundedLocGraphic u 
+emptyBoundedLocGraphic = promoteLoc $ \pt -> 
+    replaceAns (BBox pt pt) $ primGraphic mempty
+
+
+
+
+-- | Build an empty 'LocThetaGraphic' returning a bounding box.
+-- 
+-- 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 
+--
+emptyBoundedLocThetaGraphic :: InterpretUnit u 
+                            => BoundedLocThetaGraphic u
+emptyBoundedLocThetaGraphic = promoteLocTheta $ \pt _ -> 
+    replaceAns (BBox pt pt) $ primGraphic mempty
+
+
+--
+-- NOTE - CONCATENATION
+--
+-- Because there is no tangible relation between the start point 
+-- and answer BoundingBox, LocBoundedGraphic supports exactly the
+-- same concatenation as LocImage.
+--
+-- PosImage and AdvGraphic are the objects that support more 
+-- sophisticated concatenation.
+--
+ 
+
+
 --------------------------------------------------------------------------------
 -- 
 
--- This is a common pattern so needs a name...
 
-illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u
-illustrateBoundedGraphic mf = 
-    mf >>= \(bb,g1) -> bbrectangle bb >>= \(_,g0) -> return (bb, g0 `oplus` g1)
+-- | Draw a BoundedGraphic, illustrating the bounding box.
+--
+illustrateBoundedGraphic :: InterpretUnit u
+                         => Image u (BoundingBox u) -> Image u (BoundingBox u)
+illustrateBoundedGraphic gf = elaborateBelow gf bbrectangle
 
 
-illustrateBoundedLocGraphic :: Fractional u 
-                            => BoundedLocGraphic u -> BoundedLocGraphic u
-illustrateBoundedLocGraphic mf = 
-    promoteR1 $ \pt -> illustrateBoundedGraphic $ apply1R1 mf pt
 
+-- | Draw a BoundedLocGraphic, illustrating the bounding box.
+--
+illustrateBoundedLocGraphic :: InterpretUnit u
+                            => LocImage u (BoundingBox u) 
+                            -> LocImage u (BoundingBox u)
+illustrateBoundedLocGraphic gf = elaborateBelow gf fn
+  where
+    fn bb = promoteLoc $ \_ -> bbrectangle bb
 
-illustrateBoundedLocThetaGraphic :: Fractional u 
-    => BoundedLocThetaGraphic u -> BoundedLocThetaGraphic u
-illustrateBoundedLocThetaGraphic mf = 
-    promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta
 
 
 
-bbrectangle :: Fractional u => BoundingBox u -> Graphic u
+-- | Draw a BoundedLocThetaGraphic, illustrating the bounding box.
+--
+illustrateBoundedLocThetaGraphic :: InterpretUnit u
+                                 => LocThetaImage u (BoundingBox u)
+                                 -> LocThetaImage u (BoundingBox u)
+illustrateBoundedLocThetaGraphic gf = elaborateBelow gf fn
+  where
+    fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb
+
+
+
+-- | Draw a bounding box as a stroked rectangle with 
+-- dotted lines.
+--
+bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u
 bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))
-    | llx == urx && lly == ury = emptyLocGraphic `at` p1
+    | llx == urx && lly == ury = mempty `at` p1
     | otherwise                = 
-        localize drawing_props $ rect1 `oplus` cross
+        localize drawing_props $ rect1 `mappend` cross
   where
-    drawing_props = strokeColour blue . 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)
+    drawing_props = cap_round . dotted_line
+    rect1         = dcRectangle DRAW_STROKE (urx-llx) (ury-lly) `at` p1
+    cross         = straightLine p1 p2 
+                      `mappend` straightLine (P2 llx ury) (P2 urx lly)
 
+
+
+-- | 'boundedRect' : @ style * width * height -> LocGraphic @
+--
+-- Create a stroked rectangle - the implicit start point is 
+-- /bottom-left/, return the bounding box of the rectangle as the 
+-- answer.
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+boundedRect :: InterpretUnit u 
+            => DrawMode -> u -> u -> BoundedLocGraphic u 
+boundedRect style w h = promoteLoc $ \pt@(P2 x y) -> 
+    let bb = BBox pt (P2 (x + w) (y + h))
+    in replaceAns bb $ applyLoc (dcRectangle style w h) pt
+
+ 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Concat.hs b/src/Wumpus/Basic/Kernel/Objects/Concat.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Concat.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Concat
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Classes for concatenation.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Concat
+  (
+
+    ZConcat(..)
+  , cat
+  , Concat(..)
+  , hcat
+  , vcat
+
+  , CatSpace(..)
+  , hsep
+  , vsep
+
+  , Align(..)
+  , alignRow
+  , alignColumn
+
+  , AlignSpace(..)
+  , alignRowSep
+  , alignColumnSep
+  
+  
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Monoid
+
+infixr 6 `superior`, `anterior`
+
+-- | Minimal defintion is 'superior', 'anterior' is usually 
+-- @flip superior@.
+--
+-- > `superior` (infixr 6)
+--
+-- > `anterior` (infixr 6)
+-- 
+-- 
+class ZConcat o where
+  anterior :: o -> o -> o 
+  superior :: o -> o -> o
+
+  anterior = flip superior
+
+
+cat :: (Monoid o, ZConcat o) => [o] -> o
+cat [] = mempty
+cat (x:xs) = go x xs
+  where
+    go acc []     = acc
+    go acc (a:as) = go (acc `superior` a) as
+  
+
+
+infixr 6 `hconcat`
+infixr 5 `vconcat`
+
+
+-- | Concatenation with /movement/ - the second object is moved
+-- next to the first.
+--
+-- > hconcat is equivalent to @(<>)@ in WL-PPrint.
+-- > (infixr 6)
+-- 
+-- > vconcat is equivalent to @(<$>)@ in WL_PPrint.
+-- > (infixr 5)
+--
+class Concat o where
+  hconcat :: o -> o -> o
+  vconcat :: o -> o -> o
+
+-- | Horizontally concatenate a list of objects.
+-- 
+-- Note - the first argument is an /alternative/ - this is drawn 
+-- if the list is empty, otherwise it is not drawn.
+--
+hcat :: (Monoid o, Concat o) => [o] -> o
+hcat []     = mempty
+hcat (x:xs) = go x xs
+  where
+    go acc []     = acc
+    go acc (a:as) = go (acc `hconcat` a) as
+  
+
+-- | Vertically concatenate a list of objects.
+-- 
+-- Note - the first argument is an /alternative/ - this is drawn 
+-- if the list is empty, otherwise it is not drawn.
+--
+vcat :: (Monoid o, Concat o) => [o] -> o
+vcat []     = mempty
+vcat (x:xs) = go x xs
+  where
+    go acc []     = acc
+    go acc (a:as) = go (acc `vconcat` a) as
+  
+
+class CatSpace o where
+   hspace :: u ~ DUnit o => u -> o -> o -> o
+   vspace :: u ~ DUnit o => u -> o -> o -> o
+
+hsep :: (Monoid o, CatSpace o, u ~ DUnit o) => u -> [o] -> o
+hsep _  []     = mempty
+hsep dx (x:xs) = go x xs
+  where
+    op            = hspace dx
+    go acc []     = acc
+    go acc (a:as) = go (acc `op` a) as
+  
+
+vsep :: (Monoid o, CatSpace o, u ~ DUnit o) => u -> [o] -> o
+vsep _  []     = mempty
+vsep dx (x:xs) = go x xs
+  where
+    op            = vspace dx
+    go acc []     = acc
+    go acc (a:as) = go (acc `op` a) as
+
+
+class Align o where
+  halign :: HAlign -> o -> o -> o 
+  valign :: VAlign -> o -> o -> o
+
+
+alignRow :: (Monoid o, Align o) => HAlign -> [o] -> o
+alignRow _ []     = mempty
+alignRow ha (x:xs) = go x xs
+  where
+    op            = halign ha 
+    go acc []     = acc
+    go acc (a:as) = go (acc `op` a) as
+
+
+alignColumn :: (Monoid o, Align o) => VAlign -> [o] -> o
+alignColumn _ []     = mempty
+alignColumn va (x:xs) = go x xs
+  where
+    op            = valign va 
+    go acc []     = acc
+    go acc (a:as) = go (acc `op` a) as
+
+
+
+class AlignSpace o where
+  halignSpace :: u ~ DUnit o => HAlign -> u -> o -> o -> o 
+  valignSpace :: u ~ DUnit o => VAlign -> u -> o -> o -> o
+
+
+
+alignRowSep :: (Monoid o, AlignSpace o, u ~ DUnit o) 
+            => HAlign -> u -> [o] -> o
+alignRowSep _  _  []     = mempty
+alignRowSep ha dx (x:xs) = go x xs
+  where
+    op            = halignSpace ha dx
+    go acc []     = acc
+    go acc (a:as) = go (acc `op` a) as
+
+
+alignColumnSep :: (Monoid o, AlignSpace o, u ~ DUnit o) 
+            => VAlign -> u -> [o] -> o
+alignColumnSep _  _  []     = mempty
+alignColumnSep va dx (x:xs) = go x xs
+  where
+    op            = valignSpace va dx
+    go acc []     = acc
+    go acc (a:as) = go (acc `op` a) as
+
+
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
@@ -1,74 +1,295 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Objects.Connector
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
 -- Stability   :  highly unstable
 -- Portability :  GHC 
 --
--- Graphic and Image types representing connectors - connectors
--- have two implicit points - start and end.
+-- ConnImage and ConnGraphic types - these are functional types
+-- from the DrawingContext plus start point and end point to a 
+-- graphic /primitive/.
 --
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Objects.Connector
-  (
+   (
+     ConnectorImage
+   , ConnectorGraphic
 
-  -- * Connector Graphic
-    ConnectorGraphic
-  , DConnectorGraphic
+   , DConnectorImage
+   , DConnectorGraphic
 
+   , ConnectorQuery
 
-  -- * Connector Image
-  , ConnectorImage
-  , DConnectorImage
+   , runConnectorImage
+   , runConnectorQuery
+   , connect
 
+   , stripConnectorImage
+   , liftConnectorQuery
 
+   , promoteConn
+   , applyConn
 
-  ) where
+   , qpromoteConn
+   , qapplyConn
 
-import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Objects.BaseObjects
+   , emptyConnectorImage
 
--- import Wumpus.Core                              -- package: wumpus-core
+   )
 
+   where
 
---------------------------------------------------------------------------------
--- Connector Graphic
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Image
 
+import Wumpus.Core                              -- package: wumpus-core
 
--- | ConnectorGraphic is a connector drawn between two points 
--- contructing a Graphic.
+import Control.Applicative
+import Data.Monoid
+
+
+-- | ConnectorImage - function from DrawingContext and start and 
+-- end points to a polymorphic /answer/ and a graphic /primitive/.
 --
-type ConnectorGraphic u         = ConnectorCF u (GraphicAns u)
+newtype ConnectorImage u a = ConnectorImage { 
+          getConnectorImage :: DPoint2 -> DPoint2 -> Image u a }
 
 
-type DConnectorGraphic          = ConnectorGraphic Double
+type instance DUnit (ConnectorImage u a) = u
 
 
 
+type ConnectorGraphic u = ConnectorImage u (UNil u)
 
+-- | Type specialized version of 'ConnectorImage'.
+--
+type DConnectorImage a        = ConnectorImage Double a
+
+-- | Type specialized version of 'ConnectorGraphic'.
+--
+type DConnectorGraphic        = ConnectorGraphic Double 
+
+
+newtype ConnectorQuery u a = ConnectorQuery { 
+          getConnectorQuery :: DPoint2 -> DPoint2 -> Query u a }
+
+
+-- Functor 
+
+instance Functor (ConnectorImage u) where
+  fmap f ma = ConnectorImage $ \p0 p1 -> fmap f $ getConnectorImage ma p0 p1
+
+instance Functor (ConnectorQuery u) where
+  fmap f ma = ConnectorQuery $ \p0 p1 -> fmap f $ getConnectorQuery ma p0 p1
+
+
+-- Applicative
+
+instance Applicative (ConnectorImage u) where
+  pure a    = ConnectorImage $ \_  _  -> pure a
+  mf <*> ma = ConnectorImage $ \p0 p1 -> 
+                getConnectorImage mf p0 p1 <*> getConnectorImage ma p0 p1
+
+instance Applicative (ConnectorQuery u) where
+  pure a    = ConnectorQuery $ \_  _  -> pure a
+  mf <*> ma = ConnectorQuery $ \p0 p1 -> 
+                getConnectorQuery mf p0 p1 <*> getConnectorQuery ma p0 p1
+
+
+-- Monad 
+
+instance Monad (ConnectorImage u) where
+  return a  = ConnectorImage $ \_  _  -> return a
+  ma >>= k  = ConnectorImage $ \p0 p1 -> 
+                getConnectorImage ma p0 p1 >>= \ans -> 
+                getConnectorImage (k ans) p0 p1
+
+
+instance Monad (ConnectorQuery u) where
+  return a  = ConnectorQuery $ \_  _  -> return a
+  ma >>= k  = ConnectorQuery $ \p0 p1 -> 
+                getConnectorQuery ma p0 p1 >>= \ans -> 
+                getConnectorQuery (k ans) p0 p1
+
+
+-- Monoid
+
+instance Monoid a => Monoid (ConnectorImage u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = ConnectorImage $ \p0 p1 -> 
+                      getConnectorImage ma p0 p1 
+                        `mappend` getConnectorImage mb p0 p1 
+
+
+instance Monoid a => Monoid (ConnectorQuery u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = ConnectorQuery $ \p0 p1 -> 
+                      getConnectorQuery ma p0 p1 
+                        `mappend` getConnectorQuery mb p0 p1 
+
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (ConnectorImage u) where
+  askDC           = ConnectorImage $ \_  _  -> askDC
+  asksDC fn       = ConnectorImage $ \_  _  -> asksDC fn
+  localize upd ma = ConnectorImage $ \p0 p1 -> 
+                      localize upd (getConnectorImage ma p0 p1)
+
+instance DrawingCtxM (ConnectorQuery u) where
+  askDC           = ConnectorQuery $ \_  _  -> askDC
+  asksDC fn       = ConnectorQuery $ \_  _  -> asksDC fn
+  localize upd ma = ConnectorQuery $ \p0 p1 -> 
+                      localize upd (getConnectorQuery ma p0 p1)
+
+
+  
+
+
+instance Decorate ConnectorImage where
+  decorate zo ma mz     = ConnectorImage $ \p0 p1 -> 
+    decorate zo (getConnectorImage ma p0 p1) (getConnectorImage mz p0 p1)
+
+  elaborate zo ma f     = ConnectorImage $ \p0 p1 -> 
+    elaborate zo (getConnectorImage ma p0 p1) 
+                 (\a -> getConnectorImage (f a) p0 p1)
+
+  obliterate ma         = ConnectorImage $ \p0 p1 -> 
+    obliterate $ getConnectorImage ma p0 p1
+
+  hyperlink xl ma       = ConnectorImage $ \p0 p1 -> 
+    hyperlink xl $ getConnectorImage ma p0 p1
+
+  svgId ss ma           = ConnectorImage $ \p0 p1 -> 
+    svgId ss $ getConnectorImage ma p0 p1
+
+  svgAnnotate attrs ma  = ConnectorImage $ \p0 p1 -> 
+    svgAnnotate attrs $ getConnectorImage ma p0 p1
+
+
+
+
+runConnectorImage :: InterpretUnit u 
+                  => DrawingContext -> Point2 u -> Point2 u
+                  -> ConnectorImage u a
+                  -> PrimResult u a
+runConnectorImage ctx p0 p1 ma = 
+    let dp0 = normalizeF (dc_font_size ctx) p0
+        dp1 = normalizeF (dc_font_size ctx) p1 
+    in runImage ctx $ getConnectorImage ma dp0 dp1
+
+
+runConnectorQuery :: InterpretUnit u 
+                  => DrawingContext -> Point2 u -> Point2 u 
+                  -> ConnectorQuery u a
+                  -> a
+runConnectorQuery ctx p0 p1 ma = 
+    let dp0 = normalizeF (dc_font_size ctx) p0
+        dp1 = normalizeF (dc_font_size ctx) p1 
+    in runQuery ctx $ getConnectorQuery ma dp0 dp1
+
+
+connect :: InterpretUnit u 
+        => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a
+connect ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> 
+                   normalizeCtxF p1 >>= \dp1 -> 
+                   getConnectorImage ma dp0 dp1
+
+
+stripConnectorImage :: ConnectorImage u a -> ConnectorQuery u a
+stripConnectorImage ma = ConnectorQuery $ \p1 p2 -> 
+    stripImage $ getConnectorImage ma p1 p2
+
+
+liftConnectorQuery :: ConnectorQuery u a -> ConnectorImage u a
+liftConnectorQuery ma = ConnectorImage $ \p1 p2 -> 
+    liftQuery $ getConnectorQuery ma p1 p2
+
+
+promoteConn :: InterpretUnit u 
+            => (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a
+promoteConn k = ConnectorImage $ \p0 p1 ->
+    dinterpCtxF p0 >>= \up0 -> 
+    dinterpCtxF p1 >>= \up1 -> 
+    k up0 up1
+
+applyConn :: InterpretUnit u 
+          => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a
+applyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> 
+                     normalizeCtxF p1 >>= \dp1 -> 
+                     getConnectorImage ma dp0 dp1
+
+
+
+
+qpromoteConn :: InterpretUnit u 
+             => (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a
+qpromoteConn k = ConnectorQuery $ \p0 p1 ->
+    dinterpCtxF p0 >>= \up0 -> 
+    dinterpCtxF p1 >>= \up1 -> 
+    k up0 up1
+
+qapplyConn :: InterpretUnit u
+           => ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a
+qapplyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> 
+                      normalizeCtxF p1 >>= \dp1 -> 
+                      getConnectorQuery ma dp0 dp1
+
+
 --------------------------------------------------------------------------------
--- Connector Image
+-- UConvert instance
 
+instance UConvert ConnectorImage where
+  uconvF = uconvConnectorImageF
+  uconvZ = uconvConnectorImageZ
 
--- | ConnectorImage is a connector drawn between two points 
--- constructing an Image.
+
+-- | Use this to convert 'ConnectorGraphic' or 'ConnectorImage' 
+-- with Functor answer.
 --
--- Usually the answer type of a ConnectorImage will be a Path so
--- the Points ar @midway@, @atstart@ etc. can be taken on it.
+uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
+                     => ConnectorImage u (t u) -> ConnectorImage u1 (t u1)
+uconvConnectorImageF ma = ConnectorImage $ \p0 p1 -> 
+    uconvF $ getConnectorImage ma p0 p1
+
+
+
+
+-- | Use this to convert 'ConnectorImage' with unit-less answer.
 --
-type ConnectorImage u a = ConnectorCF u (ImageAns u a)
+uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1) 
+                     => ConnectorImage u a -> ConnectorImage u1 a
+uconvConnectorImageZ ma = ConnectorImage $ \p0 p1 -> 
+    uconvZ $ getConnectorImage ma p0 p1
 
+-- | Having /empty/ at the specific 'ConnectorImage' type is useful.
+-- 
+emptyConnectorImage :: Monoid a => ConnectorImage u a
+emptyConnectorImage = mempty
 
-type DConnectorImage a  = ConnectorImage Double a
 
+--------------------------------------------------------------------------------
 
 
+
+--
+-- Design note - potentially there are no useful combining 
+-- operators on Connectors (!).
+--
+-- Division - i.e. splitting a path at points between the start 
+-- and end - seems a more obvious operation on connector paths 
+-- than combination. See the ConnectorPath operations in 
+-- Wumpus-Drawing for some examples.
+--
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
+++ /dev/null
@@ -1,563 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- A Picture-with-implicit-context object. 
--- 
--- 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).
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.CtxPicture
-  (
-
-    CtxPicture
-  , DCtxPicture
-  , runCtxPicture
-  , runCtxPictureU
-  , drawTracing
-
-  , clipCtxPicture
-  , mapCtxPicture
-
-  -- * Composition
-  , over 
-  , under
-
-  , centric
-  , nextToH
-  , nextToV
-  
-  , atPoint 
-  , centeredAt
-
-  , zconcat
-
-  , hcat 
-  , vcat
-
-
-  , hspace
-  , vspace
-  , hsep
-  , vsep
- 
-  -- * Compose with alignment
-  , alignH
-  , alignV
-  , alignHSep
-  , alignVSep
-  , hcatA
-  , vcatA
-  , hsepA
-  , vsepA
-
-
-  ) where
-
-import Wumpus.Basic.Kernel.Base.Anchors
-import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Base.DrawingContext
-import Wumpus.Basic.Kernel.Objects.TraceDrawing
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AdditiveGroup                       -- package: vector-space
-import Data.AffineSpace
-
-import Control.Applicative
-import Data.List ( foldl' )
-
-
-
-newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }
-
-type DCtxPicture = CtxPicture Double
-
-
-type instance DUnit (CtxPicture u) = u
-
-
-
-
-runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)
-runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)  
-
-
-runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u
-runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df
-  where
-    fk = error "runCtxPictureU - empty CtxPicture."   
-
-
-
-drawTracing :: (Real u, Floating u, FromPtSize u) 
-            => TraceDrawing u a -> CtxPicture u
-drawTracing mf = CtxPicture $ 
-    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )
-
-
--- Note - cannot get an answer from a TraceDrawing with this 
--- CtxPicture type. There is nowhere to put the answer in the type.
---
--- If the type was extended:
---
--- > newtype CtxPicture u a = CtxPicture { getCtxPicture :: CF (a, Maybe (Picture u))) }
---
--- It would make things difficult for the drawing composition 
--- operators. @a@ could be monoidial but are there any types of 
--- 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 cpath = mapCtxPicture (clip cpath)
-
-
-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)
-
-instance (Real u, Floating u) => RotateAbout (CtxPicture u) where
-  rotateAbout r pt = mapCtxPicture (rotateAbout r pt)
-
-instance (Num u, Ord u) => Scale (CtxPicture u) where
-  scale sx sy = mapCtxPicture (scale sx sy)
-
-instance (Num u, Ord u) => Translate (CtxPicture u) where
-  translate dx dy = mapCtxPicture (translate dx dy)
-
-
-
---------------------------------------------------------------------------------
-
-
---------------------------------------------------------------------------------
--- Extract anchors
-
-boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a
-boundaryExtr f = f . boundary
-
--- Operations on bounds
-
--- | The center of a picture.
---
-boundaryCtr :: Fractional u => Picture u -> Point2 u
-boundaryCtr = boundaryExtr center
-
-
-
--- | Extract the mid point of the top edge.
---
-boundaryN :: Fractional u => Picture u -> Point2 u
-boundaryN = boundaryExtr north
-
--- | Extract the mid point of the bottom edge.
---
-boundaryS :: Fractional u => Picture u -> Point2 u
-boundaryS = boundaryExtr south
-
--- | Extract the mid point of the left edge.
---
-boundaryE :: Fractional u => Picture u -> Point2 u
-boundaryE = boundaryExtr east
-
--- | Extract the mid point of the right edge.
---
-boundaryW :: Fractional u => Picture u -> Point2 u
-boundaryW = boundaryExtr west
-
-
--- | Extract the top-left corner.
---
-boundaryNW :: Fractional u => Picture u -> Point2 u
-boundaryNW = boundaryExtr northwest
-
--- | Extract the top-right corner.
---
-boundaryNE :: Picture u -> Point2 u
-boundaryNE = boundaryExtr ur_corner
-
--- | Extract the bottom-left corner.
---
-boundarySW :: Picture u -> Point2 u
-boundarySW = boundaryExtr ll_corner
-
--- | Extract the bottom-right corner.
---
-boundarySE :: Fractional u => Picture u -> Point2 u
-boundarySE = boundaryExtr southeast
-
-
-boundaryLeftEdge :: Picture u -> u
-boundaryLeftEdge = boundaryExtr (point_x . ll_corner)
-
-boundaryRightEdge :: Picture u -> u
-boundaryRightEdge = boundaryExtr (point_x . ur_corner)
-
-boundaryBottomEdge :: Picture u -> u
-boundaryBottomEdge = boundaryExtr (point_y . ll_corner)
-
-
-boundaryTopEdge :: Picture u -> u
-boundaryTopEdge = boundaryExtr (point_y . ur_corner)
-
-
-
-
-  
--- 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
-
-
-drawingConcat :: (Picture u -> Picture u -> Picture u) 
-              -> CtxPicture u -> CtxPicture u -> CtxPicture u
-drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)
-
-
-
-mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)
-mbpostcomb op = liftA2 fn 
-  where
-    fn (Just a) (Just b) = Just $ a `op` b
-    fn a        Nothing  = a
-    fn Nothing  b        = b
-
-
--- Note - the megaCombR operator is in some way an
--- /anti-combinator/. It seems easier to think about composing 
--- drawings if we do work on the result Pictures directly rather 
--- than build combinators to manipulate CtxPictures.
---
--- The idea of combining pre- and post- operating combinators
--- makes me worry about circular programs even though I know 
--- lazy evaluation allows me to write them (in some cicumstances).
---
-
-
--- Picture /mega-combiner/ - moves only the second argument aka the 
--- right picture.
---
-megaCombR :: (Num u, Ord u)
-          => (Picture u -> a) -> (Picture u -> a) 
-          -> (a -> a -> Picture u -> Picture u) 
-          -> CtxPicture u -> CtxPicture u
-          -> CtxPicture u
-megaCombR qL qR trafoR = drawingConcat fn
-  where
-    fn pic1 pic2 = let a    = qL pic1
-                       b    = qR pic2
-                       p2   = trafoR a b pic2
-                   in pic1 `picOver` p2
-
-
-
-
--- | > a `over` 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
-
-
-
--- | > a `under` b
---
--- Similarly @under@ draws the first drawing behind 
--- the second but move neither.
---
-under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-under = flip over
-
-
-
--- | Move in both the horizontal and vertical.
---
-move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u
-move v = mapCtxPicture (\p -> p `picMoveBy` v)
-
-
-
-
---------------------------------------------------------------------------------
--- Composition
-
-infixr 5 `nextToV`
-infixr 6 `nextToH`, `centric`
-
-
-
-
--- | 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 
---
---
-centric :: (Fractional u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-centric = megaCombR boundaryCtr boundaryCtr moveFun
-  where
-    moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v
-
-
-
--- | > a `nextToH` b
--- 
--- Horizontal composition - move @b@, placing it to the right 
--- of @a@.
--- 
-nextToH :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
-  where 
-    moveFun a b pic = pic `picMoveBy` hvec (a - b)
-
-
-
--- | > a `nextToV` b
---
--- Vertical composition - move @b@, placing it below @a@.
---
-nextToV :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-nextToV = 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
-  where
-    fn p = let bb = boundary p
-               dx = x - (boundaryWidth  bb * 0.5)
-               dy = y - (boundaryHeight bb * 0.5)
-           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.
--- 
-hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
-hcat []     = empty_drawing
-hcat (d:ds) = foldl' nextToH d ds
-
-
--- | Concatenate the list of pictures @xs@ vertically.
---
-vcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
-vcat []     = empty_drawing
-vcat (d:ds) = foldl' nextToV d ds
-
-
-
-
---------------------------------------------------------------------------------
-
-
-
-
--- | > hspace 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
-  where
-    moveFun a b pic = pic `picMoveBy` hvec (n + a - b)
-
-    
-
-
-
--- | > vspace 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
-  where 
-    moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)
-
-
-
--- | > hsep n 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
-
-
-
--- | > vsep 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
-
-
---------------------------------------------------------------------------------
--- Aligning pictures
-
-alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u
-alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)
-
-
-
--- | > alignH 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
-
-
--- | > alignV 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) 
-       => 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
-
-
-
-alignMove2 :: (Num u, Ord u) 
-           => Vec2 u ->  Point2 u -> Point2 u -> Picture u -> Picture u
-alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2))
-
-
-
--- | > alignHSep align sep a b
--- 
--- Spacing version of alignH - 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))
-
-
--- | > alignVSep 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))
-
-
--- | Variant of 'hcat' 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
-
-
-
--- | Variant of 'vcat' 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
-
-
--- | Variant of @hsep@ 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 
-
-
--- | Variant of @vsep@ 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 
-
-
-
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,358 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Displacement
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Displacing points - often start points. 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Displacement
+  (
+
+
+  -- * Displacement
+    PointDisplace
+  , ThetaPointDisplace
+  , displace
+
+  , dispParallel
+  , dispPerpendicular
+  , dispOrtho
+
+  , dispDirectionTheta
+  , dispCardinalTheta
+
+  -- * Named vector constructors
+
+  , go_up
+  , go_down
+  , go_left
+  , go_right
+
+  , go_north
+  , go_south
+  , go_east
+  , go_west
+  , go_north_east
+  , go_north_west
+  , go_south_east
+  , go_south_west
+  
+  , go_up_left
+  , go_up_right
+  , go_down_left
+  , go_down_right
+
+  , theta_up
+  , theta_down
+  , theta_left
+  , theta_right
+
+  , theta_north
+  , theta_south
+  , theta_east
+  , theta_west
+  , theta_north_east
+  , theta_north_west
+  , theta_south_east
+  , theta_south_west
+
+  , theta_up_left
+  , theta_up_right
+  , theta_down_left
+  , theta_down_right
+
+  , theta_adj_grazing
+  , theta_bkwd_adj_grazing
+
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+
+
+-- | '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
+
+
+
+
+-- | '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 -> Point2 u -> Point2 u
+
+
+
+-- | 'displace' : @ Vec2 -> PointDisplace @
+--
+-- Alias for @.+^@ from @Data.AffineSpace@.
+--
+displace :: Num u => Vec2 u -> PointDisplace u
+displace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
+
+
+
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- ThetaPointDisplace functions
+
+
+-- | 'dispParallel' : @ dist -> ThetaPointDisplace @
+-- 
+-- Build a combinator to move @Points@ in parallel to the 
+-- direction of the implicit angle by the supplied distance 
+-- @dist@. 
+--
+dispParallel :: Floating u => u -> ThetaPointDisplace u
+dispParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
+
+
+-- | 'dispParallel' : @ dist -> ThetaPointDisplace @
+-- 
+-- Build a combinator to move @Points@ perpendicular to the 
+-- inclnation of the implicit angle by the supplied distance 
+-- @dist@. 
+--
+dispPerpendicular :: Floating u => u -> ThetaPointDisplace u
+dispPerpendicular d = 
+    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d
+
+
+
+-- | 'dispOrtho' : @ 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. 
+-- 
+dispOrtho :: Floating u => u -> u -> ThetaPointDisplace u
+dispOrtho x y = \theta -> dispParallel x theta . dispPerpendicular y theta
+
+
+
+
+-- | /Angular/ version of 'dispDirection'. 
+--
+-- The displacement direction is with respect to implicit angle
+-- of inclination, so:
+--
+-- > up    == perpendicular
+-- > down  == perdendicular . negate
+-- > left  == parallel . negate
+-- > right == parallel
+-- 
+dispDirectionTheta :: Floating u => Direction -> u -> ThetaPointDisplace u
+dispDirectionTheta UP      = dispPerpendicular
+dispDirectionTheta DOWN    = dispPerpendicular . negate
+dispDirectionTheta LEFT    = dispParallel . negate
+dispDirectionTheta RIGHT   = dispParallel
+
+
+-- | /Angular/ version of 'dispCardinal'.
+--
+-- The displacement direction is with respect to implicit angle
+-- of inclination, so:
+--
+-- > north == perpendicular
+-- > east  == parallel
+-- > south == perdendicular . negate
+-- > etc.
+-- 
+dispCardinalTheta :: Floating u => Cardinal -> u -> ThetaPointDisplace u
+dispCardinalTheta NORTH      = dispPerpendicular
+dispCardinalTheta NORTH_EAST = \d ang -> displace (avec (ang + (0.25*pi)) d)
+dispCardinalTheta EAST       = dispParallel
+dispCardinalTheta SOUTH_EAST = \d ang -> displace (avec (ang + (1.75*pi)) d)
+dispCardinalTheta SOUTH      = dispPerpendicular . negate
+dispCardinalTheta SOUTH_WEST = \d ang -> displace (avec (ang + (1.25*pi)) d)
+dispCardinalTheta WEST       = dispParallel . negate
+dispCardinalTheta NORTH_WEST = \d ang -> displace (avec (ang + (0.75*pi)) d)
+
+
+--------------------------------------------------------------------------------
+-- Named vectors
+
+
+go_up :: Num u => u -> Vec2 u
+go_up d = V2 0 d
+
+go_down :: Num u => u -> Vec2 u
+go_down d = V2 0 (-d)
+
+go_left :: Num u => u -> Vec2 u
+go_left d = V2 (-d) 0
+
+go_right :: Num u => u -> Vec2 u
+go_right d = V2 d 0
+
+
+go_north :: Num u => u -> Vec2 u
+go_north = go_up
+
+go_south :: Num u => u -> Vec2 u
+go_south = go_down
+
+go_east :: Num u => u -> Vec2 u
+go_east = go_right
+
+go_west :: Num u => u -> Vec2 u
+go_west = go_left
+
+
+go_north_east :: Floating u => u -> Vec2 u
+go_north_east = avec (0.25*pi)
+
+go_north_west :: Floating u => u -> Vec2 u
+go_north_west = avec (0.75*pi)
+
+go_south_east :: Floating u => u -> Vec2 u
+go_south_east = avec (1.75*pi)
+
+go_south_west :: Floating u => u -> Vec2 u
+go_south_west = avec (1.25*pi)
+
+
+go_up_left :: Num u => u -> Vec2 u
+go_up_left d = V2 (-d) d
+
+go_up_right :: Num u => u -> Vec2 u
+go_up_right d = V2 d d
+
+go_down_left :: Num u => u -> Vec2 u
+go_down_left d = V2 (-d) (-d)
+
+go_down_right :: Num u => u -> Vec2 u
+go_down_right d = V2 d (-d)
+
+
+--------------------------------------------------------------------------------
+
+
+
+theta_up :: Floating u => u -> Radian -> Vec2 u
+theta_up d ang = avec (ang + half_pi) d
+
+theta_down :: Floating u => u -> Radian -> Vec2 u
+theta_down d ang = avec (ang - half_pi) d
+
+
+-- | Parallel (reverse)
+--
+theta_left :: Floating u => u -> Radian -> Vec2 u
+theta_left d ang = avec (ang + pi) d
+
+-- | Parallel (forward)
+--
+theta_right :: Floating u => u -> Radian -> Vec2 u
+theta_right d ang = avec ang d
+
+
+
+theta_north :: Floating u => u -> Radian -> Vec2 u
+theta_north = theta_up
+
+theta_south :: Floating u => u -> Radian -> Vec2 u
+theta_south = theta_down
+
+theta_east :: Floating u => u -> Radian -> Vec2 u
+theta_east = theta_right
+
+theta_west :: Floating u => u -> Radian -> Vec2 u
+theta_west = theta_left
+
+
+theta_north_east :: Floating u => u -> Radian -> Vec2 u
+theta_north_east d ang = avec (ang + quarter_pi) d
+
+theta_north_west :: Floating u => u -> Radian -> Vec2 u
+theta_north_west d ang = avec (ang + 0.75*pi) d
+
+theta_south_east :: Floating u => u -> Radian -> Vec2 u
+theta_south_east d ang = avec (ang - quarter_pi) d
+
+theta_south_west :: Floating u => u -> Radian -> Vec2 u
+theta_south_west d ang = avec (ang + 1.25*pi) d
+
+
+
+theta_up_left :: Floating u => u -> Radian -> Vec2 u
+theta_up_left d = orthoVec (-d) d
+
+theta_up_right :: Floating u => u -> Radian -> Vec2 u
+theta_up_right d = orthoVec d d
+
+theta_down_left :: Floating u => u -> Radian -> Vec2 u
+theta_down_left d = orthoVec (-d) (-d)
+
+theta_down_right :: Floating u => u -> Radian -> Vec2 u
+theta_down_right d = orthoVec d (-d)
+
+
+
+
+-- | Return @a-o@ when supplied length of @b-o@ and the grazing 
+-- angle @boa@:
+--
+-- >    a
+-- >    .\
+-- >    . \
+-- >  ..b..o
+--
+-- This is useful for building arrowhead vectors.
+--
+theta_adj_grazing :: Floating u => u -> Radian -> Radian -> Vec2 u 
+theta_adj_grazing adj_len ang theta = orthoVec adj_len (-opp) theta
+  where
+    opp = adj_len * (fromRadian $ tan ang)
+
+
+-- | Return @o-c@ when supplied length of @b-o@ and the grazing 
+-- angle @boc@:
+--
+--
+-- >  ..b..o
+-- >    . /
+-- >    ./
+-- >    c
+--
+-- This is useful for building arrowhead vectors.
+--
+theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> Vec2 u 
+theta_bkwd_adj_grazing adj_len ang theta = orthoVec (-adj_len) (-opp) theta
+  where
+    opp = adj_len * (fromRadian $ tan ang)
+
+
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,614 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Primitive drawings - text, paths, lines, rectangles, disks, 
+-- ellipses...
+--
+-- All the primitives take their drawing properties (colour, line 
+-- width, etc.) from the DrawingContext.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+  (
+
+
+  -- * Prim Paths
+    locPP
+
+  , emptyLocPP
+  , vertexPP
+  , curvePP
+
+
+  , dcPath
+  , dcOpenPath
+  , dcClosedPath
+
+  -- * Text
+  , dcTextlabel
+  , dcRTextlabel
+  , dcEscapedlabel
+  , dcREscapedlabel
+
+  , hkernLine
+  , vkernLine
+
+  -- * Lines
+  , straightLine
+  , locStraightLine
+  , curvedLine
+  , straightConnector
+
+  -- * Circles
+  , dcCircle
+
+  -- * Ellipses
+  , dcEllipse
+  , dcREllipse
+
+
+  -- * Rectangles
+  , dcRectangle
+
+  -- * Disks  
+  , dcDisk
+  , dcEllipseDisk
+
+  -- * Arc
+  , dcArc
+
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Objects.Connector
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Kernel.Objects.LocThetaImage
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+
+-- Helpers
+
+
+textPrim :: (RGBi -> FontAttr -> Primitive) -> Graphic u
+textPrim fn = 
+    textAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)
+    
+
+
+strokePrim :: (RGBi -> StrokeAttr -> Primitive) -> Graphic u
+strokePrim fn = 
+    strokeAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)
+                     
+
+fillPrim :: (RGBi -> Primitive) -> Graphic u
+fillPrim fn = 
+    fillAttr >>= \rgb -> primGraphic (prim1 $ fn rgb)
+
+fillStrokePrim :: (RGBi -> StrokeAttr -> RGBi -> Primitive) 
+               -> Graphic u
+fillStrokePrim fn = 
+    borderedAttr >>= \(frgb,attr,srgb) -> 
+        primGraphic (prim1 $ fn frgb attr srgb)
+
+
+textLoc :: InterpretUnit u 
+        => (RGBi -> FontAttr -> DPoint2 -> Primitive) -> LocGraphic u
+textLoc fn = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt)
+
+
+strokeLoc :: InterpretUnit u
+          => (RGBi -> StrokeAttr -> DPoint2 -> Primitive) -> LocGraphic u
+strokeLoc fn = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> strokePrim (\rgb attr -> fn rgb attr dpt)
+
+fillLoc :: InterpretUnit u 
+        => (RGBi -> DPoint2 -> Primitive) -> LocGraphic u
+fillLoc fn = promoteLoc $ \pt ->
+    normalizeCtxF pt >>= \dpt -> fillPrim (\rgb -> fn rgb dpt)
+
+fillStrokeLoc :: InterpretUnit u
+              => (RGBi -> StrokeAttr -> RGBi -> DPoint2 -> Primitive) 
+              -> LocGraphic u
+fillStrokeLoc fn = promoteLoc $ \pt ->
+    normalizeCtxF pt >>= \dpt -> 
+    fillStrokePrim (\frgb attr srgb -> fn frgb attr srgb dpt) 
+ 
+
+
+textLocTheta :: InterpretUnit u 
+             => (RGBi -> FontAttr -> DPoint2 -> Radian -> Primitive) 
+             -> LocThetaGraphic u
+textLocTheta fn = promoteLocTheta $ \pt ang -> 
+    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt ang)
+
+
+
+
+--------------------------------------------------------------------------------
+-- Paths
+
+-- Note - naming convention, the PP suffix is to avoid confusion 
+-- with the Path data type in Wumpus-Drawing. These paths are
+-- considered more /internal/.
+--
+
+-- | 'locPP' : @ [next_vector] -> LocImage PrimPath @
+--
+-- Create a path /query/ - 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'.
+--
+locPP :: InterpretUnit u => [Vec2 u] -> LocQuery u PrimPath
+locPP vs = qpromoteLoc $ \pt -> 
+    vectorPrimPath <$> normalizeCtxF pt <*> mapM normalizeCtxF vs
+
+
+
+
+-- | 'emptyLocPP' : @ (Point ~> PrimPath) @
+--
+-- Create an empty path /query/ - 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'.
+--
+emptyLocPP :: InterpretUnit u => LocQuery u PrimPath
+emptyLocPP = locPP []
+
+
+
+
+-- | 'vertexPP' : @ (Point ~> PrimPath) @
+--
+-- Create a PrimPath made of straight line segments joining the 
+-- supplied points.
+--
+-- This is the analogue to 'vertexPrimPath' in @Wumpus-Core@, but 
+-- it is polymorphic on unit.
+--
+vertexPP :: InterpretUnit u => [Point2 u] -> Query u PrimPath
+vertexPP xs = vertexPrimPath <$> mapM normalizeCtxF xs
+
+
+
+-- | 'curvePP' : @ (Point ~> PrimPath) @
+--
+-- Create a path made of curve segments joining the 
+-- supplied points.
+--
+-- This is the analogue to 'curvedPrimPath' in @Wumpus-Core@, but 
+-- it is polymorphic on unit.
+--
+curvePP :: InterpretUnit u => [Point2 u] -> Query u PrimPath
+curvePP xs = curvedPrimPath <$> mapM normalizeCtxF xs
+
+
+--------------------------------------------------------------------------------
+
+--
+-- Drawing paths (stroke, fill, fillStroke)...
+--
+
+dcPath :: PathMode -> PrimPath -> Graphic u
+dcPath OSTROKE      = dcOpenPath
+dcPath CSTROKE      = dcClosedPath DRAW_STROKE
+dcPath CFILL        = dcClosedPath DRAW_FILL
+dcPath CFILL_STROKE = dcClosedPath DRAW_FILL_STROKE
+
+
+
+-- | 'dcOpenPath' : @ path -> Graphic @
+--
+-- This is the analogue to the 'ostroke' function in 
+-- @Wumpus-Core@, but the drawing properties (colour, line width, 
+-- etc.) are taken from the implicit 'DrawingContext'.
+--
+dcOpenPath :: PrimPath -> Graphic u
+dcOpenPath pp = strokePrim (\rgb attr -> ostroke rgb attr pp)
+
+
+
+-- | 'dcClosedPath' : @ DrawStyle * path -> Graphic @
+--
+-- Draw a closed path according to the supplied DrawStyle
+-- ( fill | stroke | fill_stroke). 
+---
+-- Drawing properties (colour, line width, etc.) for the 
+-- respective style are taken from the implicit 'DrawingContext'.
+--
+dcClosedPath :: DrawMode -> PrimPath -> Graphic u
+dcClosedPath DRAW_FILL        pp = fillPrim (\rgb -> fill rgb pp)
+
+dcClosedPath DRAW_STROKE      pp = strokePrim (\rgb attr -> cstroke rgb attr pp)
+
+dcClosedPath DRAW_FILL_STROKE pp = 
+    fillStrokePrim (\frgb attr srgb -> fillStroke frgb attr srgb pp)
+
+
+--------------------------------------------------------------------------------
+-- Text
+
+-- | 'dcTextlabel' : @ 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'.
+--
+dcTextlabel :: InterpretUnit u => String -> LocGraphic u
+dcTextlabel ss = textLoc (\rgb attr pt -> textlabel rgb attr ss pt)
+
+
+
+
+
+-- | 'dcRTextlabel' : @ 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@.
+--
+dcRTextlabel :: InterpretUnit u => String -> LocThetaGraphic u
+dcRTextlabel ss =
+    textLocTheta (\rgb attr pt ang -> rtextlabel rgb attr ss ang pt)
+
+
+-- | 'dcEscapedlabel' : @ 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'.
+--
+dcEscapedlabel :: InterpretUnit u => EscapedText -> LocGraphic u
+dcEscapedlabel esc =           
+    textLoc (\rgb attr pt -> escapedlabel rgb attr esc pt)
+
+
+
+-- | 'dcREscapedlabel' : @ 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'.
+--
+dcREscapedlabel :: InterpretUnit u => EscapedText -> LocThetaGraphic u
+dcREscapedlabel esc = 
+    textLocTheta (\rgb attr pt ang -> rescapedlabel rgb attr esc ang pt)
+
+
+
+
+uconvKernChar :: InterpretUnit u => [KernChar u] -> Query u [KerningChar]
+uconvKernChar = mapM mf
+  where
+    mf (u,ch) = (\u1 -> (u1,ch)) <$> normalizeCtx u
+
+
+
+-- | '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 :: InterpretUnit u => [KernChar u] -> LocGraphic u
+hkernLine ks = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt
+  where
+    body pt ans = textPrim (\rgb attr -> hkernlabel rgb attr ans 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 :: InterpretUnit u => [KernChar u] -> LocGraphic u
+vkernLine ks = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt
+  where
+    body pt ans = textPrim (\rgb attr -> vkernlabel rgb attr ans pt)
+
+--------------------------------------------------------------------------------
+-- Lines
+
+-- | 'straightLine' : @ 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'.
+-- 
+straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u
+straightLine p1 p2 = liftQuery (vertexPP [p1,p2]) >>= dcOpenPath
+
+
+-- | 'locStraightLine' : @ 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'.
+-- 
+locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u
+locStraightLine v = promoteLoc $ \pt -> 
+    liftQuery (qapplyLoc (locPP [v]) pt) >>= dcOpenPath
+
+
+
+-- | 'curveLine' : @ 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'.
+-- 
+curvedLine :: InterpretUnit u
+           => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
+curvedLine p0 p1 p2 p3 = liftQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath
+
+
+
+
+-- | 'straightConnector' : @ start_point * end_point -> Connector @ 
+-- 
+-- Create a straight line 'Graphic', the start and end point 
+-- are supplied implicitly.
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+straightConnector :: InterpretUnit u => ConnectorGraphic u
+straightConnector = promoteConn $ \p0 p1 -> 
+    liftQuery (vertexPP [p0,p1]) >>= dcOpenPath
+
+
+
+--------------------------------------------------------------------------------
+-- Circles
+
+-- | Helper for circle drawing.
+--
+circlePath :: InterpretUnit u 
+         => u -> LocQuery u PrimPath
+circlePath r = qpromoteLoc $ \pt -> 
+    (\dr dpt -> curvedPrimPath $ bezierCircle dr dpt) 
+      <$> normalizeCtx r <*> normalizeCtxF pt
+
+
+-- | 'dcCircle' : @ DrawStyle * radius -> LocGraphic @
+--
+-- Create a circle 'LocGraphic' - the implicit point is 
+-- center. The circle is drawn with four Bezier curves. 
+-- 
+-- The respective line or fill properties for the 'DrawStyle' are 
+-- taken from the implicit 'DrawingContext'.
+-- 
+dcCircle :: InterpretUnit u => DrawMode -> u -> LocGraphic u
+dcCircle style r = promoteLoc $ \pt -> 
+    liftQuery (qapplyLoc (circlePath r) pt) >>= dcClosedPath style
+
+
+
+--------------------------------------------------------------------------------
+-- Ellipses
+
+
+-- | Helper for ellipse drawing.
+--
+ellipsePath :: InterpretUnit u 
+            => u -> u -> LocQuery u PrimPath
+ellipsePath rx ry = qpromoteLoc $ \pt -> 
+    (\drx dry dpt -> curvedPrimPath $ bezierEllipse drx dry dpt) 
+      <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt
+
+
+-- | Helper for ellipse drawing.
+--
+rellipsePath :: InterpretUnit u 
+            => u -> u -> LocThetaQuery u PrimPath
+rellipsePath rx ry = qpromoteLocTheta $ \pt ang ->
+    (\drx dry dpt -> curvedPrimPath $ rbezierEllipse drx dry ang dpt) 
+      <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt
+
+
+-- | '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'.
+-- 
+dcEllipse :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u
+dcEllipse style rx ry = promoteLoc $ \pt ->
+   liftQuery (qapplyLoc (ellipsePath rx ry) pt) >>= dcClosedPath style 
+
+
+-- | 'dcREllipse' : @ 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'.
+-- 
+dcREllipse :: InterpretUnit u
+           => DrawMode -> u -> u -> LocThetaGraphic u
+dcREllipse style rx ry = promoteLocTheta $ \pt ang -> 
+    liftQuery (qapplyLocTheta (rellipsePath rx ry) pt ang) >>= 
+    dcClosedPath style
+
+
+-- Note - clipping needs some higher level path object than is defined here.
+
+--------------------------------------------------------------------------------
+-- Rectangles
+
+-- | Supplied point is /bottom-left/.
+--
+rectanglePath :: InterpretUnit u 
+              => u -> u -> LocQuery u PrimPath
+rectanglePath w h = locPP [hvec w, vvec h, hvec (-w)]
+
+
+
+-- | 'strokedRectangle' : @ style * 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'.
+-- 
+dcRectangle :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u
+dcRectangle style w h = promoteLoc $ \pt -> 
+    liftQuery (qapplyLoc (rectanglePath w h) pt) >>= dcClosedPath style
+
+
+---------------------------------------------------------------------------
+
+-- | 'dcDisk' : @ radius -> LocGraphic @
+--
+-- Create a 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 
+-- 'dcCircle' instead.
+--
+-- The fill or stroke properties for the respective DrawStyle are
+-- taken from the implicit 'DrawingContext'.
+-- 
+dcDisk :: InterpretUnit u => DrawMode -> u -> LocGraphic u
+dcDisk DRAW_FILL radius = 
+    normalizeCtx radius >>= \r -> 
+    fillLoc (\rgb pt -> fillEllipse rgb r r pt)
+
+dcDisk DRAW_STROKE radius = 
+    normalizeCtx radius >>= \r -> 
+    strokeLoc (\rgb attr pt -> strokeEllipse rgb attr r r pt)
+
+dcDisk DRAW_FILL_STROKE radius = 
+    normalizeCtx radius >>= \r -> 
+    fillStrokeLoc (\frgb attr srgb pt -> fillStrokeEllipse frgb attr srgb r r pt)
+
+
+
+
+-- | 'strokeEllipseDisk' : @ 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'.
+-- 
+dcEllipseDisk :: InterpretUnit u 
+              => DrawMode -> u -> u -> LocGraphic u
+dcEllipseDisk style rx ry = 
+    normalizeCtx rx >>= \drx -> 
+    normalizeCtx ry >>= \dry -> 
+    case style of
+      DRAW_FILL -> fillLoc (\rgb pt -> fillEllipse rgb drx dry pt)
+      DRAW_STROKE -> strokeLoc 
+                       (\rgb attr pt -> strokeEllipse rgb attr drx dry pt)
+      DRAW_FILL_STROKE -> fillStrokeLoc $ 
+                       (\frgb attr srgb pt -> 
+                           fillStrokeEllipse frgb attr srgb drx dry pt)
+
+
+
+--------------------------------------------------------------------------------
+
+
+
+-- | dcArc : radius * apex_angle
+-- 
+-- Always open-stroked.
+--
+dcArc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u
+dcArc radius ang = promoteLocTheta $ \pt inclin -> 
+    let ps = bezierArcPoints ang radius inclin pt
+    in liftQuery (curvePP ps) >>= dcOpenPath
diff --git a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs
+++ /dev/null
@@ -1,478 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.Graphic
--- Copyright   :  (c) Stephen Tetley 2010
--- 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.
---
--- API in @Wumpus.Core@, but here they exploit the implicit 
--- @DrawingContext@.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.Graphic
-  (
-
-    Graphic
-  , DGraphic
-
-
-  -- * LocGraphic  
-  , LocGraphic
-  , DLocGraphic
-
-
-  , LocThetaGraphic
-  , DLocThetaGraphic
-
-  -- * Functions
-  , 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
-
-  , strokedCircle
-  , filledCircle
-  , borderedCircle
-  
-  , strokedDisk
-  , filledDisk
-  , borderedDisk
-
-  ) where
-
-import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.QueryDC
-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
-
---------------------------------------------------------------------------------
--- Graphic
-
--- | Simple drawing - produce a primitive, access the DrawingContext
--- as required, e.g for fill colour, stroke colur, line width, etc.
---
-type Graphic u          = Image u (UNil u)
-
--- | Alias of 'Graphic' where the unit type is specialized to 
--- Double. 
---
-type DGraphic           = Graphic Double
-
-
--- | /Originated/ drawing - produce a primitive respective to the 
--- supplied start-point, access the DrawingContext as required.
---
-type LocGraphic u       = LocImage u (UNil u)
-
--- | Alias of 'LocGraphic' where the unit type is specialized to 
--- Double. 
---
-type DLocGraphic        = LocGraphic Double
-
-
-
-
--- | /Originated/ drawing - produce a primitive respective to the 
--- supplied start-point, access the DrawingContext as required.
---
-type LocThetaGraphic u       = LocThetaImage u (UNil u)
-
-
--- | Alias of 'LocThetaGraphic' where the unit type is specialized 
--- to Double. 
---
-type DLocThetaGraphic        = LocThetaGraphic Double
-
-
---------------------------------------------------------------------------------
--- 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@.
---
-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. 
--- 
--- 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.
--- 
-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
-
-
--- | '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 -> graphicBody $ 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 -> 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'.
---
---
-borderedPath :: Num u => PrimPath u -> Graphic u
-borderedPath pp =
-    withBorderedAttr $ \frgb attr srgb -> 
-      graphicBody $ fillStroke frgb attr srgb pp
-
-
-
-
--- | This is the analogue to 'textlabel' in @Wumpus-core@.
---
-textline :: Num u => String -> LocGraphic u
-textline ss = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (textlabel rgb attr ss pt)
-
-
-
-
--- | This is the analogue to 'rtextlabel' in @Wumpus-core@.
---
-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@.
---
-escapedline :: Num u => EscapedText -> LocGraphic u
-escapedline ss = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (escapedlabel rgb attr ss pt)
-
-
-
--- | This is the analogue to 'rescapedlabel' in @Wumpus-core@.
---
-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@.
---
-hkernline :: Num u => [KerningChar u] -> LocGraphic u
-hkernline xs = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (hkernlabel rgb attr xs pt)
-
-
--- | This is the analogue to 'vkernlabel' in @Wumpus-core@.
---
-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@.
---
-strokedEllipse :: Num u => u -> u -> LocGraphic u
-strokedEllipse hw hh =
-    promoteR1 $ \pt -> 
-      withStrokeAttr $ \rgb attr -> graphicBody (strokeEllipse rgb attr hw hh pt)
-
-
-
--- | 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@.
---
-rfilledEllipse :: Num u => u -> u -> LocThetaGraphic u
-rfilledEllipse hw hh = 
-    promoteR2 $ \pt theta ->
-      withFillAttr $ \rgb -> graphicBody (rfillEllipse rgb hw hh theta 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@.
---
-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.
--- 
-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.
--- 
-straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u
-straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2]
-
-
-
--- | 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)
---
-
-drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u 
-drawWith g mf = promoteR1 $ \pt -> mf (g pt)
-
-
--- | 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
-
--- | Supplied point is /bottom left/.
---
-strokedRectangle :: Fractional u => u -> u -> LocGraphic u
-strokedRectangle w h = rectanglePath w h `drawWith` closedStroke
-
-
--- | 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/.
---
-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. 
---
-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. 
---
-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. 
---
-borderedCircle :: Floating u => Int -> u -> LocGraphic u
-borderedCircle n r = (curvedPath . bezierCircle n r) `drawWith` borderedPath 
-
-
--- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.
---
--- This is a efficient representation of circles using 
--- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
--- output. However, stroked-circles do not draw well after 
--- non-uniform scaling - the line width is scaled as well as 
--- the shape.
---
--- For stroked circles that can be adequately scaled, use 
--- 'strokedCircle' instead.
---
-strokedDisk :: Num u => u -> LocGraphic u
-strokedDisk radius = strokedEllipse radius radius
-
--- | Filled disk...
---
-filledDisk :: Num u => u -> LocGraphic u
-filledDisk radius = filledEllipse radius radius
-
--- | bordered disk...
---
-borderedDisk :: Num u => u -> LocGraphic u
-borderedDisk radius = borderedEllipse radius radius
diff --git a/src/Wumpus/Basic/Kernel/Objects/Image.hs b/src/Wumpus/Basic/Kernel/Objects/Image.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Image.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Image
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Common types and operations.
+-- 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Image
+  (
+
+
+    Image
+  , Graphic 
+
+  , Query
+
+  , DImage
+  , DGraphic
+
+  , runImage
+  , runQuery
+
+  , stripImage
+  , liftQuery
+
+  , emptyImage
+  , primGraphic
+  , clipImage
+
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Objects.Basis
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+import Data.Monoid
+
+--------------------------------------------------------------------------------
+
+
+newtype Image u a = Image { 
+          getImage :: DrawingContext -> (a, CatPrim) }
+
+type instance DUnit (Image u a) = u
+
+type Graphic u = Image u (UNil u)
+
+
+-- | Type specialized version of 'Image'.
+--
+type DImage a       = Image Double a
+
+-- | Type specialized version of 'Graphic'.
+--
+type DGraphic       = Graphic Double 
+
+
+newtype Query u a = Query { 
+          getQuery :: DrawingContext -> a }
+
+type instance DUnit (Query u a) = u
+
+-- Functor
+
+instance Functor (Image u) where
+  fmap f ma = Image $ \ctx -> let (a,w1) = getImage ma ctx in (f a, w1)
+
+instance Functor (Query u) where
+  fmap f ma = Query $ \ctx -> f $ getQuery ma ctx
+
+-- Applicative
+
+instance Applicative (Image u) where
+  pure a    = Image $ \_   -> (a,mempty)
+  mf <*> ma = Image $ \ctx -> let (f,w1) = getImage mf ctx 
+                                  (a,w2) = getImage ma ctx
+                              in (f a, w1 `mappend` w2)
+
+instance Applicative (Query u) where
+  pure a    = Query $ \_   -> a
+  mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx 
+                                  a = getQuery ma ctx
+                              in f a
+
+
+-- Monad
+
+instance Monad (Image u) where
+  return a = Image $ \_   -> (a,mempty)
+  ma >>= k = Image $ \ctx -> let (a,w1) = getImage ma ctx 
+                                 (b,w2) = getImage (k a) ctx
+                             in (b,w1 `mappend` w2)
+
+
+instance Monad (Query u) where
+  return a = Query $ \_   -> a
+  ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx
+
+-- Monoid
+
+instance Monoid a => Monoid (Image u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = Image $ \ctx -> 
+                      getImage ma ctx `mappend` getImage mb ctx
+
+instance Monoid a => Monoid (Query u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = Query $ \ctx -> 
+                      getQuery ma ctx `mappend` getQuery mb ctx
+
+
+-- DrawingCtxM
+
+
+instance DrawingCtxM (Image u) where
+  askDC           = Image $ \ctx -> (ctx, mempty)
+  asksDC fn       = Image $ \ctx -> (fn ctx, mempty)
+  localize upd ma = Image $ \ctx -> getImage ma (upd ctx)
+
+instance DrawingCtxM (Query u) where
+  askDC           = Query $ \ctx -> ctx
+  asksDC fn       = Query $ \ctx -> (fn ctx)
+  localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)
+
+
+runImage :: DrawingContext -> Image u a -> PrimResult u a
+runImage ctx ma = getImage ma ctx
+
+runQuery :: DrawingContext -> Query u a -> a
+runQuery ctx ma = getQuery ma ctx
+
+
+
+-- | Strip the graphic content from an 'Image' making a 'Query'.
+-- 
+stripImage :: Image u a -> Query u a
+stripImage ma = Query $ \ctx -> fst $ getImage ma ctx
+
+
+-- | Turn a 'Query' into an 'Image' without graphic content.
+--
+liftQuery :: Query u a -> Image u a
+liftQuery ma = askDC >>= \ctx -> let a = runQuery ctx ma in return a
+
+
+
+-- | Constructor for Primtive graphics.
+--
+primGraphic :: CatPrim -> Graphic u
+primGraphic w = Image $ \_ -> (UNil, w)
+
+
+-- | Clip an Image.
+-- 
+clipImage :: PrimPath -> Image u a -> Image u a
+clipImage pp ma = Image $ \ctx -> 
+     let (a,w) = getImage ma ctx in (a, cpmap (clipPrim pp) w)
+
+
+
+instance UConvert Image where
+  uconvZ = uconvImageZ
+  uconvF = uconvImageF
+
+uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
+            => Image u (t u) -> Image u1 (t u1) 
+uconvImageF ma = Image $ \ctx -> 
+    let (a,w) = getImage ma ctx
+        a'    = uconvertF (dc_font_size ctx) a
+    in (a',w)
+
+
+uconvImageZ :: (InterpretUnit u, InterpretUnit u1) 
+            => Image u a -> Image u1 a
+uconvImageZ ma = Image $ \ctx -> getImage ma ctx
+
+
+-- | Having /empty/ at the specific 'Image' type is useful.
+-- 
+emptyImage :: Monoid a => Image u a
+emptyImage = mempty
+
+--------------------------------------------------------------------------------
+
+
+instance Decorate Image where
+  decorate      = decorateImage
+  elaborate     = elaborateImage  
+  obliterate    = obliterateImage
+  hyperlink     = hyperlinkImage
+  svgId         = svgIdImage  
+  svgAnnotate   = svgAnnotateImage 
+
+-- | Decorate Image.
+--
+decorateImage :: ZOrder -> Image u a -> Image u z -> Image u a
+decorateImage zo ma mb = Image $ \ctx -> 
+    step zo (getImage ma ctx) (getImage mb ctx)
+  where
+    step ZABOVE (a,w1) (_,w2) = (a, w1 `mappend` w2)
+    step ZBELOW (a,w1) (_,w2) = (a, w2 `mappend` w1)
+
+
+-- | Elaborate Image.
+--
+elaborateImage :: ZOrder -> Image u a -> (a -> Image u z) -> Image u a
+elaborateImage zo ma k = Image $ \ ctx ->
+    let (a,w1) = getImage ma ctx
+        (_,w2) = getImage (k a) ctx 
+    in case zo of
+      ZABOVE -> (a, w1 `mappend` w2)
+      ZBELOW -> (a, w2 `mappend` w1)
+
+
+obliterateImage :: Image u a -> Image u a
+obliterateImage ma = Image $ \ctx -> 
+    let (a,_) = getImage ma ctx in (a,mempty)
+  
+hyperlinkImage :: XLink -> Image u a -> Image u a
+hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)
+  where
+    step (a,w) = (a, cpmap (xlinkPrim xl) w)
+
+svgIdImage :: String -> Image u a -> Image u a
+svgIdImage ss ma = Image $ \ctx -> step (getImage ma ctx)
+  where
+    step (a,w) = (a, cpmap (xidPrim ss) w)
+
+svgAnnotateImage :: [SvgAttr] -> Image u a -> Image u a
+svgAnnotateImage attrs ma = Image $ \ctx -> step (getImage ma ctx)
+  where
+    step (a,w) = (a, cpmap (annotateGroup attrs) w)
+
+
+--------------------------------------------------------------------------------
+-- Affine instances 
+
+-- 
+-- Design Note
+--
+-- Are PrimW instances needed as Image cannot use them?
+-- 
+
+instance Rotate a => Rotate (Image u a) where
+  rotate ang ma = Image $ \ctx -> 
+      let (a,w) = getImage ma ctx
+      in (rotate ang a, rotate ang w)
+
+instance (RotateAbout a, InterpretUnit u, u ~ DUnit a) => 
+    RotateAbout (Image u a) where
+  rotateAbout ang pt ma = Image $ \ctx -> 
+      let ptu   = uconvertF (dc_font_size ctx) pt
+          (a,w) = getImage ma ctx
+      in (rotateAbout ang pt a, rotateAbout ang ptu w)
+
+
+instance Scale a => Scale (Image u a) where
+  scale sx sy ma = Image $ \ctx -> 
+      let (a,w) = getImage ma ctx
+      in (scale sx sy a, scale sx sy w)
+
+
+instance (Translate a, InterpretUnit u, u ~ DUnit a) => 
+    Translate (Image u a) where
+  translate dx dy ma = Image $ \ctx -> 
+      let sz    = dc_font_size ctx
+          ddx   = uconvert1 sz dx
+          ddy   = uconvert1 sz dy
+          (a,w) = getImage ma ctx
+      in (translate dx dy a, translate ddx ddy w)
+
+
+
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/LocImage.hs b/src/Wumpus/Basic/Kernel/Objects/LocImage.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/LocImage.hs
@@ -0,0 +1,357 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.LocImage
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- LocImage and LocGraphic types - these are functional types from the 
+-- DrawingContext and start point to a graphic /primitive/.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.LocImage
+   (
+
+     LocImage
+   , LocGraphic
+
+   , DLocImage
+   , DLocGraphic
+
+   , LocQuery
+
+   , runLocImage
+   , runLocQuery
+
+   , stripLocImage
+   , liftLocQuery
+
+   , promoteLoc
+   , applyLoc
+   , supplyLoc
+   , qpromoteLoc
+   , qapplyLoc
+
+   , emptyLocImage
+
+   , moveStart
+   , at
+
+   -- * Composing LocImages
+   , distrib
+   , distribH 
+   , distribV
+   
+   , duplicate
+   , duplicateH
+   , duplicateV
+
+
+   )
+
+   where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Image
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Control.Applicative
+import Data.Monoid
+
+
+
+-- | 'LocThetaImage' - function from  start point and 
+-- DrawingContext to a polymorphic /answer/ and a graphic 
+-- /primitive/ (PrimW).
+--
+newtype LocImage u a = LocImage { 
+          getLocImage :: DPoint2 -> Image u a }
+
+type instance DUnit (LocImage u a) = u
+
+type LocGraphic u = LocImage u (UNil u)
+
+
+-- | Type specialized version of 'LocImage'.
+--
+type DLocImage a        = LocImage Double a
+
+-- | Type specialized version of 'LocGraphic'.
+--
+type DLocGraphic        = LocGraphic Double 
+
+newtype LocQuery u a = LocQuery { 
+          getLocQuery :: DPoint2 -> Query u a }
+
+-- Functor
+
+instance Functor (LocImage u) where
+  fmap f ma = LocImage $ \pt -> fmap f $ getLocImage ma pt
+
+
+instance Functor (LocQuery u) where
+  fmap f ma = LocQuery $ \pt -> fmap f $ getLocQuery ma pt
+
+-- Applicative
+
+instance Applicative (LocImage u) where
+  pure a    = LocImage $ \_  -> pure a
+  mf <*> ma = LocImage $ \pt -> getLocImage mf pt <*> getLocImage ma pt
+
+instance Applicative (LocQuery u) where
+  pure a    = LocQuery $ \_  -> pure a
+  mf <*> ma = LocQuery $ \pt -> getLocQuery mf pt <*> getLocQuery ma pt
+                                
+
+
+-- Monad
+
+instance Monad (LocImage u) where
+  return a  = LocImage $ \_  -> return a
+  ma >>= k  = LocImage $ \pt -> getLocImage ma pt >>= \ans -> 
+                                  getLocImage (k ans) pt
+
+
+instance Monad (LocQuery u) where
+  return a  = LocQuery $ \_  -> return a
+  ma >>= k  = LocQuery $ \pt -> getLocQuery ma pt >>= \ans -> 
+                                  getLocQuery (k ans) pt
+
+
+-- Monoid
+
+instance Monoid a => Monoid (LocImage u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocImage $ \pt -> 
+                      getLocImage ma pt `mappend` getLocImage mb pt 
+
+instance Monoid a => Monoid (LocQuery u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocQuery $ \pt -> 
+                      getLocQuery ma pt `mappend` getLocQuery mb pt 
+
+-- DrawingCtxM
+
+instance DrawingCtxM (LocImage u) where
+  askDC           = LocImage $ \_  -> askDC
+  asksDC fn       = LocImage $ \_  -> asksDC fn
+  localize upd ma = LocImage $ \pt -> localize upd (getLocImage ma pt)
+
+instance DrawingCtxM (LocQuery u) where
+  askDC           = LocQuery $ \_  -> askDC
+  asksDC fn       = LocQuery $ \_  -> asksDC fn
+  localize upd ma = LocQuery $ \pt -> localize upd (getLocQuery ma pt)
+
+
+
+  
+instance Decorate LocImage where
+  decorate zo ma mz = LocImage $ \pt -> 
+    decorate zo (getLocImage ma pt) (getLocImage mz pt)
+
+  elaborate zo ma f = LocImage $ \pt -> 
+    elaborate zo (getLocImage ma pt) (\a -> getLocImage (f a) pt)
+
+  obliterate ma = LocImage $ \pt -> obliterate $ getLocImage ma pt 
+
+  hyperlink xl ma = LocImage $ \pt -> hyperlink xl $ getLocImage ma pt 
+
+  svgId ss ma = LocImage $ \pt -> svgId ss $ getLocImage ma pt 
+
+  svgAnnotate attrs ma = LocImage $ \pt -> svgAnnotate attrs $ getLocImage ma pt
+
+
+runLocImage :: InterpretUnit u 
+            => DrawingContext -> Point2 u -> LocImage u a -> PrimResult u a
+runLocImage ctx pt ma = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runImage ctx $ getLocImage ma dpt
+
+runLocQuery :: InterpretUnit u 
+            => DrawingContext -> Point2 u -> LocQuery u a -> a
+runLocQuery ctx pt ma = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runQuery ctx $ getLocQuery ma dpt
+
+
+stripLocImage :: LocImage u a -> LocQuery u a
+stripLocImage ma = LocQuery $ \pt -> 
+    stripImage $ getLocImage ma pt
+
+
+liftLocQuery :: LocQuery u a -> LocImage u a
+liftLocQuery ma = LocImage $ \pt -> 
+    liftQuery $ getLocQuery ma pt
+
+
+promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a
+promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= k 
+
+applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
+applyLoc ma pt = normalizeCtxF pt >>= getLocImage ma
+
+
+-- | Flipped version of 'applyLoc'. 
+-- 
+supplyLoc :: InterpretUnit u => Point2 u -> LocImage u a -> Image u a
+supplyLoc = flip at
+
+
+qpromoteLoc :: InterpretUnit u 
+            => (Point2 u -> Query u a) -> LocQuery u a
+qpromoteLoc k = LocQuery $ \pt -> dinterpCtxF pt >>= k
+
+qapplyLoc :: InterpretUnit u
+          => LocQuery u a -> Point2 u -> Query u a
+qapplyLoc ma pt = normalizeCtxF pt >>= getLocQuery ma
+
+
+
+--------------------------------------------------------------------------------
+-- Affine instances
+
+instance (Real u, Floating u, InterpretUnit u, Rotate a) => 
+    Rotate (LocImage u a) where
+  rotate ang ma = promoteLoc $ \pt -> 
+      normalizeCtxF pt >>= \dpt ->  
+      fmap (rotate ang) $ getLocImage ma (rotate ang dpt)
+
+
+instance (Real u, Floating u, InterpretUnit u, RotateAbout a, u ~ DUnit a) => 
+    RotateAbout (LocImage u a) where
+  rotateAbout ang pt ma = promoteLoc $ \p0 ->
+      normalizeCtxF p0 >>= \dp0 ->  
+      normalizeCtxF pt >>= \dpt ->  
+      fmap (rotateAbout ang pt) $ 
+          getLocImage ma (rotateAbout ang dpt dp0)
+
+
+instance (Fractional u, InterpretUnit u, Scale a) => Scale (LocImage u a) where
+  scale sx sy ma = promoteLoc $ \pt -> 
+      normalizeCtxF pt >>= \dpt -> 
+      fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)
+
+instance (InterpretUnit u, Translate a, ScalarUnit u, u ~ DUnit a) => 
+    Translate (LocImage u a) where
+  translate dx dy ma = promoteLoc $ \pt -> 
+      normalizeCtxF pt >>= \dpt -> 
+      normalizeCtx dx  >>= \ddx ->
+      normalizeCtx dy  >>= \ddy ->
+      translate dx dy $ getLocImage ma (translate ddx ddy dpt)
+
+--------------------------------------------------------------------------------
+
+
+instance UConvert LocImage where
+  uconvF = uconvLocImageF
+  uconvZ = uconvLocImageZ
+
+-- | Use this to convert 'LocGraphic' or 'LocImage' with Functor 
+-- answer.
+--
+uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
+               => LocImage u (t u) -> LocImage u1 (t u1)
+uconvLocImageF ma = LocImage $ \pt -> uconvF $ getLocImage ma pt
+
+
+
+-- | Use this to convert 'LocImage' with unit-less answer.
+--
+uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1) 
+               => LocImage u a -> LocImage u1 a
+uconvLocImageZ ma = LocImage $ \pt -> uconvZ $ getLocImage ma pt
+
+
+-- | Having /empty/ at the specific 'LocImage' type is useful.
+-- 
+emptyLocImage :: Monoid a => LocImage u a
+emptyLocImage = mempty
+
+
+
+
+-- Note - maybe this should just be an operator on LocImage...
+--
+
+moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a
+moveStart v1 ma = LocImage $ \pt -> 
+    normalizeCtxF v1 >>= \dv -> getLocImage ma (pt .+^ dv) 
+
+
+
+infixr 1 `at`
+
+-- | Downcast a 'LocImage' function by applying it to the supplied 
+-- point, making an 'Image'. 
+-- 
+-- > infixr 1 `at`
+-- 
+at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
+at = applyLoc
+
+
+
+--------------------------------------------------------------------------------
+-- Combining LocImages 
+
+-- LocImages have no concept of /border/ or /next/, so they can 
+-- only be combined by manipulating the start point of successive
+-- drawings.
+
+-- 'oplus' gives super-imposition - Locimages are drawn at the same
+-- start point.
+
+
+
+distrib :: (Monoid a, InterpretUnit u) 
+        => Vec2 u -> [LocImage u a]  -> LocImage u a
+distrib _  []     = mempty
+distrib v1 (x:xs) = promoteLoc $ \pt -> 
+    go (applyLoc x pt) (pt .+^ v1) xs
+  where
+    go acc _  []     = acc
+    go acc pt (a:as) = go (acc `mappend` applyLoc a pt) (pt .+^ v1) as
+
+distribH :: (Monoid a, InterpretUnit u) 
+         => u -> [LocImage u a]  -> LocImage u a
+distribH dx = distrib (hvec dx)
+
+distribV :: (Monoid a, InterpretUnit u) 
+         => u -> [LocImage u a]  -> LocImage u a
+distribV dy = distrib (hvec dy)
+
+
+-- | This is analogue to @replicate@ in the Prelude.
+--
+duplicate :: (Monoid a, InterpretUnit u) 
+          => Int -> Vec2 u -> LocImage u a -> LocImage u a
+duplicate n _ _   | n < 1 = mempty
+duplicate n v img         = go img v (n-1)
+  where
+     go acc _  i | i < 1 = acc
+     go acc v1 i         = let img1 = moveStart v1 img
+                           in go (acc `mappend` img1) (v1 ^+^ v) (i-1)
+
+duplicateH :: (Monoid a, InterpretUnit u) 
+           => Int -> u -> LocImage u a -> LocImage u a
+duplicateH n dx = duplicate n (hvec dx)
+
+duplicateV :: (Monoid a, InterpretUnit u) 
+           => Int -> u -> LocImage u a -> LocImage u a
+duplicateV n dy = duplicate n (vvec dy)
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
@@ -0,0 +1,294 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.LocThetaImage
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- LocThetaImage and LocThetaGraphic types - these are functional 
+-- types from the DrawingContext, start point and angle of 
+-- inclination to a graphic /primitive/.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.LocThetaImage
+   (
+     LocThetaGraphic
+   , LocThetaImage
+
+   , DLocThetaGraphic
+   , DLocThetaImage
+
+   , LocThetaQuery
+
+   , runLocThetaImage
+   , runLocThetaQuery
+
+   , stripLocThetaImage
+   , liftLocThetaQuery
+   
+   , promoteLocTheta
+   , applyLocTheta
+   , supplyLocTheta
+   , qpromoteLocTheta
+   , qapplyLocTheta
+
+   , emptyLocThetaImage
+
+   , incline
+   , atIncline
+   , supplyIncline
+   
+   )
+
+   where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Objects.Basis
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+import Data.Monoid
+
+-- | 'LocThetaImage' - function from start point, inclination and
+-- DrawingContext to a polymorphic /answer/ and a graphic 
+-- /primitive/ (PrimW).
+--
+newtype LocThetaImage u a = LocThetaImage { 
+          getLocThetaImage :: DPoint2 -> Radian -> Image u a }
+
+type instance DUnit (LocThetaImage u a) = u
+
+type LocThetaGraphic u = LocThetaImage u (UNil u)
+
+
+-- | Type specialized version of 'LocThetaImage'.
+--
+type DLocThetaImage a        = LocThetaImage Double a
+
+-- | Type specialized version of 'LocThetaGraphic'.
+--
+type DLocThetaGraphic        = LocThetaGraphic Double 
+
+
+newtype LocThetaQuery u a = LocThetaQuery { 
+          getLocThetaQuery :: DPoint2 -> Radian -> Query u a }
+
+-- Functor
+
+instance Functor (LocThetaImage u) where
+  fmap f ma = LocThetaImage $ \pt ang -> 
+                fmap f $ getLocThetaImage ma pt ang
+
+instance Functor (LocThetaQuery u) where
+  fmap f ma = LocThetaQuery $ \pt ang -> 
+                fmap f $ getLocThetaQuery ma pt ang
+
+
+-- Applicative
+
+instance Applicative (LocThetaImage u) where
+  pure a    = LocThetaImage $ \_  _   -> pure a
+  mf <*> ma = LocThetaImage $ \pt ang -> 
+                getLocThetaImage mf pt ang <*> getLocThetaImage ma pt ang
+
+instance Applicative (LocThetaQuery u) where
+  pure a    = LocThetaQuery $ \_  _   -> pure a
+  mf <*> ma = LocThetaQuery $ \pt ang -> 
+                getLocThetaQuery mf pt ang <*> getLocThetaQuery ma pt ang
+
+
+-- Monad 
+
+instance Monad (LocThetaImage u) where
+  return a  = LocThetaImage $ \_  _   -> return a
+  ma >>= k  = LocThetaImage $ \pt ang -> 
+                getLocThetaImage ma pt ang >>= \ans -> 
+                getLocThetaImage (k ans) pt ang
+
+
+instance Monad (LocThetaQuery u) where
+  return a  = LocThetaQuery $ \_  _   -> return a
+  ma >>= k  = LocThetaQuery $ \pt ang -> 
+                getLocThetaQuery ma pt ang >>= \ans -> 
+                getLocThetaQuery (k ans) pt ang
+
+-- Monoid
+
+instance Monoid a => Monoid (LocThetaImage u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocThetaImage $ \pt ang -> 
+                      getLocThetaImage ma pt ang 
+                         `mappend` getLocThetaImage mb pt ang
+
+
+
+instance Monoid a => Monoid (LocThetaQuery u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocThetaQuery $ \pt ang -> 
+                      getLocThetaQuery ma pt ang 
+                         `mappend` getLocThetaQuery mb pt ang
+
+-- DrawingCtxM
+
+instance DrawingCtxM (LocThetaImage u) where
+  askDC           = LocThetaImage $ \_  _   -> askDC
+  asksDC fn       = LocThetaImage $ \_  _   -> asksDC fn
+  localize upd ma = LocThetaImage $ \pt ang -> 
+                      localize upd (getLocThetaImage ma pt ang)
+
+instance DrawingCtxM (LocThetaQuery u) where
+  askDC           = LocThetaQuery $ \_  _   -> askDC
+  asksDC fn       = LocThetaQuery $ \_  _   -> asksDC fn
+  localize upd ma = LocThetaQuery $ \pt ang -> 
+                      localize upd (getLocThetaQuery ma pt ang)
+
+--
+
+instance Decorate LocThetaImage where
+  decorate zo ma mz     = LocThetaImage $ \pt ang -> 
+    decorate zo (getLocThetaImage ma pt ang) (getLocThetaImage mz pt ang)
+
+  elaborate zo ma f     = LocThetaImage $ \pt ang -> 
+    elaborate zo (getLocThetaImage ma pt ang) 
+                 (\a -> getLocThetaImage (f a) pt ang)
+
+  obliterate ma         = LocThetaImage $ \pt ang -> 
+    obliterate $ getLocThetaImage ma pt ang
+
+  hyperlink xl ma       = LocThetaImage $ \pt ang -> 
+    hyperlink xl $ getLocThetaImage ma pt ang
+
+  svgId ss ma           = LocThetaImage $ \pt ang -> 
+    svgId ss $ getLocThetaImage ma pt ang
+
+  svgAnnotate attrs ma  = LocThetaImage $ \pt ang -> 
+    svgAnnotate attrs $ getLocThetaImage ma pt ang
+           
+
+
+
+runLocThetaImage :: InterpretUnit u 
+                 => DrawingContext -> Point2 u -> Radian
+                 -> LocThetaImage u a 
+                 -> PrimResult u a
+runLocThetaImage ctx pt incl ma = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runImage ctx $ getLocThetaImage ma dpt incl
+
+
+runLocThetaQuery :: InterpretUnit u 
+                 => DrawingContext -> Point2 u -> Radian  
+                 -> LocThetaQuery u a 
+                 -> a
+runLocThetaQuery ctx pt incl ma = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runQuery ctx $ getLocThetaQuery ma dpt incl
+
+
+
+stripLocThetaImage :: LocThetaImage u a -> LocThetaQuery u a
+stripLocThetaImage ma = LocThetaQuery $ \pt ang -> 
+    stripImage $ getLocThetaImage ma pt ang
+
+
+liftLocThetaQuery :: LocThetaQuery u a -> LocThetaImage u a
+liftLocThetaQuery ma = LocThetaImage $ \pt ang -> 
+    liftQuery $ getLocThetaQuery ma pt ang
+
+
+
+
+promoteLocTheta ::  InterpretUnit u 
+                => (Point2 u -> Radian -> Image u a) -> LocThetaImage u a
+promoteLocTheta k = LocThetaImage $ \pt ang -> 
+    dinterpCtxF pt >>= \upt -> k upt ang
+
+applyLocTheta :: InterpretUnit u 
+              => LocThetaImage u a -> Point2 u -> Radian -> Image u a
+applyLocTheta ma pt ang = 
+    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt ang
+
+supplyLocTheta :: InterpretUnit u 
+               => Point2 u -> Radian -> LocThetaImage u a -> Image u a
+supplyLocTheta pt ang ma = applyLocTheta ma pt ang
+
+
+qpromoteLocTheta :: InterpretUnit u 
+                 => (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a
+qpromoteLocTheta k = LocThetaQuery $ \pt ang ->
+    dinterpCtxF pt >>= \upt -> k upt ang
+
+
+qapplyLocTheta :: InterpretUnit u
+               => LocThetaQuery u a -> Point2 u -> Radian -> Query u a
+qapplyLocTheta ma pt ang = 
+    normalizeCtxF pt >>= \dpt -> getLocThetaQuery ma dpt ang
+
+
+
+
+instance UConvert LocThetaImage where
+  uconvF = uconvLocThetaImageF
+  uconvZ = uconvLocThetaImageZ
+
+
+-- | Use this to convert 'LocThetaThetaGraphic' or 'LocThetaThetaImage' 
+-- with Functor answer.
+--
+uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
+                    => LocThetaImage u (t u) -> LocThetaImage u1 (t u1)
+uconvLocThetaImageF ma = LocThetaImage $ \pt ang -> 
+    uconvF $ getLocThetaImage ma pt ang
+
+
+
+
+-- | Use this to convert 'LocThetaImage' with unit-less answer.
+--
+uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) 
+                    => LocThetaImage u a -> LocThetaImage u1 a
+uconvLocThetaImageZ ma = LocThetaImage $ \pt ang -> 
+    uconvZ $ getLocThetaImage ma pt ang
+
+
+
+-- | Having /empty/ at the specific 'LocThetaImage' type is useful.
+-- 
+emptyLocThetaImage :: Monoid a => LocThetaImage u a
+emptyLocThetaImage = mempty
+
+
+
+
+
+infixr 1 `incline`
+
+
+-- | Downcast a 'LocThetaImage' function by applying it to the 
+-- supplied angle, making a 'LocImage'. 
+-- 
+incline :: InterpretUnit u => LocThetaImage u a -> Radian -> LocImage u a
+incline ma incl = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl
+
+atIncline :: InterpretUnit u 
+          => LocThetaImage u a -> Point2 u -> Radian -> Image u a
+atIncline = applyLocTheta
+
+
+-- | Flipped version of 'incline'
+--
+supplyIncline :: InterpretUnit u => Radian -> LocThetaImage u a -> LocImage u a
+supplyIncline = flip incline
diff --git a/src/Wumpus/Basic/Kernel/Objects/Orientation.hs b/src/Wumpus/Basic/Kernel/Objects/Orientation.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Orientation.hs
@@ -0,0 +1,564 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Orientation
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Graphic objects RectAddress and Orientation to model 
+-- rectangular positioning.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Orientation
+  (
+
+
+  -- * Components
+    RectAddress(..)
+  , Orientation(..)
+
+  , vtoRectAddress
+  , vtoOrigin
+  , orientationBounds
+  , orientationWidth
+  , orientationHeight
+
+  , rotateOrientation
+ 
+  , extendOrientation
+  , extendOLeft
+  , extendORight
+  , extendODown
+  , extendOUp
+
+  , fillHEven
+  , fillXMinor
+  , fillXMajor
+  , fillVEven
+  , fillYMajor
+  , fillYMinor
+
+  , spineRight
+  , spineBelow
+
+  , halignBottomO
+  , halignCenterO
+  , halignTopO
+  , valignLeftO
+  , valignCenterO
+  , valignRightO
+
+  , spinemoveH
+  , spinemoveV
+  , binmoveHBottom
+  , binmoveHCenter
+  , binmoveHTop
+  , binmoveVLeft
+  , binmoveVCenter
+  , binmoveVRight
+
+  ) where
+
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.VectorSpace                         -- package: vector-space
+
+import Data.Monoid
+
+-- | Datatype enumerating the addressable positions of a rectangle 
+-- that can be derived for a 'PosObject'.  
+--
+-- The positions are the compass points, plus the geometric 
+-- center, origin and the baseline positions: 
+-- 
+-- > BLL - baseline-left
+--
+-- > BLC - baseline-center 
+-- 
+-- > BLR - baseline-right
+--
+data RectAddress = CENTER | ORIGIN
+                 | NN | SS | EE | WW | NE | NW | SE | SW 
+                 | BLL | BLC | BLR
+  deriving (Enum,Eq,Ord,Show)
+
+
+
+
+-- | Utility datatype representing orientation within a 
+-- rectangular /frame/. RectPos 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 Orientation u = Orientation
+      { or_x_minor      :: !u
+      , or_x_major      :: !u
+      , or_y_minor      :: !u
+      , or_y_major      :: !u
+      }
+  deriving (Eq,Ord,Show)
+
+
+
+
+--------------------------------------------------------------------------------
+
+instance Functor Orientation where
+  fmap f (Orientation xmin xmaj ymin ymaj) = 
+    Orientation (f xmin) (f xmaj) (f ymin) (f ymaj)
+
+
+-- | Concatenation coalesces the origins.
+--
+instance (Fractional u, Ord u) => Monoid (Orientation u) where
+  mempty  = Orientation 0 0 0 0
+  a `mappend` b = 
+     Orientation { or_x_minor = max (or_x_minor a) (or_x_minor b)
+                 , or_x_major = max (or_x_major a) (or_x_major b)
+                 , or_y_minor = max (or_y_minor a) (or_y_minor b)
+                 , or_y_major = max (or_y_major a) (or_y_major b)
+                 }
+
+
+-- Helper types for calculating vector from Origin 
+-- (not exported).
+
+data HDist = HCENTER | HLEFT | HRIGHT
+  deriving (Eq,Ord,Show)
+
+data VDist = VCENTER | VBASE | VTOP
+  deriving (Eq,Ord,Show)
+
+
+
+-- | The vector from a origin ro a 'RectAddress'.
+--
+vtoRectAddress :: (Fractional u, Ord u) 
+               => Orientation u -> RectAddress -> Vec2 u
+vtoRectAddress (Orientation xmin xmaj ymin ymaj) = go
+  where
+    hw        = 0.5  * (xmin + xmaj)
+    hh        = 0.5  * (ymin + ymaj)
+   
+    -- CENTER, NN, SS, EE, WW all go to bottomleft then add back 
+    -- the minors.
+
+    go CENTER = V2 (hdist HCENTER) (vdist VCENTER)
+    go ORIGIN = zeroVec
+    go NN     = V2 (hdist HCENTER) (vdist VTOP)
+    go SS     = V2 (hdist HCENTER) (vdist VBASE)
+    go EE     = V2 (hdist HRIGHT)  (vdist VCENTER)
+    go WW     = V2 (hdist HLEFT)   (vdist VCENTER)
+    go NE     = V2 (hdist HRIGHT)  (vdist VTOP)
+    go SE     = V2 (hdist HRIGHT)  (vdist VBASE)
+    go SW     = V2 (hdist HLEFT)   (vdist VBASE)
+    go NW     = V2 (hdist HLEFT)   (vdist VTOP)
+    go BLL    = V2 (hdist HLEFT)   0
+    go BLC    = V2 (hdist HCENTER) 0
+    go BLR    = V2 (hdist HRIGHT)  0 
+
+    -- > [..o..^.....]  , o -> ^
+    --
+    hdist HCENTER = if xmin < xmaj then hw - xmin else negate (xmin - hw)
+
+    -- > [..o..^.....]  , o -> [
+    --
+    hdist HLEFT   = negate xmin
+    
+    -- > [..o..^.....]  , o -> ]
+    --
+    hdist HRIGHT  = xmaj
+
+    vdist VCENTER = if ymin < ymaj then hh - ymin else negate (ymin - hh)
+    vdist VBASE   = negate ymin
+    vdist VTOP    = ymaj
+
+
+vtoOrigin :: (Fractional u, Ord u) 
+          => RectAddress -> Orientation u -> Vec2 u
+vtoOrigin addr ortt = negateV $ vtoRectAddress ortt addr
+
+-- | Calculate the bounding box formed by locating the 'Orientation'
+-- at the supplied point.
+-- 
+orientationBounds :: Num u 
+                  => Orientation u -> Point2 u -> BoundingBox u
+orientationBounds (Orientation xmin xmaj ymin ymaj) (P2 x y) = BBox llc urc
+  where
+    llc   = P2 (x-xmin) (y-ymin)
+    urc   = P2 (x+xmaj) (y+ymaj)
+
+
+-- | Height of the orientation.
+--
+orientationWidth :: Num u => Orientation u -> u
+orientationWidth (Orientation xmin xmaj _ _) = xmin + xmaj
+
+-- | Height of the orientation.
+--
+orientationHeight :: Num u => Orientation u -> u
+orientationHeight (Orientation _ _ ymin ymaj) = ymin + ymaj
+
+--------------------------------------------------------------------------------
+-- Rotation
+
+-- | Rotate an Orientation about its origin (locus).
+--
+rotateOrientation :: (Real u, Floating u, Ord u) 
+               => Radian -> Orientation u -> Orientation u
+rotateOrientation ang (Orientation { or_x_minor = xmin
+                                   , or_x_major = xmaj
+                                   , or_y_minor = ymin
+                                   , or_y_major = ymaj }) = 
+    orthoOrientation bl br tl tr  
+  where
+    bl  = rotateAbout ang zeroPt $ P2 (-xmin) (-ymin)
+    br  = rotateAbout ang zeroPt $ P2   xmaj  (-ymin)
+    tr  = rotateAbout ang zeroPt $ P2   xmaj    ymaj
+    tl  = rotateAbout ang zeroPt $ P2 (-xmin)   ymaj
+  
+
+orthoOrientation :: (Num u, Ord u)
+                 => Point2 u -> Point2 u -> Point2 u -> Point2 u 
+                 -> Orientation u
+orthoOrientation (P2 x0 y0) (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = 
+    Orientation { or_x_minor = abs $ min4 x0 x1 x2 x3
+                , or_x_major = max4 x0 x1 x2 x3
+                , or_y_minor = abs $ min4 y0 y1 y2 y3
+                , or_y_major = max4 y0 y1 y2 y3
+                }
+
+
+min4 :: Ord u => u -> u -> u -> u -> u
+min4 a b c d = min (min a b) (min c d)
+
+max4 :: Ord u => u -> u -> u -> u -> u
+max4 a b c d = max (max a b) (max c d)
+
+
+--------------------------------------------------------------------------------
+-- Extending an arm of the orientation
+
+extendOrientation :: Num u 
+                  => u -> u -> u -> u -> Orientation u -> Orientation u
+extendOrientation dxl dxr dyd dyu (Orientation xmin xmaj ymin ymaj) = 
+    Orientation (xmin+dxl) (xmaj+dxr) (ymin+dyd) (ymaj+dyu)
+
+extendOLeft :: Num u => u -> Orientation u -> Orientation u
+extendOLeft u (Orientation xmin xmaj ymin ymaj) = 
+    Orientation (u+xmin) xmaj ymin ymaj
+
+
+extendORight :: Num u => u -> Orientation u -> Orientation u
+extendORight u (Orientation xmin xmaj ymin ymaj) = 
+    Orientation xmin (u+xmaj) ymin ymaj
+
+extendODown :: Num u => u -> Orientation u -> Orientation u
+extendODown u (Orientation xmin xmaj ymin ymaj) = 
+    Orientation xmin xmaj (u+ymin) ymaj
+
+extendOUp :: Num u => u -> Orientation u -> Orientation u
+extendOUp u (Orientation xmin xmaj ymin ymaj) = 
+    Orientation xmin xmaj ymin (u+ymaj)
+
+
+--------------------------------------------------------------------------------
+-- Note these are fills not pads...
+
+
+fillHEven :: (Fractional u, Ord u) 
+          => u -> Orientation u -> Orientation u
+fillHEven w ortt@(Orientation xmin xmaj _ _) = 
+    if w > ow then ortt { or_x_minor = xmin + hdx
+                        , or_x_major = xmaj + hdx } 
+              else ortt
+  where
+    ow = xmin + xmaj
+    hdx = 0.5 * (w - ow)
+
+
+fillXMinor :: (Num u, Ord u) 
+          => u -> Orientation u -> Orientation u
+fillXMinor w ortt@(Orientation xmin xmaj _ _) = 
+    if w > ow then ortt { or_x_minor = xmin + dx } else ortt
+  where
+    ow = xmin + xmaj
+    dx = w - ow
+
+fillXMajor :: (Num u, Ord u)
+         => u -> Orientation u -> Orientation u
+fillXMajor w ortt@(Orientation xmin xmaj _ _) = 
+    if w > ow then ortt { or_x_major = xmaj + dx } else ortt
+  where
+    ow = xmin + xmaj
+    dx = w - ow
+
+fillVEven :: (Fractional u, Ord u) 
+          => u -> Orientation u -> Orientation u
+fillVEven h ortt@(Orientation _ _ ymin ymaj) = 
+    if h > oh then ortt { or_y_minor = ymin + hdy
+                        , or_y_major = ymaj + hdy } 
+              else ortt
+  where
+    oh = ymin + ymaj
+    hdy = 0.5 * (h - oh)
+
+fillYMinor :: (Num u, Ord u) 
+         => u -> Orientation u -> Orientation u
+fillYMinor h ortt@(Orientation _ _ ymin ymaj) = 
+    if h > oh then ortt { or_y_minor = ymin + dy } else ortt
+  where
+    oh = ymin + ymaj
+    dy = h - oh
+
+
+fillYMajor :: (Num u, Ord u) 
+       => u -> Orientation u -> Orientation u
+fillYMajor h ortt@(Orientation _ _ ymin ymaj) = 
+    if h > oh then ortt { or_y_major = ymaj + dy } else ortt
+  where
+    oh = ymin + ymaj
+    dy = h - oh
+
+
+--------------------------------------------------------------------------------
+-- Combining Orientation
+
+-- Note - there are lots of concatenations (due to alignment) 
+-- we need a consistent name scheme...
+
+
+-- | Second Orientation is moved /to the right/ of the first along
+-- the /spine/ i.e the baseline.
+--
+spineRight :: (Num u, Ord u) 
+            => Orientation u -> Orientation u -> Orientation u
+spineRight (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+           (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    Orientation { or_x_minor = xmin0
+                , or_x_major = xmaj0 + xmin1 + xmaj1 
+                , or_y_minor = max ymin0 ymin1
+                , or_y_major = max ymaj0 ymaj1
+                }
+
+
+-- | Second Orientation is moved /below/ the first along the spine
+-- i.e. the vertical point between the left minor and right major
+-- (not the same as the horizontal center).
+--
+spineBelow :: (Num u, Ord u) 
+           => Orientation u -> Orientation u -> Orientation u
+spineBelow (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+           (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    Orientation { or_x_minor = max xmin0 xmin1
+                , or_x_major = max xmaj0 xmaj1
+                , or_y_minor = ymin0 + ymaj1 + ymin1
+                , or_y_major = ymaj0
+                }
+
+
+-- | xmin and xmaj same as left.
+--
+halignBottomO :: (Num u, Ord u) 
+            => Orientation u -> Orientation u -> Orientation u
+halignBottomO (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+              (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    let hr = ymin1 + ymaj1
+    in Orientation { or_x_minor = xmin0
+                   , or_x_major = xmaj0 + xmin1 + xmaj1
+                   , or_y_minor = ymin0
+                   , or_y_major = max ymaj0 (hr - ymin0)
+                   }
+
+
+
+
+
+-- | xmin same as left.
+--
+halignCenterO :: (Fractional u, Ord u) 
+              => Orientation u -> Orientation u -> Orientation u
+halignCenterO (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+             (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    let hl         = ymin0 + ymaj0
+        hr         = ymin1 + ymaj1
+        half_diff  = 0.5 * (hr - hl)
+    in Orientation 
+          { or_x_minor = xmin0
+          , or_x_major = xmaj0 + xmin1 + xmaj1
+          , or_y_minor = if hl >= hr then ymin0 else (ymin0 + half_diff)
+          , or_y_major = if hl >= hr then ymaj0 else (ymaj0 + half_diff)
+          }
+
+
+
+-- | xmin and ymaj same as left.
+--
+halignTopO :: (Num u, Ord u) 
+           => Orientation u -> Orientation u -> Orientation u
+halignTopO (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+           (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    let hr = ymin1 + ymaj1
+    in Orientation { or_x_minor = xmin0
+                   , or_x_major = xmaj0 + xmin1 + xmaj1
+                   , or_y_minor = max ymin0 (hr - ymaj0)
+                   , or_y_major = ymaj0
+                   }
+
+-- | Align second below - xmin and ymaj are same as left.
+--
+valignLeftO :: (Fractional u, Ord u) 
+            => Orientation u -> Orientation u -> Orientation u
+valignLeftO (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+            (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    let wr = xmin1 + xmaj1
+    in Orientation { or_x_minor = xmin0
+                   , or_x_major = max xmaj0 (wr - xmin0)
+                   , or_y_minor = ymin0 + ymin1 + ymaj1
+                   , or_y_major = ymaj0
+                   }
+
+
+
+-- | Align second below - ymaj same as left.
+--
+valignCenterO :: (Fractional u, Ord u) 
+             => Orientation u -> Orientation u -> Orientation u
+valignCenterO (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+              (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    let wl         = xmin0 + xmaj0
+        wr         = xmin1 + xmaj1
+        half_diff  = 0.5 * (wr - wl)
+    in Orientation 
+          { or_x_minor = if wl >= wr then xmin0 else (xmin0 + half_diff)
+          , or_x_major = if wl >= wr then xmaj0 else (xmaj0 + half_diff)
+          , or_y_minor = ymin0 + ymin1 + ymaj1
+          , or_y_major = ymaj0 
+          }
+
+
+-- | Align second below - xmaj and ymaj are same as left.
+--
+valignRightO :: (Fractional u, Ord u) 
+             => Orientation u -> Orientation u -> Orientation u
+valignRightO (Orientation xmin0 xmaj0 ymin0 ymaj0) 
+             (Orientation xmin1 xmaj1 ymin1 ymaj1) = 
+    let wr = xmin1 + xmaj1
+    in Orientation { or_x_minor = max xmin0 (wr - xmaj0)
+                   , or_x_major = xmaj0 
+                   , or_y_minor = ymin0 + ymin1 + ymaj1
+                   , or_y_major = ymaj0 
+                   }
+
+
+--------------------------------------------------------------------------------
+-- Binary start pos displacement
+
+-- Note - these can be made a lot clearer...
+
+upDown :: Num u => u -> u -> u
+upDown u d = u - d
+
+downUp :: Num u => u -> u -> u
+downUp d u = negate d + u
+
+-- | Move second right.
+--
+spinemoveH :: Num u => Orientation u -> Orientation u -> Vec2 u
+spinemoveH op0 op1 = V2 hdist 0
+  where
+    hdist = or_x_major op0 + or_x_minor op1
+
+-- | Move second below.
+--
+spinemoveV :: Num u => Orientation u -> Orientation u -> Vec2 u
+spinemoveV op0 op1 = V2 0 (negate vdist)
+  where
+    vdist = or_y_minor op0 + or_y_major op1
+   
+
+
+binmoveHBottom :: Num u => Orientation u -> Orientation u -> Vec2 u
+binmoveHBottom op0 op1 = V2 hdist vdist
+  where
+    hdist = or_x_major op0 + or_x_minor op1
+    vdist = downUp (or_y_minor op0) (or_y_minor op1)
+   
+
+binmoveHCenter :: (Fractional u, Ord u) 
+               => Orientation u -> Orientation u -> Vec2 u
+binmoveHCenter (Orientation _     xmaj0 ymin0 ymaj0) 
+               (Orientation xmin1 _     ymin1 ymaj1) = 
+    V2 hdist vdist
+  where
+    h0        = ymin0 + ymaj0
+    h1        = ymin1 + ymaj1
+    half_diff = abs $ 0.5 * (h1 - h0)
+    hdist     = xmaj0 + xmin1
+    vdist     = if h0 >= h1 then downUp ymin0 (half_diff + ymin1)
+                            else upDown (ymaj0 + half_diff) ymaj1
+
+
+
+binmoveHTop :: Num u => Orientation u -> Orientation u -> Vec2 u
+binmoveHTop op0 op1 = V2 hdist vdist
+  where
+    hdist = or_x_major op0 + or_x_minor op1
+    vdist = upDown (or_y_major op0) (or_y_major op1)
+
+
+leftRight :: Num u => u -> u -> u
+leftRight l r = negate l + r
+
+
+rightLeft :: Num u => u -> u -> u
+rightLeft r l = r - l
+
+
+binmoveVLeft :: Num u => Orientation u -> Orientation u -> Vec2 u
+binmoveVLeft op0 op1 = V2 hdist vdist
+  where
+    hdist = leftRight (or_x_minor op0) (or_x_minor op1)
+    vdist = negate $ or_y_minor op0 + or_y_major op1
+
+
+binmoveVCenter :: (Fractional u, Ord u) 
+               => Orientation u -> Orientation u -> Vec2 u
+binmoveVCenter (Orientation xmin0 xmaj0 ymin0 _) 
+               (Orientation xmin1 xmaj1 _     ymaj1) = 
+    V2 hdist vdist
+  where
+    w0        = xmin0 + xmaj0
+    w1        = xmin1 + xmaj1
+    half_diff = abs $ 0.5 * (w1 - w0)
+    hdist     = if w0 >= w1 then leftRight xmin0 (half_diff + xmin1)
+                            else rightLeft (xmaj0 + half_diff) xmaj1
+    vdist     = negate $ ymin0 + ymaj1
+
+
+
+binmoveVRight :: Num u => Orientation u -> Orientation u -> Vec2 u
+binmoveVRight op0 op1 = V2 hdist vdist
+  where
+    hdist = rightLeft (or_x_major op0) (or_x_major op1)
+    vdist = negate $ or_y_minor op0 + or_y_major op1
+   
diff --git a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs
+++ /dev/null
@@ -1,338 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.TraceDrawing
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Drawing with /trace/ - a Writer like monad collecting 
--- intermediate graphics - and /drawing context/ - a reader monad
--- of attributes - font_face, fill_colour etc.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.TraceDrawing
-  (
-
-    TraceDrawing
-  , DTraceDrawing
-  , TraceDrawingT
-  , DTraceDrawingT
-
-  , runTraceDrawing
-  , execTraceDrawing
-  , evalTraceDrawing
-  , runTraceDrawingT
-  , execTraceDrawingT
-  , evalTraceDrawingT
-
-  , liftToPictureU
-  , liftToPictureMb
-  , mbPictureU
- 
-
-  , query
-  , draw
-  , xdraw
-  , drawi
-  , drawi_
-  , xdrawi
-  , xdrawi_
-
-  , node
-  , nodei
-
-  ) 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 Control.Applicative
-import Control.Monad
-import Data.Monoid
-
-
-
--- Note - TraceDrawing run \once\ - it is supplied with the starting
--- environment (DrawingContext) and returns a Picture.
---
--- Other Wumpus monads (e.g. Turtle) will typically be run inside
--- the TraceDrawing monad as a local effect, rather than built into a 
--- transformer stack.
---
-
-
-newtype TraceDrawing u a   = TraceDrawing { 
-          getTraceDrawing :: DrawingContext -> (a, HPrim u) }
-
-newtype TraceDrawingT u m a = TraceDrawingT { 
-          getTraceDrawingT :: DrawingContext -> m (a, HPrim u) }
-
-
-type DTraceDrawing a    = TraceDrawing Double a
-type DTraceDrawingT m a = TraceDrawingT Double m a
-
-
-
-type instance MonUnit (TraceDrawing u) = u
-type instance MonUnit (TraceDrawingT u m) = u
-
-
-
--- Functor
-
-instance Functor (TraceDrawing u) where
-  fmap f ma = TraceDrawing $ \ctx -> 
-                let (a,w) = getTraceDrawing ma ctx in (f a,w)
-
-
-instance Monad m => Functor (TraceDrawingT u m) where
-  fmap f ma = TraceDrawingT $ \ctx -> 
-                getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w)
-
-
-
--- Applicative
-
-instance Applicative (TraceDrawing u) where
-  pure a    = TraceDrawing $ \_   -> (a, mempty)
-  mf <*> ma = TraceDrawing $ \ctx -> 
-                let (f,w1) = getTraceDrawing mf ctx
-                    (a,w2) = getTraceDrawing ma ctx
-                in (f a, w1 `mappend` w2)
-
-
-instance Monad m => Applicative (TraceDrawingT u m) where
-  pure a    = TraceDrawingT $ \_   -> return (a,mempty)
-  mf <*> ma = TraceDrawingT $ \ctx -> 
-                getTraceDrawingT mf ctx >>= \(f,w1) ->
-                getTraceDrawingT ma ctx >>= \(a,w2) ->
-                return (f a, w1 `mappend` w2)
-
--- Monad
-
-instance Monad (TraceDrawing u) where
-  return a  = TraceDrawing $ \_   -> (a, mempty)
-  ma >>= k  = TraceDrawing $ \ctx -> 
-                let (a,w1) = getTraceDrawing ma ctx
-                    (b,w2) = (getTraceDrawing . k) a ctx
-                in (b,w1 `mappend` w2)
-                               
-
-
-
-instance Monad m => Monad (TraceDrawingT u m) where
-  return a  = TraceDrawingT $ \_   -> return (a, mempty)
-  ma >>= k  = TraceDrawingT $ \ctx -> 
-                getTraceDrawingT ma ctx      >>= \(a,w1) ->
-                (getTraceDrawingT . k) a ctx >>= \(b,w2) -> 
-                return (b, w1 `mappend` w2)
-                                 
-
-
-
--- TraceM 
---
--- Note -  @ state `mappend` a @ means the first expression in a 
--- monadic drawing is the first element in the output file. It is
--- also \*\* at the back \*\* in the the Z-Order.
---
--- Some control over the Z-Order, possibly by adding /layers/ to 
--- the drawing model would be valuable. 
--- 
-
-instance TraceM (TraceDrawing u)  where
-  trace a = TraceDrawing $ \_ -> ((), a)
-
-
-instance Monad m => TraceM (TraceDrawingT u m) where
-  trace a = TraceDrawingT $ \_ -> return ((), a)
-
-
-
--- DrawingCtxM
-
-instance DrawingCtxM (TraceDrawing u) where
-  askDC           = TraceDrawing $ \ctx -> (ctx, mempty)
-  localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx)
-
-
-
-instance Monad m => DrawingCtxM (TraceDrawingT u m) where
-  askDC           = TraceDrawingT $ \ctx -> return (ctx,mempty)
-  localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx)
-
-
-
--- Note - the result type of runTraceDrawing and friends needs more 
--- thought and may change. 
---
--- Possibly a wrapped HPrim that only supports concat and safe
--- extraction is best.
---
--- Or it could generate a picture, but then separate drawings
--- need the picture combinators to put them together. 
--- 
-
-
-runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)
-runTraceDrawing ctx ma = getTraceDrawing ma ctx
-
--- | Run the drawing returning only the output it produces, drop
--- any answer from the monadic computation.
---
-execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u
-execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma
-
--- | Run the drawing ignoring the output it produces, return the 
--- answer from the monadic computation.
---
--- Note - this useful for testing, generally one would want the 
--- opposite behaviour (return the drawing, ignore than the 
--- answer).
--- 
-evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a
-evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma
-
-
-
-runTraceDrawingT :: Monad m 
-                 => DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u) 
-runTraceDrawingT ctx ma = getTraceDrawingT ma ctx
-
-execTraceDrawingT :: Monad m 
-                  => DrawingContext -> TraceDrawingT u m a -> m (HPrim u)
-execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma
-
-
-evalTraceDrawingT :: Monad m 
-                  => DrawingContext -> TraceDrawingT u m a -> m a
-evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma
-
-
-
--- | /Unsafe/ promotion of @HPrim@ to @Picture@.
---
--- If the HPrim is empty, a run-time error is thrown.
--- 
-liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u
-liftToPictureU hf = 
-    let prims = hprimToList hf in if null prims then errK else frame prims
-  where
-    errK = error "toPictureU - empty prims list."
-
--- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.
---
--- If the HPrim is empty, then @Nothing@ is returned.
--- 
-liftToPictureMb :: (Real u, Floating u, FromPtSize u) 
-                => HPrim u -> Maybe (Picture u)
-liftToPictureMb hf = let prims = hprimToList hf in 
-    if null prims then Nothing else Just (frame prims)
-
-
-
--- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.
---
--- This is equivalent to:
---
--- > fromMaybe (error "empty") $ pic
---
--- This function is solely a convenience, using it saves one 
--- import and a few characters.
---
--- If the supplied value is @Nothing@ a run-time error is thrown.
--- 
-mbPictureU :: (Real u, Floating u, FromPtSize u) 
-           => Maybe (Picture u) -> Picture u
-mbPictureU Nothing  = error "mbPictureU - empty picture."
-mbPictureU (Just a) = a
-
--- Note - need an equivalent to Parsec\`s parseTest that provides
--- a very simple way to run graphics without concern for return 
--- type or initial drawing context.
-
---------------------------------------------------------------------------------
-
-query :: DrawingCtxM m => CF a -> m a
-query df = askDC >>= \ctx -> return $ runCF ctx df
-
-
--- | Draw a Graphic taking the drawing style from the 
--- /drawing context/. 
---
--- This operation is analogeous to @tell@ in a Writer monad.
--- 
-draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()
-draw gf = askDC >>= \ctx -> trace (collectH $ snd $ runCF ctx gf)
-
--- | Hyperlink version of 'draw'.
---
-xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) 
-      => XLink -> Graphic u -> m ()
-xdraw xl gf = draw (hyperlink xl gf)
-
-
-
--- | Draw an Image taking the drawing style from the 
--- /drawing context/. 
---
--- The graphic representation of the Image is drawn in the Trace 
--- monad, and the result is returned.
--- 
-drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a
-drawi img = askDC >>= \ctx -> 
-            let (a,o) = runCF ctx img in trace (collectH o) >> return a
-
--- | Forgetful 'drawi'.
---
-drawi_ ::  (TraceM m, DrawingCtxM m, MonUnit m ~ u) => Image u a -> m ()
-drawi_ img = drawi img >> return ()
-
-
--- | Hyperlink version of 'drawi'.
---
-xdrawi ::  (TraceM m, DrawingCtxM m, MonUnit m ~ u) 
-       => XLink -> Image u a -> m a
-xdrawi xl img = drawi (hyperlink xl img)
-
-
--- | Forgetful 'xdrawi'.
---
-xdrawi_ ::  (TraceM m, DrawingCtxM m, MonUnit m ~ u)
-        => XLink -> Image u a -> m ()
-xdrawi_ xl img = xdrawi xl img >> return ()
-
-
-
-
-node :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) 
-     => LocGraphic u -> m ()
-node gf = askDC    >>= \ctx -> 
-          position >>= \pt  -> 
-          let (_,prim) = runCF1 ctx pt gf in trace (collectH prim)
-
-
-nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) 
-     => LocImage u a -> m a
-nodei imgL = askDC    >>= \ctx -> 
-             position >>= \pt  -> 
-             let (a,o) = runCF ctx (apply1R1 imgL pt)
-             in trace (collectH o) >> return a
-
diff --git a/src/Wumpus/Basic/Kernel/Objects/Trail.hs b/src/Wumpus/Basic/Kernel/Objects/Trail.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Trail.hs
@@ -0,0 +1,1042 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Trial
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- /Trails/ - prototype paths. Less resource heavy than the Path
+-- object in Wumpus-Drawing.
+-- 
+-- @CatTrail@ supports concatenation. @AnaTrail@ supports 
+-- /initial displacement/ - this can account for drawing 
+-- rectangles from their center, for example.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Trail
+  (
+
+  -- * Trail types
+    TrailSegment(..)
+  , CatTrail
+  , AnaTrail
+
+  -- * Trail operations
+  , renderAnaTrail
+  , renderCatTrail
+
+  , destrAnaTrail
+  , destrCatTrail
+
+  , anaCatTrail
+  , modifyAna
+  
+  , trailIterateLocus
+
+  , anaTrailPoints
+
+
+  , catline
+  , catcurve
+  , orthoCatTrail
+
+  , diffCurve
+  , diffLines
+  
+
+  -- * Shape trails
+  , rectangleTrail
+  , diamondTrail
+  , polygonTrail
+  , wedgeTrail
+
+
+  -- * Named Trail constructors
+  , trail_up
+  , trail_down
+  , trail_left
+  , trail_right
+
+  , trail_north
+  , trail_south
+  , trail_east
+  , trail_west
+  , trail_north_east
+  , trail_north_west
+  , trail_south_east
+  , trail_south_west
+
+  , trail_up_left
+  , trail_up_right
+  , trail_down_left
+  , trail_down_right
+
+  , trail_para
+  , trail_perp
+
+  , trail_theta_up
+  , trail_theta_down
+  , trail_theta_left
+  , trail_theta_right
+
+  , trail_theta_north
+  , trail_theta_south
+  , trail_theta_east
+  , trail_theta_west
+  , trail_theta_north_east
+  , trail_theta_north_west
+  , trail_theta_south_east
+  , trail_theta_south_west
+
+  , trail_theta_up_left
+  , trail_theta_up_right
+  , trail_theta_down_left
+  , trail_theta_down_right
+
+  , trail_theta_adj_grazing
+  , trail_theta_bkwd_adj_grazing
+
+
+
+  , semicircleTrail
+  , semiellipseTrail
+  , minorCircleSweep
+  , circleSweep
+  , circularArc
+
+  , sineWave
+  , sineWave1
+  , squareWave
+  , sawtoothWave
+  , squiggleWave
+  , semicircleWave
+
+  , triCurve
+  , rectCurve
+  , trapCurve
+  , bowCurve
+  , wedgeCurve
+  , loopCurve
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Objects.Displacement
+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+import Wumpus.Basic.Kernel.Objects.Image
+import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Utils.HList
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Data.List ( unfoldr )
+import Data.Monoid
+
+
+--------------------------------------------------------------------------------
+-- Trail types 
+
+-- | Trail with an initial (undrawn) displacement - an anacrusis.
+--
+-- This allows trails to represent centered objects.
+--
+data AnaTrail u = AnaTrail
+      { pt_init_vec :: Vec2 u
+      , pt_segments :: [TrailSegment u]
+      }
+  deriving (Eq,Ord,Show)
+
+type instance DUnit (AnaTrail u) = u
+
+-- | Trail supporting concatenation.
+--
+newtype CatTrail u = CatTrail { getCatTrail :: H (TrailSegment u) }
+
+type instance DUnit (CatTrail u) = u
+
+
+-- | Trail segment - trails are /prototype/ paths, so the are 
+-- built from the usual straight lines and Bezier curves.
+--
+data TrailSegment u = TLine (Vec2 u)
+                    | TCurve (Vec2 u) (Vec2 u) (Vec2 u)
+  deriving (Eq,Ord,Show)
+
+type instance DUnit (TrailSegment u) = u
+
+
+instance Functor TrailSegment where
+  fmap f (TLine v1)        = TLine $ fmap f v1
+  fmap f (TCurve v1 v2 v3) = TCurve (fmap f v1) (fmap f v2) (fmap f v3)
+
+
+instance Monoid (CatTrail u) where
+  mempty        = CatTrail emptyH
+  a `mappend` b = CatTrail $ getCatTrail a `appendH` getCatTrail b
+
+
+--------------------------------------------------------------------------------
+-- Trail operations
+
+-- | Render a 'CatTrail' to make a drawable 'LocGraphic'.
+--
+renderCatTrail :: InterpretUnit u => PathMode -> CatTrail u -> LocGraphic u
+renderCatTrail mode (CatTrail ct) = promoteLoc $ \pt -> 
+    drawTrailBody mode (toListH ct) pt 
+
+
+-- | Render an 'AnaTrail' to make a drawable 'LocGraphic'.
+--
+renderAnaTrail :: InterpretUnit u => PathMode -> AnaTrail u -> LocGraphic u
+renderAnaTrail mode (AnaTrail v0 xs) = promoteLoc $ \pt -> 
+    drawTrailBody mode xs (pt .+^ v0)
+
+
+-- | Note - this optimizes contiguous lines that share the same 
+-- direction. 
+--
+drawTrailBody :: InterpretUnit u 
+              => PathMode -> [TrailSegment u] -> Point2 u -> Graphic u
+drawTrailBody mode ts pt = 
+    normalizeCtxF pt >>= \dpt -> 
+    mapM normalizeCtxF ts >>= \dxs ->
+    dcPath mode $ relPrimPath dpt $ stepA id dxs
+  where
+    stepA f []                   = toListH f
+    stepA f (TLine v1:ys)        = stepB f (vdirection v1) v1 ys
+    stepA f (TCurve v1 v2 v3:ys) = stepA (f `snocH` relCurveTo v1 v2 v3) ys
+
+    stepB f dir v0 (TLine v1:ys) 
+        | vdirection v1 == dir   = stepB f dir (v0 ^+^ v1) ys
+    stepB f _   v0 ys            = stepA (f `snocH` relLineTo v0) ys
+
+
+-- | /Destructor/ for the opaque 'AnaTrail' type.
+--
+destrAnaTrail :: AnaTrail u -> (Vec2 u, [TrailSegment u])
+destrAnaTrail (AnaTrail v0 ss) = (v0,ss)
+
+-- | /Destructor/ for the opaque 'CatTrail' type.
+--
+destrCatTrail :: CatTrail u -> [TrailSegment u]
+destrCatTrail = toListH . getCatTrail
+
+
+
+-- | Turn a 'CatTrail' into a 'AnaTrail'.
+--
+anaCatTrail :: Vec2 u -> CatTrail u -> AnaTrail u
+anaCatTrail vinit cat = AnaTrail { pt_init_vec = vinit
+                                 , pt_segments = getCatTrail cat []
+                                 }
+
+
+modifyAna :: (Vec2 u -> Vec2 u) -> AnaTrail u -> AnaTrail u
+modifyAna upd (AnaTrail v1 body) = AnaTrail (upd v1) body
+
+-- | Create a AnaTrail from the vector list - each vector in the 
+-- input list iterates to the start point rather then the 
+-- cumulative tip.
+--
+-- When the AnaTrail is run, the supplied point is the /locus/ of 
+-- the path and it does not form part of the path proper.
+-- 
+-- Like 'trailStartIsLocus', this constructor is typically used to 
+-- make /shape paths/. Some shapes are easier to express as 
+-- iterated displacements of the center rather than 
+-- /turtle drawing/. 
+-- 
+trailIterateLocus :: Num u => [Vec2 u] -> AnaTrail u
+trailIterateLocus []      = AnaTrail zeroVec []
+trailIterateLocus (v0:xs) = AnaTrail v0 (step v0 xs)
+  where
+    step v1 []      = [ TLine (v0 ^-^ v1) ]
+    step v1 (v2:vs) = TLine (v2 ^-^ v1) : step v2 vs
+
+
+anaTrailPoints :: InterpretUnit u => AnaTrail u -> LocQuery u [Point2 u]
+anaTrailPoints (AnaTrail v0 ts) = qpromoteLoc $ \pt -> 
+    return $ step (pt .+^ v0) ts
+  where
+    step p1 []                    = [p1]
+    step p1 (TLine v1:xs)         = p1 : step (p1 .+^ v1) xs
+    step p1 (TCurve v1 v2 v3 :xs) = let p2 = p1 .+^ v1
+                                        p3 = p2 .+^ v2
+                                        p4 = p3 .+^ v3 
+                                    in p1 : p2 : p3 : step p4 xs
+
+
+catline :: Vec2 u -> CatTrail u 
+catline = CatTrail . wrapH . TLine
+
+
+-- | Alternative to @catline@, specifying the vector components 
+-- rather the vector itself.
+--
+-- (cf. orthoVec from Wumpus-Core)
+--
+orthoCatTrail :: Floating u => u -> u -> Radian -> CatTrail u 
+orthoCatTrail x y ang = catline (orthoVec x y ang)
+
+
+catcurve :: Vec2 u -> Vec2 u -> Vec2 u -> CatTrail u
+catcurve v1 v2 v3 = CatTrail $ wrapH $ TCurve v1 v2 v3
+
+-- | Form a Bezier CatTrail from the vectors between four control 
+-- points.
+--
+diffCurve :: Num u 
+          => Point2 u -> Point2 u -> Point2 u -> Point2 u -> CatTrail u
+diffCurve p0 p1 p2 p3 = 
+    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)
+
+
+
+-- | Form a CatTrail from the linear segment joining the list of 
+-- points.
+-- 
+-- Some configurations of vectors seem easier to specify using 
+-- located points then making them coordinate free by taking 
+-- the joining vectors.
+--
+diffLines :: Num u => [Point2 u] -> CatTrail u
+diffLines []     = mempty
+diffLines (x:xs) = step mempty x xs 
+  where
+    step ac a (b:bs) = step (ac `mappend` catline (pvec a b)) b bs
+    step ac _ []     = ac
+
+
+
+--------------------------------------------------------------------------------
+-- Shape Trails
+
+-- | 'rectangleTrail' : @ width * height -> AnaTrail @
+--
+rectangleTrail :: Fractional u => u -> u -> AnaTrail u
+rectangleTrail w h = 
+    AnaTrail { pt_init_vec = ctr_to_bl 
+             , pt_segments = map TLine spec
+             }
+  where
+    ctr_to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)
+    spec      = [ go_right w, go_up h, go_left w, go_down h ]
+
+
+
+
+-- | 'diamondTrail' : @ half_width * half_height -> AnaTrail @
+--
+diamondTrail :: Num u => u -> u -> AnaTrail u
+diamondTrail hw hh = trailIterateLocus [ vs,ve,vn,vw ]
+  where
+    vs = vvec (-hh)
+    ve = hvec hw
+    vn = vvec hh
+    vw = hvec (-hw)
+
+
+-- | 'polygonTrail' : @ num_points * radius -> AnaTrail @ 
+--
+polygonTrail :: Floating u => Int -> u -> AnaTrail u
+polygonTrail n radius = trailIterateLocus $ unfoldr phi (0,top)
+  where
+    top                     = 0.5*pi
+    theta                   = (2*pi) / fromIntegral n
+    
+    phi (i,ang) | i < n     = Just (avec ang radius, (i+1,ang+theta))
+                | otherwise = Nothing
+
+
+
+-- | wedgeTrail : radius * apex_angle
+-- 
+-- Wedge is drawn at the apex.
+--
+wedgeTrail :: (Real u, Floating u) 
+           => u -> Radian -> Radian -> AnaTrail u
+wedgeTrail radius ang theta = 
+    anaCatTrail zeroVec $ line_in `mappend` w_arc `mappend` line_out
+  where
+    half_ang = 0.5 * ang 
+    line_in  = catline $ avec (theta + half_ang)   radius
+    line_out = catline $ avec (theta - half_ang) (-radius)
+    w_arc    = circularArcCW ang radius (theta - half_pi)
+
+
+
+--------------------------------------------------------------------------------
+-- Named Trail constructors
+
+trail_up :: Num u => u -> CatTrail u
+trail_up = catline . go_up
+
+trail_down :: Num u => u -> CatTrail u
+trail_down = catline . go_down
+
+trail_left :: Num u => u -> CatTrail u
+trail_left = catline . go_left
+
+trail_right :: Num u => u -> CatTrail u
+trail_right = catline . go_right
+
+
+trail_north :: Num u => u -> CatTrail u
+trail_north = trail_up
+
+trail_south :: Num u => u -> CatTrail u
+trail_south = catline . go_down
+
+trail_east :: Num u => u -> CatTrail u
+trail_east = catline . go_right
+
+trail_west :: Num u => u -> CatTrail u
+trail_west = catline . go_left
+
+
+trail_north_east :: Floating u => u -> CatTrail u
+trail_north_east = catline . go_north_east
+
+trail_north_west :: Floating u => u -> CatTrail u
+trail_north_west = catline . go_north_west
+
+trail_south_east :: Floating u => u -> CatTrail u
+trail_south_east = catline . go_south_east
+
+trail_south_west :: Floating u => u -> CatTrail u
+trail_south_west = catline . go_south_west
+
+
+trail_up_left :: Num u => u -> CatTrail u
+trail_up_left = catline . go_up_left
+
+trail_up_right :: Num u => u -> CatTrail u
+trail_up_right = catline . go_up_right
+
+trail_down_left :: Num u => u -> CatTrail u
+trail_down_left = catline . go_down_left
+
+trail_down_right :: Num u => u -> CatTrail u
+trail_down_right = catline . go_down_right
+
+
+trail_perp :: Floating u => u -> Radian -> CatTrail u
+trail_perp = trail_theta_up
+
+trail_para :: Floating u => u -> Radian -> CatTrail u
+trail_para = trail_theta_right
+
+
+trail_theta_up :: Floating u => u -> Radian -> CatTrail u
+trail_theta_up u = catline . theta_up u
+
+trail_theta_down :: Floating u => u -> Radian -> CatTrail u
+trail_theta_down u = catline . theta_down u
+
+trail_theta_left :: Floating u => u -> Radian -> CatTrail u
+trail_theta_left u = catline . theta_left u
+
+trail_theta_right :: Floating u => u -> Radian -> CatTrail u
+trail_theta_right u = catline . theta_right u
+
+
+trail_theta_north :: Floating u => u -> Radian -> CatTrail u
+trail_theta_north = trail_theta_up
+
+trail_theta_south :: Floating u => u -> Radian -> CatTrail u
+trail_theta_south = trail_theta_down
+
+trail_theta_east :: Floating u => u -> Radian -> CatTrail u
+trail_theta_east = trail_theta_right
+
+trail_theta_west :: Floating u => u -> Radian -> CatTrail u
+trail_theta_west = trail_theta_left
+
+
+trail_theta_north_east :: Floating u => u -> Radian -> CatTrail u
+trail_theta_north_east u = catline . theta_north_east u
+
+trail_theta_north_west :: Floating u => u -> Radian -> CatTrail u
+trail_theta_north_west u = catline . theta_north_west u
+
+trail_theta_south_east :: Floating u => u -> Radian -> CatTrail u
+trail_theta_south_east u = catline . theta_south_east u
+
+trail_theta_south_west :: Floating u => u -> Radian -> CatTrail u
+trail_theta_south_west u = catline . theta_south_west u
+
+
+trail_theta_up_left :: Floating u => u -> Radian -> CatTrail u
+trail_theta_up_left u = catline . theta_up_left u
+
+trail_theta_up_right :: Floating u => u -> Radian -> CatTrail u
+trail_theta_up_right u = catline . theta_up_right u
+
+trail_theta_down_left :: Floating u => u -> Radian -> CatTrail u
+trail_theta_down_left u = catline . theta_down_left u
+
+trail_theta_down_right :: Floating u => u -> Radian -> CatTrail u
+trail_theta_down_right u = catline . theta_down_right u
+
+
+
+-- | Return the line @a-o@ when supplied length of @b-o@ and the 
+-- grazing angle @boa@:
+--
+-- >    a
+-- >    .\
+-- >    . \
+-- >  ..b..o
+--
+-- This is useful for building arrowhead vectors.
+--
+trail_theta_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u 
+trail_theta_adj_grazing adj_len ang = 
+    catline . theta_adj_grazing adj_len ang
+
+
+-- | Return the line @o-c@ when supplied length of @b-o@ and the 
+-- grazing angle @boc@:
+--
+--
+-- >  ..b..o
+-- >    . /
+-- >    ./
+-- >    c
+--
+-- This is useful for building arrowhead vectors.
+--
+trail_theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u 
+trail_theta_bkwd_adj_grazing adj_len ang = 
+    catline . theta_bkwd_adj_grazing adj_len ang 
+
+
+--------------------------------------------------------------------------------
+
+--
+-- DESIGN NOTE
+--
+-- Angle, unit width and number of repetitions (plus height etc.) 
+-- seems the best API, although this make fitting an issue.
+--
+
+
+sineWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u
+sineWave i unit ang = 
+    mconcat $ replicate i $ sineWave1 (0.25 * unit) unit ang
+
+
+-- | One-phase sine wave. Height is parametric.
+--
+sineWave1 :: (Real u, Floating u)
+              => u -> u -> Radian -> CatTrail u
+sineWave1 h unit ang = 
+              catcurve  v1            (vdiff v1 v2)   (vdiff v2 v3)
+    `mappend` catcurve (vdiff v3 v4)  (vdiff v4 v5)   (vdiff v5 v6)
+    `mappend` catcurve (vdiff v6 v7)  (vdiff v7 v8)   (vdiff v8 v9)
+    `mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)
+  where
+    base1 = unit / 12
+    h2    = h * (pi / 6)
+    v1    = orthoVec     base1    h2  ang
+    v2    = orthoVec  (2*base1)   h   ang
+    v3    = orthoVec  (3*base1)   h   ang
+    v4    = orthoVec  (4*base1)   h   ang
+    v5    = orthoVec  (5*base1)   h2  ang
+    v6    = orthoVec  (6*base1)   0   ang
+    v7    = orthoVec  (7*base1) (-h2) ang
+    v8    = orthoVec  (8*base1) (-h)  ang
+    v9    = orthoVec  (9*base1) (-h)  ang
+    v10   = orthoVec (10*base1) (-h)  ang
+    v11   = orthoVec (11*base1) (-h2) ang
+    v12   = orthoVec (12*base1)   0   ang
+
+
+
+kappa :: Floating u => u
+kappa = 4 * ((sqrt 2 - 1) / 3)
+
+
+--
+-- DESIGN NOTE 
+--
+-- The API seems better exposing ClockDirection as an argument 
+-- rather than providing two different functions for CW and CCW 
+-- (even though some functions are defined by independent CW and 
+-- CCW versions).
+--
+
+
+-- | 'semicircleCW' : @ base_vector -> CatTrail @ 
+-- 
+-- Make an open semicircle from two Bezier curves. 
+--
+-- Although this function produces an approximation of a 
+-- semicircle, the approximation seems fine in practice.
+--
+semicircleTrail :: (Real u, Floating u) 
+                => ClockDirection -> Vec2 u -> CatTrail u
+semicircleTrail CW = semicircleCW
+semicircleTrail _  = semicircleCCW
+
+-- | 'semicircleCW' : @ base_vector -> CatTrail @ 
+-- 
+-- Make a clockwise semicircle from two Bezier curves. Although 
+-- this function produces an approximation of a semicircle, the 
+-- approximation seems fine in practice.
+--
+semicircleCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
+semicircleCW base_vec =
+              catcurve  v1           (vdiff v1 v2) (vdiff v2 v3)
+    `mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)
+  where
+    circum  = vlength base_vec
+    radius  = 0.5 * circum
+    ang     = vdirection base_vec
+    rl      = radius * kappa
+    
+    v1      = orthoVec 0 rl ang
+    v2      = orthoVec (radius - rl) radius ang
+    v3      = orthoVec radius radius ang
+
+    v4      = orthoVec (radius + rl) radius ang
+    v5      = orthoVec circum rl ang
+    v6      = orthoVec circum 0 ang
+
+
+-- | 'semicircleCCW' : @ base_vector_vector -> CatTrail @ 
+-- 
+-- Make a counter-clockwise semicircle from two Bezier curves. 
+-- Although this function produces an approximation of a 
+-- semicircle, the approximation seems fine in practice.
+--
+semicircleCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
+semicircleCCW base_vec =
+              catcurve  v1           (vdiff v1 v2) (vdiff v2 v3)
+    `mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)
+  where
+    circum  = vlength base_vec
+    radius  = 0.5 * circum
+    ang     = vdirection base_vec
+    rl      = radius * kappa
+    
+    v1      = orthoVec 0 (-rl) ang
+    v2      = orthoVec (radius - rl) (-radius) ang
+    v3      = orthoVec radius (-radius) ang
+
+    v4      = orthoVec (radius + rl) (-radius) ang
+    v5      = orthoVec circum (-rl) ang
+    v6      = orthoVec circum 0 ang
+
+
+-- | 'semicircleTrail' : @ clock_direction * ry * base_vector -> CatTrail @ 
+-- 
+-- Make an open semiellipse from two Bezier curves. 
+--
+-- Although this function produces an approximation of a 
+-- semiellipse, the approximation seems fine in practice.
+--
+semiellipseTrail :: (Real u, Floating u) 
+               => ClockDirection -> u -> Vec2 u -> CatTrail u
+semiellipseTrail CW = semiellipseBasis theta_up
+semiellipseTrail _  = semiellipseBasis theta_down
+
+
+
+-- | theta_up for CW, theta_down for CCW...
+--
+semiellipseBasis :: (Real u, Floating u) 
+                 => (u -> Radian -> Vec2 u) -> u -> Vec2 u -> CatTrail u
+semiellipseBasis perpfun ry base_vec = 
+              catcurve (pvec p00 c01) (pvec c01 c02) (pvec c02 p03)
+    `mappend` catcurve (pvec p03 c04) (pvec c04 c05) (pvec c05 p06) 
+  where
+    rx    = 0.5 * vlength base_vec
+    ang   = vdirection base_vec
+    lrx   = rx * kappa
+    lry   = ry * kappa
+    para  = theta_right `flip` ang
+    perp  = perpfun `flip` ang
+
+    p00   = zeroPt .+^ theta_left rx ang
+    c01   = p00 .+^ perp lry
+    c02   = p03 .+^ para (-lrx)
+
+    p03   = zeroPt .+^ perpfun ry ang  
+    c04   = p03 .+^ para lrx
+    c05   = p06 .+^ perp lry
+
+    p06   = zeroPt .+^ theta_right rx ang
+
+
+-- | 'minorCircleSweep' : @ clock_direction * angle * radius 
+--      * inclination -> CatTrail @
+--
+-- > ang should be in the range 0 < ang <= 90deg.
+--
+minorCircleSweep :: (Real u, Floating u)
+                 => ClockDirection -> Radian -> u -> Radian -> CatTrail u
+minorCircleSweep CW = minorCircleSweepCW 
+minorCircleSweep _  = minorCircleSweepCCW
+
+
+-- | 'minorCircleSweepCW' : @ angle * radius * inclination -> CatTrail @
+--
+-- > ang should be in the range 0 < ang <= 90deg.
+--
+minorCircleSweepCW :: (Real u, Floating u)
+                   => Radian -> u -> Radian -> CatTrail u
+minorCircleSweepCW ang radius theta = 
+    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)
+  where
+    kfactor = fromRadian $ ang / (0.5*pi)
+    rl      = kfactor * radius * kappa
+    totang  = circularModulo $ theta + (half_pi - ang)
+
+    p0      = displace (theta_up    radius theta) zeroPt
+    p1      = displace (theta_right rl     theta) p0
+    p2      = displace (theta_up    rl     totang) p3
+    p3      = displace (avec totang radius) zeroPt
+
+
+-- | 'minorCircleSweepCCW' : @ angle * radius * inclination -> CatTrail @
+--
+-- > ang should be in the range 0 < ang <= 90deg.
+--
+minorCircleSweepCCW :: (Real u, Floating u)
+                    => Radian -> u -> Radian -> CatTrail u
+minorCircleSweepCCW ang radius theta = 
+    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)
+  where
+    kfactor = fromRadian $ ang / (0.5*pi)
+    rl      = kfactor * radius * kappa
+    totang  = circularModulo $ theta - half_pi + ang
+
+    p0      = displace (theta_down  radius theta) zeroPt
+    p1      = displace (theta_right rl     theta) p0
+    p2      = displace (theta_down  rl     totang) p3
+    p3      = displace (avec totang radius) zeroPt
+
+
+-- | 'circleSweep' : @ clock_direction * apex_angle * radius 
+--      * inclination -> CatTrail @
+--
+-- > ang should be in the range 0 < ang < 360deg.
+--
+-- > if   0 < ang <=  90 returns 1 segment
+-- > if  90 < ang <= 180 returns 2 segments
+-- > if 180 < ang <= 270 returns 3 segments
+-- > if 270 < ang <  360 returns 4 segmenets
+--
+circleSweep :: (Real u, Floating u)
+            => ClockDirection -> Radian -> u -> Radian -> CatTrail u
+circleSweep CW = circleSweepCW
+circleSweep _  = circleSweepCCW
+
+
+-- | 'circleSweepCW' : @ apex_angle * radius * inclination -> CatTrail @
+--
+-- > ang should be in the range 0 < ang < 360deg.
+--
+-- > if   0 < ang <=  90 returns 1 segment
+-- > if  90 < ang <= 180 returns 2 segments
+-- > if 180 < ang <= 270 returns 3 segments
+-- > if 270 < ang <  360 returns 4 segmenets
+--
+circleSweepCW :: (Real u, Floating u)
+              => Radian -> u -> Radian -> CatTrail u
+circleSweepCW ang radius theta = 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 =           minorCircleSweepCW a radius theta
+
+    wedge2 a =           minorCircleSweepCW a radius theta
+               `mappend` minorCircleSweepCW a radius (theta-a)
+
+    wedge3 a =           minorCircleSweepCW a radius theta
+               `mappend` minorCircleSweepCW a radius (theta - a)
+               `mappend` minorCircleSweepCW a radius (theta - 2*a)
+  
+    wedge4 a =           minorCircleSweepCW a radius theta
+               `mappend` minorCircleSweepCW a radius (theta - a)
+               `mappend` minorCircleSweepCW a radius (theta - 2*a)
+               `mappend` minorCircleSweepCW a radius (theta - 3*a)
+
+
+
+
+-- | 'circleSweepCCW' : @ apex_angle * radius * inclination -> CatTrail @
+--
+-- > ang should be in the range 0 < ang < 360deg.
+--
+-- > if   0 < ang <=  90 returns 1 segment
+-- > if  90 < ang <= 180 returns 2 segments
+-- > if 180 < ang <= 270 returns 3 segments
+-- > if 270 < ang <  360 returns 4 segmenets
+--
+circleSweepCCW :: (Real u, Floating u)
+               => Radian -> u -> Radian -> CatTrail u
+circleSweepCCW ang radius theta = 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 =           minorCircleSweepCCW a radius theta
+
+    wedge2 a =           minorCircleSweepCCW a radius theta
+               `mappend` minorCircleSweepCCW a radius (theta+a)
+
+    wedge3 a =           minorCircleSweepCCW a radius theta
+               `mappend` minorCircleSweepCCW a radius (theta+a)
+               `mappend` minorCircleSweepCCW a radius (theta+a+a)
+  
+    wedge4 a =           minorCircleSweepCCW a radius theta
+               `mappend` minorCircleSweepCCW a radius (theta+a)
+               `mappend` minorCircleSweepCCW a radius (theta+a+a)
+               `mappend` minorCircleSweepCCW a radius (theta+a+a+a)
+
+circularArc :: (Real u, Floating u) 
+            => ClockDirection -> Radian -> u -> Radian -> CatTrail u 
+circularArc CW = circularArcCW
+circularArc _  = circularArcCCW
+
+
+-- | inclination is the inclination of the chord.
+--
+circularArcCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u 
+circularArcCW apex_ang radius inclin = 
+    circleSweepCW apex_ang radius (inclin + 0.5 * apex_ang)
+
+
+-- | inclination is the inclination of the chord.
+--
+circularArcCCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u 
+circularArcCCW apex_ang radius inclin = 
+    circleSweepCCW apex_ang radius (inclin - 0.5 * apex_ang)
+
+
+-- | Proper semicircles do not make a good squiggle (it needs a 
+-- bit of pinch).
+--
+squiggleWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u
+squiggleWave i unit ang = mconcat $ replicate i $ squiggle1 unit ang
+    
+squiggle1 :: (Real u, Floating u) => u -> Radian -> CatTrail u
+squiggle1 unit ang = 
+              catcurve  v1            (vdiff v1 v2)   (vdiff v2 v3)
+    `mappend` catcurve (vdiff v3 v4)  (vdiff v4 v5)   (vdiff v5 v6)
+    `mappend` catcurve (vdiff v6 v7)  (vdiff v7 v8)   (vdiff v8 v9)
+    `mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)
+  where
+    four_radius   = unit
+    radius        = 0.25 * four_radius
+    two_radius    = 0.5  * four_radius
+    three_radius  = 0.75 * four_radius
+    rl            = radius * kappa
+    micro         = 0.33 * rl           -- seems good
+    
+    v1            = orthoVec micro rl ang
+    v2            = orthoVec (radius - rl) radius ang
+    v3            = orthoVec radius radius ang
+
+    v4            = orthoVec (radius + rl) radius ang
+    v5            = orthoVec (two_radius - micro) rl ang
+    v6            = orthoVec two_radius  0 ang
+
+    v7            = orthoVec (two_radius + micro) (-rl) ang
+    v8            = orthoVec (three_radius - rl) (-radius) ang
+    v9            = orthoVec three_radius (-radius) ang
+
+    v10           = orthoVec (three_radius + rl) (-radius) ang
+    v11           = orthoVec (four_radius - micro) (-rl) ang
+    v12           = orthoVec four_radius 0 ang
+
+    
+
+squareWave :: Floating u => Int -> u -> Radian -> CatTrail u 
+squareWave n unit ang 
+    | n >  0    = monPreRepeatPost up_half (n - 1,kont) fin
+    | otherwise = mempty
+  where
+    up_half     = catline $ theta_up    (0.25 * unit) ang
+    up_one      = catline $ theta_up    (0.5  * unit) ang
+    down_one    = catline $ theta_down  (0.5  * unit) ang
+    right_half  = catline $ theta_right (0.5  * unit) ang
+
+    kont        = right_half `mappend` down_one `mappend` right_half
+                             `mappend` up_one
+
+    fin         = right_half `mappend` down_one `mappend` right_half
+                             `mappend` up_half
+
+
+
+
+-- |
+--  
+sawtoothWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u 
+sawtoothWave n unit ang 
+    | n >  0    = monPreRepeatPost up_half (n - 1,kont) fin
+    | otherwise = mempty
+  where
+    up_half  = catline $ theta_up_right (0.25 * unit) ang
+    up_one   = catline $ theta_up_right (0.5  * unit) ang
+    down_one = catline $ theta_down_right (0.5 * unit) ang
+
+    kont     = down_one `mappend` up_one
+    fin      = down_one `mappend` up_half
+
+
+
+semicircleWave :: (Real u, Floating u) 
+               => ClockDirection -> Int -> u -> Radian -> CatTrail u
+semicircleWave cdir i unit ang = 
+    mconcat $ replicate i $ fn cdir (avec ang unit)
+  where
+    fn CCW = semicircleCCW
+    fn _   = semicircleCW
+
+
+
+--------------------------------------------------------------------------------
+
+-- | 'triCurve' : @ clock_direction * base_width * height * 
+--      base_inclination -> CatTrail @
+-- 
+-- Curve in a triangle - base_width and height are expected to 
+-- be positive.
+-- 
+triCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u
+triCurve CW  bw h ang = ctriCW bw h ang
+triCurve CCW bw h ang = ctriCW bw (-h) ang
+
+
+-- | Curve in a triangle.
+-- 
+ctriCW :: Floating u => u -> u -> Radian -> CatTrail u
+ctriCW bw h ang = catcurve v1 zeroVec v2
+  where
+    v1 = orthoVec (0.5 * bw) h ang
+    v2 = orthoVec (0.5 * bw) (-h) ang
+
+
+-- | 'rectCurve' : @ clock_direction * base_width * height * 
+--      base_inclination -> CatTrail @
+-- 
+-- Curve in a rectangle.
+-- 
+rectCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u
+rectCurve CW  bw h ang = crectCW bw h ang
+rectCurve CCW bw h ang = crectCW bw (-h) ang
+
+
+-- | Curve in a rectangle.
+-- 
+crectCW :: Floating u => u -> u -> Radian -> CatTrail u
+crectCW bw h ang = catcurve v1 v2 v3
+  where
+    v1 = orthoVec 0    h  ang
+    v2 = orthoVec bw   0  ang
+    v3 = orthoVec 0  (-h) ang
+
+
+
+-- | Curve in a trapezium.
+-- 
+trapCurve :: Floating u 
+          => ClockDirection -> u -> u -> Radian -> Radian -> CatTrail u
+trapCurve CW  = ctrapCW
+trapCurve CCW = ctrapCCW
+
+-- | Curve in a trapezium (CW).
+-- 
+-- h must be positive.
+--
+ctrapCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u
+ctrapCW bw h interior_ang ang = catcurve v1 v2 v3
+  where
+    minor_bw = h / (fromRadian $ tan interior_ang)
+    v1       = orthoVec minor_bw                h  ang
+    v2       = orthoVec (bw - (2 * minor_bw))   0  ang
+    v3       = orthoVec minor_bw              (-h) ang
+
+-- | Curve in a trapezium (CCW).
+-- 
+-- h must be positive.
+--
+ctrapCCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u
+ctrapCCW bw h interior_ang ang = catcurve v1 v2 v3
+  where
+    minor_bw = h / (fromRadian $ tan interior_ang)
+    v1       = orthoVec minor_bw              (-h)  ang
+    v2       = orthoVec (bw - (2 * minor_bw))   0  ang
+    v3       = orthoVec minor_bw                h ang
+
+-- | Curve in half a /bowtie/.
+-- 
+bowCurve :: Floating u 
+         => ClockDirection -> u -> u -> Radian -> CatTrail u
+bowCurve CW  bw h ang = cbowCW bw h ang
+bowCurve CCW bw h ang = cbowCW bw (-h) ang
+
+-- | Curve in half a /bowtie/.
+-- 
+cbowCW :: Floating u => u -> u -> Radian -> CatTrail u
+cbowCW bw h ang = catcurve v1 v2 v3
+  where
+    v1 = orthoVec 0    h  ang
+    v2 = orthoVec bw (-h)  ang
+    v3 = orthoVec 0    h ang
+
+
+-- | Wedge curve formed inside a bowtie rotated by 90deg.
+-- 
+wedgeCurve :: Floating u 
+           => ClockDirection -> u -> u -> Radian -> CatTrail u
+wedgeCurve CW  bw h ang = cwedgeCW bw h ang
+wedgeCurve CCW bw h ang = cwedgeCW bw (-h) ang
+
+-- | Wedge curve clockwise.
+-- 
+cwedgeCW :: Floating u => u -> u -> Radian -> CatTrail u
+cwedgeCW bw h ang = catcurve v1 v2 v3
+  where
+    v1 = orthoVec   bw    h  ang
+    v2 = orthoVec (-bw)   0  ang
+    v3 = orthoVec   bw  (-h) ang
+
+
+-- | Variation of wedge curve that draws a loop.
+-- 
+loopCurve :: Floating u 
+          => ClockDirection -> u -> u -> Radian -> CatTrail u
+loopCurve CW  bw h ang = cloopCW bw h ang
+loopCurve CCW bw h ang = cloopCW bw (-h) ang
+
+
+-- | loop curve clockwise.
+-- 
+cloopCW :: Floating u => u -> u -> Radian -> CatTrail u
+cloopCW bw h ang = catcurve v1 v2 v3
+  where
+    ww = 2.0 * bw 
+    v1 = orthoVec  (1.5 * bw)    h  ang
+    v2 = orthoVec  (-ww)         0  ang
+    v3 = orthoVec  (1.5 * bw)  (-h) ang
diff --git a/src/Wumpus/Basic/System/FontLoader.hs b/src/Wumpus/Basic/System/FontLoader.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader.hs
@@ -0,0 +1,143 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Top level module for font loading...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader
+  (
+    FontLoader
+  , afmLoaderByEnv
+  , gsLoaderByEnv
+  , simpleFontLoader
+
+  , default_font_loader_help
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.FontSupport  
+import Wumpus.Basic.System.FontLoader.AfmTopLevel
+import Wumpus.Basic.System.FontLoader.GSTopLevel
+
+import Control.Monad
+import Control.Exception ( try )
+import System.Environment
+-- import System.IO.Error
+
+
+
+
+-- | A FontLoader is an action from a list of fonts to a
+-- 'FontLoadResult' returned in @IO@.
+-- 
+-- Fonts are supplied in a list of @Either FontDef FontFamily@,
+-- this is a little cumbersome but it allows the loader to load
+-- individual fonts and \/ or a whole families with a single API
+-- call.
+--
+type FontLoader = [Either FontDef FontFamily] -> IO FontLoadResult
+
+
+
+
+
+-- | Environment variable pointing to the GhostScript font
+-- directory.
+-- 
+-- > WUMPUS_GS_FONT_DIR
+--
+wumpus_gs_font_dir :: String
+wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR"
+
+
+-- | Environment variable pointing to the diretory containing 
+-- the Adobe Font Metrics files.
+-- 
+-- > WUMPUS_AFM_FONT_DIR
+--
+wumpus_afm_font_dir :: String
+wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR"
+
+
+
+afmLoaderByEnv :: IO (Maybe FontLoader)
+afmLoaderByEnv = do 
+    mb <- envLookup wumpus_afm_font_dir
+    case mb of 
+      Nothing   -> return Nothing
+      Just path -> return $ Just (\xs -> loadAfmFontMetrics path $ fontList xs)
+
+
+gsLoaderByEnv :: IO (Maybe FontLoader)
+gsLoaderByEnv = do
+    mb <- envLookup wumpus_gs_font_dir
+    case mb of
+      Nothing   -> return Nothing
+      Just path -> return $ Just (\xs -> loadGSFontMetrics path $ fontList xs)
+
+
+-- | Tries to find the GhostScript metrics first...
+--
+-- Runs the IO action on the loader if it finds one.
+--
+-- Either of one of the environment variables 
+-- @WUMPUS_AFM_FONT_DIR@ or @WUMPUS_GS_FONT_DIR@ must be defined
+-- and point to their respective directory. 
+-- 
+simpleFontLoader :: (FontLoader -> IO a) ->  IO (Maybe a)
+simpleFontLoader mf = 
+    gsLoaderByEnv >>= maybe fk1 sk 
+  where
+   fk1       = afmLoaderByEnv >>= maybe fk2 sk
+   fk2       = putStrLn default_font_loader_help >> return Nothing
+   sk loader = mf loader >>= return . Just
+
+
+envLookup :: String -> IO (Maybe String)
+envLookup name = liftM fn $ try $ getEnv name
+  where
+    fn :: Either IOError String -> Maybe String
+    fn (Left _)  = Nothing
+    fn (Right a) = Just a
+
+   
+
+fontList :: [Either FontDef FontFamily] -> [FontDef]
+fontList = foldr fn []
+  where
+    fn (Left a)  acc = a:acc
+    fn (Right b) acc = let f1 = maybe id (\a -> (a:)) $ ff_bold b
+                           f2 = maybe id (\a -> (a:)) $ ff_italic b
+                           f3 = maybe id (\a -> (a:)) $ ff_bold_italic b
+                     in ff_regular b : (f1 $ f2 $ f3 acc)
+
+
+default_font_loader_help :: String
+default_font_loader_help = unlines $ 
+    [ "This example uses glyph metrics loaded at runtime."
+    , "It can use either the metrics files supplied with GhostScript,"
+    , "or the AFM v4.1 metrics for the Core 14 fonts available from"
+    , "Adobe's website."
+    , "" 
+    , "To use GhostScripts font metrics set the environemt variable"
+    , wumpus_gs_font_dir ++ " to point to the GhostScript fonts"
+    , "directory (e.g. /usr/share/ghostscript/fonts)."
+    , ""
+    , "To use the Adode Core 14 font metrics download the archive from"
+    , "the Adobe website and set the environment variable "
+    , wumpus_afm_font_dir ++ " to point to it."
+    , ""
+    , "If you have both environment variables set, the GhostScript loader"
+    , "will be used."
+    ]
+
diff --git a/src/Wumpus/Basic/System/FontLoader/Afm.hs b/src/Wumpus/Basic/System/FontLoader/Afm.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Afm.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Afm
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Font loader / import shim for the Adobe \"Core 14\" glyph 
--- metrics.
---
--- Use this loader if you have the Adode glyph metrics set
--- (AFM v4.1). This metrics set is avaiable from the Adobe 
--- website.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Afm
-  ( 
-    loadAfmMetrics
-  
-  ) where
-
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser
-import Wumpus.Basic.System.FontLoader.Base.Datatypes
-import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad
-
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Control.Monad
-import Data.Monoid
-
--- The file names of the Afm fonts match there PostScript names,
--- the only difference is the addition of a @.afm@ extension.
---
-
--- | 'loadAfmMetrics' : 
--- @ path_to_afm_fonts * [font_name] -> IO (metrics, messages) @ 
--- 
--- Load the supplied list of fonts. 
--- 
--- Note - if a font fails to load a message is written to the 
--- log and monospaced /fallback metrics/ are used.
---
-loadAfmMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String])
-loadAfmMetrics font_dir_path ns = 
-    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns
-  where
-    mkFun = afmLoadFontCalcs font_dir_path  
- 
-    post (Left err,ss) = (mempty, ss ++ [err])      -- unreachable...
-    post (Right xs,ss) = (foldr insertFont mempty xs, ss)
-
-
-
-
-afmLoadFontCalcs :: FilePath -> FontName -> FontLoadIO FontMetricsOps
-afmLoadFontCalcs font_dir_path name = do
-    logLoadMsg  $ "Loading " ++ name
-    path        <- checkFontPath font_dir_path (name ++ ".afm")
-    ans         <- runParserFLIO path afmV4Dot1Parser
-    props       <- buildAfmFontProps  afm_mono_defaults_4_1 ans
-    return $ FontMetricsOps name (buildMetricsOps afmUnitScale props)
-
-
-
--- | These are values extracted from Courier in the core 14 fonts.
---
-afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit
-afm_mono_defaults_4_1 = 
-    MonospaceDefaults { default_letter_bbox  = bbox
-                      , default_cap_height   = 562
-                      , default_char_width   = V2 600 0
-                      }
-  where
-    bbox = BBox (P2 (-23) (-250)) (P2 715 805)
diff --git a/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs
@@ -0,0 +1,225 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.AfmParserBase
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Common parsers for AFM files.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.AfmParserBase
+  ( 
+
+    afmFileParser
+  , runQuery
+  , textQuery
+
+  , getFontBBox
+  , getEncodingScheme
+  , getCapHeight
+  
+  , charBBox
+  , metric
+  , keyStringPair
+  , versionNumber  
+  , startCharMetrics
+
+  , keyName
+  , newlineOrEOF
+  , name
+  , name1
+  , semi
+  , uptoNewline
+  , number
+  , cint
+  , hexInt
+  , octInt
+
+  , lexeme
+  , symbol
+  , integer
+  , int
+  , double
+
+  ) where
+
+import Wumpus.Basic.System.FontLoader.Datatypes
+
+import Wumpus.Basic.Utils.ParserCombinators
+import qualified Wumpus.Basic.Utils.TokenParsers as P
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+import Data.Char
+import qualified Data.Map               as Map
+
+
+afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile
+afmFileParser pgm = do 
+    info <- (versionNumber    *> globalInfo) 
+    cms  <- (startCharMetrics *> many pgm)
+    return $ AfmFile 
+              { afm_encoding            = getEncodingScheme info
+              , afm_letter_bbox         = getFontBBox       info
+              , afm_cap_height          = getCapHeight      info
+              , afm_descender           = getDescender      info
+              , afm_underline_position  = getUlPosition     info
+              , afm_underline_thickness = getUlThickness    info
+              , afm_glyph_metrics       = cms
+              }
+
+globalInfo :: CharParser GlobalInfo
+globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) 
+               <$> manyTill keyStringPair (peek startCharMetrics)
+
+
+ 
+runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a
+runQuery field_name p table = 
+    Map.lookup field_name table >>= extr . runParser p
+  where
+    extr (Okay a _) = Just a
+    extr _          = Nothing
+
+textQuery :: String -> GlobalInfo -> Maybe String
+textQuery = Map.lookup
+
+
+-- | Strictly speaking a fontBBox is measured in integer units.
+--
+getFontBBox            :: GlobalInfo -> Maybe AfmBoundingBox
+getFontBBox            = runQuery "FontBBox" fontBBox
+
+getEncodingScheme      :: GlobalInfo -> Maybe String
+getEncodingScheme      = textQuery "EncodingScheme"
+
+getCapHeight           :: GlobalInfo -> Maybe AfmUnit
+getCapHeight           = runQuery "CapHeight" number
+
+getDescender           :: GlobalInfo -> Maybe AfmUnit
+getDescender           = runQuery "Descender" number
+
+
+-- | Expected to be negative...
+--
+getUlPosition          :: GlobalInfo -> Maybe AfmUnit
+getUlPosition          = runQuery "UnderlinePosition" number
+
+getUlThickness         :: GlobalInfo -> Maybe AfmUnit
+getUlThickness         = runQuery "UnderlineThickness" number
+
+
+charBBox :: CharParser AfmBoundingBox
+charBBox = symbol "B" *> fontBBox <* semi
+
+fontBBox :: CharParser AfmBoundingBox
+fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury))
+              <$> number <*> number <*> number <*> number
+
+
+
+metric :: String -> a -> CharParser a -> CharParser a
+metric iden dfault p = option dfault go
+  where
+    go = symbol iden *> p <* semi
+
+
+
+keyStringPair :: CharParser (AfmKey,String)
+keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF 
+             <?> "key-value line"
+
+versionNumber :: CharParser String
+versionNumber = 
+    symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF
+      <?> "StartFontMetrics"
+
+
+startCharMetrics :: CharParser Int
+startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF
+                <?> "StartCharMetrics failed"
+
+
+
+--------------------------------------------------------------------------------
+
+
+keyName :: CharParser AfmKey
+keyName = lexeme (many1 $ satisfy isAlphaNum) 
+
+
+newlineOrEOF :: CharParser ()
+newlineOrEOF = skipOne (lexeme newline) <|> eof
+
+
+uptoNewline :: CharParser String
+uptoNewline = many1 (noneOf ['\n'])
+
+
+name :: CharParser String
+name = lexeme $ many (noneOf ";\n")
+
+name1 :: CharParser String
+name1 = lexeme $ many (noneOf "; \t\n")
+
+
+
+semi :: CharParser Char
+semi = lexeme $ char ';'
+
+
+
+
+number :: CharParser AfmUnit
+number = liftA realToFrac double
+
+
+cint :: CharParser Int
+cint = hexInt <|> octInt <|> int
+
+
+hexInt :: CharParser Int
+hexInt = lexeme $ between (char '<') (char '>') P.hexBase
+
+
+octInt :: CharParser Int
+octInt = lexeme $ char '\\' *> P.octBase
+
+
+
+--------------------------------------------------------------------------------
+
+-- no newline in whitespace
+
+
+lp :: P.LexemeParser
+lp = P.commentLineLexemeParser "Comment" [' ', '\t']
+
+
+lexeme          :: CharParser a -> CharParser a
+lexeme          = P.lexeme lp
+
+symbol          :: String -> CharParser String
+symbol          = lexeme . string
+
+-- whiteSpace      :: CharParser ()
+-- whiteSpace      = P.whiteSpace lp
+
+
+integer         :: CharParser Integer
+integer         = lexeme P.integer
+
+int             :: CharParser Int
+int             = fromIntegral <$> integer
+
+double          :: CharParser Double
+double          = lexeme P.double
diff --git a/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs b/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs
@@ -0,0 +1,113 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.AfmTopLevel
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Top-level AFM V4.1 font loader. 
+--
+-- Use this module to build a font loader if you want to work with 
+-- the Adobe metrics sets, but find the @simpleFontLoader@ in 
+-- @Wumpus.Basic.System.FontLoader@ too inflexible.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.AfmTopLevel
+  ( 
+
+    loadAfmFontMetrics
+
+  , loadAfmFont1  
+
+  ) where
+
+import Wumpus.Basic.Kernel
+import Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser
+import Wumpus.Basic.System.FontLoader.Datatypes
+import Wumpus.Basic.System.FontLoader.FontLoadMonad
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Monad
+import Data.Monoid
+
+-- The file names of the Afm fonts match there PostScript names,
+-- the only difference is the addition of a @.afm@ extension.
+--
+
+-- | 'loadAfmFontMetrics' : 
+-- @ path_to_afm_fonts * [font_name] -> IO FontLoadResult @ 
+-- 
+-- Load the supplied list of fonts. 
+-- 
+-- Note - if a font fails to load a message is written to the 
+-- log and monospaced /fallback metrics/ are used.
+--
+loadAfmFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult
+loadAfmFontMetrics font_dir_path ds = 
+    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds
+  where
+    mkFun                = afmLoadFontMetrics font_dir_path  
+ 
+    post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs
+                           in FontLoadResult mempty errs
+    post (Right xs,msgs) = let body = foldr fn mempty xs
+                           in FontLoadResult body msgs
+    
+    fn (name,metrics) table = insertFont name metrics table
+
+
+-- TODO - need a one font version...
+
+
+-- | 'loadAfmFont1' : 
+-- @ path_to_afm_fonts * font_def -> IO FontLoadResult @ 
+-- 
+-- Load a single AFM font. 
+-- 
+-- Note - if the font fails to load a message is written to the 
+-- log and monospaced /fallback metrics/ are used.
+--
+loadAfmFont1 :: FilePath -> FontDef -> IO FontLoadResult
+loadAfmFont1 font_dir_path font_def =
+    liftM post $ runFontLoadIO $ afmLoadFontMetrics font_dir_path font_def
+  where
+    post (Left err,msgs)    = let errs = fontLoadMsg err `mappend` msgs
+                              in FontLoadResult mempty errs
+    post (Right (a,b),msgs) = let body = insertFont a b mempty
+                              in FontLoadResult body msgs
+    
+
+
+afmLoadFontMetrics :: FilePath -> FontDef -> FontLoadIO (FontName,FontMetrics)
+afmLoadFontMetrics font_dir_path font_def = do
+    tellLoadMsg  $ "Loading " ++ afm_file
+    path        <- checkFontPath font_dir_path afm_file
+    ans         <- runParserFLIO path afmV4Dot1Parser
+    props       <- buildAfmFontProps  afm_mono_defaults_4_1 ans
+    return (name, buildMetricsOps afmValue props)
+  where
+    afm_file    = afm_file_name font_def
+    name        = ps_font_name $ font_def_face font_def
+
+
+-- | These are values extracted from Courier in the core 14 fonts.
+--
+afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit
+afm_mono_defaults_4_1 = 
+    MonospaceDefaults { default_letter_bbox         = bbox
+                      , default_cap_height          = 562
+                      , default_descender           = (-157)
+                      , default_underline_position  = (-100)
+                      , default_underline_thickness = 50 
+                      , default_char_width          = V2 600 0
+                      }
+  where
+    bbox = BBox (P2 (-23) (-250)) (P2 715 805)
diff --git a/src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs b/src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.AfmV2Parser
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- AFM file parser for Version 2.0.
+--
+-- Note - AFM Version 2.0 used by GhostScript and Version 3.0+
+-- have numerous differences. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.AfmV2Parser
+  ( 
+    afmV2Parser
+
+  ) where
+
+import Wumpus.Basic.System.FontLoader.AfmParserBase
+import Wumpus.Basic.System.FontLoader.Datatypes
+import Wumpus.Basic.Utils.ParserCombinators
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+
+
+
+--------------------------------------------------------------------------------
+-- parser
+
+
+afmV2Parser :: CharParser AfmFile
+afmV2Parser = afmFileParser charMetricsV2
+
+
+charMetricsV2 :: CharParser AfmGlyphMetrics
+charMetricsV2 = AfmGlyphMetrics <$>
+        metric "C" (-1) cint
+    <*> widthVector
+    <*> metric "N" "" name1
+    <*  charBBox
+    <*  many (symbol "L" *> ligature_body <* semi)
+    <*  newlineOrEOF
+  where
+    ligature_body = ((,) <$> name <*> name)
+    
+widthVector :: CharParser (Vec2 AfmUnit)
+widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)
+           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)
+
+
+--------------------------------------------------------------------------------
+
+
+
+
diff --git a/src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- AFM file parser for Version 4.1.
+--
+-- Adobe distributes font metrics for the /Core 14/ fonts as
+-- AFM Version 4.1 files.  
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser
+  ( 
+    
+    afmV4Dot1Parser  
+  ) where
+
+import Wumpus.Basic.System.FontLoader.AfmParserBase
+import Wumpus.Basic.System.FontLoader.Datatypes
+import Wumpus.Basic.Utils.ParserCombinators
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+
+afmV4Dot1Parser :: CharParser AfmFile
+afmV4Dot1Parser = afmFileParser charMetricsV4Dot1
+
+
+charMetricsV4Dot1 :: CharParser AfmGlyphMetrics
+charMetricsV4Dot1 = AfmGlyphMetrics <$>
+        characterCode
+    <*> widthVector
+    <*> metric "N" "" name1
+    <*  charBBox
+    <*  many (symbol "L" *> ligature_body <* semi)
+    <*  newlineOrEOF
+  where
+    ligature_body = ((,) <$> name <*> name)
+
+
+-- Note - there are many variants for width vectors in in 4.1.
+-- Wumpus needs some thought about what to do for them, it also
+-- needs some facility to tell how successful the parse has been.
+    
+widthVector :: CharParser (Vec2 AfmUnit)
+widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)
+           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)
+
+
+-- V4.1 allows C int or CH \<hex\>
+--
+characterCode :: CharParser Int
+characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint  
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs
+++ /dev/null
@@ -1,210 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Base.AfmParserBase
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Common parsers for AFM files.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Base.AfmParserBase
-  ( 
-
-    afmFileParser
-  , runQuery
-  , textQuery
-
-  , getFontBBox
-  , getEncodingScheme
-  , getCapHeight
-  
-  , charBBox
-  , metric
-  , keyStringPair
-  , versionNumber  
-  , startCharMetrics
-
-  , keyName
-  , newlineOrEOF
-  , name
-  , name1
-  , semi
-  , uptoNewline
-  , number
-  , cint
-  , hexInt
-  , octInt
-
-  , lexeme
-  , symbol
-  , integer
-  , int
-  , double
-
-  ) where
-
-import Wumpus.Basic.System.FontLoader.Base.Datatypes
-
-import Wumpus.Basic.Utils.ParserCombinators
-import qualified Wumpus.Basic.Utils.TokenParsers as P
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Control.Applicative
-
-import Data.Char
-import qualified Data.Map               as Map
-
-
-afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile
-afmFileParser pgm = do 
-    info <- (versionNumber    *> globalInfo) 
-    cms  <- (startCharMetrics *> many pgm)
-    return $ AfmFile 
-              { afm_encoding        = getEncodingScheme info
-              , afm_letter_bbox     = getFontBBox       info
-              , afm_cap_height      = getCapHeight      info
-              , afm_glyph_metrics   = cms
-              }
-
-globalInfo :: CharParser GlobalInfo
-globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) 
-               <$> manyTill keyStringPair (peek startCharMetrics)
-
-
- 
-runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a
-runQuery field_name p table = 
-    Map.lookup field_name table >>= extr . runParser p
-  where
-    extr (Okay a _) = Just a
-    extr _          = Nothing
-
-textQuery :: String -> GlobalInfo -> Maybe String
-textQuery = Map.lookup
-
-
--- | Strictly speaking a fontBBox is measured in integer units.
---
-getFontBBox            :: GlobalInfo -> Maybe AfmBoundingBox
-getFontBBox            = runQuery "FontBBox" fontBBox
-
-getEncodingScheme      :: GlobalInfo -> Maybe String
-getEncodingScheme      = textQuery "EncodingScheme"
-
-getCapHeight           :: GlobalInfo -> Maybe AfmUnit
-getCapHeight           = runQuery "CapHeight" number
-
-
-charBBox :: CharParser AfmBoundingBox
-charBBox = symbol "B" *> fontBBox <* semi
-
-fontBBox :: CharParser AfmBoundingBox
-fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury))
-              <$> number <*> number <*> number <*> number
-
-
-
-metric :: String -> a -> CharParser a -> CharParser a
-metric iden dfault p = option dfault go
-  where
-    go = symbol iden *> p <* semi
-
-
-
-keyStringPair :: CharParser (AfmKey,String)
-keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF 
-             <?> "key-value line"
-
-versionNumber :: CharParser String
-versionNumber = 
-    symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF
-      <?> "StartFontMetrics"
-
-
-startCharMetrics :: CharParser Int
-startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF
-                <?> "StartCharMetrics failed"
-
-
-
---------------------------------------------------------------------------------
-
-
-keyName :: CharParser AfmKey
-keyName = lexeme (many1 $ satisfy isAlphaNum) 
-
-
-newlineOrEOF :: CharParser ()
-newlineOrEOF = skipOne (lexeme newline) <|> eof
-
-
-uptoNewline :: CharParser String
-uptoNewline = many1 (noneOf ['\n'])
-
-
-name :: CharParser String
-name = lexeme $ many (noneOf ";\n")
-
-name1 :: CharParser String
-name1 = lexeme $ many (noneOf "; \t\n")
-
-
-
-semi :: CharParser Char
-semi = lexeme $ char ';'
-
-
-
-
-number :: CharParser AfmUnit
-number = liftA realToFrac double
-
-
-cint :: CharParser Int
-cint = hexInt <|> octInt <|> int
-
-
-hexInt :: CharParser Int
-hexInt = lexeme $ between (char '<') (char '>') P.hexBase
-
-
-octInt :: CharParser Int
-octInt = lexeme $ char '\\' *> P.octBase
-
-
-
---------------------------------------------------------------------------------
-
--- no newline in whitespace
-
-
-lp :: P.LexemeParser
-lp = P.commentLineLexemeParser "Comment" [' ', '\t']
-
-
-lexeme          :: CharParser a -> CharParser a
-lexeme          = P.lexeme lp
-
-symbol          :: String -> CharParser String
-symbol          = lexeme . string
-
--- whiteSpace      :: CharParser ()
--- whiteSpace      = P.whiteSpace lp
-
-
-integer         :: CharParser Integer
-integer         = lexeme P.integer
-
-int             :: CharParser Int
-int             = fromIntegral <$> integer
-
-double          :: CharParser Double
-double          = lexeme P.double
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Internal.AfmV2Parser
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- AFM file parser for Version 2.0.
---
--- Note - AFM Version 2.0 used by GhostScript and Version 3.0+
--- have numerous differences. 
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Base.AfmV2Parser
-  ( 
-    afmV2Parser
-
-  ) where
-
-import Wumpus.Basic.System.FontLoader.Base.AfmParserBase
-import Wumpus.Basic.System.FontLoader.Base.Datatypes
-import Wumpus.Basic.Utils.ParserCombinators
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Control.Applicative
-
-
-
-
---------------------------------------------------------------------------------
--- parser
-
-
-afmV2Parser :: CharParser AfmFile
-afmV2Parser = afmFileParser charMetricsV2
-
-
-charMetricsV2 :: CharParser AfmGlyphMetrics
-charMetricsV2 = AfmGlyphMetrics <$>
-        metric "C" (-1) cint
-    <*> widthVector
-    <*> metric "N" "" name1
-    <*  charBBox
-    <*  many (symbol "L" *> ligature_body <* semi)
-    <*  newlineOrEOF
-  where
-    ligature_body = ((,) <$> name <*> name)
-    
-widthVector :: CharParser (Vec2 AfmUnit)
-widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)
-           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)
-
-
---------------------------------------------------------------------------------
-
-
-
-
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- AFM file parser for Version 4.1.
---
--- Adobe distributes font metrics for the /Core 14/ fonts as
--- AFM Version 4.1 files.  
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser
-  ( 
-    
-    afmV4Dot1Parser  
-  ) where
-
-import Wumpus.Basic.System.FontLoader.Base.AfmParserBase
-import Wumpus.Basic.System.FontLoader.Base.Datatypes
-import Wumpus.Basic.Utils.ParserCombinators
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Control.Applicative
-
-
-afmV4Dot1Parser :: CharParser AfmFile
-afmV4Dot1Parser = afmFileParser charMetricsV4Dot1
-
-
-charMetricsV4Dot1 :: CharParser AfmGlyphMetrics
-charMetricsV4Dot1 = AfmGlyphMetrics <$>
-        characterCode
-    <*> widthVector
-    <*> metric "N" "" name1
-    <*  charBBox
-    <*  many (symbol "L" *> ligature_body <* semi)
-    <*  newlineOrEOF
-  where
-    ligature_body = ((,) <$> name <*> name)
-
-
--- Note - there are many variants for width vectors in in 4.1.
--- Wumpus needs some thought about what to do for them, it also
--- needs some facility to tell how successful the parse has been.
-    
-widthVector :: CharParser (Vec2 AfmUnit)
-widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)
-           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)
-
-
--- V4.1 allows C int or CH \<hex\>
---
-characterCode :: CharParser Int
-characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint  
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Base.Datatypes
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Datatypes
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Base.Datatypes
-  (
-
-  -- * Afm Unit
-    AfmUnit
-  , afmValue
-  , afmUnitScale
-  
-  -- * Glyph metrics
-
-  , PSCharCode
-  , PSEncodingScheme
-  , AfmBoundingBox
-
-  , AfmKey
-  , GlobalInfo
-  , AfmFile(..)
-  , AfmGlyphMetrics(..)
-
-  , MonospaceDefaults(..)
-
-  , FontProps(..)
-  , buildMetricsOps
-  
-  ) where
-
-
-import Wumpus.Basic.Kernel.Base.GlyphMetrics
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import qualified Data.IntMap   as IntMap
-import qualified Data.Map as Map
-
-
-
--- | Wrapped Double representing 1\/1000 of the scale factor
--- (Point size) of a font. AFM files encode all measurements 
--- as these units. 
--- 
-newtype AfmUnit = AfmUnit { getAfmUnit :: Double } 
-  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
-
-instance Show AfmUnit where
-  showsPrec p d = showsPrec p (getAfmUnit d)
-
-
--- | Compute the size of a measurement in Afm units scaled by the
--- point size of the font.
---
-afmValue :: FromPtSize u => AfmUnit -> PtSize -> u
-afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000)
-
-afmUnitScale :: AfmUnit -> PtSize 
-afmUnitScale u = (realToFrac $ getAfmUnit u / 1000)
-
-
---------------------------------------------------------------------------------
-
--- | Afm files index glyphs by /PostScript character code/. This 
--- is not the same as Unicode, ASCII...
---
--- It is expected to be determined by @EncodingScheme@ in the
--- Global Font Information Section.
---
-type PSCharCode         = Int
-
-type PSEncodingScheme   = String
-
-type AfmBoundingBox     = BoundingBox AfmUnit
-
-type AfmKey         = String
-type GlobalInfo     = Map.Map AfmKey String
-
-
-
--- | Wumpus needs a very small subset of AFM files, common to both
--- version 2.0 and version 4.1.
---
--- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1
--- 
--- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus 
--- uses cap height in calculations, glyph metrics must be build 
--- with an arbitrary value if it is not present.
---
--- Encoding Scheme is optional in AFM files.
---
-data AfmFile = AfmFile 
-      { afm_encoding        :: Maybe String
-      , afm_letter_bbox     :: Maybe AfmBoundingBox
-      , afm_cap_height      :: Maybe AfmUnit
-      , afm_glyph_metrics   :: [AfmGlyphMetrics]
-      }
-  deriving (Show) 
-  
--- Note - for AfmFile BBox is a required field for version 4.1, 
--- but it appears to be optional for version 2.0.
---
-
-
-data AfmGlyphMetrics = AfmGlyphMetrics
-      { afm_char_code       :: !PSCharCode
-      , afm_width_vector    :: !(Vec2 AfmUnit)
-      , afm_char_name       :: !String
-      }
-  deriving (Eq,Show)
-
-
--- | Monospace defaults are used if the font loader fails to 
--- extract the necessary fields.
--- 
--- The values are taken from the font correpsonding to Courier 
--- in the distributed font files.
---
-data MonospaceDefaults cu = MonospaceDefaults 
-      { default_letter_bbox  :: BoundingBox cu
-      , default_cap_height   :: cu
-      , default_char_width   :: Vec2 cu
-      }
-  deriving (Eq,Show)
-
-
-
--- | The metrics read from a font file by a font loader. 
--- 
--- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and 
--- not on the usual @u@. A typical character unit is 'AfmUnit', 
--- the unit of measurement for AFM files (1000th of a point).
---
--- The is the initial representation used by Wumpus-Basic as an
--- syntax tree when loading font files. 
---
-data FontProps cu = FontProps
-       { fp_bounding_box        :: BoundingBox cu 
-       , fp_default_adv_vec     :: Vec2 cu
-       , fp_adv_vecs            :: IntMap.IntMap (Vec2 cu)
-       , fp_cap_height          :: cu
-       }
-
-
--- | Build a MetricsOps function table, from a character unit
--- 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) = 
-    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)
-      }
-  where
-    upscale sz d            = fromPtSize $ sz * d 
- 
-    defaultAV sz            = V2 (upscale sz $ fn vx) (upscale sz $ fn vy) 
-    scalePt  sz (P2 cx cy)  = P2 (upscale sz $ fn cx) (upscale sz $ fn cy) 
-    scaleVec sz (V2 cx cy)  = V2 (upscale sz $ fn cx) (upscale sz $ fn cy) 
-
-
-
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs
+++ /dev/null
@@ -1,205 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Base.FontLoadMonad
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Font load monad handling IO (file system access), failure and 
--- logging.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Base.FontLoadMonad
-  (
-    FontLoadErr
-  , FontLoadIO
-  , runFontLoadIO
-  , evalFontLoadIO
-  , loadError
-  , logLoadMsg
-  , promoteIO
-  , promoteEither
-  , runParserFLIO
-
-  , sequenceAll
-
-  -- * Font loading
-
-  , buildAfmFontProps
-  , checkFontPath
-  
-  ) where
-
-import Wumpus.Basic.System.FontLoader.Base.Datatypes
-import Wumpus.Basic.Utils.HList
-import Wumpus.Basic.Utils.ParserCombinators
-
-
-import Wumpus.Core                              -- package: wumpus-core
-import Wumpus.Core.Text.GlyphIndices
-
-
-import Control.Monad
-import qualified Data.IntMap            as IntMap
-import qualified Data.Map as Map
-import Data.Monoid
-import System.Directory
-import System.FilePath
-
-
-
---------------------------------------------------------------------------------
--- FontLoadIO monad - IO plus Error
-
-
-
-type FontLoadErr        = String
-
-newtype FontLoadLog     = FontLoadLog { getFontLoadLog :: H String }
-
-
-instance Monoid FontLoadLog where
-  mempty        = FontLoadLog $ emptyH
-  a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b
-
-
-
-newtype FontLoadIO a = FontLoadIO { 
-          getFontLoadIO :: IO (Either FontLoadErr a, FontLoadLog ) }
-
-instance Functor FontLoadIO where
-  fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w)
- 
-instance Monad FontLoadIO where
-  return a = FontLoadIO $ return (Right a, mempty)
-  m >>= k  = FontLoadIO $ getFontLoadIO m >>= fn 
-              where
-                fn (Left err, w) = return (Left err, w)
-                fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> 
-                                   return (b, w1 `mappend` w2)
-
-runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a,[String])
-runFontLoadIO ma = liftM post $ getFontLoadIO ma 
-  where
-    post (ans,w) = (ans, toListH $ getFontLoadLog w)
-
-
-evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a)
-evalFontLoadIO ma = liftM post $ getFontLoadIO ma
-  where
-    post (ans,_) = ans
-
-
-loadError :: FontLoadErr -> FontLoadIO a
-loadError msg = FontLoadIO $ return (Left msg, mempty)
-
-logLoadMsg :: String -> FontLoadIO ()
-logLoadMsg msg = FontLoadIO $ return (Right (), message1 msg ) 
-
-
-message1 :: String -> FontLoadLog 
-message1 = FontLoadLog . wrapH
-
-
--- | aka liftIO
-promoteIO :: IO a -> FontLoadIO a
-promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty)
-
-promoteEither :: Either FontLoadErr a -> FontLoadIO a
-promoteEither = either loadError return 
-
-runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a
-runParserFLIO filepath p = 
-   promoteIO (readFile filepath) >>= promoteEither . runParserEither p
-
-
--- | The standard monadic @sequence@ would finish on first fail
--- for the FontLoadIO monad. As we want to be able to sequence
--- the loading of a list of fonts, this is not really the 
--- behaviour we want for Wumpus. Instead we prefer to use fallback 
--- metrics and produce an inaccurate drawing on a font load error
--- rather than fail and produce no drawing.
---
-sequenceAll :: [FontLoadIO a] -> FontLoadIO [a]
-sequenceAll = FontLoadIO . step
-   where
-    step []     = return (Right [], mempty)
-    step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) 
-
-cons :: (Either FontLoadErr a, FontLoadLog)
-     -> (Either FontLoadErr [a], FontLoadLog)
-     -> (Either FontLoadErr [a], FontLoadLog)
-cons (Right a, w1)  (Right as, w2) = 
-    (Right $ a:as,  w1 `mappend` w2)
-
-cons (Right a, w1)  (Left e2, w2) = 
-    (Right [a], w1 `mappend` w2 `mappend` message1 e2)
-
-cons (Left e1, w1)  (Right as, w2) = 
-    (Right as, w1 `mappend` message1 e1 `mappend` w2)
-
-cons (Left e1, w1)  (Left e2,  w2) = 
-    (Right [], w1 `mappend` message1 e1 `mappend` w2 `mappend` message1 e2)
-
-
-
---------------------------------------------------------------------------------
-
-
--- | Afm files do not have a default advance vec so use the 
--- monospace default.
--- 
--- Afm files hopefully have @CapHeight@ and @FontBBox@ properties
--- in the header. Use the monospace default only if they are 
--- missing.
--- 
-buildAfmFontProps :: MonospaceDefaults AfmUnit 
-                  -> AfmFile 
-                  -> FontLoadIO (FontProps AfmUnit)
-buildAfmFontProps defaults afm = do 
-    cap_height <- extractCapHeight 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
-               }  
-  where
-    char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm
- 
-    fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of
-                                          Nothing -> table
-                                          Just i  -> IntMap.insert i v table
-
-
-extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
-extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm
-  where
-    errk = logLoadMsg "WARNING - Could not extract CapHeight" >> 
-           return (default_cap_height defaults)
-
-
-extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile 
-                -> FontLoadIO (BoundingBox AfmUnit)
-extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm
-  where
-    errk = logLoadMsg "WARNING - Could not extract CapHeight" >> 
-           return (default_letter_bbox defaults)
-
-
-
-checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath
-checkFontPath path_root font_file_name = 
-    let full_path = normalise (path_root </> font_file_name)
-    in do { check <- promoteIO (doesFileExist full_path)
-          ; if check then return full_path
-                     else loadError $ "Could not resolve path: " ++ full_path
-          }
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs b/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.Base.GSFontMap
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- GhostScript Font map.
---
--- GhostScript aliases the /Core 14/ PostScript fonts to fonts
--- it can freely distribute. This module provides aliases to 
--- Wumpus so the font loader can find the equivalent GhostScript
--- files to the Core 14 set.
---
--- The data in this file matches GhostScript 8.63. Other versions
--- of GhostScript may need different aliases.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.Base.GSFontMap
-  (
-   
-    GSFontMap(..)
-  , gsMetricsFile
-  , gsFontAlias
-  , gsVersionNumber
-  , ghostscript_fontmap_8_54
-
-  ) where
-
-
-import Data.Map ( Map )
-import qualified Data.Map as Map
-
-
--- | GhostScript version that the aliases were derived from.
--- 
--- ghostscript_version :: String
--- ghostscript_version = "gs8.54"
-
-
--- | A map from standard /Adode PostScript/ font name to the
--- equivalent GhostScript font and AFM file name.
---
--- It is expected that all GhostScript AFM files will be located
--- in the same directory.
---
-data GSFontMap = GSFontMap
-      { ghostscript_version :: String
-      , ghostscript_fontmap :: Map String (String, FilePath)
-      }
-
-
--- | Get the @.afm@ metrics file.
---
--- Note this return only the file name and not the path to it.
--- The full path must be resolved in client code.
---
-gsMetricsFile :: GSFontMap -> String -> Maybe FilePath
-gsMetricsFile mp name = fmap snd $ Map.lookup name (ghostscript_fontmap mp)
-
--- | Get the GhostScript font name alias.
---
-gsFontAlias :: GSFontMap -> String -> Maybe String
-gsFontAlias mp name = fmap fst $ Map.lookup name (ghostscript_fontmap mp)
-
-
--- | Get the GhostScript version number that the FontMap 
--- represents.
---
-gsVersionNumber :: GSFontMap -> String
-gsVersionNumber = ghostscript_version 
-
-
--- | Map from PostScript font name to the corresponding 
--- GhostScript name and file.
---
--- Naming is correct for GhostSCript version 8.54.
--- 
-ghostscript_fontmap_8_54 :: GSFontMap
-ghostscript_fontmap_8_54 = GSFontMap "8.54" body
-  where
-    body = Map.fromList $ 
-            [ ("Courier",                 ("NimbusMonL-Regu",         "n022003l.afm"))
-            , ("Courier-Oblique",         ("NimbusMonL-ReguObli",     "n022023l.afm"))
-            , ("Courier-Bold",            ("NimbusMonL-Bold",         "n022004l.afm"))
-            , ("Courier-BoldOblique",     ("NimbusMonL-BoldObli",     "n022024l.afm"))
-  
-            , ("Helvetica",               ("NimbusSanL-Regu",         "n019003l.afm"))
-            , ("Helvetica-Oblique",       ("NimbusSanL-ReguItal",     "n019023l.afm"))
-            , ("Helvetica-Bold",          ("NimbusSanL-Bold",         "n019004l.afm"))
-            , ("Helvetica-BoldOblique",   ("NimbusSanL-BoldItal",     "n019024l.afm"))
-
-            , ("Times-Roman",             ("NimbusRomNo9L-Regu",      "n021003l.afm"))
-            , ("Times-Italic",            ("NimbusRomNo9L-ReguItal",  "n021023l.afm"))
-            , ("Times-Bold",              ("NimbusRomNo9L-Medi",      "n021004l.afm"))
-            , ("Times-BoldItalic",        ("NimbusRomNo9L-MediItal",  "n021024l.afm"))
-
-            , ("Symbol",                  ("StandardSymL",            "s050000l.afm"))
-
-            , ("ZapfDingbats",            ("Dingbats",                "d050000l.afm"))
-            ]
-
diff --git a/src/Wumpus/Basic/System/FontLoader/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Datatypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/Datatypes.hs
@@ -0,0 +1,166 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.Datatypes
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Datatypes
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.Datatypes
+  (
+  
+  -- * Glyph metrics
+
+    PSCharCode
+  , PSEncodingScheme
+  , AfmBoundingBox
+
+  , AfmKey
+  , GlobalInfo
+  , AfmFile(..)
+  , AfmGlyphMetrics(..)
+
+  , MonospaceDefaults(..)
+
+  , FontProps(..)
+  , buildMetricsOps
+  
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.FontSupport
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import qualified Data.IntMap   as IM
+import qualified Data.Map      as M
+
+
+
+
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- | Afm files index glyphs by /PostScript character code/. This 
+-- is not the same as Unicode, ASCII...
+--
+-- It is expected to be determined by @EncodingScheme@ in the
+-- Global Font Information Section.
+--
+type PSCharCode         = Int
+
+type PSEncodingScheme   = String
+
+type AfmBoundingBox     = BoundingBox AfmUnit
+
+type AfmKey         = String
+type GlobalInfo     = M.Map AfmKey String
+
+
+
+-- | Wumpus needs a very small subset of AFM files, common to both
+-- version 2.0 and version 4.1.
+--
+-- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1
+-- 
+-- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus 
+-- uses cap height in calculations, glyph metrics must be build 
+-- with an arbitrary value if it is not present.
+--
+-- Encoding Scheme is optional in AFM files.
+--
+data AfmFile = AfmFile 
+      { afm_encoding                :: Maybe String
+      , afm_letter_bbox             :: Maybe AfmBoundingBox
+      , afm_cap_height              :: Maybe AfmUnit
+      , afm_descender               :: Maybe AfmUnit
+      , afm_underline_position      :: Maybe AfmUnit
+      , afm_underline_thickness     :: Maybe AfmUnit
+      , afm_glyph_metrics           :: [AfmGlyphMetrics]
+      }
+  deriving (Show) 
+  
+-- Note - for AfmFile BBox is a required field for version 4.1, 
+-- but it appears to be optional for version 2.0.
+--
+
+
+data AfmGlyphMetrics = AfmGlyphMetrics
+      { afm_char_code       :: !PSCharCode
+      , afm_width_vector    :: !(Vec2 AfmUnit)
+      , afm_char_name       :: !String
+      }
+  deriving (Eq,Show)
+
+
+-- | Monospace defaults are used if the font loader fails to 
+-- extract the necessary fields.
+-- 
+-- The values are taken from the font correpsonding to Courier 
+-- in the distributed font files.
+--
+data MonospaceDefaults cu = MonospaceDefaults 
+      { default_letter_bbox         :: BoundingBox cu
+      , default_cap_height          :: cu
+      , default_descender           :: cu
+      , default_underline_position  :: cu
+      , default_underline_thickness :: cu
+      , default_char_width          :: Vec2 cu
+      }
+  deriving (Eq,Show)
+
+
+
+-- | The metrics read from a font file by a font loader. 
+-- 
+-- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and 
+-- not on the usual @u@. A typical character unit is 'AfmUnit', 
+-- the unit of measurement for AFM files (1000th of a point).
+--
+-- The is the initial representation used by Wumpus-Basic as an
+-- syntax tree when loading font files. 
+--
+data FontProps cu = FontProps
+       { fp_bounding_box        :: BoundingBox cu 
+       , fp_default_adv_vec     :: Vec2 cu
+       , fp_adv_vecs            :: IM.IntMap (Vec2 cu)
+       , fp_cap_height          :: cu
+       , fp_descender           :: cu
+       , fp_underline_position  :: cu
+       , fp_underline_thickness :: cu
+       }
+
+
+-- | Build a MetricsOps function table, from a character unit
+-- scaling function and FontProps read from a file.
+--
+buildMetricsOps :: (FontSize -> cu -> Double) -> FontProps cu -> FontMetrics
+buildMetricsOps fn font@(FontProps { fp_bounding_box = BBox ll ur
+                                   , fp_default_adv_vec = V2 vx vy }) = 
+    FontMetrics
+      { get_bounding_box  = \sz -> BBox (scalePt sz ll) (scalePt sz ur)
+      , get_cw_table      = \sz i -> 
+            maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font)
+      , get_cap_height    = \sz -> fn sz (fp_cap_height font)
+      , get_descender     = \sz -> fn sz (fp_descender font)
+      , get_underline_position  = \sz -> fn sz (fp_underline_position font)
+      , get_underline_thickness = \sz -> fn sz (fp_underline_thickness font)
+      }
+  where
+    defaultAV sz            = V2 (fn sz vx) (fn sz vy) 
+    scalePt  sz (P2 cx cy)  = P2 (fn sz cx) (fn sz cy) 
+    scaleVec sz (V2 cx cy)  = V2 (fn sz cx) (fn sz cy) 
+
+
+
diff --git a/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs
@@ -0,0 +1,218 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.FontLoadMonad
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Font load monad handling IO (file system access), failure and 
+-- logging.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.FontLoadMonad
+  (
+    FontLoadIO
+  , runFontLoadIO
+  , evalFontLoadIO
+  , loadError
+  , tellLoadMsg
+  , promoteIO
+  , promoteEither
+  , runParserFLIO
+
+  , sequenceAll
+
+  -- * Font loading
+
+  , buildAfmFontProps
+  , checkFontPath
+  
+  ) where
+
+import Wumpus.Basic.Kernel
+import Wumpus.Basic.System.FontLoader.Datatypes
+import Wumpus.Basic.Utils.ParserCombinators
+
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Text.GlyphIndices
+
+
+import Control.Monad
+import qualified Data.IntMap            as IntMap
+import qualified Data.Map as Map
+import Data.Monoid
+import System.Directory
+import System.FilePath
+
+
+
+--------------------------------------------------------------------------------
+-- FontLoadIO monad - IO plus Error
+
+
+
+newtype FontLoadIO a = FontLoadIO { 
+          getFontLoadIO :: IO (Either FontLoadMsg a, FontLoadLog ) }
+
+instance Functor FontLoadIO where
+  fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w)
+ 
+instance Monad FontLoadIO where
+  return a = FontLoadIO $ return (Right a, mempty)
+  m >>= k  = FontLoadIO $ getFontLoadIO m >>= fn 
+              where
+                fn (Left err, w) = return (Left err, w)
+                fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> 
+                                   return (b, w1 `mappend` w2)
+
+runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadMsg a, FontLoadLog)
+runFontLoadIO ma = getFontLoadIO ma 
+
+
+evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadMsg a)
+evalFontLoadIO ma = liftM post $ getFontLoadIO ma
+  where
+    post (ans,_) = ans
+
+
+loadError :: FontLoadMsg -> FontLoadIO a
+loadError msg = FontLoadIO $ return (Left msg, mempty)
+
+tellLoadMsg :: String -> FontLoadIO ()
+tellLoadMsg msg = FontLoadIO $ return (Right (), fontLoadMsg msg ) 
+
+
+
+-- | Promote an @IO@ action into the the @FontLoadIO@ monad.
+--
+-- This function is equivalent to @liftIO@.
+--
+promoteIO :: IO a -> FontLoadIO a
+promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty)
+
+promoteEither :: Either FontLoadMsg a -> FontLoadIO a
+promoteEither = either loadError return 
+
+runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a
+runParserFLIO filepath p = 
+   promoteIO (readFile filepath) >>= promoteEither . runParserEither p
+
+
+-- | The standard monadic @sequence@ would finish on first fail
+-- for the FontLoadIO monad. As we want to be able to sequence
+-- the loading of a list of fonts, this is not really the 
+-- behaviour we want for Wumpus. Instead we prefer to use fallback 
+-- metrics and produce an inaccurate drawing on a font load error
+-- rather than fail and produce no drawing.
+--
+sequenceAll :: [FontLoadIO a] -> FontLoadIO [a]
+sequenceAll = FontLoadIO . step
+   where
+    step []     = return (Right [], mempty)
+    step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) 
+
+cons :: (Either FontLoadMsg a, FontLoadLog)
+     -> (Either FontLoadMsg [a], FontLoadLog)
+     -> (Either FontLoadMsg [a], FontLoadLog)
+cons (Right a, w1)  (Right as, w2) = 
+    (Right $ a:as,  w1 `mappend` w2)
+
+cons (Right a, w1)  (Left e2, w2) = 
+    (Right [a], w1 `mappend` w2 `mappend` fontLoadMsg e2)
+
+cons (Left e1, w1)  (Right as, w2) = 
+    (Right as, w1 `mappend` fontLoadMsg e1 `mappend` w2)
+
+cons (Left e1, w1)  (Left e2,  w2) = 
+    (Right [], w1 `mappend` fontLoadMsg e1 `mappend` w2 `mappend` fontLoadMsg e2)
+
+
+
+--------------------------------------------------------------------------------
+
+
+-- | Afm files do not have a default advance vec so use the 
+-- monospace default.
+-- 
+-- Afm files hopefully have @CapHeight@ and @FontBBox@ properties
+-- in the header. Use the monospace default only if they are 
+-- missing.
+-- 
+buildAfmFontProps :: MonospaceDefaults AfmUnit 
+                  -> AfmFile 
+                  -> FontLoadIO (FontProps AfmUnit)
+buildAfmFontProps defaults afm = do 
+    cap_height    <- extractCapHeight   defaults afm
+    desc_depth    <- extractDescender   defaults afm
+    ul_position   <- extractUlPosition  defaults afm
+    ul_thickness  <- extractUlThickness 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
+               , fp_underline_position  = ul_position
+               , fp_underline_thickness = ul_thickness
+               }  
+  where
+    char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm
+ 
+    fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of
+                                          Nothing -> table
+                                          Just i  -> IntMap.insert i v table
+
+
+extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
+extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm
+  where
+    errk = tellLoadMsg "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 = tellLoadMsg "WARNING - Could not extract Descender" >> 
+           return (default_descender defaults)
+
+extractUlPosition :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
+extractUlPosition defaults afm = 
+    maybe errk return $ afm_underline_position afm
+  where
+    errk = tellLoadMsg "WARNING - Could not extract UnderlinePosition" >> 
+           return (default_underline_position defaults)
+
+extractUlThickness :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
+extractUlThickness defaults afm = 
+    maybe errk return $ afm_underline_thickness afm
+  where
+    errk = tellLoadMsg "WARNING - Could not extract UnderlineThickness" >> 
+           return (default_underline_thickness defaults)
+
+
+extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile 
+                -> FontLoadIO (BoundingBox AfmUnit)
+extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm
+  where
+    errk = tellLoadMsg "WARNING - Could not extract CapHeight" >> 
+           return (default_letter_bbox defaults)
+
+
+
+checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath
+checkFontPath path_root font_file_name = 
+    let full_path = normalise (path_root </> font_file_name)
+    in do { check <- promoteIO (doesFileExist full_path)
+          ; if check then return full_path
+                     else loadError $ "Could not resolve path: " ++ full_path
+          }
diff --git a/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs b/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs
@@ -0,0 +1,110 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.System.FontLoader.GSTopLevel
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Top-level GhostScript font loader. 
+--
+-- Use this module to build a font loader if you want to work with 
+-- GhostScript, but find the @simpleFontLoader@ in 
+-- @Wumpus.Basic.System.FontLoader@ too inflexible.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.System.FontLoader.GSTopLevel
+  ( 
+
+    loadGSFontMetrics
+
+  , loadGSFont1 
+   
+  ) where
+
+import Wumpus.Basic.Kernel
+import Wumpus.Basic.System.FontLoader.AfmV2Parser
+import Wumpus.Basic.System.FontLoader.Datatypes
+import Wumpus.Basic.System.FontLoader.FontLoadMonad
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Monad
+import Data.Monoid
+
+
+-- | 'loadGSFontMetrics' : 
+-- @ path_to_gs_fonts * [font_name] -> IO FontLoadResult @ 
+-- 
+-- Load the supplied list of fonts. 
+-- 
+-- Note - if a font fails to load a message is written to the 
+-- log and monospaced /fallback metrics/ are used.
+--
+loadGSFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult
+loadGSFontMetrics font_dir_path ds = 
+    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds
+  where
+    mkFun = gsLoadFontMetrics font_dir_path  
+
+    post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs
+                           in FontLoadResult mempty errs 
+    post (Right xs,msgs) = let body = foldr fn mempty xs
+                           in FontLoadResult body msgs
+
+    fn (name,metrics) table = insertFont name metrics table
+
+
+-- | 'loadGSFont1' : 
+-- @ path_to_gs_fonts * font_name -> IO FontLoadResult @ 
+-- 
+-- Load a single GhostScript font. 
+-- 
+-- Note - if the font fails to load a message is written to the 
+-- log and monospaced /fallback metrics/ are used.
+--
+loadGSFont1 :: FilePath -> FontDef -> IO FontLoadResult
+loadGSFont1 font_dir_path font_def = 
+   liftM post $ runFontLoadIO $ gsLoadFontMetrics font_dir_path font_def
+  where
+    post (Left err,msgs)    = let errs = fontLoadMsg err `mappend` msgs
+                              in FontLoadResult mempty errs 
+    post (Right (a,b),msgs) = let body = insertFont a b mempty
+                              in FontLoadResult body msgs
+
+
+
+gsLoadFontMetrics :: FilePath -> FontDef
+                  -> FontLoadIO (FontName,FontMetrics)
+gsLoadFontMetrics font_dir_path font_def = do
+    tellLoadMsg  $ "Loading " ++ gs_file
+    path        <- checkFontPath font_dir_path gs_file
+    ans         <- runParserFLIO path afmV2Parser
+    props       <- buildAfmFontProps  ghostscript_mono_defaults_8_54 ans
+    return (name, buildMetricsOps afmValue props)
+  where
+    gs_file     = gs_file_name font_def
+    name        = ps_font_name $ font_def_face font_def
+
+
+
+-- | These are values extracted from the file @n022003l.afm@
+-- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent 
+-- font for the core 14 font Courier.
+--
+ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit
+ghostscript_mono_defaults_8_54 = 
+    MonospaceDefaults { default_letter_bbox         = bbox
+                      , default_cap_height          = 563
+                      , default_descender           = (-186)
+                      , default_underline_position  = (-100)
+                      , default_underline_thickness = 50 
+                      , default_char_width          = V2 600 0
+                      }
+  where
+    bbox = BBox (P2 (-46) (-273)) (P2 650 820)
diff --git a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs b/src/Wumpus/Basic/System/FontLoader/GhostScript.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.System.FontLoader.GhostScript
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Font loader / import shim for GhostScript glyph metrics.
---
--- Use this loader if you have GhostScript installed and you want 
--- to use the (AFM v2.0) metrics that are distributed with 
--- GhostScript.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.System.FontLoader.GhostScript
-  ( 
-
-    loadGSMetrics
-  
-  ) where
-
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Base.AfmV2Parser
-import Wumpus.Basic.System.FontLoader.Base.Datatypes
-import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad
-import Wumpus.Basic.System.FontLoader.Base.GSFontMap
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Control.Monad
-import Data.Monoid
-
-
--- | 'loadGSMetrics' : 
--- @ path_to_gs_fonts * [font_name] -> IO (metrics, messages) @ 
--- 
--- Load the supplied list of fonts. 
--- 
--- Note - if a font fails to load a message is written to the 
--- log and monospaced /fallback metrics/ are used.
---
-loadGSMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String])
-loadGSMetrics font_dir_path ns = 
-    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns
-  where
-    mkFun = gsLoadFontCalcs font_dir_path ghostscript_fontmap_8_54 
-    
-    post (Left err,ss) = (mempty, ss ++ [err]) -- unreachable...
-    post (Right xs,ss) = (foldr insertFont mempty xs, ss)
-
-
-gsLoadFontCalcs :: FilePath -> GSFontMap -> FontName 
-                -> FontLoadIO FontMetricsOps
-gsLoadFontCalcs font_dir_path fm name = do
-    logLoadMsg  $ "Loading " ++ name
-    font_file   <- resolveFontFile fm name 
-    path        <- checkFontPath font_dir_path font_file
-    ans         <- runParserFLIO path afmV2Parser
-    props       <- buildAfmFontProps  ghostscript_mono_defaults_8_54 ans
-    return $ FontMetricsOps name (buildMetricsOps afmUnitScale props)
-
-
-resolveFontFile :: GSFontMap -> FontName -> FontLoadIO FilePath
-resolveFontFile fm name = maybe errk return $ gsMetricsFile fm name
-  where
-    errk = loadError $ "Could note resolve GhostScript alias for " ++ name
-
-
--- | These are values extracted from the file @n022003l.afm@
--- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent 
--- font for the core 14 font Courier.
---
-ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit
-ghostscript_mono_defaults_8_54 = 
-    MonospaceDefaults { default_letter_bbox  = bbox
-                      , default_cap_height   = 563
-                      , default_char_width   = V2 600 0
-                      }
-  where
-    bbox = BBox (P2 (-46) (-273)) (P2 650 820)
diff --git a/src/Wumpus/Basic/Utils/FormatCombinators.hs b/src/Wumpus/Basic/Utils/FormatCombinators.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Utils/FormatCombinators.hs
+++ /dev/null
@@ -1,430 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Utils.FormatCombinators
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Formatting combinators - pretty printers without the fitting.
---
--- Note - indentation support is very limited. Generally one 
--- should use a proper pretty printing library.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Utils.FormatCombinators
-  (
-    Doc
-  , DocS
-  , Format(..)
-  , empty
-  , showsDoc
-  , (<>)
-  , (<+>)  
-  , vconcat
-  , separate
-  , hcat
-  , hsep
-  , vcat
-
-  , text
-  , char
-  , int
-  , integer
-  , integral
-  , float
-  , double
-  , hex4
-
-  , space
-  , comma
-  , semicolon
-  , line
-
-  , fill
-  , fillStringR
-  , fillStringL
-
-  , punctuate
-  , enclose
-  , squotes
-  , dquotes
-  , parens
-  , brackets
-  , braces
-  , angles
-
-  , lparen
-  , rparen
-  , lbracket
-  , rbracket
-  , lbrace
-  , rbrace
-  , langle
-  , rangle
-
-  , list
-  , tupled
-  , semiBraces
-
-  , indent
-
-  , writeDoc
-    
-  ) where
-
-import Data.Monoid
-import Numeric
-
--- | Doc is a Join List ...
---
-data Doc = Doc1   ShowS 
-         | Join   Doc   Doc
-         | Line
-         | Indent !Int  Doc 
-
-
-type DocS = Doc -> Doc
-
-
--- Join could be improved...
---
-unDoc :: Doc -> ShowS
-unDoc = step 0 id
-  where
-   step _ acc (Doc1 sf)    = acc . sf
-   step n acc (Join a b)   = let acc' = step n acc a in step n acc' b
-   step n acc Line         = acc . showChar '\n' . indentS n
-   step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d
-
-
-indentS :: Int -> ShowS
-indentS i | i < 1     = id
-          | otherwise = showString $ replicate i ' '
-
-runDoc :: Doc -> String
-runDoc = ($ "") . unDoc
-
-
-instance Show Doc where
-  show = runDoc
-
-instance Monoid Doc where
-  mempty = empty
-  mappend = (<>)
-
-
-class Format a where format :: a -> Doc
-
---------------------------------------------------------------------------------
-        
-infixr 6 <>, <+>
-
-
-
--- | Create an empty, zero length document.
---
-empty :: Doc
-empty = Doc1 id
-
--- | Create a document from a ShowS function.
---
-showsDoc :: ShowS -> Doc
-showsDoc = Doc1
-
-
--- | Horizontally concatenate two documents with no space 
--- between them.
--- 
-(<>) :: Doc -> Doc -> Doc
-a <> b = Join a b 
-
-
--- | Horizontally concatenate two documents with a single space 
--- between them.
--- 
-(<+>) :: Doc -> Doc -> Doc
-a <+> b = Join a (Join space b)
-
--- | Vertical concatenate two documents with a line break.
--- 
-vconcat :: Doc -> Doc -> Doc
-vconcat a b = a <> Line <> b
-
-
-
-separate :: Doc -> [Doc] -> Doc
-separate _   []     = empty
-separate sep (a:as) = step a as
-  where
-    step acc []     = acc
-    step acc (x:xs) = step (acc <> sep <> x) xs
-
--- | Horizontally concatenate a list of documents with @(\<\>)@.
---
-hcat :: [Doc] -> Doc
-hcat = foldr (<>) empty
-
--- | Horizontally concatenate a list of documents with @(\<+\>)@.
---
-hsep :: [Doc] -> Doc
-hsep = separate space
-
--- | Vertically concatenate a list of documents, with a line 
--- break between each doc.
---
-vcat :: [Doc] -> Doc
-vcat []     = empty
-vcat (x:xs) = step x xs 
-  where
-    step acc (z:zs) = step (acc `vconcat` z) zs
-    step acc []     = acc
-
--- | Create a document from a literal string.
--- 
--- The string should not contain newlines (though this is not 
--- enforced). 
---
-text :: String -> Doc
-text = Doc1 . showString
-
-
--- | Create a document from a literal character.
---
--- The char should not be a tab or newline. 
---
-char :: Char -> Doc
-char = Doc1 . showChar
-
--- | Show the Int as a Doc.
---
--- > int  = text . show
---
-int :: Int -> Doc
-int  = Doc1 . showInt
-
--- | Show the Integer as a Doc.
---
-integer :: Integer -> Doc
-integer = Doc1 . showInt
-
--- | Show an \"integral value\" as a Doc via 'fromIntegral'.
---
-integral :: Integral a => a -> Doc
-integral = Doc1 . showInt
-
--- | Show the Float as a Doc.
---
-float :: Double -> Doc
-float = Doc1 . showFloat
-
--- | Show the Double as a Doc.
---
-double :: Double -> Doc
-double = Doc1 . showFloat
-
--- | Show the Int as hexadecimal, padding up to 4 digits if 
--- necessary.
---
--- No trucation occurs if the value has more than 4 digits.
---
-hex4 :: Int -> Doc
-hex4 n | n < 0x0010 = text "000" <> showsDoc (showHex n)
-       | n < 0x0100 = text "00"  <> showsDoc (showHex n)
-       | n < 0x1000 = text "0"   <> showsDoc (showHex n)
-       | otherwise  = showsDoc (showHex n)
- 
--- | Create a Doc containing a single space character.
---
-space :: Doc
-space = char ' '
-
--- | Create a Doc containing a comma, \",\".
---
-comma :: Doc
-comma = char ','
-
--- | Create a Doc containing a semi colon, \";\".
---
-semicolon :: Doc
-semicolon = char ';'
-
--- | Create a Doc containing newline, \"\\n\".
---
-line :: Doc 
-line = char '\n'
-
-
---------------------------------------------------------------------------------
-
--- | Fill a doc to the supplied length, padding the right-hand
--- side with spaces.
---
--- Note - this function is expensive - it unrolls the functional
--- representation of the String. 
--- 
--- Also it should only be used for single line Doc\'s.
--- 
-fill :: Int -> Doc -> Doc
-fill i d = Doc1 (padr i ' ' $ unDoc d) 
-
-padr :: Int -> Char -> ShowS -> ShowS
-padr i c df = step (length $ df []) 
-  where
-    step len | len >= i  = df
-             | otherwise = df . showString (replicate (i-len) c)
-
--- | String version of 'fill'.
---
--- This is more efficient than 'fill' as the input is a string
--- so its length is more accesible.
---
--- Padding is the space character appended to the right.
--- 
-fillStringR :: Int -> String -> Doc
-fillStringR i s = step (length s)
-  where
-    step n | n >= i = text s
-    step n          = text s <> text (replicate (i-n) ' ')
-
--- | Left-padding version of 'fillStringR'.
---
-fillStringL :: Int -> String -> Doc
-fillStringL i s = step (length s)
-  where
-    step n | n >= i = text s
-    step n          = text (replicate (i-n) ' ') <> text s
-
---------------------------------------------------------------------------------
-
--- | Punctuate the Doc list with the separator, producing a Doc. 
---
-punctuate :: Doc -> [Doc] -> Doc
-punctuate _ []     = empty
-punctuate _ [x]    = x
-punctuate s (x:xs) = x <> s <> punctuate s xs
-
-
--- | Enclose the final Doc within the first two.
---
--- There are no spaces between the documents:
---
--- > enclose l r d = l <> d <> r
---
-enclose :: Doc -> Doc -> Doc -> Doc
-enclose l r d = l <> d <> r
-
-
-
--- | Enclose the Doc within single quotes.
---
-squotes :: Doc -> Doc
-squotes = enclose (char '\'') (char '\'')
-
--- | Enclose the Doc within double quotes.
---
-dquotes :: Doc -> Doc
-dquotes = enclose (char '"') (char '"')
-
--- | Enclose the Doc within parens @()@.
---
-parens :: Doc -> Doc
-parens = enclose lparen rparen
-
--- | Enclose the Doc within square brackets @[]@.
---
-brackets :: Doc -> Doc
-brackets = enclose lbracket rbracket
-
--- | Enclose the Doc within curly braces @{}@.
---
-braces :: Doc -> Doc
-braces = enclose lbrace rbrace
-
--- | Enclose the Doc within angle brackets @\<\>@.
---
-angles :: Doc -> Doc
-angles = enclose langle rangle
-
-
-
--- | Create a Doc containing a left paren, \'(\'.
---
-lparen :: Doc
-lparen = char '('
-
--- | Create a Doc containing a right paren, \')\'.
---
-rparen :: Doc
-rparen = char ')'
-
--- | Create a Doc containing a left square bracket, \'[\'.
---
-lbracket :: Doc
-lbracket = char '['
-
--- | Create a Doc containing a right square bracket, \']\'.
---
-rbracket :: Doc
-rbracket = char ']'
-
--- | Create a Doc containing a left curly brace, \'{\'.
---
-lbrace :: Doc
-lbrace = char '{'
-
--- | Create a Doc containing a right curly brace, \'}\'.
---
-rbrace :: Doc
-rbrace = char '}'
-
--- | Create a Doc containing a left angle bracket, \'\<\'.
---
-langle :: Doc
-langle = char '<'
-
--- | Create a Doc containing a right angle bracket, \'\>\'.
---
-rangle :: Doc
-rangle = char '>'
-
--- | Comma separate the list of documents and enclose in square
--- brackets.
---
-list :: [Doc] -> Doc
-list = brackets . punctuate comma
-
--- | Comma separate the list of documents and enclose in parens.
---
-tupled :: [Doc] -> Doc
-tupled = parens . punctuate comma
-
--- | Separate the list with a semicolon and enclose in curly 
--- braces.
---
-semiBraces :: [Doc] -> Doc
-semiBraces = braces . punctuate semicolon
-
-
--- | Horizontally indent a Doc.
---
--- Note - this space-prefixes the Doc on /the current line/. It
--- does not indent subsequent lines if the Doc spans multiple 
--- lines.
---
-indent :: Int -> Doc -> Doc
-indent i d | i < 1     = d
-           | otherwise = Indent i d
-
---------------------------------------------------------------------------------
-
-
--- | Write a Doc to file.
---
-writeDoc :: FilePath -> Doc -> IO ()
-writeDoc filepath d = writeFile filepath $ show d 
diff --git a/src/Wumpus/Basic/Utils/HList.hs b/src/Wumpus/Basic/Utils/HList.hs
--- a/src/Wumpus/Basic/Utils/HList.hs
+++ b/src/Wumpus/Basic/Utils/HList.hs
@@ -29,6 +29,7 @@
   , concatH
 
   , toListH
+  , prefixListH
   , fromListH
 
 
@@ -79,6 +80,9 @@
 
 toListH :: H a -> [a]
 toListH = ($ [])
+
+prefixListH :: H a -> [a] -> [a]
+prefixListH hf xs = hf $ xs
 
 fromListH :: [a] -> H a
 fromListH xs = (xs++)
diff --git a/src/Wumpus/Basic/Utils/JoinList.hs b/src/Wumpus/Basic/Utils/JoinList.hs
--- a/src/Wumpus/Basic/Utils/JoinList.hs
+++ b/src/Wumpus/Basic/Utils/JoinList.hs
@@ -135,7 +135,7 @@
 -- | Convert a join list to a regular list.
 --
 toList :: JoinList a -> [a]
-toList = joinfoldl (flip (:)) []
+toList = joinfoldr (:) []
 
 
 
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-2012
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,15,0)
+-- > (0,24,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,15,0)
+wumpus_basic_version = (0,24,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.24.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -9,8 +9,8 @@
 synopsis:         Basic objects and system code built on Wumpus-Core.
 description:
   .
-  Kernel code for higher-level drawing built on Wumpus-Core.
-  This package provides font loader code (limited to AFM font 
+  Kernel code for higher-level drawing built on Wumpus-Core. This 
+  package provides font loader code (currently limited to AFM font 
   files) and a various /drawing objects/ intended to be a 
   higher-level basis to make vector drawings than the primitives 
   (paths, text labels) provided by Wumpus-Core. 
@@ -29,29 +29,76 @@
   .
   .
   Changelog:
+  . 
+  v0.23.0 to v0.24.0:
   .
-  v0.14.0 to v0.15.0:
+  * Changes to type funs to work with GHC 7.4.
   . 
-  * Split previous @Wumpus-Basic@ package into two packages:
-    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move 
-    to separate the developed (although not yet polished) @Kernel@ 
-    and @FontLoader@ code from the prototypical @Drawing@ code.
+  * Removed FormatCombinators module.
   .
-  * Renamed the @Drawing@ object to @CtxPicture@. Although 
-    @CtxPicture@ is a less pleasant name, it should be less 
-    confusing. A @CtxPicture@ is the essentially the @Picture@ 
-    type from Wumpus-Core with an implicit context - 
-    @ContextPicture@ is simply too long and @CtxPicture@ is 
-    almost jibberish but the previous unrelated name @Drawing@ 
-    was not helpful.
+  v0.22.0 to v0.23.0:
   .
-  * @Kernel.Base.ScalingContext@ has been simplified. 
-    ScalingContexts are no longer manipulated via a custom Reader
-    monad or transformer as the type signatures were too unwieldy.
+  * Re-worked the Chain module and API.
   .
-  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing 
-    can now calculate more appealing bounding boxes for text.
+  * Replaced @ZDeco@ enumeration with @ZOrder@.
   .
+  * Removed the @Basic.Geometry@ modules, they are superseded in 
+    Wumpus-Drawing. Some of the equivalent functionality is now
+    internal to the respective modules in Wumpus-Drawing - Wumpus
+    has scaled back the amount of /geometric/ types and operations
+    it wants to expose.  
+  .
+  * Renamed the @PlacedTrail@ object to @AnaTrail@ - the prefix 
+    vector is considered an /anacrusis/. Tidied up the API of the 
+    @Trail@ module.
+  .
+  * Moved @bezierArcPoints@ and @BezierMinorArc@ from 
+    @Basic.Geometry@ and marked the @Basic.Geometry@ code as 
+    obsolute.
+  .
+  v0.21.0 to v0.22.0:
+  .
+  * Reverted argument order of @run@ functions they back to the 
+    @monadLib@ style (args * monadic_operation) rather than @MTL@
+    style (monadic_operation * args). Typographically this seems 
+    better.
+  .
+  * Removed module @Geometry.Paths@ it is superseded in
+    Wumpus-Drawing.
+  .
+  * Added user state to PosObject and moved it into 
+    @Kernel.Drawing@.
+  .
+  * Changed the enumeration @DrawStyle@ to @DrawMode@. Added 
+    another enumeration @PathMode@.
+  .
+  * Changed Chain so that first item in the chain is the start 
+    point (previously the start point was iterated by the chain).
+  .
+  * Removed @ConnectorProps@ from the @DrawingContext@ , they are 
+    now used \"locally\" in Wumpus-Drawing.
+  .
+  * Added more vector constructors to 
+    @Kernel.Objects.Displacement@. 
+  .
+  * Added extra methods to the @Decorate@ class for annotating 
+    SVG elements.
+  .
+  v0.20.0 to v0.21.0:
+  .
+  * The code from the @Kernel.Base.UserState@ module has been 
+    moved to the module @Kernel.Drawing.Basis@.
+  .
+  * Moved @Image@ and @Query@ from @Objects.Basis@ to new module
+    @Objects.Image@. Moved @Chain@, @CtxPicture@ and 
+    @TraceDrawing@ into the new @Drawing@ folder.
+  .
+  * Added @Wumpus.Basic.Kernel.Drawing.LocDrawing@ module.
+  . 
+  * Rationalized the combinators exported by the drawing objects 
+    @Image@, @LocImage@, @LocThetaImage@ and @Connector@.
+  . 
+  .
 build-type:         Simple
 stability:          highly unstable
 cabal-version:      >= 1.2
@@ -59,7 +106,10 @@
 extra-source-files:
   CHANGES,
   LICENSE,
-  demo/FontDeltaPic.hs
+  demo/AltUnits.hs,
+  demo/FontDeltaPic.hs,
+  demo/SimpleAdvGraphic.hs,
+  demo/SimplePosObject.hs
 
 library
   hs-source-dirs:     src
@@ -68,37 +118,47 @@
                       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.52.0  && <  0.53.0
 
   
   exposed-modules:
     Wumpus.Basic.Kernel,
-    Wumpus.Basic.Kernel.Base.Anchors,
     Wumpus.Basic.Kernel.Base.BaseDefs,
-    Wumpus.Basic.Kernel.Base.ContextFun,
     Wumpus.Basic.Kernel.Base.DrawingContext,
-    Wumpus.Basic.Kernel.Base.GlyphMetrics,
+    Wumpus.Basic.Kernel.Base.FontSupport,
     Wumpus.Basic.Kernel.Base.QueryDC,
-    Wumpus.Basic.Kernel.Base.ScalingContext,
+    Wumpus.Basic.Kernel.Base.Units,
     Wumpus.Basic.Kernel.Base.UpdateDC,
     Wumpus.Basic.Kernel.Base.WrappedPrimitive,
-    Wumpus.Basic.Kernel.Objects.AdvanceGraphic,
-    Wumpus.Basic.Kernel.Objects.BaseObjects,
+    Wumpus.Basic.Kernel.Drawing.Basis,
+    Wumpus.Basic.Kernel.Drawing.Chain,
+    Wumpus.Basic.Kernel.Drawing.CtxPicture,
+    Wumpus.Basic.Kernel.Drawing.LocDrawing,
+    Wumpus.Basic.Kernel.Drawing.LocTrace,
+    Wumpus.Basic.Kernel.Drawing.PosObject,
+    Wumpus.Basic.Kernel.Drawing.TraceDrawing,
+    Wumpus.Basic.Kernel.Objects.AdvObject,
+    Wumpus.Basic.Kernel.Objects.Anchors,
+    Wumpus.Basic.Kernel.Objects.Basis,
     Wumpus.Basic.Kernel.Objects.Bounded,
+    Wumpus.Basic.Kernel.Objects.Concat,
     Wumpus.Basic.Kernel.Objects.Connector,
-    Wumpus.Basic.Kernel.Objects.CtxPicture,
-    Wumpus.Basic.Kernel.Objects.Graphic,
-    Wumpus.Basic.Kernel.Objects.TraceDrawing,
-    Wumpus.Basic.System.FontLoader.Afm,
-    Wumpus.Basic.System.FontLoader.GhostScript,
-    Wumpus.Basic.System.FontLoader.Base.AfmParserBase,
-    Wumpus.Basic.System.FontLoader.Base.AfmV2Parser,
-    Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser,
-    Wumpus.Basic.System.FontLoader.Base.Datatypes,
-    Wumpus.Basic.System.FontLoader.Base.FontLoadMonad,
-    Wumpus.Basic.System.FontLoader.Base.GSFontMap,
+    Wumpus.Basic.Kernel.Objects.Displacement,
+    Wumpus.Basic.Kernel.Objects.DrawingPrimitives,
+    Wumpus.Basic.Kernel.Objects.Image,
+    Wumpus.Basic.Kernel.Objects.LocImage,
+    Wumpus.Basic.Kernel.Objects.LocThetaImage,
+    Wumpus.Basic.Kernel.Objects.Orientation,
+    Wumpus.Basic.Kernel.Objects.Trail,
+    Wumpus.Basic.System.FontLoader,
+    Wumpus.Basic.System.FontLoader.AfmParserBase,
+    Wumpus.Basic.System.FontLoader.AfmTopLevel,
+    Wumpus.Basic.System.FontLoader.AfmV2Parser,
+    Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser,
+    Wumpus.Basic.System.FontLoader.Datatypes,
+    Wumpus.Basic.System.FontLoader.FontLoadMonad,
+    Wumpus.Basic.System.FontLoader.GSTopLevel,
     Wumpus.Basic.Utils.HList,
-    Wumpus.Basic.Utils.FormatCombinators,
     Wumpus.Basic.Utils.JoinList,
     Wumpus.Basic.Utils.ParserCombinators,
     Wumpus.Basic.Utils.TokenParsers,