2 ;;;; graphics.lsp XLISP-STAT custom dialog objects and functions
3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
5 ;;;; You may give out copies of this software; for conditions see the file
6 ;;;; COPYING included with this distribution.
11 (export '(num-to-string ok-or-cancel-dialog-proto ok-or-cancel-dialog
12 message-dialog-proto message-dialog
13 get-string-dialog-proto get-string-dialog get-value-dialog
14 choose-item-dialog-proto choose-item-dialog
15 choose-subset-dialog-proto choose-subset-dialog
16 sequence-scroll-item-proto sequence-slider-dialog-proto
17 sequence-slider-dialog
18 interval-scroll-item-proto interval-slider-dialog-proto
19 interval-slider-dialog
))
21 (defun num-to-string (n) (prin1-to-string n
))
25 ;;;; OK-or-Cancel Dialog Prototype
29 (defproto ok-or-cancel-dialog-proto
30 '(ok-button cancel-button
) () modal-dialog-proto
)
32 (defmeth ok-or-cancel-dialog-proto
:isnew
(items &rest args
34 (ok-action #'(lambda () t
))
37 (let ((items (if (consp items
) items
(list items
)))
38 (ok-button (send modal-button-proto
:new
"OK"
40 (cancel-button (send modal-button-proto
:new
"Cancel"
41 :action cancel-action
)))
42 (setf items
(mapcar #'(lambda (x)
44 (send text-item-proto
:new x
)
47 (setf (slot-value 'ok-button
) ok-button
)
48 (setf (slot-value 'cancel-button
) cancel-button
)
49 (apply #'call-next-method
50 (append items
(list (list ok-button cancel-button
)))
52 (send self
:default-button
(if ok-default ok-button cancel-button
))))
54 (defun ok-or-cancel-dialog (s &optional
(ok-default t
) &rest args
)
55 "Args: (s &optional (ok-default t) &rest args)
56 Open modal dialog with string S and OK, Cancel buttons. Returns T for
57 OK, NIL for Cancel. S can contain format directives, which are filled
58 from the remaining arguments."
59 (let ((d (send ok-or-cancel-dialog-proto
:new
60 (apply #'format nil s args
) :ok-default ok-default
)))
61 (send d
:modal-dialog
)))
65 ;;;; Message Dialog Prototype
69 (defproto message-dialog-proto
'() () modal-dialog-proto
)
71 (defmeth message-dialog-proto
:isnew
(s)
72 (let ((text (if (consp s
) s
(list s
)))
73 (ok-button (send modal-button-proto
:new
"OK")))
74 (call-next-method (append text
(list ok-button
)))
75 (send self
:default-button ok-button
)))
77 (defun message-dialog (&rest args
)
79 Open modal dialog with string S and OK buttons. Returns NIL. S can contain
80 format directives, which are filled from the remaining arguments."
81 (let ((d (send message-dialog-proto
:new
(apply #'format nil args
))))
82 (send d
:modal-dialog
)))
86 ;;;; Get String/Value Dialog Prototype
90 (defproto get-string-dialog-proto
() () ok-or-cancel-dialog-proto
)
92 (defmeth get-string-dialog-proto
:isnew
(s &rest args
&key
(initial nil has-init
))
93 (let* ((prompt-item (send text-item-proto
:new s
))
94 (edit-item (send edit-text-item-proto
:new
95 (if has-init
(format nil
"~a" initial
) "")
97 (apply #'call-next-method
98 (list prompt-item edit-item
)
99 :ok-action
#'(lambda () (send edit-item
:text
))
102 (defun get-string-dialog (&rest args
)
103 "Args: (s &key initial)
104 Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
105 INITIAL is converted to a string with ~A format directive. Returns string
106 of text field content on OK, NIL on cancel."
107 (let ((d (apply #'send get-string-dialog-proto
:new args
)))
108 (send d
:modal-dialog
)))
110 (defun get-value-dialog (prompt &rest args
&key
(initial "" supplied
))
111 "Args: (s &key initial)
112 Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
113 INITIAL is converted to a string with ~S format directive. On Cancel returns
114 NIL. ON OK Returns list of result of reading and eval'ing the text field's
116 (let* ((initial (if supplied
117 (format nil
"~s" initial
)
119 (s (apply #'get-string-dialog prompt
:initial initial args
)))
120 (if s
(list (eval (read (make-string-input-stream s
) nil
))))))
124 ;;;; Choose string/value dialog prototype
128 (defproto choose-item-dialog-proto
() () ok-or-cancel-dialog-proto
)
130 (defmeth choose-item-dialog-proto
:isnew
(s strings
&rest args
132 (let* ((prompt-item (send text-item-proto
:new s
))
133 (string-item (send choice-item-proto
:new strings
:value initial
)))
134 (apply #'call-next-method
(list prompt-item string-item
)
135 :ok-action
#'(lambda () (send string-item
:value
))
138 (defun choose-item-dialog (&rest args
)
139 "Args: (s strings &key initial)
140 Opens modal dialog with prompt S, a choice item for list of strings STRINGS
141 and OK, Cancel buttons. Returns chosen string on OK, NIL on cancel."
142 (let ((d (apply #'send choose-item-dialog-proto
:new args
)))
143 (send d
:modal-dialog
)))
147 ;;;; Choose string/value dialog prototype
151 (defproto choose-subset-dialog-proto
() () ok-or-cancel-dialog-proto
)
153 (defmeth choose-subset-dialog-proto
:isnew
(s strings
&rest args
155 (let ((prompt-item (send text-item-proto
:new s
))
156 (subset-items (mapcar #'(lambda (x y
)
157 (send toggle-item-proto
158 :new x
:value
(member y initial
)))
159 strings
(iseq 0 (- (length strings
) 1)))))
160 (apply #'call-next-method
(cons prompt-item subset-items
)
161 :ok-action
#'(lambda ()
162 (list (which (mapcar #'(lambda (x) (send x
:value
))
166 (defun choose-subset-dialog (&rest args
)
167 "Args: (s strings &key initial)
168 Opens modal dialog with prompt S, a set of toggle items for list of
169 strings STRINGS, and OK, Cancel buttons. Returns list of list of indices
170 of chosen items on OK, NIL on cancel."
171 (let ((d (apply #'send choose-subset-dialog-proto
:new args
)))
172 (send d
:modal-dialog
)))
176 ;;;; Sequence Scroll Bar Item Prototype
180 (defproto sequence-scroll-item-proto
181 '(sequence display-sequence value-text-item
) () scroll-item-proto
)
183 (defmeth sequence-scroll-item-proto
:isnew
184 (x &key text-item
(size '(180 16)) location action display
)
185 (let* ((sequence (coerce x
'vector
))
186 (display (if display
(coerce display
'vector
) sequence
)))
187 (setf (slot-value 'sequence
) sequence
)
188 (setf (slot-value 'display-sequence
) display
)
189 (setf (slot-value 'value-text-item
) text-item
)
190 (call-next-method :size size
192 :min-value
0 :max-value
(1- (length sequence
))
196 (defmeth sequence-scroll-item-proto
:scroll-action
()
197 (send self
:display-value
)
198 (send self
:user-action
))
200 (defmeth sequence-scroll-item-proto
:do-action
()
201 (send self
:display-value
)
202 (send self
:user-action
))
204 (defmeth sequence-scroll-item-proto
:value
(&optional
(val nil set
))
205 (when set
(call-next-method val
) (send self
:display-value
))
208 (defmeth sequence-scroll-item-proto
:display-value
()
209 (if (slot-value 'value-text-item
)
210 (send (slot-value 'value-text-item
) :text
212 (elt (slot-value 'display-sequence
)
213 (send self
:value
))))))
215 (defmeth sequence-scroll-item-proto
:user-action
()
216 (if (slot-value 'action
)
217 (funcall (slot-value 'action
)
218 (elt (slot-value 'sequence
) (send self
:value
)))))
222 ;;;; Sequence Slider Dialog Prototype
226 (defproto sequence-slider-dialog-proto
() () dialog-proto
)
228 (defmeth sequence-slider-dialog-proto
:isnew
229 (data &key
(text "Value") (title "Slider") action display
)
230 (let* ((name-item (send text-item-proto
:new text
))
231 (value-item (send text-item-proto
:new
" "
233 (scroll-item (send sequence-scroll-item-proto
:new data
234 :text-item value-item
235 :action action
:display display
)))
236 (call-next-method (list name-item value-item scroll-item
) :title title
)
237 (send scroll-item
:display-value
)))
239 (defmeth sequence-slider-dialog-proto
:value
(&rest args
)
240 (apply #'send
(nth 2 (slot-value 'items
)) :value args
))
242 (defun sequence-slider-dialog (&rest args
)
243 "Args: (data &key (text \"Value\") (title \"Slider\") action display)
244 Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
245 scrollbar. The scrollbar scrolls through the DATA sequence and displays the
246 corresponding element of the DISPLAY sequence. When a scroll event occurs
247 ACTION is called with the current value of DATA as argument."
248 (apply #'send sequence-slider-dialog-proto
:new args
))
253 ;;;; Interval Scroll Bar Item Prototype
257 (defproto interval-scroll-item-proto
258 '(interval num-points value-text-item
) () scroll-item-proto
)
260 (defmeth interval-scroll-item-proto
:isnew
261 (x &key text-item
(size '(180 16)) location action
262 (points (nth 2 (get-nice-range (nth 0 x
) (nth 1 x
) 50))))
263 (setf (slot-value 'interval
) x
)
264 (setf (slot-value 'num-points
) points
)
265 (setf (slot-value 'value-text-item
) text-item
)
266 (call-next-method :size size
:location location
:min-value
0
267 :max-value
(1- points
)
270 (defmeth interval-scroll-item-proto
:value
(&optional
(val nil set
))
271 (let ((interval (slot-value 'interval
))
272 (num-points (slot-value 'num-points
)))
274 (let* ((min (elt interval
0))
275 (max (elt interval
1))
276 (val (floor (* (1- num-points
) (/ (- val min
) (- max min
))))))
277 (call-next-method val
)
278 (send self
:display-value
)
279 (send self
:user-action
)))
280 (let ((min (elt interval
0))
281 (max (elt interval
1)))
282 (+ min
(* (/ (call-next-method) (1- num-points
)) (- max min
))))))
284 (defmeth interval-scroll-item-proto
:max
(&optional
(max nil set
))
285 (let ((value (send self
:value
)))
286 (when set
(setf (elt interval
1) max
) (send self
:value value
))
289 (defmeth interval-scroll-item-proto
:min
(&optional
(min nil set
))
290 (let ((value (send self
:value
)))
291 (when set
(setf (elt interval
0) min
) (send self
:value value
))
294 (defmeth interval-scroll-item-proto
:user-action
()
295 (if (slot-value 'action
)
296 (funcall (slot-value 'action
) (send self
:value
))))
298 (defmeth interval-scroll-item-proto
:display-value
()
299 (if (slot-value 'value-text-item
)
300 (send (slot-value 'value-text-item
)
301 :text
(num-to-string (send self
:value
)))))
303 (defmeth interval-scroll-item-proto
:scroll-action
()
304 (send self
:display-value
)
305 (send self
:user-action
))
307 (defmeth interval-scroll-item-proto
:do-action
()
308 (send self
:display-value
)
309 (send self
:user-action
))
313 ;;;; Interval Slider Dialog Prototype
317 (defproto interval-slider-dialog-proto
() () dialog-proto
)
319 (defmeth interval-slider-dialog-proto
:isnew
320 (data &key
(text "Value") (title "Slider") action
(points 30) (nice t
))
322 (let ((range (get-nice-range (nth 0 data
) (nth 1 data
) points
)))
323 (setq data
(list (nth 0 range
) (nth 1 range
)))
324 (setq points
(nth 2 range
))))
325 (let* ((value-item (send text-item-proto
:new
" "
327 (name-item (send text-item-proto
:new text
))
328 (scroll-item (send interval-scroll-item-proto
:new data
329 :text-item value-item
330 :action action
:points points
)))
331 (call-next-method (list name-item value-item scroll-item
) :title title
)
332 (send scroll-item
:display-value
)))
334 (defmeth interval-slider-dialog-proto
:value
(&rest args
)
335 (apply #'send
(nth 2 (slot-value 'items
)) :value args
))
337 (defun interval-slider-dialog (&rest args
)
338 "Args: (data &key (text \"Value\") (title \"Slider\") action (points 30) (nice t))
339 Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
340 scrollbar. The scrollbar scrolls through the interval DATA, a list of the form
341 (LOW HIGH), sequence and displays the value. When a scroll event occurs
342 ACTION is called with the current value in the interval as argument. If NICE
343 is not NIL DATA and POINTS are revised to produce a nice set of values."
344 (apply #'send interval-slider-dialog-proto
:new args
))