#| -*-Scheme-*-
     
     $Id: $
     |#
     
     (declare (usual-integrations))

     
     (load "ghelper.scm")
     (load "discovery.scm")
     (load-option 'FFI)
     (C-include "prhello")
(load "generic-string-opers.scm")

(define get-vals car)
(define (get-proc-symbols input) (map car (cdr input)))
(define (apply-ith-thunk input i) ((cadr (list-ref (cdr input) i))))


(define (thing-to-string thing)
 (let ((buff (open-output-string)))
   (display thing buff)
   (get-output-string buff)))

(define (discover-gui . input)
					;(display (discover:named-opers-for 1))
  (C-call "gtk_init" 0 null-alien)
  (let* ((discovered-opers (apply discover:thunklist-for input))
	 (window (let ((alien (make-alien '|GtkWidget|)))
		   (C-call "gtk_window_new" alien
			   (C-enum "GTK_WINDOW_TOPLEVEL"))
		   (if (alien-null? alien) (error "Could not create window."))
		       alien))
	 (hbox (let ((alien (make-alien '|GtkWidget|)))
		 (C-call "gtk_hbox_new" alien 0 20)
		 (if (alien-null? alien) (error "Could not create hbox."))
		 alien))
	 (combo (let ((alien (make-alien '|GtkWidget|)))
		  (C-call "gtk_combo_box_new_text" alien)
		  (if (alien-null? alien) (error "Could not create combo."))
		  alien))
	 (labels (map (lambda (val) 
			(let ((alien (make-alien '|GtkWidget|)))
			  (C-call "gtk_label_new" alien (thing-to-string val))
			  (if (alien-null? alien) (error "Could not create label."))
			  alien))
		      (get-vals discovered-opers))))
    (for-each (lambda (proc-symbol)
		(C-call "gtk_combo_box_append_text" combo (thing-to-string proc-symbol)))
	      (get-proc-symbols discovered-opers))
				
    (for-each (lambda (label) (C-call "gtk_container_add" hbox label)) labels)
    (C-call "gtk_container_add" hbox combo)
    (C-call "gtk_container_add" window hbox)
    (C-call "gtk_window_set_title" window "Generic Operator Discovery")
    (C-call "gtk_container_set_border_width" window 10)
    (C-call "gtk_window_resize" window 250 20)
    (C-call "g_signal_connect" combo "changed"
	    (C-callback "changed")	;trampoline
	    (C-callback			;callback ID
	     (lambda (w)
	       (let ((i (C-call "gtk_combo_box_get_active" combo)))
		 (discover-gui (apply-ith-thunk discovered-opers i))))))

    (C-call "g_signal_connect" window "delete_event"
	    (C-callback "delete_event")	;trampoline
	    (C-callback			;callback ID
	     (lambda (w e)
	       (begin
		 (C-call "gtk_main_quit")
		 0))))
    (C-call "gtk_widget_show_all" window)
    (C-call "gtk_main")
    window))