source: release/1.4/source/examples/cocoa/easygui/example/extended-demo.lisp

Last change on this file was 13074, checked in by R. Matthew Emerson, 15 years ago

Merge trunk changes r13055 through r13065
File size: 22.4 KB
RevLine 
[11847]1(in-package :easygui-demo)
2
3; ---------------
4; Demo for the new control types for EasyGui within Clozure CL
5; Contributed March 2009 by AWSC (arthur.cater@ucd.ie)
6; based upon earlier work by an unknown author.
7; Permission is given to disseminate, use, and modify.
8; No warranty is expressed or implied.
9;
10; Tested in cclv1.2 on 32-bitPPC, in cclv1.3 on 32-bitPPC and 64-bitIntel Macs.
11; Tested only in images constructed using (require :cocoa-application).
12
[13074]13(setf easygui::*debug-cocoa-calls* nil)
[11847]14
15(defclass view-hierarchy-demo-window (window)
16 ((with :initarg :with :initform :button)
17 (textbox :initarg :textbox :initform nil :accessor demo-textbox))
18 (:default-initargs :size (point 480 270)
19 :position (point 125 513)
20 :resizable-p nil
21 :minimizable-p t
22 :title "View tree demo")
23 (:documentation "Shows a window with a simple view hierarchy and one or more controls
24 that manipulate this hierarchy."))
25
26(defclass brown-drawing-view (drawing-view) ())
27
28(defmethod draw-view-rectangle ((drawing brown-drawing-view) rectangle)
29 (declare (ignore rectangle))
30 (let* ((cocoa-view (cocoa-ref drawing))
31 (rect (dcc (#/bounds cocoa-view)))
32 (brown (dcc (#/brownColor ns:ns-color))))
33 (with-focused-view cocoa-view
34 (dcc (#/setFill brown))
35 (dcc (#_NSRectFill rect)))))
36
37(defmethod initialize-view :after ((w view-hierarchy-demo-window))
38 (let (left-box right-box button left-button right-button checkbox popup pulldown slider
39 drawing text (leftp t)
40 (normalfont (gui::default-font :name "Monaco" :size 10.0 :attributes nil))
41 (shoutfont (gui::default-font :name "Courier" :size 36.0 :attributes '(:bold :italic))))
42 (labels ((to-left ()
43 (retaining-objects (text)
44 (cond ((not leftp)
45 (remove-subviews right-box text)
46 (add-subviews left-box text))))
47 (setf leftp t))
48 (to-right ()
49 (retaining-objects (text)
50 (cond (leftp
51 (remove-subviews left-box text)
52 (add-subviews right-box text))))
53 (setf leftp nil))
54 (to-other ()
55 (retaining-objects (text)
56 (cond ((not leftp)
57 (remove-subviews right-box text)
58 (add-subviews left-box text))
59 (leftp
60 (remove-subviews left-box text)
61 (add-subviews right-box text))))
62 (setf leftp (not leftp)))
63 (generate-menu-items ()
64 (list (make-instance 'menu-item-view :title "Left" :action #'to-left)
65 (make-instance 'menu-item-view :title "Right" :action #'to-right)
66 (make-instance 'menu-item-view :title "Other" :action #'to-other)
67 (make-instance 'pop-up-menu :title "Text Options"
68 :menu-items
69 (list (make-instance 'menu-item-view :title "Oink"
70 :action #'(lambda () (setf (view-font text) normalfont)
71 (setf (view-text text) "Oink!")
72 (setf (view-size text) (point 60 20))
73 (setf (view-position text) (point 37 112))))
74 (make-instance 'menu-item-view :title "SHOUT!"
75 :action #'(lambda () (setf (view-font text) shoutfont)
76 (setf (view-text text) "HEY!")
77 (setf (view-size text) (point 160 60))
78 (setf (view-position text) (point 17 10))))
79 (make-instance 'pop-up-menu :title "Whisper"
80 :menu-items
81 (list (make-instance 'menu-item-view :title "sh!"
82 :action #'(lambda () (setf (view-font text) normalfont)
83 (setf (view-text text) "sh!")))
84 (make-instance 'menu-item-view :title "psst!"
85 :action #'(lambda () (setf (view-font text) normalfont)
86 (setf (view-text text) "psst!"))))))))))
87 (setf left-box (make-instance 'box-view
88 :position (point 17 51)
89 :size (point 208 199)
90 :title "Left"
91 :tip #'(lambda nil (unless leftp "The occupied box has no tooltip"))
92 :view-nick-name :leftbox)
93 right-box (make-instance 'box-view
94 :position (point 255 51)
95 :size (point 208 199)
96 :tip #'(lambda nil (if leftp "The occupied box has no tooltip"))
97 :title "Right"
98 :view-nick-name :rightbox)
99 button (make-instance 'push-button-view
100 :position (point 173 12)
101 :text "Change side"
102 :tip #'(lambda nil "Button tip does not work!")
103 :view-nick-name :push-button
104 :action #'to-other)
105 left-button (make-instance 'radio-button-view
106 :position (point 103 12)
107 :text "Left side"
108 :selected t
109 :view-nick-name :leftbutton
110 :tip #'(lambda nil (format nil
111 "Where's the amazing tooltip?~%The text is in the box on the ~:[right~;left~]"
112 leftp))
113 :action #'to-left)
114 right-button (make-instance 'radio-button-view
115 :position (point 243 12)
116 :text "Right side"
117 :view-nick-name :rightbutton
118 :tip #'(lambda nil (format nil
119 "Where's the amazing tooltip?~%The text is in the box on the ~:[right~;left~]"
120 leftp))
121
122 :action #'to-right)
123 checkbox (make-instance 'check-box-view
124 :position (point 173 12)
125 :text "Right side"
126 :view-nick-name :checkbox
127 :tip #'(lambda nil (format nil
128 "Where's the amazing tooltip?~%The text is in the box on the ~:[right~;left~]"
129 leftp))
130 :action #'to-other)
131 popup (make-instance 'pop-up-menu
132 :position (point 173 12)
133 :size (point 120 24)
134 :title "Command?"
135 :tip #'(lambda nil (format nil "Pop up menus can have tooltips,~%however their menu items cannot."))
136 :view-nick-name :pop-up-menu
137 :menu-items (generate-menu-items))
138 pulldown (make-instance 'pull-down-menu
139 :position (point 173 12)
140 :size (point 120 24)
141 :title "Command?"
142 :tip #'(lambda nil (format nil "Pull down menus can have tooltips,~%however their menu items cannot."))
143 :view-nick-name :pull-down-menu
144 :menu-items (generate-menu-items))
145 drawing (make-instance 'brown-drawing-view
146 :position (point 173 12)
147 :size (point 120 24)
148 :view-nick-name :drawing
149 :tip #'(lambda nil (format nil
150 "See the amazing tooltip!~%The text is in the box on the ~:[right~;left~]"
151 leftp))
152 :mouse-down #'(lambda (view &key &allow-other-keys)
153 (declare (ignore view))
154 (if (shift-key-p) (to-left) (to-other))))
155 text (make-instance 'static-text-view
156 :text "Oink!"
157 :view-font normalfont
158 :tip :identify
159 :position (point 37 112)
160 :size (point 60 20)
161 :fore-color (make-rgb :red 0 :green 0 :blue 255)
162 :back-color (make-rgb :red 255 :green 220 :blue 200))
163 slider (make-instance 'slider-view :min-value 0 :max-value 1
164 ; :text "How right" ;; No provision for title or text?
165 :position (point 173 12) :size (point 136 24)
166 :view-nick-name :slider
167 :tip #'(lambda nil (format nil
168 "See the amazing tooltip!~%The text is in the box on the ~:[right~;left~]"
169 leftp))
170 :action #'(lambda ()
171 (if (> (dcc (#/floatValue (cocoa-ref slider))) 0.5)
172 (to-right)
173 (to-left)))))
174 (add-subviews w left-box right-box)
175 (case (slot-value w 'with)
176 (:button (add-subviews w button))
177 (:radio (add-subviews w left-button right-button))
178 (:check (add-subviews w checkbox))
179 (:popup (add-subviews w popup))
180 (:pulldown (add-subviews w pulldown))
181 (:slider (add-subviews w slider))
182 (:drawing (add-subviews w drawing))
183 (otherwise (format t "~&** The WITH slot is ~s, it must be either :BUTTON :RADIO :CHECK :POPUP ~
184 :PULLDOWN :DRAWING or :SLIDER~%"
185 (slot-value w 'with))))
186 (add-subviews left-box text)
187 (setf (demo-textbox w) text)
188 (add-contextual-menu w
189 (make-instance 'contextual-menu
190 :menu-items (generate-menu-items))
191 t)
192 (window-show w))))
193
194(defparameter *w nil)
195
196(defparameter *run-file-chooser-anyway* nil)
197
198(defvar *closing-under-program-control* nil
199"Used in demonstrating tailored window-closing behaviour.")
200
201(defmethod window-may-close ((w view-hierarchy-demo-window))
202 (or *closing-under-program-control*
203 (when (y-or-n-dialog "Do you really want to close the window like this?")
204 (setf *w nil)
205 t)))
206
207(defun run-demo ()
208 (flet ((example (with)
209 (when *w (let ((*closing-under-program-control* t)) (perform-close *w)))
210 (setf *w (make-instance 'view-hierarchy-demo-window :with with))))
211 (dolist (spec `(("Did you know?" "Contextual Menus" ,#'(lambda nil (y-or-n-dialog
212 (format nil
213 "Did you know there are contextual menus ~
214 available - in many but not all places - ~
215 when you press control-click?"))))
216 ("Did you know?" "New TOOLS item" ,#'(lambda nil (y-or-n-dialog
217 (format nil
218 "Did you know there is a \"Choose Color\" ~
219 item added to the TOOLS menu?~%
220 (Sadly however there is no keyboard ~
221 shortcut for it and it simply prints the ~
222 chosen color in the console window.)"))))
223 ("Did you know?" "Tooltips" ,#'(lambda nil (y-or-n-dialog
224 (format nil
225 "Did you know that some sorts of view ~
226 have tooltips attached?~%~
227 (Sadly however some do not work as intended.)~%~
228 These may be fixed strings, dynamically ~
229 generated strings, or cocoa descriptions."))))
230 ("Did you know?" "Choose File menu items (not working)"
231 ,#'(lambda nil (y-or-n-dialog
232 (format nil
233 "Did you know that there are items in the File menu ~
234 and in the Easygui Demo menu that let you use a ~
235 Choose-File-Dialog? Sadly however they do not work properly ~
236 right now and will probably crash your CCL session. ~
237 If you want to go ahead anyway, first select the ~
238 \"Run File Chooser Anyway\" item."))))
239 ("Did you know?" "Flipped screen mode" ,#'(lambda nil (y-or-n-dialog
240 (format nil
241 "Did you know that it is possible to position windows ~
242 and items within them as if screen coordinates had their ~
243 origin at screen top-left, as in Digitool's MCL?"))))
244 ("Did you know?" "Cocoa tracing" ,#'(lambda nil (y-or-n-dialog
245 (format nil
246 "Did you know that debugging messages can be ~
247 produced when Cocoa calls are made? ~
248 This relies on the DCC macro being used conscientiously, ~
249 it is not automatic."))))
250 ("Did you know?" "Font and Color support" ,#'(lambda nil (y-or-n-dialog
251 (format nil
252 "Did you know that there is some limited support for ~
253 handling text fonts and colors and backgrounds? ~
254 Try out the \"SHOUT!\" options in a demo window menu."))))
255 ("Did you know?" "Window Close behaviour" ,#'(lambda nil (y-or-n-dialog
256 (format nil
257 "Did you know that windows can be made to invoke Lisp ~
258 code when they are told to close? The primary method ~
259 for Window-Should-Close decides whether the window ~
260 should close or not, before- and after-methods could ~
261 be used for other purposes. The Demo Window behaves ~
262 differently when you close the window as part of ~
263 creating a new one, and when you press its close button."))))
264 ("Give Example" "With Button" ,#'(lambda nil (example :button)))
265 ("Give Example" "With Radio Buttons" ,#'(lambda nil (example :radio)))
266 ("Give Example" "With Checkbox" ,#'(lambda nil (example :check)))
267 ("Give Example" "With Popup Menu" ,#'(lambda nil (example :popup)))
268 ("Give Example" "With Pulldown Menu" ,#'(lambda nil (example :pulldown)))
269 ("Give Example" "With Drawing" ,#'(lambda nil (example :drawing)))
270 ("Give Example" "With Slider" ,#'(lambda nil (example :slider)))
271 ("Flipping" "New windows are flipped" ,#'(lambda nil (setf *screen-flipped* t)))
272 ("Flipping" "New windows are not flipped" ,#'(lambda nil (setf *screen-flipped* nil)))
[13074]273 ("Tracing" "Cocoa Calls are traced" ,#'(lambda nil (setf easygui::*debug-cocoa-calls* t)))
274 ("Tracing" "Cocoa Calls are not traced" ,#'(lambda nil (setf easygui::*debug-cocoa-calls* nil)))
[11847]275 ("Color Picker" "Text" ,#'(lambda nil
276 (cl-user::process-run-function "Pick color for text in box"
277 #'(lambda nil
278 (gui::with-autorelease-pool
279 (let* ((textbox (if *w (demo-textbox *w)))
280 (color (if textbox
281 (get-fore-color textbox)
282 (make-rgb :red 0 :green 0 :blue 255))))
283 (setf color (user-pick-color :color color
284 :prompt "Pick a text color"))
285 (when textbox
286 (set-fore-color textbox color)
287 (invalidate-view textbox))))))))
288 ("Color Picker" "Background" ,#'(lambda nil
289 (cl-user::process-run-function "Pick color for text in box"
290 #'(lambda nil
291 (gui::with-autorelease-pool
292 (let* ((textbox (if *w (demo-textbox *w)))
293 (color (if textbox
294 (get-back-color textbox)
295 (make-rgb :red 255 :green 220 :blue 200))))
296 (setf color (user-pick-color :color color
297 :prompt "Pick a background color"))
298 (when textbox
299 (set-back-color textbox color t))))))))
300 ("Destroy this menu" ,#'(lambda nil (remove-topbar-item (list "Easygui Demo"))))
301 ("Run File Chooser Anyway" ,#'(lambda nil (setf *run-file-chooser-anyway* t)))
302 ("File" "Get a pathname" ,#'(lambda nil
303 (when *run-file-chooser-anyway*
304 (print "Getting a pathname(Easygui Demo Menu)...doomed to failure!")
305 (choose-file-dialog :button-string "Get a pathname(EG)"))))))
306 (add-topbar-item (cons "Easygui Demo" (butlast spec)) (first (last spec))))
307 (add-topbar-item '("Tools" "Choose Color") #'(lambda nil
308 (print (user-pick-color))))
309 (add-topbar-item '("File" "Get a pathname") #'(lambda nil
310 (when *run-file-chooser-anyway*
311 (running-on-main-thread ()
312 (print "Getting a pathname(File Menu)...doomed to failure")
313 (print (choose-file-dialog :button-string "Get a pathname(FILE)"))))))
314 (y-or-n-dialog "Have you spotted the new \"Easygui Demo\" item in the menubar?")))
315
316; (easygui-demo::run-extended-demo)
Note: See TracBrowser for help on using the repository browser.