Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 110:fe104dbd9147 r20-1b7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b7
author cvs
date Mon, 13 Aug 2007 09:19:45 +0200
parents 360340f9fd5f
children 8619ce7e4c50
comparison
equal deleted inserted replaced
109:e183fc049578 110:fe104dbd9147
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/03/03 15:15:42 3 ;; Created: 1997/03/10 15:18:19
4 ;; Version: 1.34 4 ;; Version: 1.36
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
975 g 0 975 g 0
976 b 0))) 976 b 0)))
977 (list r g b) )) 977 (list r g b) ))
978 978
979 (defsubst font-rgb-color-p (obj) 979 (defsubst font-rgb-color-p (obj)
980 (and (vectorp obj) 980 (or (and (vectorp obj)
981 (= (length obj) 4) 981 (= (length obj) 4)
982 (eq (aref obj 0) 'rgb))) 982 (eq (aref obj 0) 'rgb))
983 (string-match "^#[0-9a-fA-F]+$" obj)))
983 984
984 (defsubst font-rgb-color-red (obj) (aref obj 1)) 985 (defsubst font-rgb-color-red (obj) (aref obj 1))
985 (defsubst font-rgb-color-green (obj) (aref obj 2)) 986 (defsubst font-rgb-color-green (obj) (aref obj 2))
986 (defsubst font-rgb-color-blue (obj) (aref obj 3)) 987 (defsubst font-rgb-color-blue (obj) (aref obj 3))
987 988
1070 1071
1071 (defun font-normalize-color (color &optional device) 1072 (defun font-normalize-color (color &optional device)
1072 "Return an RGB tuple, given any form of input. If an error occurs, black 1073 "Return an RGB tuple, given any form of input. If an error occurs, black
1073 is returned." 1074 is returned."
1074 (case (device-type device) 1075 (case (device-type device)
1075 ((x pm win32) 1076 ((x pm)
1076 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color))) 1077 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
1078 (win32
1079 (let* ((rgb (font-color-rgb-components color))
1080 (color (apply 'format "#%02x%02x%02x" rgb)))
1081 (win32-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
1082 color))
1077 (tty 1083 (tty
1078 (apply 'font-tty-find-closest-color (font-color-rgb-components color))) 1084 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
1079 (ns 1085 (ns
1080 (let ((vals (mapcar (function (lambda (x) (>> x 8))) 1086 (let ((vals (mapcar (function (lambda (x) (>> x 8)))
1081 (font-color-rgb-components color)))) 1087 (font-color-rgb-components color))))
1082 (apply 'format "RGB%02x%02x%02xff" vals))) 1088 (apply 'format "RGB%02x%02x%02xff" vals)))
1083 (otherwise "black"))) 1089 (otherwise
1090 color)))
1084 1091
1085 (defun font-set-face-background (&optional face color &rest args) 1092 (defun font-set-face-background (&optional face color &rest args)
1086 (interactive) 1093 (interactive)
1087 (condition-case nil 1094 (condition-case nil
1088 (cond 1095 (cond