diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,4 +1,38 @@
 
+0.18.0 to 0.19.0:
+
+  * Removed the Semigroup (OPlus) and Bifunctor classes. They are 
+    no longer so pertinent now that Image, LocImage etc. are 
+    newtypes rather than /ContextFuns/.
+
+  * Changed internals of LocImage, LocThetaImage and  Connector 
+    types so the internal points always have Double (PostScript 
+    point) as the unit. This fixes a bug where otherwise changing
+    the font size for drawings with Em or En units would break the
+    layout.
+
+  * Added @ORIGIN@ to the @RectAddress@ enumeration. I had 
+    overlooked that @BLC /= ORIGIN@.
+
+  * Added underline-position and underline-thickness to the font 
+    metrics read by the font loader.
+
+0.17.0 to 0.18.0:
+ 
+  * Major change - removed @ContextFun@ from @Kernel.Base@. Now 
+    the drawing objects (Image, LocImage, Connector...) are 
+    newtype wrapped Reader-Writer monads rather than aliases to 
+    one of the arity family of ContextFuns. Being newtypes gives
+    a lot better opportunities for overloading.
+
+  * Changed Displacement API - it is smaller, and the function 
+    naming is more uniform.
+  
+  * Changed @DrawingPimitives@ to use @DrawStyle@.
+  
+  * Moved vertices generating functions from @Geometry.Path@ to 
+    @Geometry.Vertices@.
+ 
 0.16.0 to 0.17.0:
 
   * Changed representation of ContextFuns - context funs are no 
diff --git a/demo/SimpleAdvGraphic.hs b/demo/SimpleAdvGraphic.hs
--- a/demo/SimpleAdvGraphic.hs
+++ b/demo/SimpleAdvGraphic.hs
@@ -50,15 +50,15 @@
 -- Normally, text calculate the advance vector from the font 
 -- metrics...
 --
-text01 :: AdvObject Double
+text01 :: AdvGraphic Double
 text01 = makeAdvObject (pure $ hvec 84) $ dcTextlabel "text01"
     
 
-text02 :: AdvObject Double
+text02 :: AdvGraphic Double
 text02 = makeAdvObject (pure $ hvec 210) $ dcTextlabel "text number two"
 
 
-miniDisk :: AdvObject Double
+miniDisk :: AdvGraphic Double
 miniDisk = makeAdvObject (pure $ V2 0 0) disk1 
   where
     disk1 = localize (fill_colour sienna) $ dcDisk FILL 3
diff --git a/demo/SimplePosObject.hs b/demo/SimplePosObject.hs
--- a/demo/SimplePosObject.hs
+++ b/demo/SimplePosObject.hs
@@ -58,15 +58,18 @@
     draw $ testDrawBl    BLC    `at` (P2 150  0)
     draw $ testDrawBl    BLR    `at` (P2 225  0)
     
+    drawl (P2 300 0) $ runPosObject msg SW
+  where
+    msg = multilinePosText VALIGN_RIGHT "Red dot represents the\nrectangle address."
 
-testDrawBl :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u
+
+testDrawBl :: RectAddress -> LocGraphic Double
 testDrawBl raddr = dcDisk FILL 2 `mappend` rectBl raddr
 
 
-rectBl :: (Fractional u, InterpretUnit u) 
-       => RectAddress -> LocGraphic u
+rectBl :: RectAddress -> LocGraphic Double
 rectBl raddr = 
-    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)
+    ignoreAns $ runPosObject (makePosObject (return ortt) (mkRectBl w h)) raddr
   where
     w    = 40 
     h    = 30
@@ -82,16 +85,14 @@
 
 
 
-testDrawMinor :: (Floating u, InterpretUnit u) 
-              => RectAddress -> LocGraphic u
+testDrawMinor :: RectAddress -> LocGraphic Double
 testDrawMinor raddr = 
     dcDisk FILL 2 `mappend` (ignoreAns $ rectMinor raddr)
 
 
-rectMinor :: (Fractional u, InterpretUnit u) 
-          => RectAddress -> LocImage u (BoundingBox u)
+rectMinor :: RectAddress -> LocGraphic Double
 rectMinor raddr = 
-    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)
+    runPosObject (makePosObject (return ortt) (mkRectMinor m w h)) raddr
   where
     m    = 10
     w    = 40 
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,6 +23,7 @@
   , 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.Objects.AdvObject
   , module Wumpus.Basic.Kernel.Objects.Anchors
@@ -48,6 +49,7 @@
 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.Objects.AdvObject
 import Wumpus.Basic.Kernel.Objects.Anchors
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
@@ -21,19 +21,10 @@
   
     MonUnit 
 
-  -- * A semigroup class
-  , OPlus(..)
-  , oconcat
-  , altconcat
 
-
-  -- * A bifunctor class
-  , Bimap(..)
-  , replaceL
-  , replaceR
-
   -- * Unit phantom type
   , UNil(..)
+  , ureturn
 
   -- * Non-contextual unit conversion.
   , ScalarUnit(..)
@@ -44,9 +35,14 @@
   , normalizeF
   , uconvert1
   , uconvertF
+
   , intraMapPoint
   , intraMapFunctor
 
+
+  -- * KernChar
+  , KernChar
+
   -- * Drawing paths
   , DrawStyle(..)
 
@@ -57,6 +53,9 @@
   , HAlign(..)
   , VAlign(..)  
 
+  -- * Text height
+  , TextHeight(..)
+
   -- * Cardinal (compass) positions
   , Cardinal(..)
 
@@ -64,8 +63,9 @@
   , Direction(..)
   
 
-  -- * Misc (potentially for Wumpus-Core)
+  -- * Misc
   , vsum
+  , both
 
   ) where
 
@@ -87,128 +87,7 @@
 
 
 
-
-
-
-infixr 6 `oplus`
-
--- | A Semigroup class.
--- 
--- The perhaps unusual name is the TeX name for the circled plus 
--- glyph. It would be nice if there was a semigroup class in the
--- Haskell Base libraries...  
--- 
-class OPlus t where
-  oplus :: t -> t -> t
-
--- | 'oconcat' : @ list_head * [rest] -> Ans @
--- 
--- Semigroup version of @mconcat@ from the module @Data.Monoid@.
---
--- As a semigroup cannot build a zero value, /concat/ cannot 
--- handle the empty list. So to make 'oconcat' a safe function
--- the input list is already destructured by one cons cell.
--- 
--- Effectively this means that client code must handle the 
--- empty list case, before calling 'oconcat'.
--- 
-oconcat :: OPlus t => t -> [t] -> t
-oconcat t = step t
-  where
-    step ac []     = ac
-    step ac (x:xs) = step (ac `oplus` x) xs
-
-
-
--- | 'altconcat' : @ alternative * [list] -> Ans@
--- 
--- 'altconcat' uses 'oplus' to create a summary value from a list
--- of values. 
---
--- When supplied the empty list 'altconcat' returns the supplied 
--- /alternative/ value. If the list is inhabited, the alternative
--- value is discarded.
---
--- This contrasts to 'oconcat' where the single value represents 
--- the head of an already destructured list.
--- 
-altconcat :: OPlus a => a -> [a] -> a
-altconcat _   (x:xs) = oconcat x xs
-altconcat alt []     = alt
-
-
-instance OPlus () where
-  _ `oplus` _ = ()
-
-
-instance OPlus a => OPlus (Const a b) where
-  Const a0 `oplus` Const a1 = Const $ a0 `oplus` a1 
-
-
-instance Ord u => OPlus (BoundingBox u) where
-  oplus = boundaryUnion
-
-instance OPlus Primitive where
-  a `oplus` b = primGroup [a,b]
-
-instance (OPlus a, OPlus b) => OPlus (a,b) where
-  (a,b) `oplus` (m,n) = (a `oplus` m, b `oplus` n)
-
-instance (OPlus a, OPlus b, OPlus c) => OPlus (a,b,c) where
-  (a,b,c) `oplus` (m,n,o) = (a `oplus` m, b `oplus` n, c `oplus` o)
-
-instance (OPlus a, OPlus b, OPlus c, OPlus d) => OPlus (a,b,c,d) where
-  (a,b,c,d) `oplus` (m,n,o,p) = (oplus a m, oplus b n, oplus c o, oplus d p)
-
-
-
-instance OPlus a => OPlus (r -> a) where
-  f `oplus` g = \x -> f x `oplus` g x
-
--- The functional instance (r -> a) also covers (r1 -> r2 -> a),
--- (r1 -> r2 -> r3 -> a) etc.
-
-instance Num u => OPlus (Vec2 u) where 
-  oplus = (^+^)
-
-
 --------------------------------------------------------------------------------
-
--- | A Bifunctor class.
--- 
--- Again, it would be nice if there was a Bifunctor class in the
--- Haskell Base libraries...  
--- 
-class Bimap f where
-  bimap     :: (a -> p) -> (b -> q) -> f a b -> f p q
-  bimapL    :: (a -> p) -> f a b -> f p b
-  bimapR    :: (b -> q) -> f a b -> f a q
-
-
-
-instance Bimap (,) where
-  bimap f g (a,b) = (f a, g b)
-  bimapL f (a,b)  = (f a, b)
-  bimapR g (a,b)  = (a, g b)
-
-instance Bimap Either where
-  bimap f _ (Left a)  = Left (f a)
-  bimap _ g (Right b) = Right (g b)
-
-  bimapL f (Left a)  = Left (f a)
-  bimapL _ (Right b) = Right b
-
-  bimapR _ (Left a)  = Left a
-  bimapR g (Right b) = Right (g b)
-
-replaceL :: Bimap f => p -> f a b -> f p b
-replaceL = bimapL . const
-
-replaceR :: Bimap f => q -> f a b -> f a q
-replaceR = bimapR . const
-
-
---------------------------------------------------------------------------------
 -- Simple objects wrapped with unit phatom type 
 
 
@@ -227,12 +106,9 @@
   mempty        = UNil
   _ `mappend` _ = UNil
 
-instance OPlus (UNil u) where
-  _ `oplus` _ = UNil
 
 
 
-
 instance Rotate (UNil u) where
   rotate _              = id
 
@@ -245,6 +121,27 @@
 instance Translate (UNil u) where
   translate _ _         = id
 
+-- | Return a 'UNil' rather than @()@ at the end of sequence of
+-- monadic commands.
+--
+-- Many Wumpus objects are usefully constructed in the 
+-- @do-notation@, but due to the need to type their unit
+-- must finish the do-block with:
+--
+-- > ureturn
+-- 
+-- or:
+-- 
+-- return UNil
+--
+-- rather than:
+--
+-- > return ()
+--
+--
+ureturn :: Monad m => m (UNil u)
+ureturn = return UNil
+
 --------------------------------------------------------------------------------
 -- Non-contextual units
 
@@ -331,8 +228,26 @@
 
 
 --------------------------------------------------------------------------------
+-- KernChar
+
+
+-- | Unit parametric version of KerningChar from Wumpus-Core.
+--
+type KernChar u = (u,EscapedChar)
+
+
+--------------------------------------------------------------------------------
 -- Drawing closed paths
 
+
+-- | Draw closed paths. 
+-- 
+-- > FILL 
+--
+-- > STROKE
+--
+-- > FILL_STROKE - the path is filled and its edge is stroked.
+--
 data DrawStyle = FILL | STROKE | FILL_STROKE
   deriving (Bounded,Enum,Eq,Ord,Show)
 
@@ -354,16 +269,38 @@
 
 -- | Horizontal alignment - align to the top, center or bottom.
 --
-data HAlign = HTop | HCenter | HBottom
+data HAlign = HALIGN_TOP | HALIGN_CENTER | HALIGN_BASE
   deriving (Enum,Eq,Ord,Show)
 
 -- | Vertical alignment - align to the left, center or bottom.
 --
-data VAlign = VLeft | VCenter | VRight
+data VAlign = VALIGN_LEFT | VALIGN_CENTER | VALIGN_RIGHT
   deriving (Enum,Eq,Ord,Show)
 
+
 --------------------------------------------------------------------------------
+-- Text height
 
+
+-- | Wumpus distinguishes two use-cases for displaying vertically 
+-- centered text.
+-- 
+-- Arbitrary text that is expected to contain lower case letters 
+-- with descenders, show take the vertical center as the mid-point 
+-- between the cap height and the descender depth.
+--
+-- Unfortunately, including the descender depth can produce 
+-- unbalanced results for text which is not expected to have 
+-- descenders (e.g. numbers within a bordered box), visually this 
+-- makes the center too high.
+-- 
+data TextHeight = JUST_CAP_HEIGHT | CAP_HEIGHT_PLUS_DESCENDER
+  deriving (Enum,Eq,Ord,Show)
+
+
+
+--------------------------------------------------------------------------------
+
 -- Compass positions
 
 -- | An enumeratied type representing the compass positions.
@@ -393,3 +330,11 @@
   where
     go a []     = a
     go a (b:bs) = go (a ^+^ b) bs
+
+
+-- | Applicative /both/ - run both computations return the pair
+-- of the the answers.
+--
+both :: Applicative f => f a -> f b -> f (a,b)
+both fa fb = (,) <$> fa <*> fb
+
diff --git a/src/Wumpus/Basic/Kernel/Base/FontSupport.hs b/src/Wumpus/Basic/Kernel/Base/FontSupport.hs
--- a/src/Wumpus/Basic/Kernel/Base/FontSupport.hs
+++ b/src/Wumpus/Basic/Kernel/Base/FontSupport.hs
@@ -158,10 +158,12 @@
 -- current point size, the actual fields are all functions.
 --
 data FontMetrics = FontMetrics
