summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--final_project/work/discovery.scm148
-rw-r--r--final_project/work/disovery-mech-play.scm24
-rw-r--r--final_project/work/ghelper.scm106
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