diff --git a/Graphics/PDF.hs b/Graphics/PDF.hs
--- a/Graphics/PDF.hs
+++ b/Graphics/PDF.hs
@@ -44,8 +44,11 @@
   , module Graphics.PDF.Pattern
   -- ** Shading
   , module Graphics.PDF.Shading
+  -- ** Typesetting
+  , module Graphics.PDF.Typesetting
   ) where
  
+import Graphics.PDF.Typesetting
 import Graphics.PDF.Shading
 import Graphics.PDF.Pattern
 import Graphics.PDF.Navigation
@@ -55,7 +58,6 @@
 import qualified Data.ByteString.Lazy as B
 import Data.Int
 import System.IO
-import Control.Exception(bracket)
 import Text.Printf(printf)
 import Control.Monad.State
 import Graphics.PDF.Annotation
@@ -70,6 +72,9 @@
 import Graphics.PDF.Action
 import Graphics.PDF.Image
 import Graphics.PDF.Resources(emptyResource)
+import Data.Binary.Builder(Builder,fromLazyByteString, toLazyByteString)
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
 
 -- | Create a new PDF document and return a first page
 -- The page is using the document size by default
@@ -82,17 +87,20 @@
   return ()
   
 -- Create the PDF stream objects from the draw monads
-createStreams :: [(Int, (Maybe (PDFReference PDFPage),Draw ()))] -> PDF ()
-createStreams l = mapM_ addStream l
+createStreams :: PDF ()
+createStreams = do
+    ls <- gets streams >>= return . IM.toList
+    modifyStrict $ \s -> s {streams = IM.empty}
+    mapM_ addStream ls
  where
-    addStream (k,(p,d)) = do
+    addStream (k,(p,(state',w'))) = do
      -- New reference for the stream
      r <- supply
      -- Run the drawing and get the new state (resource, annotation)
-     myBounds <- gets xobjectBound
-     cp <- gets currentPage
-     let (_,state',w') = runDrawing d (emptyEnvironment {streamId = r, xobjectb = myBounds, currentp = maybe Nothing (\(PDFReference x) -> Just x) cp })
-         ref = PDFReference r :: PDFReference PDFLength
+     --myBounds <- gets xobjectBound
+     --cp <- gets currentPage
+     --let (_,state',w') = runDrawing d (emptyEnvironment {streamId = r, xobjectb = myBounds, currentp = maybe Nothing (\(PDFReference x) -> Just x) cp })
+     let ref = PDFReference r :: PDFReference PDFLength
          
      -- Pattern NEEDS a resource entry even if empty otherwise don't work with acrobat reader
      -- Image DON'T want a resource entry if empty otherwise don't work with apple reader
@@ -124,43 +132,30 @@
      -- We compress only if the stream is not using its own filter
      if (compressed infos) && (not (pdfDictMember (PDFName "Filter") resources))
        then do
-         let w'' = compress w'
+         let w''' = compress . toLazyByteString $ w'
+             w'' = fromLazyByteString w'''
          updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w'' True ref resources)