-    { get_bounding_box :: FontSize -> BoundingBox Double
-    , get_cw_table     :: FontSize -> CharWidthLookup
-    , get_cap_height   :: FontSize -> Double
-    , get_descender    :: FontSize -> Double
+    { get_bounding_box          :: FontSize -> BoundingBox Double
+    , get_cw_table              :: FontSize -> CharWidthLookup
+    , get_cap_height            :: FontSize -> Double
+    , get_descender             :: FontSize -> Double
+    , get_underline_position    :: FontSize -> Double
+    , get_underline_thickness   :: FontSize -> Double
     }
 
 
@@ -235,10 +237,12 @@
 --
 monospace_metrics :: FontMetrics
 monospace_metrics = FontMetrics
-    { get_bounding_box  = \sz -> BBox (lowerLeft sz) (upperRight sz)
-    , get_cw_table      = \sz _ -> hvec (upscale sz width_vec) 
-    , get_cap_height    = \sz -> upscale sz cap_height
-    , get_descender     = \sz -> upscale sz descender
+    { get_bounding_box          = \sz -> BBox (lowerLeft sz) (upperRight sz)
+    , get_cw_table              = \sz _ -> hvec (upscale sz width_vec) 
+    , get_cap_height            = \sz -> upscale sz cap_height
+    , get_descender             = \sz -> upscale sz descender
+    , get_underline_position    = \sz -> upscale sz underline_pos
+    , get_underline_thickness   = \sz -> upscale sz underline_width
     }
   where
     llx             = (-23)  / 1000
@@ -248,6 +252,8 @@
     width_vec       = 600    / 1000
     cap_height      = 562    / 1000
     descender       = (-157) / 1000
+    underline_pos   = (-100) / 1000
+    underline_width = 50     / 1000
 
     upscale sz d    = d * fromIntegral sz
     lowerLeft sz    = P2 (upscale sz llx) (upscale sz lly) 
diff --git a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs
--- a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs
+++ b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs
@@ -53,8 +53,16 @@
   , glyphBoundingBox
   , capHeight
   , descender
+  , underlinePosition
+  , underlineThickness
   , verticalSpan
+  , heightSpan
 
+  -- * Text metrics
+  , escTextVector
+  , escCharVector
+  , hkernVector
+
   , cwLookupTable
 
 
@@ -76,11 +84,20 @@
 import Wumpus.Basic.Kernel.Base.FontSupport
 
 import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Text.GlyphIndices
+
+import Data.VectorSpace                         -- package: vector-space
  
 import Control.Applicative
-
+import Data.Char
+import qualified Data.Map               as Map
+import Data.Maybe 
 
 
+--
+-- NOTE 20.5.11 - The normalize functions are not satisfactory,
+-- point size is too promiscuous for evaluation contextual units.
+--
 
 normalizeCtx :: (DrawingCtxM m, InterpretUnit u) => u -> m Double
 normalizeCtx u = (\sz -> normalize sz u) <$> pointSize
@@ -224,11 +241,98 @@
 descender = dinterp <$> asksDC dc_font_size <*> glyphQuery get_descender
 
 
+-- | Note - underline_position is expected to be negative.
+--
+underlinePosition :: (DrawingCtxM m, InterpretUnit u) => m u
+underlinePosition = 
+    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_position
+
+
+-- | Line width of underline line.
+--
+underlineThickness :: (DrawingCtxM m, InterpretUnit u) => m u
+underlineThickness = 
+    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_thickness
+
+
 -- | This is the distance from cap_height to descender.
 --
 verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u
 verticalSpan = 
     (\ch dd -> ch - dd) <$> capHeight <*> descender
+
+
+
+-- | Variant of 'verticalSpan' that accounts for the specified
+-- 'TextHeight'.
+--
+-- This returns a pair of @(yminor, ymajor)@.
+-- 
+heightSpan :: (DrawingCtxM m, InterpretUnit u )
+           => TextHeight -> m (u,u)
+heightSpan JUST_CAP_HEIGHT           = (\ymaj -> (0, ymaj)) <$> capHeight
+heightSpan CAP_HEIGHT_PLUS_DESCENDER = 
+    (\ymin ymaj -> (abs ymin, ymaj)) <$> descender <*> capHeight
+
+
+
+--------------------------------------------------------------------------------
+
+
+
+-- | Find the advance vector for the supplied 'EscapedText'.
+--
+-- Note - the text assumed to be a single line.
+-- 
+escTextVector :: (DrawingCtxM m, InterpretUnit u) 
+              => EscapedText -> m (Vec2 u)
+escTextVector esc = 
+    cwLookupTable >>= \table -> 
+    pointSize     >>= \sz    -> 
+    let cs = destrEscapedText id esc 
+    in return $ foldr (step sz table) (vec 0 0) cs
+  where
+    step sz table ch v = let cv = escCharWidth sz table ch in v ^+^ cv
+
+
+
+-- | Find the advance vector for the supplied 'EscapedChar'.
+--
+escCharVector :: (DrawingCtxM m, InterpretUnit u) 
+           => EscapedChar -> m (Vec2 u)
+escCharVector ch = 
+    (\table sz -> escCharWidth sz table ch) <$> cwLookupTable <*> pointSize
+
+
+-- | This is outside the Drawing context as we don\'t want to get
+-- the @cwLookupTable@ for every char.
+--
+escCharWidth :: InterpretUnit u 
+             => FontSize -> CharWidthLookup -> EscapedChar -> Vec2 u
+escCharWidth sz fn (CharLiteral c) = fmap (dinterp sz) $ fn $ ord c
+escCharWidth sz fn (CharEscInt i)  = fmap (dinterp sz) $ fn i
+escCharWidth sz fn (CharEscName s) = fmap (dinterp sz) $ fn ix
+  where
+    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
+
+
+
+
+-- | 'hkernVector' : @ [kerning_char] -> AdvanceVec @
+-- 
+-- 'hkernvector' takes whatever length is paired with the 
+-- EscapedChar for the init of the the list, for the last element 
+-- it takes the charVector.
+--
+hkernVector :: (DrawingCtxM m, InterpretUnit u) 
+            => [KernChar u] -> m (Vec2 u)
+hkernVector = go 0
+  where
+    go w []             = return $ V2 w 0
+    go w [(dx,ch)]      = fmap (addWidth $ w + dx) (escCharVector ch)
+    go w ((dx,_ ):xs)   = go (w + dx) xs
+    
+    addWidth w (V2 x y) = V2 (w+x) y
 
 
 
diff --git a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs
--- a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs
+++ b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs
@@ -35,6 +35,7 @@
   , line_thick
   , line_ultra_thick
   
+  , contextual_line_width
   , relative_line_width
 
   -- * Line cap
@@ -189,17 +190,22 @@
 
 
 
--- | Set the line width to a size relative to the current font 
--- size. The size is calculated with the supplied function.
+-- | Scale the line width respective to its current value. 
+-- 
+-- The size is calculated with the supplied function.
 --
-relative_line_width :: (FontSize -> Double) -> DrawingContextF
+relative_line_width :: (Double -> Double) -> DrawingContextF
 relative_line_width fn = 
-    withFontSize $ \sz s -> set_line_width (fn sz) s
+    updateStrokeProps (\s -> let lw = line_width s in s { line_width = fn lw })
 
 
---
--- All options share the prefix so the enumeration is obvious...
+-- | Set the line width to a size relative to the current font 
+-- size. The size is calculated with the supplied function.
 --
+contextual_line_width :: (FontSize -> Double) -> DrawingContextF
+contextual_line_width fn = 
+    withFontSize $ \sz s -> set_line_width (fn sz) s
+
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Wumpus/Basic/Kernel/Base/UserState.hs b/src/Wumpus/Basic/Kernel/Base/UserState.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Base/UserState.hs
@@ -0,0 +1,36 @@
+{-# 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/Base/WrappedPrimitive.hs b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs
--- a/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs
+++ b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs
@@ -25,6 +25,7 @@
     CatPrim
   , prim1
   , cpmap
+  , cpmove
 
   , HPrim
   , hprimToList
@@ -32,7 +33,6 @@
 
   ) where
 
-import Wumpus.Basic.Kernel.Base.BaseDefs
 import Wumpus.Basic.Utils.HList
 
 import Wumpus.Core                      -- package: wumpus-core
@@ -44,7 +44,14 @@
 
 -- | A wrapped version of 'Primitive' from Wumpus-Core that 
 -- supports Monoid.
+-- 
+-- Note that CatPrim provides a /single-object/ that can be
+-- hyperlinked or whatever. 
 --
+-- It is different to 'HPrim' which is intended as a list type 
+-- with efficient concatenation to support building of multiple
+-- Primitives in a frame.
+--
 -- This type is essentially internal to Wumpus-Basic.
 --
 data CatPrim = CZero
@@ -52,10 +59,6 @@
 
 type instance DUnit CatPrim = Double
 
-instance OPlus CatPrim where
-  CZero  `oplus` b      = b
-  a      `oplus` CZero  = a
-  Cat1 a `oplus` Cat1 b = Cat1 $ a `primCat` b
 
 
 instance Monoid CatPrim where
@@ -71,6 +74,8 @@
       step ac (x:xs) = step (ac `mappend` x) xs
 
 
+
+
 --------------------------------------------------------------------------------
 
 instance Rotate CatPrim where
@@ -101,23 +106,17 @@
 cpmap _ CZero    = CZero
 cpmap f (Cat1 a) = Cat1 $ f a
 
+
+cpmove :: Vec2 Double -> CatPrim -> CatPrim
+cpmove (V2 x y) = translate x y
+
+
 --------------------------------------------------------------------------------
 -- Lists of primitives...
 
 
--- | Graphics objects, even simple ones (line, arrow, dot) might 
--- need more than one primitive (path or text label) for their
--- construction. Hence, the primary representation that all the 
--- others are built upon must support /concatenation/ of 
--- primitives. 
---
--- Wumpus-Core has a type Picture - made from one or more 
--- Primitives - but Pictures include support for affine frames. 
--- For drawing many simple graphics (dots, connector lines...) 
--- that do not need individual affine transformations this is a 
--- penalty. A list of Primitives is therefore more suitable 
--- representation, and a Hughes list which supports
--- efficient concatenation is wise.
+-- | Collected primitives - this type is effectively an analogue
+-- to a @Frame@ in Wumpus-Core.
 --
 -- This type is essentially internal to Wumpus-Basic.
 -- 
@@ -138,6 +137,9 @@
 
 
 -- | Extract the internal list of 'Primitive' from a 'HPrim'.
+-- 
+-- The expectation is that this Primitive list will be rendered
+-- by Wumpus-Core as a @frame@.
 --
 hprimToList :: HPrim u -> [Primitive]
 hprimToList = toListH . getHPrim
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
@@ -29,6 +29,9 @@
   -- * Advance-vector object and graphic
   , AdvObject
   , DAdvObject
+
+  , AdvGraphic
+  , DAdvGraphic
   
   , runAdvObject
 
@@ -57,8 +60,7 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
-import Data.VectorSpace
+import Data.VectorSpace                         -- package: vector-space
 
 import Control.Applicative
 import Data.Monoid
@@ -97,54 +99,103 @@
 --------------------------------------------------------------------------------
 -- AdvObject
 
-type AdvDraw u = Point2 u -> CatPrim
+-- | Internal newtype wrapper so we can have a monoid instance 
+-- with vector plus (^+^) for mappend.
+--
+newtype DAV = DAV { getDAV :: AdvanceVec Double }
 
 
+instance Monoid DAV where
+  mempty = DAV $ V2 0 0
+  DAV v1 `mappend` DAV v2 = DAV $ v1 ^+^ v2
 
 -- | /Advance vector/ graphic - this partially models the 
 -- PostScript @show@ command which moves the /current point/ by the
 -- advance (width) vector as each character is drawn.
 --
-newtype AdvObject u = AdvObject { getAdvObject :: Query u (Vec2 u, AdvDraw u) }
+newtype AdvObject u a = AdvObject 
+          { getAdvObject :: DrawingContext -> DPoint2 -> (a, DAV, CatPrim) }
 
-type instance DUnit (AdvObject u) = u
+type instance DUnit (AdvObject u a) = u
 
-type DAdvObject     = AdvObject Double
+type DAdvObject a   = AdvObject Double a
 
 
+type AdvGraphic u = AdvObject u (UNil u)
+type DAdvGraphic  = AdvGraphic Double
 
 
---------------------------------------------------------------------------------
+instance Functor (AdvObject u) where
+  fmap f mf = AdvObject $ \ctx pt -> 
+              let (a,v1,w1) = getAdvObject mf ctx pt in (f a,v1,w1)
 
-instance (InterpretUnit u) => Monoid (AdvObject u) where
-  mempty  = blankAdvObject (V2 0 0)
-  mappend = advplus
 
+instance Applicative (AdvObject u) where
+  pure a    = AdvObject $ \_   _  -> (a,mempty,mempty)
+  mf <*> ma = AdvObject $ \ctx pt -> 
+              let (f,v1,w1) = getAdvObject mf ctx pt
+                  (a,v2,w2) = getAdvObject ma ctx pt
+              in (f a, v1 `mappend` v2, w1 `mappend` w2)
 
--- | Run an 'AdvObject' turning it into an 'LocImage'.
+
+
+instance Monad (AdvObject u) where
+  return a  = AdvObject $ \_   _  -> (a,mempty,mempty)
+  mf >>= k  = AdvObject $ \ctx pt -> 
+              let (a,v1,w1) = getAdvObject mf ctx pt
+                  (b,v2,w2) = getAdvObject (k a) ctx pt
+              in (b, v1 `mappend` v2, w1 `mappend` w2)
+
+
+
+instance DrawingCtxM (AdvObject u) where
+  askDC           = AdvObject $ \ctx _ -> (ctx, mempty, mempty)
+  asksDC fn       = AdvObject $ \ctx _ -> (fn ctx, mempty, mempty)
+  localize upd ma = AdvObject $ \ctx pt -> getAdvObject ma (upd ctx) pt
+
+
+
+
+instance (Monoid a, InterpretUnit u) => Monoid (AdvObject u a) where
+  mempty = AdvObject $ \_ _ -> (mempty, mempty, mempty)
+  ma `mappend` mb = AdvObject $ \ctx pt -> 
+                    let (a,v1,w1) = getAdvObject ma ctx pt
+                        (b,v2,w2) = getAdvObject mb ctx pt
+                        w2r       = cpmove (getDAV v1) w2
+                    in (a `mappend` b, v1 `mappend` v2, w1 `mappend` w2r)
+
+
+
+-- | Running an AdvObject produces a LocImage.
 --
-runAdvObject :: AdvObject u -> LocImage u (Vec2 u)
-runAdvObject (AdvObject mf) = promoteLoc $ \pt -> 
-   askDC >>= \ctx -> 
-   let (v1,df) = runQuery ctx mf
-   in replaceAns v1 $ primGraphic (df pt)
+runAdvObject :: InterpretUnit u 
+             => AdvObject u a -> LocImage u a
+runAdvObject ma = promoteLoc $ \ot -> 
+    askDC >>= \ctx -> 
+    let dot      = normalizeF (dc_font_size ctx) ot
+        (a,_,ca) = getAdvObject ma ctx dot
+    in replaceAns a $ primGraphic ca
 
 
--- | 'makeAdvObject' : @ loc_context_function * graphic -> AdvObject @
+
+--------------------------------------------------------------------------------
+
+
+-- | 'makeAdvObject' : @ loc_context_function * image -> AdvObject @
 --
 -- Build an 'AdvObject' from a context function ('CF') that 
 -- generates the answer displacement vector and a 'LocGraphic' 
 -- that draws the 'AdvObject'.
 --
-makeAdvObject :: Query u (Vec2 u) -> LocGraphic u -> AdvObject u
-makeAdvObject mq gf = AdvObject body
-  where
-    body = askDC >>= \ctx -> 
-           let v1   = runQuery ctx mq
-               pf   = \pt -> getCP $ runLocImage pt ctx gf
-           in return (v1,pf)
+makeAdvObject :: InterpretUnit u 
+              => Query u (Vec2 u) -> LocImage u a -> AdvObject u a
+makeAdvObject ma gf = AdvObject $ \ctx pt -> 
+    let v1    = runQuery ma ctx
+        dav1  = DAV $ normalizeF (dc_font_size ctx) v1
+        upt   = dinterpF (dc_font_size ctx) pt
+        (a,w) = runLocImage gf ctx upt
+    in (a,dav1,w)
 
-    getCP (PrimW ca _) = ca
 
 
 -- | 'emptyAdvObjectAU' : @ AdvObject @
@@ -155,62 +206,31 @@
 -- @Wumpus-Core@ and is not drawn, the answer vector generated is
 -- the zero vector @(V2 0 0)@.
 -- 
-emptyAdvObject :: InterpretUnit u => AdvObject u
-emptyAdvObject = blankAdvObject (V2 0 0)
+emptyAdvObject :: (Monoid a, InterpretUnit u) => AdvObject u a
+emptyAdvObject = mempty
 
 
-blankAdvObject :: Vec2 u -> AdvObject u
-blankAdvObject v1 = AdvObject $ pure (v1, const mempty)
 
+blankAdvObject :: (Monoid a, InterpretUnit u) 
+               => Vec2 u -> AdvObject u a
+blankAdvObject v1 = AdvObject $ \ctx _ ->
+                    let dav1  = DAV $ normalizeF (dc_font_size ctx) v1
+                    in (mempty, dav1, mempty)
 
 
 
 
+
 --------------------------------------------------------------------------------
 -- Combining AdvObjects
 
 
--- | Design note - this is rather /uncool/.
---
--- Here it would be nicer if PrimW didn\'t cover two cases - 
--- queries (Pure) and images (PrimW). However implementing this 
--- would double the amount of code and then require extra 
--- bind-like combinators to promote queries to images.
---
--- This is simulated in @appendW@ by dropping any graphic embedded 
--- in a PrimW (everything should be a query anyway). But it would 
--- be nicer in this particular case, if the type system enforced 
--- this.
---
-appendW :: Num u 
-        => (Vec2 u, AdvDraw u) 
-        -> (Vec2 u, AdvDraw u) 
-        -> (Vec2 u, AdvDraw u)
-appendW (v0,pf0) (v1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 (pt .+^ v0)
-                            in (v0 ^+^ v1, pf)
 
-
--- | Primitive combination.
--- 
--- Move second object by the advance vector of the first. Sum 
--- both advance vectors.
---
-advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u
-advplus a b = AdvObject body
-  where 
-    body = askDC >>= \ctx ->
-           let ans1 = runQuery ctx (getAdvObject a)
-               ans2 = runQuery ctx (getAdvObject b)
-           in return (appendW ans1 ans2)
-
-
-
-
 -- Helper for list concatenation.
 -- 
-listcat :: InterpretUnit u 
-        => (AdvObject u -> AdvObject u -> AdvObject u)
-        -> [AdvObject u] -> AdvObject u
+listcat :: (Monoid a, InterpretUnit u)
+        => (AdvObject u a -> AdvObject u a -> AdvObject u a)
+        -> [AdvObject u a] -> AdvObject u a
 listcat _ []     = mempty
 listcat op (x:xs) = go x xs
   where
@@ -232,28 +252,33 @@
 --
 -- The final answer is the sum of both advance vectors.
 --
-advance :: Num u => AdvObject u -> AdvObject u -> AdvObject u
-advance = advplus
+advance :: (Monoid a, InterpretUnit u) 
+        => AdvObject u a -> AdvObject u a -> AdvObject u a
+advance = mappend
   
 
 -- | Concatenate the list of AdvObjects with 'advance'.
 --
-advances :: InterpretUnit u => [AdvObject u] -> AdvObject u
-advances = listcat advance
+advances :: (Monoid a, InterpretUnit u) 
+         => [AdvObject u a] -> AdvObject u a
+advances = mconcat
 
 
 -- | Combine the AdvObjects using the answer vector of the 
 -- first object plus the separator to move the start of the second
 -- object. 
 --
-advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u
-advspace sep a b = a `advplus` blank `advplus` b
+advspace :: (Monoid a, InterpretUnit u) 
+         => Vec2 u -> AdvObject u a -> AdvObject u a -> AdvObject u a
+advspace sep a b = a `mappend` blank `mappend` b
   where
     blank = blankAdvObject sep
 
+
 -- | List version of 'nextSpace'.
 --
-evenspace :: InterpretUnit u => Vec2 u -> [AdvObject u] -> AdvObject u
+evenspace :: (Monoid a, InterpretUnit u) 
+          => Vec2 u -> [AdvObject u a] -> AdvObject u a
 evenspace v = listcat (advspace v)
 
 
@@ -261,14 +286,16 @@
 -- | Repeat the AdvObject @n@ times, moving each time with 
 -- 'advance'.
 --
-advrepeat :: InterpretUnit u => Int -> AdvObject u -> AdvObject u
+advrepeat :: (Monoid a, InterpretUnit u)
+          => Int -> AdvObject u a -> AdvObject u a
 advrepeat n = advances . replicate n
 
 
 -- | Concatenate the list of AdvObjects, going next and adding
 -- the separator at each step.
 --
-punctuate :: InterpretUnit u => AdvObject u -> [AdvObject u] -> AdvObject u
+punctuate :: (Monoid a, InterpretUnit u)
+          => AdvObject u a -> [AdvObject u a] -> AdvObject u a
 punctuate sep =  listcat (\a b -> a `advance` sep `advance` b)
 
 
@@ -277,11 +304,11 @@
 -- for the supplied vector. This function has behaviour analogue 
 -- to @fill@ in the @wl-pprint@ library.
 -- 
-advfill :: Num u => Vec2 u -> AdvObject u -> AdvObject u
-advfill sv a = AdvObject body
-  where 
-    body = askDC >>= \ctx ->
-           let (_,df) = runQuery ctx (getAdvObject a)
-           in return (sv,df)
+advfill :: InterpretUnit u 
+        => Vec2 u -> AdvObject u a -> AdvObject u a
+advfill sv mf = AdvObject $ \ctx pt -> 
+    let (a,_,ca) = getAdvObject mf ctx pt
+        dav1     = DAV $ normalizeF (dc_font_size ctx) sv 
+    in (a,dav1,ca)
 
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/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
@@ -21,8 +21,7 @@
 module Wumpus.Basic.Kernel.Objects.Basis
   (
 
-    PrimW(..)
-  , primAnswer
+    PrimResult
 
   , Image
   , Graphic 
@@ -45,14 +44,15 @@
 
   , emptyImage
 
-
-  , both
-
   , ignoreAns
   , replaceAns
 
   , Decorate(..)
+  , sdecorate
+  , adecorate
 
+  , selaborate
+  , aelaborate
 
   ) where
 
@@ -67,68 +67,15 @@
 import Data.Monoid
 
 
-
--- | Unit @u@ is a phantom.
---
-data PrimW u a = PrimW CatPrim a
-
-type instance DUnit (PrimW u a) = u
-
-
-instance Monoid a => Monoid (PrimW u a) where
-  mempty = PrimW mempty mempty
-  PrimW ca a `mappend` PrimW cb b = PrimW (ca `mappend` cb) (a `mappend` b)
-
-instance Functor (PrimW u) where
-  fmap f (PrimW w a) = PrimW w (f a)
-
-
-instance Applicative (PrimW u) where
-  pure a                        = PrimW mempty a
-  (PrimW c1 f) <*> (PrimW c2 a) = PrimW (c1 `mappend` c2) (f a) 
-
-
-instance Monad (PrimW u) where
-  return a            = PrimW mempty a
-  (PrimW c1 a) >>= mf = let (PrimW c2 b) = mf a
-                        in PrimW (c1 `mappend` c2) b
-
-
-primAnswer :: PrimW u a -> a
-primAnswer (PrimW _ a) = a
-
-
--- | For the moment the second fun is type preserving...
---
-bimapPrimW :: (CatPrim -> CatPrim) -> (a -> a) -> PrimW u a -> PrimW u a
-bimapPrimW f g (PrimW ca a) = PrimW (f ca) (g a)
-
-
-
-
+type PrimResult u a = (a, CatPrim)
 
 
 
--- | Convert a PrimW where the answer is some functor type 
--- parametrized by the unit.
---
-szconvPrimF :: (Functor t, InterpretUnit u, InterpretUnit u1)
-            => FontSize -> PrimW u (t u)  -> PrimW u1 (t u1)
-szconvPrimF sz (PrimW c a) = PrimW c (uconvertF sz a)
-
-
--- | Convert a PrimW where the answer is oblivious to unit.
---
-szconvPrimZ :: (InterpretUnit u, InterpretUnit u1)
-            => FontSize -> PrimW u a  -> PrimW u1 a
-szconvPrimZ _ (PrimW c a) = PrimW c a
-
-
 --------------------------------------------------------------------------------
 
 
 newtype Image u a = Image { 
-          getImage :: DrawingContext -> PrimW u a }
+          getImage :: DrawingContext -> (a, CatPrim) }
 
 type instance DUnit (Image u a) = u
 
@@ -152,7 +99,7 @@
 -- Functor
 
 instance Functor (Image u) where
-  fmap f ma = Image $ \ctx -> fmap f $ getImage ma ctx
+  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
@@ -160,9 +107,10 @@
 -- Applicative
 
 instance Applicative (Image u) where
-  pure a    = Image $ \_   -> pure a
-  mf <*> ma = Image $ \ctx -> 
-                getImage mf ctx <*> getImage ma ctx
+  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
@@ -174,8 +122,10 @@
 -- Monad
 
 instance Monad (Image u) where
-  return a = Image $ \_ -> return a
-  ma >>= k = Image $ \ctx -> getImage ma ctx >>= \ans -> getImage (k ans) ctx
+  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
@@ -199,8 +149,8 @@
 
 
 instance DrawingCtxM (Image u) where
-  askDC           = Image $ \ctx -> return ctx
-  asksDC fn       = Image $ \ctx -> return (fn ctx)
+  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
@@ -209,29 +159,28 @@
   localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)
 
 
-runImage :: DrawingContext -> Image u a -> PrimW u a
-runImage ctx mf = getImage mf ctx
+runImage :: Image u a -> DrawingContext -> PrimResult u a
+runImage = getImage
 
-runQuery :: DrawingContext -> Query u a -> a
-runQuery ctx mf = getQuery mf ctx
+runQuery :: Query u a -> DrawingContext -> a
+runQuery = getQuery
 
 
 
 zapQuery :: Query u a -> Image u a
-zapQuery mq = askDC >>= \ctx -> let a = runQuery ctx mq in return a
+zapQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx in return a
 
 -- | Constructor for Primtive graphics.
 --
 primGraphic :: CatPrim -> Graphic u
-primGraphic ca = Image $ \_ -> PrimW ca UNil
+primGraphic w = Image $ \_ -> (UNil, w)
 
 
 -- | Clip an Image.
 -- 
 clipImage :: PrimPath -> Image u a -> Image u a
-clipImage pp ma = Image $ \ctx -> step (getImage ma ctx)
-  where
-    step (PrimW ca a) = PrimW (cpmap (clip pp) ca) a
+clipImage pp ma = Image $ \ctx -> 
+     let (a,w) = getImage ma ctx in (a, cpmap (clip pp) w)
 
 
 
@@ -249,17 +198,14 @@
 uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
             => Image u (t u) -> Image u1 (t u1) 
 uconvImageF ma = Image $ \ctx -> 
-                   let sz  = dc_font_size ctx
-                       ans = getImage ma ctx
-                   in szconvPrimF sz ans
+    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 -> 
-                   let sz  = dc_font_size ctx
-                       ans = getImage ma ctx
-                   in szconvPrimZ sz ans
+uconvImageZ ma = Image $ \ctx -> getImage ma ctx
 
 
 -- | Having /empty/ at the specific 'Image' type is useful.
@@ -270,10 +216,7 @@
 --------------------------------------------------------------------------------
 
 
-both :: Applicative f => f a -> f b -> f (a,b)
-both fa fb = (,) <$> fa <*> fb
 
-
 -- | Note - the kind of f allows fo unit annotation.
 --
 ignoreAns :: Functor (f u) => f u a -> f u (UNil u)
@@ -293,45 +236,57 @@
 -- it with the graphic from the second.
 --
 class Decorate (f :: * -> * -> *) where
-  decorate   :: f u a -> f u z -> f u a
-  elaborate  :: f u a -> (a -> f u z) -> f u a
-  obliterate :: f u a -> f u z -> f u a
+  decorate   :: ZDeco -> f u a -> f u z -> f u a
+  elaborate  :: ZDeco -> f u a -> (a -> f u z) -> f u a
+  obliterate :: f u a -> f u a
   hyperlink  :: XLink -> f u a -> f u a
 
 
--- | Do not export...
---
-getCatPrim :: PrimW u a -> CatPrim
-getCatPrim (PrimW ca _) = ca
+sdecorate :: Decorate f => f u a -> f u z -> f u a
+sdecorate = decorate SUPERIOR
 
--- | Should a decoration \"lift\" a query (Pure) to an image (PrimW)? 
---
--- Currently I don\'t think it should.
+adecorate :: Decorate f => f u a -> f u z -> f u a
+adecorate = decorate ANTERIOR
+
+
+selaborate :: Decorate f => f u a -> (a -> f u z) -> f u a
+selaborate = elaborate SUPERIOR
+
+aelaborate :: Decorate f => f u a -> (a -> f u z) -> f u a
+aelaborate = elaborate ANTERIOR
+
+
+
+
+-- | Decorate Image.
 --
-decorateImage :: Image u a -> Image u z -> Image u a
-decorateImage ma mb = Image $ \ctx -> 
-    step (getImage ma ctx) (getImage mb ctx)
+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 (PrimW ca a) (PrimW cb _) = PrimW (ca `mappend` cb) a
+    step SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)
+    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)
 
 
--- |
+-- | Elaborate Image.
 --
