diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,5 +1,30 @@
 
-0.18.0 to 0.19.0:
+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 
diff --git a/demo/SimplePosObject.hs b/demo/SimplePosObject.hs
--- a/demo/SimplePosObject.hs
+++ b/demo/SimplePosObject.hs
@@ -110,5 +110,5 @@
         br = displace (hvec w) bl
         tr = displace (vvec h) br
         tl = displace (vvec h) bl
-    in zapQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE
+    in liftQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE
 
diff --git a/src/Wumpus/Basic/Geometry/Paths.hs b/src/Wumpus/Basic/Geometry/Paths.hs
--- a/src/Wumpus/Basic/Geometry/Paths.hs
+++ b/src/Wumpus/Basic/Geometry/Paths.hs
@@ -97,7 +97,7 @@
 drawVertexPathAlg :: InterpretUnit u 
                   => DrawStyle -> PathAlg u -> LocGraphic u
 drawVertexPathAlg style alg = promoteLoc $ \pt -> 
-    zapQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style
+    liftQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style
 
 
 -- | Create a PathAlg from the vertex list.
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
@@ -23,23 +23,26 @@
   , module Wumpus.Basic.Kernel.Base.QueryDC
   , module Wumpus.Basic.Kernel.Base.Units
   , module Wumpus.Basic.Kernel.Base.UpdateDC
-  , module Wumpus.Basic.Kernel.Base.UserState
   , module Wumpus.Basic.Kernel.Base.WrappedPrimitive
+  , 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.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.Chain
   , module Wumpus.Basic.Kernel.Objects.Concat
   , module Wumpus.Basic.Kernel.Objects.Connector
-  , module Wumpus.Basic.Kernel.Objects.CtxPicture
   , module Wumpus.Basic.Kernel.Objects.Displacement
   , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+  , module Wumpus.Basic.Kernel.Objects.Image
   , module Wumpus.Basic.Kernel.Objects.LocImage
   , module Wumpus.Basic.Kernel.Objects.LocThetaImage
   , module Wumpus.Basic.Kernel.Objects.Orientation
   , module Wumpus.Basic.Kernel.Objects.PosObject
-  , module Wumpus.Basic.Kernel.Objects.TraceDrawing
 
   ) where
 
@@ -49,20 +52,23 @@
 import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Base.Units 
 import Wumpus.Basic.Kernel.Base.UpdateDC
-import Wumpus.Basic.Kernel.Base.UserState
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+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.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.Chain
 import Wumpus.Basic.Kernel.Objects.Concat
 import Wumpus.Basic.Kernel.Objects.Connector
-import Wumpus.Basic.Kernel.Objects.CtxPicture
 import Wumpus.Basic.Kernel.Objects.Displacement
 import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Kernel.Objects.LocImage
 import Wumpus.Basic.Kernel.Objects.LocThetaImage
 import Wumpus.Basic.Kernel.Objects.Orientation
 import Wumpus.Basic.Kernel.Objects.PosObject
