aboutsummaryrefslogtreecommitdiffstats
path: root/minimal.scm
blob: 6e4c3c4198474015d1e0404b0d052f73223f3a30 (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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250

; cyclic dependency graph (sigh)
;
; meaning
;   expression-to-action
;     list-to-action
;       *application
;         meaning
;
;   actions

; ### preliminaries, utilities, shorthand

; check if something is an atom vs {null, collection}
(define atom?
  (lambda (x)
    (and (not (pair? x)) (not (null? x)))))

; need a list or tuple type; tuples prefered
(define first
  (lambda (p) (car p)))

(define second 
  (lambda (p) (car (cdr p))))

(define third
  (lambda (p) (car (cdr (cdr p)))))

(define build
  (lambda (a b) (cons a (cons b (quote ())))))

(define text-of second)

; test functions
(define add1 (lambda (x) (+ x 1)))
(define sub1 (lambda (x) (- x 1)))

; table operations
(define new-entry build)

(define lookup-in-entry
  (lambda (name entry entry-f)
    (lookup-in-entry-help name
			  (first entry)
			  (second entry)
			  entry-f)))

(define lookup-in-entry-help
  (lambda (name names values entry-f)
    (cond
     ((null? names) (entry-f name))
     ((eq? (car names) name) (car values))
     (else (lookup-in-entry-help name (cdr names) (cdr values) entry-f)))))

(define extend-table cons)

(define lookup-in-table
  (lambda (name table table-f)
    (cond
     ((null? table) (table-f name))
     (else (lookup-in-entry name 
			    (car table)
			    (lambda (n)
			      (lookup-in-table n (cdr table) table-f)))))))

(define initial-table
  (lambda (name)
    (car (quote ()))))

;(lookup-in-entry 'fish
;		 '((teach a man to fish)
;		   (1 2 3 4 5))
;		 (lambda (x) x))

;(lookup-in-table 'fish
;		 (extend-table '((teach a man to fish)
;				 (1 2 3 4 5))
;			       (quote ()))
;		 (lambda (x) x))

; ### specific types/helpers
(define builtin?
  (lambda (l)
    (eq? (first l) (quote builtin))))

(define non-builtin?
  (lambda (l)
    (eq? (first l) (quote non-builtin))))

