| 1 |
;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details |
|---|
| 2 |
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net |
|---|
| 3 |
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html |
|---|
| 4 |
|
|---|
| 5 |
;;; |
|---|
| 6 |
;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) |
|---|
| 7 |
;;; |
|---|
| 8 |
|
|---|
| 9 |
;;; Support for TrueTypeUnicode fonts |
|---|
| 10 |
|
|---|
| 11 |
(in-package #:pdf) |
|---|
| 12 |
|
|---|
| 13 |
(defclass ttu-font-metrics (font-metrics) |
|---|
| 14 |
((c2g :accessor c2g |
|---|
| 15 |
:initform (make-array 131072 :element-type 'character :initial-element #\Nul)) |
|---|
| 16 |
(cid-widths :accessor cid-widths :initform (make-array 0 :adjustable t :fill-pointer 0)) |
|---|
| 17 |
(pdf-widths :accessor pdf-widths :initform nil) |
|---|
| 18 |
(binary-data :accessor binary-data :initform nil) |
|---|
| 19 |
(min-code :accessor min-code :initform 0) |
|---|
| 20 |
(max-code :accessor max-code :initform 0) |
|---|
| 21 |
(length1 :accessor length1))) |
|---|
| 22 |
|
|---|
| 23 |
(defmethod font-type ((fm ttu-font-metrics)) |
|---|
| 24 |
"Type0") |
|---|
| 25 |
|
|---|
| 26 |
(defun load-ttu-font (ufm-file &optional ttf-file) |
|---|
| 27 |
(let ((ttufm (read-ufm-file ufm-file 'ttu-font-metrics))) |
|---|
| 28 |
(when ttf-file |
|---|
| 29 |
(with-open-file (in ttf-file :direction :input :element-type '(unsigned-byte 8)) |
|---|
| 30 |
(setf (length1 ttufm) |
|---|
| 31 |
(file-length in) |
|---|
| 32 |
(binary-data ttufm) |
|---|
| 33 |
(make-array (length1 ttufm) :element-type '(unsigned-byte 8))) |
|---|
| 34 |
(read-sequence (binary-data ttufm) in))) |
|---|
| 35 |
ttufm)) |
|---|
| 36 |
|
|---|
| 37 |
;;; example: (pdf:load-ttu-font #P"/tmp/arial.ufm" #P"/tmp/arial.ttf") |
|---|
| 38 |
|
|---|
| 39 |
(defmethod font-descriptor ((fm ttu-font-metrics) &key (embed *embed-fonts*) &allow-other-keys) |
|---|
| 40 |
(flet ((conv-dim (d) (round (* 1000 d)))) |
|---|
| 41 |
(make-instance |
|---|
| 42 |
'indirect-object |
|---|
| 43 |
:content |
|---|
| 44 |
(make-instance |
|---|
| 45 |
'dictionary ; :obj-number 0 :no-link t |
|---|
| 46 |
:dict-values |
|---|
| 47 |
`(("/Type" . "/FontDescriptor") |
|---|
| 48 |
("/FontName" . ,(add-/ (font-name fm))) |
|---|
| 49 |
("/Flags" |
|---|
| 50 |
. ,(logior |
|---|
| 51 |
(if (fixed-pitch-p fm) 1 0) |
|---|
| 52 |
;; 4 ? non-ascii present |
|---|
| 53 |
32 |
|---|
| 54 |
(if (< 0 (italic-angle fm)) 64 0))) |
|---|
| 55 |
("/FontBBox" . ,(map 'vector #'conv-dim (font-bbox fm))) |
|---|
| 56 |
("/ItalicAngle" . ,(conv-dim (italic-angle fm))) |
|---|
| 57 |
("/Ascent" . ,(conv-dim (ascender fm))) |
|---|
| 58 |
("/Descent" . ,(conv-dim (descender fm))) |
|---|
| 59 |
("/CapHeight" . ,(conv-dim (cap-height fm))) |
|---|
| 60 |
("/XHeight" . ,(conv-dim (x-height fm))) |
|---|
| 61 |
("/StemV" . ,10) |
|---|
| 62 |
,@(when (and embed (binary-data fm)) |
|---|
| 63 |
`(("/FontFile2" |
|---|
| 64 |
. ,(make-instance |
|---|
| 65 |
'indirect-object |
|---|
| 66 |
:content |
|---|
| 67 |
(make-instance |
|---|
| 68 |
'pdf-stream |
|---|
| 69 |
:content (binary-data fm) |
|---|
| 70 |
:no-compression (not *compress-fonts*) |
|---|
| 71 |
:dict-values `(("/Length1" . ,(length1 fm))))))))))))) |
|---|
| 72 |
|
|---|
| 73 |
(defclass cid-font () |
|---|
| 74 |
((base-font :accessor base-font :initarg :base-font) |
|---|
| 75 |
(descriptor :accessor descriptor :initarg :descriptor) |
|---|
| 76 |
(widths :accessor widths :initarg :widths) |
|---|
| 77 |
(c2g :accessor c2g :initarg :c2g))) |
|---|
| 78 |
|
|---|
| 79 |
(defmethod make-dictionary ((font cid-font) &key &allow-other-keys) |
|---|
| 80 |
(make-instance |
|---|
| 81 |
'dictionary |
|---|
| 82 |
:dict-values |
|---|
| 83 |
`(("/Type" . "/Font") |
|---|
| 84 |
("/Subtype" . "/CIDFontType2") |
|---|
| 85 |
("/BaseFont" . ,(add-/ (base-font font))) |
|---|
| 86 |
("/CIDSystemInfo" |
|---|
| 87 |
. ,(make-instance |
|---|
| 88 |
'dictionary |
|---|
| 89 |
:dict-values |
|---|
| 90 |
`(("/Registry" . ,(pdf-string "Adobe")) |
|---|
| 91 |
("/Ordering" . ,(pdf-string "UCS")) |
|---|
| 92 |
("/Supplement" . 0)))) |
|---|
| 93 |
("/FontDescriptor" . ,(descriptor font)) |
|---|
| 94 |
("/W" . ,(widths font)) |
|---|
| 95 |
("/CIDToGIDMap" |
|---|
| 96 |
. ,(make-instance |
|---|
| 97 |
'indirect-object |
|---|
| 98 |
:content |
|---|
| 99 |
(make-instance |
|---|
| 100 |
'pdf-stream |
|---|
| 101 |
:content (c2g font) |
|---|
| 102 |
:no-compression (not *compress-fonts*))))))) |
|---|
| 103 |
|
|---|
| 104 |
(defmethod make-dictionary ((fm ttu-font-metrics) |
|---|
| 105 |
&key font (encoding (encoding font)) (embed *embed-fonts*)) |
|---|
| 106 |
(declare (ignore encoding)) |
|---|
| 107 |
(let* ((font-descriptor (font-descriptor fm :embed embed :errorp nil)) |
|---|
| 108 |
(cid-font (make-instance |
|---|
| 109 |
'cid-font |
|---|
| 110 |
:base-font (font-name fm) |
|---|
| 111 |
:descriptor font-descriptor |
|---|
| 112 |
:widths (cid-widths fm) |
|---|
| 113 |
:c2g (c2g fm)))) |
|---|
| 114 |
(make-instance |
|---|
| 115 |
'dictionary |
|---|
| 116 |
:dict-values |
|---|
| 117 |
`(("/Type" . "/Font") |
|---|
| 118 |
("/Subtype" . ,(add-/ (font-type fm))) |
|---|
| 119 |
("/BaseFont" . ,(add-/ (concatenate 'string (font-name fm) "-UCS"))) |
|---|
| 120 |
("/Encoding" . "/Identity-H") |
|---|
| 121 |
;; TODO shouldn't it be this? if not, then delete encoding keyword argument... |
|---|
| 122 |
#+nil("/Encoding" . (if (standard-encoding encoding) |
|---|
| 123 |
(add-/ (name encoding)) |
|---|
| 124 |
(find-encoding-object encoding))) |
|---|
| 125 |
("/DescendantFonts" |
|---|
| 126 |
. ,(vector |
|---|
| 127 |
(make-instance |
|---|
| 128 |
'indirect-object |
|---|
| 129 |
:content (make-dictionary cid-font)))))))) |
|---|
