e9f5c38686eab1b4b123da2bbec29d5b6868521c
[cl-gtk2.git] / gtk / gtk.tree-model.lisp
1 (in-package :gtk)
2
3 (define-vtable ("GtkTreeModel" c-gtk-tree-model)
4   (:skip parent-instance g-type-interface)
5   ;;some signals
6   (:skip tree-model-row-changed :pointer)
7   (:skip tree-model-row-inserted :pointer)
8   (:skip tree-model-row-has-child-toggled :pointer)
9   (:skip tree-model-row-deleted :pointer)
10   (:skip tree-model-rows-reordered :pointer)
11   ;;methods
12   (tree-model-get-flags-impl tree-model-get-flags-cb tree-model-flags (tree-model g-object))
13   (tree-model-get-n-columns-impl tree-model-get-n-columns-cb :int (tree-model g-object))
14   (tree-model-get-column-type-impl tree-model-get-column-type-cb g-type-designator (tree-model g-object) (index :int))
15   (tree-model-get-iter-impl tree-model-get-iter-cb :boolean (tree-model g-object) (iter (g-boxed-ref tree-iter)) (path (g-boxed-ref tree-path)))
16   (tree-model-get-path-impl tree-model-get-path-cb (g-boxed-ref tree-path) (tree-model g-object) (iter (g-boxed-ref tree-iter)))
17   (tree-model-get-value-impl tree-model-get-value-cb :void (tree-model g-object) (iter (g-boxed-ref tree-iter)) (n :int) (value (:pointer g-value)))
18   (tree-model-iter-next-impl tree-model-iter-next-cb :boolean (tree-model g-object) (iter (g-boxed-ref tree-iter)))
19   (tree-model-iter-children-impl tree-model-iter-children-cb :boolean (tree-model g-object) (iter (g-boxed-ref tree-iter)) (parent (g-boxed-ref tree-iter)))
20   (tree-model-iter-has-child-impl tree-model-iter-has-child-cb :boolean (tree-model g-object) (iter (g-boxed-ref tree-iter)))
21   (tree-model-iter-n-children-impl tree-model-iter-n-children-cb :int (tree-model g-object) (iter (g-boxed-ref tree-iter)))
22   (tree-model-iter-nth-child-impl tree-model-iter-nth-child-cb :boolean (tree-model g-object) (iter (g-boxed-ref tree-iter)) (parent (g-boxed-ref tree-iter)) (n :int))
23   (tree-model-iter-parent-impl tree-model-iter-parent-cb :boolean (tree-model g-object) (iter (g-boxed-ref tree-iter)) (child (g-boxed-ref tree-iter)))
24   (tree-model-ref-node-impl tree-model-ref-node-cb :void (tree-model g-object) (iter (g-boxed-ref tree-iter)))
25   (tree-model-unref-node-impl tree-model-unref-node-cb :void (tree-model g-object) (iter (g-boxed-ref tree-iter))))
26
27 ; TODO: GtkTreeSortable
28
29 ; TODO: GtkTreeModelSort
30
31 ; TODO: GtkTreeModelFilter
32
33
34 (defclass array-list-store (g-object tree-model)
35   ((items :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-items)
36    (columns-getters :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-getters)
37    (columns-types :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-types)))
38
39 (export 'array-list-store)
40
41 (register-object-type-implementation "LispArrayListStore" array-list-store "GObject" ("GtkTreeModel") nil)
42
43 (defun store-items-count (store)
44   (length (store-items store)))
45
46 (export 'store-items-count)
47
48 (defun store-item (store index)
49   (aref (store-items store) index))
50
51 (export 'store-item)
52
53 (defun store-add-item (store item)
54   (vector-push-extend item (store-items store))
55   (using* ((path (make-instance 'tree-path))
56            (iter (make-instance 'tree-iter)))
57     (setf (tree-path-indices path) (list (1- (length (store-items store)))))
58     (setf (tree-iter-stamp iter) 0 (tree-iter-user-data iter) (1- (length (store-items store))))
59     (emit-signal store "row-inserted" path iter)))
60
61 (export 'store-add-item)
62
63 (defun store-remove-item (store item &key (test 'eq))
64   (with-slots (items) store
65     (let ((index (position item items :test test)))
66       (unless index (error "No such item~%~A~%in list-store~%~A" item store))
67       (setf items (delete item items :test test))
68       (using (path (make-instance 'tree-path))
69              (setf (tree-path-indices path) (list index))
70              (emit-signal store "row-deleted" path)))))
71
72 (export 'store-remove-item)
73
74 (defun store-add-column (store type getter)
75   (vector-push-extend type (store-types store))
76   (vector-push-extend getter (store-getters store))
77   (1- (length (store-types store))))
78
79 (export 'store-add-column)
80
81 (defmethod tree-model-get-flags-impl ((model array-list-store))
82   '(:list-only))
83
84 (defmethod tree-model-get-n-columns-impl ((model array-list-store))
85   (length (store-types model)))
86
87 (defmethod tree-model-get-column-type-impl ((tree-model array-list-store) index)
88   (aref (store-types tree-model) index))
89
90 (defmethod tree-model-get-iter-impl ((model array-list-store) iter path)
91   (using* (iter path)
92     (let ((indices (tree-path-indices path)))
93       (when (and (= 1 (length indices))
94                  (< (first indices) (length (store-items model))))
95         (setf (tree-iter-stamp iter) 0 (tree-iter-user-data iter) (first indices))
96         t))))
97
98 (defmethod tree-model-ref-node-impl ((model array-list-store) iter) (release iter))
99 (defmethod tree-model-unref-node-impl ((model array-list-store) iter) (release iter))
100
101 (defmethod tree-model-iter-next-impl ((model array-list-store) iter)
102   (using* (iter)
103     (let ((n (tree-iter-user-data iter)))
104       (when (< n (1- (length (store-items model))))
105         (setf (tree-iter-user-data iter) (1+ n))
106         t))))
107
108 (defmethod tree-model-iter-nth-child-impl ((model array-list-store) iter parent n)
109   (using* (iter parent)
110     (setf (tree-iter-stamp iter) 0
111           (tree-iter-user-data iter) n)
112     t))
113
114 (defmethod tree-model-iter-n-children-impl ((model array-list-store) iter)
115   (if (null iter)
116       (length (store-items model))
117       0))
118
119 (defmethod tree-model-get-path-impl ((model array-list-store) iter)
120   (using* (iter)
121     (let ((path (make-instance 'tree-path)))
122       (setf (tree-path-indices path) (list (tree-iter-user-data iter)))
123       (disown-boxed-ref path)
124       path)))
125
126 (defmethod tree-model-iter-has-child-impl ((model array-list-store) iter)
127   (release iter)
128   nil)
129
130 (defgeneric tree-model-item (model iter-or-path))
131
132 (defmethod tree-model-item ((model array-list-store) (iter tree-iter))
133   (let ((n-row (tree-iter-user-data iter)))
134     (aref (store-items model) n-row)))
135
136 (defmethod tree-model-item ((model array-list-store) (path tree-path))
137   (let ((n-row (first (tree-path-indices path))))
138     (aref (store-items model) n-row)))
139
140 (export 'tree-model-item)
141
142 (defmethod tree-model-get-value-impl ((model array-list-store) iter n value)
143   (using (iter)
144     (let ((n-row (tree-iter-user-data iter)))
145       (set-g-value value
146                    (funcall (aref (store-getters model) n) 
147                             (aref (store-items model) n-row))
148                    (aref (store-types model) n)))))
149
150 (defcfun (tree-model-flags "gtk_tree_model_get_flags") tree-model-flags
151   (tree-model g-object))
152
153 (export 'tree-modelg-flags)
154
155 (defcfun (tree-model-n-columns "gtk_tree_model_get_n_columns") :int
156   (tree-model g-object))
157
158 (export 'tree-model-flags)
159
160 (defcfun (tree-model-column-type "gtk_tree_model_get_column_type") g-type-designator
161   (tree-model g-object)
162   (index :int))
163
164 (export 'tree-model-column-type)
165
166 (defcfun (tree-model-set-iter-to-path "gtk_tree_model_get_iter") :boolean
167   (tree-model g-object)
168   (iter (g-boxed-ref tree-iter))
169   (path (g-boxed-ref tree-path)))
170
171 (defun tree-model-iter-by-path (tree-model tree-path)
172   (let ((iter (make-instance 'tree-iter)))
173     (if (tree-model-set-iter-to-path tree-model iter tree-path)
174         iter
175         (progn (release iter) nil))))
176
177 (export 'tree-model-iter-by-path)
178
179 (defcfun (tree-model-set-iter-from-string "gtk_tree_model_get_iter_from_string") :boolean
180   (tree-model g-object)
181   (iter (g-boxed-ref tree-iter))
182   (path-string :string))
183
184 (defun tree-model-iter-from-string (tree-model path-string)
185   (let ((iter (make-instance 'tree-iter)))
186     (if (tree-model-set-iter-from-string tree-model iter path-string)
187         iter
188         (progn (release iter) nil))))
189
190 (export 'tree-model-iter-from-string)
191
192 (defcfun (tree-model-set-iter-to-first "gtk_tree_model_get_iter_first") :boolean
193   (model g-object)
194   (iter (g-boxed-ref tree-iter)))
195
196 (defun tree-model-iter-first (tree-model)
197   (let ((iter (make-instance 'tree-iter)))
198     (if (tree-model-set-iter-to-first tree-model iter)
199         iter
200         (progn (release iter) nil))))
201
202 (export 'tree-model-iter-first)
203
204 (defcfun (tree-model-path "gtk_tree_model_get_path") (g-boxed-ref tree-path :owner :lisp)
205   (tree-model g-object)
206   (iter (g-boxed-ref tree-iter)))
207
208 (export 'tree-model-path)
209
210 (defcfun gtk-tree-model-get-value :void
211   (model g-object)
212   (iter (g-boxed-ref tree-iter))
213   (column :int)
214   (value (:pointer g-value)))
215
216 (defun tree-model-value (tree-model iter column)
217   (with-foreign-object (v 'g-value)
218     (g-value-zero v)
219     (gtk-tree-model-get-value tree-model iter column v)
220     (prog1 (parse-g-value v)
221       (g-value-unset v))))
222
223 (export 'tree-model-value)
224
225 (defcfun (tree-model-iter-next "gtk_tree_model_iter_next") :boolean
226   (tree-model g-object)
227   (iter (g-boxed-ref tree-iter)))
228
229 (export 'tree-model-iter-next)
230
231 (defcfun gtk-tree-model-iter-children :boolean
232   (tree-model g-object)
233   (iter (g-boxed-ref tree-iter))
234   (parent (g-boxed-ref tree-iter)))
235
236 (defun tree-model-iter-first-child (tree-model parent)
237   (let ((iter (make-instance 'tree-iter)))
238     (if (gtk-tree-model-iter-children tree-model iter parent)
239         iter
240         (progn (release iter) nil))))
241
242 (export 'tree-model-iter-first-child)
243
244 (defcfun (tree-model-iter-has-child "gtk_tree_model_iter_has_child") :boolean
245   (tree-model g-object)
246   (iter (g-boxed-ref tree-iter)))
247
248 (export 'tree-model-iter-has-child)
249
250 (defcfun (tree-model-iter-n-children "gtk_tree_model_iter_n_children") :int
251   (tree-model g-object)
252   (iter (g-boxed-ref tree-iter)))
253
254 (export 'tree-model-iter-n-children)
255
256 (defcfun gtk-tree-model-iter-nth-child :boolean
257   (tree-model g-object)
258   (iter (g-boxed-ref tree-iter))
259   (parent (g-boxed-ref tree-iter))
260   (n :int))
261
262 (defun tree-model-iter-nth-child (tree-model parent n)
263   (let ((iter (make-instance 'tree-iter)))
264     (if (gtk-tree-model-iter-nth-child tree-model iter parent n)
265         iter
266         (progn (release iter) n))))
267
268 (export 'tree-model-iter-nth-child)
269
270 (defcfun gtk-tree-model-iter-parent :boolean
271   (tree-model g-object)
272   (iter (g-boxed-ref tree-iter))
273   (parent (g-boxed-ref tree-iter)))
274
275 (defun tree-model-iter-parent (tree-model iter)
276   (let ((parent (make-instance 'tree-iter)))
277     (if (gtk-tree-model-iter-parent tree-model iter parent)
278         parent
279         (progn (release parent) nil))))
280
281 (export 'tree-model-iter-parent)
282
283 (defcfun (tree-model-iter-to-string "gtk_tree_model_get_string_from_iter") (g-string :free-from-foreign t)
284   (tree-model g-object)
285   (iter (g-boxed-ref tree-iter)))
286
287 (export 'tree-model-iter-to-string)
288
289 (defcfun (tree-model-ref-node "gtk_tree_model_ref_node") :void
290   (tree-model g-object)
291   (iter (g-boxed-ref tree-iter)))
292
293 (export 'tree-model-ref-node)
294
295 (defcfun (tree-model-unref-node "gtk_tree_model_unref_node") :void
296   (tree-model g-object)
297   (iter (g-boxed-ref tree-iter)))
298
299 (export 'tree-model-unref-node)
300
301 (defcallback gtk-tree-model-foreach-cb :boolean ((model g-object) (path (g-boxed-ref tree-path)) (iter (g-boxed-ref tree-iter)) (data :pointer))
302   (let ((fn (get-stable-pointer-value data)))
303     (restart-case
304         (funcall fn model path iter)
305       (stop-tree-model-iteration () t)
306       (skip-tree-model-current () nil))))
307
308 (defcfun gtk-tree-model-foreach :void
309   (model g-object)
310   (func :pointer)
311   (data :pointer))
312
313 (defun do-tree-model (model fn)
314   (with-stable-pointer (ptr fn)
315     (gtk-tree-model-foreach model (callback gtk-tree-model-foreach-cb) ptr)))
316
317 (export 'do-tree-model)
318
319 (defun array-insert-at (array element index)
320   (assert (adjustable-array-p array))
321   (adjust-array array (1+ (length array)) :fill-pointer t)
322   (iter (for i from (1- (length array)) above index)
323         (setf (aref array i)
324               (aref array (1- i))))
325   (setf (aref array index) element)
326   array)
327
328 (defun array-remove-at (array index)
329   (assert (adjustable-array-p array))
330   (iter (for i from index below (1- (length array)))
331         (setf (aref array i)
332               (aref array (1+ i))))
333   (adjust-array array (1- (length array)) :fill-pointer t)
334   array)
335
336 (defclass tree-lisp-store (g-object tree-model)
337   ((columns-getters :initform (make-array 0 :adjustable t :fill-pointer t) :reader tree-lisp-store-getters)
338    (columns-types :initform (make-array 0 :adjustable t :fill-pointer t) :reader tree-lisp-store-types)
339    (root :initform (make-tree-node) :reader tree-lisp-store-root)
340    (id-map :initform (make-hash-table) :reader tree-lisp-store-id-map)
341    (next-id-value :initform 0 :accessor tree-lisp-store-next-id-value)))
342
343 (defmethod initialize-instance :after ((object tree-lisp-store) &key &allow-other-keys)
344   (setf (tree-node-tree (tree-lisp-store-root object)) object))
345
346 (register-object-type-implementation "LispTreeStore" tree-lisp-store "GObject" ("GtkTreeModel") nil)
347
348 (defstruct tree-node
349   (tree nil)
350   (parent nil)
351   (id nil)
352   (item nil)
353   (children (make-array 0 :element-type 'tree-node :adjustable t :fill-pointer t)))
354
355 (defun map-subtree (node fn)
356   (funcall fn node)
357   (iter (for child in-vector (tree-node-children node))
358         (map-subtree child fn)))
359
360 (defun clear-id (node)
361   (map-subtree node
362                (lambda (n)
363                  (when (and (tree-node-id n)
364                             (tree-node-tree n))
365                    (remhash (tree-node-id n)
366                             (tree-lisp-store-id-map (tree-node-tree n))))
367                  (setf (tree-node-id n) nil))))
368
369 (defun set-node-tree (node tree)
370   (map-subtree node
371                (lambda (n)
372                  (setf (tree-node-tree n) tree))))
373
374 (defun tree-node-insert-at (node child index)
375   (assert (null (tree-node-parent child)))
376   (clear-id child)
377   (setf (tree-node-parent child) node)
378   (set-node-tree child (tree-node-tree node))
379   (array-insert-at (tree-node-children node) child index)
380   (notice-tree-node-insertion (tree-node-tree node) node child index)
381   node)
382
383 (defun tree-node-child-at (node index)
384   (aref (tree-node-children node) index))
385
386 (defun tree-node-remove-at (node index)
387   (assert (<= 0 index (1- (length (tree-node-children node)))))
388   (let ((child (tree-node-child-at node index)))
389     (clear-id child)
390     (setf (tree-node-parent child) nil)
391     (set-node-tree child nil)
392     (array-remove-at (tree-node-children node) index)
393     (notice-tree-node-removal (tree-node-tree node) node child index)))
394
395 (defun tree-lisp-store-add-column (store column-type column-getter)
396   (vector-push-extend column-getter (tree-lisp-store-getters store))
397   (vector-push-extend column-type (tree-lisp-store-types store)))
398
399 (defmethod tree-model-get-flags-impl ((store tree-lisp-store))
400   nil)
401
402 (defmethod tree-model-get-n-columns-impl ((store tree-lisp-store))
403   (length (tree-lisp-store-getters store)))
404
405 (defmethod tree-model-get-column-type-impl ((store tree-lisp-store) index)
406   (aref (tree-lisp-store-types store) index))
407
408 (defun get-node-by-indices (root indices)
409   (if indices
410       (get-node-by-indices (tree-node-child-at root (first indices)) (rest indices))
411       root))
412
413 (defun get-node-by-path (tree path)
414   (let ((indices (tree-path-indices path)))
415     (get-node-by-indices (tree-lisp-store-root tree) indices)))
416
417 (defun get-node-path (node)
418   (iter (with z = nil)
419         (for parent = (tree-node-parent node))
420         (while parent)
421         (for index = (position node (tree-node-children parent)))
422         (push index z)
423         (setf node parent)
424         (finally (return z))))
425
426 (defun tree-lisp-store-get-next-id (tree)
427   (incf (tree-lisp-store-next-id-value tree)))
428
429 (defun tree-lisp-store-add-id-map (tree id node)
430   (setf (gethash id (tree-lisp-store-id-map tree)) node))
431
432 (defun get-assigned-id (tree node)
433   (or (tree-node-id node)
434       (let ((id (tree-lisp-store-get-next-id tree)))
435         (tree-lisp-store-add-id-map tree id node)
436         (setf (tree-node-id node) id)
437         id)))
438
439 (defun get-node-by-id (tree id)
440   (gethash id (tree-lisp-store-id-map tree)))
441
442 (defmethod tree-model-get-iter-impl ((store tree-lisp-store) iter path)
443   (using* (iter path)
444     (let* ((node (get-node-by-path store path))
445            (node-idx (get-assigned-id store node)))
446       (setf (tree-iter-stamp iter) 0
447             (tree-iter-user-data iter) node-idx))))
448
449 (defun get-node-by-iter (tree iter)
450   (get-node-by-id tree (tree-iter-user-data iter)))
451
452 (defmethod tree-model-get-path-impl ((store array-list-store) iter)
453   (using* (iter)
454     (let* ((path (make-instance 'tree-path))
455            (node (get-node-by-iter store iter))
456            (indices (get-node-path node)))
457       (setf (tree-path-indices path) indices)
458       (disown-boxed-ref path)
459       path)))
460
461 (defmethod tree-model-get-value-impl ((store tree-lisp-store) iter n value)
462   (using* (iter)
463     (let* ((node (get-node-by-iter store iter))
464            (getter (aref (tree-lisp-store-getters store) n))
465            (type (aref (tree-lisp-store-types store) n)))
466       (set-g-value value (funcall getter (tree-node-item node)) type))))
467
468 (defmethod tree-model-iter-next-impl ((store tree-lisp-store) iter)
469   (using* (iter)
470     (let* ((node (get-node-by-iter store iter))
471            (parent (tree-node-parent node))
472            (index (position node (tree-node-children parent))))
473       (when (< (1+ index) (length (tree-node-children parent)))
474         (setf (tree-iter-stamp iter)
475               0
476               (tree-iter-user-data iter)
477               (get-assigned-id store (tree-node-child-at parent (1+ index))))
478         t))))
479
480 (defmethod tree-model-iter-children-impl ((store tree-lisp-store) iter parent)
481   (using* (iter parent)
482     (let* ((node (if parent
483                      (get-node-by-iter store parent)
484                      (tree-lisp-store-root store))))
485       (when (plusp (length (tree-node-children node)))
486         (setf (tree-iter-stamp iter)
487               0
488               (tree-iter-user-data iter)
489               (get-assigned-id store (tree-node-child-at node 0)))
490         t))))
491
492 (defmethod tree-model-iter-has-child-impl ((store tree-lisp-store) iter)
493   (using* (iter)
494     (let ((node (get-node-by-iter store iter)))
495       (plusp (length (tree-node-children node))))))
496
497 (defmethod tree-model-iter-n-children-impl ((store tree-lisp-store) iter)
498   (using* (iter)
499     (let* ((node (if iter
500                      (get-node-by-iter store iter)
501                      (tree-lisp-store-root store))))
502       (length (tree-node-children node)))))
503
504 (defmethod tree-model-iter-nth-child-impl ((store tree-lisp-store) iter parent n)
505   (using* (iter parent)
506     (let* ((node (if parent
507                      (get-node-by-iter store parent)
508                      (tree-lisp-store-root store)))
509            (requested-node (tree-node-child-at node n)))
510       (setf (tree-iter-stamp iter) 0
511             (tree-iter-user-data iter) (get-assigned-id store requested-node))
512       t)))
513
514 (defmethod tree-model-iter-parent-impl ((store tree-lisp-store) iter child)
515   (using* (iter child)
516     (let ((node (get-node-by-iter store child)))
517       (when (tree-node-parent node)
518         (setf (tree-iter-stamp iter) 0
519               (tree-iter-user-data iter) (get-assigned-id store (tree-node-parent node)))))))
520
521 (defmethod tree-model-ref-node-impl ((store tree-lisp-store) iter)
522   )
523
524 (defmethod tree-model-unref-node-impl ((store tree-lisp-store) iter)
525   )
526
527 (defun notice-tree-node-insertion (tree node child index)
528   (declare (ignore node index))
529   (when tree
530     (using* ((path (make-instance 'tree-path))
531              (iter (make-instance 'tree-iter)))
532       (setf (tree-path-indices path) (get-node-path child)
533             (tree-iter-stamp iter) 0
534             (tree-iter-user-data iter) (get-assigned-id tree child))
535       (emit-signal tree "row-inserted" path iter)
536       (when (plusp (length (tree-node-children child)))
537         (emit-signal tree "row-has-child-toggled" path iter)))))
538
539 (defun notice-tree-node-removal (tree node child index)
540   (declare (ignore child))
541   (when tree
542     (using (path (make-instance 'tree-path))
543       (setf (tree-path-indices path) (nconc (get-node-path node) (list index)))
544       (emit-signal tree "row-deleted" path))
545     (when (zerop (length (tree-node-children node)))
546       (using* ((path (make-instance 'tree-path))
547                (iter (make-instance 'tree-iter)))
548         (setf (tree-path-indices path) (get-node-path node)
549               (tree-iter-stamp iter) 0
550               (tree-iter-user-data iter) (get-assigned-id tree node))
551         (emit-signal tree "row-has-child-toggled" path iter)))))