-import Wumpus.Basic.Kernel.Objects.TraceDrawing
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
@@ -19,12 +19,11 @@
 module Wumpus.Basic.Kernel.Base.BaseDefs
   (
   
-    MonUnit 
 
-
   -- * Unit phantom type
-  , UNil(..)
+    UNil(..)
   , ureturn
+  , uvoid
 
   -- * Non-contextual unit conversion.
   , ScalarUnit(..)
@@ -80,13 +79,8 @@
 
 
 
--- | Type family to access the unit parameter of a TraceDrawing
--- or a promoted TraceDrawingT transformer.
---
-type family MonUnit m :: *
 
 
-
 --------------------------------------------------------------------------------
 -- Simple objects wrapped with unit phatom type 
 
@@ -125,14 +119,15 @@
 -- monadic commands.
 --
 -- Many Wumpus objects are usefully constructed in the 
--- @do-notation@, but due to the need to type their unit
--- must finish the do-block with:
+-- @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
 -- 
 -- or:
 -- 
--- return UNil
+-- > return UNil
 --
 -- rather than:
 --
@@ -141,6 +136,11 @@
 --
 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
diff --git a/src/Wumpus/Basic/Kernel/Base/UserState.hs b/src/Wumpus/Basic/Kernel/Base/UserState.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Base/UserState.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Base.UserState
--- Copyright   :  (c) Stephen Tetley 2011
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- User state class for Drawing monads.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Base.UserState
-  (
-
-    UState
-  , UserStateM(..)
-
-  ) where
-
-
-import Control.Applicative
-
-type family UState m :: *
-
-
-class (Applicative m, Monad m) => UserStateM (m :: * -> *) where
-  getState    :: st ~ UState m  => m st
-  setState    :: st ~ UState m  => st -> m ()
-  updateState :: st ~ UState m  => (st -> st) -> m ()
-   
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
+-- 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  => m st
+  setState    :: st ~ UState m  => st -> m ()
+  updateState :: st ~ UState m  => (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,306 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.Chain
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Chaining moveable LocGraphics.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Drawing.Chain
+  (
+  
+    GenChain
+  , Chain
+  , DChain
+  , ChainScheme(..)
+
+  , runGenChain
+  , evalGenChain
+  , execGenChain
+  , stripGenChain
+
+  , runChain
+  , runChain_
+
+  , cnext
+  , setChainScheme
+
+
+  , chainIterate
+  , chainH
+  , chainV
+
+  , tableRight  
+  , tableDown
+
+  , radialChain
+
+  ) 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.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) = 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 
+      { scheme_start    :: Point2 u -> cst
+      , scheme_step     :: Point2 u -> cst -> (Point2 u,cst)
+      }
+
+type instance DUnit (ChainScheme u) = u
+
+
+data ChainSt st u = forall cst. ChainSt 
+       { 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 a b _) -> 
+                      ((), pt, ChainSt a b ust, mempty)
+  updateState upd = GenChain $ \_ pt (ChainSt a b ust) -> 
+                      ((), pt, ChainSt 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 
+         => GenChain st u a -> ChainScheme u -> st -> LocImage u (a,st)
+runGenChain ma (ChainScheme start step) ust = promoteLoc $ \pt -> 
+    askDC >>= \ctx ->
+    let st_zero     = ChainSt { 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 
+             => GenChain st u a -> ChainScheme u -> st -> LocImage u a
+evalGenChain ma cscm st = fmap fst $ runGenChain ma cscm st
+
+
+-- | Forget the /answer/, just return the user state.
+--
+execGenChain :: InterpretUnit u 
+             => GenChain st u a -> ChainScheme u -> st -> LocImage u st 
+execGenChain ma cscm st = fmap snd $ runGenChain ma cscm st
+
+
+stripGenChain :: InterpretUnit u 
+              => GenChain st u a -> ChainScheme u -> st -> LocQuery u (a,st)
+stripGenChain ma cscm st = stripLocImage $ runGenChain ma cscm st 
+
+
+
+runChain :: InterpretUnit u 
+         => Chain u a -> ChainScheme u -> LocImage u a
+runChain ma cscm = evalGenChain ma cscm ()
+
+runChain_ :: InterpretUnit u 
+          => Chain u a -> ChainScheme u -> LocGraphic u
+runChain_ ma cscm = ignoreAns $ runChain ma cscm
+
+
+
+--------------------------------------------------------------------------------
+-- Operations
+
+cnext :: InterpretUnit u 
+      => LocImage u a -> GenChain st u a
+cnext gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> 
+    let dpt       = dinterpF (dc_font_size ctx) pt
+        (pt1,st1) = sf dpt s0
+        dpt1      = normalizeF (dc_font_size ctx) pt1
+        (a,w1)    = runImage (applyLoc gf pt1) ctx
+        new_st    = ChainSt { chain_st = st1
+                            , chain_next = sf
+                            , chain_user_state = ust }
+    in (a, dpt1, new_st, w1)
+
+
+setChainScheme :: InterpretUnit u 
+               => ChainScheme u -> GenChain st u ()
+setChainScheme (ChainScheme start step) = 
+    GenChain $ \ctx pt (ChainSt _ _ ust) -> 
+      let upt     = dinterpF (dc_font_size ctx) pt
+          new_st  = ChainSt { chain_st = start upt
+                            , chain_next = step
+                            , chain_user_state = ust }
+      in ((), pt, new_st, mempty) 
+
+
+
+--------------------------------------------------------------------------------
+-- Schemes
+
+chainIterate :: (Point2 u -> Point2 u) -> ChainScheme u
+chainIterate fn = ChainScheme { scheme_start = const ()
+                              , scheme_step  = \pt _ -> (fn pt, ())
+                              }
+
+
+chainH :: Num u => u -> ChainScheme u
+chainH dx = 
+    ChainScheme { scheme_start = const ()
+                , scheme_step  = \pt _ -> (displace (hvec dx) pt, ())
+                }
+   
+chainV :: Num u => u -> ChainScheme u
+chainV dy = 
+    ChainScheme { scheme_start = const ()
+                , scheme_step  = \pt _ -> (displace (vvec dy) pt, ())
+                }
+
+
+
+
+-- | Outer and inner steppers.
+--
+scStepper :: PointDisplace u -> Int -> PointDisplace u 
+          -> ChainScheme u
+scStepper outF n innF = 
+    ChainScheme { scheme_start = start, scheme_step = step }
+  where
+    start pt                      = (pt,0)
+    step  pt (ogin,i) | i < n     = (innF pt, (ogin, i+1))
+                      | otherwise = let o1 = outF ogin 
+                                    in (innF o1, (o1,1)) 
+
+
+tableRight :: Num u => Int -> (u,u) -> ChainScheme u
+tableRight num_cols (col_width,row_height) = 
+    scStepper downF num_cols rightF
+  where
+    downF   = displace $ vvec $ negate row_height
+    rightF  = displace $ hvec col_width
+
+tableDown :: Num u => Int -> (u,u) -> ChainScheme u
+tableDown num_rows (col_width,row_height) = 
+    scStepper rightF num_rows downF
+  where
+    downF   = displace $ vvec $ negate row_height
+    rightF  = displace $ hvec col_width
+
+
+
+radialChain :: Floating u 
+            => u -> Radian -> Radian -> ChainScheme u
+radialChain radius angstart angi = 
+    ChainScheme { scheme_start = start, scheme_step = step }
+  where
+    start pt           = (pt,angstart)
+    step  _ (ogin,ang) = (displace (avec ang radius) ogin, (ogin,ang + angi))
+
+-- Note - radialChains stepper is oblivious to 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 mf = 
+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx
+
+-- | '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 _ mf = 
+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx
+
+
+-- 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,238 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocDrawing
+-- Copyright   :  (c) Stephen Tetley 2011
+-- 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 Control.Monad
+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)   = 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) 
+                 => GenLocDrawing st u a -> st -> LocImage u (a,st)
+runGenLocDrawing ma st = 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) 
+                  => GenLocDrawing st u a -> st -> LocImage u a
+evalGenLocDrawing ma st = fmap fst $ runGenLocDrawing ma st
+
+
+-- | Forget the /answer/, just return the user state.
+--
+execGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+                  => GenLocDrawing st u a -> st -> LocImage u st 
+execGenLocDrawing ma st = fmap snd $ runGenLocDrawing ma st
+
+
+stripGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) 
+                   => GenLocDrawing st u a -> st -> LocQuery u (a,st)
+stripGenLocDrawing ma st = stripLocImage $ runGenLocDrawing ma st 
+
+
+-- | 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 gf ctx 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 gf ctx p1 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 gf ctx p1 p2 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,214 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocTrace
+-- Copyright   :  (c) Stephen Tetley 2011
+-- 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 Control.Monad
+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)   = 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 gf ctx upt
+    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 
+               => GenLocTrace st u a -> st -> LocImage u (a,st)
+runGenLocTrace ma st = 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 
+                => GenLocTrace st u a -> st -> LocImage u a
+evalGenLocTrace ma st = fmap fst $ runGenLocTrace ma st
+
+
+-- | Forget the /answer/, just return the user state.
+--
+execGenLocTrace :: InterpretUnit u 
+                => GenLocTrace st u a -> st -> LocImage u st 
+execGenLocTrace ma st = fmap snd $ runGenLocTrace ma st
+
+
+stripGenLocTrace :: InterpretUnit u 
+                 => GenLocTrace st u a -> st -> LocQuery u (a,st)
+stripGenLocTrace ma st = stripLocImage $ runGenLocTrace ma st 
+
+
+-- | 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/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,411 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Drawing.TraceDrawing
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- 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 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 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)   = 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 :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)
+runTraceDrawing ma ctx = 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 :: TraceDrawing u a -> DrawingContext -> HPrim u
+execTraceDrawing ma ctx = snd $ runTraceDrawing ma ctx
+
+-- | 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 :: TraceDrawing u a -> DrawingContext -> a
+evalTraceDrawing ma ctx = fst $ runTraceDrawing ma ctx
+
+
+runGenTraceDrawing :: GenTraceDrawing st u a -> DrawingContext -> st 
+                   -> (a,st,HPrim u)
+runGenTraceDrawing = getGenTraceDrawing
+
+
+
+
+
+-- | /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 textAttr ctx
+        (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 df ctx
+
+
+
+-- | 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 gf ctx 
+          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 gf ctx
+           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 gf ctx pt
+               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 img = drawci an0 an1 img >> 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 img = drawi (connect p0 p1 img)
+
+
+
+
+
+
+
+
+-- | 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 gf ctx pt
+                 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 p0 p1 gf)
diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs b/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs
--- a/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs
@@ -56,6 +56,7 @@
 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
