{-# OPTIONS_GHC -fglasgow-exts #-}
---------------------------------------------------------
-- |
-- Copyright   : (c) alpha 2006
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- PDF API for Haskell
---------------------------------------------------------
-- #hide
module Graphics.PDF.Draw(
 -- * Draw monad
   Draw
 , PDFStream(..)
 , withNewContext
 , DrawState(..)
 , DrawEnvironment(..)
 , readDrawST 
 , writeDrawST 
 , modifyDrawST 
 , DrawTuple()
 , penPosition
 , supplyName
 , emptyDrawing
-- , writeCmd
 , runDrawing
 , setResource
 , emptyEnvironment
 , PDFXForm
 , PDFXObject(..)
 , AnyPdfXForm
 , pdfDictMember
 -- PDF types
 , PDF(..)
 , PDFPage(..)
 , PDFPages(..)
 , PdfState(..)
 , PDFCatalog(..)
 , Pages(..)
 , PDFDocumentPageMode(..)
 , PDFDocumentPageLayout(..)
 , PDFViewerPreferences(..)
 , PDFDocumentInfo(..)
 -- ** Page transitions
 , PDFTransition(..)
 , PDFTransStyle(..)
 , PDFTransDirection(..)
 , PDFTransDimension(..)
 , PDFTransDirection2(..)
 -- ** Outlines
 , PDFOutline(..)
 , OutlineStyle(..)
 , PDFOutlineEntry(..)
 , Destination(..)
 , Outline
 , OutlineLoc(..)
 , Tree(..)
 , OutlineCtx(..)
 , AnnotationObject(..)
 , Color(..)
 , hsvToRgb
 , OutlineData
 , AnyAnnotation(..)
 , AnnotationStyle(..)
 , PDFShading(..)
 , getRgbColor
 , emptyDrawState
 , Matrix(..)
 , identity
 , applyMatrix
 , currentMatrix
 , multiplyCurrentMatrixWith
 , PDFGlobals(..)
 ) where
 
import Data.Maybe
import Data.Monoid

import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Binary.Builder as BU

import Control.Monad.ST
import Data.STRef

import Control.Monad.Writer.Class
import Control.Monad.Reader.Class
import Control.Monad.State

import Graphics.PDF.Coordinates
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.LowLevel.Serializer
import Graphics.PDF.Resources
import Graphics.PDF.Data.PDFTree(PDFTree)

data AnnotationStyle = AnnotationStyle !(Maybe Color)

class AnnotationObject a where
    addAnnotation :: a -> PDF (PDFReference a)
    annotationType :: a -> PDFName
    annotationContent :: a -> PDFString
    annotationRect :: a -> [PDFFloat]
    annotationToGlobalCoordinates :: a -> Draw a
    annotationToGlobalCoordinates = return
    
data AnyAnnotation = forall a.(PdfObject a,AnnotationObject a) => AnyAnnotation a

instance PdfObject AnyAnnotation where
    toPDF (AnyAnnotation a) = toPDF a
    
instance AnnotationObject AnyAnnotation where
    addAnnotation (AnyAnnotation a) = do
        PDFReference r <- addAnnotation a
        return (PDFReference r)
    annotationType (AnyAnnotation a) = annotationType a
    annotationContent (AnyAnnotation a) = annotationContent a
    annotationRect (AnyAnnotation a) = annotationRect a
    

-- | A PDF color
data Color = Rgb !Double !Double !Double
           | Hsv !Double !Double !Double
           deriving(Eq,Ord)

data DrawState = DrawState {
                   supplyNames :: [String]
                ,  rsrc :: PDFResource
                ,  strokeAlphas :: M.Map StrokeAlpha String
                ,  fillAlphas :: M.Map FillAlpha String
                ,  theFonts :: M.Map PDFFont String
                ,  xobjects :: M.Map (PDFReference AnyPdfXForm) String
                ,  otherRsrcs :: PDFDictionary
                ,  annots :: [AnyAnnotation]
                ,  patterns :: M.Map (PDFReference AnyPdfPattern) String
                ,  colorSpaces :: M.Map PDFColorSpace String
                ,  shadings :: M.Map PDFShading String
                ,  matrix :: [Matrix]
                }
data DrawEnvironment = DrawEnvironment {
                        streamId :: Int
                     ,  xobjectBoundD :: IM.IntMap (PDFFloat,PDFFloat)
                     }   

data DrawTuple s
   = DrawTuple {  drawEnvironment    :: DrawEnvironment
               ,  drawStateRef  :: STRef s DrawState
               ,  builderRef :: STRef s BU.Builder
               ,  penPosition :: STRef s Point
               }
    
emptyEnvironment :: DrawEnvironment
emptyEnvironment = DrawEnvironment 0 IM.empty

class PDFGlobals m where
    bounds :: PDFXObject a => PDFReference a -> m (PDFFloat,PDFFloat)
    
-- | The drawing monad
newtype Draw a = Draw {unDraw :: forall s. DrawTuple s -> ST s a }

instance Monad Draw where
    m >>= f  = Draw $ \env -> do
                          a <- unDraw m env
                          unDraw (f a) env
    return x = Draw $ \_env -> return x

instance MonadReader DrawEnvironment Draw where
   ask       = Draw $ \env -> return (drawEnvironment env)
   local f m = Draw $ \env -> let drawenv' = f (drawEnvironment env)
                                  env' = env { drawEnvironment = drawenv' }
                               in unDraw m env' 

