|
0
|
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)
|
