diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,81 @@
+
+0.16.0 to 0.17.0:
+
+  * Changed representation of ContextFuns - context funs are no 
+    longer an arity family of newtypes. The new representation 
+    is simpler, but some of the opportunities for overloading 
+    have been lost.
+
+  * Substantial round of renaming for the @DrawingContext@ types
+    an query and update functions.
+
+  * Re-worked the font metrics and font loader modules. The new
+    names should be more systematic. Removed the need for the 
+    GhostScript font modules to match PostScript names to 
+    GhostScript font files.    
+
+  * Superceded the PointSupplyM class by adding snapping grid 
+    scaling to the DrawingContext. 
+ 
+  * Removed @ScalingContext@ module.
+
+  * Made text colour a distinct property in the DrawingContext. 
+    Text is now drawn with the text colour rather than the stroke 
+    colour.
+
+  * Added FontLoadLog to the DrawingContext - this allows access 
+    to the errors recorded during font loading.
+
+0.15.0 to 0.16.0:
+
+  * Moved the Geometry modules from Wumpus-Drawing into 
+    Wumpus-Basic.
+
+  * Re-worked the @CtxPicture@ API, although the current naming 
+    scheme is not satisfactory.
+
+  * Added extra Anchor classes.
+
+  * Added @PosImage@ object - this is a rectangle-framed object 
+    that can be drawn from any of its corners or its center. 
+
+  * Added @CF3@, an arity three /ContextFunction/.
+
+  * Added @Displacement@ module. This defines the @PointDisplace@
+    type and provides a library of @PointDisplace@ functions.
+    Note - some of the new functions have taken names previously 
+    used for anchor projection functions (@northwards@, 
+    @southwards@, etc.), anchor projections are now build with the 
+    function @projectAnchor@.
+
+  * Added the property @descender@ to the font metrics.
+
+  * Split drawing primitives from type in @Objects.Graphic@, 
+    drawing primitives are now in the module 
+    @Objects.DrawingPrimitives@.
+
+0.14.0 to 0.15.0:
+ 
+  * Split previous @Wumpus-Basic@ package into two packages:
+    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move 
+    to separate the developed (although not yet polished) @Kernel@ 
+    and @FontLoader@ code from the prototypical @Drawing@ code.
+
+  * Renamed the @Drawing@ object to @CtxPicture@. Although 
+    @CtxPicture@ is a less pleasant name, it should be less 
+    confusing. A @CtxPicture@ is the essentially the @Picture@ 
+    type from Wumpus-Core with an implicit context - 
+    @ContextPicture@ is simply too long and @CtxPicture@ is 
+    almost jibberish but the previous unrelated name @Drawing@ 
+    was not helpful.
+
+  * @Kernel.Base.ScalingContext@ has been simplified. 
+    ScalingContexts are no longer manipulated via a custom Reader
+    monad or transformer as the type signatures were too unwieldy.
+
+  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing 
+    can now calculate more appealing bounding boxes for text.
+
 0.13.0 to 0.14.0:
 
   * Re-organised module hierarchy, Wumpus-Basic is now divided 
diff --git a/demo/AltUnits.hs b/demo/AltUnits.hs
--- a/demo/AltUnits.hs
+++ b/demo/AltUnits.hs
@@ -7,6 +7,7 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Data.Monoid
 import System.Directory
 
 main :: IO ()
@@ -36,30 +37,30 @@
 combined :: TraceDrawing Double ()
 combined = do 
     draw $ dblLocGraphic `at` P2 12 108
-    drawl (P2 12 72) $ uconvLocImageF emLocGraphic
-    draw $ uconvImageF $ emLocGraphic `at` P2 1 3
-    drawl (P2 12 0) $ uconvLocImageF $ pushR1 (hyperlink haskell_org) enLocGraphic
+    drawl (P2 12 72) $ uconvF emLocGraphic
+    draw $ uconvF $ emLocGraphic `at` P2 1 3
+    drawl (P2 12 0) $ uconvF $ hyperlink haskell_org enLocGraphic
 
 dblLocGraphic :: LocGraphic Double
-dblLocGraphic = rect1 `oplus` rect2  
+dblLocGraphic = rect1 `mappend` rect2  
   where
-    rect1 = borderedRectangle 36 24 
-    rect2 = moveStart (displaceH 36) $ borderedRectangle 60 24 
+    rect1 = dcRectangle FILL_STROKE 36 24 
+    rect2 = moveStart (hvec 36) $ dcRectangle FILL_STROKE 60 24 
 
 
 
 emLocGraphic :: LocGraphic Em
-emLocGraphic = localize swap_colours $  rect1 `oplus` rect2  
+emLocGraphic = localize swap_colours $  rect1 `mappend` rect2  
   where
-    rect1 = borderedRectangle 3 2 
-    rect2 = moveStart (displaceH 3) $ borderedRectangle 5 2 
+    rect1 = dcRectangle FILL_STROKE 3 2 
+    rect2 = moveStart (hvec 3) $ dcRectangle FILL_STROKE 5 2 
 
 
 enLocGraphic :: LocGraphic En
-enLocGraphic = localize (fill_colour lemon_chiffon) $  rect1 `oplus` rect2  
+enLocGraphic = localize (fill_colour lemon_chiffon) $ rect1 `mappend` rect2  
   where
-    rect1 = borderedRectangle 6 4
-    rect2 = moveStart (displaceH 6) $ borderedRectangle 10 4
+    rect1 = dcRectangle FILL_STROKE 6 4
+    rect2 = moveStart (hvec 6) $ dcRectangle FILL_STROKE 10 4
 
 
 haskell_org :: XLink
diff --git a/demo/FontDeltaPic.hs b/demo/FontDeltaPic.hs
--- a/demo/FontDeltaPic.hs
+++ b/demo/FontDeltaPic.hs
@@ -39,11 +39,11 @@
     draw $ line4 `at` (P2 0  25)
     draw $ line5 `at` (P2 0   0) 
   where
-    line1 = plainTextLine "All the lines of this drawing" 
-    line2 = plainTextLine "should be grouped within a SVG"
-    line3 = plainTextLine "g-element, from where they"
-    line4 = plainTextLine "inherit the font-family and"
-    line5 = plainTextLine "font-size attributes."
+    line1 = dcTextlabel "All the lines of this drawing" 
+    line2 = dcTextlabel "should be grouped within a SVG"
+    line3 = dcTextlabel "g-element, from where they"
+    line4 = dcTextlabel "inherit the font-family and"
+    line5 = dcTextlabel "font-size attributes."
 
 
 
diff --git a/demo/SimpleAdvGraphic.hs b/demo/SimpleAdvGraphic.hs
--- a/demo/SimpleAdvGraphic.hs
+++ b/demo/SimpleAdvGraphic.hs
@@ -35,33 +35,33 @@
 mf :: TraceDrawing Double ()
 mf = do
     drawl (P2 0 120) $ 
-        runAdvObjectR1 $ evenspace (hvec 10) [text01, text02, text01]
+        runAdvObject $ evenspace (hvec 10) [text01, text02, text01]
 
     drawl (P2 0 80) $ 
-        runAdvObjectR1 $ advances [text01, text02, text01]
+        runAdvObject $ advances [text01, text02, text01]
 
     drawl (P2 0 40) $ 
-        runAdvObjectR1 (miniDisk `advance` text01 `advance` miniDisk)
+        runAdvObject (miniDisk `advance` text01 `advance` miniDisk)
 
     drawl (P2 0 0) $
-        runAdvObjectR1 (miniDisk `advance` text02 `advance` miniDisk)
+        runAdvObject (miniDisk `advance` text02 `advance` miniDisk)
 
 
 -- Normally, text calculate the advance vector from the font 
 -- metrics...
 --
 text01 :: AdvObject Double
-text01 = makeAdvObject (pure $ hvec 84) $ plainTextLine "text01"
+text01 = makeAdvObject (pure $ hvec 84) $ dcTextlabel "text01"
     
 
 text02 :: AdvObject Double
-text02 = makeAdvObject (pure $ hvec 210) $ plainTextLine "text number two"
+text02 = makeAdvObject (pure $ hvec 210) $ dcTextlabel "text number two"
 
 
 miniDisk :: AdvObject Double
 miniDisk = makeAdvObject (pure $ V2 0 0) disk1 
   where
-    disk1 = localize (fill_colour sienna) $ filledDisk 3
+    disk1 = localize (fill_colour sienna) $ dcDisk FILL 3
 
 
 sienna :: RGBi
diff --git a/demo/SimplePosObject.hs b/demo/SimplePosObject.hs
--- a/demo/SimplePosObject.hs
+++ b/demo/SimplePosObject.hs
@@ -8,6 +8,7 @@
 import Wumpus.Core                      -- package: wumpus-core
 import Wumpus.Core.Colour ( red )
 
+import Data.Monoid
 import System.Directory
 
 
@@ -59,11 +60,13 @@
     
 
 testDrawBl :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u
-testDrawBl rpos = 
-    filledDisk 2 `oplus` (pushR1 ignoreAns $ rectBl `startAddr` rpos)
+testDrawBl raddr = dcDisk FILL 2 `mappend` rectBl raddr
 
-rectBl :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u
-rectBl = runPosObjectR2 $ makePosObject (return ortt) (mkRectBl w h)
+
+rectBl :: (Fractional u, InterpretUnit u) 
+       => RectAddress -> LocGraphic u
+rectBl raddr = 
+    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)
   where
     w    = 40 
     h    = 30
@@ -75,18 +78,20 @@
 
 -- start-point - bottom left
 mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u
-mkRectBl w h = strokedRectangle w h
+mkRectBl w h = dcRectangle STROKE w h
 
 
 
-testDrawMinor :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u
-testDrawMinor rpos = 
-    filledDisk 2 `oplus` (pushR1 ignoreAns $ rectMinor `startAddr` rpos)
+testDrawMinor :: (Floating u, InterpretUnit u) 
+              => RectAddress -> LocGraphic u
+testDrawMinor raddr = 
+    dcDisk FILL 2 `mappend` (ignoreAns $ rectMinor raddr)
 
 
-rectMinor :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u 
-rectMinor = 
-    runPosObjectR2 $ makePosObject (return ortt) (mkRectMinor m w h)
+rectMinor :: (Fractional u, InterpretUnit u) 
+          => RectAddress -> LocImage u (BoundingBox u)
+rectMinor raddr = 
+    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)
   where
     m    = 10
     w    = 40 
@@ -99,10 +104,10 @@
 
 -- start-point - +10 +10
 mkRectMinor :: InterpretUnit u => u -> u -> u -> LocGraphic u
-mkRectMinor m w h = promoteR1 $ \pt -> 
-    let bl = displaceVec (vec (-m) (-m)) pt
-        br = displaceH w bl
-        tr = displaceV h br
-        tl = displaceV h bl
-    in vertexPP [bl, br, tr, tl] >>= closedStroke
+mkRectMinor m w h = promoteLoc $ \pt -> 
+    let bl = displace (vec (-m) (-m)) pt
+        br = displace (hvec w) bl
+        tr = displace (vvec h) br
+        tl = displace (vvec h) bl
+    in zapQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE
 
diff --git a/src/Wumpus/Basic/Geometry.hs b/src/Wumpus/Basic/Geometry.hs
--- a/src/Wumpus/Basic/Geometry.hs
+++ b/src/Wumpus/Basic/Geometry.hs
@@ -18,14 +18,18 @@
 module Wumpus.Basic.Geometry
   (
     module Wumpus.Basic.Geometry.Base
+  , module Wumpus.Basic.Geometry.Illustrate
   , module Wumpus.Basic.Geometry.Intersection
   , module Wumpus.Basic.Geometry.Paths
   , module Wumpus.Basic.Geometry.Quadrant
+  , module Wumpus.Basic.Geometry.Vertices
 
   ) where
 
 
 import Wumpus.Basic.Geometry.Base
+import Wumpus.Basic.Geometry.Illustrate
 import Wumpus.Basic.Geometry.Intersection
 import Wumpus.Basic.Geometry.Paths
 import Wumpus.Basic.Geometry.Quadrant
+import Wumpus.Basic.Geometry.Vertices
diff --git a/src/Wumpus/Basic/Geometry/Base.hs b/src/Wumpus/Basic/Geometry/Base.hs
--- a/src/Wumpus/Basic/Geometry/Base.hs
+++ b/src/Wumpus/Basic/Geometry/Base.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -28,6 +29,10 @@
   , identity2'2
   , det2'2
   , transpose2'2
+
+  -- * Line 
+  , Line(..)
+  , inclinedLine
   
   -- * Line in equational form 
   , LineEquation(..)
@@ -65,7 +70,7 @@
   ) 
   where
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Kernel
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -101,6 +106,8 @@
 data Matrix2'2 u = M2'2 !u !u   !u !u
   deriving (Eq)
 
+type instance DUnit (Matrix2'2 u) = u
+
 type DMatrix2'2 = Matrix2'2 Double
 
 
@@ -158,6 +165,29 @@
 
 --------------------------------------------------------------------------------
 
+-- | Infinite line represented by two points.
+--
+data Line u = Line (Point2 u) (Point2 u)
+  deriving (Eq,Show)
+
+type instance DUnit (Line u) = u
+
+
+
+-- | 'inclinedLine' : @ point * ang -> Line @
+--
+-- Make an infinite line passing through the supplied point 
+-- inclined by @ang@.
+--
+inclinedLine :: Floating u => Point2 u -> Radian -> Line u
+inclinedLine radial_ogin ang = Line radial_ogin (radial_ogin .+^ avec ang 100)
+
+
+
+
+
+--------------------------------------------------------------------------------
+
 -- | Line in equational form, i.e. @Ax + By + C = 0@.
 --
 data LineEquation u = LineEquation 
@@ -167,6 +197,9 @@
       }
   deriving (Eq,Show)
 
+type instance DUnit (LineEquation u) = u
+
+
 type DLineEquation = LineEquation Double
 
 
@@ -230,6 +263,9 @@
 data LineSegment u = LineSegment (Point2 u) (Point2 u)
   deriving (Eq,Ord,Show)
 
+type instance DUnit (LineSegment u) = u
+
+
 type DLineSegment = LineSegment Double
 
 
@@ -275,6 +311,9 @@
 data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)
   deriving (Eq,Ord,Show)
 
+type instance DUnit (BezierCurve u) = u
+
+
 type DBezierCurve = BezierCurve Double
 
 
@@ -362,7 +401,7 @@
 
 
 
--- | 'bezierArcPoints' : @ apex_angle * radius * rotation * center -> [Point] @
+-- | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @
 --
 -- > ang should be in the range 0 < ang < 360deg.
 --
@@ -415,10 +454,10 @@
     rl      = kfactor * radius * kappa
     totang  = circularModulo $ ang + theta
 
-    p0      = displaceParallel radius theta pt
-    c1      = displacePerpendicular rl theta p0
-    c2      = displacePerpendicular (-rl) totang p3
-    p3      = displaceParallel radius totang pt
+    p0      = dispParallel radius theta pt
+    c1      = dispPerpendicular rl theta p0
+    c2      = dispPerpendicular (-rl) totang p3
+    p3      = dispParallel radius totang pt
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Wumpus/Basic/Geometry/Illustrate.hs b/src/Wumpus/Basic/Geometry/Illustrate.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Geometry/Illustrate.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Geometry.Illustrate
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Draw the geometrical objects.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Geometry.Illustrate
+  ( 
+
+    illustrateLine
+  , illustrateLineSegment
+
+  ) 
+  where
+
+import Wumpus.Basic.Geometry.Base
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Colour 
+
+import Data.Monoid
+
+
+emline :: InterpretUnit u => Vec2 Em -> LocGraphic u
+emline = uconvF . locStraightLine
+
+enDot :: InterpretUnit u => LocGraphic u
+enDot = uconvF body
+  where
+    body :: LocGraphic En
+    body = localize (fill_colour white) $ dcDisk FILL_STROKE 0.5
+
+illustrateLine :: (Real u, Floating u, InterpretUnit u) 
+               => Line u -> Graphic u
+illustrateLine (Line p1 p2) = 
+    mconcat [ prefix, join_line, suffix, d1, d2 ]
+  where
+    join_line = straightLine p1 p2
+    v1        = pvec p1 p2
+    dir       = vdirection v1
+    
+    prefix    = localize dotted_line $ emline (avec dir (-6)) `at` p1
+    suffix    = localize dotted_line $ emline (avec dir 6)    `at` p2
+    d1        = enDot `at` p1
+    d2        = enDot `at` p2
+
+       
+
+
+
+illustrateLineSegment :: InterpretUnit u => LineSegment u -> Graphic u
+illustrateLineSegment (LineSegment p1 p2) = 
+    join_line `mappend` d1 `mappend` d2
+  where
+    join_line = straightLine p1 p2
+    d1        = enDot `at` p1
+    d2        = enDot `at` p2
diff --git a/src/Wumpus/Basic/Geometry/Intersection.hs b/src/Wumpus/Basic/Geometry/Intersection.hs
--- a/src/Wumpus/Basic/Geometry/Intersection.hs
+++ b/src/Wumpus/Basic/Geometry/Intersection.hs
@@ -26,7 +26,6 @@
   , interCurveLine
 
   , findIntersect
-  , makePlane
 
 
   ) 
@@ -36,7 +35,6 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
 
 
 
@@ -50,13 +48,12 @@
 -- Lines are infinite they are represented by points on them, 
 -- they are not line segments.
 --
--- An answer of @Nothing@ may indicate wither the lines coincide
+-- An answer of @Nothing@ may indicate either the lines coincide
 -- or the are parallel.
 --
 interLineLine :: Fractional u 
-              => (Point2 u, Point2 u) -> (Point2 u, Point2 u) 
-              -> Maybe (Point2 u)
-interLineLine (p1,p2) (q1,q2) = 
+              => Line u -> Line u -> Maybe (Point2 u)
+interLineLine (Line p1 p2) (Line q1 q2) = 
     if det_co == 0 then Nothing 
                    else Just $ P2 (det_xm / det_co) (det_ym / det_co)
   where
@@ -85,7 +82,7 @@
 interLinesegLineseg :: (Fractional u, Ord u, Tolerance u)
                     => LineSegment u -> LineSegment u -> Maybe (Point2 u)
 interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) = 
-    interLineLine (p,q) (s,t) >>= segcheck
+    interLineLine (Line p q) (Line s t) >>= segcheck
   where
     segcheck = mbCheck (\pt -> withinPoints pt a && withinPoints pt b)
  
@@ -99,9 +96,9 @@
 -- segment coincide, or that there is no intersection.
 --
 interLinesegLine :: (Fractional u, Ord u, Tolerance u)
-                 => LineSegment u -> (Point2 u, Point2 u) -> Maybe (Point2 u)
+                 => LineSegment u -> Line u -> Maybe (Point2 u)
 interLinesegLine a@(LineSegment p q) line = 
-    interLineLine (p,q) line >>= segcheck
+    interLineLine (Line p q) line >>= segcheck
   where
     segcheck = mbCheck (\pt -> withinPoints pt a)
 
@@ -112,7 +109,7 @@
 -- | Check the point is \"within\" the span of the line.
 --
 -- Note - this function is to be used \*after\* an intersection
--- has been found. Hence it is not export.
+-- has been found. Hence it is not exported.
 --
 withinPoints :: (Ord u, Fractional u, Tolerance u) 
              => Point2 u -> LineSegment u -> Bool
@@ -120,7 +117,7 @@
     between x (ordpair x0 x1) && between y (ordpair y0 y1)
   where
     ordpair a b     = (min a b, max a b)
-    between a (s,t) = (s `tGT` a) && (a `tGT` t)
+    between a (s,t) = (s `tLTE` a) && (a `tLTE` t)
 
 
 
@@ -136,8 +133,8 @@
 -- intersection of line and Bezier curve
 
 interCurveLine :: (Floating u , Ord u, Tolerance u)
-               => BezierCurve u -> (Point2 u, Point2 u) -> Maybe (Point2 u)
-interCurveLine c0 (p,q) = step c0
+               => BezierCurve u -> Line u -> Maybe (Point2 u)
+interCurveLine c0 (Line p q) = step c0
   where
     eqline  = lineEquation p q
     step c  = case cut c eqline of
@@ -156,15 +153,15 @@
 --
 cut :: (Floating u , Ord u, Tolerance u)
     => BezierCurve u -> LineEquation u -> Either (Point2 u) Bool
-cut (BezierCurve p0 p1 p2 p3) line = 
+cut (BezierCurve p0 p1 p2 p3) eqline = 
     if d0 `tEQ` 0 then Left p0 else
     if d3 `tEQ` 0 then Left p3 else
     let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds
   where
-    d0  = pointLineDistance p0 line 
-    d1  = pointLineDistance p1 line 
-    d2  = pointLineDistance p2 line 
-    d3  = pointLineDistance p3 line 
+    d0  = pointLineDistance p0 eqline 
+    d1  = pointLineDistance p1 eqline 
+    d2  = pointLineDistance p2 eqline 
+    d3  = pointLineDistance p3 eqline 
 
 
 
@@ -187,9 +184,9 @@
               -> Maybe (Point2 u)
 findIntersect radial_ogin ang = step 
   where
-    plane       = makePlane radial_ogin ang
+    line1       = inclinedLine radial_ogin ang
     step []     = Nothing
-    step (x:xs) = case interLinesegLine x plane of 
+    step (x:xs) = case interLinesegLine x line1 of 
                      Just pt | quadrantCheck ang radial_ogin pt -> Just pt
                      _       -> step xs
 
@@ -200,16 +197,5 @@
               => Radian -> Point2 u -> Point2 u -> Bool
 quadrantCheck theta ctr pt = theta == lineAngle ctr pt
 
-
-
-
-
--- | 'makePlane' : @ point * ang -> Line @
---
--- Make an infinite line \/ plane passing through the supplied 
--- with elevation @ang@.
---
-makePlane :: Floating u => Point2 u -> Radian -> (Point2 u, Point2 u)
-makePlane radial_ogin ang = (radial_ogin, radial_ogin .+^ avec ang 100)
 
 
diff --git a/src/Wumpus/Basic/Geometry/Paths.hs b/src/Wumpus/Basic/Geometry/Paths.hs
--- a/src/Wumpus/Basic/Geometry/Paths.hs
+++ b/src/Wumpus/Basic/Geometry/Paths.hs
@@ -11,10 +11,9 @@
 -- Stability   :  highly unstable
 -- Portability :  GHC
 --
--- Paths for /elementary/ shapes - rectangles...
+-- Path /algorithms/ for elementary shapes - rectangle, diamond, 
+-- polygon.
 -- 
--- \*\* - WARNING \*\* - half baked. 
---
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Geometry.Paths
@@ -23,6 +22,8 @@
     PathAlg
   , runPathAlgPoint
   , runPathAlgVec
+  , drawVertexPathAlg
+
   , pathStartIsStart
   , pathStartIsLocus
   , pathIterateLocus
@@ -31,25 +32,20 @@
   , blRectanglePathAlg
 
   , diamondPathAlg
+  , isoscelesTriPathAlg
   , polygonPathAlg
 
   , arcPathAlg
   , circlePathAlg
 
-  , LocCoordPath
-  , coordinatePrimPath
+  , parallelogramPathAlg
+  , isoscelesTrapeziumPathAlg
 
-  , rectangleCoordPath
-  , diamondCoordPath
-  , polygonCoordPath
-  , isoscelesTriangleCoordPath
-  , isoscelesTrianglePoints
-  , equilateralTriangleCoordPath
-  , equilateralTrianglePoints
   ) 
   where
 
 import Wumpus.Basic.Geometry.Base
+import Wumpus.Basic.Geometry.Vertices
 import Wumpus.Basic.Kernel
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -80,6 +76,7 @@
 
 type instance DUnit (PathAlg u) = u
 
+
 runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u]
 runPathAlgPoint _  (PathAlg _   [])       = []
 runPathAlgPoint p0 (PathAlg scm (v0:xs)) 
@@ -96,24 +93,58 @@
 
 
 
--- TO CLARIFY - should all four side paths of a rectangle be 
--- generated, or three sides with the implication that close forms
--- the fourth?
---
 
+drawVertexPathAlg :: InterpretUnit u 
+                  => DrawStyle -> PathAlg u -> LocGraphic u
+drawVertexPathAlg style alg = promoteLoc $ \pt -> 
+    zapQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style
+
+
+-- | Create a PathAlg from the vertex list.
+--
+-- When the PathAlg is run the supplied point will be the start 
+-- of the path. 
+-- 
 pathStartIsStart :: [Vec2 u] -> PathAlg u
 pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START
                               , path_alg_steps  = vs }
 
 
 
+-- | Create a PathAlg from the vector list - the first vector
+-- displaces the /start point/ the subsequent vectors displace 
+-- the /current tip/. Figuratively, this is rather like Logo 
+-- /turtle drawing/.
+--
+-- When the PathAlg is run, the supplied point is the /locus/ of 
+-- the path and it does not form part of the path proper.
+-- 
+-- This constructor is typically used to make /shape paths/ where
+-- the supplied point is the center and the generated path is the 
+-- border.
+-- 
 pathStartIsLocus :: [Vec2 u] -> PathAlg u
 pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS
                               , path_alg_steps  = vs }
 
--- | Note this creates a path very the first vector represents a
+
+-- | Note this creates a path where the first vector represents a
 -- @moveto@, then the subsequence vectors represent @linetos@.
 -- 
+
+
+-- | Create a PathAlg from the vector list - each vector in the 
+-- input list iterates to the start point rather then the 
+-- cumulative tip.
+--
+-- When the PathAlg is run, the supplied point is the /locus/ of 
+-- the path and it does not form part of the path proper.
+-- 
+-- Like 'pathStartIsLocus', this constructor is typically used to 
+-- make /shape paths/. Some shapes are easier to express as 
+-- iterated displacements of the center rather than 
+-- /turtle drawing/. 
+-- 
 pathIterateLocus :: Num u => [Vec2 u] -> PathAlg u
 pathIterateLocus []      = pathStartIsLocus []
 pathIterateLocus (v0:xs) = pathStartIsLocus $ v0 : step v0 xs
@@ -124,20 +155,27 @@
 
 
 
--- | Supplied point is /center/, the genearated points are 
--- counter-clockwise so [ bl, br, tr, tl ] .
+-- | Implicit start point is /center/, the genearated moves are 
+-- counter-clockwise so the move-list is
 --
+-- > [ moveto_bl, moveto_br, moveto_tr, moveto_tl ]
+--
 rectanglePathAlg :: Fractional u => u -> u -> PathAlg u
-rectanglePathAlg w h = pathStartIsLocus [ vbl, vbr, vtr, vtl ]
+rectanglePathAlg w h = 
+    pathStartIsLocus [ to_bl, to_br, to_tr, to_tl ]
   where
-    vbl = vec (negate $ 0.5*w) (negate $ 0.5*h)
-    vbr = hvec w
-    vtr = vvec h
-    vtl = hvec (-w) 
+    to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)
+    to_br = hvec w
+    to_tr = vvec h
+    to_tl = hvec (-w) 
 
--- | Supplied point is /bottom-left/, subsequent points are 
--- counter-clockwise so [ bl, br, tr, tl ] .
+
+
+-- | Implicit start point is /bottom-left/, subsequent moves are 
+-- counter-clockwise so the move-list is:
 --
+-- > [ moveto_br, moveto_tr, moveto_tl, moveto_bl ]
+--
 blRectanglePathAlg :: Num u => u -> u -> PathAlg u
 blRectanglePathAlg w h = pathStartIsStart [ vbr, vtr, vtl, vbl ]
   where
@@ -158,6 +196,19 @@
     ve = hvec hw
     vn = vvec hh
     vw = hvec (-hw)
+
+
+
+-- | 'isoscelesTriPathAlg' : @ base_width * height -> PathAlg @
+--
+-- Start point is centtroid not incenter.
+--
+isoscelesTriPathAlg :: Floating u => u -> u -> PathAlg u
+isoscelesTriPathAlg bw h = 
+    pathIterateLocus [ to_bl, to_br, to_apex ]
+  where
+    (to_bl, to_br, to_apex) = isoscelesTriangleVertices bw h
+
     
 
 -- | 'polygonPathAlg' : @ num_points * radius -> PathAlg @ 
