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

(define (discover:apply-all . args)
  (filter (compose not null?) 
	  (map (lambda (oper)
		 (if (symbol? oper)
		     '()
		     (list oper (apply oper args))))
	       (apply discover:opers-for args))))

(discover:apply-all 2)
  
(discover:named-opers-for 2)

(environment-lookup (the-environment) 'sin)

(one-like 4)