{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
---------------------------------------------------------
-- |
-- Copyright   : (c) 2006-2016, alpheccar.org
-- 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
 , registerResource
 , 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(..)
 , ColorSpace(..)
 , colorSpaceName
 , calculator1
 , calculator2
 , ColorFunction1(..)
 , ColorFunction2(..)
 , Function1(..)
 , Function2(..)
 , Global
 , Local
 , linearStitched
 , FunctionObject(FunctionObject, FunctionStream)
 , rsrcFromCalculator
 , rsrcFromInterpolated
 , rsrcFromSampled
 , rsrcFromStitched
 , ColorTuple
 , domain1Dict
 , domain2Dict
 , SoftMask(..)
 , getRgbColor
 , emptyDrawState
 , Matrix(..)
 , identity
 , applyMatrix
 , currentMatrix
 , multiplyCurrentMatrixWith
 , PDFGlobals(..)
 ) where

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif

import qualified Data.Map.Strict as M
import qualified Data.IntMap as IM
import qualified Data.Binary.Builder as BU
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.Array as Array
import Data.Array (Array)

import Control.Monad.ST
import Data.STRef

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

import qualified Graphics.PDF.Expression as Expr
import Graphics.PDF.Expression (PDFExpression)
import Graphics.PDF.Coordinates
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.LowLevel.Serializer
import Graphics.PDF.Resources
import Graphics.PDF.Data.PDFTree(PDFTree)
import qualified Data.Text as T
import Graphics.PDF.Fonts.Font(PDFFont(..))

import Text.Printf (printf)

data AnnotationStyle = AnnotationStyle !(Maybe Color)

class AnnotationObject a where
    addAnnotation :: a -> PDF (PDFReference a)
    annotationType :: a -> PDFName
    annotationContent :: a -> AnyPdfObject
    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 PdfLengthInfo AnyAnnotation where

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
                ,  softMasks :: M.Map SoftMask 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 Applicative Draw where
    pure x = Draw $ \_env -> return x
    df <*> af = Draw $ \env -> do
       f <- unDraw df env
       a <- unDraw af env
       return $ f 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
        !(Either (PDFReference MaybeLength) 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 [entry "Filter" [PDFName $ "FlateDecode"]] else []
      lenDict = dictFromList $ [either (entry "Length") (entry "Length") l] ++ compressedStream c
      dict = pdfDictUnion lenDict d

instance PdfLengthInfo PDFStream where 
  pdfLengthInfo (PDFStream s _ el _) =
      either
        (\ref -> Just (PDFLength . B.length . BU.toLazyByteString $ s, ref))
        (const Nothing)
        el

-- | 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
    xs <- gets supplyNames -- infinite list
    modifyStrict $ \s -> s {supplyNames = tail xs}
    return (head xs)
    
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 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 drawState 
    = runST $ do
        dRef <- newSTRef drawState
        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)

-- ToDo: setter and getter could be replaced by an Accessor or a Lens
registerResource ::
    (Ord a, PdfResourceObject a) =>
    String ->
    (DrawState -> M.Map a String) ->
    (M.Map a String -> DrawState -> DrawState) ->
    a -> Draw String
registerResource dict getMap setMap resource = do
    oldMap <- gets getMap
    (newName,newMap) <- setResource dict resource oldMap
    modifyStrict $ setMap newMap
    return newName


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
        newName <-
            registerResource "XObject"
                xobjects (\newMap s -> s { xobjects = newMap })
                (PDFReference r)
        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 PdfLengthInfo AnyPdfXForm where

instance PDFXObject AnyPdfXForm

data PDFXForm
instance PDFXObject PDFXForm
instance PdfObject PDFXForm where
    toPDF _ = noPdfObject
instance PdfLengthInfo PDFXForm where

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, Applicative, 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 :: T.Text
                   , subject :: T.Text
                   , 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 $ dictFromList $ [
    entry "Type" (PDFName $ "Outlines")
  , entry "First" first
  , entry "Last" lasto
  ]

instance PdfLengthInfo PDFOutline where

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 $ dictFromList $
   [ entry "HideToolbar" ht
   , entry "HideMenubar" hm
   , entry "HideWindowUI" hwui
   , entry "FitWindow" fw
   , entry "CenterWindow" cw
   , entry "DisplayDocTitle" ddt
   , entry "NonFullScreenPageMode" (PDFName . show $ nfspm)
   ]

