Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hui-epV4-b.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: hui-epV4-b.el
4 ;; SUMMARY: Support color and flashing of hyper-buttons under Epoch V4
5 ;; USAGE: Epoch Lisp Library
6 ;; KEYWORDS: faces, hypermedia
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 27-Apr-91 at 05:37:10
12 ;; LAST-MOD: 14-Apr-95 at 16:10:55 by Bob Weiner
13 ;;
14 ;; This file is part of Hyperbole.
15 ;; It is for use with Epoch, a modified version of GNU Emacs.
16 ;; Available for use and distribution under the same terms as GNU Emacs.
17 ;;
18 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
19 ;; Developed with support from Motorola Inc.
20 ;;
21 ;; DESCRIPTION:
22 ;;
23 ;; Requires Epoch 4.0a or greater.
24 ;;
25 ;; This is truly prototype code.
26 ;;
27 ;; DESCRIP-END.
28
29 (if (and (boundp 'epoch::version) (stringp epoch::version)
30 (or noninteractive (not (string-lessp epoch::version "Epoch 4"))))
31 nil
32 (error "(hui-epV4-b.el): Load only under Epoch V4 or higher."))
33
34 (load "button")
35 (require 'hui-ep-but)
36
37 (defun hproperty:background ()
38 "Returns default background color for selected frame."
39 (epoch::background))
40
41 (defun hproperty:foreground ()
42 "Returns default foreground color for selected frame."
43 (epoch::foreground))
44
45 ;;; ************************************************************************
46 ;;; Public variables
47 ;;; ************************************************************************
48
49 (defvar hproperty:item-highlight-color (foreground)
50 "Color with which to highlight list/menu selections.
51 Call (hproperty:set-item-highlight <color>) to change value.")
52
53 ;;; ************************************************************************
54 ;;; Public functions
55 ;;; ************************************************************************
56
57 (defun hproperty:but-create (&optional start-delim end-delim regexp-match)
58 "Mark all hyper-buttons in buffer as Epoch buttons, for later highlighting.
59 Will use optional strings START-DELIM and END-DELIM instead of default values.
60 If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
61 expression which matches an entire button string.
62 If REGEXP-MATCH is non-nil, only buttons matching this argument are
63 highlighted."
64 ;; Clear out Hyperbole button zones.
65 (hproperty:but-clear)
66 ;; Then recreate them.
67 (hproperty:but-create-all start-delim end-delim regexp-match))
68
69 (defun hproperty:but-clear ()
70 "Delete all Hyperbole button zones from current buffer."
71 (interactive)
72 (mapcar (function (lambda (zone)
73 (if (eq (epoch::zone-style zone) hproperty:but)
74 (epoch::delete-zone zone))))
75 (epoch::zone-list)))
76
77 (defun hproperty:cycle-but-color (&optional color)
78 "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr."
79 (interactive "sHyperbole button color: ")
80 (if (<= (epoch::number-of-colors) 2)
81 nil
82 (if color (setq hproperty:color-ptr nil))
83 (epoch::set-style-foreground
84 hproperty:but
85 (or color (car (hproperty:list-cycle
86 hproperty:color-ptr hproperty:good-colors))))
87 (hproperty:set-flash-color)
88 (redraw-display)
89 t))
90
91 (defun hproperty:but-flash ()
92 "Flash a Hyperbole button at point to indicate selection, when using Epoch."
93 (interactive)
94 (let ((ibut) (prev)
95 (start (hattr:get 'hbut:current 'lbl-start))
96 (end (hattr:get 'hbut:current 'lbl-end))
97 (b) (a))
98 (if (and start end (setq prev (epoch::button-at start)
99 ibut t))
100 (progn (if (not prev) (hproperty:but-add start end hproperty:but))
101 (setq b (and start (epoch::button-at start))))
102 (setq b (button-at (point))))
103 (if (setq a (and (epoch::buttonp b) (epoch::button-style b)))
104 (progn
105 (epoch::set-button-style b hproperty:flash-face)
106 (epoch::redisplay-screen)
107 ;; Delay before redraw button
108 (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i))))
109 (epoch::set-button-style b a)
110 (epoch::redisplay-screen)
111 ))
112 (if (and ibut (not prev)) (hproperty:but-delete start))
113 ))
114
115 (defun hproperty:set-item-highlight (&optional background foreground)
116 "Setup or reset item highlight style using optional BACKGROUND and FOREGROUND."
117 (make-local-variable 'hproperty:item-face)
118 (if (stringp background) (setq hproperty:item-highlight-color background))
119 (if (not hproperty:highlight-face)
120 (progn
121 (setq hproperty:highlight-face (make-style))
122 (set-style-foreground hproperty:highlight-face (background))
123 (set-style-underline hproperty:highlight-face nil)))
124
125 (let ((update-rolo-highlight-flag
126 (and (boundp 'rolo-highlight-face) (stylep rolo-highlight-face)
127 (or (null (style-foreground rolo-highlight-face))
128 (equal (style-foreground hproperty:highlight-face)
129 (style-foreground rolo-highlight-face))))))
130 (if (not (equal (style-background hproperty:highlight-face)
131 (get-color hproperty:item-highlight-color)))
132 (set-style-background hproperty:highlight-face
133 hproperty:item-highlight-color))
134 (and background (not (equal (style-background hproperty:highlight-face)
135 (get-color background)))
136 (set-style-background hproperty:highlight-face background))
137 (and foreground (not (equal (style-foreground hproperty:highlight-face)
138 (get-color foreground)))
139 (set-style-foreground hproperty:highlight-face foreground))
140 (setq hproperty:item-face hproperty:highlight-face)
141 (if update-rolo-highlight-flag
142 (progn
143 (set-style-background rolo-highlight-face
144 (style-background hproperty:highlight-face))
145 (set-style-foreground rolo-highlight-face
146 (style-foreground hproperty:highlight-face))
147 (set-style-font rolo-highlight-face
148 (style-font hproperty:highlight-face))
149 (set-style-underline rolo-highlight-face
150 (style-underline hproperty:highlight-face))))))
151
152 (defun hproperty:select-item (&optional pnt)
153 "Select item in current buffer at optional position PNT using hproperty:item-face."
154 (or hproperty:item-button
155 (setq hproperty:item-button (add-button (point) (point) hproperty:item-face)))
156 (if pnt (goto-char pnt))
157 (skip-chars-forward " \t")
158 (skip-chars-backward "^ \t\n")
159 (let ((start (point)))
160 (save-excursion
161 (skip-chars-forward "^ \t\n")
162 (move-button hproperty:item-button start (point))
163 ))
164 (epoch::redisplay-screen)
165 )
166
167 (defun hproperty:select-line (&optional pnt)
168 "Select line in current buffer at optional position PNT using hproperty:item-face."
169 (or hproperty:item-button
170 (setq hproperty:item-button (add-button (point) (point) hproperty:item-face)))
171 (if pnt (goto-char pnt))
172 (save-excursion
173 (beginning-of-line)
174 (move-button hproperty:item-button (point) (progn (end-of-line) (point)))
175 )
176 (epoch::redisplay-screen)
177 )
178
179 ;;; ************************************************************************
180 ;;; Private functions
181 ;;; ************************************************************************
182
183 (defun hproperty:set-flash-color ()
184 "Set button flashing colors based upon current color set."
185 (if (<= (epoch::number-of-colors) 2)
186 nil
187 (epoch::set-style-background hproperty:flash-face (hproperty:but-color))
188 (epoch::set-style-foreground hproperty:flash-face (hproperty:background))
189 ))
190
191 ;;; ************************************************************************
192 ;;; Private variables
193 ;;; ************************************************************************
194
195 (defvar hproperty:but (epoch::make-style) "Style for hyper-buttons.")
196 (epoch::set-style-foreground hproperty:but (hproperty:but-color))
197 (epoch::set-style-background hproperty:but (hproperty:background))
198
199 (defvar hproperty:flash-face (epoch::make-style)
200 "Style for flashing hyper-buttons.")
201 (hproperty:set-flash-color)
202
203 (defvar hproperty:item-button nil
204 "Button used to highlight an item in a listing buffer.")
205 (make-variable-buffer-local 'hproperty:item-button)
206 (defvar hproperty:item-face nil "Style for item marking.")
207 (defvar hproperty:highlight-face nil
208 "Item highlighting face. Use (hproperty:set-item-highlight) to set.")
209 (if hproperty:highlight-face
210 nil
211 ;; Reverse foreground and background colors for default block-style highlighting.
212 (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background)))
213
214 (provide 'hui-epV4-b)