{-# OPTIONS_GHC -fglasgow-exts #-}
-- #hide
module Graphics.PDF.LowLevel
 (-- * PDF low level operators
  -- ** Data types
   PdfObject(..),PdfDictionary(..),PDF(..),Content(..),PdfCmd,CreatedObject,ObjectKind(..), Cmd(..), PdfString(..),TextRendering(..)
  -- ** Data type support functions
  ,dictionaryExtract, pdfDictionaryEmpty, emptyDictionary, emptyPdf
  -- ** Low level object operators
  ,nbObjects, objectIndex, allObjects,pdfDictionary
  -- ** Low level PDF operators
  ,addObject, addFont, addState, addNewContent, applyCommand,computeObjectPos,(<>),withContext
  ) where
  
import qualified Data.Map as Map
import Data.Monoid
import Text.Printf
import Text.Show

-- | A PDF string
newtype PdfString = S String

data TextRendering = TextStroke 
                   | TextFill
                   | TextFillStroke
                   | TextClip

data Cmd =  PdfRgbSpace
          | PdfSC Float Float Float
          | PdfSF Float Float Float
          | PdfBT String Int
          | PdfCM Float Float Float Float Float Float 
          | PdfL Float Float Float Float
          | PdfW Float
          | PdfRect Float Float Float Float
          | PdfFillRect Float Float Float Float
          | PdfDash [Float] Float
          | PdfStartPath Float Float
          | PdfAddLineToPath Float Float
          | PdfAddRectangleToPath Float Float Float Float
          | PdfText TextRendering Float Float [PdfString]
          | PdfStroke
          | PdfFill
          | PdfClip
          | PdfFillAndStroke
          | PdfClosePath
          | PdfAlpha String
          | PdfQ [Cmd] 
          | PdfResetAlpha
          | PdfCharSpacing Float
          | PdfWordSpacing Float
          | PdfLeading Float
          | PdfStrokePattern String
          | PdfFillPattern String
          | PdfNone
          
-- | Escape character whose meaning is special in a PDF String
instance Show PdfString where
  show (S a) = "("++a++")"
  showList l = \s -> r ++ s
               where
                 r = case l of
                       [] -> ""
                       (a:l) -> (show a) ++ " Tj " ++ concat (zipWith (++) (map show l) (repeat " ' "))
          
instance Show Cmd where
  show (PdfQ l) = error "Require a special processing"
  show PdfNone = ""
  show PdfClip = "\nW"
  show PdfResetAlpha = "\n/standardAlpha gs"
  show (PdfAlpha s) = printf "\n/%s gs" s
  show (PdfStrokePattern s) = printf "\n/Pattern CS /%s SCN" s
  show (PdfFillPattern s) = printf "\n/Pattern cs /%s scn" s
  show PdfRgbSpace = "\n/DeviceRGB CS\n/DeviceRGB cs\n/standardAlpha gs"
  show (PdfSC r g b) = printf "\n%f %f %f SC" r g b
  show (PdfSF r g b) = printf "\n%f %f %f sc" r g b
  show (PdfBT fontName fontSize) = printf "\nBT /%s %d Tf ET" fontName fontSize
  show (PdfCM a b c d e f) = printf "\n%f %f %f %f %f %f cm" a b c d e f
  show (PdfL xa ya xb yb) = printf "\nh %f %f m %f %f l S" xa ya xb yb
  show (PdfW w) = printf "\n%f w" w
  show (PdfRect xa ya width height) = printf "\nh %f %f %f %f re S" xa ya width height
  show (PdfFillRect xa ya width height) = printf "\nh %f %f %f %f re f" xa ya width height
  show (PdfDash a phase) = printf "\n[%s] %f d" (unwords . map show $ a) phase
  show (PdfStartPath xa ya) = printf "\nh %f %f m" xa ya
  show (PdfClosePath) = "\nh"
  show (PdfAddLineToPath xa ya) = printf "\n%f %f l" xa ya
  show (PdfAddRectangleToPath xa ya width height) = printf "\n%f %f %f %f re" xa ya width height
  show PdfStroke = "\nS"
  show PdfFill = "\nf"
  show PdfFillAndStroke = "\nB"
  show (PdfText TextStroke px py s) = printf "\n1 Tr BT %f %f Td %s ET" px py (show s)
  show (PdfText TextFill px py s) = printf "\n0 Tr BT %f %f Td %s ET" px py (show s)
  show (PdfText TextFillStroke px py s) = printf "\n2 Tr BT %f %f Td %s ET" px py (show s)
  show (PdfText TextClip px py s) = printf "\n7 Tr BT %f %f Td %s ET" px py (show s)
  show (PdfCharSpacing x) = printf "\n%f Tc" x
  show (PdfWordSpacing x) = printf "\n%f Tw" x
  show (PdfLeading x) = printf "\n%f TL" x
  
-- | PDF commands for a picture
newtype Content = Content ([Cmd])

instance Monoid Content where
  mempty = Content ([])
  mappend (Content(ca)) (Content(cb)) = Content(ca ++ cb)
  
-- | A PDF object as defined in PDF specification
data PdfObject = PdfInt Int 
               | PdfFloat Float 
               | PdfString String 
               | PdfName String 
               | PdfDict PdfDictionary 
               | PdfUnknownPointer String 
               | PdfPointer Int 
               | PdfBool Bool
               | PdfArray [PdfObject]
               | PdfStream Content
               
-- | A dictionary of objects
newtype PdfDictionary = PdfDictionary (Map.Map String PdfObject)

dictionaryExtract :: PdfDictionary -> Map.Map String PdfObject
dictionaryExtract (PdfDictionary a) = a

-- | Kind of created object
data ObjectKind = PdfAnyObject | PdfFont | PdfState | PdfShading | PdfPatternObject

-- | Object created by a command
type CreatedObject = (ObjectKind,String,PdfObject)

-- | Type returned by a PDF command creator
type PdfCmd = (Cmd,[CreatedObject])

-- | Number of objects in the PDF
nbObjects :: PDF -> Int
nbObjects p = let PdfDictionary d = (objects p) 
              in
               Map.size d
               
                          
 
-- | Object index in the PDF              
objectIndex :: String -> PDF -> Int
objectIndex s p = let PdfDictionary d = (objects p) 
                  in
                   (Map.findIndex s d) + 1

-- | List of object contents with their index
allObjects :: PDF -> [(Int,PdfObject)]
allObjects p = let d = dictionaryExtract (objects p)
               in
                   map createItem . Map.toAscList $ d
                  where
                    createItem (k,s) = ((objectIndex k p),s)

-- Name of PDF object containing the content
contentName :: String
contentName = "Main"

-- | PDF data with its state, xobject and font dictionary
data PDF = PDF {content :: Content,
                objects :: PdfDictionary,
                extgstate :: PdfDictionary,
                xobject :: PdfDictionary,
                font :: PdfDictionary,
                pattern :: PdfDictionary,
                shading :: PdfDictionary,
                x :: Float,
                y :: Float
               }
               

-- | Check is a dictionary is empty
pdfDictionaryEmpty :: PdfDictionary -> Bool
pdfDictionaryEmpty (PdfDictionary m) | Map.null m = True
                                     | otherwise  = False     
                                     
emptyDictionary :: PdfDictionary
emptyDictionary = PdfDictionary Map.empty

-- | Create a new empty document of given width and height
emptyPdf :: Float -> Float -> PDF
emptyPdf width height = PDF {
    objects = emptyDictionary,
    content = mempty, 
    extgstate=emptyDictionary,
    xobject=emptyDictionary,
    font=emptyDictionary,
    pattern=emptyDictionary,
    shading=emptyDictionary,
    x = width,
    y = height
 }
 
-- | Insert an object into a PdfDictionary
insertObject :: String -> PdfObject -> PdfDictionary -> PdfDictionary
insertObject name object (PdfDictionary d) = PdfDictionary (Map.insert name object d)

-- | Add an object of a PDF
addObject :: String -> PdfObject -> PDF -> PDF
addObject name object p = p {objects = insertObject name object (objects p)}
                                         
-- | Add a font object of a PDF
addFont :: String -> PdfObject -> PDF -> PDF
addFont name object p  = p {font=insertObject name object (font p)}
 
-- | Add a font object of a PDF
addState :: String -> PdfObject -> PDF -> PDF
addState name object p  = p {extgstate=insertObject name object (extgstate p)}

-- | Add a shading object of a PDF
addShading :: String -> PdfObject -> PDF -> PDF
addShading name object p  = p {shading=insertObject name object (shading p)}

-- | Add a pattern object of a PDF
addPattern :: String -> PdfObject -> PDF -> PDF
addPattern name object p  = p {pattern=insertObject name object (pattern p)}

                                                                           
-- | Add a created object     
addCreatedObject :: CreatedObject -> PDF -> PDF
addCreatedObject (PdfFont,name,object) p =  addFont name object p
addCreatedObject (PdfState,name,object) p = addState name object p
addCreatedObject (PdfShading,name,object) p = addShading name object p
addCreatedObject (PdfPatternObject,name,object) p = addPattern name object p
addCreatedObject (_,name,object) p = addObject name object p
                                                                   
pdfDictionary :: [(String,PdfObject)] -> PdfObject
pdfDictionary l = PdfDict (PdfDictionary(Map.fromList l))
 

-- PDF document can be concatenated              
instance Monoid PDF where
  mempty = emptyPdf 0 0
  mappend pdfa pdfb = PDF {objects = union (objects pdfa) (objects pdfb),
     content = (content pdfa) `mappend` (content pdfb),
     extgstate = union (extgstate pdfa) (extgstate pdfb),
     xobject = union (xobject pdfa) (xobject pdfb),
     font = union (font pdfa) (font pdfb),
     pattern = union (pattern pdfa) (pattern pdfb),
     shading = union (shading pdfa) (shading pdfb),
     x = max (x pdfa) (x pdfb),
     y = max (y pdfa) (y pdfb)
   } where
     union (PdfDictionary a) (PdfDictionary b) = PdfDictionary (Map.union a b)
     

-- | Generate a new PDF with an updated content
addNewContent :: Cmd -> PDF -> PDF
addNewContent s p =   p {content = Content(s : c)} 
                      where
                        Content(c) = content p
                     
-- | Generate a new PDF with an updated content
replaceContent :: Content -> PDF -> PDF
replaceContent s p = p {content = s}
                     
-- | Create a new PDF graphic where the graphic context is saved\/restored and thus isolated
-- from additional modifications that could be applied to this PDF document
withContext :: PDF -> PdfCmd
withContext f =  (PdfQ l,newobjs)
                 where
                   Content(l) = content f 
                   newobjs = listOfObjects PdfState (extgstate f) ++ listOfObjects PdfFont (font f)
                   listOfObjects s d = map tag (Map.toList (dictionaryExtract d))
                                       where
                                         tag (n,o) = (s,n,o)

--addNewContent "\nq"  (f `mappend` (addNewContent "\nQ"  mempty))

                

-- | add a PDF command to the current PDF content                     
applyCommand :: Cmd -> PDF -> PDF
applyCommand cmd p = addNewContent cmd  p

-- | Update the pointer value of the PDF dictionary given element of list objects.
-- The specific dictionary extgstate, xobject and font are merged with the generic dictionary
computeObjectPos :: PDF -> PDF
computeObjectPos p = p {content = mempty,
                        objects = renumber newobjects,
                        extgstate= emptyDictionary,
                        xobject= emptyDictionary,
                        font= emptyDictionary,
                        pattern= emptyDictionary,
                        shading= emptyDictionary
                       } 
                       where
                        newobjects = foldl insertObjs (objects p) [(contentName,(PdfStream (content p))),
                               ("ExtGState",PdfDict (extgstate p)),
                               ("XObject",PdfDict (xobject p)),
                               ("Font",PdfDict (font p)),
                               ("Pattern",PdfDict (pattern p)),
                               ("Shading",PdfDict (shading p))
                            ]
                        insertObjs dict (s,o) = insertObject s o dict
                        renumber (PdfDictionary objs) = PdfDictionary(Map.map (setNumber objs) objs) 
                        setNumber objs (PdfUnknownPointer s) = PdfPointer ((Map.findIndex s objs)+1)
                        setNumber objs (PdfDict (PdfDictionary d)) = PdfDict . PdfDictionary . Map.map (setNumber objs)  $ d
                        setNumber objs (PdfArray l) = PdfArray . map (setNumber objs) $ l
                        setNumber _ a = a
                          
infixr 9 <>
-- | Combine two PDF actions
(<>) :: PdfCmd -> PDF -> PDF
(<>) (c,l) p = addNewContent c (foldr addCreatedObject p l)