@@ -172,6 +223,8 @@
                 | otherwise = Nothing
 
 
+-- | 'arcPathAlg' : @ radius * angle1 * angle2 ->  PathAlg @ 
+--
 arcPathAlg :: Floating u => u -> Radian -> Radian -> PathAlg u
 arcPathAlg r ang1 ang2 = pathStartIsLocus $ step1 $ arcdiv ang1 ang2
   where
@@ -240,104 +293,23 @@
 
 
 
--- arcs - wedges - circles...
-
----------------------------------------------------------------------------
--- OLD ...
-
--- | A functional type from /initial point/ to point list.
---
-type LocCoordPath u = Point2 u -> [Point2 u]
-
-
--- Note - extraction needs a naming scheme - extractFROM or 
--- extractTO? - in either case this might be queuing up 
--- name-clash problems.
---
--- The Path data type will also need a similar function...
---
- 
--- | Relative unit version of 'coordinatePrimPathAU'.
---
-coordinatePrimPath :: InterpretUnit u 
-                   => LocCoordPath u -> Point2 u -> Query PrimPath
-coordinatePrimPath fn pt = vertexPP $ fn pt
-
-
-
--- | Supplied point is /bottom-left/, subsequenct points are 
--- counter-clockwise so [ bl, br, tr, tl ] .
---
-rectangleCoordPath :: Num u => u -> u -> LocCoordPath u
-rectangleCoordPath w h bl = [ bl, br, tr, tl ]
-  where
-    br = bl .+^ hvec w
-    tr = br .+^ vvec h
-    tl = bl .+^ vvec h 
-
-
-
--- | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @
---
-diamondCoordPath :: Num u => u -> u -> LocCoordPath u
-diamondCoordPath hw hh ctr = [ s,e,n,w ]
-  where
-    s     = ctr .+^ vvec (-hh)
-    e     = ctr .+^ hvec hw
-    n     = ctr .+^ vvec hh
-    w     = ctr .+^ hvec (-hw)
-    
-
--- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ 
+-- | @ width * height * bottom_left_angle @
 --
-polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u
-polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))
+parallelogramPathAlg :: Floating u => u -> u -> Radian -> PathAlg u
+parallelogramPathAlg w h bl_ang = 
+    pathIterateLocus [ bl, br, tr, tl ]
   where
-    theta = (pi*2) / fromIntegral n
-    
-    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))
-                | otherwise = Nothing
+    (bl, br, tr, tl) = parallelogramVertices w h bl_ang
 
 
 
--- | @isocelesTriangle bw h pt@
---
--- Supplied point is the centriod of the triangle. This has a 
--- nicer visual balance than using half-height.
---
-isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u
-isoscelesTriangleCoordPath bw h ctr = [bl,br,top]
-  where
-    (bl,br,top) = isoscelesTrianglePoints bw h ctr
-
-
--- | @isocelesTriangle bw h pt@
---
--- Supplied point is the centriod of the triangle. This has a 
--- nicer visual balance than using half-height.
+-- | @ base_width * top_width * height @
 --
-isoscelesTrianglePoints :: Floating u 
-                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
-isoscelesTrianglePoints bw h ctr = (bl, br, top) 
+isoscelesTrapeziumPathAlg :: Floating u => u -> u -> u -> PathAlg u
+isoscelesTrapeziumPathAlg bw tw h = 
+    pathIterateLocus [ bl, br, tr, tl ]
   where
-    hw         = 0.5*bw 
-    theta      = atan $ h / hw
-    centroid_h = hw * tan (0.5*theta)
-    top        = ctr .+^ vvec (h - centroid_h)
-    br         = ctr .+^ V2   hw  (-centroid_h)
-    bl         = ctr .+^ V2 (-hw) (-centroid_h)
+    (bl, br, tr, tl) = isoscelesTrapeziumVertices bw tw h
 
 
--- | @ side_length * ctr -> [Points] @
---
-equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u
-equilateralTriangleCoordPath sl ctr = [bl, br, top] 
-  where
-    (bl,br,top) = equilateralTrianglePoints sl ctr
-
-equilateralTrianglePoints :: Floating u 
-                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
-equilateralTrianglePoints sl = isoscelesTrianglePoints sl h
-  where
-    h = sl * sin (pi/3)
 
diff --git a/src/Wumpus/Basic/Geometry/Quadrant.hs b/src/Wumpus/Basic/Geometry/Quadrant.hs
--- a/src/Wumpus/Basic/Geometry/Quadrant.hs
+++ b/src/Wumpus/Basic/Geometry/Quadrant.hs
@@ -21,11 +21,23 @@
     Quadrant(..)
 
   , quadrant
-  , qiModulo
 
-  , rectRadialVector
+  , RadialIntersect
+  , QuadrantAlg(..)
+  , runQuadrantAlg
+
+
+  , hypotenuseQI
   , rectangleQI
+  , hquadrilAcuteQI
+  , hquadrilObtusQI
 
+  , rectangleQuadrantAlg
+  , diamondQuadrantAlg
+  , isoscelesTriQuadrantAlg
+
+  -- OLD...
+  , rectRadialVector
   , diamondRadialVector
   , triangleRadialVector
   , triangleQI
@@ -36,6 +48,8 @@
   ) 
   where
 
+import Wumpus.Basic.Geometry.Base
+
 import Wumpus.Core                              -- package: wumpus-core
 
 data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE
@@ -54,49 +68,141 @@
          | otherwise    = QUAD_SE
 
 
--- | 'qiModulo' : @ ang -> Radian @
+-- | 'reflectionModuloQI' : @ ang -> Radian @
 -- 
--- Modulo an angle so it lies in quadrant I (north east), 
--- i.e. modulo into the range @0..(pi/2)@.
+-- Modulo an angle so it lies in quadrant I (north east) 
+-- /by reflection/ - thats to say:
+-- 
+-- > If the angle is in QI the result is identity.
 --
-qiModulo :: Radian -> Radian 
-qiModulo r = d2r $ dec + (fromIntegral $ i `mod` 90)
+-- > If the angle is in QII it is reflected about the Y-axis.
+-- >
+-- > e.g. 170deg becomes 10deg.
+-- 
+-- > If the angle is in QIII it is reflected about both axes.
+-- >
+-- > e.g. 190deg becomes 10deg.
+-- 
+-- > If the angle is in QIV it is reflected about the X-axis.
+-- >
+-- > e.g. 350deg becomes 10deg.
+-- 
+--
+reflectionModuloQI :: Radian -> Radian
+reflectionModuloQI = step . circularModulo 
   where
-    i       :: Integer
-    dec     :: Double
-    (i,dec) = properFraction $ r2d r
+    step ang | ang < 0.5*pi   = ang
+             | ang < pi       = pi - ang
+             | ang < 1.5*pi   = ang - pi
+             | otherwise      = two_pi - ang
 
 
---------------------------------------------------------------------------------
+type RadialIntersect u = Radian -> Vec2 u
 
+
+-- | A /Quadrant algorithm/.
+--
+data QuadrantAlg u = QuadrantAlg 
+      { calc_quad1 :: RadialIntersect u
+      , calc_quad2 :: RadialIntersect u
+      , calc_quad3 :: RadialIntersect u
+      , calc_quad4 :: RadialIntersect u
+      }
+
+runQuadrantAlg :: Radian -> QuadrantAlg u -> Vec2 u
+runQuadrantAlg a qa = step (circularModulo a)
+  where
+    step ang | ang < half_pi  = calc_quad1 qa ang
+             | ang < pi       = calc_quad2 qa ang
+             | ang < 1.5*pi   = calc_quad3 qa ang
+             | otherwise      = calc_quad4 qa ang
+
+    
+
+-- | Reuse a QI algorithm to work in QII /provided/ it works
+-- under reflection.
+--
+reflectCalcQ2ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u
+reflectCalcQ2ToQ1 q1Fun = negateX . q1Fun . reflectionModuloQI
+
+
+-- | Reuse a QI algorithm to work in QIII /provided/ it works
+-- under reflection.
+--
+reflectCalcQ3ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u
+reflectCalcQ3ToQ1 q1Fun = negateXY . q1Fun . reflectionModuloQI
+
+
+-- | Reuse a QI algorithm to work in QIV /provided/ it works
+-- under reflection.
+--
+reflectCalcQ4ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u
+reflectCalcQ4ToQ1 q1Fun = negateY . q1Fun . reflectionModuloQI
+
+
+
+--
+-- Negating vectors - aka relfecting them:
+
+-- | Negate a vector in X - aka reflect it about the Y-axis.
+--
 negateX :: Num u => Vec2 u -> Vec2 u
 negateX (V2 x y) = V2 (-x) y
 
+-- | Negate a vector in Y - aka reflect it about the X-axis.
+--
 negateY :: Num u => Vec2 u -> Vec2 u
 negateY (V2 x y) = V2 x (-y)
 
+-- | Negate a vector in X and Y - aka reflect it about both axes.
+--
 negateXY :: Num u => Vec2 u -> Vec2 u
 negateXY (V2 x y) = V2 (-x) (-y)
 
 
--- | 'rectRadialVector' : @ half_width * half_height * ang -> Vec @
+
+-- | Builder for the usual case of /Quadrant algorithm/ where
+-- each quadrant is calculated in QI then the answer is reflected 
+-- to the respective quadrant.
 --
--- Find where a radial line extended from (0,0) with the elevation
--- @ang@ intersects with an enclosing rectangle. The rectangle is 
--- centered at (0,0).
--- 
--- Internally the calculation is made in quadrant I (north east),
--- symmetry is used to translate result to the other quadrants.
+-- Calulating for QI is usually easier...
 --
-rectRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u
-rectRadialVector hw hh ang = fn $ circularModulo ang
+makeReflectionQuadrantAlg :: Num u 
+                          => RadialIntersect u 
+                          -> RadialIntersect u
+                          -> RadialIntersect u 
+                          -> RadialIntersect u
+                          -> QuadrantAlg u
+makeReflectionQuadrantAlg f1 f2 f3 f4 = 
+    QuadrantAlg { calc_quad1 = f1
+                , calc_quad2 = reflectCalcQ2ToQ1 f2
+                , calc_quad3 = reflectCalcQ3ToQ1 f3
+                , calc_quad4 = reflectCalcQ4ToQ1 f4
+                }
+
+--------------------------------------------------------------------------------
+
+
+
+-- | 'triangleQI' : @ dx * dy -> RadialIntersect @
+--
+-- Find where a line from (0,0) with elevation @ang@ intersects 
+-- the hypotenuse a right triangle in QI (the legs of the triangle 
+-- take the x and y-axes).  
+--
+-- > ang must be in the @range 0 < ang <= 90@.
+-- >
+-- > width and height must be positive.
+--
+hypotenuseQI :: (Real u, Floating u) => u -> u -> RadialIntersect u
+hypotenuseQI dx dy ang = avec ang dist
   where
-    fn a | a < 0.5*pi   = rectangleQI hw hh a
-         | a < pi       = negateX  $ rectangleQI hw hh (pi - a)
-         | a < 1.5*pi   = negateXY $ rectangleQI hw hh (a - pi) 
-         | otherwise    = negateY  $ rectangleQI hw hh (2*pi - a)
+    base_ang = atan (dy / dx)
+    apex     = pi - (base_ang + fromRadian ang)
+    dist     = sin base_ang * (dx / sin apex)
 
 
+
 -- | 'rectangleQI' : @ width * height * ang -> Vec @
 --
 -- Find where a line from (0,0) in direction @ang@ intersects the 
@@ -108,13 +214,203 @@
 -- > width and height must be positive.
 --
 rectangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u    
-rectangleQI w h ang
-    | ang < theta  = let y = w * fromRadian (tan ang) in V2 w y
-    | otherwise    = let x = h / fromRadian (tan ang) in V2 x h
+rectangleQI dx dy ang
+    | ang < theta  = let y1 = dx * fromRadian (tan ang) in V2 dx y1
+    | otherwise    = let x1 = dy / fromRadian (tan ang) in V2 x1 dy
   where
-    theta               = toRadian $ atan (h/w)
+    theta               = toRadian $ atan (dy/dx)
 
 
+
+-- | 'hquadrilAcuteQI' : @ dx * dy * ang -> RadialIntersect @
+--
+-- Find where a line from (0,0) with elevation @ang@ intersects 
+-- a quadrilateral in /H acute/ form in QI.  
+--
+-- > ang must be in the @range 0 < ang <= 90@.
+-- >
+-- > dx (top width @bc@) and dy (height @ab) must be positive.
+--
+-- Horizontal acute quadrilateral (@H@ because one of the two 
+-- \"sides of interest\" is horizontal, /acute/ because the 
+-- angle of interest @bcd@ is acute:
+--
+-- >      
+-- >  b---*----c
+-- >  |       /
+-- >  |      %
+-- >  |     /
+-- >  a----d
+-- >
+--
+hquadrilAcuteQI :: (Real u, Floating u) 
+                => u -> u -> Radian -> RadialIntersect u
+hquadrilAcuteQI bc ab bcd ang = 
+    if ang >= cad then bisectingHTop ab ang else bisecting_dc ad adc ang
+  where
+    cad           = half_pi - (atan $ toRadian $ bc / ab)
+    adc           = pi - bcd
+    star_c        = ab / (fromRadian $ tan bcd)
+    ad            = bc - star_c
+
+    
+-- This is intersecting dc at percent-sign - now called z.
+--
+-- Know one side (ad) and two angs (zad which is ang) and (adc == adz)
+-- Use law of sines to find (az) :
+-- 
+-- >
+-- >         z
+-- >    . ' /
+-- >  a----d
+-- > 
+--
+bisecting_dc :: Floating u => u -> Radian -> Radian -> Vec2 u
+bisecting_dc ad adc ang = avec ang az
+  where
+    adz  = adc
+    azd  = pi - (ang + adz)
+    sine = fromRadian . sin
+    az   = (ad * (sine adz)) / sine azd 
+  
+
+
+-- This is intersecting bc at star now called o.
+--
+-- >  b---o----c
+-- >  |  / 
+-- >  | /  
+-- >  |/    
+-- >  a-----
+--
+bisectingHTop :: Fractional u => u -> Radian -> Vec2 u
+bisectingHTop ab ang = V2 bo ab
+  where
+    bao = half_pi - ang 
+    bo  = ab * (fromRadian $ tan bao)
+     
+
+-- | 'hquadrilObtusQI' : @ dx * dy * ang -> RadialIntersect @
+--
+-- Find where a line from (0,0) with elevation @ang@ intersects 
+-- a quadrilateral in /H obtus/ form in QI.  
+--
+-- > ang must be in the @range 0 < ang <= 90@.
+-- >
+-- > dx (top width @bc@) and dy (height @ab) must be positive.
+--
+-- H Obtus quadrilateral (@H@ because one of the two 
+-- \"sides of interest\" is horizontal, /obtus/ because the 
+-- angle interest @bcd@ is obtuse:
+--
+-- >      
+-- >  b---*----c
+-- >  |         \
+-- >  |          %
+-- >  |           \
+-- >  a------------d
+-- >
+--
+hquadrilObtusQI :: (Real u, Floating u) 
+                => u -> u -> Radian -> RadialIntersect u
+hquadrilObtusQI bc ab bcd ang = 
+    if ang < cad then bisecting_dc ad adc ang else bisectingHTop ab ang 
+  where
+    cad           = half_pi - (atan $ toRadian $ bc / ab)
+    adc           = pi - bcd
+    star_c        = ab / (fromRadian $ tan bcd)
+    ad            = bc - star_c
+
+
+
+
+
+     
+
+
+
+
+-- | 'diamondQuadrantAlg' : @ width * height -> QuadrantAlg @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing diamond. The diamond is 
+-- centered at (0,0).
+-- 
+-- Internally the calculation is made in quadrant I (north east),
+-- symmetry is used to translate result to the other quadrants.
+--
+diamondQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u
+diamondQuadrantAlg w h = makeReflectionQuadrantAlg q1 q1 q1 q1
+  where
+    hw = 0.5 * w
+    hh = 0.5 * h
+    q1 = hypotenuseQI hw hh
+
+
+-- | 'rectangleQuadrantAlg' : @ width * height -> QuadrantAlg @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing rectangle. The rectangle is 
+-- centered at (0,0).
+-- 
+-- Internally the calculation is made in quadrant I (north east),
+-- symmetry is used to translate result to the other quadrants.
+--
+rectangleQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u
+rectangleQuadrantAlg w h = makeReflectionQuadrantAlg q1 q1 q1 q1
+  where
+    hw = 0.5 * w
+    hh = 0.5 * h
+    q1 = rectangleQI hw hh
+
+-- | 'isoscelesTriQuadrantAlg' : @ base_width * height -> QuadrantAlg @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing isosceles triangle. 
+-- 
+-- Note the /center/ of the triangle (0,0) is the centroid not the
+-- incenter.
+-- 
+-- Internally the calculation is made in quadrant I (north east),
+-- symmetry is used to translate result to the other quadrants.
+--
+isoscelesTriQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u
+isoscelesTriQuadrantAlg bw h = 
+    makeReflectionQuadrantAlg qtop qtop qbase qbase
+  where
+    ymaj      = 2 * (h / 3)
+    ymin      = h / 3
+    hbw       = 0.5 * bw
+    half_apex = atan (toRadian $ hbw / h)
+    ctrdw     = ymaj * (fromRadian $ tan half_apex)
+    ang       = half_pi - half_apex
+
+    qtop      = hypotenuseQI ctrdw ymaj
+    qbase     = hquadrilAcuteQI hbw ymin ang
+    
+
+
+-- OLD ...
+
+-- | 'rectRadialVector' : @ half_width * half_height * ang -> Vec @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing rectangle. The rectangle is 
+-- centered at (0,0).
+-- 
+-- Internally the calculation is made in quadrant I (north east),
+-- symmetry is used to translate result to the other quadrants.
+--
+rectRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u
+rectRadialVector hw hh ang = fn $ circularModulo ang
+  where
+    fn a | a < 0.5*pi   = rectangleQI hw hh a
+         | a < pi       = negateX  $ rectangleQI hw hh (pi - a)
+         | a < 1.5*pi   = negateXY $ rectangleQI hw hh (a - pi) 
+         | otherwise    = negateY  $ rectangleQI hw hh (2*pi - a)
+
+
+
 -- | 'diamondRadialVector' : @ half_width * half_height * ang -> Vec @
 --
 -- Find where a radial line extended from (0,0) with the elevation
@@ -301,6 +597,5 @@
     | tr_ang > half_pi = tw + extend
     | otherwise        = tw
   where
-    half_pi  = 0.5*pi
     shorten  = h / fromRadian (tan tr_ang)
     extend   = let lr_ang = pi - tr_ang in h / fromRadian (tan lr_ang)
diff --git a/src/Wumpus/Basic/Geometry/Vertices.hs b/src/Wumpus/Basic/Geometry/Vertices.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Geometry/Vertices.hs
@@ -0,0 +1,142 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basic.Vertices
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Vertices generators for elementary objects - triangles.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Geometry.Vertices
+  ( 
+    
+    Vertices2
+  , Vertices3
+  , Vertices4
+
+  , runVertices2
+  , runVertices3
+  , runVertices4
+
+
+  , rectangleVertices  
+  , isoscelesTriangleVertices
+  , equilateralTriangleVertices
+
+  , parallelogramVertices
+
+  , isoscelesTrapeziumVertices
+
+  ) 
+  where
+
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+
+type Vertices2 u = (Vec2 u, Vec2 u)
+type Vertices3 u = (Vec2 u, Vec2 u, Vec2 u)
+type Vertices4 u = (Vec2 u, Vec2 u, Vec2 u, Vec2 u)
+
+
+runVertices2 :: Num u => Point2 u -> Vertices2 u -> [Point2 u]
+runVertices2 ctr (v1,v2) = [ctr .+^ v1, ctr .+^ v2]
+
+runVertices3 :: Num u => Point2 u -> Vertices3 u -> [Point2 u]
+runVertices3 ctr (v1,v2,v3) = [ctr .+^ v1, ctr .+^ v2, ctr .+^ v3]
+
+runVertices4 :: Num u => Point2 u -> Vertices4 u -> [Point2 u]
+runVertices4 ctr (v1,v2,v3,v4) = 
+    [ctr .+^ v1, ctr .+^ v2, ctr .+^ v3, ctr .+^ v4]
+
+
+-- | Vertices are from the center to (bl, br, tr, tl).
+--
+rectangleVertices :: Num u => u -> u -> Vertices4 u
+rectangleVertices hw hh = (bl, br, tr, tl)
+  where
+    bl = V2 (-hw) (-hh)
+    br = V2   hw  (-hh)
+    tr = V2   hw    hh
+    tl = V2 (-hw)   hh 
+
+
+
+
+
+
+-- | @base_width * height -> (BL,BR,Apex)@
+--
+-- Vertices are from the centeriod to (bl, br,apex).
+--
+
+-- | @ height -> (BL,BR,Apex)@
+-- 
+-- Point is centroid (not incenter).
+--
+isoscelesTriangleVertices :: Floating u => u -> u -> Vertices3 u
+isoscelesTriangleVertices bw h = (bl, br, top) 
+  where
+    hw            = 0.5*bw 
+    centroid_min  = 1 * (h / 3)
+    centroid_maj  = h - centroid_min
+    top           = vvec centroid_maj
+    br            = V2   hw  (-centroid_min)
+    bl            = V2 (-hw) (-centroid_min)
+
+
+
+
+
+-- | @ side_length -> (BL,BR,Apex)@
+--
+equilateralTriangleVertices :: Floating u => u -> Vertices3 u
+equilateralTriangleVertices h = isoscelesTriangleVertices sl h
+  where
+    sl = 2.0 * (h / tan (pi/3))
+
+
+
+parallelogramVertices :: Floating u => u -> u -> Radian -> Vertices4 u
+parallelogramVertices w h bl_ang = (to_bl, to_br, to_tr, to_tl)
+  where
+    hw              = 0.5 * w
+    hh              = 0.5 * h
+    hypo            = hh / (fromRadian $ sin bl_ang)
+
+    to_bl           = hvec (-hw) ^+^ avec bl_ang (-hypo)
+    to_br           = hvec hw    ^+^ avec bl_ang (-hypo)
+    to_tl           = hvec (-hw) ^+^ avec bl_ang hypo
+    to_tr           = hvec hw    ^+^ avec bl_ang hypo
+
+
+
+
+-- Trapezium - make an isosceles trapezium...
+-- base - top - height 
+
+-- 
+isoscelesTrapeziumVertices :: Floating u
+                           => u -> u -> u -> Vertices4 u
+isoscelesTrapeziumVertices wbase wtop h = 
+    (to_bl, to_br, to_tr, to_tl)
+  where
+    hh    = 0.5 * h
+    hbw   = 0.5 * wbase
+    htw   = 0.5 * wtop    
+    to_bl = V2 (-hbw) (-hh) 
+    to_br = V2   hbw  (-hh) 
+    to_tl = V2 (-htw)   hh 
+    to_tr = V2   htw    hh
+
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
@@ -18,7 +18,6 @@
 module Wumpus.Basic.Kernel
   (
     module Wumpus.Basic.Kernel.Base.BaseDefs
-  , module Wumpus.Basic.Kernel.Base.ContextFun
   , module Wumpus.Basic.Kernel.Base.DrawingContext
   , module Wumpus.Basic.Kernel.Base.FontSupport
   , module Wumpus.Basic.Kernel.Base.QueryDC
@@ -35,7 +34,6 @@
   , module Wumpus.Basic.Kernel.Objects.CtxPicture
   , module Wumpus.Basic.Kernel.Objects.Displacement
   , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives
-  , module Wumpus.Basic.Kernel.Objects.Image
   , module Wumpus.Basic.Kernel.Objects.LocImage
   , module Wumpus.Basic.Kernel.Objects.LocThetaImage
   , module Wumpus.Basic.Kernel.Objects.Orientation
@@ -45,7 +43,6 @@
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.FontSupport
 import Wumpus.Basic.Kernel.Base.QueryDC
@@ -62,7 +59,6 @@
 import Wumpus.Basic.Kernel.Objects.CtxPicture
 import Wumpus.Basic.Kernel.Objects.Displacement
 import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
-import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Kernel.Objects.LocImage
 import Wumpus.Basic.Kernel.Objects.LocThetaImage
 import Wumpus.Basic.Kernel.Objects.Orientation
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
@@ -47,6 +47,12 @@
   , intraMapPoint
   , intraMapFunctor
 
+  -- * Drawing paths
+  , DrawStyle(..)
+
+  -- * Drawing /layer/
+  , ZDeco(..)  
+
   -- * Alignment
   , HAlign(..)
   , VAlign(..)  
@@ -54,11 +60,13 @@
   -- * Cardinal (compass) positions
   , Cardinal(..)
 
-  -- * Advance vector
-  , AdvanceVec
-  , advanceH
-  , advanceV
+  -- * Direction enumeration
+  , Direction(..)
+  
 
+  -- * Misc (potentially for Wumpus-Core)
+  , vsum
+
   ) where
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -323,7 +331,25 @@
 
 
 --------------------------------------------------------------------------------
+-- Drawing closed paths
 
+data DrawStyle = FILL | STROKE | FILL_STROKE
+  deriving (Bounded,Enum,Eq,Ord,Show)
+
+
+
+-- | Decorating with resepct to the Z-order 
+-- 
+-- > SUPERIOR - in front. 
+--
+-- > ANTERIOR - behind.
+--
+data ZDeco = SUPERIOR | ANTERIOR
+  deriving (Bounded,Enum,Eq,Ord,Show)
+
+
+--------------------------------------------------------------------------------
+
 -- Alignment
 
 -- | Horizontal alignment - align to the top, center or bottom.
@@ -346,31 +372,24 @@
               | SOUTH | SOUTH_WEST | WEST | NORTH_WEST
    deriving (Enum,Eq,Ord,Show) 
 
---------------------------------------------------------------------------------
 
--- | Advance vectors provide an idiom for drawing consecutive
--- graphics. PostScript uses them to draw left-to-right text - 
--- each character has an advance vector for the width and 
--- as characters are drawn they successively displace the start
--- point for the next character with their advance vector.
---
--- Type alias for Vec2.
---
-type AdvanceVec u = Vec2 u
+-- | An enumerated type representing horizontal and vertical 
+-- directions.
+data Direction = UP | DOWN | LEFT | RIGHT
+   deriving (Enum,Eq,Ord,Show) 
 
 
--- | Extract the horizontal component of an advance vector.
---
--- For left-to-right latin text, the vertical component of an
--- advance vector is expected to be 0. Ingoring it seems 
--- permissible when drawing text.
---
-advanceH :: AdvanceVec u -> u
-advanceH (V2 w _)  = w
 
--- | Extract the verticall component of an advance vector.
---
-advanceV :: AdvanceVec u -> u
-advanceV (V2 _ h)  = h
 
-
+-- | Sum a list of Vectors.
+--
+-- Note - this function is a candidate to go in Wumpus-Core, but
+-- it will be added when there is an intrinsic reason to to update
+-- Core (bug fix, or API change).
+--
+vsum :: Num u => [Vec2 u] -> Vec2 u
+vsum [] = V2 0 0
+vsum (v:vs) = go v vs
+  where
+    go a []     = a
+    go a (b:bs) = go (a ^+^ b) bs
diff --git a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs
+++ /dev/null
@@ -1,305 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Base.ContextFun
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- Function types operating over the DrawingContext as a /static/ 
--- argument. 
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Base.ContextFun
-  (
-
-  -- * /Context functional/ type
-    CF     
-
-  -- * Alias
-  , Query
-
-  -- * Run function
-  , runCF
-
-  -- * Construction
-  , consCF
-
-  , domMap1
-  , domMap2
-
-  , promoteR1
-  , promoteR2
-
-  , pushR0
-  , pushR1
-  , pushR2
-
-  , apply1R1
-  , apply1R2
-  , apply2R2
-
-  , lift0R1
-  , lift0R2
-  , lift1R2
-
-  , uconvR0
-  , uconvR1
-  , uconvR2a
-  , uconvR2ab
-
-  , drawingCtx
-
-  ) where
-
-import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.DrawingContext
-
-import Wumpus.Core                              -- package: wumpus-core
-
-
-import Control.Applicative
-import Data.Monoid
-
-
---------------------------------------------------------------------------------
---
-
--- NOTE - 31.03.11 - is there an advantage to adding a phantom
--- unit param to the CF functions?
-
--- | Most drawing operations in Wumpus-Basic have an implicit 
--- /graphics state/ the 'DrawingContext', so the most primitive 
--- building block is a function from the DrawingContext to some 
--- polymorphic answer.
--- 
--- This functional type is represented concretely as the initials 
--- @CF@ for /contextual function/.
--- 
--- > CF :: DrawingContext -> a 
---
-newtype CF a            = CF  { getCF :: DrawingContext -> a }
-
-type instance DUnit (CF a) = DUnit a
-
-
-
--- | Alias for 'CF'. Wumpus considers Context functions that
--- don\'t produce graphics to be /queries/.
--- 
--- > Query :: DrawingContext -> a 
---
--- 'Query' has no unit type parameter.
--- 
-type Query a            = CF a
- 
-
-
-
-
-
---------------------------------------------------------------------------------
--- CF instances
-
--- OPlus
-
-instance OPlus a => OPlus (CF a)  where
-  fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx
-
-
--- Monoid
- 
-instance Monoid a => Monoid (CF a) where 
-  mempty          = CF $ \_   -> mempty
-  fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx
-
-
--- Functor
-
-instance Functor CF where
-  fmap f ma = CF $ \ctx -> f $ getCF ma ctx 
-
-
-
--- Applicative
-
-instance Applicative CF where
-  pure a    = CF $ \_   -> a
-  mf <*> ma = CF $ \ctx -> let f = getCF mf ctx
-                               a = getCF ma ctx
-                           in f a
-
-
-
--- Monad 
-
-instance Monad CF where
-  return a  = CF $ \_   -> a
-  ma >>= k  = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx 
-
-
--- DrawingCtxM 
-
-instance DrawingCtxM CF where
-  askDC           = CF $ \ctx -> ctx
-  localize upd df = CF $ \ctx -> getCF df (upd ctx)
-  
-
-
---------------------------------------------------------------------------------
--- Affine instances
-
-
-
-instance Rotate a => Rotate (CF a) where
-  rotate ang            = fmap (rotate ang)
-
-instance RotateAbout a => RotateAbout (CF a) where
-  rotateAbout ang pt    = fmap (rotateAbout ang pt)
-
-instance Scale a => Scale (CF a) where
-  scale sx sy           = fmap (scale sx sy)
-
-instance Translate a => Translate (CF a) where
-  translate dx dy       = fmap (translate dx dy)
-
-
-
---------------------------------------------------------------------------------
--- Run functions
-
--- | Run a /CF/ (context function) with the supplied 
--- /DrawingContext/.
---
-runCF :: DrawingContext -> CF a -> a
-runCF ctx cf = getCF cf ctx
-
-
-
--- | Construction function.
---
-consCF :: (DrawingContext -> a) -> CF a
-consCF fn = CF $ \ctx -> fn ctx
-
-
-
-
-
-domMap1 :: (r1 -> r1) -> CF (r1 -> a) -> CF (r1 -> a)
-domMap1 f ma = CF $ \ctx -> 
-    (\r1 -> let f1 = getCF ma ctx in f1 (f r1))
-
-domMap2 :: (r1 -> r1) -> (r2 -> r2) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a)
-domMap2 f g ma = CF $ \ctx -> 
-    (\r1 r2 -> let f1 = getCF ma ctx in f1 (f r1) (g r2))
-
-
-
-promoteR1 :: (r1 -> CF a) -> CF (r1 -> a)
-promoteR1 mf = CF $ \ctx r1 -> getCF (mf r1) ctx
-
-promoteR2 :: (r1 -> r2 -> CF a) -> CF (r1 -> r2 -> a)
-promoteR2 mf = CF $ \ctx r1 r2 -> getCF (mf r1 r2) ctx
-
--- | Apply the value transformer to the answer of the context 
--- function. Figuratively /push it right/ so it works on the 
--- answer.
---
--- > pushR0 = fmap
---
-pushR0 :: (a -> a1) -> CF a -> CF a1
-pushR0 = fmap
-
-
--- | Apply the value transformer to the answer of the context 
--- function. Figuratively /push it right/ so it works on the 
--- answer.
---
--- > pushR1 = fmap . fmap
---
-pushR1 :: (a -> a1) -> CF (r1 -> a) -> CF (r1 -> a1)
-pushR1 = fmap . fmap
-
--- | Apply the value transformer to the answer of the context 
--- function. Figuratively /push it right/ so it works on the 
--- answer.
---
--- > pushR2 = fmap . fmap . fmap 
---
-pushR2 :: (a -> a1) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a1)
-pushR2 = fmap . fmap . fmap
-
-
-
-
-apply1R1 :: CF (r1 -> a) -> r1 -> CF a
-apply1R1 mf r1 = CF $ \ctx -> getCF mf ctx r1
-
-
-apply1R2 :: CF (r1 -> r2 -> a) -> r2 -> CF (r1 -> a)
-apply1R2 mf r2 = CF $ \ctx r1 -> getCF mf ctx r1 r2
-
-
-apply2R2 :: CF (r1 -> r2 -> a) -> r1 -> r2 -> CF a
-apply2R2 mf r1 r2 = CF $ \ctx -> getCF mf ctx r1 r2
-
-
-lift0R1             :: CF a -> CF (r1 -> a)
-lift0R1 mf          = CF $ \ctx _ -> getCF mf ctx
-
-lift0R2             :: CF a -> CF (r1 -> r2 -> a)
-lift0R2 mf          = CF $ \ctx _ _ -> getCF mf ctx
-
-lift1R2             :: CF (r1 -> a) -> CF (r1 -> r2 -> a)
-lift1R2 mf          = CF $ \ctx r1 _ -> getCF mf ctx r1
-
-
-
-
-uconvR0 :: (FontSize -> ans -> ans1)  -> CF ans -> CF ans1
-uconvR0 post df = CF $ \ctx ->
-    let sz = dc_font_size ctx 
-    in post sz $ getCF df ctx
-
-
-uconvR1 :: (Functor t, InterpretUnit u, InterpretUnit u1) 
-        => (FontSize -> ans -> ans1) 
-        -> CF (t u -> ans) -> CF (t u1 -> ans1)
-uconvR1 post df = CF $ \ctx r1 -> 
-    let sz = dc_font_size ctx 
-    in post sz $ getCF df ctx (uconvertF sz r1)
-
-
-uconvR2a :: (Functor t, InterpretUnit u, InterpretUnit u1) 
-         => (FontSize -> ans -> ans1)
-         -> CF (t u -> r2 -> ans) -> CF (t u1 -> r2 -> ans1)
-uconvR2a post df = CF $ \ctx r1 r2 -> 
-    let sz = dc_font_size ctx 
-    in post sz $ getCF df ctx (uconvertF sz r1) r2
-
-
-
-uconvR2ab :: (Functor t1, Functor t2, InterpretUnit u, InterpretUnit u1) 
-          => (FontSize -> ans -> ans1)
-          -> CF (t1 u -> t2 u ->  ans) -> CF (t1 u1 -> t2 u1 -> ans1)
-uconvR2ab post df = CF $ \ctx r1 r2 -> 
-    let sz = dc_font_size ctx 
-    in post sz $ getCF df ctx (uconvertF sz r1) (uconvertF sz r2)
-
-
-
--- | Extract the drawing context from a CtxFun.
---
--- > (ctx -> ctx)
--- 
-drawingCtx      :: Query DrawingContext
-drawingCtx      = CF $ \ctx -> ctx
-
-
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
@@ -47,8 +47,6 @@
   , getFontFace
   , getTextColour
 