-elaborateImage :: Image u a -> (a -> Image u z) -> Image u a
-elaborateImage ma k = Image $ \ ctx -> case getImage ma ctx of 
-    PrimW ca a -> let cb = getCatPrim $ getImage (k a) ctx 
-                  in PrimW (ca `mappend` cb) a
+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 z -> Image u a
-obliterateImage ma mb = Image $ \ctx -> 
-    let a  = primAnswer $ getImage ma ctx
-        ca = getCatPrim $ getImage mb ctx
-    in PrimW ca a
+
+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 (PrimW ca a) = PrimW (cpmap (xlinkPrim xl) ca) a
+    step (a,w) = (a, cpmap (xlinkPrim xl) w)
 
 
 
@@ -350,77 +305,34 @@
 -- Are PrimW instances needed as Image cannot use them?
 -- 
 
-instance Rotate a => Rotate (PrimW u a) where
-  rotate ang (PrimW ca a) = PrimW (rotate ang ca) (rotate ang a)
-
-
-instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => 
-    RotateAbout (PrimW u a) where
-  rotateAbout ang pt@(P2 x y) (PrimW ca a) = 
-    PrimW (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) ca)
-          (rotateAbout ang pt a) 
-        
-
-
-instance Scale a => Scale (PrimW u a) where
-  scale sx sy (PrimW ca a) = PrimW (scale sx sy ca) (scale sx sy a)
-
-
-instance (Translate a, ScalarUnit u, u ~ DUnit a) => 
-    Translate (PrimW u a) where
-  translate dx dy (PrimW cp a) = 
-    PrimW (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a) 
-
-
-
--- Image
--- Cannot use /fmap/ as it does not touch the CatPrim (w)
-
-
 instance Rotate a => Rotate (Image u a) where
   rotate ang ma = Image $ \ctx -> 
-      bimapPrimW (rotate ang) (rotate ang) $ getImage ma 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
-      in bimapPrimW (rotateAbout ang ptu) (rotateAbout ang pt) $ getImage ma 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 -> 
-      bimapPrimW (scale sx sy) (scale sx sy) $ getImage ma 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
-      in bimapPrimW (translate ddx ddy) (translate dx dy) $ getImage ma ctx
-
-
---------------------------------------------------------------------------------
-
-
-
-
-
-{-
-
--- OLD STUFF
-
-
--- | Downcast a LocThetaQuery function by applying it to the 
--- supplied point and angle, making an arity-zero Context Function 
--- (a CF). 
---
-atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a
-atIncline = apply2R2
+      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
@@ -127,7 +127,7 @@
 --
 illustrateBoundedGraphic :: InterpretUnit u
                          => Image u (BoundingBox u) -> Image u (BoundingBox u)
-illustrateBoundedGraphic gf = elaborate gf bbrectangle
+illustrateBoundedGraphic gf = aelaborate gf bbrectangle
 
 
 
@@ -136,9 +136,9 @@
 illustrateBoundedLocGraphic :: InterpretUnit u
                             => LocImage u (BoundingBox u) 
                             -> LocImage u (BoundingBox u)
-illustrateBoundedLocGraphic gf = elaborate gf fn
+illustrateBoundedLocGraphic gf = aelaborate gf fn
   where
-    fn bb = promoteLoc $ \_ ->bbrectangle bb
+    fn bb = promoteLoc $ \_ -> bbrectangle bb
 
 
 
@@ -148,7 +148,7 @@
 illustrateBoundedLocThetaGraphic :: InterpretUnit u
                                  => LocThetaImage u (BoundingBox u)
                                  -> LocThetaImage u (BoundingBox u)
-illustrateBoundedLocThetaGraphic gf = elaborate gf fn
+illustrateBoundedLocThetaGraphic gf = aelaborate gf fn
   where
     fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Chain.hs b/src/Wumpus/Basic/Kernel/Objects/Chain.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Chain.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Chain.hs
@@ -19,16 +19,19 @@
 
 module Wumpus.Basic.Kernel.Objects.Chain
   (
-    ChainAlg
-  , IterationScheme
   
-  , chain
-  , chain_
-  
-  , linearChain
-  , prefixChain
-  , iterationScheme
+    GenChain
+  , Chain
+  , DChain
+  , ChainScheme(..)
 
+  , runChain
+  , runChain_
+
+  , cnext
+  , setChainScheme
+
+
   , chainIterate
   , chainH
   , chainV
@@ -42,184 +45,223 @@
 
 
 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.Basic.Utils.HList
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Control.Applicative
 import Data.Monoid
 
--- In TikZ chains are finite node list and iterated (infite) points
 
 
--- | Chain algorithm.
+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.
 -- 
--- @Linear@ simply iterates points.
+-- For instance, we might want to cache the origin - this would
+-- not be possible if start was just a pure @cst@ value. 
 --
--- @Prefix@ runs the left chain @n@ times then runs the right 
--- chain from the end point of the left chain.
--- 
-data ChainAlg u = L1 (IterationScheme u)
-                | PX Int (ChainAlg u) (ChainAlg u)
+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 (ChainAlg u) = u
 
+type instance DUnit (ChainSt st u) = u
 
 
-data IterationScheme u = forall st. Scheme 
-      { scheme_start    :: Point2 u -> st
-      , scheme_step     :: st -> (st, Point2 u)
-      }
+-- Functor 
 
-type instance DUnit (IterationScheme u) = u
+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
 
--- | Note the tail of of result list is infinite.
--- 
--- As any prefixes will be generated fully. This potentially
--- produces a /space bubble/ where a long prefix has to be 
--- generated without the streaming of lazy evaluation. However,
--- chains that are long enough to cause this problem will be 
--- problematic for a PostScript or SVG renderer.
---
--- In short - don'\t make long chains.
---
-interpChainAlg :: ChainAlg u -> Point2 u -> [Point2 u]
-interpChainAlg ch start = go start ch
-  where
-    go pt (L1 (Scheme mk run)) = let st = mk pt in runInf run st
-    go pt (PX n chl chr)       = let (af,end) = takeAndLast n (go pt chl)
-                                 in prefixListH af $ go end chr
+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)
 
 
-runInf :: (st -> (st,Point2 u)) -> st -> [Point2 u]
-runInf fn = \st -> go (fn st) 
-  where
-    go (st,a) = a : go (fn st)
 
+-- 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)
 
 
--- | Take n elements - also return the last of element in the 
--- tuple so it can be accessed without a second traversal.
---
--- Note @(n > 0)@ 
--- 
-takeAndLast :: Int -> [a] -> (H a,a)
-takeAndLast _ []      = error "takeAndLast - empty list (unreachable?)"
-takeAndLast n (a:as)  = go (wrapH a,a) (n-1) as
-  where
-    go (af,_) i (x:xs) | i > 0     = go (af `snocH` x, x) (i-1) xs
-    go acc    _ _                  = acc
+-- DrawingCtxM
 
-emptyLoc :: LocGraphic u
-emptyLoc = mempty
+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
 
--- | Returns the end point...
---
-chain :: InterpretUnit u
-      => ChainAlg u -> [LocImage u a] -> LocImage u (Point2 u)
-chain _   [] = promoteLoc $ \pt -> replaceAns pt (applyLoc emptyLoc pt)
-chain alg fs = promoteLoc $ \pt -> 
-    let ps = interpChainAlg alg pt in go1 fs pt ps 
-  where
-    go1 (gf:gs) _  (p:ps)     = go (ignoreAns $ applyLoc gf p) gs p ps
-    go1 _       p0 _          = replaceAns p0 $ applyLoc emptyLoc p0
 
-    go acc (gf:gs) _  (p:ps)  = let g1 = ignoreAns $ applyLoc gf p
-                                in go (acc `mappend` g1) gs  p ps
-    go acc _       p0 _       = replaceAns p0 acc
 
+-- UserStateM 
 
--- | Returns no answer, just a 'LocGraphic'.
-chain_ :: InterpretUnit u => ChainAlg u -> [LocImage u a] -> LocGraphic u
-chain_ alg xs = fmap (const UNil) $ chain alg xs
+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)
 
 
-linearChain :: IterationScheme u -> ChainAlg u
-linearChain = L1
 
