#! /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       gnu@gnu.org

(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 <gtk-cell-renderer-text>))
	 (column1   (make <gtk-tree-view-column>
		      :title       "Column 1"
		      :sizing      'fixed
		      :fixed-width 65
					;:clickable   #f
					;:resizable   #f
					;:reorderable #f
		      :alignment   .5
		      ))
	 (renderer2 (make <gtk-cell-renderer-text>))
	 (column2   (make <gtk-tree-view-column>
		      :title       "Column 2"
		      :sizing      'fixed
		      :fixed-width 65
					;:clickable   #f
					;:resizable   #f
					;:reorderable #f
		      :alignment   .5
		      ))
	 (renderer3 (make <gtk-cell-renderer-text>))
	 (column3   (make <gtk-tree-view-column>
		      :title       "Column 3"
		      :expand      #t
		      :alignment   .5
		      ))
	 ;; ROW BACKGROUND COLOUR
	 (renderer4 (make <gtk-cell-renderer-text>
		      :xalign      1))
	 (column4   (make <gtk-tree-view-column>
		      :visible     #f
		      ))
	 ;; ROW FOREGROUND COLOUR
	 (renderer5 (make <gtk-cell-renderer-text>
		      :xalign      1))
	 (column5   (make <gtk-tree-view-column>
		      :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 <gchararray>
			     <gchararray>
			     <gchararray>
			     <gchararray>
			     <gchararray>))
	 (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 <gtk-menu>)))
    (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 <gtk-window>
		   :type 'toplevel
		   :title "Get path at pos test"
		   ))
	 (vbox (make <gtk-vbox>
		 :homogeneous #f
		 :spacing 2))
	 (hbox (make <gtk-hbox>
		 :homogeneous #f
		 :spacing 2))
	 (scrollw (make <gtk-scrolled-window>
		    :hscrollbar-policy 'never
		    :vscrollbar-policy 'automatic))
	 (treeview (make <gtk-tree-view>))
	 (firstrow (make <gtk-button>
		    :label "first row")) ;; (gtk-stock-id 'close)
	 (nextrow (make <gtk-button>
		    :label "next row")) ;; (gtk-stock-id 'close)
	 (test-1 (make <gtk-button>
		   :label "Test suite"))
	 (test-2 (make <gtk-button>
		   :label "Start ..."))
	 (statusbar (make <gtk-statusbar>))
	 (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)
		     (set! i (1+ i))
		     ))))

      )

    (show-all window)

    (gtk-main)))

(animate)