-  , markHeight
-  , markHalfHeight
   , textlineSpace
 
   -- * Glyph metrics
@@ -78,7 +76,6 @@
 import Wumpus.Basic.Kernel.Base.FontSupport
 
 import Wumpus.Core                              -- package: wumpus-core
-import qualified Wumpus.Core.FontSize   as FS
  
 import Control.Applicative
 
@@ -185,23 +182,6 @@
 
 getTextColour   :: DrawingCtxM m => m RGBi
 getTextColour   = asksDC dc_text_colour
-
-
--- | The /mark/ height is the height of a lowercase letter in the 
--- Courier font at the current point size.
---
--- Arrowheads, dots etc. should generally be drawn at the mark 
--- height.
--- 
-markHeight :: (DrawingCtxM m, InterpretUnit u) => m u
-markHeight = post <$> asksDC dc_font_size 
-  where
-    post sz = dinterp sz (FS.xcharHeight sz)
-
-
-
-markHalfHeight :: (Fractional u, DrawingCtxM m, InterpretUnit u) => m u
-markHalfHeight = (0.5*) <$> markHeight
 
 
 
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
@@ -24,30 +24,32 @@
 module Wumpus.Basic.Kernel.Base.UpdateDC
   ( 
 
-  -- * Modifiers       
+  -- * Globals
     snap_grid_factors
 
-  -- ** Line widths
+  -- * Line widths
   , set_line_width
 
   , line_default
   , line_thin
   , line_thick
   , line_ultra_thick
+  
+  , relative_line_width
 
-  -- ** Line caps
+  -- * Line cap
   , cap_default
   , cap_butt
   , cap_round
   , cap_square
 
-  -- ** Line joins
+  -- * Line join
   , join_default
   , join_miter
   , join_round
   , join_bevel
 
-  -- ** Dash Pattern
+  -- * Dash pattern
   , set_dash_pattern
 
   , solid_line
@@ -63,14 +65,13 @@
   , font_attr
   , set_font
   , set_font_size
-
-
-  -- * Font / mark drawing size
   , scale_point_size
 
   , double_point_size
   , half_point_size
 
+
+  -- * Text margins
   , text_margin
   , text_margin_none
   , text_margin_tight
@@ -187,7 +188,16 @@
 line_ultra_thick    = set_line_width 4.0
 
 
+
+-- | Set the line width to a size relative to the current font 
+-- size. The size is calculated with the supplied function.
 --
+relative_line_width :: (FontSize -> Double) -> DrawingContextF
+relative_line_width fn = 
+    withFontSize $ \sz s -> set_line_width (fn sz) s
+
+
+--
 -- All options share the prefix so the enumeration is obvious...
 --
 
@@ -211,10 +221,14 @@
 
 -- | Set the line_cap to @butt@.
 --
--- Butt squares of the stroke at the end point.
+-- Butt chamfers off the stroke, flush to the end point.
 --
 -- This is the default.
 --
+-- >  .-------.
+-- >  |=======|
+-- >  '-------'
+--
 cap_butt            :: DrawingContextF
 cap_butt            = setLineCap CapButt
 
@@ -223,15 +237,23 @@
 -- This rounds the end of the stroke and the visually the 
 -- rounding slightly extends the length of the line.
 --
+-- >  .-------.
+-- > ( ======= )
+-- >  '-------'
+--
 cap_round           :: DrawingContextF
 cap_round           = setLineCap CapRound
 
 
 -- | Set the line_cap to @square@.
 --
--- This squares off the end of the stroke, visually extending 
--- the stroke by half the line width.
+-- This squares off the end of the stroke, but visual extends the 
+-- stroke by half the line width.
 --
+-- >  .---------.
+-- >  | ======= |
+-- >  '---------'
+--
 cap_square          :: DrawingContextF
 cap_square          = setLineCap CapSquare
 
@@ -251,6 +273,12 @@
 --
 -- This is the default.
 --
+-- >      /\
+-- >     /..\ 
+-- >    /./\.\
+-- >   /./  \.\
+-- >  /./    \.\
+--
 join_miter          :: DrawingContextF
 join_miter          = setLineJoin JoinMiter
 
@@ -259,6 +287,12 @@
 --
 -- This rounds off the corner of the joined line segments.
 --
+-- >  \.\  
+-- >   \.\ 
+-- >    ,.)
+-- >   /./
+-- >  /./
+--
 join_round          :: DrawingContextF
 join_round          = setLineJoin JoinRound
 
@@ -268,6 +302,12 @@
 -- This bevels off the corner of the joined line segments with a 
 -- notch.
 --
+-- >      __
+-- >     /..\ 
+-- >    /./\.\
+-- >   /./  \.\
+-- >  /./    \.\
+--
 join_bevel          :: DrawingContextF
 join_bevel          = setLineJoin JoinBevel
 
@@ -403,7 +443,7 @@
 
 -- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @
 --
--- NOTE - ideally this would use Em or En rather thn Double...
+-- Note - this is in @Em@ units.
 --
 text_margin   :: Em -> Em -> DrawingContextF
 text_margin xsep ysep = \s -> 
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
@@ -13,13 +13,14 @@
 --
 -- Wrapped versions of the @Primitive@ type from Wumpus-Core.
 --
+-- This file is essentially /internal/ to Wumpus-Basic.
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Base.WrappedPrimitive
   (
 
 
-
   -- * Primitives
     CatPrim
   , prim1
@@ -29,9 +30,6 @@
   , hprimToList
   , singleH
 
-
-
-
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
@@ -44,9 +42,11 @@
 
 
 
--- | CatPrim could probably manage happily just being a
--- Primitive, but it is wrapped as a newtype...
+-- | A wrapped version of 'Primitive' from Wumpus-Core that 
+-- supports Monoid.
 --
+-- This type is essentially internal to Wumpus-Basic.
+--
 data CatPrim = CZero
              | Cat1 Primitive
 
@@ -64,6 +64,11 @@
   a      `mappend` CZero  = a
   Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b
 
+  mconcat []      = mempty
+  mconcat (a:as)  = step a as
+    where
+      step ac []     = ac
+      step ac (x:xs) = step (ac `mappend` x) xs
 
 
 --------------------------------------------------------------------------------
@@ -90,6 +95,8 @@
 prim1 :: Primitive -> CatPrim 
 prim1 = Cat1
 
+
+-- | Map 
 cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim
 cpmap _ CZero    = CZero
 cpmap f (Cat1 a) = Cat1 $ f a
@@ -97,6 +104,7 @@
 --------------------------------------------------------------------------------
 -- 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 
@@ -111,11 +119,8 @@
 -- representation, and a Hughes list which supports
 -- efficient concatenation is wise.
 --
--- NOTE - currently HPrim has a phantom unit @u@, this is so 
--- trace drawings can have a unit type, but this may change as 
--- perhaps trace drawings don\'t benefit from having units.
---
-
+-- This type is essentially internal to Wumpus-Basic.
+-- 
 newtype HPrim u = HPrim { getHPrim :: H Primitive }
 
 -- Note - only a Monoid instance for HPrim - they cannot be 
@@ -125,11 +130,21 @@
   mempty          = HPrim emptyH
   ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb
 
+  mconcat []      = mempty
+  mconcat (a:as)  = step a as
+    where
+      step ac []     = ac
+      step ac (x:xs) = step (ac `mappend` x) xs
 
+
+-- | Extract the internal list of 'Primitive' from a 'HPrim'.
+--
 hprimToList :: HPrim u -> [Primitive]
 hprimToList = toListH . getHPrim
 
 
+-- | Form a 'HPrim' from a 'CatPrim'.
+--
 singleH :: CatPrim -> HPrim u
 singleH CZero    = HPrim emptyH
 singleH (Cat1 a) = HPrim $ wrapH a
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
@@ -19,19 +19,23 @@
 module Wumpus.Basic.Kernel.Objects.AdvObject
   (
 
+
+  -- * Advance vector
+    AdvanceVec
+  , advanceH
+  , advanceV
+
+
   -- * Advance-vector object and graphic
-    AdvObject
+  , AdvObject
   , DAdvObject
   
-  , AdvGraphic
-  , DAdvGraphic
+  , runAdvObject
 
   , makeAdvObject
   , emptyAdvObject
-
-  , runAdvObjectR0
-  , runAdvObjectR1
-
+  , blankAdvObject
+  
 
   -- * Composition
   , advance
@@ -46,10 +50,9 @@
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.Basis
-import Wumpus.Basic.Kernel.Objects.Displacement
-import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Kernel.Objects.LocImage
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -62,45 +65,86 @@
 
 
 
-type AdvDraw u = Point2 u -> GraphicAns u
 
+--------------------------------------------------------------------------------
 
+-- | Advance vectors provide an idiom for drawing consecutive
+-- graphics. PostScript uses them to draw left-to-right text - 
+-- each character has an advance vector for the width and 
+-- as characters are drawn they successively displace the start
+-- point for the next character with their advance vector.
+--
+-- Type alias for Vec2.
+--
+type AdvanceVec u = Vec2 u
+
+
+-- | Extract the horizontal component of an advance vector.
+--
+-- For left-to-right latin text, the vertical component of an
+-- advance vector is expected to be 0. Ingoring it seems 
+-- permissible when drawing text.
+--
+advanceH :: AdvanceVec u -> u
+advanceH (V2 w _)  = w
+
+-- | Extract the verticall component of an advance vector.
+--
+advanceV :: AdvanceVec u -> u
+advanceV (V2 _ h)  = h
+
+
+--------------------------------------------------------------------------------
+-- AdvObject
+
+type AdvDraw u = Point2 u -> CatPrim
+
+
+
 -- | /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 :: CF (Vec2 u, AdvDraw u) }
+newtype AdvObject u = AdvObject { getAdvObject :: Query u (Vec2 u, AdvDraw u) }
 
 type instance DUnit (AdvObject u) = u
 
 type DAdvObject     = AdvObject Double
 
 
-type AdvGraphic u       = LocImage u (Vec2 u)
-type DAdvGraphic        = AdvGraphic Double
 
 
 --------------------------------------------------------------------------------
 
 instance (InterpretUnit u) => Monoid (AdvObject u) where
-  mempty  = emptyAdvObject
+  mempty  = blankAdvObject (V2 0 0)
   mappend = advplus
 
 
+-- | Run an 'AdvObject' turning it into an '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)
+
+
 -- | 'makeAdvObject' : @ loc_context_function * graphic -> AdvObject @
 --
 -- Build an 'AdvObject' from a context function ('CF') that 
 -- generates the answer displacement vector and a 'LocGraphic' 
 -- that draws the 'AdvObject'.
 --
-makeAdvObject :: Query (Vec2 u) -> LocGraphic u -> AdvObject u
-makeAdvObject qvec gf = AdvObject body
+makeAdvObject :: Query u (Vec2 u) -> LocGraphic u -> AdvObject u
+makeAdvObject mq gf = AdvObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let v1   = runCF ctx qvec
-               pf   = runCF ctx gf
+    body = askDC >>= \ctx -> 
+           let v1   = runQuery ctx mq
+               pf   = \pt -> getCP $ runLocImage pt ctx gf
            in return (v1,pf)
 
+    getCP (PrimW ca _) = ca
 
 
 -- | 'emptyAdvObjectAU' : @ AdvObject @
@@ -112,45 +156,62 @@
 -- the zero vector @(V2 0 0)@.
 -- 
 emptyAdvObject :: InterpretUnit u => AdvObject u
-emptyAdvObject = makeAdvObject (pure $ V2 0 0) emptyLocGraphic
+emptyAdvObject = blankAdvObject (V2 0 0)
 
 
+blankAdvObject :: Vec2 u -> AdvObject u
+blankAdvObject v1 = AdvObject $ pure (v1, const mempty)
 
-runAdvObjectR0 :: Point2 u -> AdvObject u -> Image u (Vec2 u)
-runAdvObjectR0 pt (AdvObject mf) =  
-   (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf
 
 
-runAdvObjectR1 :: AdvObject u -> AdvGraphic u
-runAdvObjectR1 (AdvObject mf) = promoteR1 $ \pt -> 
-   (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf
 
 
 --------------------------------------------------------------------------------
 -- 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 vecots.
+-- both advance vectors.
 --
 advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u
 advplus a b = AdvObject body
   where 
-    body = drawingCtx >>= \ctx ->
-           let (v0,pf0) = runCF ctx (getAdvObject a)
-               (v1,pf1) = runCF ctx (getAdvObject b)
-               pf       = \pt -> pf0 pt `oplus` pf1 (pt .+^ v0)
-           in return (v0 ^+^ v1, pf)
+    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 _ []     = emptyAdvObject
+listcat _ []     = mempty
 listcat op (x:xs) = go x xs
   where
     go acc []     = acc
@@ -186,13 +247,9 @@
 -- object. 
 --
 advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u
-advspace sep a b = AdvObject body
-  where 
-    body = drawingCtx >>= \ctx ->
-           let (v0,pf0) = runCF ctx (getAdvObject a)
-               (v1,pf1) = runCF ctx (getAdvObject b)
-               pf       = \pt -> pf0 pt `oplus` pf1 (displaceVec (sep ^+^ v0) pt)
-           in return (v0 ^+^ sep ^+^ v1, pf)
+advspace sep a b = a `advplus` blank `advplus` b
+  where
+    blank = blankAdvObject sep
 
 -- | List version of 'nextSpace'.
 --
@@ -223,8 +280,8 @@
 advfill :: Num u => Vec2 u -> AdvObject u -> AdvObject u
 advfill sv a = AdvObject body
   where 
-    body = drawingCtx >>= \ctx ->
-           let (_,pf) = runCF ctx (getAdvObject a) in return (sv, pf)
-
+    body = askDC >>= \ctx ->
+           let (_,df) = runQuery ctx (getAdvObject a)
+           in return (sv,df)
 
 
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,47 +21,43 @@
 module Wumpus.Basic.Kernel.Objects.Basis
   (
 
-    LocQuery
-  , LocThetaQuery
-  , ConnectorQuery 
+    PrimW(..)
+  , primAnswer
 
-  , GraphicAns
-  , ImageAns(..)
+  , Image
+  , Graphic 
 
-  , graphicAns
-  , mapAns
-  , replaceAns
-  , ignoreAns
-  , answer
-  , hyperlink  
-  , clipObject 
-  
-  , szconvAnsF
-  , szconvAnsZ
+  , Query
 
+  , DImage
+  , DGraphic
 
-  , at
-  , incline
-  , atIncline
-  , connect
+  , runImage
+  , runQuery
+  , zapQuery
 
-  , replaceAnsR0
-  , replaceAnsR1
-  , replaceAnsR2
+  , primGraphic
+  , clipImage
 
-  , decorateR0
-  , decorateR1
-  , decorateR2
+  , UConvert(..)
+  , uconvImageF
+  , uconvImageZ
 
-  , elaborateR0
-  , elaborateR1
-  , elaborateR2
-  
+  , emptyImage
 
+
+  , both
+
+  , ignoreAns
+  , replaceAns
+
+  , Decorate(..)
+
+
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -71,494 +67,360 @@
 import Data.Monoid
 
 
-type LocQuery u a               = CF (Point2 u -> a)
-type LocThetaQuery u a          = CF (Point2 u -> Radian -> a)
-type ConnectorQuery u a         = CF (Point2 u -> Point2 u -> a)
 
+-- | Unit @u@ is a phantom.
+--
+data PrimW u a = PrimW CatPrim a
 
--- Design note - GraphicAns needs a unit for consistency even 
--- though it is never scrutinized.
--- 
+type instance DUnit (PrimW u a) = u
 
 
-data ImageAns u a = Ans CatPrim a
+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)
 
-type GraphicAns u = ImageAns u (UNil u)
+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) 
 
-type instance DUnit (ImageAns u a) = u
 
+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
 
---------------------------------------------------------------------------------
--- OPlus and monoid
 
+primAnswer :: PrimW u a -> a
+primAnswer (PrimW _ a) = a
 
-instance OPlus a => OPlus (ImageAns u a) where
-  Ans cp0 a `oplus` Ans cp1 b = Ans (cp0 `oplus` cp1) (a `oplus` b)
 
+-- | 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)
 
-instance Monoid a => Monoid (ImageAns u a) where
-  mempty                        = Ans mempty mempty
-  Ans cp0 a `mappend` Ans cp1 b = Ans (cp0 `mappend` cp1) (a `mappend` b)
 
 
---------------------------------------------------------------------------------
--- Affine instances 
 
--- 
--- Design Note
---
--- Translate and RotateAbout require the unit to be /scalar/ 
--- e.g. Double, Centimeter, Pica.
---
--- This is annoying and a limitation, but an alternative would
--- need access to current-font-size which cannot be a pure 
--- function.
--- 
 
-instance Rotate a => Rotate (ImageAns u a) where
-  rotate ang (Ans cp a) = Ans (rotate ang cp) (rotate ang a)
 
 
-instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => 
-    RotateAbout (ImageAns u a) where
-  rotateAbout ang pt@(P2 x y) (Ans cp a) = 
-    Ans (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) cp)
-        (rotateAbout ang pt a) 
-        
-
-
-instance Scale a => Scale (ImageAns u a) where
-  scale sx sy (Ans cp a) = Ans (scale sx sy cp) (scale sx sy a)
+-- | 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)
 
 
-instance (Translate a, ScalarUnit u, u ~ DUnit a) => 
-    Translate (ImageAns u a) where
-  translate dx dy (Ans cp a) = 
-    Ans (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy 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 }
 
--- | Map the answer produced by a graphic object.
---
--- Note - the new answer must share the same unit type as the
--- initial answer, although it does not need to have the same
--- wrapper type.
---
-mapAns :: (a -> a1) -> ImageAns u a -> ImageAns u a1
-mapAns f (Ans cp a) = Ans cp (f a) 
+type instance DUnit (Image u a) = u
 
+type Graphic u = Image u (UNil u)
 
 
--- | Replace the answer produced by a graphic object.
+-- | Type specialized version of 'Image'.
 --
--- Note - the new answer must share the same unit type as the
--- initial answer, although it does not need to have the same
--- wrapper type.
+type DImage a       = Image Double a
+
+-- | Type specialized version of 'Graphic'.
 --
-replaceAns :: ans -> ImageAns u a -> ImageAns u ans
-replaceAns ans (Ans prim _) = Ans prim ans
+type DGraphic       = Graphic Double 
 
 
--- | Turn an imageAns into a GraphicAns by ignoring the 
--- result.
--- 
--- Usually this function will be used with one of the @push@ 
--- family of combinators.
---
--- > LocImage-to-LocGraphic = pushR1 ignoreAns 
---
-ignoreAns :: ImageAns u a -> GraphicAns u
-ignoreAns(Ans prim _) = Ans prim UNil
+newtype Query u a = Query { 
+          getQuery :: DrawingContext -> a }
 
+type instance DUnit (Query u a) = u
 
+-- Functor
 
-graphicAns :: CatPrim -> GraphicAns u
-graphicAns prim = Ans prim UNil
+instance Functor (Image u) where
+  fmap f ma = Image $ \ctx -> fmap f $ getImage ma ctx
 
--- | Extractor for the answer part of an image.
---
-answer :: ImageAns u a -> a
-answer (Ans _ a) = a
+instance Functor (Query u) where
+  fmap f ma = Query $ \ctx -> f $ getQuery ma ctx
 
+-- Applicative
 
--- | Note - maybe this requires an arity family instead?
---
-hyperlink :: XLink -> ImageAns u a -> ImageAns u a
-hyperlink hypl (Ans prim a) = Ans (cpmap (xlinkPrim hypl) prim) a
+instance Applicative (Image u) where
+  pure a    = Image $ \_   -> pure a
+  mf <*> ma = Image $ \ctx -> 
+                getImage mf ctx <*> getImage ma ctx
 
+instance Applicative (Query u) where
+  pure a    = Query $ \_   -> a
+  mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx 
+                                  a = getQuery ma ctx
+                              in f a
 
--- | Clip a graphic object.
--- 
--- Note - maybe this requires an arity family instead?
---
-clipObject :: PrimPath -> ImageAns t u -> ImageAns t u
-clipObject pp (Ans prim a) =  Ans (cpmap (clip pp) prim) a
 
