| 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 easygui::*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 easygui::*debug-cocoa-calls* t))) |
|---|
| 274 | ("Tracing" "Cocoa Calls are not traced" ,#'(lambda nil (setf easygui::*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) |
|---|