diff --git a/src/Wumpus/Basic/Kernel/Objects/Basis.hs b/src/Wumpus/Basic/Kernel/Objects/Basis.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Basis.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Basis.hs
@@ -23,27 +23,8 @@
 
     PrimResult
 
-  , Image
-  , Graphic 
-
-  , Query
-
-  , DImage
-  , DGraphic
-
-  , runImage
-  , runQuery
-  , zapQuery
-
-  , primGraphic
-  , clipImage
-
   , UConvert(..)
-  , uconvImageF
-  , uconvImageZ
 
-  , emptyImage
-
   , ignoreAns
   , replaceAns
 
@@ -57,16 +38,11 @@
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 
 import Wumpus.Core                              -- package: wumpus-core
 
 
-import Control.Applicative
-import Data.Monoid
-
-
 type PrimResult u a = (a, CatPrim)
 
 
@@ -74,116 +50,6 @@
 --------------------------------------------------------------------------------
 
 
-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 :: Image u a -> DrawingContext -> PrimResult u a
-runImage = getImage
-
-runQuery :: Query u a -> DrawingContext -> a
-runQuery = getQuery
-
-
-
-zapQuery :: Query u a -> Image u a
-zapQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx 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 (clip pp) w)
-
-
-
 class UConvert (f :: * -> * -> *) where
   uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
          => f u (t u) -> f u1 (t u1)
@@ -191,28 +57,7 @@
   uconvZ :: (InterpretUnit u, InterpretUnit u1) 
          => f u a -> f u1 a
 
-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
-
 --------------------------------------------------------------------------------
 
 
@@ -254,84 +99,6 @@
 
 aelaborate :: Decorate f => f u a -> (a -> f u z) -> f u a
 aelaborate = elaborate ANTERIOR