-prefixChain :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u
-prefixChain n c1 c2 | n < 1     = c2
-                    | otherwise = PX n c1 c2
+-- 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)
 
-iterationScheme :: (Point2 u -> st) 
-                -> (st -> (st, Point2 u)) 
-                -> IterationScheme u
-iterationScheme start stepper = Scheme start stepper
 
+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
 
 
 
-chainIterate :: (Point2 u -> Point2 u) -> ChainAlg u
-chainIterate fn = L1 $ Scheme { scheme_start = id
-                              , scheme_step  = \pt -> (fn pt, pt)
-                              }
+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
 
-chainH :: Num u => u -> ChainAlg u
-chainH = L1 . scHorizontal
 
-scHorizontal :: Num u => u -> IterationScheme u
-scHorizontal dx = Scheme { scheme_start = id
-                         , scheme_step  = \pt -> (displace (hvec dx) pt, pt)
-                         }
+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, ())
+                }
 
 
-chainV :: Num u => u -> ChainAlg u
-chainV = L1 . scVertical
 
-scVertical :: Num u => u -> IterationScheme u
-scVertical dy = Scheme { scheme_start = id
-                       , scheme_step  = \pt -> (displace (vvec dy) pt, 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) -> ChainAlg u
+
+tableRight :: Num u => Int -> (u,u) -> ChainScheme u
 tableRight num_cols (col_width,row_height) = 
-    L1 $ scStepper downF num_cols rightF
+    scStepper downF num_cols rightF
   where
     downF   = displace $ vvec $ negate row_height
     rightF  = displace $ hvec col_width
 
-tableDown :: Num u => Int -> (u,u) -> ChainAlg u
+tableDown :: Num u => Int -> (u,u) -> ChainScheme u
 tableDown num_rows (col_width,row_height) = 
-    L1 $ scStepper rightF num_rows downF
+    scStepper rightF num_rows downF
   where
     downF   = displace $ vvec $ negate row_height
     rightF  = displace $ hvec col_width
 
 
--- | Outer and inner steppers.
---
-scStepper :: PointDisplace u -> Int -> PointDisplace u -> IterationScheme u
-scStepper outF n innF = Scheme start step
-  where
-    start pt                      = (pt,pt,0)
-    step  (ogin,pt,i) | i < n     = ((ogin, innF pt, i+1), pt)
-                      | otherwise = let o1 = outF ogin 
-                                    in ((o1, innF o1,1), o1) 
 
-
-
-
-radialChain :: Floating u => u -> Radian -> Radian -> ChainAlg u
-radialChain radius start step = L1 $ scCircular radius start step
-
-   
-scCircular :: Floating u => u -> Radian -> Radian -> IterationScheme u
-scCircular radius angstart angseg = Scheme start step 
+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) = ((ogin,ang + angseg), displace (avec ang radius) ogin)
+    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
@@ -58,7 +58,7 @@
 -- end points to a polymorphic /answer/ and a graphic /primitive/.
 --
 newtype ConnectorImage u a = ConnectorImage { 
-          getConnectorImage :: Point2 u -> Point2 u -> Image u a }
+          getConnectorImage :: DPoint2 -> DPoint2 -> Image u a }
 
 
 type instance DUnit (ConnectorImage u a) = u
@@ -154,46 +154,58 @@
 
 
 instance Decorate ConnectorImage where
-  decorate ma mz = ConnectorImage $ \p0 p1 -> 
-                      getConnectorImage ma p0 p1 `decorate` 
-                        getConnectorImage mz p0 p1
+  decorate zo ma mz = ConnectorImage $ \p0 p1 -> 
+    decorate zo (getConnectorImage ma p0 p1) (getConnectorImage mz p0 p1)
 
-  elaborate ma f = ConnectorImage $ \p0 p1 -> 
-                     getConnectorImage ma p0 p1 `elaborate` 
-                       (\a -> getConnectorImage (f a) p0 p1)
+  elaborate zo ma f = ConnectorImage $ \p0 p1 -> 
+    elaborate zo (getConnectorImage ma p0 p1) 
+                 (\a -> getConnectorImage (f a) p0 p1)
 
-  obliterate ma mz = ConnectorImage $ \p0 p1 -> 
-                       getConnectorImage ma p0 p1 `obliterate` 
-                         getConnectorImage mz p0 p1
+  obliterate ma = ConnectorImage $ \p0 p1 -> 
+    obliterate $ getConnectorImage ma p0 p1
 
   hyperlink xl ma = ConnectorImage $ \p0 p1 -> 
-                       hyperlink xl $ getConnectorImage ma p0 p1
+    hyperlink xl $ getConnectorImage ma p0 p1
 
 
 
-runConnectorImage :: Point2 u -> Point2 u 
-                  -> DrawingContext -> ConnectorImage u a 
-                  -> PrimW u a
-runConnectorImage p0 p1 ctx mf = runImage ctx (getConnectorImage mf p0 p1)
+runConnectorImage :: InterpretUnit u 
+                  => ConnectorImage u a -> DrawingContext 
+                  -> Point2 u -> Point2 u
+                  -> PrimResult u a
+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 :: Point2 u -> Point2 u 
-                  -> DrawingContext -> ConnectorQuery u a 
+runConnectorQuery :: ConnectorQuery u a -> DrawingContext 
+                  -> Point2 u -> Point2 u 
                   -> a
-runConnectorQuery p0 p1 ctx mf = runQuery ctx (getConnectorQuery mf p0 p1)
+runConnectorQuery ma ctx p0 p1 = runQuery (getConnectorQuery ma p0 p1) ctx
 
 
-connect :: Point2 u -> Point2 u -> ConnectorImage u a -> Image u a
-connect p0 p1 mf = getConnectorImage mf p0 p1
+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
 
 
 
 
-promoteConn :: (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a
-promoteConn fn       = ConnectorImage $ \p0 p1 -> fn p0 p1
+promoteConn :: InterpretUnit u 
+            => (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a
+promoteConn k = ConnectorImage $ \p0 p1 ->
+    dinterpCtxF p0 >>= \up0 -> dinterpCtxF p1 >>= \up1 -> k up0 up1
 
-applyConn :: ConnectorImage u a -> Point2 u -> Point2 u -> Image u a
-applyConn mf p0 p1   = getConnectorImage mf p0 p1
+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
 
 
 qpromoteConn :: (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a
@@ -206,8 +218,8 @@
 -- | \"zero-apply\" a Connector.
 --
 zapConnectorQuery :: ConnectorQuery u a -> Point2 u -> Point2 u -> Image u a
-zapConnectorQuery mq p0 p1  = askDC >>= \ctx -> 
-    let a = runConnectorQuery p0 p1 ctx mq in return a
+zapConnectorQuery ma p0 p1  = askDC >>= \ctx -> 
+    let a = runConnectorQuery ma ctx p0 p1 in return a
 
 
 
@@ -222,10 +234,7 @@
 uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
                      => ConnectorImage u (t u) -> ConnectorImage u1 (t u1)
 uconvConnectorImageF ma = ConnectorImage $ \p0 p1 -> 
-    getFontSize >>= \sz -> 
-    let p0u = uconvertF sz p0
-        p1u = uconvertF sz p1
-    in uconvImageF $ getConnectorImage ma p0u p1u
+    uconvF $ getConnectorImage ma p0 p1
 
 
 
@@ -235,10 +244,7 @@
 uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1) 
                      => ConnectorImage u a -> ConnectorImage u1 a
 uconvConnectorImageZ ma = ConnectorImage $ \p0 p1 -> 
-    getFontSize >>= \sz -> 
-    let p0u = uconvertF sz p0
-        p1u = uconvertF sz p1
-    in uconvImageZ $ getConnectorImage ma p0u p1u
+    uconvZ $ getConnectorImage ma p0 p1
 
 -- | Having /empty/ at the specific 'ConnectorImage' type is useful.
 -- 
diff --git a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
--- a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
@@ -130,7 +130,7 @@
 --
 drawTracing :: TraceDrawing u a -> CtxPicture
 drawTracing mf = 
-    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx mf
+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx
 
 -- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @
 --
@@ -141,10 +141,10 @@
 --
 udrawTracing :: u -> TraceDrawing u a -> CtxPicture
 udrawTracing _ mf = 
-    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx mf
-
+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx
 
 
+-- Note need Gen versions with user state...
 
 
 -- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @
@@ -256,22 +256,9 @@
                in pl `picOver` (picMoveBy pr v1)
 
 
-
-
--- | > a `oplus` b
--- 
--- Place \'drawing\' a over b. The idea of @over@ here is in 
--- terms z-ordering, nither picture a or b are actually moved.
---
-instance OPlus CtxPicture where
-  oplus = moveSnd $ \_ _ -> V2 0 0
-
-
-
-
 instance ZConcat CtxPicture where
-  superior = oplus
-  anterior = flip oplus
+  superior = mappend
+  anterior = flip mappend
 
 --------------------------------------------------------------------------------
 -- Composition
@@ -371,9 +358,9 @@
 -- of @a@ and align it with the top, center or bottom of @a@.
 -- 
 cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture
-cxpAlignH HTop     = moveSnd $ \a b -> northeast a .-. northwest b
-cxpAlignH HCenter  = moveSnd $ \a b -> east a .-. west b
-cxpAlignH HBottom  = moveSnd $ \a b -> southeast a .-. southwest b
+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
@@ -382,9 +369,9 @@
 -- and align it with the left, center or right of @a@.
 -- 
 cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture
-cxpAlignV VLeft    = moveSnd $ \a b -> southwest a .-. northwest b
-cxpAlignV VCenter  = moveSnd $ \a b -> south a .-. north b
-cxpAlignV VRight   = moveSnd $ \a b -> southeast a .-. northeast b
+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
 
 
 
@@ -400,10 +387,10 @@
 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 HTop    = mv northeast northwest
-    go HCenter = mv east west 
-    go HBottom = mv southeast southwest
+    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
@@ -414,8 +401,8 @@
 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 VLeft   = mv southwest northwest 
-    go VCenter = mv south north  
-    go VRight  = mv southeast northeast 
+    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
@@ -37,7 +37,6 @@
   , dcEscapedlabel
   , dcREscapedlabel
 
-  , KernChar
   , hkernLine
   , vkernLine
 
@@ -70,7 +69,6 @@
 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
 
@@ -312,9 +310,6 @@
 
 
 
--- | Unit parametric version of KerningChar from Wumpus-Core.
---
-type KernChar u = (u,EscapedChar)
 
 uconvKernChar :: InterpretUnit u => [KernChar u] -> Query u [KerningChar]
 uconvKernChar = mapM mf
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
@@ -35,6 +35,7 @@
    , qpromoteLoc
    , qapplyLoc
    , zapLocQuery
+   , extrLoc
 
    , emptyLocImage
 
@@ -76,7 +77,7 @@
 -- /primitive/ (PrimW).
 --
 newtype LocImage u a = LocImage { 
-          getLocImage :: Point2 u -> Image u a }
+          getLocImage :: DPoint2 -> Image u a }
 
 type instance DUnit (LocImage u a) = u
 
@@ -157,32 +158,33 @@
 
   
 instance Decorate LocImage where
-  decorate ma mz = LocImage $ \pt -> 
-                      getLocImage ma pt `decorate` getLocImage mz pt 
+  decorate zo ma mz = LocImage $ \pt -> 
+    decorate zo (getLocImage ma pt) (getLocImage mz pt)
 
-  elaborate ma f = LocImage $ \pt -> 
-                      getLocImage ma pt `elaborate` (\a -> getLocImage (f a) pt)
+  elaborate zo ma f = LocImage $ \pt -> 
+    elaborate zo (getLocImage ma pt) (\a -> getLocImage (f a) pt)
 
-  obliterate ma mz = LocImage $ \pt -> 
-                       getLocImage ma pt `obliterate` getLocImage mz pt 
+  obliterate ma = LocImage $ \pt -> obliterate $ getLocImage ma pt 
 
-  hyperlink xl ma = LocImage $ \pt -> 
-                       hyperlink xl $ getLocImage ma pt 
+  hyperlink xl ma = LocImage $ \pt -> hyperlink xl $ getLocImage ma pt 
 
 
-runLocImage :: Point2 u -> DrawingContext -> LocImage u a -> PrimW u a
-runLocImage pt ctx mf = runImage ctx (getLocImage mf pt)
+runLocImage :: InterpretUnit u 
+            => LocImage u a -> DrawingContext -> Point2 u -> PrimResult u a
+runLocImage ma ctx pt = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runImage (getLocImage ma dpt) ctx
 
-runLocQuery :: Point2 u -> DrawingContext -> LocQuery u a -> a
-runLocQuery pt ctx mf = runQuery ctx (getLocQuery mf pt)
+runLocQuery :: LocQuery u a -> DrawingContext -> Point2 u -> a
+runLocQuery ma ctx pt = runQuery (getLocQuery ma pt) ctx
 
 
 
-promoteLoc ::  (Point2 u -> Image u a) -> LocImage u a
-promoteLoc k = LocImage $ \pt -> k pt
+promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a
+promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= \upt -> k upt
 
-applyLoc :: LocImage u a -> Point2 u -> Image u a
-applyLoc mq pt = getLocImage mq pt
+applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
+applyLoc mq pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mq dpt
 
 
 qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a
@@ -192,13 +194,26 @@
 qapplyLoc mq pt = getLocQuery mq pt
 
 
+-- | 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
 
 -- | \"zero-apply\" a LocQuery.
 --
 zapLocQuery :: LocQuery u a -> Point2 u -> Image u a
-zapLocQuery mq pt = askDC >>= \ctx -> let a = runLocQuery pt ctx mq in return a
+zapLocQuery ma pt = askDC >>= \ctx -> 
+                    let a = runLocQuery ma ctx pt in return a
 
 
 
@@ -218,27 +233,35 @@
 --------------------------------------------------------------------------------
 -- Affine instances
 
-instance (Real u, Floating u, Rotate a) => Rotate (LocImage u a) where
+instance (Real u, Floating u, InterpretUnit u, Rotate a) => 
+    Rotate (LocImage u a) where
   rotate ang ma = promoteLoc $ \pt -> 
-                     fmap (rotate ang) $ getLocImage ma (rotate ang pt)
+                     zapQuery (normalizeCtxF pt) >>= \dpt ->  
+                     fmap (rotate ang) $ getLocImage ma (rotate ang dpt)
 
 
-instance (Real u, Floating u, RotateAbout a, ScalarUnit u, u ~ DUnit a) => 
+instance (Real u, Floating u, InterpretUnit u, RotateAbout a, u ~ DUnit a) => 
     RotateAbout (LocImage u a) where
-  rotateAbout ang pt ma = promoteLoc $ \p0 -> 
+  rotateAbout ang pt ma = promoteLoc $ \p0 ->
+                            zapQuery (normalizeCtxF p0) >>= \dp0 ->  
+                            zapQuery (normalizeCtxF pt) >>= \dpt ->  
                             fmap (rotateAbout ang pt) $ 
-                              getLocImage ma (rotateAbout ang pt p0)
+                              getLocImage ma (rotateAbout ang dpt dp0)
 
 
-instance (Fractional u, Scale a) => Scale (LocImage u a) where
+instance (Fractional u, InterpretUnit u, Scale a) => Scale (LocImage u a) where
   scale sx sy ma = promoteLoc $ \pt -> 
-                   fmap (scale sx sy) $ getLocImage ma (scale sx sy pt)
+                     zapQuery (normalizeCtxF pt) >>= \dpt -> 
+                     fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)
 
-instance (Num u, Translate a, ScalarUnit u, u ~ DUnit a) => 
+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 dx dy pt)
+                             getLocImage ma (translate ddx ddy dpt)
 
 --------------------------------------------------------------------------------
 
@@ -252,10 +275,7 @@
 --
 uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
                => LocImage u (t u) -> LocImage u1 (t u1)
-uconvLocImageF ma = LocImage $ \pt -> 
-    getFontSize >>= \sz -> 
-    let ptu = uconvertF sz pt
-    in uconvF $ getLocImage ma ptu
+uconvLocImageF ma = LocImage $ \pt -> uconvF $ getLocImage ma pt
 
 
 
@@ -263,10 +283,7 @@
 --
 uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1) 
                => LocImage u a -> LocImage u1 a
-uconvLocImageZ ma = LocImage $ \pt -> 
-    getFontSize >>= \sz ->  
-    let ptu = uconvertF sz pt
-    in uconvZ $ getLocImage ma ptu
+uconvLocImageZ ma = LocImage $ \pt -> uconvZ $ getLocImage ma pt
 
 
 -- | Having /empty/ at the specific 'LocImage' type is useful.
@@ -280,8 +297,9 @@
 -- Note - maybe this should just be an operator on LocImage...
 --
 
-moveStart :: Num u => Vec2 u -> LocImage u a -> LocImage u a
-moveStart v1 ma = LocImage $ \pt -> getLocImage ma (pt .+^ v1) 
+moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a
+moveStart v1 ma = LocImage $ \pt -> 
+    zapQuery (normalizeCtxF v1) >>= \dv -> getLocImage ma (pt .+^ dv) 
 
 
 
