問題4.35-4.44

非決定計算です。パラレルワールドです。

めも

問題を解くのにamb評価器使いたいから先に構成して動かせるようにしておきます。なんか継続が出てきました。amb評価器になんで継続が必要なのかは分かるんだけど、複雑過ぎてちょっとこのコードまだ把握できてないです。後半の問題やる過程で把握できるようにしたいです。

4.35

(define (an-integer-between i j)
  (require (<= i j))
  (amb i (an-integer-between (+ i 1) j))))

こんな感じ。実行は、

;;; Amb-Eval input:
(an-integer-between 4 6)
;;; Starting a new problem 
;;; Amb-Eval value:
4

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
5

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
6

;;; Amb-Eval input:
try-again
;;; There are no more values of
(an-integer-between 4 6)

a-pythagorean-triple-betweenの実行もちゃんとできる。

;;; Amb-Eval input:
(a-pythagorean-triple-between 100 1000)
;;; Starting a new problem 
;;; Amb-Eval value:
(100 105 145)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(100 240 260)

けどとても遅い。探索の仕方を工夫すると向上するかも。

4.36

an-integer-betweenをan-integer-starting-fromに置き換えると、次のような探索を行ってしまうかもしれない。
(1 1 1) (1 1 2) ... (1 1 9999999) (1 1 10000000) ..........
するとこれは終わらないので不適切。全ての値を生成できるようにするには、バックトラックが無限の分岐に入らないように書く必要がある。i,j,kの制限に注目すると、kを決めるとjの範囲が決まり、jを決めるとiの範囲が決まるので、次のように書くといいと分かる。

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

実行すると、

;;; Amb-Eval input:
(a-pythagorean-triple)
;;; Starting a new problem 
;;; Amb-Eval value:
(3 4 5)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(6 8 10)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(5 12 13)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(9 12 15)

...

4.37

効率はよくなる。前のだとi,j,kの(<= i j k)における可能な組すべてを調べていたが、今回はi,jのみの可能な組のなかで、特にi^2+j^2が最大(high^2)を超えないもののみを調べているのではるかに効率がいい。

4.38

論理パズルを計算機に解かせます。楽しい。

;;; 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)

で5通りですね。

4.39

requireの順序が解に影響することはない。
効率についてもrequireの順序はたぶん影響しない。いや、failになるのが多い条件を先に持ってくれば他の条件が重い場合は多少影響するけど、今回のはどれもそんなに重い条件じゃないから大した影響はないはず。それにtry-againで解の全部を探索するなら順序がどうでも結局のところ同じだけ時間がかかるような気がする。

4.40

人の階の割り当てがそれぞれ異なるという制限の前においては、5*5*5*5*5=3125通りのパターンがある。制限後は、5*4*3*2*1=120通りになる。
制限が多い順にletを並べていくといいと思う。こんな感じ。

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

さっきより大分速くなりました。

4.41

できた。

