From 2aad489f2c311a8fdfed8419fdf523f055f0296d Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@eta.mit.edu>
Date: Fri, 8 May 2009 03:35:05 -0400
Subject: oh yeah

---
 final_project/work/discovery.scm | 59 ++++++++++++++++++++++++++++++++--------
 1 file changed, 47 insertions(+), 12 deletions(-)

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

diff --git a/final_project/work/discovery.scm b/final_project/work/discovery.scm
index 3fa138f..e3756ab 100644
--- a/final_project/work/discovery.scm
+++ b/final_project/work/discovery.scm
@@ -9,6 +9,8 @@
 ; If it isn't already....
 ;(load "ghelper")
 
+(define filter keep-matching-items)
+
 ; takes two lists: the first is a set of predicates and the second a set
 ; of arguments; if any of the predicates are #t for the args, win, else fail
 (define (for-any? preds args)
@@ -137,21 +139,54 @@
 
 -------------------- End Testing ------------------- |#
 
-(define (discover:apply-all . args)
-  (filter (compose not null?) 
-	  (map (lambda (oper)
-		 (if (symbol? oper)
-		     '()
-		     (list oper (apply oper args))))
-	       (apply discover:opers-for args))))
+; this is just what operators do
+(define (discover:apply-name name . args)
+  (let ((record (hash-table/get *generic-operator-table* name #f)))
+    (let ((succeed
+	   (lambda (handler)
+	     (apply handler args))))
+      (let per-arg
+	  ((tree (operator-record-tree record))
+	   (args args)
+	   (fail
+	    (lambda ()
+	      (error:no-applicable-methods operator args))))
+	(let per-pred ((tree tree) (fail fail))
+	  (cond ((pair? tree)
+		 (if ((caar tree) (car args))
+		     (if (pair? (cdr args))
+			 (per-arg (cdar tree)
+				  (cdr args)
+				  (lambda ()
+				    (per-pred (cdr tree) fail)))
+			 (succeed (cdar tree)))
+		     (per-pred (cdr tree) fail)))
+		((null? tree)
+		 (fail))
+		(else
+		 (succeed tree))))))))
+
+(define (discover:thunklist-for . args)
+  (let ((names (apply discover:named-opers-for args)))
+    (cons args
+	  (map (lambda (x)
+		 (list x
+		       (lambda ()
+			 (apply discover:apply-name (cons x args)))))
+	       names))))
+
+
+
+
+
+
+
+
+
+
 
-(discover:apply-all 2)
-  
-(discover:named-opers-for 2)
 
-(environment-lookup (the-environment) 'sin)
 
-(one-like 4)
 
 
 
-- 
cgit v1.2.3