instance MonadState DrawState Draw where
    get    = Draw $ \env -> readSTRef  (drawStateRef env)
    put st = Draw $ \env -> writeSTRef (drawStateRef env) st

instance MonadWriter BU.Builder Draw where
    tell bu  = Draw $ \env -> modifySTRef (builderRef env) (`mappend` bu)
    listen m = Draw $ \env -> do
                 a <- unDraw m env
                 w <- readSTRef (builderRef env)
                 return (a,w)
    pass   m = Draw $ \env -> do
                 (a, f) <- unDraw m env
                 modifySTRef (builderRef env) f
                 return a

instance Functor Draw where
     fmap f = \m -> do { a <- m; return (f a) }

instance MonadPath Draw

readDrawST :: (forall s. DrawTuple s -> STRef s a) -> Draw a
readDrawST   f   = Draw $ \env -> readSTRef   (f env) 

writeDrawST :: (forall s. DrawTuple s -> STRef s a) -> a -> Draw ()
writeDrawST  f x = Draw $ \env -> writeSTRef  (f env) x 

modifyDrawST :: (forall s. DrawTuple s -> STRef s a) -> (a -> a) -> Draw ()
modifyDrawST f g = Draw $ \env -> modifySTRef (f env) g

-- | A PDF stream object
data PDFStream = PDFStream !BU.Builder !Bool !(PDFReference PDFLength) !PDFDictionary
                                   
instance PdfObject PDFStream where
  toPDF (PDFStream s c l d) = 
      mconcat   $ [ toPDF dict
                  , serialize "\nstream"
                  , newline
                  , s
                  , newline
                  , serialize "endstream"]
   where
      compressedStream False = []
      compressedStream True = if not (pdfDictMember (PDFName "Filter") d) then [(PDFName "Filter",AnyPdfObject $ [AnyPdfObject . PDFName $ "FlateDecode"])] else []
      lenDict = PDFDictionary. M.fromList $ [ (PDFName "Length",AnyPdfObject l)] ++ compressedStream c
      dict = pdfDictUnion lenDict d
    
-- | An empty drawing
emptyDrawing :: Draw ()
emptyDrawing = return ()
  
-- | is member of the dictionary
pdfDictMember :: PDFName -> PDFDictionary -> Bool
pdfDictMember k (PDFDictionary d)  = M.member k d

