1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
|
;;;;
;;;; graphics.lsp XLISP-STAT custom dialog objects and functions
;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
;;;; You may give out copies of this software; for conditions see the file
;;;; COPYING included with this distribution.
;;;;
(in-package "XLISP")
(provide "dialogs")
(export '(num-to-string ok-or-cancel-dialog-proto ok-or-cancel-dialog
message-dialog-proto message-dialog
get-string-dialog-proto get-string-dialog get-value-dialog
choose-item-dialog-proto choose-item-dialog
choose-subset-dialog-proto choose-subset-dialog
sequence-scroll-item-proto sequence-slider-dialog-proto
sequence-slider-dialog
interval-scroll-item-proto interval-slider-dialog-proto
interval-slider-dialog))
(defun num-to-string (n) (prin1-to-string n))
;;;;
;;;;
;;;; OK-or-Cancel Dialog Prototype
;;;;
;;;;
(defproto ok-or-cancel-dialog-proto
'(ok-button cancel-button) () modal-dialog-proto)
(defmeth ok-or-cancel-dialog-proto :isnew (items &rest args
&key (ok-default t)
(ok-action #'(lambda () t))
(cancel-action
#'(lambda () nil)))
(let ((items (if (consp items) items (list items)))
(ok-button (send modal-button-proto :new "OK"
:action ok-action))
(cancel-button (send modal-button-proto :new "Cancel"
:action cancel-action)))
(setf items (mapcar #'(lambda (x)
(if (stringp x)
(send text-item-proto :new x)
x))
items))
(setf (slot-value 'ok-button) ok-button)
(setf (slot-value 'cancel-button) cancel-button)
(apply #'call-next-method
(append items (list (list ok-button cancel-button)))
args)
(send self :default-button (if ok-default ok-button cancel-button))))
(defun ok-or-cancel-dialog (s &optional (ok-default t) &rest args)
"Args: (s &optional (ok-default t) &rest args)
Open modal dialog with string S and OK, Cancel buttons. Returns T for
OK, NIL for Cancel. S can contain format directives, which are filled
from the remaining arguments."
(let ((d (send ok-or-cancel-dialog-proto :new
(apply #'format nil s args) :ok-default ok-default)))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Message Dialog Prototype
;;;;
;;;;
(defproto message-dialog-proto '() () modal-dialog-proto)
(defmeth message-dialog-proto :isnew (s)
(let ((text (if (consp s) s (list s)))
(ok-button (send modal-button-proto :new "OK")))
(call-next-method (append text (list ok-button)))
(send self :default-button ok-button)))
(defun message-dialog (&rest args)
"Args: (s &rest args)
Open modal dialog with string S and OK buttons. Returns NIL. S can contain
format directives, which are filled from the remaining arguments."
(let ((d (send message-dialog-proto :new (apply #'format nil args))))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Get String/Value Dialog Prototype
;;;;
;;;;
(defproto get-string-dialog-proto () () ok-or-cancel-dialog-proto)
(defmeth get-string-dialog-proto :isnew (s &rest args &key (initial nil has-init))
(let* ((prompt-item (send text-item-proto :new s))
(edit-item (send edit-text-item-proto :new
(if has-init (format nil "~a" initial) "")
:text-length 20)))
(apply #'call-next-method
(list prompt-item edit-item)
:ok-action #'(lambda () (send edit-item :text))
args)))
(defun get-string-dialog (&rest args)
"Args: (s &key initial)
Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
INITIAL is converted to a string with ~A format directive. Returns string
of text field content on OK, NIL on cancel."
(let ((d (apply #'send get-string-dialog-proto :new args)))
(send d :modal-dialog)))
(defun get-value-dialog (prompt &rest args &key (initial "" supplied))
"Args: (s &key initial)
Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
INITIAL is converted to a string with ~S format directive. On Cancel returns
NIL. ON OK Returns list of result of reading and eval'ing the text field's
content."
(let* ((initial (if supplied
(format nil "~s" initial)
initial))
(s (apply #'get-string-dialog prompt :initial initial args)))
(if s (list (eval (read (make-string-input-stream s) nil))))))
;;;;
;;;;
;;;; Choose string/value dialog prototype
;;;;
;;;;
(defproto choose-item-dialog-proto () () ok-or-cancel-dialog-proto)
(defmeth choose-item-dialog-proto :isnew (s strings &rest args
&key (initial 0))
(let* ((prompt-item (send text-item-proto :new s))
(string-item (send choice-item-proto :new strings :value initial)))
(apply #'call-next-method (list prompt-item string-item)
:ok-action #'(lambda () (send string-item :value))
args)))
(defun choose-item-dialog (&rest args)
"Args: (s strings &key initial)
Opens modal dialog with prompt S, a choice item for list of strings STRINGS
and OK, Cancel buttons. Returns chosen string on OK, NIL on cancel."
(let ((d (apply #'send choose-item-dialog-proto :new args)))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Choose string/value dialog prototype
;;;;
;;;;
(defproto choose-subset-dialog-proto () () ok-or-cancel-dialog-proto)
(defmeth choose-subset-dialog-proto :isnew (s strings &rest args
&key (initial nil))
(let ((prompt-item (send text-item-proto :new s))
(subset-items (mapcar #'(lambda (x y)
(send toggle-item-proto
:new x :value (member y initial)))
strings (iseq 0 (- (length strings) 1)))))
(apply #'call-next-method (cons prompt-item subset-items)
:ok-action #'(lambda ()
(list (which (mapcar #'(lambda (x) (send x :value))
subset-items))))
args)))
(defun choose-subset-dialog (&rest args)
"Args: (s strings &key initial)
Opens modal dialog with prompt S, a set of toggle items for list of
strings STRINGS, and OK, Cancel buttons. Returns list of list of indices
of chosen items on OK, NIL on cancel."
(let ((d (apply #'send choose-subset-dialog-proto :new args)))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Sequence Scroll Bar Item Prototype
;;;;
;;;;
(defproto sequence-scroll-item-proto
'(sequence display-sequence value-text-item) () scroll-item-proto)
(defmeth sequence-scroll-item-proto :isnew
(x &key text-item (size '(180 16)) location action display)
(let* ((sequence (coerce x 'vector))
(display (if display (coerce display 'vector) sequence)))
(setf (slot-value 'sequence) sequence)
(setf (slot-value 'display-sequence) display)
(setf (slot-value 'value-text-item) text-item)
(call-next-method :size size
:location location
:min-value 0 :max-value (1- (length sequence))
:page-increment 5
:action action)))
(defmeth sequence-scroll-item-proto :scroll-action ()
(send self :display-value)
(send self :user-action))
(defmeth sequence-scroll-item-proto :do-action ()
(send self :display-value)
(send self :user-action))
(defmeth sequence-scroll-item-proto :value (&optional (val nil set))
(when set (call-next-method val) (send self :display-value))
(call-next-method))
(defmeth sequence-scroll-item-proto :display-value ()
(if (slot-value 'value-text-item)
(send (slot-value 'value-text-item) :text
(format nil "~s"
(elt (slot-value 'display-sequence)
(send self :value))))))
(defmeth sequence-scroll-item-proto :user-action ()
(if (slot-value 'action)
(funcall (slot-value 'action)
(elt (slot-value 'sequence) (send self :value)))))
;;;;
;;;;
;;;; Sequence Slider Dialog Prototype
;;;;
;;;;
(defproto sequence-slider-dialog-proto () () dialog-proto)
(defmeth sequence-slider-dialog-proto :isnew
(data &key (text "Value") (title "Slider") action display)
(let* ((name-item (send text-item-proto :new text))
(value-item (send text-item-proto :new " "
:location '(100 5)))
(scroll-item (send sequence-scroll-item-proto :new data
:text-item value-item
:action action :display display)))
(call-next-method (list name-item value-item scroll-item) :title title)
(send scroll-item :display-value)))
(defmeth sequence-slider-dialog-proto :value (&rest args)
(apply #'send (nth 2 (slot-value 'items)) :value args))
(defun sequence-slider-dialog (&rest args)
"Args: (data &key (text \"Value\") (title \"Slider\") action display)
Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
scrollbar. The scrollbar scrolls through the DATA sequence and displays the
corresponding element of the DISPLAY sequence. When a scroll event occurs
ACTION is called with the current value of DATA as argument."
(apply #'send sequence-slider-dialog-proto :new args))
;;;;
;;;;
;;;; Interval Scroll Bar Item Prototype
;;;;
;;;;
(defproto interval-scroll-item-proto
'(interval num-points value-text-item) () scroll-item-proto)
(defmeth interval-scroll-item-proto :isnew
(x &key text-item (size '(180 16)) location action
(points (nth 2 (get-nice-range (nth 0 x) (nth 1 x) 50))))
(setf (slot-value 'interval) x)
(setf (slot-value 'num-points) points)
(setf (slot-value 'value-text-item) text-item)
(call-next-method :size size :location location :min-value 0
:max-value (1- points)
:action action))
(defmeth interval-scroll-item-proto :value (&optional (val nil set))
(let ((interval (slot-value 'interval))
(num-points (slot-value 'num-points)))
(if set
(let* ((min (elt interval 0))
(max (elt interval 1))
(val (floor (* (1- num-points) (/ (- val min) (- max min))))))
(call-next-method val)
(send self :display-value)
(send self :user-action)))
(let ((min (elt interval 0))
(max (elt interval 1)))
(+ min (* (/ (call-next-method) (1- num-points)) (- max min))))))
(defmeth interval-scroll-item-proto :max (&optional (max nil set))
(let ((value (send self :value)))
(when set (setf (elt interval 1) max) (send self :value value))
(elt interval 1)))
(defmeth interval-scroll-item-proto :min (&optional (min nil set))
(let ((value (send self :value)))
(when set (setf (elt interval 0) min) (send self :value value))
(elt interval 0)))
(defmeth interval-scroll-item-proto :user-action ()
(if (slot-value 'action)
(funcall (slot-value 'action) (send self :value))))
(defmeth interval-scroll-item-proto :display-value ()
(if (slot-value 'value-text-item)
(send (slot-value 'value-text-item)
:text (num-to-string (send self :value)))))
(defmeth interval-scroll-item-proto :scroll-action ()
(send self :display-value)
(send self :user-action))
(defmeth interval-scroll-item-proto :do-action ()
(send self :display-value)
(send self :user-action))
;;;;
;;;;
;;;; Interval Slider Dialog Prototype
;;;;
;;;;
(defproto interval-slider-dialog-proto () () dialog-proto)
(defmeth interval-slider-dialog-proto :isnew
(data &key (text "Value") (title "Slider") action (points 30) (nice t))
(if nice
(let ((range (get-nice-range (nth 0 data) (nth 1 data) points)))
(setq data (list (nth 0 range) (nth 1 range)))
(setq points (nth 2 range))))
(let* ((value-item (send text-item-proto :new " "
:location '(100 5)))
(name-item (send text-item-proto :new text))
(scroll-item (send interval-scroll-item-proto :new data
:text-item value-item
:action action :points points)))
(call-next-method (list name-item value-item scroll-item) :title title)
(send scroll-item :display-value)))
(defmeth interval-slider-dialog-proto :value (&rest args)
(apply #'send (nth 2 (slot-value 'items)) :value args))
(defun interval-slider-dialog (&rest args)
"Args: (data &key (text \"Value\") (title \"Slider\") action (points 30) (nice t))
Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
scrollbar. The scrollbar scrolls through the interval DATA, a list of the form
(LOW HIGH), sequence and displays the value. When a scroll event occurs
ACTION is called with the current value in the interval as argument. If NICE
is not NIL DATA and POINTS are revised to produce a nice set of values."
(apply #'send interval-slider-dialog-proto :new args))
|
