Common Lisp で遅延評価（part 1/2）

『計算機プログラムの構造と解釈』（SICP）を読んでいる。いま Scheme インタプリタ再構築の章。近いうち、Common Lisp の上に実装して遊びたい。
今日の記事は、遅延評価を Common Lisp でやってみた、という話。delay & force も、マクロにかかればイチコロだ。

(defvar *unforced* (gensym))

(defclass delay () (forced closure))

(defmacro delay (expr)
  (let ((self (gensym)))
    `(let ((,self (make-instance 'delay)))
       (setf (slot-value ,self 'forced) *unforced*)
       (setf (slot-value ,self 'closure)
             #'(lambda ()
                 (setf (slot-value ,self 'forced) ,expr)))
       ,self)))

(defun unforced? (x)
  (and (typep x 'delay)
       (eq *unforced* (slot-value x 'forced))))

(defun force (x)
  (if (typep x 'delay)
      (if (eq (slot-value x 'forced) *unforced*)
          (funcall (slot-value x 'closure))
          (slot-value x 'forced))
      x))

Delay オブジェクトの実体は、キャッシュとクロージャの組。いったん force されるとクロージャの評価結果がキャッシュされて、以降はそれが force の値となる。
これを使って遅延評価による無限リストを作ってみよう。SICP の言葉で言うなら「ストリーム」だが、Common Lisp にはもう同名のクラスがあるので、ここではとりあえず遅延リスト（lazy list）と呼ぶ。関数のプレフィクスはだいたい lz としてある（lazy と毎回打つのは面倒だし……）。仮引数の名前で ll （エルエル）となっている部分は遅延リストを受け取ることが想定されている部分。ls は単なるリストを表している。

(declaim (inline lz-car lz-cdr))


(defun  lz-car (ll)  (car ll))

(defun lz-cdr (ll)  (force (cdr ll)))

(defmacro lz-cons (expr rest)
  `(cons ,expr (delay ,rest)))

(defmacro lz-list (&rest exprs)
  (reduce #'(lambda (new acc) `(lz-cons ,new ,acc))
          exprs
          :from-end t :initial-value nil))

(defun lz-nth (n ll)
  (check-type n (integer 0 *))
  (labels ((rec (n ll)
             (if (zerop n)
                 (lz-car ll)
                 (rec (1- n) (lz-cdr ll)))))
    (rec n ll)))

(defun lz-nthcdr (n ll)
  (check-type n (integer 0 *))
  (labels ((rec (n ll)
             (if (zerop n)
                 ll
                 (rec (1- n) (lz-cdr ll)))))
    (rec n ll)))


(defun take (n ll &optional default)
  (check-type n (integer 0 *))
  (labels ((rec (n ll acc)
             (if (= n 1)
                 (nreverse (cons (if ll (lz-car ll) default)
                                 acc))
                 (rec (1- n) (lz-cdr ll)
                      (cons (if ll (lz-car ll) default)
                            acc)))))
    (if (zerop n)
        nil
        (rec n ll nil))))

lz-cons が遅延リストを作るキモとなる。ただの cons と違ってマクロで、第２引数に delay を作用させてから cons するようになっている。こうやって作られたコンスセルに lz-cdr でアクセスすると、遅延されていた cdr 部が評価され、遅延リストの続きが動的に生成される。アクセサとして nth と nthcdr の遅延評価対応版、それに遅延リストの先頭 n 個を取り出すための関数 take を用意しておく。
なお、ここで用意した関数をアクセサとして使う限り、遅延リストを受け取る関数はすべて、普通のリストを受け取っても機能する。普通のリストというのはすなわち、すでに全要素が force されている有限長の遅延リストというわけだ。
以下の例では、関数 princ が最初に必要になったときだけ評価されていることが分かる。

使用例：

CL-USER> (setq ll (lz-list (princ 0) (princ 1) (princ 2) (princ 3)))
0
(0 . #<DELAY @ #x208f83d2>)
CL-USER> (lz-cdr ll)
1
(1 . #<DELAY @ #x20916162>)
CL-USER> (take 3 ll)
2
(0 1 2)
CL-USER> (take 6 ll)
3
(0 1 2 3 NIL NIL)

遅延リストを作るには lz-cons し、後続を得るには lz-cdr を使う……という仕組みがいったんできてしまうと、あとはこれを使って遅延リストに再帰的な処理を加えられる。ためしに無限数列を定義してみよう。

(defun lz-const (x)
  (lz-cons x (lz-const x)))

(defun lz-seq (a0 fn)
  (lz-cons a0 (lz-seq (funcall fn a0) fn)))

(defun lz-ari (a0 d)
  (lz-seq a0 #'(lambda (x) (+ x d))))

(defun lz-geo (a0 r)
  (lz-seq a0 #'(lambda (x) (* x r))))

(defun lz-seq/inv (a0 fn)
  (lz-cons (/ 1 a0)
           (lz-seq/inv (funcall fn a0) fn)))

(defun lz-ari/inv (a0 d)
  (lz-seq/inv a0 #'(lambda (x) (+ x d))))

(defun lz-geo/inv (a0 r)
  (lz-seq/inv a0 #'(lambda (x) (* x r))))

(defvar *identity-sequence* (lz-const 1))

(defvar *whole-number* (lz-ari 0 1))

(defvar *harmonic-sequence* (lz-ari/inv 1 1))

lz-seq は「次の値」を生成する関数と初期値を受け取って、無限数列を返す。これを特殊化したのが、等差数列（arithmetic sequence）を作る lz-ari と、等比数列（geometric sequence）を作る lz-geo。それぞれ /inv がついたものは、各項の逆数で数列を作る。まあこれらは後で見るように、lz-mapcar で代替が効くのだけれど。
３つほど有用な数列をあらかじめ用意してみた。順に定数列、０から始まる自然数、そして調和数列（1, 1/2, 1/3, 1/4, ...）。

CL-USER> (take 5 *identity-sequence*)
(1 1 1 1 1)
CL-USER> (take 5 *whole-number*)
(0 1 2 3 4)
CL-USER> (take 5 *harmonic-sequence*)
(1 1/2 1/3 1/4 1/5)

Lisp 系言語の入門書ではたいてい、car と cdr を再帰的に処理して cons するというタイプの関数がまず紹介される。まあ普段はそういうのも dolist とか loop とかで済ませてしまったりもするわけだが、遅延リストを扱うにあたってはその伝統的な手法が要となる。

(defun lz-app/force (ll-1 ll-2)
  (if (null ll-1)
      (force ll-2)
      (lz-cons (lz-car ll-1)
               (lz-app/force (lz-cdr ll-1) ll-2))))

(defmacro lz-append (&rest lls)
  (if (null lls)
      nil
      (reduce #'(lambda (new acc)
                  `(lz-app/force ,new (delay ,acc)))
              lls
              :from-end t)))

(defun lz-mapcar (fn ll &rest more-lls)
  (let ((lls (cons ll more-lls)))
    (if (some #'null lls)
        nil
        (lz-cons (apply fn (mapcar #'lz-car lls))
                 (apply #'lz-mapcar fn
                        (mapcar #'lz-cdr lls))))))

(defun lz-flatmap (fn ll &rest more-lls)
  (let ((lls (cons ll more-lls)))
    (if (some #'null lls)
        nil
        (lz-append (apply fn (mapcar #'lz-car lls))
                   (apply #'lz-flatmap fn
                          (mapcar #'lz-cdr lls))))))

(defun lz-flatten (lt)
  (cond ((null lt) nil)
        ((atom lt) (lz-cons lt nil))
        (t
         (lz-append (lz-flatten (lz-car lt))
                    (lz-flatten (lz-cdr lt))))))

(defun lz-filter (pred ll)
  (if (null ll)
      nil
      (if (funcall pred (lz-car ll))
          (lz-cons (lz-car ll)
                   (lz-filter pred (lz-cdr ll)))
          (lz-filter pred (lz-cdr ll)))))

lz-append は lz-cons のリスト版という感じのマクロだが、少し違う点もある。第１引数が nil だった場合、第２引数以降の連結を返すにあたって、lz-cdr のように force しなければいけない（そうでないと遅延リストではなく delay オブジェクトそのものを渡すことになる）。その部分を担当しているのが lz-app/force という補助関数だ。
lz-mapcar は名前そのまま。遅延リスト（複数可）に対して mapcar する。これを使えば、無限数列を項ごとに足したり掛けたり、もっとすごいこともできる。
lz-flatmap は mapcar の結果に append を apply するようなものだが、ここでは lz-append がマクロなので mapcar と別個に定義した。lz-flatten もよくある flatten の遅延評価版。ツリーを１段階のリストにする。
lz-filter は遅延リスト版の remove-if-not。
ここでは例として、lz-mapcar で調和数列を再定義してみる。

使用例：

CL-USER> (setq ll (lz-mapcar #'/
                             *identity-sequence* 
                             (lz-cdr *whole-number*)))
(1 . #<DELAY @ #x2097e792>)
CL-USER> (take 5 ll)
(1 1/2 1/3 1/4 1/5)