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

Last change on this file since 12153 was 12153, checked in by gb, 10 years ago

Wrap an (EVAL-WHEN (:COMPILE-TOPLEVEL) around the OPTIMIZE declamation.

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