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

; 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)
(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*)))))


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

(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)))))))


; see discovery-examples.scm for testing and examples