-
-
-
-
--- | Decorate Image.
---
-decorateImage :: ZDeco -> 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 SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)
-    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)
-
-
--- | Elaborate Image.
---
-elaborateImage :: ZDeco -> 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
-      SUPERIOR -> (a, w1 `mappend` w2)
-      ANTERIOR -> (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)
-
-
-
-instance Decorate Image where
-  decorate    = decorateImage
-  elaborate   = elaborateImage  
-  obliterate  = obliterateImage
-  hyperlink   = hyperlinkImage
-  
---------------------------------------------------------------------------------
--- 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/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
@@ -45,6 +45,7 @@
 import Wumpus.Basic.Kernel.Base.UpdateDC
 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
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Chain.hs b/src/Wumpus/Basic/Kernel/Objects/Chain.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/Chain.hs
+++ /dev/null
@@ -1,267 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE ExistentialQuantification  #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.Chain
--- Copyright   :  (c) Stephen Tetley 2011
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- Chaining moveable LocGraphics.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.Chain
-  (
-  
-    GenChain
-  , Chain
-  , DChain
-  , ChainScheme(..)
-
-  , runChain
-  , runChain_
-
-  , cnext
-  , setChainScheme
-
-
-  , chainIterate
-  , chainH
-  , chainV
-
-  , tableRight  
-  , tableDown
-
-  , radialChain
-
-  ) where
-
-
-import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.DrawingContext
-import Wumpus.Basic.Kernel.Base.UserState
-import Wumpus.Basic.Kernel.Base.WrappedPrimitive
-import Wumpus.Basic.Kernel.Objects.Basis
-import Wumpus.Basic.Kernel.Objects.Displacement
-import Wumpus.Basic.Kernel.Objects.LocImage
-
-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) = 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 
-      { scheme_start    :: Point2 u -> cst
-      , scheme_step     :: Point2 u -> cst -> (Point2 u,cst)
-      }
-
-type instance DUnit (ChainScheme u) = u
-
-
-data ChainSt st u = forall cst. ChainSt 
-       { 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 a b _) -> 
-                      ((), pt, ChainSt a b ust, mempty)
-  updateState upd = GenChain $ \_ pt (ChainSt a b ust) -> 
-                      ((), pt, ChainSt a b (upd ust), 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)
-
-
-runGenChain :: InterpretUnit u 
-         => GenChain st u a -> ChainScheme u -> st -> LocImage u a
-runGenChain ma (ChainScheme start step) ust = promoteLoc $ \pt -> 
-    askDC >>= \ctx ->
-    let st_zero    = ChainSt { chain_st         = start pt
-                             , chain_next       = step
-                             , chain_user_state = ust }
-        dpt        = normalizeF (dc_font_size ctx) pt
-        (a,_,_,w1) = getGenChain ma ctx dpt st_zero
-    in replaceAns a $ primGraphic w1
-
-
-
-runChain :: InterpretUnit u 
-         => Chain u a -> ChainScheme u -> LocImage u a
-runChain ma cscm = runGenChain ma cscm ()
-
-runChain_ :: InterpretUnit u 
-          => Chain u a -> ChainScheme u -> LocGraphic u
-runChain_ ma cscm = ignoreAns $ runChain ma cscm
-
-
-cnext :: InterpretUnit u 
-      => LocImage u a -> GenChain st u a
-cnext gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> 
-    let dpt       = dinterpF (dc_font_size ctx) pt
-        (pt1,st1) = sf dpt s0
-        dpt1      = normalizeF (dc_font_size ctx) pt1
-        (a,w1)    = runImage (applyLoc gf pt1) ctx
-        new_st    = ChainSt { chain_st = st1
-                            , chain_next = sf
-                            , chain_user_state = ust }
-    in (a, dpt1, new_st, w1)
-
-
-setChainScheme :: InterpretUnit u 
-               => ChainScheme u -> GenChain st u ()
-setChainScheme (ChainScheme start step) = 
-    GenChain $ \ctx pt (ChainSt _ _ ust) -> 
-      let upt     = dinterpF (dc_font_size ctx) pt
-          new_st  = ChainSt { chain_st = start upt
-                            , chain_next = step
-                            , chain_user_state = ust }
-      in ((), pt, new_st, mempty) 
-
-
-
---------------------------------------------------------------------------------
--- Schemes
-
-chainIterate :: (Point2 u -> Point2 u) -> ChainScheme u
-chainIterate fn = ChainScheme { scheme_start = const ()
-                              , scheme_step  = \pt _ -> (fn pt, ())
-                              }
-
-
-chainH :: Num u => u -> ChainScheme u
-chainH dx = 
-    ChainScheme { scheme_start = const ()
-                , scheme_step  = \pt _ -> (displace (hvec dx) pt, ())
-                }
-   
-chainV :: Num u => u -> ChainScheme u
-chainV dy = 
-    ChainScheme { scheme_start = const ()
-                , scheme_step  = \pt _ -> (displace (vvec dy) pt, ())
-                }
-
-
-
-
--- | Outer and inner steppers.
---
-scStepper :: PointDisplace u -> Int -> PointDisplace u 
-          -> ChainScheme u
-scStepper outF n innF = 
-    ChainScheme { scheme_start = start, scheme_step = step }
-  where
-    start pt                      = (pt,0)
-    step  pt (ogin,i) | i < n     = (innF pt, (ogin, i+1))
-                      | otherwise = let o1 = outF ogin 
-                                    in (innF o1, (o1,1)) 
-
-
-tableRight :: Num u => Int -> (u,u) -> ChainScheme u
-tableRight num_cols (col_width,row_height) = 
-    scStepper downF num_cols rightF
-  where
-    downF   = displace $ vvec $ negate row_height
-    rightF  = displace $ hvec col_width
-
-tableDown :: Num u => Int -> (u,u) -> ChainScheme u
-tableDown num_rows (col_width,row_height) = 
-    scStepper rightF num_rows downF
-  where
-    downF   = displace $ vvec $ negate row_height
-    rightF  = displace $ hvec col_width
-
-
-
-radialChain :: Floating u 
-            => u -> Radian -> Radian -> ChainScheme u
-radialChain radius angstart angi = 
-    ChainScheme { scheme_start = start, scheme_step = step }
-  where
-    start pt           = (pt,angstart)
-    step  _ (ogin,ang) = (displace (avec ang radius) ogin, (ogin,ang + angi))
-
--- Note - radialChains stepper is oblivious to the previous point...
-
-
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
@@ -31,11 +31,14 @@
    , runConnectorQuery
    , connect
 