(define else?
  (lambda (x)
    (cond
     ((atom? x) (eq? x (quote else)))
     (else #f))))

(define table-of first)
(define formals-of second)
(define body-of third)
(define question-of first)
(define answer-of second)
(define cond-lines-of cdr)
(define function-of car)
(define arguments-of cdr)

; need generic true/false booleans, a number type, and a symbol type
; also need a mutable "table" collection
(define *const
  (lambda (e table) 
    (cond          
     ((number? e) e) 
     ((eq? e #t) #t)
     ((eq? e #f) #f)
     (else (build (quote builtin) e)))))
;(*const 'asdf '()) ; (builtin asdf)

(define *lambda
  (lambda (e table)
    (build (quote non-builtin) (cons table (cdr e)))))
;(*lambda '(lambda (a b) (cond ((eq? a b) b) (else a))) '( ((1 2 3) (a b c))))
;  (non-builtin ((((1 2 3) (a b c))) (a b) (cond ((eq? a b) b) (else a))))

(define *quote
  (lambda (e table)
    (text-of e)))
;(*quote '(quote stuff) '()) ; stuff

(define *identifier
  (lambda (e table)
    (lookup-in-table e table initial-table)))
;(*identifier 'asdf '()) ; error
;(*identifier 'a '( ((1 2 3 a b c) (first second third 1 2 3)))) ; 1

(define *cond
  (lambda (e table)
    (evcon (cond-lines-of e) table)))

(define :atom?
  (lambda (x)
    (cond
     ((atom? x) #t)
     ((null? x) #f)
     ((eq? (car x) (quote builtin)) #t)
     ((eq? (car x) (quote non-builtin)) #t)
     (else #f))))

; ### now we start the meat!

(define atom-to-action
  (lambda (e)
    (cond
     ((number? e) *const)
     ((eq? e #t) *const)
     ((eq? e #f) *const)
     ((eq? e (quote cons)) *const)
     ((eq? e (quote car)) *const)
     ((eq? e (quote cdr)) *const)
     ((eq? e (quote null?)) *const)
     ((eq? e (quote eq?)) *const)
     ((eq? e (quote atom?)) *const)
     ((eq? e (quote zero?)) *const)
     ((eq? e (quote add1)) *const)
     ((eq? e (quote sub1)) *const)
     ((eq? e (quote number?)) *const)
     (else *identifier))))
;(atom-to-action 'number?); *const

(define list-to-action
  (lambda (e)
    (cond
     ((atom? (car e)) (cond
		       ((eq? (car e) (quote quote)) *quote)
		       ((eq? (car e) (quote lambda)) *lambda)
		       ((eq? (car e) (quote cond)) *cond)
		       (else *application)))
     (else *application))))
;(list-to-action '(lambda (x) x)) ; *lambda
;(list-to-action '(cond ((eq? 1 2) #f) (else #t))) ; *cond

(define expression-to-action
  (lambda (e)
    (cond
     ((atom? e) (atom-to-action e))
     (else (list-to-action e)))))
;(expression-to-action '#f) ; *const
;(expression-to-action '(lambda (x) x)) ; *lambda

(define evcon
  (lambda (lines table)
    (cond
     ((else? (question-of (car lines)))
      (meaning (answer-of (car lines)) table))
     ((meaning (question-of (car lines)) table)
      (meaning (answer-of (car lines)) table))
     (else (evcon (cdr lines) table)))))

(define evlis
  (lambda (args table)
    (cond
     ((null? args) (quote ()))
     (else (cons (meaning (car args) table)
		 (evlis (cdr args) table))))))
;(evlis '(cons #f 4) '()) ; ((builtin cons) #f 4)

(define *application
  (lambda (e table)
    (apply2
     (meaning (function-of e) table)
     (evlis (arguments-of e) table))))

; basic, low-level, non-compound functions
(define apply-builtin
  (lambda (name vals)
    (cond
     ((eq? name (quote cons)) (cons (first vals) (second vals)))
     ((eq? name (quote car)) (car (first vals)))
     ((eq? name (quote cdr)) (cdr (first vals)))
     ((eq? name (quote null?)) (null? (first vals)))
     ((eq? name (quote eq?)) (eq? (first vals) (second vals)))
     ((eq? name (quote atom?)) (:atom? (first vals)))
     ((eq? name (quote zero?)) (zero? (first vals)))
     ((eq? name (quote add1)) (add1 (first vals)))
     ((eq? name (quote sub1)) (sub1 (first vals)))
     ((eq? name (quote number?)) (number? (first vals))))))

; for compound functions
(define apply-closure
  (lambda (closure vals)
    (meaning (body-of closure)
	     (extend-table (new-entry (formals-of closure) vals)
			   (table-of closure)))))

; this is "how apply would be implemented"; it isn't used in this file
(define apply2
  (lambda (fun vals)
    (cond
     ((builtin? fun) (apply-builtin (second fun) vals))
     ((non-builtin? fun) (apply-closure (second fun) vals)))))

; find the value of an s-expression in the context of an environment
(define meaning
  (lambda (e table)
    ((expression-to-action e) e table)))
;(meaning '(lambda (x) (cons x y)) '(((y z) ((8) 9))))
; (non-primative ((((y z) ((8) 9)))) (x) (cons x y))

; and finally, helper to find values in a starting environment
(define value
  (lambda (e)
    (meaning e (quote ()))))
;(value '((lambda (a b) (a (add1 b))) (lambda (c) (add1 c)) 4)) ; 6