From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Miles Bader Newsgroups: gmane.emacs.devel Subject: Re: face-remapping-alist client code Date: Mon, 02 Jun 2008 22:13:18 +0900 Message-ID: <87zlq4yo7l.fsf@catnip.gol.com> References: <611w3gcesf.fsf@fencepost.gnu.org> Reply-To: Miles Bader NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1212412443 1796 80.91.229.12 (2 Jun 2008 13:14:03 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 2 Jun 2008 13:14:03 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Mon Jun 02 15:14:41 2008 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1K39rl-0002MP-I1 for ged-emacs-devel@m.gmane.org; Mon, 02 Jun 2008 15:14:25 +0200 Original-Received: from localhost ([127.0.0.1]:43019 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1K39qz-0000fD-80 for ged-emacs-devel@m.gmane.org; Mon, 02 Jun 2008 09:13:37 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1K39qt-0000dL-SF for emacs-devel@gnu.org; Mon, 02 Jun 2008 09:13:31 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1K39qs-0000at-3t for emacs-devel@gnu.org; Mon, 02 Jun 2008 09:13:31 -0400 Original-Received: from [199.232.76.173] (port=43586 helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1K39qr-0000ai-RD for emacs-devel@gnu.org; Mon, 02 Jun 2008 09:13:29 -0400 Original-Received: from smtp12.dentaku.gol.com ([203.216.5.74]:56000) by monty-python.gnu.org with esmtps (TLS-1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.60) (envelope-from ) id 1K39qm-0002UE-1g; Mon, 02 Jun 2008 09:13:25 -0400 Original-Received: from 218.231.108.5.eo.eaccess.ne.jp ([218.231.108.5] helo=catnip.gol.com) by smtp12.dentaku.gol.com with esmtpa (Dentaku) id 1K39qj-0003a3-9I; Mon, 02 Jun 2008 22:13:21 +0900 Original-Received: by catnip.gol.com (Postfix, from userid 1000) id 019822F3E; Mon, 2 Jun 2008 22:13:19 +0900 (JST) System-Type: i686-pc-linux-gnu In-Reply-To: <611w3gcesf.fsf@fencepost.gnu.org> (Miles Bader's message of "Mon, 02 Jun 2008 06:27:44 -0400") Original-Lines: 11 X-Virus-Scanned: ClamAV GOL (outbound) X-Abuse-Complaints: abuse@gol.com X-detected-kernel: by monty-python.gnu.org: Linux 2.6 (newer, 3) X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:98228 Archived-At: --=-=-= Here's a newer version that makes the text-scaling stuff into a minor-mode. -Miles --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=face-remap.el Content-Transfer-Encoding: quoted-printable Content-Description: face-remap.el ;;; face-remap.el --- Functions for managing `face-remapping-alist' ;; ;; Copyright (C) 2008 Free Software Foundation, Inc. ;; ;; Author: Miles Bader ;; Keywords: faces face display user commands ;; ;; This file is part of GNU Emacs. ;; ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;; ;;; Commentary: ;; ;; This file defines some simple operations that can be used for ;; maintaining the `face-remapping-alist' in a cooperative way. This is ;; especially important for the `default' face. ;; ;; Each face-remapping definition in `face-remapping-alist' added by ;; this code uses the form: ;; ;; (face RELATIVE_SPECS_1 RELATIVE_SPECS_2 ... BASE_SPECS) ;; ;; The "specs" values are a lists of face names or face attribute-value ;; pairs, and are merged together, with earlier values taking precedence. ;; ;; The RELATIVE_SPECS_* values are added by `add-relative-face-remapping' ;; (and removed by `remove-relative-face-remapping', and are intended for ;; face "modifications" (such as increasing the size). Typical users of ;; relative specs would be minor modes. ;; ;; BASE_SPECS is the lowest-priority value, and by default is just the ;; face name, which causes the global definition of that face to be used. ;; ;; A non-default value of BASE_SPECS may also be set using ;; `set-base-face-remapping'. Because this _overwrites_ the default ;; value inheriting from the global face definition, it is up to the ;; caller of set-base-face-remapping to add such inheritance if it is ;; desired. A typical use of set-base-face-remapping would be a major ;; mode setting face remappings, e.g., of the default face. ;; ;; All modifications cause face-remapping-alist to be made buffer-local. ;; ;;; Code: (defun add-relative-face-remapping (face &rest specs) "Add a face remapping entry of FACE to SPECS in the current buffer. SPECS can be any value suitable for the `face' text property, including a face name, a list of face names, or a face-attribute property list. The attributes given by SPECS will be merged with any other currently active face remappings of FACE, and with the global definition of FACE, with the most recently added relative remapping taking precedence. The base (lowest priority) remapping may be set to a specific value, instead of the default of the global face definition, using `set-base-face-remapping'. Return a cookie which can be used to delete the remapping with `remove-relative-face-remapping'." (make-local-variable 'face-remapping-alist) (let ((entry (assq face face-remapping-alist))) (when (null entry) (setq entry (list face face)) ; explicitly merge with global def (push entry face-remapping-alist)) (setcdr entry (cons specs (cdr entry))) (cons face specs))) (defun remove-relative-face-remapping (cookie) "Remove a face remapping previously added by `add-relative-face-remapping= '. COOKIE should be the return value from that function." (let ((remapping (assq (car cookie) face-remapping-alist))) (when remapping (let ((updated-entries (remq (cdr cookie) (cdr remapping)))) (unless (eq updated-entries (cdr remapping)) (setcdr remapping updated-entries) (when (or (null updated-entries) (and (eq (car-safe updated-entries) (car cookie)) (null (cdr updated-entries)))) (setq face-remapping-alist (remq remapping face-remapping-alist))) (cdr cookie)))))) (defun set-default-base-face-remapping (face) "Set the base remapping of FACE to inherit from FACE's global definition." (let ((entry (assq face face-remapping-alist))) (when entry ;; If there's nothing except a base remapping, we simply remove ;; the entire remapping entry, as setting the base to the default ;; would be the same as the global definition. Otherwise, we ;; modify the base remapping. (if (null (cddr entry)) ; nothing except base remapping (setq face-remapping-alist ; so remove entire entry (remq entry face-remapping-alist)) (setcar (last entry) face))))) ; otherwise, just inherit global def (defun set-base-face-remapping (face &rest specs) "Set the base remapping of FACE in the current buffer to SPECS. If SPECS is empty, the default base remapping is restored, which inherits from the global definition of FACE; note that this is different from SPECS containing a single value `nil', which does not inherit from the global definition of FACE." (if (or (null specs) (and (eq (car specs) face) (null (cdr specs)))) ; default ;; Set entry back to default (set-default-base-face-remapping face) ;; Set the base remapping (make-local-variable 'face-remapping-alist) (let ((entry (assq face face-remapping-alist))) (if entry (setcar (last entry) specs) ; overwrite existing base entry (push (list face specs) face-remapping-alist))))) =20=20 ;; ---------------------------------------------------------------- ;; increase-buffer-face-height and decrease-buffer-face-height (defvar text-scale-mode-step 1.2) ;; current buffer-face-height remapping cookie (defvar text-scale-mode-remapping nil) (defvar text-scale-mode-lighter "+0") (defvar text-scale-mode-amount 0) (define-minor-mode text-scale-mode "Minor mode for displaying buffer text in a larger/smaller font than usua= l. The amount of scaling is determined by the variable `text-scale-mode-amount': one step scales the global default face size by the variable `text-scale-mode-step' (a negative amount shrinks the text). The `increase-buffer-face-height' and `decrease-buffer-face-height' functions may be used to interactively modify the variable `text-scale-mode-amount' (they also enable or disable `text-scale-mode' as necessary." :lighter (" " text-scale-mode-lighter) (when text-scale-mode-remapping (remove-relative-face-remapping text-scale-mode-remapping)) (set (make-local-variable 'text-scale-mode-lighter) (format (if (>=3D text-scale-mode-amount 0) "+%d" "%d") text-scale-mode-amount)) (set (make-local-variable 'text-scale-mode-remapping) (and text-scale-mode (add-relative-face-remapping 'default :height (expt text-scale-mode-step text-scale-mode-amount)))) (force-window-update (current-buffer))) (defun increase-buffer-face-height (&optional inc) "Increase the height of the default face in the current buffer by INC ste= ps. If the new height is other than the default, `text-scale-mode' is enabled. Each step scales the default height by the variable `text-scale-mode-step' (a negative number of steps decreases the height by the same amount). As a special case, an argument of 0 will remove any scaling currently active." (interactive (list (cond ((eq current-prefix-arg '-) -1) ((numberp current-prefix-arg) current-prefix-arg) ((consp current-prefix-arg) -1) (t 1)))) (set (make-local-variable 'text-scale-mode-amount) (if (=3D inc 0) 0 (+ text-scale-mode-amount inc))) (text-scale-mode (if (zerop text-scale-mode-amount) -1 1))) (defun decrease-buffer-face-height (&optional dec) "Decrease the height of the default face in the current buffer by DEC ste= ps. See `increase-buffer-face-height' for more details." (interactive (list (cond ((eq current-prefix-arg '-) -1) ((numberp current-prefix-arg) current-prefix-arg) ((consp current-prefix-arg) -1) (t 1)))) (increase-buffer-face-height (- dec))) ;; Global bindings: ;; (global-set-key [(control =3D)] 'increase-buffer-face-height) (global-set-key [(control +)] 'increase-buffer-face-height) (global-set-key [(control -)] 'decrease-buffer-face-height) ;; ---------------------------------------------------------------- ;; variable-pitch-mode ;; current variable-pitch-mode remapping cookie (defvar variable-pitch-mode-remapping nil) (define-minor-mode variable-pitch-mode "Variable-pitch default-face mode. When active, causes the buffer text to be displayed using the `variable-pitch' face." :lighter " VarPitch" (when variable-pitch-mode-remapping (remove-relative-face-remapping variable-pitch-mode-remapping)) (set (make-local-variable 'variable-pitch-mode-remapping) (and variable-pitch-mode (add-relative-face-remapping 'default 'variable-pitch))) (force-window-update (current-buffer))) ;; suggested binding: (global-set-key "\C-cv" 'variable-pitch-mode) (provide 'face-remap) ;;; faces.el ends here --=-=-= -- Defenceless, adj. Unable to attack. --=-=-=--