SICP 読み (213) 4.3.2 非決定性プログラムの例

なんか直前エントリの手続きが微妙。最後の

	(list (list 'Moore (cadr Moore))
	      (list 'Dowing (cadr Dowing))
	      (list 'Hall (cadr Hall))
	      (list 'Barnacle (cadr Barnacle))
	      (list 'Parker (cadr Parker)))))))

って何だ。ムスメの父親が出ないと意味ないし。(とほほほ

	(list (list 'Moore (cadr Moore) (car ((caddr Moore))))
	      (list 'Dowing (cadr Dowing) (car ((caddr Dowing))))
	      (list 'Hall (cadr Hall) (car ((caddr Hall))))
	      (list 'Barnacle (cadr Barnacle) (car ((caddr Barnacle))))
	      (list 'Parker (cadr Parker) (car ((caddr Parker)))))

でないと意味ナシ。
で、8queen な問題をヤる前に評価器に吸わせてみる事に。

つづき

で、評価器は allcode のソレを流用するとして、let が無いんだったかな。と思ったら Support for Let というナニが ch4-ambeval.scm にあった。いやはや。

で、以下のソレを作って評価器を起動

(add-load-path ".")
(load "ch4-ambeval.scm")
(define the-global-environment (setup-environment))
(driver-loop)

あと、true やら false について文句を言われたので ch4-mceval.scm に手を入れて評価器を起動して multiple-dwelling を吸わせてみたら require なんぞ知らん、とのお達し。driver-loop を起動した後に

(define (require p) (if (not p) (amb)))

を評価させないと駄目なのね、と。(を
で、リトライしたらこんどは distinct? が無い、との事。ちきしょうめ。ここの distinct? は以下

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

これも吸わせる必要ありですかそうですか。で、以下の出力を確認。

;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

;;; Amb-Eval input:
try-again

;;; There are no more values of
(multiple-dwelling)

;;; Amb-Eval input:

あと、問題 4.40 な解も吸わせてみましたが返答は同様。処理速度が改善されているかどうかは不明 (こら
あるいは問題 4.38 は以下な解が云々とあります。

((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

ヤッてみるか。

(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)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (> miller cooper))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

上記を評価器に吸わせてみれば良いのか。

;;; Amb-Eval input:
(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)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (> miller cooper))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))


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

;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))

;;; Amb-Eval input:
try-again

;;; There are no more values of
(multiple-dwelling)

;;; Amb-Eval input:

あらら。結構出てきたなぁ。って、解は 5 個だったな。4.41 なソレで確認済みだった。あるいは問題 4.42 はどうか、という事で手続き定義を吸わせてみたらオチた。(とほほ
って名前 let はサポートしてないんかな。

で、名前 let を無理矢理修正して再度評価してみたら、今後は and がない、と。仕方が無いのでとりあえず require をパラで書く形に。リトライしてみると今度は cadr が無いってアナタ。
と言いつつケツマづきながら修正を繰り返し、挙句の果てに betty なんて知らん、というメセジが出力。今、以下の状態になってるんですが、やっぱ名前 let じゃねぇとダメじゃん。

(define (liars)
  (define (cond-set l)
    (amb l (list (car (cdr l)) (car l))))
  (define (liars-iter l)
    (cond ((null? l)
	   (list (list 'betty betty)
		 (list 'ethel ethel)
		 (list 'joan joan)
		 (list 'kitty kitty)
		 (list 'mary mary)))
	  (else
	   (require (not ((car (car l)))))
	   (require ((car (cdr (car l)))))
	   (liars-iter (cdr l)))))

  (let ((betty (amb 1 2 3 4 5)))
    (let ((ethel (amb 1 2 3 4 5)))
      (require (distinct? (list betty ethel)))
      (let ((joan (amb 1 2 3 4 5)))
	(require (distinct? (list betty ethel joan)))
	(let ((kitty (amb 1 2 3 4 5)))
	  (require (distinct? (list betty ethel joan kitty)))
	  (let ((mary (amb 1 2 3 4 5)))
	    (require (distinct? (list betty ethel joan kitty mary)))
	    (liars-iter (list (cond-set (list (lambda () (= kitty 2))
					      (lambda () (= betty 3))))
			      (cond-set (list (lambda () (= ethel 1))
					      (lambda () (= joan 2))))
			      (cond-set (list (lambda () (= joan 3))
					      (lambda () (= ethel 5))))
			      (cond-set (list (lambda () (= kitty 2))
					      (lambda () (= mary 4))))
			      (cond-set (list (lambda () (= mary 4))
					      (lambda () (= betty 1))))))))))))

そりゃ liars-iter ん中じゃ betty は分からんよね。let の中で手続き定義してやれば可視範囲内かなぁ。って現実トウヒの規模がどんどん大きくなってます。イキオイ付いてしまって止まらん。盛り込んでみたら動いたぞ。動作した手続きは以下。

(define (liars)
  (define (cond-set l)
    (amb l (list (car (cdr l)) (car l))))

  (let ((betty (amb 1 2 3 4 5)))
    (let ((ethel (amb 1 2 3 4 5)))
      (require (distinct? (list betty ethel)))
      (let ((joan (amb 1 2 3 4 5)))
	(require (distinct? (list betty ethel joan)))
	(let ((kitty (amb 1 2 3 4 5)))
	  (require (distinct? (list betty ethel joan kitty)))
	  (let ((mary (amb 1 2 3 4 5)))
	    (require (distinct? (list betty ethel joan kitty mary)))
	    (define (liars-iter l)
	      (cond ((null? l)
		     (list (list 'betty betty)
			   (list 'ethel ethel)
			   (list 'joan joan)
			   (list 'kitty kitty)
			   (list 'mary mary)))
		    (else
		     (require (not ((car (car l)))))
		     (require ((car (cdr (car l)))))
		     (liars-iter (cdr l)))))
	    (liars-iter (list (cond-set (list (lambda () (= kitty 2))
					      (lambda () (= betty 3))))
			      (cond-set (list (lambda () (= ethel 1))
					      (lambda () (= joan 2))))
			      (cond-set (list (lambda () (= joan 3))
					      (lambda () (= ethel 5))))
			      (cond-set (list (lambda () (= kitty 2))
					      (lambda () (= mary 4))))
			      (cond-set (list (lambda () (= mary 4))
					      (lambda () (= betty 1))))))))))))

評価器の出力が以下。

;;; Amb-Eval input:
(liars)

;;; Starting a new problem 
;;; Amb-Eval value:
((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4))

;;; Amb-Eval input:
try-again

;;; There are no more values of
(liars)

;;; Amb-Eval input:

うーん。一応セイフらしい。ってよく見りゃここでも lambda な手続きをリストしてるな。次の問題でいきなり忘れる、とゆーのも後天性記憶不全な症状として酷いッス。
問題 4.43 なソレは後の楽しみにとっておく、とゆー事にして (以下略

つづき

問題 4.43 な解は NG な模様。根本的な見直しが必要みたいです。(とほほ

さらに

へろへろになりつつ、改善版がでっち上がったのですが、スデに試験は不可能。