;;;; vim :ft=lisp
;;;; Touched: <07-Oct-03 08:30:13 IST, madhu>
;;;; Bugs-To:<enometh@net.meer>
(defpackage "T1"
  (:use "COMMON-LISP")
  (:export))
(in-package "T1")
#|
we still dont have a framework for fonts. The way I'm assuming it'll work is
you specify fonts with (pdf:get-font "NAME"). This will create a object of 
of the appropriate Font Subtype.

So when `pdf:font-object' is instantiated, it can call %initialize-font to fill
up it's (i.e. the font-object's) dictionary.
|#
(defclass t1-font-mixin ()     ; -- subtype Type1 (embedded)
  (;;for now encapsulate the generic pdf::font object
   (font :initform nil :accessor pdf-font)
   ;; encapsulate the file stream object for the pfb
   (fontfile-stream :initform (make-instance 'pdf::pdf-stream)
		    :accessor fontfile)
   ;; these 3 are files we read (from tex installations)
   (pfb-path :initarg :pfb-path) 
   (afm-path :initarg :afm-path)
   (enc-path :initarg :enc-path)
   ;; the rest are filled in by the typesetting system 
   ;; based on the characters actually used in the document
   ;; (I think)
   (font-bbox ;; this is there in the pfb file. afm is wrong. see below
     :initarg font-bbox
     :accessor font-bbox)
   (first-char ;; :initform 0 
     :initarg first-char 
     :accessor first-char)
   (last-char ;; :initform 255 
     :initarg last-char 
     :accessor last-char)
   (char-widths ;; :initform (make-array 256 :initial-element nil)
     :initarg char-widths
     :accessor char-widths)
   (encoding-vector
     :accessor encoding-vector)
   ))

;; ad hoc parsing of PFB Files: 
;;
(defconstant +pfb-marker+ 128)
(defconstant +pfb-ascii+ 1)
(defconstant +pfb-binary+ 2)
(defconstant +pfb-done+ 3)

(defun %READ-PFB (input-stream *dump-stream* 
		  &aux *length1* *length2* *length3*)
  "input-stream, dump-stream are binary unsigned 8-bit byte streams"
  (flet ((%block-type ()
           (assert (= (read-byte input-stream) +pfb-marker+))
	   (let ((c (read-byte input-stream)))
	     (assert (member c (list +pfb-binary+ +pfb-ascii+ +pfb-done+)))c))
	 (%get-block () ; allocates block completely; 
	  (let* ((len ; read-block-length
		   (+ (+ (read-byte input-stream)
			 (* (read-byte input-stream) 256))
		      (* (+ (read-byte input-stream) 
			    (* (read-byte input-stream) 256)) 65536)))
		 (buf (make-array len :element-type '(unsigned-byte 8)))
		 (pos (read-sequence buf input-stream)))
	    (assert (= pos len)) buf)))

    ;; just hardcode reading of an ascii block, a binary block 
    ;; and a trailing ascii block. no loops for now
  (setf *length1* (list nil (file-position *dump-stream*))) ; initialize

  (assert (= (%block-type) +pfb-ascii+))
  (write-sequence (%get-block) *dump-stream*)
  (let ((p (file-position *dump-stream*))) 
     (setf *length1* (list (- p (cadr *length1*)) p)))

  (assert (= (%block-type) +pfb-binary+))
  (write-sequence (%get-block) *dump-stream*)
  (let ((p (file-position *dump-stream*))) 
     (setf *length2* (list (- p (cadr *length1*)) p)))

  (assert (= (%block-type) +pfb-ascii+))
  (write-sequence (%get-block) *dump-stream*)
  (let ((p (file-position *dump-stream*)))
     (setf *length3* (list (- p (cadr *length2*)) p)))

  (assert (= (%block-type) +pfb-done+))
  (let ((lengths (mapcar #'car (list *length1* *length2* *length3*))))
    (warn "LENGTHS=~a" lengths)
    lengths) ))

;; some hair to interface to %read-pfb
;; 
(defmacro with-binary-output-to-string-via-tempfile ((stream) &body body)
  `(let ((filename (pathname (string (gensym)))))
     (warn "tempfile=~a" filename)
      (unwind-protect
	(progn
	 (with-open-file (,stream filename :direction :output :element-type 
				  '(unsigned-byte 8))
	   ,@body)
	 (with-open-file (i filename :direction :input :element-type
			    '(unsigned-byte 8))
	   (let* ((len (file-length i))
		  (buf (make-array len :element-type '(unsigned-byte 8)))
		  (pos (read-sequence buf i)))
	     (assert (= pos len))
	     (map 'string #'code-char buf))))
       (warn "deleting ~a" filename)
       (delete-file filename))))


#+nil
(pprint   ; (macroexpand-1)
(with-binary-output-to-string-via-tempfile
  (foo)
  (loop for x across
	(with-output-to-string (bar)
	  (format bar "~a ~a ~a" '(1 2 3) #("foo" "bar" "car") :barf)) do
	(write-byte (char-code x) foo)))
);)

;; ; very ad-hoc parsing of .enc files
(defun %read-enc (stream &optional (encoding-vector (make-array 256 :initial-element nil)))
  "STREAM is a character stream, typically a `TeX' encoding file. fills
up ENCODING-VECTOR, a vector of size 256. Returns the ENCODING VECTOR"
   (check-type encoding-vector vector)
   (assert (= (length encoding-vector) 256))
   (let ((glyphno -1))
     (flet ((%brittle-read-glyphnames (line) 
	      (loop for start = 0 then end1 
		    for end = (or (position #\] line) ; todo: fails on %]
				  (position #\% line))
		    for start1 = (or (position #\/ line :start start :end end) 
				     (return))
		    for end1 = (position #\Space line :start start1 :end end) 
		    for name = (subseq line (1+ start1) (or end1 end))
		    do
		    (setf (aref encoding-vector glyphno) name)
		    (incf glyphno)
		    (unless end1 (return)))))
       (loop for line = (read-line stream nil) for lineno from 0 while line do
	     (cond ((< glyphno 0) ; skip file header upto `/name ['
		    (when (and (> (length line) 1)
			       (not (char= (schar line 0) #\%)))
		      (unless (and (char= (schar line 0) #\/) (find #\[ line))
			(error "invalid encoding: name or `[' missing"))
		      (setq glyphno 0)
		      (%brittle-read-glyphnames 
			(subseq line (position #\[ line)))))
		   ((> glyphno 256) (error "too many glyphs"))
		   ;; trailing `] def' ignored by the %brittle-read-glyphnames
		   (t (%brittle-read-glyphnames line))))))
   encoding-vector)

;; read the external files and fill in some blanks
;; 
(defmethod initialize-instance :after ((t1 t1-font-mixin) &rest initargs
					&key afm-path pfb-path enc-path
					&allow-other-keys)
  (with-slots (font fontfile-stream) t1
    ;; read afm file
    (let ((afm-metrics (pdf::read-afm-file afm-path)))
      (setf font (pdf::get-font (pdf::font-name afm-metrics)))
      ;; read enc file
      (with-open-file (encoding-stream enc-path :direction :input :element-type
				       'character)
	;; currently encoding-vector is nil. we set it.
	(setf (encoding-vector t1)
	      (%read-enc encoding-stream))))
    ;; read pfb file
    (setf (pdf::content fontfile-stream)
	  (with-binary-output-to-string-via-tempfile
	    (dump-stream)
	    (with-open-file (pfb-stream pfb-path :direction :input :element-type
					'(unsigned-byte 8))
	      (destructuring-bind
		(length1 length2 length3)
		(%read-pfb pfb-stream dump-stream)
		(pdf::add-dict-value fontfile-stream "/Length3" length3)
		(pdf::add-dict-value fontfile-stream "/Length2" length2)
		(pdf::add-dict-value fontfile-stream "/Length1" length1)))))))
  
(defmethod %make-differences-array ((t1 t1-font-mixin))
  (let ((ev (encoding-vector t1)))
    (with-output-to-string (s)
      (loop with undef-p for i from 0 to 255
	    do (if (= i 0) 
		 (cond ((string/= (aref ev i) ".notdef")
			(setf undef-p nil)
			(format s "[~d/~a" i (aref ev i)))
		       (t (setf undef-p t) 
			  (format s "[~d/.notdef" i)))
		 (cond ((string/= (aref ev i) ".notdef")
			(when undef-p 
			  (setf undef-p nil)
			  (format s " ~d" i))
			(format s "/~a" (aref ev i)))
		       (t (unless undef-p
			    (setf undef-p t)
			    (format s " ~d/.notdef" i)))))
	    finally 
	    (format s "]"))) ))

(defmethod %get-stem-v ((t1 t1-font-mixin)) ;; fixme. this is wrong.
  (let* ((font (pdf-font t1))
	 (fm  (pdf::font-metrics font))
	 (c (pdf::characters fm))
	 (cm (gethash "period" c)))
  (round (/ (* 1000 (pdf::width cm)) 3))))

(defmethod %make-font-descriptor-dict ((t1 t1-font-mixin))
  (let* ((font (pdf-font t1)) (fm  (pdf::font-metrics font)))
    (make-instance 
      'pdf::dictionary
      :dict-values
      `(("/Type" . "/FontDescriptor")
	("/FontName"  . ,(pdf::add-/ (pdf::name font)))
	("/Flags" . "4") ;; wth 4 = symbolic, catchall. 34 if no fontfile. not specified in afm
	("/FontBBox" .  ,(font-bbox t1))
	;; FIXMEthis also is incorrect. we get #(-270 -250 1011 948) from
	;; the afm file while we get [-62 -250 1011 750] for actual chars used. this needs to 
	;; be fixed elsewhere (i.e. in `t1-font' class)
	;;,(map 'vector (lambda (x) (round (* 1000 x))) (pdf::font-bbox fm))
	("/ItalicAngle" . ,(round (* 1000 (pdf::italic-angle fm))))
	("/Ascent" . ,(round (* 1000 (pdf::ascender fm))))
	("/Descent" . ,(round (* 1000 (pdf::descender fm))))
	("/Leading" . ,(round (* 1000 (pdf::leading fm))))
	("/CapHeight" . ,(round (* 1000 (pdf::cap-height fm))))
	("/XHeight" . ,(round (* 1000 (pdf::x-height fm))))
	("/StemV" . ,(%get-stem-v t1))
	("/FontFile" . 
	 ,(make-instance 'pdf::indirect-object
			 :content (fontfile t1)))))))

;;
;;
(defmethod %make-t1-font-dict ((t1 t1-font-mixin))
  (make-instance 
    'pdf::dictionary
    :dict-values
    `(("/Type" . "/Font")
      ("/Subtype" . "/Type1")
      ("/Encoding" . 
       ,(make-instance 'pdf::indirect-object
	     :content (make-instance 
			'pdf::dictionary
			:dict-values
			`(("/Type" . "/Encoding")
			  ("/Differences" . ,(%make-differences-array t1))))))
      ("/FirstChar" . ,(first-char t1))
      ("/LastChar" . ,(last-char t1))
      ("/Widths" . 
       ,(make-instance 'pdf::indirect-object 
				   :content (char-widths t1)))
      ("/BaseFont" . ,(pdf::add-/ (pdf::name (pdf-font t1))))
      ("/FontDescriptor" .
       ,(make-instance 'pdf::indirect-object
	    :content (%make-font-descriptor-dict t1))))))

;; intgratiate into PDF
;;
(defmethod pdf::%initialize-font ((font-object pdf::font-object) 
				  (t1 t1-font-mixin)
				  &rest init-options &key &allow-other-keys)
  (when init-options (warn "Type 1: ignoring init-options ~a" init-options))
  (setf (pdf::content font-object) (%make-t1-font-dict t1))
  (pdf::add-dict-value (pdf::content font-object) 
		       "/Name" (pdf::name font-object)))

;;; sample use
;;;
(defparameter *t1* (make-instance 't1::t1-font-mixin 
				  :pfb-path #p"skt:cmb10;cmb10.pfb"
				  :afm-path #p"skt:cmb10;cmb10.afm"
				  :enc-path #p"skt:cmb10;f7b6d320.enc"
				  ;; fake typesetter state
				  't1::first-char 97
				  't1::last-char 121
				  't1::font-bbox #(-62 -250 1011 750)
				  't1::char-widths 
				  #(486 0 444 556 467 306 500 556 278 0 0 278 833 556 500 556 0 428 394 390 0 0 722 0 528)))

(defun t1-example (&optional (file #p"t1.pdf") &aux
                             (pdf:*compress-streams* nil))
  (pdf:with-document ()
    (pdf:with-page ()
      (pdf:with-outline-level ("PFB Example" (pdf:register-page-reference))
	 (pdf:in-text-mode
	   (pdf:set-font *t1* 9.963)
	   ;; the following is what the typesetter would provide
	   (pdf:move-text 148.712 657.235)
	   (pdf:show-spaced-strings
	     '("no" 28 "w" -333 "is" -334 "the" -333 "time" -333 "f"1 "or"
	       -334 "al" 1 "l" -333 "go" -28 "o" -28 "d" -333 "men" -333 "to"
	       -333 "c" -1 "ome" -333 "to" -333 "t" -1 "h" 1 "e" -333 "aid" 
	       -333 "of" -333 "the" -333 "p" 1 "art" 27 "y")))))
    (pdf:write-document file)))

#+nil
(t1::t1-example)