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