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