font-metrics.lisp

Revision 2636, 17.0 kB (checked in by hans, 10 months ago)
add cl-pdf for pixel->pdf converter

Line
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	(in-package #:pdf)
6
7	;;Many thanks to Alexey Dejneka (adejneka@comail.ru) who finished the parsing of the AFM files.
8
9	(defvar font-metrics (make-hash-table :test #'equal))
10
11	(defclass char-metrics ()
12	((code :accessor code :initarg :code)
13	(name :accessor name :initarg :name)
14	(index :accessor index :initarg :index)
15	(width :accessor width :initarg :width)
16	(spacing :accessor spacing :initarg :spacing)
17	(right-italic-correction :accessor right-italic-correction :initarg :right-italic-correction)
18	(left-italic-correction :accessor left-italic-correction :initarg :left-italic-correction)
19	(bbox :accessor bbox :initarg :bbox)))
20
21	(defmethod print-object ((self char-metrics) stream)
22	(print-unreadable-object (self stream :type t)
23	(format stream "~a" (name self))))
24
25	(defclass font-metrics ()
26	((font-name :accessor font-name)
27	(full-name :accessor full-name)
28	(family-name :accessor family-name)
29	(weight :accessor weight)
30	(underline-position :accessor underline-position :initform 0)
31	(underline-thickness :accessor underline-thickness :initform 0)
32	(italic-angle :accessor italic-angle :initform 0)
33	(italic-sin :accessor italic-sin :initform 0)
34	(fixed-pitch-p :accessor fixed-pitch-p :initform nil)
35	(char-width :accessor char-width :initform nil)
36	(font-bbox :accessor font-bbox)
37	(version :accessor version)
38	(notice :accessor notice)
39	(encoding-scheme :accessor encoding-scheme)
40	(encoding-vector :accessor encoding-vector :initform (make-array 256 :initial-element nil))
41	(characters :accessor characters :initform (make-hash-table :test #'equal))
42	(mapping-scheme :accessor mapping-scheme)
43	(esc-char :accessor esc-char)
44	(character-set :accessor character-set)
45	(base-font-p :initform t :accessor base-font-p)
46	(vvector :accessor vvector)
47	(fixed-v-p :accessor fixed-v-p)
48	(cap-height :accessor cap-height :initform 1)
49	(x-height :accessor x-height :initform 0.5)
50	(ascender :accessor ascender :initform 1)
51	(descender :accessor descender :initform 0)
52	(leading :accessor leading :initform 1)
53	; (char-metrics :accessor char-metrics)
54	(kernings :accessor kernings :initform (make-hash-table :test #'equal))))
55
56	(defmethod print-object ((self font-metrics) stream)
57	(print-unreadable-object (self stream :identity t :type t)
58	(format stream "~a" (full-name self))))
59
60	;;; Utilities
61	(defmacro mcond (&rest clauses &environment env)
62	"An analog of COND, but MACROEXPANDs every clause."
63	`(cond ,@(mapcar (lambda (clause)
64	(loop
65	(unless (and (consp clause)
66	(symbolp (first clause))
67	(multiple-value-bind (expansion expanded-p)
68	(macroexpand-1 clause env)
69	(setq clause expansion)
70	expanded-p))
71	(return clause))))
72	clauses)))
73
74	(eval-when (:compile-toplevel :load-toplevel :execute)
75	(defmacro with-gensyms ((&rest names) &body body)
76	`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) names))
77	,@body)))
78
79	;;; Parser
80	(defun whitespace-p (char)
81	(or (char= char #\Space) (char= char #\Tab)))
82
83	(defun get-afm-string (line start)
84	(declare (type string line))
85	(let* ((length (length line))
86	(start (or (position-if-not #'whitespace-p line :start start) length)))
87	(values (subseq line start) length)))
88
89	(defun get-afm-integer (line start)
90	(declare (type string line))
91	(parse-integer line :start start :junk-allowed t))
92
93	(defun get-afm-hex (line start)
94	(declare (type string line))
95	(let ((length (length line))
96	(start (position-if-not #'whitespace-p line :start start)))
97	(unless (and start (<= start (- length 2))
98	(char= (aref line start) #\<)
99	(digit-char-p (aref line (1+ start)) 16))
100	(error 'parse-error))
101	(multiple-value-bind (value position)
102	(parse-integer line :start (1+ start) :radix 16 :junk-allowed t)
103	(unless (and value
104	(< position length)
105	(char= (aref line position) #\>))
106	(error 'parse-error))
107	(values value (1+ position)))))
108
109	(defun get-afm-number (line start)
110	(declare (type string line))
111	(multiple-value-bind (value position)
112	(parse-integer line :start start :junk-allowed t)
113	(cond ((not value) (error 'parse-error))
114	((or (= position (length line))
115	(whitespace-p (aref line position)))
116	(values value position))
117	((not (char= (aref line position) #\.))
118	(error 'parse-error))
119	((= (incf position) (length line)) (values value position))
120	((not (or (digit-char-p (aref line position))
121	(whitespace-p (aref line position))))
122	(error 'parse-error))
123	(t (multiple-value-bind (fraction end)
124	(parse-integer line :start position :junk-allowed t)
125	(values (+ value (* (signum value)
126	(/ fraction (expt 10.0 (- end position)))))
127	end))))))
128
129	(defun get-afm-name (line start)
130	(declare (type string line))
131	(let ((name-start (position-if-not #'whitespace-p line :start start)))
132	(if name-start
133	(let ((name-end (or (position-if #'whitespace-p line :start name-start)
134	(length line))))
135	(values (subseq line name-start name-end)
136	name-end))
137	nil)))
138
139	(defun get-afm-boolean (line start)
140	(multiple-value-bind (word pos) (get-afm-name line start)
141	(values (cond ((string= word "true") t)
142	((string= word "false") nil)
143	(t (error 'parse-error)))
144	pos)))
145
146	(defmacro define-afm-section ((name afm-name)(stream &rest args) &body body)
147	(with-gensyms (file-line line keyword position start value new-position)
148	`(defun ,name (,stream ,@args)
149	(macrolet ((process-keywords (&rest clauses)
150	`(loop
151	for ,',file-line = (or (read-line ,',stream nil nil)
152	(error "Unclosed AFM section ~S."
153	,',afm-name))
154	for ,',line = (string-trim '(#\space #\newline #\return)
155	,',file-line)
156	do (multiple-value-bind (,',keyword ,',position)
157	(get-afm-name ,',line 0)
158	(declare (ignorable ,',position))
159	(when ,',keyword
160	(mcond ,@clauses)))))
161	(process-keywords-in-line (&rest clauses)
162	`(loop
163	for ,',start = -1 then (position #\; ,',line :start ,',position)
164	for ,',position = (and ,',start
165	(position-if-not #'whitespace-p
166	,',line
167	:start (1+ ,',start)))
168	while ,',position
169	do (multiple-value-bind (,',keyword ,',position)
170	(get-afm-name ,',line ,',position)
171	(declare (ignorable ,',position))
172	(when ,',keyword
173	(mcond ,@clauses)))))
174	(get-object-of-type (type)
175	`(multiple-value-bind (,',value ,',new-position)
176	(,(read-from-string (format nil "get-afm-~A" (string-downcase type))) ,',line ,',position)
177	(setq ,',position ,',new-position)
178	,',value))
179	(key (key arglist &body body)
180	(loop for (name type) in arglist
181	collect `(,name (get-object-of-type ,type)) into bindings
182	finally (return `((string= ,',keyword ,key)
183	(let ,bindings
184	,@body))))))
185	,@body))))
186
187	(define-afm-section (afm-font-metrics "FontMetrics") (stream font-metrics-class)
188	(let ((font-metrics (make-instance font-metrics-class)))
189	(macrolet ((named-parameter (key type param)
190	`(key ,key ((,param ,type)) (setf (,param font-metrics) ,param)))
191	(scaled-parameter (key type param)
192	`(key ,key ((,param ,type)) (setf (,param font-metrics) (* 0.001 ,param)))))
193	(process-keywords
194	(key "EndFontMetrics" ()
195	(setf (gethash (string-downcase (font-name font-metrics)) font-metrics) font-metrics
196	; (gethash (string-downcase (full-name font-metrics)) font-metrics) font-metrics
197	(leading font-metrics)(- 1 (descender font-metrics))
198	(italic-sin font-metrics)(sin (/ (* pi (italic-angle font-metrics)) -180)))
199	(return-from afm-font-metrics font-metrics))
200	(named-parameter "FontName" string font-name)
201	(named-parameter "FullName" string full-name)
202	(named-parameter "FamilyName" string family-name)
203	(named-parameter "Weight" string weight)
204	(key "FontBBox" ((llx number) (lly number) (urx number) (ury number))
205	(setf (font-bbox font-metrics)
206	(vector (* 0.001 llx) (* 0.001 lly) (* 0.001 urx) (* 0.001 ury))))
207	(named-parameter "Version" string version)
208	(named-parameter "Notice" string notice)
209	(named-parameter "EncodingScheme" string encoding-scheme)
210	(named-parameter "MappingScheme" integer mapping-scheme)
211	(named-parameter "EscChar" integer esc-char)
212	(named-parameter "CharacterSet" string character-set)
213	(named-parameter "Characters" integer characters)
214	(named-parameter "IsBaseFont" boolean base-font-p)
215	;; vvector
216	(named-parameter "IsFixedV" boolean fixed-v-p)
217	(scaled-parameter "CapHeight" number cap-height)
218	(scaled-parameter "XHeight" number x-height)
219	(scaled-parameter "Ascender" number ascender)
220	(scaled-parameter "Descender" number descender)
221	(named-parameter "IsFixedPitch" boolean fixed-pitch-p)
222	(key "CharWidth" ((x number) (y number))
223	(setf (char-width font-metrics)(list (* 0.001 x) (* 0.001 y))
224	(fixed-pitch-p font-metrics) t))
225	(named-parameter "ItalicAngle" number italic-angle)
226	(scaled-parameter "UnderlinePosition" number underline-position)
227	(scaled-parameter "UnderlineThickness" number underline-thickness)
228	(key "StartCharMetrics" ()
229	(setf (characters font-metrics)
230	(afm-char-metrics stream (char-width font-metrics)(italic-sin font-metrics) font-metrics)))
231	(key "StartKernPairs" ()
232	(afm-char-kernings stream (characters font-metrics)(kernings font-metrics)))
233	))))
234
235	(define-afm-section (afm-char-metrics "CharMetrics")(stream default-width italic-sin font-metrics)
236	(let ((metrics (make-hash-table :test #'equal))
237	(encoding (encoding-vector font-metrics))
238	char-metrics)
239	(setf (gethash "VoidCharacter" metrics)
240	(make-instance 'char-metrics :code -1 :name "VoidChar" :index 0
241	:width 0 :bbox #(0 0 0 0) :spacing 0))
242	(process-keywords
243	(key "EndCharMetrics" () (return-from afm-char-metrics metrics))
244	(t (let ((width default-width)
245	(stroke-width 0)
246	(index 0)
247	(code -1)
248	(name nil)
249	(bbox (font-bbox font-metrics)))
250	(process-keywords-in-line
251	(key "C" ((p-code integer)) (setq code p-code))
252	(key "CH" ((p-code hex)) (setq code p-code))
253	(key "WX" ((p-width number)) (setq width (* 0.001 p-width)))
254	(key "N" ((p-name name)) (setq name p-name))
255	(key "I" ((p-index number)) (setq index p-index))
256	(key "B" ((llx number) (lly number) (urx number) (ury number))
257	(setf bbox (vector (* 0.001 llx) (* 0.001 lly) (* 0.001 urx) (* 0.001 ury)))
258	(setf stroke-width (if (zerop urx) width (* 0.001 urx)))))
259	(unless width
260	(error "Width is not given for a character C ~D." code))
261	(setf char-metrics
262	(make-instance 'char-metrics :code code :name name :index index :width width :bbox bbox
263	:spacing (- width stroke-width)
264	:left-italic-correction (if bbox (* italic-sin (aref bbox 3)) 0)
265	:right-italic-correction (if bbox (* italic-sin (aref bbox 1)) 0)))
266	(when (<= 0 code 255)
267	(setf (aref encoding code) char-metrics))
268	(when name
269	(setf (gethash name metrics) char-metrics)))))))
270
271	(define-afm-section (afm-char-kernings "CharKernPairs")(stream characters kernings)
272	(flet ((register-kern-pair (name1 name2 dx dy)
273	(let* ((char1 (gethash name1 characters))
274	(char2 (when char1 (gethash name2 characters))))
275	(when char2
276	(setf (gethash (cons char1 char2) kernings) (cons (* 0.001 dx) (* 0.001 dy)))))))
277	(process-keywords
278	(key "EndKernPairs" () (return-from afm-char-kernings))
279	(t (process-keywords-in-line
280	(key "KP" ((name1 name)(name2 name)(dx number)(dy number))
281	(register-kern-pair name1 name2 dx dy))
282	(key "KPX" ((name1 name)(name2 name)(dx number))
283	(register-kern-pair name1 name2 dx 0)))))))
284
285	(defun read-afm-file (filename &optional (font-metrics-class 'font-metrics))
286	(with-open-file (s filename :direction :input :external-format +external-format+)
287	(afm-font-metrics s font-metrics-class)))
288
289	(defun read-ufm-file (filename &optional (font-metrics-class 'ttu-font-metrics))
290	(let ((min-code #xfffe)
291	(max-code 0)
292	void-char encoding-vector pdf-widths font-metrics)
293	(with-open-file (s filename :direction :input :external-format +external-format+)
294	(setf font-metrics (afm-font-metrics s font-metrics-class)))
295	(setf void-char (gethash "VoidCharacter" (characters font-metrics)))
296	(iter (for (nil char-metrics) in-hashtable (characters font-metrics))
297	(for gid = (index char-metrics))
298	(for code = (code char-metrics))
299	(when (and (<= 0 code #xfffe))
300	(when (> code max-code) (setf max-code code))
301	(when (< code min-code) (setf min-code code))
302	(setf (aref (c2g font-metrics) (* 2 code))
303	(code-char (ldb (byte 8 8) gid))
304	(aref (c2g font-metrics) (+ (* 2 code) 1))
305	(code-char (ldb (byte 8 0) gid)))
306	(vector-push-extend code (cid-widths font-metrics))
307	(vector-push-extend (vector (round (* 1000 (width char-metrics)))) (cid-widths font-metrics))))
308	(setf encoding-vector (make-array (1+ max-code) :initial-element void-char)
309	pdf-widths (make-array (1+ max-code) :initial-element 0))
310	(iter (for (nil char-metrics) in-hashtable (characters font-metrics))
311	(for code = (code char-metrics))
312	(when (<= min-code code max-code)
313	(setf (aref encoding-vector code) char-metrics
314	(aref pdf-widths code) (round (* 1000 (width char-metrics))))))
315	(setf (min-code font-metrics) min-code
316	(max-code font-metrics) max-code
317	(encoding-vector font-metrics) encoding-vector
318	(pdf-widths font-metrics) pdf-widths
319	(encoding-scheme font-metrics) :unicode-encoding
320	(gethash (string-downcase (font-name font-metrics)) font-metrics) font-metrics
321	(leading font-metrics) (- 1 (descender font-metrics))
322	(italic-sin font-metrics) (sin (/ (* pi (italic-angle font-metrics)) -180)))
323	font-metrics))
324
325	(defmethod font-type (font-metrics)
326	(declare (ignore font-metrics))
327	"Type1")
328
329	(defmethod font-descriptor (font-metrics &key (errorp nil) &allow-other-keys)
330	(declare (ignore font-metrics))
331	(if errorp
332	(error "Generic fonts do not have descriptors.")
333	nil))
334
335	(defmethod make-dictionary ((fm font-metrics)
336	&key font (encoding (encoding font)) (embed embed-fonts)
337	&allow-other-keys)
338	(let ((font-descriptor (font-descriptor fm :embed embed :errorp nil)))
339	(make-instance 'dictionary :dict-values
340	`(("/Type" . "/Font")
341	("/Subtype" . ,(add-/ (font-type fm)))
342	("/BaseFont" . ,(add-/ (font-name fm)))
343	("/Encoding" . ,(if (standard-encoding encoding)
344	(add-/ (name encoding))
345	(find-encoding-object encoding)))
346	,@(when font-descriptor
347	`(("/FirstChar" . 0)
348	("/LastChar" . 255)
349	("/Widths" . ,(pdf-widths font))
350	("/FontDescriptor" . ,font-descriptor))) )) ))
351
352
353	(defun extract-font-metrics-encoding (font-metrics)
354	;; Make extract-font-metrics-encoding generic?
355	(let ((encoding (or (get-encoding (encoding-scheme font-metrics))
356	(get-encoding (font-name font-metrics)))))
357	(if encoding
358	encoding
359	(make-instance 'single-byte-encoding :name (font-name font-metrics)
360	:standard-encoding nil
361	:char-names (map 'vector #'(lambda (char)
362	(and char (name char)))
363	(encoding-vector font-metrics))))))
364

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format