+   , stripConnectorImage
+   , liftConnectorQuery
+
    , promoteConn
    , applyConn
+
    , qpromoteConn
    , qapplyConn
-   , zapConnectorQuery
 
    , emptyConnectorImage
 
@@ -47,6 +50,7 @@
 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
 
@@ -77,7 +81,7 @@
 
 
 newtype ConnectorQuery u a = ConnectorQuery { 
-          getConnectorQuery :: Point2 u -> Point2 u -> Query u a }
+          getConnectorQuery :: DPoint2 -> DPoint2 -> Query u a }
 
 
 -- Functor 
@@ -173,55 +177,71 @@
                   => ConnectorImage u a -> DrawingContext 
                   -> Point2 u -> Point2 u
                   -> PrimResult u a
-runConnectorImage ma ctx p0 p1= 
+runConnectorImage ma ctx p0 p1 = 
     let dp0 = normalizeF (dc_font_size ctx) p0
         dp1 = normalizeF (dc_font_size ctx) p1 
     in runImage (getConnectorImage ma dp0 dp1) ctx
 
 
-runConnectorQuery :: ConnectorQuery u a -> DrawingContext 
+runConnectorQuery :: InterpretUnit u 
+                  => ConnectorQuery u a -> DrawingContext 
                   -> Point2 u -> Point2 u 
                   -> a
-runConnectorQuery ma ctx p0 p1 = runQuery (getConnectorQuery ma p0 p1) ctx
+runConnectorQuery ma ctx p0 p1 = 
+    let dp0 = normalizeF (dc_font_size ctx) p0
+        dp1 = normalizeF (dc_font_size ctx) p1 
+    in runQuery (getConnectorQuery ma dp0 dp1) ctx
 
 
 connect :: InterpretUnit u 
         => Point2 u -> Point2 u -> ConnectorImage u a -> Image u a
-connect p0 p1 mf = 
-    zapQuery (normalizeCtxF p0) >>= \dp0 -> 
-    zapQuery (normalizeCtxF p1) >>= \dp1 -> 
-    getConnectorImage mf dp0 dp1
+connect p0 p1 ma = 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
+    dinterpCtxF p0 >>= \up0 -> 
+    dinterpCtxF p1 >>= \up1 -> 
+    k up0 up1
 
 applyConn :: InterpretUnit u 
           => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a