(define (solve)
  (define (pred lst)
    (let ((b (car lst))
          (c (cadr lst))
          (f (caddr lst))
          (m (cadddr lst))
          (s (cadddr (cdr lst))))
      (cond ((= b 5) #f)
            ((= c 1) #f)
            ((= f 5) #f)
            ((= f 1) #f)
            ((<= m c) #f)
            ((= (abs (- s f)) 1) #f)
            ((= (abs (- f c)) 1) #f)
            (else #t))))
  (define (insert-pattern-list x lst)
    (define (recursive lst n)
      (cond ((null? lst) (list x))
            ((= n 0) (cons x lst))
            (else (cons (car lst)
                        (recursive (cdr lst) (- n 1))))))
    (let loop ((i (length lst)))
      (if (= i 0)
          (list (recursive lst i))
          (cons (recursive lst i) (loop (- i 1))))))  
  (define (permutation lst)
    (if (null? (cdr lst))
        (list lst)
        (apply append
               (map (lambda (k) (insert-pattern-list (car lst) k))
                    (permutation (cdr lst))))))
  (filter pred (permutation '(1 2 3 4 5))))

順列生成が結構めんどい。

4.42

嘘つきパズルを解くにあたって、andとorが欲しいです。が、実行手続きに変換するのが結構ややこしそうなので、導出された式への変換によって実現します。問題4.4で作ったものを使います。
嘘つきパズルを解く手続きをsolve-puzzleとして、以下のようにします。

(define (solve-puzzle)
  (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)))
    (require
     (distinct? (list betty ethel joan kitty mary)))
    (require
     (or (and (= kitty 2) (not (= betty 3)))
         (and (= betty 3) (not (= kitty 2)))))
    (require
     (or (and (= ethel 1) (not (= joan 2)))
         (and (= joan 2) (not (= ethel 1)))))
    (require
     (or (and (= joan 3) (not (= ethel 5)))
         (and (= ethel 5) (not (= joan 3)))))
    (require
     (or (and (= kitty 2) (not (= mary 4)))
         (and (= mary 4) (not (= kitty 2)))))
    (require
     (or (and (= mary 4) (not (= betty 1)))
         (and (= betty 1) (not (= mary 4)))))
    (list (list 'betty betty)
          (list 'ethel ethel)
          (list 'joan joan)
          (list 'kitty kitty)
          (list 'mary mary))))

実行します。

;;; Amb-Eval input:
(solve-puzzle)
;;; 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
(solve-puzzle)

入力に疲れた。

4.43

(define (solve-puzzle2)
  (let ((barnacle '(melissa gabrielle))
        (moore '(mary lorna))
        (hall (list (amb 'gabrielle 'lorna) 'rosalind))
        (downing (list (amb 'gabrielle 'lorna 'rosalind) 'melissa))
        (parker (list (amb 'gabrielle 'lorna 'rosalind) 'mary)))
    (require
     (distinct? (map daughter (list hall downing parker))))
    (require
     (eq? (yacht (car (filter (lambda (x) (eq? (daughter x) 'gabrielle))
                              (list hall downing parker))))
          (daughter parker)))
    (list (list 'barnacle barnacle)
          (list 'moore moore)
          (list 'hall hall)
          (list 'downing downing)
          (list 'parker parker))))

自分で推論できるところはいれちゃいました。実行すると、

;;; Amb-Eval input:
(solve-puzzle2)
;;; Starting a new problem 
;;; Amb-Eval value:
((barnacle (melissa gabrielle)) (moore (mary lorna)) (hall (gabrielle rosalind)) (downing (lorna melissa)) (parker (rosalind mary)))

;;; Amb-Eval input:
try-again
;;; There are no more values of
(solve-puzzle2)

となります。だからLornaの父親はDowningですね。
次にMaryがMooreの娘だと分からない場合は、次のように書けます。

(define (solve-puzzle2)
  (let ((barnacle '(melissa gabrielle))
        (moore (list (amb 'gabrielle 'rosalind 'mary) 'lorna))
        (hall (list (amb 'gabrielle 'lorna 'mary) 'rosalind))
        (downing (list (amb 'gabrielle 'lorna 'rosalind 'mary) 'melissa))
        (parker (list (amb 'gabrielle 'lorna 'rosalind) 'mary)))
    (require
     (distinct? (map daughter (list moore hall downing parker))))
    (require
     (eq? (yacht (car (filter (lambda (x) (eq? (daughter x) 'gabrielle))
                              (list moore hall downing parker))))
          (daughter parker)))
    (list (list 'barnacle barnacle)
          (list 'moore moore)
          (list 'hall hall)
          (list 'downing downing)
          (list 'parker parker))))

;;; Amb-Eval input:
(solve-puzzle2)
;;; Starting a new problem 
;;; Amb-Eval value:
((barnacle (melissa gabrielle)) (moore (gabrielle lorna)) (hall (mary rosalind)) (downing (rosalind melissa)) (parker (lorna mary)))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((barnacle (melissa gabrielle)) (moore (mary lorna)) (hall (gabrielle rosalind)) (downing (lorna melissa)) (parker (rosalind mary)))

;;; Amb-Eval input:
try-again
;;; There are no more values of
(solve-puzzle2)

問題4.44

やりません。

今日はここまで。結構頑張った。