source: trunk/source/examples/cocoa/easygui/example/extended-demo.lisp @ 11899

Last change on this file since 11899 was 11899, checked in by rme, 11 years ago

Port r11841-r11847 (easygui enhancements) back to trunk.

File size: 22.3 KB
Line 
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
13(setf *debug-cocoa-calls* nil)
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)))
273                    ("Tracing" "Cocoa Calls are traced"        ,#'(lambda nil (setf *debug-cocoa-calls* t)))
274                    ("Tracing" "Cocoa Calls are not traced"    ,#'(lambda nil (setf *debug-cocoa-calls* nil)))
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.