diff options
| -rw-r--r-- | final_project/work/discovery.scm | 148 | ||||
| -rw-r--r-- | final_project/work/disovery-mech-play.scm | 24 | ||||
| -rw-r--r-- | final_project/work/ghelper.scm | 106 |
3 files changed, 278 insertions, 0 deletions
diff --git a/final_project/work/discovery.scm b/final_project/work/discovery.scm new file mode 100644 index 0000000..8104733 --- /dev/null +++ b/final_project/work/discovery.scm @@ -0,0 +1,148 @@ +; discovery.scm +; author: bnewbold @ mit (with lch @ mit) +; for 6.945 +; circa 04/2009 + +; For speed? +;(declare (usual-integrations)) + +; If it isn't already.... +;(load "ghelper") + +; takes two lists: the first is a set of predicates and the second a set +; of arguments; if any of the predicates are #t for the args, win, else fail +(define (for-any? preds args) + (cond ((null? preds) #f) + ((null? (car preds)) #f) + ((apply (car preds) args) #t) + (else (for-any? (cdr preds) args)))) + +; 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) +(define (discover:opers-for . args) + (let* ((arity (length args)) + (opers (hash-table->alist *generic-operator-table*)) + (check + (lambda (op) + (if (not (eq? arity (cadr op))) + #f + (let per-arg ((tree (operator-record-tree (cdr op))) + (args args) + (fail (lambda () #f))) + (let per-pred ((tree tree) (fail fail)) + (cond ((pair? tree) + (if ((caar tree) (car args)) + (if (pair? (cdr args)) + (per-arg (cdar tree) + (cdr args) + (lambda () + (per-pred (cdr tree) fail))) + #t) + (per-pred (cdr tree) fail))) + ((null? tree) (fail)) + (else #t)))))))) + (map car (filter check opers)))) + +; same as the above but only grabs the symboled ones +(define (discover:named-opers-for . args) + (filter symbol? (apply discover:opers-for args))) + +; returns a list of +(define (discover:named-opers) + (let ((check (lambda (x) (cond ((null? x) '()) + ((symbol? x) x) + (else '()))))) + (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 ------------------- |# + + + + + + + + + + diff --git a/final_project/work/disovery-mech-play.scm b/final_project/work/disovery-mech-play.scm new file mode 100644 index 0000000..c2d5013 --- /dev/null +++ b/final_project/work/disovery-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/ghelper.scm b/final_project/work/ghelper.scm new file mode 100644 index 0000000..4e39cbe --- /dev/null +++ b/final_project/work/ghelper.scm @@ -0,0 +1,106 @@ +;;; From 6.945 Staff, with minor edit by bnewbold (May 2009) + +;;;; Most General Generic-Operator Dispatch + +(declare (usual-integrations)) + +;;; Generic-operator dispatch is implemented here by a discrimination +;;; list, where the arguments passed to the operator are examined by +;;; predicates that are supplied at the point of attachment of a +;;; handler (by ASSIGN-OPERATION). + +;;; To be the correct branch all arguments must be accepted by +;;; the branch predicates, so this makes it necessary to +;;; backtrack to find another branch where the first argument +;;; is accepted if the second argument is rejected. Here +;;; backtracking is implemented by OR. + +(define (make-generic-operator arity default-operation #!optional name) + (let ((record (make-operator-record arity))) + + (define (operator . arguments) + (if (not (= (length arguments) arity)) + (error:wrong-number-of-arguments operator arity arguments)) + (let ((succeed + (lambda (handler) + (apply handler arguments)))) + (let per-arg + ((tree (operator-record-tree record)) + (args arguments) + (fail + (lambda () + (error:no-applicable-methods operator arguments)))) + (let per-pred ((tree tree) (fail fail)) + (cond ((pair? tree) + (if ((caar tree) (car args)) + (if (pair? (cdr args)) + (per-arg (cdar tree) + (cdr args) + (lambda () + (per-pred (cdr tree) fail))) + (succeed (cdar tree))) + (per-pred (cdr tree) fail))) + ((null? tree) + (fail)) + (else + (succeed tree))))))) + + (hash-table/put! *generic-operator-table* operator record) + (if default-operation + (assign-operation operator default-operation)) + (if (not (default-object? name)) + (hash-table/put! *generic-operator-table* name record)) + operator)) + +(define *generic-operator-table* + (make-eq-hash-table)) + +(define (make-operator-record arity) (cons arity '())) +(define (operator-record-arity record) (car record)) +(define (operator-record-tree record) (cdr record)) +(define (set-operator-record-tree! record tree) (set-cdr! record tree)) + +(define (assign-operation operator handler . argument-predicates) + (let ((record + (let ((record (hash-table/get *generic-operator-table* operator #f)) + (arity (length argument-predicates))) + (if record + (begin + (if (not (<= arity (operator-record-arity record))) + (error "Incorrect operator arity:" operator)) + record) + (let ((record (make-operator-record arity))) + (hash-table/put! *generic-operator-table* operator record) + record))))) + (set-operator-record-tree! record + (bind-in-tree argument-predicates + handler + (operator-record-tree record)))) + operator) + +(define defhandler assign-operation) + +(define (bind-in-tree keys handler tree) + (let loop ((keys keys) (tree tree)) + (if (pair? keys) + (let find-key ((tree* tree)) + (if (pair? tree*) + (if (eq? (caar tree*) (car keys)) + (begin + (set-cdr! (car tree*) + (loop (cdr keys) (cdar tree*))) + tree) + (find-key (cdr tree*))) + (cons (cons (car keys) + (loop (cdr keys) '())) + tree))) + (if (pair? tree) + (let ((p (last-pair tree))) + (if (not (null? (cdr p))) + (warn "Replacing a handler:" (cdr p) handler)) + (set-cdr! p handler) + tree) + (begin + (if (not (null? tree)) + (warn "Replacing top-level handler:" tree handler)) + handler)))))
\ No newline at end of file |