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
|
;;;;
;;;; menus.lsp Menus for the Macintosh, MS Windows, and UNIX
;;;; 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 "menus")
;;;;
;;;; Standard Menus for Macontosh Version
;;;;
#+macintosh
(progn
;;**** check over exports
(export '(find-menu set-menu-bar
*apple-menu* *file-menu* *edit-menu* *command-menu*
*standard-menu-bar*))
;;;;
;;;; Editing Methods
;;;;
(defmeth edit-window-proto :edit-selection ()
(send (send edit-window-proto :new)
:paste-stream (send self :selection-stream)))
(defmeth edit-window-proto :eval-selection ()
(let ((s (send self :selection-stream)))
(do ((expr (read s nil '*eof*) (read s nil '*eof*)))
((eq expr '*eof*))
(eval expr))))
(let ((last-string ""))
(defmeth edit-window-proto :find ()
"Method args: ()
Opens dialog to get string to find and finds it. Beeps if not found."
(let ((s (get-string-dialog "String to find:" :initial last-string)))
(when s
(if (stringp s) (setq last-string s))
(unless (and (stringp s) (send self :find-string s))
(sysbeep)))))
(defmeth edit-window-proto :find-again ()
(unless (and (stringp last-string)
(< 0 (length last-string))
(send self :find-string last-string))
(sysbeep))))
;;;;
;;;; General Menu Methods and Functions
;;;;
(defmeth menu-proto :find-item (str)
"Method args: (str)
Finds and returns menu item with tile STR."
(dolist (item (send self :items))
(if (string-equal str (send item :title))
(return item))))
(defun find-menu (title)
"Args: (title)
Finds and returns menu in the menu bar with title TITLE."
(dolist (i *hardware-objects*)
(let ((object (nth 2 i)))
(if (and (kind-of-p object menu-proto)
(send object :installed-p)
(string-equal (string title) (send object :title)))
(return object)))))
(defun set-menu-bar (menus)
"Args (menus)
Makes the list MENUS the current menu bar."
(dolist (i *hardware-objects*)
(let ((object (nth 2 i)))
(if (kind-of-p object menu-proto) (send object :remove))))
(dolist (i menus) (send i :install)))
;;;;
;;;; Apple Menu
;;;;
(defvar *apple-menu* (send apple-menu-proto :new (string #\apple)))
(send *apple-menu* :append-items
(send menu-item-proto :new "About XLISP-STAT"
:action 'about-xlisp-stat))
;;;;
;;;; File Menu
;;;;
(defvar *file-menu* (send menu-proto :new "File"))
(defproto file-edit-item-proto '(message) '() menu-item-proto)
(defmeth file-edit-item-proto :isnew (title message &rest args)
(setf (slot-value 'message) message)
(apply #'call-next-method title args))
(defmeth file-edit-item-proto :do-action ()
(send (front-window) (slot-value 'message)))
(defmeth file-edit-item-proto :update ()
(send self :enabled (kind-of-p (front-window) edit-window-proto)))
(send *file-menu* :append-items
(send menu-item-proto :new "Load" :key #\L :action
#'(lambda ()
(let ((f (open-file-dialog t)))
(when f (load f) (format t "; finished loading ~s~%" f)))))
(send dash-item-proto :new)
(send menu-item-proto :new "New Edit" :key #\N
:action #'(lambda () (send edit-window-proto :new)))
(send menu-item-proto :new "Open Edit" :key #\O
:action #'(lambda ()
(send edit-window-proto :new :bind-to-file t)))
(send dash-item-proto :new)
(send file-edit-item-proto :new "Save Edit" :save :key #\S)
(send file-edit-item-proto :new "Save Edit As" :save-as)
(send file-edit-item-proto :new "Save Edit Copy" :save-copy)
(send file-edit-item-proto :new "Revert Edit" :revert)
(send dash-item-proto :new)
(send menu-item-proto :new "Quit" :key #\Q :action 'exit))
;;;;
;;;; Edit Menu
;;;;
(defproto edit-menu-item-proto '(item message) '() menu-item-proto)
(defmeth edit-menu-item-proto :isnew (title item message &rest args)
(setf (slot-value 'item) item)
(setf (slot-value 'message) message)
(apply #'call-next-method title args))
(defmeth edit-menu-item-proto :do-action ()
(unless (system-edit (slot-value 'item))
(let ((window (front-window)))
(if window (send window (slot-value 'message))))))
(defvar *edit-menu* (send menu-proto :new "Edit"))
(send *edit-menu* :append-items
(send edit-menu-item-proto :new "Undo" 0 :undo :enabled nil)
(send dash-item-proto :new)
(send edit-menu-item-proto :new "Cut" 2 :cut-to-clip :key #\X)
(send edit-menu-item-proto :new "Copy" 3 :copy-to-clip :key #\C)
(send edit-menu-item-proto :new "Paste" 4 :paste-from-clip :key #\V)
(send edit-menu-item-proto :new "Clear" 5 :clear :enabled nil)
(send dash-item-proto :new)
(send menu-item-proto :new "Copy-Paste" :key #\/ :action
#'(lambda ()
(let ((window (front-window)))
(when window
(send window :copy-to-clip)
(send window :paste-from-clip)))))
(send dash-item-proto :new)
(send menu-item-proto :new "Find ..." :key #\F :action
#'(lambda ()
(let ((window (front-window)))
(if window (send window :find)))))
(send menu-item-proto :new "Find Again" :key #\A :action
#'(lambda ()
(let ((window (front-window)))
(if window (send window :find-again)))))
(send dash-item-proto :new)
(send menu-item-proto :new "Edit Selection" :action
#'(lambda () (send (front-window) :edit-selection)))
(send menu-item-proto :new "Eval Selection" :key #\E :action
#'(lambda () (send (front-window) :eval-selection))))
;;;;
;;;; Command Menu
;;;;
(defvar *command-menu* (send menu-proto :new "Command"))
(send *command-menu* :append-items
(send menu-item-proto :new "Show XLISP-STAT"
:action #'(lambda () (send *listener* :show-window)))
(send dash-item-proto :new)
(send menu-item-proto :new "Clean Up" :key #\, :action #'clean-up)
(send menu-item-proto :new "Toplevel" :key #\. :action #'top-level)
(send dash-item-proto :new)
(let ((item (send menu-item-proto :new "Dribble")))
(send item :action
#'(lambda ()
(cond
((send item :mark) (dribble) (send item :mark nil))
(t (let ((f (set-file-dialog "Dribble file:")))
(when f
(dribble f)
(send item :mark t)))))))
item))
(defconstant *standard-menu-bar*
(list *apple-menu* *file-menu* *edit-menu* *command-menu*)))
;;;;
;;;; Standard Menus for Microsoft Windows Version
;;;;
#+msdos
(progn
(export '(find-menu set-menu-bar
*file-menu* *edit-menu* *command-menu*
*standard-menu-bar*))
(setf *file-menu* (send menu-proto :new "&File"))
(send *file-menu* :append-items
(send menu-item-proto :new "&Load" :action
#'(lambda ()
(let ((fname (open-file-dialog)))
(if fname (load fname)))))
(let ((dribble-item (send menu-item-proto :new "&Dribble")))
(defmeth dribble-item :do-action ()
(case (send self :mark)
(nil (let ((df (set-file-dialog "Dribble File Name:")))
(when df
(dribble df)
(send self :mark t))))
(t (dribble) (send self :mark nil))))
dribble-item)
(send dash-item-proto :new)
#+win32 (send menu-item-proto :new "&Print...\tCtrl+P" :action
#'msw-print)
#+win32 (send dash-item-proto :new)
(send menu-item-proto :new "E&xit" :action #'msw-exit)
(send menu-item-proto :new "About XLISP-STAT ..." :action
#'about-xlisp-stat))
(setf *edit-menu* (send menu-proto :new "&Edit"))
(send *edit-menu* :append-items
(send menu-item-proto :new "&Undo\tCtrl+Z" :enabled nil)
(send dash-item-proto :new)
(send menu-item-proto :new "Cu&t\tCtrl+X" :action #'msw-cut)
(send menu-item-proto :new "&Copy\tCtrt+C" :action #'msw-copy)
(send menu-item-proto :new "&Paste\tCtrl+V" :action #'msw-paste)
(send menu-item-proto :new "C&lear\tDel" :action #'msw-clear)
(send dash-item-proto :new)
(send menu-item-proto :new "Copy-Paste\tAlt+V"
:action #'msw-copy-paste))
(defun set-menu-bar (menus)
"Args (menus)
Makes the list MENUS the current menu bar."
(dolist (i *hardware-objects*)
(let ((object (nth 2 i)))
(if (kind-of-p object menu-proto) (send object :remove))))
(dolist (i menus) (send i :install)))
(defconstant *standard-menu-bar* (list *file-menu* *edit-menu*)))
;;;
;;; Fake menu bar for UNIX systems with graphics
;;; This is a complete hack but at least provides enough functionality
;;; to do the examples in the book.
;;;
#+unix
(progn
(export 'find-menu)
(defun make-fake-menu-bar ()
(cond
((and (boundp '*fake-menu-bar*) *fake-menu-bar*)
(send *fake-menu-bar* :show-window))
(t (let* ((ascent (send graph-window-proto :text-ascent))
(descent (send graph-window-proto :text-descent))
(gap (floor (/ ascent 2)))
(width 400))
(setf *fake-menu-bar*
(send graph-window-proto :new
:title "Menu Bar"
:menu-button nil
:size (list width (+ ascent descent (* 2 gap))))))
(send *fake-menu-bar* :add-slot 'menus)
(defmeth *fake-menu-bar* :menus (&optional (menus nil set))
(if set (setf (slot-value 'menus) menus))
(slot-value 'menus))
(defmeth *fake-menu-bar* :install-menu (menu)
(unless (member menu (send self :menus))
(send self :menus (append (send self :menus) (list menu)))
(send self :show-window)
(send self :redraw)))
(defmeth *fake-menu-bar* :remove-menu (menu)
(send self :menus (remove menu (send self :menus)))
(send self :redraw))
(defmeth *fake-menu-bar* :redraw ()
(let* ((ascent (send self :text-ascent))
(gap (floor (/ ascent 2)))
(menus (send self :menus))
(left gap)
(bottom (+ gap ascent)))
(apply #'send self :erase-rect (send self :view-rect))
(dolist (m menus)
(let ((title (send m :title)))
(send self :draw-string title left bottom)
(setf left (+ left gap (send self :text-width title)))))))
(defmeth *fake-menu-bar* :do-click (x y m1 m2)
(declare (ignore m1 m2))
(let* ((loc (+ (list x y) (send self :location)))
(gap (floor (/ (send self :text-ascent) 2)))
(menus (send self :menus))
(x (- x gap)))
(dolist (m menus)
(let ((w (send self :text-width (send m :title))))
(when (< 0 x w)
(apply #'send m :popup loc)
(return))
(setf x (- x gap w))))))
(defun find-menu (name)
(dolist (m (send *fake-menu-bar* :menus))
(if (string-equal (string name) (send m :title))
(return m)))))))
(defmeth menu-proto :install ()
(make-fake-menu-bar)
(send *fake-menu-bar* :install-menu self))
(defmeth menu-proto :remove ()
(send *fake-menu-bar* :remove-menu self)))
|
