Mercurial > hg > xemacs-beta

comparison lisp/x-faces.el @ 3354:15fb91e3a115

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2006-04-23 16:11:16 by stephent] Xft/fontconfig refactoring, Part I. <87hd4ks29d.fsf@tleepslib.sk.tsukuba.ac.jp>
author stephent
date Sun, 23 Apr 2006 16:11:34 +0000
parents d97bc868eaaf
children 316fddbf58e2
comparison
equal deleted inserted replaced
3353:521d94807505 3354:15fb91e3a115
64 64
65 (globally-declare-fboundp 65 (globally-declare-fboundp
66 '(x-get-resource-and-maybe-bogosity-check 66 '(x-get-resource-and-maybe-bogosity-check
67 x-get-resource x-init-pointer-shape)) 67 x-get-resource x-init-pointer-shape))
68 68
69 (require 'fontconfig) 69 (if (featurep 'xft-fonts)
70 (require 'fontconfig)
71 (globally-declare-boundp
72 '(fc-font-name-weight-bold fc-font-name-weight-black
73 fc-font-name-weight-demibold fc-font-name-weight-medium
74 fc-font-name-slant-oblique fc-font-name-slant-italic
75 fc-font-name-slant-roman))
76 (globally-declare-fboundp
77 '(fc-font-real-pattern fc-pattern-get-size fc-copy-pattern-partial
78 fc-pattern-del-weight fc-pattern-del-style fc-pattern-duplicate
79 fc-pattern-add-weight fc-try-font fc-pattern-add-size
80 fc-name-unparse fc-pattern-del-slant fc-pattern-add-slant
81 fc-pattern-del-size fc-pattern-get-pixelsize)))
70 82
71 (defconst x-font-regexp nil) 83 (defconst x-font-regexp nil)
72 (defconst x-font-regexp-head nil) 84 (defconst x-font-regexp-head nil)
73 (defconst x-font-regexp-head-2 nil) 85 (defconst x-font-regexp-head-2 nil)
74 (defconst x-font-regexp-weight nil) 86 (defconst x-font-regexp-weight nil)
184 (defun x-make-font-bold-xft (font &optional device) 196 (defun x-make-font-bold-xft (font &optional device)
185 (let ((pattern (fc-font-real-pattern 197 (let ((pattern (fc-font-real-pattern
186 font (or device (default-x-device))))) 198 font (or device (default-x-device)))))
187 (if pattern 199 (if pattern
188 (let ((size (fc-pattern-get-size pattern 0)) 200 (let ((size (fc-pattern-get-size pattern 0))
189 (copy (fc-copy-pattern-partial 201 (copy (fc-copy-pattern-partial pattern (list "family"))))
190 pattern (list fc-font-name-property-family)))) 202 (fc-pattern-del-weight copy)
191 (fc-pattern-del copy fc-font-name-property-weight) 203 (fc-pattern-del-style copy)
192 (fc-pattern-del copy fc-font-name-property-style)
193 (when copy 204 (when copy
194 (or 205 (or
195 ;; try bold font 206 ;; try bold font
196 (let ((copy-2 (fc-pattern-duplicate copy))) 207 (let ((copy-2 (fc-pattern-duplicate copy)))
197 (fc-pattern-add copy-2 fc-font-name-property-weight 208 (fc-pattern-add-weight copy-2 fc-font-name-weight-bold)
198 fc-font-name-weight-bold)
199 (when (fc-try-font copy-2 device) 209 (when (fc-try-font copy-2 device)
200 (fc-pattern-add copy-2 fc-font-name-property-size size) 210 (fc-pattern-add-size copy-2 size)
201 (fc-name-unparse copy-2))) 211 (fc-name-unparse copy-2)))
202 ;; try black font 212 ;; try black font
203 (let ((copy-2 (fc-pattern-duplicate copy))) 213 (let ((copy-2 (fc-pattern-duplicate copy)))
204 (fc-pattern-add copy-2 fc-font-name-property-weight 214 (fc-pattern-add-weight copy-2 fc-font-name-weight-black)
205 fc-font-name-weight-black)
206 (when (fc-try-font copy-2 device) 215 (when (fc-try-font copy-2 device)
207 (fc-pattern-add copy-2 fc-font-name-property-size size) 216 (fc-pattern-add-size copy-2 size)
208 (fc-name-unparse copy-2))) 217 (fc-name-unparse copy-2)))
209 ;; try demibold font 218 ;; try demibold font
210 (let ((copy-2 (fc-pattern-duplicate copy))) 219 (let ((copy-2 (fc-pattern-duplicate copy)))
211 (fc-pattern-add copy-2 fc-font-name-property-weight 220 (fc-pattern-add-weight copy-2 fc-font-name-weight-demibold)
212 fc-font-name-weight-demibold)
213 (when (fc-try-font copy-2 device) 221 (when (fc-try-font copy-2 device)
214 (fc-pattern-add copy-2 fc-font-name-property-size size) 222 (fc-pattern-add-size copy-2 size)
215 (fc-name-unparse copy-2))))))))) 223 (fc-name-unparse copy-2)))))))))
216 224
217 (defun x-make-font-bold-core (font &optional device) 225 (defun x-make-font-bold-core (font &optional device)
218 ;; Certain Type1 fonts know "bold" as "black"... 226 ;; Certain Type1 fonts know "bold" as "black"...
219 (or (try-font-name (x-frob-font-weight font "bold") device) 227 (or (try-font-name (x-frob-font-weight font "bold") device)
231 239
232 (defun x-make-font-unbold-xft (font &optional device) 240 (defun x-make-font-unbold-xft (font &optional device)
233 (let ((pattern (fc-font-real-pattern 241 (let ((pattern (fc-font-real-pattern
234 font (or device (default-x-device))))) 242 font (or device (default-x-device)))))
235 (when pattern 243 (when pattern
236 (fc-pattern-del pattern fc-font-name-property-weight) 244 (fc-pattern-del-weight pattern)
237 (fc-pattern-add pattern fc-font-name-property-weight 245 (fc-pattern-add-weight pattern fc-font-name-weight-medium)
238 fc-font-name-weight-medium)
239 (if (fc-try-font pattern device) 246 (if (fc-try-font pattern device)
240 (fc-name-unparse pattern))))) 247 (fc-name-unparse pattern)))))
241 248
242 (defun x-make-font-unbold-core (font &optional device) 249 (defun x-make-font-unbold-core (font &optional device)
243 (try-font-name (x-frob-font-weight font "medium") device)) 250 (try-font-name (x-frob-font-weight font "medium") device))
263 (defun x-make-font-italic-xft (font &optional device) 270 (defun x-make-font-italic-xft (font &optional device)
264 (let ((pattern (fc-font-real-pattern 271 (let ((pattern (fc-font-real-pattern
265 font (or device (default-x-device))))) 272 font (or device (default-x-device)))))
266 (if pattern 273 (if pattern
267 (let ((size (fc-pattern-get-size pattern 0)) 274 (let ((size (fc-pattern-get-size pattern 0))
268 (copy (fc-copy-pattern-partial 275 (copy (fc-copy-pattern-partial pattern (list "family"))))
269 pattern (list fc-font-name-property-family))))
270 (when copy 276 (when copy
271 (fc-pattern-del copy fc-font-name-property-slant) 277 (fc-pattern-del-slant copy)
272 (fc-pattern-del copy fc-font-name-property-style) 278 (fc-pattern-del-style copy)
279 ;; #### can't we do this with one ambiguous pattern?
273 (let ((pattern-oblique (fc-pattern-duplicate copy)) 280 (let ((pattern-oblique (fc-pattern-duplicate copy))
274 (pattern-italic (fc-pattern-duplicate copy))) 281 (pattern-italic (fc-pattern-duplicate copy)))
275 (fc-pattern-add pattern-oblique fc-font-name-property-slant 282 (fc-pattern-add-slant pattern-oblique fc-font-name-slant-oblique)
276 fc-font-name-slant-oblique) 283 (fc-pattern-add-slant pattern-italic fc-font-name-slant-italic)
277 (fc-pattern-add pattern-italic fc-font-name-property-slant
278 fc-font-name-slant-italic)
279 (let ((have-oblique (fc-try-font pattern-oblique device)) 284 (let ((have-oblique (fc-try-font pattern-oblique device))
280 (have-italic (fc-try-font pattern-italic device))) 285 (have-italic (fc-try-font pattern-italic device)))
281 (if try-oblique-before-italic-fonts 286 (if try-oblique-before-italic-fonts
282 (if have-oblique 287 (if have-oblique
283 (progn 288 (progn
284 (if size 289 (if size
285 (fc-pattern-add pattern-oblique fc-font-name-property-size size)) 290 (fc-pattern-add-size pattern-oblique size))
286 (fc-name-unparse pattern-oblique)) 291 (fc-name-unparse pattern-oblique))
287 (if have-italic 292 (if have-italic
288 (progn 293 (progn
289 (if size 294 (if size
290 (fc-pattern-add pattern-italic fc-font-name-property-size size)) 295 (fc-pattern-add-size pattern-italic size))
291 (fc-name-unparse pattern-italic)))) 296 (fc-name-unparse pattern-italic))))
292 (if have-italic 297 (if have-italic
293 (progn 298 (progn
294 (if size 299 (if size
295 (fc-pattern-add pattern-italic fc-font-name-property-size size)) 300 (fc-pattern-add-size pattern-italic size))
296 (fc-name-unparse pattern-italic)) 301 (fc-name-unparse pattern-italic))
297 (if have-oblique 302 (if have-oblique
298 (progn 303 (progn
299 (if size 304 (if size
300 (fc-pattern-add pattern-oblique fc-font-name-property-size size)) 305 (fc-pattern-add-size pattern-oblique size))
301 (fc-name-unparse pattern-oblique)))))))))))) 306 (fc-name-unparse pattern-oblique))))))))))))
302 307
303 (defun x-make-font-italic-core (font &optional device) 308 (defun x-make-font-italic-core (font &optional device)
304 (if try-oblique-before-italic-fonts 309 (if try-oblique-before-italic-fonts
305 (or (try-font-name (x-frob-font-slant font "o") device) 310 (or (try-font-name (x-frob-font-slant font "o") device)
318 323
319 (defun x-make-font-unitalic-xft (font &optional device) 324 (defun x-make-font-unitalic-xft (font &optional device)
320 (let ((pattern (fc-font-real-pattern 325 (let ((pattern (fc-font-real-pattern
321 font (or device (default-x-device))))) 326 font (or device (default-x-device)))))
322 (when pattern 327 (when pattern
323 (fc-pattern-del pattern fc-font-name-property-slant) 328 (fc-pattern-del-slant pattern)
324 (fc-pattern-add pattern fc-font-name-property-slant 329 (fc-pattern-add-slant pattern fc-font-name-slant-roman)
325 fc-font-name-slant-roman)
326 (if (fc-try-font pattern device) 330 (if (fc-try-font pattern device)
327 (fc-name-unparse pattern))))) 331 (fc-name-unparse pattern)))))
328 332
329 (defun x-make-font-unitalic-core (font &optional device) 333 (defun x-make-font-unitalic-core (font &optional device)
330 (try-font-name (x-frob-font-slant font "r") device)) 334 (try-font-name (x-frob-font-slant font "r") device))
521 font (or device (default-x-device))))) 525 font (or device (default-x-device)))))
522 (when pattern 526 (when pattern
523 (let ((size (fc-pattern-get-size pattern 0))) 527 (let ((size (fc-pattern-get-size pattern 0)))
524 (if (floatp size) 528 (if (floatp size)
525 (let ((copy (fc-pattern-duplicate pattern))) 529 (let ((copy (fc-pattern-duplicate pattern)))
526 (fc-pattern-del copy fc-font-name-property-size) 530 (fc-pattern-del-size copy)
527 (fc-pattern-add copy fc-font-name-property-size 531 (fc-pattern-add-size copy (funcall new-size-proc size))
528 (funcall new-size-proc size))
529 (if (fc-try-font font device) 532 (if (fc-try-font font device)
530 (fc-name-unparse copy)))))))) 533 (fc-name-unparse copy))))))))
531 534
532 (defun x-find-smaller-font-xft (font &optional device) 535 (defun x-find-smaller-font-xft (font &optional device)
533 (x-find-xft-font-of-size font '(lambda (old-size) (- old-size 1.0)) device)) 536 (x-find-xft-font-of-size font '(lambda (old-size) (- old-size 1.0)) device))