summaryrefslogtreecommitdiffstats
path: root/final_project/work/discovery.scm
blob: 3fa138fd440e0eeb48ff26737aa9cdea181f9cc3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
; 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)