root/trunk/thirdparty/cl-pdf/pdf-template.lisp

;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html

;;;# PDF Templates by Tim Daly jr
;;;
;;; Copyright (c) 2005 Tim Daly Jr.  All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in
;;;    the documentation and/or other materials provided with the
;;;    distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY TIM DALY JR. ``AS IS'' AND ANY
;;; EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL TIM DALY JR. OR
;;; HIS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;;; OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Converting a page of a PDF document into a template allows you to
;;; draw it just like an image or some text.  This is useful for
;;; watermarking, merging documents, and creating templates that can
;;; be filled in.

;;; This code was developed using Adobe's PDF Reference, Third
;;; Edition, Version 1.4, which is currently available here:

;;; http://partners.adobe.com/public/developer/en/pdf/PDFReference.pdf

;;; We refer to this document as "PDF-REF <Section-ID>" below.

;;;## Package definition

(in-package #:pdf)

;;;## Template Objects

(defparameter *default-template-size* #(0 0 595 841)
  ;; A4 page size (same default as page object)
  ;; the initform of the bounds slot in the pdf::page class.
  "Default size of a template's bounding box.")

;;; A template is implemented as a Form XObject, see PDF-REF 4.9.
(defclass template (indirect-object)
  ((name  :accessor name
          ;; I'm assuming that you can use any name you want to.
          :initform (gen-name "/CLXOBJ") :initarg :name)
   (bounds  :accessor bounds
            :initform *default-template-size* :initarg :bounds)
   (resources :accessor resources
              :initform (make-instance 'dictionary))))

(defmethod initialize-instance :after ((template template) &rest init-options
                                       &key no-compression
                                       &allow-other-keys)
  (declare (ignore init-options))
  ;; ProcSet is not really necessary, see PDF-REF 9.1.
  (add-dict-value (resources template) "/ProcSet" "[ /PDF /Text ]")
  (setf (content template)
        (make-instance 'pdf-stream
                       :no-compression no-compression
                       :dict-values `(("/Type" . "/Xobject")
                                      ("/Subtype" . "/Form")
                                      ("/FormType" . "1")
                                      ("/BBox" . ,#'(lambda () (bounds template)))
                                      ("/Resources" . ,(resources template))))))

(defun draw-template (template)
  "Cause a template to be drawn on the current page."
  ;; See PDF-REF 4.7.
  (format *page-stream* "~a Do~%" (name template)))


(defun add-templates-to-page (&rest templates)
  "Add TEMPLATES to the resources dictionary of the current page, so
that they can be drawn by e.g., DRAW-TEMPLATE."
  (dolist (template templates)
    (add-dict-value (xobjects *page*) (name template) template)))

(defconstant +identity-matrix+
  (if (boundp '+identity-matrix+)
      (symbol-value '+identity-matrix+)
      #(1 0 0 1 0 0)))

(defun make-template-from-page (old-page &key scale rotate
                                (translate-x 0) (translate-y 0))
  (when (typep old-page 'indirect-object)
    (setf old-page (content old-page)))
  (let ((template (make-instance 'template :bounds
                                 (or (resolve-page-dict-value old-page "/MediaBox")
                                     *default-template-size*))))
    (let ((old-content-stream (resolve-dict-value old-page "/Contents"))
          (new-content-stream (content template)))
      ;; copy the old content stream 
      (setf (content new-content-stream)
            (content old-content-stream))
      ;; copy the other dict entries, e.g. filter, length, from the old stream
      (loop for ((name . value)) on (dict-values old-content-stream) do
            (change-dict-value new-content-stream name (copy-pdf-structure value))))

    (let ((form-matrix +identity-matrix+))
      ;; rotate the template
      (when (and rotate (not (zerop rotate)))        
        (setf form-matrix
              (let ((translate-to-origin (translation-matrix
                                          (- (/ (template-width template) 2))
                                          (- (/ (template-height template) 2))))
                    (translate-back (translation-matrix
                                     (/ (template-width template) 2)
                                     (/ (template-height template) 2))))
                (multiply-tranformation-matrices
                 (multiply-tranformation-matrices translate-to-origin
                                                  (rotation-matrix rotate))
                 translate-back))))
      ;; scale the template
      (when scale
        (setf form-matrix
              (multiply-tranformation-matrices
               form-matrix
               (scale-matrix scale scale))))

      ;;translate the template
      (setf form-matrix
            (multiply-tranformation-matrices
             form-matrix
             (translation-matrix translate-x translate-y)))

      ;; set the template's form matrix, see PDF-REF Table 4.41
      (change-dict-value (content template) "/Matrix" form-matrix))

    ;; copy any metadata associated with the page.  Not sure if this
    ;; is what we want.
    (when (get-dict-value old-page "/Metadata")
      (add-dict-value (content template) "/Metadata"
                      (copy-pdf-structure (get-dict-value old-page "/Metadata"))))

    ;; copy the page's resources, such as images and fonts.
    (let ((old-resources (resolve-page-dict-value old-page "/Resources")))
      (loop for ((name . value)) on (dict-values old-resources) do
            (change-dict-value (resources template) name (copy-pdf-structure value))))
    
    template))

(defun template-width (template)
  (svref (bounds template) 2))

(defun template-height (template)
  (svref (bounds template) 3))

;;;## Transformation Matrices (See PDF-REF 4.2.3)      
(defun rotation-matrix (deg)
  (let* ((angle (/ (* pi deg) 180))
         (s (sin angle))
         (c (cos angle)))
    (vector c s (- s) c 0 0)))

(defun translation-matrix (x y)
  (vector 1 0 0 1 x y))

(defun scale-matrix (x y)
  (vector x 0 0 y 0 0))

(defun multiply-tranformation-matrices (a b)
  "C_ik = A_ij B_jk, where a matrix like this:  [ a b 0 ]
                                                [ c d 0 ]
                                                [ e f 1 ]

is stored liked this:  [ a b c d e f ]."
  (let ((a_11 (svref a 0))
        (a_12 (svref a 1))
        (a_21 (svref a 2))
        (a_22 (svref a 3))
        (a_31 (svref a 4))
        (a_32 (svref a 5))

        (b_11 (svref b 0))
        (b_12 (svref b 1))
        (b_21 (svref b 2))
        (b_22 (svref b 3))
        (b_31 (svref b 4))
        (b_32 (svref b 5)))
    (vector (+ (* a_11 b_11) (* a_12 b_21))
            (+ (* a_11 b_12) (* a_12 b_22))
            (+ (* a_21 b_11) (* a_22 b_21))
            (+ (* a_21 b_12) (* a_22 b_22))
            (+ (* a_31 b_11) (* a_32 b_21) b_31)
            (+ (* a_31 b_12) (* a_32 b_22) b_32))))

;;;## Copying PDF Structure

(defgeneric copy-pdf-structure (arg)
  (:documentation "Copy some piece of a PDF, creating fresh indirect
objects."))

(defmethod copy-pdf-structure ((dict dictionary))
  (let ((new-dict (make-instance 'dictionary)))
    (loop for ((name . value)) on (dict-values dict) do
          (change-dict-value new-dict name (copy-pdf-structure value)))
    new-dict))

(defmethod copy-pdf-structure ((obj indirect-object))
  (make-instance 'indirect-object
                 :content (copy-pdf-structure (content obj))))

(defmethod copy-pdf-structure ((obj pdf-stream))
  (let ((new-stream (make-instance 'pdf-stream :empty t)))
    (setf (content new-stream)
          (copy-pdf-structure (content obj)))
    ;; I think this suppresses compressing the stream again..?
    (setf (no-compression new-stream) t)
    (loop for ((name . value)) on (dict-values obj) do
          (change-dict-value new-stream name (copy-pdf-structure value)))

    new-stream))

(defmethod copy-pdf-structure ((obj sequence))
  (map (type-of obj)
       (lambda (o)
         (copy-pdf-structure o))
       obj))

(defmethod copy-pdf-structure ((obj t))
;; This can be useful for debugging:  
;;  (format t "warning, not copying ~A~%" (type-of obj))
  obj)

;;;## A couple of utility functions.

(defun resolve-dict-value (obj key)
  "If a dictionary value is an indirect object, return the indirect
object's content."
  (do ((value (get-dict-value obj key) (content value)))
      ((not (typep value 'indirect-object)) value)))


(defun resolve-page-dict-value (page key)
  "Look KEY up in the page dictionary.  If it is not found, look it up
in the parent page dictionary."
  ;; Some values in a page dictionary can be inherited from the parent
  ;; page's dictionary, such as the MediaBox.  This is a handy way to
  ;; look them up.  See PDF-REF Table 3.18.
  (let ((value (resolve-dict-value page key)))
    (or value
        (let ((parent-page (resolve-dict-value page "/Parent")))
          (and parent-page
               (resolve-page-dict-value parent-page key))))))



;;;## Example Usage

;;; Try something like this after loading pdf-template.lisp:
;;;
;;; (pdf:test-template "/tmp/ex7.pdf" 1 "/tmp/template.pdf")
#+nil
(defun test-template (in-file page-number out-file)
  "Create a new PDF with the given file and page number drawn several
times.  This test requires pdf-parser to be loaded."
  (let* ((old-doc (read-pdf-file in-file))
         (old-root (root-page old-doc))
         (old-page (aref (pages old-root) page-number))
         (old-page-bounds (or (resolve-page-dict-value (content old-page) "/MediaBox")
                              *default-template-size*))
         (width (svref old-page-bounds 2))
         (height (svref old-page-bounds 3)))
    (with-document ()
      (with-page (:bounds old-page-bounds)
        (let ((top-template (make-template-from-page
                             old-page :scale 2/5 :translate-x (* 3/10 width)
                             :translate-y (* 3/5 height)))
              (right-template (make-template-from-page
                               old-page :scale 2/5 :rotate 90
                               :translate-x (* 3/5 width) :translate-y (* 3/10 height)))
              (left-template (make-template-from-page
                              old-page :scale 2/5 :rotate -90
                              :translate-y (* 3/10 height )))
              (bottom-template (make-template-from-page
                                old-page :scale 2/5 :rotate 180
                                :translate-x (* 3/10 width))))
          (add-templates-to-page top-template right-template
                                 left-template bottom-template)
          (draw-template top-template)
          (draw-template bottom-template)
          (draw-template left-template)
          (draw-template right-template)))
      (write-document out-file))))