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

Last change on this file since 9793 was 9793, checked in by gz, 11 years ago

From Arthur Carter: fix *view-class-to-ns-class-map* to more specific first

File size: 15.4 KB
Line 
1(in-package :easygui)
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;; view protocol
5
6(defgeneric initialize-view (view)
7  (:documentation "Initializes the view with a cocoa object, sets it up
8according to initargs."))
9
10(defgeneric add-1-subview (view super-view)
11  (:documentation "Adds a subview to another view in the view hierarchy."))
12
13(defgeneric remove-1-subview (view super-view)
14  (:documentation "Removes a view from its superview, possibly deallocating it.
15To avoid deallocation, use RETAINING-OBJECTS"))
16
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;;; mixins
19
20(defclass value-mixin () ())
21(defclass string-value-mixin (value-mixin) ())
22(defclass numeric-value-mixin (value-mixin) ())
23
24(macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer
25                                     &key new-value-form return-value-converter)
26               (let ((name (intern (format nil "~A-VALUE-OF" lisp-type))))
27                 `(progn
28                    (defmethod ,name ((o ,class))
29                      ,(if return-value-converter
30                           `(,return-value-converter
31                             (dcc (,cocoa-reader (cocoa-ref o))))
32                           `(dcc (,cocoa-reader (cocoa-ref o)))))
33                    (defmethod (setf ,name) (new-value (o ,class))
34                      (dcc (,cocoa-writer (cocoa-ref o)
35                                          ,(or new-value-form
36                                               'new-value))))))))
37  (def-type-accessor string-value-mixin string #/stringValue #/setStringValue:
38                     :return-value-converter lisp-string-from-nsstring )
39
40  (def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:)
41  (def-type-accessor numeric-value-mixin float
42    #/floatValue #/setFloatValue:
43    :new-value-form (coerce new-value 'single-float))
44  (def-type-accessor numeric-value-mixin double
45    #/doubleValue #/setDoubleValue:
46    :new-value-form (coerce new-value 'double-float)))
47
48(defclass view-text-mixin ()
49     ((text :initarg :text)))
50(defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mixin)
51     ())
52(defclass view-text-via-title-mixin (view-text-mixin)
53     ((text :initarg :title)))
54
55(defmethod view-text ((view view-text-via-stringvalue-mixin))
56  (string-value-of view))
57
58(defmethod view-text ((view view-text-via-title-mixin))
59  (lisp-string-from-nsstring (dcc (#/title (cocoa-ref view)))))
60
61(defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin))
62  (setf (string-value-of view) new-text))
63
64(defmethod (setf view-text) (new-text (view view-text-via-title-mixin))
65  (dcc (#/setTitle: (cocoa-ref view) new-text)))
66
67(defmethod initialize-view :after ((view view-text-mixin))
68  (when (slot-boundp view 'text)
69    (setf (view-text view) (slot-value view 'text))))
70
71(defclass editable-mixin () ())
72
73(defmethod editable-p ((view editable-mixin))
74  (dcc (#/isEditable (cocoa-ref view))))
75
76(defmethod (setf editable-p) (editable-p (view editable-mixin))
77  (check-type editable-p boolean)
78  (dcc (#/setEditable: (cocoa-ref view) editable-p)))
79
80(defclass one-selection-mixin () ())
81
82(defmethod (setf selection) (selection (view one-selection-mixin))
83  (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection))))
84
85(defmethod selection ((view one-selection-mixin))
86  (let ((range (dcc (#/selectedRange (cocoa-ref view)))))
87    (if (= (ns:ns-range-location range) #$NSNotFound)
88        nil
89        (range (ns:ns-range-location range)
90               (ns:ns-range-length range)))))
91
92(defclass content-view-mixin ()
93     (content-view))
94
95(defmethod initialize-view :after ((view content-view-mixin))
96  (setf (slot-value view 'content-view)
97        (make-instance 'view
98           :cocoa-ref (dcc (#/contentView (cocoa-ref view))))))
99
100(defmethod content-view ((view content-view-mixin))
101  (assert (eql (cocoa-ref (slot-value view 'content-view))
102               (dcc (#/contentView (cocoa-ref view)))))
103  (slot-value view 'content-view))
104
105(defmethod (setf content-view) (new-content-view (view content-view-mixin))
106  (setf (slot-value view 'content-view) new-content-view)
107  (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view))))
108
109;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110;;; the actual views (when adding a new class,
111;;; consider *view-class-to-ns-class-map*):
112
113(defclass view (easy-cocoa-object)
114     ((position :initarg :position :reader view-position)
115      (size :initarg :size :reader view-size)
116      (frame-inited-p :initform nil)))
117
118(defclass window (content-view-mixin view-text-via-title-mixin view)
119     ((text :initarg :title :initform "" :reader window-title)
120      (zoomable-p :initarg :zoomable-p :initform t :reader window-zoomable-p)
121      (minimizable-p :initarg :minimizable-p :initform t
122                     :reader window-minimizable-p)
123      (resizable-p :initarg :resizable-p :initform t
124                   :reader window-resizable-p)
125      (closable-p :initarg :closable-p :initform t :reader window-closable-p)))
126
127(defclass static-text-view (view view-text-via-stringvalue-mixin) ())
128
129(defclass text-input-view (view editable-mixin view-text-via-stringvalue-mixin
130                                ;; XXX: requires NSTextView, but this is an
131                                ;; NSTextField:
132                                #+not-yet one-selection-mixin)
133     ((input-locked-p :initform nil :initarg :input-locked-p
134                      :reader text-input-locked-p)))
135
136(defclass password-input-view (text-input-view)
137     ())
138
139(defclass push-button-view (view view-text-via-title-mixin)
140     ((default-button-p :initarg :default-button-p :initform nil
141                        :reader default-button-p)))
142
143(defclass form-view (view)
144     ((autosize-cells-p :initarg :autosize-cells-p :initform nil)
145      (interline-spacing :initarg :interline-spacing :initform 9)
146      ;; cell width
147      ))
148
149(defclass form-cell-view (view editable-mixin view-text-via-stringvalue-mixin)
150     ())
151
152(defclass box-view (content-view-mixin view-text-via-title-mixin view) ())
153
154(defclass drawing-view (view)
155     (
156      ;; TODO: make this a mixin
157      (accept-key-events-p :initform nil :initarg :accept-key-events-p
158                           :accessor accept-key-events-p)))
159
160(defclass slider-view (view numeric-value-mixin)
161     ((max-value :initarg :max-value)
162      (min-value :initarg :min-value)
163      (tick-mark-count :initarg :tick-mark-count)
164      (discrete-tick-marks-p :initarg :discrete-tick-marks-p)))
165
166(defparameter *view-class-to-ns-class-map*
167              '((static-text-view . ns:ns-text-field)
168                (password-input-view . ns:ns-secure-text-field)
169                (text-input-view . ns:ns-text-field)
170                (push-button-view . ns:ns-button)
171                (form-view . ns:ns-form)
172                (form-cell-view . ns:ns-form-cell)
173                (box-view . ns:ns-box)
174                (drawing-view . cocoa-drawing-view)
175                (slider-view . ns:ns-slider)))
176
177;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
178;;; view initialization:
179
180(defmethod shared-initialize :around ((view view) new-slots &rest initargs)
181  (declare (ignore new-slots initargs))
182  (call-next-method)
183  (running-on-main-thread ()
184    (initialize-view view)))
185
186(defmethod initialize-view ((view view))
187  "Initializes the view via the class-to-ns-class map."
188  (when (slot-boundp view 'ref)
189    (return-from initialize-view nil))
190  (let ((ns-view-class (cdr (assoc (class-name (class-of view))
191                                   *view-class-to-ns-class-map*
192                                   :test #'subtypep))))
193    (when ns-view-class
194      (setf (cocoa-ref view)
195            (cond
196              ((and (slot-boundp view 'position)
197                    (slot-boundp view 'size))
198               (setf (slot-value view 'frame-inited-p) t)
199               (make-instance ns-view-class
200                  :with-frame (with-slots (position size) view
201                                 (ns-rect-from-points position size))))
202              (t (make-instance ns-view-class)))))))
203
204(defmethod initialize-view ((win window))
205  "Initialize size, title, flags."
206  (with-slots (position size) win
207     (let ((content-rect
208            (multiple-value-call
209                #'ns:make-ns-rect
210              (if (slot-boundp win 'position)
211                  (values (point-x position) (point-y position))
212                  (values *window-position-default-x*
213                          *window-position-default-y*))
214              (if (slot-boundp win 'size)
215                  (values (point-x size) (point-y size))
216                  (values *window-size-default-x*
217                          *window-size-default-y*))))
218           (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win))
219                        (flag-mask :resizable-p
220                                   (window-resizable-p win))
221                        (flag-mask :minimizable-p
222                                   (window-minimizable-p win))
223                        (flag-mask :closable-p
224                                   (window-closable-p win))
225                        #$NSTitledWindowMask)))
226       (setf (cocoa-ref win) (make-instance 'ns:ns-window
227                                :with-content-rect content-rect
228                                :style-mask style-mask
229                                :backing #$NSBackingStoreBuffered ; TODO?
230                                :defer nil)))))
231
232(defmethod initialize-view :after ((view text-input-view))
233  (setf (editable-p view) (not (text-input-locked-p view))))
234
235(defmethod initialize-view :after ((view static-text-view))
236  (dcc (#/setEditable: (cocoa-ref view) nil))
237  (dcc (#/setBordered: (cocoa-ref view) nil))
238  (dcc (#/setBezeled: (cocoa-ref view) nil))
239  (dcc (#/setDrawsBackground: (cocoa-ref view) nil)))
240
241(defmethod initialize-view :after ((view push-button-view))
242  (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle))
243  (let ((default-button-p (slot-value view 'default-button-p)))
244    (typecase default-button-p
245      (cons
246       (dcc (#/setKeyEquivalent: (cocoa-ref view) (string
247                                                   (first default-button-p))))
248       (dcc (#/setKeyEquivalentModifierMask:
249         (cocoa-ref view)
250         (apply #'logior (mapcar #'key-mask (cdr default-button-p))))))
251      (string
252       (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p)))
253      (null)
254      (t
255       (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return))))))))
256
257(defmethod initialize-view :after ((view form-view))
258  (when (slot-boundp view 'interline-spacing)
259    (dcc (#/setInterlineSpacing: (cocoa-ref view)
260                             (coerce (slot-value view 'interline-spacing)
261                                     'double-float)))))
262
263(defmethod initialize-view :after ((view slider-view))
264  (with-slots (discrete-tick-marks-p tick-mark-count min-value max-value) view
265     (cond 
266       #| BUG: tick-mark-values is not defined.
267       ((and (not (slot-boundp view 'tick-mark-count))
268       (slot-boundp view 'discrete-tick-marks-p)
269       (/= (length tick-mark-values) tick-mark-count))
270       (error "Incompatible tick mark specification: ~A doesn't match ~
271       count of ~A" tick-mark-values tick-mark-values))|#
272       ((or (not (slot-boundp view 'max-value))
273            (not (slot-boundp view 'min-value)))
274        (error "A slider view needs both :min-value and :max-value set.")))
275     (dcc (#/setMinValue: (cocoa-ref view) (float min-value ns:+cgfloat-zero+)))
276     (dcc (#/setMaxValue: (cocoa-ref view) (float max-value ns:+cgfloat-zero+)))
277     (when (slot-boundp view 'tick-mark-count)
278       (dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count))
279       (dcc (#/setAllowsTickMarkValuesOnly:
280             (cocoa-ref view) (not (not discrete-tick-marks-p)))))))
281
282;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
283;;; view hierarchies:
284
285(defmethod add-1-subview :around ((view view) (cw-view content-view-mixin))
286  (add-1-subview view (content-view cw-view)))
287
288(defmethod add-1-subview :around ((view view) (super-view view))
289  "Correctly initialize view positions"
290  (call-next-method)
291  (with-slots (position size frame-inited-p) view
292     (unless frame-inited-p
293       (dcc (#/setFrameOrigin: (cocoa-ref view)
294                               (ns:make-ns-point (point-x position)
295                                                 (point-y position))))
296       (if (slot-boundp view 'size)
297           (dcc (#/setFrameSize: (cocoa-ref view)
298                                 (ns:make-ns-point (point-x size)
299                                                   (point-y size))))
300           (dcc (#/sizeToFit (cocoa-ref view)))))
301     (dcc (#/setNeedsDisplay: (cocoa-ref view) t))
302     (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t))))
303
304(defmethod add-1-subview ((view view) (super-view view))
305  (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view))))
306
307(defun add-subviews (superview subview &rest subviews)
308  (add-1-subview subview superview)
309  (dolist (subview subviews)
310    (add-1-subview subview superview))
311  superview)
312
313(defmethod remove-1-subview ((view view) (cw-view content-view-mixin))
314  (remove-1-subview view (content-view cw-view)))
315
316(defmethod remove-1-subview ((view view) (super-view view))
317  (assert (eql (cocoa-ref super-view) (#/superview (cocoa-ref view))))
318  (maybe-invalidating-object (view)
319    (#/removeFromSuperview (cocoa-ref view))))
320
321(defun remove-subviews (superview subview &rest subviews)
322  (remove-1-subview subview superview)
323  (dolist (subview subviews)
324    (remove-1-subview subview superview))
325  superview)
326
327(defmethod window-show ((window window))
328  (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil))
329  window)
330
331
332;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333;;; Forms:
334
335(defmethod add-entry (entry (view form-view))
336  (make-instance 'form-cell-view
337     :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry))))
338
339(defun add-entries (view &rest entries)
340  (prog1 (mapcar (lambda (entry) (add-entry entry view)) entries)
341         (dcc (#/setAutosizesCells: (cocoa-ref view)
342                                    (slot-value view 'autosize-cells-p)))))
343
344(defmethod cell-count ((view form-view))
345  (dcc (#/numberOfRows (cocoa-ref view))))
346
347(defmethod nth-cell (index view)
348  (assert (< index (cell-count view)))
349  (let ((cocoa-cell (dcc (#/cellAtIndex: (cocoa-ref view) index))))
350    (when cocoa-cell
351      (make-instance 'form-cell-view :cocoa-ref cocoa-cell))))
352
353(defmethod (setf entry-text) (text view index)
354  (setf (view-text (nth-cell index view)) text))
355
356(defmethod entry-text (view index)
357  (view-text (nth-cell index view)))
358
359;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360;;; Drawing:
361
362(defclass cocoa-drawing-view (ns:ns-view)
363     ((easygui-view :initarg :eg-view :reader easygui-view-of))
364  (:metaclass ns:+ns-view))
365
366(defmethod initialize-view :after ((view drawing-view))
367  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
368
369(objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view)
370                                     (rect :<NSR>ect))
371  (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)))
372
373(objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-view))
374  (accept-key-events-p (easygui-view-of view)))
375
376(defgeneric draw-view-rectangle (view rectangle)
377  (:method ((view drawing-view) rectangle)
378    (declare (ignore view rectangle))
379    nil))
380
381(defmethod redisplay ((view drawing-view)
382                      &key rect)
383  (setf rect (if rect
384                 (rectangle-nsrect rect)
385                 (#/bounds (cocoa-ref view))))
386  (#/setNeedsDisplayInRect: (cocoa-ref view) rect))
387
388(define-useful-mouse-event-handling-routines cocoa-drawing-view)
Note: See TracBrowser for help on using the repository browser.