root/trunk/thirdparty/cl-pdf/pdf-base.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

(in-package #:pdf)

;;;text functions

(defmacro in-text-mode (&body body)
  `(unwind-protect
     (let ((*font* nil))
       (write-line "BT" *page-stream*)
       ,@body)
    (write-line "ET" *page-stream*)))

(defun set-font (font size)
  (setf *font* font)
  (setf *font-size* size)
  (format *page-stream* "~a ~,2f Tf~%" (name (add-font-to-page font)) size))

(defun set-gstate (&rest gstate)
  (format *page-stream* "~a gs~%" (name (apply #'add-gstate-to-page gstate))))

(defmacro def-pdf-op (name (&rest args) format)
  (if args
    `(defun ,name ,args (format *page-stream* ,format ,@args))
    `(defun ,name () (write-line ,format *page-stream*))))

(def-pdf-op move-text (dx dy) "~8f ~8f Td~%")

;;; String output

(defgeneric write-to-page (object encoding &optional escape)
 (:documentation
  "Write object (only text for now) into current *page-stream* in text mode"))

;;; show-text writes string as is, draw-text escapes dangerous characters.
;;; Args: text String or a single character

(defun show-text (text)
  (if *font*
      (progn (write-to-page text (if *font* (encoding *font*)))
        (write-line "Tj" *page-stream*))
      (format *page-stream* "(~a) Tj~%" text)))

(defun draw-text (text)
  (if *font*
      (progn (write-to-page text (if *font* (encoding *font*)) t)
        (write-line "Tj" *page-stream*))
      (format *page-stream* "(~a) Tj~%" text)))

(defun show-text-on-next-line (string)
  (write-to-page string (if *font* (encoding *font*)))
  (write-line "'" *page-stream*))

(defun draw-text-on-next-line (string)
  (write-to-page string (if *font* (encoding *font*)) t)
  (write-line "'" *page-stream*))

(defun show-spaced-strings (strings)
  (write-string "[ " *page-stream*)
  (let ((encoding (if *font* (encoding *font*))))
    (dolist (item strings)
      (if (numberp item)
          (format *page-stream* "~a " item)
          (write-to-page item encoding))))
  (write-line "] TJ" *page-stream*))

(defun draw-spaced-strings (strings)
  (write-string "[ " *page-stream*)
  (let ((encoding (if *font* (encoding *font*))))
    (dolist (item strings)
      (if (numberp item)
          (format *page-stream* "~a " item)
          (write-to-page item encoding t))))
  (write-line "] TJ" *page-stream*))

(defmethod write-to-page ((string string) encoding &optional escape)
  (declare (ignore encoding))
  (write-char #\( *page-stream*)
  (if escape
      (loop for char across string
            do (case char
                 ((#\( #\) #\\)
                  (write-char #\\ *page-stream*)
                  (write-char char *page-stream*))
                 (otherwise
                  (write-char char *page-stream*))))
    (write-string string *page-stream*))
  (write-string ") " *page-stream*))

(defmethod write-to-page ((string string) (encoding single-byte-encoding) &optional escape)
  ;; There is no point to interpret \n and others in a special way
  ;; as they are not control characters within content stream
  (write-char #\( *page-stream*)
  (if (or escape
          #+lispworks (lw:text-string-p string)         ; may include unicode
          #+allegro t)
      (loop with charset = (charset encoding)
            for char across string
            do (case char
                 ((#\( #\) #\\)
                  (write-char #\\ *page-stream*)
                  (write-char char *page-stream*))
                 ;(#\Newline
                 ; (write-string "\\n" *page-stream*))
                 ;(#\Return
                 ; (write-string "\\r" *page-stream*))
                 ;(#\Tab
                 ; (write-string "\\t" *page-stream*))
                 (otherwise
                  (write-char (if #+lispworks (lw:base-char-p char)
                                  #+(or allegro sbcl) (standard-char-p char)
                                  #-(or lispworks allegro sbcl) t
                                  char
                                  (code-char (char-external-code char charset)))
                              *page-stream*))))
      (write-string string *page-stream*))
  (write-string ") " *page-stream*))

(defmethod write-to-page ((string string) (encoding unicode-encoding) &optional escape)
  (declare (ignore escape))
  (write-char #\< *page-stream*)
  (loop for char across string do
        (format *page-stream* "~4,'0x" (char-code char)))
  (write-string "> " *page-stream*))

;;; Single character output

(defun show-char (char)
 ;;; Deprecated in favor of show-text or draw-text
  (write-to-page char (if *font* (encoding *font*)) t)
  (write-line "Tj" *page-stream*))

(defmethod write-to-page ((char character) encoding &optional escape)
 ;;; This default method is only needed for deprecated and legacy code,
  ;; e.g. bar-codes.lisp: draw-chars (*font* is nil) -> draw-char
  (declare (ignore encoding))
  (write-char #\( *page-stream*)
  (when escape (case char
                 ((#\( #\) #\\) (write-char #\\ *page-stream*))))
  (write-char char *page-stream*)
  (write-char #\) *page-stream*))

(defmethod write-to-page ((char character)(encoding single-byte-encoding) &optional escape)
  (write-char #\( *page-stream*)
  (when escape (case char
                 ((#\( #\) #\\) (write-char #\\ *page-stream*))))
  (write-char (if #+lispworks (lw:base-char-p char)
                  #+(or allegro sbcl) (standard-char-p char)
                  #-(or lispworks allegro sbcl) t
                  char
                  (code-char (char-external-code char (charset encoding))))
              *page-stream*)
  (write-char #\) *page-stream*))

(defmethod write-to-page ((char character) (encoding unicode-encoding) &optional escape)
  (declare (ignore escape))
  (write-char #\< *page-stream*)
  (format *page-stream* "~4,'0x" (char-code char))
  (write-char #\> *page-stream*))

(def-pdf-op set-text-rendering-mode (mode) "~d Tr~%")

(def-pdf-op set-char-spacing (space) "~8f Tc~%")

(def-pdf-op set-text-x-scale (scale) "~8f Tz~%")

(def-pdf-op set-text-leading (space) "~8f TL~%")

(def-pdf-op set-text-rise (rise) "~8f Ts~%")

(def-pdf-op move-to-next-line () " T*")

(def-pdf-op set-text-matrix (a b c d e f) "~10f ~10f ~10f ~10f ~10f ~10f Tm~%")

;;; graphic functions
(defconstant +deg-to-rad+ #.(/ pi 180))

(defmacro with-saved-state (&body body)
  `(unwind-protect
     (progn (write-line "q" *page-stream*)
            ,@body)
    (write-line "Q" *page-stream*)))

(def-pdf-op set-transform-matrix (a b c d e f) "~8f ~8f ~8f ~8f ~8f ~8f cm~%")

(def-pdf-op translate (dx dy) "1.0 0.0 0.0 1.0 ~8f ~8f cm~%")

(defun rotate (deg)
  (let* ((angle (* +deg-to-rad+ deg))
         (s (sin angle))
         (c (cos angle)))
    (format *page-stream* "~10f ~10f ~10f ~10f 0.0 0.0 cm~%" c s (- s) c)))

(defun rotate* (radians)
  (let* ((s (sin radians))
         (c (cos radians)))
    (format *page-stream* "~10f ~10f ~10f ~10f 0.0 0.0 cm~%" c s (- s) c)))

(def-pdf-op scale (sx sy) " ~8f 0.0 0.0 ~8f 0.0 0.0 cm~%")

(defun skew (x-deg y-deg)
  (format *page-stream* " 1.0 ~10f ~10f 1.0 0.0 0.0 cm~%"
          (tan (* +deg-to-rad+ x-deg))(tan (* +deg-to-rad+ y-deg))))

(defun skew* (x-radians y-radians)
  (set-transform-matrix 1.0 (tan x-radians) (tan y-radians) 1.0 0.0 0.0))

(def-pdf-op set-line-width (width) "~8f w~%")

(def-pdf-op set-line-cap (mode) "~d J~%")

(def-pdf-op set-line-join (mode) "~d j~%")

(def-pdf-op set-dash-pattern (dash-array phase) "[~{~d~^ ~}] ~d d~%")

(def-pdf-op set-miter-limit (limit) "~8f M~%")

(def-pdf-op move-to (x y) "~8f ~8f m~%")

(def-pdf-op line-to (x y) "~8f ~8f l~%")

(def-pdf-op bezier-to (x1 y1 x2 y2 x3 y3) "~8f ~8f ~8f ~8f ~8f ~8f c~%")

(def-pdf-op bezier2-to (x2 y2 x3 y3) "~8f ~8f ~8f ~8f v~%")

(def-pdf-op bezier3-to (x1 y1 x3 y3) "~8f ~8f ~8f ~8f y~%")

(def-pdf-op close-path () " h")

(def-pdf-op basic-rect (x y dx dy) "~8f ~8f ~8f ~8f re~%")

(defun paint-image (image)
  (format *page-stream* "~a Do~%" (name image)))

(def-pdf-op stroke () " S")

(def-pdf-op close-and-stroke () " s")

(def-pdf-op fill-path () " f")

(def-pdf-op close-and-fill () " h f")

(def-pdf-op even-odd-fill () " f*")

(def-pdf-op fill-and-stroke () " B")

(def-pdf-op even-odd-fill-and-stroke () " B*")

(def-pdf-op close-fill-and-stroke () " b")

(def-pdf-op close-even-odd-fill-and-stroke () " b*")

(def-pdf-op end-path-no-op  () " n")

(def-pdf-op clip-path () " W")

(def-pdf-op even-odd-clip-path () " W*")

(def-pdf-op set-gray-stroke (gray) "~5f G~%")

(def-pdf-op set-gray-fill (gray) "~5f g~%")

(def-pdf-op set-rgb-stroke (r g b) "~5f ~5f ~5f RG~%")

(defgeneric get-rgb (color)
 (:method ((color list))  
  (values (first color)(second color)(third color)))

 (:method ((color vector))
  #+lispworks
  (if (numberp (aref color 0))
      (values (aref color 0)(aref color 1)(aref color 2))
      (case (aref color 0)              ; convert from (color:make-rgb ...) or other model
        (:RGB   (values (aref color 1)(aref color 2)(aref color 3)))
        (:GRAY  (values (aref color 1)(aref color 1)(aref color 1)))))
  #-lispworks
  (values (aref color 0)(aref color 1)(aref color 2)))

 (:method ((color string))      ; takes a CSS color string like "#CCBBFF"
  (if (eql #\# (aref color 0))
      (values (/ (parse-integer color :start 1 :end 3 :radix 16) 255.0)
              (/ (parse-integer color :start 3 :end 5 :radix 16) 255.0)
              (/ (parse-integer color :start 5 :end 7 :radix 16) 255.0))
      (find-color-from-string color)))

 (:method ((color integer))     ; a la CSS but specified as a Lisp number like #xCCBBFF
  (values (/ (ldb (byte 8 16) color) 255.0)
          (/ (ldb (byte 8 8) color) 255.0)
          (/ (ldb (byte 8 0) color) 255.0))) 

 (:method ((color symbol))      ; :blue, :darkgreen, or win32:color_3dface
   (find-color-from-symbol color)))

(defun set-color-stroke (color)
  (multiple-value-call #'set-rgb-stroke (get-rgb color)))

(defun set-color-fill (color)
  (multiple-value-call #'set-rgb-fill (get-rgb color)))

(def-pdf-op set-rgb-fill (r g b) "~5f ~5f ~5f rg~%")

(def-pdf-op set-cymk-stroke (c y m k) "~5f ~5f ~5f ~5f K~%")

(def-pdf-op set-cymk-fill (c y m k) "~5f ~5f ~5f ~5f k~%")

(defun draw-image (image x y dx dy rotation &optional keep-aspect-ratio)
  (when keep-aspect-ratio
    (let ((r1 (/ dy dx))
          (r2 (/ (height image)(width image))))
      (if (> r1 r2)
        (setf dy (* dx r2)))
        (when (< r1 r2)(setf dx (/ dy r2)))))
  (with-saved-state
      (translate x y)
      (rotate rotation)
      (scale dx dy)
      (paint-image image)))

(defun add-link (x y dx dy ref-name &key (border #(0 0 0)))
  (let ((annotation (make-instance 'annotation :rect (vector x y (+ x dx) (+ y dy))
                                   :type "/Link" :border border)))
    (push (cons "/Dest" (get-named-reference ref-name)) (dict-values (content annotation)))
    annotation))

(defun add-URI-link (x y dx dy uri &key (border #(0 0 0)))
  (let ((annotation (make-instance 'annotation :rect (vector x y (+ x dx) (+ y dy))
                                   :type "/Link" :border border ))
        (action (make-instance 'dictionary :dict-values '(("/S" . "/URI")))))
    (add-dict-value (content annotation) "/A" action)
    (add-dict-value action "/URI" (concatenate 'string "(" uri ")"))
    annotation))

(defun add-external-link (x y dx dy filename page-nb &key (border #(0 0 0)))
  (let ((annotation (make-instance 'annotation :rect (vector x y (+ x dx) (+ y dy))
                                   :type "/Link" :border border ))
        (action (make-instance 'dictionary :dict-values '(("/S" . "/GoToR")))))
    (add-dict-value (content annotation) "/A" action)
    (add-dict-value action "/F" (concatenate 'string "(" filename ")"))
    (add-dict-value action "/D" (vector page-nb "/Fit"))
    annotation))

(defparameter +jpeg-color-spaces+ #("?" "/DeviceGray" "?" "/DeviceRGB" "/DeviceCMYK"))

(defclass bitmap-image ()
  ((width  :accessor width :initarg :width)
   (height :accessor height :initarg :height)
   (nb-components :accessor nb-components :initarg :nb-components)
   (data   :accessor data :initarg :data)))

(defclass jpeg-image (bitmap-image)
  ())

(defun %read-jpeg-file% (filename)
  (with-open-file (s filename :direction :input :element-type '(unsigned-byte 8))
    (loop with width and height and nb-components and data
          for marker = (read-byte s)
          if (= marker #xFF) do
              (setf marker (read-byte s))
              (cond
                ((member marker '(#xC0 #xC1 #xC2));SOF markers
                 (read-byte s)(read-byte s) ;size
                 (when (/= (read-byte s) 8) (error "JPEG must have 8bits per component"))
                 (setf height (+ (ash (read-byte s) 8)(read-byte s)))
                 (setf width (+ (ash (read-byte s) 8)(read-byte s)))
                 (setf nb-components (read-byte s))
                 (file-position s :start)
                 (setf data (make-array (file-length s) :element-type '(unsigned-byte 8)))
                 (read-sequence data s)
                 (return (values nb-components width height data)))
                ((member marker '(#xC3 #xC5 #xC6 #xC7 #xC8 #xC9 #xCA #xCB #xCD #xCE #xCF)) ;unsupported markers
                 (error "Unsupported JPEG format"))
                ((not (member marker '(#xD0 #xD1 #xD2 #xD3 #xD4 #xD5 #xD6 #xD7 #xD8 #x01))) ;no param markers
                 (file-position s (+ (file-position s)(ash (read-byte s) 8)(read-byte s) -2)))))))

(defun read-jpeg-file (filename)
  (multiple-value-bind (nb-components width height data) (%read-jpeg-file% filename)
    (when nb-components
      (make-instance 'jpeg-image :nb-components nb-components
                     :width width :height height :data data))))

(defmethod make-jpeg-image (jpeg)
  (make-image jpeg))

(defmethod make-jpeg-image ((pathname pathname))
  (make-jpeg-image (read-jpeg-file pathname)))

(defmethod make-jpeg-image ((string string))
  (make-jpeg-image (read-jpeg-file string)))

(defgeneric make-image (object &key type &allow-other-keys)
 (:documentation "Returns more than just one pdf:image object when mask is supplied"))

(defmethod make-image ((object pathname) &rest args &key (type (pathname-type object)))
  (cond ((member type '("jpeg" "jpg") :test #'equalp)
         (apply 'make-image (read-jpeg-file object) args))
        ((equalp type "png")
         (apply 'make-image (read-png-file object) args))
        (t (error "Unsupported image file type ~s." type))))

(defmethod make-image ((object string) &rest args &key type)
  (apply #'make-image (merge-pathnames object (make-pathname :type type))
         args))

(defmethod make-image ((jpeg jpeg-image) &key &allow-other-keys)
  (make-instance 'pdf:image
         :bits (data jpeg)
         :width (width jpeg) :height (height jpeg)
         :filter "/DCTDecode"
         :color-space (aref +jpeg-color-spaces+ (nb-components jpeg))
         :no-compression t))