-- | Get a new resource name
supplyName :: Draw String
supplyName = do
    (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 [identity]
  
-- | Execute the drawing commands to get a new state and an uncompressed PDF stream
runDrawing :: Draw a -> DrawEnvironment -> DrawState -> (a,DrawState,BU.Builder)
runDrawing drawing environment state 
    = runST $ do
        dRef <- newSTRef state
        bRef <- newSTRef mempty
        posRef <- newSTRef 0
        let tuple = DrawTuple { drawEnvironment = environment
                              , drawStateRef    = dRef
                              , builderRef      = bRef
                              , penPosition     = posRef
                              } 
        a <- unDraw drawing tuple
        drawSt <- readSTRef (drawStateRef tuple)
        builder <- readSTRef (builderRef tuple)
        return (a, drawSt, builder)
     
pushMatrixStack :: Matrix -> Draw ()
pushMatrixStack m = do
    modifyStrict $ \s -> s {matrix = m : matrix s}
    
popMatrixStack :: Draw ()
popMatrixStack = do
    modifyStrict $ \s -> s {matrix = tail (matrix s)}
    

multiplyCurrentMatrixWith :: Matrix -> Draw ()
multiplyCurrentMatrixWith m' = modifyStrict $ \s -> s {matrix = let (m:l) = matrix s in (m' * m ):l}

    
currentMatrix :: Draw Matrix
currentMatrix = gets matrix >>= return . head
      
-- | 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
    tell . serialize $ "\nq"
    pushMatrixStack identity
    a <- m
    popMatrixStack
    tell . serialize $ "\nQ"
    return a
    
-- | Set a resource in the resource dictionary
setResource :: (Ord a, PdfResourceObject a) => String -- ^ Dict name
            -> a -- ^ Resource value
            -> M.Map a String -- ^ Old cache value
            -> Draw (String,M.Map a String) -- ^ New cache value
setResource dict values oldCache = do
    case M.lookup values oldCache of
        Nothing -> do
             newName <- supplyName
             modifyStrict $ \s -> s { rsrc = addResource (PDFName dict) (PDFName newName) (toRsrc values) (rsrc s)}
             return (newName,M.insert values newName oldCache)
        Just n -> return (n,oldCache)

instance PDFGlobals Draw where
    bounds (PDFReference r) = getBoundInDraw r
    
instance PDFGlobals PDF where
    bounds (PDFReference r) = getBoundInPDF r
    
-- | A PDF Xobject which can be drawn
class PDFXObject a where
    drawXObject :: PDFReference a -> Draw ()
    
    privateDrawXObject :: PDFReference a -> Draw ()
    privateDrawXObject (PDFReference r) = do
        xobjectMap <- gets xobjects
        (newName,newMap) <- setResource "XObject" (PDFReference r) xobjectMap
        modifyStrict $ \s -> s { xobjects = newMap }
        tell . mconcat  $ [ serialize "\n/" 
                          , serialize newName
                          , serialize " Do"
                          ]
    drawXObject = privateDrawXObject
    
-- | An XObject
data AnyPdfXForm = forall a. (PDFXObject a,PdfObject a) => AnyPdfXForm a
instance PdfObject AnyPdfXForm where
    toPDF (AnyPdfXForm a) = toPDF a

instance PDFXObject AnyPdfXForm

data PDFXForm
instance PDFXObject PDFXForm
instance PdfObject PDFXForm where
    toPDF _ = noPdfObject
instance PdfResourceObject (PDFReference PDFXForm) where
    toRsrc = AnyPdfObject
    
instance PdfResourceObject (PDFReference AnyPdfXForm) where
    toRsrc = AnyPdfObject
    

-- | Get the bounds for an xobject
getBoundInDraw :: Int -- ^ Reference
         -> Draw (PDFFloat,PDFFloat)  
getBoundInDraw ref = do
    theBounds <- asks xobjectBoundD
    return $ IM.findWithDefault (0.0,0.0) ref theBounds
 
-- | Get the bounds for an xobject
getBoundInPDF :: Int -- ^ Reference
              -> PDF (PDFFloat,PDFFloat)  
getBoundInPDF ref = do
    theBounds <- gets xobjectBound
    return $ IM.findWithDefault (0.0,0.0) ref theBounds
   
-----------
--
-- PDF types
--
------------

-- | The PDF Catalog
data PDFCatalog = PDFCatalog 
                   !(Maybe (PDFReference PDFOutline))
                   !(PDFReference PDFPages)
                   !PDFDocumentPageMode
                   !PDFDocumentPageLayout
                   !PDFViewerPreferences