+-- Monad
 
---------------------------------------------------------------------------------
--- Helpers for unit conversion...
+instance Monad (Image u) where
+  return a = Image $ \_ -> return a
+  ma >>= k = Image $ \ctx -> getImage ma ctx >>= \ans -> getImage (k ans) ctx
 
 
+instance Monad (Query u) where
+  return a = Query $ \_   -> a
+  ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx
 
-szconvAnsF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
-                => FontSize -> ImageAns u (t u) -> ImageAns u1 (t u1)
-szconvAnsF sz (Ans prim a) = Ans prim (uconvertF sz a)
+-- Monoid
 
-szconvAnsZ :: FontSize -> ImageAns u a -> ImageAns u1 a
-szconvAnsZ _ (Ans prim a) = Ans prim a
+instance Monoid a => Monoid (Image u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = Image $ \ctx -> 
+                      getImage ma ctx `mappend` getImage mb ctx
 
+instance Monoid a => Monoid (Query u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = Query $ \ctx -> 
+                      getQuery ma ctx `mappend` getQuery mb ctx
 
 
-infixr 1 `at`
+-- DrawingCtxM
 
 
--- | Downcast a 'LocCF' function by applying it to the supplied 
--- point, making an arity-zero Context Function. 
--- 
--- Remember a 'LocCF' function is a 'CF1' context function where
--- the /static argument/ is specialized to a start point.
---
-at :: LocQuery u a -> Point2 u -> CF a
-at = apply1R1
+instance DrawingCtxM (Image u) where
+  askDC           = Image $ \ctx -> return ctx
+  asksDC fn       = Image $ \ctx -> return (fn ctx)
+  localize upd ma = Image $ \ctx -> getImage ma (upd ctx)
 
+instance DrawingCtxM (Query u) where
+  askDC           = Query $ \ctx -> ctx
+  asksDC fn       = Query $ \ctx -> (fn ctx)
+  localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)
 
 
-infixr 1 `incline`
+runImage :: DrawingContext -> Image u a -> PrimW u a
+runImage ctx mf = getImage mf ctx
 
+runQuery :: DrawingContext -> Query u a -> a
+runQuery ctx mf = getQuery mf ctx
 
--- | Downcast a 'LocThetaQuery' function by applying it to the 
--- supplied angle, making an arity-one Context Function (a 
--- 'LocCF'). 
--- 
-incline :: LocThetaQuery u a -> Radian -> LocQuery u a
-incline = apply1R2
 
 
--- | Downcast a LocThetaQuery function by applying it to the 
--- supplied point and angle, making an arity-zero Context Function 
--- (a CF). 
+zapQuery :: Query u a -> Image u a
+zapQuery mq = askDC >>= \ctx -> let a = runQuery ctx mq in return a
+
+-- | Constructor for Primtive graphics.
 --
-atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a
-atIncline = apply2R2
+primGraphic :: CatPrim -> Graphic u
+primGraphic ca = Image $ \_ -> PrimW ca UNil
 
 
--- | Downcast a 'ConnectorQuery' function by applying it to the 
--- start and end point, making an arity-zero Context Function 
--- (a 'CF'). 
+-- | Clip an Image.
 -- 
-connect :: ConnectorQuery u a -> Point2 u -> Point2 u -> CF a
-connect = apply2R2
+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
 
 
 
--- | Replace the ans - arity 0.
--- 
-replaceAnsR0 :: ans -> CF (ImageAns u a) -> CF (ImageAns u ans)
-replaceAnsR0 ans = fmap (replaceAns ans)
+class UConvert (f :: * -> * -> *) where
+  uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
+         => f u (t u) -> f u1 (t u1)
 
+  uconvZ :: (InterpretUnit u, InterpretUnit u1) 
+         => f u a -> f u1 a
 
--- | Replace the ans - arity 1.
---
-replaceAnsR1 :: ans -> CF (r1 -> ImageAns u a) -> CF (r1 -> ImageAns u ans)
-replaceAnsR1 ans = fmap $ fmap (replaceAns ans)
+instance UConvert Image where
+  uconvZ = uconvImageZ
+  uconvF = uconvImageF
 
+uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
+            => Image u (t u) -> Image u1 (t u1) 
+uconvImageF ma = Image $ \ctx -> 
+                   let sz  = dc_font_size ctx
+                       ans = getImage ma ctx
+                   in szconvPrimF sz ans
 
--- | Replace the ans - arity 2.
---
-replaceAnsR2 :: ans 
-             -> CF (r1 -> r2 -> ImageAns u a) 
-             -> CF (r1 -> r2 -> ImageAns u ans)
-replaceAnsR2 ans = fmap $ fmap $ fmap (replaceAns ans) 
 
+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
 
--- | Decorate an Image by superimposing a Graphic.
---
--- Note - this function has a very general type signature and
--- supports various graphic types:
---
-decorateR0 :: CF (ImageAns u a) -> CF (GraphicAns u) -> CF (ImageAns u a) 
-decorateR0 img gf = op <$> img <*> gf
-  where
-    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a
 
+-- | Having /empty/ at the specific 'Image' type is useful.
+-- 
+emptyImage :: Monoid a => Image u a
+emptyImage = mempty
 
-decorateR1 :: CF (r1 -> ImageAns u a) 
-           -> CF (r1 -> GraphicAns u) 
-           -> CF (r1 -> ImageAns u a) 
-decorateR1 img gf = promoteR1 $ \r1 ->
-    op <$> apply1R1 img r1 <*> apply1R1 gf r1
-  where
-    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a
+--------------------------------------------------------------------------------
 
 
-decorateR2 :: CF (r1 -> r2 -> ImageAns u a) 
-           -> CF (r1 -> r2 -> GraphicAns u) 
-           -> CF (r1 -> r2 -> ImageAns u a) 
-decorateR2 img gf = promoteR2 $ \r1 r2 ->
-    op <$> apply2R2 img r1 r2 <*> apply2R2 gf r1 r2
-  where
-    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a
+both :: Applicative f => f a -> f b -> f (a,b)
+both fa fb = (,) <$> fa <*> fb
 
 
--- | Decorate an Image by superimposing a Graphic.
+-- | Note - the kind of f allows fo unit annotation.
 --
--- Note - this function has a very general type signature and
--- supports various graphic types:
+ignoreAns :: Functor (f u) => f u a -> f u (UNil u)
+ignoreAns = fmap (const UNil)
+
+-- | Replace the answer produced by a graphic object.
 --
-elaborateR0 :: CF (ImageAns u a) -> (a -> CF (GraphicAns u)) -> CF (ImageAns u a) 
-elaborateR0 img gf = 
-    img  >>= \(Ans p1 a) ->
-    gf a >>= \(Ans p2 _) -> 
-    return $ Ans (p1 `oplus` p2) a
+replaceAns :: Functor (f u) => a -> f u z -> f u a
+replaceAns a = fmap (const a)
 
 
 
 
--- | Decorate an Image by superimposing a Graphic.
+-- | Decorate an object
 --
--- Note - this function has a very general type signature and
--- supports various graphic types:
+-- oliterate - drops the graphic from the first object replacing 
+-- it with the graphic from the second.
 --
-elaborateR1 :: CF (r1 -> ImageAns u a) 
-            -> (a -> CF (r1 -> GraphicAns u)) 
-            -> CF (r1 -> ImageAns u a) 
-elaborateR1 img gf = promoteR1 $ \r1 -> 
-    apply1R1 img r1    >>= \(Ans p1 a) ->
-    apply1R1 (gf a) r1 >>= \(Ans p2 _) -> 
-    return $ Ans (p1 `oplus` p2) a
-
-
-
-elaborateR2 :: CF (r1 -> r2 -> ImageAns u a) 
-            -> (a -> CF (r1 -> r2 -> GraphicAns u)) 
-            -> CF (r1 -> r2 -> ImageAns u a) 
-elaborateR2 img gf = promoteR2 $ \r1 r2 -> 
-    apply2R2 img r1 r2    >>= \(Ans p1 a) ->
-    apply2R2 (gf a) r1 r2 >>= \(Ans p2 _) -> 
-    return $ Ans (p1 `oplus` p2) a
-
-
+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
+  hyperlink  :: XLink -> f u a -> f u a
 
 
-{-
-
--- Not exported - thanks to Max Bollingbroke.
+-- | Do not export...
 --
-type family   GuardEqAns a b :: *
-type instance GuardEqAns a a = a
+getCatPrim :: PrimW u a -> CatPrim
+getCatPrim (PrimW ca _) = ca
 
--- | An Image always returns a pair of some polymorphic answer @a@
--- and a PrimGraphic.
+-- | Should a decoration \"lift\" a query (Pure) to an image (PrimW)? 
 --
-data ImageAns t u       = Ans (t u) CatPrim
+-- Currently I don\'t think it should.
+--
+decorateImage :: Image u a -> Image u z -> Image u a
+decorateImage ma mb = Image $ \ctx -> 
+    step (getImage ma ctx) (getImage mb ctx)
+  where
+    step (PrimW ca a) (PrimW cb _) = PrimW (ca `mappend` cb) a
 
-type instance DUnit (ImageAns t u) = GuardEqAns u (DUnit (t u))
 
-type GraphicAns u       = ImageAns UNil u
+-- |
+--
+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
 
+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
+  
+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
 
-instance Functor t => Functor (ImageAns t) where
-  fmap f (Ans a prim) = Ans (fmap f a) prim
 
-instance OPlus (t u) => OPlus (ImageAns t u) where
-  Ans a p1 `oplus` Ans b p2 = Ans (a `oplus` b) (p1 `oplus` p2)
 
-
+instance Decorate Image where
+  decorate    = decorateImage
+  elaborate   = elaborateImage  
+  obliterate  = obliterateImage
+  hyperlink   = hyperlinkImage
+  
 --------------------------------------------------------------------------------
 -- Affine instances 
 
 -- 
 -- Design Note
 --
--- Translate and RotateAbout require the unit to be /scalar/ 
--- e.g. Double, Centimeter, Pica.
---
--- This is annoying and a limitation, but an alternative would
--- need access to current-font-size which cannot be a pure 
--- function.
+-- Are PrimW instances needed as Image cannot use them?
 -- 
 
-instance Rotate (t u) => Rotate (ImageAns t u) where
-  rotate ang (Ans a p) = Ans (rotate ang a) (rotate ang p)
+instance Rotate a => Rotate (PrimW u a) where
+  rotate ang (PrimW ca a) = PrimW (rotate ang ca) (rotate ang a)
 
 
-instance (RotateAbout (t u), ScalarUnit u, u ~ DUnit (t u)) => 
-    RotateAbout (ImageAns t u) where
-  rotateAbout ang pt@(P2 x y) (Ans a p) = 
-    Ans (rotateAbout ang pt a) 
-        (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) p)
+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 (t u) => Scale (ImageAns t u) where
-  scale sx sy (Ans a p) = Ans (scale sx sy a) (scale sx sy p)
+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 (t u), ScalarUnit u, u ~ DUnit (t u)) => 
-    Translate (ImageAns t u) where
-  translate dx dy (Ans a p) = 
-    Ans (translate dx dy a) (translate (toPsPoint dx) (toPsPoint dy) p)
+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)
 
--- | Ignore the answer produced by an Image (or LocImage, etc.)
--- and form a Graphic instead.
---
-ignoreAns :: Functor f
-          => cf (ImageAns t u) -> cf (GraphicAns u)
-ignoreAns = fmap (\(Ans _ prim) -> Ans UNil prim)
 
+instance Rotate a => Rotate (Image u a) where
+  rotate ang ma = Image $ \ctx -> 
+      bimapPrimW (rotate ang) (rotate ang) $ getImage ma ctx
 
 
--- | Replace the answer produced by a graphic object.
---
--- Note - the new answer must share the same unit type as the
--- initial answer, although it does not need to have the same
--- wrapper type.
---
-replaceAns :: Functor cf
-          => t1 u -> cf (ImageAns t u) -> cf (ImageAns t1 u)
-replaceAns ans = fmap (\(Ans _ prim) -> Ans ans prim)
+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
 
 
--- | Map the answer produced by a graphic object.
---
--- Note - the new answer must share the same unit type as the
--- initial answer, although it does not need to have the same
--- wrapper type.
---
-mapAns :: Functor cf
-       => (t u -> t1 u) -> cf (ImageAns t u) -> cf (ImageAns t1 u)
-mapAns f = fmap (trafoImageAns f id) 
+instance Scale a => Scale (Image u a) where
+  scale sx sy ma = Image $ \ctx -> 
+      bimapPrimW (scale sx sy) (scale sx sy) $ getImage ma ctx
 
+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
 
 
--- | Transform both the answer produced by a graphic object and 
--- transform the primitive drawing.
---
--- Note - the new answer must share the same unit type as the
--- initial answer, although it does not need to have the same
--- wrapper type. Also this function is specifically exposed to
--- enable affine transofrmations - it is not expected to be 
--- generally useful.
---
-trafoImageAns :: (t u -> t1 u) -> (CatPrim -> CatPrim) 
-              -> ImageAns t u -> ImageAns t1 u
-trafoImageAns f g (Ans a prim) = Ans (f a) (g prim)
+--------------------------------------------------------------------------------
 
 
--- | Decorate an Image by superimposing a Graphic.
---
--- Note - this function has a very general type signature and
--- supports various graphic types:
---
--- > decorate :: Image u a -> Graphic u -> Image u a
--- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a
--- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
---
-decorate :: Monad cf
-         => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) 
-decorate img gf = combind const img (const gf) 
 
 
--- | Ante-decorate - version of 'decorate' where the decoration is 
--- drawn behind the Image.
---
-adecorate :: Monad cf
-          => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) 
-adecorate img gf = acombind const img (const gf)
 
-
--- | Version of 'elaborate' where the decorating Graphic has access 
--- to the result produced by the Image.
---
--- Again, this function has a very general type signature and
--- supports various graphic types:
---
--- > elaborate :: Image u a -> Graphic u -> Image u a
--- > elaborate :: LocImage u a -> LocGraphic u -> LocImage u a
--- > elaborate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
---
-elaborate :: Monad cf 
-          => cf (ImageAns t u) 
-          -> (t u -> cf (GraphicAns u)) 
-          -> cf (ImageAns t u)
-elaborate img gf = combind const img gf
+{-
 
--- | Ante-elaborate - version of 'elaborate' where the decoration 
--- is drawn behind the Image.
---
-aelaborate :: Monad cf 
-           => cf (ImageAns t u) -> (t u -> cf (GraphicAns u)) -> cf (ImageAns t u)
-aelaborate img gf = acombind const img gf
+-- OLD STUFF
 
 
--- | Hyperlink a graphic object.
--- 
--- This function has a very general type signature and supports 
--- various graphic types:
---
--- > hyperlink :: XLink -> Graphic u -> Graphic u
--- > hyperlink :: XLink -> Image u a -> Image u a
--- > hyperlink :: XLink -> LocImage u a -> LocImage u a
--- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a
+-- | Downcast a LocThetaQuery function by applying it to the 
+-- supplied point and angle, making an arity-zero Context Function 
+-- (a CF). 
 --
-hyperlink :: Functor cf 
-          => XLink -> cf (ImageAns t u) -> cf (ImageAns t u)
-hyperlink hypl = 
-    fmap (\(Ans a prim) -> Ans a (cpmap (xlinkPrim hypl) prim))
-
-
--- | Clip a graphic object.
--- 
-clipObject :: Functor cf 
-           => PrimPath -> cf (ImageAns t u) -> cf (ImageAns t u)
-clipObject pp = 
-    fmap (\(Ans a prim) -> Ans a (cpmap (clip pp) prim))
-
+atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a
+atIncline = apply2R2
 
 
 
--- | This is a very general monadic combiner.
--- 
--- The first argument is a pure combiner cf. @liftM2@, @liftA2@
--- 
--- The second argument is an Image to be evaluated.
---
--- The third argument, uses the ouput from the first Image to 
--- build a second Image.
--- 
--- The function concatenates the CatPrims formed by both Images
--- and uses the pure combiner to build an answer from the
--- intermediate answers.
---
--- NOTE - note useful with CF representation change.
---
-combind :: Monad cf 
-        => (t1 u -> t2 u -> t3 u)
-        -> cf (ImageAns t1 u) 
-        -> (t1 u -> cf (ImageAns t2 u)) 
-        -> cf (ImageAns t3 u) 
-combind op gf fn = gf   >>= \(Ans a p1) -> 
-                   fn a >>= \(Ans b p2) -> 
-                   return $ Ans (a `op` b) (p1 `oplus` p2)
-
-
--- | Version of combind where the drawing order is flipped.
---
-acombind :: Monad cf 
-         => (t1 u -> t2 u -> t3 u)
-         -> cf (ImageAns t1 u) 
-         -> (t1 u -> cf (ImageAns t2 u)) 
-         -> cf (ImageAns t3 u) 
-acombind op gf fn = gf   >>= \(Ans a p1) -> 
-                    fn a >>= \(Ans b p2) -> 
-                    return $ Ans (a `op` b) (p2 `oplus` p1)
-
 -}
+
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
@@ -10,12 +10,8 @@
 -- Stability   :  highly unstable
 -- Portability :  GHC 
 --
--- Bounded versions of Graphic and LocGraphic.
---
--- Bounded meaning they are actually Images that return the 
--- bounding box of the Graphic.
--- 
--- These abojects are type synonyms.
+-- Helpers for working with Images and LocImages that produce
+-- bounding boxes.
 --
 --------------------------------------------------------------------------------
 
@@ -23,19 +19,18 @@
   (
 
 
-  -- * Bounded graphic / loc graphic
+  -- * Type synonyms
     BoundedGraphic
-  , DBoundedGraphic
   , BoundedLocGraphic
-  , DBoundedLocGraphic
   , BoundedLocThetaGraphic
-  , DBoundedLocThetaGraphic
 
+  -- * Bounding box graphic helpers
+  , centerOrthoBBox
 
+
   , emptyBoundedLocGraphic
   , emptyBoundedLocThetaGraphic
 
-  , centerOrthoBBox
 
   , illustrateBoundedGraphic
   , illustrateBoundedLocGraphic
@@ -46,52 +41,25 @@
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.UpdateDC
 import Wumpus.Basic.Kernel.Objects.Basis
 import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
-import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Kernel.Objects.LocImage
 import Wumpus.Basic.Kernel.Objects.LocThetaImage
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Data.Monoid
 
 --------------------------------------------------------------------------------
 
--- | Graphic with a bounding box.
--- 
-type BoundedGraphic u      = Image u (BoundingBox u)
 
-type DBoundedGraphic       = BoundedGraphic Double
-
-
-
-
--- | LocGraphic with a bounding box.
---
-type BoundedLocGraphic u      = LocImage u (BoundingBox u)
-
-type DBoundedLocGraphic       = BoundedLocGraphic Double
-
-
--- | LocThetaGraphic with a bounding box.
---
--- Note the size of bounding box for the \"same\" shape will vary 
--- according to the rotation. A bounding box is always 
--- orthonormal (?) to the x- and y-axes.
---
+type BoundedGraphic u           = Image u (BoundingBox u)
+type BoundedLocGraphic u        = LocImage u (BoundingBox u)
 type BoundedLocThetaGraphic u   = LocThetaImage u (BoundingBox u)
 
-type DBoundedLocThetaGraphic    = BoundedLocThetaGraphic Double
 
-
-
-
-
-
-
 -- | 'centerOrthoBBox' : @ theta * bbox -> BBox @
 -- 
 -- Rotate a bounding box by @theta@ about its center. Take the 
@@ -110,37 +78,32 @@
     ps  = boundaryCornerList bb
 
 
--- | 'emptyBoundedLocGraphic' : @ BoundedLocGraphic @
---
--- Build an empty 'BoundedLocGraphic'.
+
+-- | Build an empty 'LocGraphic' returning a bounding box.
 -- 
 -- The 'emptyBoundedLocGraphic' is treated as a /null primitive/ 
 -- by @Wumpus-Core@ and is not drawn, although it does generate
 -- the minimum bounding box with both the bottom-left and 
 -- upper-right corners at the implicit start point.
 --
-emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u
-emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic
-  where
-    fn = promoteR1 $ \pt -> return $ BBox pt pt
+emptyBoundedLocGraphic :: InterpretUnit u => LocImage u (BoundingBox u)
+emptyBoundedLocGraphic = promoteLoc $ \pt -> 
+    replaceAns (BBox pt pt) $ primGraphic mempty
 
 
 
 
--- | 'emptyBoundedLocThetaGraphic' : @ BoundedLocThetaGraphic @
---
--- Build an empty 'BoundedLocThetaGraphic'.
+-- | Build an empty 'LocThetaGraphic' returning a bounding box.
 -- 
--- The 'emptyBoundedLocThetaGraphic' is treated as a /null primitive/ 
--- by @Wumpus-Core@ and is not drawn, although it does generate
--- the minimum bounding box with both the bottom-left and 
--- upper-right corners at the implicit start point (the implicit 
--- inclination can be ignored).
+-- The 'emptyBoundedLocThetaGraphic' is treated as a 
+-- /null primitive/  by @Wumpus-Core@ and is not drawn, although 
+-- it does generate the minimum bounding box with both the 
+-- bottom-left and upper-right corners at the implicit start point 
 --
-emptyBoundedLocThetaGraphic :: InterpretUnit u => BoundedLocThetaGraphic u
-emptyBoundedLocThetaGraphic = intoLocThetaImage fn emptyLocThetaGraphic
-  where
-    fn = promoteR2 $ \pt _ -> return $ BBox pt pt
+emptyBoundedLocThetaGraphic :: InterpretUnit u 
+                            => LocThetaImage u (BoundingBox u)
+emptyBoundedLocThetaGraphic = promoteLocTheta $ \pt _ -> 
+    replaceAns (BBox pt pt) $ primGraphic mempty
 
 
 --
@@ -163,18 +126,19 @@
 -- | Draw a BoundedGraphic, illustrating the bounding box.
 --
 illustrateBoundedGraphic :: InterpretUnit u
-                         => BoundedGraphic u -> BoundedGraphic u
-illustrateBoundedGraphic gf = elaborateR0 gf bbrectangle
+                         => Image u (BoundingBox u) -> Image u (BoundingBox u)
+illustrateBoundedGraphic gf = elaborate gf bbrectangle
 
 
 
 -- | Draw a BoundedLocGraphic, illustrating the bounding box.
 --
 illustrateBoundedLocGraphic :: InterpretUnit u
-                            => BoundedLocGraphic u -> BoundedLocGraphic u
-illustrateBoundedLocGraphic gf = elaborateR1 gf fn
+                            => LocImage u (BoundingBox u) 
+                            -> LocImage u (BoundingBox u)
+illustrateBoundedLocGraphic gf = elaborate gf fn
   where
-    fn bb = lift0R1 (bbrectangle bb)
+    fn bb = promoteLoc $ \_ ->bbrectangle bb
 
 
 
@@ -182,23 +146,23 @@
 -- | Draw a BoundedLocThetaGraphic, illustrating the bounding box.
 --
 illustrateBoundedLocThetaGraphic :: InterpretUnit u
-                                 => BoundedLocThetaGraphic u 
-                                 -> BoundedLocThetaGraphic u
-illustrateBoundedLocThetaGraphic gf = elaborateR2 gf fn
+                                 => LocThetaImage u (BoundingBox u)
+                                 -> LocThetaImage u (BoundingBox u)
+illustrateBoundedLocThetaGraphic gf = elaborate gf fn
   where
-    fn bb = lift0R2 (bbrectangle bb)
+    fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb
 
 
 
 
 bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u
 bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))
-    | llx == urx && lly == ury = emptyLocGraphic `at` p1
+    | llx == urx && lly == ury = mempty `at` p1
     | otherwise                = 
-        localize drawing_props $ rect1 `oplus` cross
+        localize drawing_props $ rect1 `mappend` cross
   where
     drawing_props = cap_round . dotted_line
-    rect1         = strokedRectangle (urx-llx) (ury-lly) `at` p1
+    rect1         = dcRectangle STROKE (urx-llx) (ury-lly) `at` p1
     cross         = straightLine p1 p2 
-                      `oplus` straightLine (P2 llx ury) (P2 urx lly)
+                      `mappend` straightLine (P2 llx ury) (P2 urx lly)
 
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
@@ -25,8 +25,8 @@
   , chain
   , chain_
   
-  , linear
-  , prefix
+  , linearChain
+  , prefixChain
   , iterationScheme
 
   , chainIterate
@@ -42,16 +42,14 @@
 
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Objects.Basis
 import Wumpus.Basic.Kernel.Objects.Displacement
 import Wumpus.Basic.Kernel.Objects.LocImage
-import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Utils.HList
 
 import Wumpus.Core                              -- package: wumpus-core
 
-
+import Data.Monoid
 
 -- In TikZ chains are finite node list and iterated (infite) points
 
@@ -121,37 +119,36 @@
     go (af,_) i (x:xs) | i > 0     = go (af `snocH` x, x) (i-1) xs
     go acc    _ _                  = acc
 
-
+emptyLoc :: LocGraphic u
+emptyLoc = mempty
 
 -- | Returns the end point...
 --
-chain :: InterpretUnit u 
+chain :: InterpretUnit u
       => ChainAlg u -> [LocImage u a] -> LocImage u (Point2 u)
-chain _   []      = promoteR1 $ \pt -> 
-    fmap (replaceAns pt) $ emptyLocGraphic `at` pt
-
-chain alg fs = promoteR1 $ \pt -> 
-    let ps = interpChainAlg  alg pt in go1 fs pt ps 
+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 (graphic_ $ gf `at` p) gs p ps
-    go1 _       p0 _          = fmap (replaceAns p0) $ emptyLocGraphic `at` p0
+    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 = graphic_ $ gf `at` p
-                                in go (acc `oplus` g1) gs  p ps
-    go acc _       p0 _       = fmap (replaceAns p0) acc
+    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
 
 
 -- | Returns no answer, just a 'LocGraphic'.
 chain_ :: InterpretUnit u => ChainAlg u -> [LocImage u a] -> LocGraphic u
-chain_ alg xs = locGraphic_ $ chain alg xs
+chain_ alg xs = fmap (const UNil) $ chain alg xs
 
 
-linear :: IterationScheme u -> ChainAlg u
-linear = L1
+linearChain :: IterationScheme u -> ChainAlg u
+linearChain = L1
 
-prefix :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u
-prefix n c1 c2 | n < 1     = c2
-               | otherwise = PX n c1 c2
+prefixChain :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u
+prefixChain n c1 c2 | n < 1     = c2
+                    | otherwise = PX n c1 c2
 
 
 iterationScheme :: (Point2 u -> st) 
@@ -173,7 +170,7 @@
 
 scHorizontal :: Num u => u -> IterationScheme u
 scHorizontal dx = Scheme { scheme_start = id
-                         , scheme_step  = \pt -> (displaceH dx pt, pt)
+                         , scheme_step  = \pt -> (displace (hvec dx) pt, pt)
                          }
    
 
@@ -183,7 +180,7 @@
 
 scVertical :: Num u => u -> IterationScheme u
 scVertical dy = Scheme { scheme_start = id
-                       , scheme_step  = \pt -> (displaceV dy pt, pt)
+                       , scheme_step  = \pt -> (displace (vvec dy) pt, pt)
                        }
 
 
@@ -191,15 +188,15 @@
 tableRight num_cols (col_width,row_height) = 
     L1 $ scStepper downF num_cols rightF
   where
-    downF   = displaceV $ negate row_height
-    rightF  = displaceH col_width
+    downF   = displace $ vvec $ negate row_height
+    rightF  = displace $ hvec col_width
 
 tableDown :: Num u => Int -> (u,u) -> ChainAlg u
 tableDown num_rows (col_width,row_height) = 
     L1 $ scStepper rightF num_rows downF
   where
-    downF   = displaceV $ negate row_height
-    rightF  = displaceH col_width
+    downF   = displace $ vvec $ negate row_height
+    rightF  = displace $ hvec col_width
 
 
 -- | Outer and inner steppers.
