| 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)
|
|---|