-- | The PDF state
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)),(DrawState,BU.Builder))) -- ^ Draw commands
                         , catalog :: !(PDFReference PDFCatalog) -- ^ Reference to the PDF catalog
                         , defaultRect :: !PDFRect -- ^ Default page size
                         , docInfo :: !PDFDocumentInfo -- ^ Document infos
                         , outline :: Maybe Outline -- ^ Root outline
                         , currentPage :: Maybe (PDFReference PDFPage) -- ^ Reference to the current page used to create outlines
                         , xobjectBound :: !(IM.IntMap (PDFFloat,PDFFloat)) -- ^ Width and height of xobjects
                         , firstOutline :: [Bool] -- ^ Used to improve the outline API
                         }
                         
-- | A PDF Page object
#ifndef __HADDOCK__
data PDFPage = PDFPage 
          !(Maybe (PDFReference PDFPages)) --  Reference to parent
          !(PDFRect) -- Media box
          !(PDFReference PDFStream) -- Reference to content
          !(Maybe (PDFReference PDFResource)) -- Reference to resources
          !(Maybe PDFFloat) -- Optional duration
          !(Maybe PDFTransition) -- Optional transition
          ![AnyPdfObject] -- Annotation array
#else
data PDFPage
#endif

instance Show PDFPage where
    show _ = "PDFPage"
    
-- | List of all pages
newtype Pages = Pages (PDFTree PDFPage)

-- | PDF Pages
#ifndef __HADDOCK__
data PDFPages = PDFPages 
              !Int
              !(Maybe (PDFReference PDFPages)) -- Reference to parent 
              [Either (PDFReference PDFPages) (PDFReference PDFPage)]
#else
data PDFPages
#endif

-- | A PDF Transition
data PDFTransition = PDFTransition !PDFFloat !PDFTransStyle  
  deriving(Eq)


-- | Dimension of a transition
data PDFTransDimension = Horizontal | Vertical 
 deriving(Eq)


instance Show PDFTransDimension where
    show Horizontal = "H"
    show Vertical = "V"

-- | Direction of a transition
data PDFTransDirection = Inward | Outward deriving(Eq)

instance Show PDFTransDirection where
    show Inward = "I"
    show Outward = "O"

-- | Direction of a transition
data PDFTransDirection2 = LeftToRight
                        | BottomToTop -- ^ Wipe only
                        | RightToLeft -- ^ Wipe only
                        | TopToBottom
                        | TopLeftToBottomRight -- ^ Glitter only
                        deriving(Eq)

-- | The PDF Monad
newtype PDF a = PDF {unPDF :: State PdfState a}
#ifndef __HADDOCK__
  deriving (Functor, Monad, MonadState PdfState)
#else
instance Functor PDF
instance Monad PDF
instance MonadState PdfState PDF
#endif

-- | Transition style
data PDFTransStyle = Split PDFTransDimension PDFTransDirection
                   | Blinds PDFTransDimension 
                   | Box  PDFTransDirection
                   | Wipe PDFTransDirection2
                   | Dissolve 
                   | Glitter PDFTransDirection2
                   deriving(Eq)

-- | Document metadata
data PDFDocumentInfo = PDFDocumentInfo {
                     author :: PDFString
                   , subject :: PDFString
                   , pageMode :: PDFDocumentPageMode
                   , pageLayout :: PDFDocumentPageLayout
                   , viewerPreferences :: PDFViewerPreferences
                   , compressed :: Bool
                   }


-- | Document page mode
data PDFDocumentPageMode = UseNone
                       | UseOutlines
                       | UseThumbs
                       | FullScreen
                       deriving(Eq,Show)

-- | Document page layout
data PDFDocumentPageLayout = SinglePage
                           | OneColumn
                           | TwoColumnLeft
                           | TwoColumnRight
                           | TwoPageLeft
                           | TwoPageRight
                           deriving(Eq,Show)

