/[gtk-cffi]/gtk-cffi/ext/lisp-model.lisp
ViewVC logotype

Contents of /gtk-cffi/ext/lisp-model.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Mon Dec 31 13:55:22 2012 UTC (15 months, 2 weeks ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.7: +4 -4 lines
Fixed gtk-ext
1 (in-package #:gtk-cffi-ext)
2
3 (defclass lisp-model-impl ()
4 ((columns :initarg :columns :accessor columns)))
5
6 (defclass lisp-model-list (lisp-model-impl)
7 ())
8
9 (defclass lisp-model-tree (lisp-model-impl)
10 ())
11
12 ;; 1 1
13 ;; 2 1.1
14 ;; 3 1.2
15 ;; 4 2
16 ;; 5 2.1
17 ;; 6 2.1.1
18 ;; tree = (child*)
19 ;; child = (row child*)
20 ;; row = (field*)
21 ;; path = (index*)
22 ;; (((1) ((1.1)) ((1.2))) ((2) ((2.1) ((2.1.1)))))
23 ;;
24 ;; a[i] = (cons path child)
25
26 (defstruct node
27 (parent nil :type (or null node))
28 (children nil :type (or null (vector node)))
29 (address "" :type string)
30 (index 0 :type fixnum))
31
32
33 (defun make-tree-array (tree)
34 (let (res arr-tree)
35 (labels ((process-child (child)
36 (declare (special i prefix))
37 (let ((address (concatenate 'string prefix ":"
38 (princ-to-string i))))
39 (let ((index (length res)))
40 (push (cons (subseq address 1) (car child)) res)
41 (incf i)
42 (let ((i 0) (prefix address))
43 (declare (special i prefix))
44 (cons index
45 (process (cdr child)))))))
46 (process (seq)
47 (let ((l (mapcar #'process-child seq)))
48 (when l (coerce l 'simple-vector)))))
49 (let ((i 0) prefix)
50 (declare (special i prefix))
51 (setf arr-tree (process tree))))
52 (values (coerce (nreverse res) 'simple-vector) arr-tree)))
53
54 (defclass lisp-model-tree-array (lisp-model-tree)
55 ((array :accessor larray :type (array tree-item))
56 (tree :accessor tree :type list))
57 (:documentation
58 "ARRAY should contain lists with address as car and columns data as cdr"))
59
60 (defmethod shared-initialize :after ((o lisp-model-tree-array) slot-names
61 &key tree)
62 (setf (values (larray o) (tree o)) (make-tree-array tree)))
63
64 (defclass lisp-model-array (lisp-model-list)
65 ((array :initarg :array :accessor larray :type (array list)))
66 (:documentation "ARRAY should contain lists with columns data"))
67
68 (defgeneric get-flags (lisp-model-impl)
69 (:method ((lisp-model-list lisp-model-list))
70 2)
71 (:method ((lisp-model-tree lisp-model-tree))
72 0))
73
74 (defgeneric get-n-columns (lisp-model-impl)
75 (:method ((lisp-model-impl lisp-model-impl))
76 (length (columns lisp-model-impl))))
77
78 (defgeneric get-column-type (lisp-model-impl index)
79 (:method ((lisp-model-impl lisp-model-impl) index)
80 (keyword->g-type (nth index (columns lisp-model-impl)))))
81
82 (defgeneric lisp-model-length (lisp-model-list)
83 (:method ((lisp-model-array lisp-model-array))
84 (length (larray lisp-model-array))))
85
86 (defgeneric get-iter (lisp-model iter path)
87 (:method ((lisp-model-impl lisp-model-impl) iter path)
88 (warn "Undefined implementation of GET-ITER for ~a" lisp-model-impl)))
89
90 (defun set-iter (iter index)
91 (setf (stamp iter) 0
92 (u1 iter) (make-pointer index))
93 t)
94
95 (defmethod get-iter ((lisp-model-list lisp-model-list) iter path)
96 (let ((index (aref path 0)))
97 (when (< index (lisp-model-length lisp-model-list))
98 (set-iter iter index))))
99
100 (defun descend (tree address)
101 (when (> (length tree) (car address))
102 (let ((child (aref tree (car address))))
103 (if (cdr address)
104 (descend (cdr child) (cdr address))
105 (values t (car child) (cdr child))))))
106
107 (defmethod get-iter ((lisp-model lisp-model-tree-array) iter path)
108 (multiple-value-bind (found index) (descend (tree lisp-model)
109 (coerce path 'list))
110 (when found (set-iter iter index))))
111
112 (defun iter->index (iter)
113 (pointer-address (u1 iter)))
114
115 (defun iter->aref (lisp-model iter)
116 (aref (larray lisp-model) (iter->index iter)))
117
118 (defgeneric get-path (lisp-model-impl iter)
119 (:method ((lisp-model-list lisp-model-list) iter)
120 (list (iter->index iter)))
121 (:method ((lisp-model lisp-model-tree-array) iter)
122 (car (iter->aref lisp-model iter))))
123
124 (defun set-value (g-value value-list n)
125 (g-object-cffi::init-g-value g-value nil (nth n value-list) t))
126
127
128 (defgeneric get-value (lisp-model-impl iter n value)
129 (:method ((lisp-model lisp-model-array) iter n value)
130 (set-value value (iter->aref lisp-model iter) n))
131 (:method ((lisp-model lisp-model-tree-array) iter n value)
132 (set-value value (cdr (iter->aref lisp-model iter)) n)))
133
134 (defun set-iter-checked (lisp-model-list iter index)
135 (when (and (>= index 0) (< index (lisp-model-length lisp-model-list)))
136 (set-iter iter index)))
137
138 (defun path-string->list (str)
139 (let (res (buf ""))
140 (iter
141 (for ch in-string str)
142 (if (char-equal ch #\:)
143 (progn
144 (push (parse-integer buf) res)
145 (setf buf ""))
146 (setf buf (concatenate 'string buf
147 (make-string 1 :initial-element ch)))))
148 (push (parse-integer buf) res)
149 (nreverse res)))
150
151 (defun iter->path-list (tree iter)
152 (path-string->list (car (iter->aref tree iter))))
153
154
155 (defun move-tree-iter-checked (lisp-model-tree iter delta)
156 (multiple-value-bind (found index)
157 (descend (tree lisp-model-tree)
158 (let ((r (iter->path-list lisp-model-tree iter)))
159 (incf (car (last r)) delta)
160 r))
161 (when found (set-iter iter index))))
162
163 (defgeneric iter-next (lisp-model-impl iter)
164 (:method ((lisp-model-list lisp-model-list) iter)
165 (set-iter-checked lisp-model-list iter (1+ (iter->index iter))))
166 (:method ((lisp-model lisp-model-tree-array) iter)
167 (move-tree-iter-checked lisp-model iter 1)))
168
169 (defgeneric iter-previous (lisp-model-impl iter)
170 (:method ((lisp-model-list lisp-model-list) iter)
171 (set-iter-checked lisp-model-list iter (1- (iter->index iter))))
172 (:method ((lisp-model lisp-model-tree-array) iter)
173 (move-tree-iter-checked lisp-model iter -1)))
174
175 (defgeneric iter-children (lisp-model-impl iter parent)
176 (:method ((lisp-model-list lisp-model-list) iter parent)
177 ; (break)
178 (unless parent
179 (set-iter iter 0)))
180 (:method ((lisp-model lisp-model-tree-array) iter parent)
181 (multiple-value-bind (found index)
182 (descend (tree lisp-model)
183 (let ((r (iter->path-list lisp-model parent)))
184 (append r '(0))))
185 (when found (set-iter iter index)))))
186
187 (defgeneric iter-has-child (lisp-model-impl iter)
188 (:method ((lisp-model-list lisp-model-list) iter)
189 nil)
190 (:method ((lisp-model lisp-model-tree-array) iter)
191 (descend (tree lisp-model)
192 (let ((r (iter->path-list lisp-model iter)))
193 (append r '(0))))))
194
195 (defgeneric iter-n-children (lisp-model-impl iter)
196 (:method ((lisp-model-list lisp-model-list) iter)
197 0)
198 (:method ((lisp-model lisp-model-tree-array) iter)
199 (multiple-value-bind (found index children)
200 (descend (tree lisp-model)
201 (iter->path-list lisp-model iter))
202 (declare (ignore found index))
203 (length children))))
204
205 (defgeneric iter-nth-child (lisp-model-impl iter parent n)
206 (:method ((lisp-model-list lisp-model-list) iter parent n)
207 (when (and (null parent) (< n (lisp-model-length lisp-model-list)))
208 (set-iter iter n)))
209 (:method ((lisp-model lisp-model-tree-array) iter parent n)
210 (multiple-value-bind (found index)
211 (descend (tree lisp-model)
212 (if (null parent)
213 (list n)
214 (let ((r (iter->path-list lisp-model parent)))
215 (append r (list n)))))
216 (when found (set-iter iter index)))))
217
218 (defgeneric iter-parent (lisp-model-impl iter child)
219 (:method ((lisp-model-list lisp-model-list) iter child)
220 nil)
221 (:method ((lisp-model lisp-model-tree-array) iter child)
222 (multiple-value-bind (found index)
223 (descend (tree lisp-model)
224 (let ((r (iter->path-list lisp-model child)))
225 (butlast r)))
226 (when found (set-iter iter index)))))
227
228 (defgeneric ref-node (lisp-model-impl iter)
229 (:method ((lisp-model-impl lisp-model-impl) iter)
230 nil))
231
232 (defgeneric unref-node (lisp-model-impl iter)
233 (:method ((lisp-model-impl lisp-model-impl) iter)
234 nil))
235
236 (defclass lisp-model (g-object tree-model)
237 ((implementation :type standard-object
238 :initarg :implementation
239 :initform (error "Implementation not set")
240 :reader implementation)))
241
242 (defcallback cb-lisp-model-class-init :void ((class :pointer))
243 (declare (ignore class))
244 (debug-out "Class init called~%"))
245
246 (defcallback cb-lisp-model-init :void ((self :pointer))
247 (declare (ignore self))
248 (debug-out "Object init called~%"))
249
250 (defmacro init-interface (interface &rest callbacks)
251 `(progn
252 ,@(loop :for (callback args) :on callbacks :by #'cddr
253 :collecting
254 `(defcallback ,(symbolicate '#:cb- callback) ,(car args)
255 ((object pobject) ,@(cdr args))
256 ;(debug-out "callback: ~a~%" ',callback)
257 (,callback (implementation object) ,@(mapcar #'car (cdr args)))))
258 (defcallback ,(symbolicate '#:cb-init- interface)
259 :void ((class ,interface))
260 ,@(loop :for (callback args) :on callbacks :by #'cddr
261 :collecting `(setf (foreign-slot-value class
262 ',interface ; :struct
263 ',callback)
264 (callback ,(symbolicate '#:cb- callback)))))))
265
266 (init-interface
267 tree-model-iface
268 get-flags (:int)
269 get-n-columns (:int)
270 get-column-type (:int (index :int))
271 get-iter (:boolean (iter (object tree-iter))
272 (path ptree-path))
273 get-path (ptree-path (iter (object tree-iter)))
274 get-value (:void (iter (object tree-iter)) (n :int)
275 (value :pointer))
276 iter-next (:boolean (iter (object tree-iter)))
277 iter-previous (:boolean (iter (object tree-iter)))
278 iter-children (:boolean (iter (object tree-iter))
279 (parent (object tree-iter)))
280 iter-has-child (:boolean (iter (object tree-iter)))
281 iter-n-children (:int (iter (object tree-iter)))
282 iter-nth-child (:boolean (iter (object tree-iter))
283 (parent (object tree-iter)) (n :int))
284 iter-parent (:boolean (iter (object tree-iter))
285 (child (object tree-iter)))
286 ref-node (:void (iter (object tree-iter)))
287 unref-node (:void (iter (object tree-iter))))
288
289
290 (defcstruct g-interface-info
291 (init :pointer)
292 (finalize :pointer)
293 (data pdata))
294
295 (defcfun gtk-tree-model-get-type :uint)
296
297 (defgeneric get-type (lisp-model))
298 (let ((interface-info (foreign-alloc 'g-interface-info))
299 g-type)
300 (setf (foreign-slot-value interface-info 'g-interface-info 'init)
301 (callback cb-init-tree-model-iface))
302 (defmethod get-type ((lisp-model lisp-model))
303 (or g-type
304 (prog1
305 (setf g-type
306 (g-type-register-static-simple
307 #.(keyword->g-type :object)
308 (g-intern-static-string "GtkLispModel")
309 (foreign-type-size 'g-object-class-struct)
310 (callback cb-lisp-model-class-init)
311 (foreign-type-size 'g-object)
312 (callback cb-lisp-model-init)
313 0))
314
315 (g-type-add-interface-static g-type
316 (gtk-tree-model-get-type)
317 interface-info)))))
318
319 (defmethod gconstructor ((lisp-model lisp-model) &rest initargs)
320 (declare (ignore initargs))
321 (new (get-type lisp-model)))
322
323 (import 'lisp-model "GTK-CFFI")

  ViewVC Help
Powered by ViewVC 1.1.5