source: release/1.3/source/examples/cocoa/easygui/views.lisp @ 12576

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

Don't make OPTIMIZE declamation persistent.

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