-
Notifications
You must be signed in to change notification settings - Fork 2
/
pjb-font.el
344 lines (310 loc) · 13.6 KB
/
pjb-font.el
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
;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: pjb-font.el
;;;;LANGUAGE: emacs lisp
;;;;SYSTEM: POSIX
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Font stuff.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal Bourguignon <[email protected]>
;;;;MODIFICATIONS
;;;; 2006-11-15 <PJB> Created. Extracted code from ~/.emacs.
;;;;BUGS
;;;;LEGAL
;;;; GPL
;;;;
;;;; Copyright Pascal Bourguignon 2006 - 2011
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version
;;;; 2 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be
;;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;; PURPOSE. See the GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public
;;;; License along with this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;**************************************************************************
(require 'cl)
(require 'devices nil t)
(require 'font nil t)
(require 'pjb-list)
(defun font-exists-p (pattern)
(unless (eq window-system 'x)
(error "font-exists-p works only on X"))
(zerop
(nth-value 0 (cl:parse-integer
(shell-command-to-string
(format "xlsfonts -fn %S 2>&1|awk 'BEGIN{r=0;} /xlsfonts: pattern .* unmatched/{r=1;} END{printf \"%%d\",r;}'"
pattern))))))
(defun font-canonical-to-pixel (canon &optional device)
(let ((pix-width (float (or (cond ((fboundp 'device-pixel-width)
(device-pixel-width device))
((fboundp 'display-pixel-width)
(display-pixel-width) device)
(t nil))
1024)))
(mm-width (float (or (cond ((fboundp 'device-mm-width)
(device-mm-width device))
((fboundp 'display-mm-width)
(display-mm-width) device)
(t nil))
293))))
(/ canon (/ pix-width mm-width) (/ 25.4 72.0))))
(defun get-font-size-in-pixel (font &optional device)
"
RETURN: The font height in pixel.
"
(cond ((and (fboundp 'font-size)
(fboundp 'font-create-object)
(fboundp 'font-spatial-to-canonical))
(let ((fs (font-size (font-create-object font))))
(if (numberp fs)
fs
(font-canonical-to-pixel
(font-spatial-to-canonical fs device) device))))
(t (error "How do I compute the font size in pixel for font %S?" font))))
(defun create-new-fontset (fontset-spec &optional style-variant noerror)
(handler-case
(create-fontset-from-fontset-spec fontset-spec style-variant noerror)
(error ())))
(defun split-font-pattern (pattern)
"Splits a X font pattern into a plist."
(let ((parts (split-string pattern "-"))
(plist nil))
;; (unless (and (elt parts 7) (string-match "^[0-9]" (elt parts 7)))
;; (message ".EMACS: font=%S\nparts=%S\n" pattern parts))
(loop
for item in (cdr parts)
for key in '(:foundry
:family :weight :slant :width :style
:pixel-size :point-size :resolution-x :resolution-y
:spacing :average-width :registry :encoding)
collect key
collect item)))
(defun* make-font-pattern (&key foundry family weight slant width
style pixel-size point-size
resolution-x resolution-y spacing
average-width registry encoding
(defaults "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))
"Builds a X font pattern from the keyword arguments
DEFAULTS: either a X font pattern (string) or a plist used as default
when the corresponding keyword is not given.
EXAMPLE: Changing the size of a font:
(make-font-pattern
:defaults \"-lispm-fixed-medium-r-normal-*-13-*-*-*-*-*\"
:pixel-size 12)"
(when (stringp defaults)
(setf defaults (split-font-pattern defaults)))
(macrolet ((field (name)
`(or ,name (getf defaults ,(intern (format ":%s" name))) "*")))
(format "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s"
(field foundry) (field family) (field weight) (field slant)
(field width) (field style) (field pixel-size) (field point-size)
(field resolution-x) (field resolution-y) (field spacing)
(field average-width) (field registry) (field encoding))))
(defun* get-font-parts (pattern &key foundry family weight slant width
style pixel-size point-size
resolution-x resolution-y spacing
average-width registry encoding)
"
RETURN: A list of unique property lists containing the selected keys
with all unique tuples in the fonts selected by the pattern.
"
(let ((parts nil)
(plist)
(res nil))
(dolist (font (split-string
(shell-command-to-string
(format "xlsfonts -fn '%s'|sort -u" pattern)) "\n"))
(pushnew (split-font-pattern font) res :test (function equalp)))
res))
(defun get-independant-font-parts (pattern &key foundry family weight
slant width style
pixel-size point-size
resolution-x resolution-y
spacing average-width
registry encoding
registry-encoding)
"
RETURN: An a-list with entries for the selected keywords,
each being the list of unique values for the corresponding
field in all fonts selected by the pattern.
EXAMPLE: All families in the Adobe foundry:
(get-independant-font-parts (make-font-pattern :foundry \"adobe\")
:family t)
"
(let ((p-foundry nil) (p-family nil)
(p-weight nil) (p-slant nil)
(p-width nil) (p-style nil)
(p-pixel-size nil) (p-point-size nil)
(p-resolution-x nil) (p-resolution-y nil)
(p-spacing nil) (p-average-width nil)
(p-registry nil) (p-encoding nil)
(p-registry-encoding nil)
(parts nil)
(res nil)
(test (function string-equal)))
(dolist (font (split-string
(shell-command-to-string
(format "xlsfonts -fn '%s'|sort -u" pattern)) "\n"))
(setf parts (split-string font "-"))
(when foundry
(pushnew (elt parts 1) p-foundry :test test))
(when family
(pushnew (elt parts 2) p-family :test test))
(when weight
(pushnew (elt parts 3) p-weight :test test))
(when slant
(pushnew (elt parts 4) p-slant :test test))
(when width
(pushnew (elt parts 5) p-width :test test))
(when style
(pushnew (elt parts 6) p-style :test test))
(when pixel-size
(pushnew (elt parts 7) p-pixel-size :test test))
(when point-size
(pushnew (elt parts 8) p-point-size :test test))
(when resolution-x
(pushnew (elt parts 9) p-resolution-x :test test))
(when resolution-y
(pushnew (elt parts 10) p-resolution-y :test test))
(when spacing
(pushnew (elt parts 11) p-spacing :test test))
(when average-width
(pushnew (elt parts 12) p-average-width :test test))
(when registry
(pushnew (elt parts 13) p-registry :test test))
(when encoding
(pushnew (elt parts 14) p-encoding :test test))
(when registry-encoding
(pushnew (format "%s-%s" (elt parts 13) (elt parts 14))
p-registry-encoding :test test)))
(when registry-encoding
(push (cons :registry-encoding p-registry-encoding ) res))
(when encoding (push (cons :encoding p-encoding ) res))
(when registry (push (cons :registry p-registry ) res))
(when average-width (push (cons :average-width p-average-width) res))
(when spacing (push (cons :spacing p-spacing ) res))
(when resolution-y (push (cons :resolution-y p-resolution-y ) res))
(when resolution-x (push (cons :resolution-x p-resolution-x ) res))
(when point-size (push (cons :point-size p-point-size ) res))
(when pixel-size (push (cons :pixel-size p-pixel-size ) res))
(when style (push (cons :style p-style ) res))
(when width (push (cons :width p-width ) res))
(when slant (push (cons :slant p-slant ) res))
(when weight (push (cons :weight p-weight ) res))
(when family (push (cons :family p-family ) res))
(when foundry (push (cons :foundry p-foundry ) res))
res))
(defmacro make-my-mac-font-sets (size)
`(progn
(create-new-fontset
,(format "-*-courier-*-*-*-*-%d-*-*-*-*-*-fontset-courier,
ascii:-*-courier-*-*-*-*-%d-*-*-*-*-*-*,
latin-iso8859-1:-*-courier-*-*-*-*-%d-*-*-*-*-*-*"
size size size))
(create-new-fontset
,(format "-apple-monaco-%s--%d-*-*-*-*-*-fontset-monaco,
ascii:-apple-monaco-%s--%d-%d0-75-75-m-%d0-mac-roman,
latin-iso8859-1:-apple-monaco-%s--%d-%d0-75-75-m-%d0-mac-roman"
"medium-r-normal" size
"medium-r-normal" size size size
"medium-r-normal" size size size))))
;; ---------------------------
;; select-font
;; ---------------------------
(defstruct ftree label children)
(defun build-font-tree (fps &optional label)
"
FPS: A property list of font pattern fields (in order).
RETURN: A tree where the child of each node are labelled with
the corresponding pattern field.
"
(when fps
(setf label (or label "root"))
(if (car fps)
(let ((classes (equivalence-classes
fps (lambda (a b) (equalp (second a) (second b))))))
(make-ftree :label label
:children (mapcar (lambda (class)
(build-font-tree
(mapcar (function cddr) class)
(second (first class))))
classes)))
(make-ftree :label label))))
(defun ftree-children-named (font-tree name)
(car (delete-if (lambda (child) (not (string-equal name (ftree-label child))))
(ftree-children font-tree))))
(defparameter *font-default-fields*
'(:spacing "m" :registry "iso8859"))
(defparameter *font-tree*
(when (eq window-system 'x)
(build-font-tree
(delete-if (lambda (fp)
(let* ((ssize (plist-get fp :pixel-size))
(size (when (and ssize (not (string-equal "*" ssize)))
(nth-value 0 (cl:parse-integer ssize)))))
(or (null size) (< size 8))))
(get-font-parts
(apply (function make-font-pattern) *font-default-fields*)
:family t :weight t :slant t :pixel-size t)))))
(defvar *font-current-node* nil)
(defvar *font-family-history* nil)
(defvar *font-weight-history* nil)
(defvar *font-slant-history* nil)
(defvar *font-pixel-size-history* nil)
(defun select-font (family weight slant pixel-size)
(interactive
(list
(completing-read
"Family: "
(mapcar (lambda (child) (cons (ftree-label child) child))
(ftree-children *font-tree*))
(lambda (item) (setq *font-current-node* (cdr item))) t nil
'*font-family-history*)
(completing-read
"Weight: "
(mapcar (lambda (child) (cons (ftree-label child) child))
(ftree-children *font-current-node*))
(lambda (item) (setq *font-current-node* (cdr item))) t nil
'*font-weight-history*)
(completing-read
"Slant: "
(mapcar (lambda (child) (cons (ftree-label child) child))
(ftree-children *font-current-node*))
(lambda (item) (setq *font-current-node* (cdr item))) t nil
'*font-slant-history*)
(completing-read
"Pixel-Size: "
(mapcar (lambda (child) (cons (ftree-label child) child))
(ftree-children *font-current-node*))
(lambda (item) (setq *font-current-node* (cdr item))) t nil
'*font-pixel-size-history*)))
(set-frame-font (make-font-pattern :family family :weight weight
:slant slant :pixel-size pixel-size
:spacing "m"))
(when (fboundp 'single-frame) (single-frame)))
(defvar *default-font* "fixed")
(defun select-default-font ()
(interactive)
(set-frame-font *default-font*)
(when (fboundp 'single-frame) (single-frame)))
(defun pjb-font-init ()
(cond
((eq window-system 'mac)
(make-my-mac-font-sets 9)
(make-my-mac-font-sets 10)
(make-my-mac-font-sets 12)
(make-my-mac-font-sets 14))
((eq window-system 'x)
(select-default-font))))
(provide 'pjb-font)