The Little Schemer

最近、Scheme がちょっとした流行になっているようです。

Scheme を勉強しようと思っている人に、僕が声を大にして薦めたい本は、「The Little Schemer」です。

The Little Schemer (The MIT Press)

1章から7章にかけて、たくさんの例題とともに「再帰」が説明されています。「再帰の再帰」も勉強できます。実際、「この本を読んで人生が変わった」という感想を何回か聞いたことがあります。なぜなら、物事を再帰で考えられるようになるからです。再帰が分らない人は、ぜひ読んで下さい。

8章は、「クロージャ」や「継続」が出て来て、毛色が変わります。まぁ、なんとかついて行けるでしょう。

しかし、9章で「Yコンビネータ」が出てくると、もう大変です。実際、「Yコンビネータ」が何なのか知っていないと、内容の難しさに興味が保てず挫折してしまいます。

10章では、Scheme で Scheme のインタープリタを実装する話です。Lisp 1.5 Programmer's Manual を読んだことのない人には、「ふーん」で終わってしまうかもしれません。

という訳で、9章と10章について、ちょっとだけ解説しておきます。挫折した人が、再び興味を取り戻すのに役に立てば嬉しいです。

9章

Y コンビネータは、関数名を使わずに再帰を実現するための補助関数です。こんな感じです。

(lambda (le)
  ((lambda (f) (f f))
   (lambda (g) (le (lambda (x) ((g g) x))))))

たとえば、リストの長さを算出する関数を再帰で定義したいとします。しかし、関数名は使ってはいけません。どうしますか？ Y コンビネータに与えることを前提にすると、次のように書けます。

(lambda (length)
  (lambda (l)
    (cond
     ((null? l) 0)
     (else
      (add1 (length (cdr l)))))))

length は、関数名ではなく、引数名であることに注意して下さい。

これを Y コンビネータに与えると、ちゃんと再帰します。

(((lambda (le)
    ((lambda (f) (f f))
     (lambda (g) (le (lambda (x) ((g g) x))))))
  (lambda (length)
    (lambda (l)
      (cond
       ((null? l) 0)
       (else
	(add1 (length (cdr l))))))))
 '(boo foo woo))
→ 3

すごいですね！

10章

Lisp のインタープリタは、データを読み、評価し、結果を出力するという作業を繰り返します。それらを実現する関数は、read、eval、print です。この繰り返しを REPL (read-eval-print loop) と呼ぶことがあります。

10章は、read と print は Scheme に任せ、eval の部分を実装してみようという話です。作る関数名は、eval ではなく、value になっていますけど。

evlis や evcon という関数が出てきますが、これは Lisp 1.5 Programmer's Manual に出てくる由緒正しい関数です。:)

実装する value がどの程度の能力があるのかよく理解していませんでしたが、今日コードを入力して実験したところ、上記の Y コンビネータも動きました。

(value 
 '(((lambda (le)
      ((lambda (f) (f f))
       (lambda (g) (le (lambda (x) ((g g) x))))))
    (lambda (length)
      (lambda (l)
	(cond
	 ((null? l) 0)
	 (else
	  (add1 (length (cdr l))))))))
   '(boo foo woo)))

いやー、びっくりです。

コードを入力するのは僕だけで十分ですから、参考までそのコードを載せておきます。いろんなところに、print を挿入して、いろいろ実験してみて下さい。(apply は apply1、:atom? は *atom? に変更しています。)

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

(define atom?
  (lambda (x)
    (and (not (pair? x)) (not (null? x)))))

(define build
  (lambda (s1 s2) (cons s1 (cons s2 '()))))
(define new-entry build)

(define add1 (lambda (n) (+ n 1)))
(define sub1 (lambda (n) (- n 1)))

(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 (name)
	 (lookup-in-table
	  name
	  (cdr table)
	  table-f)))))))

(define expression-to-action
  (lambda (e)
    (cond
     ((atom? e) (atom-to-action e))
     (else
      (list-to-action e)))))

(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))))

(define list-to-action
  (lambda (e)
    (cond
     ((atom? (car e))
      (cond
       ((eq? (car e) 'quote)
	*quote)
       ((eq? (car e) 'lambda)
	*lambda)
       ((eq? (car e) 'cond)
	*cond)
       (else 
	*application)))
     (else
      *application))))

(define value
  (lambda (e)
    (meaning e '())))

(define meaning
  (lambda (e table)
    ((expression-to-action e) e table)))

(define *const
  (lambda (e table)
    (cond
     ((number? e) e)
     ((eq? e #t) #t)
     ((eq? e #f) #f)
     (else
      (build 'primitive e)))))

(define *quote
  (lambda (e table)
    (text-of e)))

(define text-of second)

(define *identifier
  (lambda (e table)
    (lookup-in-table e table initial-table)))

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

(define *lambda
  (lambda (e table)
    (build 'non-primitive
	   (cons table (cdr e)))))

(define table-of first)
(define formals-of second)
(define body-of third)

(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 else?
  (lambda (x)
    (cond
     ((atom? x) (eq? x 'else))
     (else #f))))
(define question-of first)
(define answer-of second)

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

(define cond-lines-of cdr)

(define evlis
  (lambda (args table)
    (cond
     ((null? args) '())
     (else
      (cons (meaning (car args) table)
	    (evlis (cdr args) table))))))

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

(define function-of car)
(define arguments-of cdr)

(define primitive?
  (lambda (l)
    (eq? (first l) 'primitive)))

(define non-primitive?
  (lambda (l)
    (eq? (first l) 'non-primitive)))

(define apply1
  (lambda (fun vals)
    (cond
     ((primitive? fun)
      (apply-primitive (second fun) vals))
     ((non-primitive? fun)
      (apply-closure (second fun) vals)))))

(define apply-primitive
  (lambda (name vals)
    (cond
     ((eq? name 'cons)
      (cons (first vals) (second vals)))
     ((eq? name 'car)
      (car (first vals)))
     ((eq? name 'cdr)
      (cdr (first vals)))
     ((eq? name 'null?)
      (null? (first vals)))
     ((eq? name 'eq?)
      (eq? (first vals) (second vals)))
     ((eq? name 'atom?)
      (*atom? (first vals)))
     ((eq? name 'zero?)
      (zero? (first vals)))
     ((eq? name 'add1)
      (add1 (first vals)))
     ((eq? name 'sub1)
      (sub1 (first vals)))
     ((eq? name 'number?)
      (number (first vals))))))

(define *atom?
  (lambda (x)
    (cond
     ((atom? x) #t)
     ((null? x) #f)
     ((eq? (car x) 'primitive) #t)
     ((eq? (car x) 'non-primitive) #t)
     (else #f))))

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