annotate lisp/font.el @ 5104:868a5349acee

add documentation to frame.c, rearrange some functions to consolidate in related areas -------------------- ChangeLog entries follow: -------------------- src/ChangeLog addition: 2010-03-05 Ben Wing <ben@xemacs.org> * frame.c: * frame.c (frame_live_p): * frame.c (Fframep): * frame.c (Fdisable_frame): * frame.c (Fenable_frame): * frame.c (Fraise_frame): * frame.c (Fframe_name): * frame.c (Fset_frame_height): * frame.c (internal_set_frame_size): * frame.c (adjust_frame_size): Add documentation on the different types of units used to measure frame size. Add section headers to the various sections. Rearrange the location of some functions in the file to keep related functions together. This especially goes for frame-sizing functions (internal_set_frame_size() and adjust_frame_size()), which have been moved so that they form a group with change_frame_size() and change_frame_size_1(). No functionality should change.
author Ben Wing <ben@xemacs.org>
date Fri, 05 Mar 2010 22:50:27 -0600
parents 32b358a240b0
children e0db3c197671 8b2f75cecb89
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; font.el --- New font model
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
2
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
3 ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
4 ;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 1346
diff changeset
5 ;; Copyright (C) 2002, 2004 Ben Wing.
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
6
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Author: wmperry
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
8 ;; Maintainer: XEmacs Development Team
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 ;; Created: 1997/09/05 15:44:37
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
10 ;; Keywords: faces
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;; Version: 1.52
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
12
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
13 ;; XEmacs is free software; you can redistribute it and/or modify it
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
14 ;; under the terms of the GNU General Public License as published by
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
15 ;; the Free Software Foundation; either version 2, or (at your option)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
16 ;; any later version.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
17
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
18 ;; XEmacs is distributed in the hope that it will be useful, but
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
21 ;; General Public License for more details.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
23 ;; You should have received a copy of the GNU General Public License
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
24 ;; along with XEmacs; see the file COPYING. If not, write to the Free
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
26 ;; 02111-1307, USA.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
27
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
28 ;;; Synched up with: Not in FSF
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
29
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
30 ;;; Commentary:
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
32 ;; This file is totally bogus in the context of Emacs. Much of what it does
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
33 ;; is really in the provice of faces (for example all the style parameters),
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
34 ;; and that's the way it is in GNU Emacs.
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
35 ;;
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
36 ;; What is needed for fonts at the Lisp level is a consistent way to access
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
37 ;; face properties that are actually associated with fonts for some rendering
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
38 ;; engine, in other words, the kinds of facilities provided by fontconfig
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
39 ;; patterns. We just need to provide an interface to looking up, storing,
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
40 ;; and manipulating font specifications with certain properties. There will
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
41 ;; be some engine-specific stuff, like the bogosity of X11's character set
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
42 ;; registries.
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
43
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
44 ;;; Code:
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
45
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
46 (globally-declare-fboundp
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 1346
diff changeset
47 '(internal-facep fontsetp get-font-info
523
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
48 get-fontset-info mswindows-define-rgb-color cancel-function-timers
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
49 mswindows-font-regexp mswindows-canonicalize-font-name
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
50 mswindows-parse-font-style mswindows-construct-font-style
523
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
51 ;; #### perhaps we should rewrite font-warn to avoid the warning
4103
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 4099
diff changeset
52 ;; Eh, now I look at the code, we definitely should.
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 4099
diff changeset
53 font-warn
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 4099
diff changeset
54 fc-pattern-get-family fc-pattern-get-size fc-pattern-get-weight
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 4099
diff changeset
55 fc-font-weight-translate-from-constant make-fc-pattern
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 4099
diff changeset
56 fc-pattern-add-family fc-pattern-add-size))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
57
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
58 (globally-declare-boundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
59 '(global-face-data
1346
01c57eb70ae9 [xemacs-hg @ 2003-03-09 02:27:27 by ben]
ben
parents: 872
diff changeset
60 x-font-regexp x-font-regexp-foundry-and-family
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
61 fc-font-regexp
1346
01c57eb70ae9 [xemacs-hg @ 2003-03-09 02:27:27 by ben]
ben
parents: 872
diff changeset
62 mswindows-font-regexp))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
63
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 (require 'cl)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 (eval-and-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 (defvar device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 (condition-case ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 (require 'custom)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 (error nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 nil ;; We've got what we needed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 ;; We have the old custom-library, hack around it!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 (defmacro defgroup (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 (defmacro defcustom (var value doc &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 `(defvar ,var ,value ,doc))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 1346
diff changeset
79 ; delete alternate defn of try-font-name
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 (if (not (fboundp 'facep))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 (defun facep (face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 "Return t if X is a face name or an internal face vector."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 (if (not window-system)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 nil ; FIXME if FSF ever does TTY faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (and (or (internal-facep face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 (and (symbolp face) (assq face global-face-data)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 (if (not (fboundp 'set-face-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (defun set-face-property (face property value &optional locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 tag-set how-to-add)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 "Change a property of FACE."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 (and (symbolp face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 (put face property value))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 (if (not (fboundp 'face-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (defun face-property (face property &optional locale tag-set exact-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 "Return FACE's value of the given PROPERTY."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 (and (symbolp face) (get face property))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (require 'disp-table)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 ;;; Lots of variables / keywords for use later in the program
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 ;;; Not much should need to be modified
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
109 ;; #### These aren't window system mappings
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (defconst font-window-system-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 '((x . (x-font-create-name x-font-create-object))
608
4d7fdf497470 [xemacs-hg @ 2001-06-04 16:59:51 by wmperry]
wmperry
parents: 523
diff changeset
112 (gtk . (x-font-create-name x-font-create-object))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
113 ;; #### FIXME should this handle fontconfig font objects?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
114 (fc . (fc-font-create-name fc-font-create-object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
117 ;; #### what is this bogosity?
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (tty . (tty-font-create-plist tty-font-create-object)))
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
119 "An assoc list mapping device types to a list of translations.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
120
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
121 The first function creates a font name from a font descriptor object.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
122 The second performs the reverse translation.")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (defconst x-font-weight-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 '((:extra-light . "extralight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 (:light . "light")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (:demi-light . "demilight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (:demi . "demi")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (:book . "book")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (:medium . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 (:normal . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (:demi-bold . "demibold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 (:bold . "bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 (:extra-bold . "extrabold"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 "An assoc list mapping keywords to actual Xwindow specific strings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 for use in the 'weight' field of an X font string.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 (defconst font-possible-weights
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (mapcar 'car x-font-weight-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 (defvar font-rgb-file nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 "Where the RGB file was found.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 (defvar font-maximum-slippage "1pt"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 "How much a font is allowed to vary from the desired size.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
147 ;; Canonical (internal) sizes are in points.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
149 ;; Property keywords: :family :style :size :registry :encoding :weight
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
150 ;; Weight keywords: :extra-light :light :demi-light :medium
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
151 ;; :normal :demi-bold :bold :extra-bold
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
152 ;; See GNU Emacs 21.4 for more properties and keywords we should support
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 (defvar font-style-keywords nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
156 (defun set-font-family (fontobj family)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 (aset fontobj 1 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
159 (defun set-font-weight (fontobj weight)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (aset fontobj 3 weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
162 (defun set-font-style (fontobj style)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (aset fontobj 5 style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
165 (defun set-font-size (fontobj size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 (aset fontobj 7 size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
168 (defun set-font-registry (fontobj reg)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 (aset fontobj 9 reg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
171 (defun set-font-encoding (fontobj enc)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 (aset fontobj 11 enc))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
174 (defun font-family (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 (aref fontobj 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
177 (defun font-weight (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 (aref fontobj 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
180 (defun font-style (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (aref fontobj 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
183 (defun font-size (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 (aref fontobj 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
186 (defun font-registry (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (aref fontobj 9))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
189 (defun font-encoding (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (aref fontobj 11))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 (eval-when-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 (defmacro define-new-mask (attr mask)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (setq font-style-keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (cons (cons (quote ,attr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 (cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 (quote ,(intern (format "set-font-%s-p" attr)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 (quote ,(intern (format "font-%s-p" attr)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 font-style-keywords))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
201 (defconst ,(intern (format "font-%s-mask" attr)) (lsh 1 ,mask)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 ,(format
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 "Bitmask for whether a font is to be rendered in %s or not."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 attr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 (defun ,(intern (format "font-%s-p" attr)) (fontobj)
4577
de0228446b18 Docstring spelling fixes.
"Ville Skyttä <scop@xemacs.org>"
parents: 4453
diff changeset
206 ,(format "Whether FONTOBJ will be rendered in `%s' or not." attr)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
207 (if (/= 0 (logand (font-style fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 ,(intern (format "font-%s-mask" attr))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
4577
de0228446b18 Docstring spelling fixes.
"Ville Skyttä <scop@xemacs.org>"
parents: 4453
diff changeset
212 ,(format "Set whether FONTOBJ will be rendered in `%s' or not."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 attr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 (val
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
216 (set-font-style fontobj (logior (font-style fontobj)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
217 ,(intern
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
218 (format "font-%s-mask" attr)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 ((,(intern (format "font-%s-p" attr)) fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 (set-font-style fontobj (- (font-style fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 ,(intern
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 (format "font-%s-mask" attr)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224
523
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
225 (define-new-mask bold 1)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
226 (define-new-mask italic 2)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
227 (define-new-mask oblique 3)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
228 (define-new-mask dim 4)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
229 (define-new-mask underline 5)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
230 (define-new-mask overline 6)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
231 (define-new-mask linethrough 7)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
232 (define-new-mask strikethru 8)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
233 (define-new-mask reverse 9)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
234 (define-new-mask blink 10)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
235 (define-new-mask smallcaps 11)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
236 (define-new-mask bigcaps 12)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
237 (define-new-mask dropcaps 13)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 (defvar font-caps-display-table
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 (let ((table (make-display-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 (i 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 ;; Standard ASCII characters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 (while (< i 26)
4451
e214ff9f9507 Use char-tables, not vectors, to instantiate the display table specifiers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4103
diff changeset
244 (put-display-table (+ i ?a) (+ i ?A) table)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 ;; Now ISO translations
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
247 ;; #### FIXME what's this for??
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 (setq i 224)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 (while (< i 247) ;; Agrave - Ouml
4451
e214ff9f9507 Use char-tables, not vectors, to instantiate the display table specifiers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4103
diff changeset
250 (put-display-table i (- i 32) table)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (setq i 248)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 (while (< i 255) ;; Oslash - Thorn
4451
e214ff9f9507 Use char-tables, not vectors, to instantiate the display table specifiers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4103
diff changeset
254 (put-display-table i (- i 32) table)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 ;;; Utility functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
261 ;; #### unused?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
262 ; (defun set-font-style-by-keywords (fontobj styles)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
263 ; (make-local-variable 'font-func)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
264 ; (declare (special font-func))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
265 ; (if (listp styles)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
266 ; (while styles
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
267 ; (setq font-func (car-safe (cdr-safe (assq (car styles)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
268 ; font-style-keywords)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
269 ; styles (cdr styles))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
270 ; (and (fboundp font-func) (funcall font-func fontobj t)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
271 ; (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
272 ; (and (fboundp font-func) (funcall font-func fontobj t))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
274 ;; #### unused?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
275 ; (defun font-properties-from-style (fontobj)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
276 ; (let ((todo font-style-keywords)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
277 ; type func retval)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
278 ; (while todo
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
279 ; (setq func (cdr (cdr (car todo)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
280 ; type (car (pop todo)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
281 ; (if (funcall func fontobj)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
282 ; (setq retval (cons type retval))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
283 ; retval))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 (defun font-higher-weight (w1 w2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 (let ((index1 (length (memq w1 font-possible-weights)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 (index2 (length (memq w2 font-possible-weights))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 ((<= index1 index2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 (or w1 w2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 ((not w2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 w1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 w2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 (defun font-spatial-to-canonical (spec &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
297 "Convert SPEC (in inches, millimeters, points, picas, or pixels) into points.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
298
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
299 Canonical sizes are in points. If SPEC is null, nil is returned. If SPEC is
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
300 a number, it is interpreted as the desired point size and returned unchanged.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
301 Otherwise SPEC must be a string consisting of a number and an optional type.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
302 The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or
2685
64752935473d [xemacs-hg @ 2005-03-25 15:58:02 by aidan]
aidan
parents: 2527
diff changeset
303 \"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches),
64752935473d [xemacs-hg @ 2005-03-25 15:58:02 by aidan]
aidan
parents: 2527
diff changeset
304 \"cm\" (centimeters), or \"mm\" (millimeters).
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
305
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
306 1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt. Pixel size is device-dependent."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 ((numberp spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 ((null spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 (let ((num nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 (type nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 ;; If for any reason we get null for any of this, default
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 ;; to 1024x768 resolution on a 17" screen
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 (pix-width (float (or (device-pixel-width device) 1024)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 (mm-width (float (or (device-mm-width device) 293)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 (retval nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 (cond
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
321 ;; #### this is pretty bogus and should probably be made gone
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
322 ;; or supported at a higher level
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 (let ((math-func (intern (match-string 1 spec)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 (other (font-spatial-to-canonical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 (substring spec (match-end 0) nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (default (font-spatial-to-canonical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 (font-default-size-for-device device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 (if (fboundp math-func)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 spec (int-to-string (funcall math-func default other)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 spec (int-to-string other)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 ((string-match "[^0-9.]+$" spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (setq type (substring spec (match-beginning 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 spec (substring spec 0 (match-beginning 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 spec spec)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 (setq num (string-to-number spec))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 ((member type '("pixel" "px" "pix"))
2685
64752935473d [xemacs-hg @ 2005-03-25 15:58:02 by aidan]
aidan
parents: 2527
diff changeset
343 (setq retval (* num (/ mm-width pix-width) (/ 72.0 25.4))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 ((member type '("point" "pt"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (setq retval num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 ((member type '("pica" "pa"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 (setq retval (* num 12.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 ((member type '("inch" "in"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (setq retval (* num 72.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 ((string= type "mm")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 (setq retval (* num (/ 72.0 25.4))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 ((string= type "cm")
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
353 (setq retval (* num (/ 72.0 2.54))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (setq retval num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 ;;; The main interface routines - constructors and accessor functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 (defun make-font (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 (vector :family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 (if (stringp (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 (list (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 :weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 (plist-get args :weight)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 :style
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 (if (numberp (plist-get args :style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 (plist-get args :style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 :size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 (plist-get args :size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 :registry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 (plist-get args :registry)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 :encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 (plist-get args :encoding)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 (defun font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
382 "Return a font name constructed from FONTOBJ, appropriate for DEVICE."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 (let* ((type (device-type device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 (func (car (cdr-safe (assq type font-window-system-mappings)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 (and func (fboundp func) (funcall func fontobj device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 (defun font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
389 "Return a font descriptor object for FONTNAME, appropriate for DEVICE."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 (let* ((type (device-type device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 (and func (fboundp func) (funcall func fontname device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 (let ((retval (make-font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 (size-1 (and (font-size fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 (font-spatial-to-canonical (font-size fontobj-1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 (size-2 (and (font-size fontobj-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 (font-spatial-to-canonical (font-size fontobj-2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 (font-weight fontobj-2)))
4607
517f6887fbc0 Remove duplicate functions, chiefly #'delete-duplicates reimplementations.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4577
diff changeset
402 (set-font-family retval
517f6887fbc0 Remove duplicate functions, chiefly #'delete-duplicates reimplementations.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4577
diff changeset
403 (delete-duplicates (append (font-family fontobj-1)
4727
90dbf8e772b6 Fix typo in font-combine-fonts-internal.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4607
diff changeset
404 (font-family fontobj-2))
90dbf8e772b6 Fix typo in font-combine-fonts-internal.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4607
diff changeset
405 :test #'equal))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
406 (set-font-style retval (logior (font-style fontobj-1)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
407 (font-style fontobj-2)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 (set-font-registry retval (or (font-registry fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 (font-registry fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 (set-font-encoding retval (or (font-encoding fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (font-encoding fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 (set-font-size retval (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 ((and size-1 size-2 (>= size-2 size-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (font-size fontobj-2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 ((and size-1 size-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 (font-size fontobj-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 (size-1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (font-size fontobj-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (size-2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (font-size fontobj-2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 (defun font-combine-fonts (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 ((null args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 (error "Wrong number of arguments to font-combine-fonts"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 ((= (length args) 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 (car args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 (setq args (cdr (cdr args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 (while args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (setq retval (font-combine-fonts-internal retval (car args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 args (cdr args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
439 (defvar font-default-cache nil)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
440
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
441 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
442 (defun font-default-font-for-device (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
443 (or device (setq device (selected-device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
444 (font-truename
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
445 (make-font-specifier
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
446 (face-font-name 'default device))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
447
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
448 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
449 (defun font-default-object-for-device (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
450 (let ((font (font-default-font-for-device device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
451 (or (cdr-safe (assoc font font-default-cache))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
452 (let ((object (font-create-object font)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
453 (push (cons font object) font-default-cache)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
454 object))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
455
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
456 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
457 (defun font-default-family-for-device (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
458 (font-family (font-default-object-for-device (or device (selected-device)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
459
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
460 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
461 (defun font-default-registry-for-device (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
462 (font-registry (font-default-object-for-device (or device (selected-device)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
463
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
464 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
465 (defun font-default-encoding-for-device (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
466 (font-encoding (font-default-object-for-device (or device (selected-device)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
467
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
468 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
469 (defun font-default-size-for-device (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
470 ;; face-height isn't the right thing (always 1 pixel too high?)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
471 ;; (if font-running-xemacs
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
472 ;; (format "%dpx" (face-height 'default device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
473 (font-size (font-default-object-for-device (or device (selected-device)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
474
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 ;;; The window-system dependent code (TTY-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 (defun tty-font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
480 "Return a font descriptor object for FONTNAME, appropriate for TTY devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 (make-font :size "12pt"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 (defun tty-font-create-plist (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
484 "Return a font name constructed from FONTOBJ, appropriate for TTY devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 (list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 (cons 'underline (font-underline-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 (cons 'highlight (if (or (font-bold-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 (memq (font-weight fontobj) '(:bold :demi-bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 (cons 'dim (font-dim-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 (cons 'blinking (font-blink-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 (cons 'reverse (font-reverse-p fontobj))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 ;;; The window-system dependent code (X-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
498 (defvar font-x-font-regexp (when (and (boundp 'x-font-regexp)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
499 x-font-regexp)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 (let
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 ((- "[-?]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 (foundry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 (family "[^-]*")
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
504 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 (weight\? "\\([^-]*\\)")
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
506 ;(slant "\\([ior]\\)")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 (slant\? "\\([^-]?\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 (swidth "\\([^-]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 (adstyle "\\([^-]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 (pixelsize "\\(\\*\\|[0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 (resx "\\([*0]\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 (resy "\\([*0]\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 (spacing "[cmp?*]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 (avgwidth "\\(\\*\\|[0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 (registry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 (encoding "[^-]+")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 (concat "\\`\\*?[-?*]"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 foundry - family - weight\? - slant\? - swidth - adstyle -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 pixelsize - pointsize - resx - resy - spacing - avgwidth -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 registry - encoding "\\'"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 ))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 (defvar font-x-registry-and-encoding-regexp
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
526 (when (and (boundp 'x-font-regexp-registry-and-encoding)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
527 (symbol-value 'x-font-regexp-registry-and-encoding))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
528 (let ((- "[-?]")
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
529 (registry "[^-]*")
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
530 (encoding "[^-]+"))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
531 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 (defvar font-x-family-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 '(
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 ("serif" . ("new century schoolbook"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 "utopia"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 "charter"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 "times"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 "lucidabright"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 "garamond"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 "palatino"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 "times new roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 "baskerville"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 "bookman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 "bodoni"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 "computer modern"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 "rockwell"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 ("sans-serif" . ("lucida"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 "helvetica"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 "gills-sans"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 "avant-garde"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 "univers"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 "optima"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 ("elfin" . ("tymes"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 ("monospace" . ("courier"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 "fixed"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 "lucidatypewriter"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 "clean"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 "terminal"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 ("cursive" . ("sirene"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 "zapf chancery"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 "A list of font family mappings on X devices.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (defun x-font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
567 "Return a font descriptor object for FONTNAME, appropriate for X devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 (let ((case-fold-search t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 (if (or (not (stringp fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 (not (string-match font-x-font-regexp fontname)))
4099
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
571 (if (and (stringp fontname)
4766
32b358a240b0 Avoid calling Xft if not built in.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4759
diff changeset
572 (featurep 'xft-fonts)
4099
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
573 (string-match font-xft-font-regexp fontname))
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
574 ;; Return an XFT font.
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
575 (xft-font-create-object fontname)
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
576 ;; It's unclear how to parse the font; return an unspecified
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
577 ;; one.
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
578 (make-font))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 (let ((family nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 (size nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 (weight (match-string 1 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 (slant (match-string 2 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 (swidth (match-string 3 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 (adstyle (match-string 4 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 (pxsize (match-string 5 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 (ptsize (match-string 6 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 (retval nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 (if (not (string-match x-font-regexp-foundry-and-family fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 (setq family (list (downcase (match-string 1 fontname)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (if (string= "*" weight) (setq weight nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 (if (string= "*" slant) (setq slant nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 (if (string= "*" swidth) (setq swidth nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 (if (string= "*" adstyle) (setq adstyle nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 (if (string= "*" pxsize) (setq pxsize nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 (if (string= "*" ptsize) (setq ptsize nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 (if (and adstyle (not (equal adstyle "")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 (setq family (append family (list (downcase adstyle)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 (setq retval (make-font :family family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 :weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 :size size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 (set-font-bold-p retval (eq :bold weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 ((null slant) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 ((member slant '("i" "I"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 (set-font-italic-p retval t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 ((member slant '("o" "O"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 (set-font-oblique-p retval t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 (when (string-match font-x-registry-and-encoding-regexp fontname)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 (set-font-registry retval (match-string 1 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 (set-font-encoding retval (match-string 2 fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 (defun x-font-families-for-device (&optional device no-resetp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 (ignore-errors (require 'x-font-menu))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 (if (boundp 'device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 (if (and (not menu) (not no-resetp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 (reset-device-font-menus device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 (x-font-families-for-device device t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 (aref menu 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 (aref menu 1))))
4607
517f6887fbc0 Remove duplicate functions, chiefly #'delete-duplicates reimplementations.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4577
diff changeset
632 (sort (delete-duplicates (nconc scaled normal) :test 'equal)
517f6887fbc0 Remove duplicate functions, chiefly #'delete-duplicates reimplementations.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4577
diff changeset
633 'string-lessp))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 (cons "monospace" (mapcar 'car font-x-family-mappings))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (defun x-font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
637 "Return a font name constructed from FONTOBJ, appropriate for X devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 (if (and (not (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 (font-weight fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 (font-size fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 (font-encoding fontobj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 (= (font-style fontobj) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (face-font 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 (let* ((default (font-default-object-for-device device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 (family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 (font-family default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 (x-font-families-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (weight (or (font-weight fontobj) :medium))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
651 (size (or (font-size fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 (font-size default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 (registry (or (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 (font-registry default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 "*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 (encoding (or (font-encoding fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 (font-encoding default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 "*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 (setq weight (font-higher-weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 (and (font-bold-p fontobj) :bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 (setq size (truncate (font-spatial-to-canonical size device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 (if (assoc cur-family font-x-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 ;; font-x-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 font-x-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 ;; Not an alias for a list of fonts, so we just check it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 ;; First, convert all '-' to spaces so that we don't screw up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 ;; the oh-so wonderful X font model. Wheee.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (let ((x (length cur-family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 (while (> x 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 (if (= ?- (aref cur-family (1- x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 (aset cur-family (1- x) ? ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 (setq x (1- x))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 ;; We treat oblique and italic as equivalent. Don't ask.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 (let ((slants '("o" "i")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 (while (and slants (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 cur-family weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 (if (or (font-italic-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 (font-oblique-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 (car slants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 "r")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 (if size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 (int-to-string (* 10 size)) "*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 registry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 slants (cdr slants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 done (try-font-name font-name device))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 (if done font-name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
708 ;;; Cache building code
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
709 ;;;###autoload
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
710 (defun x-font-build-cache (&optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
711 (let ((hash-table (make-hash-table :test 'equal :size 15))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
712 (fonts (mapcar 'x-font-create-object
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
713 (font-list "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
714 (plist nil)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
715 (cur nil))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
716 (while fonts
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
717 (setq cur (car fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
718 fonts (cdr fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
719 plist (cl-gethash (car (font-family cur)) hash-table))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
720 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
721 (setq plist (plist-put plist 'weights (cons (font-weight cur)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
722 (plist-get plist 'weights)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
723 (if (not (member (font-size cur) (plist-get plist 'sizes)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
724 (setq plist (plist-put plist 'sizes (cons (font-size cur)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
725 (plist-get plist 'sizes)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
726 (if (and (font-oblique-p cur)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
727 (not (memq 'oblique (plist-get plist 'styles))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
728 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
729 (if (and (font-italic-p cur)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
730 (not (memq 'italic (plist-get plist 'styles))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
731 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
732 (cl-puthash (car (font-family cur)) plist hash-table))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
733 hash-table))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
734
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
735
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
737 ;;; The rendering engine-dependent code (Xft-style)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
738 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
739
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
740 ;;; #### FIXME actually, this section should be fc-*, right?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
741
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
742 (defvar font-xft-font-regexp
4099
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
743 (concat "\\`"
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
744 #r"\(\\-\|\\:\|\\,\|[^:-]\)*" ; optional foundry and family
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
745 ; (allows for escaped colons,
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
746 ; dashes, commas)
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
747 "\\(-[0-9]*\\(\\.[0-9]*\\)?\\)?" ; optional size (points)
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
748 "\\(:[^:]*\\)*" ; optional properties
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
749 ; not necessarily key=value!!
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
750 "\\'"
4099
a5e2d0f90f97 [xemacs-hg @ 2007-08-06 07:00:26 by aidan]
aidan
parents: 3360
diff changeset
751 ))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
752
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
753 (defvar font-xft-family-mappings
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
754 ;; #### FIXME this shouldn't be needed or used for Xft
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
755 '(("serif" . ("new century schoolbook"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
756 "utopia"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
757 "charter"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
758 "times"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
759 "lucidabright"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
760 "garamond"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
761 "palatino"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
762 "times new roman"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
763 "baskerville"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
764 "bookman"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
765 "bodoni"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
766 "computer modern"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
767 "rockwell"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
768 ))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
769 ("sans-serif" . ("lucida"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
770 "helvetica"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
771 "gills-sans"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
772 "avant-garde"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
773 "univers"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
774 "optima"))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
775 ("elfin" . ("tymes"))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
776 ("monospace" . ("courier"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
777 "fixed"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
778 "lucidatypewriter"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
779 "clean"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
780 "terminal"))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
781 ("cursive" . ("sirene"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
782 "zapf chancery"))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
783 )
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
784 "A list of font family mappings on Xft devices.")
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
785
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
786 (defun xft-font-create-object (fontname &optional device)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3125
diff changeset
787 "Return a font descriptor object for FONTNAME, appropriate for Xft.
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3125
diff changeset
788
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3125
diff changeset
789 Optional DEVICE defaults to `default-x-device'."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
790 (let* ((name fontname)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
791 (device (or device (default-x-device)))
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3125
diff changeset
792 (pattern (fc-font-match device (fc-name-parse name)))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
793 (font-obj (make-font))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
794 (family (fc-pattern-get-family pattern 0))
4362
f5693b5f7f2d Compute size for Xft fonts.
Mike Sperber <sperber@deinprogramm.de>
parents: 4103
diff changeset
795 (size (fc-pattern-get-or-compute-size pattern 0))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
796 (weight (fc-pattern-get-weight pattern 0)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
797 (set-font-family font-obj
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
798 (and (not (equal family 'fc-result-no-match))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
799 family))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
800 (set-font-size font-obj
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
801 (and (not (equal size 'fc-result-no-match))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
802 size))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
803 (set-font-weight font-obj
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
804 (and (not (equal weight 'fc-result-no-match))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
805 (fc-font-weight-translate-from-constant weight)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
806 font-obj))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
807
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
808 ;; #### FIXME Xft fonts are not defined by the device.
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
809 ;; ... Does that mean the whole model here is bogus?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
810 (defun xft-font-families-for-device (&optional device no-resetp)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
811 (ignore-errors (require 'x-font-menu)) ; #### FIXME xft-font-menu?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
812 (or device (setq device (selected-device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
813 (if (boundp 'device-fonts-cache) ; #### FIXME does this make sense?
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
814 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
815 (if (and (not menu) (not no-resetp))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
816 (progn
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
817 (reset-device-font-menus device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
818 (xft-font-families-for-device device t))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
819 ;; #### FIXME clearly bogus for Xft
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
820 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
821 (aref menu 0)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
822 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
823 (aref menu 1))))
4607
517f6887fbc0 Remove duplicate functions, chiefly #'delete-duplicates reimplementations.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4577
diff changeset
824 (sort (delete-duplicates (nconc scaled normal) :test #'equal)
517f6887fbc0 Remove duplicate functions, chiefly #'delete-duplicates reimplementations.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4577
diff changeset
825 'string-lessp))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
826 ;; #### FIXME clearly bogus for Xft
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
827 (cons "monospace" (mapcar 'car font-xft-family-mappings))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
828
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
829 (defun xft-font-create-name (fontobj &optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
830 (let* ((pattern (make-fc-pattern)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
831 (if (font-family fontobj)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
832 (fc-pattern-add-family pattern (font-family fontobj)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
833 (if (font-size fontobj)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
834 (fc-pattern-add-size pattern (font-size fontobj)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
835 (fc-name-unparse pattern)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
836
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
837
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 ;;; The window-system dependent code (mswindows-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 (defconst mswindows-font-weight-mappings
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
843 '((:thin . "Thin")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
844 (:extra-light . "Extra Light")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 (:light . "Light")
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
846 (:demi-light . "Light")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
847 (:demi . "Light")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
848 (:book . "Medium")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 (:medium . "Medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 (:normal . "Normal")
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
851 (:demi-bold . "Demi Bold")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 (:bold . "Bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 (:regular . "Regular")
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
854 (:extra-bold . "Extra Bold")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
855 (:heavy . "Heavy"))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 "An assoc list mapping keywords to actual mswindows specific strings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 for use in the 'weight' field of an mswindows font string.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 (defvar font-mswindows-family-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 '(
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 ("serif" . ("times new roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 "century schoolbook"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 "book antiqua"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 "bookman old style"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 ("sans-serif" . ("arial"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 "verdana"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 "lucida sans unicode"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 ("monospace" . ("courier new"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 "lucida console"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 "courier"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 "terminal"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 ("cursive" . ("roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 "script"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 "A list of font family mappings on mswindows devices.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 (defun mswindows-font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
878 "Return a font descriptor object for FONTNAME, appropriate for MS Windows devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 (let ((case-fold-search t)
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
880 (font (declare-fboundp (mswindows-canonicalize-font-name fontname))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (if (or (not (stringp font))
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
882 (not (string-match mswindows-font-regexp font)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 (make-font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 (let ((family (match-string 1 font))
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
885 (style (match-string 2 font))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
886 (pointsize (match-string 3 font))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
887 (effects (match-string 4 font))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
888 (charset (match-string 5 font))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 (retval nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 (size nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 (case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 )
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
893 (destructuring-bind (weight . slant)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
894 (mswindows-parse-font-style style)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
895 (if (equal pointsize "") (setq pointsize nil))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
896 (if pointsize (setq size (concat pointsize "pt")))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
897 (if weight (setq weight
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
898 (intern-soft
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
899 (concat ":" (downcase (replace-in-string
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
900 weight " " "-"))))))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
901 (setq retval (make-font :family family
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
902 :weight weight
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
903 :size size
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
904 :encoding charset))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
905 (set-font-bold-p retval (eq :bold weight))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
906 (cond
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
907 ((null slant) nil)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
908 ((string-match "[iI]talic" slant)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
909 (set-font-italic-p retval t)))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
910 (cond
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
911 ((null effects) nil)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
912 ((string-match "^[uU]nderline [sS]trikeout" effects)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
913 (set-font-underline-p retval t)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
914 (set-font-strikethru-p retval t))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
915 ((string-match "[uU]nderline" effects)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
916 (set-font-underline-p retval t))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
917 ((string-match "[sS]trikeout" effects)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
918 (set-font-strikethru-p retval t)))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
919 retval)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 (defun mswindows-font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
922 "Return a font name constructed from FONTOBJ, appropriate for MS Windows devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 (if (and (not (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 (font-weight fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 (font-size fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 (font-encoding fontobj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 (= (font-style fontobj) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 (face-font 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 (let* ((default (font-default-object-for-device device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 (family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 (font-family default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 (weight (or (font-weight fontobj) :regular))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
935 (size (or (font-size fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 (font-size default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 (underline-p (font-underline-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 (strikeout-p (font-strikethru-p fontobj))
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
939 (encoding (font-encoding fontobj)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 (setq weight (font-higher-weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 (and (font-bold-p fontobj) :bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 (setq size (truncate (font-spatial-to-canonical size device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 (setq weight (or (cdr-safe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 (assq weight mswindows-font-weight-mappings)) ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 (if (assoc cur-family font-mswindows-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 ;; font-mswindows-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 font-mswindows-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 ;; We treat oblique and italic as equivalent. Don't ask.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 ;; Courier New:Bold Italic:10:underline strikeout:western
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
965 (setq font-name (format "%s:%s:%s:%s:%s"
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
966 cur-family
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
967 (mswindows-construct-font-style
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
968 weight
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
969 (if (font-italic-p fontobj)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
970 "Italic" ""))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 (if size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 (int-to-string size) "10")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 (if underline-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 (if strikeout-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 "underline strikeout"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 "underline")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 (if strikeout-p "strikeout" ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 (if encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 encoding ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 done (try-font-name font-name device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 (if done font-name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 ;;; Now overwrite the original copy of set-face-font with our own copy that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 ;;; can deal with either syntax.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 ;;; ###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 (defun font-set-face-font (&optional face font &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 ((and (vectorp font) (= (length font) 12))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 (let ((font-name (font-create-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 (set-face-property face 'font-specification font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 ((null font-name) ; No matching font!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 ((listp font-name) ; For TTYs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 (let (cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 (while font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 (setq cur (car font-name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 font-name (cdr font-name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 (apply 'set-face-property face (car cur) (cdr cur) args))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1003 (t
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 (apply 'set-face-font face font-name args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 (apply 'set-face-underline-p face (font-underline-p font) args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 (fboundp 'set-face-display-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 (apply 'set-face-display-table
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 face font-caps-display-table args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 (apply 'set-face-property face 'strikethru (or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 (font-linethrough-p font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 (font-strikethru-p font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 args))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1014 ;;; this used to be default with preceding conditioned on font-running-xemacs
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1015 ; (t
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1016 ; (condition-case nil
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1017 ; (apply 'set-face-font face font-name args)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1018 ; (error
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1019 ; (let ((args (car-safe args)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1020 ; (and (or (font-bold-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1021 ; (memq (font-weight font) '(:bold :demi-bold)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1022 ; (make-face-bold face args t))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1023 ; (and (font-italic-p font) (make-face-italic face args t)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1024 ; (apply 'set-face-underline-p face (font-underline-p font) args))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1025 )))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 ;; Let the original set-face-font signal any errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 (set-face-property face 'font-specification nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 (apply 'set-face-font face font args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 ;;; Now for emacsen specific stuff
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035 (defun font-update-device-fonts (device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 ;; Update all faces that were created with the 'font' package
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 ;; to appear correctly on the new device. This should be in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 ;; create-device-hook. This is XEmacs 19.12+ specific
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 (let ((faces (face-list 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 (cur nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 (font-spec nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 (while faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 (setq cur (car faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 faces (cdr faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 font-spec (face-property cur 'font-specification))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 (if font-spec
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 (set-face-font cur font-spec device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 (defun font-update-one-face (face &optional device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 ;; Update FACE on all devices in DEVICE-LIST
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 ;; DEVICE_LIST defaults to a list of all active devices
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 (setq device-list (or device-list (device-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 (if (devicep device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 (setq device-list (list device-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 (let* ((cur-device nil)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1056 (font-spec (face-property face 'font-specification)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 (if (not font-spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 ;; Hey! Don't mess with fonts we didn't create in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 ;; first place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 (while device-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062 (setq cur-device (car device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 device-list (cdr device-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 (if (not (device-live-p cur-device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 ;; Whoah!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 (if font-spec
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068 (set-face-font face font-spec cur-device)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 ;;; Various color related things
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 ((fboundp 'display-warning)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 (fset 'font-warn 'display-warning))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 ((fboundp 'w3-warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 (fset 'font-warn 'w3-warn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 ((fboundp 'url-warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 (fset 'font-warn 'url-warn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 ((fboundp 'warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 (defun font-warn (class message &optional level)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 (warn "(%s/%s) %s" class (or level 'warning) message)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 (defun font-warn (class message &optional level)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086 (set-buffer (get-buffer-create "*W3-WARNINGS*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 (goto-char (point-max))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 (display-buffer (current-buffer))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 (defun font-lookup-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 The list (R G B) is returned, or an error is signaled if the lookup fails."
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 1346
diff changeset
1095 (let ((lib-list (if-boundp 'x-library-search-path
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 x-library-search-path
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 (list "/usr/X11R6/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 "/usr/X11R5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 "/usr/lib/X11R6/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 "/usr/lib/X11R5/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 "/usr/local/X11R6/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 "/usr/local/X11R5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 "/usr/local/lib/X11R6/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 "/usr/local/lib/X11R5/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 "/usr/X11/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 "/usr/lib/X11/"
3125
d97bc868eaaf [xemacs-hg @ 2005-12-05 09:43:36 by scop]
scop
parents: 3094
diff changeset
1107 "/usr/share/X11/"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 "/usr/local/lib/X11/"
3125
d97bc868eaaf [xemacs-hg @ 2005-12-05 09:43:36 by scop]
scop
parents: 3094
diff changeset
1109 "/usr/local/share/X11/"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 "/usr/X386/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 "/usr/x386/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 "/usr/XFree86/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 "/usr/unsupported/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 "/usr/athena/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 "/usr/local/x11r5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 "/usr/lpp/Xamples/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 "/usr/openwin/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 "/usr/openwin/share/lib/X11/")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 (file font-rgb-file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 r g b)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121 (if (not file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 (while lib-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 (setq file (expand-file-name "rgb.txt" (car lib-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 (if (file-readable-p file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 (setq lib-list nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 font-rgb-file file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 (setq lib-list (cdr lib-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 file nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 (if (null file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 (list 0 0 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 (set-buffer (find-file-noselect file))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 (if (not (= (aref (buffer-name) 0) ? ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 (save-restriction
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 (widen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 (goto-char (point-min))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 (beginning-of-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 (setq r (* (read (current-buffer)) 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 g (* (read (current-buffer)) 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 b (* (read (current-buffer)) 256)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 (font-warn 'color (format "No such color: %s" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 b 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 (list r g b) ))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 (defun font-hex-string-to-number (string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 "Convert STRING to an integer by parsing it as a hexadecimal number."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 (?1 . 1) (?b . 11) (?B . 11)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 (?2 . 2) (?c . 12) (?C . 12)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 (?3 . 3) (?d . 13) (?D . 13)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 (?4 . 4) (?e . 14) (?E . 14)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 (?5 . 5) (?f . 15) (?F . 15)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 (?6 . 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 (?7 . 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 (?8 . 8)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 (?9 . 9)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 (n 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 (i 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 (lim (length string)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 (while (< i lim)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 n ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 (defun font-parse-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 "Parse RGB color specification and return a list of integers (R G B).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 (let ((case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 r g b str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 (cond ((string-match "^#[0-9a-f]+$" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 ((= (length color) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 (setq r (font-hex-string-to-number (substring color 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 g (font-hex-string-to-number (substring color 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 b (font-hex-string-to-number (substring color 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182 r (* r 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 g (* g 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 b (* b 4096)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 ((= (length color) 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 (setq r (font-hex-string-to-number (substring color 1 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 g (font-hex-string-to-number (substring color 3 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188 b (font-hex-string-to-number (substring color 5 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1189 r (* r 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 g (* g 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 b (* b 256)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 ((= (length color) 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 (setq r (font-hex-string-to-number (substring color 1 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194 g (font-hex-string-to-number (substring color 4 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 b (font-hex-string-to-number (substring color 7 10))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 r (* r 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197 g (* g 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 b (* b 16)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 ((= (length color) 13)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 (setq r (font-hex-string-to-number (substring color 1 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 g (font-hex-string-to-number (substring color 5 9))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 b (font-hex-string-to-number (substring color 9 13))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 (font-warn 'color (format "Invalid RGB color specification: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 b 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 (> (- (match-end 2) (match-beginning 2)) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 (> (- (match-end 3) (match-beginning 3)) 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 (error "Invalid RGB color specification: %s" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 (setq str (match-string 1 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 r (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 (expt 16 (- 4 (length str))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 str (match-string 2 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 g (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 (expt 16 (- 4 (length str))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 str (match-string 3 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 b (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 (expt 16 (- 4 (length str)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 (font-warn 'html (format "Invalid RGB color specification: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 b 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 (list r g b) ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1232 (defun font-rgb-color-p (obj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 (or (and (vectorp obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 (= (length obj) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 (eq (aref obj 0) 'rgb))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1237 (defun font-rgb-color-red (obj) (aref obj 1))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1238 (defun font-rgb-color-green (obj) (aref obj 2))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1239 (defun font-rgb-color-blue (obj) (aref obj 3))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 (defun font-color-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 "Return the RGB components of COLOR as a list of integers (R G B).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 16-bit values are always returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 into their components.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 RGB values for color names are looked up in the rgb.txt file.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 The variable x-library-search-path is use to locate the rgb.txt file."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 (let ((case-fold-search t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 ((and (font-rgb-color-p color) (floatp (aref color 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 (list (* 65535 (aref color 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 (* 65535 (aref color 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 (* 65535 (aref color 2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 ((font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 (list (font-rgb-color-red color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 (font-rgb-color-green color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 (font-rgb-color-blue color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 ((and (vectorp color) (= 3 (length color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 (list (aref color 0) (aref color 1) (aref color 2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 ((and (listp color) (= 3 (length color)) (floatp (car color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 (mapcar #'(lambda (x) (* x 65535)) color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 ((and (listp color) (= 3 (length color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 ((or (string-match "^#" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265 (string-match "^rgb:" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 (font-parse-rgb-components color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 (let ((r (string-to-number (match-string 1 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 (g (string-to-number (match-string 2 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 (b (string-to-number (match-string 3 color))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 (if (floatp r)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 (setq r (round (* 255 r))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 g (round (* 255 g))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 b (round (* 255 b))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 (font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 (font-lookup-rgb-components color)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1280 (defun font-tty-compute-color-delta (col1 col2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 (+
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 (* (- (aref col1 0) (aref col2 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 (- (aref col1 0) (aref col2 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 (* (- (aref col1 1) (aref col2 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 (- (aref col1 1) (aref col2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 (* (- (aref col1 2) (aref col2 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 (- (aref col1 2) (aref col2 2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 (defun font-tty-find-closest-color (r g b)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 ;; This is basically just a lisp copy of allocate_nearest_color
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 ;; from objects-x.c from Emacs 19
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 ;; We really should just check tty-color-list, but unfortunately
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 ;; that does not include any RGB information at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 ;; So for now we just hardwire in the default list and call it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 ;; good for now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 (setq r (/ r 65535.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 g (/ g 65535.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 b (/ b 65535.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 (let* ((color_def (vector r g b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 (colors [([1.0 1.0 1.0] . "white")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 ([0.0 1.0 1.0] . "cyan")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 ([1.0 0.0 1.0] . "magenta")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 ([0.0 0.0 1.0] . "blue")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 ([1.0 1.0 0.0] . "yellow")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 ([0.0 1.0 0.0] . "green")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 ([1.0 0.0 0.0] . "red")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 ([0.0 0.0 0.0] . "black")])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 (no_cells (length colors))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 (x 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 (nearest 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 (nearest_delta 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 (trial_delta 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 color_def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 (while (/= no_cells x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 (setq trial_delta (font-tty-compute-color-delta (car (aref colors x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 color_def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 (if (< trial_delta nearest_delta)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 (setq nearest x
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 nearest_delta trial_delta))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 (setq x (1+ x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 (cdr-safe (aref colors nearest))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 (defun font-normalize-color (color &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 "Return an RGB tuple, given any form of input. If an error occurs, black
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 is returned."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 (case (device-type device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 ((x pm)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 (mswindows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 (let* ((rgb (font-color-rgb-components color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 (color (apply 'format "#%02x%02x%02x" rgb)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 (tty
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 (ns
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1338 (let ((vals (mapcar #'(lambda (x) (lsh x -8))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 (font-color-rgb-components color))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 (apply 'format "RGB%02x%02x%02xff" vals)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 (otherwise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 (defun font-set-face-background (&optional face color &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 ((or (font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 (string-match "^#[0-9a-fA-F]+$" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 (apply 'set-face-background face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 (font-normalize-color color) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 (apply 'set-face-background face color args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 (error nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 (defun font-set-face-foreground (&optional face color &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 ((or (font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 (string-match "^#[0-9a-fA-F]+$" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 (apply 'set-face-foreground face (font-normalize-color color) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 (apply 'set-face-foreground face color args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 (error nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 ;;; Support for 'blinking' fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 (defun font-map-windows (func &optional arg frame)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 (let* ((start (selected-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 (cur start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 (result nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 (push (funcall func start arg) result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 (while (not (eq start (setq cur (next-window cur))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 (push (funcall func cur arg) result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 (defun font-face-visible-in-window-p (window face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 (let ((st (window-start window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 (nd (window-end window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 (found nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 (face-at nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 (setq face-at (get-text-property st 'face (window-buffer window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 (setq found t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 (while (and (not found)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 (/= nd
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 (setq st (next-single-property-change
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 st 'face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 (window-buffer window) nd))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 (setq face-at (get-text-property st 'face (window-buffer window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394 (setq found t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 found))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 (defun font-blink-callback ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 ;; Optimized to never invert the face unless one of the visible windows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 ;; is showing it.
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1400 (let ((faces (face-list t))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 (obj nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 (while faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 (if (and (setq obj (face-property (car faces) 'font-specification))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 (font-blink-p obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 (memq t
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1406 (font-map-windows 'font-face-visible-in-window-p
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2685
diff changeset
1407 (car faces))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408 (invert-face (car faces)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 (pop faces))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411 (defcustom font-blink-interval 0.5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412 "How often to blink faces"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 :type 'number
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 :group 'faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 (defun font-blink-initialize ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 ((featurep 'itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 (if (get-itimer "font-blinker")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 (delete-itimer (get-itimer "font-blinker")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 (start-itimer "font-blinker" 'font-blink-callback
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 font-blink-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 font-blink-interval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 ((fboundp 'run-at-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 (cancel-function-timers 'font-blink-callback)
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 707
diff changeset
1426 (declare-fboundp (run-at-time font-blink-interval
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 707
diff changeset
1427 font-blink-interval
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 707
diff changeset
1428 'font-blink-callback)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 (provide 'font)