source: branches/easygui/ccl/examples/cocoa/easygui/views.lisp @ 7347

Last change on this file since 7347 was 7347, checked in by af, 12 years ago

Initial work on an interface to selections in text fields.

NB: Not entirely working yet.

File size: 10.2 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 view-text-mixin ()
18     ((text :initarg :text)))
19(defclass view-text-via-stringvalue-mixin (view-text-mixin) ())
20(defclass view-text-via-title-mixin (view-text-mixin) ())
21
22(defmethod view-text ((view view-text-via-stringvalue-mixin))
23  (lisp-string-from-nsstring (dcc (#/stringValue (cocoa-ref view)))))
24
25(defmethod view-text ((view view-text-via-title-mixin))
26  (lisp-string-from-nsstring (dcc (#/title (cocoa-ref view)))))
27
28(defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin))
29  (dcc (#/setStringValue: (cocoa-ref view) new-text)))
30
31(defmethod (setf view-text) (new-text (view view-text-via-title-mixin))
32  (dcc (#/setTitle: (cocoa-ref view) new-text)))
33
34(defmethod initialize-view :after ((view view-text-mixin))
35  (when (slot-boundp view 'text)
36    (setf (view-text view) (slot-value view 'text))))
37
38(defclass editable-mixin () ())
39
40(defmethod editable-p ((view editable-mixin))
41  (dcc (#/isEditable (cocoa-ref view))))
42
43(defmethod (setf editable-p) (editable-p (view editable-mixin))
44  (check-type editable-p boolean)
45  (dcc (#/setEditable: (cocoa-ref view) editable-p)))
46
47(defclass one-selection-mixin () ())
48
49(defmethod (setf selection) (selection (view one-selection-mixin))
50  (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection))))
51
52(defmethod selection ((view one-selection-mixin))
53  (let ((range (dcc (#/selectedRange (cocoa-ref view)))))
54    (if (= (ns:ns-range-location range) #$NSNotFound)
55        nil
56        (range (ns:ns-range-location range)
57               (ns:ns-range-length range)))))
58
59;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60;;; the actual views (when adding one,
61;;; consider *view-class-to-ns-class-map*):
62
63(defclass view (easy-cocoa-object)
64     ((position :initarg :position :reader view-position)
65      (size :initarg :size :reader view-size)
66      (frame-inited-p :initform nil)))
67
68(defclass window (view)
69     ((text :initarg :title :initform "" :reader window-title)
70      (zoomable-p :initarg :zoomable-p :initform t :reader window-zoomable-p)
71      (minimizable-p :initarg :minimizable-p :initform t
72                     :reader window-minimizable-p)
73      (resizable-p :initarg :resizable-p :initform t
74                   :reader window-resizable-p)
75      (closable-p :initarg :closable-p :initform t :reader window-closable-p)
76      (content-view :initform nil :reader window-content-view)))
77
78(defclass static-text-view (view view-text-via-stringvalue-mixin) ())
79
80(defclass text-input-view (view editable-mixin view-text-via-stringvalue-mixin
81                                ;; XXX: requires NSTextView, but this is an
82                                ;; NSTextField:
83                                #+not-yet one-selection-mixin)
84     ((input-locked-p :initform nil :initarg :input-locked-p
85                      :reader text-input-locked-p)))
86
87(defclass password-input-view (text-input-view)
88     ())
89
90(defclass push-button-view (view view-text-via-title-mixin)
91     ((default-button-p :initarg :default-button-p :initform nil
92                        :reader default-button-p)))
93
94(defclass form-view (view)
95     ((autosize-cells-p :initarg :autosize-cells-p :initform nil)
96      (interline-spacing :initarg :interline-spacing :initform 9)
97      ;; cell width
98      ))
99
100(defclass form-cell-view (view editable-mixin view-text-via-stringvalue-mixin)
101     ((ref :initarg :cocoa-ref)))
102
103(defclass box-view (view) ())
104
105(defparameter *view-class-to-ns-class-map*
106              '((static-text-view . ns:ns-text-field)
107                (text-input-view . ns:ns-text-field)
108                (password-input-view . ns:ns-secure-text-field)
109                (push-button-view . ns:ns-button)
110                (form-view . ns:ns-form)
111                (form-cell-view . ns:ns-form-cell)
112                (box-view . ns:ns-box)))
113
114;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
115;;; view initialization:
116
117(defmethod shared-initialize :around ((view view) new-slots &rest initargs)
118  (declare (ignore new-slots initargs))
119  (call-next-method)
120  (running-on-main-thread ()
121    (initialize-view view)))
122
123(defmethod initialize-view ((view view))
124  "Initializes the view via the class-to-ns-class map."
125  (when (slot-boundp view 'ref)
126    (format *trace-output* "hey, it's bound! (on ~A)~%" view)
127    (return-from initialize-view nil))
128  (let ((ns-view-class (cdr (assoc (class-name (class-of view))
129                                   *view-class-to-ns-class-map*))))
130    (when ns-view-class
131      (setf (cocoa-ref view)
132            (cond
133              ((and (slot-boundp view 'position)
134                    (slot-boundp view 'size))
135               (setf (slot-value view 'frame-inited-p) t)
136               (make-instance ns-view-class
137                  :with-frame (with-slots (position size) view
138                                 (ns-rect-from-points position size))))
139              (t (make-instance ns-view-class)))))))
140
141(defmethod initialize-view ((win window))
142  "Initialize size, title, flags."
143  (with-slots (position size) win
144     (let ((content-rect
145            (multiple-value-call
146                #'ns:make-ns-rect
147              (if (slot-boundp win 'position)
148                  (values (point-x position) (point-y position))
149                  (values *window-position-default-x*
150                          *window-position-default-y*))
151              (if (slot-boundp win 'size)
152                  (values (point-x size) (point-y size))
153                  (values *window-size-default-x*
154                          *window-size-default-y*))))
155           (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win))
156                        (flag-mask :resizable-p
157                                   (window-resizable-p win))
158                        (flag-mask :minimizable-p
159                                   (window-minimizable-p win))
160                        (flag-mask :closable-p
161                                   (window-closable-p win))
162                        #$NSTitledWindowMask)))
163       (setf (cocoa-ref win) (make-instance 'ns:ns-window
164                                :with-content-rect content-rect
165                                :style-mask style-mask
166                                :backing #$NSBackingStoreBuffered ; TODO?
167                                :defer nil))
168       ;; initialize the content-view proxy object
169       (setf (slot-value win 'content-view)
170             (make-instance 'view))
171       (setf (cocoa-ref (window-content-view win))
172             (dcc (#/contentView (cocoa-ref win)))))))
173
174(defmethod initialize-view :after ((view text-input-view))
175  (setf (editable-p view) (not (text-input-locked-p view))))
176
177(defmethod initialize-view :after ((view static-text-view))
178  (dcc (#/setEditable: (cocoa-ref view) nil))
179  (dcc (#/setBordered: (cocoa-ref view) nil))
180  (dcc (#/setBezeled: (cocoa-ref view) nil))
181  (dcc (#/setDrawsBackground: (cocoa-ref view) nil)))
182
183(defmethod initialize-view :after ((view push-button-view))
184  (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle))
185  (let ((default-button-p (slot-value view 'default-button-p)))
186    (typecase default-button-p
187      (cons
188       (dcc (#/setKeyEquivalent: (cocoa-ref view) (string
189                                                   (first default-button-p))))
190       (dcc (#/setKeyEquivalentModifierMask:
191         (cocoa-ref view)
192         (apply #'logior (mapcar #'key-mask (cdr default-button-p))))))
193      (string
194       (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p)))
195      (null)
196      (t
197       (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return))))))))
198
199(defmethod initialize-view :after ((view form-view))
200  (when (slot-boundp view 'interline-spacing)
201    (dcc (#/setInterlineSpacing: (cocoa-ref view)
202                             (coerce (slot-value view 'interline-spacing)
203                                     'double-float)))))
204
205;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206;;; view hierarchies:
207
208(defmethod add-1-subview :around ((view view) (window window))
209  (add-1-subview view (window-content-view window)))
210
211(defmethod add-1-subview :around ((view view) (super-view view))
212  "Correctly initialize view positions"
213  (call-next-method)
214  (with-slots (position size frame-inited-p) view
215     (unless frame-inited-p
216       (dcc (#/setFrameOrigin: (cocoa-ref view)
217                               (ns:make-ns-point (point-x position)
218                                                 (point-y position))))
219       (if (slot-boundp view 'size)
220           (dcc (#/setFrameSize: (cocoa-ref view)
221                                 (ns:make-ns-point (point-x size)
222                                                   (point-y size))))
223           (dcc (#/sizeToFit (cocoa-ref view)))))
224     (dcc (#/setNeedsDisplay: (cocoa-ref view) t))
225     (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t))))
226
227(defmethod add-1-subview ((view view) (super-view view))
228  (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view))))
229
230(defun add-subviews (superview subview &rest subviews)
231  (add-1-subview subview superview)
232  (dolist (subview subviews)
233    (add-1-subview subview superview))
234  superview)
235
236(defmethod window-show ((window window))
237  (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil))
238  window)
239
240
241;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242;;; Forms:
243
244(defmethod add-entry (entry (view form-view))
245  (make-instance 'form-cell-view
246     :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry))))
247
248(defun add-entries (view &rest entries)
249  (prog1 (mapcar (lambda (entry) (add-entry entry view)) entries)
250         (dcc (#/setAutosizesCells: (cocoa-ref view)
251                                    (slot-value view 'autosize-cells-p)))))
252
253(defmethod nth-cell (index view)
254  (let ((cocoa-cell (dcc (#/cellAtIndex: (cocoa-ref view) index))))
255    (when cocoa-cell
256      (make-instance 'form-cell-view :cocoa-ref cocoa-cell))))
257
258(defmethod (setf entry-text) (text view index)
259  (setf (view-text (nth-cell index view)) text))
260
261(defmethod entry-text (view index)
262  (view-text (nth-cell index view)))
263
Note: See TracBrowser for help on using the repository browser.