scheme中文编程

scheme中文编程 （转）

    受javaeye上的《Ruby中文编程》启发，帖子中有人提到如果 if 这样的关键字都可以定义成中文，那就是真正的中文编程。那时我就想到，这个其实要在scheme中实现是多么简单，将sicp书中的解释器稍微修改下就可以了，只要修改解析的部分即可。解释器的完整代码放后面，我们先看看有趣的例子：

1 (定义 你  ' 男)
2 (当 ((是 你  ' 男) (打印  ' 男人是泥土做的))
3     ((是 你  ' 女) (打印  ' 女人是水做的))
4     (否则
5          (打印  ' 妖怪啊)))
6

    其实呢，“定义”等价于define，“当”等价于cond，“打印”等价于display，说穿了不值一提，只是有趣罢了。不过设想在某些效率不是攸关的场景嵌入这么一个scheme解释器来定义DSL给业务人员使用，似乎也是不错的主意。当然这里还是scheme的前缀表达式，再修改下就可以像自然语言那样流畅，只不过括号还是少不了呀。

    再看几个例子：

 1 (使得 ((a  3 )
 2        (b  2 ))
 3        ( +  a b))
 4
 5 (定义 成绩  90 )
 6 (如果 ( >  成绩  80 )
 7       (打印  ' 良好)
 8       (打印  ' 要打PP了))
 9 ((函数(x) ( *  x x))  3 )   =>   9
10
11 (定义 (平方 x) ( *  x x))
12 (平方  3 )                => 9
13

    “使得”就是let，如果就是if，函数就是lambda。这不是中文编程吗？也许可以考虑申请国家专项资金来扶持:D

    完整的解释器代码，在drscheme选择R5RS标准下测试通过(代码折叠，请展开)：

解释器源码
  1(define apply-in-underlying-scheme apply)
  2(define (eval exp env)
  3  ((analyze exp) env))
  4(define (analyze exp)
  5  (cond ((self-evaluating? exp)
  6         (analyze-self-evaluating exp))
  7        ((quoted? exp)
  8         (analyze-quoted exp))
  9        ((variable? exp)
 10         (analyze-variable exp))
 11        ((assignment? exp)
 12         (analyze-assignment exp))
 13        ((definition? exp)
 14         (analyze-definition exp))
 15        ((if? exp)
 16         (analyze-if exp))
 17        ((lambda? exp)
 18         (analyze-lambda exp))
 19        ((begin? exp)
 20         (analyze-sequence (begin-actions exp)))
 21        ((cond? exp)
 22         (analyze (cond->if exp)))
 23        ((let? exp) (analyze (let->combination exp)))
 24        ((application? exp)(analyze-application exp))
 25        (else
 26           (error "Unknown expression type--ANALYZE" exp))))
 27
 28(define (apply procedure arguments)
 29  (cond ((primitive-procedure? procedure)
 30         (apply-primitive-procedure procedure arguments))
 31        ((compound-procedure? procedure)
 32         (eval-sequence 
 33          (procedure-body procedure)
 34          (extend-environment (procedure-parameters procedure)
 35                              arguments
 36                              (procedure-environment procedure))))
 37        (else
 38           (error "Unknown procedure type --APPLY" procedure))))
 39
 40(define (self-evaluating? exp)
 41  (cond ((number? exp) #t)
 42        ((string? exp) #t)
 43        (else
 44           #f)))
 45(define (variable? exp) (symbol? exp))
 46(define (quoted? exp)
 47  (tagged-list? exp 'quote))
 48(define (text-of-quotation exp)
 49  (cadr exp))
 50(define (tagged-list? exp tag)
 51  (if (pair? exp)
 52      (eq? (car exp) tag)
 53      #f))
 54(define (assignment? exp)
 55  (tagged-list? exp '设置))
 56(define (assignment-variable exp)
 57  (cadr exp))
 58(define (assignment-value exp)
 59  (caddr exp))
 60(define (definition? exp)
 61  (tagged-list? exp '定义))
 62(define (definition-variable exp)
 63  (if (symbol? (cadr exp))
 64      (cadr exp)
 65      (caadr exp)))
 66(define (definition-value exp)
 67  (if (symbol? (cadr exp))
 68      (caddr exp)
 69      (make-lambda (cdadr exp)
 70                   (cddr exp))))
 71(define (lambda? exp)
 72  (tagged-list? exp '函数))
 73(define (lambda-parameters exp)
 74  (cadr exp))
 75(define (lambda-body exp)
 76  (cddr exp))
 77(define (make-lambda parameters body)
 78  (cons '函数 (cons parameters body)))
 79(define (if? exp)
 80  (tagged-list? exp '如果))
 81(define (if-predicate exp) (cadr exp))
 82(define (if-consequent exp) (caddr exp))
 83(define (if-alternative exp)
 84  (if (not (null? (cdddr exp)))
 85      (cadddr exp)
 86      'false))
 87(define (make-if predicate consequent alternative)
 88  (list '如果 predicate consequent alternative))
 89(define (begin? exp)
 90  (tagged-list? exp '开始))
 91(define (begin-actions exp) (cdr exp))
 92(define (last-exp? exps) (null? (cdr exps)))
 93(define (first-exp exps) (car exps))
 94(define (rest-exps exps) (cdr exps))
 95(define (make-begin seq) (cons '开始 seq))
 96(define (sequence->exp seq)
 97  (cond ((null? seq) seq)
 98        ((last-exp? seq) (first-exp seq))
 99        (else
100           (make-begin seq))))
101(define (application? exp)
102  (pair? exp))
103(define (operator exp)
104  (car exp))
105(define (operands exp)
106  (cdr exp))
107(define (no-operands? ops) (null? ops))
108(define (first-operand ops) (car ops))
109(define (rest-operands ops) (cdr ops))
110(define (let? exp)
111  (tagged-list? exp '使得))
112(define (make-define var parameters body)
113  (list '定义 (cons var parameters) body))
114(define (let->combination exp)
115  (if (symbol? (cadr exp))
116      (let ((var (cadr exp))
117            (vars (map car (caddr exp)))
118            (vals (map cadr (caddr exp)))
119            (pairs (caddr exp))
120            (body (cadddr exp)))
121        (cons (make-lambda vars (list (make-define var vars body) body)) vals))
122      (let ((vars (map car (cadr exp)))
123            (vals (map cadr (cadr exp)))
124            (body (caddr exp)))
125              (cons (make-lambda vars (list body)) vals))))
126(define (cond? exp)
127  (tagged-list? exp '当))
128(define (cond-clauses exp) (cdr exp))
129(define (cond-else-clauses? clause)
130  (eq? (cond-predicate clause) '否则))
131(define (cond-extended-clauses? clause)
132  (and (> (length clause) 2) (eq? (cadr clause) '=>)))
133(define (extended-cond-test clause)
134  (car clause))
135(define (extended-cond-recipient clause)
136  (caddr clause)) 
137(define (cond-predicate clause) (car clause))
138(define (cond-actions clause) (cdr clause))
139(define (cond->if exp)
140  (expand-clauses (cond-clauses exp)))
141(define (expand-clauses clauses)
142  (if (null? clauses)
143      'false
144      (let ((first (car clauses))
145            (rest (cdr clauses)))
146        (cond ((cond-else-clauses? first)
147                (if (null? rest)
148                    (sequence->exp (cond-actions first))
149                    (error "else clause is not LAST" clauses)))
150              ((cond-extended-clauses? first)
151               (make-if
152                   (extended-cond-test first)
153                    (list
154                      (extended-cond-recipient first)
155                      (extended-cond-test first))
156                      (expand-clauses rest)))
157              (else
158               (make-if (cond-predicate first)
159                        (sequence->exp (cond-actions first))
160                        (expand-clauses rest)))))))
161
162(define (true? exp)
163  (or (eq? exp 'true) exp))
164(define (false? exp)
165  (or (eq? exp 'false) exp))
166(define (make-procedure parameters body env)
167  (list 'procedure parameters body env))
168(define (compound-procedure? p)
169  (tagged-list? p 'procedure))
170(define (procedure-parameters p)
171  (cadr p))
172(define (procedure-body p)
173  (caddr p))
174(define (procedure-environment p)
175  (cadddr p))
176(define (enclosing-environment env) (cdr env))
177(define (first-frame env) (car env))
178(define the-empty-environment '())
179(define (make-frame variables values)
180  (cons variables values))
181(define (frame-variables f)
182  (car f))
183(define (frame-values f)
184  (cdr f))
185(define (add-binding-to-frame! var val frame)
186  (set-car! frame (cons var (car frame)))
187  (set-cdr! frame (cons val (cdr frame))))
188(define (extend-environment vars vals base-env)
189  (if (= (length vars) (length vals))
190      (cons (make-frame vars vals) base-env)
191      (if (< (length vars) (length vals))
192          (error "Too many arguments supplied" vars vals)
193          (error "Too few arguments supplied" vars vals))))
194(define (lookup-variable-value var env)
195  (define (env-loop env)
196    (define (scan vars vals)
197      (cond ((null? vars)
198             (env-loop (enclosing-environment env)))
199            ((eq? var (car vars))
200             (car vals))
201            (else
202              (scan (cdr vars) (cdr vals)))))
203    (if (eq? env the-empty-environment)
204        (error "Unbound variable" var)
205        (let ((frame (first-frame env)))
206          (scan (frame-variables frame)
207                (frame-values frame)))))
208  (env-loop env))
209(define (set-variable-value! var val env)
210  (define (env-loop env)
211    (define (scan vars vals)
212      (cond ((null? vars)
213             (env-loop (enclosing-environment env)))
214            ((eq? var (car vars))
215             (set-car! vals val))
216            (else
217              (scan (cdr vars) (cdr vals)))))
218    (if (eq? env the-empty-environment)
219        (error "Unbound variable --SET!" var)
220        (let ((frame (first-frame env)))
221          (scan (frame-variables frame)
222                (frame-values frame)))))
223  (env-loop env))
224(define (define-variable! var val env)
225  (let ((frame (first-frame env)))
226    (define (scan vars vals)
227      (cond ((null? vars)
228             (add-binding-to-frame! var val frame))
229            ((eq? (car vars) var)
230             (set-car! vals val))
231            (else
232               (scan (cdr vars) (cdr vals)))))
233    (scan (frame-variables frame)
234          (frame-values frame))))
235(define (primitive-procedure? p)
236  (tagged-list? p 'primitive))
237(define (primitive-implementation proc) (cadr proc))
238(define primitive-procedures
239  (list (list 'car car) 
240        (list 'cdr cdr)
241        (list 'cons cons)
242        (list 'null? null?)
243        (list '+ +)
244        (list '- -)
245        (list '* *)
246        (list '/ /)
247        (list '< <)
248        (list '> >)
249        (list '是 equal?)
250        (list '= =)
251        (list 'assoc assoc)
252        (list 'cadr cadr)
253        (list 'cadr caddr)
254        (list '打印 display)
255        (list '换行 newline)
256        (list '映射 map)))
257(define (primitive-procedure-names)
258  (map car primitive-procedures)
259  )
260(define (primitive-procedure-objects)
261  (map (lambda(proc) (list 'primitive (cadr proc))) primitive-procedures))
262(define (setup-environment)
263  (let ((initial-env
264           (extend-environment (primitive-procedure-names)
265                               (primitive-procedure-objects)
266                               the-empty-environment)))
267    (define-variable! 'true #t initial-env)
268    (define-variable! 'false #f initial-env)
269    initial-env))
270(define the-global-environment (setup-environment))
271(define (apply-primitive-procedure proc args)
272  (apply-in-underlying-scheme (primitive-implementation proc) args))
273(define input-prompt ";;; M-Eval input:")
274(define out-prompt ";;; M-Eval value:")
275(define (prompt-for-input string)
276  (newline)
277  (newline)
278  (display string)
279  (newline))
280(define (announce-output string)
281  (newline)
282  (display string)
283  (newline))
284(define (user-print object)
285  (if (compound-procedure? object)
286      (display (list 'compound-procedure
287                     (procedure-parameters object)
288                     (procedure-body object)
289                     '<procedure-env>))
290      (display object)))
291(define (drive-loop)
292  (prompt-for-input input-prompt)
293  (let ((input (read)))
294    (let ((output (eval input the-global-environment)))
295      (announce-output out-prompt)
296      (user-print output)))
297  (drive-loop))
298
299;接下来是分析过程
300(define (analyze-self-evaluating exp)
301  (lambda(env) exp))
302(define (analyze-variable exp)
303  (lambda(env) (lookup-variable-value exp env)))
304(define (analyze-quoted exp)
305  (let ((qval (text-of-quotation exp)))
306    (lambda(env) qval)))
307(define (analyze-assignment exp)
308  (let ((var (assignment-variable exp))
309        (vproc (analyze (assignment-value exp))))
310    (lambda(env)
311        (set-variable-value! var (vproc env) env)
312        'ok)))
313(define (analyze-definition exp)
314  (let ((var (definition-variable exp))
315        (vproc (analyze (definition-value exp))))
316    (lambda(env)
317      (define-variable! var (vproc env) env)
318      'ok)))
319(define (analyze-if exp)
320  (let ((pproc (analyze (if-predicate exp)))
321        (cproc (analyze (if-consequent exp)))
322        (aproc (analyze (if-alternative exp))))
323    (lambda(env)
324      (if (true? (pproc env))
325          (cproc env)
326          (aproc env)))))
327(define (analyze-lambda exp)
328  (let ((vars (lambda-parameters exp))
329        (bproc (analyze-sequence (lambda-body exp))))
330    (lambda(env) (make-procedure vars bproc env))))
331(define (analyze-sequence exps)
332  (define (sequentially proc1 proc2)
333    (lambda(env) (proc1 env) (proc2 env)))
334  (define (loop first-proc rest-proc)
335    (if (null? rest-proc)
336        first-proc
337        (loop (sequentially first-proc (car rest-proc))
338              (cdr rest-proc))))
339  (let ((procs (map analyze exps))
340        )
341    (if (null? procs)
342        (error "Empty sequence --ANALYZE")
343        (loop (car procs) (cdr procs)))))
344(define (analyze-application exp)
345  (let ((fproc (analyze (operator exp)))
346        (aprocs (map analyze (operands exp))))
347    (lambda(env)
348      (execution-application (fproc env)
349                             (map (lambda (aproc) (aproc env)) aprocs)))))
350(define (execution-application proc args)
351  (cond ((primitive-procedure? proc)
352         (apply-primitive-procedure proc args))
353        ((compound-procedure? proc)
354         ((procedure-body proc)
355           (extend-environment (procedure-parameters proc)
356                              args
357                              (procedure-environment proc))))
358        (else
359         (error "Unknown procedure type --EXECUTE--APPLICATION" proc))))
360(drive-loop)
361