@@ -223,6 +220,6 @@
 scCircular radius angstart angseg = Scheme start step 
   where
     start pt        = (pt,angstart)
-    step (ogin,ang) = ((ogin,ang + angseg), displaceVec (avec ang radius) ogin)
+    step (ogin,ang) = ((ogin,ang + angseg), displace (avec ang radius) ogin)
 
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Connector.hs b/src/Wumpus/Basic/Kernel/Objects/Connector.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Connector.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Connector.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -24,89 +25,195 @@
    , DConnectorImage
    , DConnectorGraphic
 
-   , intoConnectorImage
-   , connectorGraphic_
+   , ConnectorQuery
 
-   , emptyConnectorGraphic
+   , runConnectorImage
+   , runConnectorQuery
+   , connect
 
-   , uconvConnectorImageF
-   , uconvConnectorImageZ
+   , promoteConn
+   , applyConn
+   , qpromoteConn
+   , qapplyConn
+   , zapConnectorQuery
 
+   , emptyConnectorImage
+
    )
 
    where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Objects.Basis
-import Wumpus.Basic.Kernel.Objects.LocImage
 
+import Wumpus.Core                              -- package: wumpus-core
 
 import Control.Applicative
+import Data.Monoid
 
 
 -- | ConnectorImage - function from DrawingContext and start and 
 -- end points to a polymorphic /answer/ and a graphic /primitive/.
 --
-type ConnectorImage u a = ConnectorQuery u (ImageAns u a)
+newtype ConnectorImage u a = ConnectorImage { 
+          getConnectorImage :: Point2 u -> Point2 u -> Image u a }
 
 
--- | ConnectorGraphic - function from DrawingContext and start and 
--- end points to a graphic /primitive/.
---
-type ConnectorGraphic u = ConnectorQuery u (GraphicAns u)
+type instance DUnit (ConnectorImage u a) = u
 
 
+
+type ConnectorGraphic u = ConnectorImage u (UNil u)
+
 -- | Type specialized version of 'ConnectorImage'.
 --
-type DConnectorImage a   = ConnectorImage Double a
+type DConnectorImage a        = ConnectorImage Double a
 
 -- | Type specialized version of 'ConnectorGraphic'.
 --
-type DConnectorGraphic   = ConnectorGraphic Double 
+type DConnectorGraphic        = ConnectorGraphic Double 
 
 
+newtype ConnectorQuery u a = ConnectorQuery { 
+          getConnectorQuery :: Point2 u -> Point2 u -> Query u a }
 
--- | 'intoConnectorImage' : @ conn_query * conn_graphic -> LocImage @
---
--- /Connector/ version of 'intoImage'. 
--- 
--- The 'ConnectorImage' is built as a function from an implicit 
--- start and end points to the answer.
---
-intoConnectorImage :: ConnectorQuery u a
-                   -> ConnectorGraphic u 
-                   -> ConnectorImage u a
-intoConnectorImage qf ma = 
-    promoteR2 $ \a b -> replaceAns <$> apply2R2 qf a b <*> apply2R2 ma a b  
 
+-- Functor 
 
--- | /Downcast/ an 'ConnectorImage' to a 'ConnectorGraphic'.
--- 
--- This means forgetting the answer of the Image, replacing it 
--- with @()@.
---
-connectorGraphic_ :: ConnectorImage u a -> ConnectorGraphic u
-connectorGraphic_ = (fmap . fmap . fmap) ignoreAns
+instance Functor (ConnectorImage u) where
+  fmap f ma = ConnectorImage $ \p0 p1 -> fmap f $ getConnectorImage ma p0 p1
 
+instance Functor (ConnectorQuery u) where
+  fmap f ma = ConnectorQuery $ \p0 p1 -> fmap f $ getConnectorQuery ma p0 p1
 
--- | 'emptyConnectorGraphic' : @ ConnectorGraphic @
+
+-- Applicative
+
+instance Applicative (ConnectorImage u) where
+  pure a    = ConnectorImage $ \_  _  -> pure a
+  mf <*> ma = ConnectorImage $ \p0 p1 -> 
+                getConnectorImage mf p0 p1 <*> getConnectorImage ma p0 p1
+
+instance Applicative (ConnectorQuery u) where
+  pure a    = ConnectorQuery $ \_  _  -> pure a
+  mf <*> ma = ConnectorQuery $ \p0 p1 -> 
+                getConnectorQuery mf p0 p1 <*> getConnectorQuery ma p0 p1
+
+
+-- Monad 
+
+instance Monad (ConnectorImage u) where
+  return a  = ConnectorImage $ \_  _  -> return a
+  ma >>= k  = ConnectorImage $ \p0 p1 -> 
+                getConnectorImage ma p0 p1 >>= \ans -> 
+                getConnectorImage (k ans) p0 p1
+
+
+instance Monad (ConnectorQuery u) where
+  return a  = ConnectorQuery $ \_  _  -> return a
+  ma >>= k  = ConnectorQuery $ \p0 p1 -> 
+                getConnectorQuery ma p0 p1 >>= \ans -> 
+                getConnectorQuery (k ans) p0 p1
+
+
+-- Monoid
+
+instance Monoid a => Monoid (ConnectorImage u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = ConnectorImage $ \p0 p1 -> 
+                      getConnectorImage ma p0 p1 
+                        `mappend` getConnectorImage mb p0 p1 
+
+
+instance Monoid a => Monoid (ConnectorQuery u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = ConnectorQuery $ \p0 p1 -> 
+                      getConnectorQuery ma p0 p1 
+                        `mappend` getConnectorQuery mb p0 p1 
+
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (ConnectorImage u) where
+  askDC           = ConnectorImage $ \_  _  -> askDC
+  asksDC fn       = ConnectorImage $ \_  _  -> asksDC fn
+  localize upd ma = ConnectorImage $ \p0 p1 -> 
+                      localize upd (getConnectorImage ma p0 p1)
+
+instance DrawingCtxM (ConnectorQuery u) where
+  askDC           = ConnectorQuery $ \_  _  -> askDC
+  asksDC fn       = ConnectorQuery $ \_  _  -> asksDC fn
+  localize upd ma = ConnectorQuery $ \p0 p1 -> 
+                      localize upd (getConnectorQuery ma p0 p1)
+
+
+  
+
+
+instance Decorate ConnectorImage where
+  decorate ma mz = ConnectorImage $ \p0 p1 -> 
+                      getConnectorImage ma p0 p1 `decorate` 
+                        getConnectorImage mz p0 p1
+
+  elaborate ma f = ConnectorImage $ \p0 p1 -> 
+                     getConnectorImage ma p0 p1 `elaborate` 
+                       (\a -> getConnectorImage (f a) p0 p1)
+
+  obliterate ma mz = ConnectorImage $ \p0 p1 -> 
+                       getConnectorImage ma p0 p1 `obliterate` 
+                         getConnectorImage mz p0 p1
+
+  hyperlink xl ma = ConnectorImage $ \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)
+
+
+runConnectorQuery :: Point2 u -> Point2 u 
+                  -> DrawingContext -> ConnectorQuery u a 
+                  -> a
+runConnectorQuery p0 p1 ctx mf = runQuery ctx (getConnectorQuery mf p0 p1)
+
+
+connect :: Point2 u -> Point2 u -> ConnectorImage u a -> Image u a
+connect p0 p1 mf = getConnectorImage mf p0 p1
+
+
+
+
+promoteConn :: (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a
+promoteConn fn       = ConnectorImage $ \p0 p1 -> fn p0 p1
+
+applyConn :: ConnectorImage u a -> Point2 u -> Point2 u -> Image u a
+applyConn mf p0 p1   = getConnectorImage mf p0 p1
+
+
+qpromoteConn :: (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a
+qpromoteConn fn      = ConnectorQuery $ \p0 p1 -> fn p0 p1
+
+qapplyConn :: ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a
+qapplyConn mf p0 p1   = getConnectorQuery mf p0 p1
+
+
+-- | \"zero-apply\" a Connector.
 --
--- Build an empty 'ConnectorGraphic'.
--- 
--- The 'emptyConnectorGraphic' is treated as a /null primitive/ by 
--- @Wumpus-Core@ and is not drawn, although it does generate a 
--- bounding box around the rectangular hull of the start and end 
--- points.
--- 
-emptyConnectorGraphic :: InterpretUnit u => ConnectorGraphic u 
-emptyConnectorGraphic = promoteR2 $ \start end -> 
-    let a = emptyLocGraphic `at` start
-        b = emptyLocGraphic `at` end
-    in a `oplus` b
+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
 
 
 
+instance UConvert ConnectorImage where
+  uconvF = uconvConnectorImageF
+  uconvZ = uconvConnectorImageZ
 
 
 -- | Use this to convert 'ConnectorGraphic' or 'ConnectorImage' 
@@ -114,20 +221,35 @@
 --
 uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
                      => ConnectorImage u (t u) -> ConnectorImage u1 (t u1)
-uconvConnectorImageF = uconvR2ab szconvAnsF
+uconvConnectorImageF ma = ConnectorImage $ \p0 p1 -> 
+    getFontSize >>= \sz -> 
+    let p0u = uconvertF sz p0
+        p1u = uconvertF sz p1
+    in uconvImageF $ getConnectorImage ma p0u p1u
 
 
 
+
 -- | Use this to convert 'ConnectorImage' with unit-less answer.
 --
 uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1) 
                      => ConnectorImage u a -> ConnectorImage u1 a
-uconvConnectorImageZ = uconvR2ab szconvAnsZ
+uconvConnectorImageZ ma = ConnectorImage $ \p0 p1 -> 
+    getFontSize >>= \sz -> 
+    let p0u = uconvertF sz p0
+        p1u = uconvertF sz p1
+    in uconvImageZ $ getConnectorImage ma p0u p1u
 
+-- | Having /empty/ at the specific 'ConnectorImage' type is useful.
+-- 
+emptyConnectorImage :: Monoid a => ConnectorImage u a
+emptyConnectorImage = mempty
 
+
 --------------------------------------------------------------------------------
 
 
+
 --
 -- Design note - potentially there are no useful combining 
 -- operators on Connectors (!).
@@ -137,3 +259,4 @@
 -- than combination. See the ConnectorPath operations in 
 -- Wumpus-Drawing for some examples.
 --
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
--- a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
@@ -177,9 +177,17 @@
 --------------------------------------------------------------------------------
 -- Monoid
 
+-- | Avoid initial mempty for mconcat.
+--
 instance Monoid CtxPicture where
   mempty  = CtxPicture $ \_ -> Nothing
   mappend = moveSnd $ \_ _ -> V2 0 0
+
+  mconcat []      = mempty
+  mconcat (a:as)  = step a as
+    where
+      step ac []     = ac
+      step ac (x:xs) = step (ac `mappend` x) xs
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs
@@ -19,73 +19,45 @@
 module Wumpus.Basic.Kernel.Objects.Displacement
   (
 
+
+  -- * Displacement
     PointDisplace
-  , ThetaDisplace
   , ThetaPointDisplace
+  , displace
 
+  , dispParallel
+  , dispPerpendicular
+  , dispOrtho
 
-  , moveStart
-  , moveStartTheta
-  , moveStartThetaPoint
-  , moveStartThetaIncl
+  , dispDirectionTheta
+  , dispCardinalTheta
 
-  , displace
-  , displaceVec
-  , displaceH
-  , displaceV
+  -- * Named vectors
 
-  , disp_up
-  , disp_down
-  , disp_left
-  , disp_right
+  , go_up
+  , go_down
+  , go_left
+  , go_right
 
-  , disp_up_left
-  , disp_up_right
-  , disp_down_left
-  , disp_down_right
+  , go_north
+  , go_south
+  , go_east
+  , go_west
+  , go_north_east
+  , go_north_west
+  , go_south_east
+  , go_south_west
   
-
-  , disp_north
-  , disp_south
-  , disp_east
-  , disp_west
-
-  , disp_northeast
-  , disp_northwest
-  , disp_southeast
-  , disp_southwest
+  , go_up_left
+  , go_up_right
+  , go_down_left
+  , go_down_right
 
 
-  , displaceParallel
-  , displacePerpendicular
-  , displaceOrtho
-
-  , adisp_north
-  , adisp_south
-  , adisp_east
-  , adisp_west  
-
-  , adisp_northeast
-  , adisp_northwest
-  , adisp_southeast
-  , adisp_southwest
-
-  , centerRelative
-  , left_of
-  , right_of
-  , above_left_of
-  , above_right_of
-  , below_left_of
-  , below_right_of
-
   ) where
 
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Base.QueryDC
-import Wumpus.Basic.Kernel.Objects.Anchors
-import Wumpus.Basic.Kernel.Objects.Basis
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -106,16 +78,6 @@
 
 
 
--- | 'ThetaDisplace' is a type representing functions 
--- @from Radian to Radian@.
---
--- It is especially useful for building composite graphics where 
--- one part of the graphic is drawn from a different start point 
--- to the other part.
---
-type ThetaDisplace = Radian -> Radian
-
-
 -- | 'ThetaPointDisplace' is a type representing functions 
 -- @from Radian * Point to Point@.
 --
@@ -126,218 +88,161 @@
 type ThetaPointDisplace u = Radian -> Point2 u -> Point2 u
 
 
---------------------------------------------------------------------------------
--- Displacing points and inclination
 
-
-
--- | Move the start-point of a 'LocQuery' with the supplied 
--- displacement function.
+-- | 'displace' : @ Vec2 -> PointDisplace @
 --
-moveStart :: PointDisplace u -> LocQuery u a -> LocQuery u a
-moveStart f ma = domMap1 f ma
-
-
-
--- | Move the start-point of a 'LocThetaQuery' with the supplied 
--- displacement function.
+-- Alias for @.+^@ from @Data.AffineSpace@.
 --
-moveStartTheta :: ThetaPointDisplace u 
-               -> LocThetaQuery u a -> LocThetaQuery u a
-moveStartTheta f cf = consCF $ \ctx -> 
-    (\pt ang -> let f1 = runCF ctx cf in f1 (f ang pt) ang)
+displace :: Num u => Vec2 u -> PointDisplace u
+displace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
 
 
--- | Move the start-point of a 'LocThetaCF' with the supplied 
--- displacement function.
---
-moveStartThetaPoint :: PointDisplace u 
-                    -> LocThetaQuery u a -> LocThetaQuery u a
-moveStartThetaPoint f = domMap2 f id
 
 
--- | Change the inclination of a 'LocThetaCF' with the supplied 
--- displacement function.
---
-moveStartThetaIncl :: ThetaDisplace -> LocThetaQuery u a -> LocThetaQuery u a
-moveStartThetaIncl f = domMap2 id f
 
 
---------------------------------------------------------------------------------
--- PointDisplace functions
 
--- | 'displace' : @ x -> y -> PointDisplace @
---
--- Build a combinator to move @Points@ by the supplied @x@ and 
--- @y@ distances.
---
-displace :: Num u => u -> u -> PointDisplace u
-displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
 
-
--- | 'displaceV' : @ (V2 x y) -> PointDisplace @
--- 
--- Version of 'displace' where the displacement is supplied as
--- a vector rather than two parameters.
--- 
-displaceVec :: Num u => Vec2 u -> PointDisplace u
-displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
-
-
--- | 'displaceH' : @ x -> PointDisplace @
--- 
--- Build a combinator to move @Points@ by horizontally the 
--- supplied @x@ distance.
---
-displaceH :: Num u => u -> PointDisplace u
-displaceH dx (P2 x y) = P2 (x+dx) y
-
--- | 'displaceV' : @ y -> PointDisplace @
--- 
--- Build a combinator to move @Points@ vertically by the supplied 
--- @y@ distance.
---
-displaceV :: Num u => u -> PointDisplace u
-displaceV dy (P2 x y) = P2 x (y+dy)
-
-
-
-
-disp_up :: Num u => u -> PointDisplace u
-disp_up = displaceV
-
-disp_down :: Num u => u -> PointDisplace u
-disp_down = displaceV . negate
-
-disp_left :: Num u => u -> PointDisplace u
-disp_left = displaceH . negate
-
-disp_right :: Num u => u -> PointDisplace u
-disp_right = displaceH
-
-
--- diagonals - these are different to cardinals which have the
--- hypotenuese as the dist.
---
-
-disp_up_left :: Num u => u -> PointDisplace u
-disp_up_left u = displaceVec (V2 (-u) u)
-
-disp_up_right :: Num u => u -> PointDisplace u
-disp_up_right u = displaceVec (V2 u u)
-
-disp_down_left :: Num u => u -> PointDisplace u
-disp_down_left u = displaceVec (V2 (-u) (-u))
-
-disp_down_right :: Num u => u -> PointDisplace u
-disp_down_right u = displaceVec (V2 u (-u))
-
-
-
-
-
-
-
--- Cardinal displacement 
-
-disp_north :: Num u => u -> PointDisplace u
-disp_north = displaceV
-
-
-disp_south :: Num u => u -> PointDisplace u
-disp_south =  displaceV . negate
-
-disp_east :: Num u => u -> PointDisplace u
-disp_east = displaceH
-
-disp_west :: Num u => u -> PointDisplace u
-disp_west = displaceH . negate
-
-disp_northeast :: Floating u => u -> PointDisplace u
-disp_northeast = displaceVec . avec (0.25 * pi)
-
-disp_northwest ::  Floating u => u -> PointDisplace u
-disp_northwest = displaceVec . avec (0.75 * pi)
-
-disp_southeast ::  Floating u => u -> PointDisplace u
-disp_southeast = displaceVec . avec (1.75 * pi)
-
-disp_southwest ::  Floating u => u -> PointDisplace u
-disp_southwest = displaceVec . avec (1.25 * pi)
-
-
 --------------------------------------------------------------------------------
 -- ThetaPointDisplace functions
 
 
--- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
+-- | 'dispParallel' : @ dist -> ThetaPointDisplace @
 -- 
 -- Build a combinator to move @Points@ in parallel to the 
 -- direction of the implicit angle by the supplied distance 
 -- @dist@. 
 --
-displaceParallel :: Floating u => u -> ThetaPointDisplace u
-displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
+dispParallel :: Floating u => u -> ThetaPointDisplace u
+dispParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
 
 
--- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
+-- | 'dispParallel' : @ dist -> ThetaPointDisplace @
 -- 
 -- Build a combinator to move @Points@ perpendicular to the 
 -- inclnation of the implicit angle by the supplied distance 
 -- @dist@. 
 --
-displacePerpendicular :: Floating u => u -> ThetaPointDisplace u
-displacePerpendicular d = 
+dispPerpendicular :: Floating u => u -> ThetaPointDisplace u
+dispPerpendicular d = 
     \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d
 
 
 
--- | 'displaceOrtho' : @ vec -> ThetaPointDisplace @
+-- | 'dispOrtho' : @ vec -> ThetaPointDisplace @
 -- 
 -- This is a combination of @displaceParallel@ and 
 -- @displacePerpendicular@, with the x component of the vector
 -- displaced in parallel and the y component displaced
 -- perpendicular. 
 -- 
-displaceOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u
-displaceOrtho (V2 x y) = \theta -> 
-    displaceParallel x theta . displacePerpendicular y theta
+dispOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u
+dispOrtho (V2 x y) = \theta -> dispParallel x theta . dispPerpendicular y theta
 
 
-adisp_north :: Floating u => u -> ThetaPointDisplace u
-adisp_north = displacePerpendicular
 
 
-adisp_south :: Floating u => u -> ThetaPointDisplace u
-adisp_south = displacePerpendicular . negate
+-- | /Angular/ version of 'dispDirection'. 
+--
+-- The displacement direction is with respect to implicit angle
+-- of inclination, so:
+--
+-- > up    == perpendicular
+-- > down  == perdendicular . negate
+-- > left  == parallel . negate
+-- > right == parallel
+-- 
+dispDirectionTheta :: Floating u => Direction -> u -> ThetaPointDisplace u
+dispDirectionTheta UP      = dispPerpendicular
+dispDirectionTheta DOWN    = dispPerpendicular . negate
+dispDirectionTheta LEFT    = dispParallel . negate
+dispDirectionTheta RIGHT   = dispParallel
 
 
-adisp_east :: Floating u => u -> ThetaPointDisplace u
-adisp_east = displaceParallel
+-- | /Angular/ version of 'dispCardinal'.
+--
+-- The displacement direction is with respect to implicit angle
+-- of inclination, so:
+--
+-- > north == perpendicular
+-- > east  == parallel
+-- > south == perdendicular . negate
+-- > etc.
+-- 
+dispCardinalTheta :: Floating u => Cardinal -> u -> ThetaPointDisplace u
+dispCardinalTheta NORTH      = dispPerpendicular
+dispCardinalTheta NORTH_EAST = \d ang -> displace (avec (ang + (0.25*pi)) d)
+dispCardinalTheta EAST       = dispParallel
+dispCardinalTheta SOUTH_EAST = \d ang -> displace (avec (ang + (1.75*pi)) d)
+dispCardinalTheta SOUTH      = dispPerpendicular . negate
+dispCardinalTheta SOUTH_WEST = \d ang -> displace (avec (ang + (1.25*pi)) d)
+dispCardinalTheta WEST       = dispParallel . negate
+dispCardinalTheta NORTH_WEST = \d ang -> displace (avec (ang + (0.75*pi)) d)
 
 
-adisp_west :: Floating u => u -> ThetaPointDisplace u
-adisp_west = displaceParallel . negate
+--------------------------------------------------------------------------------
+-- Named vectors
 
-adisp_northeast :: Floating u => u -> ThetaPointDisplace u
-adisp_northeast d = \ang pt -> pt .+^ avec (ang + (0.25*pi)) d
 
+go_up :: Num u => u -> Vec2 u
+go_up d = V2 0 d
 
-adisp_northwest :: Floating u => u -> ThetaPointDisplace u
-adisp_northwest d = \ang pt -> pt .+^ avec (ang + (0.75*pi)) d
+go_down :: Num u => u -> Vec2 u
+go_down d = V2 0 (-d)
 
+go_left :: Num u => u -> Vec2 u
+go_left d = V2 (-d) 0
 
-adisp_southeast :: Floating u => u -> ThetaPointDisplace u
-adisp_southeast d = \ang pt -> pt .+^ avec (ang + (1.75*pi)) d
+go_right :: Num u => u -> Vec2 u
+go_right d = V2 d 0
 
 
-adisp_southwest :: Floating u => u -> ThetaPointDisplace u
-adisp_southwest d = \ang pt -> pt .+^ avec (ang + (1.25*pi)) d
+go_north :: Num u => u -> Vec2 u
+go_north = go_up
 
+go_south :: Num u => u -> Vec2 u
+go_south = go_down
 
+go_east :: Num u => u -> Vec2 u
+go_east = go_right
 
+go_west :: Num u => u -> Vec2 u
+go_west = go_left
+
+
+go_north_east :: Floating u => u -> Vec2 u
+go_north_east = avec (0.25*pi)
+
+go_north_west :: Floating u => u -> Vec2 u
+go_north_west = avec (0.75*pi)
+
+go_south_east :: Floating u => u -> Vec2 u
+go_south_east = avec (1.75*pi)
+
+go_south_west :: Floating u => u -> Vec2 u
+go_south_west = avec (1.25*pi)
+
+
+go_up_left :: Num u => u -> Vec2 u
+go_up_left d = V2 (-d) d
+
+go_up_right :: Num u => u -> Vec2 u
+go_up_right d = V2 d d
+
+go_down_left :: Num u => u -> Vec2 u
+go_down_left d = V2 (-d) (-d)
+
+go_down_right :: Num u => u -> Vec2 u
+go_down_right d = V2 d (-d)
+
+
 --------------------------------------------------------------------------------
 
+
+{-
+
+-- ORPHANS - need a new home...
+
 -- | Absolute units.
 -- 
 centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
@@ -405,3 +310,4 @@
 below_left_of   = centerRelative ((-1),(-1))
  
 
+-}
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
@@ -28,16 +28,14 @@
   , vertexPP
   , curvePP
 
-  , openStroke
-  , closedStroke
-  , filledPath
-  , borderedPath
+  , dcOpenPath
+  , dcClosedPath
 
   -- * Text
-  , plainTextLine
-  , rplainTextLine
-  , escTextLine
-  , rescTextLine
+  , dcTextlabel
+  , dcRTextlabel
+  , dcEscapedlabel
+  , dcREscapedlabel
 
   , KernChar
   , hkernLine
@@ -50,41 +48,29 @@
   , straightConnector
 
   -- * Circles
-  , strokedCircle
-  , filledCircle
-  , borderedCircle
+  , dcCircle
 
   -- * Ellipses
-  , strokedEllipse
-  , rstrokedEllipse
-  , filledEllipse
-  , rfilledEllipse
-  , borderedEllipse
-  , rborderedEllipse
+  , dcEllipse
+  , dcREllipse
 
+
   -- * Rectangles
-  , strokedRectangle
-  , filledRectangle
-  , borderedRectangle
+  , dcRectangle
 
   -- * Disks  
-  , strokedDisk
-  , filledDisk
-  , borderedDisk
+  , dcDisk
+  , dcEllipseDisk
 
-  , strokedEllipseDisk
-  , filledEllipseDisk
-  , borderedEllipseDisk
 
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.Basis
 import Wumpus.Basic.Kernel.Objects.Connector
-import Wumpus.Basic.Kernel.Objects.Image
+-- import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Kernel.Objects.LocImage
 import Wumpus.Basic.Kernel.Objects.LocThetaImage
 
@@ -96,28 +82,62 @@
 -- Helpers
 
 
-norm2 :: InterpretUnit u => u -> u -> Query (Double,Double)
-norm2 a b = (,) <$> normalizeCtx a <*> normalizeCtx b
+textPrim :: (RGBi -> FontAttr -> Primitive) -> Graphic u
+textPrim fn = 
+    textAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)
+    
 
-makeGraphic :: Query a -> (a -> Primitive) -> Graphic u
-makeGraphic qy fn = qy >>= \a -> return $ graphicAns $ prim1 $ fn a
 
+strokePrim :: (RGBi -> StrokeAttr -> Primitive) -> Graphic u
+strokePrim fn = 
+    strokeAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)
+                     
 
-makeLocGraphic :: InterpretUnit u 
-               => Query a -> (a -> DPoint2 -> Primitive) -> LocGraphic u
-makeLocGraphic qy fn = promoteR1 $ \pt -> 
-    normalizeCtxF pt >>= \dpt ->
-    qy >>= \a -> return $ graphicAns $ prim1 $ fn a dpt
+fillPrim :: (RGBi -> Primitive) -> Graphic u
+fillPrim fn = 
+    fillAttr >>= \rgb -> primGraphic (prim1 $ fn rgb)
 
-makeLocThetaGraphic :: InterpretUnit u 
-                    => Query a -> (a -> DPoint2 -> Radian -> Primitive) 
-                    -> LocThetaGraphic u
-makeLocThetaGraphic qy fn = promoteR2 $ \pt ang -> 
-    normalizeCtxF pt >>= \dpt ->
-    qy >>= \a -> return $ graphicAns $ prim1 $ fn a dpt ang
+fillStrokePrim :: (RGBi -> StrokeAttr -> RGBi -> Primitive) 
+               -> Graphic u
+fillStrokePrim fn = 
+    borderedAttr >>= \(frgb,attr,srgb) -> 
+        primGraphic (prim1 $ fn frgb attr srgb)
 
 
+textLoc :: InterpretUnit u 
+        => (RGBi -> FontAttr -> DPoint2 -> Primitive) -> LocGraphic u
+textLoc fn = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt)
 