-applyConn mf p0 p1 = 
-    zapQuery (normalizeCtxF p0) >>= \dp0 -> 
-    zapQuery (normalizeCtxF p1) >>= \dp1 -> 
-    getConnectorImage mf dp0 dp1
+applyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> 
+                     normalizeCtxF p1 >>= \dp1 -> 
+                     getConnectorImage ma dp0 dp1
 
 
-qpromoteConn :: (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a
-qpromoteConn fn      = ConnectorQuery $ \p0 p1 -> fn p0 p1
 
-qapplyConn :: ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a
-qapplyConn mf p0 p1   = getConnectorQuery mf p0 p1
 
+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
 
--- | \"zero-apply\" a Connector.
---
-zapConnectorQuery :: ConnectorQuery u a -> Point2 u -> Point2 u -> Image u a
-zapConnectorQuery ma p0 p1  = askDC >>= \ctx -> 
-    let a = runConnectorQuery ma ctx p0 p1 in return a
+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
 
 
+--------------------------------------------------------------------------------
+-- UConvert instance
 
 instance UConvert ConnectorImage where
   uconvF = uconvConnectorImageF
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,408 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.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.Objects.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.Objects.Anchors
-import Wumpus.Basic.Kernel.Objects.Concat
-import Wumpus.Basic.Kernel.Objects.TraceDrawing
-
-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 mf = 
-    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx
-
--- | '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 _ mf = 
-    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx
-
-
--- 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/Objects/DrawingPrimitives.hs b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs
--- a/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs
@@ -67,8 +67,8 @@
 import Wumpus.Basic.Kernel.Base.BaseDefs
 import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
-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.Basic.Kernel.Objects.LocThetaImage
 
@@ -331,8 +331,7 @@
 --
 hkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u
 hkernLine ks = promoteLoc $ \pt -> 
-               normalizeCtxF pt >>= \dpt -> 
-               zapQuery (uconvKernChar ks) >>= body dpt
+    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt
   where
     body pt ans = textPrim (\rgb attr -> hkernlabel rgb attr ans pt)
 
@@ -351,8 +350,7 @@
 --
 vkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u
 vkernLine ks = promoteLoc $ \pt -> 
-               normalizeCtxF pt >>= \dpt -> 
-               zapQuery (uconvKernChar ks) >>= body dpt
+    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt
   where
     body pt ans = textPrim (\rgb attr -> vkernlabel rgb attr ans pt)
 
@@ -368,7 +366,7 @@
 -- from the implicit 'DrawingContext'.
 -- 
 straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u
-straightLine p1 p2 = zapQuery (vertexPP [p1,p2]) >>= dcOpenPath
+straightLine p1 p2 = liftQuery (vertexPP [p1,p2]) >>= dcOpenPath
 
 
 -- | 'locStraightLine' : @ vec_to -> LocGraphic @ 
@@ -384,7 +382,8 @@
 -- from the implicit 'DrawingContext'.
 -- 
 locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u
-locStraightLine v = promoteLoc $ \pt -> zapLocQuery (locPP [v]) pt >>= dcOpenPath
+locStraightLine v = promoteLoc $ \pt -> 
+    liftQuery (qapplyLoc (locPP [v]) pt) >>= dcOpenPath
 
 
 
@@ -399,8 +398,7 @@
 -- 
 curvedLine :: InterpretUnit u
            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
-curvedLine p0 p1 p2 p3 = 
-    zapQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath
+curvedLine p0 p1 p2 p3 = liftQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath
 
 
 
@@ -415,7 +413,7 @@
 -- 
 straightConnector :: InterpretUnit u => ConnectorGraphic u
 straightConnector = promoteConn $ \p0 p1 -> 
-    zapQuery (vertexPP [p0,p1]) >>= dcOpenPath
+    liftQuery (vertexPP [p0,p1]) >>= dcOpenPath
 
 
 
@@ -441,7 +439,7 @@
 -- 
 dcCircle :: InterpretUnit u => DrawStyle -> u -> LocGraphic u
 dcCircle style r = promoteLoc $ \pt -> 
-    zapLocQuery (circlePath r) pt >>= dcClosedPath style
+    liftQuery (qapplyLoc (circlePath r) pt) >>= dcClosedPath style
 
 
 
@@ -477,7 +475,7 @@
 -- 
 dcEllipse :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u
 dcEllipse style rx ry = promoteLoc $ \pt ->
-   zapLocQuery (ellipsePath rx ry) pt >>= dcClosedPath style 
+   liftQuery (qapplyLoc (ellipsePath rx ry) pt) >>= dcClosedPath style 
 
 
 -- | 'dcREllipse' : @ x_radius * y_radius -> LocGraphic @
@@ -492,7 +490,8 @@
 dcREllipse :: InterpretUnit u
            => DrawStyle -> u -> u -> LocThetaGraphic u
 dcREllipse style rx ry = promoteLocTheta $ \pt ang -> 
-    zapLocThetaQuery (rellipsePath rx ry) pt ang >>= dcClosedPath style
+    liftQuery (qapplyLocTheta (rellipsePath rx ry) pt ang) >>= 
+    dcClosedPath style
 
 
 -- Note - clipping needs some higher level path object than is defined here.
@@ -518,7 +517,7 @@
 -- 
 dcRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u
 dcRectangle style w h = promoteLoc $ \pt -> 
-    zapLocQuery (rectanglePath w h) pt >>= dcClosedPath style
+    liftQuery (qapplyLoc (rectanglePath w h) pt) >>= dcClosedPath style
 
 
 ---------------------------------------------------------------------------
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,283 @@
+{-# 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 :: Image u a -> DrawingContext -> PrimResult u a
+runImage = getImage
+
+runQuery :: Query u a -> DrawingContext -> a
+runQuery = getQuery
+
+
+
+-- | 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 ma ctx 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 (clip 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
+  
+
+
+-- | Decorate Image.
+--
+decorateImage :: ZDeco -> 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 SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)
+    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)
+
+
+-- | Elaborate Image.
+--
+elaborateImage :: ZDeco -> 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
+      SUPERIOR -> (a, w1 `mappend` w2)
+      ANTERIOR -> (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)
+
+
+--------------------------------------------------------------------------------
+-- 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
--- a/src/Wumpus/Basic/Kernel/Objects/LocImage.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/LocImage.hs
@@ -30,12 +30,13 @@
    , runLocImage
    , runLocQuery
 
+   , stripLocImage
+   , liftLocQuery
+
    , promoteLoc
    , applyLoc
    , qpromoteLoc
    , qapplyLoc
-   , zapLocQuery
-   , extrLoc
 
    , emptyLocImage
 
@@ -60,6 +61,7 @@
 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
@@ -93,7 +95,7 @@
 type DLocGraphic        = LocGraphic Double 
 
 newtype LocQuery u a = LocQuery { 
-          getLocQuery :: Point2 u -> Query u a }
+          getLocQuery :: DPoint2 -> Query u a }
 
 -- Functor
 
@@ -175,93 +177,71 @@
     let dpt = normalizeF (dc_font_size ctx) pt 
     in runImage (getLocImage ma dpt) ctx
 
-runLocQuery :: LocQuery u a -> DrawingContext -> Point2 u -> a
-runLocQuery ma ctx pt = runQuery (getLocQuery ma pt) ctx
+runLocQuery :: InterpretUnit u 
+            => LocQuery u a -> DrawingContext -> Point2 u -> a
+runLocQuery ma ctx pt = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runQuery (getLocQuery ma dpt) ctx
 
 
+stripLocImage :: LocImage u a -> LocQuery u a
+stripLocImage ma = LocQuery $ \pt -> 
+    stripImage $ getLocImage ma pt
 
-promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a
-promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= \upt -> k upt
 
-applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
-applyLoc mq pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mq dpt
+liftLocQuery :: LocQuery u a -> LocImage u a
+liftLocQuery ma = LocImage $ \pt -> 
+    liftQuery $ getLocQuery ma pt
 
 
-qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a
-qpromoteLoc k = LocQuery $ \pt -> k pt
+promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a
+promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= k 
 
-qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
-qapplyLoc mq pt = getLocQuery mq pt
+applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
+applyLoc ma pt = normalizeCtxF pt >>= getLocImage ma
 
 
--- | Design Note - the set of combinators to shift between Images 
--- and Queries needs sorting out - @zapLocQuery@ probably has the 
--- wrong type signature - show be LocQuery to LocImage.
---
-
-extrLoc :: InterpretUnit u => LocImage u a -> LocQuery u a
-extrLoc ma = LocQuery $ \pt ->
-     askDC >>= \ctx -> 
-     let (a,_) = runLocImage ma ctx pt
-     in return a
-     
-
--- qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
--- qapplyLoc mq pt = getLocQuery mq pt
+qpromoteLoc :: InterpretUnit u 
+            => (Point2 u -> Query u a) -> LocQuery u a
+qpromoteLoc k = LocQuery $ \pt -> dinterpCtxF pt >>= k
 
--- | \"zero-apply\" a LocQuery.
---
-zapLocQuery :: LocQuery u a -> Point2 u -> Image u a
-zapLocQuery ma pt = askDC >>= \ctx -> 
-                    let a = runLocQuery ma ctx pt in return a
+qapplyLoc :: InterpretUnit u
+          => LocQuery u a -> Point2 u -> Query u a
+qapplyLoc ma pt = normalizeCtxF pt >>= getLocQuery ma
 
 
 
--- Maybe there is need for a function line qapplyLoc of this type:
---
--- > blankLoc :: LocQuery u a -> Point2 u -> Image u a
--- 
--- This then means we can have monadic bind back for the notation:
---
--- > qapplyLocTheta (rellipsePath rx ry) pt ang  `bindQ` dcClosedPath style
--- 
--- becomes
---
--- > blankLoc (rellipsePath rx ry) pt ang >>= dcClosedPath style
-
-
 --------------------------------------------------------------------------------
 -- Affine instances
 
 instance (Real u, Floating u, InterpretUnit u, Rotate a) => 
     Rotate (LocImage u a) where
   rotate ang ma = promoteLoc $ \pt -> 
-                     zapQuery (normalizeCtxF pt) >>= \dpt ->  
-                     fmap (rotate ang) $ getLocImage ma (rotate ang dpt)
+      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 ->
-                            zapQuery (normalizeCtxF p0) >>= \dp0 ->  
-                            zapQuery (normalizeCtxF pt) >>= \dpt ->  
-                            fmap (rotateAbout ang pt) $ 
-                              getLocImage ma (rotateAbout ang dpt dp0)
+      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 -> 
-                     zapQuery (normalizeCtxF pt) >>= \dpt -> 
-                     fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)
+      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 -> 
-                         zapQuery (normalizeCtxF pt) >>= \dpt -> 
-                         zapQuery (normalizeCtx dx)  >>= \ddx ->
-                         zapQuery (normalizeCtx dy)  >>= \ddy ->
-                         fmap (translate dx dy) $ 
-                             getLocImage ma (translate ddx ddy dpt)
+      normalizeCtxF pt >>= \dpt -> 
+      normalizeCtx dx  >>= \ddx ->
+      normalizeCtx dy  >>= \ddy ->
+      translate dx dy $ getLocImage ma (translate ddx ddy dpt)
 
 --------------------------------------------------------------------------------
 
@@ -299,7 +279,7 @@
 
 moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a
 moveStart v1 ma = LocImage $ \pt -> 
-    zapQuery (normalizeCtxF v1) >>= \dv -> getLocImage ma (pt .+^ dv) 
+    normalizeCtxF v1 >>= \dv -> getLocImage ma (pt .+^ dv) 
 
 
 
@@ -310,7 +290,7 @@
 -- point, making an 'Image'. 
 -- 
 at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
-at mf pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mf dpt
+at mf pt = normalizeCtxF pt >>= \dpt -> getLocImage mf dpt
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
--- a/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
@@ -30,11 +30,13 @@
    , runLocThetaImage
    , runLocThetaQuery
 
+   , stripLocThetaImage
+   , liftLocThetaQuery
+   
    , promoteLocTheta
    , applyLocTheta
    , qpromoteLocTheta
    , qapplyLocTheta
-   , zapLocThetaQuery
 
    , emptyLocThetaImage
 
@@ -49,6 +51,7 @@
 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
@@ -78,7 +81,7 @@
 
 
 newtype LocThetaQuery u a = LocThetaQuery { 
-          getLocThetaQuery :: Point2 u -> Radian -> Query u a }
+          getLocThetaQuery :: DPoint2 -> Radian -> Query u a }
 
 -- Functor
 
@@ -177,35 +180,49 @@
     in runImage (getLocThetaImage ma dpt incl) ctx
 
 
-runLocThetaQuery :: LocThetaQuery u a -> DrawingContext 
+runLocThetaQuery :: InterpretUnit u 
+                 => LocThetaQuery u a -> DrawingContext 
                  -> Point2 u -> Radian  
                  -> a
-runLocThetaQuery ma ctx pt incl = runQuery (getLocThetaQuery ma pt incl) ctx
+runLocThetaQuery ma ctx pt incl = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runQuery (getLocThetaQuery ma dpt incl) ctx
 
 
+
+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
+    dinterpCtxF pt >>= \upt -> k upt ang
 
 applyLocTheta :: InterpretUnit u 
               => LocThetaImage u a -> Point2 u -> Radian -> Image u a
 applyLocTheta mq pt ang = 