-- | Viewer preferences
data PDFViewerPreferences = PDFViewerPreferences { hideToolbar :: Bool -- ^ To hide the toolbar
                          , hideMenuBar :: Bool -- ^ To hide the menubar
                          , hideWindowUI :: Bool -- ^ To hide the window
                          , fitWindow :: Bool -- ^ Fit window to screen
                          , centerWindow :: Bool -- ^ Center window on screen
                          , displayDoctitle :: Bool -- ^ Display the docu,ent title
                          , nonFullScreenPageMode :: PDFDocumentPageMode -- ^ Display mode when exiting the full screen mode
                          }

data PDFOutline = PDFOutline !(PDFReference PDFOutlineEntry) !(PDFReference PDFOutlineEntry)

instance PdfObject PDFOutline where
 toPDF (PDFOutline first lasto) = toPDF $ PDFDictionary. M.fromList $ [
    (PDFName "Type",AnyPdfObject . PDFName $ "Outlines")
  , (PDFName "First",AnyPdfObject first)
  , (PDFName "Last",AnyPdfObject lasto)
  ]

data OutlineStyle = NormalOutline
                  | ItalicOutline
                  | BoldOutline
                  deriving(Eq)

data PDFOutlineEntry = PDFOutlineEntry !PDFString 
                              !(PDFReference PDFOutlineEntry) -- Parent
                              !(Maybe (PDFReference PDFOutlineEntry)) -- Prev
                              !(Maybe (PDFReference PDFOutlineEntry)) -- Next
                              !(Maybe (PDFReference PDFOutlineEntry)) -- First
                              !(Maybe (PDFReference PDFOutlineEntry)) -- Last
                              Int -- Count of descendent (negative)
                              Destination
                              Color --
                              OutlineStyle 

data Destination = Destination !(PDFReference PDFPage) deriving(Eq,Show)

-- Outline types without a position pointer. The true outline is the derivative
type OutlineData = (PDFString,Maybe Color, Maybe OutlineStyle,Destination)
type Outline = OutlineLoc OutlineData

data Tree a = Node a [Tree a]

data OutlineCtx a = Top | Child { value :: a
                                , parent :: OutlineCtx a 
                                , lefts :: [Tree a]
                                , rights :: [Tree a]
                                }
                                

data OutlineLoc  a = OutlineLoc (Tree a) (OutlineCtx a)

instance PdfObject PDFViewerPreferences where
  toPDF (PDFViewerPreferences ht hm hwui fw cw ddt nfspm ) = toPDF $ PDFDictionary. M.fromList $ 
   [ (PDFName "HideToolbar",AnyPdfObject ht)
   , (PDFName "HideMenubar",AnyPdfObject hm)
   , (PDFName "HideWindowUI",AnyPdfObject hwui)
   , (PDFName "FitWindow",AnyPdfObject fw)
   , (PDFName "CenterWindow",AnyPdfObject cw)
   , (PDFName "DisplayDocTitle",AnyPdfObject ddt)
   , (PDFName "NonFullScreenPageMode",AnyPdfObject  . PDFName . show $ nfspm)
   ]


instance Show PDFTransStyle where
   show (Split _ _) = "Split"
   show (Blinds _) = "Blinds"
   show (Box _) = "Box"
   show (Wipe _) = "Wipe"
   show (Dissolve) = "Dissolve"
   show (Glitter _) = "Glitter"

instance PdfObject PDFTransition where
 toPDF (PDFTransition d t) = toPDF $ PDFDictionary. M.fromList $ 
   [ (PDFName "Type",AnyPdfObject (PDFName "Trans"))
   , (PDFName "S",AnyPdfObject (PDFName (show t)))
   , (PDFName "D",AnyPdfObject d)
   ] ++ optionalDm t ++ optionalM t ++ optionalDi t
  where
    optionalDm (Split a _) = [ (PDFName "Dm",AnyPdfObject (PDFName (show a)))]
    optionalDm (Blinds a) = [ (PDFName "Dm",AnyPdfObject (PDFName (show a)))]
    optionalDm _ = []
    optionalM (Split _ a) = [ (PDFName "M",AnyPdfObject (PDFName (show a)))]
    optionalM (Box a) = [ (PDFName "M",AnyPdfObject (PDFName (show a)))]
    optionalM _ = []    
    optionalDi (Wipe a) = [ (PDFName "Di",AnyPdfObject (floatDirection a))]
    optionalDi (Glitter a)  = [ (PDFName "Di",AnyPdfObject (floatDirection a))]
    optionalDi _ = []  

