2015-08-01

SICP 読書ノート#61 - 4.3.2 非決定性のプログラムの例 (pp.248-250)

SICP Scheme

前回に引き続きambオペレータを使って色々な論理パズルを解いていきます。

問題 4.39

解そのものには影響しない
解が出るまでの時間（計算回数には）影響する
- →問題 4.37 のようにバックトラックの回数をカウントすればよい

(define *backtrack-count* 0)

(define (req p)
  (if (not p)
      (begin (set! *backtrack-count* (add1 *backtrack-count*))
             (amb))
      false))

問題 4.40

まずはテキストの問題分を写経。

(define (distinct? items)
  (cond ((null? items) true)
        ((null? (cdr items)) true)
        ((member (car items) (cdr items)) false)
        (else (distinct? (cdr items)))))

(define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4 5))
        (cooper (amb 1 2 3 4 5))
        (fletcher (amb 1 2 3 4 5))
        (miller (amb 1 2 3 4 5))
        (smith (amb 1 2 3 4 5)))
    (req (distinct? (list baker cooper fletcher miller smith)))
    (req (not (= baker 5)))
    (req (not (= cooper 1)))
    (req (not (= fletcher 5)))
    (req (not (= fletcher 1)))
    (req (> miller cooper))
    (req (not (= (abs (- smith fletcher)) 1)))
    (req (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

動作を確認してみる。

racket@> (multiple-dwelling)
=> '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

racket@> (try-again)
=> '(there are no more values)

racket@> *backtrack-count*
=> 3124

バックトラックの回数からもわかるように、baker, cooper, fletcher, miller, smith で各々5パターンずつなので、5*5*5*5*5 => 3125パターンを試しているが、条件の絞り方を工夫すれば、こんなに試行する必要はない。

(define (multiple-dwelling-ex)
  (let ((fletcher (amb 1 2 3 4 5)))
    (req (not (= fletcher 5)))
    (req (not (= fletcher 1)))
    (let ((baker (amb 1 2 3 4 5)))
      (req (not (= baker 5)))
      (let ((cooper (amb 1 2 3 4 5)))
        (req (not (= cooper 1)))
        (let ((miller (amb 1 2 3 4 5)))
          (req (> miller cooper))
          (let ((smith (amb 1 2 3 4 5)))
            (req (not (= (abs (- smith fletcher)) 1)))
            (req (not (= (abs (- fletcher cooper)) 1)))
            (begin
              (req (distinct? (list baker cooper fletcher miller smith)))
              (list (list 'baker baker)
                    (list 'cooper cooper)
                    (list 'fletcher fletcher)
                    (list 'miller miller)
                    (list 'smith smith)))))))))

実行結果。バックトラックの回数がずいぶん減った。ただ、ヒューリスティックなアプローチで実装したので、これが最適解かどうかはわからない。

racket@> (multiple-dwelling-ex)
=> '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

racket@> (try-again)
=> '(there are no more values)

racket@> *backtrack-count*
=> 544

問題 4.42

発言の片方が正しく、もう片方が誤り、というのは排他的論理和で表現できる。

Racketの場合、xorという組み込み手続きがあるので、ありがたく使わせてもらいました。

(define (girls-standing)
  (let ((betty (amb 1 2 3 4 5))
        (ethel (amb 1 2 3 4 5))
        (joan (amb 1 2 3 4 5))
        (kitty (amb 1 2 3 4 5))
        (mary (amb 1 2 3 4 5)))
    (req (distinct? (list betty ethel joan kitty mary)))
    (req (xor (= kitty 2) (= betty 3))) ;; betty said
    (req (xor (= ethel 1) (= joan 2)))  ;; ehtel said
    (req (xor (= joan 3) (= ethel 5)))  ;; joan said
    (req (xor (= kitty 2) (= mary 4)))  ;; kitty said
    (req (xor (= mary 4) (= betty 1)))  ;; mary said
    (list (list 'betty betty)
          (list 'ethel ethel)
          (list 'joan joan)
          (list 'kitty kitty)
          (list 'mary mary))))

実行結果。

racket@> (girls-standing)
=> '((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4))

racket@> (try-again)
=> '(there are no more values)

問題 4.43

問題を整理すると以下のようになる。

持ち主	娘	ヨット
Moore	Mary Ann	Lorna
Downing	? (※1)	Melissa
Hall	? (※2)	Rosalind
Barnacle	Melissa	Gabrielle
Parker	? (※3)	? (※4)

ただし、

※4 Parkerのヨット
- Parkerのヨットは、残りのひとつ Mary Ann
※3 Parkerの娘
- テキストに「Gabrielleの父のヨットはDr.Parkerの娘から」とある
- Parkerの娘はGabrielleではない
- 残りの選択肢から Lorna or Rosalind
※2 Hallの娘
- 残りの選択肢から Lorna or Gabrielle
※1 Downingの娘
- 残りの選択肢から Lorna or Rosalind or Gabrielle

あとは実装すればよい。娘とヨットの組み合わせはconsセルで表現する。

(define (yacht-owner)
  (let ((moore    (cons 'mary 'lorna))
        (downing  (cons (amb 'lorna 'rosalind 'gabrielle) 'melissa))
        (hall     (cons (amb 'lorna 'gabrielle) 'rosalind))
        (barnacle (cons 'melissa 'gabrielle))
        (parker   (cons (amb 'lorna 'rosalind) 'mary)))
                      
    (let ((fathers (list moore downing hall barnacle parker)))
      ;; 娘は重複しない
      (req (distinct? (map car fathers)))

      ;; 「Gabrielleの父のヨットはDr.Parkerの娘から」をチェック
      (let ((gabrielle-father
             (car (filter (lambda (owner) (equal? (car owner) 'gabrielle))
                          fathers))))
        (req (equal? (cdr gabrielle-father) (car parker)))
        
        (list (list 'moore moore)
              (list 'downing downing)
              (list 'hall hall)
              (list 'barnacle barnacle)
              (list 'parker parker))))))

テスト。

racket@> (yacht-owner)
'((moore (mary . lorna))
  (downing (lorna . melissa))
  (hall (gabrielle . rosalind))
  (barnacle (melissa . gabrielle))
  (parker (rosalind . mary)))

racket@> (try-again)
'(there are no more values)

Mooreの娘がMary Annと確定していない場合についてはパスします。

問題 4.44

問題 2.42で悩まされまくった8クイーンパズル、こんなのところで現れるとは。。

まずは3x3で考えてみる。1列目のクイーンをq1、2列目のクイーンをq2としていくと、ambを使えば選択肢はかんたんに作り出せる。

(define (3-queens)
  (let ((q1 (amb 1 2 3)))
    (req (safe? 1 (list 1 q1)))
    (let ((q2 (amb 1 2 3)))
      (req (safe? 2 (list (list 1 q1)
                          (list 2 q2))))
      (let ((q3 (amb 1 2 3)))
        (req (safe? 3 (list (list 1 q1)
                            (list 2 q2)
                            (list 3 q3))))
        (try-again)))))

k列目のクイーンの位置をチェックするsafe?()は、単に位置を出力するだけで仮実装。

(define (safe? k positions)
  (display (format "k=~a pos=~a ~%" k positions))
  true)

テスト。ambらしく深さ優先でgame treeが作られていることがわかる。

racket@> (3-queens)
k=1 pos=(1 1) 
k=2 pos=((1 1) (2 1)) 
k=3 pos=((1 1) (2 1) (3 1)) 
k=3 pos=((1 1) (2 1) (3 2)) 
k=3 pos=((1 1) (2 1) (3 3)) 
k=2 pos=((1 1) (2 2)) 
k=3 pos=((1 1) (2 2) (3 1)) 
k=3 pos=((1 1) (2 2) (3 2)) 
k=3 pos=((1 1) (2 2) (3 3)) 
k=2 pos=((1 1) (2 3)) 
k=3 pos=((1 1) (2 3) (3 1)) 
k=3 pos=((1 1) (2 3) (3 2)) 
k=3 pos=((1 1) (2 3) (3 3)) 
k=1 pos=(1 2) 
k=2 pos=((1 2) (2 1)) 
k=3 pos=((1 2) (2 1) (3 1)) 
k=3 pos=((1 2) (2 1) (3 2)) 
k=3 pos=((1 2) (2 1) (3 3)) 
k=2 pos=((1 2) (2 2)) 
k=3 pos=((1 2) (2 2) (3 1)) 
k=3 pos=((1 2) (2 2) (3 2)) 
k=3 pos=((1 2) (2 2) (3 3)) 
k=2 pos=((1 2) (2 3)) 
k=3 pos=((1 2) (2 3) (3 1)) 
k=3 pos=((1 2) (2 3) (3 2)) 
k=3 pos=((1 2) (2 3) (3 3)) 
k=1 pos=(1 3) 
k=2 pos=((1 3) (2 1)) 
k=3 pos=((1 3) (2 1) (3 1)) 
k=3 pos=((1 3) (2 1) (3 2)) 
k=3 pos=((1 3) (2 1) (3 3)) 
k=2 pos=((1 3) (2 2)) 
k=3 pos=((1 3) (2 2) (3 1)) 
k=3 pos=((1 3) (2 2) (3 2)) 
k=3 pos=((1 3) (2 2) (3 3)) 
k=2 pos=((1 3) (2 3)) 
k=3 pos=((1 3) (2 3) (3 1)) 
k=3 pos=((1 3) (2 3) (3 2)) 
k=3 pos=((1 3) (2 3) (3 3)) 
'(there are no more values)

あとは8x8に拡張し、safe?()を問題2.42で解いた時と同じものを持ってくる。

ダラダラと長いのは僕のマクロ力が0だからです。プルリクお待ちしてます(笑)

(define (8-queens)
  (let ((q1 (amb 1 2 3 4 5 6 7 8)))
    (req (safe? 1 (list 1 q1)))
    (let ((q2 (amb 1 2 3 4 5 6 7 8)))
      (req (safe? 2 (list (list 1 q1)
                          (list 2 q2))))
      (let ((q3 (amb 1 2 3 4 5 6 7 8)))
        (req (safe? 3 (list (list 1 q1)
                            (list 2 q2)
                            (list 3 q3))))
        (let ((q4 (amb 1 2 3 4 5 6 7 8)))
          (req (safe? 4 (list (list 1 q1)
                              (list 2 q2)
                              (list 3 q3)
                              (list 4 q4))))
          (let ((q5 (amb 1 2 3 4 5 6 7 8)))
            (req (safe? 5 (list (list 1 q1)
                                (list 2 q2)
                                (list 3 q3)
                                (list 4 q4)
                                (list 5 q5))))
            (let ((q6 (amb 1 2 3 4 5 6 7 8)))
              (req (safe? 6 (list (list 1 q1)
                                  (list 2 q2)
                                  (list 3 q3)
                                  (list 4 q4)
                                  (list 5 q5)
                                  (list 6 q6))))
              (let ((q7 (amb 1 2 3 4 5 6 7 8)))
                (req (safe? 7 (list (list 1 q1)
                                    (list 2 q2)
                                    (list 3 q3)
                                    (list 4 q4)
                                    (list 5 q5)
                                    (list 6 q6)
                                    (list 7 q7))))                                  
                (let ((q8 (amb 1 2 3 4 5 6 7)))
                  (req (safe? 8 (list (list 1 q1)
                                      (list 2 q2)
                                      (list 3 q3)
                                      (list 4 q4)
                                      (list 5 q5)
                                      (list 6 q6)
                                      (list 7 q7)
                                      (list 8 q8))))
                  (display (format "~a ~%" (list (list 1 q1)
                                                 (list 2 q2)
                                                 (list 3 q3)
                                                 (list 4 q4)
                                                 (list 5 q5)
                                                 (list 6 q6)
                                                 (list 7 q7)
                                                 (list 8 q8))))
                  (try-again))))))))))
                            
(define (safe? k positions)
  (safe-iter? (- k 1) k positions))
  
(define (safe-iter? i k positions)
  (if (= i 0)
      #t
      (let ((old-pos (list-ref positions (- i 1)))
            (new-pos (list-ref positions (- k 1))))
        (and (not (= (cadr old-pos) (cadr new-pos)))
             (not (= (cadr old-pos) (- (cadr new-pos) (- k i))))
             (not (= (cadr old-pos) (+ (cadr new-pos) (- k i))))
             (safe-iter? (- i 1) k positions)))))

テスト。

racket@> (8-queens)
((1 1) (2 5) (3 8) (4 6) (5 3) (6 7) (7 2) (8 4)) 
((1 1) (2 6) (3 8) (4 3) (5 7) (6 4) (7 2) (8 5)) 
((1 1) (2 7) (3 4) (4 6) (5 8) (6 2) (7 5) (8 3)) 
((1 1) (2 7) (3 5) (4 8) (5 2) (6 4) (7 6) (8 3))
;; ...
((1 8) (2 2) (3 4) (4 1) (5 7) (6 5) (7 3) (8 6)) 
((1 8) (2 2) (3 5) (4 3) (5 1) (6 7) (7 4) (8 6)) 
((1 8) (2 3) (3 1) (4 6) (5 2) (6 5) (7 7) (8 4)) 
((1 8) (2 4) (3 1) (4 3) (5 6) (6 2) (7 7) (8 5)) 
'(there are no more values)

あんなに苦労した8クイーンパズルがあっさり解けたよ！やったぜ！！

次回は「§4.3.2(続き) 自然言語の構文解析」から。

※「SICP読書ノート」の目次はこちら

2015-07-14

SICP 読書ノート#60 - 4.3.1 ambと探索 (pp.246-248)

SICP Scheme

前回のエントリで実装したambオペレータを使って練習問題を解いていきます。

問題 4.35

二つの境界値の間の整数を返す手続き an-integer-between を実装する。いくつか方法はあると思うが、§2で登場した enumerate-interval を流用してみた。

(define (enumerate-interval low high)
  (if (> low high)
      '()
      (cons low (enumerate-interval (+ low 1) high))))

(define (an-integer-between low high)
  (an-element-of (enumerate-interval low high)))

ピタゴラス三角形の辺の組み合わせを求める a-pytagorean-triple-between を動かしてみる。

(define (a-pythagorean-triple-between low high)
  (let ((i (an-integer-between low high)))
    (let ((j (an-integer-between i high)))
      (let ((k (an-integer-between j high)))
        (req (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

テスト。

racket@> (a-pythagorean-triple-between 1 20)
'(3 4 5)
racket@> (try-again)
'(5 12 13)
racket@> (try-again)
'(6 8 10)
racket@> (try-again)
'(8 15 17)
racket@> (try-again)
'(9 12 15)
racket@> (try-again)
'(12 16 20)
racket@> (try-again)
'(there are no more values)

問題 4.36

テキストの例では、

(define (a-pythagorean-triple)
  (let ((i (an-integer-starting-from 1)))
    (let ((j (an-integer-starting-from 1)))
      (let ((k (an-integer-starting-from 1)))
        (req (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

i,j,kの組み合わせが [1,1,1] => [1,1,2] => [1,1,3] => ... => [1,1,N] => ... と k ばかり増えてしまうため、永遠に返ってこない。

これを回避するには、i,j,kの組み合わせを、

=> [1,1,1]
=> [1,1,2] => [1,2,2] => [2,2,2]
=> [1,1,3] => [1,2,3] => [2,2,3] => [1,3,3] => [2,3,3] => [3,3,3]
=> ...

のように進めていけばよいので、以下のような実装となる。

(define (a-pythagorean-triple)
  (let* ((k (an-integer-starting-from 1))
         (j (an-integer-between 1 k))
         (i (an-integer-between 1 j)))
    (req (= (+ (* i i) (* j j)) (* k k)))
    (list i j k)))

テスト。

racket@> (a-pythagorean-triple)
'(3 4 5)
racket@> (try-again)
'(6 8 10)
racket@> (try-again)
'(5 12 13)
racket@> (try-again)
'(9 12 15)
racket@> (try-again)
'(8 15 17)
racket@> (try-again)
'(12 16 20)
racket@> (try-again)
'(15 20 25)

;; => 以降、永遠につづく…

問題 4.37

問題 4.35 と比べると、今回の実装の方がずっと効率がよい。

(define (a-pythagorean-triple-between-ex low high)
  (let ((i (an-integer-between low high))
        (hsq (* high high)))
    (let ((j (an-integer-between i high)))
      (let ((ksq (+ (* i i) (* j j))))
        (req (>= hsq ksq))
        (let ((k (sqrt ksq)))
          (req (integer? k))
          (list i j k))))))

理由は以下の通り。

kの走査がない
jの取りうる範囲がせまくなっている

どの程度効率がよくなっているかは、バックトラックの実施数をカウントすれば分かる。

(define *backtrack-count* 0)

(define (req p)
  (if (not p)
      (begin (set! *backtrack-count* (add1 *backtrack-count*))
             (amb))
      false))

テスト。まずは問題 4.35 の実装。

racket@> (a-pythagorean-triple-between 1 20)
'(3 4 5)
racket@> (try-again)
'(5 12 13)
racket@> (try-again)
'(6 8 10)
racket@> (try-again)
'(8 15 17)
racket@> (try-again)
'(9 12 15)
racket@> (try-again)
'(12 16 20)
racket@> (try-again)
'(there are no more values)

racket@> *backtrack-count*
1584

次に問題 4.37の実装。

racket@> (a-pythagorean-triple-between-ex 1 20)
'(3 4 5)
racket@> (try-again)
'(5 12 13)
racket@> (try-again)
'(6 8 10)
racket@> (try-again)
'(8 15 17)
racket@> (try-again)
'(9 12 15)
racket@> (try-again)
'(12 16 20)
racket@> (try-again)
'(there are no more values)

racket@> *backtrack-count*
225

差は歴然である。。

次回は「§4.3.2 非決定性プログラムの例」から。

※「SICP読書ノート」の目次はこちら

2015-07-03

SICP 読書ノート#59 - 4.3 非決定性計算 - call/ccによるambオペレータの実装 (pp.245)

SICP Scheme

前回で継続やcall/ccの振る舞いはつかめたので、今回はambオペレータをcall/ccで実装します。

ソースコードは以下に置いています。

https://github.com/uents/sicp/blob/master/ch4.3-amb-operator

amb評価器を動作させる

まずは動かしてみないとambが何者かすらわからないので動かしてみる。

1. SICP本家からサンプルコードをダウンロード

% curl -O https://mitpress.mit.edu/sicp/code/ch4-ambeval.scm
% curl -O https://mitpress.mit.edu/sicp/code/ch4-mceval.scm

2. Racket処理系で解釈できるようにいくつか修正

§4.2の遅延評価器の時とほぼ同じことをやればよい。

`ch4-ambeval.scm`

ファイルの先頭に#lang racketのシェバンを追加
ch4-mceval.scmのロード処理をloadからincludeに変更

(require racket/include)
(include "ch4-mceval.scm")

ファイルの終端に以下を追加

(define the-global-environment (setup-environment))
(driver-loop)

`ch4-mceval.scm`

ファイルの先頭に(require r5rs)を追加
Racket処理系やch4-ambeval.scmと重複している定義をコメントアウト
- eval
- apply
- primitive-procedures
- input-prompt
- output-prompt
- driver-loop

3. amb評価器を起動

ch4-ambeval.scmをロードすると遅延評価器のREPLが起きて入力プロンプトが表示される。

racket@> ,enter "ch4-ambeval.scm"
'METACIRCULAR-EVALUATOR-LOADED
'AMB-EVALUATOR-LOADED

;;; Amb-Eval input:

amb評価器の仕様

amb評価器のインターフェース

amb評価器のREPL(driver-loop)で、(amb 1 2 3)とした場合、1,2,3の選択肢の集合が評価器にセットされ、どれかひとつが返される。すでに選択肢がセットされていた場合、これまでのものは捨てられ、与えられた選択肢がセットされる。

;;; Amb-Eval input:
(amb 1 2 3)

;;; Starting a new problem 
;;; Amb-Eval value:
1

さらに'try-againとすると、残りの選択肢からひとつ返される

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
2

さらに'try-againを続けていき、選択肢がなくなった場合、There are no more values of ...とprintされる

;;; Amb-Eval input:
try-again

;;; There are no more values of
(amb 1 2 3)

また、REPLではなくコード上で(amb <choices> ...)を呼ぶ場合、

<choices>がある場合、新たな選択肢の集合が追加される
<choices>がない場合、残りの選択肢からひとつ返される ('try-againと同じ)

となる。

選択肢のうちどれが選択されるか本質的にはわからない。このような処理を非決定性計算（または非決定性オートマトン）と呼ぶらしい。

ambの選択肢の探索

例えば、以下のようなコードをamb評価器のREPLに与えると、

;;; Amb-Eval input:
(let ((x (amb 1 2 3))
      (y (amb 'a 'b)))
  (list x y))

;;; Starting a new problem 
;;; Amb-Eval value:
(1 a)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(1 b)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(2 a)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(2 b)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(3 a)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(3 b)

;;; Amb-Eval input:
try-again

;;; There are no more values of
(let ((x (amb 1 2 3)) (y (amb (quote a) (quote b)))) (list x y))

;;; Amb-Eval input:
try-again

;;; There is no current problem

集合 '(1 2 3) と '(a b) の内積を逐次返すコードとなる。

これをみても分かるように'try-againとすると、以前の選択点に戻って別の選択肢を返していることがわかる。このように以前の選択点へ戻る処理を「バックトラック」と呼ぶ。

call/ccによるambオペレータの実装

ここからが本題。

SICPテキストのamb評価器を使うと、Racketの豊富な組み込みライブラリの恩恵が受けられないので、この先この評価器を使って問題を解いていくのは辛そう。

そこでambオペレータをcall/ccを使って実装する。まぁ、On Lispのコードを少し改変しただけですが。。

まず、与えられた選択肢からひとつを選び、残りの選択肢をキュー（コード上の*alternatives*）にpushする手続きchooseを実装する。

(define *alternatives* '())

(define (choose choices)
  (if (null? choices)
      (try-again)
      (call/cc
       (lambda (cc)
         (set! *alternatives*
               (cons
                (lambda ()
                  (cc (choose (cdr choices))))
                *alternatives*))
         (car choices)))))

残りの選択肢をキューにpushする際に(lambda () (cc (choose (cdr choices))))とccを付けるのがポイント。ccを呼ぶことで、残りの選択肢から選ぶ度に(amb <choices> ...)を実行したコンテキストへジャンプすることができる。

次に、残りの選択肢*alternatives*から選び直す手続きtry-againを実装する。これは*alternatives*から手続きをpopし実行するだけなので、わかりやすい。

この時のnextは上記の(lambda () (cc (choose (cdr choices))))に相当。つまりnextを作用させることでバックトラックを引き起こす。

(define try-again false)
    
(call/cc
 (lambda (cc)
   (set! try-again
         (lambda ()
           (if (null? *alternatives*)
               (cc '(there are no more values))
               (let ((next (car *alternatives*)))
                 (set! *alternatives* (cdr *alternatives*))
                 (next)))))))

あとは、chooseのラッパーとしてambを定義。

(define (amb . choices)
  (choose choices))

上記をamb.scmというファイルで保存し、Racket REPLで動かしてみる。

racket@> (require "amb.scm")
racket@> (let ((x (amb 1 2 3))
               (y (amb 'a 'b)))
           (list x y))
'(1 a)
racket@> (try-again)
'(1 b)
racket@> (try-again)
'(2 a)
racket@> (try-again)
'(2 b)
racket@> (try-again)
'(3 a)
racket@> (try-again)
'(3 b)
racket@> (try-again)
'(there are no more values)

できた！

このときの動作は以下のようになる。

(let ...)で
- (choose '(2 3))が*alternatives*にpushされ、xに1が束縛される
- (choose '(b))が*alternatives*にpushされ、yに'aが束縛される
- '(1 a)が返る
(try-again)で
- (choose '(b))がバックトラックされ
  - xには1が束縛されたまま
  - (choose '())が*alternatives*にpushされ、yに'bが束縛される
  - '(1 b)が返る
(try-again)で
- (choose '())がバックトラックされると、(try-again)が実行される
- (choose '(2 3))がバックトラックされ
  - (choose '(3))が*alternatives*にpushされ、xに2が束縛される
  - (choose '(b))が*alternatives*にpushされ、yに'aが束縛される
  - '(2 a)が返る

後の(try-again)もこれの繰り返しです。

ambオペレータの基本手続き

まずはrequireだが、Racket組み込みのrequireを奪われるとさすがに辛いので、reqという名前で定義する。また、Racketはif構文でaltenative節がないのを許さないので、適当にfalseを返すようにしておく。

(define (req p)
  (if (not p) (amb) false))

次にan-element-of。SICPの通りの実装では、

(define (an-element-of items)
  (req (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

実行時にamb手続きの引数が先に評価されてしまうので、an-element-ofの評価の無限ループに嵌まり返ってこなくなる。

そこで引数を遅延オブジェクト化する。

(define (an-element-of items)
  (req (not (null? items)))
  (amb (car items) (delay (an-element-of (cdr items)))))

反対にambオペレータの実装となるchooseではforceさせる。

(define (choose choices)
  (if (null? choices)
      (try-again)
      (call/cc
       (lambda (cc)
         (define try-next
           (lambda () (cc (choose (cdr choices)))))
         (set! *alternatives*
               (cons try-next *alternatives*))
         (force (car choices)))))) ;; ここでforce

これでan-element-ofが動くようになった。

racket@> (an-element-of '(1 3 5))
1
racket@> (try-again)
3
racket@> (try-again)
5
racket@> (try-again)
'(there are no more values)

これでprime-sum-pairも問題なく動く。

racket@> (require math/number-theory) ;; prime?のためにロード

racket@> (define (prime-sum-pair list1 list2)
           (let ((a (an-element-of list1))
                 (b (an-element-of list2)))
             (req (prime? (+ a b)))
             (list a b)))

racket@> (prime-sum-pair '(1 3 5 8) '(20 35 110))
'(3 20)
racket@> (try-again)
'(3 110)
racket@> (try-again)
'(8 35)
racket@> (try-again)
'(there are no more values)

ただし、上記のan-element-ofは(try-agian)の度に(choose '())が*alternatives*にpushされるし、毎回delay/forceが絡むので効率はいまいち。

このambオペレータは特殊形式ではなく手続きなので、単純にapplyで実装する方がよいかもしれない。

(define (an-element-of items)
  (apply amb items))

次は§4.3の練習問題を解いていきます。

※「SICP読書ノート」の目次はこちら

2015-06-27

SICP 読書ノート#58 - 4.3 非決定性計算 - 継続とは何か (pp.245)

SICP Scheme

「§4.3 Schemeの変形---非決定性計算」に入りました。

最初はテキストの内容の全貌が掴めず、サンプルコードをロードしてambを叩きまくっていたのですが、だんだん何がわからないかが頭の中で整理できてきました。

→ambの振る舞いがどういうことなのかわからない

→非決定性計算が何なのかがわからない

→継続が何なのかがわからない

おそらく、継続に関する説明がないままにambを使った例題が続いた後に、ambの実装で唐突に継続が出てくるところがわかりにくい原因だと思います。さらに、Schemeでは継続を作り出すcall/cc (call-with-current-continuation) があるのに、この章では登場しません。

そこで、まずは「継続」とは何かから学びました。

継続とは何か

例えば、jQueryのajax メソッドで、

$.ajax({
    url: "ajax.html",
}).done(function(data){
    alert('success!!');
}).fail(function(data){
    alert('error!!!');
});

のように、通信に成功した場合はdone()、失敗した場合はfail()といったコールバックが呼び出されると思います。

このように、◯◯の後は□□、といった処理のリレー渡しのような実装スタイルを「継続渡しスタイル」といいます。なお、SICP本文のamb評価器も成功/失敗処理を継続渡しスタイルで実装しています。

On Lisp

作者: ポールグレアム,野田開,Paul Graham
出版社/メーカー: オーム社
発売日: 2007/03
メディア: 単行本
購入: 10人クリック: 146回
この商品を含むブログ (128件) を見る

ただし、SchemeやLispでいうところの「継続」はプラスαがあります。

On Lispでは次のように書かれています。

継続とは、動作中に凍結したプログラムだ。すなわち計算処理の状態を含んだ一つの関数的オブジェクトだ。保存された計算処理は、それが中断された時点から再開する。プログラムの状態を保存し、後に再開できる能力は、ある種の問題解決に素晴しい威力を発揮する。

この計算処理を保存し再開する能力を、汎用的に与えてくれる仕組みがcall/ccです。

call/cc入門

文章ではうまく説明できないので、コードを動かしながら解説します。書いていると自分の理解も深まりますしね。

他のScheme処理系と同様、Racketでもcall/ccは最初から使えるので前準備は不要です。

まずはcall/ccを呼んでみます。

racket@> (+ 1
            (call/cc
             (lambda (cc)
               2))
            3)
=> 6

この(call/cc (lambda (cc) 2))のcc(current continuation)がまさに継続で、この瞬間の計算処理の状態を含むオブジェクトとなります。ここではccは特に使わず、call/ccで単に2を返すので、普通に(+ 1 2 3) => 6となります。

次にccをfrozenというグローバル変数に束縛させます。

racket@> (define frozen false)

racket@> (+ 1
            (call/cc
             (lambda (cc)
               (set! frozen cc)
               2))
            3)
=> 6

frozenを叩いてみると、#<continuation>と返ってきます。ccは継続オブジェクトということが分かります。

racket@> frozen
=> #<continuation>

frozenに引数を作用させます。

racket@> (frozen 10)
=> 14

racket@> (+ 100 (frozen 10))
=> 14

racket@> (+ (frozen 10) 100)
=> 14

この例から分かるように、frozenを作用させた時の振る舞いは、

(lambda (x) (+ 1 x 3))のような処理が実行される
コンテキストはcall/ccの実行時へジャンプ。作用元へは戻ってこない

となります。On Lispの「継続とは、動作中に凍結したプログラムだ。すなわち計算処理の状態を含んだ一つの関数的オブジェクトだ」の説明通り、ccには処理だけでなくスタックの状態を全て保持され、ccを呼び出すときにそのスタックの状態から処理を再開するように振る舞うことがわかります。

さらに(lambda (x) (+ 1 x 3))のような処理について、もう少し検証してみます。

racket@> (frozen false)
+: contract violation
  expected: number?
  given: #f
  argument position: 2nd
  other arguments...:
   1
   3
;; => 引数は2番目ということが分かる

racket@> (frozen 10 20 30)
result arity mismatch;
 expected number of values not received
  expected: 1
  received: 3
  values...:
   10
   20
   30
;; => 引数は1つしかとれない

このことから、(lambda (x) (+ 1 x 3))のような処理という言い方で間違いないかと思います。

今度は、変数の加算処理で実験してみます。

racket@> (define a 1)
racket@> (define b 3)
racket@> (+ a
            (call/cc
             (lambda (cc)
               (set! frozen cc)
               2))
            b)
=> 6

racket@> (frozen 10)
=> 14

racket@> (set! a 100)
racket@> (set! b 200)
racket@> (frozen 10)
=> 211

最後の結果は310ではなく211でした。call/ccが呼び出された時の計算処理状態では、aはすでに評価されています。よって、frozenの実行時には(lambda (x) (+ 1 x b))のような処理が実行されることとなり、結果は211となります。

次に、call/ccの中でccを実行してみます。

racket@> (set! frozen false)

racket@> (+ 1
            (call/cc
             (lambda (cc)
               (set! frozen cc)
               (cc 10)
               2))
            3)
=> 14

racket@> frozen
=> #f

ccは(lambda (x) (+ 1 x 3))のような処理のため、(cc 10) => 14となる。また、そこで処理を抜け出すため14がそのまま返る
(cc 10)の実行は、(set! frozen cc)より前のためfrozenは#fのまま

となります。

レキシカルクロージャはどうでしょうか。

racket@> (define accumlator false)

racket@> (let ((x 0))
           (call/cc
            (lambda (cc)
              (set! accumlator cc)))
           (set! x (+ x 1))
           x)
=> 1

racket@> (accumlator)
=> 2

racket@> (accumlator)
=> 3

racket@> (accumlator 100) ;; この場合の引数は無視される
=> 4

継続においてもレキシカルクロージャはもちろん有効です。

深さ優先探索の例

On Lispの例をそのまま引用。carをleft-branch、cdrをright-branchとする木について考えます。

(define t1 '(a (b (d h) (c e (f i) g))))

この木を深さ優先で探索するプログラムはcarを優先させればよいので、以下のように実装できます。

(define (dft tree)
  (cond ((null? tree) 'done)
        ((not (pair? tree))
         (display (format "~A " tree)))
        (else (dft (car tree))
              (dft (cdr tree)))))

実行結果は以下の通り。

racket@> (dft t1)
=> a b d h c e f i g 'done

次にnodeにヒットすると結果を出力して探索を停止、restartで探索を再開するようなプログラムを、call/ccを使って実装し直します。

(define *saved* '())

(define (dft-node tree)
  (cond ((null? tree) (restart))
        ((not (pair? tree)) tree)
        (else (call/cc
               (lambda (cc)
                 (set! *saved*
                       (cons (lambda ()
                               (cc (dft-node (cdr tree))))
                             *saved*))
                 (dft-node (car tree)))))))

(define (restart)
  (if (null? *saved*)
      'done
      (let ((cont (car *saved*)))
        (set! *saved* (cdr *saved*))
        (cont))))

これを実行すると以下のようになります。left-branchの探索を進める際に、right-branchの探索を*saved*にpushし、やがてnodeにぶつかると探索を停止します。(restart)を実行するとright-branchの探索が再開される。

racket@> (dft-node t1)
=> 'a

racket@> (restart)
=> 'b

racket@> (restart)
=> 'c

;; ...

racket@> (restart)
=> 'done

nodeの出力とrestartを続けて呼ぶことで、dftと同じく全ノードを深さ優先探索するプログラムとなります。

racket@> (define (dft2 tree)
           (set! *saved* '())
           (let ((node (dft-node tree)))
            (cond ((eq? node 'done) 'done)
                  (else (display (format "~A " node))
                        (restart)))))

racket@> (dft2 t1)
=> a b d h c e f i g 'done

ただしこの例だと、わざわざcall/ccを使わなくてもdft-nodeを実装できてしまうけど… :-P

         
racket@> (define (dft-node2 tree)
           (cond ((null? tree) (restart))
                  ((not (pair? tree)) tree)
                  (else (begin
                          (set! *saved*
                                (cons (lambda () (dft-node2 (cdr tree)))
                                      *saved*))
                          (dft-node2 (car tree))))))

racket@> (dft-node2 t1)
=> 'a
racket@> (restart)
=> 'b
racket@> (restart)
=> 'c

;; ...

長くなったのでここまで。

次回はcall/ccを使ってambオペレータを実装します。

※「SICP読書ノート」の目次はこちら

2015-06-15

SICP 読書ノート#57 - 4.2.3 遅延評価リストとしてのストリーム (pp.243-245)

Scheme SICP

遅延評価器では手続きの引数が全て遅延されるので、consセルをcompound procedureとして定義すれば、リストとストリームは同義となる。

consの手続きは§2でも出たあれだ。

(define (cons first rest)
  (lambda (pair) (pair first rest)))

(define (car pair)
  (pair (lambda (f r) f)))

(define (cdr pair)
  (pair (lambda (f r) r)))

§3のストリームは遅延されるのはcdrだけだったのに対し、この遅延リストはcarもcdrも同様に遅延ができる。これを「遅延度が高い」と言うらしい。

問題 4.32

この遅延度の高さのおかげで未定義の対が定義できる。

;;; L-Eval input:
(define a-stream (cons x y)) ;; x,yは未定義の変数

;;; L-Eval value:
ok

;;; L-Eval input:
a-stream

;;; L-Eval value:
(compound-procedure (pair) ((pair first rest)) <procedure-env>)

§3のストリームだとxが未定義でエラーするはず。

問題 4.33-34

あまり興味が惹かれないでパスします。

次回は「§4.3 Schemeの変形---非決定性計算」から。

@uents blog

Code wins arguments.

SICP 読書ノート#61 - 4.3.2 非決定性のプログラムの例 (pp.248-250)

問題 4.39

問題 4.40

問題 4.42

問題 4.43

問題 4.44

SICP 読書ノート#60 - 4.3.1 ambと探索 (pp.246-248)

問題 4.35

問題 4.36

問題 4.37

SICP 読書ノート#59 - 4.3 非決定性計算 - call/ccによるambオペレータの実装 (pp.245)

amb評価器を動作させる

1. SICP本家からサンプルコードをダウンロード

2. Racket処理系で解釈できるようにいくつか修正

`ch4-ambeval.scm`

`ch4-mceval.scm`

3. amb評価器を起動

amb評価器の仕様

amb評価器のインターフェース

ambの選択肢の探索

call/ccによるambオペレータの実装

ambオペレータの基本手続き

SICP 読書ノート#58 - 4.3 非決定性計算 - 継続とは何か (pp.245)

継続とは何か

call/cc入門

深さ優先探索の例

SICP 読書ノート#57 - 4.2.3 遅延評価リストとしてのストリーム (pp.243-245)

問題 4.32

問題 4.33-34