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