1 files changed, 148 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 ------------------- |#
+
+
+
+
+
+
+
+
+
+