diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2008 Stephen Peter Tetley
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+#!/usr/bin/env runhaskell
+
+import Distribution.Simple
+main = defaultMain
diff --git a/demo/LabelPic.hs b/demo/LabelPic.hs
new file mode 100644
--- /dev/null
+++ b/demo/LabelPic.hs
@@ -0,0 +1,145 @@
+{-# OPTIONS -Wall #-}
+
+module LabelPic where
+
+import Wumpus.Core
+
+
+--------------------------------------------------------------------------------
+
+
+
+drawBounds :: (Fractional u, Ord u) => Picture u -> Picture u
+drawBounds p        = p `over` (frame $ cstroke () ph) where
+    ph   = vertexPath $ corners $ boundary p
+
+--------------------------------------------------------------------------------
+
+
+peru :: PSRgb
+peru = RGB3 0.804  0.522  0.247
+
+plum :: PSRgb
+plum = RGB3 0.867  0.627  0.867
+
+black :: PSRgb
+black = RGB3 0 0 0 
+
+
+
+lbl1 :: Picture Double
+lbl1 = line1 -//- line2 where
+  line1 = frame (textlabel attrs zeroPt "Hello")
+  line2 = frame (textlabel attrs zeroPt "World")
+  attrs = (peru, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12) 
+
+
+demo01 :: IO ()
+demo01 = do 
+    writeEPS_latin1 "./out/label01.eps" lbl1
+    writeSVG_latin1 "./out/label01.svg" lbl1
+
+demo02 :: IO ()
+demo02 = do 
+    writeEPS_latin1 "./out/label02.eps" p1
+    writeSVG_latin1 "./out/label02.svg" p1
+  where
+    p1 = lbl1 ->- lbl1 ->- (rotateAbout (pi/4) (center lbl1) lbl1) ->- lbl1
+
+demo03 :: IO ()
+demo03 = do 
+    writeEPS_latin1 "./out/label03.eps" p1
+    writeSVG_latin1 "./out/label03.svg" p1
+  where
+    p1 = (drawBounds lbl1) ->- 
+         (drawBounds lbl1) ->- 
+         (drawBounds $ rotateAbout (pi/4) (center lbl1) lbl1) ->- 
+         (drawBounds lbl1)
+
+
+
+demo04 :: IO ()
+demo04 = do
+    writeEPS_latin1 "./out/label04.eps" p1
+    writeSVG_latin1 "./out/label04.svg" p1
+  where
+    p1 =        (drawBounds lbl1) 
+         `over` (drawBounds $ scale 2 2 lbl1)
+         `over` (drawBounds $ scale 3 3 lbl1)
+
+
+
+
+bigA, bigB, bigT :: Picture Double
+bigA = bigLetter black 'A'
+bigB = bigLetter peru  'B'
+bigT = bigLetter plum  'T'
+
+bigLetter :: PSRgb -> Char -> Picture Double
+bigLetter col ch = uniformScale 5 $ frame $ textlabel attrs zeroPt [ch]
+  where
+    attrs = (col, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 12) 
+
+
+-- | A should be above B, above T
+demo05 :: IO ()
+demo05 = do 
+    writeEPS_latin1 "./out/label05.eps" p1
+    writeSVG_latin1 "./out/label05.svg" p1
+  where
+    p1 = uniformScale 10 $ stackOntoCenter [bigA, bigB] bigT
+
+
+demo06 :: IO ()
+demo06 = do 
+    writeEPS_latin1 "./out/label06.eps" p1
+    writeSVG_latin1 "./out/label06.svg" p1
+  where
+    p1 = hsep 20 (fn 'a') (map fn "abcdefg")
+    fn = drawBounds . bigLetter peru
+
+
+demo07 :: IO ()
+demo07 = do 
+    writeEPS_latin1 "./out/label07.eps" p1
+    writeSVG_latin1 "./out/label07.svg" p1
+  where
+    p1 = pA ->- pB ->- pC ->- pA
+    
+    pA = drawBounds bigA
+    pB = drawBounds $ uniformScale 2 bigB
+    pC = drawBounds $ move 0 10 $ bigLetter peru 'C'
+
+
+demo08 :: IO ()
+demo08 = do 
+    writeEPS_latin1 "./out/label08.eps" p1
+    writeSVG_latin1 "./out/label08.svg" p1
+  where
+    p1 = hcat pA [pA, pB, pC]
+    
+    pA = drawBounds bigA
+    pB = drawBounds $ uniformScale 2 bigB
+    pC = drawBounds $ move 0 10 $ bigLetter peru 'C'
+
+demo09 :: IO ()
+demo09 = do 
+    writeEPS_latin1 "./out/label09.eps" p1
+    writeSVG_latin1 "./out/label09.svg" p1
+  where
+    p1 = (bigA -//- bigB) ->- (bigA -\\- bigB) 
+    
+demo10 :: IO ()
+demo10 = do 
+    writeEPS_latin1 "./out/label10.eps" p1
+    writeSVG_latin1 "./out/label10.svg" p1
+  where
+    p1 :: Picture Double
+    p1 = frame $ textlabel () zeroPt "myst&#egrave;re"
+
+
+main :: IO ()
+main = sequence_
+  [ demo01, demo02, demo03, demo04, demo05
+  , demo06, demo07, demo08, demo09, demo10
+  ]  
diff --git a/demo/Picture.hs b/demo/Picture.hs
new file mode 100644
--- /dev/null
+++ b/demo/Picture.hs
@@ -0,0 +1,133 @@
+{-# OPTIONS -Wall #-}
+
+module Picture where
+
+import Wumpus.Core
+
+
+
+peru :: PSRgb
+peru = RGB3 0.804  0.522  0.247
+
+plum :: PSRgb
+plum = RGB3 0.867  0.627  0.867
+
+black :: PSRgb
+black = RGB3 0 0 0 
+
+
+square :: DPicture 
+square = frame $ cstroke () $ vertexPath
+  [ P2 0 0, P2 40 0, P2 40 40, P2 0 40 ]
+
+funnyshape :: DPicture
+funnyshape = frame $ cstroke () $ vertexPath
+  [ P2 0 0, P2 20 0, P2 20 10, P2 30 10, P2 30 20, P2 0 20 ]
+
+
+demo01 :: IO ()
+demo01 = do 
+  writePS_latin1  "./out/picture01.ps"    [funnyshape ->- square]
+  writeSVG_latin1 "./out/picture01.svg" $ funnyshape ->- square
+
+
+pic1 :: Picture Double
+pic1 = square ->- (funnyshape ->- funnyshape) ->- square
+
+squares :: Picture Double
+squares = square ->- square ->- square
+
+demo02 :: IO ()
+demo02 = do 
+   writePS_latin1  "./out/picture02.ps"  [squares]
+   writeSVG_latin1 "./out/picture02.svg" squares 
+    
+
+demo03 :: IO ()
+demo03 = do 
+    writeEPS_latin1 "./out/picture03.eps" p1 
+    writeSVG_latin1 "./out/picture03.svg" p1
+  where     
+    p1 = square ->- (rotate45About (center squares) squares) ->- square
+
+
+demo04 :: IO ()
+demo04 = do 
+    writeEPS_latin1 "./out/picture04.eps" p1
+    writeSVG_latin1 "./out/picture04.svg" p1
+  where
+    p1 = square -//- squares
+   
+
+demo05 :: IO ()
+demo05 = do 
+    writeEPS_latin1 "./out/picture05.eps" p1
+    writeSVG_latin1 "./out/picture05.svg" p1
+  where
+    p1 = square `over` (rotate (pi/4) squares)
+   
+
+demo06 :: IO ()
+demo06 = do 
+    writeEPS_latin1 "./out/picture06.eps" p1
+    writeSVG_latin1 "./out/picture06.svg" p1
+  where
+    p1 = square `over` (rotate45 square)
+
+
+-- Note the move via @at@ is not apparent when SVG file is 
+-- viewed with Mozilla or Chrome - check picture7a.svg
+-- We only see that the move has /worked/ when we compose
+-- with with `over` a square at the origin. 
+
+demo07 :: IO ()
+demo07 = do 
+    writeEPS_latin1 "./out/picture07.eps" p1
+    writeSVG_latin1 "./out/picture07.svg" p1
+    writeSVG_latin1 "./out/picture07a.svg" p2
+  where
+    p1 = square `over` p2
+    p2 = (square `at` (P2 100 30))  -@- (rotate45 square)
+
+
+demo08 :: IO ()
+demo08 = do 
+    writeEPS_latin1 "./out/picture08.eps" p1
+    writeSVG_latin1 "./out/picture08.svg" p1
+  where
+    p1 = hspace 20 square square
+
+mkFilledSquare :: (PSColour c, Fill c) => c -> DPicture 
+mkFilledSquare col = frame $ fill col $ vertexPath
+  [ P2 0 0, P2 40 0, P2 40 40, P2 0 40 ]
+
+
+demo09 :: IO ()
+demo09 = do 
+    writeEPS_latin1 "./out/picture09.eps" p1
+    writeSVG_latin1 "./out/picture09.svg" p1
+  where
+    p1 = (alignH HTop s1 s2) `op` s3
+    s1 = uniformScale 1.5  $ mkFilledSquare plum 
+    s2 = uniformScale 1.75 $ mkFilledSquare peru
+    s3 = scale 3 1.5       $ mkFilledSquare black
+    op = alignH HBottom
+ 
+
+demo10 :: IO ()
+demo10 = do 
+    writeEPS_latin1 "./out/picture10.eps" p1
+    writeSVG_latin1 "./out/picture10.svg" p1
+  where
+    p1 = vsepA VRight 5 s1 [s2,s3]
+    s1 = uniformScale 1.5  $ mkFilledSquare plum 
+    s2 = uniformScale 1.75 $ mkFilledSquare peru
+    s3 = scale 3 1.5       $ mkFilledSquare black
+ 
+
+
+main :: IO ()
+main = sequence_
+  [ demo01, demo02, demo03, demo04, demo05
+  , demo06, demo07, demo08, demo09, demo10
+  ]
diff --git a/src/Wumpus/Core.hs b/src/Wumpus/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core.hs
@@ -0,0 +1,67 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Common interface to Wumpus.Core...
+-- 
+-- 
+--------------------------------------------------------------------------------
+
+
+module Wumpus.Core
+  (
+    module Wumpus.Core.AffineTrans 
+  , module Wumpus.Core.BoundingBox
+  , module Wumpus.Core.Colour
+  , module Wumpus.Core.FontSize
+  , module Wumpus.Core.Geometry
+  , module Wumpus.Core.GraphicsState
+  , module Wumpus.Core.OutputPostScript
+  , module Wumpus.Core.OutputSVG
+  , module Wumpus.Core.Picture
+  , module Wumpus.Core.PictureLanguage
+  , module Wumpus.Core.TextEncoding
+
+  -- Export from Picture Internal
+  , Picture
+  , DPicture
+  , Primitive
+  , DPrimitive
+  , Path
+  , DPath
+  , PathSegment
+  , DPathSegment
+  , Label
+  , DLabel
+
+  , PathProps                   -- Better hidden?
+  , LabelProps                  --      "
+  , EllipseProps                --      "
+  , DrawPath                    --      "
+  , DrawEllipse                 --      "
+
+  ) where
+
+import Wumpus.Core.AffineTrans
+import Wumpus.Core.BoundingBox
+import Wumpus.Core.Colour hiding ( black, white, red, green, blue )
+import Wumpus.Core.FontSize
+import Wumpus.Core.Geometry
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.OutputPostScript
+import Wumpus.Core.OutputSVG
+import Wumpus.Core.Picture
+import Wumpus.Core.PictureInternal
+import Wumpus.Core.PictureLanguage
+import Wumpus.Core.TextEncoding
+
+
+
diff --git a/src/Wumpus/Core/AffineTrans.hs b/src/Wumpus/Core/AffineTrans.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/AffineTrans.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.AffineTrans
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Affine transformations
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.AffineTrans
+  ( 
+  -- * Type classes
+    Rotate(..)
+  , RotateAbout(..)
+  , Scale(..)
+  , Translate(..)
+
+  -- * Common rotations
+  , rotate30
+  , rotate30About
+  , rotate45
+  , rotate45About
+  , rotate60
+  , rotate60About
+  , rotate90
+  , rotate90About
+  , rotate120
+  , rotate120About
+  
+  -- * Common scalings
+  , uniformScale
+  , reflectX
+  , reflectY
+
+  -- * Translate by a vector
+  , translateBy
+  
+  -- * Reflections in supplied plane rather than about the origin
+  , reflectXPlane
+  , reflectYPlane   
+
+  ) where
+
+import Wumpus.Core.Geometry
+
+
+
+--------------------------------------------------------------------------------
+-- Affine transformations 
+
+
+-- Rotate
+
+class Rotate t where
+  rotate :: Radian -> t -> t
+
+
+instance (Floating a, Real a) => Rotate (Point2 a) where
+  rotate a = ((rotationMatrix a) *#)
+
+instance (Floating a, Real a) => Rotate (Vec2 a) where
+  rotate a = ((rotationMatrix a) *#)
+
+-- Rotate about
+
+class RotateAbout t where
+  rotateAbout :: Radian -> Point2 (DUnit t) -> t -> t 
+
+
+instance (Floating a, Real a) => RotateAbout (Point2 a) where
+  rotateAbout a pt = ((originatedRotationMatrix a pt) *#) 
+
+
+instance (Floating a, Real a) => RotateAbout (Vec2 a) where
+  rotateAbout a pt = ((originatedRotationMatrix a pt) *#) 
+  
+--------------------------------------------------------------------------------
+-- Scale
+
+class Scale t where
+  scale :: DUnit t -> DUnit t -> t -> t
+
+instance Num u => Scale (Point2 u) where
+  scale x y = ((scalingMatrix x y) *#) 
+
+instance Num u => Scale (Vec2 u) where
+  scale x y = ((scalingMatrix x y) *#) 
+
+--------------------------------------------------------------------------------
+-- Translate
+
+class Translate t where
+  translate :: DUnit t -> DUnit t -> t -> t
+
+-- | translate @x@ @y@.
+instance Num u => Translate (Point2 u) where
+  translate x y = ((translationMatrix x y) *#)
+
+instance Num u => Translate (Vec2 u) where
+  translate x y = ((translationMatrix x y) *#)
+
+
+-------------------------------------------------------------------------------- 
+-- Common rotations
+
+
+
+
+rotate30 :: Rotate t => t -> t 
+rotate30 = rotate (pi/6) 
+
+rotate30About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t 
+rotate30About = rotateAbout (pi/6)
+
+
+rotate45 :: Rotate t => t -> t 
+rotate45 = rotate (pi/4) 
+
+rotate45About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t 
+rotate45About = rotateAbout (pi/4)
+
+
+rotate60 :: Rotate t => t -> t 
+rotate60 = rotate (2*pi/3) 
+
+rotate60About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t 
+rotate60About = rotateAbout (2*pi/3)
+
+rotate90 :: Rotate t => t -> t 
+rotate90 = rotate (pi/2) 
+
+rotate90About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t 
+rotate90About = rotateAbout (pi/2)
+
+
+rotate120 :: Rotate t => t -> t 
+rotate120 = rotate (4*pi/3) 
+
+rotate120About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t 
+rotate120About = rotateAbout (4*pi/3)
+
+
+
+--------------------------------------------------------------------------------
+-- Common scalings
+
+uniformScale :: (Scale t, DUnit t ~ u) => u -> t -> t 
+uniformScale a = scale a a 
+
+
+reflectX :: (Num u, Scale t, DUnit t ~ u) => t -> t
+reflectX = scale (-1) 1
+
+reflectY :: (Num u, Scale t, DUnit t ~ u) => t -> t
+reflectY = scale 1 (-1)
+
+--------------------------------------------------------------------------------
+-- translations
+
+translateBy :: (Translate t, DUnit t ~ u) => Vec2 u -> t -> t 
+translateBy (V2 x y) = translate x y
+
+
+--------------------------------------------------------------------------------
+-- Translation and scaling
+
+-- | Reflect in the X plane that intersects the supplied point. 
+reflectXPlane :: (Num u, Scale t, Translate t, u ~ DUnit t) 
+              => Point2 u -> t -> t
+reflectXPlane (P2 x y) = translate x y . scale (-1) 1 . translate (-x) (-y)
+
+-- | Reflect in the Y plane that intersects the supplied point.
+reflectYPlane :: (Num u, Scale t, Translate t, u ~ DUnit t) 
+              => Point2 u -> t -> t
+reflectYPlane (P2 x y) = translate x y . scale 1 (-1) . translate (-x) (-y)
diff --git a/src/Wumpus/Core/BoundingBox.hs b/src/Wumpus/Core/BoundingBox.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/BoundingBox.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.BoundingBox
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Bounding box with no notion of \'empty\'.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.BoundingBox 
+  ( 
+  -- * Types
+    BoundingBox(..)
+  , DBoundingBox
+  , CardinalPoint(..)
+
+  -- * Type class
+  , Boundary(..)
+  
+  -- * Operations
+  , bbox
+  , obbox
+  , union 
+  , trace
+  , corners
+  , lowerLeftUpperRight
+  , withinBB
+  , boundaryWidth
+  , boundaryHeight
+  , boundaryBottomLeft
+  , boundaryTopRight
+  , boundaryTopLeft
+  , boundaryBottomRight
+  , boundaryPoint
+  , leftPlane
+  , rightPlane
+  , lowerPlane
+  , upperPlane
+
+  ) where
+
+import Wumpus.Core.AffineTrans
+import Wumpus.Core.Geometry
+import Wumpus.Core.Utils ( CMinMax(..), within )
+
+import Data.Semigroup
+
+import Text.PrettyPrint.Leijen hiding ( width )
+
+
+
+-- | Bounding box of a picture.
+-- 
+-- We cannot construct empty pictures - so bounding boxes too a 
+-- saved the obligation to be empty.
+-- 
+data BoundingBox a = BBox { 
+                         ll_corner :: Point2 a, 
+                         ur_corner :: Point2 a 
+                       }
+  deriving (Eq,Show)
+
+type DBoundingBox = BoundingBox Double
+
+data CardinalPoint = C | N | NE | E | SE | S | SW | W | NW
+  deriving (Eq,Show)
+
+
+--------------------------------------------------------------------------------
+-- instances
+
+-- BBox is NOT monoidal - it\'s much simpler that way.
+
+instance Ord a => Semigroup (BoundingBox a) where
+  append = union
+
+
+instance Pretty a => Pretty (BoundingBox a) where
+  pretty (BBox p0 p1) = text "|_" <+> pretty p0 <+> pretty p1 <+> text "_|" 
+
+
+--------------------------------------------------------------------------------
+-- 
+
+type instance DUnit (BoundingBox u) = u
+
+instance (Num u, Ord u) => Scale (BoundingBox u) where
+  scale x y bb     = trace $ map (scale x y) $ corners bb
+
+
+
+--------------------------------------------------------------------------------
+-- Boundary class
+
+class Boundary a where
+  boundary :: a -> BoundingBox (DUnit a)
+
+
+--------------------------------------------------------------------------------
+
+
+instance Pointwise (BoundingBox a) where
+  type Pt (BoundingBox a) = Point2 a
+  pointwise f (BBox bl tr) = BBox (f bl) (f tr)
+
+
+--------------------------------------------------------------------------------
+
+bbox :: Point2 a -> Point2 a -> BoundingBox a
+bbox = BBox 
+
+
+-- | Create a BoundingBox with bottom left corner at the origin,
+-- and dimensions @w@ and @h@.
+obbox :: Num a => a -> a -> BoundingBox a
+obbox w h = BBox zeroPt (P2 w h)
+
+
+union :: Ord a => BoundingBox a -> BoundingBox a -> BoundingBox a
+BBox ll ur `union` BBox ll' ur' = BBox (cmin ll ll') (cmax ur ur')
+
+-- Trace the point list finding the /extremity/...
+
+trace :: (Num a, Ord a) => [Point2 a] -> BoundingBox a
+trace (p:ps) = uncurry BBox $ foldr (\z (a,b) -> (cmin z a, cmax z b) ) (p,p) ps
+trace []     = error $ "BoundingBox.trace called in empty list"
+
+
+corners :: BoundingBox a -> [Point2 a]
+corners (BBox bl@(P2 x0 y0) tr@(P2 x1 y1)) = [bl, br, tr, tl] where
+    br = P2 x1 y0
+    tl = P2 x0 y1
+
+
+lowerLeftUpperRight :: (a,a,a,a) -> BoundingBox a -> (a,a,a,a)
+lowerLeftUpperRight _   (BBox (P2 x0 y0) (P2 x1 y1)) = (x0,y0,x1,y1)
+
+
+
+withinBB :: Ord a => Point2 a -> BoundingBox a -> Bool
+withinBB p (BBox ll ur) = within p ll ur
+
+
+boundaryWidth :: Num a => BoundingBox a -> a
+boundaryWidth (BBox (P2 xmin _) (P2 xmax _)) = xmax - xmin
+
+boundaryHeight :: Num a => BoundingBox a -> a
+boundaryHeight (BBox (P2 _ ymin) (P2 _ ymax)) = ymax - ymin
+
+
+--------------------------------------------------------------------------------
+
+-- Points on the boundary
+
+
+boundaryBottomLeft  :: BoundingBox a -> Point2 a
+boundaryBottomLeft (BBox p0 _ ) = p0
+
+boundaryTopRight :: BoundingBox a -> Point2 a
+boundaryTopRight (BBox _ p1) = p1
+
+boundaryTopLeft :: BoundingBox a -> Point2 a
+boundaryTopLeft (BBox (P2 x _) (P2 _ y)) = P2 x y
+
+boundaryBottomRight :: BoundingBox a -> Point2 a
+boundaryBottomRight (BBox (P2 _ y) (P2 x _)) = P2 x y
+
+
+boundaryPoint :: Fractional a 
+              => CardinalPoint -> BoundingBox a -> Point2 a
+boundaryPoint loc (BBox (P2 x0 y0) (P2 x1 y1)) = fn loc where
+  fn C      = P2 xMid   yMid
+  fn N      = P2 xMid   y1
+  fn NE     = P2 x1     y1
+  fn E      = P2 x1     yMid
+  fn SE     = P2 x1     y0
+  fn S      = P2 xMid   y0
+  fn SW     = P2 x0     y0
+  fn W      = P2 x0     yMid
+  fn NW     = P2 x0     y1       
+
+  xMid      = x0 + 0.5 * (x1 - x0)
+  yMid      = y0 + 0.5 * (y1 - y0)
+
+
+--------------------------------------------------------------------------------
+
+-- /planes/ on the bounding box
+
+-- Are these really worthwhile ? ...
+
+leftPlane :: BoundingBox a -> a
+leftPlane (BBox (P2 l _) _) = l
+
+rightPlane :: BoundingBox a -> a
+rightPlane (BBox _ (P2 r _)) = r
+
+lowerPlane :: BoundingBox a -> a
+lowerPlane (BBox (P2 _ l) _) = l
+
+upperPlane :: BoundingBox a -> a
+upperPlane (BBox _ (P2 _ u)) = u
+
+
+
+
+
+
diff --git a/src/Wumpus/Core/Colour.hs b/src/Wumpus/Core/Colour.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Colour.hs
@@ -0,0 +1,223 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.Colour
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- RGB, HSB, Gray colour types.
+--
+--------------------------------------------------------------------------------
+
+
+module Wumpus.Core.Colour 
+  (
+  -- * Colour types
+    RGB3(..)
+  , DRGB
+  , HSB3(..)
+  , DHSB
+  , Gray(..)
+  , DGray
+
+  -- * Operations
+  , rgb2hsb
+  , hsb2rgb
+
+  , rgb2gray
+  , gray2rgb
+
+  , hsb2gray
+  , gray2hsb
+  
+  -- * Predefined colours
+  , black
+  , white
+  , red
+  , green
+  , blue
+
+  ) where
+
+import Wumpus.Core.Utils
+
+
+import Data.VectorSpace
+
+-- | Red-Green-Blue - no alpha.
+data RGB3 a = RGB3 !a !a !a
+  deriving (Eq,Show)
+
+-- | RGB representated by Double - values should be in the range
+-- 0.0 to 1.0. 
+-- 
+-- 1.0 represents full saturation, for instance red is 
+-- 1.0, 0.0, 0.0.
+type DRGB = RGB3 Double
+
+
+-- | Hue-Saturation-Brightness.
+data HSB3 a = HSB3 !a !a !a 
+  deriving (Eq,Show)
+
+-- | HSB represented by Double - values should be in the range
+-- 0.0 to 1.0.
+type DHSB = HSB3 Double 
+
+
+newtype Gray a = Gray a
+  deriving (Eq,Num,Ord,Show)
+
+-- | Gray represented by a Double - values should be in the range
+-- 0.0 (black) to 1.0 (white).
+type DGray = Gray Double
+
+
+instance Num a => Num (RGB3 a) where
+  (+) (RGB3 a b c) (RGB3 x y z) = RGB3 (a+x) (b+y) (c+z)
+  (-) (RGB3 a b c) (RGB3 x y z) = RGB3 (a-x) (b-y) (c-z)
+  (*) (RGB3 a b c) (RGB3 x y z) = RGB3 (a*x) (b*y) (c*z)
+  abs (RGB3 a b c)            = RGB3 (abs a) (abs b) (abs c)
+  negate (RGB3 a b c)         = RGB3 (negate a) (negate b) (negate c)
+  signum (RGB3 a b c)         = RGB3 (signum a) (signum b) (signum c)
+  fromInteger i = RGB3 (fromInteger i) (fromInteger i) (fromInteger i)
+
+instance Fractional a => Fractional (RGB3 a) where
+  (/) (RGB3 a b c) (RGB3 x y z) = RGB3 (a/x) (b/y) (c/z)
+  recip (RGB3 a b c)            = RGB3 (recip a) (recip b) (recip c)
+  fromRational a = RGB3 (fromRational a) (fromRational a) (fromRational a)
+
+ 
+instance Num a => AdditiveGroup (RGB3 a) where
+  zeroV = RGB3 0 0 0
+  (^+^) = (+)
+  negateV = negate
+
+
+instance (Num a, VectorSpace a) => VectorSpace (RGB3 a) where
+  type Scalar (RGB3 a) = Scalar a
+  s *^ (RGB3 a b c) = RGB3 (s*^a) (s*^b) (s*^c)
+
+
+
+instance Num a => Num (HSB3 a) where
+  (+) (HSB3 a b c) (HSB3 x y z) = HSB3 (a+x) (b+y) (c+z)
+  (-) (HSB3 a b c) (HSB3 x y z) = HSB3 (a-x) (b-y) (c-z)
+  (*) (HSB3 a b c) (HSB3 x y z) = HSB3 (a*x) (b*y) (c*z)
+  abs (HSB3 a b c)            = HSB3 (abs a) (abs b) (abs c)
+  negate (HSB3 a b c)         = HSB3 (negate a) (negate b) (negate c)
+  signum (HSB3 a b c)         = HSB3 (signum a) (signum b) (signum c)
+  fromInteger i = HSB3 (fromInteger i) (fromInteger i) (fromInteger i)
+
+instance Fractional a => Fractional (HSB3 a) where
+  (/) (HSB3 a b c) (HSB3 x y z) = HSB3 (a/x) (b/y) (c/z)
+  recip (HSB3 a b c)            = HSB3 (recip a) (recip b) (recip c)
+  fromRational a = HSB3 (fromRational a) (fromRational a) (fromRational a)
+
+
+ 
+instance Num a => AdditiveGroup (HSB3 a) where
+  zeroV = HSB3 0 0 0
+  (^+^) = (+)
+  negateV = negate
+
+
+
+instance (Num a, VectorSpace a) => VectorSpace (HSB3 a) where
+  type Scalar (HSB3 a) = Scalar a
+  s *^ (HSB3 a b c) = HSB3 (s*^a) (s*^b) (s*^c)
+
+--------------------------------------------------------------------------------
+-- Operations
+
+
+vE :: DRGB
+vE = RGB3 1 1 1
+
+-- Acknowledgment - the conversion functions are derived from
+-- the documentation to Dr. Uwe Kern's xcolor LaTeX package
+
+
+
+rgb2hsb :: DRGB -> DHSB
+rgb2hsb (RGB3 r g b) = HSB3 hue sat bri
+  where
+    x     = max3 r g b
+    y     = med3 r g b
+    z     = min3 r g b
+
+    bri   = x
+
+    (sat,hue) = if x==z then (0,0) else ((x-z)/x, f $ (x-y)/(x-z))
+    
+    f n | r >= g && g >= b    = (1/6) * (1-n) 
+        | g >= r && r >= b    = (1/6) * (1+n)
+        | g >= b && b >= r    = (1/6) * (3-n)
+        | b >= g && g >= r    = (1/6) * (3+n)
+        | b >= r && r >= g    = (1/6) * (5-n)
+        | otherwise           = (1/6) * (5+n)
+
+
+
+hsb2rgb :: DHSB -> DRGB
+hsb2rgb (HSB3 hue sat bri) = bri *^ (vE - (sat *^ fV))
+  where
+    i     :: Int
+    i     = floor $ (6 * hue)
+    f     = (6 * hue) - fromIntegral i
+    fV    | i == 0    = RGB3  0     (1-f) 1 
+          | i == 1    = RGB3  f     0     1
+          | i == 2    = RGB3  1     0     (1-f)
+          | i == 3    = RGB3  1     f     0
+          | i == 4    = RGB3  (1-f) 1     0
+          | i == 5    = RGB3  0     1     f
+          | otherwise = RGB3  0     1     1
+          
+rgb2gray :: DRGB -> DGray
+rgb2gray (RGB3 r g b) = Gray $ 0.3 * r + 0.59 * g + 0.11 * b 
+
+gray2rgb :: DGray -> DRGB
+gray2rgb (Gray a) = a *^ vE
+
+hsb2gray :: DHSB -> DGray
+hsb2gray (HSB3 _ _ b) = Gray b 
+
+gray2hsb :: DGray -> DHSB
+gray2hsb (Gray a) = HSB3 0 0 a
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- Some colours
+
+-- There will be name clashes with the X11Colours / SVGColours.
+
+-- | Black - 0.0, 0.0, 0.0.
+black :: DRGB
+black = RGB3 0 0 0
+
+-- | White - 1.0, 1.0, 1.0.
+white :: DRGB
+white = RGB3 1 1 1
+
+-- | Red - 1.0, 0.0, 0.0.
+red :: DRGB
+red = RGB3 1 0 0
+
+-- | Green - 0.0, 1.0, 0.0.
+green :: DRGB 
+green = RGB3 0 1 0
+
+-- | Blue - 0.0, 0.0, 1.0.
+blue :: DRGB
+blue = RGB3 0 0 1
+
diff --git a/src/Wumpus/Core/FontSize.hs b/src/Wumpus/Core/FontSize.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/FontSize.hs
@@ -0,0 +1,137 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.FontSize
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Text handling
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.FontSize
+  ( 
+  
+  -- * Type synonym
+    FontSize
+
+  -- * Courier metrics at 48 point
+  , courier48_width
+  , courier48_body_height
+  , courier48_height
+  , courier48_descender_depth
+  , courier48_spacer_width
+
+  , widthAt48pt
+  , textWidth
+  , textHeight
+  , descenderDepth
+
+  , textBounds
+
+  ) where
+
+import Wumpus.Core.BoundingBox
+import Wumpus.Core.Geometry
+
+import Data.AffineSpace         -- vector-space
+
+type CharCount = Int
+type FontSize = Int
+
+-- | The width of a letter in Courier at 48 pt.
+--
+-- The value is not entirely accurate but it is satisfactory.
+courier48_width :: Num u => u
+courier48_width = 26
+
+
+-- | The height of a letter without accents, ascenders or 
+-- descenders in Courier at 48 pt .
+--
+-- The value is not entirely accurate but it is satisfactory - 
+-- some letters are taller than others (e.g. numbers are taller 
+-- then capitals).
+courier48_body_height :: Num u => u 
+courier48_body_height = 30
+
+
+-- | The /common maximum/ height of a letter in Courier at 48pt.
+--
+-- By common maximum the letter is allowed to have both an accent 
+-- or ascender and a descender.
+--
+-- Naturally the height is 48.0.
+--
+courier48_height :: Num u => u
+courier48_height = 48
+
+
+-- | The depth of a descender in Courier at 48 pt.
+-- 
+-- Also the height of an ascender.
+courier48_descender_depth :: Num u => u 
+courier48_descender_depth = 9
+
+
+
+-- | The spacing between letters printed directly with 
+-- PostScript\'s show command for Courier at 48 pt.
+--
+-- The value is not entirely accurate but it is satisfactory.
+courier48_spacer_width :: Num u => u
+courier48_spacer_width = 3
+
+
+-- | Width of the supplied string when printed at 48pt.
+widthAt48pt :: Fractional u => CharCount -> u
+widthAt48pt n = courier48_width * len + courier48_spacer_width * len_sub
+  where
+    len      = fromIntegral n
+    len_sub  = len - 1.0
+
+--- | Text width at @sz@ point size of the string @s@. All
+-- characters are counted literally - special chars may cause
+-- problems (this a current deficiency of Wumpus).
+textWidth :: Fractional u => FontSize -> CharCount -> u
+textWidth sz n = (fromIntegral sz)/48 * widthAt48pt n
+
+-- | Text height is just identity/double-coercion, i.e. 
+-- @18 == 18.0@. The /size/ of a font is (apparently) the maximum
+-- height (body + descender max + ascender max).
+textHeight :: Num u =>  FontSize -> u
+textHeight = fromIntegral
+
+-- | Descender depth for font size @sz@.
+-- 
+-- (The metrics are taken from Courier, of course).
+--
+descenderDepth :: Fractional u => FontSize -> u
+descenderDepth sz =  (fromIntegral sz) / 48 * courier48_descender_depth
+
+-- | Find the bounding box for the character count at the 
+-- supplied font-size.
+-- 
+-- The supplied point represents the bottom left corner of the 
+-- a regular upper-case letter (that is without descenders).
+-- The bounding box will always be /dropped/ to accommodate 
+-- ascenders - no interpretation of the string takes place to 
+-- see if it actually contains ascenders or descenders.
+--  
+-- The metrics used are derived from Courier - a monospaced font.
+-- For variable width fonts the calculated bounding box will 
+-- usually be too long.
+--
+textBounds :: Fractional u 
+           => FontSize -> Point2 u -> CharCount -> BoundingBox u
+textBounds sz body_bl n = bbox bl tr where
+    h           = textHeight sz
+    w           = textWidth  sz n
+    dd          = descenderDepth sz
+    bl          = body_bl .-^ V2 0 dd 
+    tr          = bl .+^ V2 w h
+  
diff --git a/src/Wumpus/Core/Geometry.hs b/src/Wumpus/Core/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Geometry.hs
@@ -0,0 +1,627 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# OPTIONS -Wall #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.Geometry
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- 2D geometry
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.Geometry 
+  ( 
+  -- * Type family 
+    DUnit
+  
+  -- * Data types
+  , Vec2(..)
+  , DVec2
+  , Point2(..)
+  , DPoint2
+  , Frame2(..)
+  , DFrame2
+  , Matrix3'3(..)
+  , DMatrix3'3
+  , Radian
+
+
+  -- * Pointwise type class
+  , Pointwise(..)
+
+  -- * Matrix multiply type class
+  , MatrixMult(..)
+
+  -- * Vector operations
+  , hvec
+  , vvec
+  , avec
+
+  -- * Point operations
+  , zeroPt
+  , langle
+
+  -- * Frame operations
+  , ortho
+  , displaceOrigin
+  , pointInFrame
+  , frame2Matrix
+  , matrix2Frame
+  , frameProduct
+  , standardFrame
+
+  -- * Matrix contruction
+  , identityMatrix
+  , scalingMatrix
+  , translationMatrix
+  , rotationMatrix
+  , originatedRotationMatrix
+
+  -- * matrix operations
+  , invert
+  , determinant
+  , transpose
+
+  -- * Radian operations
+  , req
+  , toRadian
+  , fromRadian
+  , d2r
+  , r2d
+
+  ) where
+
+import Wumpus.Core.Utils ( CMinMax(..), PSUnit(..) )
+
+import Data.Aviary
+
+import Data.AffineSpace
+import Data.VectorSpace
+
+import Text.PrettyPrint.Leijen hiding ( langle )
+
+import Data.Function ( on )
+import Data.Monoid
+
+
+--------------------------------------------------------------------------------
+
+-- | Some unit of dimension usually double.
+
+type family DUnit a :: *
+
+
+
+-- Datatypes 
+
+-- Vectors
+
+data Vec2 a = V2 !a !a
+  deriving (Eq,Show)
+
+type DVec2 = Vec2 Double
+
+-- Points
+
+data Point2 a = P2 !a !a
+  deriving (Eq,Show)
+
+type DPoint2 = Point2 Double
+
+
+
+-- | A two dimensional frame.
+-- 
+-- The components are the two basis vectors @e0@ and @e1@ and 
+-- the origin @o@.
+--
+-- Typically these names for the elements will be used:
+--
+-- > Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)
+-- 
+
+data Frame2 a = Frame2 (Vec2 a) (Vec2 a) (Point2 a)
+  deriving (Eq,Show)
+
+type DFrame2 = Frame2 Double
+
+
+
+-- | 3x3 matrix, considered to be in row-major form.
+-- 
+-- > (M3'3 a b c
+-- >       d e f
+-- >       g h i)
+--
+-- For instance the rotation matrix is represented as
+--
+-- >  ( cos(a) -sin(a) 0
+-- >    sin(a)  cos(a) 0  
+-- >      0         0  1 )
+--
+-- This is congruent with the form presented in Santos -  
+-- Example 45, page 17 extended to 3x3. 
+--
+-- ref. David A. Santos /Multivariable and Vector Calculus/,
+-- July 17, 2008 Version.
+--
+-- The right-most column is considered to represent a
+-- coordinate:
+--
+-- >  ( 1 0 x
+-- >    0 1 y  
+-- >    0 0 1 ) 
+-- >
+-- 
+-- So a translation matrix representing the displacement in x 
+-- of 40 and in y of 10 would be:
+--
+-- >  ( 1 0 40
+-- >    0 1 10  
+-- >    0 0 1  ) 
+-- >
+-- 
+
+
+data Matrix3'3 a = M3'3 !a !a !a  !a !a !a  !a !a !a
+  deriving (Eq)
+
+type DMatrix3'3 = Matrix3'3 Double
+
+
+
+-- | Radian is represented with a distinct type. 
+-- Equality and ordering are approximate where the epsilon is 0.0001.
+newtype Radian = Radian { getRadian :: Double }
+  deriving (Num,Real,Fractional,Floating,RealFrac,RealFloat)
+
+
+--------------------------------------------------------------------------------
+-- Family instances
+
+type instance DUnit (Point2 a)    = a
+type instance DUnit (Vec2 a)      = a
+type instance DUnit (Frame2 a)    = a
+type instance DUnit (Matrix3'3 a) = a
+
+--------------------------------------------------------------------------------
+-- lifters / convertors
+
+lift2Vec2 :: (a -> a -> a) -> Vec2 a -> Vec2 a -> Vec2 a
+lift2Vec2 op (V2 x y) (V2 x' y') = V2 (x `op` x') (y `op` y')
+
+
+lift2Matrix3'3 :: (a -> a -> a) -> Matrix3'3 a -> Matrix3'3 a -> Matrix3'3 a
+lift2Matrix3'3 op (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) = 
+      M3'3 (a `op` m) (b `op` n) (c `op` o)  
+           (d `op` p) (e `op` q) (f `op` r)  
+           (g `op` s) (h `op` t) (i `op` u)
+
+
+
+--------------------------------------------------------------------------------
+-- instances
+
+
+instance Functor Vec2 where
+  fmap f (V2 a b) = V2 (f a) (f b)
+
+
+instance Functor Point2 where
+  fmap f (P2 a b) = P2 (f a) (f b)
+
+instance Functor Matrix3'3 where
+  fmap f (M3'3 m n o p q r s t u) = 
+    M3'3 (f m) (f n) (f o) (f p) (f q) (f r) (f s) (f t) (f u)
+
+
+-- Vectors have a sensible Monoid instance as addition, points don't
+
+
+
+instance Num a => Monoid (Vec2 a) where
+  mempty  = V2 0 0
+  mappend = lift2Vec2 (+) 
+
+
+-- Affine frames also have a sensible Monoid instance
+
+instance (Num a, InnerSpace (Vec2 a)) => Monoid (Frame2 a) where
+  mempty = ortho zeroPt
+  mappend = frameProduct
+
+
+
+
+
+instance Show a => Show (Matrix3'3 a) where
+  show (M3'3 a b c d e f g h i) = "(M3'3 " ++ body ++ ")" where
+    body = show [[a,b,c],[d,e,f],[g,h,i]]
+
+instance Num a => Num (Matrix3'3 a) where
+  (+) = lift2Matrix3'3 (+) 
+  (-) = lift2Matrix3'3 (-)
+
+  (*) (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) = 
+      M3'3 (a*m+b*p+c*s) (a*n+b*q+c*t) (a*o+b*r+c*u) 
+           (d*m+e*p+f*s) (d*n+e*q+f*t) (d*o+e*r+f*u) 
+           (g*m+h*p+i*s) (g*n+h*q+i*t) (g*o+h*r+i*u) 
+  
+  abs    = fmap abs 
+  negate = fmap negate
+  signum = fmap signum
+  fromInteger a = M3'3 a' a' a'  a' a' a'  a' a' a' where a' = fromInteger a 
+
+-- Radians
+
+instance Show Radian where
+  showsPrec i (Radian a) = showsPrec i a
+
+instance Eq Radian where (==) = req
+
+instance Ord Radian where
+  compare a b | a `req` b = EQ
+              | otherwise = getRadian a `compare` getRadian b
+
+--------------------------------------------------------------------------------
+-- Pretty printing
+
+instance Pretty a => Pretty (Vec2 a) where
+  pretty (V2 a b) = angles (char '|' <+> pretty a <+> pretty b <+> char '|')
+
+instance Pretty a => Pretty (Point2 a) where
+  pretty (P2 a b) = brackets (char '|' <+> pretty a <+> pretty b <+> char '|')
+
+instance Pretty a => Pretty (Frame2 a) where
+  pretty (Frame2 e0 e1 o) = braces $
+        text "e0:" <> pretty e0
+    <+> text "e1:" <> pretty e1
+    <+> text "o:" <> pretty o
+
+instance PSUnit a => Pretty (Matrix3'3 a) where
+  pretty (M3'3 a b c  d e f  g h i) = 
+      matline a b c <$> matline d e f <$> matline g h i
+    where
+      matline x y z = char '|' 
+         <+> (hcat $ map (fill 12 . text . dtrunc) [x,y,z]) 
+         <+> char '|'   
+
+
+instance Pretty Radian where
+  pretty (Radian d) = double d <> text ":rad"
+
+--------------------------------------------------------------------------------
+-- Vector space and related instances
+
+instance Num a => AdditiveGroup (Vec2 a) where
+  zeroV = V2 0 0 
+  (^+^) = lift2Vec2 (+)  
+  negateV = fmap negate 
+
+
+instance Num a => VectorSpace (Vec2 a) where
+  type Scalar (Vec2 a) = a
+  s *^ v = fmap (s*) v
+
+
+-- scalar (dot / inner) product via the class InnerSpace
+
+instance (Num a, InnerSpace a, Scalar a ~ a) 
+    => InnerSpace (Vec2 a) where
+  (V2 a b) <.> (V2 a' b') = (a <.> a') ^+^ (b <.> b')
+
+
+instance Num a => AffineSpace (Point2 a) where
+  type Diff (Point2 a) = Vec2 a
+  (P2 a b) .-. (P2 x y)   = V2 (a-x)  (b-y)
+  (P2 a b) .+^ (V2 vx vy) = P2 (a+vx) (b+vy)
+
+
+instance Num a => AdditiveGroup (Matrix3'3 a) where
+  zeroV = fromInteger 0
+  (^+^) = (+)
+  negateV = negate
+
+
+instance Num a => VectorSpace (Matrix3'3 a) where
+  type Scalar (Matrix3'3 a) = a
+  s *^ m = fmap (s*) m 
+
+--------------------------------------------------------------------------------
+
+-- | Pointwise is a Functor like type class, except that the 
+-- container/element relationship is defined by a type family 
+-- rather than a type parameter. This means that applied function 
+-- must be type preserving.
+
+
+class Pointwise sh where
+  type Pt sh :: *
+  pointwise :: (Pt sh -> Pt sh) -> sh -> sh
+
+
+instance Pointwise (a -> a) where
+  type Pt (a->a) = a
+  pointwise f pf = \a -> pf (f a)
+
+instance Pointwise a => Pointwise [a] where 
+  type Pt [a] = Pt a
+  pointwise f pts = map (pointwise f) pts 
+
+instance Pointwise (Vec2 a) where
+  type Pt (Vec2 a) = Vec2 a
+  pointwise f v = f v
+
+instance Pointwise (Point2 a) where
+  type Pt (Point2 a) = Point2 a
+  pointwise f pt = f pt
+
+--------------------------------------------------------------------------------
+
+instance Ord a => CMinMax (Point2 a) where
+  cmin (P2 x y) (P2 x' y') = P2 (min x x') (min y y')
+  cmax (P2 x y) (P2 x' y') = P2 (max x x') (max y y')
+
+--------------------------------------------------------------------------------
+-- Matrix multiply
+
+infixr 7 *# 
+
+class MatrixMult mat t where 
+  type MatrixParam t :: *
+  (*#) :: MatrixParam t ~ a => mat a -> t -> t
+
+
+-- Matrix multiplication of points and vectors as per homogeneous 
+-- coordinates (we don't perform the /last three/ multiplications
+-- as we throw the result away).
+ 
+instance Num a => MatrixMult Matrix3'3 (Vec2 a) where
+  type MatrixParam (Vec2 a) = a       
+  (M3'3 a b c d e f _ _ _) *# (V2 m n) = V2 (a*m+b*n+c*0) (d*m+e*n+f*0)
+
+
+instance Num a => MatrixMult Matrix3'3 (Point2 a) where
+  type MatrixParam (Point2 a) = a
+  (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1)
+
+--------------------------------------------------------------------------------
+-- Vectors
+
+-- | Construct a vector with horizontal displacement.
+hvec :: Num a => a -> Vec2 a
+hvec d = V2 d 0
+
+-- | Construct a vector with vertical displacement.
+vvec :: Num a => a -> Vec2 a
+vvec d = V2 0 d
+
+-- | Construct a vector from an angle and magnitude.
+avec :: Floating a => Radian -> a -> Vec2 a
+avec theta d = V2 x y where
+  ang = fromRadian theta
+  x   = d * cos ang
+  y   = d * sin ang
+
+
+--------------------------------------------------------------------------------
+-- Points
+
+zeroPt :: Num a => Point2 a
+zeroPt = P2 0 0
+
+langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian
+langle (P2 x y) (P2 x' y') = toRadian $ atan $ (y'-y) / (x'-x) 
+
+
+--------------------------------------------------------------------------------
+-- Frame operations
+
+ortho :: Num a => Point2 a -> Frame2 a
+ortho o = Frame2 (V2 1 0) (V2 0 1) o
+
+displaceOrigin :: Num a => Vec2 a -> Frame2 a -> Frame2 a
+displaceOrigin v (Frame2 e0 e1 o) = Frame2 e0 e1 (o.+^v)
+
+
+pointInFrame :: Num a => Point2 a -> Frame2 a -> Point2 a
+pointInFrame (P2 x y) (Frame2 vx vy o) = (o .+^ (vx ^* x)) .+^ (vy ^* y)  
+
+-- | Concatenate the elements of the frame as columns forming a
+-- 3x3 matrix. Points and vectors are considered homogeneous 
+-- coordinates - triples where the least element is either 0 
+-- indicating a vector or 1 indicating a point:
+--
+-- > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)
+-- 
+-- becomes
+--
+-- > (M3'3 e0x e1x ox
+-- >       e0y e1y oy
+-- >        0   0   1  )
+--
+
+frame2Matrix :: Num a =>  Frame2 a -> Matrix3'3 a
+frame2Matrix (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) = 
+    M3'3 e0x e1x ox  
+         e0y e1y oy 
+         0   0   1
+
+
+-- | Interpret the matrix as columns forming a frame.
+--
+-- > (M3'3 e0x e1x ox
+-- >       e0y e1y oy
+-- >        0   0   1  )
+--
+-- becomes
+--
+-- > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)
+-- 
+
+matrix2Frame :: Matrix3'3 a -> Frame2 a
+matrix2Frame (M3'3 e0x e1x ox 
+                   e0y e1y oy
+                   _   _   _ ) = Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)
+
+
+-- | /Multiplication/ of frames to form their product.
+frameProduct :: (Num a, InnerSpace (Vec2 a)) => Frame2 a -> Frame2 a -> Frame2 a
+frameProduct = matrix2Frame `oo` on (*) frame2Matrix
+
+
+
+-- | Is the origin at (0,0) and are the basis vectors orthogonal 
+-- with unit length?
+standardFrame :: Num a => Frame2 a -> Bool
+standardFrame (Frame2 (V2 1 0) (V2 0 1) (P2 0 0)) = True
+standardFrame _                                   = False
+
+
+--------------------------------------------------------------------------------
+-- Matrix construction
+
+-- | Construct the identity matrix:
+--
+-- > (M3'3 1 0 0
+-- >       0 1 0
+-- >       0 0 1 )
+--
+
+identityMatrix :: Num a => Matrix3'3 a
+identityMatrix = M3'3 1 0 0  
+                      0 1 0  
+                      0 0 1
+
+-- Common transformation matrices (for 2d homogeneous coordinates)
+
+-- | Construct a scaling matrix:
+--
+-- > (M3'3 sx 0  0
+-- >       0  sy 0
+-- >       0  0  1 )
+--
+
+scalingMatrix :: Num a => a -> a -> Matrix3'3 a
+scalingMatrix sx sy = M3'3  sx 0  0   
+                            0  sy 0   
+                            0  0  1
+
+translationMatrix :: Num a => a -> a -> Matrix3'3 a
+translationMatrix x y = M3'3 1 0 x  
+                             0 1 y  
+                             0 0 1
+
+rotationMatrix :: (Floating a, Real a) => Radian -> Matrix3'3 a
+rotationMatrix a = M3'3 (cos ang) (negate $ sin ang) 0 
+                        (sin ang) (cos ang)          0  
+                        0         0                  1
+  where ang = fromRadian a
+
+-- No reflectionMatrix function
+-- A reflection about the x-axis is a scale of 1 (-1)
+-- A reflection about the y-axis is a scale of (-1) 1
+
+
+-- Rotation about some /point/.
+originatedRotationMatrix :: (Floating a, Real a) 
+                         => Radian -> (Point2 a) -> Matrix3'3 a
+originatedRotationMatrix ang (P2 x y) = mT * (rotationMatrix ang) * mTinv
+  where
+    mT    = M3'3 1 0 x     
+                 0 1 y     
+                 0 0 1
+
+    mTinv = M3'3 1 0 (-x)  
+                 0 1 (-y)  
+                 0 0   1
+
+
+
+-- inversion
+
+invert :: Fractional a => Matrix3'3 a -> Matrix3'3 a 
+invert m = (1 / determinant m) *^ adjoint m
+
+determinant :: Num a => Matrix3'3 a -> a
+determinant (M3'3 a b c d e f g h i) = a*e*i - a*f*h - b*d*i + b*f*g + c*d*h - c*e*g
+
+
+adjoint :: Num a => Matrix3'3 a -> Matrix3'3 a 
+adjoint = transpose . cofactor . mofm
+
+transpose :: Matrix3'3 a -> Matrix3'3 a
+transpose (M3'3 a b c 
+                d e f 
+                g h i) = M3'3 a d g  
+                              b e h  
+                              c f i
+
+cofactor :: Num a => Matrix3'3 a -> Matrix3'3 a
+cofactor (M3'3 a b c  
+               d e f  
+               g h i) = M3'3   a  (-b)   c
+                             (-d)   e  (-f)
+                               g  (-h)   i
+
+mofm :: Num a => Matrix3'3 a -> Matrix3'3 a
+mofm (M3'3 a b c  
+               d e f  
+               g h i)  = M3'3 m11 m12 m13  
+                              m21 m22 m23 
+                          m31 m32 m33
+  where  
+    m11 = (e*i) - (f*h)
+    m12 = (d*i) - (f*g)
+    m13 = (d*h) - (e*g)
+    m21 = (b*i) - (c*h)
+    m22 = (a*i) - (c*g)
+    m23 = (a*h) - (b*g)
+    m31 = (b*f) - (c*e)
+    m32 = (a*f) - (c*d)
+    m33 = (a*e) - (b*d)
+
+
+
+--------------------------------------------------------------------------------
+-- Radians
+
+-- Radian numeric type
+
+radian_epsilon :: Double
+radian_epsilon = 0.0001
+
+
+req :: Radian -> Radian -> Bool
+req a b = (fromRadian $ abs (a-b)) < radian_epsilon
+
+
+
+-- Radian construction
+toRadian :: Real a => a -> Radian 
+toRadian = Radian . realToFrac
+
+
+-- Radian extraction 
+fromRadian :: Fractional a => Radian -> a
+fromRadian = realToFrac . getRadian
+
+
+-- | Degrees to radians.
+d2r :: (Floating a, Real a) => a -> Radian
+d2r = Radian . realToFrac . (*) (pi/180)
+
+-- | Radians to degrees.
+r2d :: (Floating a, Real a) => Radian -> a
+r2d = (*) (180/pi) . fromRadian
+
diff --git a/src/Wumpus/Core/GraphicsState.hs b/src/Wumpus/Core/GraphicsState.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/GraphicsState.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.GraphicsState
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Data types modelling the Graphics state
+--
+--------------------------------------------------------------------------------
+
+
+module Wumpus.Core.GraphicsState 
+  (
+  -- * Data types  
+  
+  -- ** Stroke attributes
+    StrokeAttr(..)
+  , LineCap(..)
+  , LineJoin(..)
+  , DashPattern(..)
+
+  -- ** Font
+  , FontAttr(..)
+  , SVGFontStyle(..)
+
+  -- ** Colour
+  , PSRgb
+
+  -- ** Current Translation Matrix
+  , CTM(..)
+
+  -- * Convert to CTM
+  , ToCTM(..)
+
+  -- * Convert to PSColour
+  , PSColour(..)
+
+  ) where
+
+import Wumpus.Core.Colour
+import Wumpus.Core.Geometry
+import Wumpus.Core.Utils
+
+-- Graphics state datatypes
+
+
+data StrokeAttr = LineWidth   Double
+                | MiterLimit  Double
+                | LineCap     LineCap
+                | LineJoin    LineJoin
+                | DashPattern DashPattern 
+  deriving (Eq,Show)
+
+data LineCap = CapButt | CapRound | CapSquare
+  deriving (Enum,Eq,Show)
+
+data LineJoin = JoinMiter | JoinRound | JoinBevel
+  deriving (Enum,Eq,Show)
+
+data DashPattern = Solid | Dash Int [Int]
+  deriving (Eq,Show)
+
+
+-- PostScript (or at least GhostScript) seems to require both
+-- attributes (name & size) are set at the same time.
+
+data FontAttr = FontAttr { 
+                    font_name       :: String,        -- for PostScript
+                    svg_font_family :: String,        -- for SVG
+                    svg_font_style  :: SVGFontStyle,
+                    font_size       :: Int 
+                  }
+  deriving (Eq,Show)
+
+data SVGFontStyle = SVG_REGULAR | SVG_BOLD | SVG_ITALIC | SVG_BOLD_ITALIC
+                  | SVG_OBLIQUE | SVG_BOLD_OBLIQUE
+  deriving (Eq,Show)
+
+type PSRgb = RGB3 Double
+
+
+
+-- | PostScript's current transformation matrix.
+-- 
+-- PostScript and its documentation considers the matrix to be 
+-- in this form:
+--
+-- > | a  b  0 |
+-- > | c  d  0 | 
+-- > | tx ty 1 |
+-- 
+-- i.e it considers the homogeneous coordinates of an affine 
+-- frame as /rows/ rather than /columns/ (Wumpus uses rows, as 
+-- they were the usual representation in the geometry 
+-- presentations that inspired it).
+-- 
+-- Using the component names that we have used in the 
+-- description of 'Frame2', the CTM is:
+--
+-- > | e0x  e0y  0 |
+-- > | e1x  e1y  0 | 
+-- > | ox   oy   1 |
+-- 
+-- The CTM is represented in PostScript as an array, using our 
+-- names its layout is
+--
+-- > [ e0x e0y e1x e1y ox oy ] 
+--
+-- Some examples, the scaling matrix:
+--
+-- > | sx 0  0 |
+-- > | 0  sy 0 |  = [ sx 0 0 sy 0 0 ]
+-- > | 0  0  1 |
+-- 
+-- Translation (displacement) :
+--
+-- > | 1  0  0 |
+-- > | 0  1  0 |  = [ 1 0 0 1 tx ty ]
+-- > | tx ty 1 |
+-- 
+-- Rotation:
+-- 
+-- > |  cos(a)  sin(a)  0 |
+-- > | -sin(a)  cos(a)  0 |  = [ cos(a) sin(a) -sin(a) cos(a) 0 0 ]
+-- > |    0       0     1 |
+
+data CTM u = CTM !u !u  !u !u  !u !u
+  deriving (Eq,Show)
+
+type instance DUnit (CTM u) = u
+
+--------------------------------------------------------------------------------
+-- Conversion to CTM
+
+
+class ToCTM a where 
+  toCTM :: u ~ DUnit a => a -> CTM u
+
+instance ToCTM (Frame2 a) where
+  toCTM (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) 
+    = CTM e0x e0y  e1x e1y  ox oy
+ 
+
+instance ToCTM (Matrix3'3 a) where
+  toCTM (M3'3 e0x e1x ox  
+              e0y e1y oy  
+              _   _   _  ) 
+    = CTM e0x e0y  e1x e1y  ox oy
+
+
+--------------------------------------------------------------------------------
+-- Conversion to PSColour
+
+class PSColour a where psColour :: a -> RGB3 Double
+
+instance PSColour (RGB3 Double) where
+  psColour (RGB3 r g b) = RGB3 (ramp r) (ramp g) (ramp b)
+
+instance PSColour (HSB3 Double) where
+  psColour = psColour . hsb2rgb
+
+instance PSColour (Gray Double) where
+  psColour = psColour . gray2rgb
+
+
+
+
diff --git a/src/Wumpus/Core/OutputPostScript.hs b/src/Wumpus/Core/OutputPostScript.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/OutputPostScript.hs
@@ -0,0 +1,373 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.OutputPostScript
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.OutputPostScript 
+  ( 
+  -- * Output PostScript
+  -- $fontdoc
+    writePS
+  , writeEPS
+  
+  , writePS_latin1
+  , writeEPS_latin1
+
+  ) where
+
+import Wumpus.Core.BoundingBox
+import Wumpus.Core.Colour
+import Wumpus.Core.Geometry
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.PictureInternal
+import Wumpus.Core.PostScript
+import Wumpus.Core.TextEncoding
+import Wumpus.Core.TextLatin1
+import Wumpus.Core.Utils
+
+import Data.Aviary ( appro )
+
+import MonadLib hiding ( Label )
+
+import Control.Monad ( mapM_, zipWithM_ )
+
+
+
+
+
+
+-- $fontdoc
+--
+-- The following fonts are expected to exist on most platforms:
+--
+-- > Times-Roman  Times-Italic  Times-Bold  Times-Bolditalic
+-- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique
+-- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique
+-- > Symbol
+--
+-- See the PostScript Language Reference Manual.
+
+-- type FontSpec = (String,Int)
+
+
+
+--------------------------------------------------------------------------------
+-- Render to PostScript
+
+-- | Write a series of pictures to a Postscript file. Each 
+-- picture will be printed on a separate page. 
+--
+-- If the picture contains text labels, you should provide a 
+-- FontSpec to transmit @findfont@, @scalefont@ etc. commands 
+-- to PostScript.    
+writePS :: (Fractional u, Ord u, PSUnit u) 
+        => FilePath -> TextEncoder -> [Picture u] -> IO ()
+writePS filepath enc pic = do 
+    timestamp <- mkTimeStamp
+    writeFile filepath $ psDraw timestamp enc pic
+
+-- | Write a picture to an EPS (Encapsulated PostScript) file. 
+-- The .eps file can then be imported or embedded in another 
+-- document.
+--
+-- If the picture contains text labels, you should provide a 
+-- FontSpec to transmit @findfont@, @scalefont@ etc. commands 
+-- to PostScript.    
+writeEPS :: (Fractional u, Ord u, PSUnit u)  
+         => FilePath -> TextEncoder -> Picture u -> IO ()
+writeEPS filepath enc pic = do
+    timestamp <- mkTimeStamp
+    writeFile filepath $ epsDraw timestamp enc pic
+
+
+-- | Version of 'writePS' - using Latin1 encoding. 
+writePS_latin1 :: (Fractional u, Ord u, PSUnit u) 
+        => FilePath -> [Picture u] -> IO ()
+writePS_latin1 filepath = writePS filepath latin1Encoder 
+
+-- | Version of 'writeEPS' - using Latin1 encoding. 
+writeEPS_latin1 :: (Fractional u, Ord u, PSUnit u)  
+         => FilePath -> Picture u -> IO ()
+writeEPS_latin1 filepath = writeEPS filepath latin1Encoder
+
+
+
+
+
+
+
+
+
+-- | Draw a picture, generating PostScript output.
+psDraw :: (Fractional u, Ord u, PSUnit u) 
+       => String -> TextEncoder -> [Picture u] -> PostScript
+psDraw timestamp enc pics = runWumpus enc $ do
+    psHeader 1 timestamp
+    zipWithM_ psDrawPage pages pics
+    psFooter
+  where
+    pages = map (\i -> (show i,i)) [1..]
+
+
+psDrawPage :: (Fractional u, Ord u, PSUnit u) 
+           => (String,Int) -> Picture u -> WumpusM ()
+psDrawPage (lbl,ordinal) pic = do
+    dsc_Page lbl ordinal
+    ps_gsave
+    cmdtrans
+    outputPicture pic
+    ps_grestore
+    ps_showpage
+  where
+    (_,mbv)   = repositionProperties pic
+    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv
+  
+
+
+-- Note the bounding box may have negative components - if it 
+-- does it will need translating.
+
+epsDraw :: (Fractional u, Ord u, PSUnit u) 
+        => String -> TextEncoder -> Picture u -> PostScript
+epsDraw timestamp enc pic = runWumpus enc $ do 
+    epsHeader bb timestamp      
+    ps_gsave
+    cmdtrans
+    outputPicture pic
+    ps_grestore
+    epsFooter  
+  where
+    (bb,mbv)  = repositionProperties pic
+    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv
+     
+
+psHeader :: Int -> String -> WumpusM ()
+psHeader pagecount timestamp = do
+    bang_PS
+    dsc_Pages pagecount
+    dsc_CreationDate $ parens timestamp
+    dsc_EndComments
+
+
+epsHeader :: PSUnit u => BoundingBox u -> String -> WumpusM ()
+epsHeader bb timestamp = do
+    bang_EPS
+    dsc_BoundingBox llx lly urx ury
+    dsc_CreationDate $ parens timestamp
+    dsc_EndComments
+  where
+    (llx,lly,urx,ury) = getBounds bb
+
+getBounds :: Num u => BoundingBox u -> (u,u,u,u)
+getBounds (BBox (P2 llx lly) (P2 urx ury)) = (llx,lly,urx,ury)
+
+psFooter :: WumpusM ()
+psFooter = dsc_EOF
+
+
+epsFooter :: WumpusM ()
+epsFooter = do
+    ps_showpage
+    dsc_EOF
+
+-- Create margins at the left and bottom of 4 points...
+
+
+-- | outputPicture 
+-- Frame changes, representing scalings translation, rotations...
+-- are drawn when they are encountered as a @concat@ statement in a 
+-- block of @gsave ... grestore@.
+
+outputPicture :: (Fractional u, PSUnit u) => Picture u -> WumpusM ()
+outputPicture (PicBlank  _)             = return ()
+outputPicture (Single (fr,_) prim)      = 
+    updateFrame fr $ outputPrimitive prim
+outputPicture (Picture (fr,_) ones)      = do
+    updateFrame fr $ onesmapM_ outputPicture  ones
+outputPicture (Clip (fr,_) cp p)        = 
+    updateFrame fr $ do { clipPath cp ; outputPicture p }
+
+
+-- | @updateFrame@ relies on the current frame, when translated
+-- to a matrix being invertible.
+--
+-- This is an allowable optimization because the current frame
+-- is only manipulated with the affine transformations (scalings, 
+-- rotations...) which are invertible. 
+-- 
+-- It also performs another optimization:
+--
+-- If the frame is the standard frame @ [1 0 0 1 0 0] @ then 
+-- the monadic action is run as-is rather than being nested
+-- in a block:
+-- 
+-- > [1 0 0 1 0 0] concat
+-- > ...
+-- > [1 0 0 1 0 0] concat
+--
+
+updateFrame :: (Fractional u, PSUnit u) => Frame2 u -> WumpusM () -> WumpusM ()
+updateFrame frm ma 
+  | standardFrame frm = ma
+  | otherwise         = let m1 = frame2Matrix frm in 
+                        do { ps_concat $ toCTM m1
+                           ; ma 
+                           ; ps_concat $ toCTM $ invert m1
+                           }
+
+outputPrimitive :: (Fractional u, PSUnit u) => Primitive u -> WumpusM ()
+outputPrimitive (PPath (c,dp) p)           = outputPath dp c p 
+outputPrimitive (PLabel props l)           = updateFont props $ outputLabel l
+outputPrimitive (PEllipse (c,dp) ct hw hh) = outputEllipse dp c ct hw hh
+
+updateFont :: LabelProps -> WumpusM () -> WumpusM ()
+updateFont (c,fnt) ma = updateColour c $ do 
+    mb_fnt <- deltaFontAttr fnt
+    maybe (return ()) fontCommand mb_fnt
+    ma
+    
+
+
+updateColour :: PSColour c => c -> WumpusM () -> WumpusM ()
+updateColour c ma = let rgbc = psColour c in do 
+    mb_col  <- deltaRgbColour rgbc
+    maybe (return ()) colourCommand mb_col
+    ma
+  where
+    colourCommand :: DRGB -> WumpusM ()
+    colourCommand (RGB3 r g b) = ps_setrgbcolor r g b
+ 
+    
+
+
+fontCommand :: FontAttr -> WumpusM ()
+fontCommand (FontAttr name _ _ sz) = do
+    ps_findfont name
+    ps_scalefont sz
+    ps_setfont
+
+
+
+    
+outputPath :: (PSColour c, PSUnit u) 
+           => DrawPath -> c -> Path u -> WumpusM ()
+outputPath CFill        c p = updateColour c $ do  
+    startPath p
+    ps_closepath
+    ps_fill
+
+outputPath (CStroke xs) c p = updatePen c xs $ do
+    startPath p
+    ps_closepath
+    ps_stroke
+
+outputPath (OStroke xs) c p = updatePen c xs $ do
+    startPath p
+    ps_stroke
+  
+
+startPath :: PSUnit u => Path u -> WumpusM ()
+startPath (Path (P2 x y) xs) = do
+    ps_newpath
+    ps_moveto x y
+    mapM_ outputPathSeg xs
+
+
+
+clipPath :: PSUnit u => Path u -> WumpusM ()
+clipPath p = do 
+    startPath p
+    ps_closepath
+    ps_clip
+
+
+
+updatePen :: PSColour c => c -> [StrokeAttr] -> WumpusM () -> WumpusM ()
+updatePen c xs ma = let (mset, mreset) = strokeSetReset xs in 
+                    updateColour c $ do { mset ; ma ; mreset }
+
+strokeSetReset :: [StrokeAttr] -> (WumpusM (), WumpusM ())
+strokeSetReset = foldr (appro link cmd id) (return (), return ())
+  where
+    link Nothing      funs    = funs 
+    link (Just (f,g)) (fs,gs) = (fs >> f, gs >> g)
+    
+    mkSetReset mf        = maybe Nothing (\(a,b) -> Just (mf a, mf b))
+    
+    cmd (LineWidth d)    = mkSetReset ps_setlinewidth  $ deltaStrokeWidth d
+    cmd (MiterLimit d)   = mkSetReset ps_setmiterlimit $ deltaMiterLimit d
+    cmd (LineCap lc)     = mkSetReset ps_setlinecap    $ deltaLineCap lc
+    cmd (LineJoin lj)    = mkSetReset ps_setlinejoin   $ deltaLineJoin lj
+    cmd (DashPattern dp) = mkSetReset ps_setdash       $ deltaDashPattern dp
+
+
+outputPathSeg :: PSUnit u => PathSegment u -> WumpusM ()
+outputPathSeg (PLine (P2 x y))  = ps_lineto x y
+outputPathSeg (PCurve p1 p2 p3) = ps_curveto x1 y1 x2 y2 x3 y3 
+  where
+    P2 x1 y1 = p1
+    P2 x2 y2 = p2
+    P2 x3 y3 = p3
+
+-- | This is not very good as it uses a PostScript's
+-- @scale@ operator - this will vary the line width during the
+-- drawing of a stroked ellipse.
+outputEllipse :: (PSColour c, Fractional u, PSUnit u)
+              => DrawEllipse -> c -> Point2 u -> u -> u -> WumpusM ()
+outputEllipse dp c (P2 x y) hw hh 
+    | hw==hh    = outputArc dp c x y hw
+    | otherwise = do { ps_gsave
+                     -- Not so good -- the next line changes stroke width...
+                     ; ps_scale 1 (hh/hw)
+                     ; outputArc dp c x y hw
+                     ; ps_grestore
+                     }
+
+outputArc :: (PSColour c, PSUnit u) 
+          => DrawEllipse -> c -> u -> u -> u -> WumpusM ()
+outputArc EFill        c x y r = updateColour c $ do 
+    ps_arc x y r 0 360 
+    ps_closepath
+    ps_fill
+
+outputArc (EStroke xs) c x y r = updatePen c xs $ do 
+    ps_arc x y r 0 360 
+    ps_closepath
+    ps_stroke
+
+
+outputLabel :: PSUnit u => Label u -> WumpusM ()
+outputLabel (Label (P2 x y) entxt) = do
+    ps_moveto x y
+    outputEncodedText entxt
+--    ps_show str
+
+outputEncodedText :: EncodedText -> WumpusM () 
+outputEncodedText = mapM_ outputTextChunk . getEncodedText
+
+outputTextChunk :: TextChunk -> WumpusM () 
+outputTextChunk (SText s)  = ps_show s
+
+outputTextChunk (EscInt i) = 
+    ask >>= \env -> maybe (failk env) ps_glyphshow $ lookupByCharCode i env
+  where
+    failk = missingCode i . ps_fallback  
+
+outputTextChunk (EscStr s) = ps_glyphshow s 
+
+missingCode :: CharCode -> GlyphName -> WumpusM ()
+missingCode i fallback =  do
+    ps_comment $ "missing lookup for &#" ++ show i ++ ";" 
+    ps_glyphshow fallback
+            
+
+
diff --git a/src/Wumpus/Core/OutputSVG.hs b/src/Wumpus/Core/OutputSVG.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/OutputSVG.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.OutputSVG
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Output SVG. 
+--
+-- This is complicated by two differences with PostScript.
+--
+-- 1. The coordinate space of SVG is /origin top-left/, for 
+-- PostScript it is /origin bottom-left/.
+-- 
+-- 2. Clipping in PostScript works by changing the graphics state
+-- Clip a path, then all subsequent drawing be rendered only 
+-- when it is within the clip bounds. Clearly using clipping 
+-- paths within a @gsave ... grestore@ block is a good idea...
+--
+-- SVG uses /tagging/. A clipPath element is declared and named 
+-- then referenced in subsequent elements via the clip-path 
+-- attribute - @clip-path=\"url(#clip_path_tag)\"@.
+--
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.OutputSVG
+  ( 
+  
+  -- * Output SVG
+    writeSVG
+
+  , writeSVG_latin1
+  
+  ) where
+
+import Wumpus.Core.AffineTrans
+import Wumpus.Core.Geometry
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.PictureInternal
+import Wumpus.Core.SVG
+import Wumpus.Core.TextEncoding
+import Wumpus.Core.TextLatin1
+import Wumpus.Core.Utils
+
+import Data.Aviary ( (#) )
+
+import MonadLib hiding ( Label )
+
+import Text.XML.Light
+
+
+
+type Clipped    = Bool
+
+
+coordChange ::  (Num u, Ord u, Scale t, u ~ DUnit t) => t -> t
+coordChange = scale 1 (-1)
+
+
+--------------------------------------------------------------------------------
+
+writeSVG :: (Ord u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO ()
+writeSVG filepath enc pic = 
+    writeFile filepath $ unlines $ map ppContent $ svgDraw enc pic 
+
+writeSVG_latin1 :: (Ord u, PSUnit u) => FilePath -> Picture u -> IO ()
+writeSVG_latin1 filepath = writeSVG filepath latin1Encoder 
+
+
+
+svgDraw :: (Ord u, PSUnit u) => TextEncoder -> Picture u -> [Content]
+svgDraw enc pic = runSVG enc $ 
+    picture False pic' >>= return . topLevelPic mbvec >>= prefixXmlDecls
+  where
+    pic'      = coordChange pic
+    (_,mbvec) = repositionProperties pic'
+
+
+prefixXmlDecls :: Element -> SvgM [Content]
+prefixXmlDecls e = do 
+    enc <- asks svg_encoding_name
+    let xmlv = xmlVersion enc
+    return $ [Text xmlv, Text svgDocType, Elem e]    
+
+topLevelPic :: PSUnit u => Maybe (Vec2 u) -> Element -> Element
+topLevelPic Nothing         p = svgElement [p]
+topLevelPic (Just (V2 x y)) p = svgElement [gElement [trans_attr] [p]] 
+  where 
+    trans_attr = attr_transform $ val_translate x y
+
+
+
+picture :: (Ord u, PSUnit u) => Clipped -> Picture u -> SvgM Element
+picture _ (PicBlank _)            = return $ gElement [] []
+picture c (Single (fr,_) prim)    = do 
+    elt <- primitive c prim
+    return $ gElement (maybe [] return $ frameChange fr) [elt]
+
+picture c (Picture (fr,_) ones)    = do
+    es <- toListWithM (picture c) ones
+    return $ gElement (maybe [] return $ frameChange fr) es
+
+picture _ (Clip (fr,_) p a) = do 
+   cp <- clipPath p
+   e1 <- picture True a
+   return $ gElement (maybe [] return $ frameChange fr) [cp,e1]
+
+
+primitive :: (Ord u, PSUnit u) => Clipped -> Primitive u -> SvgM Element
+primitive c (PPath props p)            = clipAttrib c $ path props p
+primitive c (PLabel props l)           = clipAttrib c $ label props l
+primitive c (PEllipse props mid hw hh) = clipAttrib c $ 
+                                                ellipse props mid hw hh
+
+
+
+-- All clipping paths are closed.
+clipPath :: PSUnit u => Path u -> SvgM Element
+clipPath p = do
+    name <- newClipLabel
+    return $ element_clippath ps # add_attr (attr_id name)
+  where
+    ps = closePath $ pathInstructions p
+
+
+
+clipAttrib :: Clipped -> SvgM Element -> SvgM Element
+clipAttrib False melt = melt
+clipAttrib True  melt = do 
+    s   <- currentClipLabel
+    elt <- melt
+    return $ add_attr (attr_clippath s) elt
+
+
+-- None of the remaining translation functions need to be in the
+-- SvgM monad.
+
+path :: PSUnit u => PathProps -> Path u -> SvgM Element
+path (c,dp) p = 
+    return $ element_path ps # add_attrs (fill_a : stroke_a : opts)
+  where
+    (fill_a,stroke_a,opts) = drawProperties c dp
+    ps                     = svgPath dp p 
+
+
+-- Labels need the coordinate system remapping otherwise
+-- the will be printed upside down. Both the start point and 
+-- the label itself need transforming.
+-- 
+-- Also rendering coloured text is convoluted (needing the
+-- tspan element).
+-- 
+label :: (Ord u, PSUnit u) => LabelProps -> Label u -> SvgM Element
+label (c,FontAttr _ fam style sz) (Label pt entxt) = do 
+     str <- encodedText entxt
+     let tspan_elt = element_tspan str # add_attrs [ attr_fill c ]
+     return $ element_text tspan_elt # add_attrs text_xs 
+                                     # add_attrs (fontStyle style)
+  where
+    P2 x y    = coordChange pt
+    text_xs   = [ attr_x x
+                , attr_y y 
+                , attr_transform $ val_matrix 1 0 0 (-1) 0 (0::Double)
+                , attr_font_family fam
+                , attr_font_size sz 
+                ]
+    
+    
+
+
+encodedText :: EncodedText -> SvgM String 
+encodedText entxt = 
+    let xs = getEncodedText entxt in mapM textChunk  xs >>= return . concat
+
+-- | Unfortunately we can\'t readily put a comment in the 
+-- generated SVG when glyph-name lookup fails. Doing similar in 
+-- PostScript is easy because we are emiting /linear/ PostScript 
+-- as we go along. For SVG we are building an abstract syntax 
+-- tree.
+-- 
+textChunk :: TextChunk -> SvgM String
+textChunk (SText s)  = return s
+textChunk (EscInt i) = return $ escapeCharCode i
+textChunk (EscStr s) = 
+    asks (lookupByGlyphName s) >>= maybe failk (return . escapeCharCode) 
+  where
+    failk = asks svg_fallback >>= return . escapeCharCode 
+
+escapeCharCode :: CharCode -> String
+escapeCharCode i = "&#" ++ show i ++ ";"
+
+ 
+fontStyle :: SVGFontStyle -> [Attr]
+fontStyle SVG_REGULAR      = []
+fontStyle SVG_BOLD         = [attr_font_weight "bold"]
+fontStyle SVG_ITALIC       = [attr_font_style "italic"]
+fontStyle SVG_BOLD_ITALIC  = 
+    [attr_font_weight "bold", attr_font_style "italic"]
+fontStyle SVG_OBLIQUE      = [attr_font_style "oblique"]
+fontStyle SVG_BOLD_OBLIQUE = 
+    [attr_font_weight "bold", attr_font_style "oblique"]
+
+-- If w==h the draw the ellipse as a circle
+
+ellipse :: PSUnit u => EllipseProps -> Point2 u -> u -> u -> SvgM Element
+ellipse (c,dp) (P2 x y) w h 
+    | w == h    = return $ element_circle  
+                         # add_attrs (circle_attrs  ++ style_attrs)
+    | otherwise = return $ element_ellipse 
+                         # add_attrs (ellipse_attrs ++ style_attrs)
+  where
+    circle_attrs  = [attr_cx x, attr_cy y, attr_r w]
+    ellipse_attrs = [attr_cx x, attr_cy y, attr_rx w, attr_ry h]
+    style_attrs   = fill_a : stroke_a : opts
+                    where (fill_a,stroke_a,opts) = drawEllipse c dp
+
+
+-- A rule of thumb seems to be that SVG (at least SVG in Firefox)
+-- will try to fill unless told not to. So always label paths
+-- with @fill=...@ even if fill is @\"none\"@.
+--
+-- CFill   ==> stroke="none" fill="..."
+-- CStroke ==> stroke="..."  fill="none"
+-- OStroke ==> stroke="..."  fill="none"
+--
+
+drawProperties :: PSColour c => c -> DrawPath -> (Attr, Attr, [Attr])
+drawProperties = fn where
+  fn c CFill        = (attr_fill c, attr_stroke_none, [])
+  fn c (OStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)
+  fn c (CStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)
+
+drawEllipse :: PSColour c => c -> DrawEllipse -> (Attr, Attr, [Attr])
+drawEllipse = fn where
+  fn c EFill        = (attr_fill c, attr_stroke_none, [])
+  fn c (EStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)
+ 
+
+strokeAttributes :: [StrokeAttr] -> [Attr]
+strokeAttributes = foldr fn [] where
+  fn (LineWidth a)    = (:) (attr_stroke_width a)
+  fn (MiterLimit a)   = (:) (attr_stroke_miterlimit a)
+  fn (LineCap lc)     = (:) (attr_stroke_linecap lc)
+  fn (LineJoin lj)    = (:) (attr_stroke_linejoin lj)
+  fn (DashPattern dp) = dash dp where
+    dash Solid       = (:) (attr_stroke_dasharray_none)
+    dash (Dash _ []) = (:) (attr_stroke_dasharray_none)
+    dash (Dash i xs) = (:) (attr_stroke_dashoffset i) . 
+                       (:) (attr_stroke_dasharray xs)
+   
+
+
+svgPath :: PSUnit u => DrawPath -> Path u -> SvgPath
+svgPath (OStroke _) p = pathInstructions p
+svgPath _           p = closePath $ pathInstructions p
+
+
+pathInstructions :: PSUnit u => Path u -> [String]
+pathInstructions (Path (P2 x y) xs) = path_m x y : map pathSegment xs
+
+pathSegment :: PSUnit u => PathSegment u -> String
+pathSegment (PLine (P2 x1 y1))                        = path_l x1 y1
+pathSegment (PCurve (P2 x1 y1) (P2 x2 y2) (P2 x3 y3)) = 
+    path_s x1 y1 x2 y2 x3 y3
+
+
+
+frameChange :: PSUnit u => Frame2 u -> Maybe Attr
+frameChange fr 
+    | standardFrame fr = Nothing
+    | otherwise        = Just $ attr_transform $ val_matrix a b c d e f 
+  where
+    CTM a b c d e f = toCTM fr
+
+
+
+closePath :: SvgPath -> SvgPath 
+closePath xs = xs ++ ["Z"]
diff --git a/src/Wumpus/Core/Picture.hs b/src/Wumpus/Core/Picture.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Picture.hs
@@ -0,0 +1,443 @@
+{-# LANGUAGE FlexibleInstances          #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.Picture
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.Picture 
+  (
+  
+   -- * Construction
+    blankPicture
+  , frame
+  , frameWithin
+  , frameMulti
+  , multi
+
+
+  , path
+  , lineTo
+  , curveTo
+  , vertexPath  
+  , curvedPath
+
+  -- * Constructing primitives
+  , Stroke(..)
+  , zostroke
+  , zcstroke
+
+  , Fill(..)
+  , zfill
+  
+  , clip
+
+  , TextLabel(..)
+  , ztextlabel
+  , multilabel
+
+  , Ellipse(..)
+  , zellipse
+
+
+
+
+  -- * Operations
+  , extendBoundary
+
+  ) where
+
+import Wumpus.Core.BoundingBox
+import Wumpus.Core.Colour
+import Wumpus.Core.Geometry
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.PictureInternal
+import Wumpus.Core.TextEncoding
+import Wumpus.Core.Utils
+
+import Data.Semigroup
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- Default attributes
+
+psBlack :: PSRgb
+psBlack = RGB3 0 0 0
+ 
+-- aka the standard frame
+stdFrame :: Num u => Frame2 u 
+stdFrame = ortho zeroPt
+
+--------------------------------------------------------------------------------
+-- OneList helper
+
+
+-- | This module (Wumpus.Core.Picture) should be the only 
+-- interface to the /outside world/ for creating 
+
+--------------------------------------------------------------------------------
+-- Construction
+
+
+
+-- | Create a blank picture sized to the supplied bounding box.
+-- This is useful for spacing rows or columns of pictures.
+blankPicture :: Num u => BoundingBox u -> Picture u
+blankPicture bb = PicBlank (stdFrame, bb)
+
+
+-- | Lift a Primitive to a Picture, located in the standard frame.
+frame :: (Fractional u, Ord u) => Primitive u -> Picture u
+frame p = Single (stdFrame, boundary p) p 
+
+-- | Frame a picture within the supplied bounding box
+-- 
+-- A text label uses the supplied bounding box as is - no 
+-- clipping is performed if the bounding box is 
+-- smaller than the boundary size of the text. This may 
+-- cause strange overlap for subsequent composite pictures, and
+-- incorrect bounding box annotations in the prologue of the 
+-- generated EPS file. 
+-- 
+-- Paths and ellipses are bound within the union of the supplied 
+-- bounding box and the inherent bounding box or the path or 
+-- ellipse. Thus the bounding box will never reframed to a 
+-- smaller size than the /natural/ bounding box.
+--
+frameWithin :: (Fractional u, Ord u) => Primitive u -> BoundingBox u -> Picture u
+frameWithin p@(PLabel _ _) bb = Single (stdFrame,bb) p
+frameWithin p              bb = Single (stdFrame,bb `append` boundary p) p
+
+
+
+
+-- | Lift a list of Primitives to a composite Picture, all 
+-- Primitives will be located within the standard frame.
+-- The list of Primitives must be non-empty.
+--
+frameMulti :: (Fractional u, Ord u) => [Primitive u] -> Picture u
+frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list"
+frameMulti xs = multi $ map frame xs
+
+
+-- | Place multiple pictures within the same affine frame
+-- This function throws an error when supplied the empty list.
+multi :: (Fractional u, Ord u) => [Picture u] -> Picture u
+multi ps = Picture (stdFrame, sconcat $ map boundary ps) ones
+  where 
+    sconcat []      = error err_msg
+    sconcat (x:xs)  = foldr append x xs
+
+    ones            = fromListErr err_msg ps
+
+    err_msg         = "Wumpus.Core.Picture.multi - empty list"
+
+
+
+-- | Create a Path from the start point and alist of PathSegments.
+path :: Point2 u -> [PathSegment u] -> Path u
+path = Path 
+
+-- | Create a straight-line PathSegment.
+lineTo :: Point2 u -> PathSegment u
+lineTo = PLine
+
+-- | Create a curved PathSegment.
+curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u
+curveTo = PCurve
+
+
+-- | Convert the list of vertices to a path of straight line 
+-- segments.
+vertexPath :: [Point2 u] -> Path u
+vertexPath []     = error "Picture.vertexPath - empty point list"
+vertexPath (x:xs) = Path x (map PLine xs)
+
+
+-- Not a paramorphism as you want to consume3 rather than 
+-- look-ahead3...
+
+-- | Convert a list of vertices to a path of curve segments.
+-- The first point in the list makes the start point, each curve 
+-- segment thereafter takes 3 points. /Spare/ points at the end 
+-- are discarded. 
+curvedPath :: [Point2 u] -> Path u
+curvedPath []     = error "Picture.curvedPath - empty point list"
+curvedPath (x:xs) = Path x (fn xs) where
+  fn (a:b:c:ys) = PCurve a b c : fn ys 
+  fn _          = []
+
+
+  
+
+
+
+--------------------------------------------------------------------------------
+-- Take Paths to Primitives
+
+
+ostrokePath :: (Num u, Ord u) 
+            => PSRgb -> [StrokeAttr] -> Path u -> Primitive u
+ostrokePath c attrs p = PPath (c, OStroke attrs) p
+
+cstrokePath :: (Num u, Ord u) 
+            => PSRgb -> [StrokeAttr] -> Path u -> Primitive u
+cstrokePath c attrs p = PPath (c, CStroke attrs) p
+
+class Stroke t where
+  ostroke :: (Num u, Ord u) => t -> Path u -> Primitive u
+  cstroke :: (Num u, Ord u) => t -> Path u -> Primitive u
+
+instance Stroke () where
+  ostroke () = ostrokePath psBlack []
+  cstroke () = cstrokePath psBlack []
+
+instance Stroke (RGB3 Double) where
+  ostroke c = ostrokePath (psColour c) []
+  cstroke c = cstrokePath (psColour c) []
+
+instance Stroke (HSB3 Double) where
+  ostroke c = ostrokePath (psColour c) []
+  cstroke c = cstrokePath (psColour c) []
+
+instance Stroke (Gray Double) where
+  ostroke c = ostrokePath (psColour c) []
+  cstroke c = cstrokePath (psColour c) []
+
+
+instance Stroke StrokeAttr where
+  ostroke x = ostrokePath psBlack [x]
+  cstroke x = cstrokePath psBlack [x]
+
+instance Stroke [StrokeAttr] where
+  ostroke xs = ostrokePath psBlack xs
+  cstroke xs = cstrokePath psBlack xs
+
+
+
+instance Stroke (RGB3 Double,StrokeAttr) where
+  ostroke (c,x) = ostrokePath (psColour c) [x]
+  cstroke (c,x) = cstrokePath (psColour c) [x]
+
+instance Stroke (HSB3 Double,StrokeAttr) where
+  ostroke (c,x) = ostrokePath (psColour c) [x]
+  cstroke (c,x) = cstrokePath (psColour c) [x]
+
+instance Stroke (Gray Double,StrokeAttr) where
+  ostroke (c,x) = ostrokePath (psColour c) [x]
+  cstroke (c,x) = cstrokePath (psColour c) [x]
+
+instance Stroke (RGB3 Double,[StrokeAttr]) where
+  ostroke (c,xs) = ostrokePath (psColour c) xs
+  cstroke (c,xs) = cstrokePath (psColour c) xs
+
+instance Stroke (HSB3 Double,[StrokeAttr]) where
+  ostroke (c,xs) = ostrokePath (psColour c) xs
+  cstroke (c,xs) = cstrokePath (psColour c) xs
+
+instance Stroke (Gray Double,[StrokeAttr]) where
+  ostroke (c,xs) = ostrokePath (psColour c) xs
+  cstroke (c,xs) = cstrokePath (psColour c) xs
+
+
+-- | Create an open stoke coloured black.
+zostroke :: (Num u, Ord u) => Path u -> Primitive u
+zostroke = ostrokePath psBlack []
+ 
+-- | Create a closed stroke coloured black.
+zcstroke :: (Num u, Ord u) => Path u -> Primitive u
+zcstroke = cstrokePath psBlack []
+
+
+
+
+-- fills only have one property - colour
+-- Having a fill class seems uniform as we have a stroke class 
+
+
+
+fillPath :: (Num u, Ord u) => PSRgb -> Path u -> Primitive u
+fillPath c p = PPath (c,CFill) p
+
+class Fill t where
+  fill :: (Num u, Ord u) => t -> Path u -> Primitive u
+ 
+
+instance Fill ()                where fill () = fillPath psBlack 
+instance Fill (RGB3 Double)     where fill = fillPath . psColour
+instance Fill (HSB3 Double)     where fill = fillPath . psColour
+instance Fill (Gray Double)     where fill = fillPath . psColour
+
+-- | Create a filled path coloured black. 
+zfill :: (Num u, Ord u) => Path u -> Primitive u
+zfill = fillPath psBlack
+
+--------------------------------------------------------------------------------
+-- Clipping 
+
+clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u
+clip cp p = Clip (ortho zeroPt, boundary cp) cp p
+
+
+--------------------------------------------------------------------------------
+-- Labels to primitive
+
+mkTextLabel :: PSRgb -> FontAttr -> Point2 u -> String -> Primitive u
+mkTextLabel c attr pt txt = PLabel (c,attr) (Label pt $ lexLabel txt)
+
+-- SVG seems to have an issue with /Courier/ and needs /Courier New/.
+
+default_font :: FontAttr
+default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 12
+
+class TextLabel t where 
+  textlabel :: t -> Point2 u -> String -> Primitive u
+
+
+instance TextLabel () where textlabel () = mkTextLabel psBlack default_font
+
+instance TextLabel (RGB3 Double) where
+  textlabel c = mkTextLabel (psColour c) default_font
+
+instance TextLabel (HSB3 Double) where
+  textlabel c = mkTextLabel (psColour c) default_font
+
+instance TextLabel (Gray Double) where
+  textlabel c = mkTextLabel (psColour c) default_font
+
+instance TextLabel FontAttr where
+  textlabel a = mkTextLabel psBlack a
+
+instance TextLabel (RGB3 Double,FontAttr) where
+  textlabel (c,a) = mkTextLabel (psColour c) a
+
+instance TextLabel (HSB3 Double,FontAttr) where
+  textlabel (c,a) = mkTextLabel (psColour c) a
+
+instance TextLabel (Gray Double,FontAttr) where
+  textlabel (c,a) = mkTextLabel (psColour c) a
+
+-- | Create a label where the font is @Courier@, text size is 10 
+-- and colour is black.
+ztextlabel :: Point2 u -> String -> Primitive u
+ztextlabel = mkTextLabel psBlack default_font
+
+
+
+-- (The implementation of this function needs attention).
+--
+multilabel :: (Fractional u, Ord u) 
+           => [Label u] -> LabelProps -> BoundingBox u -> Picture u
+multilabel ps props bb = 
+    Picture (stdFrame, bb) $ fromListErr err_msg 
+                           $ map frame
+                           $ zipWith PLabel (repeat props) ps 
+  where 
+    err_msg = "Wumpus.Core.Picture.multilabel - empty list."
+
+--------------------------------------------------------------------------------
+
+mkEllipse :: Num u 
+          => PSRgb -> DrawEllipse -> Point2 u -> u -> u -> Primitive u
+mkEllipse c dp pt hw hh = PEllipse (c,dp) pt hw hh
+
+
+ellipseDefault :: EllipseProps
+ellipseDefault = (psBlack, EFill)
+
+
+-- | Instances will create a filled ellipse unless the supplied 
+-- element /implies/ a stoked ellipse, e.g.:
+--
+-- > ellipse (LineWidth 4) zeroPt 40 40 
+-- > ellipse EFill zeroPt 40 40  
+--
+class Ellipse t where
+  ellipse :: Fractional u => t -> Point2 u -> u -> u -> Primitive u
+
+instance Ellipse ()             where ellipse () = zellipse
+instance Ellipse DrawEllipse    where ellipse dp = mkEllipse psBlack dp
+
+instance Ellipse StrokeAttr     where 
+    ellipse = mkEllipse psBlack . EStroke . return
+
+instance Ellipse [StrokeAttr]   where 
+    ellipse = mkEllipse psBlack . EStroke
+
+instance Ellipse (RGB3 Double) where 
+    ellipse c = mkEllipse (psColour c) EFill
+
+instance Ellipse (HSB3 Double) where 
+    ellipse c = mkEllipse (psColour c) EFill
+
+instance Ellipse (Gray Double) where 
+    ellipse c = mkEllipse (psColour c) EFill
+
+
+instance Ellipse (RGB3 Double,DrawEllipse) where 
+    ellipse (c,dp) = mkEllipse (psColour c) dp
+
+instance Ellipse (HSB3 Double,DrawEllipse) where 
+    ellipse (c,dp) = mkEllipse (psColour c) dp
+
+instance Ellipse (Gray Double,DrawEllipse) where 
+    ellipse (c,dp) = mkEllipse (psColour c) dp
+
+
+instance Ellipse (RGB3 Double,StrokeAttr) where 
+    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])
+
+instance Ellipse (HSB3 Double,StrokeAttr) where 
+    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])
+
+instance Ellipse (Gray Double,StrokeAttr) where 
+    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])
+
+instance Ellipse (RGB3 Double,[StrokeAttr]) where 
+    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)
+
+instance Ellipse (HSB3 Double,[StrokeAttr]) where 
+    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)
+
+instance Ellipse (Gray Double,[StrokeAttr]) where 
+    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)
+
+
+-- | Create a black, filled ellipse. 
+zellipse :: Num u => Point2 u -> u -> u -> Primitive u
+zellipse = uncurry mkEllipse ellipseDefault
+
+
+--------------------------------------------------------------------------------
+
+-- Operations on pictures and paths
+
+
+
+
+-- | Extend the bounding box of a picture. 
+--
+-- The bounding box is both horizontal directions by @x@ and 
+-- both vertical directions by @y@. @x@ and @y@ must be positive
+-- This function cannot be used to shrink a boundary.
+--
+extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
+extendBoundary x y = mapLocale (\(fr,bb) -> (fr, extBB (posve x) (posve y) bb)) 
+  where
+    extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where 
+        pt1 = P2 (x0-x') (y0-y')
+        pt2 = P2 (x1+x') (y1+y')
+    
+    posve n | n < 0     = 0
+            | otherwise = n 
diff --git a/src/Wumpus/Core/PictureInternal.hs b/src/Wumpus/Core/PictureInternal.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/PictureInternal.hs
@@ -0,0 +1,461 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.PictureInternal
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Internal representation of Pictures 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.PictureInternal 
+  (
+  -- * Data types
+    Picture(..)
+  , DPicture
+  , Primitive(..)
+  , DPrimitive
+  , Path(..)
+  , DPath
+  , PathSegment(..)
+  , DPathSegment
+  , Label(..)
+  , DLabel
+
+  , PathProps                   -- hide in Wumpus.Core export?
+  , LabelProps                  -- hide in Wumpus.Core export?
+  , EllipseProps                -- 
+  , DrawPath(..)                -- hide in Wumpus.Core export?
+  , DrawEllipse(..)
+  , Locale  
+ 
+  -- * Type class
+
+  , PSUnit(..)
+  
+  -- * Extras
+  , mapLocale
+  , extractFrame
+  , repositionProperties
+
+  ) where
+
+import Wumpus.Core.AffineTrans
+import Wumpus.Core.BoundingBox
+import Wumpus.Core.FontSize
+import Wumpus.Core.Geometry
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.PictureLanguage hiding ( hcat, vcat, hsep, vsep )
+import Wumpus.Core.TextEncoding
+import Wumpus.Core.Utils
+
+import Data.Aviary
+
+import Data.AffineSpace
+import Data.Semigroup
+
+import Text.PrettyPrint.Leijen
+
+
+
+-- | Picture is a leaf attributed tree - where atttibutes are 
+-- colour, line-width etc. It is parametric on the unit type 
+-- of points (typically Double).
+-- 
+-- Wumpus\'s Picture, being a leaf attributed tree, is not 
+-- ideally matched to PostScript\'s picture representation, 
+-- which might be considered a node attributed tree if you 
+-- recast graphics state updates as syntactic commands 
+-- encountered during top-down evaluation.
+-- 
+-- Currently this mismatch means that the PostScript code 
+-- generated by Wumpus has significant overuse of PostScript's
+-- @gsave@ and @grestore@.
+--
+-- At some point a tree-rewriting step might be added to 
+-- coalesce some of the repeated graphics state updates.
+--
+-- Apropos the constructors, Picture is a simple non-empty 
+-- leaf-labelled rose tree via 
+-- 
+-- > Single (aka leaf) | Picture (OneList tree)
+--
+-- Where OneList is a variant of the standard list type that 
+-- disallows empty lists.
+-- 
+-- The additional constructors are convenience:
+--
+-- @PickBlank@ has a bounding box but no content and is useful for
+-- some picture language operations (e.g. @hsep@).
+--
+-- @Clip@ nests a picture (tree) inside a clipping path.
+--
+
+
+data Picture u = PicBlank (Locale u)
+               | Single   (Locale u) (Primitive u)
+               | Picture  (Locale u) (OneList (Picture u))
+               | Clip     (Locale u) (Path u)      (Picture u)
+  deriving (Eq,Show) 
+
+type DPicture = Picture Double
+
+
+-- | Wumpus\'s drawings are built from two fundamental 
+-- primitives: paths (line segments and Bezier curves) and 
+-- labels (single lines of text). 
+-- 
+-- Ellipses are a included as a primitive only for optimization 
+-- - drawing a reasonable circle with Bezier curves needs at 
+-- least eight curves. This is inconvenient for drawing dots 
+-- which can otherwise be drawn with a single @arc@ command.
+-- 
+-- Wumpus does not follow PostScript and employ arcs as general 
+-- path primitives - they are used only to draw ellipses. This 
+-- is because arcs do not enjoy the nice properties of Bezier 
+-- curves, whereby the affine transformation of a Bezier curve 
+-- can simply be achieved by the affine transformation of it\'s 
+-- control points.
+--
+-- Ellipses are represented by their center, half-width and 
+-- half-height. Half-width and half-height are used so the 
+-- bounding box can be calculated using only multiplication, and 
+-- thus initially only obliging a Num constraint on the unit.
+-- Though typically for affine transformations a Fractional 
+-- constraint is also obliged.
+--
+
+data Primitive u = PPath    PathProps (Path u)
+                 | PLabel   LabelProps (Label u) 
+                 | PEllipse { 
+                      ellipse_props       :: EllipseProps,
+                      ellipse_center      :: Point2 u,
+                      ellipse_half_width  :: u,
+                      ellipse_half_height :: u 
+                    } 
+  deriving (Eq,Show)
+
+type DPrimitive = Primitive Double
+
+
+
+data Path u = Path (Point2 u) [PathSegment u]
+  deriving (Eq,Show)
+
+type DPath = Path Double
+
+
+data PathSegment u = PCurve  (Point2 u) (Point2 u) (Point2 u)
+                   | PLine   (Point2 u)
+  deriving (Eq,Show)
+
+type DPathSegment = PathSegment Double
+
+data Label u = Label { 
+                   label_bottom_left :: Point2 u,
+                   label_text        :: EncodedText
+                 }
+  deriving (Eq,Show)
+
+type DLabel = Label Double
+
+
+-- | Note when drawn /filled/ and drawn /stroked/ the same 
+-- polygon will have (slightly) different size: 
+-- 
+-- * A filled shape fills /within/ the boundary of the shape
+-- 
+-- * A stroked shape draws a pen line around the boundary 
+--   of the shape. The actual size depends on the thickness
+--   of the line (stroke width).
+--
+data DrawPath = CFill | CStroke [StrokeAttr] | OStroke [StrokeAttr]
+  deriving (Eq,Show)
+
+-- | Ellipses and circles are always closed.
+data DrawEllipse = EFill | EStroke [StrokeAttr]
+  deriving (Eq,Show)
+
+type PathProps    = (PSRgb, DrawPath)
+type LabelProps   = (PSRgb, FontAttr)
+type EllipseProps = (PSRgb, DrawEllipse)
+
+-- | Locale = (current frame x bounding box)
+-- 
+-- Pictures (and sub-pictures) are located within an affine frame.
+-- So pictures can be arranged (vertical and horizontal 
+-- composition) their bounding box is cached.
+--
+-- In Wumpus, affine transformations (scalings, rotations...)
+-- transform the frame rather than the constituent points of 
+-- the primitives. Changes of frame are transmitted to PostScript
+-- as @concat@ commands (and matrix transforms in SVG) - the 
+-- @point-in-world-coordinate@ of a point on a path is never 
+-- calculated.
+--  
+-- So that picture composition is remains stable under affine
+-- transformation, the corners of bounding boxes are transformed
+-- pointwise when the picture is scaled, rotated etc.
+--
+type Locale u = (Frame2 u, BoundingBox u) 
+
+
+--------------------------------------------------------------------------------
+-- Pretty printing
+
+instance (Num u, Pretty u) => Pretty (Picture u) where
+  pretty (PicBlank m)       = text "*BLANK*" <+> ppLocale m
+  pretty (Single m prim)    = ppLocale m <$> indent 2 (pretty prim)
+  pretty (Picture m ones)  = 
+      ppLocale m <$> indent 2 (list $ toListWith pretty ones)
+
+  pretty (Clip m cpath p)   = 
+      text "Clip:" <+> ppLocale m <$> indent 2 (pretty cpath)
+                                   <$> indent 2 (pretty p)
+
+ppLocale :: (Num u, Pretty u) => Locale u -> Doc
+ppLocale (fr,bb) = align (ppfr <$> pretty bb) where
+   ppfr = if standardFrame fr then text "*std-frame*" else pretty fr
+
+
+instance Pretty u => Pretty (Primitive u) where
+  pretty (PPath _ p)        = pretty "path:" <+> pretty p
+  pretty (PLabel _ lbl)     = pretty lbl
+  pretty (PEllipse _ c w h) = pretty "ellipse" <+> pretty c
+                                               <+> text "w:" <> pretty w
+                                               <+> text "h:" <> pretty h
+
+
+instance Pretty u => Pretty (Path u) where
+   pretty (Path pt ps) = pretty pt <> hcat (map pretty ps)
+
+instance Pretty u => Pretty (PathSegment u) where
+  pretty (PCurve p1 p2 p3)    = text ".*" <> pretty p1 <> text ",," <> pretty p2 
+                                          <> text "*." <> pretty p3
+  pretty (PLine pt)           = text "--" <> pretty pt
+
+instance Pretty u => Pretty (Label u) where
+  pretty (Label pt s) = dquotes (pretty s) <> char '@' <> pretty pt
+
+
+--------------------------------------------------------------------------------
+
+-- | Paths are sensibly a Semigroup - there is no notion of 
+-- /empty path/.
+
+instance Semigroup (Path u) where
+  Path st xs `append` Path st' xs' = Path st (xs ++ (PLine st' : xs'))
+
+
+instance Pointwise (Path u) where
+  type Pt (Path u) = Point2 u
+  pointwise f (Path st xs) = Path (f st) (map (pointwise f) xs)
+
+instance Pointwise (PathSegment u) where
+  type Pt (PathSegment u) = Point2 u
+  pointwise f (PLine p)         = PLine (f p)
+  pointwise f (PCurve p1 p2 p3) = PCurve (f p1) (f p2) (f p3)
+  
+
+
+--------------------------------------------------------------------------------
+-- Affine trans instances
+
+type instance DUnit (Picture u) = u
+type instance DUnit (Primitive u) = u
+type instance DUnit (Path u) = u
+
+instance (Floating u, Real u) => Rotate (Picture u) where
+  rotate = rotatePicture 
+
+instance (Floating u, Real u) => RotateAbout (Picture u) where
+  rotateAbout = rotatePictureAbout
+
+instance (Num u, Ord u) => Scale (Picture u) where
+  scale = scalePicture
+
+instance (Num u, Ord u) => Translate (Picture u) where
+  translate = translatePicture
+
+--------------------------------------------------------------------------------
+
+-- Helpers for the affine transformations
+
+rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u
+rotatePicture = bigphi transformPicture rotate rotate
+
+
+rotatePictureAbout :: (Real u, Floating u) 
+                   => Radian -> Point2 u -> Picture u -> Picture u
+rotatePictureAbout ang pt = 
+    transformPicture (rotateAbout ang pt) (rotateAbout ang pt)
+  
+scalePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
+scalePicture x y = transformPicture (scale x y) (scale x y)
+
+translatePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
+translatePicture x y = transformPicture (translate x y) (translate x y)
+
+
+transformPicture :: (Num u, Ord u) 
+                 => (Point2 u -> Point2 u) 
+                 -> (Vec2 u -> Vec2 u) 
+                 -> Picture u 
+                 -> Picture u
+transformPicture fp fv = 
+    mapLocale $ \(frm,bb) -> (transformFrame fp fv frm, transformBBox fp bb)
+
+
+-- Shouldn't transforming the frame be the inverse transformation?
+
+transformFrame :: Num u
+               => (Point2 u -> Point2 u) 
+               -> (Vec2 u -> Vec2 u) 
+               -> Frame2 u 
+               -> Frame2 u
+transformFrame fp fv (Frame2 e0 e1 o) = Frame2 (fv e0) (fv e1) (fp o)
+
+
+-- Bounding boxes need recalculating after a transformation.
+-- For instance after a reflection in the y-axis br becomes bl.
+transformBBox :: (Num u, Ord u)
+              => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u
+transformBBox fp = trace . map fp . corners
+
+
+--------------------------------------------------------------------------------
+
+-- TO DETERMINE
+-- What should leftBound and rightBound be for an empty picture?
+
+type instance PUnit (Picture u) = u
+
+instance (Num u, Ord u) => Horizontal (Picture u) where
+  moveH a    = movePic (hvec a) 
+  leftBound  = leftPlane . boundary
+  rightBound = rightPlane . boundary
+
+instance (Num u, Ord u) => Vertical (Picture u) where
+  moveV a     = movePic (vvec a) 
+  topBound    = upperPlane . boundary
+  bottomBound = lowerPlane . boundary
+
+-- Note - picture is a binary tree and drawing is depth-first,
+-- left-to-right so pictures in the right of the tree potentially
+-- are drawn on top of pictures on the left.
+--
+-- So to print picture a _over_ picture b we form this node:
+--
+-- >  locale 
+-- >    /\
+-- >   /  \
+-- >  b    a
+--
+-- Hence `over` flips b and a
+
+
+instance (Num u, Ord u) => Composite (Picture u) where
+  a `over` b = Picture (ortho zeroPt, bb) (mkList2 b a) where
+               bb = union (boundary a) (boundary b)
+                       
+
+
+
+instance (Num u, Ord u, Horizontal (Picture u), Vertical (Picture u)) => 
+      Move (Picture u) where
+  move x y = movePic (V2 x y)
+
+
+instance Num u => Blank (Picture u) where
+  blank w h = PicBlank (ortho zeroPt, bbox zeroPt (P2 w h))
+
+--------------------------------------------------------------------------------
+-- Boundary
+
+instance (Num u, Ord u) => Boundary (Path u) where
+  boundary (Path st xs) = trace $ st : foldr f [] xs where
+      f (PLine p1)        acc  = p1 : acc
+      f (PCurve p1 p2 p3) acc  = p1 : p2 : p3 : acc 
+
+
+-- Note - this will calculate a very bad bounding box for text.
+-- Descenders will be transgress the boundary and width will be 
+-- very long.
+
+instance (Fractional u, Ord u) => Boundary (Primitive u) where
+  boundary (PPath _ p)                  = boundary p
+  boundary (PLabel (_,a) (Label pt xs)) = textBounds (font_size a) pt char_count
+    where char_count = textLength xs
+  boundary (PEllipse _ c hw hh)         = BBox (c .-^ v) (c .+^ v) 
+    where v = V2 hw hh
+
+
+instance Boundary (Picture u) where
+  boundary (PicBlank (_,bb))     = bb
+  boundary (Single   (_,bb) _)   = bb
+  boundary (Picture  (_,bb) _)   = bb
+  boundary (Clip     (_,bb) _ _) = bb
+
+
+
+
+
+--------------------------------------------------------------------------------
+--
+
+
+mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u
+mapLocale f (PicBlank m)      = PicBlank (f m)
+mapLocale f (Single   m prim) = Single (f m) prim
+mapLocale f (Picture  m ones) = Picture (f m) ones
+mapLocale f (Clip     m x p)  = Clip (f m) x p
+
+
+movePic :: Num u => Vec2 u -> Picture u -> Picture u
+movePic v = mapLocale (moveLocale v) 
+
+  
+moveLocale :: Num u => Vec2 u -> Locale u -> Locale u
+moveLocale v (fr,bb) = (displaceOrigin v fr, pointwise (.+^ v) bb) 
+
+--------------------------------------------------------------------------------
+
+
+-- | Should this really be public?
+extractFrame :: Num u => Picture u -> Frame2 u
+extractFrame (PicBlank (fr,_))     = fr
+extractFrame (Single   (fr,_) _)   = fr
+extractFrame (Picture  (fr,_) _)   = fr
+extractFrame (Clip     (fr,_) _ _) = fr
+
+
+-- This needs is for PostScript and SVG output - it should be 
+-- hidden in the export list of Wumpus.Core
+
+
+-- If a picture has coordinates smaller than (P2 4 4) then it 
+-- needs repositioning before it is drawn to PostSCript or SVG.
+-- 
+-- (P2 4 4) gives a 4 pt margin - maybe it sould be (0,0) or 
+-- user defined.
+--
+repositionProperties :: (Num u, Ord u) => Picture u -> (BoundingBox u, Maybe (Vec2 u))
+repositionProperties = fn . boundary where
+  fn bb@(BBox (P2 llx lly) (P2 urx ury))
+      | llx < 4 || lly < 4  = (BBox ll ur, Just $ V2 x y)
+      | otherwise           = (bb, Nothing)
+    where 
+      x  = 4 - llx
+      y  = 4 - lly
+      ll = P2 (llx+x) (lly+y)
+      ur = P2 (urx+x) (ury+y)  
+
+
diff --git a/src/Wumpus/Core/PictureLanguage.hs b/src/Wumpus/Core/PictureLanguage.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/PictureLanguage.hs
@@ -0,0 +1,317 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.PictureLanguage
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Picture language operations c.f. PPrint and 
+-- Text.PrettyPrint.HughesPJ, but fully in two dimensions 
+-- rather than horizontal + carriage return.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.PictureLanguage 
+  (
+    HAlign(..)
+  , VAlign(..)
+
+  -- * Type family and classes
+  , PUnit 
+  , Horizontal(..)
+  , Vertical(..)
+  , Composite(..)
+  , Move(..)
+  , Blank(..)
+
+  -- * Bounds
+  , center
+  , topleft
+  , topright
+  , bottomleft
+  , bottomright
+
+  -- * Composition
+  , ( ->- )
+  , ( -<- )
+  , ( -//- )
+  , ( -\\- )
+  , at
+  , stackOnto
+  , hcat 
+  , vcat
+  , ( -@- )
+  , stackOntoCenter
+
+  , hspace
+  , vspace
+  , hsep
+  , vsep
+ 
+  -- * Compose with alignment
+  , alignH
+  , alignV
+  , hcatA
+  , vcatA
+  , hsepA
+  , vsepA
+
+  ) where
+
+import Wumpus.Core.Geometry ( Point2(..), Vec2(..) )
+
+import Data.AffineSpace
+
+import Data.List ( foldl' )
+
+
+--------------------------------------------------------------------------------
+-- Data types
+
+-- Alignment
+
+
+data HAlign = HTop | HCenter | HBottom
+  deriving (Eq,Show)
+
+data VAlign = VLeft | VCenter | VRight
+  deriving (Eq,Show)
+
+
+
+
+--------------------------------------------------------------------------------
+-- Type family and classes
+
+
+-- The unit type of /points/ within a Picture.
+type family PUnit a
+
+
+class Horizontal a where
+  moveH      :: PUnit a -> a -> a
+  leftBound  :: a -> PUnit a
+  rightBound :: a -> PUnit a
+
+class Vertical a where
+  moveV       :: PUnit a -> a -> a
+  topBound    :: a -> PUnit a
+  bottomBound :: a -> PUnit a
+
+class Composite a where
+  over    :: a -> a -> a
+  beneath :: a -> a -> a
+
+  beneath = flip over
+  
+-- Move in 2D
+class Move a where
+  move :: PUnit a -> PUnit a -> a -> a
+
+
+class Blank a where
+  blank :: PUnit a -> PUnit a -> a
+
+
+
+--------------------------------------------------------------------------------
+
+-- Operations on bounds
+
+-- | The center of a picture.
+center :: (Horizontal a, Vertical a, Fractional u, u ~ PUnit a) => a -> Point2 u
+center a = P2 hcenter vcenter where  
+    hcenter = leftBound a   + 0.5 * (rightBound a - leftBound a)
+    vcenter = bottomBound a + 0.5 * (topBound a   - bottomBound a)
+
+topleft       :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+topleft a     = P2 (leftBound a)  (topBound a)
+
+topright      :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+topright a    = P2 (rightBound a) (topBound a)
+
+bottomleft    :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+bottomleft a  = P2 (leftBound a)  (bottomBound a)
+
+bottomright   :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+bottomright a = P2 (rightBound a) (bottomBound a)
+
+
+leftmid       :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+leftmid a     = P2 (leftBound a) (midpt (bottomBound a) (topBound a))
+
+rightmid      :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+rightmid a    = P2 (rightBound a) (midpt (bottomBound a) (topBound a))
+
+
+topmid        :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+topmid a      = P2 (midpt (leftBound a) (rightBound a)) (topBound a)
+
+bottommid     :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+bottommid a   = P2 (midpt (leftBound a) (rightBound a)) (bottomBound a)
+
+
+midpt :: Fractional a => a -> a -> a
+midpt a b = a + 0.5*(b-a)
+
+--------------------------------------------------------------------------------
+-- Composition
+
+infixr 5 -//-
+infixr 6 ->-, -@-
+
+
+-- | Center the pic1 on top of pic2.
+(-@-) :: (Horizontal a, Vertical a, Composite a, Move a, Fractional u, 
+             u ~ PUnit a)
+         => a -> a -> a
+p1 -@- p2 = p1 `over` (move x y p2) where V2 x y = center p1 .-. center p2
+
+
+-- | Horizontal composition - place @b@ at the right of @a@.
+(->-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a ->- b = over a (moveH disp b) where disp = rightBound a - leftBound b 
+
+-- | Horizontal composition - place @a@ at the left of @b@.
+(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+(-<-) = flip (->-)   -- TO TEST...
+
+-- | Vertical composition - place @b@ below @a@.
+(-//-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a -//- b = over a (moveV disp b) where disp = bottomBound a - topBound b 
+
+-- | Vertical composition - place @a@ above @b@.
+(-\\-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+(-\\-) = flip (-//-)
+
+
+-- | Place the picture at the supplied point.
+at :: (Move a, u ~ PUnit a) => a -> Point2 u  -> a
+p `at` (P2 x y) = move x y p
+
+
+-- stackOnto :: [a] -> a -> a
+-- This would obviate the need for pempty without needing a 
+-- non-empty list
+
+-- | Stack the pictures using 'over' - the first picture in the 
+-- list is drawn at the top, last picture is on drawn at the 
+-- bottom.
+stackOnto :: (Composite a) => [a] -> a -> a
+stackOnto = flip (foldr over)
+
+hcat :: (Horizontal a, Composite a, Num u, u ~ PUnit a)
+     => a -> [a] -> a
+hcat = foldl' (->-)
+
+vcat :: (Vertical a, Composite a, Num u, u ~ PUnit a)
+     => a -> [a] -> a
+vcat = foldl' (-//-)
+
+
+
+-- | Stack pictures centered ontop of each other - the first 
+-- picture in the list is drawn at the top, last picture is on 
+-- drawn at the bottom.
+stackOntoCenter :: (Horizontal a, Vertical a, Composite a, 
+                Move a, Fractional u,
+                u ~ PUnit a)
+            => [a] -> a -> a
+stackOntoCenter = flip $ foldr (-@-)
+
+
+
+--------------------------------------------------------------------------------
+
+
+blankH  :: (Num u, Blank a, u ~ PUnit a) => u -> a
+blankH = blank `flip` 0
+
+blankV  :: (Num u, Blank a, u ~ PUnit a) => u -> a
+blankV = blank 0
+
+
+
+-- | The following simple definition of hspace is invalid:
+--
+-- > hspace n a b = a ->- (moveH n b)
+-- 
+-- The movement due to @moveH n@ is annulled by the @->-@ 
+-- operator which moves relative to the bounding box.
+-- 
+-- The almost as simple definition below, seems to justify 
+-- including Blank as a Picture constructor.
+--
+hspace :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) 
+       => u -> a -> a -> a
+hspace n a b = a ->- blankH n ->-  b
+
+vspace :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) 
+       => u -> a -> a -> a
+vspace n a b = a -//- blankV n -//-  b
+
+hsep :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) 
+       => u -> a -> [a] -> a
+hsep n = foldl' (hspace n)
+
+vsep :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) 
+       => u -> a -> [a] -> a
+vsep n = foldl' (vspace n)
+
+
+--------------------------------------------------------------------------------
+-- Aligning pictures
+
+
+vecMove :: (Composite a, Move a, u ~ PUnit a) => a -> a -> (Vec2 u) -> a 
+vecMove a b (V2 x y) = a `over` (move x y) b 
+
+alignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
+          , u ~ PUnit a ) 
+       => HAlign -> a -> a -> a
+alignH HTop    p1 p2 = vecMove p1 p2 (topright p1    .-. topleft p2)
+alignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1    .-. leftmid p2)
+alignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft p2)
+
+alignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
+          , u ~ PUnit a ) 
+       => VAlign -> a -> a -> a
+alignV VLeft   p1 p2 = vecMove p1 p2 (bottomleft p1  .-. topleft p2)
+alignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1   .-. topmid p2)
+alignV VRight  p1 p2 = vecMove p1 p2 (bottomright p1 .-. topright p2)
+
+
+hcatA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, u ~ PUnit a)
+     => HAlign -> a -> [a] -> a
+hcatA ha = foldl' (alignH ha)
+
+vcatA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, u ~ PUnit a)
+     => VAlign -> a -> [a] -> a
+vcatA va = foldl' (alignV va)
+
+
+
+hsepA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, Blank a, u ~ PUnit a)
+     => HAlign -> u -> a -> [a] -> a
+hsepA ha n = foldl' op where 
+   a `op` b = alignH ha (alignH ha a (blankH n)) b 
+
+vsepA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, Blank a, u ~ PUnit a)
+     => VAlign -> u -> a -> [a] -> a
+vsepA va n = foldl' op where 
+   a `op` b = alignV va (alignV va a (blankV n)) b 
+
diff --git a/src/Wumpus/Core/PostScript.hs b/src/Wumpus/Core/PostScript.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/PostScript.hs
@@ -0,0 +1,525 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.PostScript
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Wumpus - Writer Monad PostScript 
+--
+-- PostScript is emitted line by line - there is no abstract
+-- syntax tree representing PostScript. So we use a writer 
+-- monad.
+---
+--------------------------------------------------------------------------------
+
+
+module Wumpus.Core.PostScript 
+  (
+  -- * Types
+    PostScript
+  , WumpusM
+
+  , runWumpus
+
+  -- * Deltas 
+  , deltaFontAttr
+  , deltaRgbColour
+
+  , deltaStrokeWidth
+  , deltaMiterLimit
+  , deltaLineCap
+  , deltaLineJoin
+  , deltaDashPattern
+ 
+  -- * Emit PostScript 
+  , ps_comment
+  
+  , ps_gsave
+  , ps_grestore
+  , ps_setlinewidth
+  , ps_setlinecap
+  , ps_setlinejoin
+  , ps_setmiterlimit
+  , ps_setdash
+  , ps_setgray
+  , ps_setrgbcolor
+  , ps_sethsbcolor
+  , ps_translate
+  , ps_scale
+  , ps_concat
+  , ps_newpath
+  , ps_moveto
+  , ps_rmoveto
+  , ps_lineto
+  , ps_rlineto
+  , ps_arc
+  , ps_arcn
+  , ps_curveto
+  , ps_closepath
+  , ps_clip
+  , ps_fill
+  , ps_stroke
+  , ps_showpage
+  , ps_findfont
+  , ps_scalefont
+  , ps_setfont
+  , ps_show
+  , ps_glyphshow
+  , bang_PS
+  , bang_EPS
+  , dsc_comment
+  , dsc_BoundingBox
+  , dsc_CreationDate
+  , dsc_Pages
+  , dsc_Page
+  , dsc_EndComments
+  , dsc_EOF
+
+  ) where
+
+import Wumpus.Core.Colour
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.TextEncoding
+import Wumpus.Core.Utils ( PSUnit(..), roundup, parens, hsep )
+
+import Data.Aviary
+
+import qualified Data.DList as DL
+import MonadLib
+
+import Data.List ( foldl' )
+
+
+-- Graphics state for PostScript Rendering
+--
+-- Values with no default value (e.g. font) in the graphics 
+-- state of the PostScript interpreter (not Wumpus\'s renderer) 
+-- are Maybes.
+-- 
+-- The graphics state is considered successive - all elements 
+-- have a colour and all text labels have a font. So during 
+-- processing there are two situations: 
+
+-- (1) If font or colour is the same as the last no state
+-- change needs to be printed.
+--
+-- (2) If the font or colour changes the update needs to be 
+-- printed, but as the next element always has a colour (and a
+-- font if it is a label), no @undo@ needs to be printed.
+--
+-- This contrasts with the behaviour for stroke attributes
+-- which needs @undo@.
+
+data PostScriptGS = PostScriptGS { 
+        gs_font         :: Maybe FontAttr,
+        gs_rgb_colour   :: DRGB
+      }
+  deriving (Eq,Show)
+
+
+
+-- | Stroke properties do not have to be fully specified in 
+-- Wumpus\'s picture types - i.e. a Path might have it\'s stroke 
+-- width set but nothing else.
+--
+-- If a path changes any of the stroke properties, it 
+-- immediately undoes the changes after drawing, returning the 
+-- the stroke values to their PostScript defaults.
+--
+-- This means Wumpus doesn't have to carry a nested environment 
+-- around as it renders to PostScript. As stroke properties can
+-- only be assigned to leaves in the picture tree, a nested 
+-- environment wouldn\'t really be an ideal fit anyway.
+
+
+gs_stroke_width :: Double
+gs_stroke_width = 1.0
+
+gs_miter_limit  :: Double
+gs_miter_limit  = 10.0
+
+gs_line_cap     :: LineCap
+gs_line_cap     = CapSquare
+
+gs_line_join    :: LineJoin
+gs_line_join    = JoinMiter
+
+gs_dash_pattern :: DashPattern
+gs_dash_pattern = Solid
+
+
+
+type PostScript = String
+
+type PsOutput = DL.DList Char
+
+type WumpusM a = PsT Id a
+
+
+newtype PsT m a = PsT { 
+    unPsT :: StateT PostScriptGS 
+                    (WriterT PsOutput (ReaderT TextEncoder m)) a }
+
+gs_init :: PostScriptGS 
+gs_init = PostScriptGS { gs_font           = Nothing
+                       , gs_rgb_colour     = black 
+                       }
+           
+            
+runPsT :: Monad m 
+       => TextEncoder -> PsT m a -> m ((a,PostScriptGS),PsOutput)
+runPsT i m = runReaderT i $ runWriterT $ runStateT gs_init $ unPsT m
+
+instance Monad m => Functor (PsT m) where
+  fmap f (PsT mf) = PsT $ fmap f mf 
+
+instance Monad m => Monad (PsT m) where
+  return a  = PsT $ return a
+  ma >>= f  = PsT $ unPsT ma >>= unPsT . f
+
+instance Monad m => WriterM (PsT m) PsOutput where
+  put = PsT . put
+
+instance Monad m => ReaderM (PsT m) TextEncoder where
+  ask = PsT $ ask
+
+instance Monad m => StateM (PsT m) PostScriptGS where
+  set = PsT . set
+  get = PsT $ get
+
+instance MonadT PsT where
+  lift = PsT . lift . lift . lift
+
+
+pstId :: TextEncoder -> PsT Id a -> ((a,PostScriptGS),PsOutput)
+pstId = runId `oo` runPsT
+
+-- | Drop state and result, take the Writer trace.
+runWumpus :: TextEncoder -> WumpusM a -> String
+runWumpus = (DL.toList . snd) `oo` pstId
+
+--------------------------------------------------------------------------------
+-- "Deltas" of the graphics state
+
+deltaFontAttr :: FontAttr -> WumpusM (Maybe FontAttr)
+deltaFontAttr new = get >>= maybe update diff . gs_font
+  where
+    update :: WumpusM (Maybe FontAttr)
+    update = sets_ (\s -> s { gs_font = Just new }) >> return (Just new)
+    
+    diff :: FontAttr -> WumpusM (Maybe FontAttr)
+    diff old | old == new = return Nothing
+             | otherwise  = update
+
+
+deltaRgbColour :: DRGB -> WumpusM (Maybe DRGB)
+deltaRgbColour new = get >>= diff . gs_rgb_colour
+  where
+    diff :: DRGB -> WumpusM (Maybe DRGB)
+    diff old | old == new = return Nothing
+             | otherwise  = do { sets_ (\s -> s { gs_rgb_colour = new })
+                               ; return (Just new)
+                               }
+
+
+deltaStrokeWidth :: Double -> Maybe (Double,Double)
+deltaStrokeWidth n
+    | n == gs_stroke_width = Nothing
+    | otherwise            = Just (n,gs_stroke_width)
+
+deltaMiterLimit :: Double -> Maybe (Double,Double)
+deltaMiterLimit n 
+    | n == gs_miter_limit  = Nothing
+    | otherwise            = Just (n,gs_miter_limit)
+
+
+deltaLineCap :: LineCap -> Maybe (LineCap,LineCap)
+deltaLineCap lc
+    | lc == gs_line_cap    = Nothing
+    | otherwise            = Just (lc,gs_line_cap)
+
+deltaLineJoin :: LineJoin -> Maybe (LineJoin,LineJoin)
+deltaLineJoin lj 
+    | lj == gs_line_join   = Nothing
+    | otherwise            = Just (lj,gs_line_join)
+
+deltaDashPattern :: DashPattern -> Maybe (DashPattern,DashPattern)
+deltaDashPattern p 
+    | p == gs_dash_pattern = Nothing
+    | otherwise            = Just (p,gs_dash_pattern)
+
+
+
+--------------------------------------------------------------------------------
+-- writer monad helpers
+
+tell :: WriterM m i => i -> m ()
+tell s = puts ((),s)
+
+writeChar :: WriterM m PsOutput => Char -> m ()
+writeChar = tell . DL.singleton 
+
+
+write :: WriterM m PsOutput => String -> m ()
+write = tell . DL.fromList 
+
+
+writeln :: WriterM m PsOutput => String -> m ()
+writeln s = write s >> writeChar '\n'
+
+
+writeArg :: WriterM m PsOutput => String -> m () 
+writeArg s = write s >> writeChar ' '
+
+
+
+
+type Command = String
+
+command :: Command -> [String] -> WumpusM ()
+command cmd xs = mapM_ writeArg xs >> writeln cmd
+
+
+
+showArray :: (a -> ShowS) -> [a] -> String
+showArray _ []     = "[ ]"
+showArray f (x:xs) = sfun "]" 
+  where 
+    sfun = foldl' (\a e -> a . (' ':) . f e) (('[':) . f x) xs
+                              
+
+
+-- | @ %% ... @
+ps_comment :: String -> WumpusM ()
+ps_comment s = write "%% " >> writeln s
+
+--------------------------------------------------------------------------------
+-- graphics state operators
+
+-- | @ gsave @
+ps_gsave :: WumpusM ()
+ps_gsave = command "gsave" []
+
+-- | @ grestore @
+ps_grestore :: WumpusM () 
+ps_grestore = command "grestore" []
+
+-- | @ ... setlinewidth @
+ps_setlinewidth :: PSUnit u => u -> WumpusM ()
+ps_setlinewidth = command "setlinewidth" . return . dtrunc
+
+-- | @ ... setlinecap @
+ps_setlinecap :: LineCap -> WumpusM ()
+ps_setlinecap = command "setlinecap" . return . show . fromEnum
+
+-- | @ ... setlinejoin @
+ps_setlinejoin :: LineJoin -> WumpusM ()
+ps_setlinejoin = command "setlinejoin" . return . show . fromEnum
+
+-- | @ ... setmiterlimit @
+ps_setmiterlimit :: PSUnit u => u -> WumpusM ()
+ps_setmiterlimit = command "setmiterlimit" . return . dtrunc
+
+-- | @ [... ...] ... setdash @
+ps_setdash :: DashPattern -> WumpusM ()
+ps_setdash Solid        = command "setdash" ["[]", "0"]
+ps_setdash (Dash n arr) = command "setdash" [showArray shows arr, show n]
+
+-- | @ ... setgray @
+ps_setgray :: PSUnit u => u -> WumpusM ()
+ps_setgray = command "setgray" . return . dtrunc 
+
+-- | @ ... ... ... setrgbcolor @
+ps_setrgbcolor :: PSUnit u => u -> u -> u -> WumpusM ()
+ps_setrgbcolor r g b = command "setrgbcolor" $ map dtrunc [r,g,b]
+
+-- | @ ... ... ... sethsbcolor @
+ps_sethsbcolor :: PSUnit u => u -> u -> u -> WumpusM ()
+ps_sethsbcolor h s b = command "sethsbcolor" $ map dtrunc [h,s,b]
+
+
+--------------------------------------------------------------------------------
+-- coordinate system and matrix operators 
+
+-- | @ ... ... translate @
+ps_translate :: PSUnit u => u -> u -> WumpusM ()
+ps_translate tx ty = do
+    command "translate" $ map dtrunc [tx,ty]
+
+-- | @ ... ... scale @
+ps_scale :: PSUnit u => u -> u -> WumpusM ()
+ps_scale tx ty = do
+    command "scale" $ map dtrunc [tx,ty]
+
+
+-- Do not use setmatrix for changing the CTM use concat...
+
+-- | @ [... ... ... ... ... ...] concat @
+ps_concat :: PSUnit u => CTM u -> WumpusM ()
+ps_concat (CTM a b  c d  e f) = command "concat" [mat] where 
+    mat = showArray ((++) . dtrunc) [a,b,c,d,e,f]
+
+
+--------------------------------------------------------------------------------
+-- Path construction operators
+
+-- | @ newpath @
+ps_newpath :: WumpusM ()
+ps_newpath = command "newpath" []
+
+
+-- Note - it is preferable to show doubles as 0.0 rather than 0.
+-- In PostScript the coercion from int to float is apparently 
+-- quite expensive.
+
+-- | @ ... ... moveto @
+ps_moveto :: PSUnit u => u -> u -> WumpusM ()
+ps_moveto x y = command "moveto" [dtrunc x, dtrunc y]
+
+-- | @ ... ... rmoveto @
+ps_rmoveto :: PSUnit u => u -> u -> WumpusM ()
+ps_rmoveto x y = command "rmoveto" [dtrunc x, dtrunc y]
+
+-- | @ ... ... lineto @
+ps_lineto :: PSUnit u => u -> u -> WumpusM ()
+ps_lineto x y = command "lineto" [dtrunc x, dtrunc y]
+
+-- | @ ... ... rlineto @
+ps_rlineto :: PSUnit u => u -> u -> WumpusM ()
+ps_rlineto x y = command "rlineto" [dtrunc x, dtrunc y]
+
+-- | @ ... ... ... ... ... arc @
+ps_arc :: PSUnit u => u -> u -> u -> u -> u -> WumpusM ()
+ps_arc x y r ang1 ang2 = 
+    command "arc" $ map dtrunc [x,y,r,ang1,ang2]
+
+-- | @ ... ... ... ... ... arcn @
+ps_arcn :: PSUnit u => u -> u -> u -> u -> u -> WumpusM ()
+ps_arcn x y r ang1 ang2 = 
+    command "arcn" $ map dtrunc [x,y,r,ang1,ang2]
+
+-- | @ ... ... ... ... ... ... curveto @
+ps_curveto :: PSUnit u => u -> u -> u -> u -> u -> u -> WumpusM ()
+ps_curveto x1 y1 x2 y2 x3 y3 = 
+    command "curveto" $ map dtrunc [x1,y1, x2,y2, x3,y3]
+
+-- | @ closepath @
+ps_closepath :: WumpusM ()
+ps_closepath = command "closepath" []
+
+-- | @ clip @
+ps_clip :: WumpusM ()
+ps_clip = command "clip" []
+
+--------------------------------------------------------------------------------
+--  painting operators
+
+-- | @ fill @
+ps_fill :: WumpusM ()
+ps_fill = command "fill" []
+
+-- | @ stroke @
+ps_stroke :: WumpusM ()
+ps_stroke = command "stroke" []
+
+
+--------------------------------------------------------------------------------
+-- Output operators
+
+-- | @ showpage @
+ps_showpage :: WumpusM ()
+ps_showpage = command "showpage" []
+
+
+
+--------------------------------------------------------------------------------
+-- Character and font operators
+
+-- | The following fonts are expected to exist on most platforms:
+--
+-- > Times-Roman  Times-Italic  Times-Bold  Times-BoldItalic
+-- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique
+-- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique
+-- > Symbol
+--
+-- List from Bill Casselman \'Mathematical Illustrations\' p279.
+
+-- | @ /... findfont @
+ps_findfont :: String -> WumpusM () 
+ps_findfont = command "findfont" . return . ('/' :)
+
+-- | @ ... scalefont @
+ps_scalefont :: Int -> WumpusM ()
+ps_scalefont = command "scalefont" . return . show
+
+-- | @ setfont @
+ps_setfont :: WumpusM ()
+ps_setfont = command "setfont" []
+
+-- | @ (...) show  @
+ps_show :: String -> WumpusM ()
+ps_show = command "show" . return . parens
+
+-- | @ (...) show  @
+ps_glyphshow :: String -> WumpusM ()
+ps_glyphshow = command "glyphshow" . return . ('/':)
+
+
+--------------------------------------------------------------------------------
+-- document structuring conventions
+
+-- | @ %!PS-Adobe-3.0 @
+bang_PS :: WumpusM ()
+bang_PS = writeln "%!PS-Adobe-3.0"
+
+-- | @ %!PS-Adobe-3.0 EPSF-3.0 @
+bang_EPS :: WumpusM ()
+bang_EPS = writeln "%!PS-Adobe-3.0 EPSF-3.0"
+
+-- | @ %%...: ... @
+dsc_comment :: String -> [String] -> WumpusM ()
+dsc_comment name [] = write "%%" >> writeln name
+dsc_comment name xs = write "%%" >> write name >> write ": " >> writeln (hsep xs)
+
+
+-- | @ %%BoundingBox: ... ... ... ... @  /llx lly urx ury/
+dsc_BoundingBox :: PSUnit u => u -> u -> u -> u -> WumpusM ()
+dsc_BoundingBox llx lly urx ury = 
+  dsc_comment "BoundingBox"  (map (roundup . toDouble) [llx,lly,urx,ury])
+
+-- | @ %%CreationDate: ... @
+-- 
+-- The creation date is informational and never interpreted, 
+-- thus the format is entirely arbitrary.
+dsc_CreationDate :: String -> WumpusM ()
+dsc_CreationDate = dsc_comment "CreationDate" . return
+
+-- | @ %%Pages: ... @
+dsc_Pages :: Int -> WumpusM ()
+dsc_Pages = dsc_comment "Pages" . return . show
+
+
+-- | @ %%Page: ... ... @
+dsc_Page :: String -> Int -> WumpusM ()
+dsc_Page label ordinal = 
+    dsc_comment "Page" [label, show ordinal]
+
+
+-- | @ %%EndComments @
+dsc_EndComments :: WumpusM ()
+dsc_EndComments = dsc_comment "EndComments" []
+
+-- | @ %%EOF @
+dsc_EOF :: WumpusM ()
+dsc_EOF = dsc_comment "EOF" []
+
diff --git a/src/Wumpus/Core/SVG.hs b/src/Wumpus/Core/SVG.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/SVG.hs
@@ -0,0 +1,434 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.SVG
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- SVG is represented using XML.Light. XML.Light is a simple,
+-- generic XML representation (almost) everything is an element 
+-- with attributes.
+--
+-- SVG output is monadic to handle clipping paths and 
+-- configurable text encoding via a Reader monad. 
+--
+-- SVG does not achieve clipping by changing the graphics state 
+-- (being /declarative/ SVG doesn\'t have a graphics state as 
+-- such). Instead a clipping path has an id, subsequent elements 
+-- that are bound by the clipping path are tagged with a 
+-- @clip-path@ attribute that references the clipping path id: 
+--
+-- > clip-path=\"url(#clip1)\"
+-- 
+-- 
+-- The operations to build XML elements (e.g. element_path) don\'t 
+-- take more parameters than necessary, and are expected to be 
+-- augmented with attributes using 'add_attr' and 'add_attrs' from 
+-- the XML.Light library.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.SVG 
+  (
+  -- * SVG Monad 
+    SvgM
+  , runSVG
+  , newClipLabel
+  , currentClipLabel   
+
+
+  -- * Build SVG
+  , SvgPath
+
+  , unqualAttr
+  , xmlVersion
+  , svgDocType
+  , gElement
+  , svgElement
+  
+  , element_circle
+  , element_ellipse
+  , attr_x
+  , attr_y
+  , attr_r
+  , attr_rx
+  , attr_ry
+  , attr_cx
+  , attr_cy
+  , element_path
+  , element_clippath
+  , element_text
+  , element_tspan
+  , content_text
+  , attr_font_family
+  , attr_font_size
+  , attr_font_weight
+  , attr_font_style
+  , attr_id
+  , attr_fill
+  , attr_fill_none
+  , attr_stroke
+  , attr_stroke_none
+  , attr_stroke_width
+  , attr_stroke_miterlimit
+  , attr_stroke_linecap
+  , attr_stroke_linejoin
+
+  , attr_stroke_dasharray
+  , attr_stroke_dasharray_none
+  , attr_stroke_dashoffset
+
+  , attr_color
+  , attr_clippath
+  , attr_transform
+  , val_matrix
+  , val_colour
+  , val_rgb
+  , val_url
+  , val_translate
+  , path_m
+  , path_l
+  , path_s
+
+
+  ) where
+
+import Wumpus.Core.Colour
+import Wumpus.Core.GraphicsState
+import Wumpus.Core.TextEncoding
+import Wumpus.Core.Utils
+
+import Data.Aviary
+
+import MonadLib hiding ( version )
+import Text.XML.Light
+
+
+data SvgState = SvgSt { clipCount :: Int }
+
+-- | The SVG monad - which wraps a state monad to generate 
+-- fresh names.
+type SvgM a = SvgT Id a
+
+newtype SvgT m a = SvgT { unSvgT :: StateT SvgState (ReaderT TextEncoder m) a }
+
+runSvgT :: Monad m => TextEncoder -> SvgT m a -> m (a,SvgState)
+runSvgT i m = runReaderT i $ runStateT st0 $ unSvgT m where
+    st0 = SvgSt { clipCount = 0 } 
+
+instance Monad m => Functor (SvgT m) where
+  fmap f (SvgT mf) = SvgT $ fmap f mf 
+
+instance Monad m => Monad (SvgT m) where
+  return a  = SvgT $ return a
+  ma >>= f  = SvgT $ unSvgT ma >>= unSvgT . f
+
+instance Monad m => StateM (SvgT m) SvgState where
+  get = SvgT $ get
+  set = SvgT . set
+
+instance Monad m => ReaderM (SvgT m) TextEncoder where
+  ask = SvgT $ ask
+
+instance MonadT SvgT where
+  lift = SvgT . lift . lift
+
+
+svgId :: TextEncoder -> SvgT Id a -> (a,SvgState)
+svgId = runId `oo` runSvgT  
+
+-- | Run the SVG monad.
+runSVG :: TextEncoder -> SvgM a -> a
+runSVG = fst `oo` svgId
+
+
+-- | Get the current clip label.
+currentClipLabel :: SvgM String
+currentClipLabel = get >>= return . clipname . clipCount
+
+-- | Generate a new clip label.
+newClipLabel :: SvgM String
+newClipLabel = do 
+  i <- (get >>= return . clipCount)
+  sets_ (\s -> s { clipCount=i+1 })
+  return $ clipname i
+
+
+clipname :: Int -> String
+clipname = ("clip" ++) . show
+
+
+--------------------------------------------------------------------------------
+-- Helpers for XML.Light and /data in strings/.
+
+-- | Helper for XML.Light
+unqualAttr :: String -> String -> Attr
+unqualAttr name val = Attr (unqual name) val
+
+
+--------------------------------------------------------------------------------
+-- SVG helpers
+
+type SvgPath = [String]
+
+
+-- | @ \<?xml version=\"1.0\" encoding=\"...\"?\> @
+--
+xmlVersion :: String -> CData
+xmlVersion s = CData CDataRaw 
+                     ("<?xml version=\"1.0\" encoding=\"" ++ s ++ "\"?>")
+                     (Just 1)
+
+-- |
+-- > <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"           
+-- >     "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" > 
+--
+svgDocType :: CData
+svgDocType = CData CDataRaw (line1 ++ "\n" ++ line2) (Just 1)
+  where
+    line1 = "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\""
+    line2 = "  \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">"
+
+-- | 
+-- > <g> ... </g>
+--
+-- Wumpus uses the g element (group) to achieve nesting. 
+gElement :: [Attr] -> [Element] -> Element
+gElement xs ys = unode "g" (xs,ys)
+
+-- |
+-- > <svg xmlns="http://www.w3.org/2000/svg" version="1.1">
+-- > ...
+-- > </svg>
+--
+svgElement :: [Element] -> Element
+svgElement xs = unode "svg" ([xmlns,version],xs)
+  where
+    xmlns   = unqualAttr "xmlns" "http://www.w3.org/2000/svg"
+    version = unqualAttr "version" "1.1"  
+
+
+--------------------------------------------------------------------------------
+
+
+
+-- |
+-- > <circle/>
+--
+element_circle :: Element
+element_circle = unode "circle" ()
+
+-- |
+-- > <ellipse/>
+--
+element_ellipse :: Element
+element_ellipse = unode "ellipse" ()
+
+
+
+-- | @ x=\"...\" @
+attr_x :: PSUnit u => u -> Attr
+attr_x = unqualAttr "x" . dtrunc
+
+-- | @ y=\"...\" @
+attr_y :: PSUnit u => u -> Attr
+attr_y = unqualAttr "y" . dtrunc
+
+-- | @ r=\"...\" @
+attr_r :: PSUnit u => u -> Attr
+attr_r = unqualAttr "r" . dtrunc
+
+
+-- | @ rx=\"...\" @
+attr_rx :: PSUnit u => u -> Attr
+attr_rx = unqualAttr "rx" . dtrunc
+
+-- | @ ry=\"...\" @
+attr_ry :: PSUnit u => u -> Attr
+attr_ry = unqualAttr "ry" . dtrunc
+
+-- | @ cx=\"...\" @
+attr_cx :: PSUnit u => u -> Attr
+attr_cx = unqualAttr "cx" . dtrunc
+
+-- | @ cy=\"...\" @
+attr_cy :: PSUnit u => u -> Attr
+attr_cy = unqualAttr "cy" . dtrunc
+
+
+
+
+-- |
+-- > <path d="..." />
+--
+-- Note the argument to this function is an attribute rather
+-- than content. We have no use for empty paths.
+element_path :: SvgPath -> Element
+element_path = unode "path" . attr_d
+
+-- |
+-- > <clipPath>
+-- > ...
+-- > </clipPath>
+--
+element_clippath :: SvgPath -> Element
+element_clippath = unode "clipPath" . element_path
+
+-- |
+-- > <text>...</text>
+--
+element_text :: Node t => t -> Element
+element_text = unode "text" 
+
+-- |
+-- > <text>...</text>
+--
+element_tspan :: String -> Element
+element_tspan = unode "tspan" . content_text
+
+
+-- | Render the string as 'CDataText' - see XML.Light.
+content_text :: String -> Content
+content_text str = Text $ CData CDataRaw str Nothing
+
+
+-- | @ font-family=\"...\" @
+attr_font_family :: String -> Attr
+attr_font_family = unqualAttr "font-family" 
+
+-- | @ font-size=\"...\" @
+attr_font_size :: Int -> Attr
+attr_font_size = unqualAttr "font-size" . show
+
+-- | @ font-weight=\"...\" @
+attr_font_weight :: String -> Attr
+attr_font_weight = unqualAttr "font-weight"
+
+-- | @ font-style=\"...\" @
+attr_font_style :: String -> Attr
+attr_font_style = unqualAttr "font-style"
+
+
+-- | @ id=\"...\" @
+attr_id :: String -> Attr
+attr_id = unqualAttr "id" 
+
+-- | @ d="..." @
+attr_d :: SvgPath -> Attr
+attr_d = unqualAttr "d" . hsep
+
+-- | @ fill=\"rgb(..., ..., ...)\" @
+attr_fill :: PSColour c => c -> Attr
+attr_fill = unqualAttr "fill" . val_colour
+
+-- | @ fill=\"none\" @
+attr_fill_none :: Attr
+attr_fill_none = unqualAttr "fill" "none"
+
+-- | @ stroke=\"rgb(..., ..., ...)\" @
+attr_stroke :: PSColour c => c -> Attr
+attr_stroke = unqualAttr "stroke" . val_colour
+
+-- | @ stroke=\"none\" @
+attr_stroke_none :: Attr
+attr_stroke_none = unqualAttr "stroke" "none"
+
+-- | @ stroke-width=\"...\" @
+attr_stroke_width :: PSUnit u => u -> Attr
+attr_stroke_width = unqualAttr "stoke-width" . dtrunc
+
+
+-- | @ stroke-miterlimit=\"...\" @
+attr_stroke_miterlimit :: PSUnit u => u -> Attr
+attr_stroke_miterlimit = unqualAttr "stoke-miterlimit" . dtrunc
+
+-- | @ stroke-linejoin=\"...\" @
+attr_stroke_linejoin :: LineJoin -> Attr
+attr_stroke_linejoin JoinMiter = unqualAttr "stroke-linejoin" "miter"
+attr_stroke_linejoin JoinRound = unqualAttr "stroke-linejoin" "round"
+attr_stroke_linejoin JoinBevel = unqualAttr "stroke-linejoin" "bevel"
+
+
+
+attr_stroke_linecap :: LineCap -> Attr
+attr_stroke_linecap CapButt   = unqualAttr "stroke-linecap" "butt"
+attr_stroke_linecap CapRound  = unqualAttr "stroke-linecap" "round"
+attr_stroke_linecap CapSquare = unqualAttr "stroke-linecap" "square"
+
+
+-- | @ stroke-dasharray=\"...\" @
+attr_stroke_dasharray :: [Int] -> Attr
+attr_stroke_dasharray = unqualAttr "stroke-dasharray" . commasep . map show
+
+-- | @ stroke-dasharray=\"none\" @
+attr_stroke_dasharray_none :: Attr
+attr_stroke_dasharray_none = unqualAttr "stroke-dasharray" "none"
+
+-- | @ stroke-dashoffset=\"...\" @
+attr_stroke_dashoffset :: Int -> Attr
+attr_stroke_dashoffset = unqualAttr "stroke-dashoffset" . show
+
+-- | @ color=\"rgb(..., ..., ...)\" @
+--
+-- Gray or HSB values will be converted to and rendered as RGB.
+attr_color :: PSColour c => c -> Attr
+attr_color = unqualAttr "color" . val_colour
+
+-- | @ clip-path=\"url(#...)\" @
+attr_clippath :: String -> Attr
+attr_clippath = unqualAttr "clip-path" . val_url
+
+-- | @ transform="..." @
+attr_transform :: String -> Attr
+attr_transform = unqualAttr "transform"
+
+-- | @ matrix(..., ..., ..., ..., ..., ...) @
+val_matrix :: PSUnit u => u -> u -> u -> u -> u -> u -> String
+val_matrix a b c d e f = "matrix" ++ tupled (map dtrunc [a,b,c,d,e,f])
+
+
+
+-- | @ rgb(..., ..., ...) @
+-- 
+-- HSB and gray scale are translated to RGB values.
+val_colour :: PSColour c => c -> String
+val_colour = val_rgb . psColour
+
+
+-- | @ rgb(..., ..., ...) @
+val_rgb :: RGB3 Double -> String
+val_rgb (RGB3 r g b) = "rgb" ++ show (ramp255 r,ramp255 g,ramp255 b)
+
+
+-- | @ url(#...) @
+val_url :: String -> String
+val_url s = "url" ++ parens ('#':s)
+
+-- | @ translate(..., ...) @
+val_translate :: PSUnit u => u -> u -> String
+val_translate x y = "translate" ++ tupled (map dtrunc [x,y])
+  
+-- | @ M ... ... @
+--
+-- c.f. PostScript's @moveto@.
+path_m :: PSUnit u => u -> u -> String
+path_m x y  = hsep $ "M" : map dtrunc [x,y]
+
+-- | @ L ... ... @
+--
+-- c.f. PostScript's @lineto@.
+path_l :: PSUnit u => u -> u -> String
+path_l x y  = hsep $ "L" : map dtrunc [x,y]
+
+-- | @ S ... ... ... ... ... ... @
+-- 
+-- c.f. PostScript's @curveto@.
+path_s :: PSUnit u => u -> u -> u -> u -> u -> u -> String
+path_s x1 y1 x2 y2 x3 y3 =  hsep $ "S" : map dtrunc [x1,y1,x2,y2,x3,y3]
+
+
diff --git a/src/Wumpus/Core/TextEncoding.hs b/src/Wumpus/Core/TextEncoding.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/TextEncoding.hs
@@ -0,0 +1,119 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.TextEncoding
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Extended character handling...
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.TextEncoding
+  ( 
+    GlyphName
+  , CharCode
+  , PostScriptLookup
+  , SVGLookup
+  , TextEncoder(..)
+
+  , EncodedText(..)    
+  , TextChunk(..)
+
+  , textLength
+  , lookupByCharCode  
+  , lookupByGlyphName
+
+  , lexLabel
+
+  ) where
+
+import Text.PrettyPrint.Leijen hiding ( SText )
+
+import Data.Char
+
+type GlyphName = String
+type CharCode  = Int 
+
+type PostScriptLookup = CharCode -> Maybe GlyphName
+type SVGLookup        = GlyphName -> Maybe CharCode
+
+data TextEncoder = TextEncoder  {
+                       ps_lookup         :: PostScriptLookup,
+                       svg_lookup        :: SVGLookup,
+                       svg_encoding_name :: String,
+                       ps_fallback       :: GlyphName,
+                       svg_fallback      :: CharCode
+                     }
+                     
+
+
+newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] }
+  deriving (Eq,Show)
+
+
+data TextChunk = SText  String
+               | EscInt Int
+               | EscStr GlyphName
+  deriving (Eq,Show)
+
+
+--------------------------------------------------------------------------------
+
+instance Pretty EncodedText where
+  pretty = hcat . map pretty . getEncodedText
+
+instance Pretty TextChunk where
+  pretty (SText s)   = string s
+  pretty (EscInt i)  = text "&#" <> int i  <> semi
+  pretty (EscStr s)  = text "&#" <> text s <> semi
+
+--------------------------------------------------------------------------------
+
+textLength :: EncodedText -> Int
+textLength = foldr add 0 . getEncodedText where 
+    add (SText s) n = n + length s
+    add _         n = n + 1
+
+
+lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName
+lookupByCharCode i enc = (ps_lookup enc) i
+
+lookupByGlyphName :: GlyphName -> TextEncoder -> Maybe CharCode
+lookupByGlyphName i enc = (svg_lookup enc) i
+
+
+-- | Output to PostScript as @ /egrave glyphshow @
+
+-- Output to SVG as an escaped decimal, e.g. @ &#232; @
+--
+-- Note, HTML entity names do not seem to be supported in SVG,
+-- @ &egrave; @ does not work in FireFox or Chrome.
+
+
+lexLabel :: String -> EncodedText
+lexLabel = EncodedText . lexer
+
+lexer :: String -> [TextChunk]
+lexer []            = []
+
+lexer ('&':'#':xs)  = esc xs
+  where
+    esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs 
+                             in  intval (c:s) cs'
+               | otherwise = let (s,cs') = span isAlpha cs 
+                             in EscStr (c:s) : optsemi cs'
+    esc []                 = []
+
+    optsemi (';':cs)   = lexer cs      -- let ill-formed go through
+    optsemi cs         = lexer cs
+
+    intval [] rest  = optsemi rest
+    intval cs rest  = EscInt (read cs) : optsemi rest
+
+lexer (x:xs)        = let (s,xs') = span (/= '&') xs 
+                      in SText (x:s) : lexer xs'
diff --git a/src/Wumpus/Core/TextLatin1.hs b/src/Wumpus/Core/TextLatin1.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/TextLatin1.hs
@@ -0,0 +1,250 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.TextLatin1
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  experimental
+-- Portability :  GHC only
+--
+-- Extended character handling...
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Core.TextLatin1
+  ( 
+    Latin1Name
+  , Latin1ISOCode
+  
+  , latin1Encoder
+
+  , latin1All
+
+  ) where
+
+import Wumpus.Core.TextEncoding
+
+import qualified Data.Map as Map
+
+type Latin1Name = String
+type Latin1ISOCode = Int
+
+latin1Encoder :: TextEncoder
+latin1Encoder = TextEncoder {
+    ps_lookup         = Map.lookup `flip` codeToName,
+    svg_lookup        = Map.lookup `flip` nameToCode,
+    svg_encoding_name = "ISO-8859-1",
+    ps_fallback       = "space",
+    svg_fallback      = 0o040
+  }
+nameToCode :: Map.Map String Int
+nameToCode = Map.fromList latin1All
+
+codeToName :: Map.Map Int String
+codeToName = foldr fn Map.empty latin1All where
+  fn (s,i) a = Map.insert i s a 
+
+latin1All :: [(Latin1Name, Latin1ISOCode)]
+latin1All = [ ("A",                     0o101)
+            , ("AE",                    0o306)
+            , ("Aacute",                0o301)
+            , ("Acircumflex",           0o302)
+            , ("Adieresis",             0o304)
+            , ("Agrave",                0o300)
+            , ("Aring",                 0o305)
+            , ("Atilde",                0o303)
+            , ("B",                     0o102)
+            , ("C",                     0o103)
+            , ("Ccedilla",              0o307)
+            , ("D",                     0o104)
+            , ("E",                     0o105)
+            , ("Eacute",                0o311)
+            , ("Ecircumflex",           0o312)
+            , ("Edieresis",             0o313)
+            , ("Egrave",                0o310)
+            , ("Eth",                   0o320)
+            , ("F",                     0o106)
+            , ("G",                     0o107)
+            , ("H",                     0o110)
+            , ("I",                     0o111)
+            , ("Iacute",                0o315)
+            , ("Icircumflex",           0o316)
+            , ("Idieresis",             0o317)
+            , ("Igrave",                0o314)
+            , ("J",                     0o112)
+            , ("K",                     0o113)
+            , ("L",                     0o114)
+            , ("M",                     0o115)
+            , ("N",                     0o116)
+            , ("Ntilde",                0o321)
+            , ("O",                     0o117)
+            , ("Oacute",                0o323)
+            , ("Ocircumflex",           0o324)
+            , ("Odieresis",             0o326)
+            , ("Ograve",                0o322)
+            , ("Oslash",                0o351)
+            , ("Otilde",                0o325)
+            , ("P",                     0o120)
+            , ("Q",                     0o121)
+            , ("R",                     0o122)
+            , ("S",                     0o123)
+            , ("T",                     0o124)
+            , ("Thorn",                 0o336)
+            , ("U",                     0o125)
+            , ("Uacute",                0o332)
+            , ("Ucircumflex",           0o333)
+            , ("Udieresis",             0o334)
+            , ("Ugrave",                0o331)
+            , ("V",                     0o126)
+            , ("W",                     0o127)
+            , ("X",                     0o130)
+            , ("Y",                     0o131)
+            , ("Yacute",                0o335)
+            , ("Z",                     0o132)
+            , ("a",                     0o141)
+            , ("aacute",                0o341)
+            , ("acircumflex",           0o342)
+            , ("acute2",                0o264)
+            , ("adieresis",             0o344)
+            , ("ae",                    0o346)
+            , ("agrave",                0o340)
+            , ("ampersand",             0o046)
+            , ("aring",                 0o345)
+            , ("asciicircum",           0o136)
+            , ("asciitilde",            0o176)
+            , ("asterisk",              0o052)
+            , ("at",                    0o100)
+            , ("atilde",                0o343)
+            , ("b",                     0o142)
+            , ("backslash",             0o134)
+            , ("bar",                   0o174)
+            , ("braceleft",             0o173)
+            , ("braceright",            0o175)
+            , ("bracketleft",           0o133)
+            , ("bracketright",          0o135)
+            , ("breve",                 0o226)
+            , ("brokenbar",             0o246)
+            , ("c",                     0o143)
+            , ("caron",                 0o237)
+            , ("ccedilla",              0o347)
+            , ("cedilla",               0o270)
+            , ("cent",                  0o242)
+            , ("circumflex",            0o223)
+            , ("colon",                 0o072)
+            , ("comma",                 0o054)
+            , ("copyright",             0o251)
+            , ("currency",              0o244)
+            , ("d",                     0o144)
+            , ("degree",                0o260)
+            , ("dieresis",              0o250)
+            , ("divide",                0o367)
+            , ("dollar",                0o044)
+            , ("dotaccent",             0o227)
+            , ("dotlessi",              0o220)
+            , ("e",                     0o145)
+            , ("eacute",                0o351)
+            , ("ecircumflex",           0o352)
+            , ("edieresis",             0o353)
+            , ("egrave",                0o350)
+            , ("eight",                 0o070)
+            , ("equal",                 0o075)
+            , ("eth",                   0o360)
+            , ("exclam",                0o041)
+            , ("exclamdown",            0o241)
+            , ("f",                     0o146)
+            , ("five",                  0o065)
+            , ("four",                  0o064)
+            , ("g",                     0o147)
+            , ("germandbls",            0o337)
+            , ("grave",                 0o221)
+            , ("greater",               0o076)
+            , ("guillemotleft",         0o253)
+            , ("guillemotright",        0o273)
+            , ("h",                     0o150)
+            , ("hungarumlaut",          0o235)
+            , ("hyphen",                0o255)
+            , ("i",                     0o151)
+            , ("iacute",                0o355)
+            , ("icircumflex",           0o356)
+            , ("idieresis",             0o357)
+            , ("igrave",                0o354)
+            , ("j",                     0o152)
+            , ("k",                     0o153)
+            , ("l",                     0o154)
+            , ("less",                  0o074)
+            , ("logicalnot",            0o254)
+            , ("m",                     0o155)
+            , ("macron",                0o257)
+            , ("minus",                 0o055)
+            , ("mu",                    0o265)
+            , ("multiply",              0o327)
+            , ("n",                     0o156)
+            , ("nine",                  0o071)
+            , ("ntilde",                0o361)
+            , ("numbersign",            0o043)
+            , ("o",                     0o157)
+            , ("oacute",                0o363)
+            , ("ocircumflex",           0o364)
+            , ("odieresis",             0o366)
+            , ("ogonek",                0o236)
+            , ("ograve",                0o362)
+            , ("one",                   0o061)
+            , ("onehalf",               0o275)
+            , ("onequarter",            0o274)
+            , ("onesuperior",           0o271)
+            , ("ordfeminine",           0o252)
+            , ("ordmasculine",          0o272)
+            , ("oslash",                0o370)
+            , ("otilde",                0o365)
+            , ("p",                     0o160)
+            , ("paragraph",             0o266)
+            , ("parenleft",             0o050)
+            , ("parenright",            0o051)
+            , ("percent",               0o045)
+            , ("period",                0o056)
+            , ("periodcentered",        0o267)
+            , ("plus",                  0o053)
+            , ("plusminus",             0o261)
+            , ("q",                     0o161)
+            , ("question",              0o077)
+            , ("questiondown",          0o277)
+            , ("quotedbl",              0o042)
+            , ("quoteleft",             0o140)
+            , ("quoteright",            0o047)
+            , ("r",                     0o162)
+            , ("registered",            0o256)
+            , ("ring",                  0o232)
+            , ("s",                     0o163)
+            , ("section",               0o247)
+            , ("semicolon",             0o073)
+            , ("seven",                 0o067)
+            , ("six",                   0o066)
+            , ("slash",                 0o057)
+            , ("space",                 0o040)
+            , ("sterling",              0o243)
+            , ("t",                     0o164)
+            , ("thorn",                 0o376)
+            , ("three",                 0o063)
+            , ("threequarters",         0o276)
+            , ("threesuperior",         0o263)
+            , ("tilde",                 0o224)
+            , ("two",                   0o062)
+            , ("twosuperior",           0o262)
+            , ("u",                     0o165)
+            , ("uacute",                0o372)
+            , ("ucircumflex",           0o373)
+            , ("udieresis",             0o374)
+            , ("ugrave",                0o371)
+            , ("underscore",            0o137)
+            , ("v",                     0o166)
+            , ("w",                     0o167)
+            , ("x",                     0o170)
+            , ("y",                     0o171)
+            , ("yacute",                0o375)
+            , ("ydieresis",             0o377)
+            , ("yen",                   0o245)
+            , ("z",                     0o172)
+            , ("zero",                  0o060)
+            ]
diff --git a/src/Wumpus/Core/Utils.hs b/src/Wumpus/Core/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Utils.hs
@@ -0,0 +1,270 @@
+{-# LANGUAGE FlexibleInstances          #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Core.Utils
+-- Copyright   :  (c) Stephen Tetley 2009
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Utility functions
+--
+--------------------------------------------------------------------------------
+
+
+module Wumpus.Core.Utils
+  ( 
+
+  -- * Component-wise min and max
+    CMinMax(..)
+  , within
+
+  -- * Three values  
+  , max3
+  , min3
+  , med3
+
+
+  -- * Truncate / print a double
+  , PSUnit(..)
+  , truncateDouble
+  , roundup
+
+  , clamp
+  , ramp
+  , ramp255
+
+  -- * PostScript timetmap
+  , mkTimeStamp
+
+  -- * Pretty printers for strings  
+  , parens
+  , hsep
+  , commasep
+  , tupled
+
+  -- * Extras  
+  , sequenceA
+  , (<:>) 
+
+
+  
+
+  -- * One type - non-empty list type
+  , OneList(..)
+  , mkList2
+  , onesmapM_
+  , toListWith
+  , toListWithM
+  , fromListErr
+
+  ) where
+
+
+
+import Control.Applicative
+import Control.Monad ( ap )
+import Data.List ( intersperse )
+import Data.Ratio
+import System.Time 
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- | /Component-wise/ min and max. 
+-- Standard 'min' and 'max' via Ord are defined lexographically
+-- on pairs, e.g.:
+-- 
+-- > min (1,2) (2,1) = (1,2)
+-- 
+-- For certain geometrical objects (Points!) we want the 
+-- (constructed-) componentwise min and max, e.g:
+--
+-- > cmin (1,2) (2,1) = (1,1) 
+-- > cmax (1,2) (2,1) = (2,2)
+-- 
+
+class CMinMax a where
+  cmin :: a -> a -> a
+  cmax :: a -> a -> a
+
+
+
+instance (Ord a, Ord b) => CMinMax (a,b) where
+  cmin (x,y) (x',y') = (min x x', min y y')
+  cmax (x,y) (x',y') = (max x x', max y y')
+
+
+-- | Test whether a is within opper and lower.
+within :: Eq a => CMinMax a => a -> a -> a -> Bool
+within a lower upper = (cmin a lower) == lower && (cmax a upper) == upper
+
+
+-- | max of 3
+max3 :: Ord a => a -> a -> a -> a
+max3 a b c = max (max a b) c
+
+-- | min of 3
+min3 :: Ord a => a -> a -> a -> a
+min3 a b c = min (min a b) c
+
+
+-- | median of 3
+med3 :: Ord a => a -> a -> a -> a
+med3 a b c = if c <= x then x else if c > y then y else c
+  where 
+    (x,y)                 = order a b
+    order p q | p <= q    = (p,q)
+              | otherwise = (q,p)
+
+
+--------------------------------------------------------------------------------
+-- PS Unit
+
+class Num a => PSUnit a where
+  toDouble :: a -> Double
+  dtrunc   :: a -> String
+  
+  dtrunc = truncateDouble . toDouble
+
+instance PSUnit Double where
+  toDouble = id
+  dtrunc   = truncateDouble
+
+instance PSUnit Float where
+  toDouble = realToFrac
+
+instance PSUnit (Ratio Integer) where
+  toDouble = realToFrac
+
+instance PSUnit (Ratio Int) where
+  toDouble = realToFrac
+
+
+-- | Truncate the printed decimal representation of a Double.
+-- The is prefered to 'showFFloat' from Numeric as it produces
+-- shorter representations where appropriate.
+-- 
+-- 0.000000000 becomes 0.0 rather than however many digs are 
+-- specified.
+--  
+truncateDouble :: Double -> String
+truncateDouble d | abs d < 0.0001  = "0.0"
+                 | d < 0.0         = '-' :  show (abs tx)
+                 | otherwise       = show tx
+  where
+    tx :: Double
+    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0
+
+roundi :: RealFrac a => a -> Integer
+roundi = round
+
+-- | Take 'ceilingi' and show.
+roundup :: Double -> String
+roundup = show . ceilingi
+
+-- Avoid those annoying 'Defaulting ...' warnings...
+ceilingi :: RealFrac a => a -> Integer
+ceilingi = ceiling
+
+
+clamp :: Ord a => a -> a -> a -> a 
+clamp a b x = max a (min b x)
+
+ramp :: Double -> Double
+ramp = clamp 0 1
+
+-- | Scale a Double between 0.0 and 1.0 to be an Int between 0 
+-- and 255.
+ramp255 :: Double -> Int
+ramp255 = clamp 0 255  . ceiling . (*255)
+
+
+
+-- | Generate a time stamp for the output files. Note PostScript
+-- does no interpretation of the time stamp, it is solely for 
+-- information and so the representation is arbitrary.
+mkTimeStamp :: IO String
+mkTimeStamp = getClockTime >>= toCalendarTime >>= return . format
+  where
+    format t = mkTime t ++ " " ++ mkDate t
+    mkTime = concat . intersperse ":" . sequenceA tfuns
+    mkDate = concat . intersperse " " . sequenceA dfuns
+    tfuns  = [ pad2 . ctHour, pad2 . ctMin, pad2 . ctSec ]
+    dfuns  = [ show . ctDay, show . ctMonth, show . ctYear ]
+    pad2 i | i < 10    = '0' : show i
+           | otherwise = show i  
+
+
+
+-- | Enclose string in parens.
+parens :: String -> String 
+parens s = "(" ++ s  ++ ")"
+
+-- | Separate with a space.
+hsep :: [String] -> String
+hsep = concat . intersperse " "
+
+commasep :: [String] -> String
+commasep = concat . intersperse ","
+
+-- | @ (..., ...)@
+tupled :: [String] -> String
+tupled = parens . concat . intersperse ", " 
+
+
+
+-- | Applicative version of (monadic) 'sequence'.
+-- Because we use MonadLib we don't want to bring in 
+-- Control.Monad.Instances ()
+sequenceA :: Applicative f => [f a] -> f [a]
+sequenceA = foldr (<:>) (pure []) 
+
+
+-- | Applicative 'cons'.
+infixr 6 <:>
+(<:>) :: Applicative f => f a -> f [a] -> f [a]
+(<:>) a b = (:) <$> a <*> b
+
+
+
+--------------------------------------------------------------------------------
+
+infixr 5 :+
+
+data OneList a = One a | a :+ OneList a
+  deriving (Eq)
+
+instance Show a => Show (OneList a) where
+  show = ('{':) . ($ []) . step where
+     step (One a)   = shows a . showChar '}'
+     step (a :+ xs) = shows a . showChar ',' . step xs
+
+
+mkList2 :: a -> a -> OneList a
+mkList2 a b = a :+ One b
+
+
+onesmapM_ :: Monad m => (a -> m b) -> OneList a -> m ()
+onesmapM_ f (One a)   = f a >> return ()
+onesmapM_ f (a :+ xs) = f a >> onesmapM_ f xs
+
+toListWith :: (a -> b) -> OneList a -> [b]
+toListWith f (One a)   = [f a]
+toListWith f (a :+ xs) = f a : toListWith f xs
+
+toListWithM :: Monad m => (a -> m b) -> OneList a -> m [b]
+toListWithM f (One a)   = return return `ap` f a
+toListWithM f (a :+ xs) = return (:) `ap` f a `ap` toListWithM f xs
+
+
+fromListErr :: String -> [a] -> OneList a
+fromListErr msg []     = error msg
+fromListErr _   [a]    = One a
+fromListErr msg (a:xs) = a :+ fromListErr msg xs
diff --git a/wumpus-core.cabal b/wumpus-core.cabal
new file mode 100644
--- /dev/null
+++ b/wumpus-core.cabal
@@ -0,0 +1,107 @@
+name:             wumpus-core
+version:          0.12.0
+license:          BSD3
+license-file:     LICENSE
+copyright:        Stephen Tetley <stephen.tetley@gmail.com>
+maintainer:       Stephen Tetley <stephen.tetley@gmail.com>
+homepage:         http://code.google.com/p/copperbox/
+category:         Graphics
+synopsis:         Pure Haskell PostScript and SVG generation. 
+description:
+  Wumpus - (W)riter (M)onad (P)ost (S)cript. 
+  .
+  Wumpus is a library for generating 2D vector pictures, its 
+  salient feature is portability due to no FFI dependencies. 
+  It can generate PostScript (EPS) files and SVG files. The 
+  generated PostScript code is quite efficient (no unnecessary 
+  stack operations) and plain [1].
+  .
+  Pictures in Wumpus are made from /paths/ and text /labels/. 
+  Paths themselves are made from points. The usual affine 
+  transformations (rotations, scaling, translations) can be
+  applied to all geometric objects. Unlike PostScript there 
+  is no notion of a current point, Wumpus builds pictures in a
+  coordinate-free style. There is a set of combinators for 
+  composing pictures (more-or-less similar to the usual pretty
+  printing combinators).
+  .
+  THE DRAWBACKS...
+  .
+  For actually drawing pictures, diagrams, etc. Wumpus is very 
+  low level. I am working on a complementary package 
+  @wumpus-extra@ with higher-level stuff (polygons, arrows etc.)
+  but it is far too unstable for Hackage. Preview releases can be
+  found at http://code.google.com/p/copperbox/ though.
+  .
+  Wumpus-core should be fairly stable from now on, except for
+  the fact that more modules are exposed than strictly necessary
+  this is so their Haddock docs are available. Client\'s should 
+  only import the @Wumpus.Core@ module. There may be some name 
+  changes etc. that will change interfaces, but Wumpus has 
+  been carefully implemented. Some of the design decisions are
+  not sophisticated (e.g. how attributes like colour are handled, 
+  and the bounding boxes of text labels are calculated), so
+  Wumpus might be limited compared to other systems but its 
+  design permits a simple implementation - which is a priority. 
+  Text encoding is the exception, the current implementation 
+  appears reasonable for Latin 1 but I\'m not sure about other 
+  character sets, and I might have to revise it significantly.
+  .
+  /There is no documentation/ - the graphics model used by 
+  Wumpus is different to PostScript or SVG, and Wumpus really 
+  needs a manual. Unfortunately there isn\'t one yet, and I will 
+  be focusing on @wumpus-extra@ for the foreseeable future so a
+  manual won\'t be written soon. If you want FFI-free vector
+  graphics and Wumpus seems to otherwise fit the task, please 
+  email me and I will try to help.
+  .
+  \[1\] Because the output is simple, straight-line PostScript 
+  code it is possible to use GraphicsMagick or similar tools to 
+  convert Wumpus'\s EPS files to many other formats (bitmaps). 
+ 
+build-type:         Simple
+stability:          highly unstable
+cabal-version:      >= 1.2
+
+extra-source-files:
+  demo/LabelPic.hs,
+  demo/Picture.hs
+
+
+library
+  hs-source-dirs:     src
+  build-depends:      base < 5, containers, old-time,
+                      wl-pprint, vector-space, 
+                      monadLib, xml, dlist, algebra, 
+                      data-aviary > 0.1.0
+                        
+  exposed-modules:
+    Wumpus.Core,
+    Wumpus.Core.AffineTrans,
+    Wumpus.Core.BoundingBox,
+    Wumpus.Core.Colour,
+    Wumpus.Core.FontSize,
+    Wumpus.Core.Geometry,
+    Wumpus.Core.GraphicsState,
+    Wumpus.Core.OutputPostScript,
+    Wumpus.Core.OutputSVG,
+    Wumpus.Core.Picture,
+    Wumpus.Core.PictureInternal,
+    Wumpus.Core.PictureLanguage,
+    Wumpus.Core.PostScript,
+    Wumpus.Core.SVG,
+    Wumpus.Core.TextEncoding,
+    Wumpus.Core.TextLatin1,
+    Wumpus.Core.Utils
+  other-modules:
+    
+  extensions:
+    
+
+  ghc-options:
+  
+  includes: 
+  
+
+  
+