Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 707:a307f9a2021d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-12-20 05:49:28 by andyp] sync with 21-4-6-windows
author andyp
date Thu, 20 Dec 2001 05:49:48 +0000
parents 4d7fdf497470
children 79940b592197
comparison
equal deleted inserted replaced
706:c9bf82d465b5 707:a307f9a2021d
108 (gtk . (x-font-create-name x-font-create-object)) 108 (gtk . (x-font-create-name x-font-create-object))
109 (ns . (ns-font-create-name ns-font-create-object)) 109 (ns . (ns-font-create-name ns-font-create-object))
110 (mswindows . (mswindows-font-create-name mswindows-font-create-object)) 110 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
111 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME 111 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
112 (tty . (tty-font-create-plist tty-font-create-object))) 112 (tty . (tty-font-create-plist tty-font-create-object)))
113 "An assoc list mapping device types to the function used to create 113 "An assoc list mapping device types to a list of translations.
114 a font name from a font structure.") 114
115 The first function creates a font name from a font descriptor object.
116 The second performs the reverse translation.")
115 117
116 (defconst ns-font-weight-mappings 118 (defconst ns-font-weight-mappings
117 '((:extra-light . "extralight") 119 '((:extra-light . "extralight")
118 (:light . "light") 120 (:light . "light")
119 (:demi-light . "demilight") 121 (:demi-light . "demilight")
146 "Where the RGB file was found.") 148 "Where the RGB file was found.")
147 149
148 (defvar font-maximum-slippage "1pt" 150 (defvar font-maximum-slippage "1pt"
149 "How much a font is allowed to vary from the desired size.") 151 "How much a font is allowed to vary from the desired size.")
150 152
153 ;; Canonical (internal) sizes are in points.
154 ;; Registry
151 (define-font-keywords :family :style :size :registry :encoding) 155 (define-font-keywords :family :style :size :registry :encoding)
152 156
153 (define-font-keywords 157 (define-font-keywords
154 :weight :extra-light :light :demi-light :medium :normal :demi-bold 158 :weight :extra-light :light :demi-light :medium :normal :demi-bold
155 :bold :extra-bold) 159 :bold :extra-bold)
302 w1) 306 w1)
303 (t 307 (t
304 w2)))) 308 w2))))
305 309
306 (defun font-spatial-to-canonical (spec &optional device) 310 (defun font-spatial-to-canonical (spec &optional device)
307 "Convert SPEC (in inches, millimeters, points, or picas) into points." 311 "Convert SPEC (in inches, millimeters, points, picas, or pixels) into points.
308 ;; 1 in = 6 pa = 25.4 mm = 72 pt 312
313 Canonical sizes are in points. If SPEC is null, nil is returned. If SPEC is
314 a number, it is interpreted as the desired point size and returned unchanged.
315 Otherwise SPEC must be a string consisting of a number and an optional type.
316 The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or
317 \"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches), \"cm\"
318 (centimeters), or \"mm\" (millimeters).
319
320 1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt. Pixel size is device-dependent."
309 (cond 321 (cond
310 ((numberp spec) 322 ((numberp spec)
311 spec) 323 spec)
312 ((null spec) 324 ((null spec)
313 nil) 325 nil)
318 ;; to 1024x768 resolution on a 17" screen 330 ;; to 1024x768 resolution on a 17" screen
319 (pix-width (float (or (device-pixel-width device) 1024))) 331 (pix-width (float (or (device-pixel-width device) 1024)))
320 (mm-width (float (or (device-mm-width device) 293))) 332 (mm-width (float (or (device-mm-width device) 293)))
321 (retval nil)) 333 (retval nil))
322 (cond 334 (cond
335 ;; the following string-match is broken, there will never be a
336 ;; left operand detected
323 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee! 337 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
324 (let ((math-func (intern (match-string 1 spec))) 338 (let ((math-func (intern (match-string 1 spec)))
325 (other (font-spatial-to-canonical 339 (other (font-spatial-to-canonical
326 (substring spec (match-end 0) nil))) 340 (substring spec (match-end 0) nil)))
327 (default (font-spatial-to-canonical 341 (default (font-spatial-to-canonical
377 (plist-get args :registry) 391 (plist-get args :registry)
378 :encoding 392 :encoding
379 (plist-get args :encoding))) 393 (plist-get args :encoding)))
380 394
381 (defun font-create-name (fontobj &optional device) 395 (defun font-create-name (fontobj &optional device)
396 "Return a font name constructed from FONTOBJ, appropriate for DEVICE."
382 (let* ((type (device-type device)) 397 (let* ((type (device-type device))
383 (func (car (cdr-safe (assq type font-window-system-mappings))))) 398 (func (car (cdr-safe (assq type font-window-system-mappings)))))
384 (and func (fboundp func) (funcall func fontobj device)))) 399 (and func (fboundp func) (funcall func fontobj device))))
385 400
386 ;;;###autoload 401 ;;;###autoload
387 (defun font-create-object (fontname &optional device) 402 (defun font-create-object (fontname &optional device)
403 "Return a font descriptor object for FONTNAME, appropriate for DEVICE."
388 (let* ((type (device-type device)) 404 (let* ((type (device-type device))
389 (func (car (cdr (cdr-safe (assq type font-window-system-mappings)))))) 405 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
390 (and func (fboundp func) (funcall func fontname device)))) 406 (and func (fboundp func) (funcall func fontname device))))
391 407
392 (defun font-combine-fonts-internal (fontobj-1 fontobj-2) 408 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
435 451
436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 452 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
437 ;;; The window-system dependent code (TTY-style) 453 ;;; The window-system dependent code (TTY-style)
438 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 454 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
439 (defun tty-font-create-object (fontname &optional device) 455 (defun tty-font-create-object (fontname &optional device)
456 "Return a font descriptor object for FONTNAME, appropriate for TTY devices."
440 (make-font :size "12pt")) 457 (make-font :size "12pt"))
441 458
442 (defun tty-font-create-plist (fontobj &optional device) 459 (defun tty-font-create-plist (fontobj &optional device)
460 "Return a font name constructed from FONTOBJ, appropriate for TTY devices."
443 (list 461 (list
444 (cons 'underline (font-underline-p fontobj)) 462 (cons 'underline (font-underline-p fontobj))
445 (cons 'highlight (if (or (font-bold-p fontobj) 463 (cons 'highlight (if (or (font-bold-p fontobj)
446 (memq (font-weight fontobj) '(:bold :demi-bold))) 464 (memq (font-weight fontobj) '(:bold :demi-bold)))
447 t)) 465 t))
522 "zapf chancery")) 540 "zapf chancery"))
523 ) 541 )
524 "A list of font family mappings on X devices.") 542 "A list of font family mappings on X devices.")
525 543
526 (defun x-font-create-object (fontname &optional device) 544 (defun x-font-create-object (fontname &optional device)
545 "Return a font descriptor object for FONTNAME, appropriate for X devices."
527 (let ((case-fold-search t)) 546 (let ((case-fold-search t))
528 (if (or (not (stringp fontname)) 547 (if (or (not (stringp fontname))
529 (not (string-match font-x-font-regexp fontname))) 548 (not (string-match font-x-font-regexp fontname)))
530 (make-font) 549 (make-font)
531 (let ((family nil) 550 (let ((family nil)
624 ;; (if font-running-xemacs 643 ;; (if font-running-xemacs
625 ;; (format "%dpx" (face-height 'default device)) 644 ;; (format "%dpx" (face-height 'default device))
626 (font-size (font-default-object-for-device (or device (selected-device))))) 645 (font-size (font-default-object-for-device (or device (selected-device)))))
627 646
628 (defun x-font-create-name (fontobj &optional device) 647 (defun x-font-create-name (fontobj &optional device)
648 "Return a font name constructed from FONTOBJ, appropriate for X devices."
629 (if (and (not (or (font-family fontobj) 649 (if (and (not (or (font-family fontobj)
630 (font-weight fontobj) 650 (font-weight fontobj)
631 (font-size fontobj) 651 (font-size fontobj)
632 (font-registry fontobj) 652 (font-registry fontobj)
633 (font-encoding fontobj))) 653 (font-encoding fontobj)))
715 (normal (mapcar #'(lambda (x) (if x (aref x 0))) 735 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
716 (aref menu 1)))) 736 (aref menu 1))))
717 (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) 737 (sort (font-unique (nconc scaled normal)) 'string-lessp))))))
718 738
719 (defun ns-font-create-name (fontobj &optional device) 739 (defun ns-font-create-name (fontobj &optional device)
740 "Return a font name constructed from FONTOBJ, appropriate for NextSTEP devices."
720 (let ((family (or (font-family fontobj) 741 (let ((family (or (font-family fontobj)
721 (ns-font-families-for-device device))) 742 (ns-font-families-for-device device)))
722 (weight (or (font-weight fontobj) :medium)) 743 (weight (or (font-weight fontobj) :medium))
723 (style (or (font-style fontobj) (list :normal))) 744 (style (or (font-style fontobj) (list :normal)))
724 (size (font-size fontobj))) 745 (size (font-size fontobj)))
813 "script")) 834 "script"))
814 ) 835 )
815 "A list of font family mappings on mswindows devices.") 836 "A list of font family mappings on mswindows devices.")
816 837
817 (defun mswindows-font-create-object (fontname &optional device) 838 (defun mswindows-font-create-object (fontname &optional device)
839 "Return a font descriptor object for FONTNAME, appropriate for MS Windows devices."
818 (let ((case-fold-search t) 840 (let ((case-fold-search t)
819 (font (mswindows-font-canonicalize-name fontname))) 841 (font (mswindows-font-canonicalize-name fontname)))
820 (if (or (not (stringp font)) 842 (if (or (not (stringp font))
821 (not (string-match font-mswindows-font-regexp font))) 843 (not (string-match font-mswindows-font-regexp font)))
822 (make-font) 844 (make-font)
851 ((string-match "[sS]trikeout" effects) 873 ((string-match "[sS]trikeout" effects)
852 (set-font-strikethru-p retval t))) 874 (set-font-strikethru-p retval t)))
853 retval)))) 875 retval))))
854 876
855 (defun mswindows-font-create-name (fontobj &optional device) 877 (defun mswindows-font-create-name (fontobj &optional device)
878 "Return a font name constructed from FONTOBJ, appropriate for MS Windows devices."
856 (if (and (not (or (font-family fontobj) 879 (if (and (not (or (font-family fontobj)
857 (font-weight fontobj) 880 (font-weight fontobj)
858 (font-size fontobj) 881 (font-size fontobj)
859 (font-registry fontobj) 882 (font-registry fontobj)
860 (font-encoding fontobj))) 883 (font-encoding fontobj)))