summaryrefslogtreecommitdiffstats
path: root/final_project
diff options
context:
space:
mode:
authorbnewbold <bnewbold@eta.mit.edu>2009-05-08 05:18:46 -0400
committerbnewbold <bnewbold@eta.mit.edu>2009-05-08 05:18:46 -0400
commit8ea03531c363e0260a1463d006653ac23bb0edf6 (patch)
tree469127604bd6a50043132e73d9fc11fe951d3d3e /final_project
parent4c4b1ef874c75e87e0a8435c73a203e19820ac10 (diff)
download6.945-8ea03531c363e0260a1463d006653ac23bb0edf6.tar.gz
6.945-8ea03531c363e0260a1463d006653ac23bb0edf6.zip
working code
Diffstat (limited to 'final_project')
-rw-r--r--final_project/work/discovery.scm63
1 files changed, 57 insertions, 6 deletions
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)))))))