@@ -291,8 +309,8 @@
 -- | Downcast a 'LocImage' function by applying it to the supplied 
 -- point, making an 'Image'. 
 -- 
-at :: LocImage u a -> Point2 u -> Image u a
-at mf pt = getLocImage mf pt
+at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a
+at mf pt = zapQuery (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
@@ -61,7 +61,7 @@
 -- /primitive/ (PrimW).
 --
 newtype LocThetaImage u a = LocThetaImage { 
-          getLocThetaImage :: Point2 u -> Radian -> Image u a }
+          getLocThetaImage :: DPoint2 -> Radian -> Image u a }
 
 type instance DUnit (LocThetaImage u a) = u
 
@@ -152,41 +152,46 @@
 --
 
 instance Decorate LocThetaImage where
-  decorate ma mz = LocThetaImage $ \pt ang -> 
-                      getLocThetaImage ma pt ang `decorate` 
-                        getLocThetaImage mz pt ang
+  decorate zo ma mz = LocThetaImage $ \pt ang -> 
+    decorate zo (getLocThetaImage ma pt ang) (getLocThetaImage mz pt ang)
 
-  elaborate ma f = LocThetaImage $ \pt ang -> 
-                     getLocThetaImage ma pt ang `elaborate` 
-                       (\a -> getLocThetaImage (f a) pt ang)
+  elaborate zo ma f = LocThetaImage $ \pt ang -> 
+    elaborate zo (getLocThetaImage ma pt ang) 
+                 (\a -> getLocThetaImage (f a) pt ang)
 
-  obliterate ma mz = LocThetaImage $ \pt ang -> 
-                       getLocThetaImage ma pt ang `obliterate` 
-                         getLocThetaImage mz pt ang
+  obliterate ma = LocThetaImage $ \pt ang -> 
+    obliterate $ getLocThetaImage ma pt ang
 
   hyperlink xl ma = LocThetaImage $ \pt ang -> 
-                       hyperlink xl $ getLocThetaImage ma pt ang
+    hyperlink xl $ getLocThetaImage ma pt ang
            
 
 
 
-runLocThetaImage :: Point2 u -> Radian -> DrawingContext 
-                 -> LocThetaImage u a 
-                 -> PrimW u a
-runLocThetaImage pt incl ctx mf = runImage ctx (getLocThetaImage mf pt incl)
+runLocThetaImage :: InterpretUnit u 
+                 => LocThetaImage u a -> DrawingContext 
+                 -> Point2 u -> Radian
+                 -> PrimResult u a
+runLocThetaImage ma ctx pt incl = 
+    let dpt = normalizeF (dc_font_size ctx) pt 
+    in runImage (getLocThetaImage ma dpt incl) ctx
 
 
-runLocThetaQuery :: Point2 u -> Radian -> DrawingContext 
-                 -> LocThetaQuery u a 
+runLocThetaQuery :: LocThetaQuery u a -> DrawingContext 
+                 -> Point2 u -> Radian  
                  -> a
-runLocThetaQuery pt incl ctx mf = runQuery ctx (getLocThetaQuery mf pt incl)
+runLocThetaQuery ma ctx pt incl = runQuery (getLocThetaQuery ma pt incl) ctx
 
 
-promoteLocTheta ::  (Point2 u -> Radian -> Image u a) -> LocThetaImage u a
-promoteLocTheta k = LocThetaImage $ \pt ang -> k pt ang
+promoteLocTheta ::  InterpretUnit u 
+                => (Point2 u -> Radian -> Image u a) -> LocThetaImage u a
+promoteLocTheta k = LocThetaImage $ \pt ang -> 
+                      dinterpCtxF pt >>= \upt -> k upt ang
 
-applyLocTheta :: LocThetaImage u a -> Point2 u -> Radian -> Image u a
-applyLocTheta mq pt ang = getLocThetaImage mq pt 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
 
 
 qpromoteLocTheta :: (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a
@@ -199,11 +204,12 @@
 -- | \"zero-apply\" a LocThetaQuery.
 --
 zapLocThetaQuery :: LocThetaQuery u a -> Point2 u -> Radian -> Image u a
-zapLocThetaQuery mq pt ang = askDC >>= \ctx -> 
-    let a = runLocThetaQuery pt ang ctx mq in return a
+zapLocThetaQuery ma pt ang = askDC >>= \ctx -> 
+    let a = runLocThetaQuery ma ctx pt ang in return a
 
 
 
+
 instance UConvert LocThetaImage where
   uconvF = uconvLocThetaImageF
   uconvZ = uconvLocThetaImageZ
@@ -215,9 +221,7 @@
 uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
                     => LocThetaImage u (t u) -> LocThetaImage u1 (t u1)
 uconvLocThetaImageF ma = LocThetaImage $ \pt ang -> 
-    getFontSize >>= \sz -> 
-    let ptu = uconvertF sz pt
-    in uconvF $ getLocThetaImage ma ptu ang
+    uconvF $ getLocThetaImage ma pt ang
 
 
 
@@ -227,9 +231,7 @@
 uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) 
                     => LocThetaImage u a -> LocThetaImage u1 a
 uconvLocThetaImageZ ma = LocThetaImage $ \pt ang -> 
-    getFontSize >>= \sz -> 
-    let ptu = uconvertF sz pt
-    in uconvZ $ getLocThetaImage ma ptu ang
+    uconvZ $ getLocThetaImage ma pt ang
 
 
 
@@ -248,8 +250,12 @@
 -- | Downcast a 'LocThetaImage' function by applying it to the 
 -- supplied angle, making a 'LocImage'. 
 -- 
-incline :: LocThetaImage u a -> Radian -> LocImage u a
-incline ma incl = promoteLoc $ \pt -> getLocThetaImage ma pt incl
+incline :: InterpretUnit u => LocThetaImage u a -> Radian -> LocImage u a
+incline ma incl = promoteLoc $ \pt -> 
+                    zapQuery (normalizeCtxF pt) >>= \dpt ->
+                    getLocThetaImage ma dpt incl
 
-atIncline :: LocThetaImage u a -> Point2 u -> Radian -> Image u a
-atIncline ma pt incl = getLocThetaImage ma pt 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
diff --git a/src/Wumpus/Basic/Kernel/Objects/Orientation.hs b/src/Wumpus/Basic/Kernel/Objects/Orientation.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Orientation.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Orientation.hs
@@ -23,8 +23,13 @@
     RectAddress(..)
   , Orientation(..)
 
-  , orientationStart
+  , vtoRectAddress
+  , vtoOrigin
   , orientationBounds
+  , orientationWidth
+  , orientationHeight
+
+  , rotateOrientation
  
   , extendOrientation
   , extendOLeft
@@ -32,12 +37,12 @@
   , extendODown
   , extendOUp
 
-  , padHEven
-  , padXMinor
-  , padXMajor
-  , padVEven
-  , padYMajor
-  , padYMinor
+  , fillHEven
+  , fillXMinor
+  , fillXMajor
+  , fillVEven
+  , fillYMajor
+  , fillYMinor
 
   , spineRight
   , spineBelow
@@ -61,16 +66,26 @@
   ) where
 
 
-import Wumpus.Basic.Kernel.Base.BaseDefs
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Data.VectorSpace                         -- package: vector-space
+
 import Data.Monoid
 
 -- | Datatype enumerating the addressable positions of a rectangle 
 -- that can be derived for a 'PosObject'.  
 --
-data RectAddress = CENTER 
+-- The positions are the compass points, plus the geometric 
+-- center, origin and the baseline positions: 
+-- 
+-- > BLL - baseline-left
+--
+-- > BLC - baseline-center 
+-- 
+-- > BLR - baseline-right
+--
+data RectAddress = CENTER | ORIGIN
                  | NN | SS | EE | WW | NE | NW | SE | SW 
                  | BLL | BLC | BLR
   deriving (Enum,Eq,Ord,Show)
@@ -111,75 +126,77 @@
   fmap f (Orientation xmin xmaj ymin ymaj) = 
     Orientation (f xmin) (f xmaj) (f ymin) (f ymaj)
 
-instance (Fractional u, Ord u) => OPlus (Orientation u) where
-  oplus = concatOrientation
 
-
+-- | Concatenation coalesces the origins.
+--
 instance (Fractional u, Ord u) => Monoid (Orientation u) where
   mempty  = Orientation 0 0 0 0
