scheme中文编程

   受javaeye上的《Ruby中文编程》启发,帖子中有人提到如果if这样的关键字都可以定义成中文,那就是真正的中文编程。那时我就想到,这个其实要在scheme中实现是多么简单,将sicp书中的解释器稍微修改下就可以了,只要修改解析的部分即可。解释器的完整代码放后面,我们先看看有趣的例子:
(定义 你 '男)
(当 ((是 你 '男) (打印 '男人是泥土做的))
    ((是 你 
'女) (打印 '女人是水做的))
    (否则
         (打印 
'妖怪啊)))

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

    再看几个例子:
(使得 ((a 3)
       (b 
2))
       (
+ a b))

(定义 成绩 
90)
(如果 (
> 成绩 80)
      (打印 
'良好)
      (打印 '要打PP了))
((函数(x) (* x x)) 3)  => 9

(定义 (平方 x) (* x x))
(平方 3)               =>9
   
    “使得”就是let,如果就是if,函数就是lambda。这不是中文编程吗?也许可以考虑申请国家专项资金来扶持:D

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

scheme中文编程scheme中文编程解释器源码
(define apply-in-underlying-scheme apply)
(define (eval exp env)
  ((analyze exp) env))
(define (analyze exp)
  (cond ((self
-evaluating? exp)
         (analyze
-self-evaluating exp))
        ((quoted? exp)
         (analyze
-quoted exp))
        ((variable? exp)
         (analyze
-variable exp))
        ((assignment? exp)
         (analyze
-assignment exp))
        ((definition? exp)
         (analyze
-definition exp))
        ((
if? exp)
         (analyze
-if exp))
        ((
lambda? exp)
         (analyze
-lambda exp))
        ((begin? exp)
         (analyze
-sequence (begin-actions exp)))
        ((cond? exp)
         (analyze (cond
->if exp)))
        ((let? exp) (analyze (let
->combination exp)))
        ((application? exp)(analyze
-application exp))
        (
else
           (error 
"Unknown expression type--ANALYZE" exp))))

(define (apply procedure arguments)
  (cond ((primitive
-procedure? procedure)
         (apply
-primitive-procedure procedure arguments))
        ((compound
-procedure? procedure)
         (eval
-sequence 
          (procedure
-body procedure)
          (extend
-environment (procedure-parameters procedure)
                              arguments
                              (procedure
-environment procedure))))
        (
else
           (error 
"Unknown procedure type --APPLY" procedure))))

(define (self
-evaluating? exp)
  (cond ((number? exp) 
#t)
        ((string? exp) #t)
        (else
           
#f)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
  (tagged
-list? exp 'quote))
(define (text-of-quotation exp)
  (cadr exp))
(define (tagged
-list? exp tag)
  (
if (pair? exp)
      (eq? (car exp) tag)
      
#f))
(define (assignment? exp)
  (tagged
-list? exp '设置))
(define (assignment-variable exp)
  (cadr exp))
(define (assignment
-value exp)
  (caddr exp))
(define (definition? exp)
  (tagged
-list? exp '定义))
(define (definition-variable exp)
  (
if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (definition
-value exp)
  (
if (symbol? (cadr exp))
      (caddr exp)
      (make
-lambda (cdadr exp)
                   (cddr exp))))
(define (
lambda? exp)
  (tagged
-list? exp '函数))
(define (lambda-parameters exp)
  (cadr exp))
(define (
lambda-body exp)
  (cddr exp))
(define (make
-lambda parameters body)
  (cons 
'函数 (cons parameters body)))
(define (if? exp)
  (tagged
-list? exp '如果))
(define (if-predicate exp) (cadr exp))
(define (
if-consequent exp) (caddr exp))
(define (
if-alternative exp)
  (
if (not (null? (cdddr exp)))
      (cadddr exp)
      
'false))
(define (make-if predicate consequent alternative)
  (list 
'如果 predicate consequent alternative))
(define (begin? exp)
  (tagged
-list? exp '开始))
(define (begin-actions exp) (cdr exp))
(define (last
-exp? exps) (null? (cdr exps)))
(define (first
-exp exps) (car exps))
(define (rest
-exps exps) (cdr exps))
(define (make
-begin seq) (cons '开始 seq))
(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last
-exp? seq) (first-exp seq))
        (
else
           (make
-begin seq))))
(define (application? exp)
  (pair? exp))
(define (operator exp)
  (car exp))
(define (operands exp)
  (cdr exp))
(define (no
-operands? ops) (null? ops))
(define (first
-operand ops) (car ops))
(define (rest
-operands ops) (cdr ops))
(define (let? exp)
  (tagged
-list? exp '使得))
(define (make-define var parameters body)
  (list 
'定义 (cons var parameters) body))
(define (let->combination exp)
  (
if (symbol? (cadr exp))
      (let ((var (cadr exp))
            (vars (map car (caddr exp)))
            (vals (map cadr (caddr exp)))
            (pairs (caddr exp))
            (body (cadddr exp)))
        (cons (make
-lambda vars (list (make-define var vars body) body)) vals))
      (let ((vars (map car (cadr exp)))
            (vals (map cadr (cadr exp)))
            (body (caddr exp)))
              (cons (make
-lambda vars (list body)) vals))))
(define (cond? exp)
  (tagged
-list? exp '当))
(define (cond-clauses exp) (cdr exp))
(define (cond
-else-clauses? clause)
  (eq? (cond
-predicate clause) '否则))
(define (cond-extended-clauses? clause)
  (
and (> (length clause) 2) (eq? (cadr clause) '=>)))
(define (extended-cond-test clause)
  (car clause))
(define (extended
-cond-recipient clause)
  (caddr clause)) 
(define (cond
-predicate clause) (car clause))
(define (cond
-actions clause) (cdr clause))
(define (cond
->if exp)
  (expand
-clauses (cond-clauses exp)))
(define (expand
-clauses clauses)
  (
if (null? clauses)
      
'false
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (cond ((cond
-else-clauses? first)
                (
if (null? rest)
                    (sequence
->exp (cond-actions first))
                    (error 
"else clause is not LAST" clauses)))
              ((cond
-extended-clauses? first)
               (make
-if
                   (extended
-cond-test first)
                    (list
                      (extended
-cond-recipient first)
                      (extended
-cond-test first))
                      (expand
-clauses rest)))
              (
else
               (make
-if (cond-predicate first)
                        (sequence
->exp (cond-actions first))
                        (expand
-clauses rest)))))))

(define (true? exp)
  (
or (eq? exp 'true) exp))
(define (false? exp)
  (
or (eq? exp 'false) exp))
(define (make-procedure parameters body env)
  (list 
'procedure parameters body env))
(define (compound-procedure? p)
  (tagged
-list? p 'procedure))
(define (procedure-parameters p)
  (cadr p))
(define (procedure
-body p)
  (caddr p))
(define (procedure
-environment p)
  (cadddr p))
(define (enclosing
-environment env) (cdr env))
(define (first
-frame env) (car env))
(define the
-empty-environment '())
(define (make-frame variables values)
  (cons variables values))
(define (frame
-variables f)
  (car f))
(define (frame
-values f)
  (cdr f))
(define (add
-binding-to-frame! var val frame)
  (set
-car! frame (cons var (car frame)))
  (set
-cdr! frame (cons val (cdr frame))))
(define (extend
-environment vars vals base-env)
  (
if (= (length vars) (length vals))
      (cons (make
-frame vars vals) base-env)
      (
if (< (length vars) (length vals))
          (error 
"Too many arguments supplied" vars vals)
          (error 
"Too few arguments supplied" vars vals))))
(define (lookup
-variable-value var env)
  (define (env
-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env
-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (
else
              (scan (cdr vars) (cdr vals)))))
    (
if (eq? env the-empty-environment)
        (error 
"Unbound variable" var)
        (let ((frame (first
-frame env)))
          (scan (frame
-variables frame)
                (frame
-values frame)))))
  (env
-loop env))
(define (set
-variable-value! var val env)
  (define (env
-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env
-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set
-car! vals val))
            (
else
              (scan (cdr vars) (cdr vals)))))
    (
if (eq? env the-empty-environment)
        (error 
"Unbound variable --SET!" var)
        (let ((frame (first
-frame env)))
          (scan (frame
-variables frame)
                (frame
-values frame)))))
  (env
-loop env))
(define (define
-variable! var val env)
  (let ((frame (first
-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add
-binding-to-frame! var val frame))
            ((eq? (car vars) var)
             (set
-car! vals val))
            (
else
               (scan (cdr vars) (cdr vals)))))
    (scan (frame
-variables frame)
          (frame
-values frame))))
(define (primitive
-procedure? p)
  (tagged
-list? p 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive
-procedures
  (list (list 
'car car) 
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list '< <)
        (list '> >)
        (list '是 equal?)
        (list '= =)
        (list 'assoc assoc)
        (list 'cadr cadr)
        (list 'cadr caddr)
        (list '打印 display)
        (list '换行 newline)
        (list '映射 map)))
(define (primitive-procedure-names)
  (map car primitive
-procedures)
  )
(define (primitive
-procedure-objects)
  (map (
lambda(proc) (list 'primitive (cadr proc))) primitive-procedures))
(define (setup-environment)
  (let ((initial
-env
           (extend
-environment (primitive-procedure-names)
                               (primitive
-procedure-objects)
                               the
-empty-environment)))
    (define
-variable! 'true #t initial-env)
    (define-variable! 'false #f initial-env)
    initial-env))
(define the
-global-environment (setup-environment))
(define (apply
-primitive-procedure proc args)
  (apply
-in-underlying-scheme (primitive-implementation proc) args))
(define input
-prompt ";;; M-Eval input:")
(define out
-prompt ";;; M-Eval value:")
(define (prompt
-for-input string)
  (newline)
  (newline)
  (display string)
  (newline))
(define (announce
-output string)
  (newline)
  (display string)
  (newline))
(define (user
-print object)
  (
if (compound-procedure? object)
      (display (list 
'compound-procedure
                     (procedure-parameters object)
                     (procedure
-body object)
                     
'<procedure-env>))
      (display object)))
(define (drive
-loop)
  (prompt
-for-input input-prompt)
  (let ((input (read)))
    (let ((output (eval input the
-global-environment)))
      (announce
-output out-prompt)
      (user
-print output)))
  (drive
-loop))
;接下来是分析过程
(define (analyze
-self-evaluating exp)
  (
lambda(env) exp))
(define (analyze
-variable exp)
  (
lambda(env) (lookup-variable-value exp env)))
(define (analyze
-quoted exp)
  (let ((qval (text
-of-quotation exp)))
    (
lambda(env) qval)))
(define (analyze
-assignment exp)
  (let ((var (assignment
-variable exp))
        (vproc (analyze (assignment
-value exp))))
    (
lambda(env)
        (set
-variable-value! var (vproc env) env)
        
'ok)))
(define (analyze-definition exp)
  (let ((var (definition
-variable exp))
        (vproc (analyze (definition
-value exp))))
    (
lambda(env)
      (define
-variable! var (vproc env) env)
      
'ok)))
(define (analyze-if exp)
  (let ((pproc (analyze (
if-predicate exp)))
        (cproc (analyze (
if-consequent exp)))
        (aproc (analyze (
if-alternative exp))))
    (
lambda(env)
      (
if (true? (pproc env))
          (cproc env)
          (aproc env)))))
(define (analyze
-lambda exp)
  (let ((vars (
lambda-parameters exp))
        (bproc (analyze
-sequence (lambda-body exp))))
    (
lambda(env) (make-procedure vars bproc env))))
(define (analyze
-sequence exps)
  (define (sequentially proc1 proc2)
    (
lambda(env) (proc1 env) (proc2 env)))
  (define (loop first
-proc rest-proc)
    (
if (null? rest-proc)
        first
-proc
        (loop (sequentially first
-proc (car rest-proc))
              (cdr rest
-proc))))
  (let ((procs (map analyze exps))
        )
    (
if (null? procs)
        (error 
"Empty sequence --ANALYZE")
        (loop (car procs) (cdr procs)))))
(define (analyze
-application exp)
  (let ((fproc (analyze (operator exp)))
        (aprocs (map analyze (operands exp))))
    (
lambda(env)
      (execution
-application (fproc env)
                             (map (
lambda (aproc) (aproc env)) aprocs)))))
(define (execution
-application proc args)
  (cond ((primitive
-procedure? proc)
         (apply
-primitive-procedure proc args))
        ((compound
-procedure? proc)
         ((procedure
-body proc)
           (extend
-environment (procedure-parameters proc)
                              args
                              (procedure
-environment proc))))
        (
else
         (error 
"Unknown procedure type --EXECUTE--APPLICATION" proc))))
(drive
-loop)
        文章转自庄周梦蝶  ,原文发布时间 2009-03-20 

                 
上一篇:推进SDN与NFV 英特尔领航网络转型


下一篇:SQL Server里的闩锁介绍