From 38e10dc81d5f8f1a2bbededb790e775c0c637d6c Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@eta.mit.edu>
Date: Mon, 11 May 2009 13:45:12 -0400
Subject: files from laura

---
 final_project/work/prhello.scm | 77 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 77 insertions(+)
 create mode 100644 final_project/work/prhello.scm

(limited to 'final_project/work/prhello.scm')

diff --git a/final_project/work/prhello.scm b/final_project/work/prhello.scm
new file mode 100644
index 0000000..c57f6f9
--- /dev/null
+++ b/final_project/work/prhello.scm
@@ -0,0 +1,77 @@
+     #| -*-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))
+      
+
+
-- 
cgit v1.2.3