+
+strokeLoc :: InterpretUnit u
+          => (RGBi -> StrokeAttr -> DPoint2 -> Primitive) -> LocGraphic u
+strokeLoc fn = promoteLoc $ \pt -> 
+    normalizeCtxF pt >>= \dpt -> strokePrim (\rgb attr -> fn rgb attr dpt)
+
+fillLoc :: InterpretUnit u 
+        => (RGBi -> DPoint2 -> Primitive) -> LocGraphic u
+fillLoc fn = promoteLoc $ \pt ->
+    normalizeCtxF pt >>= \dpt -> fillPrim (\rgb -> fn rgb dpt)
+
+fillStrokeLoc :: InterpretUnit u
+              => (RGBi -> StrokeAttr -> RGBi -> DPoint2 -> Primitive) 
+              -> LocGraphic u
+fillStrokeLoc fn = promoteLoc $ \pt ->
+    normalizeCtxF pt >>= \dpt -> 
+    fillStrokePrim (\frgb attr srgb -> fn frgb attr srgb dpt) 
+ 
+
+
+textLocTheta :: InterpretUnit u 
+             => (RGBi -> FontAttr -> DPoint2 -> Radian -> Primitive) 
+             -> LocThetaGraphic u
+textLocTheta fn = promoteLocTheta $ \pt ang -> 
+    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt ang)
+
+
+
+
 --------------------------------------------------------------------------------
 -- Paths
 
@@ -126,16 +146,16 @@
 -- considered more /internal/.
 --
 
--- | 'locPP' : @ [next_vector] -> LocQuery PrimPath @
+-- | 'locPP' : @ [next_vector] -> LocImage PrimPath @
 --
--- Create a path 'LocQuery' - i.e. a functional type 
+-- Create a path /query/ - i.e. a functional type 
 -- /from Point to PrimPath/.
 -- 
 -- This is the analogue to 'vectorPath' in @Wumpus-Core@, but the 
 -- result is produced /within/ the 'DrawingContext'.
 --
 locPP :: InterpretUnit u => [Vec2 u] -> LocQuery u PrimPath
-locPP vs = promoteR1 $ \ pt  ->
+locPP vs = qpromoteLoc $ \pt -> 
     vectorPrimPath <$> normalizeCtxF pt <*> mapM normalizeCtxF vs
 
 
@@ -143,7 +163,7 @@
 
 -- | 'emptyLocPP' : @ (Point ~> PrimPath) @
 --
--- Create an empty path 'LocQuery' - i.e. a functional type 
+-- Create an empty path /query/ - i.e. a functional type 
 -- /from Point to PrimPath/.
 --
 -- This is the analogue to 'emptyPath' in @Wumpus-Core@, but the
@@ -163,7 +183,7 @@
 -- This is the analogue to 'vertexPrimPath' in @Wumpus-Core@, but 
 -- it is polymorphic on unit.
 --
-vertexPP :: InterpretUnit u => [Point2 u] -> Query PrimPath
+vertexPP :: InterpretUnit u => [Point2 u] -> Query u PrimPath
 vertexPP xs = vertexPrimPath <$> mapM normalizeCtxF xs
 
 
@@ -176,66 +196,49 @@
 -- This is the analogue to 'curvedPrimPath' in @Wumpus-Core@, but 
 -- it is polymorphic on unit.
 --
-curvePP :: InterpretUnit u => [Point2 u] -> Query PrimPath
+curvePP :: InterpretUnit u => [Point2 u] -> Query u PrimPath
 curvePP xs = curvedPrimPath <$> mapM normalizeCtxF xs
 
 
 --------------------------------------------------------------------------------
 
 --
--- Drawing paths (stroke, fill, bordered)...
+-- Drawing paths (stroke, fill, fillStroke)...
 --
 
--- | 'openStroke' : @ path -> Graphic @
---
--- This is the analogue to 'ostroke' in @Wumpus-core@, but the 
--- drawing properties (colour, line width, etc.) are taken from 
--- the implicit 'DrawingContext'.
---
-openStroke :: PrimPath -> Graphic u
-openStroke pp = makeGraphic strokeAttr (\(rgb,attr) -> ostroke rgb attr pp)
 
-
-
--- | 'closedStroke' : @ path -> Graphic @
+-- | 'dcOpenPath' : @ path -> Graphic @
 --
--- This is the analogue to 'cstroke' in @Wumpus-core@, but the 
--- drawing properties (colour, line width, etc.) are taken from 
--- the implicit 'DrawingContext'.
+-- This is the analogue to the 'ostroke' function in 
+-- @Wumpus-Core@, but the drawing properties (colour, line width, 
+-- etc.) are taken from the implicit 'DrawingContext'.
 --
-closedStroke :: PrimPath -> Graphic u
-closedStroke pp = 
-    makeGraphic strokeAttr (\(rgb,attr) -> cstroke rgb attr pp)
+dcOpenPath :: PrimPath -> Graphic u
+dcOpenPath pp = strokePrim (\rgb attr -> ostroke rgb attr pp)
 
 
--- | 'filledPath' : @ path -> Graphic @
--- 
--- This is the analogue to 'fill' in @Wumpus-core@, but the 
--- fill colour is taken from the implicit 'DrawingContext'.
---
---
-filledPath :: PrimPath -> Graphic u
-filledPath pp = makeGraphic fillAttr (\rgb -> fill rgb pp)
-                 
 
--- | 'borderedPath' : @ path -> Graphic @
---
--- This is the analogue to 'fillStroke' in @Wumpus-core@, but the 
--- drawing properties (fill colour, border colour, line width, 
--- etc.) are taken from the implicit 'DrawingContext'.
+-- | 'dcClosedPath' : @ DrawStyle * path -> Graphic @
 --
+-- Draw a closed path according to the supplied DrawStyle
+-- ( fill | stroke | fill_stroke). 
+---
+-- Drawing properties (colour, line width, etc.) for the 
+-- respective style are taken from the implicit 'DrawingContext'.
 --
-borderedPath :: PrimPath -> Graphic u
-borderedPath pp =
-    makeGraphic borderedAttr 
-                (\(frgb,attr,srgb) -> fillStroke frgb attr srgb pp)
+dcClosedPath :: DrawStyle -> PrimPath -> Graphic u
+dcClosedPath FILL        pp = fillPrim (\rgb -> fill rgb pp)
 
+dcClosedPath STROKE      pp = strokePrim (\rgb attr -> cstroke rgb attr pp)
 
+dcClosedPath FILL_STROKE pp = 
+    fillStrokePrim (\frgb attr srgb -> fillStroke frgb attr srgb pp)
 
+
 --------------------------------------------------------------------------------
 -- Text
 
--- | 'plainTextLine' : @ string -> LocGraphic @
+-- | 'dcTextlabel' : @ string -> LocGraphic @
 -- 
 -- Create a text 'LocGraphic' - i.e. a functional type 
 -- /from Point to Graphic/.
@@ -246,16 +249,14 @@
 -- text properties (font family, font size, colour) are taken from
 -- the implicit 'DrawingContext'.
 --
-plainTextLine :: InterpretUnit u => String -> LocGraphic u
-plainTextLine ss = 
-    makeLocGraphic textAttr 
-                   (\(rgb,attr) pt -> textlabel rgb attr ss pt)
+dcTextlabel :: InterpretUnit u => String -> LocGraphic u
+dcTextlabel ss = textLoc (\rgb attr pt -> textlabel rgb attr ss pt)
 
 
 
 
 
--- | 'rplainTextLine' : @ string -> LocThetaGraphic @
+-- | 'dcRTextlabel' : @ string -> LocThetaGraphic @
 -- 
 -- Create a text 'LocThetaGraphic' - i.e. a functional type 
 -- /from Point and Angle to Graphic/.
@@ -268,13 +269,12 @@
 -- 
 -- This is the analogue to 'rtextlabel' in @Wumpus-core@.
 --
-rplainTextLine :: InterpretUnit u => String -> LocThetaGraphic u
-rplainTextLine ss =
-    makeLocThetaGraphic textAttr
-                        (\(rgb,attr) pt ang -> rtextlabel rgb attr ss ang pt)
+dcRTextlabel :: InterpretUnit u => String -> LocThetaGraphic u
+dcRTextlabel ss =
+    textLocTheta (\rgb attr pt ang -> rtextlabel rgb attr ss ang pt)
 
 
--- | 'escTextline' : @ escaped_text -> LocGraphic @
+-- | 'dcEscapedlabel' : @ escaped_text -> LocGraphic @
 -- 
 -- Create a text 'LocGraphic' - i.e. a functional type 
 -- /from Point to Graphic/.
@@ -285,14 +285,13 @@
 -- the text properties (font family, font size, colour) are taken 
 -- from the implicit 'DrawingContext'.
 --
-escTextLine :: InterpretUnit u => EscapedText -> LocGraphic u
-escTextLine esc =           
-    makeLocGraphic textAttr 
-                   (\(rgb,attr) pt -> escapedlabel rgb attr esc pt)
+dcEscapedlabel :: InterpretUnit u => EscapedText -> LocGraphic u
+dcEscapedlabel esc =           
+    textLoc (\rgb attr pt -> escapedlabel rgb attr esc pt)
 
 
 
--- | 'rescTextLine' : @ escaped_text -> LocThetaGraphic @
+-- | 'dcREscapedlabel' : @ escaped_text -> LocThetaGraphic @
 -- 
 -- Create a text 'LocThetaGraphic' - i.e. a functional type 
 -- /from Point and Angle to Graphic/.
@@ -307,10 +306,9 @@
 -- the text properties (font family, font size, colour) are taken 
 -- from the implicit 'DrawingContext'.
 --
-rescTextLine :: InterpretUnit u => EscapedText -> LocThetaGraphic u
-rescTextLine esc = 
-    makeLocThetaGraphic textAttr
-                        (\(rgb,attr) pt ang -> rescapedlabel rgb attr esc ang pt)
+dcREscapedlabel :: InterpretUnit u => EscapedText -> LocThetaGraphic u
+dcREscapedlabel esc = 
+    textLocTheta (\rgb attr pt ang -> rescapedlabel rgb attr esc ang pt)
 
 
 
@@ -318,7 +316,7 @@
 --
 type KernChar u = (u,EscapedChar)
 
-uconvKernChar :: InterpretUnit u => [KernChar u] -> Query [KerningChar]
+uconvKernChar :: InterpretUnit u => [KernChar u] -> Query u [KerningChar]
 uconvKernChar = mapM mf
   where
     mf (u,ch) = (\u1 -> (u1,ch)) <$> normalizeCtx u
@@ -337,10 +335,11 @@
 -- from the implicit 'DrawingContext'.
 --
 hkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u
-hkernLine ks = uconvKernChar ks >>= body   
+hkernLine ks = promoteLoc $ \pt -> 
+               normalizeCtxF pt >>= \dpt -> 
+               zapQuery (uconvKernChar ks) >>= body dpt
   where
-    body ans = makeLocGraphic textAttr
-                  (\(rgb,attr) pt -> hkernlabel rgb attr ans pt)
+    body pt ans = textPrim (\rgb attr -> hkernlabel rgb attr ans pt)
 
 
 
@@ -356,10 +355,11 @@
 -- from the implicit 'DrawingContext'.
 --
 vkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u
-vkernLine ks = uconvKernChar ks >>= body
+vkernLine ks = promoteLoc $ \pt -> 
+               normalizeCtxF pt >>= \dpt -> 
+               zapQuery (uconvKernChar ks) >>= body dpt
   where
-    body ans = makeLocGraphic textAttr
-                  (\(rgb,attr) pt -> vkernlabel rgb attr ans pt)
+    body pt ans = textPrim (\rgb attr -> vkernlabel rgb attr ans pt)
 
 --------------------------------------------------------------------------------
 -- Lines
@@ -373,7 +373,7 @@
 -- from the implicit 'DrawingContext'.
 -- 
 straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u
-straightLine p1 p2 = vertexPP [p1,p2] >>= openStroke
+straightLine p1 p2 = zapQuery (vertexPP [p1,p2]) >>= dcOpenPath
 
 
 -- | 'locStraightLine' : @ vec_to -> LocGraphic @ 
@@ -389,8 +389,7 @@
 -- from the implicit 'DrawingContext'.
 -- 
 locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u
-locStraightLine v = promoteR1 $ \pt -> 
-    apply1R1 (locPP [v]) pt >>= openStroke
+locStraightLine v = promoteLoc $ \pt -> zapLocQuery (locPP [v]) pt >>= dcOpenPath
 
 
 
@@ -405,7 +404,8 @@
 -- 
 curvedLine :: InterpretUnit u
            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
-curvedLine p0 p1 p2 p3 = curvePP [p0,p1,p2,p3] >>= openStroke
+curvedLine p0 p1 p2 p3 = 
+    zapQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath
 
 
 
@@ -419,7 +419,8 @@
 -- from the implicit 'DrawingContext'.
 -- 
 straightConnector :: InterpretUnit u => ConnectorGraphic u
-straightConnector = promoteR2 $ \p0 p1 -> vertexPP [p0,p1] >>= openStroke
+straightConnector = promoteConn $ \p0 p1 -> 
+    zapQuery (vertexPP [p0,p1]) >>= dcOpenPath
 
 
 
@@ -430,54 +431,25 @@
 --
 circlePath :: InterpretUnit u 
          => u -> LocQuery u PrimPath
-circlePath r = promoteR1 $ \pt  ->
+circlePath r = qpromoteLoc $ \pt -> 
     (\dr dpt -> curvedPrimPath $ bezierCircle dr dpt) 
       <$> normalizeCtx r <*> normalizeCtxF pt
 
 
-
-
--- | 'strokedCircle' : @ radius -> LocGraphic @
---
--- Create a stroked circle 'LocGraphic' - the implicit point is 
--- center. The circle is drawn with four Bezier curves. 
--- 
--- The line properties (colour, pen thickness, etc.) are taken 
--- from the implicit 'DrawingContext'.
--- 
-strokedCircle :: InterpretUnit u => u -> LocGraphic u
-strokedCircle r = promoteR1 $ \pt -> 
-    apply1R1 (circlePath r) pt >>= openStroke
-
-
-
-
--- | 'filledCircle' : @ radius -> LocGraphic @
+-- | 'dcCircle' : @ DrawStyle * radius -> LocGraphic @
 --
--- Create a filled circle 'LocGraphic' - the implicit point is 
+-- Create a circle 'LocGraphic' - the implicit point is 
 -- center. The circle is drawn with four Bezier curves. 
 -- 
--- The fill colour is taken from the implicit 'DrawingContext'.
+-- The respective line or fill properties for the 'DrawStyle' are 
+-- taken from the implicit 'DrawingContext'.
 -- 
-filledCircle :: InterpretUnit u => u -> LocGraphic u
-filledCircle r = promoteR1 $ \pt -> 
-    apply1R1 (circlePath r) pt >>= filledPath 
+dcCircle :: InterpretUnit u => DrawStyle -> u -> LocGraphic u
+dcCircle style r = promoteLoc $ \pt -> 
+    zapLocQuery (circlePath r) pt >>= dcClosedPath style
 
 
 
--- | 'borderedCircle' : @ radius -> LocGraphic @
---
--- Create a bordered circle 'LocGraphic' - the implicit point is 
--- center. The circle is drawn with four Bezier curves. 
--- 
--- The background fill colour and the outline stroke properties 
--- are taken from the implicit 'DrawingContext'.
--- 
-borderedCircle :: InterpretUnit u => u -> LocGraphic u
-borderedCircle r = promoteR1 $ \pt -> 
-    apply1R1 (circlePath r) pt >>= borderedPath
-
-
 --------------------------------------------------------------------------------
 -- Ellipses
 
@@ -486,7 +458,7 @@
 --
 ellipsePath :: InterpretUnit u 
             => u -> u -> LocQuery u PrimPath
-ellipsePath rx ry = promoteR1 $ \pt ->
+ellipsePath rx ry = qpromoteLoc $ \pt -> 
     (\drx dry dpt -> curvedPrimPath $ bezierEllipse drx dry dpt) 
       <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt
 
@@ -495,13 +467,11 @@
 --
 rellipsePath :: InterpretUnit u 
             => u -> u -> LocThetaQuery u PrimPath
-rellipsePath rx ry = promoteR2 $ \pt ang ->
+rellipsePath rx ry = qpromoteLocTheta $ \pt ang ->
     (\drx dry dpt -> curvedPrimPath $ rbezierEllipse drx dry ang dpt) 
       <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt
 
 
-
-
 -- | 'strokedEllipse' : @ x_radius * y_radius -> LocGraphic @
 --
 -- Create a stroked ellipse 'LocGraphic' - the implicit point is 
@@ -510,70 +480,12 @@
 -- The line properties (colour, pen thickness, etc.) are taken 
 -- from the implicit 'DrawingContext'.
 -- 
-strokedEllipse :: InterpretUnit u => u -> u -> LocGraphic u
-strokedEllipse rx ry = promoteR1 $ \pt ->
-   apply1R1 (ellipsePath rx ry) pt >>= closedStroke
-
-
-
--- | 'rstrokedEllipse' : @ x_radius * y_radius -> LocThetaGraphic @
---
--- Create a stroked ellipse 'LocThetaGraphic' - the implicit point
--- is center and the angle is rotation about the center. The 
--- ellipse is drawn with four Bezier curves. 
--- 
--- The line properties (colour, pen thickness, etc.) are taken 
--- from the implicit 'DrawingContext'.
--- 
-rstrokedEllipse :: InterpretUnit u
-                => u -> u -> LocThetaGraphic u
-rstrokedEllipse rx ry = promoteR2 $ \pt ang -> 
-    apply2R2 (rellipsePath rx ry) pt ang >>= closedStroke
-
-
-
-
--- | 'filledEllipse' : @ x_radius * y_radius -> LocGraphic @
---
--- Create a filled ellipse 'LocGraphic' - the implicit point is 
--- center. The ellipse is drawn with four Bezier curves. 
--- 
--- The fill colour is taken from the implicit 'DrawingContext'.
--- 
-filledEllipse :: InterpretUnit u => u -> u -> LocGraphic u
-filledEllipse rx ry = promoteR1 $ \pt -> 
-    apply1R1 (ellipsePath rx ry) pt >>= filledPath
-
-
--- | 'rfilledEllipse' : @ x_radius * y_radius -> LocGraphic @
---
--- Create a filled ellipse 'LocThetaGraphic' - the implicit point
--- is center and the angle is rotation about the center. The 
--- ellipse is drawn with four Bezier curves.  
--- 
--- The fill colour is taken from the implicit 'DrawingContext'.
--- 
-rfilledEllipse :: InterpretUnit u => u -> u -> LocThetaGraphic u
-rfilledEllipse rx ry = promoteR2 $ \pt ang ->
-    apply2R2 (rellipsePath rx ry) pt ang >>= filledPath
-
-
-
--- | 'borderedEllipse' : @ x_radius * y_radius -> LocGraphic @
---
--- Create a bordered ellipse 'LocGraphic' - the implicit point is 
--- center. The ellipse is drawn with four Bezier curves. 
--- 
--- The background fill colour and the outline stroke properties 
--- are taken from the implicit 'DrawingContext'.
--- 
-borderedEllipse :: InterpretUnit u => u -> u -> LocGraphic u
-borderedEllipse rx ry = promoteR1 $ \pt -> 
-    apply1R1 (ellipsePath rx ry) pt >>= borderedPath
-
+dcEllipse :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u
+dcEllipse style rx ry = promoteLoc $ \pt ->
+   zapLocQuery (ellipsePath rx ry) pt >>= dcClosedPath style 
 
 
--- | 'rborderedEllipse' : @ x_radius * y_radius -> LocGraphic @
+-- | 'dcREllipse' : @ x_radius * y_radius -> LocGraphic @
 --
 -- Create a bordered ellipse 'LocThetaGraphic' - the implicit point
 -- is center and the angle is rotation about the center. The 
@@ -582,14 +494,13 @@
 -- The background fill colour and the outline stroke properties 
 -- are taken from the implicit 'DrawingContext'.
 -- 
-rborderedEllipse :: InterpretUnit u
-                 => u -> u -> LocThetaGraphic u
-rborderedEllipse rx ry = promoteR2 $ \pt ang -> 
-    apply2R2 (rellipsePath rx ry) pt ang >>= borderedPath
-
+dcREllipse :: InterpretUnit u
+           => DrawStyle -> u -> u -> LocThetaGraphic u
+dcREllipse style rx ry = promoteLocTheta $ \pt ang -> 
+    zapLocThetaQuery (rellipsePath rx ry) pt ang >>= dcClosedPath style
 
 
--- Note - clipping to do...
+-- Note - clipping needs some higher level path object than is defined here.
 
 --------------------------------------------------------------------------------
 -- Rectangles
@@ -601,6 +512,7 @@
 rectanglePath w h = locPP [hvec w, vvec h, hvec (-w)]
 
 
+
 -- | 'strokedRectangle' : @ width * height -> LocGraphic @
 --
 -- Create a stroked rectangle 'LocGraphic' - the implicit point is 
@@ -609,41 +521,17 @@
 -- The line properties (colour, pen thickness, etc.) are taken 
 -- from the implicit 'DrawingContext'.
 -- 
-strokedRectangle :: InterpretUnit u => u -> u -> LocGraphic u
-strokedRectangle w h = promoteR1 $ \pt -> 
-    apply1R1 (rectanglePath w h) pt >>= closedStroke
-
-
--- | 'filledRectangle' : @ width * height -> LocGraphic @
---
--- Create a filled rectangle 'LocGraphic' - the implicit point is 
--- the bottom-left. 
--- 
--- The fill colour is taken from the implicit 'DrawingContext'.
--- 
-filledRectangle :: InterpretUnit u => u -> u -> LocGraphic u
-filledRectangle w h = promoteR1 $ \pt -> 
-    apply1R1 (rectanglePath w h) pt >>= filledPath
+dcRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u
+dcRectangle style w h = promoteLoc $ \pt -> 
+    zapLocQuery (rectanglePath w h) pt >>= dcClosedPath style
 
 
--- | 'borderedRectangle' : @ width * height -> LocGraphic @
---
--- Create a bordered rectangle 'LocGraphic' - the implicit point is 
--- bottom-left. 
--- 
--- The background fill colour and the outline stroke properties 
--- are taken from the implicit 'DrawingContext'.
--- 
-borderedRectangle :: InterpretUnit u => u -> u -> LocGraphic u
-borderedRectangle w h = promoteR1 $ \pt -> 
-    apply1R1 (rectanglePath w h) pt >>= borderedPath 
-
 ---------------------------------------------------------------------------
 
--- | 'strokedDisk' : @ radius -> LocGraphic @
+-- | 'dcDisk' : @ radius -> LocGraphic @
 --
--- Create a stroked circle 'LocGraphic' - the implicit point is 
--- the center. 
+-- Create a circle 'LocGraphic' - the implicit point is the 
+-- center. 
 -- 
 -- This is a efficient representation of circles using 
 -- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
@@ -652,66 +540,28 @@
 -- the shape.
 --
 -- For stroked circles that can be adequately scaled, use 
--- 'strokedCircle' instead.
+-- 'dcCircle' instead.
 --
--- The line properties (colour, pen thickness, etc.) are taken 
--- from the implicit 'DrawingContext'.
+-- The fill or stroke properties for the respective DrawStyle are
+-- taken from the implicit 'DrawingContext'.
 -- 
-strokedDisk :: InterpretUnit u => u -> LocGraphic u
-strokedDisk radius = 
-    normalizeCtx radius >>= body
-  where
-    body r = makeLocGraphic strokeAttr
-                (\(rgb,attr) pt -> strokeEllipse rgb attr r r pt)
+dcDisk :: InterpretUnit u => DrawStyle -> u -> LocGraphic u
+dcDisk FILL radius = 
+    normalizeCtx radius >>= \r -> 
+    fillLoc (\rgb pt -> fillEllipse rgb r r pt)
 
+dcDisk STROKE radius = 
+    normalizeCtx radius >>= \r -> 
+    strokeLoc (\rgb attr pt -> strokeEllipse rgb attr r r pt)
 
+dcDisk FILL_STROKE radius = 
+    normalizeCtx radius >>= \r -> 
+    fillStrokeLoc (\frgb attr srgb pt -> fillStrokeEllipse frgb attr srgb r r pt)
 
 
--- | 'filledDisk' : @ radius -> LocGraphic @
---
--- Create a filled circle 'LocGraphic' - the implicit point is 
--- the center. 
--- 
--- This is a efficient representation of circles using 
--- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
--- output. As the circle is filled rather than drawn with a 
--- \"pen\" a @filledDisk@ can be scaled. 
---
--- The fill colour is taken from the implicit 'DrawingContext'.
--- 
-filledDisk :: InterpretUnit u => u -> LocGraphic u
-filledDisk radius = 
-    normalizeCtx radius >>= body
-  where
-    body r = makeLocGraphic fillAttr (\rgb pt -> fillEllipse rgb r r pt)
 
 
--- | 'borderedDisk' : @ radius -> LocGraphic @
---
--- Create a bordered circle 'LocGraphic' - the implicit point is 
--- the center. 
--- 
--- This is a efficient representation of circles using 
--- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
--- output. However, bordereded circles do not draw well after 
--- non-uniform scaling - the pen width of the outline is scaled as 
--- well as the shape.
---
--- For bordered circles that can be adequately scaled, use 
--- 'borderedCircle' instead.
---
--- The background fill colour and the outline stroke properties 
--- are taken from the implicit 'DrawingContext'.
--- 
-borderedDisk :: InterpretUnit u => u -> LocGraphic u
-borderedDisk radius = 
-    normalizeCtx radius >>= body
-  where
-    body r = makeLocGraphic borderedAttr
-                (\(frgb,attr,srgb) pt -> fillStrokeEllipse frgb attr srgb r r pt)
-
-
--- | 'strokedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
+-- | 'strokeEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
 --
 -- Create a stroked ellipse 'LocGraphic' - the implicit point is 
 -- the center. 
@@ -728,54 +578,15 @@
 -- The line properties (colour, pen thickness, etc.) are taken 
 -- from the implicit 'DrawingContext'.
 -- 
-strokedEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u
-strokedEllipseDisk rx ry = norm2 rx ry >>= body
-  where
-    body (drx,dry) = makeLocGraphic strokeAttr
-                        (\(rgb,attr) pt -> strokeEllipse rgb attr drx dry pt)
-
-
-
--- | 'filledEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
---
--- Create a filled ellipse 'LocGraphic' - the implicit point is 
--- the center. 
--- 
--- This is a efficient representation of ellipses using 
--- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated 
--- output. As the ellipse is filled rather than drawn with a 
--- \"pen\" a @filledEllipseDisk@ can be scaled. 
---
--- The fill colour is taken from the implicit 'DrawingContext'.
--- 
-filledEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u
-filledEllipseDisk rx ry = norm2 rx ry >>= body
-  where
-    body (drx,dry) = makeLocGraphic fillAttr
-                        (\rgb pt -> fillEllipse rgb drx dry pt)
-
+dcEllipseDisk :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u
+dcEllipseDisk style rx ry = 
+    normalizeCtx rx >>= \drx -> 
+    normalizeCtx ry >>= \dry -> 
+    case style of
+      FILL -> fillLoc (\rgb pt -> fillEllipse rgb drx dry pt)
+      STROKE -> strokeLoc (\rgb attr pt -> strokeEllipse rgb attr drx dry pt)
+      FILL_STROKE -> fillStrokeLoc $ 
+                       (\frgb attr srgb pt -> 
+                           fillStrokeEllipse frgb attr srgb drx dry pt)
 