-- PDF Pages

instance PdfObject PDFPages where
 toPDF (PDFPages c Nothing l) = toPDF $ PDFDictionary. M.fromList $ 
  [ (PDFName "Type",AnyPdfObject (PDFName "Pages"))
  , (PDFName "Kids",AnyPdfObject $ map AnyPdfObject l)
  , (PDFName "Count",AnyPdfObject . PDFInteger $ c)
  ] 
 toPDF (PDFPages c (Just theParent) l) = toPDF $ PDFDictionary. M.fromList $ 
  [ (PDFName "Type",AnyPdfObject (PDFName "Pages"))
  , (PDFName "Parent",AnyPdfObject theParent)
  , (PDFName "Kids",AnyPdfObject $ map AnyPdfObject l)
  , (PDFName "Count",AnyPdfObject . PDFInteger $ c)
  ] 


instance PdfObject PDFPage where
 toPDF (PDFPage (Just theParent) box content theRsrc d t theAnnots) = toPDF $ PDFDictionary. M.fromList $ 
  [ (PDFName "Type",AnyPdfObject (PDFName "Page"))
  , (PDFName "Parent",AnyPdfObject theParent)
  , (PDFName "MediaBox",AnyPdfObject box)
  , (PDFName "Contents",AnyPdfObject content)
  , if isJust theRsrc 
      then
       (PDFName "Resources",AnyPdfObject . fromJust $ theRsrc) 
      else 
       (PDFName "Resources",AnyPdfObject emptyDictionary)
  ] ++ (maybe [] (\x -> [(PDFName "Dur",AnyPdfObject x)]) d)
  ++ (maybe [] (\x -> [(PDFName "Trans",AnyPdfObject x)]) t)
  ++ ((\x -> if null x then [] else [(PDFName "Annots",AnyPdfObject x)]) theAnnots)
 toPDF (PDFPage Nothing _ _ _ _ _ _) = noPdfObject


-- Main objects in a PDF document

instance PdfObject PDFCatalog where
 toPDF (PDFCatalog outlines lPages pgMode pgLayout viewerPrefs) = toPDF $ PDFDictionary . M.fromList $ 
   [ (PDFName "Type",AnyPdfObject (PDFName "Catalog"))
   , (PDFName "Pages",AnyPdfObject lPages)
   , (PDFName "PageMode", AnyPdfObject . PDFName . show $ pgMode)
   , (PDFName "PageLayout", AnyPdfObject . PDFName . show $ pgLayout)
   , (PDFName "ViewerPreferences", AnyPdfObject viewerPrefs)
   ] ++ (maybe [] (\x -> [(PDFName "Outlines",AnyPdfObject x)]) outlines)


instance PdfObject OutlineStyle where
   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) = 
     toPDF $ PDFDictionary. M.fromList $ [
        (PDFName "Title",AnyPdfObject title)
        , (PDFName "Parent",AnyPdfObject theParent)
        ]
      ++
      maybe [] (\x -> [(PDFName "Prev",AnyPdfObject x)]) prev
      ++
      maybe [] (\x -> [(PDFName "Next",AnyPdfObject x)]) next
      ++
      maybe [] (\x -> [(PDFName "First",AnyPdfObject x)]) first
      ++
      maybe [] (\x -> [(PDFName "Last",AnyPdfObject x)]) theLast
      ++
      [ (PDFName "Count",AnyPdfObject (PDFInteger count))
      , (PDFName "Dest",AnyPdfObject dest)
      , (PDFName "C",AnyPdfObject color)
      , (PDFName "F",AnyPdfObject style)
      ]



instance PdfObject Destination where
  toPDF (Destination r) = toPDF                [ AnyPdfObject r
                                               , AnyPdfObject . PDFName $ "Fit"
                                               ]
                                               
instance PdfObject Color where
   toPDF (Rgb r g b) = toPDF . map AnyPdfObject $ [r,g,b]  
   toPDF (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v)
    in toPDF . map AnyPdfObject $ [r,g,b]

