SICP 読書ノート#61 - 4.3.2 非決定性のプログラムの例 (pp.248-250)
前回に引き続き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クイーンパズルがあっさり解けたよ！やったぜ！！