-  mappend = concatOrientation
-
--- | Concatenation here essentially turns both Orientation objects
--- into /center-form/ then finds the maximum rectangle.
---
-concatOrientation :: (Fractional u, Ord u) 
-                => Orientation u -> Orientation u -> Orientation u
-concatOrientation op0 op1 = Orientation hw hw hh hh
-  where
-    (hw0,hh0) = halfDists op0
-    (hw1,hh1) = halfDists op1
-    hw        = max hw0 hw1
-    hh        = max hh0 hh1
-
-
+  a `mappend` b = 
+     Orientation { or_x_minor = max (or_x_minor a) (or_x_minor b)
+                 , or_x_major = max (or_x_major a) (or_x_major b)
+                 , or_y_minor = max (or_y_minor a) (or_y_minor b)
+                 , or_y_major = max (or_y_major a) (or_y_major b)
+                 }
 
 
--- | Find the half-width and half-height of an Orientation.
--- 
--- Essentially this is /center-form/ of an Orientation, but 
--- in /center-form/ there is duplication: 
---
--- > xminor == xmajor
--- > yminor == ymajor
--- 
--- So instead, the result type is just a pair.
---
-halfDists :: Fractional u => Orientation u -> (u,u)
-{-# INLINE halfDists #-}
-halfDists (Orientation xmin xmaj ymin ymaj) = 
-    (0.5 * (xmin+xmaj), 0.5 * (ymin+ymaj))
+-- Helper types for calculating vector from Origin 
+-- (not exported).
 
+data HDist = HCENTER | HLEFT | HRIGHT
+  deriving (Eq,Ord,Show)
 
+data VDist = VCENTER | VBASE | VTOP
+  deriving (Eq,Ord,Show)
 
 
 
--- | The vector from a 'RectAddress' to the start point.
+-- | The vector from a origin ro a 'RectAddress'.
 --
-orientationStart :: Fractional u => RectAddress -> Orientation u -> Vec2 u
-orientationStart rpos (Orientation xmin xmaj ymin ymaj) = go rpos
+vtoRectAddress :: (Fractional u, Ord u) 
+               => Orientation u -> RectAddress -> Vec2 u
+vtoRectAddress (Orientation xmin xmaj ymin ymaj) = go
   where
-    w         = xmin + xmaj
-    h         = ymin + ymaj
-    hw        = 0.5 * w
-    hh        = 0.5 * h
+    hw        = 0.5  * (xmin + xmaj)
+    hh        = 0.5  * (ymin + ymaj)
    
     -- CENTER, NN, SS, EE, WW all go to bottomleft then add back 
     -- the minors.
 
-    go CENTER = V2 ((-hw) + xmin) ((-hh) + ymin)
-    go NN     = V2 ((-hw) + xmin) ((-h)  + ymin)
-    go SS     = V2 ((-hw) + xmin)   ymin
-    go EE     = V2 ((-w)  + xmin) ((-hh) + ymin)
-    go WW     = V2 xmin           ((-hh) + ymin)
-    go NE     = V2 (-xmaj)        (-ymaj)
-    go SE     = V2 (-xmaj)          ymin
-    go SW     = V2 xmin             ymin
-    go NW     = V2 xmin           (-ymaj)
-    go BLL    = V2 xmin             0
-    go BLC    = V2 ((-hw) + xmin)   0
-    go BLR    = V2 ((-w)  + xmin)   0 
+    go CENTER = V2 (hdist HCENTER) (vdist VCENTER)
+    go ORIGIN = zeroVec
+    go NN     = V2 (hdist HCENTER) (vdist VTOP)
+    go SS     = V2 (hdist HCENTER) (vdist VBASE)
+    go EE     = V2 (hdist HRIGHT)  (vdist VCENTER)
+    go WW     = V2 (hdist HLEFT)   (vdist VCENTER)
+    go NE     = V2 (hdist HRIGHT)  (vdist VTOP)
+    go SE     = V2 (hdist HRIGHT)  (vdist VBASE)
+    go SW     = V2 (hdist HLEFT)   (vdist VBASE)
+    go NW     = V2 (hdist HLEFT)   (vdist VTOP)
+    go BLL    = V2 (hdist HLEFT)   0
+    go BLC    = V2 (hdist HCENTER) 0
+    go BLR    = V2 (hdist HRIGHT)  0 
 
+    -- > [..o..^.....]  , o -> ^
+    --
+    hdist HCENTER = if xmin < xmaj then hw - xmin else negate (xmin - hw)
 
+    -- > [..o..^.....]  , o -> [
+    --
+    hdist HLEFT   = negate xmin
+    
+    -- > [..o..^.....]  , o -> ]
+    --
+    hdist HRIGHT  = xmaj
+
+    vdist VCENTER = if ymin < ymaj then hh - ymin else negate (ymin - hh)
+    vdist VBASE   = negate ymin
+    vdist VTOP    = ymaj
+
+
+vtoOrigin :: (Fractional u, Ord u) 
+          => RectAddress -> Orientation u -> Vec2 u
+vtoOrigin addr ortt = negateV $ vtoRectAddress ortt addr
+
 -- | Calculate the bounding box formed by locating the 'Orientation'
 -- at the supplied point.
 -- 
@@ -191,7 +208,54 @@
     urc   = P2 (x+xmaj) (y+ymaj)
 
 
+-- | Height of the orientation.
+--
+orientationWidth :: Num u => Orientation u -> u
+orientationWidth (Orientation xmin xmaj _ _) = xmin + xmaj
+
+-- | Height of the orientation.
+--
+orientationHeight :: Num u => Orientation u -> u
+orientationHeight (Orientation _ _ ymin ymaj) = ymin + ymaj
+
 --------------------------------------------------------------------------------
+-- Rotation
+
+-- | Rotate an Orientation about its origin (locus).
+--
+rotateOrientation :: (Real u, Floating u, Ord u) 
+               => Radian -> Orientation u -> Orientation u
+rotateOrientation ang (Orientation { or_x_minor = xmin
+                                   , or_x_major = xmaj
+                                   , or_y_minor = ymin
+                                   , or_y_major = ymaj }) = 
+    orthoOrientation bl br tl tr  
+  where
+    bl  = rotateAbout ang zeroPt $ P2 (-xmin) (-ymin)
+    br  = rotateAbout ang zeroPt $ P2   xmaj  (-ymin)
+    tr  = rotateAbout ang zeroPt $ P2   xmaj    ymaj
+    tl  = rotateAbout ang zeroPt $ P2 (-xmin)   ymaj
+  
+
+orthoOrientation :: (Num u, Ord u)
+                 => Point2 u -> Point2 u -> Point2 u -> Point2 u 
+                 -> Orientation u
+orthoOrientation (P2 x0 y0) (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = 
+    Orientation { or_x_minor = abs $ min4 x0 x1 x2 x3
+                , or_x_major = max4 x0 x1 x2 x3
+                , or_y_minor = abs $ min4 y0 y1 y2 y3
+                , or_y_major = max4 y0 y1 y2 y3
+                }
+
+
+min4 :: Ord u => u -> u -> u -> u -> u
+min4 a b c d = min (min a b) (min c d)
+
+max4 :: Ord u => u -> u -> u -> u -> u
+max4 a b c d = max (max a b) (max c d)
+
+
+--------------------------------------------------------------------------------
 -- Extending an arm of the orientation
 
 extendOrientation :: Num u 
@@ -218,10 +282,12 @@
 
 
 --------------------------------------------------------------------------------
+-- Note these are fills not pads...
 
-padHEven :: (Fractional u, Ord u) 
+
+fillHEven :: (Fractional u, Ord u) 
           => u -> Orientation u -> Orientation u
-padHEven w ortt@(Orientation xmin xmaj _ _) = 
+fillHEven w ortt@(Orientation xmin xmaj _ _) = 
     if w > ow then ortt { or_x_minor = xmin + hdx
                         , or_x_major = xmaj + hdx } 
               else ortt
@@ -230,25 +296,25 @@
     hdx = 0.5 * (w - ow)
 
 
-padXMinor :: (Num u, Ord u) 
+fillXMinor :: (Num u, Ord u) 
           => u -> Orientation u -> Orientation u
-padXMinor w ortt@(Orientation xmin xmaj _ _) = 
+fillXMinor w ortt@(Orientation xmin xmaj _ _) = 
     if w > ow then ortt { or_x_minor = xmin + dx } else ortt
   where
     ow = xmin + xmaj
     dx = w - ow
 
-padXMajor :: (Num u, Ord u)
+fillXMajor :: (Num u, Ord u)
          => u -> Orientation u -> Orientation u
-padXMajor w ortt@(Orientation xmin xmaj _ _) = 
+fillXMajor w ortt@(Orientation xmin xmaj _ _) = 
     if w > ow then ortt { or_x_major = xmaj + dx } else ortt
   where
     ow = xmin + xmaj
     dx = w - ow
 
-padVEven :: (Fractional u, Ord u) 
+fillVEven :: (Fractional u, Ord u) 
           => u -> Orientation u -> Orientation u
-padVEven h ortt@(Orientation _ _ ymin ymaj) = 
+fillVEven h ortt@(Orientation _ _ ymin ymaj) = 
     if h > oh then ortt { or_y_minor = ymin + hdy
                         , or_y_major = ymaj + hdy } 
               else ortt
@@ -256,18 +322,18 @@
     oh = ymin + ymaj
     hdy = 0.5 * (h - oh)
 
-padYMinor :: (Num u, Ord u) 
+fillYMinor :: (Num u, Ord u) 
          => u -> Orientation u -> Orientation u
-padYMinor h ortt@(Orientation _ _ ymin ymaj) = 
+fillYMinor h ortt@(Orientation _ _ ymin ymaj) = 
     if h > oh then ortt { or_y_minor = ymin + dy } else ortt
   where
     oh = ymin + ymaj
     dy = h - oh
 
 
-padYMajor :: (Num u, Ord u) 
+fillYMajor :: (Num u, Ord u) 
        => u -> Orientation u -> Orientation u
-padYMajor h ortt@(Orientation _ _ ymin ymaj) = 
+fillYMajor h ortt@(Orientation _ _ ymin ymaj) = 
     if h > oh then ortt { or_y_major = ymaj + dy } else ortt
   where
     oh = ymin + ymaj
@@ -407,12 +473,12 @@
 --------------------------------------------------------------------------------
 -- Binary start pos displacement
 
+-- Note - these can be made a lot clearer...
+
 upDown :: Num u => u -> u -> u
-{-# INLINE upDown #-}
 upDown u d = u - d
 
 downUp :: Num u => u -> u -> u
-{-# INLINE downUp #-}
 downUp d u = negate d + u
 
 -- | Move second right.
@@ -461,12 +527,10 @@
 
 
 leftRight :: Num u => u -> u -> u
-{-# INLINE leftRight #-}
 leftRight l r = negate l + r
 
 
 rightLeft :: Num u => u -> u -> u
-{-# INLINE rightLeft #-}
 rightLeft r l = r - l
 
 
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
@@ -29,23 +29,49 @@
     PosObject
   , DPosObject
 
+  , PosGraphic
+  , DPosGraphic
 
   -- * Operations
   , runPosObject
+  , runPosObjectBBox
 
   , makePosObject
---  , makeBindPosObject
   , emptyPosObject
 
+  , elaboratePosObject
+  , decoratePosObject
 
-  , localPosObject
-  , decoPosObject
   , extendPosObject
   , mapOrientation
 
   , illustratePosObject
 
+  , posChar
+  , posEscChar 
+  , posCharUpright
+  , posEscCharUpright
+  
+  , posCharPrim
 
+  , posText
+  , posEscText 
+  , posTextUpright
+  , posEscTextUpright
+
+  , posTextPrim
+
+  , multilinePosText
+  , multilinePosEscText
+
+  , rposText
+  , rposEscText
+
+  , posHKernText
+
+  , monospaceText
+  , monospaceEscText
+
   ) where
 
 
@@ -58,6 +84,7 @@
 import Wumpus.Basic.Kernel.Objects.Concat
 import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
 import Wumpus.Basic.Kernel.Objects.LocImage
+import Wumpus.Basic.Kernel.Objects.LocThetaImage
 import Wumpus.Basic.Kernel.Objects.Orientation
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -69,81 +96,103 @@
 import Control.Applicative
 import Data.Monoid
 
+type DOrt = Orientation Double
 
--- | Helper for PosObject - a LocImage that is /pre-applied/ to 
--- the DrawingContext.
+-- | A positionable \"Object\".
 --
--- This is somewhat contrived, but the orientation and the result
--- graphic from a PosImage have to be generated within the same 
--- DrawingContext.
+newtype PosObject u a = PosObject 
+          { getPosObject :: DrawingContext -> DPoint2 -> (a, DOrt, CatPrim) }
+
+type instance DUnit (PosObject u a) = u
+    
+-- | Version of PosObject specialized to Double for the unit type.
 --
-type PosDraw u = Point2 u -> CatPrim
+type DPosObject a = PosObject Double a
 
 
--- | A positionable \"Object\" that is drawn as a 
--- 'BoundedLocGraphic'.
+-- | Version of PosObject with answer specialized to UNil.
 --
-newtype PosObject u = PosObject 
-          { getPosObject :: Query u (Orientation u, PosDraw u) }
+type PosGraphic u = PosObject u (UNil u)
 
-type instance DUnit (PosObject u) = u
-    
--- | Version of PosObject specialized to Double for the unit type.
+-- | Version of PosGraphic specialized to Double for the unit type.
 --
-type DPosObject = PosObject Double
+type DPosGraphic = PosGraphic Double
 
 
 
 
+instance Functor (PosObject u) where
+  fmap f mf = PosObject $ \ctx pt -> 
+              let (a,o1,w1) = getPosObject mf ctx pt in (f a,o1,w1)
 
---------------------------------------------------------------------------------
 
+instance Applicative (PosObject u) where
+  pure a    = PosObject $ \_   _  -> (a,mempty,mempty)
+  mf <*> ma = PosObject $ \ctx pt -> 
+              let (f,o1,w1) = getPosObject mf ctx pt
+                  (a,o2,w2) = getPosObject ma ctx pt
+              in (f a, o1 `mappend` o2, w1 `mappend` w2)
 
 
-instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where
-  mempty  = emptyPosObject
-  mappend = poconcat
 
+instance Monad (PosObject u) where
+  return a  = PosObject $ \_   _  -> (a,mempty,mempty)
+  mf >>= k  = PosObject $ \ctx pt -> 
+              let (a,o1,w1) = getPosObject mf ctx pt
+                  (b,o2,w2) = getPosObject (k a) ctx pt
+              in (b, o1 `mappend` o2, w1 `mappend` w2)
 
 
-poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u
-poconcat a b = PosObject body
-   where
-    body = askDC >>= \ctx ->
-           let ans1 = runQuery ctx (getPosObject a)
-               ans2 = runQuery ctx (getPosObject b)
-           in pure (appendW ans1 ans2)
 
+instance DrawingCtxM (PosObject u) where
+  askDC           = PosObject $ \ctx _ -> (ctx, mempty, mempty)
+  asksDC fn       = PosObject $ \ctx _ -> (fn ctx, mempty, mempty)
+  localize upd ma = PosObject $ \ctx pt -> getPosObject ma (upd ctx) pt
 
 
-appendW :: (Fractional u, Ord u)
-        => (Orientation u, PosDraw u) 
-        -> (Orientation u, PosDraw u) 
-        -> (Orientation u, PosDraw u)
-appendW (o0,pf0) (o1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 pt
-                            in (o0 `mappend` o1, pf)
 
 
+instance (Monoid a, InterpretUnit u) => Monoid (PosObject u a) where
+  mempty = PosObject $ \_ _ -> (mempty, mempty, mempty)
+  ma `mappend` mb = PosObject $ \ctx pt -> 
+                    let (a,o1,w1) = getPosObject ma ctx pt
+                        (b,o2,w2) = getPosObject mb ctx pt
+                    in (a `mappend` b, o1 `mappend` o2, w1 `mappend` w2)
 
--- | Version of 'runPosObject' that produces a 
--- 'LocImage' that returns a bounding box. 
--- 
--- The 'PosObject' is run with only rect-address as an explicit 
--- argument (start-point is implicit). The corresponding answer is 
--- an /arity one/ Graphic that needs drawing with the start-point.
+
+
+-- | Running an PosObject produces a LocImage.
 --
-runPosObject :: Fractional u 
-             => RectAddress -> PosObject u -> LocImage u (BoundingBox u)
-runPosObject addr (PosObject mf) = promoteLoc $ \pt ->
-   askDC >>= \ctx -> 
-   let (o1,df) = runQuery ctx mf
-       v1      = orientationStart addr o1
-       p1      = pt .+^ v1
-       bb      = orientationBounds o1 p1
-   in replaceAns bb $ primGraphic (df p1)
+runPosObject :: InterpretUnit u 
+             => PosObject u a -> RectAddress -> LocImage u a
+runPosObject ma addr = promoteLoc $ \ot -> 
+    askDC >>= \ctx -> 
+    let dot       = normalizeF (dc_font_size ctx) ot
+        (a,o1,ca) = getPosObject ma ctx dot
+        v1        = vtoOrigin addr o1
+    in replaceAns a $ primGraphic $ cpmove v1 ca
 
 
 
+-- | Run a PosObject producing a LocImage (BoundingBox u).
+--
+runPosObjectBBox :: InterpretUnit u 
+                 => PosObject u a -> RectAddress -> LocImage u (BoundingBox u)
+runPosObjectBBox ma addr = promoteLoc $ \pt -> 
+    askDC >>= \ctx -> 
+    let sz        = dc_font_size ctx 
+        dpt       = normalizeF sz pt
+        (_,o1,w1) = getPosObject ma ctx dpt
+        v1        = vtoOrigin addr o1
+        bb        = dinterpF sz $ orientationBounds o1 (dpt .+^ v1)
+    in replaceAns bb $ primGraphic $ cpmove v1 w1
+
+
+
+
+--------------------------------------------------------------------------------
+
+
 -- | 'makePosObject' : @ object_pos * loc_image -> PosObject @ 
 --
 -- Create a 'PosObject' from an 'Orientation' describing how it
@@ -154,69 +203,83 @@
 -- PosObject type is considered as a specialized object it does
 -- not have the range of functions of LocImage or LocThetaImage.
 -- 
-makePosObject :: Query u (Orientation u) -> LocGraphic u -> PosObject u
-makePosObject qortt gf = PosObject body
-  where
-    body = askDC >>= \ctx -> 
-           let v1   = runQuery ctx qortt
-               pf   = \pt -> getCP $ runLocImage pt ctx gf
-           in return (v1,pf)
-
-    getCP (PrimW ca _) = ca
+makePosObject :: InterpretUnit u
+              => Query u (Orientation u) -> LocImage u a -> PosObject u a
+makePosObject ma gf = PosObject $ \ctx pt -> 
+    let ort1  = runQuery ma ctx
+        dort1 = normalizeF (dc_font_size ctx) ort1
+        upt   = dinterpF (dc_font_size ctx) pt
+        (a,w) = runLocImage gf ctx upt
+    in (a,dort1,w)
 
 
 -- | 'emptyPosObject' : @ PosObject @
 --
 -- Build an empty 'PosGraphicObject'.
 --
-emptyPosObject :: InterpretUnit u => PosObject u
-emptyPosObject = PosObject $ pure (Orientation 0 0 0 0, const mempty)
+emptyPosObject :: (Monoid a, InterpretUnit u) => PosObject u a
+emptyPosObject = PosObject $ \_ _ -> (mempty, mempty, mempty) 
 
     
 
-
-
--- | Apply a DrawingContext update to a 'PosObject'.
 --
-localPosObject :: DrawingContextF -> PosObject u -> PosObject u
-localPosObject upd = PosObject . localize upd . getPosObject
+-- decorate  - oblivious to /answer/.
+-- elaborate - derives annotation from the /answer/ and makes a 
+--             cumulative graphic.
+--
 
 
-decoPosObject :: (Orientation u -> LocGraphic u) -> ZDeco 
-              -> PosObject u -> PosObject u
-decoPosObject fn zdec po = PosObject body
+elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)
+                   => ZDeco -> RectAddress -> LocGraphic u -> PosObject u a
+                   -> PosObject u a
+elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma
   where
-    body = askDC >>= \ctx -> 
-           let (ortt,ptf) = runQuery ctx (getPosObject po)
-               deco       = \pt -> getCP $ runLocImage pt ctx (fn ortt)
-               gf         = case zdec of
-                              ANTERIOR -> deco `mappend` ptf
-                              SUPERIOR -> ptf  `mappend` deco
-           in return (ortt, gf)
+    fn ortt = moveStart (vtoOrigin raddr ortt) gf
 
-    getCP (PrimW ca _) = ca
 
 
+decoratePosObject :: InterpretUnit u 
+                  => ZDeco -> (Orientation u -> LocGraphic u) -> PosObject u a
+                  -> PosObject u a
+decoratePosObject zdec fn ma = PosObject $ \ctx pt -> 
+    let (a,o1,w1) = getPosObject ma ctx pt
+        uortt     = dinterpF (dc_font_size ctx) o1
+        upt       = dinterpF (dc_font_size ctx) pt
+        (_,w2)    = runLocImage (fn uortt) ctx upt
+        wout      = case zdec of
+                         ANTERIOR -> w2 `mappend` w1
+                         SUPERIOR -> w1  `mappend` w2
+    in (a,o1,wout)
 
+
+
+
 -- | Extend the orientation.
 --
-extendPosObject :: Num u 
-                => u -> u -> u -> u -> PosObject u -> PosObject u
-extendPosObject x0 x1 y0 y1 po = PosObject body
-  where
-    body = askDC >>= \ctx -> 
-           let (o0,pf0) = runQuery ctx (getPosObject po)
-               ortt     = extendOrientation x0 x1 y0 y1 o0
-           in return (ortt,pf0)
-
+extendPosObject :: InterpretUnit u 
+                => u -> u -> u -> u -> PosObject u a -> PosObject u a
+extendPosObject x0 x1 y0 y1 ma = PosObject $ \ctx pt ->
+    let (a,o1,w1) = getPosObject ma ctx pt
+        sz        = dc_font_size ctx        
+        ux0       = normalize sz x0
+        ux1       = normalize sz x1
+        uy0       = normalize sz y0
+        uy1       = normalize sz y1
+        o2        = extendOrientation ux0 ux1 uy0 uy1 o1
+    in (a,o2,w1)
 
 
-mapOrientation :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u
-mapOrientation fn po = PosObject body
-  where
-    body = askDC >>= \ctx -> 
-           let (o0,pf0) = runQuery ctx (getPosObject po)
-           in return (fn o0,pf0)
+-- | Note - this is a bad API, it would be better to have padders
+-- and fillers and not expose the orientation directly.
+-- 
+mapOrientation :: InterpretUnit u
+               => (Orientation u -> Orientation u) 
+               -> PosObject u a -> PosObject u a
+mapOrientation fn mf = PosObject $ \ctx pt -> 
+    let (a,o1,w1) = getPosObject mf ctx pt
+        uort      = fn $ dinterpF (dc_font_size ctx) o1
+        o2        = normalizeF (dc_font_size ctx) uort
+    in (a,o2,w1)
 
 
 --------------------------------------------------------------------------------
@@ -228,14 +291,17 @@
 -- of the PosObject.
 --
 illustratePosObject :: InterpretUnit u 
-                   => PosObject u -> LocGraphic u
-illustratePosObject (PosObject mf)  = promoteLoc $ \pt ->   
-    zapQuery mf >>= \(ortt,ptf) -> 
-    decorate (primGraphic $ ptf pt) (illustrateOrientation ortt `at` pt)
+                   => PosObject u a -> LocGraphic u
+illustratePosObject mf  = promoteLoc $ \pt ->   
+    askDC >>= \ctx ->
+    let dpt       = normalizeF (dc_font_size ctx) pt 
+        (_,o1,w1) = getPosObject mf ctx dpt
+        uort      = dinterpF (dc_font_size ctx) o1
+    in adecorate (primGraphic w1) (illustrateOrientation uort `at` pt)
 
 
 illustrateOrientation :: InterpretUnit u 
-                    => Orientation u -> LocGraphic u
+                      => Orientation u -> LocGraphic u
 illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt -> 
     dinterpCtx 3 >>= \radius -> 
     let upd = localize (fill_colour blue . dotted_line)
@@ -247,92 +313,286 @@
     in mconcat [ bdr, hln, vln, dot ]
 
 
+
 --------------------------------------------------------------------------------
+-- Char PosObjects
+
+
+-- Note - because the TextHeight constructors are so long winded,
+-- using them directly makes for a bad API. Instead we have two 
+-- versions for each function.
+
+-- | Note - no margins are added to the containing rectangle.
+-- 
+-- To get a Char with margins, use 'posText' instead:
+--
+-- > posText ['1']
+-- 
+posChar             :: InterpretUnit u => Char -> PosGraphic u
+posChar             = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral
+
+posEscChar          :: InterpretUnit u => EscapedChar -> PosGraphic u
+posEscChar          = makeCharPO CAP_HEIGHT_PLUS_DESCENDER
+
+posCharUpright      :: InterpretUnit u => Char -> PosGraphic u
+posCharUpright      = makeCharPO JUST_CAP_HEIGHT . CharLiteral
+
+posEscCharUpright   :: InterpretUnit u => EscapedChar -> PosGraphic u
+posEscCharUpright   = makeCharPO JUST_CAP_HEIGHT
+
+
+-- | Primtive builder that does not add margins.
+--
+posCharPrim         :: InterpretUnit u 
+                    => Either Char EscapedChar -> PosGraphic u
+posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id
+
+
+makeCharPO :: InterpretUnit u 
+           => TextHeight -> EscapedChar -> PosGraphic u
+makeCharPO hspec esc = 
+    makePosObject (charOrientation hspec esc) 
+                  (dcEscapedlabel $ wrapEscChar esc)
+
+
+
+
+-- | Build the Orientation of an EscapedChar.
+-- 
+-- The locus of the Orientation is baseline left - margins are 
+-- added.
+--
+charOrientation :: (DrawingCtxM m, InterpretUnit u)
+                => TextHeight -> EscapedChar -> m (Orientation u)
+charOrientation hspec esc = 
+    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) 
+      <$> escCharVector esc <*> heightSpan hspec
+
+
+--------------------------------------------------------------------------------
+-- Text PosObjects
+
+
+
+posText     :: InterpretUnit u => String -> PosGraphic u
+posText     = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString
+
+posEscText  :: InterpretUnit u => EscapedText -> PosGraphic u
+posEscText  = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER
+
+
+posTextUpright      :: InterpretUnit u => String -> PosGraphic u
+posTextUpright      = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString
+
+posEscTextUpright   :: InterpretUnit u => EscapedText -> PosGraphic u
+posEscTextUpright   = addMargins . makeTextPO JUST_CAP_HEIGHT
+
+-- | Primtive builder that does not add margins.
+--
+posTextPrim         :: InterpretUnit u 
+                    => Either String EscapedText -> PosGraphic u
+posTextPrim = makeTextPO CAP_HEIGHT_PLUS_DESCENDER . either escapeString id
+
+
+multilinePosText :: (Fractional u, InterpretUnit u)
+                 => VAlign -> String -> PosGraphic u
+multilinePosText vspec xs = 
+    multilinePosEscText vspec $ map escapeString $ lines xs
+
+multilinePosEscText :: (Fractional u, InterpretUnit u)
+                    => VAlign -> [EscapedText] -> PosGraphic u
+multilinePosEscText vspec xs = 
+    addMargins $ PosObject $ \ctx pt -> 
+      let sep    = runQuery textlineSpace ctx
+      in getPosObject (body sep) ctx pt
+  where
+    body sp = alignColumnSep vspec sp $ 
+                map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs
+
+
+
+-- | Note - this does not add margins.
+--
+makeTextPO :: InterpretUnit u 
+           => TextHeight -> EscapedText -> PosGraphic u
+makeTextPO hspec esc = 
+    makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)
+
+
+addMargins :: InterpretUnit u => PosObject u a -> PosObject u a
+addMargins ma = 
+   textMargin >>= \(xsep,ysep) -> extendPosObject xsep xsep ysep ysep ma
+
+-- | Build the Orientation of a single line of EscapedText - 
+-- writing direction zero (left-to-right).
+-- 
+-- The locus of the Orientation is baseline left - margins are 
+-- added.
+--
+textOrientationZero :: (DrawingCtxM m, InterpretUnit u )
+                    => TextHeight -> EscapedText -> m (Orientation u)
+textOrientationZero hspec esc = 
+    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) 
+      <$> escTextVector esc <*> heightSpan hspec
+
+
+--------------------------------------------------------------------------------
+-- Rotated text
+
+-- | Note - for single line text.
+--
+rposText        :: (Real u, Floating u, InterpretUnit u) 
+                => Radian -> String -> PosGraphic u
+rposText ang    = addMargins . makeRotatedPO ang . escapeString
+
+-- | Note - for single line text.
+--
+rposEscText     :: (Real u, Floating u, InterpretUnit u) 
+                => Radian -> EscapedText -> PosGraphic u
+rposEscText ang = addMargins . makeRotatedPO ang
+
+
+makeRotatedPO :: (Real u, Floating u, InterpretUnit u) 
+              => Radian -> EscapedText -> PosGraphic u
+makeRotatedPO ang esc = makePosObject qry body
+  where
+    qry  = rotateOrientation ang <$> 
+             textOrientationZero CAP_HEIGHT_PLUS_DESCENDER esc
+
+    body = incline (dcREscapedlabel esc) ang
+
+
+--------------------------------------------------------------------------------
+-- Kerned text
+
+
+posHKernText :: InterpretUnit u
+            => [KernChar u] -> PosGraphic u
+posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)
+
+-- | The query should retrieve the width of one char.
+--
+monospaceText :: InterpretUnit u 
+              => Query u u -> String -> PosGraphic u
+monospaceText qry = monospaceEscText qry . escapeString
+
+
+-- | The query should retrieve the width of one char.
+--
+monospaceEscText :: InterpretUnit u 
+                 => Query u u -> EscapedText -> PosGraphic u
+monospaceEscText qry esc = PosObject $ \ctx pt ->
+    let upt    = dinterpF (dc_font_size ctx) pt
+        uw     = runQuery qry ctx
+        ks     = monos uw $ destrEscapedText id esc
+        ortt   = runQuery (hkernOrientationZero  ks) ctx
+        dort   = normalizeF (dc_font_size ctx) ortt
+        (_,w1) = runLocImage (hkernLine ks) ctx upt
+    in (UNil, dort, w1)
+
+
+
+
+
+monos :: Num u => u -> [EscapedChar] -> [KernChar u]
+monos w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs
+monos _  []     = []
+
+
+
+-- | Note - always CAP_HEIGHT_PLUS_DESCENDER for this one.
+--
+hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )
+                     => [KernChar u] -> m (Orientation u)
+hkernOrientationZero xs = 
+    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) 
+      <$> hkernVector xs <*> heightSpan CAP_HEIGHT_PLUS_DESCENDER
+
+ 
+
+--------------------------------------------------------------------------------
 -- Combining PosObject
 
 