instance PdfLengthInfo PDFViewerPreferences where


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 $ dictFromList $
   [ entry "Type" (PDFName "Trans")
   , entry "S" (PDFName (show t))
   , entry "D" d
   ] ++ optionalDm t ++ optionalM t ++ optionalDi t
  where
    optionalDm (Split a _) = [ entry "Dm" (PDFName (show a))]
    optionalDm (Blinds a) = [ entry "Dm" (PDFName (show a))]
    optionalDm _ = []
    optionalM (Split _ a) = [ entry "M" (PDFName (show a))]
    optionalM (Box a) = [ entry "M" (PDFName (show a))]
    optionalM _ = []    
    optionalDi (Wipe a) = [ entry "Di" (floatDirection a)]
    optionalDi (Glitter a)  = [ entry "Di" (floatDirection a)]
    optionalDi _ = []  

instance PdfLengthInfo PDFTransition where

-- PDF Pages

instance PdfObject PDFPages where
 toPDF (PDFPages c Nothing l) = toPDF $ dictFromList $
  [ entry "Type" (PDFName "Pages")
  , entry "Kids" l
  , entry "Count" (PDFInteger $ c)
  ]
 toPDF (PDFPages c (Just theParent) l) = toPDF $ dictFromList $
  [ entry "Type" (PDFName "Pages")
  , entry "Parent" theParent
  , entry "Kids" l
  , entry "Count" (PDFInteger $ c)
  ]

instance PdfLengthInfo PDFPages where


instance PdfObject PDFPage where
 toPDF (PDFPage (Just theParent) box content theRsrc d t theAnnots) = toPDF $ dictFromList $
  [ entry "Type" (PDFName "Page")
  , entry "Parent" theParent
  , entry "MediaBox" box
  , entry "Contents" content
  , case theRsrc of
      Just res -> entry "Resources" res
      Nothing -> entry "Resources" emptyDictionary
  ] ++ (maybe [] (\x -> [entry "Dur" x]) d)
  ++ (maybe [] (\x -> [entry "Trans" x]) t)
  ++ ((\x -> if null x then [] else [entry "Annots" x]) theAnnots)
 toPDF (PDFPage Nothing _ _ _ _ _ _) = noPdfObject

instance PdfLengthInfo PDFPage where

-- Main objects in a PDF document

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

instance PdfLengthInfo PDFCatalog where

instance PdfObject OutlineStyle where
   toPDF NormalOutline = toPDF (PDFInteger 0)
   toPDF ItalicOutline = toPDF (PDFInteger 1)
   toPDF BoldOutline = toPDF (PDFInteger 2)

instance PdfLengthInfo OutlineStyle where

instance PdfObject PDFOutlineEntry where
 toPDF (PDFOutlineEntry title theParent prev next first theLast count dest color style) = 
     toPDF $ dictFromList $ [
        entry "Title" title
        , entry "Parent" theParent
        ]
      ++
      maybe [] (\x -> [entry "Prev" x]) prev
      ++
      maybe [] (\x -> [entry "Next" x]) next
      ++
      maybe [] (\x -> [entry "First" x]) first
      ++
      maybe [] (\x -> [entry "Last" x]) theLast
      ++
      [ entry "Count" (PDFInteger count)
      , entry "Dest" dest
      , entry "C" color
      , entry "F" style
      ]

instance PdfLengthInfo PDFOutlineEntry where


instance PdfObject Destination where
  toPDF (Destination r) = toPDF                [ AnyPdfObject r
                                               , AnyPdfObject . PDFName $ "Fit"
                                               ]

instance PdfLengthInfo Destination where

                                              
instance PdfObject Color where
   toPDF (Rgb r g b) = toPDF [r,g,b]
   toPDF (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v)
    in toPDF [r,g,b]

instance PdfLengthInfo Color where

-- 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)  

type FloatRGB  = (PDFFloat, PDFFloat, PDFFloat)
type FloatCMYK = (PDFFloat, PDFFloat, PDFFloat, PDFFloat)

class ColorTuple a where
    rgbHex :: a -> String
    colorComponents :: a -> [PDFFloat]
    colorDimensions :: f a e -> Int

instance ColorTuple PDFFloat where
    rgbHex c = printf "%02X" (byteFromFloat c)
    colorComponents c = [c]
    colorDimensions _ = 1

instance (a ~ PDFFloat, b ~ PDFFloat, c ~ PDFFloat) => ColorTuple (a,b,c) where
    rgbHex (r,g,b) =
        printf "%02X%02X%02X"
            (byteFromFloat r) (byteFromFloat g) (byteFromFloat b)
    colorComponents (r,g,b) = [r,g,b]
    colorDimensions _ = 3