-    zapQuery (normalizeCtxF pt) >>= \dpt -> getLocThetaImage mq dpt ang
+    normalizeCtxF pt >>= \dpt -> getLocThetaImage mq dpt ang
 
 
-qpromoteLocTheta :: (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a
-qpromoteLocTheta k = LocThetaQuery $ \pt ang -> k 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 :: LocThetaQuery u a -> Point2 u -> Radian -> Query u a
-qapplyLocTheta mq pt ang = getLocThetaQuery mq pt ang
-
--- | \"zero-apply\" a LocThetaQuery.
---
-zapLocThetaQuery :: LocThetaQuery u a -> Point2 u -> Radian -> Image u a
-zapLocThetaQuery ma pt ang = askDC >>= \ctx -> 
-    let a = runLocThetaQuery ma ctx pt ang in return a
+qapplyLocTheta :: InterpretUnit u
+               => LocThetaQuery u a -> Point2 u -> Radian -> Query u a
+qapplyLocTheta ma pt ang = 
+    normalizeCtxF pt >>= \dpt -> getLocThetaQuery ma dpt ang
 
 
 
@@ -252,10 +269,9 @@
 -- 
 incline :: InterpretUnit u => LocThetaImage u a -> Radian -> LocImage u a
 incline ma incl = promoteLoc $ \pt -> 
-                    zapQuery (normalizeCtxF pt) >>= \dpt ->
-                    getLocThetaImage ma dpt incl
+    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl
 
 atIncline :: InterpretUnit u 
           => LocThetaImage u a -> Point2 u -> Radian -> Image u a
-atIncline ma pt incl = zapQuery (normalizeCtxF pt) >>= \dpt -> 
-                       getLocThetaImage ma dpt incl
+atIncline ma pt incl = 
+    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl
diff --git a/src/Wumpus/Basic/Kernel/Objects/PosObject.hs b/src/Wumpus/Basic/Kernel/Objects/PosObject.hs
--- a/src/Wumpus/Basic/Kernel/Objects/PosObject.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/PosObject.hs
@@ -83,6 +83,7 @@
 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
@@ -234,7 +235,7 @@
                    -> PosObject u a
 elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma
   where
-    fn ortt = moveStart (vtoOrigin raddr ortt) gf
+    fn ortt = moveStart (vtoRectAddress ortt raddr) gf
 
 
 
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,411 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.TraceDrawing
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- 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
-  (
-
-  -- * 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.UserState
-import Wumpus.Basic.Kernel.Base.WrappedPrimitive
-import Wumpus.Basic.Kernel.Objects.Anchors
-import Wumpus.Basic.Kernel.Objects.Basis
-import Wumpus.Basic.Kernel.Objects.Connector
-import Wumpus.Basic.Kernel.Objects.LocImage
-
-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 GenTraceDrawing st u a   = GenTraceDrawing { 
-          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }
-
-
-type instance MonUnit (GenTraceDrawing st u a) = u
-type instance UState  (GenTraceDrawing st u)   = 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 :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)
-runTraceDrawing ma ctx = 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 :: TraceDrawing u a -> DrawingContext -> HPrim u
-execTraceDrawing ma ctx = snd $ runTraceDrawing ma ctx
-
--- | 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 :: TraceDrawing u a -> DrawingContext -> a
-evalTraceDrawing ma ctx = fst $ runTraceDrawing ma ctx
-
-
-runGenTraceDrawing :: GenTraceDrawing st u a -> DrawingContext -> st 
-                   -> (a,st,HPrim u)
-runGenTraceDrawing = getGenTraceDrawing
-
-
-
-
-
--- | /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 textAttr ctx
-        (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 df ctx
-
-
-
--- | 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 gf ctx 
-          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 gf ctx
-           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 gf ctx pt
-               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 img = drawci an0 an1 img >> 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 img = drawi (connect p0 p1 img)
-
-
-
-
-
-
-
-
--- | 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 gf ctx pt
-                 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 p0 p1 gf)
diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs
--- a/src/Wumpus/Basic/VersionNumber.hs
+++ b/src/Wumpus/Basic/VersionNumber.hs
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,20,0)
+-- > (0,21,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,20,0)
+wumpus_basic_version = (0,21,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.20.0
+version:          0.21.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -30,8 +30,22 @@
   .
   Changelog:
   .
-  v0.19.0 to v0.20.0:
+  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@.
+  . 
+  v0.18.0 to v0.20.0:
+  .
   * Added text advance-vector calculations to @QueryDC@ - 
     previously they were in Wumpus-Drawing.
   . 
@@ -94,23 +108,26 @@
     Wumpus.Basic.Kernel.Base.QueryDC,
     Wumpus.Basic.Kernel.Base.Units,
     Wumpus.Basic.Kernel.Base.UpdateDC,
-    Wumpus.Basic.Kernel.Base.UserState,
     Wumpus.Basic.Kernel.Base.WrappedPrimitive,
+    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.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.Chain,
     Wumpus.Basic.Kernel.Objects.Concat,
     Wumpus.Basic.Kernel.Objects.Connector,
-    Wumpus.Basic.Kernel.Objects.CtxPicture,
     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.PosObject,
-    Wumpus.Basic.Kernel.Objects.TraceDrawing,
     Wumpus.Basic.System.FontLoader,
     Wumpus.Basic.System.FontLoader.AfmParserBase,
     Wumpus.Basic.System.FontLoader.AfmTopLevel,