summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--final_project/work/discovery-examples.scm100
-rw-r--r--final_project/work/discovery-mech-play.scm (renamed from final_project/work/disovery-mech-play.scm)0
-rw-r--r--final_project/work/discovery.scm124
3 files changed, 108 insertions, 116 deletions
diff --git a/final_project/work/discovery-examples.scm b/final_project/work/discovery-examples.scm
new file mode 100644
index 0000000..45ae2ea
--- /dev/null
+++ b/final_project/work/discovery-examples.scm
@@ -0,0 +1,100 @@
+
+(load "ghelper")
+(load "discovery")
+
+(define inverse
+ (make-generic-operator 1 #f 'inverse))
+(define plus
+ (make-generic-operator 2 #f 'plus))
+(define minus
+ (make-generic-operator 2 #f 'minus))
+
+(assign-operation inverse
+ (lambda (x) (/ 1 x))
+ (lambda (x) (and (number? x)
+ (not (integer? x)))))
+
+; actually a transpose, but meh
+(assign-operation inverse
+ (lambda (x) (apply zip x))
+ (lambda (x)
+ (and (list? x)
+ (for-all? x list?))))
+
+(define any? (lambda (x) #t))
+(assign-operation minus - any? any?)
+(assign-operation plus + any? any?)
+
+(plus 1 2)
+; 3
+
+;(minus 3)
+; ERROR
+
+(inverse 6.5)
+;Value: .15384615384615385
+
+(discover:opers-for 6.5)
+;Value 57: (#[compound-procedure 38 operator] thingaling)
+
+(discover:named-opers-for 6.5)
+;Value 58: (thingaling)
+
+(discover:named-opers-for 1 2)
+;Value 81: (plus minus)
+
+;;; this stuff is just play crap
+
+(car (hash-table->alist *generic-operator-table*))
+
+(caadr (hash-table/get *generic-operator-table* inverse #f))
+
+(environment-bound-names (the-environment))
+
+(environment-lookup (the-environment) 'inverse)
+
+
+(inverse '( (1 2 3)
+ (0 1 2)
+ (0 0 1)))
+
+(hash-table/get *generic-operator-table* inverse #f)
+(hash-table/get *generic-operator-table* minus #f)
+
+(hash-table-size *generic-operator-table*)
+;Value: 92 ;this is for mechanics
+
+;this prints all keys line by line
+(for-each
+ (lambda (x) (newline)
+ (display x))
+ (hash-table/key-list *generic-operator-table*))
+
+
+(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))
+(define inverse (make-generic-operator 1 #f 'inverse))
+(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?)
+(defhandler inverse (lambda (x) (/ 1 x)) (lambda (n)
+ (and (number? n)
+ (not (zero? n)))))
+
+(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)
+
+
diff --git a/final_project/work/disovery-mech-play.scm b/final_project/work/discovery-mech-play.scm
index c2d5013..c2d5013 100644
--- a/final_project/work/disovery-mech-play.scm
+++ b/final_project/work/discovery-mech-play.scm
diff --git a/final_project/work/discovery.scm b/final_project/work/discovery.scm
index b6f315d..6aaeba9 100644
--- a/final_project/work/discovery.scm
+++ b/final_project/work/discovery.scm
@@ -17,6 +17,13 @@
((apply (car preds) args) #t)
(else (for-any? (cdr preds) args))))
+; Test
+(for-any? (list list? null? vector?) '(5))
+; #f
+(for-any? (list list? null? vector?) '('(1 2 3)))
+; #t
+
+
; finds all the operators which can be applied to the args; returns a list
; of operators (not the actual procedures; will include duplicate symbols and
; operator stubs for named operators)
@@ -56,86 +63,6 @@
(filter (lambda (x) (not (null? x)))
(map check (hash-table-keys *generic-operator-table*)))))
-;(discover:named-opers)
-
-
-
-;#| ------------------- Testing --------------------
-
-(for-any? (list list? null? vector?) '(4))
-; #f
-(for-any? (list list? null? vector?) '('(1 2 3)))
-; #t
-
-(define inverse
- (make-generic-operator 1 #f 'thingaling))
-(define plus
- (make-generic-operator 2 #f 'plus))
-(define minus
- (make-generic-operator 2 #f 'minus))
-
-(assign-operation inverse
- (lambda (x) (/ 1 x))
- (lambda (x) (and (number? x)
- (not (integer? x)))))
-
-; actually a transpose, but meh
-(assign-operation inverse
- (lambda (x) (apply zip x))
- (lambda (x)
- (and (list? x)
- (for-all? x list?))))
-
-(define any? (lambda (x) #t))
-(assign-operation minus - any? any?)
-(assign-operation plus + any? any?)
-
-(plus 1 2)
-; 3
-
-;(minus 3)
-; ERROR
-
-(inverse 6.5)
-;Value: .15384615384615385
-
-(discover:opers-for 6.5)
-;Value 57: (#[compound-procedure 38 operator] thingaling)
-
-(discover:named-opers-for 6.5)
-;Value 58: (thingaling)
-
-(discover:named-opers-for 1 2)
-;Value 81: (plus minus)
-
-;;; this stuff is just play crap
-
-(car (hash-table->alist *generic-operator-table*))
-
-(caadr (hash-table/get *generic-operator-table* inverse #f))
-
-(environment-bound-names (the-environment))
-
-(environment-lookup (the-environment) 'inverse)
-
-
-(inverse '( (1 2 3)
- (0 1 2)
- (0 0 1)))
-
-(hash-table/get *generic-operator-table* inverse #f)
-(hash-table/get *generic-operator-table* minus #f)
-
-(hash-table-size *generic-operator-table*)
-;Value: 92 ;this is for mechanics
-
-;this prints all keys line by line
-(for-each
- (lambda (x) (newline)
- (display x))
- (hash-table/key-list *generic-operator-table*))
-
-;-------------------- End Testing ------------------- |#
; this is just what operators do
(define (discover:apply-name name . args)
@@ -197,33 +124,6 @@
(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)))
@@ -239,13 +139,5 @@
objs)))))))
-
-
-
-
-
-
-
-
-
+; see discovery-examples.scm for testing and examples