instance
    (a ~ PDFFloat, b ~ PDFFloat, c ~ PDFFloat, d ~ PDFFloat) =>
        ColorTuple (a,b,c,d) where
    rgbHex (c,m,y,k) =
        printf "%02X%02X%02X%02X"
            (byteFromFloat c) (byteFromFloat m)
            (byteFromFloat y) (byteFromFloat k)
    colorComponents (c,m,y,k) = [c,m,y,k]
    colorDimensions _ = 4

byteFromFloat :: PDFFloat -> Int
byteFromFloat x = round $ min 255 $ max 0 $ x*255

pdfStreamFromLazyByteString :: C.ByteString -> PDFDictionary -> PDFStream
pdfStreamFromLazyByteString stream dict =
    PDFStream
        (BU.fromLazyByteString stream)
        False
        (Right . PDFLength . B.length $ stream)
        dict

data FunctionObject a e =
      FunctionObject (PDFReference PDFDictionary)
    | FunctionStream (PDFReference PDFStream)
    deriving (Eq, Ord)

rsrcFromSampled ::
    (ColorTuple a) =>
    PDFDictionary ->
    ((i, i) -> [Int]) -> Array i a -> PDFStream
rsrcFromSampled domain computeSizes arr =
    pdfStreamFromLazyByteString
        ((C.pack $ concatMap rgbHex $ Array.elems arr)
            <>
            C.pack " >")
        (pdfDictUnion domain . dictFromList $
           [entry "FunctionType" (PDFInteger 0),
            entry "Size" (computeSizes $ Array.bounds arr),
            entry "BitsPerSample" (PDFInteger 8),
            entry "Filter" (PDFName "ASCIIHexDecode")
            ])

-- | Interpolation function
rsrcFromInterpolated ::
    (ColorTuple a) =>
    PDFDictionary -> PDFFloat -> a -> a -> PDFDictionary
rsrcFromInterpolated domain n a b =
    pdfDictUnion domain . dictFromList $
                            [ entry "FunctionType" (PDFInteger 2)
                            , entry "C0" (colorComponents a)
                            , entry "C1" (colorComponents b)
                            , entry "N" n
                            ]

rsrcFromStitched ::
    (ColorTuple a, Expr.Result e) =>
    PDFDictionary ->
    Function1 Local a e -> [(PDFFloat, Function1 Local a e)] -> PDFDictionary
rsrcFromStitched domain part parts =
    let funcs = part : map snd parts in
    pdfDictUnion domain . dictFromList $
        [ entry "FunctionType" (PDFInteger 3)
        , entry "Bounds" (map fst parts)
        , entry "Encode" (concatMap (const [0,1::Int]) funcs)
        , entry "Functions" (map toRsrc funcs)
        ]

rsrcFromCalculator ::
    (Expr.Function f) => PDFDictionary -> f -> PDFStream
rsrcFromCalculator domain f =
    pdfStreamFromLazyByteString
        (C.cons '{' $ C.snoc (Expr.serialize f) '}')
        (pdfDictUnion domain . dictFromList $
            [entry "FunctionType" (PDFInteger 4)])


type ExprFloat = PDFExpression PDFFloat
type ExprRGB = (ExprFloat, ExprFloat, ExprFloat)
type ExprCMYK = (ExprFloat, ExprFloat, ExprFloat, ExprFloat)


data ColorSpace a e where
    GraySpace :: ColorSpace PDFFloat ExprFloat
    RGBSpace :: ColorSpace FloatRGB ExprRGB
    CMYKSpace :: ColorSpace FloatCMYK ExprCMYK

deriving instance Eq (ColorSpace a e)
deriving instance Ord (ColorSpace a e)

colorSpaceName :: ColorSpace a e -> PDFName
colorSpaceName space =
    case space of
        GraySpace -> PDFName "DeviceGray"
        RGBSpace -> PDFName "DeviceRGB"
        CMYKSpace -> PDFName "DeviceCMYK"

colorSpaceEntry :: ColorSpace a e -> (PDFName, AnyPdfObject)
colorSpaceEntry space = entry "ColorSpace" $ colorSpaceName space

rangeEntry :: (ColorTuple a) => f a e -> (PDFName, AnyPdfObject)
rangeEntry func =
    entry "Range" $ concat $ replicate (colorDimensions func) [0,1::Int]


data ColorFunction1 =
    forall a e.
    (ColorTuple a, Expr.Result e) =>
    ColorFunction1 (ColorSpace a e) (Function1 Local a e)

