#! /bin/sh # -*- scheme -*- hn=`hostname` if [[ "$hn" == "tabu" ]] then exec guile-gnome-0 -s $0 "$@" else exec guile-gnome-2 -s $0 "$@" fi !# ;; guile-gnome ;; Copyright (C) 2003,2004 Free Software Foundation, Inc. ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation; either version 2 of ;; the License, or (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, contact: ;; ;; Free Software Foundation Voice: +1-617-542-5942 ;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 ;; Boston, MA 02111-1307, USA address@hidden (read-set! keywords 'prefix) (use-modules (ice-9 receive) (oop goops) (gnome gobject) (gnome gtk) (gnome gtk gdk-event)) (define *model* #f) (define *selection* #f) (define (pack-tv-column tv column renderer pos) (pack-start column renderer #t) (add-attribute column renderer "text" pos) (append-column tv column)) (define (add-columns treeview) (let* ((renderer1 (make )) (column1 (make :title "Column 1" :sizing 'fixed :fixed-width 65 ;:clickable #f ;:resizable #f ;:reorderable #f :alignment .5 )) (renderer2 (make )) (column2 (make :title "Column 2" :sizing 'fixed :fixed-width 65 ;:clickable #f ;:resizable #f ;:reorderable #f :alignment .5 )) (renderer3 (make )) (column3 (make :title "Column 3" :expand #t :alignment .5 )) ;; ROW BACKGROUND COLOUR (renderer4 (make :xalign 1)) (column4 (make :visible #f )) ;; ROW FOREGROUND COLOUR (renderer5 (make :xalign 1)) (column5 (make :visible #f ))) (pack-tv-column treeview column1 renderer1 0) (pack-tv-column treeview column2 renderer2 1) (pack-tv-column treeview column3 renderer3 2) (pack-tv-column treeview column4 renderer4 3) (pack-tv-column treeview column5 renderer5 4) ;; background colour (add-attribute column1 renderer1 "cell-background" 3) (add-attribute column2 renderer2 "cell-background" 3) (add-attribute column3 renderer3 "cell-background" 3) ;; foreground colour (add-attribute column1 renderer1 "foreground" 4) (add-attribute column2 renderer2 "foreground" 4) (add-attribute column3 renderer3 "foreground" 4) (set-search-column treeview 2) )) (define (ocs/add-model treeview) (let* ((column-types (list )) (model (gtk-list-store-new column-types))) (set-model treeview model) (values model (get-selection treeview)) )) (define (setup-treeview treeview) (add-columns treeview) (receive (model selection) (ocs/add-model treeview) (set-mode selection 'single) (values model selection))) (define (populate-model model) (for-each (lambda (row) (let ((iter (gtk-list-store-append model))) (set-value model iter 0 (car row)) (set-value model iter 1 (cadr row)) (set-value model iter 2 (caddr row)))) '(("r1c1" "r1c2" "r1c3") ("r2c1" "r2c2" "r2c3") ("r3c1" "r3c2" "r3c3")) )) (define (make-simple-popup-menu entries) (let ((menu (make ))) (for-each (lambda (entry) (if (pair? entry) (let* ((label (car entry)) (callback (cdr entry)) (menu-item (gtk-menu-item-new-with-label label))) (connect menu-item 'activate (lambda (widget) (callback))) (gtk-menu-shell-append menu menu-item) (show menu-item)) (let ((menu-item (gtk-separator-menu-item-new))) (gtk-menu-shell-append menu menu-item) (show menu-item)))) entries) menu)) (define (gtku/status-push status-bar message source) (let ((context-id (gtk-statusbar-get-context-id status-bar source))) (gtk-statusbar-push status-bar context-id message))) (define (gtku/status-pop status-bar source) (let ((context-id (gtk-statusbar-get-context-id status-bar source))) (gtk-statusbar-pop status-bar context-id))) (define (make-popup-menu) (make-simple-popup-menu `(("popup option 1" . ,(lambda () (display "popup option 1\n"))) ("popup option 2" . ,(lambda () (display "popup option 2\n"))) separator ("popup option 3" . ,(lambda () (display "popup option 3\n")))) )) (define (test-suite-1 treeview model selection popup-menu) (let ((i 0) (nb-rows -1) (bgcolours '("Black" "grey20" "grey40")) (fgcolours '("white" "wheat" "royalblue"))) (while (< i 1000) (let* ((sibling (get-iter model 2)) ;; (iter (gtk-list-store-append model)) (iter (insert-after model sibling)) ) (set-value model iter 0 (symbol->string (gensym "gs-"))) (set-value model iter 1 (symbol->string (gensym "gs-"))) (set-value model iter 2 (symbol->string (gensym "gs-"))) (set-value model iter 3 (list-ref bgcolours (modulo i 3))) (set-value model iter 4 (list-ref fgcolours (modulo i 3))) ) (select-path selection (list (modulo i 100))) (set! i (1+ i))) (select-path selection (list 0)) (set! i 0) (while (< i 500) (let ((iter (get-iter model (list i)))) (set-value model iter 3 "grey20") (set-value model iter 4 "Royalnavy1") (remove model iter)) (set! i (1+ i))) (set! nb-rows (gtk-tree-model-iter-n-children model #f)) ;; (gtk-menu-popup popup-menu #f #f #f 3 0) (select-path selection (list 2)) (set! i 0) (while (< i nb-rows) (gtk-tree-view-scroll-to-cell treeview (list i) #f #t 0.3) (set! i (1+ i))) )) (define (test-suite-2 treeview model selection first next) (let ((nb-rows (gtk-tree-model-iter-n-children model #f)) (i 0)) (emit first 'clicked) (while (< i nb-rows) ;; (select-path selection (list i)) ;; (gtk-tree-view-scroll-to-cell treeview (list i) #f #t 0.3) ;; (usleep 500) (emit next 'clicked) (set! i (1+ i))) )) (define (start-test treeview model selection popup-menu first next) (let ((i 0)) (gtk-list-store-clear model) (test-suite-1 treeview model selection popup-menu) (while (< i 10) (test-suite-2 treeview model selection first next) (set! i (1+ i)) ))) (define (animate) (let* ((window (make :type 'toplevel :title "Get path at pos test" )) (vbox (make :homogeneous #f :spacing 2)) (hbox (make :homogeneous #f :spacing 2)) (scrollw (make :hscrollbar-policy 'never :vscrollbar-policy 'automatic)) (treeview (make )) (firstrow (make :label "first row")) ;; (gtk-stock-id 'close) (nextrow (make :label "next row")) ;; (gtk-stock-id 'close) (test-1 (make :label "Test suite")) (test-2 (make :label "Start ...")) (statusbar (make )) (popup-menu (make-popup-menu))) (set-default-size window 400 150) (receive (model selection) (setup-treeview treeview) (populate-model model) (add window vbox) (add scrollw treeview) (pack-start vbox scrollw #t #t 0) (pack-start vbox hbox #f #f 0) (pack-start hbox firstrow #f #f 0) (pack-start hbox nextrow #f #f 0) (pack-start hbox test-1 #f #f 0) (pack-start hbox test-2 #t #t 0) (pack-start vbox statusbar #f #f 0) (connect window 'delete-event (lambda (widget event) (destroy widget) (gtk-main-quit) #f)) (connect selection 'changed (lambda (selection) (receive (model iter) (get-selected selection) (if iter (let* ((path (get-path model iter)) (row (car path))) ;(gtku/status-pop statusbar "") ;(gtku/status-push statusbar (get-value model iter 0) "") #t ))) #f)) (connect treeview 'button-press-event (lambda (w ev) (case (gdk-event:type ev) ((button-press) (let* ((button (gdk-event-button:button ev)) (time (gdk-event-button:time ev)) (x-pos (inexact->exact (gdk-event-button:x ev))) (y-pos (inexact->exact (gdk-event-button:y ev))) (path-values;; (get-path-at-pos w x-pos y-pos) (values (list 1) #t 10 10) )) (case button ((3) (receive (indices bool x y) path-values (let* ((row (car indices)) (iter (get-iter model row))) (gtk-menu-popup popup-menu #f ;; parent-menu-shell or #f #f ;; parent-menu-item or #f #f ;; user supplied func to position the menu or #f ;; #f - no more user supplied data to pass to func button time ))))))) ((2button-press) (simple-format #t "ignoring 2button-press events...~%")) ((3button-press) (simple-format #t "ignoring 3button-press events...~%")) ) #f )) (connect firstrow 'clicked (lambda (but) (select-path selection (list 0)) (gtk-tree-view-scroll-to-cell treeview (list 0) #f #t 0.3))) (connect nextrow 'clicked (lambda (but) (receive (model iter) (get-selected selection) (if iter (let* ((path (get-path model iter)) (row (car path)) (new-path (list (1+ row)))) (select-path selection new-path) (gtk-tree-view-scroll-to-cell treeview new-path #f #t 0.3)))) )) (connect test-1 'clicked (lambda (but) (start-test treeview model selection popup-menu firstrow nextrow))) (connect test-2 'clicked (lambda (but) (let ((i 0)) (while (< i 10) (emit test-1 'clicked))))) ) (show-all window) (gtk-main))) (animate)