From c02dece30f877532eb9b7883730edbc9f1cdd362 Mon Sep 17 00:00:00 2001 From: bnewbold Date: Fri, 8 May 2009 07:38:15 -0400 Subject: split out examples --- final_project/work/discovery-examples.scm | 100 +++++++++++++++++++++++ final_project/work/discovery-mech-play.scm | 24 ++++++ final_project/work/discovery.scm | 124 ++--------------------------- final_project/work/disovery-mech-play.scm | 24 ------ 4 files changed, 132 insertions(+), 140 deletions(-) create mode 100644 final_project/work/discovery-examples.scm create mode 100644 final_project/work/discovery-mech-play.scm delete mode 100644 final_project/work/disovery-mech-play.scm 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/discovery-mech-play.scm b/final_project/work/discovery-mech-play.scm new file mode 100644 index 0000000..c2d5013 --- /dev/null +++ b/final_project/work/discovery-mech-play.scm @@ -0,0 +1,24 @@ + +(load "discovery") +;Loading "discovery.scm"... done +;Value: discover:named-opers + +(discover:named-opers) +;Value: (+ one-like cos dot-product expt one? * gcd partial-derivative acos exp atan2 cosh imag-part one = conjugate zero? / zero-like abs sinh identity? sin asin derivative angle magnitude inexact? type apply identity make-polar arity real-part - invert negate identity-like trace determinant sqrt zero log square make-rectangular type-predicate atan1) + +(discover:named-opers-for 1) +;Value: (one-like cos one? acos exp cosh imag-part conjugate zero? zero-like abs sinh identity? sin asin angle magnitude inexact? type arity real-part invert negate identity-like trace determinant sqrt log square type-predicate atan1) + +(discover:named-opers-for (matrix-by-rows '(1 0 0) + '(0 1 0) + '(0 0 1))) +;Value: (one-like cos exp conjugate zero? zero-like identity? sin inexact? type arity invert negate identity-like trace determinant type-predicate) + +(discover:named-opers-for 1 2) +;Value: (+ dot-product expt * gcd atan2 = / apply make-polar - make-rectangular) + +(discover:named-opers-for 'a) +;Value: (one-like cos acos exp cosh imag-part conjugate zero-like sinh sin asin angle magnitude inexact? type arity real-part invert negate identity-like sqrt log type-predicate atan1) + +(discover:named-opers-for (compose sin cos)) +;Value: (one-like cos acos exp cosh imag-part zero-like abs sinh sin asin angle magnitude inexact? type arity real-part invert negate identity-like sqrt log square type-predicate atan1) 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 diff --git a/final_project/work/disovery-mech-play.scm b/final_project/work/disovery-mech-play.scm deleted file mode 100644 index c2d5013..0000000 --- a/final_project/work/disovery-mech-play.scm +++ /dev/null @@ -1,24 +0,0 @@ - -(load "discovery") -;Loading "discovery.scm"... done -;Value: discover:named-opers - -(discover:named-opers) -;Value: (+ one-like cos dot-product expt one? * gcd partial-derivative acos exp atan2 cosh imag-part one = conjugate zero? / zero-like abs sinh identity? sin asin derivative angle magnitude inexact? type apply identity make-polar arity real-part - invert negate identity-like trace determinant sqrt zero log square make-rectangular type-predicate atan1) - -(discover:named-opers-for 1) -;Value: (one-like cos one? acos exp cosh imag-part conjugate zero? zero-like abs sinh identity? sin asin angle magnitude inexact? type arity real-part invert negate identity-like trace determinant sqrt log square type-predicate atan1) - -(discover:named-opers-for (matrix-by-rows '(1 0 0) - '(0 1 0) - '(0 0 1))) -;Value: (one-like cos exp conjugate zero? zero-like identity? sin inexact? type arity invert negate identity-like trace determinant type-predicate) - -(discover:named-opers-for 1 2) -;Value: (+ dot-product expt * gcd atan2 = / apply make-polar - make-rectangular) - -(discover:named-opers-for 'a) -;Value: (one-like cos acos exp cosh imag-part conjugate zero-like sinh sin asin angle magnitude inexact? type arity real-part invert negate identity-like sqrt log type-predicate atan1) - -(discover:named-opers-for (compose sin cos)) -;Value: (one-like cos acos exp cosh imag-part zero-like abs sinh sin asin angle magnitude inexact? type arity real-part invert negate identity-like sqrt log square type-predicate atan1) -- cgit v1.2.3