path: root/final_project/work/discovery.scm

; 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 ------------------- |#

; this is just what operators do
(define (discover:apply-name name . args)
  (let ((record (hash-table/get *generic-operator-table* name #f)))
    (let ((succeed
	   (lambda (handler)
	     (apply handler args))))
      (let per-arg
	  ((tree (operator-record-tree record))
	   (args args)
	   (fail
	    (lambda ()
	      (error:no-applicable-methods operator args))))
	(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))))))))

(define (discover:thunklist-for . args)
  (let ((names (apply discover:named-opers-for args)))
    (cons args
	  (map (lambda (x)
		 (list x
		       (lambda ()
			 (apply discover:apply-name (cons x args)))))
	       names))))

(define (discover:apply-all . args)
  (let ((names (apply discover:named-opers-for args)))
    (map (lambda (x)
	   (apply discover:apply-name (cons x args)))
	 names)))

(define (discover:apply-all-name . args)
  (let ((names (apply discover:named-opers-for args)))
    (map (lambda (x)
	   (list (apply discover:apply-name (cons x args)) x))
	 names)))

(define (discover:satisfy pred? . args)
  (let try ((objs (list args)))
    (let ((goodies (filter (lambda (x) (apply pred? x)) objs)))
      (if (not (null? goodies))
	  (car goodies)
	  (try (fold-right append 
			  '()
			  (map (lambda (x)
				 (map list
				      (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)))
      (if (not (null? goodies))
	  goodies
	  (try (fold-right append 
			  '()
			  (map (lambda (x)
				 (map (lambda (y)
					(cons (list (car y)) (cons (cadr y) 
								   (cdr x))))
				      (apply discover:apply-all-name (car x))))
			       objs)))))))