-instance (Fractional u, Ord u, InterpretUnit u) => ZConcat (PosObject u) where
+instance (Monoid a, InterpretUnit u) => ZConcat (PosObject u a) where
   superior = mappend
   anterior = flip mappend
 
 
-instance (Num u, Ord u) => Concat (PosObject u) where
+instance Monoid a => Concat (PosObject u a) where
   hconcat = genMoveAlign spinemoveH spineRight
   vconcat = genMoveAlign spinemoveV spineBelow
 
-instance (Num u, Ord u) => CatSpace (PosObject u) where
+instance (Monoid a, InterpretUnit u) => CatSpace (PosObject u a) where
   hspace = genMoveSepH spinemoveH spineRight
   vspace = genMoveSepV spinemoveV spineBelow
 
 
 
-instance (Fractional u, Ord u) => Align (PosObject u) where
-  halign HTop    = genMoveAlign binmoveHTop    halignTopO
-  halign HCenter = genMoveAlign binmoveHCenter halignCenterO
-  halign HBottom = genMoveAlign binmoveHBottom halignBottomO
+instance Monoid a => Align (PosObject u a) where
+  halign HALIGN_TOP    = genMoveAlign binmoveHTop    halignTopO
+  halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO
+  halign HALIGN_BASE   = genMoveAlign binmoveHBottom halignBottomO
 
-  valign VLeft   = genMoveAlign binmoveVLeft   valignLeftO
-  valign VCenter = genMoveAlign binmoveVCenter valignCenterO
-  valign VRight  = genMoveAlign binmoveVRight  valignRightO
+  valign VALIGN_LEFT   = genMoveAlign binmoveVLeft   valignLeftO
+  valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO
+  valign VALIGN_RIGHT  = genMoveAlign binmoveVRight  valignRightO
 
 
 
-genMoveAlign :: (Num u)   
-             => (Orientation u -> Orientation u -> Vec2 u) 
-             -> (Orientation u -> Orientation u -> Orientation u) 
-             -> PosObject u -> PosObject u -> PosObject u
-genMoveAlign mkV mkO po0 po1 = PosObject body
-  where
-   body = askDC >>= \ctx -> 
-          let (ortt0,pf0) = runQuery ctx (getPosObject po0)
-              (ortt1,pf1) = runQuery ctx (getPosObject po1)
-              v1          = mkV ortt0 ortt1
-              ortt        = mkO ortt0 ortt1
-              pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)
-          in return (ortt,pf)
+genMoveAlign :: Monoid a
+             => (Orientation Double -> Orientation Double -> Vec2 Double) 
+             -> (Orientation Double -> Orientation Double -> Orientation Double) 
+             -> PosObject u a -> PosObject u a -> PosObject u a
+genMoveAlign mkV mkO ma mb = PosObject $ \ctx pt -> 
+    let (a,o1,w1) = getPosObject ma ctx pt
+        (b,o2,w2) = getPosObject mb ctx pt
+        v1        = mkV o1 o2
+        ortt      = mkO o1 o2
+        w2'       = cpmove v1 w2 
+    in (a `mappend` b, ortt, w1 `mappend` w2')
 
 
 --------------------------------------------------------------------------------
 -- Sep
 
-instance (Fractional u, Ord u) => AlignSpace (PosObject u) where
-  halignSpace HTop    = genMoveSepH binmoveHTop    halignTopO
-  halignSpace HCenter = genMoveSepH binmoveHCenter halignCenterO
-  halignSpace HBottom = genMoveSepH binmoveHBottom halignBottomO
+instance (Monoid a, InterpretUnit u) => AlignSpace (PosObject u a) where
+  halignSpace HALIGN_TOP    = genMoveSepH binmoveHTop    halignTopO
+  halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO
+  halignSpace HALIGN_BASE   = genMoveSepH binmoveHBottom halignBottomO
 
-  valignSpace VLeft   = genMoveSepV binmoveVLeft   valignLeftO
-  valignSpace VCenter = genMoveSepV binmoveVCenter valignCenterO
-  valignSpace VRight  = genMoveSepV binmoveVRight  valignRightO
+  valignSpace VALIGN_LEFT   = genMoveSepV binmoveVLeft   valignLeftO
+  valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO
+  valignSpace VALIGN_RIGHT  = genMoveSepV binmoveVRight  valignRightO
 
 
-genMoveSepH :: (Num u)   
-            => (Orientation u -> Orientation u -> Vec2 u) 
-            -> (Orientation u -> Orientation u -> Orientation u) 
+genMoveSepH :: (Monoid a, InterpretUnit u) 
+            => (Orientation Double -> Orientation Double -> Vec2 Double) 
+            -> (Orientation Double -> Orientation Double -> Orientation Double) 
             -> u
-            -> PosObject u -> PosObject u -> PosObject u
-genMoveSepH mkV mkO sep po0 po1  = PosObject body
-  where
-    body = askDC >>= \ctx -> 
-           let (ortt0,pf0) = runQuery ctx (getPosObject po0)
-               (ortt1,pf1) = runQuery ctx (getPosObject po1)
-               v1          = hvec sep ^+^ mkV ortt0 ortt1
-               ortt        = extendORight sep $ mkO ortt0 ortt1
-               pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)
-           in return (ortt,pf)
+            -> PosObject u a -> PosObject u a -> PosObject u a
+genMoveSepH mkV mkO sep ma mb  = PosObject $ \ctx pt -> 
+    let (a,o1,w1) = getPosObject ma ctx pt
+        (b,o2,w2) = getPosObject mb ctx pt
+        dsep      = normalize (dc_font_size ctx) sep
+        v1        = hvec dsep ^+^ mkV o1 o2
+        ortt      = extendORight dsep $ mkO o1 o2
+        w2'       = cpmove v1 w2
+    in (a `mappend` b, ortt, w1 `mappend` w2')
 
 
-genMoveSepV :: (Num u)   
-            => (Orientation u -> Orientation u -> Vec2 u) 
-            -> (Orientation u -> Orientation u -> Orientation u) 
+
+genMoveSepV :: (Monoid a, InterpretUnit u)
+            => (Orientation Double -> Orientation Double -> Vec2 Double) 
+            -> (Orientation Double -> Orientation Double -> Orientation Double) 
             -> u
-            -> PosObject u -> PosObject u -> PosObject u
-genMoveSepV mkV mkO sep po0 po1 = PosObject body
-  where
-    body = askDC >>= \ctx -> 
-           let (ortt0,pf0) = runQuery ctx (getPosObject po0)
-               (ortt1,pf1) = runQuery ctx (getPosObject po1)
-               v1          = vvec (-sep) ^+^ mkV ortt0 ortt1
-               ortt        = extendODown sep $ mkO ortt0 ortt1
-               pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)
-           in return (ortt,pf)
+            -> PosObject u a -> PosObject u a -> PosObject u a
+genMoveSepV mkV mkO sep ma mb = PosObject $ \ctx pt -> 
+    let (a,o1,w1) = getPosObject ma ctx pt
+        (b,o2,w2) = getPosObject mb ctx pt
+        dsep      = normalize (dc_font_size ctx) sep
+        v1        = vvec (-dsep) ^+^ mkV o1 o2
+        ortt      = extendODown dsep $ mkO o1 o2
+        w2'       = cpmove v1 w2
+    in (a `mappend` b, ortt, w1 `mappend` w2')
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs
--- a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs
@@ -1,6 +1,4 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -22,26 +20,24 @@
 module Wumpus.Basic.Kernel.Objects.TraceDrawing
   (
 
-  -- * Collect primitives (writer monad) 
-    TraceM(..)
-
+  -- * Collect primitives (writer-like monad) 
+    GenTraceDrawing
   , TraceDrawing
   , DTraceDrawing
-  , TraceDrawingT
-  , DTraceDrawingT
 
   , runTraceDrawing
   , execTraceDrawing
   , evalTraceDrawing
-  , runTraceDrawingT
-  , execTraceDrawingT
-  , evalTraceDrawingT
 
+  , runGenTraceDrawing
+
+
   , liftToPictureU
   , liftToPictureMb
   , mbPictureU
  
-
+  , trace
+  , fontDelta
   , evalQuery
 
   , draw
@@ -64,6 +60,7 @@
 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
@@ -81,13 +78,6 @@
 
 
 
--- | Collect elementary graphics as part of a larger drawing.
---
--- TraceM works much like a writer monad.
---
-class TraceM (m :: * -> *) where
-  trace     :: MonUnit (m ()) ~ u => HPrim u -> m ()
-  fontDelta :: m a -> m a
 
 -- Note - TraceDrawing run \once\ - it is supplied with the starting
 -- environment (DrawingContext) and returns a Picture.
@@ -98,142 +88,76 @@
 --
 
 
-newtype TraceDrawing u a   = TraceDrawing { 
-          getTraceDrawing :: DrawingContext -> (a, HPrim u) }
+newtype GenTraceDrawing st u a   = GenTraceDrawing { 
+          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }
 
-newtype TraceDrawingT u m a = TraceDrawingT { 
-          getTraceDrawingT :: DrawingContext -> m (a, HPrim u) }
 
-type instance MonUnit (TraceDrawing u a) = u
-type instance MonUnit (TraceDrawingT u m a) = 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
-type DTraceDrawingT m a = TraceDrawingT Double m a
 
 
-
 -- Functor
 
-instance Functor (TraceDrawing u) where
-  fmap f ma = TraceDrawing $ \ctx -> 
-                let (a,w) = getTraceDrawing ma ctx in (f a,w)
-
-
-instance Monad m => Functor (TraceDrawingT u m) where
-  fmap f ma = TraceDrawingT $ \ctx -> 
-                getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w)
-
+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 (TraceDrawing u) where
-  pure a    = TraceDrawing $ \_   -> (a, mempty)
-  mf <*> ma = TraceDrawing $ \ctx -> 
-                let (f,w1) = getTraceDrawing mf ctx
-                    (a,w2) = getTraceDrawing ma ctx
-                in (f a, w1 `mappend` w2)
+instance 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)
 
 
-instance Monad m => Applicative (TraceDrawingT u m) where
-  pure a    = TraceDrawingT $ \_   -> return (a,mempty)
-  mf <*> ma = TraceDrawingT $ \ctx -> 
-                getTraceDrawingT mf ctx >>= \(f,w1) ->
-                getTraceDrawingT ma ctx >>= \(a,w2) ->
-                return (f a, w1 `mappend` w2)
-
 -- Monad
 
-instance Monad (TraceDrawing u) where
-  return a  = TraceDrawing $ \_   -> (a, mempty)
-  ma >>= k  = TraceDrawing $ \ctx -> 
-                let (a,w1) = getTraceDrawing ma ctx
-                    (b,w2) = (getTraceDrawing . k) a ctx
-                in (b,w1 `mappend` w2)
+instance Monad (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)
                                
 
-
-
-instance Monad m => Monad (TraceDrawingT u m) where
-  return a  = TraceDrawingT $ \_   -> return (a, mempty)
-  ma >>= k  = TraceDrawingT $ \ctx -> 
-                getTraceDrawingT ma ctx      >>= \(a,w1) ->
-                (getTraceDrawingT . k) a ctx >>= \(b,w2) -> 
-                return (b, w1 `mappend` w2)
-                                 
-
-
-
--- TraceM 
---
--- Note -  @ state `mappend` a @ means the first expression in a 
--- monadic drawing is the first element in the output file. It is
--- also \*\* at the back \*\* in the the Z-Order.
---
--- Some control over the Z-Order, possibly by adding /layers/ to 
--- the drawing model would be valuable. 
--- 
-
-instance TraceM (TraceDrawing u) where
-  trace a = TraceDrawing $ \_ -> ((), a)
-  fontDelta = fontDeltaMon
-
-fontDeltaMon :: TraceDrawing u a -> TraceDrawing u a
-fontDeltaMon mf = TraceDrawing $ \ctx -> 
-    let (_,font_attrs) = primAnswer $ runImage ctx textAttr
-        (a,hf)         = runTraceDrawing ctx mf
-        prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList hf
-    in (a, singleH $ prim1 $ prim)
-
-instance Monad m => TraceM (TraceDrawingT u m) where
-  trace a = TraceDrawingT $ \_ -> return ((), a)
-  fontDelta = fontDeltaTrans
-
-fontDeltaTrans :: Monad m => TraceDrawingT u m a -> TraceDrawingT u m a
-fontDeltaTrans mf = TraceDrawingT $ \ctx -> 
-    let (_,font_props) = primAnswer $ runImage ctx textAttr
-    in runTraceDrawingT ctx mf >>= \(a,hf) ->
-       let prim  = fontDeltaContext font_props $ primGroup $ hprimToList hf
-       in return (a, singleH $ prim1 $ prim)
-
-
-
 -- DrawingCtxM
 
