chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gtk / gtktree.lisp
1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
3 ;;
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23 ;; $Id: gtktree.lisp,v 1.34 2008-04-11 20:53:32 espen Exp $
24
25
26 (in-package "GTK")
27
28
29 ;;;; Cell Layout
30
31 (defbinding cell-layout-pack-start () nil
32   (cell-layout cell-layout)
33   (cell cell-renderer)
34   (expand boolean))
35
36 (defbinding cell-layout-pack-end () nil
37   (cell-layout cell-layout)
38   (cell cell-renderer)
39   (expand boolean))
40
41 (defun cell-layout-pack (layout cell &key end expand)
42   (if end
43       (cell-layout-pack-end layout cell expand)
44     (cell-layout-pack-start layout cell expand)))
45
46
47 (defbinding cell-layout-reorder () nil
48   (cell-layout cell-layout)
49   (cell cell-renderer)
50   (position int))
51
52 (defbinding cell-layout-clear () nil
53   (cell-layout cell-layout))
54
55 (defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil
56   (cell-layout cell-layout)
57   (cell cell-renderer)
58   ((string-downcase attribute) string)
59   (column int))
60
61 (define-callback-marshal %cell-layout-data-callback nil 
62   (cell-layout cell-renderer tree-model tree-iter))
63
64 (defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
65   (cell-layout cell-layout)
66   (cell cell-renderer)
67   (%cell-layout-data-callback callback)
68   ((register-callback-function function) unsigned-int)
69   (user-data-destroy-callback callback))
70
71 (defbinding cell-layout-clear-attributes () nil
72   (cell-layout cell-layout)
73   (cell cell-renderer))
74
75
76 ;;;; Cell Renderer
77
78 (defmethod compute-signal-function ((gobject cell-renderer-toggle) (signal (eql 'toggled)) function object args)
79   (declare (ignore gobject signal function object args))
80   (let ((function (call-next-method)))
81     #'(lambda (object path)
82         (funcall function object (ensure-tree-path path)))))
83
84
85 ;;;; List Store
86
87 (defmethod initialize-instance ((list-store list-store) &key column-types
88                                 column-names initial-content)
89   (call-next-method)
90   (%list-store-set-column-types list-store column-types)
91   (when column-names
92     (setf 
93      (user-data list-store 'column-names) 
94      (coerce column-names 'vector)))
95   (when initial-content
96     (loop
97      with iter = (make-instance 'tree-iter)
98      for row in initial-content
99      do (list-store-append list-store row iter))))
100
101
102 (defbinding %list-store-set-column-types () nil
103   (list-store list-store)
104   ((length columns) unsigned-int)
105   (columns (vector gtype)))
106
107 (defbinding list-store-remove (store row) boolean
108   (store list-store)
109   ((ensure-tree-iter store row) tree-iter))
110
111 (defbinding %list-store-set-value () nil
112   (list-store list-store)
113   (tree-iter tree-iter)
114   (column int)
115   (gvalue gvalue))
116
117 (defmethod (setf tree-model-value) (value (store list-store) row column)
118   (let* ((index (tree-model-column-index store column))
119          (type (tree-model-get-column-type store index)))
120     (with-gvalue (gvalue type value)
121       (%list-store-set-value store (ensure-tree-iter store row) index gvalue)))
122   value)
123
124 (defbinding %list-store-insert-with-valuesv () nil
125   (list-store list-store)
126   (tree-iter tree-iter)
127   (position int)
128   (columns (vector int))
129   (gvalues pointer)
130   ((length columns) int))
131
132 (defbinding %list-store-insert () nil
133   (list-store list-store)
134   (tree-iter tree-iter)
135   (position int))
136
137 (defun list-store-insert (store position &optional data (iter (make-instance 'tree-iter)))
138   (etypecase data
139     (null (%list-store-insert store iter position))
140
141     (list (with-memory (gvalues (* (/ (length data) 2) +gvalue-size+))
142             (let ((columns
143                    (loop
144                     for (column value) on data by #'cddr
145                     as index = (tree-model-column-index store column)
146                     as type = (tree-model-get-column-type store index)
147                     as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
148                     do (gvalue-init gvalue type value)
149                     collect index)))
150                 (unwind-protect
151                     (%list-store-insert-with-valuesv store iter position columns gvalues)
152                   (loop
153                    repeat (length columns)
154                    as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
155                    do (gvalue-unset gvalue))))))
156
157     (vector (with-memory (gvalues (* (length data) +gvalue-size+))
158               (let ((columns
159                      (loop
160                       for index below (length data)
161                       as type = (tree-model-get-column-type store index)
162                       as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
163                       do (gvalue-init gvalue type (aref data index))
164                       collect index)))
165                 (unwind-protect
166                     (%list-store-insert-with-valuesv store iter position columns gvalues))
167                 (loop
168                  repeat (length data)
169                  as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
170                  do (gvalue-unset gvalue))))))
171   iter)
172
173 (defbinding %list-store-insert-before () nil
174   (list-store list-store)
175   (tree-iter tree-iter)
176   (sibling (or null tree-iter)))
177
178 (defun list-store-insert-before
179     (store sibling &optional data (iter (make-instance 'tree-iter)))
180   (%list-store-insert-before store iter sibling)
181   (when data (setf (tree-model-row-data store iter) data))
182   iter)
183
184 (defbinding %list-store-insert-after () nil
185   (list-store list-store)
186   (tree-iter tree-iter)
187   (sibling (or null tree-iter)))
188
189 (defun list-store-insert-after
190     (store sibling &optional data (iter (make-instance 'tree-iter)))
191   (%list-store-insert-after store iter sibling)
192   (when data (setf (tree-model-row-data store iter) data))
193   iter)
194
195 (defbinding %list-store-prepend () nil
196   (list-store list-store)
197   (tree-iter tree-iter))
198
199 (defun list-store-prepend 
200     (store &optional data (iter (make-instance 'tree-iter)))
201   (%list-store-prepend store iter)
202   (when data (setf (tree-model-row-data store iter) data))
203   iter)
204
205 (defbinding %list-store-append () nil
206   (list-store list-store)
207   (tree-iter tree-iter))
208
209 (defun list-store-append 
210     (store &optional data (iter (make-instance 'tree-iter)))
211   (%list-store-append store iter)
212   (when data (setf (tree-model-row-data store iter) data))
213   iter)
214
215 (defbinding list-store-clear () nil
216   (list-store list-store))
217
218 (defbinding list-store-reorder () nil
219   (list-store list-store)
220   (new-order (vector int)))
221
222 (defbinding list-store-swap () nil
223   (list-store list-store)
224   (a tree-iter)
225   (b tree-iter))
226
227 (defbinding list-store-move-before () nil
228   (list-store list-store)
229   (iter tree-iter)
230   (psoition (or null tree-iter)))
231
232 (defbinding list-store-move-after () nil
233   (list-store list-store)
234   (iter tree-iter)
235   (psoition tree-iter))
236
237
238 ;;; Tree Path
239
240 (defbinding %tree-path-free () nil
241   (location pointer))
242
243 (defbinding %tree-path-get-indices () pointer
244   (location pointer))
245
246 (defbinding %tree-path-get-depth () int
247   (location pointer))
248
249 (defun %make-tree-path (path)
250   (let* ((c-vector (make-c-vector 'int (length path) :content path))
251          (pointer-offset (adjust-offset (size-of 'int) 'pointer))
252          (location (allocate-memory (+ pointer-offset (size-of 'pointer)))))
253     (funcall (writer-function 'int) (length path) location)
254     (funcall (writer-function 'pointer) c-vector location pointer-offset)
255     location))
256
257 (defun %tree-path-to-vector (location)
258   (unless (null-pointer-p location)
259     (let ((indices (%tree-path-get-indices location))
260           (depth (%tree-path-get-depth location)))
261       (if (null-pointer-p indices)
262           #()
263         (map-c-vector 'vector #'identity indices 'int depth)))))
264
265 (defmacro %with-tree-path ((var path) &body body)
266   (let* ((pointer-offset (adjust-offset (size-of 'int) 'pointer))
267          (vector-offset (adjust-offset (+ pointer-offset (size-of 'pointer)) 'int)))
268     `(with-memory (,var (+ ,vector-offset (* ,(size-of 'int) (length ,path))))
269       (funcall (writer-function 'int) (length ,path) ,var)
270       (setf (ref-pointer ,var ,pointer-offset) (pointer+ ,var ,vector-offset))
271       (make-c-vector 'int (length ,path) :content ,path :location (pointer+ ,var ,vector-offset))
272       ,@body)))
273
274 (eval-when (:compile-toplevel :load-toplevel :execute)
275   (define-type-method alien-type ((type tree-path))
276     (declare (ignore type))
277     (alien-type 'pointer))
278   
279   (define-type-method size-of ((type tree-path) &key inlined)
280     (assert-not-inlined type inlined)
281     (size-of 'pointer))
282   
283   (define-type-method alien-arg-wrapper ((type tree-path) var path style form &optional copy-in-p)
284     (declare (ignore type))
285     (cond
286      ((and (in-arg-p style) copy-in-p)
287       `(with-pointer (,var (%make-tree-path ,path))
288          ,form))
289      ((and (in-arg-p style) (not (out-arg-p style)))
290       `(%with-tree-path (,var ,path)
291          ,form))
292      ((and (in-arg-p style) (out-arg-p style))
293       (let ((tree-path (make-symbol "SYMBOL")))
294         `(%with-tree-path (,tree-path ,path)
295            (with-pointer (,var ,tree-path)
296              ,form))))
297      ((and (out-arg-p style) (not (in-arg-p style)))
298       `(with-pointer (,var)
299          ,form))))
300
301   (define-type-method to-alien-form ((type tree-path) path &optional copy-p)
302     (declare (ignore type copy-p))
303     `(%make-tree-path ,path))
304   
305   (define-type-method from-alien-form ((type tree-path) location &key (ref :free))
306     (declare (ignore type))
307     `(prog1
308          (%tree-path-to-vector ,location)
309        ,(when (eq ref :free)
310           `(%tree-path-free ,location)))))
311   
312 (define-type-method to-alien-function ((type tree-path) &optional copy-p)
313   (declare (ignore type))
314   #'%make-tree-path
315   (unless copy-p
316     #'(lambda (tree-path location)
317         (declare (ignore tree-path))
318         (%tree-path-free location))))
319   
320 (define-type-method from-alien-function ((type tree-path) &key (ref :free))
321   (declare (ignore type))
322   (if (eq ref :free)
323       #'(lambda (location)
324           (prog1
325               (%tree-path-to-vector location)
326             (%tree-path-free location)))
327     #'(lambda (location)
328         (%tree-path-to-vector location))))
329   
330 (define-type-method writer-function ((type tree-path) &key temp inlined)
331   (declare (ignore temp))
332   (assert-not-inlined type inlined)
333   (let ((writer (writer-function 'pointer)))
334     #'(lambda (path location &optional (offset 0))
335         (funcall writer (%make-tree-path path) location offset))))
336
337 (define-type-method reader-function ((type tree-path) &key ref inlined)
338   (declare (ignore ref))
339   (assert-not-inlined type inlined)
340   #'(lambda (location &optional (offset 0))
341       (%tree-path-to-vector (ref-pointer location offset))))
342
343 (define-type-method destroy-function ((type tree-path) &key temp inlined)
344   (declare (ignore temp))
345   (assert-not-inlined type inlined)
346   #'(lambda (location &optional (offset 0))
347       (%tree-path-free (ref-pointer location offset))))
348
349 (defun ensure-tree-path (path)
350   (etypecase path
351     (string (coerce (clg-utils:split-string path :delimiter #\:) 'vector))
352     (vector path)))
353
354
355 ;;; Tree Model
356
357 (defgeneric tree-model-value (model row column))
358 (defgeneric (setf tree-model-value) (value model row column))
359 (defgeneric tree-model-row-data (model row))
360 (defgeneric (setf tree-model-row-data) (data model row))
361 (defgeneric tree-model-column-index (model column))
362 (defgeneric tree-model-column-name (model index))
363
364
365 (defbinding %tree-row-reference-new () pointer
366   (model tree-model)
367   (path tree-path))
368
369 (defmethod allocate-foreign ((reference tree-row-reference) &key model path)
370   (%tree-row-reference-new model path))
371
372 (defbinding tree-row-reference-get-path () (or null tree-path)
373   (reference tree-row-reference))
374
375 (defbinding (tree-row-reference-valid-p "gtk_tree_row_reference_valid") () boolean
376   (reference tree-row-reference))
377
378
379 (defbinding tree-model-get-column-type () gtype
380   (tree-model tree-model)
381   (index int))
382
383 (defbinding tree-model-get-iter (model path &optional (iter (make-instance 'tree-iter))) boolean
384   (model tree-model)
385   (iter tree-iter :in/return)
386   (path tree-path))
387
388 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0")
389 (defmethod allocate-foreign ((tree-iter tree-iter) &rest initargs)
390   (declare (ignore initargs))
391   (let ((size (foreign-size (class-of tree-iter))))
392     (slice-alloc size)))
393  
394 (defun ensure-tree-iter (model row)
395   (etypecase row
396     (tree-iter row)
397     (tree-path 
398      (multiple-value-bind (valid-p iter) (tree-model-get-iter model row)
399        (if valid-p
400            iter
401          (error "Invalid tree path for ~A: ~A" model row))))
402     (tree-row-reference 
403      (let ((path (tree-row-reference-get-path row)))
404        (if path
405            (ensure-tree-iter model path)
406          (error "~A not valid" row))))))
407
408 (defbinding tree-model-get-path () tree-path
409   (tree-model tree-model)
410   (iter tree-iter))
411
412 (defbinding %tree-model-get-value () nil
413   (tree-model tree-model)
414   (iter tree-iter)
415   (column int)
416   (gvalue gvalue))
417
418 (defmethod tree-model-value ((model tree-model) row column)
419   (let ((index (tree-model-column-index model column)))
420     (with-gvalue (gvalue)
421       (%tree-model-get-value model (ensure-tree-iter model row) index gvalue))))
422
423 (defmethod tree-model-row-data ((model tree-model) row)
424   (coerce
425    (loop
426     with iter = (ensure-tree-iter model row)
427     for index from 0 below (tree-model-n-columns model)
428     collect (tree-model-value model iter index))
429    'vector))
430
431
432 (defbinding tree-model-iter-next () boolean
433   (tree-model tree-model)
434   (iter tree-iter :in/return))
435
436 (defbinding tree-model-iter-children 
437     (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
438   (tree-model tree-model)
439   (iter tree-iter :in/return)
440   (parent (or null tree-iter)))
441
442 (defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child") 
443     () boolean
444   (tree-model tree-model)
445   (iter tree-iter))
446
447 (defbinding tree-model-iter-n-children (tree-model &optional iter) int
448   (tree-model tree-model)
449   (iter (or null tree-iter)))
450
451 (defbinding tree-model-iter-nth-child
452     (tree-model parent n &optional (iter (make-instance 'tree-iter))) boolean
453   (tree-model tree-model)
454   (iter tree-iter :in/return)
455   (parent (or null tree-iter))
456   (n int))
457
458 (defbinding tree-model-iter-parent
459     (tree-model child &optional (iter (make-instance 'tree-iter))) boolean
460   (tree-model tree-model)
461   (iter tree-iter :in/return)
462   (child tree-iter))
463
464 (define-callback-marshal %tree-model-foreach-callback boolean 
465   (tree-model tree-path tree-iter))
466
467 (defbinding %tree-model-foreach (tree-model callback-id) nil
468   (tree-model tree-model)
469   (%tree-model-foreach-callback callback)
470   (callback-id unsigned-int))
471
472 (defun tree-model-foreach (model function)
473   (with-callback-function (id function)
474     (%tree-model-foreach model id)))
475
476 (defbinding tree-model-row-changed () nil
477   (tree-model tree-model)
478   (path tree-path)
479   (iter tree-iter))
480
481 (defbinding tree-model-row-inserted () nil
482   (tree-model tree-model)
483   (path tree-path)
484   (iter tree-iter))
485
486 (defbinding tree-model-row-has-child-toggled () nil
487   (tree-model tree-model)
488   (path tree-path)
489   (iter tree-iter))
490
491 (defbinding tree-model-row-deleted () nil
492   (tree-model tree-model)
493   (path tree-path)
494   (iter tree-iter))
495
496 (defbinding tree-model-rows-reordered () nil
497   (tree-model tree-model)
498   (path tree-path)
499   (iter tree-iter)
500   (new-order int))
501
502 (defmethod tree-model-column-index ((model tree-model) column)
503   (or
504    (etypecase column
505      (number column)
506      (string (position column (user-data model 'column-names) :test #'string=))
507      (symbol (position column (user-data model 'column-names))))
508    (error "~A has no column ~S" model column)))
509
510 (defmethod tree-model-column-name ((model tree-model) index)
511   (svref (user-data model 'column-names) index))
512
513
514 (defmethod (setf tree-model-row-data) ((data list) (model tree-model) (iter tree-iter))
515   (loop
516    for (column value) on data by #'cddr
517    do (setf (tree-model-value model iter column) value))
518   data)
519
520 (defmethod (setf tree-model-row-data) ((data vector) (model tree-model) row)
521   (loop
522    with iter = (ensure-tree-iter model row)
523    for index from 0
524    for value across data
525    do (setf (tree-model-value model iter index) value))
526   data)
527
528
529 ;;; Tree Selection
530
531 (define-callback-marshal %tree-selection-callback boolean 
532   (tree-selection tree-model tree-path (path-currently-selected boolean)))
533
534 (defbinding tree-selection-set-select-function (selection function) nil
535   (selection tree-selection)
536   (%tree-selection-callback callback)
537   ((register-callback-function function) unsigned-int)
538   (user-data-destroy-callback callback))
539
540 (defbinding tree-selection-get-selected 
541     (selection &optional (iter (make-instance 'tree-iter))) boolean
542   (selection tree-selection)
543   (nil null) 
544   (iter tree-iter :in/return))
545
546 (define-callback-marshal %tree-selection-foreach-callback nil (tree-model tree-path tree-iter))
547
548 (defbinding %tree-selection-selected-foreach (tree-selection callback-id) nil
549   (tree-selection tree-selection)
550   (%tree-selection-foreach-callback callback)
551   (callback-id unsigned-int))
552
553 (defun tree-selection-selected-foreach (selection function)
554   (with-callback-function (id function)
555     (%tree-selection-selected-foreach selection id)))
556
557 (defbinding tree-selection-get-selected-rows () (glist tree-path)
558   (tree-selection tree-selection)
559   (nil null))
560
561 (defbinding tree-selection-count-selected-rows () int
562   (tree-selection tree-selection))
563
564 (defbinding %tree-selection-select-path () nil
565   (tree-selection tree-selection)
566   (tree-path tree-path))
567
568 (defbinding %tree-selection-unselect-path () nil
569   (tree-selection tree-selection)
570   (tree-path tree-path))
571
572 (defbinding %tree-selection-path-is-selected () boolean
573   (tree-selection tree-selection)
574   (tree-path tree-path))
575
576 (defbinding %tree-selection-select-iter () nil
577   (tree-selection tree-selection)
578   (tree-iter tree-iter))
579
580 (defbinding %tree-selection-unselect-iter () nil
581   (tree-selection tree-selection)
582   (tree-iter tree-iter))
583
584 (defbinding %tree-selection-iter-is-selected () boolean
585   (tree-selection tree-selection)
586   (tree-iter tree-iter))
587
588 (defun tree-selection-select (selection row)
589   (etypecase row
590     (tree-path (%tree-selection-select-path selection row))
591     (tree-iter (%tree-selection-select-iter selection row))))
592
593 (defun tree-selection-unselect (selection row)
594   (etypecase row
595     (tree-path (%tree-selection-unselect-path selection row))
596     (tree-iter (%tree-selection-unselect-iter selection row))))
597
598 (defun tree-selection-is-selected-p (selection row)
599   (etypecase row
600     (tree-path (%tree-selection-path-is-selected selection row))
601     (tree-iter (%tree-selection-iter-is-selected selection row))))
602
603 (defbinding tree-selection-select-all () nil
604   (tree-selection tree-selection))
605
606 (defbinding tree-selection-unselect-all () nil
607   (tree-selection tree-selection))
608
609 (defbinding tree-selection-select-range () nil
610   (tree-selection tree-selection)
611   (start tree-path)
612   (end tree-path))
613
614 (defbinding tree-selection-unselect-range () nil
615   (tree-selection tree-selection)
616   (start tree-path)
617   (end tree-path))
618
619
620 ;;; Tree Sortable
621
622 (eval-when (:compile-toplevel :load-toplevel :execute)
623   (define-enum-type sort-column (:default -1) (:unsorted -2))
624   (define-enum-type sort-order (:before -1) (:equal 0) (:after 1)))
625
626
627 (define-callback-marshal %tree-iter-compare-callback (or int sort-order)
628   (tree-model (a tree-iter) (b tree-iter)))
629
630 (defbinding tree-sortable-sort-column-changed () nil
631   (sortable tree-sortable))
632
633 (defbinding %tree-sortable-get-sort-column-id () boolean
634   (sortable tree-sortable)
635   (column int :out)
636   (order sort-type :out))
637
638 (defun tree-sortable-get-sort-column (sortable)
639   (multiple-value-bind (special-p column order) 
640       (%tree-sortable-get-sort-column-id sortable)
641     (values
642      (if special-p
643          (int-to-sort-order column)
644        (tree-model-column-name sortable column))
645      order)))
646
647 (defbinding (tree-sortable-set-sort-column 
648              "gtk_tree_sortable_set_sort_column_id") 
649     (sortable column order) nil
650   (sortable tree-sortable)
651   ((etypecase column
652      ((or integer sort-column) column)
653      (symbol (tree-model-column-index sortable column))) 
654    (or sort-column int))
655   (order sort-type))
656
657 (defbinding %tree-sortable-set-sort-func (sortable column function) nil
658   (sortable tree-sortable)
659   ((tree-model-column-index sortable column) int)
660   (%tree-iter-compare-callback callback)
661   ((register-callback-function function) unsigned-int)
662   (user-data-destroy-callback callback))
663
664 (defbinding %tree-sortable-set-default-sort-func () nil
665   (sortable tree-sortable)
666   (compare-func (or null callback))
667   (callback-id unsigned-int)
668   (destroy-func (or null callback)))
669
670 (defun tree-sortable-set-sort-func (sortable column function)
671   "Sets the comparison function used when sorting to be FUNCTION. If
672 the current sort column of SORTABLE is the same as COLUMN,
673 then the model will sort using this function."
674   (cond
675    ((and (eq column :default) (not function))
676     (%tree-sortable-set-default-sort-func sortable nil 0 nil))
677    ((eq column :default) 
678     (%tree-sortable-set-default-sort-func sortable 
679      %tree-iter-compare-callback
680      (register-callback-function function)
681      user-data-destroy-callback))
682    ((%tree-sortable-set-sort-func sortable column function))))
683
684 (defbinding tree-sortable-has-default-sort-func-p () boolean
685   (sortable tree-sortable))
686
687
688 ;;; Tree Store
689
690 (defbinding %tree-store-set-column-types () nil
691   (tree-store tree-store)
692   ((length columns) unsigned-int)
693   (columns (vector gtype)))
694
695 (defmethod initialize-instance ((tree-store tree-store) &key column-types
696                                 column-names)
697   (call-next-method)
698   (%tree-store-set-column-types tree-store column-types)
699   (when column-names
700     (setf (user-data tree-store 'column-names) column-names)))
701
702
703 (defbinding %tree-store-set-value () nil
704   (tree-store tree-store)
705   (tree-iter tree-iter)
706   (column int)
707   (gvalue gvalue))
708
709 (defmethod (setf tree-model-value) (value (store tree-store) row column)
710   (let* ((index (tree-model-column-index store column))
711          (type (tree-model-get-column-type store index)))
712     (with-gvalue (gvalue type value)
713       (%tree-store-set-value store (ensure-tree-iter store row) index gvalue)))
714   value)
715
716
717 (defbinding tree-store-remove () boolean
718   (tree-store tree-store)
719   (tree-iter tree-iter))
720
721 (defbinding %tree-store-insert () nil
722   (tree-store tree-store)
723   (tree-iter tree-iter)
724   (parent (or null tree-iter))
725   (position int))
726
727 (defun tree-store-insert 
728     (store parent position &optional data (iter (make-instance 'tree-iter)))
729   (%tree-store-insert store iter parent position)
730   (when data (setf (tree-model-row-data store iter) data))
731   iter)
732
733 (defbinding %tree-store-insert-before () nil
734   (tree-store tree-store)
735   (tree-iter tree-iter)
736   (parent (or null tree-iter))
737   (sibling (or null tree-iter)))
738
739 (defun tree-store-insert-before 
740     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
741   (%tree-store-insert-before store iter parent sibling)
742   (when data (setf (tree-model-row-data store iter) data))
743   iter)
744
745 (defbinding %tree-store-insert-after () nil
746   (tree-store tree-store)
747   (tree-iter tree-iter)
748   (parent (or null tree-iter))
749   (sibling (or null tree-iter)))
750
751 (defun tree-store-insert-after 
752     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
753   (%tree-store-insert-after store iter parent sibling)
754   (when data (setf (tree-model-row-data store iter) data))
755   iter)
756
757 (defbinding %tree-store-prepend () nil
758   (tree-store tree-store)
759   (tree-iter tree-iter)
760   (parent (or null tree-iter)))
761
762 (defun tree-store-prepend 
763     (store parent &optional data (iter (make-instance 'tree-iter)))
764   (%tree-store-prepend store iter parent)
765   (when data (setf (tree-model-row-data store iter) data))
766   iter)
767
768 (defbinding %tree-store-append () nil
769   (tree-store tree-store)
770   (tree-iter tree-iter)
771   (parent (or null tree-iter)))
772
773 (defun tree-store-append 
774     (store parent &optional data (iter (make-instance 'tree-iter)))
775   (%tree-store-append store iter parent)
776   (when data (setf (tree-model-row-data store iter) data))
777   iter)
778
779 (defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean
780   (tree-store tree-store)
781   (tree-iter tree-iter)
782   (descendant tree-iter))
783
784 (defbinding tree-store-iter-depth () int
785   (tree-store tree-store)
786   (tree-iter tree-iter))
787
788 (defbinding tree-store-clear () nil
789   (tree-store tree-store))
790
791 (defbinding tree-store-reorder () nil
792   (tree-store tree-store)
793   (parent tree-iter)
794   (new-order (vector int)))
795
796 (defbinding tree-store-swap () nil
797   (tree-store tree-store)
798   (a tree-iter)
799   (b tree-iter))
800
801 (defbinding tree-store-move-before () nil
802   (tree-store tree-store)
803   (iter tree-iter)
804   (psoition (or null tree-iter)))
805
806
807 (defbinding tree-store-move-after () nil
808   (tree-store tree-store)
809   (iter tree-iter)
810   (psoition tree-iter))
811
812
813
814 ;;; Tree View
815
816 (defmethod initialize-instance ((tree-view tree-view) &rest initargs 
817                                 &key column)
818   (declare (ignore column))
819   (call-next-method)
820   (mapc #'(lambda (column)
821             (tree-view-append-column tree-view column))
822         (get-all initargs :column)))
823
824
825 (defbinding tree-view-columns-autosize () nil
826   (tree-view tree-view))
827
828 (defbinding tree-view-append-column () int
829   (tree-view tree-view)
830   (tree-view-column tree-view-column))
831
832 (defbinding tree-view-remove-column () int
833   (tree-view tree-view)
834   (tree-view-column tree-view-column))
835
836 (defbinding tree-view-insert-column (view column position) int
837   (view tree-view)
838   (column tree-view-column)
839   ((if (eq position :end) -1 position) int))
840
841 (defbinding tree-view-get-column () tree-view-column
842   (tree-view tree-view)
843   (position int))
844
845 (defbinding tree-view-move-column-after () nil
846   (tree-view tree-view)
847   (column tree-view-column)
848   (base-column (or null tree-view-column)))
849
850 (define-callback-setter tree-view-set-column-drag-function tree-view boolean
851   (column tree-view-column) 
852   (prev tree-view-column) 
853   (next tree-view-column))
854
855 (defbinding tree-view-scroll-to-point () nil
856   (tree-view tree-view)
857   (tree-x int)
858   (tree-y int))
859
860 (defbinding tree-view-scroll-to-cell () nil
861   (tree-view tree-view)
862   (path (or null tree-path))
863   (column (or null tree-view-column))
864   (use-align boolean)
865   (row-align single-float)
866   (col-align single-float))
867
868 (defbinding (tree-view-set-cursor "gtk_tree_view_set_cursor_on_cell") 
869     (tree-view path &key focus-column focus-cell start-editing) nil
870   (tree-view tree-view)
871   (path tree-path)
872   (focus-column (or null tree-view-column))
873   (focus-cell (or null cell-renderer))
874   (start-editing boolean))
875
876 (defbinding tree-view-get-cursor () nil
877   (tree-view tree-view)
878   (path tree-path :out )
879   (focus-column tree-view-column :out))
880
881 (defbinding tree-view-row-activated () nil
882   (tree-view tree-view)
883   (path tree-path )
884   (column tree-view-column))
885
886 (defbinding tree-view-expand-all () nil
887   (tree-view tree-view))
888
889 (defbinding tree-view-collapse-all () nil
890   (tree-view tree-view))
891
892 (defbinding tree-view-expand-to-path () nil
893   (tree-view tree-view)
894   (path tree-path))
895
896 (defbinding tree-view-expand-row () nil
897   (tree-view tree-view)
898   (path tree-path)
899   (open-all boolean))
900
901 (defbinding tree-view-collapse-row () nil
902   (tree-view tree-view)
903   (path tree-path))
904
905 (define-callback-marshal %tree-view-mapping-callback nil (tree-view tree-path))
906
907 (defbinding %tree-view-map-expanded-rows (tree-view callback-id) nil
908   (tree-view tree-view)
909   (%tree-view-mapping-callback callback)
910   (callback-id unsigned-int))
911
912 (defun map-expanded-rows (function tree-view)
913   (with-callback-function (id function)
914     (%tree-view-map-expanded-rows tree-view id)))
915
916 (defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
917   (tree-view tree-view)
918   (path tree-path))
919
920 (defbinding tree-view-get-path-at-pos 
921     (tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
922   (tree-view tree-view)
923   (x int)
924   (y int)
925   (path tree-path :out)
926   (column tree-view-column :out)
927   (cell-x int)
928   (cell-y int))
929
930 (defbinding tree-view-get-cell-area () nil
931   (tree-view tree-view)
932   (path (or null tree-path))
933   (column (or null tree-view-column))
934   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
935
936 (defbinding tree-view-get-background-area () nil
937   (tree-view tree-view)
938   (path (or null tree-path))
939   (column (or null tree-view-column))
940   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
941
942 (defbinding tree-view-get-visible-rect () nil
943   (tree-view tree-view)
944   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
945
946 ;; and many more functions which we'll add later
947
948
949 ;;;; Icon View
950
951 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
952 (progn
953   (defbinding icon-view-get-path-at-pos () tree-path
954     (icon-view icon-view)
955     (x int) (y int))
956
957   (define-callback-marshal %icon-view-foreach-callback nil (icon-view tree-path))
958
959   (defbinding %icon-view-selected-foreach (icon-view callback-id) tree-path
960     (icon-view icon-view)
961     (%icon-view-foreach-callback callback)
962     (callback-id unsigned-int))
963   
964   (defun icon-view-foreach (icon-view function)
965     (with-callback-function (id function)
966       (%icon-view-selected-foreach icon-view id)))
967
968   (defbinding icon-view-select-path () nil
969     (icon-view icon-view)
970     (path tree-path))
971
972   (defbinding icon-view-unselect-path () nil
973     (icon-view icon-view)
974     (path tree-path))
975
976   (defbinding icon-view-path-is-selected-p () boolean
977     (icon-view icon-view)
978     (path tree-path))
979
980   (defbinding icon-view-get-selected-items () (glist tree-path)
981     (icon-view icon-view))
982
983   (defbinding icon-view-select-all () nil
984     (icon-view icon-view))
985
986   (defbinding icon-view-unselect-all () nil
987     (icon-view icon-view))
988   
989   (defbinding icon-view-item-activated () nil
990     (icon-view icon-view)
991     (path tree-path))
992
993   (defbinding %icon-view-set-text-column (column icon-view) nil
994     (icon-view icon-view)
995     ((if (integerp column) 
996          column 
997        (tree-model-column-index (icon-view-model icon-view) column)) int))
998
999   (defbinding %%icon-view-get-text-column () int
1000     (icon-view icon-view))
1001
1002   (defun %icon-view-get-text-column (icon-view)
1003     (tree-model-column-index 
1004      (icon-view-model icon-view) 
1005      (%%icon-view-get-text-column icon-view)))
1006
1007   (defun %icon-view-text-column-boundp (icon-view)
1008     (not (eql (%%icon-view-get-text-column icon-view) -1)))
1009
1010
1011   (defbinding %icon-view-set-markup-column (column icon-view) nil
1012     (icon-view icon-view)
1013     ((if (integerp column) 
1014          column 
1015        (tree-model-column-index (icon-view-model icon-view) column)) int))
1016
1017   (defbinding %%icon-view-get-markup-column () int
1018     (icon-view icon-view))
1019
1020   (defun %icon-view-get-markup-column (icon-view)
1021     (tree-model-column-index 
1022      (icon-view-model icon-view) 
1023      (%%icon-view-get-markup-column icon-view)))
1024
1025   (defun %icon-view-markup-column-boundp (icon-view)
1026     (not (eql (%%icon-view-get-markup-column icon-view) -1)))
1027
1028
1029   (defbinding %icon-view-set-pixbuf-column (column icon-view) nil
1030     (icon-view icon-view)
1031     ((if (integerp column) 
1032          column 
1033        (tree-model-column-index (icon-view-model icon-view) column)) int)))
1034
1035   (defbinding %%icon-view-get-pixbuf-column () int
1036     (icon-view icon-view))
1037
1038   (defun %icon-view-get-pixbuf-column (icon-view)
1039     (tree-model-column-index 
1040      (icon-view-model icon-view) 
1041      (%%icon-view-get-pixbuf-column icon-view)))
1042
1043   (defun %icon-view-pixbuf-column-boundp (icon-view)
1044     (not (eql (%%icon-view-get-pixbuf-column icon-view) -1)))
1045
1046
1047 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1048 (progn
1049   (defbinding icon-view-get-item-at-pos () boolean
1050     (icon-view icon-view)
1051     (x int)
1052     (y int)
1053     (tree-path tree-path :out)
1054     (cell cell-renderer :out))
1055
1056   (defbinding icon-view-set-cursor (icon-view path &key cell start-editing) nil
1057     (icon-view icon-view)
1058     (path tree-path)
1059     (cell (or null cell-renderer))
1060     (start-editing boolean))
1061   
1062   (defbinding icon-view-get-cursor () boolean
1063     (icon-view icon-view)
1064     (path tree-path :out)
1065     (cell cell-renderer :out))
1066
1067   (defbinding icon-view-get-dest-item-at-pos () boolean
1068     (icon-view icon-view)
1069     (drag-x int)
1070     (drag-y int)
1071     (tree-path tree-path :out)
1072     (pos drop-position :out))
1073
1074   (defbinding icon-view-create-drag-icon () gdk:pixmap
1075     (icon-view icon-view)
1076     (tree-path tree-path))
1077
1078   (defbinding icon-view-scroll-to-path (icon-view tree-path &key row-align column-align) nil
1079     (icon-view icon-view)
1080     (tree-path tree-path)
1081     ((or row-align column-align) boolean)
1082     (row-align single-float)
1083     (column-align single-float))
1084
1085   (defbinding icon-view-get-visible-range () boolean
1086     (icon-view icon-view)
1087     (start-path tree-path :out)
1088     (end-path tree-path :out))
1089
1090   (defbinding icon-view-enable-model-drag-source () nil
1091     (icon-view icon-view)
1092     (start-button-mask gdk:modifier-type)
1093     (targets (vector (inlined target-entry)))
1094     ((length targets) unsigned-int)
1095     (actions gdk:drag-action))
1096
1097   (defbinding icon-view-enable-model-drag-dest () nil
1098     (icon-view icon-view)
1099     (targets (vector (inlined target-entry)))
1100     ((length targets) unsigned-int)
1101     (actions gdk:drag-action))
1102
1103   (defbinding icon-view-unset-model-drag-source () nil
1104     (icon-view icon-view))
1105
1106   (defbinding icon-view-unset-model-drag-dest () nil
1107     (icon-view icon-view)))