source: trunk/ccl/examples/cocoa/easygui/views.lisp @ 7529

Last change on this file since 7529 was 7529, checked in by af, 13 years ago

Implement slider-view.

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