Serendip

Web Studio

問題4.42

amb 評価器に or が無かったので追加する。

(define (analyze exp)
  (cond ((self-evaluating? exp)
        ;; 省略
        ((or? exp) (analyze (or->if exp)))
        ;; 省略
        (else
          (error "Unknown expression type -- ANALYZE" exp))))

(define (or? exp) (tagged-list? exp 'or))

(define (or-clauses exp) (cdr exp))

(define (or-first-exp exp) (car exp))

(define (or-rest-exps exp) (cdr exp))

(define (or->if exp)
  (expand-or-clauses (or-clauses exp)))

(define (expand-or-clauses clauses)
  (if (null? clauses)
      'false
      (let ((first (or-first-exp clauses))
            (rest (or-rest-exps clauses)))
           (make-if first
                    first
                    (expand-or-clauses rest)))))

「嘘つき」パズルを解く手続き liar-puzzle

(define (liar-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 (= kitty 2) (= betty 3)))
       (require (or (= ethel 1) (= joan 2)))
       (require (or (= joan 3) (= ethel 5)))
       (require (or (= kitty 2) (= mary 4)))
       (require (or (= mary 4) (= betty 1)))
       (list (list 'betty betty)
             (list 'ethel ethel)
             (list 'joan joan)
             (list 'kitty kitty)
             (list 'mary mary))))

実行結果

あれ？ kitty 2番、mary 4番の組み合わせができてしまった。

;;; Amb-Eval input:
(liar-puzzle)

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

;;; Amb-Eval input:
try-again

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

;;; Amb-Eval input:
try-again

;;; There are no more values of
(liar-puzzle)

よく考えると、or だけでは排他的に条件を作ることができなかった。
and と組み合わせて作り直す。
amb 評価器には and が無かったので追加する。

(define (analyze exp)
  (cond ((self-evaluating? exp)
         ;; 省略
        ((and? exp) (analyze (and->if exp)))
         ;; 省略
        (else
          (error "Unknown expression type -- ANALYZE" exp))))

(define (and? exp) (tagged-list? exp 'and))

(define (and-clauses exp) (cdr exp))

(define (and-first-exp exp) (car exp))

(define (and-rest-exps exp) (cdr exp))

(define (and->if exp)
  (expand-and-clauses (and-clauses exp)))

(define (expand-and-clauses clauses)
  (define (expand-and-iter clauses result)
    (if (null? clauses)
        result
        (let ((first (and-first-exp clauses))
              (rest (and-rest-exps clauses)))
             (make-if first
                 (expand-and-iter rest first)
                 'false))))
  (if (null? clauses)
      'true
      (expand-and-iter clauses '())))

「嘘つき」パズルを解く手続き liar-puzzle

(define (xor a b)
  (or (and a (not b)) (and (not a) b)))

(define (liar-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 (xor (= kitty 2) (= betty 3)))
       (require (xor (= ethel 1) (= joan 2)))
       (require (xor (= joan 3) (= ethel 5)))
       (require (xor (= kitty 2) (= mary 4)))
       (require (xor (= mary 4) (= betty 1)))
       (list (list 'betty betty)
             (list 'ethel ethel)
             (list 'joan joan)
             (list 'kitty kitty)
             (list 'mary mary))))

実行結果

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

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る