-         updateObject ref (PDFLength (B.length w''))
+         updateObject ref (PDFLength (B.length w'''))
        else do
          updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w' False ref resources)
-         updateObject ref (PDFLength (B.length w'))
+         updateObject ref (PDFLength (B.length . toLazyByteString $ w'))
 
 -- | Save all the pages and streams in the main object dictionary
 saveObjects :: PDF (PDFReference PDFCatalog)
 saveObjects  = do
-  ls <- gets streams
-  createStreams . IM.toList $ ls
+  -- Save streams to the object dictionary so that they are saved in the PDF document
+  createStreams
   infos <- gets docInfo
-  -- Save pages and streams to the object dictionary so that they are saved in the PDF document
+  -- Save pages to the object dictionary so that they are saved in the PDF document
   pRef <- addPages
   -- Create outlines object
   o <- gets outline
   oref <- addOutlines o
   -- Create the catalog
   cat <- addObject $ PDFCatalog oref pRef (pageMode infos) (pageLayout infos) (viewerPreferences infos)
-  modify $ \s -> s {catalog = cat}
+  modifyStrict $ \s -> s {catalog = cat}
   gets catalog
-  
--- | Write PDF objects in the TOC
-writeObjectsAndCreateToc :: Handle -- ^ File handle
-                         -> [B.ByteString] -- ^ List of objects each object being already converted to a bytestring
-                         -> IO (Int,Int64,[B.ByteString])
-writeObjectsAndCreateToc h l = foldM writeObject (0,0::Int64,[]) l where
-  writeObject (nb,len,toc) obj = do
-    -- Write the object to the file
-    B.hPut h obj
-    -- Remember the position
-    return (nb+1,len + B.length obj,(toByteString (printf "%010d 00000 n \n" ((fromIntegral len)::Integer))) : toc)
 
-withFile :: FilePath -> (Handle -> IO c) -> IO c
-withFile name = bracket (openBinaryFile name WriteMode) hClose
-
 -- | The PDFTrailer
 #ifndef __HADDOCK__
 data PDFTrailer = PDFTrailer 
@@ -180,8 +175,61 @@
      where
       allInfos = [ (PDFName "Author",AnyPdfObject . author $ infos)
                  , (PDFName "Subject",AnyPdfObject . subject $ infos)
+                 , (PDFName "Producer",AnyPdfObject $ toPDFString "HPDF - The Haskell PDF Library" )
                  ]
-    
+
+-- | Write PDF objects in the TOC
+writeObjectsAndCreateToc :: [Builder] -- ^ List of objects each object being already converted to a bytestring
+                          -> (Int,Int64,[Builder])
+writeObjectsAndCreateToc l = 
+   let lengths =  tail . scanl (\len obj -> len + (B.length . toLazyByteString $ obj)) 0 $ l
+       createEntry x = serialize $ (printf "%010d 00000 n \n" ((fromIntegral x)::Integer) :: String)
+       entries = map createEntry (init lengths) 
+   in
+   (length l,last lengths,entries)
+-- foldr writeObject (0,0::Int64,[]) l where
+-- writeObject obj (nb,len,toc) = (nb+1,len + (B.length . toLazyByteString $ obj),(serialize $ (printf "%010d 00000 n \n" ((fromIntegral len)::Integer))) : toc)
+     
+defaultPdfSettings :: PdfState
+defaultPdfSettings = 
+  PdfState {
+             supplySrc = 1
+           , objects = IM.empty
+           , pages = noPages
+           , streams = IM.empty
+           , catalog = PDFReference 0
+           , defaultRect = PDFRect 0 0 600 400 
+           , docInfo = standardDocInfo { author=toPDFString "Unknown", compressed = True}
+           , outline = Nothing
+           , currentPage = Nothing
+           , xobjectBound = IM.empty
+           , firstOutline = [True]
+           }
+
+createObjectByteStrings :: PdfState -> PDF a -> Builder 
+createObjectByteStrings pdfState m =
+      let header = serialize "%PDF-1.5\n"
+          objectEncoding (x,a) = toPDF . PDFReferencedObject (fromIntegral x) $ a
+          (root,s) = flip runState pdfState  . unPDF $ createPDF >> m >> saveObjects
+          objs = objects s
+          objectContents = header : (map objectEncoding . IM.toAscList $ objs)
+          (nb,len,toc) = writeObjectsAndCreateToc objectContents
+      in
+        mconcat$ objectContents ++
+                [ serialize "xref\n"
+                , serialize $ "0 " ++ show nb ++ "\n"
+                , serialize "0000000000 65535 f \n"
+                ]
+                ++
+                toc
+                ++
+                [ serialize "\ntrailer\n"
+                , toPDF $ PDFTrailer nb root (docInfo pdfState)
+                , serialize "\nstartxref\n"
+                , serialize (show len)
+                , serialize "\n%%EOF"
+                ]
+      
 -- | Generates a PDF document
 runPdf :: String -- ^ Name of the PDF document
        -> PDFDocumentInfo
@@ -189,33 +237,7 @@
        -> PDF a  -- ^ PDF action 
        -> IO ()
 runPdf filename infos rect m = do
-  (root,s) <- flip runStateT vars  . unPDF $ createPDF >> m >> saveObjects
-  let header = toByteString "%PDF-1.5\n"
-      objs = objects s
-  withFile filename $ \h -> do
-    (nb,len,toc) <- writeObjectsAndCreateToc h $ header : (map (toPDF . pointer) . IM.toAscList $ objs)
-    B.hPut h . toByteString $ "xref\n"
-    B.hPut h . toByteString $ "0 " ++ show nb ++ "\n"
-    B.hPut h . toByteString $ "0000000000 65535 f \n"
-    B.hPut h . B.concat . tail . reverse $ toc
-    B.hPut h . toByteString $ "\ntrailer\n"
-    B.hPut h . toPDF $ PDFTrailer nb root infos
-    B.hPut h . toByteString $ "\nstartxref\n"
-    B.hPut h . toByteString $ (show len)
-    B.hPut h . toByteString $ "\n%%EOF"
- where
-  pointer (x,a) = PDFReferencedObject (fromIntegral x) a
-  vars = PdfState {
-           supplySrc = 1
-         , objects = IM.empty
-         , pages = noPages
-         , streams = IM.empty
-         , catalog = PDFReference 0
-         , defaultRect = rect
-         , docInfo = infos
-         , outline = Nothing
-         , currentPage = Nothing
-         , xobjectBound = IM.empty
-         , firstOutline = [True]
-         }
+  let content = createObjectByteStrings (defaultPdfSettings {defaultRect = rect, docInfo = infos} ) m
+  B.writeFile filename (toLazyByteString content)
+
 
diff --git a/Graphics/PDF/Colors.hs b/Graphics/PDF/Colors.hs
--- a/Graphics/PDF/Colors.hs
+++ b/Graphics/PDF/Colors.hs
@@ -32,7 +32,9 @@
 import Graphics.PDF.LowLevel.Types
 import Control.Monad.State(gets)
 import Graphics.PDF.Resources
-
+import Control.Monad.Writer
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
             
 black :: Color
 black = Rgb 0 0 0  
@@ -57,7 +59,10 @@
     alphaMap <- gets strokeAlphas
     (newName,newMap) <- setResource "ExtGState" (StrokeAlpha alpha) alphaMap
     modifyStrict $ \s -> s { strokeAlphas = newMap }
-    writeCmd ("\n/" ++ newName ++ " gs")
+    tell . mconcat $[ serialize "\n/" 
+                    , serialize newName
+                    , serialize " gs"
+                    ]
         
 -- | Set alpha value for transparency
 setFillAlpha :: Double -> Draw ()
@@ -65,11 +70,14 @@
     alphaMap <- gets fillAlphas
     (newName,newMap) <- setResource "ExtGState" (FillAlpha alpha) alphaMap
     modifyStrict $ \s -> s { fillAlphas = newMap }
-    writeCmd ("\n/" ++ newName ++ " gs")
+    tell . mconcat $[ serialize "\n/" 
+                    , serialize newName
+                    , serialize " gs"
+                    ]
     
 -- | Init the PDF color space to RGB.
 setRGBColorSpace :: Draw ()
-setRGBColorSpace = writeCmd "\n/DeviceRGB CS\n/DeviceRGB cs\n"
+setRGBColorSpace = tell . serialize $ "\n/DeviceRGB CS\n/DeviceRGB cs\n"
 
 
 
@@ -77,17 +85,46 @@
 fillColor :: MonadPath m => Color -- ^ Filling color
           -> m ()
 fillColor (Rgb r g b) = do
-    writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " rg" 
+    tell . mconcat $[ serialize "\n"
+                    , toPDF r
+                    , serialize ' '
+                    , toPDF g
+                    , serialize ' '
+                    , toPDF b
+                    , serialize " rg" 
+                    ]
+                    
 fillColor (Hsv h s v) = do
         let (r,g,b) = hsvToRgb (h,s,v)
-        writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " rg"
+        tell . mconcat $[ serialize "\n"
+                        , toPDF r
+                        , serialize ' '
+                        , toPDF g
+                        , serialize ' '
+                        , toPDF b
+                        , serialize " rg" 
+                        ]
 
 -- | Select the drawing color
 strokeColor :: MonadPath m => Color -- ^ Drawing color
             -> m ()
 strokeColor (Rgb r g b) = do
-    writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " RG" 
+    tell . mconcat $[ serialize "\n"
+                    , toPDF r
+                    , serialize ' '
+                    , toPDF g
+                    , serialize ' '
+                    , toPDF b
+                    , serialize " RG" 
+                    ]
 strokeColor (Hsv h s v) = do
     let (r,g,b) = hsvToRgb (h,s,v)
-    writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " RG" 
+    tell . mconcat $[ serialize "\n"
+                    , toPDF r
+                    , serialize ' '
+                    , toPDF g
+                    , serialize ' '
+                    , toPDF b
+                    , serialize " RG" 
+                    ]
 
diff --git a/Graphics/PDF/Coordinates.hs b/Graphics/PDF/Coordinates.hs
--- a/Graphics/PDF/Coordinates.hs
+++ b/Graphics/PDF/Coordinates.hs
@@ -24,7 +24,11 @@
 
 import Graphics.PDF.LowLevel.Types
 import Graphics.PDF.Draw
+import Control.Monad.Writer
 
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
+
 -- | Angle 
 data Angle = Degree PDFFloat -- ^ Angle in degrees
            | Radian PDFFloat -- ^ Angle in radians
@@ -64,8 +68,21 @@
 -- | Apply a transformation matrix to the current coordinate frame
 applyMatrix :: Matrix -> Draw ()
 applyMatrix (Matrix a b c d e f)  = 
-    writeCmd $ "\n" ++ show (a) ++ " " ++ show (b) ++ " " ++ show (c) ++ " " ++ show (d) ++ " " ++ show (e) ++ " " ++ show (f) ++ " cm"
-
+    tell . mconcat $[ serialize '\n'
+                    , toPDF a
+                    , serialize ' '
+                    , toPDF b
+                    , serialize ' '
+                    , toPDF c
+                    , serialize ' '
+                    , toPDF d
+                    , serialize ' '
+                    , toPDF e
+                    , serialize ' '
+                    , toPDF f
+                    , serialize " cm"
+                    ]
+                    
 -- | Rotation matrix
 rotate :: Angle -- ^ Rotation angle
        -> Matrix
diff --git a/Graphics/PDF/Demo.hs b/Graphics/PDF/Demo.hs
deleted file mode 100644
--- a/Graphics/PDF/Demo.hs
+++ /dev/null
@@ -1,151 +0,0 @@
----------------------------------------------------------
--- |
--- Copyright   : (c) alpha 2007
--- License     : BSD-style
---
--- Maintainer  : misc@NOSPAMalpheccar.org
--- Stability   : experimental
--- Portability : portable
---
--- PDF demo. Generate a file demo.pdf
----------------------------------------------------------
-module Graphics.PDF.Demo(demo) where
-
-import Graphics.PDF
-            
-fontDebug :: PDFFont -> PDFString -> Draw ()
-fontDebug f t = do
-     drawText $ do
-         setFont f
-         textStart 10 200.0
-         leading $ getHeight f
-         renderMode FillText
-         displayText t
-         startNewLine
-         displayText $ toPDFString "Another little test"
-     strokeColor $ Rgb 1 0 0
-     stroke $ Line 10 200 612 200
-     fill $ Circle 10 200 10
-     stroke $ Rectangle 10 (200.0 - (getDescent f)) (10.0 + textWidth f t) (200.0 - getDescent f + getHeight f)           
-
-      
-geometryTest :: Draw ()
-geometryTest  = do
-        strokeColor red
-        stroke $ Rectangle 0 0 200 100
-        fillColor blue
-        fill $ Ellipse 100 100 300 200
-        fillAndStroke $ RoundRectangle 32 32 200 200 600 400
-
-lineStyle ::Draw ()
-lineStyle  = do
-        withNewContext $ do
-            setWidth 2
-            setDash $ DashPattern [3] 0
-            geometryTest
-            
-            
-shadingTest :: Draw ()
-shadingTest  = do
-     paintWithShading (RadialShading 0 0 50 0 0 600 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Rectangle 0 0 300 300)
-     paintWithShading (AxialShading 300 300 600 400 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Ellipse 300 300 600 400)
-     
-                     
-patternTest :: PDFReference PDFPage -> PDF ()
-patternTest page = do
-     p <- createUncoloredTiling 0 0 100 50 100 50 ConstantSpacing pattern
-     cp <- createColoredTiling 0 0 100 50 100 50 ConstantSpacing cpattern
-     drawWithPage page $ do
-         strokeColor green
-         setUncoloredFillPattern p (Rgb 1 0 0)
-         fillAndStroke $ Ellipse 0 0 300 300
-         setColoredFillPattern cp
-         fillAndStroke $ Ellipse 300 300 600 400
-         
- where 
-       myDrawing = do
-           stroke (Line 0 0 100 100)
-           fill (Rectangle 100 100 200 200)
-       pattern = do
-           stroke (Ellipse 0 0 100 50)
-       cpattern = do
-           strokeColor (Rgb 0 0 1)
-           stroke (Ellipse 0 0 100 50) 
-           
-testAnnotation :: Draw ()
-testAnnotation = do
-    strokeColor red
-    newAnnotation (URLLink (toPDFString "Go to my blog") [0,0,100,100] "http://www.alpheccar.org" True)
-    drawText $ text (PDFFont Times_Roman 12) 10 30 (toPDFString "Go to my blog")
-    stroke $ Rectangle 0 0 100 100
-    newAnnotation (TextAnnotation (toPDFString "Key annotation") [100,100,130,130] Key)
- 
-textTest :: Draw ()
-textTest = do
-    strokeColor red
-    fillColor blue
-    fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test !")
-
-              
---testImage ::  FilePath -> PDFReference PDFPage -> PDF ()
---testImage logo page =  do
---    Right jpg <- createPDFJpeg logo
---    drawWithPage page $ do
---      withNewContext $ do
---          setFillAlpha 0.4
---          drawXObject jpg
---      withNewContext $ do
---           applyMatrix $ rotate (Degree 20)
---           applyMatrix $ translate 200 200
---           applyMatrix $ scale 2 2
---           drawXObject jpg
-                                               
-testAll :: FilePath -> PDF ()
-testAll logo = do
-    page <- addPage Nothing
-    newSection (toPDFString "Shapes") Nothing Nothing $ do
-        
-      newSection (toPDFString "Geometry") Nothing Nothing $ do
-         drawWithPage page $ do
-           geometryTest 
-           
-      page <- addPage Nothing
-      newSection (toPDFString "Line style") Nothing Nothing $ do
-          drawWithPage page $ do
-            lineStyle
-      page <- addPage Nothing
-      newSection (toPDFString "Object reuse") Nothing Nothing $ do
-           r <- createPDFXForm 0 0 200 200 lineStyle
-           drawWithPage page $ do
-                drawXObject r
-            
-    page <- addPage Nothing
-    newSectionWithPage (toPDFString "Painting") Nothing Nothing page $ do
-     newSection (toPDFString "Patterns") Nothing Nothing $ do
-        patternTest page
-     page <- addPage Nothing
-     newSection (toPDFString "Shading") Nothing Nothing $ do
-        drawWithPage page $ do
-          shadingTest
-    page <- addPage Nothing
-    --newSection (toPDFString "Media") Nothing Nothing $ do
-    --  newSection (toPDFString "image") Nothing Nothing $ do   
-    --       testImage logo page  
-           
-    page <- addPage Nothing
-    newSection (toPDFString "Annotations") Nothing Nothing $ do
-        drawWithPage page $ do
-          testAnnotation 
-    page <- addPage Nothing
-    newSection (toPDFString "Text") Nothing Nothing $ do
-      drawWithPage page $ do
-        textTest
-     
-    
--- | Run the demo and create a demo.pdf file       
-demo :: IO()
-demo = do
-    let rect = PDFRect 0 0 600 400
-    runPdf "demo.pdf" (standardDocInfo { author=toPDFString $ "alpheccar"}) rect $ do
-        testAll ""
-     
diff --git a/Graphics/PDF/Document.hs b/Graphics/PDF/Document.hs
--- a/Graphics/PDF/Document.hs
+++ b/Graphics/PDF/Document.hs
@@ -47,8 +47,7 @@
 import Control.Monad.State
 import qualified Data.IntMap as IM
 import qualified Data.Map as M
-
-
+import Data.Monoid
         
 -- | No information for the document  
 standardDocInfo :: PDFDocumentInfo          
@@ -113,7 +112,7 @@
 -- | Draw on a given page
 drawWithPage :: PDFReference PDFPage -- ^ Page
             -> Draw a -- ^ Drawing commands
-            -> PDF ()
+            -> PDF a
 drawWithPage page draw = do
      -- Get the page dictionary
      lPages <- gets pages
@@ -122,13 +121,16 @@
      -- Look for the page
      let thePage = findPage page lPages
      case thePage of
-       Nothing -> return ()
+       Nothing -> error "Can't find the page to draw on it"
        -- If the page is found, get its stream reference and look for the stream
        Just(PDFPage _ _ (PDFReference streamRef) _ _ _ _) -> do
           let theContent = IM.lookup streamRef lStreams
           case theContent of
-            Nothing -> return()
+            Nothing -> error "Can't find a content for the page to draw on it"
             -- If the stream is found
-            Just (_,c) -> do
+            Just (_,(oldState,oldW)) -> do
               -- Create a new cntent and update the stream
-              modifyStrict $ \s -> s {streams = IM.insert streamRef (Just page,c >> draw >> return ()) lStreams}
+              myBounds <- gets xobjectBound
+              let (a,state',w') = runDrawing draw (emptyEnvironment {streamId = streamRef, xobjectb = myBounds}) oldState
+              modifyStrict $ \s -> s {streams = IM.insert streamRef (Just page,(state',mappend oldW w')) lStreams}
+              return a
diff --git a/Graphics/PDF/Draw.hs b/Graphics/PDF/Draw.hs
--- a/Graphics/PDF/Draw.hs
+++ b/Graphics/PDF/Draw.hs
@@ -19,7 +19,7 @@
  , DrawEnvironment(..)
  , supplyName
  , emptyDrawing
- , writeCmd
+-- , writeCmd
  , runDrawing
  , setResource
  , emptyEnvironment
@@ -62,10 +62,10 @@
  , AnnotationStyle(..)
  , PDFShading(..)
  , getRgbColor
+ , emptyDrawState
  ) where
  
 import Graphics.PDF.LowLevel.Types
-import qualified Data.ByteString.Lazy as B
 import Control.Monad.RWS
 import Control.Monad.Writer
 import Control.Monad.Reader
@@ -75,6 +75,9 @@
 import qualified Data.IntMap as IM
 import Graphics.PDF.Data.PDFTree(PDFTree)
 import Data.Maybe
+import qualified Data.Binary.Builder as BU
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
 
 data AnnotationStyle = AnnotationStyle !(Maybe Color)
 
@@ -119,21 +122,20 @@
 data DrawEnvironment = DrawEnvironment {
                         streamId :: Int
                      ,  xobjectb :: IM.IntMap (PDFFloat,PDFFloat)
-                     ,  currentp :: Maybe Int
                      }   
     
 emptyEnvironment :: DrawEnvironment
-emptyEnvironment = DrawEnvironment 0 IM.empty Nothing
+emptyEnvironment = DrawEnvironment 0 IM.empty
     
 
 
 -- | The drawing monad
-newtype Draw a = Draw {unDraw :: RWS DrawEnvironment B.ByteString DrawState a} 
+newtype Draw a = Draw {unDraw :: RWS DrawEnvironment BU.Builder DrawState a} 
 #ifndef __HADDOCK__
-               deriving(Monad,MonadWriter B.ByteString, MonadReader DrawEnvironment, MonadState DrawState, Functor)
+               deriving(Monad,MonadWriter BU.Builder, MonadReader DrawEnvironment, MonadState DrawState, Functor)
 #else
 instance Monad Draw
-instance MonadWriter B.ByteString Draw
+instance MonadWriter BU.Builder Draw
 instance MonadReader DrawEnvironment Draw
 instance MonadState DrawState Draw
 instance Functor Draw
@@ -142,16 +144,16 @@
 instance MonadPath Draw
 
 -- | A PDF stream object
-data PDFStream = PDFStream !B.ByteString !Bool !(PDFReference PDFLength) !PDFDictionary
+data PDFStream = PDFStream !BU.Builder !Bool !(PDFReference PDFLength) !PDFDictionary
                                    
 instance PdfObject PDFStream where
   toPDF (PDFStream s c l d) = 
-      B.concat $ [  toPDF dict
-                  , toByteString "\nstream"
+      mconcat   $ [ toPDF dict
+                  , serialize "\nstream"
                   , newline
                   , s
                   , newline
-                  , toByteString "endstream"]
+                  , serialize "endstream"]
    where
       compressedStream False = []
       compressedStream True = if not (pdfDictMember (PDFName "Filter") d) then [(PDFName "Filter",AnyPdfObject $ [AnyPdfObject . PDFName $ "FlateDecode"])] else []
@@ -165,10 +167,6 @@
 -- | is member of the dictionary
 pdfDictMember :: PDFName -> PDFDictionary -> Bool
 pdfDictMember k (PDFDictionary d)  = M.member k d
-    
--- | Write a command to the drawing
-writeCmd :: (MonadWriter B.ByteString m) => String -> m ()
-writeCmd = tell . toByteString
 
 -- | Get a new resource name
 supplyName :: Draw String
@@ -176,27 +174,24 @@
     (x:xs) <- gets supplyNames
     modifyStrict $ \s -> s {supplyNames = xs}
     return x
+    
+emptyDrawState :: Int -> DrawState
+emptyDrawState ref = 
+    let names = (map (("O" ++ (show ref)) ++ ) $ [replicate k ['a'..'z'] | k <- [1..]] >>= sequence) in
+    DrawState names emptyRsrc M.empty M.empty M.empty M.empty emptyDictionary []  M.empty M.empty M.empty
   
 -- | Execute the drawing commands to get a new state and an uncompressed PDF stream
-runDrawing :: Draw a -> DrawEnvironment -> (a,DrawState,B.ByteString)
-runDrawing drawing environment = 
-      let names = (map (("O" ++ (show . streamId $ environment)) ++ ) $ [replicate k ['a'..'z'] | k <- [1..]] >>= sequence)
-          state = DrawState 
-             names
-             emptyRsrc
-             M.empty M.empty M.empty M.empty 
-             emptyDictionary []  M.empty M.empty M.empty
-          (a,state',w') = (runRWS . unDraw $ drawing) environment state 
-      in
-          (a,state',w')
+runDrawing :: Draw a -> DrawEnvironment -> DrawState -> (a,DrawState,BU.Builder)
+runDrawing drawing environment state = (runRWS . unDraw $ drawing) environment state 
+     
       
 -- | Draw in a new drawing context without perturbing the previous context
 -- that is restored after the draw       
 withNewContext :: Draw a -> Draw a
 withNewContext m = do
-    writeCmd "\nq"
+    tell . serialize $ "\nq"
     a <- m
-    writeCmd "\nQ"
+    tell . serialize $ "\nQ"
     return a
     
 -- | Set a resource in the resource dictionary
@@ -222,7 +217,10 @@
         xobjectMap <- gets xobjects
         (newName,newMap) <- setResource "XObject" (PDFReference r) xobjectMap
         modifyStrict $ \s -> s { xobjects = newMap }
-        writeCmd ("\n/" ++ newName ++ " Do")
+        tell . mconcat  $ [ serialize "\n/" 
+                          , serialize newName
+                          , serialize " Do"
+                          ]
     drawXObject = privateDrawXObject
     
     bounds (PDFReference r) = getBound r
@@ -270,7 +268,7 @@
 data PdfState = PdfState { supplySrc :: !Int -- ^ Supply of unique identifiers
                          , objects :: !(IM.IntMap AnyPdfObject) -- ^ Dictionary of PDF objects
                          , pages :: !Pages -- ^ Pages
-                         , streams :: !(IM.IntMap ((Maybe (PDFReference PDFPage)),Draw ())) -- ^ Draw commands
+                         , streams :: !(IM.IntMap ((Maybe (PDFReference PDFPage)),(DrawState,BU.Builder))) -- ^ Draw commands
                          , catalog :: !(PDFReference PDFCatalog) -- ^ Reference to the PDF catalog
                          , defaultRect :: !PDFRect -- ^ Default page size
                          , docInfo :: !PDFDocumentInfo -- ^ Document infos
@@ -340,14 +338,13 @@
                         deriving(Eq)
 
 -- | The PDF Monad
-newtype PDF a = PDF {unPDF :: StateT PdfState IO a}
+newtype PDF a = PDF {unPDF :: State PdfState a}
 #ifndef __HADDOCK__
-  deriving (Functor, Monad, MonadState PdfState, MonadIO)
+  deriving (Functor, Monad, MonadState PdfState)
 #else
 instance Functor PDF
 instance Monad PDF
 instance MonadState PdfState PDF
-instance MonadIO PDF
 #endif
 
 -- | Transition style
@@ -405,9 +402,9 @@
   , (PDFName "Last",AnyPdfObject lasto)
   ]
 
-data OutlineStyle = Normal
-                  | Italic
-                  | Bold
+data OutlineStyle = NormalOutline
+                  | ItalicOutline
+                  | BoldOutline
                   deriving(Eq)
 
 data PDFOutlineEntry = PDFOutlineEntry !PDFString 
@@ -521,9 +518,9 @@
 
 
 instance PdfObject OutlineStyle where
-   toPDF Normal = toPDF (PDFInteger 0)
-   toPDF Italic = toPDF (PDFInteger 1)
-   toPDF Bold = toPDF (PDFInteger 2)
+   toPDF NormalOutline = toPDF (PDFInteger 0)
+   toPDF ItalicOutline = toPDF (PDFInteger 1)
+   toPDF BoldOutline = toPDF (PDFInteger 2)
 
 instance PdfObject PDFOutlineEntry where
  toPDF (PDFOutlineEntry title theParent prev next first theLast count dest color style) = 
diff --git a/Graphics/PDF/Image.hs b/Graphics/PDF/Image.hs
--- a/Graphics/PDF/Image.hs
+++ b/Graphics/PDF/Image.hs
@@ -14,8 +14,10 @@
    -- * Images
    -- ** Types
      PDFJpeg
+   , JpegFile
    -- ** Functions
    , createPDFJpeg
+   , readJpegFile
  ) where
      
 import Graphics.PDF.LowLevel.Types
@@ -31,6 +33,7 @@
 import Data.Bits
 import Control.Monad.Error  
 import Graphics.PDF.Coordinates
+import Data.Binary.Builder(Builder,fromLazyByteString)
 
 m_sof0 :: Int
 m_sof0 = 0xc0 
@@ -143,7 +146,7 @@
 io = FA . liftIO
 
 -- | File analyzer monad
-newtype FA a = FA {unFA :: ErrorT String PDF a} 
+newtype FA a = FA {unFA :: ErrorT String IO a} 
 #ifndef __HADDOCK__
   deriving(Monad,MonadError String,Functor)
 #else
@@ -153,7 +156,7 @@
 instance Functor FA
 #endif
     
-runFA :: FA a -> PDF (Either String a)
+runFA :: FA a -> IO (Either String a)
 runFA = runErrorT . unFA
 
 readWord16 :: Handle -> FA Int
@@ -238,42 +241,53 @@
 --test = analyzePng "Test/logo.png"
     
     
--- | Create a PDF XObject for a JPEG image
-createPDFJpeg :: FilePath
-              -> PDF (Either String (PDFReference PDFJpeg))
-createPDFJpeg f = do
+-- | Read a JPEG file and return an abstract description of its content or an error
+readJpegFile :: FilePath
+             -> IO (Either String JpegFile)
+readJpegFile f = do
      h <- liftIO $ openBinaryFile f ReadMode
      r <- runFA (analyzeJpeg h)
      liftIO $ hClose h
      case r of
-         Right settings@(_,height,width,_) -> do
+         Right (bits_per_component,height,width,color_space) -> do
                  img <- liftIO $ B.readFile f
-                 PDFReference s <- createContent (a' img settings) Nothing  
-                 recordBound s width height
-                 return (Right $ PDFReference s) 
+                 return (Right $ JpegFile bits_per_component width height color_space (fromLazyByteString img)) 
          Left s -> return $ Left s 
- where
-    color c = case c of
-        1 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceGray")]
-        3 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")]
-        4 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceCMYK")
-             ,(PDFName "Decode",AnyPdfObject . map (AnyPdfObject . PDFInteger) $ [1,0,1,0,1,0,1,0])
-             ]
-        _ -> error "Jpeg color space not supported"
-    a' img (bits_per_component,height,width,color_space) = 
-              do modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ 
-                                                [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")
-                                                , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")
-                                                , (PDFName "Width",AnyPdfObject . PDFInteger $ round width)
-                                                , (PDFName "Height",AnyPdfObject . PDFInteger $ round height)
-                                                , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ bits_per_component)
-                                                , (PDFName "Interpolate", AnyPdfObject True)
-                                                , (PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")
-                                                ] ++ color color_space
-                                          }
-                 tell img
-     
+
+  
+-- | Use an abstract description of a Jpeg to return a PDFReference that can be used to manipulate the Jpeg in the context
+-- of the PDF document
+createPDFJpeg :: JpegFile  
+              -> PDF (PDFReference PDFJpeg)
+createPDFJpeg (JpegFile bits_per_component width height color_space img) = do
+        PDFReference s <- createContent a' Nothing  
+        recordBound s width height
+        return (PDFReference s) 
+    where
+       color c = case c of
+           1 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceGray")]
+           3 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")]
+           4 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceCMYK")
+                ,(PDFName "Decode",AnyPdfObject . map (AnyPdfObject . PDFInteger) $ [1,0,1,0,1,0,1,0])
+                ]
+           _ -> error "Jpeg color space not supported"
+       a' = 
+                 do modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ 
+                                                   [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")
+                                                   , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")
+                                                   , (PDFName "Width",AnyPdfObject . PDFInteger $ round width)
+                                                   , (PDFName "Height",AnyPdfObject . PDFInteger $ round height)
+                                                   , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ bits_per_component)
+                                                   , (PDFName "Interpolate", AnyPdfObject True)
+                                                   , (PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")
+                                                   ] ++ color color_space
+                                             }
+                    tell img        
+              
+-- | A Jpeg file   
+data JpegFile = JpegFile !Int !PDFFloat !PDFFloat !Int !Builder
      
+-- | A Jpeg PDF object
 data PDFJpeg
 instance PDFXObject PDFJpeg where
     drawXObject a = withNewContext $ do
diff --git a/Graphics/PDF/LowLevel/Serializer.hs b/Graphics/PDF/LowLevel/Serializer.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/PDF/LowLevel/Serializer.hs
@@ -0,0 +1,76 @@
+---------------------------------------------------------
+-- |
+-- Copyright   : (c) alpha 2006
+-- License     : BSD-style
+--
+-- Maintainer  : misc@NOSPAMalpheccar.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Serializer
+---------------------------------------------------------
+-- #hide
+module Graphics.PDF.LowLevel.Serializer(
+  SerializeValue(..)
+ ) where
+   
+import Data.Word 
+import qualified Data.ByteString.Lazy as B
+import qualified Data.Binary.Builder as BU
+import qualified Data.ByteString.Lazy.Char8 as C
+import Data.Encoding
+import Data.Encoding.UTF8
+import Foreign.Ptr(Ptr)
+import Data.Monoid
+import Data.ByteString.Base
+
+foreign import ccall "conversion.h c_floatToString" cfloatToString :: Double -> Ptr Word8 -> IO Int
+foreign import ccall "conversion.h c_shortToString" cshortToString :: Int -> Ptr Word8 -> IO Int
+
+
+
+class (Monoid s) => SerializeValue s a where
+    serialize :: a -> s
+    cons :: a -> s -> s
+    cons a b = (serialize a) `mappend` b
+    
+instance SerializeValue B.ByteString Word8 where
+    serialize = B.singleton
+    cons = B.cons
+    
+instance SerializeValue B.ByteString Char where
+    serialize = C.singleton
+    cons = C.cons  
+    
+instance SerializeValue B.ByteString [Char] where
+    serialize = encodeLazy UTF8
+    
+instance SerializeValue B.ByteString B.ByteString where
+    serialize = id
+    
+instance SerializeValue B.ByteString Int where
+    serialize a = LPS [inlinePerformIO (createAndTrim 12 (cshortToString a))]
+ 
+instance SerializeValue B.ByteString Double where
+    serialize a = LPS [inlinePerformIO (createAndTrim 12 (cfloatToString a))]
+
+    
+instance SerializeValue BU.Builder Word8 where
+    serialize = BU.singleton
+
+instance SerializeValue BU.Builder Char where
+    serialize = BU.singleton . c2w
+    
+instance SerializeValue BU.Builder [Char] where
+    serialize = BU.fromLazyByteString . serialize
+
+instance SerializeValue BU.Builder B.ByteString where
+    serialize = BU.fromLazyByteString
+
+instance SerializeValue BU.Builder Int where
+    serialize = BU.fromLazyByteString . serialize
+
+instance SerializeValue BU.Builder Double where
+    serialize = BU.fromLazyByteString . serialize
+
+    
diff --git a/Graphics/PDF/LowLevel/Types.hs b/Graphics/PDF/LowLevel/Types.hs
--- a/Graphics/PDF/LowLevel/Types.hs
+++ b/Graphics/PDF/LowLevel/Types.hs
@@ -12,8 +12,6 @@
 -- #hide
 module Graphics.PDF.LowLevel.Types where
 
-import qualified Data.ByteString.Lazy as B
-import Data.ByteString.Base(c2w)
 import qualified Data.Map as M
 import Data.List(intersperse)
 import Data.Int
@@ -22,12 +20,19 @@
 import Control.Monad.Writer
 
 import Data.Encoding
-import Data.Encoding.UTF8
 import Data.Encoding.ISO88591
 
+import System.Random 
+import Data.Binary.Builder(Builder,fromByteString)
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
+import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString as S
+import Data.ByteString.Base(LazyByteString(..))
+
 -- | PDF Objects
 class PdfObject a where
-  toPDF :: a -> B.ByteString
+  toPDF :: a -> Builder
 
 -- | Anonymous PDF object
 data AnyPdfObject = forall a . PdfObject a => AnyPdfObject a
@@ -50,36 +55,43 @@
   fromInteger a = PDFLength (fromInteger a)
 
 -- | A real number in a PDF document
-newtype PDFFloat = PDFFloat Double deriving(Eq,Ord,Num,Fractional,Floating,RealFrac,Real)
+newtype PDFFloat = PDFFloat Double deriving(Eq,Ord,Num,Fractional,Floating,RealFrac,Real,Random)
 
 instance Show PDFFloat where
     show (PDFFloat x) = printf "%.5f" x
 
 instance PdfObject PDFInteger where
-  toPDF (PDFInteger a) = toByteString (show a)
-  
+    toPDF (PDFInteger a) = serialize a
+
+instance PdfObject Int where
+    toPDF a = serialize a
+          
 instance PdfObject PDFLength where
-  toPDF (PDFLength a) = toByteString (show a)
+    toPDF (PDFLength a) = serialize (show a)
     
 instance PdfObject PDFFloat where
-  toPDF (PDFFloat a) = toByteString (show a)
+  toPDF (PDFFloat a) = serialize a
   
+instance PdfObject Double where
+  toPDF a = serialize a
+  
 instance PdfObject Bool where
-  toPDF (True) = toByteString "true"
-  toPDF (False) = toByteString "false"
+  toPDF (True) = serialize "true"
+  toPDF (False) = serialize "false"
 
--- | A PDFString
-newtype PDFString = PDFString B.ByteString deriving(Eq,Ord)
+-- | A PDFString containing a strict bytestring
+newtype PDFString = PDFString S.ByteString deriving(Eq,Ord,Show)
 
 -- | Create a PDF string from an Haskell one
 toPDFString :: String -> PDFString
-toPDFString = PDFString . encodeLazy ISO88591 . escapeString
+toPDFString = PDFString . encode ISO88591 . escapeString
 
--- | Convert an Haskell string to an UTF8 encoded bytestring
-toByteString :: String -> B.ByteString
---toByteString = B.pack . encode
-toByteString = encodeLazy UTF8
+instance SerializeValue B.ByteString PDFString where
+  serialize (PDFString t) = LPS [t]
 
+instance SerializeValue Builder PDFString where
+  serialize (PDFString t) = fromByteString t
+
 -- | Escape PDF characters which have a special meaning
 escapeString :: String -> String
 escapeString [] = []
@@ -90,69 +102,69 @@
 
 -- Misc strings useful to build bytestrings
 
-lparen :: B.ByteString
-lparen = B.singleton . c2w $ '('
-
-rparen :: B.ByteString
-rparen = B.singleton . c2w $ ')'
+lparen :: SerializeValue s Char => s
+lparen = serialize '('
 
-lbracket :: B.ByteString
-lbracket = B.singleton . c2w $ '['
+rparen :: SerializeValue s Char => s
+rparen = serialize  ')'
 
-rbracket :: B.ByteString
-rbracket = B.singleton . c2w $ ']'
+lbracket :: SerializeValue s Char => s
+lbracket = serialize  '['
 
-bspace :: B.ByteString
-bspace = B.singleton . c2w $ ' '
+rbracket :: SerializeValue s Char => s
+rbracket = serialize  ']'
 
-blt :: B.ByteString
-blt = B.singleton . c2w $ '<'
+bspace :: SerializeValue s Char => s
+bspace = serialize  ' '
 
-bgt :: B.ByteString
-bgt = B.singleton . c2w $ '>'
+blt :: SerializeValue s Char => s
+blt = serialize  '<'
 
-newline :: B.ByteString
-newline = B.singleton . c2w $ '\n'
+bgt :: SerializeValue s Char => s
+bgt = serialize  '>'
 
-noPdfObject :: B.ByteString
-noPdfObject = B.empty
+newline :: SerializeValue s Char => s
+newline = serialize  '\n'
 
+noPdfObject :: Monoid s => s
+noPdfObject = mempty
+    
 instance PdfObject PDFString where
-  toPDF (PDFString a) = B.concat [ lparen
-                                 ,  a
-                                 , rparen
-                                 ]
+  toPDF a = mconcat [ lparen
+                    , serialize a
+                    , rparen
+                    ]
 
 -- | A PDFName object
 newtype PDFName = PDFName String deriving(Eq,Ord)
 
 instance PdfObject PDFName where
- toPDF (PDFName a) = toByteString ("/" ++ a)
+ toPDF (PDFName a) = serialize ("/" ++ a)
  
 -- | A PDFArray
 type PDFArray = [AnyPdfObject]
 
-instance PdfObject PDFArray where
-  toPDF l = B.concat $ (lbracket:intersperse bspace (map toPDF l)) ++ [bspace] ++ [rbracket]
+instance PdfObject a => PdfObject [a] where
+    toPDF l = mconcat $ (lbracket:intersperse bspace (map toPDF l)) ++ [bspace] ++ [rbracket]
                                  
 -- | A PDFDictionary
 
 newtype PDFDictionary = PDFDictionary (M.Map PDFName AnyPdfObject)
 
 instance PdfObject PDFDictionary where
-  toPDF (PDFDictionary a) = B.concat $ [blt,blt,newline]
+  toPDF (PDFDictionary a) = mconcat $ [blt,blt,newline]
                                        ++ [convertLevel a]
                                        ++ [bgt,bgt] 
    where
-     convertLevel _ = let convertItem key value current = B.concat $ [  toPDF key
-                                                                      , bspace
-                                                                      , toPDF value
-                                                                      , newline
-                                                                      , current
-                                                                      ]
+     convertLevel _ = let convertItem key value current = mconcat $ [ toPDF key
+                                                                    , bspace
+                                                                    , toPDF value
+                                                                    , newline
+                                                                    , current
+                                                                    ]
                                                                        
           in 
-           M.foldWithKey convertItem B.empty a
+           M.foldWithKey convertItem mempty a
            
 -- | Am empty dictionary
 emptyDictionary :: PDFDictionary
@@ -180,12 +192,12 @@
 
 instance PdfObject a => PdfObject (PDFReferencedObject a) where
   toPDF (PDFReferencedObject referenceId obj) =
-    B.concat $ [ toByteString . show $ referenceId
-               , toByteString " 0 obj"
+    mconcat  $ [ serialize . show $ referenceId
+               , serialize " 0 obj"
                , newline
                , toPDF obj
                , newline
-               , toByteString "endobj"
+               , serialize "endobj"
                , newline , newline
                ]
                
@@ -205,8 +217,8 @@
   fromInteger a = PDFReference (fromInteger a)
 
 instance PdfObject s => PdfObject (PDFReference s) where
-  toPDF (PDFReference i) = B.concat $ [ toByteString . show $ i
-                                      , toByteString " 0 R"]
+  toPDF (PDFReference i) = mconcat $ [ serialize . show $ i
+                                     , serialize " 0 R"]
                                       
                                    
                
@@ -220,4 +232,4 @@
   	put $! (f s)
   	
 -- | A monad where paths can be created
-class MonadWriter B.ByteString m => MonadPath m
+class MonadWriter Builder m => MonadPath m
diff --git a/Graphics/PDF/Pages.hs b/Graphics/PDF/Pages.hs
--- a/Graphics/PDF/Pages.hs
+++ b/Graphics/PDF/Pages.hs
@@ -78,7 +78,9 @@
 createContent d page = do
   -- Create a new stream referenbce
   streamref <- supply
-  modifyStrict $ \s -> s {streams = IM.insert streamref (page,d >> return ()) (streams s)}
+  myBounds <- gets xobjectBound
+  let (_,state',w') = runDrawing d (emptyEnvironment {streamId = streamref, xobjectb = myBounds}) (emptyDrawState streamref)
+  modifyStrict $ \s -> s {streams = IM.insert streamref (page,(state',w')) (streams s)}
   return (PDFReference streamref)
 
 -- | Returns a new unique identifier
@@ -244,7 +246,7 @@
                                 (-(length c))
                                 dest
                                 (maybe (Rgb 0 0 0) id col)
-                                (maybe Normal id style)
+                                (maybe NormalOutline id style)
         updateObject current o
     
 
diff --git a/Graphics/PDF/Pattern.hs b/Graphics/PDF/Pattern.hs
--- a/Graphics/PDF/Pattern.hs
+++ b/Graphics/PDF/Pattern.hs
@@ -29,6 +29,9 @@
 import qualified Data.Map as M
 import Graphics.PDF.Pages(recordBound,createContent)
 import Control.Monad.State
+import Control.Monad.Writer
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
 
 data PaintType = ColoredTiling
                | UncoloredTiling
@@ -100,8 +103,11 @@
      patternMap <- gets patterns
      (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap
      modifyStrict $ \s -> s { patterns = newMap }
-     writeCmd ("\n/Pattern cs")
-     writeCmd ("\n/" ++ newName ++ " scn")
+     tell . serialize $ ("\n/Pattern cs")
+     tell . mconcat $[ serialize "\n/" 
+                     , serialize newName
+                     , serialize " scn"
+                     ]
      
 -- | Set the stroke pattern
 setColoredStrokePattern :: PDFReference PDFColoredPattern -> Draw ()
@@ -109,8 +115,11 @@
   patternMap <- gets patterns
   (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap
   modifyStrict $ \s -> s { patterns = newMap }
-  writeCmd ("\n/Pattern CS")
-  writeCmd ("\n/" ++ newName ++ " SCN")   
+  tell . serialize $ ("\n/Pattern CS")
+  tell . mconcat $[ serialize "\n/" 
+                  , serialize newName
+                  , serialize " SCN"
+                  ]
   
   
 
@@ -123,8 +132,21 @@
        patternMap <- gets patterns
        (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap
        modifyStrict $ \s -> s { patterns = newMap }
-       writeCmd ("\n/" ++ newColorName ++ " cs")
-       writeCmd ("\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " /" ++ newName ++ " scn")
+       tell . mconcat $[ serialize "\n/" 
+                       , serialize newColorName
+                       , serialize " cs"
+                       ]
+       tell . mconcat $[ serialize '\n'
+                       , toPDF r
+                       , serialize ' '
+                       , toPDF g
+                       , serialize ' '
+                       , toPDF b
+                       , serialize ' '
+                       , serialize " /"
+                       , serialize newName
+                       , serialize " scn"
+                       ]
 
 -- | Set the stroke pattern
 setUncoloredStrokePattern :: PDFReference PDFUncoloredPattern -> Color -> Draw ()
@@ -135,5 +157,18 @@
     patternMap <- gets patterns
     (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap
     modifyStrict $ \s -> s { patterns = newMap }
-    writeCmd ("\n/" ++ newColorName ++ " CS")
-    writeCmd ("\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " /" ++ newName ++ " SCN")
+    tell . mconcat $[ serialize "\n/" 
+                    , serialize newColorName
+                    , serialize " CS"
+                    ]
+    tell . mconcat $   [ serialize '\n'
+                       , toPDF r
+                       , serialize ' '
+                       , toPDF g
+                       , serialize ' '
+                       , toPDF b
+                       , serialize ' '
+                       , serialize " /"
+                       , serialize newName
+                       , serialize " SCN"
+                       ]
diff --git a/Graphics/PDF/Resources.hs b/Graphics/PDF/Resources.hs
--- a/Graphics/PDF/Resources.hs
+++ b/Graphics/PDF/Resources.hs
@@ -64,7 +64,7 @@
     show Symbol = "Symbol"
     show ZapfDingbats = "ZapfDingbats"
 
-data PDFFont = PDFFont FontName FontSize deriving(Eq)
+data PDFFont = PDFFont FontName FontSize deriving(Eq,Show)
 
 instance Ord PDFFont where
     compare (PDFFont na sa) (PDFFont nb sb) = if sa == sb then compare na nb else compare sa sb
diff --git a/Graphics/PDF/Shading.hs b/Graphics/PDF/Shading.hs
--- a/Graphics/PDF/Shading.hs
+++ b/Graphics/PDF/Shading.hs
@@ -20,6 +20,9 @@
 import Graphics.PDF.LowLevel.Types
 import Control.Monad.State(gets)
 import Graphics.PDF.Shapes(setAsClipPath)
+import Control.Monad.Writer
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
 
 -- | Set alpha value for transparency
 applyShading :: PDFShading -> Draw ()
@@ -27,7 +30,10 @@
     shadingMap <- gets shadings
     (newName,newMap) <- setResource "Shading" shade shadingMap
     modifyStrict $ \s -> s { shadings = newMap }
-    writeCmd ("\n/" ++ newName ++ " sh")
+    tell . mconcat $[ serialize "\n/" 
+                    , serialize newName
+                    , serialize " sh"
+                    ]
     
 paintWithShading :: PDFShading -- ^ Shading
                  -> Draw a -- ^ Shape to paint
diff --git a/Graphics/PDF/Shapes.hs b/Graphics/PDF/Shapes.hs
--- a/Graphics/PDF/Shapes.hs
+++ b/Graphics/PDF/Shapes.hs
@@ -53,7 +53,9 @@
 
 import Graphics.PDF.LowLevel.Types
 import Graphics.PDF.Draw
-import Data.List(intersperse)
+import Control.Monad.Writer
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
 
 class Shape a where
     addShape :: a -> Draw ()
@@ -148,11 +150,17 @@
 
 -- | Set pen width
 setWidth :: MonadPath m => PDFFloat -> m ()
-setWidth w = writeCmd $ "\n " ++ (show w) ++ " w"
+setWidth w = tell . mconcat $[ serialize "\n" 
+                             , toPDF w
+                             , serialize " w"
+                             ]
 
 -- | Set pen width
 setMiterLimit :: MonadPath m => PDFFloat -> m ()
-setMiterLimit w = writeCmd $ "\n " ++ (show w) ++ " M"
+setMiterLimit w = tell . mconcat $[ serialize "\n" 
+                                  , toPDF w
+                                  , serialize " M"
+                                  ]
 
 -- | Line cap styles
 data CapStyle = ButtCap
@@ -168,17 +176,29 @@
                             
 -- | Set line cap
 setLineCap :: MonadPath m => CapStyle -> m ()
-setLineCap w = writeCmd $ "\n " ++ (show . fromEnum  $ w) ++ " J"
+setLineCap w = tell . mconcat $[ serialize "\n " 
+                               , toPDF (fromEnum  w)
+                               , serialize " J"
+                               ]
 
 -- | Set line join
 setLineJoin :: MonadPath m => JoinStyle -> m ()
-setLineJoin w = writeCmd $ "\n " ++ (show . fromEnum  $ w) ++ " j"
+setLineJoin w = tell . mconcat $[ serialize "\n " 
+                                , toPDF (fromEnum  w)
+                                , serialize " j"
+                                ]
 
 data DashPattern = DashPattern ![PDFFloat] PDFFloat deriving(Eq)
 
 -- | Set the dash pattern
 setDash :: MonadPath m => DashPattern -> m()
-setDash (DashPattern a p) = writeCmd $ "\n " ++  show a ++ " " ++ (show p) ++ " d"
+setDash (DashPattern a p) = 
+    tell . mconcat$ [ serialize "\n " 
+                    , toPDF a
+                    , serialize ' '
+                    , toPDF p
+                    , serialize " d"
+                    ]
 
 -- | No dash pattern
 setNoDash :: MonadPath m => m ()
@@ -192,7 +212,7 @@
 
 -- | Close current path 
 closePath :: Draw ()
-closePath = writeCmd $ "\nh"
+closePath = tell . serialize $ "\nh"
 
 
 -- | Append a cubic Bezier curve to the current path. The curve extends 
@@ -205,25 +225,58 @@
                -> PDFFloat -- ^ x3 
                -> PDFFloat -- ^ y3
                -> Draw ()
-addBezierCubic x1 y1 x2 y2 x3 y3 = writeCmd $ "\n" ++ (concat . intersperse " ". map show $ [x1,y1,x2,y2,x3,y3]) ++ " c"
-
+addBezierCubic x1 y1 x2 y2 x3 y3 = 
+    tell . mconcat $[ serialize "\n" 
+                    , toPDF x1
+                    , serialize ' '
+                    , toPDF y1
+                    , serialize ' '
+                    , toPDF x2
+                    , serialize ' '
+                    , toPDF y2
+                    , serialize ' '
+                    , toPDF x3
+                    , serialize ' '
+                    , toPDF y3
+                    , serialize " c"
+                    ]
+                    
 -- | Move pen to a given point without drawing anything
 moveto :: PDFFloat -- ^ Horizontal coordinate
        -> PDFFloat -- ^ Vertical coordinate
        -> Draw ()
-moveto x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " m"
+moveto x y = 
+    tell . mconcat $[ serialize "\n" 
+                    , toPDF x
+                    , serialize ' '
+                    , toPDF y
+                    , serialize " m"
+                    ]
 
 -- | Draw a line from current point to the one specified by lineto
 lineto :: PDFFloat -- ^ Horizontal coordinate 
        -> PDFFloat -- ^ Vertical coordinate
        -> Draw ()
-lineto x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l s"
-
+lineto x y = 
+    tell . mconcat $[ serialize "\n" 
+                    , toPDF x
+                    , serialize ' '
+                    , toPDF y
+                    , serialize " l s"
+                    ]
+    
 -- | Add a line from current point to the one specified by lineto
 addLineToPath :: PDFFloat -- ^ Horizontal coordinate 
               -> PDFFloat -- ^ Vertical coordinate
               -> Draw ()
-addLineToPath x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l"
+addLineToPath x y = 
+    tell . mconcat $[ serialize "\n" 
+                    , toPDF x
+                    , serialize ' '
+                    , toPDF y
+                    , serialize " l"
+                    ]
+    
 
 -- | A point
 type Point = (PDFFloat,PDFFloat)
@@ -233,32 +286,32 @@
                  -> Draw ()
 addPolygonToPath l =  do
     (uncurry moveto) . head $ l
-    mapM_ (\(x,y) -> writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l") (tail l)  
+    mapM_ (\(x,y) -> addLineToPath x y) (tail l)  
     
 -- | Draw current path
 strokePath :: Draw ()             
-strokePath = writeCmd "\nS"
+strokePath = tell . serialize $ "\nS"
 
 -- | Fill current path
 fillPath :: Draw ()             
-fillPath = writeCmd "\nf"
+fillPath = tell . serialize $ "\nf"
 
 -- | Fill current path
 fillAndStrokePath :: Draw ()             
-fillAndStrokePath = writeCmd "\nB"
+fillAndStrokePath = tell . serialize $ "\nB"
 
 -- | Set clipping path
 setAsClipPathEO :: Draw ()             
-setAsClipPathEO = writeCmd "\nW* n"
+setAsClipPathEO = tell . serialize $ "\nW* n"
 
 -- | Set clipping path
 setAsClipPath :: Draw ()             
-setAsClipPath = writeCmd "\nW n"
+setAsClipPath = tell . serialize $ "\nW n"
 
 -- | Fill current path using even odd rule
 fillPathEO :: Draw ()             
-fillPathEO = writeCmd "\nf*"
+fillPathEO = tell . serialize $ "\nf*"
 
 -- | Fill current path using even odd rule
 fillAndStrokePathEO :: Draw ()             
-fillAndStrokePathEO = writeCmd "\nB*"
+fillAndStrokePathEO = tell . serialize $ "\nB*"
diff --git a/Graphics/PDF/Text.hs b/Graphics/PDF/Text.hs
--- a/Graphics/PDF/Text.hs
+++ b/Graphics/PDF/Text.hs
@@ -36,14 +36,14 @@
    , textWidth
    , getDescent
    , getHeight
-   , textBox
+   , ripText
+   , charWidth
  ) where
 
 import Graphics.PDF.LowLevel.Types
 import Graphics.PDF.Draw
 import Control.Monad.State
 import Graphics.PDF.Resources
-import qualified Data.ByteString.Lazy as B
 import Control.Monad.Writer
 import Control.Monad.Trans
 import qualified Data.Set as Set
@@ -51,11 +51,15 @@
 import Data.Word
 import Graphics.PDF.LowLevel.Kern(kerns)
 import qualified Data.Map as M(findWithDefault)
-import Graphics.PDF.Shapes
-import qualified Data.ByteString.Lazy.Char8 as B(words,unwords)
+import Data.List(foldl')
+import Data.Binary.Builder(Builder)
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
+import qualified Data.ByteString as S
+import Data.ByteString.Base(w2c,c2w)
 
 foreign import ccall "ctext.h c_getLeading" cgetLeading :: Int -> Int
-foreign import ccall "ctext.h c_getAdvance" cgetAdvance :: Int -> Word8 -> Int
+foreign import ccall "ctext.h c_getAdvance" cgetAdvance :: Int -> Int -> Int
 foreign import ccall "ctext.h c_getDescent" cgetDescent :: Int -> Int
 foreign import ccall "ctext.h c_hasKern" hasKern :: Int -> Bool
 
@@ -76,13 +80,40 @@
 getKern k = M.findWithDefault 0 k kerns
 
 textWidth :: PDFFont -> PDFString -> PDFFloat
-textWidth (PDFFont n s) (PDFString t) = let w = sum . map (cgetAdvance (fromEnum n))  . B.unpack $ t in
+textWidth (PDFFont n s) (PDFString t) = 
+ let w = foldl' (\a b -> a + cgetAdvance (fromEnum n) (fromIntegral b)) 0 . S.unpack $ t
+ in
  if hasKern (fromEnum n)
    then
-      trueSize s (w + (sum . map getKern $ [(fromEnum n,ca,cb) | (ca,cb) <- B.zip t (B.tail t)]))
+      trueSize s (w + (foldl' (\a b -> a + getKern b) 0 $ [(fromEnum n,ca,cb) | (ca,cb) <- S.zip t (S.tail t)]))
    else
       trueSize s w
+      
+charWidth :: PDFFont -> Char -> PDFFloat
+charWidth (PDFFont n s) c = let w = cgetAdvance (fromEnum n) (fromEnum c) in
+    trueSize s w
     
+c2i :: Char -> Int
+c2i = fromEnum
+      
+ripText :: PDFFont -- ^ Font
+        -> PDFString -- ^ String
+        -> [(PDFFloat,Char)] -- ^ List of chars and char width taking into account kerning
+ripText (PDFFont n s) (PDFString t) = getLetters (hasKern (fromEnum n)) . S.unpack  $ t
+  where
+      getLetters _ [] = []
+      getLetters _ [a] = [(trueSize s $ cgetAdvance (fromEnum n) (fromEnum a),w2c a)]
+      getLetters False (a:l) = (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a),w2c a) : getLetters False l
+      getLetters True (a:b:c:d:l)  | b == (c2w '/') && c == (c2w '-') = 
+                                       let k = getKern (fromEnum n,a,d)
+                                           kh = getKern (fromEnum n,a,c2w '-')
+                                           hw = cgetAdvance (fromEnum n) (c2i '-') 
+                                       in
+                                       -- We record the hyphen size + an adaptation due to the different kerning with an hyphen
+                                       (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a) + k,w2c a):(0,'/'):(trueSize s $ hw-k+kh,'-'):getLetters True (d:l)
+                                   | otherwise = (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a) + getKern (fromEnum n,a,b),w2c a) : getLetters True (b:c:d:l)
+      getLetters True (a:b:l) = (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a) + getKern (fromEnum n,a,b),w2c a) : getLetters True (b:l)
+          
 type FontState = (Set.Set FontName)
 
 data TextParameter = TextParameter { tc :: !PDFFloat
@@ -95,43 +126,15 @@
 defaultParameters :: TextParameter
 defaultParameters = TextParameter 0 0 100 0 0 (Set.empty)
 
--- | Tolerance value when text is too long. We accept to overflow a little
-tolerance :: PDFFloat
-tolerance = 0.2
-
--- | Format a text string inside a rectangle. Experimental and will be replaced by a better typesetting
--- system in a next version
-textBox :: PDFFont -- ^ Font to use
-        -> PDFString -- ^ Text to draw
-        -> Rectangle -- ^ Where to draw
-        -> Draw ()
-textBox f@(PDFFont _ size) (PDFString s) (Rectangle xa _ xb yb) = do
-    let width = xb -xa
-        ws = textWidth f (toPDFString " ")
-        getLines _ l [] = [B.unwords . reverse $ l]
-        getLines c l (h:t) = let c' = c + ws + textWidth f (PDFString h) in
-                             if c' > width + tolerance * (fromIntegral size)
-                                 then
-                                     (B.unwords . reverse $ l):getLines 0 [] (h:t)
-                                 else
-                                     getLines c' (h:l) t
-    drawText $ do
-        setFont f
-        leading $ getHeight f
-        textStart xa (yb + getDescent f)
-        startNewLine
-        mapM_ (\x -> displayText x >> startNewLine) (map PDFString . getLines 0 [] $ (B.words s))
-    
      
-     
 -- | The text monad 
-newtype PDFText a = PDFText {unText :: WriterT B.ByteString (State TextParameter) a}          
+newtype PDFText a = PDFText {unText :: WriterT Builder (State TextParameter) a}          
 #ifndef __HADDOCK__                    
-  deriving(Monad,Functor,MonadWriter B.ByteString)
+  deriving(Monad,Functor,MonadWriter Builder)
 #else
 instance Monad PDFText
 instance Functor PDFText
-instance MonadWriter B.ByteString PDFText
+instance MonadWriter Builder PDFText
 #endif
     
 instance MonadPath PDFText
@@ -154,7 +157,13 @@
 setFont :: PDFFont -> PDFText ()
 setFont (PDFFont n size) = PDFText $ do
     lift (modifyStrict $ \s -> s {fontState = Set.insert n (fontState s)})
-    writeCmd $ "\n/" ++ (show n) ++ " " ++ (show size) ++ " Tf"
+    tell . mconcat$ [ serialize "\n/" 
+                    , serialize (show n)
+                    , serialize ' '
+                    , toPDF size
+                    , serialize " Tf"
+                    ]
+                    
   
 -- | Draw a text in the draw monad
 drawText :: PDFText a
@@ -162,9 +171,9 @@
 drawText t = do
     let ((a,w),s) = (runState . runWriterT . unText $ t) defaultParameters
     mapM_ addFontRsrc (Set.elems (fontState s))
-    writeCmd "\nBT"
+    tell . serialize $ "\nBT"
     tell w
-    writeCmd "\nET"
+    tell . serialize $ "\nET"
     return a
  where
    addFontRsrc f = modifyStrict $ \s -> s { rsrc = addResource (PDFName "Font") (PDFName (show f)) (toRsrc (PDFFont f 0)) (rsrc s)}
@@ -173,59 +182,97 @@
 textStart :: PDFFloat
           -> PDFFloat
           -> PDFText ()
-textStart x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " Td"         
+textStart x y = tell . mconcat  $ [ serialize '\n'
+                                  , toPDF x
+                                  , serialize ' '
+                                  , toPDF y
+                                  , serialize " Td"
+                                  ]
+ --writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " Td"         
 
 -- | Display some text
 displayText :: PDFString
             -> PDFText ()
 displayText t = do
     tell . toPDF $ t
-    writeCmd " Tj"
+    tell . serialize $ " Tj"
 
  
 -- | Start a new line (leading value must have been set)
 startNewLine :: PDFText ()
-startNewLine = writeCmd "\nT*"    
+startNewLine = tell . serialize $ "\nT*"    
 
 -- | Set leading value
 leading :: UnscaledUnit -> PDFText ()
 leading v = PDFText $ do
     lift (modifyStrict $ \s -> s {tl = v})
-    writeCmd $ "\n" ++ (show v) ++ " TL"
+    tell . mconcat $  [ serialize '\n'
+                      , toPDF v
+                      , serialize " TL"
+                      ]
 
 -- | Set the additional char space
 charSpace :: UnscaledUnit -> PDFText ()
 charSpace v = PDFText $ do
     lift (modifyStrict $ \s -> s {tc = v})
-    writeCmd $ "\n" ++ (show v) ++ " Tc"
+    tell . mconcat  $ [ serialize '\n'
+                      , toPDF v
+                      , serialize " Tc"
+                      ]
 
 -- | Set the additional word space
 wordSpace :: UnscaledUnit -> PDFText ()
 wordSpace v = PDFText $ do
     lift (modifyStrict $ \s -> s {tw = v})
-    writeCmd $ "\n" ++ (show v) ++ " Tw"
+    tell . mconcat $ [ serialize '\n'
+                      , toPDF v
+                      , serialize " Tw"
+                      ]
 
 -- | Set scaling factor for text
 textScale :: PDFFloat -> PDFText ()
 textScale v = PDFText $ do
     lift (modifyStrict $ \s -> s {tz = v})
-    writeCmd $ "\n" ++ (show v) ++ " Tz"
+    tell . mconcat  $ [ serialize '\n'
+                      , toPDF v
+                      , serialize " Tz"
+                      ]
 
 -- | Choose the text rendering mode
 renderMode :: TextMode -> PDFText ()
-renderMode v = writeCmd $ "\n" ++ (show . fromEnum $ v) ++ " Tr"
+renderMode v = 
+    tell . mconcat $  [ serialize '\n'
+                      , toPDF (fromEnum v)
+                      , serialize " Tr"
+                      ]
 
 -- | Set the rise value
 rise :: UnscaledUnit -> PDFText ()
 rise v = PDFText $ do
     lift (modifyStrict $ \s -> s {ts = v})
-    writeCmd $ "\n" ++ (show v) ++ " Ts"
+    tell . mconcat $  [ serialize '\n'
+                      , toPDF v
+                      , serialize " Ts"
+                      ]
 
 -- | Set the text transformation matrix
 setTextMatrix :: Matrix -> PDFText()
 setTextMatrix (Matrix a b c d e f) = 
-    writeCmd $ "\n" ++ show (a) ++ " " ++ show (b) ++ " " ++ show (c) ++ " " ++ show (d) ++ " " ++ show (e) ++ " " ++ show (f) ++ " Tm"
-
+    tell . mconcat $[ serialize '\n'
+                    , toPDF a
+                    , serialize ' '
+                    , toPDF b
+                    , serialize ' '
+                    , toPDF c
+                    , serialize ' '
+                    , toPDF d
+                    , serialize ' '
+                    , toPDF e
+                    , serialize ' '
+                    , toPDF f
+                    , serialize " Tm"
+                    ]
+    
 -- | Utility function to quickly display one line of text
 text :: PDFFont
      -> PDFFloat
diff --git a/Graphics/PDF/Typesetting.hs b/Graphics/PDF/Typesetting.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/PDF/Typesetting.hs
@@ -0,0 +1,326 @@
+---------------------------------------------------------
+-- |
+-- Copyright   : (c) alpha 2007
+-- License     : BSD-style
+--
+-- Maintainer  : misc@NOSPAMalpheccar.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Experimental typesetting. It is a work in progress
+---------------------------------------------------------
+
+module Graphics.PDF.Typesetting(
+  -- * Typesetting
+  -- ** Types
+    Box(..)
+  , DisplayableBox(..)
+  , Style(..)
+  , TextStyle(..)
+  , StyleFunction(..)
+  , AnyStyle
+  , ParagraphStyle(..)
+  , AnyParagraphStyle
+  , MonadStyle(..)
+  , Letter(..)
+  , BoxDimension
+  -- * Functions
+  -- ** Text display
+  , displayFormattedText
+  -- ** Text construction operators
+  , endParagraph
+  , txt
+  , paragraph
+  -- * Paragraph construction operators
+  , kern
+  , addPenalty
+--  , nullChar
+  , mkLetter
+  -- * Misc
+  , mkDrawBox
+  -- * Settings (similar to TeX ones)
+  -- ** Line breaking settings
+  , setFirstPassTolerance 
+  , setSecondPassTolerance
+  , setHyphenPenaltyValue 
+  , setFitnessDemerit
+  , setHyphenDemerit
+  , setLinePenalty
+  , getFirstPassTolerance 
+  , getSecondPassTolerance
+  , getHyphenPenaltyValue 
+  , getFitnessDemerit
+  , getHyphenDemerit
+  , getLinePenalty
+  -- ** Vertical mode settings
+  , setBaseLineSkip
+  , setLineSkipLimit
+  , setLineSkip
+  , getBaseLineSkip
+  , getLineSkipLimit
+  , getLineSkip
+  -- * Styles
+  -- ** Functions useful to change the paragraph style
+  , getParaStyle
+  , setParaStyle
+  , getTextArea
+  ) where
+  
+import Graphics.PDF.LowLevel.Types
+import Graphics.PDF.Text
+import Graphics.PDF.Draw
+import Graphics.PDF.Shapes
+import Control.Monad.RWS
+import Graphics.PDF.Typesetting.Breaking
+import Graphics.PDF.Typesetting.Vertical
+import Graphics.PDF.Typesetting.Box
+
+-- | Display a formatted text in a given bounding rectangle with a given default paragraph style, a given default text style. No clipping
+-- is taking place. Drawing stop when the last line is crossing the bounding rectangle in vertical direction
+displayFormattedText :: (Style s, ParagraphStyle s') => Rectangle -- ^ Text area
+                     -> s' -- ^ default vertical style
+                     -> s -- ^ Default horizontal style
+                     -> TM a -- ^ Typesetting monad
+                     -> Draw a -- ^ Draw monad
+displayFormattedText area@(Rectangle xa y' _ y'') defaultVStyle defaultHStyle t  = 
+    do
+    --withNewContext $ do
+    --    addShape $ Rectangle (xa-1) y' (xb+1) y''
+    --    closePath
+    --    setAsClipPath
+        let (a, s', boxes) = (runRWS . unTM $ t >>= \x' -> do {return x'} ) area (defaultTmState defaultVStyle defaultHStyle)
+        strokeVBoxes (verticalPostProcess (pageSettings s') 0 area boxes) (xa,y',y'')
+        return a
+ 
+--endParagraphBoxes :: [Letter]  
+--endParagraphBoxes = [glueBox Nothing 0 10000.0 0,penalty (-infinity)]
+
+-- | Add a penalty
+addPenalty :: Int -> Para()
+addPenalty f = tell $ [penalty f]
+  
+-- | End the current paragraph with or without using the same style
+endParagraph :: Bool -- ^ True if we use the same style to end a paragraph. false for an invisible style
+             -> Para ()
+endParagraph r = do
+    if r
+        then
+            glue 0 10000.0 0
+        else
+            tell $ [glueBox Nothing 0 10000.0 0]
+    addPenalty (-infinity)
+    
+-- | Get the bounding rectangle containing the text
+getTextArea :: TM Rectangle
+getTextArea = ask
+
+defaultTmState :: (Style s, ParagraphStyle s') => s' -> s -> TMState
+defaultTmState s' s = TMState { tmStyle = AnyStyle s
+                              , paraSettings = defaultBreakingSettings
+                              , pageSettings = defaultVerState s'
+                              }
+    
+data TMState = TMState { tmStyle :: !AnyStyle
+                       , paraSettings :: !BRState
+                       , pageSettings :: !VerState
+                       }
+                       
+newtype TM a = TM { unTM :: RWS Rectangle [VBox] TMState a} 
+#ifndef __HADDOCK__
+  deriving(Monad,MonadWriter [VBox], MonadState TMState, MonadReader Rectangle, Functor)
+#else
+instance Monad TM
+instance MonadWriter [VBox] TM
+instance MonadState TMState TM
+instance Functor TM
+instance MonadReader Rectangle TM
+#endif
+
+newtype Para a = Para { unPara :: RWS BRState [Letter] AnyStyle a} 
+#ifndef __HADDOCK__
+  deriving(Monad,MonadWriter [Letter], MonadReader BRState, MonadState AnyStyle, Functor)
+#else
+instance Monad Para
+instance MonadWriter [Letter] Para
+instance MonadState AnyStyle Para
+instance Functor Para
+instance MonadReader BRState Para
+#endif
+
+-- | A MonadStyle where some typesetting operators can be used
+class Monad m => MonadStyle m where
+    -- | Set the current text style
+    setStyle :: Style a => a -> m ()
+    
+    -- | Get the current text style
+    currentStyle :: m AnyStyle
+    
+    -- | Add a box using the current mode (horizontal or vertical. The current style is always applied to the added box)
+    addBox :: (Show a, DisplayableBox a, Box a) => a 
+           -> PDFFloat -- ^ Width
+           -> PDFFloat -- ^ Height
+           -> PDFFloat -- ^ Descent
+           -> m ()
+    
+    -- | Add a glue using the current style
+    glue :: PDFFloat -- ^ Size of glue (width or height depending on the mode)
+         -> PDFFloat -- ^ Dilatation factor
+         -> PDFFloat -- ^ Compression factor
+         -> m ()
+    
+    -- | Add a glue with no style (it is just a translation)
+    unstyledGlue :: PDFFloat -- ^ Size of glue (width or height depending on the mode) 
+                 -> PDFFloat -- ^ Dilatation factor 
+                 -> PDFFloat -- ^ Compression factor 
+                 -> m ()
+    
+    
+instance MonadStyle TM where
+    --  Set style of text
+    setStyle f = modifyStrict $ \s -> s {tmStyle = AnyStyle f}
+
+    --  Get current text style
+    currentStyle = gets tmStyle
+    
+    --  Add a box to the stream in vertical mode
+    addBox a w h d = do
+        style <- getParaStyle
+        tell $ ([SomeVBox 0 (w,h,d) (AnyBox a) (Just style)])
+    
+    --  Add a glue
+    glue h y z = do
+        style <- getParaStyle
+        Rectangle xa _ xb _ <- getTextArea
+        tell $ [vglue (Just style) h y z (xb-xa) 0]
+        
+    --  Add a glue
+    unstyledGlue h y z = do
+        Rectangle xa _ xb _ <- getTextArea
+        tell $ [vglue Nothing h y z (xb-xa) 0]
+    
+instance MonadStyle Para where
+    --  Set style of text
+    setStyle f = put $! AnyStyle f
+
+    --  Get current text style
+    currentStyle = get
+        
+    --  Add a box to the stream in horizontal mode
+    addBox a w h d = do
+        f <- currentStyle
+        addLetter . mkLetter (w,h,d) (Just f) $ a
+    
+    --  Add a glue
+    glue w y z = do
+        f <- currentStyle
+        tell $ [glueBox (Just f) w y z]
+        
+    --  Add a glue
+    unstyledGlue w y z = do
+        tell $ [glueBox Nothing w y z]
+    
+-- | Run a paragraph. Style changes are local to the paragraph
+runPara :: Para a -> TM a
+runPara m = do
+    TMState f settings pagesettings <- get
+    let (a, s', boxes) = (runRWS . unPara $ closedPara ) settings f
+    put $! TMState s' settings pagesettings
+    style <- getParaStyle
+    tell $ [Paragraph boxes (Just style) settings]
+    return a
+ where
+    closedPara = do
+        x <- m
+        endParagraph False
+        return x
+    
+-- | Get the current paragraph style
+getParaStyle :: TM AnyParagraphStyle
+getParaStyle = gets pageSettings >>= TM . return . paraStyle
+
+-- | Change the current paragraph style
+setParaStyle :: ParagraphStyle s => s -> TM ()
+setParaStyle style = do
+    modifyStrict $ \s -> s {pageSettings = (pageSettings s){paraStyle = AnyParagraphStyle style}}
+
+-- | Add a letter to the paragraph
+addLetter :: Letter -> Para ()
+addLetter l = Para . tell $ [l]
+
+-- | Add a new paragraph to the text
+paragraph :: Para a -> TM a
+paragraph = runPara
+
+-- | Add a null char
+--nullChar :: Para ()
+--nullChar = Para . tell $ [nullLetter]
+    
+-- | Add a text line
+txt :: String -> Para ()
+txt t = do
+    f <- currentStyle
+    settings <- ask
+    tell $ splitText settings f (toPDFString t)
+
+-- | add a kern (space that can be dilated or compressed and on which no line breaking can occur)
+kern :: PDFFloat -> Para()
+kern w  = do
+    f <- currentStyle
+    tell $ [kernBox f w]
+
+setBaseLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()
+setBaseLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){baselineskip = (w,y,z)}}
+ 
+getBaseLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)
+getBaseLineSkip = do
+    s <- gets pageSettings
+    return (baselineskip s)
+    
+setLineSkipLimit :: PDFFloat  -> TM ()
+setLineSkipLimit l = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskiplimit=l}}
+
+getLineSkipLimit :: TM PDFFloat
+getLineSkipLimit = gets pageSettings >>= return . lineskiplimit
+
+setLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()
+setLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskip = (w,y,z)}}
+
+getLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)
+getLineSkip = gets pageSettings >>= return . lineskip
+    
+setFirstPassTolerance :: PDFFloat -> TM ()
+setFirstPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){firstPassTolerance = x}}
+
+getFirstPassTolerance :: TM PDFFloat
+getFirstPassTolerance = gets paraSettings >>= return . firstPassTolerance
+
+setSecondPassTolerance :: PDFFloat -> TM ()
+setSecondPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){secondPassTolerance = x}}
+
+getSecondPassTolerance :: TM PDFFloat
+getSecondPassTolerance = gets paraSettings >>= return . secondPassTolerance
+
+setHyphenPenaltyValue :: Int -> TM ()
+setHyphenPenaltyValue x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){hyphenPenaltyValue = x}}
+
+getHyphenPenaltyValue :: TM Int
+getHyphenPenaltyValue = gets paraSettings >>= return . hyphenPenaltyValue
+
+setFitnessDemerit :: PDFFloat -> TM ()
+setFitnessDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){fitness_demerit = x}}
+
+getFitnessDemerit :: TM PDFFloat
+getFitnessDemerit = gets paraSettings >>= return . fitness_demerit
+
+setHyphenDemerit :: PDFFloat -> TM ()
+setHyphenDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){flagged_demerit = x}}
+
+getHyphenDemerit :: TM PDFFloat
+getHyphenDemerit = gets paraSettings >>= return . flagged_demerit
+  
+setLinePenalty :: PDFFloat -> TM ()
+setLinePenalty x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){line_penalty = x}}
+                   
+getLinePenalty :: TM PDFFloat
+getLinePenalty = gets paraSettings >>= return . line_penalty
+
diff --git a/Graphics/PDF/Typesetting/Box.hs b/Graphics/PDF/Typesetting/Box.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/PDF/Typesetting/Box.hs
@@ -0,0 +1,173 @@
+---------------------------------------------------------
+-- |
+-- Copyright   : (c) alpha 2006
+-- License     : BSD-style
+--
+-- Maintainer  : misc@NOSPAMalpheccar.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Box
+---------------------------------------------------------
+-- #hide
+module Graphics.PDF.Typesetting.Box (
+    Box(..)
+  , DisplayableBox(..)
+  , AnyBox(..)
+  , NullChar(..)
+  , Overfull(..)
+  , Style(..)
+  , TextStyle(..)
+  , StyleFunction(..)
+  , AnyStyle(..)
+  , BoxDimension
+  , DrawBox
+   ,mkDrawBox
+ ) where
+     
+import Graphics.PDF.LowLevel.Types
+import Graphics.PDF.Draw
+import Graphics.PDF.Text
+import Graphics.PDF.Shapes
+import Graphics.PDF.Coordinates
+
+-- | Make a drawing box. A box object containing a Draw value
+mkDrawBox :: Draw () -> DrawBox
+mkDrawBox d = DrawBox d
+
+-- | A box containing a Draw value
+newtype DrawBox = DrawBox (Draw())
+
+instance Box DrawBox where
+    boxWidth _ = 0
+    boxHeight _ = 0
+    boxDescent _ = 0
+    
+instance DisplayableBox DrawBox where
+    strokeBox (DrawBox a) x y = do
+        withNewContext $ do
+            applyMatrix $ translate x y
+            a
+    
+instance Show DrawBox where
+    show _ = "DrawBox"
+
+-- | Dimension of a box : width, height and descent
+type BoxDimension = (PDFFloat,PDFFloat,PDFFloat)
+
+-- | Text style used by PDF operators
+data TextStyle = TextStyle { textFont :: !PDFFont
+                           , textStrokeColor :: !Color
+                           , textFillColor :: !Color
+                           , textMode :: !TextMode
+                           , penWidth :: !PDFFloat
+                           , scaleSpace :: !PDFFloat -- ^ Scaling factor for normal space size (scale also the dilation and compression factors)
+                           , scaleDilatation :: !PDFFloat -- ^ Scale the dilation factor of glues
+                           , scaleCompression :: !PDFFloat -- ^ Scale the compression factor of glues
+                           }
+                           deriving(Eq)
+             
+-- | What kind of style drawing function is required for a word
+-- when word styling is enabled              
+data StyleFunction = DrawWord -- ^ Must style a word
+                   | DrawGlue -- ^ Must style a glue
+                   deriving(Eq)                          
+                  
+-- | Style of text  (sentences and words)       
+class Style a where
+    -- ^ Modify the look of a sentence (sequence of words using the same style on a line)
+    sentenceStyle :: a -- ^ The style
+                  -> Maybe (Rectangle -> Draw b -> Draw ()) -- ^ Function receiving the bounding rectangle and the command for drawing the sentence
+    sentenceStyle _ = Nothing
+    -- ^ Modify the look of a word
+    wordStyle :: a -- ^ The style
+              -> Maybe (Rectangle -> StyleFunction -> Draw b -> Draw ()) -- ^ Word styling function
+    wordStyle _ = Nothing
+    textStyle :: a -> TextStyle
+    -- | All styles used in a document must have different style codes
+    styleCode :: a -> Int
+    -- | A style may contain data changed from word to word
+    updateStyle :: a -> a
+    updateStyle = id
+    
+    -- | A style may change the height of words
+    styleHeight :: a -> PDFFloat
+    
+    -- | A style may change the descent of lines
+    styleDescent :: a -> PDFFloat
+    styleHeight = getHeight . textFont . textStyle 
+    styleDescent = getDescent . textFont . textStyle 
+    
+-- | Any sentence style
+data AnyStyle = forall a. (Style a) => AnyStyle a
+
+instance Style AnyStyle where
+    sentenceStyle (AnyStyle a) = sentenceStyle a
+    wordStyle (AnyStyle a) = wordStyle a
+    textStyle (AnyStyle a) = textStyle a
+    styleCode (AnyStyle a) = styleCode a
+    updateStyle (AnyStyle a) = AnyStyle $ updateStyle a
+    styleHeight (AnyStyle a) = styleHeight a
+    styleDescent (AnyStyle a) = styleDescent a
+
+
+
+-- | A box is an object with dimensions and used in the typesetting process
+class Box a where
+     -- | Box width
+     boxWidth :: a -- ^ Box
+              -> PDFFloat -- ^ Width of the box
+              
+     -- | Box height
+     boxHeight :: a -> PDFFloat
+     -- | Distance between box bottom and box baseline
+     boxDescent :: a -> PDFFloat
+     -- | Distance between box top and box baseline
+     boxAscent :: a -> PDFFloat
+     boxAscent a = boxHeight a - boxDescent a
+     
+instance Box BoxDimension where
+    boxWidth (w,_,_) = w
+    boxHeight (_,h,_) = h
+    boxDescent (_,_,d) = d
+
+-- | A box that can be displayed
+class DisplayableBox a where
+     -- | Draw a box
+     strokeBox :: a -- ^ The box
+               -> PDFFloat -- ^ Horizontal position
+               -> PDFFloat -- ^ Vertical position (top of the box and NOT baseline)
+               -> Draw ()
+
+data NullChar = NullChar deriving(Show)
+data Overfull = Overfull AnyStyle
+
+instance Box NullChar where
+    boxWidth _  = 0
+    boxHeight _ = 0
+    boxDescent _ = 0
+    
+instance DisplayableBox NullChar where
+    strokeBox _ _ _ = return ()
+    
+instance Box Overfull where
+    boxWidth _  = 0
+    boxHeight (Overfull s) = getHeight (textFont . textStyle $ s)
+    boxDescent (Overfull s) = getDescent (textFont . textStyle $ s)
+    
+instance DisplayableBox Overfull where
+    strokeBox a x y  = do
+        stroke $ Line (x+2) (y - boxDescent a) (x+2) (y - boxDescent a + boxHeight a)
+    
+instance Box AnyBox where
+    boxWidth (AnyBox a)  = boxWidth a
+    boxHeight (AnyBox a) = boxHeight a
+    boxDescent (AnyBox a) = boxDescent a
+
+instance DisplayableBox AnyBox where
+    strokeBox (AnyBox a)  = strokeBox a
+  
+instance Show AnyBox where
+    show (AnyBox a)  = show a
+    
+data AnyBox = forall a. (Show a,Box a, DisplayableBox a) => AnyBox a
diff --git a/Graphics/PDF/Typesetting/Breaking.hs b/Graphics/PDF/Typesetting/Breaking.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/PDF/Typesetting/Breaking.hs
@@ -0,0 +1,526 @@
+---------------------------------------------------------
+-- |
+-- Copyright   : (c) alpha 2006
+-- License     : BSD-style
+--
+-- Maintainer  : misc@NOSPAMalpheccar.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Breaking algorithm used to split a paragraph into lines
+-- or a text into pages
+---------------------------------------------------------
+-- #hide
+module Graphics.PDF.Typesetting.Breaking (
+   Letter(..)
+ , formatList
+ , infinity
+ , createChar
+ , kernBox
+ , glueBox
+ , penalty
+ , spaceGlueBox
+ , nullLetter
+ , hyphenPenalty
+ , splitText
+ , MaybeGlue(..)
+ , defaultBreakingSettings
+ , BRState(..)
+ , glueWidth
+ , mkLetter
+ ) where
+     
+import Graphics.PDF.LowLevel.Types
+import Data.List(minimumBy)  
+import qualified Data.Map as Map
+import Graphics.PDF.Text
+import Graphics.PDF.Typesetting.Box
+import Data.Maybe(fromJust)
+
+-- | Create a null box
+nullLetter :: Letter
+nullLetter = mkLetter (0,0,0) Nothing NullChar
+
+-- | Make a letter from any box
+mkLetter :: (Show a, Box a, DisplayableBox a) => BoxDimension -- ^ Dimension of the box
+         -> Maybe AnyStyle -- ^ Text style of the box (can use t)
+         -> a  -- ^ Box
+         -> Letter
+mkLetter d s a = Letter d (AnyBox a) s
+
+-- | A letter which can be anything. Sizes are widths and for glue the dilation and compression factors
+-- For the generic letter, height and descent are also provided
+data Letter  = Letter BoxDimension !AnyBox !(Maybe AnyStyle) -- ^ Any box as a letter
+             | Glue !PDFFloat !PDFFloat !PDFFloat !(Maybe AnyStyle) -- ^ A glue with style to know if it is part of the same sentence
+             | FlaggedPenalty !PDFFloat !Int !AnyStyle -- ^ Hyphen point
+             | Penalty !Int -- ^ Penalty
+             | AChar !AnyStyle !Char !PDFFloat -- ^ A char
+             | Kern !PDFFloat !(Maybe AnyStyle) -- ^ A kern : non dilatable and non breakable glue
+             
+class MaybeGlue a where
+    boxWidthWithRatio :: a -> PDFFloat -> PDFFloat
+    
+instance MaybeGlue Letter where
+    boxWidthWithRatio = letterWidth
+           
+-- | Compute glue width with dilation
+glueWidth :: PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat
+glueWidth w y z r =   
+          if r >= 0 
+              then
+                  r*y + w
+              else
+                  r*z + w
+                  
+letterWidth :: Letter -- ^ letter
+            -> PDFFloat -- ^ Adjustement ratio
+            -> PDFFloat -- ^ Width
+letterWidth (AChar _ _ w) _ = w
+letterWidth (Letter dim _ _) _ = boxWidth dim
+letterWidth (Glue w yi zi _) r =  glueWidth w yi zi r
+letterWidth (FlaggedPenalty _ _ _) _ = 0
+letterWidth (Penalty _) _ = 0
+letterWidth (Kern w _) _ = w
+             
+instance Show Letter where
+   show (Letter _ a _) = "(Letter " ++ show a ++ ")"
+   show (Glue a b c _) = "(Glue " ++ show a ++ " " ++ show b ++ " " ++ show c ++ ")"
+   show (FlaggedPenalty a b _) = "(FlaggedPenalty " ++ show a ++ " " ++ show b ++  ")"
+   show (Penalty a) = "(Penalty " ++ show a ++ ")"
+   show (AChar _ t _) = "(Text " ++ show t ++ ")"
+   show (Kern _ _) = "(Kern)"
+
+type CB a = (PDFFloat,PDFFloat,PDFFloat,Int,a)
+
+
+class PointedBox a where
+    isFlagged :: a -> Bool
+    getPenalty :: a -> Int
+    isPenalty :: a -> Bool
+    letter :: a -> Letter
+    position :: a -> Int
+    cumulatedW :: a -> PDFFloat
+    cumulatedY :: a -> PDFFloat
+    cumulatedZ :: a -> PDFFloat
+    isForcedBreak :: a -> Bool
+    
+instance PointedBox (PDFFloat,PDFFloat,PDFFloat,Int,Letter)  where
+    isFlagged (_,_,_,_,FlaggedPenalty _ _ _) = True    
+    isFlagged _ = False
+    isPenalty (_,_,_,_,FlaggedPenalty _ _ _) = True    
+    isPenalty (_,_,_,_,Penalty _) = True    
+    isPenalty _ = False
+    getPenalty (_,_,_,_,FlaggedPenalty _ p _) = p
+    getPenalty (_,_,_,_,Penalty p) = p
+    getPenalty _ = 0
+    letter (_,_,_,_,a) = a
+    position (_,_,_,p,_) = p
+    cumulatedW (w,_,_,_,_) = w
+    cumulatedY (_,y,_,_,_) = y
+    cumulatedZ (_,_,z,_,_) = z
+    isForcedBreak (_,_,_,_,FlaggedPenalty _ p _) = p <= (-infinity)
+    isForcedBreak (_,_,_,_,Penalty p) = p <= (-infinity)
+    isForcedBreak _ = False
+    
+    
+instance PointedBox ZList where
+    isPenalty (ZList _ b _) = isPenalty b
+    isFlagged (ZList _ b _) = isFlagged b
+    letter (ZList _ b _) = letter b
+    position (ZList _ b _) = position b
+    cumulatedW (ZList _ b _) = cumulatedW b
+    cumulatedY (ZList _ b _) = cumulatedY b
+    cumulatedZ (ZList _ b _) = cumulatedZ b
+    getPenalty (ZList _ b _) = getPenalty b
+    isForcedBreak (ZList _ b _) = isForcedBreak b
+    
+-- A penalty has no width unless you break on it so it needs a special processing
+penaltyWidth :: Letter  -> PDFFloat
+penaltyWidth (FlaggedPenalty w _ _) = w
+penaltyWidth _ = 0
+
+data BreakNode  = 
+                 BreakNode  { totalWidth :: !PDFFloat
+                            , totalDilatation :: !PDFFloat
+                            , totalCompression :: !PDFFloat
+                            , demerit :: !PDFFloat
+                            , flagged :: !Bool
+                            , fitnessValue :: !Int
+                            , ratio :: !PDFFloat
+                            , previous :: Maybe (Int,Int,Int,BreakNode)
+                            }
+                            deriving(Show)
+                            
+adjustRatio :: BreakNode
+            -> ZList
+            -> PDFFloat
+            -> PDFFloat
+adjustRatio a l maxw = 
+    let w = cumulatedW l - totalWidth a + penaltyWidth (letter l)
+        y = cumulatedY l - totalDilatation a
+        z = cumulatedZ l - totalCompression a
+    in
+  if w == maxw 
+    then 0.0
+    else if w < maxw
+      then
+          if y > 0.0 then  ((maxw - w) / y) else bigAdjustRatio
+      else
+          if z > 0.0 then  ((maxw - w) / z) else bigAdjustRatio
+
+badness :: PDFFloat -> PDFFloat
+badness r = if r < (-1) then bigAdjustRatio else 100.0 * abs(r)**3.0
+
+fitness ::  PDFFloat -> Int
+fitness r = 
+ if   r < (-0.5)
+  then 
+      0
+  else if r <= (-0.5)
+      then
+          1
+      else
+          if r <= 1 
+              then
+                  2
+              else
+                  3
+                 
+-- | Breaking algorithm settings 
+data BRState = BRState { firstPassTolerance :: !PDFFloat -- ^ Default value 100
+                       , secondPassTolerance :: !PDFFloat -- ^ Default value 200
+                       , hyphenPenaltyValue :: !Int -- ^ Default value 50
+                       , fitness_demerit :: !PDFFloat -- ^ Default value 10000
+                       , flagged_demerit :: !PDFFloat -- ^ Default value 10000
+                       , line_penalty :: !PDFFloat -- ^ Default value 10
+                       }
+                       
+defaultBreakingSettings :: BRState
+defaultBreakingSettings = BRState 100 200 50 10000 10000 10
+                  
+
+
+computeDemerit :: BRState
+               -> Bool
+               -> PDFFloat -- ^ adjust ratio
+               -> BreakNode -- ^ Flag for previous
+               -> ZList -- ^ Flag for current
+               -> Maybe(PDFFloat,Int) -- ^ Demerit for the breakpoint
+computeDemerit settings sndPass r a z =
+    let b = badness r
+        p = getPenalty z 
+        fitness' = fitness r
+        tolerance = if sndPass then (secondPassTolerance settings) else (firstPassTolerance settings)
+        in
+    if (b <= tolerance) || sndPass
+        then 
+            let fld = if isFlagged z && (flagged a) then (flagged_demerit settings) else 0.0
+                fid = if fitness' /= (fitnessValue a) then (fitness_demerit settings) else 0.0
+                dem = max 1000.0 $ if p >= 0
+                            then
+                                fid + fld + ((line_penalty settings) + b) ** 2.0 + (fromIntegral p) ** 2.0
+                            else if p < 0 && p > (-infinity)
+                                then
+                                    fid + fld + ((line_penalty settings) + b) ** 2.0 - (fromIntegral p)**2.0
+                                else
+                                    fid + fld + ((line_penalty settings) + b) ** 2.0
+            in
+               Just (dem,fitness')
+        else
+             Nothing    
+
+data MaybeCB a = NoCB 
+               | OneCB !(CB a)
+               deriving(Show)
+
+data ZList = ZList (MaybeCB Letter) (PDFFloat,PDFFloat,PDFFloat,Int,Letter) [Letter] deriving(Show)
+
+
+createZList :: [Letter] -> ZList
+createZList [] = error "List cannot be empty to create a zipper"
+createZList l = ZList NoCB (0,0,0,1,head l) (tail l)
+
+theEnd :: ZList -> Bool
+theEnd (ZList _ _ []) = True
+theEnd _ = False
+
+-- | We create a new breakpoint but we get the cumulated dimensions only at the next box following the break
+-- since glues and penalties are removed at the beginning of a line
+createBreaknode :: Maybe (Int,Int,Int,BreakNode) -> ZList -> BreakNode
+createBreaknode prev (ZList _ (w,y,z,_,FlaggedPenalty _ _ _) []) = BreakNode (w) (y) (z) 0.0 True 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,Penalty _) []) = BreakNode w (y) (z) 0.0 False 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,Glue w' y' z' _) []) = BreakNode (w + w') (y+y') (z+z') 0.0 False 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,a) []) = BreakNode (w + boxWidthWithRatio a 0.0) (y) (z) 0.0 False 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,FlaggedPenalty _ p _) _) | p <= infinity = BreakNode w y z 0.0 True 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,Penalty p) _) | p <= infinity = BreakNode w y z 0.0 False 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,Letter _ _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,AChar _ _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev 
+createBreaknode prev (ZList _ (w,y,z,_,Kern _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev 
+createBreaknode prev z = createBreaknode prev (moveRight z)
+
+-- | Create an hyphen penalty
+hyphenPenalty :: BRState
+              -> AnyStyle -- ^ Style of future hyphen
+              -> PDFFloat -- ^ Size of hyphen taking into account the kerning that was perturbed by the hyphen introduction. The char before the hyphen is now bigger
+              -> Letter
+hyphenPenalty settings s w = FlaggedPenalty w (hyphenPenaltyValue settings) s
+
+moveRight :: ZList -> ZList
+moveRight (ZList _ c@(w,y,z,p,Glue w' y' z' _) r) = 
+    let w'' = w + w'
+        y''=y+y'
+        z''=z+z'
+    in
+    ZList (OneCB c) (w'',y'',z'',p+1,head r) (tail r)
+moveRight (ZList _ c@(w,y,z,p,a) r) = 
+        let w' = boxWidthWithRatio a 0.0
+            w'' = w + w'
+        in
+        ZList (OneCB c) (w'',y,z,p+1,head r) (tail r)
+
+isFeasibleBreakpoint :: Bool -- ^ Second pass
+                     -> ZList -- ^ Current analyzed box
+                     -> Bool -- ^ Result
+isFeasibleBreakpoint True (ZList _ (_,_,_,_,FlaggedPenalty _ p _) _) = p < infinity
+isFeasibleBreakpoint False (ZList _ (_,_,_,_,FlaggedPenalty _ _ _) _) = False
+isFeasibleBreakpoint _ (ZList _ (_,_,_,_,Penalty p) _) = p < infinity
+isFeasibleBreakpoint _ (ZList NoCB _ _) = False
+isFeasibleBreakpoint _ (ZList (OneCB (_,_,_,_,Letter _ _ _)) (_,_,_,_,Glue _ _ _ _) _) = True
+isFeasibleBreakpoint _ (ZList (OneCB (_,_,_,_,AChar _ _ _)) (_,_,_,_,Glue _ _ _ _) _) = True
+isFeasibleBreakpoint _ _ = False
+
+
+
+
+-- Update a feasible breakpoint remembering only the best one
+type PossibleBreak = ActiveNodes -- Line, demerit and break node
+type ActiveNodes  = Map.Map (Int,Int,Int) BreakNode
+
+updateBreak :: BreakNode
+            -> BreakNode
+            -> BreakNode
+updateBreak a b = if demerit a < demerit b then a else b  
+
+-- | Check is a break point is possible
+-- otherwise, if none is possible and there is only one remaining active point,
+-- we force a breakpoint
+updateWithNewRIfNoSolution :: Bool
+                           -> PDFFloat -- ^ Old r
+                           -> ZList -- ^ Current
+                           -> (Int,Int,Int)
+                           -> PossibleBreak
+                           -> ActiveNodes-- ^ Actives
+                           -> (PDFFloat -> ActiveNodes -> (PossibleBreak,ActiveNodes))
+                           -> (PossibleBreak,ActiveNodes)
+updateWithNewRIfNoSolution sndPass r z key newbreak newmap f =
+        if r < -1 
+             then 
+                 --if Map.size newmap > 1 then (newbreak,Map.delete key newmap) else f (-0.99) (Map.delete key newmap)
+                 if sndPass 
+                     then
+                         f (-0.99) (Map.delete key newmap)
+                     else
+                         (newbreak,Map.delete key newmap)
+             else if isForcedBreak z
+                    then
+                        f r (Map.delete key newmap)
+                    else
+                        f r newmap                  
+
+getNewActiveBreakpoints ::  BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> (PossibleBreak,ActiveNodes)
+getNewActiveBreakpoints settings sndPass fmaxw actives z = 
+    if isFeasibleBreakpoint sndPass z
+    then
+        let analyzeActive key@(p,line,f) b (newbreak,newmap') = 
+              let r' = adjustRatio b z (fmaxw (line+1))
+              in
+              updateWithNewRIfNoSolution sndPass r' z key newbreak newmap' $
+               \r newmap -> let dem' = computeDemerit settings sndPass r b z in
+                        case dem' of
+                            Nothing -> (newbreak,newmap)
+                            Just (d',f') -> 
+                                      let  b' = createBreaknode (Just (p,line,f,b)) z in
+                                      -- We keep only the best new break
+                                      (Map.insertWith updateBreak (position z,line+1,f') (b' {demerit = d',fitnessValue = f', ratio = r}) newbreak ,newmap)
+        in
+        let (breaks',actives') = Map.foldWithKey analyzeActive (Map.empty,actives) actives
+            dmin = minimum . map demerit . Map.elems $ breaks'
+            nbreaks = Map.filter (\x -> demerit x < dmin + (fitness_demerit settings)) breaks'
+        in
+        if Map.null nbreaks
+         then
+           (breaks' , actives') 
+         else
+           (nbreaks , actives') 
+    else
+       (Map.empty,actives )
+          
+-- (position, line, fitness) -> (adjust ratio, break position)
+genNodeList :: (Int,Int,Int,BreakNode) -> [(PDFFloat,Int,Bool)]
+genNodeList (p,_,_,b@(BreakNode _ _ _ _ f _ _ Nothing)) = [(ratio b,p,f)]
+genNodeList (p,_,_,b@(BreakNode _ _ _ _ f _ _ (Just _))) = (ratio b,p,f):genNodeList (fromJust . previous $ b)
+
+
+-- Analyze the boxes to compute breaks
+analyzeBoxes :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> [(PDFFloat,Int,Bool)]
+analyzeBoxes settings pass fmaxw actives z = 
+    let getMinBreak b' = (\((xc,yc,zc),w) -> (xc,yc,zc,w)) . minimumBy (\(_,a) (_,b) -> compare (demerit a) (demerit b)) . Map.toList $ b'
+        (breaks',actives') = getNewActiveBreakpoints settings pass fmaxw actives z 
+        newActives = Map.union breaks' actives'
+        getRightOrderNodeList = tail . reverse . genNodeList
+        getKey (a,b,c,_) = (a,b,c)
+        getNode (_,_,_,BreakNode a b c d e f r _) = BreakNode a b c d e f r Nothing
+    in
+    --  If forced breakpoint or no breakpoint found
+    if Map.null actives'
+        then
+            -- If no breakpoint found
+            if Map.null breaks'
+                then
+                    -- Second pass analysis
+                    if not pass
+                     then
+                          analyzeBoxes settings True fmaxw actives z
+                     else
+                          error "Second pass analysis failed ! Generally due to wrong width in the text area or an end of text before end of paragraph detected"
+                else 
+                    -- Forced breakpoint then we gen a list from it and continue the analysis
+                    let minBreak = getMinBreak breaks' 
+                        someNewBreaks = getRightOrderNodeList minBreak
+                    in
+                    if theEnd z
+                      then
+                        someNewBreaks
+                      else
+                        someNewBreaks ++ analyzeBoxes settings pass fmaxw (Map.insert (getKey minBreak) (getNode minBreak) Map.empty) (moveRight z)
+        -- Normal feasible breakpoint
+        else
+            if Map.null breaks'
+             then
+                 if theEnd z
+                    then
+                        error "End of text found but no paragraph end detected"
+                    else
+                        analyzeBoxes settings pass fmaxw actives' (moveRight z)
+             else
+                -- If the end it must be a possible breakpoint
+                -- We should NEVER reach this part. The end should always be a forced breakpoint
+                if theEnd z
+                   then
+                     let minBreak = getMinBreak breaks' in
+                     getRightOrderNodeList minBreak
+                   else
+                     -- We continue the analysis
+                     analyzeBoxes settings pass fmaxw newActives (moveRight z)
+
+-- | Create an hyphen box
+hyphenBox :: AnyStyle -> Letter
+hyphenBox s = AChar s '-' (charWidth (textFont . textStyle $ s) '-')
+
+-- Use a list of breakpoint and adjustement ratios to generate a list of lines. Bool means if the break was done on a flagged penalty (hyphen)
+cutList :: [Letter] -> Int -> [(PDFFloat,Int,Bool)] -> [(PDFFloat,[Letter])]
+cutList [] _ _ = []
+cutList t _ [] = [(0.0,t)]
+cutList t c ((ra,ba,fa):l) = 
+   let (theLine,t') = splitAt (ba-c) t 
+   in
+   if null theLine 
+      then
+         []
+      else 
+         if null t'
+             then
+                 [(ra,theLine)]
+             else
+                 case head t' of
+                     FlaggedPenalty _ _ s -> if not fa 
+                                               then
+                                                  error $ "Breakpoint marked as not flagged but detected as flagged ! Send a bug report ! " ++ show (ra,ba,fa)
+                                               else
+                                                 (ra,theLine ++ [hyphenBox s]) : cutList t' ba l
+                     _ -> if fa 
+                            then
+                                error "Breakpoint marked as flagged but detected as not flagged ! Send a bug report !"
+                            else
+                                (ra,theLine) : cutList t' ba l
+     
+-- Compute the breakpoints and generate a list of lines with the adjustement ratios
+-- The line are not interpreted. Some additional postprocessing is required
+-- for horizontal lines of vertical boxes
+formatList :: BRState -> (Int -> PDFFloat) -> [Letter] -> [(PDFFloat,[Letter])]
+formatList settings maxw boxes = 
+    let active = Map.insert (0,0,1) (BreakNode 0 0 0 0 False 0 0.0 Nothing) Map.empty
+        theBreaks = analyzeBoxes settings False maxw active (createZList boxes)
+    in
+    cutList boxes 1 theBreaks
+     
+-- | Value modeling infinity  
+infinity :: Int 
+infinity = 10000
+
+bigAdjustRatio :: PDFFloat
+bigAdjustRatio = 10000.0
+
+-- | Add a glue to the stream
+glueBox :: Maybe AnyStyle
+        -> PDFFloat -- ^ Glue width
+        -> PDFFloat -- ^ Glue dilatation
+        -> PDFFloat -- ^ Glue compression
+        -> Letter
+glueBox s w y z = Glue w y z s
+
+-- | Add a glue to the stream
+spaceGlueBox :: AnyStyle -- ^ The style
+             -> Letter
+spaceGlueBox s = 
+     let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
+         h = scaleSpace . textStyle $ s
+         sy = scaleDilatation . textStyle $ s
+         sz = scaleCompression . textStyle $ s
+     in
+     Glue (ws*h) (h*sy*ws/2.0) (h*sz*ws/3.0) (Just s)
+
+-- | Add a glue to the stream
+punctuationGlue :: AnyStyle -- ^ The style
+                -> Letter
+punctuationGlue s = 
+  let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
+      h = scaleSpace . textStyle $ s
+      sy = scaleDilatation . textStyle $ s
+      sz = scaleCompression . textStyle $ s
+  in
+  Glue (ws*h) (h*sy*ws) (h*sz*ws/3.0) (Just s)
+  
+-- | Add a penalty to the stream
+penalty :: Int -- ^ Penalty value
+        -> Letter
+penalty p = Penalty p
+
+-- | Create a box containing text
+createChar :: AnyStyle -- ^ Char style
+           -> PDFFloat -- ^ Char width
+           -> Char -- ^ Char code
+           -> Letter
+createChar s w t = AChar s t w
+
+
+-- | Create boxes for the letters
+createLetterBoxes :: BRState
+                  -> AnyStyle -- ^ Letter style
+                  -> [(PDFFloat,Char)] -- ^ Letter and size 
+                  -> [Letter] -- ^ Boxes
+createLetterBoxes _ _ [] = []  
+createLetterBoxes settings s ((wa,'.'):b@(_,bc):l') | bc /= ' ' = (createChar s wa '.'): punctuationGlue s : createLetterBoxes settings s (b:l') 
+                                                    | otherwise = (createChar s wa '.') : punctuationGlue s : createLetterBoxes settings s l'
+createLetterBoxes settings s ((_,'/'):(w,'-'):l) = hyphenPenalty settings s w : createLetterBoxes settings s l
+createLetterBoxes settings s ((_,' '):l) = (spaceGlueBox s) : createLetterBoxes settings s l
+createLetterBoxes settings s ((w,t):l) = (createChar s w t) : createLetterBoxes settings s l
+             
+-- WARNING : must generate a list of LETTERS
+-- word are created with the analysis of style just above
+-- | split a line into boxes
+splitText :: BRState -> AnyStyle -> PDFString -> [Letter]
+splitText settings f t  = createLetterBoxes settings f . ripText (textFont . textStyle $ f) $ t
+
+kernBox :: AnyStyle -> PDFFloat -> Letter
+kernBox s w = Kern w (Just s)
diff --git a/Graphics/PDF/Typesetting/Horizontal.hs b/Graphics/PDF/Typesetting/Horizontal.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/PDF/Typesetting/Horizontal.hs
@@ -0,0 +1,345 @@
+---------------------------------------------------------
+-- |
+-- Copyright   : (c) alpha 2006f
+-- License     : BSD-style
+--
+-- Maintainer  : misc@NOSPAMalpheccar.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Horizontal mode
+---------------------------------------------------------
+-- #hide
+module Graphics.PDF.Typesetting.Horizontal (
+   HBox(..)
+ , mkHboxWithRatio
+ , horizontalPostProcess
+ ) where
+
+import Graphics.PDF.LowLevel.Types
+import Graphics.PDF.Typesetting.Breaking
+import Graphics.PDF.Shapes
+import Graphics.PDF.Draw
+import qualified Data.ByteString.Char8 as S(pack)
+import Data.Maybe(isJust,fromJust)
+import Data.List(foldl')
+import Graphics.PDF.Colors
+import Graphics.PDF.Text
+import Graphics.PDF.Typesetting.Box
+import Control.Monad.Writer(tell)
+import Control.Monad(when)
+import Graphics.PDF.LowLevel.Serializer
+import Data.Monoid
+
+-- | Current word (created from letter) is converted to a PDFString
+saveCurrentword :: String -> PDFString
+saveCurrentword = PDFString . S.pack . reverse
+
+-- WARNING
+-- According to splitText, PDFText to concatenate ARE letters so we can optimize the code
+-- Sentences are created when no word style is present, otherwise we just create words
+createWords :: PDFFloat -- ^ Adjustement ratio
+            -> Maybe (AnyStyle,String, PDFFloat) -- ^ Current word
+            -> [Letter] -- ^ List of letters
+            -> [HBox] -- ^ List of words or sentences
+
+createWords _ Nothing [] = []
+-- Empty list, current word or sentence is added
+createWords _ (Just (s,t,w)) [] = [createText s (saveCurrentword t) w]
+
+-- Start of a new word
+createWords r Nothing ((AChar s t w):l) = createWords r (Just (s,[t],w)) l
+-- New letter. Same style added to the word. Otherwise we start a new word
+createWords r (Just (s,t,w)) ((AChar s' t' w'):l) | styleCode s == styleCode s' = createWords r (Just (s,t':t,w+w')) l
+                                                  | otherwise = (createText s (saveCurrentword $ t) w):createWords r (Just (s',[t'],w')) l 
+                                                             
+-- Glue close the word and start a new one because we want glues of different widths in the PDF
+createWords r (Just (s,t,w)) ((Glue w' y z (Just s')):l) = (createText s (saveCurrentword $ t) w):(HGlue w' (Just(y,z)) (Just s')):createWords r  Nothing l
+
+-- Penalties are invisible. The are needed just to compute breaks
+createWords r c (Penalty _:l) = createWords r  c l
+createWords r c (FlaggedPenalty _ _ _:l) = createWords r  c l
+
+-- We just add the box
+createWords r Nothing ((Glue w' y z s):l) = (HGlue w' (Just(y,z)) s):createWords r Nothing l
+createWords r (Just (s,t,w)) ((Glue w' y z Nothing):l) = (createText s (saveCurrentword $ t) w):(HGlue w' (Just(y,z)) Nothing):createWords r Nothing l
+  
+createWords r Nothing ((Kern w' s):l) = (HGlue w' Nothing s):createWords r Nothing l
+createWords r (Just (s,t,w)) ((Kern w' s'):l) = (createText s (saveCurrentword $ t) w):(HGlue w' Nothing s'):createWords r Nothing l
+
+createWords r Nothing ((Letter d a s):l) = (SomeHBox d a s):createWords r Nothing l
+createWords r (Just (s,t,w)) ((Letter d a st):l) = (createText s (saveCurrentword $ t) w):(SomeHBox d a st):createWords r Nothing l
+ 
+            
+-- Remove glues and penalties at the beginning of a line
+simplify :: PDFFloat -- ^ Adjustement ratio
+         -> [Letter] -- ^ List of letters
+         -> [HBox] -- ^ List of words or sentence
+simplify r ((Glue _ _ _ _):l) = simplify r l
+simplify r ((FlaggedPenalty _ _ _):l) = simplify r l
+simplify r ((Penalty _):l) = simplify r l
+simplify r l = createWords r Nothing l
+
+-- | horizontalPostProcess
+horizontalPostProcess :: [(PDFFloat,[Letter])] -- ^ adjust ratio, hyphen style, list of letters or boxes
+                      -> [HBox] -- ^ List of lines
+horizontalPostProcess [] = []
+horizontalPostProcess ((r,l'):l) = let l'' = simplify r l' in
+  if null l''
+      then
+          horizontalPostProcess l
+      else
+          (mkHboxWithRatio r l''):horizontalPostProcess l 
+
+
+-- | An horizontal Hbox (sentence or word)
+-- The width of the glue was computed with the adjustement ratio of the HLine containing the glue
+-- The width of the text is already taking into account the adjustement ratio of the HLine containing the Text
+-- Otherwise, HBox cannot dilate or compress. 
+data HBox  = HBox !PDFFloat !PDFFloat !PDFFloat ![HBox]
+           | HGlue !PDFFloat !(Maybe (PDFFloat,PDFFloat)) !(Maybe AnyStyle)
+           | Text !AnyStyle !PDFString !PDFFloat
+           | SomeHBox !BoxDimension !AnyBox !(Maybe AnyStyle)
+     
+-- | Change the style of the box      
+withNewStyle :: AnyStyle -> HBox -> HBox
+withNewStyle _ a@(HBox _ _ _ _) = a
+withNewStyle s (HGlue a b _) = HGlue a b (Just s)
+withNewStyle s (Text _ a b) = Text s a b
+withNewStyle s (SomeHBox d a _) = SomeHBox d a (Just s) 
+    
+-- | A line of hboxes with an adjustement ratio required to display the text (generate the PDF command to increase space size)       
+--data HLine = HLine !PDFFloat ![HBox] deriving(Show)
+
+mkHboxWithRatio :: PDFFloat -- ^ Adjustement ratio
+                -> [HBox]
+                -> HBox
+mkHboxWithRatio _ [] = SomeHBox (0,0,0) (AnyBox NullChar) Nothing
+mkHboxWithRatio r l = 
+    let w = foldl' (\x y -> x + boxWidthWithRatio y r) 0.0 l
+        --h = maximum . map boxHeight $ l
+        ascent = maximum . map boxAscent $ l
+        d = maximum . map boxDescent $ l
+        h = ascent + d
+        addBox (HGlue gw (Just(y,z)) s) (HBox w' h' d' l') = HBox w' h' d' (HGlue (glueWidth gw y z r) Nothing s:l')
+        addBox a (HBox w' h' d' l') = HBox w' h' d' (a:l')
+        addBox _ _ = error "We can add boxes only to an horizontal list"
+    in
+    -- Add boxes and dilate glues when needing fixing their dimensions after dilatation
+    foldr addBox (HBox w h d []) l
+    
+instance MaybeGlue HBox where
+    boxWidthWithRatio (HGlue w (Just(y,z)) _) r = glueWidth w y z r
+    boxWidthWithRatio a _ = boxWidth a
+                        
+  
+-- | Create an HBox           
+createText :: Style s => s -- ^ Style
+           -> PDFString -- ^ String
+           -> PDFFloat -- ^ Width
+           -> HBox
+createText s t w = Text (AnyStyle s) t w
+
+
+instance Show HBox where
+   show (HBox _ _ _ a) = "(HBox " ++ show a ++ ")"
+   show (HGlue a _ _) = "(HGlue " ++ show a ++ ")"
+   show (Text _ t _) = "(Text " ++ show t ++ ")"
+   show (SomeHBox _ t _) = "(SomeHBox " ++ show t ++ ")"
+
+-- | Draw a line of words and glue using the word style
+drawTextLine :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> Draw ()
+drawTextLine  _ [] _ _ = return ()
+drawTextLine  style l@(a:l') x y | (isJust . wordStyle $ style) =  do
+    let  h = boxHeight a
+         d = boxDescent a
+         y' = y + h - d
+    strokeBox (withNewStyle style a) x y'
+    drawTextLine (updateStyle style) l' (x + boxWidth a) y
+                                 | otherwise = drawWords style l x y
+    
+-- | Draw a line of words, glue, or any box without word style
+drawWords :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> Draw ()
+drawWords _ [] _ _ = return ()
+
+drawWords s ((Text _ t w):l) x y = do
+    (l',x') <- drawText $ do
+       drawTheTextBox StartText s x y (Just t)
+       drawPureWords s l (x + w) y
+    drawWords s l' x' y
+    
+drawWords s l@((HGlue _ _ _ ):_) x y = do
+    (l',x') <- drawText $ do
+       drawTheTextBox StartText s x y Nothing
+       drawPureWords s l x y
+    drawWords s l' x' y
+    
+drawWords s (a@(SomeHBox _ _ _):l) x y =  do
+    let h = boxHeight a
+        d = boxDescent a
+        w = boxWidth a
+        y' = y - d + h
+    strokeBox a x y'
+    drawWords s l (x + w) y
+
+drawWords _ _ _ _ = return ()
+
+-- | Draw only words and glues using PDF text commands
+drawPureWords :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> PDFText ([HBox],PDFFloat)  
+
+drawPureWords s [] x y = do
+    drawTheTextBox StopText s x y Nothing
+    return ([],x)
+          
+drawPureWords s ((Text _ t w):l) x y = do
+    drawTheTextBox ContinueText s x y (Just t)
+    drawPureWords s l (x + w) y
+    
+drawPureWords s ((HGlue w _ _):l) x y = do
+    drawTextGlue s w
+    drawPureWords s l (x + w) y  
+    
+drawPureWords s l@((SomeHBox _ _ _):_) x y = do
+    drawTheTextBox StopText s x y Nothing
+    return (l,x)
+    
+drawPureWords s (_:l) x y = drawPureWords s l x y  
+ 
+-- When a start of line is detected by drawLineOfHBoxes, we start the drawing
+startDrawingNewLineOfText :: PDFFloat -> PDFFloat -> [HBox] -> PDFFloat -> PDFFloat -> AnyStyle -> Draw ()
+startDrawingNewLineOfText hl dl l x y style = 
+    do
+           -- Position of draw line based upon the whole line and not just this word
+       let y' = y - hl + dl
+           (l',l'') = span (isSameStyle style) l
+           w' = foldl' (\x' ny -> x' + boxWidth ny) 0.0 l'
+       if (isJust . sentenceStyle $ style)
+             then do
+                 (fromJust . sentenceStyle $ style) (Rectangle x (y - hl) (x+w') (y)) (drawTextLine style l' x y')
+             else do
+                 drawTextLine style l' x y'
+       drawLineOfHboxes hl dl l'' (x + w') y
+    
+
+drawLineOfHboxes :: PDFFloat -- ^ Height of the total line first time this function is called
+                 -> PDFFloat -- ^ Descent of the total line first time this function is called
+                 -> [HBox] -- ^ Remaining box to display
+                 -> PDFFloat -- ^ x for the remaining boxes
+                 -> PDFFloat -- ^ y for the whole line
+                 -> Draw ()
+drawLineOfHboxes _ _ [] _ _ = return ()
+-- | Start a new text
+drawLineOfHboxes hl dl l@((Text style _ _):_) x y = startDrawingNewLineOfText hl dl l x y style
+drawLineOfHboxes hl dl l@((HGlue _ _ (Just style)):_) x y = startDrawingNewLineOfText hl dl l x y style
+
+drawLineOfHboxes hl dl (a:l) x y = do
+      let  h = boxHeight a
+           d = boxDescent a
+           -- Compute top of box a
+           y' = y  - hl + dl - d + h
+      strokeBox a x y'
+      drawLineOfHboxes hl dl l (x + boxWidth a) y
+
+instance Box HBox where
+     boxWidth (Text _ _ w) = w
+     boxWidth (HBox w _ _ _) = w
+     boxWidth (SomeHBox d _ _)  = boxWidth d
+     boxWidth (HGlue w _ _)  = w 
+                  
+     boxHeight (Text style _ _) = styleHeight style
+     boxHeight (HBox _ h _ _) = h
+     boxHeight (SomeHBox d _ _) = boxHeight d
+     boxHeight (HGlue _ _ (Just s)) = styleHeight s
+     boxHeight (HGlue _ _ _) = 0
+    
+     boxDescent (Text style _ _) = styleDescent style
+     boxDescent (HBox _ _ d _) = d
+     boxDescent (SomeHBox d _ _) = boxDescent d
+     boxDescent (HGlue _ _ (Just s)) = styleDescent s
+     boxDescent (HGlue _ _ _) = 0
+     
+               
+-- Draw a text box
+drawTheTextBox :: Style style => TextDrawingState
+               -> style
+               -> PDFFloat
+               -> PDFFloat
+               -> Maybe PDFString
+               -> PDFText ()
+drawTheTextBox state style x y t = do
+  when (state == StartText || state == OneBlock) $ (do
+     setFont (textFont . textStyle $ style)
+     strokeColor (textStrokeColor . textStyle $ style)
+     fillColor (textFillColor . textStyle $ style)
+     renderMode (textMode . textStyle $ style)
+     textStart x y
+     tell $ mconcat [newline,lbracket])
+  -- Here we need to dilate the space to take into account r and the font setting
+  when (state == StartText || state == OneBlock || state == ContinueText) $ (do
+      case t of
+          Nothing -> return ()
+          Just myText -> tell $ toPDF myText
+    )
+  when (state == StopText || state == OneBlock) $ (do
+      tell rbracket
+      tell $ serialize " TJ")
+      
+-- | Draw the additional displacement required for a space in a text due to the dilaton of the glue
+drawTextGlue :: Style style => style
+             -> PDFFloat
+             -> PDFText ()
+drawTextGlue style w = do              
+    let ws = (textWidth (textFont . textStyle $ style) (toPDFString " "))
+        PDFFont _ size = textFont . textStyle $ style
+        delta = w - ws 
+    return ()
+    tell . mconcat $ [ lparen, bspace,rparen,bspace,toPDF ((-delta) * 1000.0 / (fromIntegral size) ), bspace]  
+    
+  
+data TextDrawingState = StartText -- ^ Send PDF commands needed to start a text
+                      | ContinueText -- ^ Continue adding text
+                      | StopText -- ^ Stop the text
+                      | OneBlock -- ^ One block of text
+                      deriving(Eq)
+              
+instance DisplayableBox HBox where
+     strokeBox a@(HBox _ _ _ l) x y = do
+         let he = boxHeight a
+             de = boxDescent a
+         drawLineOfHboxes he de l x y
+        
+     strokeBox a@(HGlue w _ (Just style)) x y = do
+         let de = boxDescent a
+             he = boxHeight a
+             y' = y - he + de
+         -- In word mode we have to apply a special function to the word
+         -- otherwise we apply a different function to the sentence
+         if (isJust . wordStyle $ style)
+             then
+                 (fromJust . wordStyle $ style) (Rectangle x (y' - de) (x+w) (y' - de + he)) DrawGlue (return ())
+             else
+                 return ()
+                 
+     strokeBox a@(Text style t w) x y = do
+         let de = boxDescent a
+             he = boxHeight a
+             y' = y - he + de
+         -- In word mode we have to apply a special function to the word
+         -- otherwise we apply a different function to the sentence
+         if (isJust . wordStyle $ style)
+             then
+                 (fromJust . wordStyle $ style) (Rectangle x (y' - de) (x+w) (y' - de + he)) DrawWord (drawText $ drawTheTextBox OneBlock style x y' (Just t))
+             else 
+                 drawText $ drawTheTextBox OneBlock style x y' (Just t)
+
+     strokeBox (SomeHBox _ a _) x y = strokeBox a x y
+     strokeBox (HGlue _ _ _) _ _ = return ()
+     
+ -- Test is a box has same style
+isSameStyle :: Style s => s 
+         -> HBox
+         -> Bool
+isSameStyle s (Text style _ _) = styleCode s == styleCode style
+isSameStyle s (HGlue _ _ (Just style)) = styleCode s == styleCode style
+isSameStyle s (SomeHBox _ _ (Just style)) = styleCode s == styleCode style
+isSameStyle _ _ = False
diff --git a/Graphics/PDF/Typesetting/Vertical.hs b/Graphics/PDF/Typesetting/Vertical.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/PDF/Typesetting/Vertical.hs
@@ -0,0 +1,316 @@
+---------------------------------------------------------
+-- |
+-- Copyright   : (c) alpha 2006
+-- License     : BSD-style
+--
+-- Maintainer  : misc@NOSPAMalpheccar.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Vertical mode
+---------------------------------------------------------
+-- #hide
+module Graphics.PDF.Typesetting.Vertical (
+    VBox(..)
+  , VerState(..)
+  , verticalPostProcess
+  , mkVboxWithRatio
+  , strokeVBoxes
+  , vglue
+  , defaultVerState
+  , ParagraphStyle(..)
+  , AnyParagraphStyle(..)
+ ) where
+ 
+import Graphics.PDF.LowLevel.Types
+import Graphics.PDF.Typesetting.Breaking
+import Graphics.PDF.Typesetting.Horizontal(horizontalPostProcess,HBox)
+import Graphics.PDF.Draw
+import Graphics.PDF.Shapes(Rectangle(..))
+import Graphics.PDF.Typesetting.Box
+import Data.List(foldl')
+import Data.Maybe(isJust,fromJust)
+
+data VerState = VerState { baselineskip :: !(PDFFloat,PDFFloat,PDFFloat) -- ^ Default value (12,0.17,0.0)
+                         , lineskip :: !(PDFFloat,PDFFloat,PDFFloat) -- ^ Default value (3.0,0.33,0.0)
+                         , lineskiplimit :: !PDFFloat -- ^ Default value 2
+                         , paraStyle :: !AnyParagraphStyle
+                         }
+        
+defaultVerState :: ParagraphStyle s => s -> VerState                 
+defaultVerState s = VerState { baselineskip = (12,0.17,0.0)
+                             , lineskip = (3.0,0.33,0.0)
+                             , lineskiplimit = 2
+                             , paraStyle = AnyParagraphStyle s
+                             }
+
+-- | Pair of functions describing the shape of a text areas : horizontal position of each line, vertical top of the area, width of each line
+-- First line is 1
+
+data VBox  = Paragraph [Letter] !(Maybe AnyParagraphStyle) !BRState
+           | VBox !PDFFloat !PDFFloat !PDFFloat ![VBox] !(Maybe AnyParagraphStyle)
+           | VGlue !PDFFloat !PDFFloat !PDFFloat !(Maybe (PDFFloat,PDFFloat)) !(Maybe AnyParagraphStyle)
+           | SomeVBox !PDFFloat !BoxDimension !AnyBox !(Maybe AnyParagraphStyle)
+           
+vglue :: Maybe AnyParagraphStyle
+      -> PDFFloat -- ^ Glue height
+      -> PDFFloat -- ^ Glue dilatation factor
+      -> PDFFloat -- ^ Glue compression factor
+      -> PDFFloat -- ^ Glue width
+      -> PDFFloat -- ^ Glue delta
+      -> VBox
+vglue s h y z width delta = VGlue h width delta (Just(y,z)) s
+
+instance Show VBox where
+  show (VBox _ _ _ a _) = "(HBox " ++ show a ++ ")"
+  show (VGlue a _ _ _ _) = "(HGlue " ++ show a ++ ")"
+  show (Paragraph _ _ _) = "(Paragraph)"
+  show (SomeVBox _ _ t _) = "(SomeHBox " ++ show t ++ ")"
+                         
+-- | A line of hboxes with an adjustement ratio required to display the text (generate the PDF command to increase space size)       
+--data HLine = HLine !PDFFloat ![HBox] deriving(Show)
+
+mkVboxWithRatio :: PDFFloat -- ^ Adjustement ratio
+                -> [VBox]
+                -> VBox
+mkVboxWithRatio _ [] = SomeVBox 0.0 (0,0,0) (AnyBox NullChar) Nothing
+mkVboxWithRatio r l = 
+   let w = foldl' (\x y -> x + boxWidthWithRatio y r) 0.0 l
+       h = maximum . map boxHeight $ l
+       d = maximum . map boxDescent $ l
+       addBox (VGlue gw gh gdelta (Just(y,z)) s) (VBox w' h' d' l' s') = VBox w' h' d' (VGlue (glueWidth gw y z r) gh gdelta Nothing s:l') s'
+       addBox a (VBox w' h' d' l' s') = VBox w' h' d' (a:l') s'
+       addBox _ _ = error "We can add boxes only to an horizontal list"
+   in
+   -- Add boxes and dilate glues when needing fixing their dimensions after dilatation
+   foldr addBox (VBox w h d [] Nothing) l
+
+instance MaybeGlue VBox where
+   boxWidthWithRatio (VGlue w _ _ (Just(y,z)) _) r = glueWidth w y z r
+   boxWidthWithRatio a _ = boxWidth a
+
+        
+-- | Convert pure lines to VBoxes
+toVBoxes :: Maybe AnyParagraphStyle
+         -> PDFFloat -- ^ Max width
+         -> [HBox] -- ^ List of lines
+         -> [VBox] -- ^ List of VBoxes
+toVBoxes Nothing _ l = map createVBox l
+ where
+    createVBox a =  SomeVBox 0.0 (boxWidth a,boxHeight a,boxDescent a) (AnyBox a) Nothing
+
+toVBoxes s@(Just style) w l = map createVBoxAndAddKern $ zip [1..] (l )
+ where
+      createVBoxAndAddKern (nb,a) = 
+          let delta = (linePosition style) w nb
+          in
+          SomeVBox delta (boxWidth a,boxHeight a,boxDescent a) (AnyBox a) s
+
+-- | Create VBoxes. Paragraphs are analyzed and cut into VBoxes. The pragraph style is updated and used
+-- to transform the list of letters
+verticalPostProcess :: VerState
+             -> Int -- ^ Line offset for the text area
+             -> Rectangle -- ^ Text area
+             -> [VBox] -- ^ List of VBox with paragraphs
+             -> [VBox] -- ^ List of VBox where paragraphs have been line broken
+verticalPostProcess _ _ _ [] = []
+verticalPostProcess pageSettings o rect@(Rectangle xa _ xb _) ((Paragraph l style paraSettings):l') = 
+    let (fl,newStyle) = case style of
+              Nothing -> (formatList paraSettings (const $ xb-xa) l,Nothing) 
+              Just aStyle -> let (style',nl) = paraChange aStyle l 
+               in
+               (formatList paraSettings (\nb -> (lineWidth style') (xb-xa) nb ) nl,Just style')
+    in
+    (addInterlineGlue pageSettings . toVBoxes newStyle (xb - xa) . horizontalPostProcess $ fl) ++ verticalPostProcess pageSettings (o + length fl) rect l'
+verticalPostProcess pageSettings o rect (a:l') = a:verticalPostProcess pageSettings (o+1) rect l'
+
+
+notGlue :: VBox -> Bool
+notGlue (VGlue _ _ _ _ _) = False
+notGlue (Paragraph _ _ _) = False
+notGlue _ = True
+
+-- | Get the required style for the interline glue
+getInterlineStyle :: VBox -> VBox -> Maybe AnyParagraphStyle
+getInterlineStyle (VBox _ _ _ _ (Just s)) (SomeVBox _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s
+                                                                     | otherwise = Nothing
+
+getInterlineStyle (VBox _ _ _ _ (Just s)) (VBox _ _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s
+                                                                   | otherwise = Nothing
+
+getInterlineStyle (SomeVBox _ _ _ (Just s)) (SomeVBox _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s
+                                                                       | otherwise = Nothing
+
+getInterlineStyle (SomeVBox _ _ _ (Just s)) (VBox _ _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s
+                                                                     | otherwise = Nothing
+
+getInterlineStyle _ _ = Nothing
+
+-- | Get the delta used to position a box with non rectangular shapes
+getBoxDelta :: VBox -> PDFFloat
+getBoxDelta (Paragraph _ _ _) = 0.0
+getBoxDelta (VBox _ _ _ _ _) = 0.0
+getBoxDelta (VGlue _ _ delta _ _) = delta
+getBoxDelta (SomeVBox delta _ _ _) = delta
+           
+addInterlineGlue :: VerState -> [VBox] -> [VBox]
+addInterlineGlue _ [] = []
+addInterlineGlue _ [a] = [a]
+addInterlineGlue settings (a:b:l) | notGlue a && notGlue b = 
+    let p = boxDescent a
+        h = boxHeight b - boxDescent b
+        (ba,by,bz) = baselineskip settings
+        (lw,ly,lz) = lineskip settings
+        li = lineskiplimit settings
+        istyle = getInterlineStyle a b
+        theWidth = boxWidth a
+        theDelta = getBoxDelta a
+    in
+    if p <= -1000 
+        then
+            a:addInterlineGlue settings (b:l)
+        else
+            if ba - p - h >= li
+                then
+                    a:(vglue istyle (ba-p-h) by bz theWidth theDelta):addInterlineGlue settings (b:l)
+                else
+                    a:(vglue istyle lw ly lz theWidth theDelta):addInterlineGlue settings (b:l)
+                                  | otherwise = a:addInterlineGlue settings (b:l)
+
+instance Box VBox where
+     boxWidth (Paragraph _ _ _) = 0
+     boxWidth (VBox w _ _ _ _) = w
+     boxWidth (SomeVBox _ d _ _)  = boxWidth d
+     boxWidth (VGlue _ w _ _ _)  = w
+                  
+     boxHeight (Paragraph _ _ _) = 0
+     boxHeight (VBox _ h _ _ _) = h
+     boxHeight (SomeVBox _ d _ _) = boxHeight d
+     boxHeight (VGlue h _ _ _ _) = h
+    
+     boxDescent (Paragraph _ _ _) = 0
+     boxDescent (VBox _ _ d _ _) = d
+     boxDescent (SomeVBox _ d _ _) = boxDescent d
+     boxDescent (VGlue _ _ _ _ _) = 0
+
+instance DisplayableBox VBox where
+          strokeBox (Paragraph _ _ _) _ _ = return ()
+          strokeBox b@(VBox _ _ _ l _) x y'' = strokeVBoxes l (x,y',y'')
+            where
+                y' = y'' - boxHeight b
+          strokeBox (VGlue h w delta _ (Just style)) x y = 
+              if (isJust . interline $ style)
+                  then
+                      (fromJust . interline $ style) $ Rectangle (x+delta) (y-h) (x+w+delta) y
+                  else
+                     return()
+          strokeBox (VGlue _ _ _ _ _) _ _ = return ()
+          
+          strokeBox (SomeVBox delta _ a _) x y = strokeBox a (x+delta) y
+ 
+isSameParaStyle :: AnyParagraphStyle -> VBox -> Bool
+isSameParaStyle s (Paragraph _ (Just s') _) = paraStyleCode s == paraStyleCode s'
+isSameParaStyle s (VBox _ _ _ _ (Just s')) = paraStyleCode s == paraStyleCode s'
+isSameParaStyle s (VGlue _ _ _ _ (Just s')) = paraStyleCode s == paraStyleCode s'
+isSameParaStyle s (SomeVBox _ _ _ (Just s'))  = paraStyleCode s == paraStyleCode s'     
+isSameParaStyle _ _ = False
+     
+recurseStrokeVBoxes :: Int -> [VBox] -> (PDFFloat,PDFFloat,PDFFloat) -> Draw ()
+recurseStrokeVBoxes _ [] _  = return ()
+recurseStrokeVBoxes _ (Paragraph _ _ _:_) _  = return ()
+recurseStrokeVBoxes nb (a@(VGlue _ _ _ _ _):l) (xa,y',y)  = do
+    let h = boxHeight a
+    strokeBox a xa y
+    if y - h >= y'
+      then
+        recurseStrokeVBoxes nb l (xa,y',(y-h))
+      else
+        return ()
+    
+recurseStrokeVBoxes nb (a:l) (xa,y',y) = do
+    let h = boxHeight a
+    strokeBox a xa y
+    if y - h >= y'
+     then
+       recurseStrokeVBoxes (nb+1) l (xa,y',(y-h))
+     else
+       return ()           
+               
+drawWithParaStyle :: AnyParagraphStyle -> [VBox] -> (PDFFloat,PDFFloat,PDFFloat) -> Draw ()   
+drawWithParaStyle style b (xa,y',y'') = do
+    let  (l',l'') = span (isSameParaStyle style) b
+         h' = foldl' (\x' ny -> x' + boxHeight ny) 0.0 l'
+    if (isJust . paragraphStyle $ style)
+      then do
+          let xleft = (minimum $ 100000:map getBoxDelta l' ) + xa
+              xright = (maximum $ 0:(map (\x -> boxWidth x + getBoxDelta x) l')) + xa
+          (fromJust . paragraphStyle $ style) (Rectangle xleft (y''- h') xright (y'')) (recurseStrokeVBoxes 1 l' (xa,y',y''))
+      else
+         recurseStrokeVBoxes 1 l' (xa,y',y'')
+    strokeVBoxes l'' (xa,y',y''-h')
+               
+-- | Stroke the VBoxes
+strokeVBoxes :: [VBox] -- ^ List of boxes
+             -> (PDFFloat,PDFFloat,PDFFloat)
+             -> Draw ()
+strokeVBoxes [] (_,_,_) = return ()
+strokeVBoxes b@((Paragraph _ (Just s') _):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')
+strokeVBoxes b@((VBox _ _ _ _ (Just s')):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')
+strokeVBoxes b@((VGlue _ _ _ _ (Just s')):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')
+strokeVBoxes b@((SomeVBox _ _ _ (Just s')):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')
+strokeVBoxes (a:l) (xa,y',y'') = 
+    do
+        let h = boxHeight a
+        strokeBox a xa y''
+        if y'' - h >= y'
+          then
+             strokeVBoxes l (xa,y',(y''-h))
+          else
+             return ()
+
+-- | Paragraph style
+class ParagraphStyle a where
+    -- | Width of the line of the paragraph
+    lineWidth :: a -- ^ The style
+               -> PDFFloat -- ^ Width of the text area used by the typesetting algorithm
+               -> Int -- ^ Line number
+               -> PDFFloat -- ^ Line width
+    
+    -- | Horizontal shift of the line position relatively to the left egde of the paragraph bounding box
+    linePosition :: a -- ^ The style 
+                  -> PDFFloat -- ^ Width of the text area used by the typesetting algorithm
+                  -> Int -- ^ Line number 
+                  -> PDFFloat -- ^ Horizontal offset from the left edge of the text area
+    
+    -- | All paragraph styles used in a document must have different codes
+    paraStyleCode :: a -- ^ The style 
+                  -> Int -- ^ Code identifying the style
+    
+    -- | How to style the interline glues added in a paragraph by the line breaking algorithm
+    interline :: a -- ^ The style 
+              -> Maybe (Rectangle -> Draw ()) -- ^ Function used to style interline glues
+    interline _ = Nothing
+    lineWidth _ w _ = w
+    linePosition _ _ = const 0.0
+    
+    -- | Change the content of a paragraph before the line breaking algorithm is run. It may also change the style
+    paraChange :: a -- ^ The style
+               -> [Letter] -- ^ List of letters in the paragraph
+               -> (a,[Letter]) -- ^ Update style and list of letters
+    paraChange a l = (a,l)
+    
+    -- | Get the paragraph bounding box and the paragraph draw command to apply additional effects
+    paragraphStyle :: a -- ^ The style 
+                   -> Maybe (Rectangle -> Draw b -> Draw ()) -- ^ Function used to style a paragraph
+    paragraphStyle _ = Nothing
+    
+-- | Any paragraph style
+data AnyParagraphStyle = forall a . ParagraphStyle a => AnyParagraphStyle a
+
+instance ParagraphStyle AnyParagraphStyle where
+    lineWidth (AnyParagraphStyle a) = lineWidth a
+    linePosition (AnyParagraphStyle a) = linePosition a
+    paraStyleCode (AnyParagraphStyle a) = paraStyleCode a
+    interline (AnyParagraphStyle a) = interline a
+    paraChange (AnyParagraphStyle a) l = let (a',l') = paraChange a l in (AnyParagraphStyle a',l')
+    paragraphStyle (AnyParagraphStyle a) = paragraphStyle a
diff --git a/HPDF.cabal b/HPDF.cabal
--- a/HPDF.cabal
+++ b/HPDF.cabal
@@ -1,19 +1,21 @@
 Name: HPDF
-Version: 1.0
+Version: 1.1
 License: LGPL
 License-file:LICENSE
 Copyright: Copyright (c) 2007, alpheccar
 category: Graphics
 synopsis: Generation of PDF documents
 maintainer: misc@NOSPAMalpheccar.org
-homepage: http://www.alpheccar.org/en/posts/show/80
-build-depends: base, haskell98,mtl,encoding >= 0.1 ,zlib >= 0.3
+tested-with: GHC==6.6
+homepage: http://www.alpheccar.org/en/posts/show/82
+build-depends: base, haskell98,mtl,encoding >= 0.1 ,zlib >= 0.3, binary >= 0.3
 ghc-options: -Wall -funbox-strict-fields  -fglasgow-exts  -O2
 extensions: ForeignFunctionInterface, CPP
-description: A PDF library allowing to generate multipage PDF documents with outlines, links ...
+description: A PDF library with support for several pages, page transitions, outlines, annotations, compression, colors, shapes, patterns, jpegs, fonts, typesetting ...
 extra-source-files:
   c/ctext.h
   c/metrics.h
+  c/conversion.h
   Test/AFMParser.hs
   Test/logo.jpg
   Test/Makefile
@@ -22,9 +24,11 @@
   README.txt
 C-Sources:	
    c/metrics.c
+   c/conversion.c
 Include-Dirs: c
 Install-Includes: 
    ctext.h
+   conversion.h
 exposed-Modules: 
    Graphics.PDF
    Graphics.PDF.Colors
@@ -38,7 +42,7 @@
    Graphics.PDF.Annotation
    Graphics.PDF.Pattern
    Graphics.PDF.Shading
-   Graphics.PDF.Demo
+   Graphics.PDF.Typesetting
 Other-Modules:
    Graphics.PDF.LowLevel.Types
    Graphics.PDF.Data.PDFTree
@@ -46,3 +50,8 @@
    Graphics.PDF.Resources
    Graphics.PDF.Draw
    Graphics.PDF.LowLevel.Kern
+   Graphics.PDF.Typesetting.Breaking
+   Graphics.PDF.Typesetting.Horizontal
+   Graphics.PDF.Typesetting.Vertical
+   Graphics.PDF.Typesetting.Box
+   Graphics.PDF.LowLevel.Serializer
diff --git a/Test/Makefile b/Test/Makefile
--- a/Test/Makefile
+++ b/Test/Makefile
@@ -1,8 +1,14 @@
 debug:
-	ghc -o test -ffi -cpp -Wall -funbox-strict-fields  -fglasgow-exts  -O2 -hidir interfaces -odir bin -optc-I../c -i..  ../c/metrics.c --make test.hs
+	ghc -o test -ffi -cpp -Wall -funbox-strict-fields  -fglasgow-exts  -O2 -hidir interfaces -odir bin -optc-I../c -i.. ../c/metrics.c ../c/conversion.c --make test.hs
+
+profile:
+	ghc -o test -prof -auto-all -ffi -cpp -Wall -funbox-strict-fields  -fglasgow-exts  -O2 -hidir interfaces -odir bin -optc-I../c -i..  ../c/metrics.c ../c/conversion.c --make test.hs
+	
+runprof:
+	./test +RTS -p
 		
 demo:
-	ghc -o test --make test.hs
+	ghc -o test -fglasgow-exts  -O2 --make test.hs
 	
 buildafm:
 	ghc -o afm --make AFMParser.hs
diff --git a/Test/test.hs b/Test/test.hs
--- a/Test/test.hs
+++ b/Test/test.hs
@@ -16,6 +16,7 @@
 
 import Graphics.PDF
 import Penrose
+import System.Random
 
             
 fontDebug :: PDFFont -> PDFString -> Draw ()
@@ -68,9 +69,6 @@
          fillAndStroke $ Ellipse 300 300 600 400
          
  where 
-       myDrawing = do
-           stroke (Line 0 0 100 100)
-           fill (Rectangle 100 100 200 200)
        pattern = do
            stroke (Ellipse 0 0 100 50)
        cpattern = do
@@ -89,12 +87,12 @@
 textTest = do
     strokeColor red
     fillColor blue
-    fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test !")
+    fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test (éèçàù)!")
 
               
-testImage ::  PDFReference PDFPage -> PDF ()
-testImage page =  do
-    Right jpg <- createPDFJpeg "logo.jpg" 
+testImage ::  JpegFile -> PDFReference PDFPage -> PDF ()
+testImage jpgf page =  do
+    jpg <- createPDFJpeg jpgf
     drawWithPage page $ do
       withNewContext $ do
           setFillAlpha 0.4
@@ -104,46 +102,326 @@
            applyMatrix $ translate 200 200
            applyMatrix $ scale 2 2
            drawXObject jpg
-                                               
-testAll :: PDF ()
-testAll = do
-    page <- addPage Nothing
+           
+data Normal = Normal deriving(Eq)
+data Bold = Bold deriving(Eq)
+data Crazy = Crazy deriving(Eq)
+data SuperCrazy = SuperCrazy !([Int],[PDFFloat]) deriving(Eq)
+data DebugStyle = DebugStyle deriving(Eq)
+data RedRectStyle = RedRectStyle deriving(Eq)
+data BlueStyle = BlueStyle deriving(Eq)
+
+instance Style Normal where
+    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
+    styleCode _ = 1
+    
+instance Style Bold where
+    textStyle _ = TextStyle (PDFFont Times_Bold 12) black black FillText 1.0 1.0 1.0 1.0
+    styleCode _ = 2 
+    
+instance Style RedRectStyle where
+    sentenceStyle _ = Just $ \r d -> do
+        strokeColor red
+        stroke r
+        d
+        return()
+    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
+    styleCode _ = 5
+        
+instance Style DebugStyle where
+    wordStyle _ = Just $ \r m d ->
+      case m of
+          DrawWord -> d >> return ()
+          DrawGlue -> d >> stroke r
+    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
+    styleCode _ = 5 
+            
+crazyWord :: Rectangle -> StyleFunction -> Draw a -> Draw ()
+crazyWord r@(Rectangle xa ya xb yb) DrawWord d = do
+    fillColor $ Rgb 0.6 1 0.6 
+    fill r
+    d
+    strokeColor $ Rgb 0 0 1
+    let m = (ya+yb)/2.0
+    stroke $ Line xa m xb m 
+crazyWord (Rectangle xa ya xb yb) DrawGlue _ = do
+    fillColor $ Rgb 0 0 1
+    fill (Circle ((xa+xb)/2.0) ((ya+yb)/2.0) ((xb-xa)/2.0))
+    
+instance Style Crazy where
+    sentenceStyle _ = Just $ \r d -> do
+        d
+        strokeColor blue
+        stroke r
+    wordStyle _ = Just crazyWord
+    textStyle _ = TextStyle (PDFFont Times_Roman 10) red red FillText 1.0 1.0 1.0 1.0
+    styleCode _ = 3   
+    
+    
+superCrazy :: SuperCrazy
+superCrazy = SuperCrazy (randomRs (0,32) (mkStdGen 0),randomRs (-10.0,10.0) (mkStdGen 10000))
+
+instance Style SuperCrazy where
+    styleCode _ = 4
+    updateStyle (SuperCrazy (a,b)) = SuperCrazy $ (drop 8 a,tail b)
+    textStyle _ = TextStyle (PDFFont Times_Roman 12) black black FillText 1.0 2.0 0.5 0.5
+    styleHeight r = (getHeight . textFont . textStyle $ r) + 4.0
+    styleDescent r = (getDescent . textFont . textStyle $ r) + 2
+    
+    wordStyle (SuperCrazy (l,_)) = Just ws 
+     where
+        ws _ DrawGlue _ = return ()
+        ws (Rectangle xa ya xb yb) DrawWord drawWord = do
+            let [a,b,c,d,e,f,g,h] :: [PDFFloat] = map (\x -> x / 16.0) . map fromIntegral . take 8 $ l
+                --angle = head angl
+                p = Polygon [ (xa-a,ya+b)
+                            , (xb+c,ya+d)
+                            , (xb+e,yb-f)
+                            , (xa-g,yb-h)
+                            , (xa-a,ya+b)
+                            ]
+            strokeColor red
+            stroke p
+            fillColor $ Rgb 0.8 1.0 0.8
+            fill p
+            withNewContext $ do
+              --applyMatrix . rotate . Degree $ angle
+              drawWord
+            return ()
+
+instance ParagraphStyle Normal where
+    paraStyleCode _ = 1
+    
+data CirclePara = CirclePara deriving(Eq)
+data BluePara = BluePara PDFFloat deriving(Eq)
+
+instance ParagraphStyle BluePara where
+    paraStyleCode _ = 3
+    lineWidth (BluePara a) w nb = (if nb > 3 then w else w-a) - 20.0
+    linePosition (BluePara a) _ nb = (if nb > 3 then 0.0 else a) + 10.0
+    interline _ = Just $ \r -> do
+        fillColor $ Rgb 0.6 0.6 1
+        strokeColor $ Rgb 0.6 0.6 1
+        fillAndStroke r
+    paraChange s [] = (s,[])
+    paraChange _ (AChar st c _:l) = 
+        let f = PDFFont Helvetica_Bold 45
+            w' = charWidth f c 
+            charRect = Rectangle 0 (- getDescent f) w' (getHeight f - getDescent f)
+            c' = mkLetter (0,0,0) Nothing . mkDrawBox $ do
+                withNewContext $ do
+                    applyMatrix $ translate (-w') (getDescent f - getHeight f + styleHeight st - styleDescent st)
+                    fillColor $ Rgb 0.6 0.6 1
+                    strokeColor $ Rgb 0.6 0.6 1
+                    fillAndStroke $ charRect
+                    fillColor black
+                    drawText $ do
+                        renderMode AddToClip
+                        textStart 0 0
+                        setFont f
+                        displayText (toPDFString [c])
+                    paintWithShading (AxialShading 0 (- getDescent f) w' (getHeight f - getDescent f) (Rgb 1 0 0) (Rgb 0 0 1)) (addShape charRect)
+        in
+        (BluePara w', c':l)
+    paraChange s l = (s,l)
+    paragraphStyle _ = Just $ \(Rectangle xa ya xb yb) b -> do
+        let f = Rectangle (xa-3) (ya-3) (xb+3) (yb+3)
+        fillColor $ Rgb 0.6 0.6 1
+        fill f
+        b
+        strokeColor red
+        stroke f
+        return ()
+        
+instance ParagraphStyle CirclePara where
+    lineWidth _ _ nb = 
+        let nbLines = 15.0
+            r = nbLines * (getHeight . textFont . textStyle $ Normal)
+            pasin x' = if x' >= 1.0 then pi/2 else if x' <= -1.0 then (-pi/2) else asin x'
+            angle l = pasin $ (nbLines - (fromIntegral l)  ) / nbLines
+        in
+        abs(2*r*cos (angle nb))
+    linePosition a w nb = max 0 ((w - lineWidth a w nb) / 2.0)
+    paraStyleCode _ = 2
+
+instance Style BlueStyle where
+    sentenceStyle _ = Just $ \r d -> do
+        fillColor $ Rgb 0.6 0.6 1
+        strokeColor $ Rgb 0.6 0.6 1
+        fillAndStroke r
+        d
+        return()
+    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
+    styleCode _ = 7
+    
+typesetTest :: Int -> PDFReference PDFPage -> PDF ()
+typesetTest test page = do
+    let --symbol = mkDrawBox $ do
+        --  applyMatrix $ translate 0 (-4)
+        --  strokeColor red
+        --  fillColor red
+        --  fillAndStroke $ Polygon [ (0,0)
+        --                          , (5,5)
+        --                          , (10,0)
+        --                          , (0,0)
+        --                          ]
+        --  strokeColor blue
+        --  fillColor blue
+        --  fillAndStroke $ Polygon [ (0,0)
+        --                          , (5,-5)
+        --                          , (10,0)
+        --                          , (0,0)
+        --                          ]
+        debugText = do
+            paragraph $ do
+                txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "
+                setStyle Bold
+                txt $ "incididunt ut labore et dolore magna aliqua. "
+                setStyle Normal
+                txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure "
+                setStyle RedRectStyle
+                txt $ "dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. "
+                setStyle Normal
+            glue 3 0 0
+            paragraph $ do
+                txt $ "Excepteur sint occaecat cupidatat non"
+                txt $ " proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
+                setStyle superCrazy
+                txt $ " And now, a super crazy style to test the code. "
+                setStyle Normal
+                txt $ "Return to a normal style :-)"
+            glue 3 0 0
+            paragraph $ do
+                txt $ "More crazy styles ... "
+                setStyle Crazy
+                par
+                setStyle Normal
+        par = do
+              txt $ "Lor/-em ip/-sum do/-lor sit am/-et, con/-se/-cte/-tur adi/-pi/-si/-cing el/-it, sed do eius/-mod tem/-por inci/-di/-dunt ut lab/-ore et do/-lo/-re ma/-gna ali/-qua. "
+              txt $ "Ut en/-im ad mi/-nim ven/-iam, quis no/-strud ex/-er/-ci/-ta/-tion ul/-lam/-co labo/-ris ni/-si ut ali/-quip ex ea com/-mo/-do con/-se/-quat. Duis au/-te ir/-ure "
+              txt $ "do/-lor in re/-pre/-hen/-der/-it in vo/-lup/-ta/-te ve/-lit es/-se cil/-lum do/-lo/-re eu fu/-giat nul/-la pa/-ria/-tur. Ex/-cep/-teur sint oc/-cae/-cat cu/-pi/-da/-tat non "
+              txt $ "pro/-id/-ent, sunt in cul/-pa qui of/-fi/-cia de/-se/-runt mol/-lit anim id est la/-bo/-rum."
+        normalPar = do
+              txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
+              txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor "
+              txt $ "in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, "
+              txt $ "sunt in culpa qui officia deserunt mollit anim id est laborum."
+        myText = do
+              -- Duplicate paragraph several times
+              paragraph normalPar
+              glue 3 0 0
+              setStyle BlueStyle
+              setParaStyle (BluePara 0)
+              setFirstPassTolerance 5000
+              setSecondPassTolerance 10000
+              unstyledGlue 3 0 0
+              paragraph $ do
+                    txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
+                    txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco "
+                    --addBox symbol 10 10 5
+                    txt $ " laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor "
+                    txt $ "in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, "
+                    txt $ "sunt in culpa qui officia deserunt mollit anim id est laborum."
+              unstyledGlue 3 0 0
+              setFirstPassTolerance 100
+              setSecondPassTolerance 200
+              setStyle Normal
+              setParaStyle Normal
+              glue 3 0 0
+              paragraph normalPar
+              glue 3 0 0
+              paragraph normalPar
+        --textStart = 300 - getHeight f + getDescent f
+        maxw = 400
+    drawWithPage page $ do
+      --strokeColor red
+      --setWidth 0.5
+      --stroke $ Rectangle 10 0 (10+maxw) 300
+      --stroke $ Line 10 textStart (10+maxw) textStart
+      strokeColor black
+      case test of
+          1 -> do
+              strokeColor red
+              stroke $ Line 10 300 (10+maxw) 300
+              displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal myText
+          2 -> do
+              strokeColor red
+              stroke $ Line 10 300 (10+maxw) 300
+              displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal debugText
+          3 -> do
+              let r = (Rectangle 10 200 (10+maxw) 300)
+              displayFormattedText r CirclePara Normal $ do
+                   setStyle Normal
+                   setFirstPassTolerance 5000
+                   setSecondPassTolerance 5000
+                   setLineSkip 0 0 0
+                   setBaseLineSkip 0 0 0
+                   setLineSkipLimit 0
+                   paragraph $ do
+                       mapM_ (const normalPar) ([1..3]::[Int])
+                       txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
+                       txt $ "Ut enim ad minim"
+              strokeColor red
+              stroke r
+          _ -> displayFormattedText ((Rectangle 0 300 (10+maxw) 300)) Normal Normal myText
+     
+                                        
+testAll :: JpegFile -> PDF ()
+testAll jpg = do
+    page1 <- addPage Nothing
+    newSection (toPDFString "Typesetting") Nothing Nothing $ do
+     newSection (toPDFString "Normal text") Nothing Nothing $ do
+        typesetTest 1 page1
+     
+     page2 <- addPage Nothing
+     newSection (toPDFString "Debug text") Nothing Nothing $ do
+            typesetTest 2 page2
+            
+     page3 <- addPage Nothing
+     newSection (toPDFString "Circle text") Nothing Nothing $ do
+            typesetTest 3 page3
+        
+    page4 <- addPage Nothing
     newSection (toPDFString "Shapes") Nothing Nothing $ do
         
       newSection (toPDFString "Geometry") Nothing Nothing $ do
-         drawWithPage page $ do
+         drawWithPage page4 $ do
            geometryTest 
            
-      page <- addPage Nothing
+      page5 <- addPage Nothing
       newSection (toPDFString "Line style") Nothing Nothing $ do
-          drawWithPage page $ do
+          drawWithPage page5 $ do
             lineStyle
-      page <- addPage Nothing
+            
+      page6 <- addPage Nothing
       newSection (toPDFString "Object reuse") Nothing Nothing $ do
            r <- createPDFXForm 0 0 200 200 lineStyle
-           drawWithPage page $ do
+           drawWithPage page6 $ do
                 drawXObject r
             
-    page <- addPage Nothing
-    newSectionWithPage (toPDFString "Painting") Nothing Nothing page $ do
+    page7 <- addPage Nothing
+    newSectionWithPage (toPDFString "Painting") Nothing Nothing page7 $ do
      newSection (toPDFString "Patterns") Nothing Nothing $ do
-        patternTest page
-     page <- addPage Nothing
+        patternTest page7
+        
+     page8 <- addPage Nothing
      newSection (toPDFString "Shading") Nothing Nothing $ do
-        drawWithPage page $ do
+        drawWithPage page8 $ do
           shadingTest
-    page <- addPage Nothing
+          
+    page9 <- addPage Nothing
     newSection (toPDFString "Media") Nothing Nothing $ do
       newSection (toPDFString "image") Nothing Nothing $ do   
-           testImage page  
+           testImage jpg page9  
            
-    page <- addPage Nothing
+    page10 <- addPage Nothing
     newSection (toPDFString "Annotations") Nothing Nothing $ do
-        drawWithPage page $ do
+        drawWithPage page10 $ do
           testAnnotation 
-    page <- addPage Nothing
-    newSection (toPDFString "Text") Nothing Nothing $ do
-      drawWithPage page $ do
+          
+    page11 <- addPage Nothing
+    newSection (toPDFString "Text encoding") Nothing Nothing $ do
+      drawWithPage page11 $ do
         textTest
     newSection (toPDFString "Fun") Nothing Nothing $ do
         penrose
@@ -153,6 +431,7 @@
 main :: IO()
 main = do
     let rect = PDFRect 0 0 600 400
-    runPdf "demo.pdf" (standardDocInfo { author=toPDFString $ "alpheccar"}) rect $ do
-        testAll
+    Right jpg <- readJpegFile "logo.jpg"  
+    runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = True}) rect $ do
+        testAll jpg
      
diff --git a/c/conversion.c b/c/conversion.c
new file mode 100644
--- /dev/null
+++ b/c/conversion.c
@@ -0,0 +1,17 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include "conversion.h"
+
+
+short c_floatToString(double f,char* s)
+{
+    sprintf(s,"%.5f",f);
+    return(strlen(s));
+}
+
+short c_shortToString(short d,char* s)
+{
+    sprintf(s,"%d",d);
+    return(strlen(s));
+}
diff --git a/c/conversion.h b/c/conversion.h
new file mode 100644
--- /dev/null
+++ b/c/conversion.h
@@ -0,0 +1,5 @@
+#ifndef _CONVERSION_H_
+#define _CONVERSION_H_
+extern short c_floatToString(double f,char* s);
+extern short c_shortToString(short d,char* s);
+#endif
diff --git a/c/ctext.h b/c/ctext.h
--- a/c/ctext.h
+++ b/c/ctext.h
@@ -1,6 +1,6 @@
 #ifndef _CTEXT_H_
 #define _CTEXT_H_
-extern short c_getAdvance(unsigned short,unsigned char);
+extern short c_getAdvance(unsigned short,short);
 extern short c_getLeading(unsigned short);
 extern short c_getDescent(unsigned short);
 extern int c_hasKern(unsigned short);
diff --git a/c/metrics.c b/c/metrics.c
--- a/c/metrics.c
+++ b/c/metrics.c
@@ -5,9 +5,11 @@
 #define GFONTSIZE (255-32+1)
 #define FFONTSIZE (5)
 
-short c_getAdvance(unsigned short font,unsigned char c)
+short c_getAdvance(unsigned short font,short c)
 {
     if (c<32)
+        return(0);
+    if (c-32 >= GFONTSIZE)
         return(0);
     return(gmetric[font*GFONTSIZE+c-32]);
 }