--- | 'borderedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
---
--- Create a bordered ellipse 'LocGraphic' - the implicit point is 
--- the center. 
--- 
--- This is a efficient representation of ellipses using 
--- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated 
--- output. However, bordereded ellipses do not draw well after 
--- non-uniform scaling - the pen width of the outline is scaled as 
--- well as the shape.
---
--- For bordered ellipses that can be adequately scaled, use 
--- 'borderedEllipse' instead.
---
--- The background fill colour and the outline stroke properties 
--- are taken from the implicit 'DrawingContext'.
--- 
-borderedEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u
-borderedEllipseDisk rx ry = norm2 rx ry >>= body
-  where
-    body (drx,dry) = makeLocGraphic borderedAttr
-                          (\(frgb,attr,srgb) pt -> 
-                                fillStrokeEllipse frgb attr srgb drx dry pt)
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Image.hs b/src/Wumpus/Basic/Kernel/Objects/Image.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Kernel/Objects/Image.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-{-# OPTIONS -Wall #-}
-
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Kernel.Objects.Image
--- Copyright   :  (c) Stephen Tetley 2011
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  highly unstable
--- Portability :  GHC 
---
--- Image and Graphic types - these are functional types from the 
--- DrawingContext to a graphic /primitive/.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Kernel.Objects.Image
-   (
-     Graphic
-   , Image
-
-   , DImage
-   , DGraphic
-
-   , intoImage
-   , graphic_
-
-   , uconvImageF
-   , uconvImageZ
-
-   )
-
-   where
-
-import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Objects.Basis
-
-import Control.Applicative
-
-
--- | Image - function from the DrawingContext to a polymorphic 
--- /answer/ and a graphic /primitive/.
---
--- The answer is expected to be a Functor.
---
-type Image u a          = CF (ImageAns u a)
-
-
-
--- | Graphic - function from the DrawingContext to a graphic 
--- /primitive/.
---
-type Graphic u          = CF (GraphicAns u)
-
-
-
--- | Type specialized version of 'Image'.
---
-type DImage a           = Image Double a 
-
-
--- | Type specialized version of 'Graphic'.
---
-type DGraphic           = Graphic Double         
-
-
--- | 'intoImage' : @ query * graphic -> Image @
---
--- Build an 'Image' from a context function ('CF') that generates 
--- the answer and a 'Graphic' that draws the 'Image'.
---
-intoImage :: Query a -> Graphic u -> Image u a
-intoImage qf ma = replaceAns <$> qf <*> ma
-
-
--- | /Downcast/ an 'Image' to a 'Graphic'.
--- 
--- This means forgetting the answer of the Image, replacing it 
--- with @()@.
---
-graphic_ :: Image u a -> Graphic u
-graphic_ = fmap ignoreAns
-
-
-
-
-
--- | Use this to convert 'Graphic' or 'Image' with Functor answer.
---
-uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1)
-            => Image u (t u) -> Image u1 (t u1)
-uconvImageF = uconvR0 szconvAnsF
-
-
-uconvImageZ :: (InterpretUnit u, InterpretUnit u1)
-            => Image u a -> Image u1 a
-uconvImageZ = uconvR0 szconvAnsZ
-
-
-
---------------------------------------------------------------------------------
-
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
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -17,20 +18,29 @@
 
 module Wumpus.Basic.Kernel.Objects.LocImage
    (
-     LocGraphic
-   , LocImage
 
+     LocImage
+   , LocGraphic
+
    , DLocImage
    , DLocGraphic
 
-   , intoLocImage
-   , locGraphic_
+   , LocQuery
 
-   , emptyLocGraphic
+   , runLocImage
+   , runLocQuery
 
-   , uconvLocImageF
-   , uconvLocImageZ
+   , promoteLoc
+   , applyLoc
+   , qpromoteLoc
+   , qapplyLoc
+   , zapLocQuery
 
+   , emptyLocImage
+
+   , moveStart
+   , at
+
    -- * Composing LocImages
    , distrib
    , distribH 
@@ -46,11 +56,9 @@
    where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.QueryDC
-import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.Basis
-import Wumpus.Basic.Kernel.Objects.Displacement
 
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -62,20 +70,17 @@
 import Data.Monoid
 
 
--- | Graphic - function from DrawingContext and start point to a 
--- polymorphic /answer/ and a graphic /primitive/.
---
--- The answer is expected to be a Functor.
---
-type LocImage u a       = LocQuery u (ImageAns u a)
 
-
+-- | 'LocThetaImage' - function from  start point and 
+-- DrawingContext to a polymorphic /answer/ and a graphic 
+-- /primitive/ (PrimW).
+--
+newtype LocImage u a = LocImage { 
+          getLocImage :: Point2 u -> Image u a }
 
+type instance DUnit (LocImage u a) = u
 
--- | LocGraphic - function from DrawingContext and start point to 
--- a graphic /primitive/.
---
-type LocGraphic u       = LocQuery u (GraphicAns u)
+type LocGraphic u = LocImage u (UNil u)
 
 
 -- | Type specialized version of 'LocImage'.
@@ -86,57 +91,171 @@
 --
 type DLocGraphic        = LocGraphic Double 
 
+newtype LocQuery u a = LocQuery { 
+          getLocQuery :: Point2 u -> Query u a }
 
+-- Functor
 
+instance Functor (LocImage u) where
+  fmap f ma = LocImage $ \pt -> fmap f $ getLocImage ma pt
 
 
+instance Functor (LocQuery u) where
+  fmap f ma = LocQuery $ \pt -> fmap f $ getLocQuery ma pt
 
--- | 'intoLocImage' : @ loc_query * loc_graphic -> LocImage @
---
--- /Loc/ version of 'intoImage'. 
--- 
--- The 'LocImage' is built as a function from an implicit start 
--- point to the answer.
---
-intoLocImage :: LocQuery u a -> LocGraphic u -> LocImage u a
-intoLocImage ma gf = promoteR1 $ \pt -> 
-                     replaceAns <$> apply1R1 ma pt <*> apply1R1 gf pt
+-- Applicative
 
+instance Applicative (LocImage u) where
+  pure a    = LocImage $ \_  -> pure a
+  mf <*> ma = LocImage $ \pt -> getLocImage mf pt <*> getLocImage ma pt
 
--- | /Downcast/ an 'LocImage' to a 'LocGraphic'.
--- 
--- This means forgetting the answer of the LocImage, replacing it 
--- with @()@.
+instance Applicative (LocQuery u) where
+  pure a    = LocQuery $ \_  -> pure a
+  mf <*> ma = LocQuery $ \pt -> getLocQuery mf pt <*> getLocQuery ma pt
+                                
+
+
+-- Monad
+
+instance Monad (LocImage u) where
+  return a  = LocImage $ \_  -> return a
+  ma >>= k  = LocImage $ \pt -> getLocImage ma pt >>= \ans -> 
+                                  getLocImage (k ans) pt
+
+
+instance Monad (LocQuery u) where
+  return a  = LocQuery $ \_  -> return a
+  ma >>= k  = LocQuery $ \pt -> getLocQuery ma pt >>= \ans -> 
+                                  getLocQuery (k ans) pt
+
+
+-- Monoid
+
+instance Monoid a => Monoid (LocImage u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocImage $ \pt -> 
+                      getLocImage ma pt `mappend` getLocImage mb pt 
+
+instance Monoid a => Monoid (LocQuery u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocQuery $ \pt -> 
+                      getLocQuery ma pt `mappend` getLocQuery mb pt 
+
+-- DrawingCtxM
+
+instance DrawingCtxM (LocImage u) where
+  askDC           = LocImage $ \_  -> askDC
+  asksDC fn       = LocImage $ \_  -> asksDC fn
+  localize upd ma = LocImage $ \pt -> localize upd (getLocImage ma pt)
+
+instance DrawingCtxM (LocQuery u) where
+  askDC           = LocQuery $ \_  -> askDC
+  asksDC fn       = LocQuery $ \_  -> asksDC fn
+  localize upd ma = LocQuery $ \pt -> localize upd (getLocQuery ma pt)
+
+
+
+  
+instance Decorate LocImage where
+  decorate ma mz = LocImage $ \pt -> 
+                      getLocImage ma pt `decorate` getLocImage mz pt 
+
+  elaborate ma f = LocImage $ \pt -> 
+                      getLocImage ma pt `elaborate` (\a -> getLocImage (f a) pt)
+
+  obliterate ma mz = LocImage $ \pt -> 
+                       getLocImage ma pt `obliterate` getLocImage mz 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)
+
+runLocQuery :: Point2 u -> DrawingContext -> LocQuery u a -> a
+runLocQuery pt ctx mf = runQuery ctx (getLocQuery mf pt)
+
+
+
+promoteLoc ::  (Point2 u -> Image u a) -> LocImage u a
+promoteLoc k = LocImage $ \pt -> k pt
+
+applyLoc :: LocImage u a -> Point2 u -> Image u a
+applyLoc mq pt = getLocImage mq pt
+
+
+qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a
+qpromoteLoc k = LocQuery $ \pt -> k pt
+
+qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
+qapplyLoc mq pt = getLocQuery mq pt
+
+
+-- qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
+-- qapplyLoc mq pt = getLocQuery mq pt
+
+-- | \"zero-apply\" a LocQuery.
 --
-locGraphic_ :: LocImage u a -> LocGraphic u
-locGraphic_ = (fmap . fmap) ignoreAns
+zapLocQuery :: LocQuery u a -> Point2 u -> Image u a
+zapLocQuery mq pt = askDC >>= \ctx -> let a = runLocQuery pt ctx mq in return a
 
 
--- | 'emptyLocGraphic' : @ LocGraphic @
+
+-- Maybe there is need for a function line qapplyLoc of this type:
 --
--- Build an empty 'LocGraphic' (i.e. a function 
--- /from Point to Graphic/). This is a path with a start point 
--- but no path segments. 
+-- > blankLoc :: LocQuery u a -> Point2 u -> Image u a
 -- 
--- The 'emptyLocGraphic' is treated as a /null primitive/ by 
--- @Wumpus-Core@ and is not drawn, although it does generate a 
--- minimum bounding box at the implicit start point.
+-- This then means we can have monadic bind back for the notation:
+--
+-- > qapplyLocTheta (rellipsePath rx ry) pt ang  `bindQ` dcClosedPath style
 -- 
-emptyLocGraphic :: InterpretUnit u => LocGraphic u
-emptyLocGraphic = promoteR1 $ \pt -> 
-                  uconvertCtxF pt >>= \dpt -> 
-                  return $ graphicAns $ prim1 $ zostroke $ emptyPrimPath dpt
+-- becomes
+--
+-- > blankLoc (rellipsePath rx ry) pt ang >>= dcClosedPath style
 
 
+--------------------------------------------------------------------------------
+-- Affine instances
 
+instance (Real u, Floating u, Rotate a) => Rotate (LocImage u a) where
+  rotate ang ma = promoteLoc $ \pt -> 
+                     fmap (rotate ang) $ getLocImage ma (rotate ang pt)
 
 
+instance (Real u, Floating u, RotateAbout a, ScalarUnit u, u ~ DUnit a) => 
+    RotateAbout (LocImage u a) where
+  rotateAbout ang pt ma = promoteLoc $ \p0 -> 
+                            fmap (rotateAbout ang pt) $ 
+                              getLocImage ma (rotateAbout ang pt p0)
+
+
+instance (Fractional u, Scale a) => Scale (LocImage u a) where
+  scale sx sy ma = promoteLoc $ \pt -> 
+                   fmap (scale sx sy) $ getLocImage ma (scale sx sy pt)
+
+instance (Num u, Translate a, ScalarUnit u, u ~ DUnit a) => 
+    Translate (LocImage u a) where
+  translate dx dy ma = promoteLoc $ \pt -> 
+                         fmap (translate dx dy) $ 
+                           getLocImage ma (translate dx dy pt)
+
+--------------------------------------------------------------------------------
+
+
+instance UConvert LocImage where
+  uconvF = uconvLocImageF
+  uconvZ = uconvLocImageZ
+
 -- | Use this to convert 'LocGraphic' or 'LocImage' with Functor 
 -- answer.
 --
 uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
                => LocImage u (t u) -> LocImage u1 (t u1)
-uconvLocImageF = uconvR1 szconvAnsF
+uconvLocImageF ma = LocImage $ \pt -> 
+    getFontSize >>= \sz -> 
+    let ptu = uconvertF sz pt
+    in uconvF $ getLocImage ma ptu
 
 
 
@@ -144,10 +263,38 @@
 --
 uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1) 
                => LocImage u a -> LocImage u1 a
-uconvLocImageZ = uconvR1 szconvAnsZ
+uconvLocImageZ ma = LocImage $ \pt -> 
+    getFontSize >>= \sz ->  
+    let ptu = uconvertF sz pt
+    in uconvZ $ getLocImage ma ptu
 
 
+-- | Having /empty/ at the specific 'LocImage' type is useful.
+-- 
+emptyLocImage :: Monoid a => LocImage u a
+emptyLocImage = mempty
 
+
+
+
+-- Note - maybe this should just be an operator on LocImage...
+--
+
+moveStart :: Num u => Vec2 u -> LocImage u a -> LocImage u a
+moveStart v1 ma = LocImage $ \pt -> getLocImage ma (pt .+^ v1) 
+
+
+
+infixr 1 `at`
+
+
+-- | 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
+
+
 --------------------------------------------------------------------------------
 -- Combining LocImages 
 
@@ -162,12 +309,12 @@
 
 distrib :: (Monoid a, InterpretUnit u) 
         => Vec2 u -> [LocImage u a]  -> LocImage u a
-distrib _  [] = pushR1 (replaceAns mempty) $ emptyLocGraphic
-distrib v1 (x:xs) = promoteR1 $ \pt -> 
-    go (x `at` pt) (pt .+^ v1) xs
+distrib _  []     = mempty
+distrib v1 (x:xs) = promoteLoc $ \pt -> 
+    go (applyLoc x pt) (pt .+^ v1) xs
   where
     go acc _  []     = acc
-    go acc pt (a:as) = go (acc `mappend` apply1R1 a pt) (pt .+^ v1) as
+    go acc pt (a:as) = go (acc `mappend` applyLoc a pt) (pt .+^ v1) as
 
 distribH :: (Monoid a, InterpretUnit u) 
          => u -> [LocImage u a]  -> LocImage u a
@@ -178,17 +325,16 @@
 distribV dy = distrib (hvec dy)
 
 
-
 -- | This is analogue to @replicate@ in the Prelude.
 --
 duplicate :: (Monoid a, InterpretUnit u) 
           => Int -> Vec2 u -> LocImage u a -> LocImage u a
-duplicate n _ _   | n < 1 = pushR1 (replaceAns mempty) $ emptyLocGraphic
+duplicate n _ _   | n < 1 = mempty
 duplicate n v img         = go img v (n-1)
   where
      go acc _  i | i < 1 = acc
-     go acc va i         = let img1 = moveStart (displaceVec va) img
-                           in go (acc `mappend` img1) (va ^+^ v) (i-1)
+     go acc v1 i         = let img1 = moveStart v1 img
+                           in go (acc `mappend` img1) (v1 ^+^ v) (i-1)
 
 duplicateH :: (Monoid a, InterpretUnit u) 
            => Int -> u -> LocImage u a -> LocImage u a
@@ -197,3 +343,4 @@
 duplicateV :: (Monoid a, InterpretUnit u) 
            => Int -> u -> LocImage u a -> LocImage u a
 duplicateV n dy = duplicate n (vvec dy)
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
--- a/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -24,344 +25,231 @@
    , DLocThetaGraphic
    , DLocThetaImage
 
-   , intoLocThetaImage
-   , locThetaGraphic_
+   , LocThetaQuery
 
-   , emptyLocThetaGraphic
+   , runLocThetaImage
+   , runLocThetaQuery
 
-   , uconvLocThetaImageF
-   , uconvLocThetaImageZ
+   , promoteLocTheta
+   , applyLocTheta
+   , qpromoteLocTheta
+   , qapplyLocTheta
+   , zapLocThetaQuery
 
+   , emptyLocThetaImage
+
+   , incline
+   , atIncline
    
    )
 
    where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Base.DrawingContext
+import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Objects.Basis
--- import Wumpus.Basic.Kernel.Objects.Displacement
 import Wumpus.Basic.Kernel.Objects.LocImage
 
--- import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core                              -- package: wumpus-core
 
 import Control.Applicative
-
+import Data.Monoid
 
--- | 'LocThetaImage' - function from DrawingContext, start point 
--- and inclination to a polymorphic /answer/ and a graphic 
--- /primitive/ (ImageAns).
---
--- The answer is expected to be a Functor.
+-- | 'LocThetaImage' - function from start point, inclination and
+-- DrawingContext to a polymorphic /answer/ and a graphic 
+-- /primitive/ (PrimW).
 --
-type LocThetaImage u a = LocThetaQuery u (ImageAns u a)
+newtype LocThetaImage u a = LocThetaImage { 
+          getLocThetaImage :: Point2 u -> Radian -> Image u a }
 
+type instance DUnit (LocThetaImage u a) = u
 
--- | LocThetaGraphic - function from DrawingContext, start point 
--- and inclination to a graphic /primitive/ (GraphicAns).
---
-type LocThetaGraphic u  = LocThetaQuery u (GraphicAns u)
+type LocThetaGraphic u = LocThetaImage u (UNil u)
 
 
 -- | Type specialized version of 'LocThetaImage'.
 --
-type DLocThetaImage a   = LocThetaImage Double a
+type DLocThetaImage a        = LocThetaImage Double a
 
 -- | Type specialized version of 'LocThetaGraphic'.
 --
-type DLocThetaGraphic   = LocThetaGraphic Double 
+type DLocThetaGraphic        = LocThetaGraphic Double 
 
 
+newtype LocThetaQuery u a = LocThetaQuery { 
+          getLocThetaQuery :: Point2 u -> Radian -> Query u a }
 
+-- Functor
 
--- | 'intoLocThetaImage' : @ loc_theta_query * loc_theta_graphic -> LocThetaImage @
---
--- /LocTheta/ version of 'intoImage'. 
--- 
--- The 'LocThetaImage' is built as a function from an implicit 
--- start point and angle of inclination to the answer.
---
-intoLocThetaImage :: LocThetaQuery u a 
-                  -> LocThetaGraphic u 
-                  -> LocThetaImage u a
-intoLocThetaImage qf ma = 
-    promoteR2 $ \a b -> replaceAns <$> apply2R2 qf a b <*> apply2R2 ma a b
+instance Functor (LocThetaImage u) where
+  fmap f ma = LocThetaImage $ \pt ang -> 
+                fmap f $ getLocThetaImage ma pt ang
 
+instance Functor (LocThetaQuery u) where
+  fmap f ma = LocThetaQuery $ \pt ang -> 
+                fmap f $ getLocThetaQuery ma pt ang
 
 
--- | /Downcast/ an 'LocThetaImage' to a 'LocThetaGraphic'.
--- 
--- This means forgetting the answer of the Image, replacing it 
--- with @()@.
---
-locThetaGraphic_ :: LocThetaImage u a -> LocThetaGraphic u
-locThetaGraphic_ = (fmap . fmap . fmap) ignoreAns
+-- Applicative
 
+instance Applicative (LocThetaImage u) where
+  pure a    = LocThetaImage $ \_  _   -> pure a
+  mf <*> ma = LocThetaImage $ \pt ang -> 
+                getLocThetaImage mf pt ang <*> getLocThetaImage ma pt ang
 
--- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @
---
--- Build an empty 'LocThetaGraphic' (i.e. a function 
--- /from Point and Inclination to Graphic/). 
--- 
--- The 'emptyLocThetaGraphic' is treated as a /null primitive/ by 
--- @Wumpus-Core@ and is not drawn, although it does generate a 
--- minimum bounding box at the implicit start point.
--- 
-emptyLocThetaGraphic :: InterpretUnit u => LocThetaGraphic u
-emptyLocThetaGraphic = lift1R2 emptyLocGraphic
+instance Applicative (LocThetaQuery u) where
+  pure a    = LocThetaQuery $ \_  _   -> pure a
+  mf <*> ma = LocThetaQuery $ \pt ang -> 
+                getLocThetaQuery mf pt ang <*> getLocThetaQuery ma pt ang
 
 
+-- Monad 
 
+instance Monad (LocThetaImage u) where
+  return a  = LocThetaImage $ \_  _   -> return a
+  ma >>= k  = LocThetaImage $ \pt ang -> 
+                getLocThetaImage ma pt ang >>= \ans -> 
+                getLocThetaImage (k ans) pt ang
 
--- | Use this to convert 'LocThetaGraphic' or 'LocThetaImage' 
--- with Functor answer.
---
-uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
-                    => LocThetaImage u (t u) -> LocThetaImage u1 (t u1)
-uconvLocThetaImageF = uconvR2a szconvAnsF
 
+instance Monad (LocThetaQuery u) where
+  return a  = LocThetaQuery $ \_  _   -> return a
+  ma >>= k  = LocThetaQuery $ \pt ang -> 
+                getLocThetaQuery ma pt ang >>= \ans -> 
+                getLocThetaQuery (k ans) pt ang
 
+-- Monoid
 
