#! /bin/sh
# -*- scheme -*-
exec guile-gnome-2 -s $0 "$@"
!#

;; 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 <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
		      )))
    (pack-tv-column treeview column1 renderer1 0)
    (pack-tv-column treeview column2 renderer2 1)
    (pack-tv-column treeview column3 renderer3 2)
    ;; (set-search-column treeview 1)
    ))

(define (ocs/add-model treeview)
  (let* ((column-types (list <gchararray>
			     <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 (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 (animate)
  (let* ((window (make <gtk-window> 
		   :type 'toplevel
		   :title "Get path at pos test"
		   ))
	 (treeview (make <gtk-tree-view>))
	 (popup-menu (make-popup-menu)))
    (set-default-size window 300 100)
    (receive (model selection)
	(setup-treeview treeview)
      (populate-model model)
      (add window treeview)

      (connect window
	       'delete-event
	       (lambda (widget event)
		 (destroy widget)
		 (gtk-main-quit)
		 #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
	       ))

      )

    (show-all window)

    (gtk-main)))

(animate)