instance Eq ColorFunction1 where
    ColorFunction1 spaceA funcA == ColorFunction1 spaceB funcB  =
        case (spaceA, spaceB) of
            (GraySpace, GraySpace) -> funcA == funcB
            (RGBSpace, RGBSpace) -> funcA == funcB
            (CMYKSpace, CMYKSpace) -> funcA == funcB
            _ -> False

instance Ord ColorFunction1 where
    compare (ColorFunction1 spaceA funcA) (ColorFunction1 spaceB funcB) =
        case (spaceA, spaceB) of
            (GraySpace, GraySpace) -> compare funcA funcB
            (RGBSpace, RGBSpace) -> compare funcA funcB
            (CMYKSpace, CMYKSpace) -> compare funcA funcB
            (GraySpace, _) -> LT; (_, GraySpace) -> GT
            (RGBSpace,  _) -> LT; (_, RGBSpace)  -> GT


data ColorFunction2 =
    forall a e.
    (ColorTuple a, Expr.Result e) =>
    ColorFunction2 (ColorSpace a e) (Function2 Local a e)

instance Eq ColorFunction2 where
    ColorFunction2 spaceA funcA == ColorFunction2 spaceB funcB  =
        case (spaceA, spaceB) of
            (GraySpace, GraySpace) -> funcA == funcB
            (RGBSpace, RGBSpace) -> funcA == funcB
            (CMYKSpace, CMYKSpace) -> funcA == funcB
            _ -> False

instance Ord ColorFunction2 where
    compare (ColorFunction2 spaceA funcA) (ColorFunction2 spaceB funcB) =
        case (spaceA, spaceB) of
            (GraySpace, GraySpace) -> compare funcA funcB
            (RGBSpace, RGBSpace) -> compare funcA funcB
            (CMYKSpace, CMYKSpace) -> compare funcA funcB
            (GraySpace, _) -> LT; (_, GraySpace) -> GT
            (RGBSpace,  _) -> LT; (_, RGBSpace)  -> GT


data Global
data Local

data Function1 scope a e where
    GlobalFunction1 ::
        FunctionObject (PDFFloat -> a) (ExprFloat -> e) ->
        Function1 Local a e
    Sampled1 :: Array Int a -> Function1 Global a e
    Interpolated1 :: PDFFloat -> a -> a -> Function1 scope a e
    Stitched1 ::
        Function1 Local a e -> [(PDFFloat, Function1 Local a e)] ->
        Function1 scope a e
    Calculator1 :: (ExprFloat -> e) -> Function1 Global a e

instance
    (Local ~ scope, ColorTuple a, Eq a, Expr.Result e) =>
        Eq (Function1 scope a e) where
    a==b =
        case (a,b) of
            (GlobalFunction1 fa, GlobalFunction1 fb) -> fa == fb
            (Interpolated1 na xa ya, Interpolated1 nb xb yb) ->
                (na, xa, ya) == (nb, xb, yb)
            (Stitched1 partA partsA, Stitched1 partB partsB) ->
                (partA, partsA) == (partB, partsB)
            _ -> False

instance
    (Local ~ scope, ColorTuple a, Ord a, Expr.Result e) =>
        Ord (Function1 scope a e) where
    compare a b =
        case (a,b) of
            (GlobalFunction1 fa, GlobalFunction1 fb) -> compare fa fb
            (Interpolated1 na xa ya, Interpolated1 nb xb yb) ->
                compare (na, xa, ya) (nb, xb, yb)
            (Stitched1 partA partsA, Stitched1 partB partsB) ->
                compare (partA, partsA) (partB, partsB)
            (GlobalFunction1 _, _) -> LT
            (_, GlobalFunction1 _) -> GT
            (Interpolated1 _ _ _, _) -> LT
            (_, Interpolated1 _ _ _) -> GT


-- ToDo: would be more type-safe with non-empty: NonEmpty (NonEmpty [])
mapAdjacent :: (a -> a -> b) -> [a] -> [b]
mapAdjacent f xs = zipWith f xs (tail xs)

linearStitched ::
    (ColorTuple a) => a -> [(PDFFloat, a)] -> a -> Function1 Local a e
linearStitched firstY nodes lastY =
    case mapAdjacent (Interpolated1 1)
            (firstY : map snd nodes ++ lastY : []) of
        [] -> error "list should be non-empty by construction"
        part:parts -> Stitched1 part (zip (map fst nodes) parts)

calculator1 :: (ExprFloat -> e) -> Function1 Global a e
calculator1 = Calculator1