-- Degree for a transition direction
floatDirection :: PDFTransDirection2 -> PDFFloat
floatDirection LeftToRight = 0
floatDirection BottomToTop = 90
floatDirection RightToLeft = 180 
floatDirection TopToBottom = 270
floatDirection TopLeftToBottomRight = 315


hsvToRgb :: (Double,Double,Double) -> (Double,Double,Double)
hsvToRgb (h,s,v) =
  let hi = fromIntegral (floor (h / 60) `mod` 6 :: Int) :: Double
      f = h/60 - hi
      p = v * (1-s)
      q = v * (1 - f*s)
      t = v * (1 - (1-f)*s) in
 case hi of
      0 -> (v,t,p)
      1 -> (q,v,p)
      2 -> (p,v,t)
      3 -> (p,q,v)
      4 -> (t,p,v)
      5 -> (v,p,q)
      _ -> error "Hue value incorrect"

getRgbColor :: Color -> (PDFFloat,PDFFloat,PDFFloat) 
getRgbColor (Rgb r g b) = (r, g, b)  
getRgbColor (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v) in (r, g, b)  

-- | Interpolation function
interpole :: Int -> PDFFloat -> PDFFloat -> AnyPdfObject
interpole n x y = AnyPdfObject . PDFDictionary . M.fromList $ 
                            [ (PDFName "FunctionType", AnyPdfObject . PDFInteger $ 2)
                            , (PDFName "Domain", AnyPdfObject . map AnyPdfObject $ ([0,1] :: [PDFFloat]))
                            , (PDFName "C0", AnyPdfObject . map AnyPdfObject $ [x])
                            , (PDFName "C1", AnyPdfObject . map AnyPdfObject $ [y])
                            , (PDFName "N", AnyPdfObject . PDFInteger $  n)
                            ]

-- | A shading                             
data PDFShading = AxialShading PDFFloat PDFFloat PDFFloat PDFFloat Color Color
                | RadialShading PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat Color Color
                deriving(Eq,Ord)

instance PdfResourceObject PDFShading where
      toRsrc (AxialShading x0 y0 x1 y1 ca cb) = AnyPdfObject . PDFDictionary . M.fromList $
                                 [ (PDFName "ShadingType",AnyPdfObject . PDFInteger $ 2)
                                 , (PDFName "Coords",AnyPdfObject . map AnyPdfObject $ [x0,y0,x1,y1])
                                 , (PDFName "ColorSpace",AnyPdfObject . PDFName $ "DeviceRGB")
                                 , (PDFName "Function",AnyPdfObject $ [interpole 1 ra rb,interpole 1 ga gb,interpole 1 ba bb])
                                 ]
        where
            (ra,ga,ba) = getRgbColor ca
            (rb,gb,bb) = getRgbColor cb
      toRsrc (RadialShading x0 y0 r0 x1 y1 r1 ca cb) = AnyPdfObject . PDFDictionary . M.fromList $
                                         [ (PDFName "ShadingType",AnyPdfObject . PDFInteger $ 3)
                                         , (PDFName "Coords",AnyPdfObject . map AnyPdfObject $ [x0,y0,r0,x1,y1,r1])
                                         , (PDFName "ColorSpace",AnyPdfObject . PDFName $ "DeviceRGB")
                                         , (PDFName "Function",AnyPdfObject $ [interpole 1 ra rb,interpole 1 ga gb,interpole 1 ba bb])
                                         ]
        where
           (ra,ga,ba) = getRgbColor ca
           (rb,gb,bb) = getRgbColor cb


-- | Apply a transformation matrix to the current coordinate frame
applyMatrix :: Matrix -> Draw ()
applyMatrix m@(Matrix a b c d e f)  = do
    multiplyCurrentMatrixWith m
    tell . mconcat $[ serialize '\n'
                    , toPDF a
                    , serialize ' '
                    , toPDF b
                    , serialize ' '
                    , toPDF c
                    , serialize ' '
                    , toPDF d
                    , serialize ' '
                    , toPDF e
                    , serialize ' '
                    , toPDF f
                    , serialize " cm"
                    ]