source: trunk/source/examples/cocoa/easygui/views.lisp

Last change on this file was 14221, checked in by arthur, 9 years ago

add-subviews and remove-subviews do their work on main thread, obj-C isFlipped methods test for failures characteristic of the SLOT-VECTOR shortness problem, and write a message if EASYGUI::*REPORT-FLIPPING-ERRORS* is non-NIL.

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