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

Last change on this file since 13061 was 13061, checked in by rme, 10 years ago

Qualify access to *debug-cocoa-calls*. In DEFINE-TOOLTIP-ACCESSOR,
correct lambda list for #/view:stringForToolTip:point:userData:.

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