comparison lisp/hyperbole/hui-xe-but.el @ 0:376386a54a3c r19-14

Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children c53a95d3c46d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: hui-xe-but.el
4 ;; SUMMARY: XEmacs button highlighting and flashing support.
5 ;; USAGE: XEmacs Lisp Library
6 ;; KEYWORDS: faces, hypermedia
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 21-Aug-92
12 ;; LAST-MOD: 24-Oct-95 at 19:55:08 by Bob Weiner
13 ;;
14 ;; This file is part of Hyperbole.
15 ;; It is for use with XEmacs, a modified version of GNU Emacs V19.
16 ;; Available for use and distribution under the same terms as GNU Emacs.
17 ;;
18 ;; Copyright (C) 1992-1995, Free Software Foundation, Inc.
19 ;; Developed with support from Motorola Inc.
20 ;;
21 ;; DESCRIPTION:
22 ;;
23 ;; This is truly prototype code.
24 ;;
25 ;; Can't use read-only buttons here because then outline-mode
26 ;; becomes unusable.
27 ;;
28 ;; DESCRIP-END.
29
30 (or hyperb:lemacs-p
31 (error "(hui-xe-but.el): Load only when running XEmacs."))
32
33 ;;; ************************************************************************
34 ;;; Other required Elisp libraries
35 ;;; ************************************************************************
36
37 (require 'hbut)
38
39 ;;; XEmacs 19.12 renamed x-color-display-p to x-display-color-p.
40 (if (and (fboundp 'x-color-display-p)
41 (not (fboundp 'x-display-color-p)))
42 (fset 'x-display-color-p 'x-color-display-p))
43
44 (defun hproperty:background ()
45 "Returns default background color for selected frame."
46 (face-background (get-face 'default)))
47
48 (defun hproperty:foreground ()
49 "Returns default foreground color for selected frame."
50 (face-foreground (get-face 'default)))
51
52 ;;; ************************************************************************
53 ;;; Public variables
54 ;;; ************************************************************************
55
56 (defvar hproperty:but-emphasize-p nil
57 "*Non-nil means visually emphasize that button under mouse cursor is selectable.")
58
59 (defvar hproperty:but-flash-time 1000
60 "*Machine specific value for empty loop counter, XEmacs button flash delay.")
61
62 (defvar hproperty:item-highlight-color (hproperty:foreground)
63 "Color with which to highlight list/menu selections.
64 Call (hproperty:set-item-highlight <color>) to change value.")
65
66 ;;; ************************************************************************
67 ;;; Public functions
68 ;;; ************************************************************************
69
70 (defun hproperty:but-add (start end face)
71 "Add between START and END a button using FACE in current buffer.
72 If 'hproperty:but-emphasize-p' is non-nil when this is called, emphasize that
73 button is selectable whenever the mouse cursor moves over it."
74 (let ((but (make-extent start end)))
75 (set-extent-face but face)
76 (set-extent-property but 'highlight hproperty:but-emphasize-p)))
77
78 (defun hproperty:but-color ()
79 "Return current color of buffer's buttons."
80 (if hproperty:color-ptr
81 (car hproperty:color-ptr)
82 (hproperty:foreground)))
83
84 (defun hproperty:but-clear ()
85 "Delete all Hyperbole buttons from current buffer."
86 (interactive)
87 (map-extents (function (lambda (extent unused-arg)
88 (if (eq (extent-face extent) 'hbut)
89 (delete-extent extent))))))
90
91 (defun hproperty:but-create (&optional start-delim end-delim regexp-match)
92 "Highlight all hyper-buttons in buffer using XEmacs extents.
93 Will use optional strings START-DELIM and END-DELIM instead of default values.
94 If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
95 expression which matches an entire button string.
96 If REGEXP-MATCH is non-nil, only buttons matching this argument are
97 highlighted.
98
99 If 'hproperty:but-emphasize-p' is non-nil when this is called, emphasize that
100 button is selectable whenever the mouse cursor moves over it."
101 (interactive)
102 (hproperty:but-clear)
103 (hproperty:but-create-all start-delim end-delim regexp-match))
104
105 (defun hproperty:but-create-all (&optional start-delim end-delim regexp-match)
106 "Mark all hyper-buttons in buffer as XEmacs buttons, for later highlighting.
107 Will use optional strings START-DELIM and END-DELIM instead of default values.
108 If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
109 expression which matches an entire button string.
110 If REGEXP-MATCH is non-nil, only buttons matching this argument are
111 highlighted."
112 (ebut:map (function (lambda (lbl start end)
113 (hproperty:but-add start end hproperty:but-face)))
114 start-delim end-delim regexp-match 'include-delims))
115
116 (defun hproperty:but-delete (&optional pos)
117 (let ((extent (extent-at (or pos (point)))))
118 (if extent (delete-extent extent))))
119
120 ;;; ************************************************************************
121 ;;; Private functions
122 ;;; ************************************************************************
123
124 (defmacro hproperty:list-cycle (list-ptr list)
125 "Move LIST-PTR to next element in LIST or when at end to first element."
126 (` (or (and (, list-ptr)
127 (setq (, list-ptr) (cdr (, list-ptr))))
128 (setq (, list-ptr) (, list)))))
129
130 ;;; ************************************************************************
131 ;;; Private variables
132 ;;; ************************************************************************
133
134 (defconst hproperty:color-list '( "red" "blue" "paleturquoise4" "mediumpurple2"
135 "lightskyblue3" "springgreen2" "salmon" "yellowgreen" "darkorchid2"
136 "aquamarine4" "slateblue4" "slateblue1" "olivedrab1" "goldenrod4"
137 "goldenrod3" "cadetblue2" "burlywood1" "slategrey" "mistyrose"
138 "limegreen" "lightcyan" "goldenrod" "gainsboro" "skyblue1" "honeydew"
139 "yellow2" "tomato3" "skyblue" "purple4" "orange3" "bisque3" "bisque2"
140 "grey34" "gray99" "gray63" "gray44" "gray37" "gray33" "gray26" "azure1"
141 "snow4" "peru" "red" "lightgoldenrod4" "mediumseagreen" "blush"
142 "mediumorchid2" "lightskyblue1" "darkslateblue" "midnightblue"
143 "lightsalmon1" "lemonchiffon" "yellow" "lightsalmon" "coral"
144 "dodgerblue3" "darkorange4" "blue" "royalblue4" "red" "green" "cyan"
145 "darkviolet" "darksalmon" "darkorange" "blue" "pink" "magenta2"
146 "sienna4" "khaki2" "grey75" "grey74" "grey73" "grey69" "grey68" "grey35"
147 "grey13" "gray90" "gray81" "gray55" "gray51" "gray31" "snow2" "pink3"
148 "grey7" "gray1" "red4" "red3" "tan" "red" "yellow" "mediumvioletred"
149 "lightslategrey" "lavenderblush4" "turquoise" "darkturquoise"
150 "darkslategrey" "lightskyblue" "lightsalmon4" "lightsalmon3"
151 "forestgreen" "dodgerblue4" "orchid" "rosybrown4" "brown" "peachpuff3"
152 "palegreen3" "orangered2" "rose" "lightcyan4" "indianred4" "indianred3"
153 "seagreen2" "indianred" "deeppink1" "navyblue" "lavender" "grey"
154 "deeppink" "salmon4" "salmon3" "oldlace" "grey78" "grey77" "grey54"
155 "grey45" "grey21" "gray97" "gray96" "gray95" "gray88" "gray87" "gray86"
156 "gray70" "gray57" "gray38" "gray12" "gray11" "plum3" "linen" "gray9"
157 "gray8" "blue4" "beige" "turquoise" "blue" "lemonchiffon4"
158 "darkseagreen1" "antiquewhite3" "mediumorchid" "springgreen"
159 "turquoise4" "steelblue3" "mistyrose2" "lightcyan2" "red" "firebrick2"
160 "royalblue" "cadetblue" "skyblue3" "yellow3" "salmon1" "orange4"
161 "hotpink" "grey90" "gray56" "gray39" "gray18" "gray14" "plum4" "grey6"
162 "gray6" "gold3" "gold1" "blue2" "tan2" "cyan" "mediumspringgreen"
163 "darkolivegreen2" "goldenrod" "lightsteelblue" "brown" "whip"
164 "chartreuse3" "violetred4" "royalblue2" "royalblue1" "papayawhip"
165 "mistyrose3" "lightcyan1" "aquamarine" "skyblue4" "hotpink4" "hotpink3"
166 "hotpink2" "dimgray" "tomato" "grey66" "grey65" "grey64" "grey33"
167 "grey27" "gray76" "gray69" "gray68" "grey0" "azure" "green"
168 "darkgoldenrod4" "darkgoldenrod3" "darkgoldenrod2" "darkgoldenrod"
169 "brown" "lightsalmon2" "deepskyblue4" "deepskyblue3" "deepskyblue2"
170 "deepskyblue" "darkorange1" "violetred3" "violetred2" "violetred1"
171 "slateblue3" "slateblue2" "drab" "indianred1" "firebrick1" "cadetblue4"
172 "violetred" "rosybrown" "blue" "firebrick" "grey100" "wheat4" "grey79"
173 "grey76" "grey61" "gray93" "gray84" "gray65" "gray36" "gray32" "gray13"
174 "gray10" "azure3" "snow1" "tan1" "gray" "darkolivegreen1" "blue"
175 "almond" "lavenderblush3" "lavenderblush2" "lavenderblush1"
176 "darkolivegreen" "lavenderblush" "aquamarine2" "red" "olivedrab2"
177 "mistyrose4" "mistyrose1" "lightcyan3" "lightcoral" "chartreuse"
178 "peachpuff" "palegreen" "mintcream" "skyblue2" "moccasin" "tomato1"
179 "orchid3" "maroon3" "salmon" "grey81" "grey62" "grey39" "grey38"
180 "grey37" "gray92" "gray83" "gray66" "gray54" "gray50" "gray30" "gray19"
181 "gray15" "azure4" "grey3" "tan3" "pink" "gray" "blue" "lightsteelblue2"
182 "lightsteelblue1" "green" "lightslategray" "lemonchiffon2"
183 "springgreen1" "greenyellow" "chartreuse2" "grey" "royalblue3"
184 "powderblue" "peachpuff2" "palegreen2" "cream" "slateblue" "seashell2"
185 "deeppink2" "darkkhaki" "maroon4" "sienna" "grey71" "grey67" "grey18"
186 "gray59" "gray43" "gray25" "bisque" "red1" "mediumslateblue"
187 "lightgoldenrod1" "goldenrod" "paleturquoise3" "lightskyblue4" "green"
188 "yellow" "smoke" "blue" "white" "steelblue4" "rosybrown3" "peachpuff1"
189 "palegreen1" "blueviolet" "seashell4" "sienna3" "grey40" "gray91"
190 "gray82" "gray5" "cyan2" "cyan1" "blue1" "snow" "lightgoldenrod2"
191 "lightslateblue" "mediumorchid3" "darkseagreen4" "springgreen3" "green"
192 "slategray4" "slategray3" "slategray2" "blue" "peachpuff4" "palegreen4"
193 "green" "orangered3" "goldenrod1" "ghostwhite" "firebrick4" "firebrick3"
194 "cadetblue3" "slategray" "seashell3" "honeydew3" "cornsilk4" "cornsilk2"
195 "purple1" "dimgrey" "khaki1" "ivory3" "grey70" "grey60" "grey32"
196 "grey22" "grey12" "gray98" "gray89" "gray71" "gray64" "gray60" "gray49"
197 "azure2" "gray3" "paleturquoise1" "mediumpurple1" "purple"
198 "lemonchiffon1" "blue" "navajowhite3" "darkorchid1" "orange"
199 "goldenrod2" "khaki" "chocolate2" "burlywood2" "honeydew1" "darkgreen"
200 "thistle3" "thistle2" "thistle1" "thistle" "maroon2" "maroon1" "grey53"
201 "grey44" "grey25" "gray74" "gray45" "gray41" "gray35" "gray27" "gray23"
202 "gray16" "brown4" "wheat" "coral" "tan4" "lightgoldenrodyellow" "blue"
203 "green" "gray" "palevioletred3" "mediumpurple4" "mediumpurple3"
204 "saddlebrown" "blue" "darkorchid4" "darkorchid3" "puff" "olivedrab4"
205 "lightblue4" "lightpink" "lightgray" "honeydew2" "cornsilk1" "lace"
206 "sienna1" "bisque4" "orchid" "khaki3" "grey84" "grey83" "grey82"
207 "grey72" "grey52" "grey43" "grey26" "grey14" "grey10" "gray75" "gray53"
208 "gray21" "gray20" "brown3" "grey8" "red2" "navy" "grey" "gold"
209 "mediumaquamarine" "lightgoldenrod" "darkslategray4" "darkseagreen3"
210 "darkseagreen2" "antiquewhite4" "white" "springgreen4" "lightyellow4"
211 "white" "aquamarine1" "turquoise3" "steelblue2" "rosybrown2" "pink"
212 "gray" "indianred2" "dodgerblue" "green" "seagreen1" "deeppink4"
213 "aliceblue" "magenta1" "pink" "sienna2" "orchid1" "gray100" "grey97"
214 "grey94" "grey87" "grey86" "grey51" "grey42" "grey19" "gray94" "gray85"
215 "gray61" "brown2" "khaki" "grey1" "gold4" "blue" "green" "grey"
216 "turquoise" "paleturquoise" "mediumorchid4" "antiquewhite2"
217 "lightyellow2" "violet" "salmon" "chartreuse1" "turquoise1" "sandybrown"
218 "orangered1" "lightpink1" "lightblue2" "lightblue1" "grey" "seagreen4"
219 "seagreen3" "lightblue" "deeppink3" "burlywood" "seashell" "hotpink1"
220 "gray" "yellow4" "yellow" "purple" "orange" "ivory4" "grey99" "grey89"
221 "grey63" "grey58" "grey49" "grey31" "grey24" "grey20" "green4" "green1"
222 "gray73" "gray67" "coral3" "coral2" "plum2" "pink4" "ivory" "gray4"
223 "gray2" "gold2" "aquamarine" "grey" "lightgoldenrod3" "darkolivegreen3"
224 "darkgoldenrod1" "goldenrod" "orchid" "chiffon" "navajowhite4"
225 "deepskyblue1" "lightyellow" "floralwhite" "blue" "mediumblue"
226 "chocolate4" "chocolate3" "burlywood4" "turquoise" "steelblue" "green"
227 "lawngreen" "honeydew4" "seagreen" "orchid4" "wheat1" "violet" "ivory1"
228 "grey88" "grey85" "grey57" "grey56" "grey55" "grey48" "grey47" "grey46"
229 "grey30" "grey17" "gray47" "gray29" "pink2" "grey5" "grey4" "green"
230 "gray0" "brown" "lightsteelblue4" "darkolivegreen4" "palevioletred4"
231 "blue" "darkslategray3" "darkslategray2" "darkslategray1"
232 "blanchedalmond" "palegoldenrod" "blue" "lightseagreen" "lemonchiffon3"
233 "darkslategray" "green" "darkseagreen" "antiquewhite" "darkorange2"
234 "chartreuse4" "blue" "rosybrown1" "olivedrab3" "lightpink2" "orangered"
235 "thistle4" "blue" "cornsilk" "salmon2" "orchid2" "ivory2" "grey93"
236 "grey92" "grey91" "grey36" "grey29" "grey28" "grey16" "gray79" "gray78"
237 "gray77" "gray48" "gray17" "coral4" "coral1" "plum1" "pink1" "grey9"
238 "grey2" "gray7" "cyan4" "blue3" "plum" "cornflowerblue" "lightskyblue2"
239 "antiquewhite1" "navajowhite2" "navajowhite1" "lightyellow3"
240 "navajowhite" "darkorange3" "whitesmoke" "turquoise2" "steelblue1"
241 "lightpink4" "lightblue3" "green" "chocolate1" "blue" "olivedrab"
242 "lightgrey" "chocolate" "magenta4" "magenta3" "yellow1" "purple3"
243 "purple2" "orange2" "orange1" "magenta" "bisque1" "wheat2" "maroon"
244 "khaki4" "grey96" "grey95" "grey80" "grey50" "grey41" "grey15" "grey11"
245 "gray80" "gray58" "gray40" "gray34" "gray22" "brown1" "snow3"
246 "mediumturquoise" "lightsteelblue3" "palevioletred2" "palevioletred1"
247 "paleturquoise2" "green" "palevioletred" "mediumorchid1" "white"
248 "mediumpurple" "lightyellow1" "dodgerblue2" "dodgerblue1" "violet"
249 "aquamarine3" "slategray1" "gray" "orangered4" "lightpink3" "blue"
250 "darkorchid" "cadetblue1" "burlywood3" "seashell1" "cornsilk3" "tomato4"
251 "tomato2" "wheat3" "grey98" "grey59" "grey23" "green3" "green2" "gray72"
252 "gray62" "gray52" "gray46" "gray42" "gray28" "gray24" "white" "cyan3"
253 "black" ))
254
255 (defvar hproperty:color-ptr nil
256 "Pointer to current color name table to use for Hyperbole buttons in XEmacs.")
257
258 (defconst hproperty:good-colors
259 '(
260 "medium violet red" "indianred4" "firebrick1" "DarkGoldenrod" "NavyBlue"
261 "darkorchid" "tomato3" "mediumseagreen" "deeppink" "forestgreen"
262 "mistyrose4" "slategrey" "purple4" "dodgerblue3" "mediumvioletred"
263 "lightsalmon3" "orangered2" "turquoise4" "Gray55"
264 )
265 "Good colors for contrast against wheat background and black foreground.")
266
267
268 ;;; ************************************************************************
269 ;;; Public functions
270 ;;; ************************************************************************
271
272 (defun hproperty:cycle-but-color (&optional color)
273 "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr."
274 (interactive "sHyperbole button color: ")
275 (if (not (x-display-color-p))
276 nil
277 (if color (setq hproperty:color-ptr nil))
278 (set-face-foreground
279 hproperty:but-face
280 (or color (car (hproperty:list-cycle
281 hproperty:color-ptr hproperty:good-colors))))
282 (hproperty:set-flash-color)
283 (sit-for 0) ;; Force display update
284 t))
285
286 (defun hproperty:set-flash-color ()
287 "Set button flashing colors based upon current color set."
288 (if (not (x-display-color-p))
289 nil
290 (set-face-background hproperty:flash-face (hproperty:but-color))
291 (set-face-foreground hproperty:flash-face (hproperty:background))))
292
293 (defun hproperty:but-flash ()
294 "Flash a XEmacs Hyperbole button at or near point to indicate selection."
295 (interactive)
296 (let ((ibut) (prev)
297 (start (hattr:get 'hbut:current 'lbl-start))
298 (end (hattr:get 'hbut:current 'lbl-end))
299 (b) (a))
300 (if (and start end (setq prev (extent-at start)
301 ibut t))
302 (progn (if (not prev) (hproperty:but-add start end hproperty:but-face))
303 (setq b (and start (extent-at start))))
304 (setq b (extent-at (point))))
305 (if (setq a (and (extentp b) (extent-face b)))
306 (progn
307 (set-extent-face b hproperty:flash-face)
308 (sit-for 0);; Force display update
309 ;; Delay before redraw button
310 (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i))))
311 (set-extent-face b a)
312 (sit-for 0);; Force display update
313 ))
314 (if (and ibut (not prev)) (hproperty:but-delete start))
315 ))
316
317 (defun hproperty:set-item-highlight (&optional background foreground)
318 "Setup or reset item highlight face using optional BACKGROUND and FOREGROUND."
319 (make-local-variable 'hproperty:item-face)
320 (if background (setq hproperty:item-highlight-color background))
321 (if (not hproperty:highlight-face)
322 (progn
323 (setq hproperty:highlight-face
324 (or (find-face 'hproperty:highlight-face)
325 (face-name (make-face 'hproperty:highlight-face))))
326 (set-face-foreground hproperty:highlight-face
327 (or foreground (hproperty:background)))
328 (set-face-underline-p hproperty:highlight-face nil)))
329
330 (let* ((tty (and (fboundp 'device-type)
331 (eq 'tty (device-type (selected-device)))))
332 (specifiers-function
333 (if (fboundp 'specifier-specs) 'specifier-specs 'identity))
334 (color-function
335 (if (fboundp 'color-name) 'color-name 'identity))
336 (update-rolo-highlight-flag
337 (and (boundp 'rolo-highlight-face) (find-face rolo-highlight-face)
338 (or (null
339 (funcall specifiers-function
340 (face-foreground rolo-highlight-face)))
341 (equal
342 (funcall color-function
343 (face-foreground rolo-highlight-face))
344 (funcall color-function (face-foreground 'default)))
345 (face-equal hproperty:highlight-face rolo-highlight-face)))))
346 (if tty
347 (copy-face 'italic 'hproperty:highlight-face)
348 (if (and (funcall specifiers-function
349 (face-background hproperty:highlight-face))
350 (equal (funcall color-function
351 (face-background hproperty:highlight-face))
352 hproperty:item-highlight-color))
353 nil
354 (set-face-background hproperty:highlight-face
355 hproperty:item-highlight-color))
356 (and background (not (equal (face-background
357 hproperty:highlight-face) background))
358 (set-face-background hproperty:highlight-face background))
359 (and foreground (not (equal (face-foreground
360 hproperty:highlight-face) foreground))
361 (set-face-foreground hproperty:highlight-face foreground)))
362 (setq hproperty:item-face hproperty:highlight-face)
363 (if update-rolo-highlight-flag
364 (if tty
365 (copy-face 'italic 'rolo-highlight-face)
366 (copy-face hproperty:highlight-face rolo-highlight-face)))))
367
368 (defun hproperty:select-item (&optional pnt)
369 "Select item in current buffer at optional position PNT using hproperty:item-face."
370 (if hproperty:item-button
371 nil
372 (set-extent-face (setq hproperty:item-button (make-extent (point) (point)))
373 hproperty:item-face))
374 (if pnt (goto-char pnt))
375 (skip-chars-forward " \t")
376 (skip-chars-backward "^ \t\n")
377 (let ((start (point)))
378 (save-excursion
379 (skip-chars-forward "^ \t\n")
380 (set-extent-endpoints hproperty:item-button start (point))
381 ))
382 (sit-for 0) ;; Force display update
383 )
384
385 (defun hproperty:select-line (&optional pnt)
386 "Select line in current buffer at optional position PNT using hproperty:item-face."
387 (if hproperty:item-button
388 nil
389 (set-extent-face (setq hproperty:item-button (make-extent (point) (point)))
390 hproperty:item-face))
391 (if pnt (goto-char pnt))
392 (save-excursion
393 (beginning-of-line)
394 (set-extent-endpoints hproperty:item-button (point) (progn (end-of-line) (point)))
395 )
396 (sit-for 0) ;; Force display update
397 )
398
399 ;;; ************************************************************************
400 ;;; Private variables
401 ;;; ************************************************************************
402
403 (defvar hproperty:but-face (face-name (make-face 'hproperty:but-face))
404 "Face for hyper-buttons.")
405 (setq hproperty:but hproperty:but-face)
406 (if (and (fboundp 'device-type)
407 (eq 'tty (device-type (selected-device))))
408 (copy-face 'italic 'hproperty:but-face)
409 (set-face-foreground hproperty:but-face (hproperty:but-color))
410 (set-face-background hproperty:but-face (hproperty:background)))
411
412 (defvar hproperty:flash-face (face-name (make-face 'hproperty:flash-face))
413 "Face for flashing hyper-buttons.")
414 (hproperty:set-flash-color)
415
416 (defvar hproperty:item-button nil
417 "Button used to highlight an item in a listing buffer.")
418 (make-variable-buffer-local 'hproperty:item-button)
419 (defvar hproperty:item-face nil "Item marking face.")
420 (defvar hproperty:highlight-face nil
421 "Item highlighting face. Use (hproperty:set-item-highlight) to set.")
422 (if hproperty:highlight-face
423 nil
424 ;; Reverse foreground and background colors for default block-style highlighting.
425 (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background)))
426
427 (provide 'hui-xe-but)