;;;; vim :ft=lisp
;;;; Type 3 Font Dictionaries.
;;;; Touched: <01-Oct-03 04:24:27 IST, madhu>
(require 'cl-pdf)
(unless (find-package "PK")
  (load (merge-pathnames #p"pktype.lisp" *cl-pdf-srcdir*)))

(defpackage "TYPE3"
  (:nicknames "T3")
  (:use "CL"))
(in-package "T3")

; skulduggery
(defclass fake-font-mixin () ; faked (not computed)
  ((first-char :initarg :first-char :accessor first-char :initform 0)
   (last-char :initarg :last-char :accessor last-char :initform 255)
   (marked-chars :initarg :marked-chars :accessor marked-chars
		 :initform (loop for x below 255 collect x))))

(defclass t3-char-metrics (PDF:char-metrics)
  ((h :accessor h :initarg :h) ; pixel height
   (w :accessor w :initarg :w) ; pixel width
   (raster :accessor raster :initarg :raster)
   (rastersize :accessor rastersize :initarg :rastersize)
   (rw :accessor rw :initarg :rw)))

(defclass t3-font-metrics (PDF:font-metrics fake-font-mixin)
  ((image-used :accessor image-used)
   (font-scale :accessor font-scale) ))

(defun load-pk-font (path &rest opts &key first-char last-char marked-chars)
  (loop with pkfile = (pk:get-pkfile path)
        and t3fm =(apply #'make-instance 't3-font-metrics opts)
        for car in (marked-chars t3fm) ; for car below 255
        for char-name = (format nil "/a~d" car) ; note: leading /!
        for (x-off y-off width height raster rastersize rw) =
          (pk:pk-char-details pkfile car)
        for llx = (- x-off)
        for lly = (1+ (- y-off height))
        for urx = (1+ (+ llx width))
        for ury = (+ lly height)
        minimizing llx into b0
        minimizing lly into b1
        maximizing urx into b2
        maximizing ury into b3
        do
        (when (or (< width 1) (< height 1)) (error "todo: handle null-glyphs"))
        (let ((char-metrics
                (make-instance 't3-char-metrics
                               :code car :name char-name
                               :bbox (make-array 4 :initial-contents
                                                 (list llx lly urx ury))
                               :h height :w width
                               :rastersize rastersize :raster raster :rw rw
                               :width  (pk:pk-char-width pkfile car))))
          (setf (aref (PDF::encoding-vector t3fm) car) char-metrics)
          (setf (gethash char-name (PDF:characters t3fm)) char-metrics))
        finally
        (setf (image-used t3fm) t)
        (setf (font-scale t3fm) (pk:pk-font-scale pkfile))
        (setf (PDF:font-bbox t3fm)
              (make-array 4 :initial-contents (list b0 b1 b2 b3)))
        (setf (PDF:font-name t3fm) (pk:pk-font-name pkfile))
        (setf (gethash (PDF:font-name t3fm) PDF::*font-metrics*) t3fm)
        (setf (PDF:encoding-scheme t3fm) nil) ; XXX
        (return t3fm)))

;;; CL-PDF protocols
;;;
;;;
(defmethod PDF::font-descriptor ((t3fm t3-font-metrics))
  (declare (ignore t3fm))
  (error "Type3 fonts dont have descriptors"))

(defmethod PDF::font-type ((t3fm t3-font-metrics))
  (declare (ignore t3fm))
  "Type3")

;;; helpers for writing out pdf
;;;
;;;
(defmethod %char-procs-content-stream ((t3cm t3-char-metrics))
  (let ((content-stream (make-instance 'PDF::pdf-stream)) p)
    (with-slots (h w raster rastersize rw PDF:bbox PDF:width) t3cm
      (destructuring-bind (llx lly urx ury)
          (loop for x across PDF:bbox collect x)
        (setf (PDF::content content-stream)
              (with-output-to-string (stream)
                (format stream "~D 0 ~D ~D ~D ~D d1~%"
                        PDF:width
                        llx lly urx ury)
                ;; if null-glyph prolly end-stream here
                (format stream "q~%~D 0 0 ~D ~D ~D cm~%BI~%" w h llx lly)
                (format stream "/W ~D~%/H ~D~%" w h)
                (format stream "/IM true~%/BPC 1~%/D [1 0]~%ID ")
                (setf p 0)
                (loop repeat h do
                (loop repeat rw do ;; #+pdf-binary etc todo
                      (write-char (code-char (aref raster p)) stream)
                      (incf p)))
                (assert (= p rastersize))
                (format stream "~%EI~%Q")))))
    content-stream))

(defmethod %make-char-procs-dict ((t3fm t3-font-metrics))
  (loop for car from (first-char t3fm) to (last-char t3fm)
        for t3cm = (aref (PDF::encoding-vector t3fm) car)
        when t3cm collect (cons (PDF:name t3cm)
                                (make-instance
                                  'PDF::indirect-object
                                  :content (%char-procs-content-stream t3cm)))
        into dict-values
        finally (return (make-instance
                          'PDF::dictionary :dict-values dict-values))))

(defmethod %make-resources-dict ((t3fm t3-font-metrics))
  (make-instance
    'PDF::dictionary
    :dict-values
    `(("/ProcSet" .
       ,(format nil "[ /PDF ~A ]" (if (image-used t3fm) "/ImageB" ""))))))

(defmethod %compute-encoding-differences ((t3fm t3-font-metrics));XXX
  (with-output-to-string (s)
    (loop with undef-p for i from (first-char t3fm) to (last-char t3fm)
	  do (if (= i (first-char t3fm))
	       (cond ((aref (PDF::encoding-vector t3fm) i)
		      (setf undef-p nil)
		      (format s "[~a/a~d" i i))
		     (t (setf undef-p t)
			(format s "[~a/.notdef" i)))
	       (cond ((aref (PDF::encoding-vector t3fm) i)
		      (when undef-p
			(setf undef-p nil)
			(format s " ~d" i))
		      (format s "/a~d" i))
		     (t (unless undef-p
			  (setf undef-p t)
			  (format s " ~d/.notdef" i)))))
	  finally (format s "]"))))

(defmethod %make-t3-font-dict  ((t3fm t3-font-metrics))
  (make-instance
    'PDF::dictionary
    :dict-values
    `(("/Type" . "/Font")
      ("/Subtype" . "/Type3")
      ("/FontMatrix" . ,(let ((font-scale (font-scale t3fm)))
                          (make-array 6 :initial-contents
                                      (list font-scale 0 0 font-scale 0 0))))
      ("/FontBBox" . ,(PDF:font-bbox t3fm))
      ("/Resources" . ,(%make-resources-dict t3fm))
      ("/FirstChar" . ,(first-char t3fm))
      ("/LastChar" . ,(last-char t3fm))
      ("/Widths" . ,(loop for car from (first-char t3fm) to (last-char t3fm)
                          for t3cm = (aref (PDF::encoding-vector t3fm) car)
                          collect (if t3cm (PDF:width t3cm) 0) into widths
                          finally (return (make-array (length widths)
                                            :initial-contents widths))))
      ("/Encoding" . ,(make-instance
                        'pdf::indirect-object :content
                        (make-instance
                          'pdf::dictionary :dict-values
                          `(("/Type" . "/Encoding")
                            ("/Differences" .
                             ,(%compute-encoding-differences t3fm))))))
      #+nil ;; / BUG
      ("/Encoding" . ,(pdf::find-encoding-object
                        (pdf::extract-font-metrics-encoding t3fm)))
      ("/CharProcs" . ,(make-instance
                         'PDF::indirect-object
                         :content (%make-char-procs-dict t3fm))))))

;;;---------------------------------------------------------------------------
;;; Sample Use: interface to PDF - register our T3 font
;;; (see `pdf::font-object's initialize-instance)

(defclass t3-font () ;?
  ((t3-font-metrics :initarg :t3-font-metrics :accessor t3-font-metrics)))

(defmethod pdf::%initialize-font ((font-object pdf::font-object)
				  (font t3-font)
				  &rest init-options &key &allow-other-keys)
  (when init-options (warn "Type 3: ignoring init-options ~a" init-options))
  (setf (pdf::content font-object) (%make-t3-font-dict 
				     (t3-font-metrics font)))
  ;; 1.4 spec doesnt require the next entry, but acrobat3 failed without it
  (pdf::add-dict-value (pdf::content font-object)
		       "/Name" (pdf::name font-object)))

(defvar *t3fm* (load-pk-font
	       #p"pk/sktbs10.864pk"
	       :first-char 4
	       :last-char 136
	       :marked-chars '(4 10 23 33 58 59 77 97 100 109 112 116 118 120 121 126 136)))

(defun t3-example (&optional (file #p"t3.pdf") &aux
                             (pdf:*compress-streams* nil))
  (pdf:with-document    ()
    (pdf:with-page      ()
      (pdf:with-outline-level
        ("PFB Example" (pdf:register-page-reference))
        (let ((skt (make-instance 't3-font :t3-font-metrics *t3fm*)
		   #+nil(pdf:get-font "sktbs10")))
         (pdf:in-text-mode
            (pdf:set-font skt 14.346)
            (pdf:move-text 200 800)
            (pdf:show-text ";\\012a:\\210!a;pa;a;d\\027;~ya;!a;mxa;tM\\027a;\\012a;d:!;v\\004a;a")))))
    (pdf:write-document file)))

#+nil
(t3::t3-example)