1;; guile-gnome
2;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com>
3
4;; This program is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU General Public License as
6;; published by the Free Software Foundation; either version 2 of
7;; the License, or (at your option) any later version.
8;;
9;; This program is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12;; GNU General Public License for more details.
13;;
14;; You should have received a copy of the GNU General Public License
15;; along with this program; if not, contact:
16;;
17;; Free Software Foundation           Voice:  +1-617-542-5942
18;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
19;; Boston, MA  02111-1307,  USA       gnu@gnu.org
20
21;;; Commentary:
22;;
23;;A lazy tree model. The value of the rows, as well the rows' children,
24;;are promises made by the @code{delay} operator.
25;;
26;;; Code:
27
28(define-module (gnome contrib delay-tree-model)
29  #:use-module (oop goops)
30  #:use-module (gnome gobject)
31  #:use-module (gnome gtk)
32  #:use-module (container nodal-tree)
33  #:use-module (container delay-tree)
34  #:use-module (scheme documentation)
35  #:export (<delay-tree-model> append-root!))
36
37(define-class-with-docs <delay-tree-model> (<guile-gtk-tree-model>)
38  "An interface that exports delay trees as GTK+ tree models. Suitable
39for use with @code{<gtk-tree-view>}."
40  (top-nodes #:init-value '()))
41
42(define-method (on-get-n-columns (obj <delay-tree-model>))
43  2) ;; name and value
44
45(define-method (on-get-column-type (obj <delay-tree-model>) index)
46  (case index
47    ((0) <gchararray>)
48    ((1) <gboxed-scm>)
49    (else (error "Invalid index:" index))))
50
51(define-method (on-get-iter (obj <delay-tree-model>) path)
52  (let loop ((node #f) (path path))
53    (if (null? path)
54        node
55        (let ((children (if node
56                            (force-ref node 'children)
57                            (slot-ref obj 'top-nodes))))
58          (cond
59           ((null? children) ;; can be the case for path == (0)
60            #f)
61           ((>= (car path) (length children))
62            #f)              ;; nonexistent path, but no error
63           (else
64            (loop (list-ref children (car path)) (cdr path))))))))
65
66(define-method (on-get-path (obj <delay-tree-model>) iter)
67  (let loop ((node iter) (path '()))
68    (let ((parent (node-ref node 'parent)))
69      (if (not parent)
70          (cons (list-index (slot-ref obj 'top-nodes) node) path)
71          (loop parent
72                (cons (list-index (node-ref parent 'children) node) path))))))
73
74(define-method (on-get-value (obj <delay-tree-model>) iter index)
75  (case index
76    ((0)
77     (force-ref iter 'name))
78    ((1)
79     (force-ref iter 'value))
80    (else
81     (error "Invalid index" index))))
82
83(define-method (on-iter-next (obj <delay-tree-model>) iter)
84  (let* ((parent (node-ref iter 'parent))
85         (siblings (if parent
86                       (node-ref parent 'children)
87                       (slot-ref obj 'top-nodes)))
88         (new-position (1+ (list-index siblings iter))))
89    (and (< new-position (length siblings))
90         (list-ref siblings new-position))))
91
92(define-method (on-iter-children (obj <delay-tree-model>) parent)
93  (let ((children (if parent
94                      (force-ref parent 'children)
95                      (slot-ref obj 'top-nodes))))
96    (and (pair? children)
97         (car children))))
98
99(define-method (on-iter-has-child (obj <delay-tree-model>) iter)
100  ;; would be nice to avoid forcing the children if there are none.
101  (not (null? (force-ref iter 'children))))
102
103(define-method (on-iter-n-children (obj <delay-tree-model>) iter)
104  (length (if iter
105              (force-ref iter 'children)
106              (slot-ref obj 'top-nodes))))
107
108(define-method (on-iter-nth-child (obj <delay-tree-model>) parent n)
109  (let ((children (if parent
110                      (force-ref parent 'children)
111                      (slot-ref obj 'top-nodes))))
112    (and (< n (length children))
113         (list-ref children n))))
114
115(define-method (on-iter-parent (obj <delay-tree-model>) iter)
116  (node-ref iter 'parent))
117
118;; To the on-* methods, the iter is just a scheme object. But outside
119;; those methods it is a boxed type. So we need to call the Gtk+
120;; notification functions (row-inserted, row-has-child-toggled) with the
121;; boxed types, not with SCM values.
122(define-method (append-root! (obj <delay-tree-model>) delay-tree)
123  (define (emit-signals path)
124    (row-inserted obj path (get-iter obj path)))
125
126  (slot-set! obj 'top-nodes (append! (slot-ref obj 'top-nodes)
127                                     (list delay-tree)))
128  (let ((path (get-path obj (get-iter obj (on-get-path obj delay-tree)))))
129    (emit-signals path)
130    (get-iter obj path)))
131