“JRM’s Syntax-rules Primer for the Merely Eccentric” メモ(その3)

SYNTAX-RULES Primer for the Merely Eccentric — https://sites.google.com/site/evalapply/eccentric.txt?attredirects=0

続きです、 sreverse 辺りから。メモっていきます。

(define-syntax sreverse
  (syntax-rules ()
    ((sreverse thing) (sreverse "top" thing ("done")))
    ((sreverse "top" () (tag . more))
     (sreverse tag () . more))
    ((sreverse "top" ((headcar . headcdr) . tail) kont)
     (sreverse "top" tail ("after-tail" (headcar . headcdr) kont)))
    ((sreverse "after-tail" new-tail head kont)
     (sreverse "top" head ("after-head" new-tail kont)))
    ((sreverse "after-head" () new-tail (tag . more))
     (sreverse tag new-tail . more))
    ((sreverse "after-head" new-head (new-tail ...) (tag . more))
     (sreverse tag (new-tail ... new-head) . more))
    ((sreverse "top" (head . tail) kont)
     (sreverse "top" tail ("after-tail2" head kont)))
    ((sreverse "after-tail2" () head (tag . more))
     (sreverse tag (head) . more))
    ((sreverse "after-tail2" (new-tail ...) head (tag . more))
     (sreverse tag (new-tail ... head) . more))
    ((sreverse "done" value)
     'value
    )))

空行を消しました。

まず、 car 部がペアの場合が以下で、そこは取り合えず置いておきます。

...
    ((sreverse "top" ((headcar . headcdr) . tail) kont)
     (sreverse "top" tail ("after-tail" (headcar . headcdr) kont)))
    ((sreverse "after-tail" new-tail head kont)
     (sreverse "top" head ("after-head" new-tail kont)))
    ((sreverse "after-head" () new-tail (tag . more))
     (sreverse tag new-tail . more))
    ((sreverse "after-head" new-head (new-tail ...) (tag . more))
     (sreverse tag (new-tail ... new-head) . more))
...

ペアでなかった場合が以下、 cdr 部を "after-tail2"という"継続"を作って辿って行きます。ここで、継続と呼んでいるものが"起動"された時に渡される形、パターンは、 (sreverse tag 新しい引数継続作成時の任意の値残りの継続) ということになります。

...
    ((sreverse "top" () (tag . more))
     (sreverse tag () . more))
...
    ((sreverse "top" (head . tail) kont)
     (sreverse "top" tail ("after-tail2" head kont)))
    ((sreverse "after-tail2" () head (tag . more)) ;; この部分は、一つ下で
     (sreverse tag (head) . more))                 ;; 表現できるので不用な
                                                   ;; 気もします
    ((sreverse "after-tail2" (new-tail ...) head (tag . more))
     (sreverse tag (new-tail ... head) . more))
...

;; マクロエクスパンドを一ステップずつ
(srverse (a b))
(sreverse "top" (a b) ("done"))
(sreverse "top" (b) ("after-tail2" a ("done")))
(sreverse "top" () ("after-tail2" b ("after-tail2" a ("done"))))
(sreverse "after-tail2" () b ("after-tail2" a ("done")))
(sreverse "after-tail2" (b) a ("done"))
(sreverse "done" (b a))
(quote (b a))

話を戻して car 部がペアの場合。

...
    ((sreverse "top" ((headcar . headcdr) . tail) kont)
     (sreverse "top" tail ("after-tail" (headcar . headcdr) kont)))
    ((sreverse "after-tail" new-tail head kont)
     (sreverse "top" head ("after-head" new-tail kont)))
    ((sreverse "after-head" () new-tail (tag . more)) ;; この部分は通らない
     (sreverse tag new-tail . more))                  ;; ので不用な気もします
    ((sreverse "after-head" new-head (new-tail ...) (tag . more))
     (sreverse tag (new-tail ... new-head) . more))
...

ここでは、コメントにある、通らないパターンじゃないかな、と思うのはなぜかを書きます。

もう一度継続が起動されるパターンを示しておきます。

(sreverse tag "新しい引数" "継続作成時の任意の値" "残りの継続")

さて、 (sreverse "after-head" () new-tail (tag . more)) として"after-head"が起動されるかどうかを考えます。"新しい引数"の部分に渡されるものは、 "after-head"作成時に辿っていた値を処理した後のものです。つまり (sreverse "after-tail" new-tail head kont) でパターンマッチした"head"の値の処理後のもの。もう一つ処理を振り返って、もともとは"after-tail"作成時の"継続作成時の任意の値"の部分のもので、

    ((sreverse "top" ((headcar . headcdr) . tail) kont)
     (sreverse "top" tail ("after-tail" (headcar . headcdr) kont)))

この (headcar . headcdr) つまり、 car 部がペアの場合のパターンとしていた値そのものです。これが () になることはないので、通らないパターンじゃないかな、と考えられます。

というわけで、自分なりに整理したのが以下。

(define-syntax srev
  (syntax-rules ()
    ((srev s) (srev "top" s ("done")))
    ((srev "top" () (tag . more))
     (srev tag () . more))
    ((srev "top" ((headcar . headcdr) . tail) kont)
     (srev "top" tail ("after-tail" (headcar . headcdr) kont)))
    ((srev "after-tail" new-tail head kont)
     (srev "top" head ("after-head" new-tail kont)))
    ((srev "after-head" new-head (new-tail ...) (tag . more))
     (srev tag (new-tail ... new-head) . more))
    ((srev "top" (head . tail) kont)
     (srev "top" tail ("after-tail2" head kont)))
    ((srev "after-tail2" (new-tail ...) head (tag . more))
     (srev tag (new-tail ... head) . more))
    ((srev "done" value)
     'value)))

Schemeの関数でやっていることを直接表現するとしたらこんな具合だろうか、というのが以下のようなものです。

(let ()
  (define (rev s k)
    (cond ((null? s) (k '()))
          ((pair? (car s))
           (rev (cdr s) (lambda (r)
                          (rev (car s) (lambda (l)
                                         (k (append r (list l))))))))
          (else
           (rev (cdr s) (lambda (l)
                          (k (append l (list (car s)))))))))

  (rev '(a (1 (11 (111) 22) 2 3) (A B C) b) values))
;;=> (b (C B A) (3 2 (22 (111) 11) 1) a)

話が逸れるけれどもツリーを反転する、というコードを何個か書き下ろします。

(use srfi-1 :only (list=))

(let ()
  (define (rev-recur s)
    (define (recur s)
      (cond ((null? s) '())
            ((pair? (car s))
             `(,@(recur (cdr s)) ,(recur (car s))))
            (else
             `(,@(recur (cdr s)) ,(car s)))))
    (recur s))
  (define (rev-accum s)
    (define (recur s a)
      (cond ((null? s) a)
            ((pair? (car s))
             (recur (cdr s)
                    (cons (recur (car s) '()) a)))
            (else
             (recur (cdr s) (cons (car s) a)))))
    (recur s '()))
  (define (rev-kont s)
    (define (recur s k)
      (cond ((null? s) (k '()))
            ((pair? (car s))
             (recur (cdr s)
                    (lambda (r)
                      (cons (recur (car s) values) (k r)))))
            (else
             (recur (cdr s) (lambda (r)
                              (cons (car s) (k r)))))))
    (recur s values))

  (let ((s '(1 (A B C (a b)) 2))
        (r '(2 ((b a) C B A) 1)))
    (list= equal?
           r
           (rev-recur s)
           (rev-accum s)
           (rev-kont  s))))
;;=> #t