cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-faces.el

   1 ;;; xwem-faces.el --- XWEM can handle Emacs faces.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;;         Steve Youngs  <steve@youngs.au.com>
   7 ;; Created: Mon Dec 29 12:04:19 MSK 2003
   8 ;; Keywords: xwem
   9 ;; X-CVS: $Id: xwem-faces.el,v 1.12 2005-04-04 19:54:11 lg Exp $
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;; Faces support.  Main purpose of `xwem-faces' is easify interface to
  33 ;; X-Gc.
  34
  35 ;;; Code:
  36 \f
  37 (require 'cus-face)                     ; for `custom-face-get-spec'
  38 (require 'xlib-xlib)
  39
  40 (require 'xwem-struct)
  41 (require 'xwem-loaddefs)
  42
  43 ;;; Customisation
  44 (defgroup xwem-faces nil
  45   "*Group to customize faces used by XWEM."
  46   :prefix "xwem-face-"
  47   :group 'xwem)
  48
  49 (defcustom xwem-background-mode-bound 72000
  50   "Number which is used to determine whether color has `dark' or `light' background mode.
  51 Normally you should'nt modify it."
  52   :type '(choice (const :tag "Default" 65536)
  53                  (const :tag "Low" 50000)
  54                  (const :tag "Medium" 72000)
  55                  (const :tag "High" 94000))
  56   :group 'xwem-faces)
  57
  58 ;;; Internal variables
  59
  60 ;;;###xwem-autoload
  61 (defun xwem-get-background-mode (color)
  62   "Return `dark' or `light' according to COLOR.
  63 COLOR is color instance, color name or list of color components."
  64   (if (< (apply '+ (or (and (listp color) color)
  65                        (color-instance-rgb-components
  66                         (or (and (color-instance-p color) color)
  67                             (make-color-instance color)))))
  68          xwem-background-mode-bound)
  69       'dark 'light))
  70
  71 ;;; TODO:
  72 ;;   - Create xwem-face widget for customisation.
  73 (define-specifier-tag 'default)
  74
  75 (defsubst xwem-face-foreground-specifier (face)
  76   (get face 'xwem-face-foreground-specifier))
  77 (defsubst xwem-face-background-specifier (face)
  78   (get face 'xwem-face-background-specifier))
  79 (defsubst xwem-face-font-specifier (face)
  80   (get face 'xwem-face-font-specifier))
  81 (defsubst xwem-face-line-style-specifier (face)
  82   (get face 'xwem-face-line-style-specifier))
  83 (defsubst xwem-face-line-width-specifier (face)
  84   (get face 'xwem-face-line-width-specifier))
  85 (defsubst xwem-face-cap-style-specifier (face)
  86   (get face 'xwem-face-cap-style-specifier))
  87 (defsubst xwem-face-join-style-specifier (face)
  88   (get face 'xwem-face-join-style-specifier))
  89 (defsubst xwem-face-function-specifier (face)
  90   (get face 'xwem-face-function-specifier))
  91 (defsubst xwem-face-subwindow-mode-specifier (face)
  92   (get face 'xwem-face-subwindow-mode-specifier))
  93 (defsubst xwem-face-graphics-exposures-specifier (face)
  94   (get face 'xwem-face-graphics-exposures-specifier))
  95
  96 (defsubst xwem-face-x-gc-specifier (face)
  97   (get face 'xwem-face-x-gc-specifier))
  98
  99 (defun xwem-face-sort-tag-set (tag-set)
 100   (sort tag-set #'(lambda (t1 t2)
 101                     (string-lessp (symbol-name t1) (symbol-name t2)))))
 102
 103 (defun xwem-custom-declare-face (face spec doc &rest args)
 104   "Define new FACE to be used in xwem.
 105 SPEC is face specification, it should be an alist in form
 106 \\((DISPLAY ATTRS) ...\\)."
 107   (unless (get face 'xwem-face-spec)
 108     (put face 'xwem-face-spec spec)
 109     (unless (find-face face)
 110       (make-empty-face face)
 111 ;      (face-display-set face spec nil '(custom))
 112
 113       (put face 'xwem-face-font-specifier
 114            (make-specifier-and-init 'generic `((global ((default) . ,(face-font-name 'default)))) t))
 115       (put face 'xwem-face-background-specifier
 116            (make-specifier-and-init 'generic `((global ((default) . "black"))) t))
 117       (put face 'xwem-face-foreground-specifier
 118            (make-specifier-and-init 'generic `((global ((default) . "white"))) t))
 119       (put face 'xwem-face-line-style-specifier
 120            (make-specifier-and-init 'generic `((global ((default) . ,X-LineSolid))) t))
 121       (put face 'xwem-face-line-width-specifier
 122            (make-specifier-and-init 'generic `((global ((default) . 0))) t))
 123       (put face 'xwem-face-cap-style-specifier
 124            (make-specifier-and-init 'generic `((global ((default) . ,X-CapButt))) t))
 125       (put face 'xwem-face-join-style-specifier
 126            (make-specifier-and-init 'generic `((global ((default) . ,X-JoinMiter))) t))
 127       (put face 'xwem-face-function-specifier
 128            (make-specifier-and-init 'generic `((global ((default) . ,X-GXCopy))) t))
 129       (put face 'xwem-face-subwindow-mode-specifier
 130            (make-specifier-and-init 'generic `((global ((default) . ,X-ClipByChildren))) t))
 131       (put face 'xwem-face-graphics-exposures-specifier
 132            (make-specifier-and-init 'generic `((global ((default) . ,X-False))) t))
 133
 134       (put face 'xwem-face-x-gc-specifier
 135            (make-specifier 'generic))
 136
 137       ;; Setup face
 138       (let (tag-set tag-set-plist tval font)
 139         (while spec
 140           (setq tag-set (caar spec))
 141           (setq tag-set-plist (cadr (car spec)))
 142           (cond ((eq tag-set t)
 143                  (setq tag-set '(default)))
 144                 ((listp tag-set)
 145                  ;; Define new tags
 146                  (setq tag-set (xwem-face-sort-tag-set tag-set))
 147                  (mapc 'define-specifier-tag tag-set))
 148                 (t (error 'xwem-error "Inavild TAG-SET specification")))
 149
 150           ;; Setup face params
 151           (when (setq tval (plist-get tag-set-plist :foreground))
 152             (add-spec-list-to-specifier (xwem-face-foreground-specifier face)
 153                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 154           (when (setq tval (plist-get tag-set-plist :background))
 155             (add-spec-list-to-specifier (xwem-face-background-specifier face)
 156                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 157
 158           ;; Play with font
 159           ;;; Old stuff commented out, because of limitations
 160 ;          (unless (setq font (plist-get tag-set-plist :font))
 161 ;            (setq font (face-font-name 'default)))
 162 ;          (if (plist-get tag-set-plist :bold)
 163 ;              (setq font (or (x-make-font-bold font) font))
 164 ;            (setq font (or (x-make-font-unbold font) font)))
 165 ;          (if (plist-get tag-set-plist :italic)
 166 ;              (setq font (or (x-make-font-italic font) font))
 167 ;            (setq font (or (x-make-font-unitalic font) font)))
 168
 169           (unless (setq font (plist-get tag-set-plist :font))
 170             (setq font (face-font-name 'default)))
 171           (when font
 172             (set-face-font face font))
 173           (flet ((booleanp (arg) (or (eq arg t) (null arg))))
 174             (mapc #'(lambda (kw-pre)
 175                       (let* ((kw (car kw-pre))
 176                              (kv (assq kw custom-face-attributes))
 177                              (rv (plist-get tag-set-plist kw)))
 178                         (when (and kv (funcall (cadr kw-pre) rv))
 179                           (funcall (caddr kv) face rv))))
 180                   '((:size numberp) (:family stringp) (:dim booleanp)
 181                     (:bold booleanp) (:italic booleanp) (:underline booleanp))))
 182           (setq font (face-font-name face))
 183           (add-spec-list-to-specifier (xwem-face-font-specifier face)
 184                                       `((global ,(cons tag-set font))) 'remove-tag-set-prepend)
 185
 186           ;; Other params
 187           (when (setq tval (plist-get tag-set-plist :line-style))
 188             (add-spec-list-to-specifier (xwem-face-line-style-specifier face)
 189                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 190           (when (setq tval (plist-get tag-set-plist :line-width))
 191             (add-spec-list-to-specifier (xwem-face-line-width-specifier face)
 192                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 193           (when (setq tval (plist-get tag-set-plist :cap-style))
 194             (add-spec-list-to-specifier (xwem-face-cap-style-specifier face)
 195                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 196           (when (setq tval (plist-get tag-set-plist :join-style))
 197             (add-spec-list-to-specifier (xwem-face-join-style-specifier face)
 198                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 199           (when (setq tval (plist-get tag-set-plist :function))
 200             (add-spec-list-to-specifier (xwem-face-function-specifier face)
 201                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 202           (when (setq tval (plist-get tag-set-plist :subwindow-mode))
 203             (add-spec-list-to-specifier (xwem-face-subwindow-mode-specifier face)
 204                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 205           (when (setq tval (plist-get tag-set-plist :graphics-exposures))
 206             (add-spec-list-to-specifier (xwem-face-graphics-exposures-specifier face)
 207                                         `((global ,(cons tag-set tval))) 'remove-tag-set-prepend))
 208
 209           (setq spec (cdr spec))))
 210
 211       (unless (and doc (not (face-doc-string face)))
 212         (set-face-doc-string face doc))
 213       (custom-handle-all-keywords face args 'custom-face)
 214       face)))
 215
 216 (defmacro define-xwem-face (face spec doc &rest args)
 217   "Define new xwem face."
 218   `(xwem-custom-declare-face (quote ,face) ,spec ,doc ,@args))
 219
 220 (defun xwem-copy-face (old-face new-face)
 221   "Create NEW-FACE as copy of OLD-FACE."
 222   (xwem-custom-declare-face new-face (get old-face 'xwem-face-spec)
 223     (format "Copy of `%S' face." (face-name old-face)))
 224   )
 225
 226 (define-xwem-face xwem-face-white
 227   `((t (:foreground "white" :background "black")))
 228   "White color face."
 229   :group 'xwem-faces)
 230
 231 (define-xwem-face xwem-face-black
 232   `((t (:foreground "black" :background "black")))
 233   "Black color face."
 234   :group 'xwem-faces)
 235
 236 (define-xwem-face xwem-face-red
 237   `((t (:foreground "red" :background "black")))
 238   "Red color face."
 239   :group 'xwem-faces)
 240
 241 (define-xwem-face xwem-face-green
 242   `((t (:foreground "green" :background "black")))
 243   "Green color face."
 244   :group 'xwem-faces)
 245
 246 (define-xwem-face xwem-face-blue
 247   `((t (:foreground "blue" :background "black")))
 248   "Blue color face."
 249   :group 'xwem-faces)
 250
 251 (define-xwem-face xwem-face-yellow
 252   `((t (:foreground "yellow" :background "black")))
 253   "Yellow color face."
 254   :group 'xwem-faces)
 255
 256 (define-xwem-face xwem-face-cyan
 257   `((t (:foreground "cyan" :background "black")))
 258   "Cyan color face."
 259   :group 'xwem-faces)
 260
 261 (define-xwem-face xwem-face-magenta
 262   `((t (:foreground "magenta" :background "black")))
 263   "Magenta color face."
 264   :group 'xwem-faces)
 265
 266 (define-xwem-face xwem-face-darkgray
 267   `((t (:foreground "gray20" :background "black")))
 268   "DarkGray color face."
 269   :group 'xwem-faces)
 270
 271 (define-xwem-face xwem-face-lightgray
 272   `((t (:foreground "gray80" :background "black")))
 273   "LightGray color face."
 274   :group 'xwem-faces)
 275
 276 (define-xwem-face xwem-face-gray
 277   `((t (:foreground "gray50" :background "black")))
 278   "Gray color face."
 279   :group 'xwem-faces)
 280
 281 (define-xwem-face xwem-face-outline1
 282   `((t (:foreground "red" :background "black")))
 283   "Face used to outline something."
 284   :group 'xwem-faces)
 285
 286 (define-xwem-face xwem-face-outline2
 287   `((t (:foreground "blue" :background "black")))
 288   "Face used to outline something."
 289   :group 'xwem-faces)
 290
 291 (define-xwem-face xwem-face-outline3
 292   `((t (:foreground "cyan" :background "black")))
 293   "Face used to outline something."
 294   :group 'xwem-faces)
 295
 296 \f
 297 (defun xwem-face-get-domain-face (face &optional domain)
 298   "Adjust FACE using DOMAIN."
 299   (cond ((null domain)
 300          (or (and (xwem-cl-selected)
 301                   (xwem-face-get-domain-face face (xwem-cl-selected)))
 302              face))
 303         ((xwem-cl-p domain)
 304          (or (cdr (assq face (xwem-cl-get-sys-prop domain 'domain-faces)))
 305              (and (xwem-cl-win domain)
 306                   (xwem-face-get-domain-face face (xwem-cl-win domain)))))
 307         ((xwem-win-p domain)
 308          (or (cdr (assq face (xwem-win-get-prop domain 'domain-faces)))
 309              (xwem-face-get-domain-face face (xwem-win-frame domain))))
 310         ((xwem-frame-p domain)
 311          (cdr (assq face (xwem-frame-get-prop domain 'domain-faces))))
 312         ((eq domain 'nodomain) face)
 313         (t (error 'xwem-error "Invalid domain" domain))))
 314
 315 ;;; Functions
 316 (defun xwem-face-generic-specifier (face spcname &optional tag-set domain)
 317   "Return FACE's SPCNAME specifier value in TAG-SET.
 318 SPCNAME is one of 'foreground, 'background, 'font, 'line-style,
 319 'line-width, 'cap-style, 'join-style, 'function, 'subwindow-mode,
 320 'graphics-exposures or 'x-gc.
 321 DOMAIN is either xwem window, xwem client or xwem frame."
 322   (if (and tag-set (listp tag-set))
 323       (setq tag-set (xwem-face-sort-tag-set tag-set))
 324     (setq tag-set '(default)))
 325
 326   ;; Adjust face according to DOMAIN, for get operation
 327   (setq face (or (xwem-face-get-domain-face face domain)
 328                  face))
 329
 330   (let* ((fn (cond ((eq spcname 'foreground) 'xwem-face-foreground-specifier)
 331                    ((eq spcname 'background) 'xwem-face-background-specifier)
 332                    ((eq spcname 'font) 'xwem-face-font-specifier)
 333                    ((eq spcname 'line-style) 'xwem-face-line-style-specifier)
 334                    ((eq spcname 'line-width) 'xwem-face-line-width-specifier)
 335                    ((eq spcname 'cap-style) 'xwem-face-cap-style-specifier)
 336                    ((eq spcname 'join-style) 'xwem-face-join-style-specifier)
 337                    ((eq spcname 'function) 'xwem-face-function-specifier)
 338                    ((eq spcname 'subwindow-mode) 'xwem-face-subwindow-mode-specifier)
 339                    ((eq spcname 'graphics-exposures) 'xwem-face-graphics-exposures-specifier)
 340                    ((eq spcname 'x-gc) 'xwem-face-x-gc-specifier)
 341                    (t (error 'xwem-error "Invalid SPCNAME" spcname))))
 342          (spec (funcall fn face)))
 343     (when (specifierp spec)
 344       (setq spec (specifier-spec-list spec nil tag-set t))
 345       (cdr (car (cdr (car spec)))))))
 346
 347 ;; Getters
 348 (defsubst xwem-face-foreground (face &optional tag-set domain)
 349   "Return FACE foreground color in TAG-SET."
 350   (or (xwem-face-generic-specifier face 'foreground tag-set domain)
 351       (xwem-face-generic-specifier face 'foreground)
 352       (face-foreground-name face)))
 353 (defsubst xwem-face-background (face &optional tag-set domain)
 354   "Return FACE background color in TAG-SET."
 355   (or (xwem-face-generic-specifier face 'background tag-set domain)
 356       (xwem-face-generic-specifier face 'background)
 357       (face-background-name face)))
 358 (defsubst xwem-face-font (face &optional tag-set domain)
 359   "Return FACE font in TAG-SET."
 360   (or (xwem-face-generic-specifier face 'font tag-set domain)
 361       (xwem-face-generic-specifier face 'font)
 362       (face-font-name face)))
 363 (defsubst xwem-face-line-style (face &optional tag-set domain)
 364   "Return FACE's line style in TAG-SET."
 365   (or (xwem-face-generic-specifier face 'line-style tag-set domain)
 366       (xwem-face-generic-specifier face 'line-style)))
 367 (defsubst xwem-face-line-width (face &optional tag-set domain)
 368   "Return FACE's line width TAG-SET."
 369   (or (xwem-face-generic-specifier face 'line-width tag-set domain)
 370       (xwem-face-generic-specifier face 'line-width)))
 371 (defsubst xwem-face-cap-style (face &optional tag-set domain)
 372   "Return FACE's cap style in TAG-SET."
 373   (or (xwem-face-generic-specifier face 'cap-style tag-set domain)
 374       (xwem-face-generic-specifier face 'cap-style)))
 375 (defsubst xwem-face-join-style (face &optional tag-set domain)
 376   "Return FACE's join style in TAG-SET."
 377   (or (xwem-face-generic-specifier face 'join-style tag-set domain)
 378       (xwem-face-generic-specifier face 'join-style)))
 379 (defsubst xwem-face-function (face &optional tag-set domain)
 380   "Return FACE's function in TAG-SET."
 381   (or (xwem-face-generic-specifier face 'function tag-set domain)
 382       (xwem-face-generic-specifier face 'function)))
 383 (defsubst xwem-face-subwindow-mode (face &optional tag-set domain)
 384   "Return FACE's cap style in TAG-SET."
 385   (or (xwem-face-generic-specifier face 'subwindow-mode tag-set domain)
 386       (xwem-face-generic-specifier face 'subwindow-mode)))
 387 (defsubst xwem-face-graphics-exposures (face &optional tag-set domain)
 388   "Return FACE's graphics exposures in TAG-SET."
 389   (or (xwem-face-generic-specifier face 'graphics-exposures tag-set domain)
 390       (xwem-face-generic-specifier face 'graphics-exposures)
 391       X-False))
 392
 393 (defsubst xwem-face-x-gc (face &optional tag-set domain)
 394   "Return FACE's X-Gc in TAG-SET."
 395   (or (face-property face (xwem-face-generic-specifier face 'x-gc tag-set domain))
 396       (face-property face 'xwem-x-gc)))
 397
 398 ;; Setters
 399 (defun xwem-face-set-domain-face (face &optional domain)
 400   (cond ((null domain) (xwem-face-get-domain-face face))
 401         ((xwem-cl-p domain)
 402          (or (cdr (assq face (xwem-cl-get-sys-prop domain 'domain-faces)))
 403              (let ((nface (intern (symbol-name (gensym "xwem-cl-domain-face")))))
 404                (xwem-cl-put-sys-prop domain 'domain-faces
 405                  (cons (cons face (xwem-copy-face face nface))
 406                        (xwem-cl-get-sys-prop domain 'domain-faces)))
 407                nface)))
 408         ((xwem-win-p domain)
 409          (or (cdr (assq face (xwem-win-get-prop domain 'domain-faces)))
 410              (let ((nface (intern (symbol-name (gensym "xwem-win-domain-face")))))
 411                (xwem-win-put-prop domain 'domain-faces
 412                  (cons (cons face (xwem-copy-face face nface))
 413                        (xwem-win-get-prop domain 'domain-faces)))
 414                nface)))
 415         ((xwem-frame-p domain)
 416          (or (cdr (assq face (xwem-frame-get-prop domain 'domain-faces)))
 417              (let ((nface (intern (symbol-name (gensym "xwem-frame-domain-face")))))
 418                (xwem-frame-put-prop domain 'domain-faces
 419                  (cons (cons face (xwem-copy-face face nface))
 420                        (xwem-frame-get-prop domain 'domain-faces)))
 421                nface)))
 422         ((eq domain 'nodomain) face)
 423         (t (error 'xwem-error "Invalid domain" domain))))
 424
 425 (defun xwem-face-set-generic-specifier (face spcname value &optional tag-set domain)
 426   "Set FACE's SPCNAME specifier to VALUE in TAG-SET."
 427   (if (and tag-set (listp tag-set))
 428       (setq tag-set (xwem-face-sort-tag-set tag-set))
 429     (setq tag-set '(default)))
 430
 431   ;; Adjust face according to DOMAIN, for set operation
 432   (setq face (or (xwem-face-set-domain-face face domain) face))
 433
 434   (let* ((fn (cond ((eq spcname 'foreground) 'xwem-face-foreground-specifier)
 435                   ((eq spcname 'background) 'xwem-face-background-specifier)
 436                   ((eq spcname 'font) 'xwem-face-font-specifier)
 437                   ((eq spcname 'line-style) 'xwem-face-line-style-specifier)
 438                   ((eq spcname 'line-width) 'xwem-face-line-width-specifier)
 439                   ((eq spcname 'cap-style) 'xwem-face-cap-style-specifier)
 440                   ((eq spcname 'join-style) 'xwem-face-join-style-specifier)
 441                   ((eq spcname 'function) 'xwem-face-function-specifier)
 442                   ((eq spcname 'subwindow-mode) 'xwem-face-subwindow-mode-specifier)
 443                   ((eq spcname 'graphics-exposures) 'xwem-face-graphics-exposures-specifier)
 444                   ((eq spcname 'x-gc) 'xwem-face-x-gc-specifier)
 445                   (t (error 'xwem-error "Invalid SPCNAME" spcname))))
 446         (spec (funcall fn face))
 447         xgc)
 448
 449     (if (specifierp spec)
 450         ;; Update specifier
 451         (add-spec-list-to-specifier spec `((global ,(cons tag-set value)))
 452                                     'remove-tag-set-prepend)
 453
 454       ;; Or update face directly (non xwem face)
 455       (cond ((eq spcname 'foreground)
 456              (set-face-foreground face value))
 457             ((eq spcname 'background)
 458              (set-face-background face value))
 459             ((eq spcname 'font)
 460              (set-face-font face value))))
 461
 462     ;; Update X Gc if needed
 463     (when (and (not (eq spcname 'x-gc))
 464                (setq xgc (xwem-face-x-gc face tag-set 'nodomain)))
 465       (cond ((eq spcname 'foreground)
 466                ;; Free color, is this really needed?
 467 ;               (XFreeColors (xwem-dpy) (XDefaultColormap (xwem-dpy)) (list (X-Gc-foreground xgc)) 0)
 468              (setf (X-Gc-foreground xgc)
 469                    (XAllocColor (xwem-dpy) (XDefaultColormap (xwem-dpy))
 470                                 (xwem-make-color value))))
 471
 472             ((eq spcname 'background)
 473              ;; Free color, is this really needed?
 474 ;               (XFreeColors (xwem-dpy) (XDefaultColormap (xwem-dpy)) (list (X-Gc-background xgc)) 0)
 475              (setf (X-Gc-background xgc)
 476                    (XAllocColor (xwem-dpy) (XDefaultColormap (xwem-dpy))
 477                                 (xwem-make-color value))))
 478
 479             ((eq spcname 'font)
 480              (setf (X-Gc-font xgc) (X-Font-get (xwem-dpy) value)))
 481             ((eq spcname 'line-style)
 482              (setf (X-Gc-line-style xgc) value))
 483             ((eq spcname 'line-width)
 484              (setf (X-Gc-line-width xgc) value))
 485             ((eq spcname 'cap-style)
 486              (setf (X-Gc-cap-style xgc) value))
 487             ((eq spcname 'join-style)
 488              (setf (X-Gc-join-style xgc) value))
 489             ((eq spcname 'function)
 490              (setf (X-Gc-function xgc) value))
 491             ((eq spcname 'subwindow-mode)
 492              (setf (X-Gc-subwindow-mode xgc) value))
 493             ((eq spcname 'graphics-exposures)
 494              (setf (X-Gc-graphics-exposures xgc) value)))
 495       (XChangeGC (xwem-dpy) xgc))
 496     ))
 497
 498 (defsubst xwem-set-face-foreground (face new-fg &optional tag-set domain)
 499   "Set FACE's foreground color to NEW-FG in TAG-SET."
 500   (xwem-face-set-generic-specifier face 'foreground new-fg tag-set domain))
 501 (defsubst xwem-set-face-background (face new-bg &optional tag-set domain)
 502   "Set FACE's background color to NEW-FG in TAG-SET."
 503   (xwem-face-set-generic-specifier face 'background new-bg tag-set domain))
 504 (defsubst xwem-set-face-font (face new-font &optional tag-set domain)
 505   "Set FACE's font to NEW-FG in TAG-SET."
 506   (xwem-face-set-generic-specifier face 'font new-font tag-set domain))
 507 (defsubst xwem-set-face-line-style (face new-ls &optional tag-set domain)
 508   "Set FACE's line style to NEW-FG in TAG-SET."
 509   (xwem-face-set-generic-specifier face 'line-style new-ls tag-set domain))
 510 (defsubst xwem-set-face-line-width (face new-lw &optional tag-set domain)
 511   "Set FACE's line width to NEW-FG in TAG-SET."
 512   (xwem-face-set-generic-specifier face 'line-width new-lw tag-set domain))
 513 (defsubst xwem-set-face-cap-style (face new-cs &optional tag-set domain)
 514   "Set FACE's cap style to NEW-FG in TAG-SET."
 515   (xwem-face-set-generic-specifier face 'cap-style new-cs tag-set domain))
 516 (defsubst xwem-set-face-join-style (face new-js &optional tag-set domain)
 517   "Set FACE's join style to NEW-FG in TAG-SET."
 518   (xwem-face-set-generic-specifier face 'join-style new-js tag-set domain))
 519 (defsubst xwem-set-face-function (face new-fun &optional tag-set domain)
 520   "Set FACE's function to NEW-FG in TAG-SET."
 521   (xwem-face-set-generic-specifier face 'function new-fun tag-set domain))
 522 (defsubst xwem-set-face-subwindow-mode (face new-sm &optional tag-set domain)
 523   "Set FACE's subwindow mode to NEW-FG in TAG-SET."
 524   (xwem-face-set-generic-specifier face 'subwindow-mode new-sm tag-set domain))
 525 (defsubst xwem-set-face-graphics-exposures (face new-ge &optional tag-set domain)
 526   "Set FACE's graphics exposures to NEW-FG in TAG-SET."
 527   (xwem-face-set-generic-specifier face 'graphics-exposures new-ge tag-set domain))
 528
 529 ;; Font attributes
 530 (defun xwem-set-face-font-attribute (face attr-fun value &optional tag-set domain)
 531   (let ((font (xwem-face-font face tag-set domain)))
 532     (set-face-font face font)
 533     (funcall attr-fun face value)
 534     (xwem-set-face-font face (face-font-name face) tag-set domain)))
 535 (defsubst xwem-set-face-font-family (face font-family &optional tag-set domain)
 536   "Set FACE's font famility to FONT-FAMILY in TAG-SET of DOMAIN."
 537   (xwem-set-face-font-attribute face 'custom-set-face-font-family font-family
 538                                 tag-set domain))
 539 (defsubst xwem-set-face-font-size (face font-size &optional tag-set domain)
 540   "Set FACE's font famility to FONT-FAMILY in TAG-SET of DOMAIN."
 541   (xwem-set-face-font-attribute face 'custom-set-face-font-size font-size
 542                                 tag-set domain))
 543 (defsubst xwem-set-face-bold (face bold-p &optional tag-set domain)
 544   "Set bold FACE's attribute to BOLD-P in TAG-SET of DOMAIN."
 545   (xwem-set-face-font-attribute face 'custom-set-face-bold bold-p
 546                                 tag-set domain))
 547 (defsubst xwem-set-face-italic (face italic-p &optional tag-set domain)
 548   "Set italic FACE's attribute to ITALIC-P in TAG-SET of DOMAIN."
 549   (xwem-set-face-font-attribute face 'custom-set-face-italic italic-p
 550                                 tag-set domain))
 551
 552 (defsubst xwem-set-face-x-gc (face new-gc &optional tag-set domain)
 553   "Set FACE's X-Gc to NEW-FG in TAG-SET."
 554   ;; NOTE: Ugly thing, we can't store NEW-GC directly in specifier,
 555   ;; because it uses `copy-tree' to ensure to not share sequence.  So
 556   ;; workaround is to create unique FACE property, which will store
 557   ;; our NEW-GC and specifier will store property name.
 558   (if (specifierp (xwem-face-x-gc-specifier face))
 559       (let ((sym (gensym "*xwem-x-gc-")))
 560         (set-face-property face sym new-gc)
 561         (xwem-face-set-generic-specifier face 'x-gc sym tag-set domain))
 562
 563     ;; No, specifier, it mean that FACE is normal emacs face, not
 564     ;; defined by `define-xwem-face'.
 565     (set-face-property face 'xwem-x-gc new-gc)))
 566
 567 ;;;###xwem-autoload
 568 (defun xwem-face-get-gc (face &optional tag-set domain d)
 569   "Return X-Gc for FACE in TAG-SET.
 570 D    - X drawable default is `XDefaultRootWindow'."
 571   (setq face (or (xwem-face-get-domain-face face domain) face))
 572
 573   (or (xwem-face-x-gc face tag-set 'nodomain)
 574       (let* ((xdpy (xwem-dpy))
 575              (cmap (XDefaultColormap xdpy))
 576              (gc (XCreateGC
 577                   xdpy (or (and (X-Drawable-p d) d)
 578                            (XDefaultRootWindow xdpy))
 579                   (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy)
 580                              :line-style (xwem-face-line-style face tag-set 'nodomain)
 581                              :line-width (xwem-face-line-width face tag-set 'nodomain)
 582                              :cap-style (xwem-face-cap-style face tag-set 'nodomain)
 583                              :join-style (xwem-face-join-style face tag-set 'nodomain)
 584                              :function (xwem-face-function face tag-set 'nodomain)
 585                              :subwindow-mode (xwem-face-subwindow-mode face tag-set 'nodomain)
 586                              :graphics-exposures (xwem-face-graphics-exposures face tag-set 'nodomain)
 587                              :foreground (let ((fc (xwem-face-foreground face tag-set 'nodomain)))
 588                                            (if (stringp fc)
 589                                                (XAllocColor xdpy cmap (xwem-make-color fc))
 590                                              fc))
 591                              :background (let ((bc (xwem-face-background face tag-set 'nodomain)))
 592                                            (if (stringp bc)
 593                                                (XAllocColor xdpy cmap (xwem-make-color bc))
 594                                              bc))
 595                              :font (X-Font-get xdpy (xwem-face-font face tag-set 'nodomain))))))
 596         (xwem-set-face-x-gc face gc tag-set 'nodomain)
 597         gc)))
 598
 599 (put 'xwem-face-get-gc 'lisp-indent-function 1)
 600
 601 \f
 602 (provide 'xwem-faces)
 603
 604 ;;; xwem-faces.el ends here