Changeset 11843
- Timestamp:
- Mar 26, 2009, 11:59:40 AM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/1.3/source/examples/cocoa/easygui/views.lisp
r9793 r11843 1 1 (in-package :easygui) 2 3 ; ---------------------------------------------------------------------- 4 ; This is the Clozure Common Lisp file named 'views.lisp', March 2009, 5 ; in the folder ccl/examples/cocoa/easygui/ 6 ; It has been modified by AWSC (arthur.cater@ucd.ie), based upon 7 ; an earlier contribution by an unknown author, borrowing also from 8 ; the 'Seuss.lisp' contribution of 'KD'. 9 ; Permission to use, further modify, disseminate, is hereby granted. 10 ; No warranty is expressed or implied. 11 ; Suggestions for - or accomplishment of - further improvement are welcome. 12 ; Accompanying documentation for this and related files will be written 13 ; and placed in ccl/examples/cocoa/easygui/documentation.txt 14 ; Testing has been only with Mac OS 10.5.6 on a 32 bit PPC 15 ; A demo of some capabilities is in 'easygui-demo-2.lisp' 16 ; ---------------------------------------------------------------------- 17 ; It extends previous work in the following principal ways: 18 ; - windows, views and subviews may have nicknames 19 ; - checkboxes and radio-buttons are provided 20 ; - menus (pop-up, pull-down, contextual, and main-menu) are provided 21 ; - MCL-like coordinates (Y increases downward) may optionally be used 22 ; for placing windows on the screen, placing subviews within windows, 23 ; and graphics within drawing views. 24 ; - views can generally respond to mouse entry, exit, movement 25 ; - static text views can respond to mouse clicks 26 ; - text views can have colored text and colored background 27 ; - windows can decline to close, and/or invoke daemons upon closing. 28 ; - views and windows can have specific OBJC subclassed counterparts 29 ; - Shift, Command, Control and Option keys may be interrogated 30 ; ---------------------------------------------------------------------- 31 32 (declaim (optimize (speed 0) (space 0) (compilation-speed 0) (safety 3) (debug 3))) 33 34 (defmacro running-on-this-thread ((&key (waitp t)) &rest body) 35 ;; The purpose of this trivial macro is to mark places where it is thought possible that 36 ;; it may be preferable to use running-on-main-thread. 37 (declare (ignore waitp)) 38 `(progn ,@body)) 39 40 41 (defparameter *screen-flipped* nil 42 "When NIL, window positions are taken as referring to their bottom right, 43 as per Cocoa's native coordinate system. 44 When non-NIL, window positions are taken to refer to their top left, 45 as per - for instance - Digitool's MCL. 46 The default orientation for graphics within a drawing view is set to 47 correspond at the time of creation of that drawing view.") 48 49 (defvar *cocoa-event* nil "Allows SHIFT-KEY-P & friends to operate on mouse clicks") 50 51 (defvar *suppress-window-flushing* nil " 52 When T, graphics output produced with calls to With-Focused-View will not be immediately 53 flushed. This can reduce flicker and increase speed when there are many related uses of 54 With-Focused-View. It is then necessary though to make sure that somebody somewhere 55 calls Flush-Graphics at an appropriate time. 56 The same effect can be obtained for an individual use of With-Focused-View by giving 57 :WITHOUT-FLUSH as the first form in its body.") 58 59 (defun ns-point-from-point (eg-point) ;; probably belongs in new-cocoa-bindings.lisp 60 (ns:make-ns-point (point-x eg-point) (point-y eg-point))) 61 62 (defmacro with-focused-view (cocoa-view &body forms) 63 ;; From KD's SEUSS.LISP but with added :WITHOUT-FLUSH syntax element 64 ;; If the first of forms is the keyword :WITHOUT-FLUSH, or if dynamically 65 ;; the value of *suppress-window-flushing* is non-NIL, then graphics output is not 66 ;; immediately flushed. 67 (let ((noflush (eq (first forms) ':without-flush))) 68 `(if (dcc (#/lockFocusIfCanDraw ,cocoa-view)) 69 (unwind-protect 70 (progn ,@forms) 71 (dcc (#/unlockFocus ,cocoa-view)) 72 ,(unless noflush 73 `(unless *suppress-window-flushing* (flush-graphics ,cocoa-view))))))) 74 75 (defun flush-graphics (cocoa-view) 76 (running-on-this-thread () 77 (dcc (#/flushGraphics (#/currentContext ns:ns-graphics-context))) 78 (dcc (#/flushWindow (#/window cocoa-view))))) 79 80 (defun cocoa-null (ptr) 81 (equalp ptr ccl:+null-ptr+)) 82 83 84 2 85 3 86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 17 100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 101 ;;; mixins 102 ;;; 103 ;;; Some view classes have an associated 'value', which can be accessed and set through 104 ;;; accessors STRING-VALUE-OF, INTEGER-VALUE-OF, FLOAT-VALUE-OF, DOUBLE-VALUE-OF 105 ;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT-VIEW, FORM-CELL-VIEW, SLIDER-VIEW 106 ;;; 107 ;;; Some view classes have an associated 'title', accessible and settable through VIEW-TEXT 108 ;;; Such classes include WINDOW, PUSH-BUTTON-VIEW, BOX-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW 109 ;;; 110 ;;; Some view classes have an associated 'text', also accessible and settable through VIEW-TEXT 111 ;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT-VIEW, FORM-CELL-VIEW 112 ;;; 113 ;;; Most of those, apart from STATIC-TEXT-VIEW, may be manually 'editable'. 114 ;;; 115 ;;; Some view classes have an associated 'action'. 116 ;;; Such classes include PUSH-BUTTON-VIEW, SLIDER-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-ITEM-VIEW 117 ;;; 118 ;;; Some view classes cannot ever have a contextual menu attached to them, even though their superview 119 ;;; and their subviews (if any) possibly do. 120 ;;; Such classes include PUSH-BUTTON-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW 121 ;;; Perhaps these should be the same classes as those with actions. 122 ;;; 123 ;;; No view classes inherit from 'one-selection-mixin' 124 ;;; Apparently it was intended that TEXT-INPUT-VIEW might do so some day. 125 ;;; 126 ;;; Some view classes have a single 'content view'. 127 ;;; Such classes include WINDOW, BOX-VIEW. 128 ;;; 129 ;;; Some view classes inherit from 'background-coloring-mixin' 130 ;;; Such classes include STATIC-TEXT-VIEW ... for now 131 ;;; 19 132 20 133 (defclass value-mixin () ()) 134 21 135 (defclass string-value-mixin (value-mixin) ()) 136 22 137 (defclass numeric-value-mixin (value-mixin) ()) 23 138 139 (defclass action-view-mixin () 140 ((action :initarg :action) 141 (enabled :accessor dialog-item-enabled-p :initarg :dialog-item-enabled-p :initform t))) 142 143 (defclass decline-menu-mixin () ()) 144 24 145 (macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer 25 &key new-value-form return-value-converter)146 &key (new-value-form 'new-value) (return-value-converter 'identity)) 26 147 (let ((name (intern (format nil "~A-VALUE-OF" lisp-type)))) 27 148 `(progn 28 149 (defmethod ,name ((o ,class)) 29 ,(if return-value-converter 30 `(,return-value-converter 31 (dcc (,cocoa-reader (cocoa-ref o)))) 32 `(dcc (,cocoa-reader (cocoa-ref o))))) 150 (,return-value-converter (dcc (,cocoa-reader (cocoa-ref o))))) 33 151 (defmethod (setf ,name) (new-value (o ,class)) 34 (dcc (,cocoa-writer (cocoa-ref o) 35 ,(or new-value-form 36 'new-value)))))))) 37 (def-type-accessor string-value-mixin string #/stringValue #/setStringValue: 38 :return-value-converter lisp-string-from-nsstring ) 39 152 (dcc (,cocoa-writer (cocoa-ref o) ,new-value-form))))))) 153 (def-type-accessor string-value-mixin string #/stringValue #/setStringValue: 154 :return-value-converter lisp-string-from-nsstring ) 40 155 (def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:) 41 (def-type-accessor numeric-value-mixin float 42 #/floatValue #/setFloatValue: 156 (def-type-accessor numeric-value-mixin float #/floatValue #/setFloatValue: 43 157 :new-value-form (coerce new-value 'single-float)) 44 (def-type-accessor numeric-value-mixin double 45 #/doubleValue #/setDoubleValue: 158 (def-type-accessor numeric-value-mixin double #/doubleValue #/setDoubleValue: 46 159 :new-value-form (coerce new-value 'double-float))) 47 160 48 161 (defclass view-text-mixin () 49 ((text :initarg :text))) 162 ((text :initarg :text :initarg :dialog-item-text))) 163 50 164 (defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mixin) 51 165 ()) 166 52 167 (defclass view-text-via-title-mixin (view-text-mixin) 53 168 ((text :initarg :title))) … … 60 175 61 176 (defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin)) 62 (setf (string-value-of view) new-text))177 (setf (string-value-of view) (ccl::%make-nsstring new-text))) 63 178 64 179 (defmethod (setf view-text) (new-text (view view-text-via-title-mixin)) 65 (dcc (#/setTitle: (cocoa-ref view) new-text))) 180 (dcc (#/setTitle: (cocoa-ref view) (ccl::%make-nsstring new-text))) 181 new-text) 66 182 67 183 (defmethod initialize-view :after ((view view-text-mixin)) … … 69 185 (setf (view-text view) (slot-value view 'text)))) 70 186 187 (defclass text-coloring-mixin () ()) 188 189 (defclass text-fonting-mixin () ()) 190 71 191 (defclass editable-mixin () ()) 72 192 … … 76 196 (defmethod (setf editable-p) (editable-p (view editable-mixin)) 77 197 (check-type editable-p boolean) 78 (dcc (#/setEditable: (cocoa-ref view) editable-p))) 198 (dcc (#/setEditable: (cocoa-ref view) editable-p)) 199 editable-p) 79 200 80 201 (defclass one-selection-mixin () ()) 81 202 82 203 (defmethod (setf selection) (selection (view one-selection-mixin)) 83 (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection)))) 204 (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection))) 205 selection) 84 206 85 207 (defmethod selection ((view one-selection-mixin)) … … 91 213 92 214 (defclass content-view-mixin () 93 (content-view)) 215 ((content-view) 216 (flipped :initarg :flipped :initform *screen-flipped*))) 217 218 (defclass contained-view (view) 219 ((flipped :initarg :flipped))) 94 220 95 221 (defmethod initialize-view :after ((view content-view-mixin)) 96 (setf (slot-value view 'content-view) 97 (make-instance 'view 98 :cocoa-ref (dcc (#/contentView (cocoa-ref view)))))) 222 (unless (slot-boundp view 'content-view) 223 (let ((containee (make-instance 'contained-view 224 :cocoa-ref (dcc (#/contentView (cocoa-ref view))) 225 :view-nick-name '%CONTENT-OF-CONTENT-VIEW% 226 :flipped (slot-value view 'flipped)))) 227 (setf (slot-value view 'content-view) containee 228 (slot-value containee 'parent) view)))) 99 229 100 230 (defmethod content-view ((view content-view-mixin)) … … 105 235 (defmethod (setf content-view) (new-content-view (view content-view-mixin)) 106 236 (setf (slot-value view 'content-view) new-content-view) 107 (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view)))) 237 (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view))) 238 new-content-view) 239 240 (defmethod set-dialog-item-enabled-p ((view action-view-mixin) value) 241 (unless (eq (not value) (not (dialog-item-enabled-p view))) 242 (setf (dialog-item-enabled-p view) value) 243 (dcc (#/setEnabled: (cocoa-ref view) (if value #$YES #$NO))))) 244 245 (defclass background-coloring-mixin () 246 ((drawsbackground :initform t :initarg :draws-background))) 247 248 (defmethod initialize-view :after ((view background-coloring-mixin)) 249 (dcc (#/setDrawsBackground: (cocoa-ref view) (slot-value view 'drawsbackground))) 250 (when (and (cocoa-ref view) (slot-boundp view 'background)) 251 (dcc (#/setBackgroundColor: (cocoa-ref view) (slot-value view 'background))))) 108 252 109 253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 114 258 ((position :initarg :position :reader view-position) 115 259 (size :initarg :size :reader view-size) 116 (frame-inited-p :initform nil))) 260 (frame-inited-p :initform nil) 261 (parent :reader view-container :initform nil) 262 (subviews :reader view-subviews :initarg :subviews :initform nil) 263 ;; When adding/removing multiple subviews, prevent multiple redraws. 264 ;; But - what code does those redraws? 265 (subviews-busy :accessor view-subviews-busy :initform nil) 266 (nickname :accessor view-nick-name :initarg :view-nick-name :initform nil) 267 (contextmenu :initarg :contextual-menu :initform nil) 268 (background :initarg :back-color :initform (#/whiteColor ns:ns-color)) 269 (foreground :initarg :fore-color :initform (#/blackColor ns:ns-color)) 270 (font :reader view-font :initarg :font :initarg :view-font :initform nil) 271 (specifically :reader view-specifically :initarg :specifically :initform nil) 272 (mouse-target :reader view-mouse-target :initform nil) 273 ;; Next three not yet operative 274 (tip :initarg :tip :reader view-tip :initform nil) 275 (tiptag :initform nil) 276 (mouse-enter :accessor view-mouse-enter :initarg :mouse-enter :initform nil) 277 (mouse-exit :accessor view-mouse-exit :initarg :mouse-exit :initform nil) 278 (mouse-move :accessor view-mouse-move :initarg :mouse-move :initform nil))) 117 279 118 280 (defclass window (content-view-mixin view-text-via-title-mixin view) … … 123 285 (resizable-p :initarg :resizable-p :initform t 124 286 :reader window-resizable-p) 125 (closable-p :initarg :closable-p :initform t :reader window-closable-p))) 126 127 (defclass static-text-view (view view-text-via-stringvalue-mixin) ()) 128 129 (defclass text-input-view (view editable-mixin view-text-via-stringvalue-mixin 287 (closable-p :initarg :closable-p :initform t :reader window-closable-p) 288 (level :initarg :window-level :accessor window-level 289 :initform (dcc (#_CGWindowLevelForKey #$kCGNormalWindowLevelKey))) 290 (hidden :initarg :hidden :reader window-hidden :initform nil) 291 (window-needs-display-on-show :initform t) 292 (optimized :initarg :optimized :initform t) ; Set to NIL if you anticipate overlapping views in this window 293 (style :initarg :window-style :initform #$NSTitledWindowMask)) 294 (:default-initargs :specifically 'cocoa-contained-view)) 295 296 (defmethod clear-page ((view view)) 297 (let* ((cview (cocoa-ref view)) 298 (rect (dcc (#/bounds cview))) 299 (color (slot-value view 'background))) 300 (with-focused-view cview 301 (dcc (#/setFill color)) 302 (dcc (#_NSRectFill rect))))) 303 304 (defmethod clear-page ((window content-view-mixin)) 305 (clear-page (content-view window))) 306 307 (defclass static-text-view (view view-text-via-stringvalue-mixin action-view-mixin text-coloring-mixin text-fonting-mixin background-coloring-mixin) 308 ((mousedown :initform nil :initarg :mouse-down :accessor static-text-view-mouse-down) 309 (mouseup :initform nil :initarg :mouse-up :accessor static-text-view-mouse-up) 310 (mousedragged :initform nil :initarg :mouse-dragged :accessor static-text-view-mouse-dragged))) 311 312 (defclass text-input-view (view editable-mixin text-coloring-mixin text-fonting-mixin view-text-via-stringvalue-mixin 130 313 ;; XXX: requires NSTextView, but this is an 131 314 ;; NSTextField: … … 137 320 ()) 138 321 139 (defclass push-button-view (view view-text-via-title-mixin )322 (defclass push-button-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) 140 323 ((default-button-p :initarg :default-button-p :initform nil 141 :reader default-button-p))) 324 :reader default-button-p) 325 (bezelstyle :reader bezel-style :initarg :bezel-style :initform :rounded))) 142 326 143 327 (defclass form-view (view) … … 156 340 ;; TODO: make this a mixin 157 341 (accept-key-events-p :initform nil :initarg :accept-key-events-p 158 :accessor accept-key-events-p))) 159 160 (defclass slider-view (view numeric-value-mixin) 342 :accessor accept-key-events-p) 343 (flipped :initform *screen-flipped* :initarg :flipped :reader flipped-p) 344 (mousedown :initform nil :initarg :mouse-down :accessor drawing-view-mouse-down) 345 (mouseup :initform nil :initarg :mouse-up :accessor drawing-view-mouse-up) 346 (mousedragged :initform nil :initarg :mouse-dragged :accessor drawing-view-mouse-dragged) 347 (draw-fn :initform nil :initarg :draw-fn :accessor draw-fn))) 348 349 (defclass slider-view (view numeric-value-mixin action-view-mixin) 161 350 ((max-value :initarg :max-value) 162 351 (min-value :initarg :min-value) 163 352 (tick-mark-count :initarg :tick-mark-count) 353 (tick-mark-values :initarg :tick-mark-values) 164 354 (discrete-tick-marks-p :initarg :discrete-tick-marks-p))) 165 355 356 ; ---------------------------------------------------------------------- 357 ; Specialisations of ns-xxx classes always begin 'cocoa-'. 358 ; They allow such things as 359 ; - finding the easygui window associated with a ns-view & easygui::view 360 ; - flipped windows, flipped drawing-views 361 ; - clickable static text, editable text fields 362 ; - tooltips 363 ; ---------------------------------------------------------------------- 364 365 (defun calculate-ns-tooltip (cview) 366 ;; Returns a Lisp string to bhe used as a tooltip, or NIL. 367 ;; Easygu Views may or may not be created with a specific :TIP keyword argument. 368 ;; If there is none, there will be no tooltip displayed for the corresponding cocoa-view. 369 ;; Otherwise, if the argument is 370 ;; - a string, that string is used 371 ;; - a function, then if its return value is 372 ;; - a string, that string is used 373 ;; - NIL, a string informing that the tooltip is null and cocoa-describing the cocoa-view 374 ;; (possibly useful for identifying this view if it turns up in errors or inspector) 375 ;; - else a string naming the type of the result returned (possibly useful for debugging) 376 ;; - the keyword :IDENTIFY, the cocoa-description of the cocoa-view 377 ;; - anything else, a string informing what type the argument is. 378 (let* ((egview (when (slot-boundp cview 'easygui-view) (slot-value cview 'easygui-view))) 379 (tip (when egview (slot-value egview 'tip)))) 380 (cond 381 ((stringp tip) 382 tip) 383 ((functionp tip) 384 (let ((it (funcall tip))) 385 (cond 386 ((stringp it) it) 387 ((null it) (format nil "Null tooltip for ~a" (lisp-string-from-nsstring (dcc (#/description cview))))) 388 (t (format nil "** Tooltip function returned non-string object of type ~s **" (type-of it)))))) 389 ((eq tip :identify) (lisp-string-from-nsstring (dcc (#/description cview)))) 390 ((null egview) 391 (format nil "** Cocoa view ~s has no EasyGui-View **" cview)) 392 ((null tip) (format nil "No tooltip for ~a" (lisp-string-from-nsstring (dcc (#/description cview))))) 393 (t (format nil "** Tip slot of Cocoa view ~s~%is of type ~s,~%not a string or a function or :IDENTIFY. **" cview tip))))) 394 395 (defmacro define-tooltip-accessor (cocoa-class) 396 `(progn 397 #| 398 (objc:defmethod #/view:stringForToolTip:point:userData: 399 ((view ,cocoa-class) 400 (tag :<NST>ool<T>ip<T>ag) 401 (point :<NSP>oint) 402 (userdata :id)) 403 (declare (ignorable tag point userdata)) 404 (ccl::%make-nsstring (or (calculate-ns-tooltip view) ""))) 405 |# 406 (objc:defmethod #/toolTip ((view ,cocoa-class)) 407 (ccl::%make-nsstring (or (calculate-ns-tooltip view) ""))))) 408 409 (defclass cocoa-window (ns:ns-window) 410 ((easygui-window :reader easygui-window-of)) 411 (:metaclass ns:+ns-object)) 412 413 (defmethod print-object ((object cocoa-window) stream) 414 (print-unreadable-object (object stream :type t :identity t) 415 (let ((egview (if (slot-boundp object 'easygui-window) (easygui-window-of object) nil))) 416 (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egview))))) 417 object) 418 419 (defmethod easygui-window-of ((eview view)) 420 (if (cocoa-ref eview) (easygui-window-of (cocoa-ref eview)) nil)) 421 422 (defmethod easygui-window-of ((nsview ns:ns-view)) 423 (let ((nswindow (dcc (#/window nsview)))) 424 (if (typep nswindow 'cocoa-window) (easygui-window-of nswindow) nil))) 425 426 (defclass cocoa-extension-mixin () 427 ((easygui-view :initarg :eg-view :reader easygui-view-of))) 428 429 (defmethod print-object ((object cocoa-extension-mixin) stream) 430 (print-unreadable-object (object stream :type t :identity t) 431 (let ((egview (if (slot-boundp object 'easygui-view) (easygui-view-of object) nil))) 432 (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egview))))) 433 object) 434 435 (defclass cocoa-text-field (cocoa-extension-mixin ns:ns-text-field) () 436 (:metaclass ns:+ns-object)) 437 438 (define-tooltip-accessor cocoa-text-field) 439 440 (defclass cocoa-mouseable-text-field (cocoa-text-field) () 441 (:metaclass ns:+ns-object)) 442 443 (define-tooltip-accessor cocoa-mouseable-text-field) 444 445 (defclass cocoa-contained-view (cocoa-extension-mixin ns:ns-view) 446 ((flipped :initarg :flipped :initform *screen-flipped*)) 447 (:metaclass ns:+ns-object)) 448 449 (define-tooltip-accessor cocoa-contained-view) 450 451 (defclass cocoa-secure-text-field (cocoa-extension-mixin ns:ns-secure-text-field) () 452 (:metaclass ns:+ns-object)) 453 454 (define-tooltip-accessor cocoa-secure-text-field) 455 456 (defclass cocoa-button (cocoa-extension-mixin ns:ns-button) () 457 (:metaclass ns:+ns-object)) 458 459 (define-tooltip-accessor cocoa-button) 460 461 (defclass cocoa-pop-up-button (cocoa-extension-mixin ns:ns-pop-up-button) () 462 (:metaclass ns:+ns-object)) 463 464 (define-tooltip-accessor cocoa-pop-up-button) 465 466 (defclass cocoa-menu-item (cocoa-extension-mixin ns:ns-menu-item) () 467 (:metaclass ns:+ns-object)) 468 469 (define-tooltip-accessor cocoa-menu-item) 470 471 (defclass cocoa-form (cocoa-extension-mixin ns:ns-form) () 472 (:metaclass ns:+ns-object)) 473 474 (define-tooltip-accessor cocoa-form) 475 476 (defclass cocoa-form-cell (cocoa-extension-mixin ns:ns-form-cell) () 477 (:metaclass ns:+ns-object)) 478 479 (define-tooltip-accessor cocoa-form-cell) 480 481 (defclass cocoa-box (cocoa-extension-mixin ns:ns-box) () 482 (:metaclass ns:+ns-object)) 483 484 (define-tooltip-accessor cocoa-box) 485 486 (defclass cocoa-drawing-view (cocoa-extension-mixin ns:ns-view) 487 ((flipped :initarg :flipped :initform *screen-flipped*)) 488 (:metaclass ns:+ns-object)) 489 490 (define-tooltip-accessor cocoa-drawing-view) 491 492 (defclass cocoa-slider (cocoa-extension-mixin ns:ns-slider) () 493 (:metaclass ns:+ns-object)) 494 495 (define-tooltip-accessor cocoa-slider) 496 166 497 (defparameter *view-class-to-ns-class-map* 167 '((static-text-view . ns:ns-text-field) 168 (password-input-view . ns:ns-secure-text-field) 169 (text-input-view . ns:ns-text-field) 170 (push-button-view . ns:ns-button) 171 (form-view . ns:ns-form) 172 (form-cell-view . ns:ns-form-cell) 173 (box-view . ns:ns-box) 174 (drawing-view . cocoa-drawing-view) 175 (slider-view . ns:ns-slider))) 498 '((static-text-view . cocoa-mouseable-text-field) 499 (password-input-view . cocoa-secure-text-field) 500 (text-input-view . cocoa-text-field) 501 (push-button-view . cocoa-button) 502 (check-box-view . cocoa-button) 503 (radio-button-view . cocoa-button) 504 (menu-view . cocoa-pop-up-button) 505 (menu-item-view . cocoa-menu-item) 506 (form-view . cocoa-form) 507 (form-cell-view . cocoa-form-cell) 508 (box-view . cocoa-box) 509 (drawing-view . cocoa-drawing-view) 510 (slider-view . cocoa-slider))) 511 512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 513 ;;; Targets for mouse-enter, mouse-exit and mouse-moved handling 514 515 (defclass easygui-mouse-target (ns:ns-object) 516 ((view :initarg :view :reader mouse-target-view :initform nil)) 517 (:metaclass ns:+ns-object)) 518 519 (objc:define-objc-method ((:void :mouse-entered (:id event)) easygui-mouse-target) 520 (let* ((view (mouse-target-view self)) 521 (fn (view-mouse-enter view))) 522 (when fn (funcall fn view :event event :allow-other-keys t)))) 523 524 (objc:define-objc-method ((:void :mouse-exited (:id event)) easygui-mouse-target) 525 (let* ((view (mouse-target-view self)) 526 (fn (view-mouse-exit view))) 527 (when fn (funcall fn view :event event :allow-other-keys t)))) 528 529 (objc:define-objc-method ((:void :mouse-move (:id event)) easygui-mouse-target) 530 (let* ((view (mouse-target-view self)) 531 (fn (view-mouse-move view))) 532 (when fn (funcall fn view :event event :allow-other-keys t)))) 176 533 177 534 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 185 542 186 543 (defmethod initialize-view ((view view)) 187 "Initializes the view via the class-to-ns-class map." 544 "Initializes the view using the class-to-ns-class map both as constraint 545 on valid values of the :SPECIFICALLY initarg, and as source of default value. 546 Also attaches contextual menu if there is one, and sets up mouse tracking 547 rectangle if the view has any non-NIL mouse-enter, mouse-exit or mouse-move." 188 548 (when (slot-boundp view 'ref) 189 549 (return-from initialize-view nil)) 190 550 (let ((ns-view-class (cdr (assoc (class-name (class-of view)) 191 551 *view-class-to-ns-class-map* 192 :test #'subtypep)))) 193 (when ns-view-class 194 (setf (cocoa-ref view) 552 :test #'subtypep))) 553 (specifically (view-specifically view)) 554 cocoaview) 555 (when specifically 556 (cond 557 ((not (find-class specifically nil)) 558 (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY does not name a class" specifically ns-view-class)) 559 ((or (null ns-view-class) (subtypep specifically ns-view-class)) 560 (setf ns-view-class specifically)) 561 (t (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY is not a subclass of ~a" specifically ns-view-class)))) 562 (if ns-view-class 563 (setf cocoaview 195 564 (cond 196 565 ((and (slot-boundp view 'position) … … 200 569 :with-frame (with-slots (position size) view 201 570 (ns-rect-from-points position size)))) 202 (t (make-instance ns-view-class))))))) 571 (t (make-instance ns-view-class))) 572 (cocoa-ref view) cocoaview) 573 (cerror "Continue with cocoa-ref unset" "No view class found for type ~a" (class-of view))) 574 (when (and cocoaview (slot-boundp view 'contextmenu)) 575 (let ((menu (slot-value view 'contextmenu))) 576 (cond 577 ((null menu)) 578 ((null ns-view-class)) 579 ((typep menu 'menu-view) 580 (dcc (#/setMenu: cocoaview (slot-value menu 'ns-menu)))) 581 (t (warn "Ignoring contextmenu value ~s for view ~s" menu view))))) 582 (when (and cocoaview (slot-value view 'tip)) 583 (setf (slot-value view 'tiptag) 584 (dcc (#/addToolTipRect:owner:userData: cocoaview (#/bounds cocoaview) cocoaview ccl:+null-ptr+)))) 585 (when (and cocoaview (or (slot-value view 'mouse-enter) (slot-value view 'mouse-exit) (slot-value view 'mouse-move))) 586 (let ((target (make-instance 'easygui-mouse-target :view view))) 587 (dcc (#/retain target)) 588 (dcc (#/addTrackingRect:owner:userData:assumeInside: 589 cocoaview 590 (dcc (#/bounds cocoaview)) 591 target 592 ccl:+null-ptr+ 593 #$YES)))))) 594 #| OS X Leopard should allow this but ... it didn't when I said VIEW not COCOAVIEW ...: 595 (area (make-instance 'ns:ns-tracking-area 596 :with-rect (dcc (#/bounds cocoaview)) 597 :options (logior #$NSTrackingMouseEnteredAndExited 598 #$NSTrackingActiveInKeyWindow 599 #$NSTrackingInVisibleRect) 600 :owner cocoaview 601 :userInfo #$NIL))) 602 (dcc (#/addTrackingArea: cocoaview area)))) 603 |# 604 605 (defun screen-height nil 606 (running-on-this-thread () 607 (ns:ns-rect-height (dcc (#/frame (#/objectAtIndex: (#/screens ns:ns-screen) 0)))))) 608 609 (defmethod view-content-rect ((view view) &optional hidden) 610 (if hidden 611 (ns:make-ns-rect 0 0 0 0) 612 (with-slots (position size) view 613 ;(if (slot-boundp view 'size) 614 ; (format t "~&View ~s has size ~s~%" view size) 615 ; (format t "~&View ~s has size unbound~%" view)) 616 (let* ((height (if (slot-boundp view 'size) (point-y size) *window-size-default-y*)) 617 (stated (if (slot-boundp view 'position) (point-y position) *window-position-default-y*)) 618 (screentop (screen-height)) ;; TODO: dtrt for multiple screens 619 (bottom (if (and *screen-flipped* (typep view 'window)) 620 (- screentop height stated) 621 stated))) 622 (ns:make-ns-rect 623 (if (slot-boundp view 'position) (point-x position) *window-position-default-x*) 624 bottom 625 (if (slot-boundp view 'size) (point-x size) *window-size-default-x*) 626 height))))) 203 627 204 628 (defmethod initialize-view ((win window)) 205 629 "Initialize size, title, flags." 206 (with-slots (position size) win 207 (let ((content-rect 208 (multiple-value-call 209 #'ns:make-ns-rect 210 (if (slot-boundp win 'position) 211 (values (point-x position) (point-y position)) 212 (values *window-position-default-x* 213 *window-position-default-y*)) 214 (if (slot-boundp win 'size) 215 (values (point-x size) (point-y size)) 216 (values *window-size-default-x* 217 *window-size-default-y*)))) 218 (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win)) 219 (flag-mask :resizable-p 220 (window-resizable-p win)) 221 (flag-mask :minimizable-p 222 (window-minimizable-p win)) 223 (flag-mask :closable-p 224 (window-closable-p win)) 225 #$NSTitledWindowMask))) 226 (setf (cocoa-ref win) (make-instance 'ns:ns-window 227 :with-content-rect content-rect 228 :style-mask style-mask 229 :backing #$NSBackingStoreBuffered ; TODO? 230 :defer nil))))) 630 (with-slots (level hidden optimized style flipped specifically) win 631 (unless (and (find-class specifically nil) (subtypep specifically 'cocoa-contained-view)) 632 (cerror "Ignore ~a and create content view of type ~a" 633 "Value given for \":specifically\" is ~a which is not a subtype of ~a" 634 specifically 'cocoa-contained-view) 635 (setf specifically 'cocoa-contained-view)) 636 (let* ((content-rect (view-content-rect win hidden)) 637 (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win)) 638 (flag-mask :resizable-p (window-resizable-p win)) 639 (flag-mask :minimizable-p (window-minimizable-p win)) 640 (flag-mask :closable-p (window-closable-p win)) 641 (if (or (window-resizable-p win) (window-minimizable-p win) (window-closable-p win)) 642 #$NSTitledWindowMask 643 0) 644 style)) 645 (c-win 646 (make-instance 'cocoa-window 647 :with-content-rect content-rect 648 :style-mask style-mask 649 :backing #$NSBackingStoreBuffered ; TODO? 650 :defer t)) 651 (containee (make-instance specifically))) 652 (setf (slot-value containee 'flipped) flipped) 653 (dcc (#/setFrame: containee content-rect)) 654 (dcc (#/setContentView: c-win containee)) 655 (dcc (#/setDelegate: c-win c-win)) 656 (dcc (#/setBackgroundColor: c-win (slot-value win 'background))) 657 (dcc (#/setLevel: c-win level)) 658 (when optimized (dcc (#/useOptimizedDrawing: c-win #$YES))) 659 (setf (cocoa-ref win) c-win) 660 (setf (slot-value c-win 'easygui-window) win) 661 (if hidden 662 (dcc (#/disableFlushWindow c-win)) 663 (window-show win)) 664 c-win))) 231 665 232 666 (defmethod initialize-view :after ((view text-input-view)) 233 (setf (editable-p view) (not (text-input-locked-p view)))) 667 (setf (editable-p view) (not (text-input-locked-p view))) 668 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 234 669 235 670 (defmethod initialize-view :after ((view static-text-view)) … … 237 672 (dcc (#/setBordered: (cocoa-ref view) nil)) 238 673 (dcc (#/setBezeled: (cocoa-ref view) nil)) 239 (dcc (#/setDrawsBackground: (cocoa-ref view) nil))) 674 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 675 676 (defmethod initialize-view :after ((view action-view-mixin)) 677 (when (and (slot-boundp view 'action) (slot-value view 'action)) 678 (setf (action view) (slot-value view 'action))) 679 (unless (dialog-item-enabled-p view) 680 (dcc (#/setEnabled: (cocoa-ref view) #$NO)))) 681 682 (defparameter *bezelstyle-alist* 683 `((:round . #.#$NSRoundedBezelStyle) 684 (:square . #.#$NSRegularSquareBezelStyle) 685 (:regular-square . #.#$NSRegularSquareBezelStyle) 686 (:thick-square . #.#$NSThickSquareBezelStyle) 687 (:thicker-square . #.#$NSThickerSquareBezelStyle) 688 (:disclosure . #.#$NSDisclosureBezelStyle) 689 (:Shadowless-square . #.#$NSShadowlessSquareBezelStyle) 690 (:circular . #.#$NSCircularBezelStyle) 691 (:textured-square . #.#$NSTexturedSquareBezelStyle) 692 (:help-button . #.#$NSHelpButtonBezelStyle) 693 (:small-square . #.#$NSSmallSquareBezelStyle) 694 (:textured-rounded . #.#$NSTexturedRoundedBezelStyle) 695 (:round-rect . #.#$NSRoundRectBezelStyle) 696 (:recessed . #.#$NSRecessedBezelStyle) 697 (:rounded-disclosure . #.#$NSRoundedDisclosureBezelStyle))) 698 699 (defun bezel-style-lookup (key) 700 (rest (or (assoc key *bezelstyle-alist*) (first *bezelstyle-alist*)))) 701 702 (defmethod (setf bezel-style) (stylename (view push-button-view)) 703 (setf (slot-value view 'bezelstyle) (if (assoc stylename *bezelstyle-alist*) stylename :round)) 704 (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (slot-value view 'bezelstyle)))) 705 stylename) 240 706 241 707 (defmethod initialize-view :after ((view push-button-view)) 242 (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle))708 (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (bezel-style view)))) 243 709 (let ((default-button-p (slot-value view 'default-button-p))) 244 710 (typecase default-button-p 245 711 (cons 246 (dcc (#/setKeyEquivalent: (cocoa-ref view) (string247 (first default-button-p))))712 (dcc (#/setKeyEquivalent: (cocoa-ref view) 713 (ccl::%make-nsstring (string (first default-button-p))))) 248 714 (dcc (#/setKeyEquivalentModifierMask: 249 715 (cocoa-ref view) 250 716 (apply #'logior (mapcar #'key-mask (cdr default-button-p)))))) 251 717 (string 252 (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p)))718 (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::%make-nsstring default-button-p)))) 253 719 (null) 254 720 (t 255 (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return)))))))) 721 (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return))))))) 722 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 723 724 (defmethod initialize-view :after ((view box-view)) 725 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 256 726 257 727 (defmethod initialize-view :after ((view form-view)) 258 728 (when (slot-boundp view 'interline-spacing) 259 729 (dcc (#/setInterlineSpacing: (cocoa-ref view) 260 ( coerce (slot-value view 'interline-spacing)261 'double-float)))))730 (gui::cgfloat (slot-value view 'interline-spacing))))) 731 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 262 732 263 733 (defmethod initialize-view :after ((view slider-view)) 264 (with-slots (discrete-tick-marks-p tick-mark-count min-value max-value) view 265 (cond 266 #| BUG: tick-mark-values is not defined. 267 ((and (not (slot-boundp view 'tick-mark-count)) 268 (slot-boundp view 'discrete-tick-marks-p) 269 (/= (length tick-mark-values) tick-mark-count)) 270 (error "Incompatible tick mark specification: ~A doesn't match ~ 271 count of ~A" tick-mark-values tick-mark-values))|# 272 ((or (not (slot-boundp view 'max-value)) 273 (not (slot-boundp view 'min-value))) 274 (error "A slider view needs both :min-value and :max-value set."))) 275 (dcc (#/setMinValue: (cocoa-ref view) (float min-value ns:+cgfloat-zero+))) 276 (dcc (#/setMaxValue: (cocoa-ref view) (float max-value ns:+cgfloat-zero+))) 734 (with-slots (discrete-tick-marks-p tick-mark-count tick-mark-values min-value max-value) view 735 (cond ((and (slot-boundp view 'tick-mark-count) 736 (slot-boundp view 'discrete-tick-marks-p) 737 (slot-boundp view 'tick-mark-values) 738 (/= (length tick-mark-values) tick-mark-count)) 739 (error "Incompatible tick mark specification: ~A doesn't match ~ 740 count of ~A" tick-mark-count tick-mark-values)) 741 ((or (not (slot-boundp view 'max-value)) 742 (not (slot-boundp view 'min-value))) 743 (error "A slider view needs both :min-value and :max-value set."))) 744 (dcc (#/setMinValue: (cocoa-ref view) (float min-value (or 1.0d0 ns:+cgfloat-zero+)))) 745 (dcc (#/setMaxValue: (cocoa-ref view) (float max-value (or 1.0d0 ns:+cgfloat-zero+)))) 277 746 (when (slot-boundp view 'tick-mark-count) 278 747 (dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count)) 279 748 (dcc (#/setAllowsTickMarkValuesOnly: 280 (cocoa-ref view) (not (not discrete-tick-marks-p))))))) 749 (cocoa-ref view) (not (not discrete-tick-marks-p)))))) 750 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 751 752 (defmethod initialize-view :after ((view text-coloring-mixin)) 753 (dcc (#/setTextColor: (cocoa-ref view) (slot-value view 'foreground)))) 754 755 (defmethod initialize-view :after ((view text-fonting-mixin)) 756 (when (slot-value view 'font) 757 (dcc (#/setFont: (cocoa-ref view) (slot-value view 'font))))) 758 759 (defmethod (setf view-font) ((new ns:ns-font) (view view)) 760 (setf (slot-value view 'font) new) 761 (dcc (#/setFont: (cocoa-ref view) new))) 762 763 ; ---------------------------------------------------------------------- 764 ; Modifying position / size of view / window 765 ; ---------------------------------------------------------------------- 766 767 (defmethod (setf view-position) (point (self view)) 768 (running-on-main-thread () 769 (setf (slot-value self 'position) point) 770 (when (slot-value self 'frame-inited-p) 771 (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self))) 772 (dcc (#/setNeedsDisplay (cocoa-ref self)))))) 773 774 (defmethod (setf view-position) (point (self window)) 775 (running-on-main-thread () 776 (setf (slot-value self 'position) point) 777 (unless (window-hidden self) 778 (let* ((contentrect (view-content-rect self nil)) 779 (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) contentrect)))) 780 (dcc (#/setFrame:display: (cocoa-ref self) framerect t)))))) 781 782 (defmethod (setf view-size) (point (self view)) 783 (running-on-main-thread () 784 (setf (slot-value self 'size) point) 785 (when (slot-value self 'frame-inited-p) 786 (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self))) 787 (dcc (#/setNeedsDisplay (cocoa-ref self)))))) 788 789 (defmethod (setf view-size) (point (self window)) 790 (running-on-main-thread () 791 (setf (slot-value self 'size) point) 792 (unless (window-hidden self) 793 (let* ((contentrect (view-content-rect self nil)) 794 (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) contentrect)))) 795 (dcc (#/setFrame:display: (cocoa-ref self) framerect t)))))) 281 796 282 797 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 283 798 ;;; view hierarchies: 799 800 (defmethod set-needs-display ((view view) flag) 801 (running-on-this-thread () 802 (dcc (#/setNeedsDisplay: (cocoa-ref view) flag)))) 803 804 (defmethod set-needs-display ((view content-view-mixin) flag) 805 (set-needs-display (content-view view) flag)) 806 807 (defmethod set-needs-display ((view window) flag) 808 (if (window-hidden view) 809 (setf (slot-value view 'window-needs-display-on-show) flag) 810 (set-needs-display (content-view view) flag))) 284 811 285 812 (defmethod add-1-subview :around ((view view) (cw-view content-view-mixin)) … … 290 817 (call-next-method) 291 818 (with-slots (position size frame-inited-p) view 292 (unless frame-inited-p 293 (dcc (#/setFrameOrigin: (cocoa-ref view) 294 (ns:make-ns-point (point-x position) 295 (point-y position)))) 296 (if (slot-boundp view 'size) 297 (dcc (#/setFrameSize: (cocoa-ref view) 298 (ns:make-ns-point (point-x size) 299 (point-y size)))) 300 (dcc (#/sizeToFit (cocoa-ref view))))) 301 (dcc (#/setNeedsDisplay: (cocoa-ref view) t)) 302 (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t)))) 819 (unless frame-inited-p 820 (setf frame-inited-p t) 821 (running-on-this-thread () 822 (let ((cocoa-view (cocoa-ref view))) 823 (dcc (#/setFrameOrigin: cocoa-view (ns-point-from-point position))) 824 (if (slot-boundp view 'size) 825 (dcc (#/setFrameSize: cocoa-view (ns-point-from-point size))) 826 (dcc (#/sizeToFit cocoa-view)))))) 827 (set-needs-display view t) 828 (unless (view-subviews-busy super-view) (set-needs-display super-view t)))) 303 829 304 830 (defmethod add-1-subview ((view view) (super-view view)) 305 (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view)))) 831 (running-on-this-thread () 832 (setf (slot-value view 'parent) super-view) 833 (push view (slot-value super-view 'subviews)) 834 (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view))))) 306 835 307 836 (defun add-subviews (superview subview &rest subviews) 837 (setf (view-subviews-busy superview) t) 308 838 (add-1-subview subview superview) 309 839 (dolist (subview subviews) 310 840 (add-1-subview subview superview)) 841 (set-needs-display superview t) 842 (setf (view-subviews-busy superview) nil) 311 843 superview) 312 844 … … 315 847 316 848 (defmethod remove-1-subview ((view view) (super-view view)) 317 (assert (eql (cocoa-ref super-view) (#/superview (cocoa-ref view)))) 849 (assert (eql (cocoa-ref super-view) (dcc (#/superview (cocoa-ref view))))) 850 (assert (member view (view-subviews super-view))) 851 (assert (eq super-view (slot-value view 'parent))) 318 852 (maybe-invalidating-object (view) 319 (#/removeFromSuperview (cocoa-ref view)))) 853 (setf (slot-value super-view 'subviews) (delete view (slot-value super-view 'subviews))) 854 (setf (slot-value view 'parent) nil) 855 (running-on-this-thread () 856 (dcc (#/removeFromSuperview (cocoa-ref view)))))) 320 857 321 858 (defun remove-subviews (superview subview &rest subviews) 859 (setf (view-subviews-busy superview) t) 322 860 (remove-1-subview subview superview) 323 861 (dolist (subview subviews) 324 862 (remove-1-subview subview superview)) 863 (set-needs-display superview t) 864 (setf (view-subviews-busy superview) nil) 325 865 superview) 326 866 327 867 (defmethod window-show ((window window)) 328 (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil)) 329 window) 868 (running-on-this-thread () 869 (let ((cwin (cocoa-ref window))) 870 (when (window-hidden window) 871 (setf (slot-value window 'hidden) nil) 872 (let* ((contentrect (view-content-rect window nil)) 873 (framerect (dcc (#/frameRectForContentRect: (cocoa-ref window) contentrect)))) 874 (dcc (#/setFrame:display: (cocoa-ref window) framerect nil))) 875 (when (dcc (#/isMiniaturized cwin)) (dcc (#/deminiaturize: cwin cwin))) 876 (when (slot-value window 'window-needs-display-on-show) 877 (setf (slot-value window 'window-needs-display-on-show) nil) 878 (dcc (#/setNeedsDisplay: (cocoa-ref (content-view window)) t)))) 879 (dcc (#/makeKeyAndOrderFront: cwin nil)) 880 (when (dcc (#/isFlushWindowDisabled cwin)) 881 (dcc (#/enableFlushWindow cwin)) 882 (dcc (#/flushWindow cwin))) 883 window))) 330 884 331 885 … … 335 889 (defmethod add-entry (entry (view form-view)) 336 890 (make-instance 'form-cell-view 337 :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry))))891 :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) (ccl::%make-nsstring entry))))) 338 892 339 893 (defun add-entries (view &rest entries) … … 358 912 359 913 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 914 ;;; Window closing 915 916 (defmethod window-may-close ((w window)) 917 "This generic is intended to allow applications to define :BEFORE and/or :AFTER methods 918 invoked when windows are closed. The default primary method returns T to indicate that 919 the window may close. If an overriding primary method returns NIL, the window will not 920 close in response to user action but will still close if the application quits. 921 (This is because window-may-close is called when the COCOA-WINDOW (specialised NS:NS-WINDOW) 922 that is attached to an EASYGUI::WINDOW object receives a performClose: message, as when 923 a user clicks the close button for example.)" 924 (declare (ignore w)) 925 t) 926 927 (defmethod perform-close ((w window)) 928 "This generic is intended to allow applications to mimic the user clicking a window's 929 close button." 930 (running-on-this-thread () 931 (dcc (#/performClose: (cocoa-ref w) ccl:+null-ptr+)))) 932 933 (objc:define-objc-method ((:<BOOL> :window-should-close (:id sender)) cocoa-window) 934 (declare (optimize (safety 0))) ; CCL v1.3 checks a faulty type declaration otherwise 935 (declare (ignore sender)) ; The cocoa-window has been set up as its own delegate. Naughty? 936 (if (window-may-close (easygui-window-of self)) #$YES #$NO)) 937 938 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 360 939 ;;; Drawing: 361 940 362 (defclass cocoa-drawing-view (ns:ns-view) 363 ((easygui-view :initarg :eg-view :reader easygui-view-of)) 364 (:metaclass ns:+ns-view)) 941 (defmethod clear-page ((cocoa-view cocoa-drawing-view)) 942 (let* ((view (easygui-view-of cocoa-view)) 943 (rect (dcc (#/bounds cocoa-view))) 944 (color (slot-value view 'background))) 945 (with-focused-view cocoa-view 946 (dcc (#/setFill color)) 947 (dcc (#_NSRectFill rect))))) 948 949 (objc::defmethod (#/isFlipped :<BOOL>) ((self cocoa-drawing-view)) 950 (if (slot-value self 'flipped) #$YES #$NO)) 951 952 (objc::defmethod (#/isFlipped :<BOOL>) ((self cocoa-contained-view)) 953 (if (slot-value self 'flipped) #$YES #$NO)) 365 954 366 955 (defmethod initialize-view :after ((view drawing-view)) 956 (setf (slot-value (cocoa-ref view) 'flipped) (slot-value view 'flipped)) 367 957 (setf (slot-value (cocoa-ref view) 'easygui-view) view)) 368 958 369 959 (objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view) 370 960 (rect :<NSR>ect)) 371 (d raw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)))961 (dcc (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)))) 372 962 373 963 (objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-view)) … … 376 966 (defgeneric draw-view-rectangle (view rectangle) 377 967 (:method ((view drawing-view) rectangle) 378 (declare (ignore view rectangle)) 968 (declare (ignorable view rectangle)) 969 (when (draw-fn view) 970 (let ((cview (cocoa-ref view))) 971 (with-focused-view cview (funcall (draw-fn view) view cview)))) 379 972 nil)) 380 973 … … 383 976 (setf rect (if rect 384 977 (rectangle-nsrect rect) 385 ( #/bounds (cocoa-ref view))))386 ( #/setNeedsDisplayInRect: (cocoa-ref view) rect))978 (dcc (#/bounds (cocoa-ref view))))) 979 (dcc (#/setNeedsDisplayInRect: (cocoa-ref view) rect))) 387 980 388 981 (define-useful-mouse-event-handling-routines cocoa-drawing-view) 982 (define-useful-mouse-event-handling-routines cocoa-mouseable-text-field) 983 984 (defmethod mouse-down ((view drawing-view) &key cocoa-event location button click-count delta) 985 (let ((mousefn (drawing-view-mouse-down view)) (*cocoa-event* cocoa-event)) 986 (when mousefn 987 (funcall mousefn view 988 :location location 989 :allow-other-keys t 990 :button button 991 :cocoa-event cocoa-event 992 :click-count click-count 993 :delta delta)))) 994 995 (defmethod mouse-up ((view drawing-view) &key cocoa-event location button click-count delta) 996 (let ((mousefn (drawing-view-mouse-up view)) (*cocoa-event* cocoa-event)) 997 (when mousefn 998 (funcall mousefn view 999 :location location 1000 :allow-other-keys t 1001 :button button 1002 :cocoa-event cocoa-event 1003 :click-count click-count 1004 :delta delta)))) 1005 1006 (defmethod mouse-dragged ((view drawing-view) &key cocoa-event location button click-count delta) 1007 (let ((mousefn (drawing-view-mouse-dragged view)) (*cocoa-event* cocoa-event)) 1008 (when mousefn 1009 (funcall mousefn view 1010 :location location 1011 :allow-other-keys t 1012 :button button 1013 :cocoa-event cocoa-event 1014 :click-count click-count 1015 :delta delta)))) 1016 1017 (defmethod mouse-down ((view static-text-view) &key cocoa-event location button click-count delta) 1018 (let ((mousefn (static-text-view-mouse-down view)) (*cocoa-event* cocoa-event)) 1019 (when mousefn 1020 (funcall mousefn view 1021 :location location 1022 :allow-other-keys t 1023 :button button 1024 :cocoa-event cocoa-event 1025 :click-count click-count 1026 :delta delta)))) 1027 1028 (defmethod mouse-up ((view static-text-view) &key cocoa-event location button click-count delta) 1029 (let ((mousefn (static-text-view-mouse-up view)) (*cocoa-event* cocoa-event)) 1030 (when mousefn 1031 (funcall mousefn view 1032 :location location 1033 :allow-other-keys t 1034 :button button 1035 :cocoa-event cocoa-event 1036 :click-count click-count 1037 :delta delta)))) 1038 1039 (defmethod mouse-dragged ((view static-text-view) &key cocoa-event location button click-count delta) 1040 (let ((mousefn (static-text-view-mouse-dragged view)) (*cocoa-event* cocoa-event)) 1041 (when mousefn 1042 (funcall mousefn view 1043 :location location 1044 :allow-other-keys t 1045 :button button 1046 :cocoa-event cocoa-event 1047 :click-count click-count 1048 :delta delta)))) 1049 1050 ; ------------------- 1051 (defmethod view-named (name (view view)) 1052 (find name (view-subviews view) :key #'view-nick-name)) 1053 1054 (defmethod view-named (name (container content-view-mixin)) 1055 (view-named name (content-view container))) 1056 1057 (defmethod view-subviews ((w content-view-mixin)) 1058 (view-subviews (content-view w))) 1059 1060 ; ---------------------- 1061 1062 (defmethod view-nickname-chain ((view view) &optional include-everything) " 1063 Yields two values: 1064 - a list of nicknames of containing views, starting with outermost container 1065 - the view or window that contains the view with the first name in the list, 1066 or NIL if the first name belongs to a window. 1067 If include-everything is NIL (the default), the list does not contain the 1068 autogenerated name for content views of windows or boxes, and contains names 1069 of views or windows that have non-NIL names. The second value may then be 1070 a view or window that has no nickname of its own. 1071 If include-everything is T, the list does contain the autogenerated name of 1072 content views of windows or boxes, it does contain NIL for views named NIL, 1073 and the second value will always be NIL." 1074 (do (chain 1075 nickname 1076 (outermost view (view-container outermost))) 1077 ((or (null outermost) 1078 (and (null (setf nickname (view-nick-name outermost))) 1079 (not include-everything))) 1080 (values chain outermost)) 1081 (when (or include-everything (not (eq nickname '%CONTENT-OF-CONTENT-VIEW%))) 1082 (push (view-nick-name outermost) chain)))) 1083 1084 ; ---------------------- 1085 1086 (defclass check-box-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) 1087 ((checked :initarg :checked :initform nil))) 1088 1089 (defmethod check-box-check ((self check-box-view) &optional perform) 1090 (running-on-this-thread () 1091 (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOnState) 1092 (if perform 1093 (dcc (#/performClick: (cocoa-ref self) nil)) 1094 (dcc (#/setState: (cocoa-ref self) #$NSOnState))) 1095 t))) 1096 1097 (defmethod initialize-view :after ((view check-box-view)) 1098 (when (cocoa-ref view) 1099 (dcc (#/setButtonType: (cocoa-ref view) #$NSSwitchButton)) 1100 (when (slot-value view 'checked) (check-box-check view)) 1101 (setf (slot-value (cocoa-ref view) 'easygui-view) view))) 1102 1103 (defmethod check-box-uncheck ((self check-box-view) &optional perform) 1104 (running-on-this-thread () 1105 (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOffState) 1106 (if perform 1107 (dcc (#/performClick: (cocoa-ref self) nil)) 1108 (dcc (#/setState: (cocoa-ref self) #$NSOffState))) 1109 t))) 1110 1111 (defmethod check-box-checked-p ((self check-box-view)) 1112 (eql (dcc (#/state (cocoa-ref self))) #$NSOnState)) 1113 1114 (defmethod (setf check-box-checked-p) (new (self check-box-view)) 1115 (if new 1116 (check-box-check self) 1117 (check-box-uncheck self)) 1118 new) 1119 1120 ; ------------------------- 1121 (defclass radio-button-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) 1122 ((selected :initarg :selected :reader radio-button-selected-p :initform nil) 1123 (cluster :initarg :cluster :initform '#:default-cluster)) 1124 (:default-initargs :action #'(lambda () nil))) 1125 1126 (defun deselect-radio-button-cohorts (radio-button-view) 1127 (when (view-container radio-button-view) 1128 (dolist (sibling (view-subviews (view-container radio-button-view))) 1129 (when (and (not (eq sibling radio-button-view)) 1130 (typep sibling 'radio-button-view) 1131 (eq (slot-value radio-button-view 'cluster) (slot-value sibling 'cluster)) 1132 (eql (dcc (#/state (cocoa-ref sibling))) #$NSOnState)) 1133 (setf (slot-value sibling 'selected) nil) 1134 (dcc (#/setState: (cocoa-ref sibling) #$NSOffState)))))) 1135 1136 (defmethod radio-button-select ((self radio-button-view) &optional perform) 1137 (running-on-this-thread () 1138 (if perform 1139 (dcc (#/performClick: (cocoa-ref self) nil)) 1140 (progn 1141 (deselect-radio-button-cohorts self) 1142 (setf (slot-value self 'selected) t) 1143 (dcc (#/setState: (cocoa-ref self) #$NSOnState)))))) 1144 1145 (defmethod initialize-view :after ((self radio-button-view)) 1146 (when (cocoa-ref self) 1147 (dcc (#/setButtonType: (cocoa-ref self) #$NSRadioButton)) 1148 (when (slot-value self 'selected) (radio-button-select self)) 1149 (setf (slot-value (cocoa-ref self) 'easygui-view) self))) 1150 1151 (defmethod radio-button-deselect ((self radio-button-view)) 1152 (running-on-this-thread () 1153 (dcc (#/setState: (cocoa-ref self) #$NSOffState)) 1154 (prog1 1155 (radio-button-selected-p self) 1156 (setf (slot-value self 'selected) nil)))) 1157 1158 (defmethod (setf action) (handler (view radio-button-view)) 1159 (call-next-method 1160 (lambda () 1161 (deselect-radio-button-cohorts view) 1162 (setf (slot-value view 'selected) t) 1163 (funcall handler)) 1164 view) 1165 handler) 1166 1167 ; ---------------------------------------------------------------------- 1168 ; INVALIDATE-VIEW 1169 ; ---------------------------------------------------------------------- 1170 1171 (defmethod invalidate-view ((view view) &optional total) 1172 (declare (ignorable total)) 1173 (let ((cview (cocoa-ref view))) 1174 (dcc (#/setNeedsDisplay: cview #$YES)))) 1175 1176 (defmethod invalidate-view ((window window) &optional total) 1177 (declare (ignorable total)) 1178 (let* ((cocoaview (cocoa-ref window)) 1179 (contentview (dcc (#/contentView cocoaview)))) 1180 (dcc (#/setNeedsDisplay: contentview #$YES)))) 1181 1182 ; ---------------------------------------------------------------------- 1183 ; Methods to GET- & SET- FORE- & BACK- COLOR 1184 ; ---------------------------------------------------------------------- 1185 1186 (defmethod set-fore-color ((view view) (color ns:ns-color)) 1187 (setf (slot-value view 'foreground) color)) 1188 1189 (defmethod set-fore-color :before ((view view-text-via-stringvalue-mixin) (color ns:ns-color)) 1190 (dcc (#/setTextColor: (cocoa-ref view) color))) 1191 1192 (defmethod set-fore-color ((view cocoa-extension-mixin) (color ns:ns-color)) 1193 (set-fore-color (easygui-view-of view) color)) 1194 1195 (defmethod set-back-color ((view view) (color ns:ns-color) &optional redisplay-p) 1196 (setf (slot-value view 'background) color) 1197 (when redisplay-p (invalidate-view view))) 1198 1199 (defmethod set-back-color :after ((view static-text-view) (color ns:ns-color) &optional redisplay-p) 1200 (dcc (#/setBackgroundColor: (cocoa-ref view) color)) 1201 (when redisplay-p (invalidate-view view))) 1202 1203 (defmethod set-back-color ((view cocoa-extension-mixin) (color ns:ns-color) &optional redisplay-p) 1204 (set-back-color (easygui-view-of view) color redisplay-p)) 1205 1206 (defmethod get-fore-color ((view view)) 1207 (slot-value view 'foreground)) 1208 1209 (defmethod get-fore-color ((view cocoa-extension-mixin)) 1210 (get-fore-color (easygui-view-of view))) 1211 1212 (defmethod get-back-color ((view view)) 1213 (slot-value view 'background)) 1214 1215 (defmethod get-back-color ((view cocoa-extension-mixin)) 1216 (get-back-color (easygui-view-of view))) 1217 1218 ; --------------------- Menus Begin --------------------- 1219 1220 (defmethod view-text ((self ns:ns-menu)) 1221 (lisp-string-from-nsstring (dcc (#/title self)))) 1222 1223 (defmethod (setf view-text) (new (self ns:ns-menu)) 1224 (running-on-this-thread () 1225 (dcc (#/setTitle: self (ccl::%make-nsstring new))) 1226 new)) 1227 1228 (defclass menu-view (view view-text-via-title-mixin decline-menu-mixin) 1229 ((selection :initarg :selection :reader menu-selection :initform nil) 1230 (menu-kind :initarg :menu-kind :reader menu-kind :initform :pull-down-menu) 1231 (menu-items :initarg :menu-items :reader menu-items :initform nil) 1232 ns-menu 1233 %result)) 1234 1235 (defclass menu-item-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) 1236 (parent-menu 1237 action 1238 submenu) 1239 (:default-initargs :action #'(lambda () nil))) 1240 1241 ;(defmethod (setf view-text) :after (new (menu menu-view)) 1242 ; (declare (ignorable new)) 1243 ; (dcc (#/setNeedsDisplay: (cocoa-ref menu) t))) 1244 1245 (defmethod initialize-instance :after ((self menu-view) &rest args &key menu-items selection) 1246 (declare (ignorable args selection)) 1247 (let ((ns-menu nil)) 1248 (if (slot-boundp self 'ns-menu) 1249 (setf ns-menu (slot-value self 'ns-menu)) 1250 (setf ns-menu (dcc (#/menu (cocoa-ref self))) 1251 (slot-value self 'ns-menu) ns-menu)) 1252 ;(format t "~&Initializing menu ~a with ~a items~%" self (length menu-items)) 1253 (dolist (item menu-items) 1254 ;(format t "~&Adding ~a to menu ~a~%" item self) 1255 (cond 1256 ((typep item 'menu-view) 1257 (let ((intermediary (make-instance 'menu-item-view 1258 :title (view-text item)))) 1259 (setf (slot-value intermediary 'submenu) item) 1260 (dcc (#/setSubmenu: (cocoa-ref intermediary) (slot-value item 'ns-menu))) 1261 (dcc (#/addItem: ns-menu (cocoa-ref intermediary))))) 1262 ((not (typep item 'menu-item-view)) 1263 (warn "Ignoring so-called menu item ~s" item)) 1264 ((slot-boundp item 'parent-menu) 1265 (warn "Ignoring menu item ~s, which is already an item in some menu" item)) 1266 (t (let ((coco (cocoa-ref item))) 1267 (dcc (#/addItem: ns-menu coco)) 1268 (setf (slot-value item 'parent-menu) self))))))) 1269 1270 (defmethod (setf action) (new (menu-item menu-item-view)) 1271 (call-next-method 1272 #'(lambda () 1273 (if (slot-boundp menu-item 'parent-menu) 1274 (let ((parent (slot-value menu-item 'parent-menu))) 1275 (setf (slot-value parent 'selection) menu-item) 1276 (setf (slot-value parent '%result) (funcall new))) 1277 (funcall new))) 1278 menu-item) 1279 new) 1280 1281 (defmethod set-menu-item-title ((menu-item menu-item-view) title) 1282 (running-on-this-thread () 1283 (dcc (#/setTitle: (cocoa-ref menu-item) (ccl::%make-nsstring title))))) 1284 1285 (defmethod set-menu-item-title ((menu-item ns:ns-menu-item) title) 1286 (running-on-this-thread () 1287 (dcc (#/setTitle: menu-item (ccl::%make-nsstring title))))) 1288 1289 ; ------------------- 1290 (defclass pop-up-menu (menu-view) 1291 () 1292 (:default-initargs :menu-kind :pop-up-menu)) 1293 1294 (defmethod initialize-instance :after ((self pop-up-menu) &rest args &key selection) 1295 (declare (ignorable args)) 1296 (with-slots (ns-menu menu-items) self 1297 (setf (view-text self) 1298 (cond 1299 ((null menu-items) 1300 "<No Items>") 1301 ((null selection) 1302 (setf (slot-value self 'selection) (first menu-items)) 1303 (view-text (first menu-items))) 1304 ((stringp selection) 1305 selection) 1306 ((member selection menu-items) 1307 (setf (slot-value self 'selection) selection) 1308 (view-text selection)) 1309 (t "<Selection Invalid>")))) 1310 (setf (slot-value (cocoa-ref self) 'easygui-view) self)) 1311 1312 ; ---------------------- 1313 (defclass pull-down-menu (menu-view) 1314 () 1315 (:default-initargs :menu-kind :pull-down-menu)) 1316 1317 (defmethod initialize-instance :after ((self pull-down-menu) &rest args &key title) 1318 (declare (ignorable args)) 1319 (running-on-this-thread () 1320 (dcc (#/insertItemWithTitle:atIndex: (cocoa-ref self) (ccl::%make-nsstring (or title "<No Title>")) 0)))) 1321 1322 (defmethod initialize-view :after ((self pull-down-menu)) 1323 (running-on-this-thread () 1324 (when (cocoa-ref self) 1325 (dcc (#/setPullsDown: (cocoa-ref self) #$YES)) 1326 (setf (slot-value (cocoa-ref self) 'easygui-view) self)))) 1327 1328 ; ----------------------- 1329 (defclass contextual-menu (menu-view) 1330 () 1331 (:default-initargs :menu-kind :contextual-menu)) 1332 1333 (defgeneric add-contextual-menu (container menu &optional subviews)) 1334 1335 (defmethod add-contextual-menu ((window window) (menu menu-view) &optional subviews) 1336 (add-contextual-menu (content-view window) menu subviews)) 1337 1338 (defmethod add-contextual-menu ((view view) (menu menu-view) &optional subviews) 1339 (running-on-this-thread () 1340 (dcc (#/setMenu: (cocoa-ref view) (slot-value menu 'ns-menu))) 1341 (when subviews 1342 (dolist (sub (view-subviews view)) 1343 (unless (or (not (cocoa-null (dcc (#/menu (cocoa-ref sub))))) 1344 (typep sub 'decline-menu-mixin)) 1345 (add-contextual-menu sub menu subviews)))))) 1346 1347 (defmethod add-contextual-menu ((view menu-view) (refusenik decline-menu-mixin) &optional subviews) 1348 (declare (ignore subviews)) 1349 (error "Cannot add a contextual menu to a view of class ~s" (type-of refusenik))) 1350 1351 ; ------------------------- 1352 (defun application-object nil 1353 (dcc (#/sharedApplication ns:ns-application))) 1354 1355 (defun application-main-menu nil 1356 (dcc (#/mainMenu (application-object)))) 1357 1358 (defgeneric navigate-menu (titles menu)) 1359 1360 (defmethod navigate-menu ((titles list) (menu menu-view)) 1361 ;; Returns NIL if the path of titles leads nowhere, when no appropriately titled menu-item or submenu exists; 1362 ;; Returns a EasyGui MENU-ITEM if the path of titles leads to a leaf item; 1363 ;; Returns a EasyGui MENU-VIEW if the path of titles leads to a submenu. 1364 (cond 1365 ((null titles) menu) 1366 (t (let ((it (find (first titles) (menu-items menu) :test #'equalp :key #'view-text))) 1367 (when it (navigate-menu (rest titles) it)))))) 1368 1369 (defun navigate-native-menu (titles menu) 1370 ;; Returns a NIL or a NS:NS-MENU-ITEM or a NS:NS-MENU 1371 ;; Returns a NS:NS-MENU when the title path leads to a submenu, 1372 ;; Returns a NS;NS-MENU-ITEM when the title path leads to a leaf menu item, 1373 ;; Returns NIL when the title path leads nowhere. 1374 (running-on-this-thread () 1375 (if (null titles) 1376 menu 1377 (do ((number (dcc (#/numberOfItems menu))) 1378 (index 0 (1+ index)) 1379 item found) 1380 ((or found (>= index number)) 1381 (cond 1382 ((or (null found) (null (rest titles))) found) 1383 ((null (dcc (#/hasSubmenu found))) nil) 1384 (t (navigate-native-menu (rest titles) (dcc (#/submenu found)))))) 1385 (setf item (dcc (#/itemAtIndex: menu index))) 1386 (if (or (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title item)))) 1387 ; The Apple menu item has title "" but its submenu has title "Apple", hence ... 1388 (and (dcc (#/hasSubmenu item)) 1389 (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title (dcc (#/submenu item)))))))) 1390 (setf found item)))))) 1391 1392 (defmethod navigate-topbar ((titles list)) 1393 (navigate-native-menu titles (application-main-menu))) 1394 1395 (defun add-menu-item (menu titles &optional action) 1396 ;; Adds a chain of submenus and a final leaf item with the indicated action. 1397 ;; If the final leaf item already exists, its action will be changed. Perhaps this is too dangerous. 1398 ;; The Apple submenu may not be altered; the application's submenu cannot be found. 1399 (cond 1400 ((null titles) 1401 (cerror "Return NIL" "No title path supplied")) 1402 ((not (and (consp titles) (stringp (first titles)))) 1403 (cerror "Return NIL, some empty submenus may have been created" "Title path is not a list of strings")) 1404 ((not (typep menu 'ns:ns-menu)) 1405 (cerror "Return NIL" "Not a Cocoa menu: ~s" menu)) 1406 (t (let* ((ns-title (ccl::%make-nsstring (first titles))) 1407 (item (dcc (#/itemWithTitle: menu ns-title))) 1408 (ns-nullstring (ccl::%make-nsstring ""))) 1409 (flet ((linkup (leaf action) ;; Modelled on code in easygui/action-targets.lisp 1410 (let ((target (make-instance 'generic-easygui-target :handler (or action #'(lambda () nil))))) 1411 (dcc (#/setTarget: leaf target)) 1412 (dcc (#/setAction: leaf (\@selector #/activateAction)))))) 1413 (cond 1414 ((equalp (first titles) "-") 1415 (if (rest titles) 1416 (cerror "Leave menu unchanged" "A menu separator (an item having title \"-\") may not have a submenu") 1417 (dcc (#/addItem: menu (dcc (#/separatorItem ns:ns-menu-item)))))) 1418 ((cocoa-null item) ;; No such item, something must be added 1419 (if (rest titles) 1420 (let ((number (dcc (#/numberOfItems menu))) 1421 (submenu (make-instance 'ns:ns-menu))) 1422 (running-on-this-thread () 1423 (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-title ccl:+null-ptr+ ns-nullstring)) 1424 (setf item (dcc (#/itemAtIndex: menu number))) ;; That's where it got put 1425 (dcc (#/initWithTitle: submenu ns-title)) 1426 (dcc (#/setSubmenu: item submenu))) 1427 (add-menu-item submenu (rest titles) action)) 1428 (let ((number (dcc (#/numberOfItems menu)))) 1429 (running-on-this-thread () 1430 (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-title ccl:+null-ptr+ ns-nullstring)) 1431 (setf item (dcc (#/itemAtIndex: menu number)))) 1432 (linkup item action)))) 1433 ((and (null (rest titles)) (dcc (#/hasSubmenu item))) 1434 (cerror "Leave menu unchanged" "An Action may not be added to any item with a submenu")) 1435 ((and (rest titles) (dcc (#/hasSubmenu item))) 1436 (add-menu-item (dcc (#/submenu item)) (rest titles) action)) 1437 ((rest titles) 1438 (cerror "Leave menu unchanged" "An existing menu item cannot be converted to have a submenu")) 1439 (t (linkup item action)))))))) ;; Change the action of an existing item: desirable, or dangerous? 1440 1441 (defun add-topbar-item (titles &optional action) 1442 (if (and (consp titles) (rest titles)) 1443 (add-menu-item (application-main-menu) titles action) 1444 (cerror "Return NIL" "Title path must be a list with at least two elements: ~s" titles))) 1445 1446 (defun remove-menu-item (menu titles retain-if-empty) 1447 (if (not (and (consp titles) (stringp (first titles)))) 1448 (cerror "Return NIL" "Title path is not a list of strings") 1449 (do ((number (dcc (#/numberOfItems menu))) 1450 (index 0 (1+ index)) 1451 item found) 1452 ((or found (>= index number)) 1453 (when found 1454 (if (rest titles) 1455 (when (dcc (#/hasSubmenu found)) 1456 (remove-menu-item (dcc (#/submenu found)) (rest titles) retain-if-empty) 1457 (unless (or retain-if-empty (> (dcc (#/numberOfItems (dcc (#/submenu found)))) 0)) 1458 (dcc (#/removeItem: menu found)))) 1459 (dcc (#/removeItem: menu found))))) 1460 (setf item (dcc (#/itemAtIndex: menu index))) 1461 (when (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title item)))) 1462 (setf found item))))) 1463 1464 (defun remove-topbar-item (titles &key retain-if-empty) 1465 (when (and (consp titles) 1466 (not (member (first titles) '("" "Apple") :test #'equalp))) 1467 (remove-menu-item (application-main-menu) titles retain-if-empty))) 1468 1469 (defun add-application-submenu (title &rest trees) " 1470 Adds a menu to the topbar application-menu with the given title. 1471 Its menu-items names are got from the CARs of the trees. 1472 The CDRs of these trees may consist either of further trees, allowing arbitrarily 1473 deep menu structures, or of a one-element list that is expected to be a parameterless 1474 function to be used as the Action of a leaf menu item. 1475 Example: 1476 (add-application-submenu \"Beeps\" 1477 '(\"Normal\" #'normal-beep) 1478 '(\"Stupid\" #'stupid-beep) 1479 '(\"Choose\" (\"Custom beep 1\" #'custom-beep-1-not-implemented) 1480 (\"Custom beep 2\" #'custom-beep-2-not-implemented))) 1481 " 1482 (labels ((valid-tree (tree) 1483 (and (consp tree) (stringp (first tree)))) 1484 (prepending (seq tree) 1485 (cond 1486 ((every #'valid-tree (rest tree)) 1487 (dolist (subtree (rest tree)) 1488 (prepending (append seq (list (first subtree))) (rest subtree)))) 1489 ((and (consp tree) (stringp (first tree)) (consp (rest tree)) (null (cddr tree))) 1490 (add-topbar-item (append seq (list (first tree))) (second tree))) 1491 (t (cerror "Ignore this tree" "Malformed tree ~s" tree))))) 1492 (if (every #'valid-tree trees) 1493 (dolist (subtree trees) (prepending (list title) subtree)) 1494 (cerror "Return NIL" "Malformed top-level trees")))) 1495 1496 ; --------------- 1497 ; Keyboard input handling 1498 1499 (defmethod view-key-event-handler ((view window) char) 1500 (declare (ignorable char)) 1501 #| (format t "~&Window ~s got ~:[~;Control-~]~:[~;Alt-~]~:[~;Command-~]~:[~;Shift-~]~s~%" 1502 view (control-key-p) (alt-key-p) (command-key-p) (shift-key-p) char)) 1503 |# 1504 nil) 1505 1506 (objc:define-objc-method ((:void :key-down (:id event)) cocoa-window) 1507 (let ((*cocoa-event* event)) 1508 (view-key-event-handler 1509 (easygui-window-of self) 1510 (schar (lisp-string-from-nsstring (dcc (#/charactersIgnoringModifiers event))) 0)))) 1511 1512 (defun shift-key-p nil 1513 (and *cocoa-event* 1514 (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) #$NSShiftKeyMask))))) 1515 1516 (defun control-key-p nil 1517 (and *cocoa-event* 1518 (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask :control)))))) 1519 1520 (defun alt-key-p nil 1521 (and *cocoa-event* 1522 (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask :alt)))))) 1523 1524 (defun command-key-p nil 1525 (and *cocoa-event* 1526 (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask :command)))))) 1527 1528 (defun view-mouse-position (view) 1529 (let* ((w (cocoa-ref (easygui-window-of view))) 1530 (mouselocation (dcc (#/mouseLocationOutsideOfEventStream w))) 1531 (cview (if (typep view 'window) (content-view view) view)) 1532 (nspt (dcc (#/convertPoint:fromView: (cocoa-ref cview) mouselocation #$NIL)))) 1533 ;; todo: check point is inside bounds, lest negative coords 1534 (point (ns:ns-point-x nspt) (ns:ns-point-y nspt))))
Note: See TracChangeset
for help on using the changeset viewer.