Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 9ee227acff29
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
1 ;;; font.el,v --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/05/29 15:44:56 3 ;; Created: 1996/08/11 16:40:36
4 ;; Version: 1.45 4 ;; Version: 1.8
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995 by William M. Perry (wmperry@spry.com) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; 9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply. 10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;; 11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by 13 ;;; it under the terms of the GNU General Public License as published by
26 26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; The emacsen compatibility package - load it up before anything else 28 ;;; The emacsen compatibility package - load it up before anything else
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (eval-and-compile 30 (eval-and-compile
31 (load-library "w3-sysdp")) 31 (load-library "w3-sysdp")
32 32 (require 'cl))
33
34 (require 'disp-table)
33 (if (not (fboundp '<<)) (fset '<< 'lsh)) 35 (if (not (fboundp '<<)) (fset '<< 'lsh))
34 (if (not (fboundp '&)) (fset '& 'logand)) 36 (if (not (fboundp '&)) (fset '& 'logand))
35 (if (not (fboundp '|)) (fset '| 'logior)) 37 (if (not (fboundp '|)) (fset '| 'logior))
36 (if (not (fboundp '~)) (fset '~ 'lognot)) 38 (if (not (fboundp '~)) (fset '~ 'lognot))
37 (if (not (fboundp '>>)) (defun >> (value count) (<< value (- count)))) 39 (if (not (fboundp '>>)) (defun >> (value count) (<< value (- count))))
90 (defvar font-maximum-slippage "1pt" 92 (defvar font-maximum-slippage "1pt"
91 "How much a font is allowed to vary from the desired size.") 93 "How much a font is allowed to vary from the desired size.")
92 94
93 (defvar font-family-mappings 95 (defvar font-family-mappings
94 '( 96 '(
95 ("serif" . ("garamond" 97 ("serif" . ("new century schoolbook"
98 "utopia"
99 "charter"
100 "times"
101 "lucidabright"
102 "garamond"
96 "palatino" 103 "palatino"
97 "times new roman" 104 "times new roman"
98 "baskerville" 105 "baskerville"
99 "bookman" 106 "bookman"
100 "bodoni" 107 "bodoni"
101 "computer modern" 108 "computer modern"
102 "rockwell" 109 "rockwell"
103 )) 110 ))
104 ("sans-serif" . ("lucida" 111 ("sans-serif" . ("lucida"
105 "lucidatypewriter" 112 "helvetica"
106 "gills-sans" 113 "gills-sans"
107 "avant-garde" 114 "avant-garde"
108 "univers" 115 "univers"
109 "helvetica"
110 "optima")) 116 "optima"))
111 ("elfin" . ("tymes")) 117 ("elfin" . ("tymes"))
112 ("monospace" . ("courier" "lucidatypewriter" "fixed")) 118 ("monospace" . ("courier"
113 ("cursive" . ("sirene" "zapf chancery")) 119 "fixed"
120 "lucidatypewriter"
121 "clean"
122 "terminal"))
123 ("cursive" . ("sirene"
124 "zapf chancery"))
114 ) 125 )
115 "A list of font family mappings.") 126 "A list of font family mappings.")
116 127
117 (defkeyword :family "Keyword specifying the font family of a FONTOBJ.") 128 (defkeyword :family "Keyword specifying the font family of a FONTOBJ.")
118 129
226 ;; If for any reason we get null for any of this, default 237 ;; If for any reason we get null for any of this, default
227 ;; to 1024x768 resolution on a 17" screen 238 ;; to 1024x768 resolution on a 17" screen
228 (pix-width (float (or (device-pixel-width device) 1024))) 239 (pix-width (float (or (device-pixel-width device) 1024)))
229 (mm-width (float (or (device-mm-width device) 293))) 240 (mm-width (float (or (device-mm-width device) 293)))
230 (retval nil)) 241 (retval nil))
231 (if (string-match "[^0-9.]+$" spec) 242 (cond
232 (setq type (substring spec (match-beginning 0)) 243 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
233 spec (substring spec 0 (match-beginning 0))) 244 (let ((math-func (intern (match-string 1 spec)))
245 (other (font-spatial-to-canonical
246 (substring spec (match-end 0) nil)))
247 (default (font-spatial-to-canonical
248 (font-default-size-for-device device))))
249 (if (fboundp math-func)
250 (setq type "px"
251 spec (int-to-string (funcall math-func default other)))
252 (setq type "px"
253 spec (int-to-string other)))))
254 ((string-match "[^0-9.]+$" spec)
255 (setq type (substring spec (match-beginning 0))
256 spec (substring spec 0 (match-beginning 0))))
257 (t
234 (setq type "px" 258 (setq type "px"
235 spec spec)) 259 spec spec)))
236 (setq num (string-to-number spec)) 260 (setq num (string-to-number spec))
237 (cond 261 (cond
238 ((member type '("pixel" "px" "pix")) 262 ((member type '("pixel" "px" "pix"))
239 (setq retval num 263 (setq retval num
240 num nil)) 264 num nil))
484 (defvar font-default-cache nil) 508 (defvar font-default-cache nil)
485 509
486 (defun font-default-font-for-device (&optional device) 510 (defun font-default-font-for-device (&optional device)
487 (or device (setq device (selected-device))) 511 (or device (setq device (selected-device)))
488 (if font-running-xemacs 512 (if font-running-xemacs
489 (face-font-name 'default device) 513 (font-truename
514 (make-font-specifier
515 (face-font-name 'default device)))
490 (cdr-safe (assq 'font (frame-parameters device))))) 516 (cdr-safe (assq 'font (frame-parameters device)))))
491 517
492 (defun font-default-object-for-device (&optional device) 518 (defun font-default-object-for-device (&optional device)
493 (let ((font (font-default-font-for-device device))) 519 (let ((font (font-default-font-for-device device)))
494 (or (cdr-safe 520 (or (cdr-safe
503 (or device (setq device (selected-device))) 529 (or device (setq device (selected-device)))
504 (font-family (font-default-object-for-device device))) 530 (font-family (font-default-object-for-device device)))
505 531
506 (defun font-default-size-for-device (&optional device) 532 (defun font-default-size-for-device (&optional device)
507 (or device (setq device (selected-device))) 533 (or device (setq device (selected-device)))
508 (if font-running-xemacs 534 ;; face-height isn't the right thing (always 1 pixel too high?)
509 (format "%dpx" (face-height 'default device)) 535 ;; (if font-running-xemacs
510 (font-size (font-default-object-for-device device)))) 536 ;; (format "%dpx" (face-height 'default device))
537 (font-size (font-default-object-for-device device)))
511 538
512 (defun x-font-create-name (fontobj &optional device) 539 (defun x-font-create-name (fontobj &optional device)
513 (if (and (not (or (font-family fontobj) 540 (if (and (not (or (font-family fontobj)
514 (font-weight fontobj) 541 (font-weight fontobj)
515 (font-size fontobj) 542 (font-size fontobj)
530 (if (stringp family) 557 (if (stringp family)
531 (setq family (list family))) 558 (setq family (list family)))
532 (setq weight (font-higher-weight weight 559 (setq weight (font-higher-weight weight
533 (and (font-bold-p fontobj) :bold))) 560 (and (font-bold-p fontobj) :bold)))
534 (if (stringp size) 561 (if (stringp size)
535 (setq size (round (font-spatial-to-canonical size device)))) 562 (setq size (truncate (font-spatial-to-canonical size device))))
536 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*")) 563 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
537 (let ((done nil) ; Did we find a good font yet? 564 (let ((done nil) ; Did we find a good font yet?
538 (font-name nil) ; font name we are currently checking 565 (font-name nil) ; font name we are currently checking
539 (cur-family nil) ; current family we are checking 566 (cur-family nil) ; current family we are checking
540 ) 567 )