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

Last change on this file since 11899 was 11899, checked in by rme, 11 years ago

Port r11841-r11847 (easygui enhancements) back to trunk.

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