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