--- | Use this to convert 'LocThetaImage' with unit-less answer.
---
-uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) 
-                    => LocThetaImage u a -> LocThetaImage u1 a
-uconvLocThetaImageZ = uconvR2a szconvAnsZ
+instance Monoid a => Monoid (LocThetaImage u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocThetaImage $ \pt ang -> 
+                      getLocThetaImage ma pt ang 
+                         `mappend` getLocThetaImage mb pt ang
 
 
 
+instance Monoid a => Monoid (LocThetaQuery u a) where
+  mempty          = pure mempty
+  ma `mappend` mb = LocThetaQuery $ \pt ang -> 
+                      getLocThetaQuery ma pt ang 
+                         `mappend` getLocThetaQuery mb pt ang
 
---------------------------------------------------------------------------------
--- Combining LocThetaImages
+-- DrawingCtxM
 
-{-
+instance DrawingCtxM (LocThetaImage u) where
+  askDC           = LocThetaImage $ \_  _   -> askDC
+  asksDC fn       = LocThetaImage $ \_  _   -> asksDC fn
+  localize upd ma = LocThetaImage $ \pt ang -> 
+                      localize upd (getLocThetaImage ma pt ang)
 
-infixr 6 `catLTI`
-infixr 5 `sepLTI`
+instance DrawingCtxM (LocThetaQuery u) where
+  askDC           = LocThetaQuery $ \_  _   -> askDC
+  asksDC fn       = LocThetaQuery $ \_  _   -> asksDC fn
+  localize upd ma = LocThetaQuery $ \pt ang -> 
+                      localize upd (getLocThetaQuery ma pt ang)
 
--- | Concatenate two LocThetaImages. The start point is /shared/.
 --
--- This is just @oplus@.
---
-catLTI :: OPlus (t u)
-       => LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u
-catLTI = oplus
 
+instance Decorate LocThetaImage where
+  decorate ma mz = LocThetaImage $ \pt ang -> 
+                      getLocThetaImage ma pt ang `decorate` 
+                        getLocThetaImage mz pt ang
 
+  elaborate ma f = LocThetaImage $ \pt ang -> 
+                     getLocThetaImage ma pt ang `elaborate` 
+                       (\a -> getLocThetaImage (f a) pt ang)
 
--- | Concatenate two LocThetaImages, the second LocThetaImage is 
--- displaced /orthonormally/ from the the start point by the 
--- supplied vector (separator). 
---
--- Here, /orthonormally/ means that the x-component of the vector
--- displaces the second LocThetaImage in parallel to the angle
--- of inclination, the y-component of the vector displaces 
--- perpendicular to the incliantion.
---
--- Note - the separator is exactly a displacement of the start
--- point, LocImages have no notion of border so this function
--- can only be used to concatenate to objects side by side if
--- there boundaries are known beforehand.
--- 
--- Consider a PosThetaImage if you need more sophisticated arrangement.
--- 
-sepLTI :: (Floating u, OPlus (t u))
-       => Vec2 u -> LocThetaImage t u -> LocThetaImage t u 
-       -> LocThetaImage t u
-sepLTI v g1 g2 = g1 `oplus` moveStartTheta (displaceOrtho v) g2
+  obliterate ma mz = LocThetaImage $ \pt ang -> 
+                       getLocThetaImage ma pt ang `obliterate` 
+                         getLocThetaImage mz pt ang
 
+  hyperlink xl ma = LocThetaImage $ \pt ang -> 
+                       hyperlink xl $ getLocThetaImage ma pt ang
+           
 
 
--- | Concatenate two LocThetaImages, the second LocImage is 
--- displaced parallel to the inclination by the supplied distance. 
---
--- Note - this is exactly a start point displacement. See the 
--- caveat for 'sepLTI'.
--- 
-paraSepLTI :: (Floating u, OPlus (t u))
-           => u -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u
-paraSepLTI u = sepLTI (hvec u)
 
+runLocThetaImage :: Point2 u -> Radian -> DrawingContext 
+                 -> LocThetaImage u a 
+                 -> PrimW u a
+runLocThetaImage pt incl ctx mf = runImage ctx (getLocThetaImage mf pt incl)
 
 
--- | Concatenate two LocThetaImages, the second LocThetaImage is 
--- displaced perpendicular to the inclination by the supplied 
--- distance.
---
--- Note - this is exactly a start point displacement. See the 
--- caveat for 'sepLTI'.
--- 
-perpSepLTI :: (Floating u, OPlus (t u))
-       => u -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u
-perpSepLTI u = sepLTI (vvec u)
+runLocThetaQuery :: Point2 u -> Radian -> DrawingContext 
+                 -> LocThetaQuery u a 
+                 -> a
+runLocThetaQuery pt incl ctx mf = runQuery ctx (getLocThetaQuery mf pt incl)
 
 
--- | Repeatedly draw a LocThetaImage, moving the start point each time 
--- /orthonormally/ by the supplied vector.
---
--- Note - the first LocThetaImage argument is the /empty/ alternative
--- this is drawn if the repeat count is less than 1.
---
-repeatLTI :: (Floating u, OPlus (t u))
-          => LocThetaImage t u -> Int -> Vec2 u -> LocThetaImage t u 
-          -> LocThetaImage t u
-repeatLTI alt i _  _  | i < 1 = alt
-repeatLTI _   i v  gf         = promoteR2 $ \start ang -> body start ang
-  where
-    body start ang = go (i-1) (drawF start) (moveF start)
-      where
-        drawF pt                = atIncline gf pt ang
-        moveF pt                = displaceOrtho v ang pt
-        go n acc pt | n < 1     = acc
-                    | otherwise = go (n-1) (acc `oplus` drawF pt) (moveF pt)
+promoteLocTheta ::  (Point2 u -> Radian -> Image u a) -> LocThetaImage u a
+promoteLocTheta k = LocThetaImage $ \pt ang -> k pt ang
 
+applyLocTheta :: LocThetaImage u a -> Point2 u -> Radian -> Image u a
+applyLocTheta mq pt ang = getLocThetaImage mq pt ang
 
 
--- | Repeatedly draw a LocThetaImage, moving parallel to the 
--- inclination each time by the supplied distance.
---
--- Note - this draws the alternative LocThetaImage if the repeat count 
--- is less than 1.
---
-paraRepeatLTI :: (Floating u, OPlus (t u))
-              => LocThetaImage t u -> Int -> u -> LocThetaImage t u 
-              -> LocThetaImage t u
-paraRepeatLTI alt i u = repeatLTI alt i (hvec u) 
+qpromoteLocTheta :: (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a
+qpromoteLocTheta k = LocThetaQuery $ \pt ang -> k pt ang
 
 
+qapplyLocTheta :: LocThetaQuery u a -> Point2 u -> Radian -> Query u a
+qapplyLocTheta mq pt ang = getLocThetaQuery mq pt ang
 
--- | Repeatedly draw a LocThetaImage, moving perpendicular to the
--- inclination each time by the supplied distance.
---
--- Note - this draws the alternative LocThetaImage if the repeat count 
--- is less than 1.
+-- | \"zero-apply\" a LocThetaQuery.
 --
-perpRepeatLTI :: (Floating u, OPlus (t u))
-          => LocThetaImage t u -> Int -> u -> LocThetaImage t u -> LocThetaImage t u
-perpRepeatLTI alt i u = repeatLTI alt i (vvec u) 
+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
 
 
 
--- | Concatenate a list of LocThetaImages, spacing them by moving 
--- the start point /orthonormally/ each time by the supplied 
--- vector.
---
--- Note - this draws the /empty/ alternative if the list is empty.
---
-spaceLTI :: (Floating u, OPlus (t u))
-         => LocThetaImage t u -> Vec2 u -> [LocThetaImage t u] 
-         -> LocThetaImage t u
-spaceLTI alt _ []     = alt
-spaceLTI _   v (g:gs) = promoteR2 $ \start ang -> body start ang 
-  where
-    body start ang = go (drawF g start) (moveF start) gs
-      where
-        drawF gf pt      = atIncline gf pt ang
-        moveF pt         = displaceOrtho v ang pt
-        go acc _  []     = acc
-        go acc pt (f:fs) = go (acc `oplus` drawF f pt) (moveF pt) fs
-
+instance UConvert LocThetaImage where
+  uconvF = uconvLocThetaImageF
+  uconvZ = uconvLocThetaImageZ
 
 
--- | Concatenate a list of LocThetaImages, spacing them by moving 
--- the start point parallel to the inclination each time by the 
--- supplied distance.
---
--- Note - this draws the /empty/ alternative if the list is empty.
+-- | Use this to convert 'LocThetaThetaGraphic' or 'LocThetaThetaImage' 
+-- with Functor answer.
 --
-paraSpaceLTI :: (Floating u, OPlus (t u))
-              => LocThetaImage t u -> u -> [LocThetaImage t u] 
-              -> LocThetaImage t u
-paraSpaceLTI alt u = spaceLTI alt (hvec u)
+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
 
 
--- | Concatenate a list of LocThetaImages, spacing them by moving 
--- the start point perpendicular to the inclination each time by 
--- the supplied distance.
---
--- Note - this draws the /empty/ alternative if the list is empty.
---
-perpSpaceLTI :: (Floating u, OPlus (t u))
-              => LocThetaImage t u -> u -> [LocThetaImage t u] 
-              -> LocThetaImage t u
-perpSpaceLTI alt u = spaceLTI alt (vvec u)
 
 
--- | Enclose l r x
---
--- Note - the @left@ LocThetaImage is drawn at the start point, the 
--- LocThetaImage @x@ is concatenated with 'sepLTI' then the right 
--- LocThetaImage is concatenated with 'sepLi'.
+-- | Use this to convert 'LocThetaImage' with unit-less answer.
 --
-encloseLTI :: (Floating u, OPlus (t u))
-           => Vec2 u 
-           -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u 
-           -> LocThetaImage t u
-encloseLTI v lft rht obj = lft `op` obj `op` rht
-  where
-    op = sepLTI v
+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
 
 
 
--- | Parallel version of 'encloseLTI'.
---
--- Note - the @left@ LocThetaImage is drawn at the start point, the 
--- LocThetaImage @x@ is concatenated with 'sepLTI' then the right 
--- LocThetaImage is concatenated with 'sepLTI'.
---
-paraEncloseLTI :: (Floating u, OPlus (t u))
-               => u 
-               -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u 
-               -> LocThetaImage t u
-paraEncloseLTI u = encloseLTI (hvec u)
+-- | Having /empty/ at the specific 'LocThetaImage' type is useful.
+-- 
+emptyLocThetaImage :: Monoid a => LocThetaImage u a
+emptyLocThetaImage = mempty
 
 
 
--- | Perpendicular version of 'encloseLTI'.
---
--- Note - the @left@ LocThetaImage is drawn at the start point, the 
--- LocThetaImage @x@ is concatenated with 'sepLTI' then the right 
--- LocThetaImage is concatenated with 'sepLTI'.
---
-perpEncloseLTI :: (Floating u, OPlus (t u))
-               => u 
-               -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u 
-               -> LocThetaImage t u
-perpEncloseLTI u = encloseLTI (vvec u)
 
 
-
--- | Concatenate a list of LocThetaImages, punctuating with the 
--- separator.
---
--- Note - this draws the /empty/ alternative if the list is empty.
---
-punctuateLTI :: (Floating u, OPlus (t u))
-             => LocThetaImage t u -> Vec2 u 
-             -> LocThetaImage t u -> [LocThetaImage t u] 
-             -> LocThetaImage t u
-punctuateLTI alt _ _   []     = alt
-punctuateLTI _   v sep (g:gs) = go g gs
-  where 
-    go acc []     = acc
-    go acc (f:fs) = go (encloseLTI v acc f sep) fs
-
-
--- | Parallel version of 'punctuateLTI'
---
-paraPunctuateLTI :: (Floating u, OPlus (t u))
-                 => LocThetaImage t u -> u 
-                 -> LocThetaImage t u -> [LocThetaImage t u] 
-                 -> LocThetaImage t u
-paraPunctuateLTI alt u = punctuateLTI alt (hvec u)
+infixr 1 `incline`
 
 
--- | Perpendicular version of 'punctuateLTI'
---
-perpPunctuateLTI :: (Floating u, OPlus (t u))
-                 => LocThetaImage t u -> u 
-                 -> LocThetaImage t u -> [LocThetaImage t u] 
-                 -> LocThetaImage t u
-perpPunctuateLTI alt u = punctuateLTI alt (vvec u)
+-- | 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
 
--}
+atIncline :: LocThetaImage u a -> Point2 u -> Radian -> Image u a
+atIncline ma pt incl = getLocThetaImage ma pt incl
diff --git a/src/Wumpus/Basic/Kernel/Objects/PosObject.hs b/src/Wumpus/Basic/Kernel/Objects/PosObject.hs
--- a/src/Wumpus/Basic/Kernel/Objects/PosObject.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/PosObject.hs
@@ -29,34 +29,19 @@
     PosObject
   , DPosObject
 
-  , LocRectQuery
-  , BoundedLocRectGraphic
 
   -- * Operations
+  , runPosObject
 
   , makePosObject
-  , makeBindPosObject
+--  , makeBindPosObject
   , emptyPosObject
-  , runPosObjectR0
-  , runPosObjectR1
-  , runPosObjectR2
 
 
-  , localizePO 
-  , elaboratePO
-  , aelaboratePO 
- 
-  , startAddr
-  , atStartAddr
-
+  , localPosObject
+  , decoPosObject
   , extendPosObject
-
-  , padHorizontalPO
-  , padLeftPO
-  , padRightPO
-  , padVerticalPO
-  , padUpPO
-  , padDownPO
+  , mapOrientation
 
   , illustratePosObject
 
@@ -65,15 +50,13 @@
 
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Base.UpdateDC
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.Basis
-import Wumpus.Basic.Kernel.Objects.Bounded
 import Wumpus.Basic.Kernel.Objects.Concat
 import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
-import Wumpus.Basic.Kernel.Objects.Displacement
 import Wumpus.Basic.Kernel.Objects.LocImage
 import Wumpus.Basic.Kernel.Objects.Orientation
 
@@ -94,14 +77,14 @@
 -- graphic from a PosImage have to be generated within the same 
 -- DrawingContext.
 --
-type PosDraw u = Point2 u -> GraphicAns u
+type PosDraw u = Point2 u -> CatPrim
 
 
 -- | A positionable \"Object\" that is drawn as a 
 -- 'BoundedLocGraphic'.
 --
 newtype PosObject u = PosObject 
-          { getPosObject :: CF (Orientation u, PosDraw u) }
+          { getPosObject :: Query u (Orientation u, PosDraw u) }
 
 type instance DUnit (PosObject u) = u
     
@@ -112,38 +95,55 @@
 
 
 
-type LocRectQuery u a = CF (Point2 u ->  RectAddress -> a)
 
-type BoundedLocRectGraphic u = LocRectQuery u (ImageAns u (BoundingBox u))
-
 --------------------------------------------------------------------------------
 
 
-instance (Fractional u, Ord u) => OPlus (PosObject u) where
-  oplus = poconcat
 
 instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where
-  mempty = pozero
+  mempty  = emptyPosObject
   mappend = poconcat
 
 
-pozero :: InterpretUnit u => PosObject u
-pozero = PosObject body
-  where
-    body = drawingCtx >>= \ctx -> 
-           let pf = \pt -> runCF ctx (apply1R1 emptyLocGraphic pt)
-           in return (Orientation 0 0 0 0, pf)
 
 poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u
 poconcat a b = PosObject body
    where
-     body = drawingCtx >>= \ctx -> 
-            let (o0,pf0) = runCF ctx (getPosObject a)
-                (o1,pf1) = runCF ctx (getPosObject b)
-                pf       = \pt -> pf0 pt `oplus` pf1 pt
-            in return (o0 `oplus` o1, pf)
+    body = askDC >>= \ctx ->
+           let ans1 = runQuery ctx (getPosObject a)
+               ans2 = runQuery ctx (getPosObject b)
+           in pure (appendW ans1 ans2)
 
 
+
+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)
+
+
+
+-- | 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.
+--
+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)
+
+
+
 -- | 'makePosObject' : @ object_pos * loc_image -> PosObject @ 
 --
 -- Create a 'PosObject' from an 'Orientation' describing how it
@@ -154,30 +154,15 @@
 -- PosObject type is considered as a specialized object it does
 -- not have the range of functions of LocImage or LocThetaImage.
 -- 
-makePosObject :: Query (Orientation u) -> LocGraphic u -> PosObject u
+makePosObject :: Query u (Orientation u) -> LocGraphic u -> PosObject u
 makePosObject qortt gf = PosObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let ortt = runCF ctx qortt
-               pf   = runCF ctx gf
-           in return (ortt,pf)
-
-
--- | This is a bit of a hack to overcome that the newtype 
--- wrapper around PosObject stops monadic bind operating 
--- with the internal CF function.
---
-makeBindPosObject :: Query a 
-                  -> (a -> Query (Orientation u)) -> (a -> LocGraphic u) 
-                  -> PosObject u 
-makeBindPosObject qy mkO mkG = PosObject body
-  where
-    body = drawingCtx >>= \ctx -> 
-           let a    = runCF ctx qy
-               ortt = runCF ctx (mkO a)
-               pf   = runCF ctx (mkG a)
-           in return (ortt,pf)
+    body = askDC >>= \ctx -> 
+           let v1   = runQuery ctx qortt
+               pf   = \pt -> getCP $ runLocImage pt ctx gf
+           in return (v1,pf)
 
+    getCP (PrimW ca _) = ca
 
 
 -- | 'emptyPosObject' : @ PosObject @
@@ -185,102 +170,31 @@
 -- Build an empty 'PosGraphicObject'.
 --
 emptyPosObject :: InterpretUnit u => PosObject u
-emptyPosObject = 
-    makePosObject (pure $ Orientation 0 0 0 0) emptyLocGraphic
+emptyPosObject = PosObject $ pure (Orientation 0 0 0 0, const mempty)
 
     
--- | Run a PosObject forming an Image (an /arity zero/ answer).
---
-runPosObjectR0 :: Fractional u 
-               => Point2 u -> RectAddress -> PosObject u -> BoundedGraphic u
-runPosObjectR0 pt addr (PosObject mf) = 
-    mf >>= \(ortt,ptf) -> let sv = orientationStart addr ortt
-                              bb = orientationBounds ortt (displaceVec sv pt)
-                          in pure $ replaceAns bb $ ptf $ displaceVec sv pt
 
 
 
--- | Version of 'runPosObject' that produces a 
--- 'BoundedLocGraphic'. 
--- 
--- 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.
---
-runPosObjectR1 :: Fractional u 
-               => RectAddress -> PosObject u -> BoundedLocGraphic u
-runPosObjectR1 addr obj = promoteR1 $ \start -> runPosObjectR0 start addr obj
-
-
--- | Version of 'runPosObject' that produces a 
--- 'BoundedLocRectGraphic'. 
--- 
--- The 'PosObject' is run with no explicit arguments (rect-address 
--- or start-point) so the corresponding answer is an /arity two/ 
--- Graphic that needs drawing with the start-point and 
--- rect-address.
---
-runPosObjectR2 :: Fractional u 
-               => PosObject u -> BoundedLocRectGraphic u
-runPosObjectR2 obj = promoteR2 $ \start addr -> runPosObjectR0 start addr obj
-
-
-
--- | Run a DrawingContext update within a 'PosObject'.
+-- | Apply a DrawingContext update to a 'PosObject'.
 --
-localizePO :: DrawingContextF -> PosObject u -> PosObject u
-localizePO upd = PosObject . localize upd . getPosObject
+localPosObject :: DrawingContextF -> PosObject u -> PosObject u
+localPosObject upd = PosObject . localize upd . getPosObject
 
 
--- | 'decorate' -like functionality.
---
-elaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u
-elaboratePO fn po = PosObject body
-  where
-    body = drawingCtx >>= \ctx -> 
-           let (ortt,ptf) = runCF ctx (getPosObject po)
-               deco       = runCF ctx (fn ortt)
-           in return (ortt, ptf `oplus` deco)
-
--- | ante-eloborate
---
-aelaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u
-aelaboratePO fn po = PosObject body
+decoPosObject :: (Orientation u -> LocGraphic u) -> ZDeco 
+              -> PosObject u -> PosObject u
+decoPosObject fn zdec po = PosObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let (ortt,ptf) = runCF ctx (getPosObject po)
-               deco       = runCF ctx (fn ortt)
-           in return (ortt, deco `oplus` ptf)
-
-
-
-
-
-infixr 1 `startAddr`
-
--- | 'startAddr' : @ bounded_loc_rect * rect_pos -> BoundedlocGraphic @
---
--- /Downcast/ a 'BoundedLocRectGraphic' to a 'BoundedLocGraphic' 
--- by supplying it with a 'RectAddress' (start address on the 
--- rectangle frame).
---  
-startAddr :: Floating u 
-          => BoundedLocRectGraphic u -> RectAddress -> BoundedLocGraphic u
-startAddr = apply1R2 
-
-
+    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)
 
--- | 'atStartAddr' : @ bounded_loc_rect * start_point * rect_pos 
---      -> BoundedGraphic @
---
--- /Downcast/ a 'BoundedLocRectGraphic' to a 'BoundedGraphic' by 
--- supplying it with an initial point and a 'RectAddress' (start 
--- address on the rectangle frame).
---  
-atStartAddr ::  Floating u 
-            => BoundedLocRectGraphic u -> Point2 u -> RectAddress 
-            -> BoundedGraphic u
-atStartAddr = apply2R2
+    getCP (PrimW ca _) = ca
 
 
 
@@ -290,42 +204,19 @@
                 => u -> u -> u -> u -> PosObject u -> PosObject u
 extendPosObject x0 x1 y0 y1 po = PosObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let (o0,pf0) = runCF ctx (getPosObject po)
+    body = askDC >>= \ctx -> 
+           let (o0,pf0) = runQuery ctx (getPosObject po)
                ortt     = extendOrientation x0 x1 y0 y1 o0
            in return (ortt,pf0)
 
-           
---------------------------------------------------------------------------------
--- Padding
 
-padHorizontalPO     :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u
-padHorizontalPO w   = genPad (padHEven w)
 
-padLeftPO       :: (Num u, Ord u) => u -> PosObject u -> PosObject u
-padLeftPO w     = genPad (padXMinor w)
-
-padRightPO      :: (Num u, Ord u) => u -> PosObject u -> PosObject u
-padRightPO w    = genPad (padXMajor w)
-
-
-padVerticalPO       :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u
-padVerticalPO w     = genPad (padVEven w)
-
-padUpPO         :: (Num u, Ord u) => u -> PosObject u -> PosObject u
-padUpPO h       = genPad (padYMajor h)
-
-padDownPO       :: (Num u, Ord u) => u -> PosObject u -> PosObject u
-padDownPO h     = genPad (padYMinor h)
-
-
-genPad :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u
-genPad fn po = PosObject body
+mapOrientation :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u
+mapOrientation fn po = PosObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let (o0,pf0) = runCF ctx (getPosObject po)
-               ortt     = fn o0
-           in return (ortt,pf0)
+    body = askDC >>= \ctx -> 
+           let (o0,pf0) = runQuery ctx (getPosObject po)
+           in return (fn o0,pf0)
 
 
 --------------------------------------------------------------------------------
@@ -338,31 +229,31 @@
 --
 illustratePosObject :: InterpretUnit u 
                    => PosObject u -> LocGraphic u
-illustratePosObject (PosObject mf)  = promoteR1 $ \pt ->   
-    mf >>= \(ortt,ptf) -> 
-    decorateR0 (pure $ ptf pt) (illustrateOrientation ortt `at` pt)
+illustratePosObject (PosObject mf)  = promoteLoc $ \pt ->   
+    zapQuery mf >>= \(ortt,ptf) -> 
+    decorate (primGraphic $ ptf pt) (illustrateOrientation ortt `at` pt)
 
 
 illustrateOrientation :: InterpretUnit u 
                     => Orientation u -> LocGraphic u
-illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteR1 $ \pt -> 
+illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt -> 
     dinterpCtx 3 >>= \radius -> 
     let upd = localize (fill_colour blue . dotted_line)
         bl  = pt .-^ V2 xmin ymin
-        dot = localize (fill_colour red) $ filledDisk radius `at` pt
+        dot = localize (fill_colour red) $ dcDisk FILL radius `at` pt
         hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin
         vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin
-        bdr = upd $ strokedRectangle (xmin+xmaj) (ymin+ymaj) `at` bl
-    in bdr `oplus` hln `oplus` vln `oplus` dot
+        bdr = upd $ dcRectangle STROKE (xmin+xmaj) (ymin+ymaj) `at` bl
+    in mconcat [ bdr, hln, vln, dot ]
 
 
 --------------------------------------------------------------------------------
 -- Combining PosObject
 
 
-instance (Fractional u, Ord u) => ZConcat (PosObject u) where
-  superior = oplus
-  anterior = flip oplus
+instance (Fractional u, Ord u, InterpretUnit u) => ZConcat (PosObject u) where
+  superior = mappend
+  anterior = flip mappend
 
 
 instance (Num u, Ord u) => Concat (PosObject u) where
@@ -392,9 +283,9 @@
              -> PosObject u -> PosObject u -> PosObject u
 genMoveAlign mkV mkO po0 po1 = PosObject body
   where
-   body = drawingCtx >>= \ctx -> 
-          let (ortt0,pf0) = runCF ctx (getPosObject po0)
-              (ortt1,pf1) = runCF ctx (getPosObject po1)
+   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)
@@ -421,9 +312,9 @@
             -> PosObject u -> PosObject u -> PosObject u
 genMoveSepH mkV mkO sep po0 po1  = PosObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let (ortt0,pf0) = runCF ctx (getPosObject po0)
-               (ortt1,pf1) = runCF ctx (getPosObject po1)
+    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)
@@ -437,10 +328,11 @@
             -> PosObject u -> PosObject u -> PosObject u
 genMoveSepV mkV mkO sep po0 po1 = PosObject body
   where
-    body = drawingCtx >>= \ctx -> 
-           let (ortt0,pf0) = runCF ctx (getPosObject po0)
-               (ortt1,pf1) = runCF ctx (getPosObject po1)
+    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)
+
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
@@ -48,6 +48,7 @@
   , drawi
   , drawl
   , drawli
+
   , drawc
   , drawci
 
@@ -61,14 +62,12 @@
 
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.QueryDC
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.Anchors
 import Wumpus.Basic.Kernel.Objects.Basis
 import Wumpus.Basic.Kernel.Objects.Connector
-import Wumpus.Basic.Kernel.Objects.Image
 import Wumpus.Basic.Kernel.Objects.LocImage
 
 import Wumpus.Core                              -- package: wumpus-core
@@ -182,7 +181,7 @@
 
 fontDeltaMon :: TraceDrawing u a -> TraceDrawing u a
 fontDeltaMon mf = TraceDrawing $ \ctx -> 
-    let (_,font_attrs) = runCF ctx textAttr
+    let (_,font_attrs) = primAnswer $ runImage ctx textAttr
         (a,hf)         = runTraceDrawing ctx mf
         prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList hf
     in (a, singleH $ prim1 $ prim)
@@ -193,7 +192,7 @@
 
 fontDeltaTrans :: Monad m => TraceDrawingT u m a -> TraceDrawingT u m a
 fontDeltaTrans mf = TraceDrawingT $ \ctx -> 
-    let (_,font_props) = runCF ctx textAttr
+    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)
@@ -307,8 +306,8 @@
 --------------------------------------------------------------------------------
 
 
-evalQuery :: DrawingCtxM m => Query a -> m a
-evalQuery df = askDC >>= \ctx -> return $ runCF ctx  df
+evalQuery :: DrawingCtxM m => Query u a -> m a
+evalQuery df = askDC >>= \ctx -> return $ runQuery ctx df
 
 
 
@@ -322,7 +321,7 @@
 draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
      => Image u a -> m ()
 draw gf = askDC >>= \ctx -> 
-          let Ans o _ = runCF ctx gf
+          let (PrimW o _) = runImage ctx gf
           in trace (singleH o) >> return ()
 
 
@@ -336,9 +335,10 @@
 -- 
 drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
       => Image u a -> m a
-drawi img = askDC >>= \ctx -> 
-            let Ans o a = runCF ctx img
-            in trace (singleH o) >> return a
+drawi gf = askDC >>= \ctx -> 
+           let (PrimW o a) = runImage ctx gf 
+           in trace (singleH o) >> return a
+            
 
 
 -- | Draw a LocImage at the supplied Anchor taking the drawing 
@@ -362,10 +362,9 @@
 -- 
 drawli :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
        => Anchor u -> LocImage u a -> m a
-drawli pt img = askDC >>= \ctx -> 
-                let Ans o a = runCF ctx img pt 
-                in trace (singleH o) >> return a
-
+drawli pt gf = askDC >>= \ctx -> 
+               let (PrimW o a) = runLocImage pt ctx gf
+               in trace (singleH o) >> return a
 
 
 -- Design note - having @drawlti@ for LocThetaImage does not seem 
@@ -399,7 +398,7 @@
 -- 
 drawci :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) 
        => Anchor u -> Anchor u -> ConnectorImage u a -> m a
-drawci p0 p1 img = drawi (connect img p0 p1)
+drawci p0 p1 img = drawi (connect p0 p1 img)
 
 
 
@@ -429,11 +428,8 @@
       => (Int,Int) -> LocImage u a -> m a
 nodei coord gf = askDC >>= \ctx -> 
                  position coord >>= \pt ->
-                 let Ans o a = runCF ctx gf pt
+                 let (PrimW o a) = runLocImage pt ctx gf
                  in trace (singleH o) >> return a
-
-
-
  
 
 
@@ -470,6 +466,6 @@
            , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b
            ) 
         => a -> b -> ConnectorImage u ans -> m ans
-drawrci a b img = 
-    let (p0,p1) = radialConnectorPoints a b in drawi (connect img p0 p1)
+drawrci a b gf = 
+    let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf)
 
diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs
--- a/src/Wumpus/Basic/VersionNumber.hs
+++ b/src/Wumpus/Basic/VersionNumber.hs
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,17,0)
+-- > (0,18,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,17,0)
+wumpus_basic_version = (0,18,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.17.0
+version:          0.18.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -9,8 +9,8 @@
 synopsis:         Basic objects and system code built on Wumpus-Core.
 description:
   .
-  Kernel code for higher-level drawing built on Wumpus-Core.
-  This package provides font loader code (limited to AFM font 
+  Kernel code for higher-level drawing built on Wumpus-Core. This 
+  package provides font loader code (currently limited to AFM font 
   files) and a various /drawing objects/ intended to be a 
   higher-level basis to make vector drawings than the primitives 
   (paths, text labels) provided by Wumpus-Core. 
@@ -29,83 +29,22 @@
   .
   .
   Changelog:
-  . 
-  v0.16.0 to v0.17.0:
   .
-  * Changed representation of ContextFuns - context funs are no 
-    longer an arity family of newtypes. The new representation 
-    is simpler, but some of the opportunities for overloading 
-    have been lost.
-  .
-  * Substantial round of renaming for the @DrawingContext@ types
-    an query and update functions.
-  .
-  * Re-worked the font metrics and font loader modules. The new
-    names should be more systematic. Removed the need for the 
-    GhostScript font modules to match PostScript names to 
-    GhostScript font files.    
-  .
-  * Superceded the PointSupplyM class by adding snapping grid 
-    scaling to the DrawingContext. 
+  v0.17.0 to v0.18.0:
   . 
-  * Removed @ScalingContext@ module.
-  .
-  * Made text colour a distinct property in the DrawingContext. 
-    Text is now drawn with the text colour rather than the stroke 
-    colour.
-  .
-  * Added FontLoadLog to the DrawingContext - this allows access 
-    to the errors recorded during font loading.
-  .
-  v0.15.0 to v0.16.0:
-  .
-  * Moved the Geometry modules from Wumpus-Drawing into 
-    Wumpus-Basic.
-  .
-  * Re-worked the @CtxPicture@ API, although the current naming 
-    scheme is not satisfactory.
-  .
-  * Added extra Anchor classes.
-  .
-  * Added @PosImage@ object - this is a rectangle-framed object 
-    that can be drawn from any of its corners or its center. 
-  .
-  * Added @CF3@, an arity three /ContextFunction/.
-  .
-  * Added @Displacement@ module. This defines the @PointDisplace@
-    type and provides a library of @PointDisplace@ functions.
-    Note - some of the new functions have taken names previously 
-    used for anchor projection functions (@northwards@, 
-    @southwards@, etc.), anchor projections are now build with the 
-    function @projectAnchor@.
-  .
-  * Added the property @descender@ to the font metrics.
-  .
-  * Split drawing primitives from type in @Objects.Graphic@, 
-    drawing primitives are now in the module 
-    @Objects.DrawingPrimitives@.
+  * 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.14.0 to v0.15.0:
+  * Changed Displacement API - it is smaller, and the function 
+    naming is more uniform.
   . 
-  * Split previous @Wumpus-Basic@ package into two packages:
-    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move 
-    to separate the developed (although not yet polished) @Kernel@ 
-    and @FontLoader@ code from the prototypical @Drawing@ code.
-  .
-  * Renamed the @Drawing@ object to @CtxPicture@. Although 
-    @CtxPicture@ is a less pleasant name, it should be less 
-    confusing. A @CtxPicture@ is the essentially the @Picture@ 
-    type from Wumpus-Core with an implicit context - 
-    @ContextPicture@ is simply too long and @CtxPicture@ is 
-    almost jibberish but the previous unrelated name @Drawing@ 
-    was not helpful.
-  .
-  * @Kernel.Base.ScalingContext@ has been simplified. 
-    ScalingContexts are no longer manipulated via a custom Reader
-    monad or transformer as the type signatures were too unwieldy.
-  .
-  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing 
-    can now calculate more appealing bounding boxes for text.
+  * Changed @DrawingPimitives@ to use @DrawStyle@.
+  . 
+  * Moved vertices generating functions from @Geometry.Path@ to 
+    @Geometry.Vertices@.
   .
 build-type:         Simple
 stability:          highly unstable
@@ -126,18 +65,19 @@
                       directory       >= 1.0     && <  2.0, 
                       filepath        >= 1.1     && <  2.0,
                       vector-space    >= 0.6     && <  1.0,
-                      wumpus-core     >= 0.50.0  && <  0.51.0
+                      wumpus-core     >= 0.51.0  && <  0.52.0
 
   
   exposed-modules:
     Wumpus.Basic.Geometry,
     Wumpus.Basic.Geometry.Base,
+    Wumpus.Basic.Geometry.Illustrate,
     Wumpus.Basic.Geometry.Intersection,
     Wumpus.Basic.Geometry.Paths,
     Wumpus.Basic.Geometry.Quadrant,
+    Wumpus.Basic.Geometry.Vertices,
     Wumpus.Basic.Kernel,
     Wumpus.Basic.Kernel.Base.BaseDefs,
-    Wumpus.Basic.Kernel.Base.ContextFun,
     Wumpus.Basic.Kernel.Base.DrawingContext,
     Wumpus.Basic.Kernel.Base.FontSupport,
     Wumpus.Basic.Kernel.Base.QueryDC,
@@ -154,7 +94,6 @@
     Wumpus.Basic.Kernel.Objects.CtxPicture,
     Wumpus.Basic.Kernel.Objects.Displacement,
     Wumpus.Basic.Kernel.Objects.DrawingPrimitives,
-    Wumpus.Basic.Kernel.Objects.Image,
     Wumpus.Basic.Kernel.Objects.LocImage,
     Wumpus.Basic.Kernel.Objects.LocThetaImage,
     Wumpus.Basic.Kernel.Objects.Orientation,