SICP 4.3 Schemeの変形 - 非決定計算 ex4.35 から ex4.44まで
SICP 4.3の非決定計算に入りました。
ここからambという新しい特殊形式が導入されます。
ambの引数に取った値のどれか一つ返すようです。
実装については4.3.3 amb評価器に入るまでお預けです。
requireとか継続使わないと実装できない気がしますが、どうやって実装するのか楽しみです。
さて、ambを使って慣れるのがこの単元の目的のようですが、MIT-schemeじゃambが無いみたいなのでコード書いても実行出来ません。
ここで書いた答えが正しいかどうかわかりませんが、
とりあえず気にせずにやっていく事にしました。
4.3.1 ambと探索
ex.4.35
こんな感じだと思います。
(define (an-integer-between low high) (require (< low high)) (amb low (an-integer-between (+ low 1) high)))
ex.4.36
an-integer-fromにすると(i**2+j**2)**0.5が整数でない場合、
kの値が整数のため永久にrequireを満たすことが出来ない。
ex.4.37
Benの方がambで値を探索する回数が少ないので効率がよい。
4.3.2 非決定性プログラムの例
ex.4.38
手で全条件を書いていきました。
解は5組あると思います。
この問題の意図は手でやるとすごいめんどくさいってのを体感するって事なのかと思いますのであえてやってみました。
結果は以下の通り。
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
ex4.39
先に値の組み合わせを全て探索するので、requireの順番を変更しても変わらない。
benのex4.37のようにしないと効率は上がらないですね。
ex4.40
実行して動作を確認していませんが、こんな感じだと思います。
(define (remove-elements l . elements) (let loop ((l l) (elements elements)) (cond ((null? elements) l) ((loop (remove (lambda (arg) (= arg (car elements))) l) (cdr elements)))))) (define (multiple-dweling) (let ((floors '(1 2 3 4 5))) (let ((baker (an-element-of (remove-elements floors)))) (require (not (= baker 5))) (let ((cooper (an-element-of (remove-elements floors baker)))) (require (not (= cooper 1))) (let ((fletcher (an-element-of (remove-elements floors baker cooper)))) (require (not (= fletcher 5))) (require (not (= fletcher 1))) (require (not (= (abs (- fletcher cooper))))) (let ((miller (an-element-of (remove-elements floors baker cooper fletcher)))) (require (not (> miller cooper))) (let ((smith (an-element-of (remove-elements floors baker cooper fletcher miller)))) (require (not (= abs (- smith fletcher)))))))))))
ex4.41
全ての組み合わせのリストを生成し、条件に合う要素だけをフィルターにかけて取り出しました。
結構長くなってしまいましたが、こんな感じに実装できると思います。
(define (integers high) (let loop ((n 1)) (if (= n high) (cons n '()) (cons n (loop (+ n 1)))))) (define (make-seed max) (let loop ((n 1)) (if (= n max) (cons `(,n) '()) (cons `(,n) (loop (+ n 1)))))) (define (add-ints ints cells) (if (null? ints) '() (append (map (lambda (x) (cons (car ints) x)) cells) (add-ints (cdr ints) cells)))) (define (make-all-paterns max) (let ((nums (integers max))) (let loop ((n max)) (if (= n 1) (make-seed max) (add-ints nums (loop (- n 1))))))) (define (distinct? items) (cond ((null? items) #t) ((null? (cdr items)) #t) ((member (car items) (cdr items)) #f) (else (distinct? (cdr items))))) (define (index-of i l) (cond ((null? l) '()) ((= i 0) (car l)) (else (index-of (- i 1) (cdr l))))) (define baker 0) (define cooper 1) (define fletcher 2) (define miller 3) (define smith 4) (define highest 5) (define lowest 1) (define floor-patterns (filter (lambda (es) (distinct? es)) (make-all-paterns highest))) (define (baker-req l) (cond ((null? l) #f) ((= (index-of baker l) highest) #f) (else #t))) (define (cooper-req l) (cond ((null? l) #f) ((= (index-of cooper l) lowest) #f) (else #t))) (define (fletcher-req l) (cond ((null? l) #f) ((= (index-of fletcher l) lowest) #f) ((= (index-of fletcher l) highest) #f) (else (let ((fletcher-floor (index-of fletcher l)) (cooper-floor (index-of cooper l))) (> (abs (- fletcher-floor cooper-floor)) 1))))) (define (miller-req l) (if (null? l) #f (let ((miller-floor (index-of miller l)) (cooper-floor (index-of cooper l))) (> miller-floor cooper-floor)))) (define (smith-req l) (if (null? l) #f (let ((smith-floor (index-of smith l)) (fletcher-floor (index-of fletcher l))) (> (abs (- smith-floor fletcher-floor)) 1)))) (define (all-req l) (and (baker-req l) (cooper-req l) (fletcher-req l) (miller-req l) (smith-req l))) (define (38req l) (and (baker-req l) (cooper-req l) (fletcher-req l) (miller-req l))) (define (println . es) (let loop ((es es)) (if (null? es) (newline) (begin (display (car es)) (display " \t") (loop (cdr es)))))) (define (print-ex4.41 l) (if (null? l) (newline) (begin (println 'baker (index-of baker (car l))) (println 'cooper (index-of cooper (car l))) (println 'fletcher (index-of fletcher (car l))) (println 'miller (index-of miller (car l))) (println 'smith (index-of smith (car l))) (newline) (print-ex4.41 (cdr l))))) (print-ex4.41 (filter all-req floor-patterns))
こんな結果が得られます。
baker 3 cooper 2 fletcher 4 miller 5 smith 1
ex4.42
ambが無いので4.41のように全組み合わせを作ってフィルターにかけました。
(define betty 0) (define ethel 1) (define joan 2) (define kitty 3) (define mary 4) (define worst 5) (define ranking-patterns (filter (lambda (es) (not (distinct? es))) (make-all-paterns worst))) (define-syntax letter-check (syntax-rules () ((_ ranking name0 rank0 name1 rank1) (let ((info0 (= rank0 (index-of name0 ranking))) (info1 (= rank1 (index-of name1 ranking)))) (or (and info0 (not info1)) (and (not info0) info1)))))) (define (betty-letter l) (letter-check l betty 3 kitty 2)) (define (ethel-letter l) (letter-check l ethel 1 joan 2)) (define (joan-letter l) (letter-check l joan 3 ethel 5)) (define (kitty-letter l) (letter-check l kitty 2 mary 4)) (define (mary-letter l) (letter-check l mary 4 betty 1)) (define (all-letter l) (and (betty-letter l) (ethel-letter l) (joan-letter l) (kitty-letter l) (mary-letter l))) (define (print-ex4.42 l) (if (null? l) (newline) (begin (println 'betty (index-of betty (car l))) (println 'ethel (index-of ethel (car l))) (println 'joan (index-of joan (car l))) (println 'kitty (index-of kitty (car l))) (println 'mary (index-of mary (car l))) (newline) (print-ex4.42 (cdr l))))) (print-ex4.42 (filter all-letter ranking-patterns))
こんな結果が得られました。
betty 3 ethel 5 joan 2 kitty 1 mary 4
ex4.43
実行していないのですが、たぶんこんな感じで実装できると思います。
足りない条件があるかもしれません。
(define (lorna-father) (let* ((daughters '(mary gabrielle lorna rosalind melissa)) (moore (an-element-of doughters))) (require (equal? moore 'mary)) (let* ((doughters (delete moore doughters)) (downing (an-element-of doughters))) (require (not (equal? downing 'melissa))) (let* ((doughters (delete downing doughters)) (hall (an-element-of doughters))) (require (not (equal? hall 'roalind))) (let* ((doughters (delete hall doughters)) (barnacle (an-element-of doughters))) (require (equal? barnacle 'melissa))) (let* ((doughters (delete barnacle doughters)) (paker (an-element-of doughters))) (require (not (distinct? `(,moore ,downing ,hall ,barnacle ,paker)))) `((moore . ,moore) (downing . ,downing) (hall . ,hall) (barnacle . ,barnacle) (melissa . ,melissa)))))))
ex4.44
これもこんな感じだと思います。safe?は実装していませんがクイーンを置けるかどうか判定する関数のつもりです。
(define (queens board-size) (let loop ((n 1) (rows (integers board-size)) (ret '())) (if (= n board-size) ret (let ((row (an-element-of rows))) (require (safe? row ret)) (loop (+ n 1) (delete row rows) (cons row ret))))))