-instance DrawingCtxM (TraceDrawing u) where
-  askDC           = TraceDrawing $ \ctx -> (ctx, mempty)
-  asksDC f        = TraceDrawing $ \ctx -> (f ctx, mempty)
-  localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx)
+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 Monad m => DrawingCtxM (TraceDrawingT u m) where
-  askDC           = TraceDrawingT $ \ctx -> return (ctx, mempty)
-  asksDC f        = TraceDrawingT $ \ctx -> return (f ctx, mempty)
-  localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx)
+instance UserStateM (GenTraceDrawing st u) where
+  getState        = GenTraceDrawing $ \_ s -> (s, s, mempty)
+  setState s      = GenTraceDrawing $ \_ _ -> ((), s, mempty)
+  updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)
+ 
 
 
 
--- Note - the result type of runTraceDrawing and friends needs more 
--- thought and may change. 
---
--- Possibly a wrapped HPrim that only supports concat and safe
--- extraction is best.
---
--- Or it could generate a picture, but then separate drawings
--- need the picture combinators to put them together. 
--- 
+runTraceDrawing :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)
+runTraceDrawing ma ctx = post $ getGenTraceDrawing ma ctx ()
+  where
+    post (a,_,w1) = (a,w1)
 
 
-runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)
-runTraceDrawing ctx ma = getTraceDrawing ma ctx
 
 -- | Run the drawing returning only the output it produces, drop
 -- any answer from the monadic computation.
 --
-execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u
-execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma
+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.
@@ -242,26 +166,18 @@
 -- opposite behaviour (return the drawing, ignore than the 
 -- answer).
 -- 
-evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a
-evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma
+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
 
-runTraceDrawingT :: Monad m 
-                 => DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u) 
-runTraceDrawingT ctx ma = getTraceDrawingT ma ctx
 
-execTraceDrawingT :: Monad m 
-                  => DrawingContext -> TraceDrawingT u m a -> m (HPrim u)
-execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma
 
 
-evalTraceDrawingT :: Monad m 
-                  => DrawingContext -> TraceDrawingT u m a -> m a
-evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma
 
-
-
 -- | /Unsafe/ promotion of @HPrim@ to @Picture@.
 --
 -- If the HPrim is empty, a run-time error is thrown.
@@ -306,8 +222,35 @@
 --------------------------------------------------------------------------------
 
 
+
+-- 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 ctx df
+evalQuery df = askDC >>= \ctx -> return $ runQuery df ctx
 
 
 
@@ -318,11 +261,10 @@
 -- Commonly, it is used to draw 'Graphic' objects which 
 -- have no /answer/.
 -- 
-draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-     => Image u a -> m ()
+draw :: Image u a -> GenTraceDrawing st u ()
 draw gf = askDC >>= \ctx -> 
-          let (PrimW o _) = runImage ctx gf
-          in trace (singleH o) >> return ()
+          let (_,w) = runImage gf ctx 
+          in trace (singleH w) >> return ()
 
 
 
@@ -333,11 +275,10 @@
 -- The graphic representation of the Image is drawn in the Trace 
 -- monad, and the result is returned.
 -- 
-drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-      => Image u a -> m a
+drawi :: Image u a -> GenTraceDrawing st u a
 drawi gf = askDC >>= \ctx -> 
-           let (PrimW o a) = runImage ctx gf 
-           in trace (singleH o) >> return a
+           let (a,w) = runImage gf ctx
+           in trace (singleH w) >> return a
             
 
 
@@ -348,8 +289,8 @@
 -- Commonly, it is used to draw 'LocGraphic' objects which 
 -- have no /answer/.
 -- 
-drawl :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-      => Anchor u -> LocImage u a -> m ()
+drawl :: InterpretUnit u
+      => Anchor u -> LocImage u a -> GenTraceDrawing st u ()
 drawl ancr img = drawli ancr img >> return ()
 
 
@@ -360,11 +301,11 @@
 -- The graphic representation of the Image is drawn in the Trace 
 -- monad, and the result is returned.
 -- 
-drawli :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-       => Anchor u -> LocImage u a -> m a
+drawli :: InterpretUnit u
+       => Anchor u -> LocImage u a -> GenTraceDrawing st u a
 drawli pt gf = askDC >>= \ctx -> 
-               let (PrimW o a) = runLocImage pt ctx gf
-               in trace (singleH o) >> return a
+               let (a,w) = runLocImage gf ctx pt
+               in trace (singleH w) >> return a
 
 
 -- Design note - having @drawlti@ for LocThetaImage does not seem 
@@ -385,8 +326,8 @@
 -- Commonly, it is used to draw 'ConnectorGraphic' objects which 
 -- have no /answer/.
 -- 
-drawc :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-      => Anchor u -> Anchor u -> ConnectorImage u a -> m ()
+drawc :: InterpretUnit u
+      => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()
 drawc an0 an1 img = drawci an0 an1 img >> return () 
 
 
@@ -396,8 +337,8 @@
 -- The graphic representation of the Image is drawn in the Trace 
 -- monad, and the result is returned.
 -- 
-drawci :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-       => Anchor u -> Anchor u -> ConnectorImage u a -> m a
+drawci :: InterpretUnit u 
+       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a
 drawci p0 p1 img = drawi (connect p0 p1 img)
 
 
@@ -415,8 +356,8 @@
 -- Commonly, it is used to draw 'LocGraphic' objects which 
 -- have no /answer/.
 -- 
-node :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-     => (Int,Int) -> LocImage u a -> m ()
+node :: ( Fractional u, InterpretUnit u)
+     => (Int,Int) -> LocImage u a -> GenTraceDrawing st u ()
 node coord gf = nodei coord gf >> return ()
 
 
@@ -424,12 +365,12 @@
 -- actual position is scaled according to the 
 -- @snap_grid_factors@ in the /drawing context/.
 -- 
-nodei :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
-      => (Int,Int) -> LocImage u a -> m a
+nodei :: (Fractional u, InterpretUnit u) 
+      => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a
 nodei coord gf = askDC >>= \ctx -> 
                  position coord >>= \pt ->
-                 let (PrimW o a) = runLocImage pt ctx gf
-                 in trace (singleH o) >> return a
+                 let (a,w) = runLocImage gf ctx pt
+                 in trace (singleH w) >> return a
  
 
 
@@ -445,12 +386,12 @@
 -- Commonly, it is used to draw 'LocGraphic' objects which 
 -- have no /answer/.
 -- 
-drawrc :: ( Real u, Floating u, DrawingCtxM m, TraceM m 
-          , CenterAnchor a, RadialAnchor a
-          , CenterAnchor b, RadialAnchor b
-          , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b 
+drawrc :: ( Real u, Floating u, InterpretUnit u
+          , CenterAnchor a1, RadialAnchor a1
+          , CenterAnchor a2, RadialAnchor a2
+          , u ~ DUnit a1, u ~ DUnit a2
           ) 
-       => a -> b -> ConnectorImage u ans -> m ()
+       => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u ()
 drawrc a b gf = drawrci a b gf >> return ()
 
 
@@ -460,12 +401,11 @@
 -- are the radial points on the objects borders that cross the 
 -- projected line.
 -- 
-drawrci :: ( Real u, Floating u, DrawingCtxM m, TraceM m
-           , CenterAnchor a, RadialAnchor  a
-           , CenterAnchor b, RadialAnchor  b
-           , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b
+drawrci :: ( Real u, Floating u, InterpretUnit u
+           , CenterAnchor a1, RadialAnchor  a1
+           , CenterAnchor a2, RadialAnchor  a2
+           , u ~ DUnit a1, u ~ DUnit a2
            ) 
-        => a -> b -> ConnectorImage u ans -> m ans
+        => 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/System/FontLoader/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs
--- a/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs
+++ b/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs
@@ -68,11 +68,13 @@
     info <- (versionNumber    *> globalInfo) 
     cms  <- (startCharMetrics *> many pgm)
     return $ AfmFile 
-              { afm_encoding        = getEncodingScheme info
-              , afm_letter_bbox     = getFontBBox       info
-              , afm_cap_height      = getCapHeight      info
-              , afm_descender       = getDescender      info
-              , afm_glyph_metrics   = cms
+              { afm_encoding            = getEncodingScheme info
+              , afm_letter_bbox         = getFontBBox       info
+              , afm_cap_height          = getCapHeight      info
+              , afm_descender           = getDescender      info
+              , afm_underline_position  = getUlPosition     info
+              , afm_underline_thickness = getUlThickness    info
+              , afm_glyph_metrics       = cms
               }
 
 globalInfo :: CharParser GlobalInfo
@@ -105,6 +107,15 @@
 
 getDescender           :: GlobalInfo -> Maybe AfmUnit
 getDescender           = runQuery "Descender" number
+
+
+-- | Expected to be negative...
+--
+getUlPosition          :: GlobalInfo -> Maybe AfmUnit
+getUlPosition          = runQuery "UnderlinePosition" number
+
+getUlThickness         :: GlobalInfo -> Maybe AfmUnit
+getUlThickness         = runQuery "UnderlineThickness" number
 
 
 charBBox :: CharParser AfmBoundingBox
diff --git a/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs b/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs
--- a/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs
+++ b/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs
@@ -102,10 +102,12 @@
 --
 afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit
 afm_mono_defaults_4_1 = 
-    MonospaceDefaults { default_letter_bbox  = bbox
-                      , default_cap_height   = 562
-                      , default_descender    = (-157)
-                      , default_char_width   = V2 600 0
+    MonospaceDefaults { default_letter_bbox         = bbox
+                      , default_cap_height          = 562
+                      , default_descender           = (-157)
+                      , default_underline_position  = (-100)
+                      , default_underline_thickness = 50 
+                      , default_char_width          = V2 600 0
                       }
   where
     bbox = BBox (P2 (-23) (-250)) (P2 715 805)
diff --git a/src/Wumpus/Basic/System/FontLoader/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Datatypes.hs
--- a/src/Wumpus/Basic/System/FontLoader/Datatypes.hs
+++ b/src/Wumpus/Basic/System/FontLoader/Datatypes.hs
@@ -81,11 +81,13 @@
 -- Encoding Scheme is optional in AFM files.
 --
 data AfmFile = AfmFile 
-      { afm_encoding        :: Maybe String
-      , afm_letter_bbox     :: Maybe AfmBoundingBox
-      , afm_cap_height      :: Maybe AfmUnit
-      , afm_descender       :: Maybe AfmUnit
-      , afm_glyph_metrics   :: [AfmGlyphMetrics]
+      { afm_encoding                :: Maybe String
+      , afm_letter_bbox             :: Maybe AfmBoundingBox
+      , afm_cap_height              :: Maybe AfmUnit
+      , afm_descender               :: Maybe AfmUnit
+      , afm_underline_position      :: Maybe AfmUnit
+      , afm_underline_thickness     :: Maybe AfmUnit
+      , afm_glyph_metrics           :: [AfmGlyphMetrics]
       }
   deriving (Show) 
   
@@ -109,10 +111,12 @@
 -- in the distributed font files.
 --
 data MonospaceDefaults cu = MonospaceDefaults 
-      { default_letter_bbox  :: BoundingBox cu
-      , default_cap_height   :: cu
-      , default_descender    :: cu
-      , default_char_width   :: Vec2 cu
+      { default_letter_bbox         :: BoundingBox cu
+      , default_cap_height          :: cu
+      , default_descender           :: cu
+      , default_underline_position  :: cu
+      , default_underline_thickness :: cu
+      , default_char_width          :: Vec2 cu
       }
   deriving (Eq,Show)
 
@@ -133,6 +137,8 @@
        , fp_adv_vecs            :: IM.IntMap (Vec2 cu)
        , fp_cap_height          :: cu
        , fp_descender           :: cu
+       , fp_underline_position  :: cu
+       , fp_underline_thickness :: cu
        }
 
 
@@ -148,6 +154,8 @@
             maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font)
       , get_cap_height    = \sz -> fn sz (fp_cap_height font)
       , get_descender     = \sz -> fn sz (fp_descender font)
+      , get_underline_position  = \sz -> fn sz (fp_underline_position font)
+      , get_underline_thickness = \sz -> fn sz (fp_underline_thickness font)
       }
   where
     defaultAV sz            = V2 (fn sz vx) (fn sz vy) 
diff --git a/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs
--- a/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs
+++ b/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs
@@ -149,15 +149,19 @@
                   -> AfmFile 
                   -> FontLoadIO (FontProps AfmUnit)
 buildAfmFontProps defaults afm = do 
-    cap_height  <- extractCapHeight defaults afm
-    desc_depth  <- extractDescender defaults afm
-    bbox        <- extractFontBBox  defaults afm 
+    cap_height    <- extractCapHeight   defaults afm
+    desc_depth    <- extractDescender   defaults afm
+    ul_position   <- extractUlPosition  defaults afm
+    ul_thickness  <- extractUlThickness defaults afm
+    bbox          <- extractFontBBox    defaults afm 
     return $ FontProps 
-               { fp_bounding_box    = bbox
-               , fp_default_adv_vec = default_char_width defaults
-               , fp_adv_vecs        = char_widths
-               , fp_cap_height      = cap_height
-               , fp_descender       = desc_depth
+               { fp_bounding_box        = bbox
+               , fp_default_adv_vec     = default_char_width defaults
+               , fp_adv_vecs            = char_widths
+               , fp_cap_height          = cap_height
+               , fp_descender           = desc_depth
+               , fp_underline_position  = ul_position
+               , fp_underline_thickness = ul_thickness
                }  
   where
     char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm
@@ -180,6 +184,20 @@
   where
     errk = tellLoadMsg "WARNING - Could not extract Descender" >> 
            return (default_descender defaults)
+
+extractUlPosition :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
+extractUlPosition defaults afm = 
+    maybe errk return $ afm_underline_position afm
+  where
+    errk = tellLoadMsg "WARNING - Could not extract UnderlinePosition" >> 
+           return (default_underline_position defaults)
+
+extractUlThickness :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
+extractUlThickness defaults afm = 
+    maybe errk return $ afm_underline_thickness afm
+  where
+    errk = tellLoadMsg "WARNING - Could not extract UnderlineThickness" >> 
+           return (default_underline_thickness defaults)
 
 
 extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile 
diff --git a/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs b/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs
--- a/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs
+++ b/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs
@@ -99,10 +99,12 @@
 --
 ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit
 ghostscript_mono_defaults_8_54 = 
-    MonospaceDefaults { default_letter_bbox  = bbox
-                      , default_cap_height   = 563
-                      , default_descender    = (-186)
-                      , default_char_width   = V2 600 0
+    MonospaceDefaults { default_letter_bbox         = bbox
+                      , default_cap_height          = 563
+                      , default_descender           = (-186)
+                      , default_underline_position  = (-100)
+                      , default_underline_thickness = 50 
+                      , default_char_width          = V2 600 0
                       }
   where
     bbox = BBox (P2 (-46) (-273)) (P2 650 820)
diff --git a/src/Wumpus/Basic/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,18,0)
+-- > (0,20,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,18,0)
+wumpus_basic_version = (0,20,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.18.0
+version:          0.20.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -30,22 +30,33 @@
   .
   Changelog:
   .
-  v0.17.0 to v0.18.0:
-  . 
-  * Major change - removed @ContextFun@ from @Kernel.Base@. Now 
-    the drawing objects (Image, LocImage, Connector...) are 
-    newtype wrapped Reader-Writer monads rather than aliases to 
-    one of the arity family of ContextFuns. Being newtypes gives
-    a lot better opportunities for overloading.
+  v0.19.0 to v0.20.0:
   .
-  * Changed Displacement API - it is smaller, and the function 
-    naming is more uniform.
+  * Added text advance-vector calculations to @QueryDC@ - 
+    previously they were in Wumpus-Drawing.
   . 
-  * Changed @DrawingPimitives@ to use @DrawStyle@.
+  * Changed argument order of @run@ functions to follow the usual
+    style - monadic action first and then dependent parameters 
+    (initial state, reader environment etc.).
   . 
-  * Moved vertices generating functions from @Geometry.Path@ to 
-    @Geometry.Vertices@.
+  * 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.
+  .
 build-type:         Simple
 stability:          highly unstable
 cabal-version:      >= 1.2
@@ -83,6 +94,7 @@
     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.Objects.AdvObject,
     Wumpus.Basic.Kernel.Objects.Anchors,