Re: two-in-a-row*? 写経、つれづれ

Updated 2018-04-16T12:52:26+09:00

two-in-a-row*? 写経、つれづれ — https://t.laafc.net/2018/04/04/two-in-a-row-star-p.html のつづきです。

まずは、再掲します。

The Seasoned Schemer — http://felleisen.org/matthias/BTSS/

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

(define two-in-a-row*?
  (letrec
      ((T?
        (lambda (a)
          (let ((n (get-next 'go)))
            (and (atom? n)
                 (or (eq? n a)
                     (T? n))))))
       (get-next
        (lambda (x)
          (let/cc here-again
            (set! leave here-again)
            (fill 'go))))
       (fill values)
       (waddle
        (lambda (l)
          (cond
           ((null? l) '())
           ((atom? (car l))
            (let ()
              (let/cc rest
                (set! fill rest)
                (leave (car l)))
              (waddle (cdr l))))
           (else
            (let ()
              (waddle (car l))
              (waddle (cdr l)))))))
       (leave values))
    (lambda (l)
      (let ((fst (let/cc here
                   (set! leave here)
                   (waddle l)
                   (leave '()))))
        (and (atom? fst)
             (T? fst))))))

(values
 (two-in-a-row*? '(((food) ()) (((food)))))
 (two-in-a-row*? '(((food) (a)) (((food)))))
 (two-in-a-row*? '(((food) (a b (c) c)) (((food))))))
;=> #t, #f, #t

呼ぶ毎に次の要素が取って来られればよい、ということは、あらかじめ木からリストに変換してしまい、そのリストを辿ることにすればよい気もします。というわけで以下。

あらかじめリストにするというのは気が引けますが…

(define (my-two-in-a-row*? tree)
  (define (flatten tree acc)
    (cond ((null? tree) acc)
          ((atom? tree) (cons tree acc))
          (else (flatten (car tree) (flatten (cdr tree) acc)))))

  (let ((xs (flatten tree '())))
    (and (not (null? xs))
         (let T? ((a (car xs))
                  (xs (cdr xs)))
           (and (not (null? xs))
                (or (eq? (car xs) a)
                    (T? (car xs) (cdr xs))))))))

リストではなくてストリームへの変換にするとすると。

(define (my-two-in-a-row*? tree)
  (define (streamify tree)
    (stream-delay
      (cond ((null? tree) stream-null)
            ((atom? (car tree))
             (stream-cons (car tree) (streamify (cdr tree))))
            (else
             (stream-append (streamify (car tree))
                            (streamify (cdr tree)))))))

  (let ((s (streamify tree)))
    (and (not (stream-null? s))
         (let T? ((a (stream-car s))
                  (s (stream-cdr s)))
           (and (not (stream-null? s))
                (or (eq? (stream-car s) a)
                    (T? (stream-car s)
                        (stream-cdr s))))))))

最初に立ち返って、ジェネレータで。Scheme では SRFI にあり、すぐに利用することができる場合があるので、助かります。

(define (my-two-in-a-row*? tree)
  (define gen
    (make-coroutine-generator
     (lambda (yield)
       (let recur ((tree tree))
         (cond ((null? tree) (eof-object))
               ((atom? (car tree))
                (yield (car tree))
                (recur (cdr tree)))
               (else
                (recur (car tree))
                (recur (cdr tree))))))))

  (let1 fst (gen)
    (and (not (eof-object? fst))
         (let T? ((a fst)
                  (n (gen)))
           (and (not (eof-object? n))
                (or (eq? n a)
                    (T? n (gen))))))))

これは冒頭の写経したコードから、継続のやり取りの部分が抽象化されたもの、と考えることができます。

Gauche/generator.scm at release0_9_5 · shirok/Gauche · GitHub — https://github.com/shirok/Gauche/blob/release0_9_5/libsrc/gauche/generator.scm#L539 より。

;; generate :: ((a -> ()) -> ()) -> Generator a
(define (generate proc)
  (define (cont)
    (reset (proc (^[value] (shift k (set! cont k) value)))
           (set! cont null-generator)
           (eof-object)))
  (^[] (cont)))
...
(define (make-coroutine-generator proc) (generate proc))

たったこれだけで冒頭の写経したコードから継続のやり取りの部分がうまいこと抽象化されています、すごいなこれ。

何が起きているのか単純な例をもって自分の言葉で反芻します。

(let ()
  (define gen
    (generate
     (lambda (yield)
       (yield 1)
       (yield 2))))
  (values
   (gen)
   (gen)
   (gen)
   (gen)))

一回目の (gen) の評価は、 generate 内の cont を通して、 yield が呼び出されます(簡便のために、 cont 内で proc に渡される無名関数を yield と呼びます)。 (yield 1) で、 (shift k ...) が評価されるので、 k に束縛される継続を関数で表現してみます。

ここで shift により k に束縛されるのは reset までの部分継続なのでこんな具合だろうと考えられます。

(lambda (x)
  ((lambda (v)
     (reset v))
   ((lambda (_v)
      (set! cont null-generator) ;; cont は generate 内の束縛
      (eof-object))
    ((lambda (_v)
       (yield 2))
     x))))

ここで、 shift と control の対比で、 control の場合は reset までなのですが、 reset 自体は含まれません。

最初、後で出てくるように、文字通り reset が無いとどこが reset なのかわからなくなるはず、と考えていたので入れていました。 control と shift を対比すると、 reset が入ることが確認できると思います。

で、これが (set! cont k) として cont に束縛されます。 (yield 1) での (shift k ...) 評価に話を進めます。

(shift k ...) の評価では、この (shift k ...) を待ち構えている継続も特別で、 reset を待っている継続を伴って ... を評価する、ということなので、結果は、 reset を待っている継続を通して渡される、文字通り、 reset までの分がごっそり削られて以下のような様子だと考えられます。

;; (yield 1) の評価を考えます
((lambda (x)
   ((lambda (v) (PRINT-THEN-REPL v))
    ((lambda (v)
       (values
        v
        (gen)
        (gen)
        (gen)))
     x)))
 ((lambda (v)
    (reset v))
  ((lambda (_v)
     (set! cont null-generator) ;; cont は generate 内の束縛
     (eof-object))
   ((lambda (yield)
      _(yield 1)_
      (yield 2)))))
 )
;; 結局 (yield 1) は (shift k ... 1) なので reset までの分はごっそり削られる
;; つまり、 reset を待ち構えている継続を通して渡される
((lambda (x)
   ((lambda (v) (PRINT-THEN-REPL v))
    ((lambda (v)
       (values
        v
        (gen)
        (gen)
        (gen)))
     x)))
 1)

次に、二回目の (gen) の評価です。パラメータはここでは置いておくとします。固定で、 #f を渡すこととします。(引数が苦しいなあ…後々よく考えます！)

((lambda (x)
   ((lambda (v) (PRINT-THEN-REPL v))
    ((lambda (v)
       (values
        1
        v
        (gen)
        (gen)))
     x)))
 ((lambda (x)
    ((lambda (v)
       (reset v))
     ((lambda (_v)
        (set! cont null-generator) ;; cont は generate 内の束縛
        (eof-object))
      ((lambda (_v)
         (yield 2))
       x))))
  #f))

(yield 2) で (shift k ...) が評価されるので、先程と同様に、 k に束縛される部分継続を関数で表現することを考えます。先程と同様 shift が k に束縛するのは、 reset までの部分継続なので、文字通り reset のところまで、ということになります。

(lambda (x)
  ((lambda (v)
     (reset v))
   ((lambda (_v)
      (set! cont null-generator) ;; cont は generate 内の束縛
      (eof-object))
    ((lambda (v)
       v)
     x))))

(shift k ...) の評価では、結果は、 reset を待っている継続を通して渡される。

((lambda (x)
   ((lambda (v) (PRINT-THEN-REPL v))
    ((lambda (v)
       (values
        1
        v
        (gen)
        (gen)))
     x)))
 2)

(gen) 三回目。

((lambda (x)
   ((lambda (v) (PRINT-THEN-REPL v))
    ((lambda (v)
       (values
        1
        2
        v
        (gen)))
     x)))
 ((lambda (x)
    ((lambda (v)
       (reset v))
     ((lambda (_v)
        (set! cont null-generator) ;; cont は generate 内の束縛
        (eof-object))
      x)))
  #f))

(yield 2) の呼び出しの後なので、ここでは yield は呼ばれません。

ここで、“The Seasoned Schemer”でのことを思い出すと、継続の呼び出しで、 waddle から返ってしまったとしたら、"Wow" と言ってしまうような、神のみぞ知る状態になってしまう、ということがありました。そこで、意図した継続へ処理を移していくように、言い替えると、 get-next から"返る"ようにするために、 (leave '()) が必要になるわけでした。

それに対してここでは、そもそも、呼び出しているのは部分継続なので、処理を移す先は reset を待っている継続、ということになるのが大きな違いです。

今回、継続がどんな様子になるのかを関数で表現しようとして確認してみると、この違いが把握できました。

話を戻して。 cont には null-generator が束縛されて、 (eof-object) の結果が評価されます。

最後、 (gen) 四回目。

((lambda (x)
   ((lambda (v) (PRINT-THEN-REPL v))
    ((lambda (v)
       (values
        1
        2
        #<eof>
        (gen)))
     x)))
 ((lambda (_v) (cont))
  #f))
;;=> 1, 2, #<eof>, #<eof>;

ここで、 cont は null-generator なので、 #<eof> が返されています。