module Graphics.PDF.File
  (-- * PDF generation
   writePdf
  ) where
  
import System.IO
import Control.Monad
import Control.Monad.State
import Graphics.PDF.LowLevel
import Text.Printf
import qualified Data.Map as Map
import Data.List
import System.Mem

-- writeSome text and increment the size counter
writeText :: Handle -> String -> StateT (Int,String) IO ()
writeText f text = do (s,t) <- get
                      put (s + (length text),t)
                      lift $ hPutStr f (seq s text)
                      
    
writeStream :: Handle -> [Cmd] -> StateT (Int,String) IO ()                  
writeStream f c = mapM_ (drawAction f) c

drawAction :: Handle -> Cmd -> StateT (Int,String) IO ()   
drawAction f  (PdfQ actions)  = do writeText f "\nq"
                                   writeStream f actions
                                   writeText f "\nQ"
                                   
                                      
drawAction f  action  = writeText f (show action)

class PdfWrite a where 
  writePdfObject :: Handle -> a -> Int -> StateT (Int,String) IO Int
  
instance PdfWrite PdfDictionary where
  writePdfObject f (PdfDictionary d) k = do writeText f "<<\n" 
                                            Map.foldWithKey item (return ()) d
                                            writeText f ">>"  
                                            return 0
                                         where
                                            item key itm m = do m
                                                                writeText f ("/" ++ key ++ " " )
                                                                writePdfObject f itm k
                                                                writeText f "\n"

instance PdfWrite PdfObject where
  writePdfObject f (PdfInt a) k = do writeText f (show a) 
                                     return 0
  writePdfObject f (PdfFloat a) k = do writeText f (show a) 
                                       return 0
  writePdfObject f (PdfUnknownPointer s) k = error ("The object " ++ s ++ " has not been found or defined")
  writePdfObject f (PdfPointer a) k = do writeText f $ (show a) ++ " 0 R"
                                         return 0
  writePdfObject f (PdfString a) k = do writeText f $ "(" ++ a ++ ")"
                                        return 0
  writePdfObject f (PdfBool a) k =  if a then do writeText f $ "true"
                                                 return 0
                                         else do writeText f $ "false"
                                                 return 0
  writePdfObject f (PdfName a) k = do writeText f $ "/" ++ a
                                      return 0
  writePdfObject f (PdfDict d) k | pdfDictionaryEmpty d = do writeText f "<< >>" 
                                                             return 0
                                 | otherwise =  do writePdfObject f d k
                                                   return 0
  writePdfObject f (PdfArray []) k = do writeText f "[]" 
                                        return 0 
  writePdfObject f (PdfArray l) k = do writeText f "["
                                       mapM_ (\x -> writePdfObject f x k >> writeText f " ") $ l 
                                       writeText f " ]"
                                       return 0
                                      
  writePdfObject f (PdfStream c) k = do  writeText f "<<\n"
                                         writeText f ("/Length " ++ (show (k+1)) ++ " 0 R")
                                         writeText f "\n>>\n"
                                         writeText f "stream"
                                         (before,_)  <- get
                                         writeStream f (stream c)
                                         (after,_)  <- get
                                         writeText f "\nendstream"
                                         return (after-before)
                       where
                         stream (Content(s)) = s
                         
                         

resources = pdfDictionary [("ExtGState",PdfUnknownPointer "ExtGState"),
                                         ("XObject",PdfUnknownPointer "XObject"),
                                         ("Font",PdfUnknownPointer "Font"),
                                         ("Pattern",PdfUnknownPointer "Pattern"),
                                         ("Shading",PdfUnknownPointer "Shading"),
                                         ("ProcSet",PdfUnknownPointer "ProcSet")
                                     ]
header = "%PDF-1.4\n"
obj1   = pdfDictionary  [("Type", PdfName "Catalog"),
                  ("Outlines",PdfUnknownPointer "Obj2"),
                  ("Pages",PdfUnknownPointer "Obj3")
                 ]
obj2  =  pdfDictionary [("Type",PdfName "Outlines"),
                  ("Count", PdfInt 0)
                ]
obj3  =  pdfDictionary  [("Type", PdfName "Pages"),
                  ("Kids",PdfArray [PdfUnknownPointer "Obj4"]),
                  ("Count",PdfInt 1)
                 ]
obj4 pdf = pdfDictionary [("Type",PdfName "Page"),
                             ("Parent",PdfUnknownPointer "Obj3"),
                             ("MediaBox",PdfArray [PdfInt 0,PdfInt 0,PdfInt (round (x pdf)),PdfInt (round (y pdf))]),
                             ("Contents",PdfUnknownPointer "Main"),
                             ("Resources",resources)
               ]
obj6  =  PdfArray [PdfName "PDF"]
beginxref nb = ("xref\n" ++ printf "0 %d\n" (nb+1))
trailer np = ("trailer\n" ++
              (printf "  << /Size %d\n" ((nbObjects np)+1)) ++
              (printf "     /Root %d 0 R\n" (objectIndex "Obj1" np) ) ++
              "  >>\n\
              \startxref\n")
eof = "%%EOF"

                        
standardAlpha = pdfDictionary [("Type",PdfName "ExtGState"),
                         ("ca",PdfFloat 1.0),
                         ("CA",PdfFloat 1.0)
                        ]
                 
-- write and object, increment the size counter and the object number
writeObj f k o maxnb = do (s,t) <- get
                          put (s,t ++ printf "%010d 00000 n \n" (s::Int) )
                          writeText f (printf "%d 0 obj\n"  k)
                          len <- writePdfObject f o maxnb
                          writeText f ("\nendobj\n\n")
                          return len
                 
 -- Write the xref table
writeXref f p = do (_,t) <- get
                   writeText f (beginxref (nbObjects p))
                   writeText f t
                   writeText f ("\n")
 -- write all pending objects
writeObjects f thepdf = do len <- foldM write 0 (allObjects thepdf)
                           return len
                        where
                          write old (k,s) =  do len <- writeObj f k s maxnb
                                                return(len+old)
                          maxnb = nbObjects thepdf
                      
-- Write the PDF document to file
writePdf :: String -> PDF -> IO ()
writePdf fileName pdf = 
                     -- New pdf with object describing a one page PDF
                 let newpdf = computeObjectPos .
                              addObject "Obj1" obj1 .
                              addObject "Obj2" obj2 .
                              addObject "Obj3" obj3 .
                              addObject "Obj4" (obj4 pdf) .
                              addObject "ProcSet" obj6 .
                              addState "standardAlpha" standardAlpha $ pdf
                 in
                 do f <- lift $ openBinaryFile fileName WriteMode
                    writeText f header
                    len <- writeObjects f newpdf
                    writeEndPdf f len (addObject "ZZZ" (PdfInt len) newpdf)
                 `evalStateT` (0,"0000000000 65535 f \n")
                 where
                    writeEndPdf f len epdf = do writeObj f (nbObjects epdf) (PdfInt len) (nbObjects epdf)
                                                (xrefStart,_) <- get
                                                writeXref f epdf
                                                writeText f (trailer epdf)
                                                writeText f (printf "%d\n" (xrefStart::Int))
                                                writeText f eof
                                                lift $ hClose f