1;; Copyright (C) 2003,2004 Free Software Foundation, Inc.
2;; GNU General Public License version 2 or later. No warrantee.
3
4(define-module (demos tree-model)
5  :use-module (oop goops)
6  :use-module (gnome gobject)
7  :use-module (gnome gtk))
8
9(define-class <my-tree-model> (<guile-gtk-tree-model>)
10  depth
11  siblings)
12
13(define-method (on-get-n-columns (obj <my-tree-model>))
14  1)
15
16(define-method (on-get-column-type (obj <my-tree-model>) index)
17  <gchararray>)
18
19(define-method (on-get-iter (obj <my-tree-model>) path)
20  path)
21
22(define-method (on-get-path (obj <my-tree-model>) iter)
23  iter)
24
25(define-method (on-get-value (obj <my-tree-model>) iter index)
26  (format #f "~A" iter))
27
28(define-method (on-iter-next (obj <my-tree-model>) iter)
29  (let* ((reversed (reverse iter))
30         (next (1+ (car reversed))))
31    (if (eq? next (slot-ref obj 'siblings))
32        #f
33        (reverse (cons next (cdr reversed))))))
34
35(define-method (on-iter-children (obj <my-tree-model>) parent)
36  (cond
37   ((not parent)
38    (list 0))
39   ((eq? (length parent) (slot-ref obj 'depth))
40    #f)
41   (else
42    (reverse (cons 0 (reverse parent))))))
43
44(define-method (on-iter-has-child (obj <my-tree-model>) iter)
45  (not (eq? (length iter) (slot-ref obj 'depth))))
46
47(define-method (on-iter-n-children (obj <my-tree-model>) iter)
48  (cond
49   ((not iter)
50    (slot-ref obj 'siblings))
51   ((on-iter-has-child obj iter)
52    (slot-ref obj 'siblings))
53   (else
54    0)))
55
56(define-method (on-iter-nth-child (obj <my-tree-model>) parent n)
57  (let ((nchildren (on-iter-n-children obj parent)))
58    (if (< n nchildren)
59        (reverse (cons n (if parent (reverse parent) '())))
60        #f)))
61
62(define-method (on-iter-parent (obj <my-tree-model>) iter)
63  (if (zero? (length iter))
64      #f
65      (reverse (cdr (reverse iter)))))
66
67(define-method (initialize (obj <my-tree-model>) initargs)
68  (next-method)
69  (slot-set! obj 'depth 4)
70  (slot-set! obj 'siblings 5))
71
72(define (main)
73  (let* ((w (make <gtk-window> :type 'toplevel :title "TreeModel Test"))
74         (scroll (make <gtk-scrolled-window>
75                   :hscrollbar-policy 'automatic :vscrollbar-policy 'automatic))
76         (tmodel (make <my-tree-model>))
77         (tview (make <gtk-tree-view> :model tmodel))
78         (cell (make <gtk-cell-renderer-text>))
79         (column (make <gtk-tree-view-column> :title "Data")))
80
81    (pack-start column cell #t)
82    (add-attribute column cell "text" 0)
83    (append-column tview column)
84
85    (set-default-size w 250 250)
86    (add w scroll)
87    (add scroll tview)
88    (show-all w)
89    (connect w 'delete-event (lambda (w e) (gtk-widget-destroy w) #f))))
90
91(define name "Tree Model")
92(define description
93  (string-append
94   "This example shows how to implement a tree model in Scheme.\n"
95   "Tree paths are natively represented as lists of integers. In this simple "
96   "model, iters and values of the model are also the same as the paths. Note "
97   "that the data is not stored in the model, only the algorithm of how to "
98   "produce the data when it is requested. "))
99