From 8ea03531c363e0260a1463d006653ac23bb0edf6 Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@eta.mit.edu>
Date: Fri, 8 May 2009 05:18:46 -0400
Subject: working code

---
 final_project/work/discovery.scm | 63 ++++++++++++++++++++++++++++++++++++----
 1 file changed, 57 insertions(+), 6 deletions(-)

(limited to 'final_project')

diff --git a/final_project/work/discovery.scm b/final_project/work/discovery.scm
index 1da7b21..b6f315d 100644
--- a/final_project/work/discovery.scm
+++ b/final_project/work/discovery.scm
@@ -60,7 +60,7 @@
 
 
 
-#| ------------------- Testing --------------------
+;#| ------------------- Testing --------------------
 
 (for-any? (list list? null? vector?) '(4))
 ; #f
@@ -93,7 +93,7 @@
 (plus 1 2)
 ; 3
 
-(minus 3)
+;(minus 3)
 ; ERROR
 
 (inverse 6.5)
@@ -135,7 +135,7 @@
 	 (display x))
  (hash-table/key-list *generic-operator-table*))
 
--------------------- End Testing ------------------- |#
+;-------------------- End Testing ------------------- |#
 
 ; this is just what operators do
 (define (discover:apply-name name . args)
@@ -173,19 +173,70 @@
 			 (apply discover:apply-name (cons x args)))))
 	       names))))
 
+(define (discover:apply-all . args)
+  (let ((names (apply discover:named-opers-for args)))
+    (map (lambda (x)
+	   (apply discover:apply-name (cons x args)))
+	 names)))
+
+(define (discover:apply-all-name . args)
+  (let ((names (apply discover:named-opers-for args)))
+    (map (lambda (x)
+	   (list (apply discover:apply-name (cons x args)) x))
+	 names)))
+
 (define (discover:satisfy pred? . args)
   (let try ((objs (list args)))
-    (let ((goodies (keep-matching-items (lambda (x) (apply pred? x)))))
+    (let ((goodies (filter (lambda (x) (apply pred? x)) objs)))
       (if (not (null? goodies))
 	  (car goodies)
-	  (lp (fold-right append 
+	  (try (fold-right append 
 			  '()
 			  (map (lambda (x)
-				 (list (apply discover:apply-all x)))
+				 (map list
+				      (apply discover:apply-all x)))
 			       objs)))))))
 
+;#| more testing
+
+(define add1 (make-generic-operator 1 #f 'add1))
+(define sub1 (make-generic-operator 1 #f 'sub1))
+(define double (make-generic-operator 1 #f 'double))
+(define square (make-generic-operator 1 #f 'square))
+(defhandler add1 (lambda (x) (+ x 1)) number?)
+(defhandler sub1 (lambda (x) (- x 1)) number?)
+(defhandler double (lambda (x) (* 2 x)) number?)
+(defhandler square (lambda (x) (* x x)) number?)
+
+(add1 4)
+;(sub1 'b)
+
+(discover:apply-all 3)
 
+(discover:satisfy (lambda (x) (eq? x 9)) (/ 1 2))
+(discover:satisfy-sequence (lambda (x) (eq? x 9)) (/ 1 2))
 
+(discover:satisfy-sequence (lambda (x) (eq? x 49)) (/ 5 6))
+
+(square (sqrt 2))
+(sqrt 2)
+(square 3)
+
+;|#
+
+(define (discover:satisfy-sequence pred? . args)
+  (let try ((objs (list (list args))))
+    (let ((goodies (filter (lambda (x) (apply pred? (car x))) objs)))
+      (if (not (null? goodies))
+	  goodies
+	  (try (fold-right append 
+			  '()
+			  (map (lambda (x)
+				 (map (lambda (y)
+					(cons (list (car y)) (cons (cadr y) 
+								   (cdr x))))
+				      (apply discover:apply-all-name (car x))))
+			       objs)))))))
 
 
 
-- 
cgit v1.2.3