File: font-metrics.lisp

package info (click to toggle)
cl-pdf 166-1
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 1,520 kB
  • ctags: 639
  • sloc: lisp: 6,902; makefile: 39
file content (364 lines) | stat: -rw-r--r-- 17,410 bytes parent folder | download
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
;;; 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

(in-package #:pdf)

;;Many thanks to Alexey Dejneka (adejneka@comail.ru) who finished the parsing of the AFM files.

(defvar *font-metrics* (make-hash-table :test #'equal))

(defclass char-metrics ()
  ((code  :accessor code  :initarg :code)
   (name  :accessor name  :initarg :name)
   (index :accessor index  :initarg :index)
   (width :accessor width :initarg :width)
   (spacing :accessor spacing :initarg :spacing)
   (right-italic-correction :accessor right-italic-correction :initarg :right-italic-correction)
   (left-italic-correction :accessor left-italic-correction :initarg :left-italic-correction)
   (bbox  :accessor bbox  :initarg :bbox)))

(defmethod print-object ((self char-metrics) stream)
  (print-unreadable-object (self stream :type t)
    (format stream "~a" (name self))))

(defclass font-metrics ()
  ((font-name :accessor font-name)
   (full-name :accessor full-name)
   (family-name :accessor family-name)
   (weight :accessor weight)
   (underline-position :accessor underline-position :initform 0)
   (underline-thickness :accessor underline-thickness :initform 0)
   (italic-angle :accessor italic-angle :initform 0)
   (italic-sin :accessor italic-sin :initform 0)
   (fixed-pitch-p :accessor fixed-pitch-p :initform nil)
   (char-width :accessor char-width :initform nil)
   (font-bbox :accessor font-bbox)
   (version :accessor version)
   (notice :accessor notice)
   (encoding-scheme :accessor encoding-scheme)
   (encoding-vector :accessor encoding-vector :initform (make-array 256 :initial-element nil))
   (characters :accessor characters :initform (make-hash-table :test #'equal))
   (mapping-scheme :accessor mapping-scheme)
   (esc-char :accessor esc-char)
   (character-set :accessor character-set)
   (base-font-p :initform t :accessor base-font-p)
   (vvector :accessor vvector)
   (fixed-v-p :accessor fixed-v-p)
   (cap-height :accessor cap-height :initform 1)
   (x-height :accessor x-height :initform 0.5)
   (ascender :accessor ascender :initform 1)
   (descender :accessor descender :initform 0)
   (leading :accessor leading :initform 1)
;   (char-metrics :accessor char-metrics)
   (kernings :accessor kernings :initform (make-hash-table :test #'equal))))

(defmethod print-object ((self font-metrics) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (format stream "~a" (full-name self))))

;;; Utilities
(defmacro mcond (&rest clauses &environment env)
  "An analog of COND, but MACROEXPANDs every clause."
  `(cond ,@(mapcar (lambda (clause)
                     (loop
                        (unless (and (consp clause)
                                     (symbolp (first clause))
                                     (multiple-value-bind (expansion expanded-p)
                                         (macroexpand-1 clause env)
                                       (setq clause expansion)
                                       expanded-p))
                          (return clause))))
                   clauses)))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-gensyms ((&rest names) &body body)
  `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) names))
     ,@body)))

;;; Parser
(defun whitespace-p (char)
  (or (char= char #\Space) (char= char #\Tab)))

(defun get-afm-string (line start)
  (declare (type string line))
  (let* ((length (length line))
         (start (or (position-if-not #'whitespace-p line :start start) length)))
    (values (subseq line start) length)))

(defun get-afm-integer (line start)
  (declare (type string line))
  (parse-integer line :start start :junk-allowed t))

(defun get-afm-hex (line start)
  (declare (type string line))
  (let ((length (length line))
        (start (position-if-not #'whitespace-p line :start start)))
    (unless (and start (<= start (- length 2))
                 (char= (aref line start) #\<)
                 (digit-char-p (aref line (1+ start)) 16))
      (error 'parse-error))
    (multiple-value-bind (value position)
        (parse-integer line :start (1+ start) :radix 16 :junk-allowed t)
      (unless (and value
                   (< position length)
                   (char= (aref line position) #\>))
        (error 'parse-error))
      (values value (1+ position)))))

(defun get-afm-number (line start)
  (declare (type string line))
  (multiple-value-bind (value position)
      (parse-integer line :start start :junk-allowed t)
    (cond ((not value) (error 'parse-error))
          ((or (= position (length line))
               (whitespace-p (aref line position)))
           (values value position))
          ((not (char= (aref line position) #\.))
           (error 'parse-error))
          ((= (incf position) (length line)) (values value position))
          ((not (or (digit-char-p (aref line position))
                    (whitespace-p (aref line position))))
           (error 'parse-error))
          (t (multiple-value-bind (fraction end)
                 (parse-integer line :start position :junk-allowed t)
               (values (+ value (*  (signum value)
                                    (/ fraction (expt 10.0 (- end position)))))
                       end))))))

(defun get-afm-name (line start)
  (declare (type string line))
  (let ((name-start (position-if-not #'whitespace-p line :start start)))
    (if name-start
        (let ((name-end (or (position-if #'whitespace-p line :start name-start)
                            (length line))))
          (values (subseq line name-start name-end)
                  name-end))
        nil)))

(defun get-afm-boolean (line start)
  (multiple-value-bind (word pos) (get-afm-name line start)
    (values (cond ((string= word "true") t)
                  ((string= word "false") nil)
                  (t (error 'parse-error)))
            pos)))

(defmacro define-afm-section ((name afm-name)(stream &rest args) &body body)
  (with-gensyms (file-line line keyword position start value new-position)
    `(defun ,name (,stream ,@args)
       (macrolet ((process-keywords (&rest clauses)
                    `(loop
                        for ,',file-line = (or (read-line ,',stream nil nil)
                                               (error "Unclosed AFM section ~S."
                                                      ,',afm-name))
                        for ,',line = (string-trim '(#\space #\newline #\return)
                                                   ,',file-line)
                        do (multiple-value-bind (,',keyword ,',position)
                               (get-afm-name ,',line 0)
                             (declare (ignorable ,',position))
                             (when ,',keyword
                               (mcond ,@clauses)))))
                  (process-keywords-in-line (&rest clauses)
                    `(loop
                        for ,',start = -1 then (position #\; ,',line :start ,',position)
                        for ,',position = (and ,',start
                                               (position-if-not #'whitespace-p
                                                                ,',line
                                                                :start (1+ ,',start)))
                        while ,',position
                        do (multiple-value-bind (,',keyword ,',position)
                               (get-afm-name ,',line ,',position)
                             (declare (ignorable ,',position))
                             (when ,',keyword
                               (mcond ,@clauses)))))
                  (get-object-of-type (type)
                    `(multiple-value-bind (,',value ,',new-position)
                         (,(read-from-string (format nil "get-afm-~A" (string-downcase type))) ,',line ,',position)
                       (setq ,',position ,',new-position)
                       ,',value))
                  (key (key arglist &body body)
                    (loop for (name type) in arglist
                       collect `(,name (get-object-of-type ,type)) into bindings
                       finally (return `((string= ,',keyword ,key)
                                         (let ,bindings
                                           ,@body))))))
         ,@body))))

(define-afm-section (afm-font-metrics "FontMetrics") (stream font-metrics-class)
  (let ((font-metrics (make-instance font-metrics-class)))
    (macrolet ((named-parameter (key type param)
                 `(key ,key ((,param ,type)) (setf (,param font-metrics) ,param)))
	       (scaled-parameter (key type param)
                 `(key ,key ((,param ,type)) (setf (,param font-metrics) (* 0.001 ,param)))))
      (process-keywords
       (key "EndFontMetrics" ()
	    (setf (gethash (string-downcase (font-name font-metrics)) *font-metrics*) font-metrics
;		  (gethash (string-downcase (full-name font-metrics)) *font-metrics*) font-metrics
		  (leading font-metrics)(- 1 (descender font-metrics))
		  (italic-sin font-metrics)(sin (/ (* pi (italic-angle font-metrics)) -180)))
	    (return-from afm-font-metrics font-metrics))
       (named-parameter "FontName" string font-name)
       (named-parameter "FullName" string full-name)
       (named-parameter "FamilyName" string family-name)
       (named-parameter "Weight" string weight)
       (key "FontBBox" ((llx number) (lly number) (urx number) (ury number))
            (setf (font-bbox font-metrics)
		  (vector (* 0.001 llx) (* 0.001 lly) (* 0.001 urx) (* 0.001 ury))))
       (named-parameter "Version" string version)
       (named-parameter "Notice" string notice)
       (named-parameter "EncodingScheme" string encoding-scheme)
       (named-parameter "MappingScheme" integer mapping-scheme)
       (named-parameter "EscChar" integer esc-char)
       (named-parameter "CharacterSet" string character-set)
       (named-parameter "Characters" integer characters)
       (named-parameter "IsBaseFont" boolean base-font-p)
       ;; vvector
       (named-parameter "IsFixedV" boolean fixed-v-p)
       (scaled-parameter "CapHeight" number cap-height)
       (scaled-parameter "XHeight" number x-height)
       (scaled-parameter "Ascender" number ascender)
       (scaled-parameter "Descender" number descender)
       (named-parameter "IsFixedPitch" boolean fixed-pitch-p)
       (key "CharWidth" ((x number) (y number))
            (setf (char-width font-metrics)(list (* 0.001 x) (* 0.001 y))
		  (fixed-pitch-p font-metrics) t))
       (named-parameter "ItalicAngle" number italic-angle)
       (scaled-parameter "UnderlinePosition" number underline-position)
       (scaled-parameter "UnderlineThickness" number underline-thickness)
       (key "StartCharMetrics" ()
            (setf (characters font-metrics)
                  (afm-char-metrics stream (char-width font-metrics)(italic-sin font-metrics) font-metrics)))
       (key "StartKernPairs" ()
	    (afm-char-kernings stream (characters font-metrics)(kernings font-metrics)))
       ))))

(define-afm-section (afm-char-metrics "CharMetrics")(stream default-width italic-sin font-metrics)
  (let ((metrics (make-hash-table :test #'equal))
	(encoding (encoding-vector font-metrics))
	char-metrics)
    (setf (gethash "VoidCharacter" metrics)
	  (make-instance 'char-metrics :code -1 :name "VoidChar" :index 0 
                         :width 0 :bbox #(0 0 0 0) :spacing 0))
    (process-keywords
     (key "EndCharMetrics" () (return-from afm-char-metrics metrics))
     (t (let ((width default-width)
	      (stroke-width 0)
              (index 0)
              (code -1)
	      (name nil)
	      (bbox (font-bbox font-metrics)))
          (process-keywords-in-line
           (key "C" ((p-code integer)) (setq code p-code))
           (key "CH" ((p-code hex)) (setq code p-code))
           (key "WX" ((p-width number)) (setq width (* 0.001 p-width)))
           (key "N" ((p-name name)) (setq name p-name))
           (key "I" ((p-index number)) (setq index p-index))
	   (key "B" ((llx number) (lly number) (urx number) (ury number))
		(setf bbox (vector (* 0.001 llx) (* 0.001 lly) (* 0.001 urx) (* 0.001 ury)))
		(setf stroke-width (if (zerop urx) width (* 0.001 urx)))))
          (unless width
            (error "Width is not given for a character C ~D." code))
	  (setf char-metrics
		(make-instance 'char-metrics :code code :name name :index index :width width :bbox bbox
			       :spacing (- width stroke-width)
			       :left-italic-correction (if bbox (* italic-sin (aref bbox 3)) 0)
			       :right-italic-correction (if bbox (* italic-sin (aref bbox 1)) 0)))
	  (when (<= 0 code 255)
	    (setf (aref encoding code) char-metrics))
	  (when name
	    (setf (gethash name metrics) char-metrics)))))))

(define-afm-section (afm-char-kernings "CharKernPairs")(stream characters kernings)
  (flet ((register-kern-pair (name1 name2 dx dy)
	   (let* ((char1 (gethash name1 characters))
		  (char2 (when char1 (gethash name2 characters))))
	     (when char2
	       (setf (gethash (cons char1 char2) kernings) (cons (* 0.001 dx) (* 0.001 dy)))))))
    (process-keywords
     (key "EndKernPairs" () (return-from afm-char-kernings))
     (t (process-keywords-in-line
	 (key "KP" ((name1 name)(name2 name)(dx number)(dy number))
	      (register-kern-pair name1 name2 dx dy))
	 (key "KPX" ((name1 name)(name2 name)(dx number))
	      (register-kern-pair name1 name2 dx 0)))))))

(defun read-afm-file (filename &optional (font-metrics-class 'font-metrics))
  (with-open-file (s filename :direction :input :external-format +external-format+)
    (afm-font-metrics s font-metrics-class)))

(defun read-ufm-file (filename &optional (font-metrics-class 'ttu-font-metrics))
  (let ((min-code #xfffe)
        (max-code 0)
        void-char encoding-vector pdf-widths font-metrics)
    (with-open-file (s filename :direction :input :external-format +external-format+)
      (setf font-metrics (afm-font-metrics s font-metrics-class)))
    (setf void-char (gethash "VoidCharacter" (characters font-metrics)))
    (iter (for (nil char-metrics) in-hashtable (characters font-metrics))
          (for gid = (index char-metrics))
          (for code = (code char-metrics))
          (when (and (<= 0 code #xfffe))
            (when (> code max-code) (setf max-code code))
            (when (< code min-code) (setf min-code code))
            (setf (aref (c2g font-metrics) (* 2 code))
		  (code-char (ldb (byte 8 8) gid))
		  (aref (c2g font-metrics) (+ (* 2 code) 1))
		  (code-char (ldb (byte 8 0) gid)))
	    (vector-push-extend code (cid-widths font-metrics))
	    (vector-push-extend (vector (round (* 1000 (width char-metrics)))) (cid-widths font-metrics))))
    (setf encoding-vector (make-array (1+ max-code) :initial-element void-char)
          pdf-widths (make-array (1+ max-code) :initial-element 0))
    (iter (for (nil char-metrics) in-hashtable (characters font-metrics))
          (for code = (code char-metrics))
          (when (<= min-code code max-code)
            (setf (aref encoding-vector code) char-metrics
                  (aref pdf-widths code) (round (* 1000 (width char-metrics))))))
    (setf (min-code font-metrics) min-code
          (max-code font-metrics) max-code
          (encoding-vector font-metrics) encoding-vector
          (pdf-widths font-metrics) pdf-widths
          (encoding-scheme font-metrics) :unicode-encoding
          (gethash (string-downcase (font-name font-metrics)) *font-metrics*) font-metrics
          (leading font-metrics) (- 1 (descender font-metrics))
          (italic-sin font-metrics) (sin (/ (* pi (italic-angle font-metrics)) -180)))
    font-metrics))

(defmethod font-type (font-metrics)
  (declare (ignore font-metrics))
  "Type1")

(defmethod font-descriptor (font-metrics &key (errorp nil) &allow-other-keys)
  (declare (ignore font-metrics))
  (if errorp
      (error "Generic fonts do not have descriptors.")
      nil))

(defmethod make-dictionary ((fm font-metrics)
                            &key font (encoding (encoding font)) (embed *embed-fonts*)
                            &allow-other-keys)
  (let ((font-descriptor (font-descriptor fm :embed embed :errorp nil)))
    (make-instance 'dictionary :dict-values
      `(("/Type" . "/Font")
        ("/Subtype" . ,(add-/ (font-type fm)))
        ("/BaseFont" . ,(add-/ (font-name fm)))
        ("/Encoding" . ,(if (standard-encoding encoding)
                            (add-/ (name encoding))
                            (find-encoding-object encoding)))
        ,@(when font-descriptor
            `(("/FirstChar" . 0)
              ("/LastChar" . 255)
              ("/Widths" . ,(pdf-widths font))
              ("/FontDescriptor" . ,font-descriptor))) )) ))


(defun extract-font-metrics-encoding (font-metrics)
 ;; Make extract-font-metrics-encoding generic?
  (let ((encoding (or (get-encoding (encoding-scheme font-metrics))
		      (get-encoding (font-name font-metrics)))))
    (if encoding
	encoding
	(make-instance 'single-byte-encoding :name (font-name font-metrics)
		       :standard-encoding nil
		       :char-names (map 'vector #'(lambda (char)
						    (and char (name char)))
					(encoding-vector font-metrics))))))