File: font.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 (180 lines) | stat: -rw-r--r-- 7,399 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
;;; 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)

(defvar *font* nil
  "The current font in text mode")

(defvar *font-size* nil
  "The current font in text mode")

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

(defgeneric font-descriptor (font-metrics &key embed errorp))

(defclass font ()
 ((name :accessor name :initform "helvetica" :initarg :name)
  (encoding :accessor encoding :initform *standard-encoding*)
  (hyphen-code :accessor hyphen-code :initform 0)
  (hyphen-char :accessor hyphen-char :initform nil)
  (font-metrics :accessor font-metrics)
  (kernings :accessor kernings :initform (make-hash-table))
  (characters :accessor characters :initform (make-array 256 :initial-element nil))
  (pdf-widths :accessor pdf-widths :initform (make-array 256 :initial-element 0))))

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

(defmethod initialize-instance :after ((font font) &key encoding &allow-other-keys)
  (let ((font-metrics (gethash (name font) *font-metrics*)))
    (unless font-metrics (error "Font ~s not found" (name font)))
    (setf (font-metrics font) font-metrics)
    (unless encoding
      (setf (gethash (list (name font) nil) *font-cache*) font))
    (setf (encoding font)
	  (if encoding
	      (get-encoding encoding)
	      (extract-font-metrics-encoding font-metrics)))
    (if (eql (keyword-name (encoding font)) :unicode-encoding)
        (setf (pdf-widths font) (pdf-widths font-metrics)
              (characters font) (encoding-vector font-metrics)
              (hyphen-code font) (if (gethash "hyphen" (characters font-metrics))
                                     (code (gethash "hyphen" (characters font-metrics))) 
                                     0)
              (hyphen-char font) (code-char (hyphen-code font)))
        (loop with font-characters = (characters font-metrics)
           with pdf-widths = (pdf-widths font)
           with void-char = (gethash "VoidCharacter" font-characters)
           and characters = (characters font)
           and hyphen-code = nil
           for i from 0 to 255
           for char-name across (char-names (encoding font))
           for char = (or (gethash char-name font-characters)
                          (aref (encoding-vector font-metrics) i)
                          void-char)
           do (setf (aref characters i) char
                    (aref pdf-widths i) (round (* 1000 (width char))))
             (when (and (not hyphen-code) (string= char-name "hyphen"))
               (setf hyphen-code i
                     (hyphen-code font) i
                     (hyphen-char font) (code-char i)))))
    (compute-kern-pairs font)
    (setf (gethash (list (name font) (encoding font)) *font-cache*) font)))

(defun compute-kern-pairs (font)
  (let ((char-to-code (make-hash-table))
	(characters (characters font))
	(kernings (kernings font)))
    (loop for c across characters
	  for code from 0
	  when c do (setf (gethash c char-to-code) code))
    (maphash #'(lambda (k v)
		 (let ((code1 (gethash (car k) char-to-code))
		       (code2 (gethash (cdr k) char-to-code)))
		   (when (and code1 code2)
		     (setf (gethash (+ (* code1 65536) code2) kernings) (car v)))))
	     (kernings (font-metrics font)))))


(defgeneric get-char-metrics (char-or-code font encoding)
 ;;; This generic allows to customize treating charset by the lisp implementation
  ;; and is intended to replace get-char.
  ;; Args: char-or-code  Lisp character or its char-code
 (:method (char-or-code font encoding)
   (declare (ignore encoding))
  (aref (characters font)
        (if (characterp char-or-code) (char-code char-or-code) char-or-code))))

(defmethod get-char-metrics (char font (encoding single-byte-encoding))
  (aref (characters font)
        (if #+lispworks (lw:base-char-p char) 
            #+(or allegro sbcl) (standard-char-p char)
            #-(or lispworks allegro sbcl) t
            (char-code char)
            (char-external-code char (charset encoding)))))

(defmethod get-char-metrics ((code integer) font (encoding single-byte-encoding))
  (let ((char (code-char code)))
  (aref (characters font)
        (if #+lispworks (lw:base-char-p char) 
              #+(or allegro sbcl) (standard-char-p char)
              #-(or lispworks allegro sbcl) t
            code
              (char-external-code char (charset encoding))))))

#+unused
(defun get-char (code font)
  (aref (characters font) code))

#+unused
(defmacro force-char-code (char-or-code)
  (let ((char (gensym "char")))
    `(let ((,char ,char-or-code))
      (if (characterp ,char) (char-code ,char) ,char))))
 
(defun get-char-width (char-or-code font &optional font-size)
  (let ((char-metrics (get-char-metrics char-or-code font (encoding font))))
    (if font-size (* (width char-metrics) font-size) (width char-metrics))))

(defun get-char-size (char-or-code font &optional font-size)
  (let* ((char-metrics (get-char-metrics char-or-code font (encoding font)))
	 (width (width char-metrics))
	 (bbox (bbox char-metrics))
	 (ascender (aref bbox 3))
	 (descender (aref bbox 1)))
    (if font-size
	(values (* width font-size)(* ascender font-size)(* descender font-size))
	(values width ascender descender))))

(defun get-char-italic-correction (char-or-code font &optional font-size)
  (let* ((char-metrics (get-char-metrics char-or-code font (encoding font)))
	 (left (left-italic-correction char-metrics))
	 (right (right-italic-correction char-metrics)))
    (if font-size
	(values (* left font-size)(* right font-size))
	(values left right))))

(defun get-font-italic-correction (font &optional font-size)
  (let* ((italic-sin (italic-sin (font-metrics font)))
	 (left (* italic-sin (ascender (font-metrics font))))
	 (right (* italic-sin (descender (font-metrics font)))))
    (if font-size
	(values (* left font-size)(* right font-size))
	(values left right))))

(defun get-kerning (char1 char2 font &optional font-size)
  (let* ((encoding (encoding font))
         (char-metrics1 (get-char-metrics char1 font encoding))
         (char-metrics2 (get-char-metrics char2 font encoding))
         (kerning (gethash (+ (ash (code char-metrics1) 16) (code char-metrics2))
                           (kernings font)
                           0)))
    (if font-size (* font-size kerning) kerning)))

(defun get-font (&optional (name "helvetica") (encoding *default-encoding*))
  (setf name (string-downcase name))
  (let ((font-metrics (gethash name *font-metrics*)))
    (when (typep font-metrics 'ttu-font-metrics)
      (setf encoding *unicode-encoding*)))
  (let ((font (gethash (list name (get-encoding encoding)) *font-cache*)))
    (if font
	font
	(make-instance 'font :name name :encoding encoding))))

(defun clear-font-cache ()
  (clrhash *font-cache*))

(defvar %fonts-loaded% nil)

(defun load-fonts (&optional force)
  (when (or (not %fonts-loaded%) force)
    (dolist (font-dir *afm-files-directories*)
      (map nil 'read-afm-file (directory (merge-pathnames font-dir "*.afm"))))
    (clear-font-cache)
    (setf %fonts-loaded% t)))

(eval-when (:load-toplevel :execute)
  (load-fonts))