Todo
4.50
Exercise 4.35
(define (an-integer-between low high)
(require (<= low high))
(amb low (an-integer-between (+ low 1) high)))
(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)))
(require (= (+ (* i i) (* j j)) (* k k)))
(display (list i j k)) (newline)
(amb)))))
;;;;;Amb-Eval input:
;;(a-pythagorean-triple-between 1 20)
;;;;; Starting a new problem
;;(3 4 5)
;;(5 12 13)
;;(6 8 10)
;;(8 15 17)
;;(9 12 15)
;;(12 16 20)
;;;;; There are no more values of
;;(a-pythagorean-triple-between 1 20)
Exercise 4.36
;; amb は search 戦略として depth first search を使用しているため、
;; 単純に an-integer-between を an-integer-starting-from に置換え
;; たのでは、特定の変数の値が大きくなるだけとなり上手く行かない。
;; ex3.69 では interleave を使って特定の stream だけが大きくなるの
;; を防いでいた。
(define (a-pythagorean-triple-from low)
(let ((k (an-integer-starting-from low)))
(let ((j (an-integer-between low k)))
(let ((i (an-integer-between low j)))
(require (= (+ (* i i) (* j j)) (* k k)))
(list i j k)))))
;;(a-pythagorean-triple-from 20)
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;(20 21 29)
;;;;;Amb-Eval input:
;;try-again
;;;;;Amb-Eval value:
;;(21 28 35)
Exercise 4.37
;; 確認する組合わせの数は n=high-low+1 とすると
;; ex4.35 では n*n*n
;; Ben版 では n*n
;; で Ben は正しいといえる。
;; sqrt をとった値を整数かどうか判定するのはちょっと危ない気もするが、
;; 現実的には問題がない？
Exercise 4.38
(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 (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(display (list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))
(newline)
(amb)))
;;;;;Amb-Eval input:
;;(multiple-dwelling)
;;;;; Starting a new problem
;;((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;;((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
;;((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
;;((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
;;;;; There are no more values of
;;(multiple-dwelling)
Exercise 4.39
;; distinct? の位置を変えて時間を計測。
;; 「大きな変化はない」という結果になった。
(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 ; (a)
(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 ; (b)
(distinct? (list baker cooper fletcher miller smith)))
(require (not (= (abs (- fletcher cooper)) 1)))
#;(require ; (c)
(distinct? (list baker cooper fletcher miller smith)))
(display (list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))
(newline)
(amb)))
;;;;; Starting a new problem (a)
;;((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;; :
;;#:real-time :4.229
;;#:user-time :4.2159999999999975
;;#:system-time :0.0
;;;;; Starting a new problem (b)
;;((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;; :
;;#:real-time :4.277
;;#:user-time :4.266
;;#:system-time :0.010000000000000009
;;;;; Starting a new problem (c)
;;((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;; :
;;#:real-time :4.254
;;#:user-time :4.246
;;#:system-time :0.0
Exercise 4.40
(define (multiple-dwelling)
(let ((cooper (amb 2 3 4))
(miller (amb 3 4 5)))
(require (> miller cooper))
(let ((fletcher (amb 2 3 4)))
(require (not (= (abs (- fletcher cooper)) 1)))
(let ((beker (amb 1 2 3 4))
(smith (amb 1 2 3 4 5)))
(require
(distinct? (list beker cooper fletcher miller smith)))
(display (list (list 'beker beker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))
(newline)
(amb)))))
;;;;; Starting a new problem
;;((beker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;; :
;;#:real-time :0.331
;;#:user-time :0.33099999999999996
;;#:system-time :0.0
;;;;;Amb-Eval value:
;;#<undef>
(define (multiple-dwelling2)
(let ((cooper (amb 1 2 3 4 5)))
(require (not (= cooper 1)))
(let ((miller (amb 1 2 3 4 5)))
(require (> miller cooper))
(let ((fletcher (amb 1 2 3 4 5)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(let ((beker (amb 1 2 3 4 5)))
(require (not (= beker 5)))
(let ((smith (amb 1 2 3 4 5)))
(require
(distinct? (list beker cooper fletcher miller smith)))
(display (list (list 'beker beker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))
(newline)
(amb)))))))
;;#:real-time :0.39
;;#:user-time :0.3809999999999998
;;#:system-time :0.0
;;;;;Amb-Eval value:
;;#<undef>
(define (multiple-dwelling3)
(let ((cooper (amb 2 3 4))
(miller (amb 3 4 5))
(fletcher (amb 2 3 4))
(beker (amb 1 2 3 4))
(smith (amb 1 2 3 4 5)))
(require
(distinct? (list beker cooper fletcher miller smith)))
(require (> miller cooper))
(require (not (= (abs (- fletcher cooper)) 1)))
(display (list (list 'beker beker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))
(newline)
(amb)))
;;#:real-time :0.798
;;#:user-time :0.8009999999999997
;;#:system-time :0.0
;;;;;Amb-Eval value:
;;#<undef>
Exercise 4.41
;; ２章でやった組合せのリストを得る premutations。
;; 今見ても難しい。
(define (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (flatmap proc seq)
(accumulate append '() (map proc seq)))
(define (permutations s)
(if (null? s)
(list '())
(flatmap (lambda (x)
(map (lambda (p) (cons x p))
(permutations (remove x s))))
s)))
(define (remove item sequence)
(filter (lambda (x) (not (= x item)))
sequence))
;;
(define (baker set) (list-ref set 0))
(define (cooper set) (list-ref set 1))
(define (fletcher set) (list-ref set 2))
(define (miller set) (list-ref set 3))
(define (smith set) (list-ref set 4))
(define sets (permutations (list 1 2 3 4 5)))
(define (filter-p set)
(and (not (= (baker set) 5))
(not (= (cooper set) 1))
(not (= (fletcher set) 5))
(not (= (fletcher set) 1))
(> (miller set) (cooper set))
; (not (= (abs (- (smith set) (fletcher set))) 1))
(not (= (abs (- (fletcher set) (cooper set))) 1))))
(define (multiple-dwelling)
(map
(lambda (set)
(display (list (list 'baker (baker set))
(list 'cooper (cooper set))
(list 'fletcher (fletcher set))
(list 'miller (miller set))
(list 'smith (smith set))))
(newline))
(filter filter-p sets)))
;;gosh> (multiple-dwelling)
;;((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;;((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
;;((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
;;((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
;;(#<undef> #<undef> #<undef> #<undef> #<undef>)
Exercise 4.42
(define (require-Lair a b)
(if a
(require (not b))
(require b)))
(define (Lairs)
(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-Lair (= Kitty 2) (= Betty 3))
(require-Lair (= Ethel 1) (= Joan 2))
(require-Lair (= Joan 3) (= Ethel 5))
(require-Lair (= Kitty 2) (= Mary 4))
(require-Lair (= Mary 4) (= Betty 1))
(display
(list (list 'Betty Betty) (list 'Ethel Ethel) (list 'Joan Joan)
(list 'Kitty Kitty) (list 'Mary Mary))
)
(newline)
(amb)))
;;;;;Amb-Eval input:
;;(Lairs)
;;;;; Starting a new problem
;;((Betty 3) (Ethel 5) (Joan 2) (Kitty 1) (Mary 4))
;;;;; There are no more values of
;;(Lairs)
Exercise 4.43
;; Lorna の父親は Colonel Downing
(define (yacht)
;; father daughter yacht
(let ((Moore (cons 'Ann 'Lorna))
(Downing (cons (amb 'Gabrielle 'Lorna 'Rosalind) 'Melissa))
(Hall (cons (amb 'Gabrielle 'Lorna) 'Rosalind))
(Hood (cons 'Melissa 'Gabrielle))
(Parker (cons (amb 'Gabrielle 'Lorna 'Rosalind) 'Ann)))
(let ((alist (list Moore Hood Hall Downing Parker)))
(require (distinct? (map car alist)))
(require (eq? (cdr (assq 'Gabrielle alist)) (car Parker)))
(display
(list (list 'Moore Moore) (list 'Hood Hood) (list 'Hall Hall)
(list 'Downing Downing) (list 'Parker Parker)))
(newline))
(amb)))
;;;;; Starting a new problem
;;((Moore (Ann . Lorna)) (Hood (Melissa . Gabrielle)) (Hall (Gabrielle . Rosalind)) (Downing (Lorna . Melissa)) (Parker (Rosalind . Ann)))
;;;;; There are no more values of
;; Moore の娘が Ann という条件を外すと組合せは２通りとなる。
(define (yacht2)
;; father daughter yacht
(let ((Moore (cons (amb 'Gabrielle 'Rosalind 'Ann) 'Lorna))
(Downing (cons (amb 'Gabrielle 'Lorna 'Rosalind 'Ann) 'Melissa))
(Hall (cons (amb 'Gabrielle 'Lorna 'Ann) 'Rosalind))
(Hood (cons 'Melissa 'Gabrielle))
(Parker (cons (amb 'Gabrielle 'Lorna 'Rosalind) 'Ann)))
(let ((alist (list Moore Hood Hall Downing Parker)))
(require (distinct? (map car alist)))
(require (eq? (cdr (assq 'Gabrielle alist)) (car Parker)))
(display
(list (list 'Moore Moore) (list 'Hood Hood) (list 'Hall Hall)
(list 'Downing Downing) (list 'Parker Parker)))
(newline))
(amb)))
;;;;; Starting a new problem
;;((Moore (Gabrielle . Lorna)) (Hood (Melissa . Gabrielle)) (Hall (Ann . Rosalind)) (Downing (Rosalind . Melissa)) (Parker (Lorna . Ann)))
;;((Moore (Ann . Lorna)) (Hood (Melissa . Gabrielle)) (Hall (Gabrielle . Rosalind)) (Downing (Lorna . Melissa)) (Parker (Rosalind . Ann)))
;;;;; There are no more values of
Exercise 4.44
;; リスト要素の引算
(define (-list list-a list-b)
(filter (lambda (x) (not (memq x list-b)))
list-a))
;; 追加されるカラムの斜め方向の安全性を確認する。
(define (attack? cols new-col)
(define (iter cols n)
(cond ((null? cols) #f)
((= (abs (- (car cols) new-col)) n) #t)
(else (iter (cdr cols) (- n 1)))))
(iter cols (length cols)))
;; 横方向の安全性をバックトラックを使わずに確認する版。
(define (8q-a)
(define rows (list 1 2 3 4 5 6 7 8))
(define board '())
(let ((col1 (amb 1 2 3 4)))
(set! board (list col1))
(let ((col2 (an-element-of (-list rows board))))
(require (not (attack? board col2)))
(set! board (list col1 col2))
(let ((col3 (an-element-of (-list rows board))))
(require (not (attack? board col3)))
(set! board (list col1 col2 col3))
(let ((col4 (an-element-of (-list rows board))))
(require (not (attack? board col4)))
(set! board (list col1 col2 col3 col4))
(let ((col5 (an-element-of (-list rows board))))
(require (not (attack? board col5)))
(set! board (list col1 col2 col3 col4 col5))
(let ((col6 (an-element-of (-list rows board))))
(require (not (attack? board col6)))
(set! board (list col1 col2 col3 col4 col5 col6))
(let ((col7 (an-element-of (-list rows board))))
(require (not (attack? board col7)))
(set! board (list col1 col2 col3 col4 col5 col6 col7))
(let ((col8 (an-element-of (-list rows board))))
(require (not (attack? board col8)))
(set! board (list col1 col2 col3 col4 col5 col6 col7 col8))
(display board)
(display " : ")
(display (map (lambda (x) (- 9 x)) board))
(newline)
(amb)
)))))))))
;;#:real-time :21.899
;;#:user-time :21.78200000000001
;;#:system-time :0.010000000000000009
;;;;;Amb-Eval value:
;;#<undef>
;; 横方向の安全性をバックトラックを逐次使って確認する版
(define (8q-b)
(define board '())
(let ((col1 (amb 1 2 3 4)))
(set! board (list col1))
(let ((col2 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col2 board)))
(require (not (attack? board col2)))
(set! board (list col1 col2))
(let ((col3 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col3 board)))
(require (not (attack? board col3)))
(set! board (list col1 col2 col3))
(let ((col4 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col4 board)))
(require (not (attack? board col4)))
(set! board (list col1 col2 col3 col4))
(let ((col5 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col5 board)))
(require (not (attack? board col5)))
(set! board (list col1 col2 col3 col4 col5))
(let ((col6 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col6 board)))
(require (not (attack? board col6)))
(set! board (list col1 col2 col3 col4 col5 col6))
(let ((col7 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col7 board)))
(require (not (attack? board col7)))
(set! board (list col1 col2 col3 col4 col5 col6 col7))
(let ((col8 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (cons col8 board)))
(require (not (attack? board col8)))
(set! board (list col1 col2 col3 col4 col5 col6 col7 col8))
(display board)
(display " : ")
(display (map (lambda (x) (- 9 x)) board))
(newline)
(amb)
)))))))))
;;#:real-time :33.231
;;#:user-time :33.048
;;#:system-time :0.019999999999999907
;;;;;Amb-Eval value:
;;#<undef>
;; 横方向・斜め方向の安全性をまとめてバックトラックで確認する版
(define (8q-c)
(define board '())
(let ((col1 (amb 1 2 3 4))
(col2 (amb 1 2 3 4 5 6 7 8))
(col3 (amb 1 2 3 4 5 6 7 8))
(col4 (amb 1 2 3 4 5 6 7 8))
(col5 (amb 1 2 3 4 5 6 7 8))
(col6 (amb 1 2 3 4 5 6 7 8))
(col7 (amb 1 2 3 4 5 6 7 8))
(col8 (amb 1 2 3 4 5 6 7 8)))
(require (distinct? (list col1 col2 col3 col4 col5 col5 col7 col8)))
(require (and (not (attack? (list col1) col2))
(not (attack? (list col1 col2) col3))
(not (attack? (list col1 col2 col3) col4))
(not (attack? (list col1 col2 col3 col4) col5))
(not (attack? (list col1 col2 col3 col4 col5) col6))
(not (attack? (list col1 col2 col3 col4 col5 col6) col7))
(not (attack? (list col1 col2 col3 col4 col5 col6 col7) col8))))
(set! board (list col1 col2 col3 col4 col5 col6 col7 col8))
(display board)
(display " : ")
(display (map (lambda (x) (- 9 x)) board))
(newline)
))
;;;;;Amb-Eval input:
;;(time (8q-c))
;;; Starting a new problem
;;#:real-time :15797.877
;;#:user-time :14527.22
;;#:system-time :0.5309999999999999
;;;Amb-Eval value:
;;#<undef>
Exercise 4.45
;; 文法用語が入ると見づらいので、元の単語だけ出力する。訳は？？？
(define (ex4.45)
(let ((s
(parse
'(the professor lectures to the student in the class with the cat))))
(display s)(newline)
(amb)))
;;;Amb-Eval input:
(ex4.45)
;;; Starting a new problem
((the professor) (((lectures (to (the student))) (in (the class))) (with (the cat))))
;猫と一緒にクラスで生徒に教える。
((the professor) ((lectures (to (the student))) (in ((the class) (with (the cat))))))
;猫のいるクラスで生徒に教える。
((the professor) ((lectures (to ((the student) (in (the class))))) (with (the cat))))
;猫と一緒にクラスの生徒に教える。
((the professor) (lectures (to (((the student) (in (the class))) (with (the cat))))))
;クラスの猫と一緒の生徒に教える。
((the professor) (lectures (to ((the student) (in ((the class) (with (the cat))))))))
;猫のいるクラスの生徒に教える。
;;; There are no more values of
(ex4.45)
Exercise 4.46
;;文法は、例えば
;;(define (parse-sentence)
;; (list 'sentence
;; (parse-noun-phrase)
;; (parse-verb-phrase)))
;;(define (parse-simple-noun-phrase)
;; (list 'simple-noun-phrase
;; (parse-word articles)
;; (parse-word nouns)))
;;のように句の並びで定義され句は語の並びで定義されている。
;;一方、文の解析は
;;(define (parse-word word-list)
;; (require (not (null? *unparsed*)))
;; (require (memq (car *unparsed*) (cdr word-list)))
;; (let ((found-word (car *unparsed*)))
;; (set! *unparsed* (cdr *unparsed*))
;; (list (car word-list) found-word)))
;;のように、文の最初から語を取り出し、それが文法により句、文を構成
;;するかどうかを確認している。
;;これは 先に読み出した語は、リスト中の先の式によって使われることを
;;前提とした方法となっている。
Exercise 4.47
;; 文が parse できる間は動作する。parse し尽くした状態で try-again
;; を入力すると loop となる。これは parse-varb-phrase が amb と再帰
;; に対し終了条件を持たない構造となっているから。
;; 一方 may-be-extend は extend がある場合に限り再帰を行っている。
(define (parse-verb-phrase)
(amb (parse-word verbs)
(list ;'verb=phrase
(parse-verb-phrase)
(parse-prepositional-phrase))))
;;;;;Amb-Eval input:
;;(parse '(the cat eats))
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;((the cat) eats)
;;;;;Amb-Eval input:
;;try-again --> loop
;;;;;Amb-Eval input:
;;(parse '(the cat eats in the class))
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;((the cat) (eats (in (the class))))
;;;;;Amb-Eval input:
;;try-again --> loop
;;;;;Amb-Eval input:
;;(parse '(the cat eats in the class with the student))
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;((the cat) (eats (in ((the class) (with (the student))))))
;;;;;Amb-Eval input:
;;try-again
;;;;;Amb-Eval value:
;;((the cat) ((eats (in (the class))) (with (the student))))
;;;;;Amb-Eval input:
;;try-again --> loop
;; こちらはすぐに loop
(define (parse-verb-phrase)
(amb (list ;'verb=phrase
(parse-verb-phrase)
(parse-prepositional-phrase))
(parse-word vervs)))
;;;;;Amb-Eval input:
;;(parse '(the cat eats))
;;;;; Starting a new problem
;; --> loop
Exercise 4.48
;; 形容詞を扱えるように拡張。副詞と重文は省略。
;; <simple-noun-phrase>::=<article><noun>
;; <adjective-noun-phrase>::=<article><adjective>+<noun>
;; <simple/adjective-noun-phrase>::=<simple-noun-phrase>|<adjective-noun-phrase>
;; <noun-phrase>::=<simple/adjective-noun-phrase><prepositional-phrase>*
(define adjectives '(adjective small big black white))
(define (parse-simple/adjective-noun-phrase)
(amb
(list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns))
(list 'adjective-noun-phrase
(parse-word articles)
(parse-adjectives)
(parse-word nouns))))
(define (parse-adjectives)
(define (iter adjs)
(amb adjs
(iter (append adjs (list (parse-word adjectives))))))
(iter (list (parse-word adjectives))))
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb noun-phrase
(maybe-extend (list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-simple/adjective-noun-phrase)))
;;;;;Amb-Eval input:
;;(parse '(the cat eats))
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;(sentence (simple-noun-phrase (article the) (noun cat)) (verb eats))
;;;;;Amb-Eval input:
;;(parse '(the small cat eats))
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;(sentence (adjective-noun-phrase (article the) ((adjective small)) (noun cat)) (verb eats))
;;;;;Amb-Eval input:
;;(parse '(the small white cat eats))
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;(sentence (adjective-noun-phrase (article the) ((adjective small) (adjective white)) (noun cat)) (verb eats))
Exercise 4.49
;; 解答になっているのかな？
(define (parse-word word-list)
#;(list (car word-list)
(list-ref word-list (+ (random (- (length word-list) 1)) 1)))
(list-ref word-list (+ (random (- (length word-list) 1)) 1))
)
(define c 1)
(define (generate-6-sentences)
(display (parse '())) (newline)
(if (>= c 6)
'done
(begin (permanent-set! c (+ c 1)) (amb))))
;;;;;Amb-Eval input:
;;(generate-6-sentences)
;;;;; Starting a new problem
;;((a student) sleeps)
;;((a student) (sleeps (with (the class))))
;;((a student) ((sleeps (with (the class))) (with (the cat))))
;;((a student) (((sleeps (with (the class))) (with (the cat))) (to (the cat))))
;;((a student) ((((sleeps (with (the class))) (with (the cat))) (to (the cat))) (to (the cat))))
;;((a student) (((((sleeps (with (the class))) (with (the cat))) (to (the cat))) (to (the cat))) (with (a class))))
;;;;;Amb-Eval value:
;;done
Exercise 4.50
Exercise 4.51
;; analyze に追加
((passignment? exp) (analyze-passignment exp))
;;
(define (passignment? exp) (tagged-list? exp 'permanent-set!))
(define (analyze-passignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(set-variable-value! var val env)
(succeed 'ok fail2)))
fail)))
;; set! なら出力される count は常に１
(define (ex4_51)
(define count 0)
(let ((x (an-element-of '(a b c)))
(y (an-element-of '(a b c))))
(permanent-set! count (+ count 1))
;;(set! count (+ count 1))
(require (not (eq? x y)))
(display (list x y count)) (newline)
(amb)))
;;;;;Amb-Eval input:
;;(ex4_51)
;;;;; Starting a new problem
;;(a b 2)
;;(a c 3)
;;(b a 4)
;;(b c 6)
;;(c a 7)
;;(c b 8)
;;;;; There are no more values of
;;(ex4_51)
Exercise 4.52
;; analyze に追加
((if-fail? exp) (analyze-if-fail exp))
;;
(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (if-fail-usual exp) (cadr exp))
(define (if-fail-fail exp) (caddr exp))
(define (analyze-if-fail exp)
(let ((uproc (analyze (if-fail-usual exp)))
(fproc (analyze (if-fail-fail exp))))
(lambda (env succeed fail)
(uproc env
(lambda (u-value fail2)
(succeed u-value fail2))
(lambda ()
(fproc env succeed fail))))))
;
(define (ex4_52a)
(if-fail (let ((x (an-element-of '(1 3 5))))
(require (even? x))
x)
'all-odd))
(define (ex4_52b)
(if-fail (let ((x (an-element-of '(1 3 5 8))))
(require (even? x))
x)
'all-odd))
;;;;;Amb-Eval input:
;;(ex4_52a)
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;all-odd
;;;;;Amb-Eval input:
;;(ex4_52b)
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;8
Exercise 4.53
(define (ex4_53)
(let ((pairs '()))
(if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
(permanent-set! pairs (cons p pairs))
(amb))
pairs)))
;;;;;Amb-Eval input:
;;(ex4_53)
;;;;; Starting a new problem
;;;;;Amb-Eval value:
;;((8 35) (3 110) (3 20))
Exercise 4.54
;; analyze に追加
((sf-require? exp) (amb-analyze-sf-require exp))
;;
(define (sf-require? exp) (tagged-list? exp 'sf-require))
(define (require-predicate exp) (cadr exp))
(define (analyze-sf-require exp)
(let ((pproc (analyze (require-predicate exp))))
(lambda (env succeed fail)
(pproc env
(lambda (pred-value fail2)
(if (not pred-value)
(fail2)
(succeed 'ok fail2)))
fail))))
;;
(define (prime-sum-pair-for-ex4_54 list1 list2)
(define (an-element-of items)
(sf-require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
(let ((a (an-element-of list1))
(b (an-element-of list2)))
(sf-require (prime? (+ a b)))
(list a b)))
(define (ex4_54a)
(display (prime-sum-pair-for-ex4_54 '(1 3 5 8) '(20 35 110)))
(newline)
(amb))
(define (ex4_54b)
(display (prime-sum-pair '(1 3 5 8) '(20 35 110)))
(newline)
(amb))
;;;;;Amb-Eval input:
;;(ex4_54a)
;;;;; Starting a new problem
;;(3 20)
;;(3 110)
;;(8 35)
;;;;; There are no more values of
;;(ex4_54a)
最終更新：2009年03月01日 18:34