domain1Dict :: (ColorTuple a) => f a e -> PDFDictionary
domain1Dict func =
    dictFromList [
        entry "Domain" [0,1::Int],
        rangeEntry func
    ]

instance
    (Local ~ scope, ColorTuple a, Expr.Result e) =>
        PdfResourceObject (Function1 scope a e) where
    toRsrc func =
        let domain = domain1Dict func in
        case func of
            GlobalFunction1 (FunctionObject obj) -> AnyPdfObject obj
            GlobalFunction1 (FunctionStream obj) -> AnyPdfObject obj
            Interpolated1 n x y ->
                AnyPdfObject $ rsrcFromInterpolated domain n x y
            Stitched1 part parts ->
                AnyPdfObject $ rsrcFromStitched domain part parts


data Function2 scope a e where
    GlobalFunction2 ::
        FunctionObject
            (PDFFloat -> PDFFloat -> a) (ExprFloat -> ExprFloat -> e) ->
        Function2 Local a e
    Sampled2 :: (Array (Int,Int) a) -> Function2 Global a e
    Calculator2 :: (ExprFloat -> ExprFloat -> e) -> Function2 Global a e

instance
    (Local ~ scope, ColorTuple a, Eq a, Expr.Result e) =>
        Eq (Function2 scope a e) where
    a==b =
        case (a,b) of
            (GlobalFunction2 fa, GlobalFunction2 fb) -> fa == fb

instance
    (Local ~ scope, ColorTuple a, Ord a, Expr.Result e) =>
        Ord (Function2 scope a e) where
    compare a b =
        case (a,b) of
            (GlobalFunction2 fa, GlobalFunction2 fb) -> compare fa fb

calculator2 :: (ExprFloat -> ExprFloat -> e) -> Function2 Global a e
calculator2 = Calculator2

domain2Dict :: (ColorTuple a) => f a e -> PDFDictionary
domain2Dict func =
    dictFromList [
        entry "Domain" [0,1, 0,1::Int],
        rangeEntry func
    ]

instance
    (Local ~ scope, ColorTuple a, Expr.Result e) =>
        PdfResourceObject (Function2 scope a e) where
    toRsrc func =
        case func of
            GlobalFunction2 (FunctionObject obj) -> AnyPdfObject obj
            GlobalFunction2 (FunctionStream obj) -> AnyPdfObject obj


-- | A shading
data PDFShading =
      FunctionalShading Matrix ColorFunction2
    | AxialShading PDFFloat PDFFloat PDFFloat PDFFloat ColorFunction1
    | RadialShading PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat ColorFunction1
                deriving(Eq,Ord)

matrixCoefficients :: Matrix -> [PDFFloat]
matrixCoefficients (Matrix a b c d e f) = [a,b,c,d,e,f]

instance PdfResourceObject PDFShading where
      toRsrc (FunctionalShading mat (ColorFunction2 cs func)) =
          AnyPdfObject . dictFromList $
                                 [ entry "ShadingType" (PDFInteger $ 1)
                                 , entry "Matrix" (matrixCoefficients $ mat)
                                 , colorSpaceEntry cs
                                 , entry "Function" (toRsrc func)
                                 ]
      toRsrc (AxialShading x0 y0 x1 y1 (ColorFunction1 cs func)) =
          AnyPdfObject . dictFromList $
                                 [ entry "ShadingType" (PDFInteger $ 2)
                                 , entry "Coords" [x0,y0,x1,y1]
                                 , entry "Extend" [True, True]
                                 , colorSpaceEntry cs
                                 , entry "Function" (toRsrc func)
                                 ]
      toRsrc (RadialShading x0 y0 r0 x1 y1 r1 (ColorFunction1 cs func)) =
          AnyPdfObject . dictFromList $
                                 [ entry "ShadingType" (PDFInteger $ 3)
                                 , entry "Coords" [x0,y0,r0,x1,y1,r1]
                                 , entry "Extend" [True, True]
                                 , colorSpaceEntry cs
                                 , entry "Function" (toRsrc func)
                                 ]


newtype SoftMask = SoftMask (PDFReference PDFXForm)
    deriving (Eq, Ord)

instance PdfResourceObject SoftMask where
    toRsrc (SoftMask ref) =
        AnyPdfObject $
        dictFromList $
            entry "Type" (PDFName "ExtGState") :
            entry "SMask"
                (dictFromList $
                    entry "Type" (PDFName "Mask") :
                    entry "S" (PDFName "Luminosity") :
                    entry "G" ref :
                    []) :
            []


-- | 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"
                    ]