diff options
| -rw-r--r-- | final_project/work/discovery-examples.scm | 100 | ||||
| -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.scm | 124 |
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 |