SICP 問題 4.75

指定した質問を満足する項目がデータベースに一つしかないときに成功する特殊形式uniqueの実装．

;; streamの個数を調べる．
(define (stream-length s)
  (let iter ((stream s)
             (count 0))
    (if (stream-null? stream)
        count
        (iter (stream-cdr stream) (+ count 1)))))

(define (unique-query exps) (car exps))

(define (uniquely-asserted contents frame-stream)
  (stream-flatmap
    (lambda (frame)
      (let ((result (qeval (unique-query contents)
                           (singleton-stream frame))))
        (if (and (not (stream-null? result))
                 (= (stream-length result) 1))
            result
            the-empty-stream)))
    frame-stream))

(put 'unique 'qeval uniquely-asserted)

test

;;; Query input:
(unique (job ?x (computer wizard)))

;;; Query result:
(unique (job (Bitdiddle Ben) (computer wizard)))

;;; Query input:
(and (job ?x ?j)
     (unique (job ?anyone ?j)))

;;; Query result:
(and (job (Aull DeWitt) (administration secretary))
     (unique (job (Aull DeWitt) (administration secretary))))
(and (job (Cratchet Robert) (accounting scrivener))
     (unique (job (Cratchet Robert) (accounting scrivener))))
(and (job (Scrooge Eben) (accounting chief accountant))
     (unique (job (Scrooge Eben) (accounting chief accountant))))
(and (job (Warbucks Oliver) (administration big wheel))
     (unique (job (Warbucks Oliver) (administration big wheel))))
(and (job (Reasoner Louis) (computer programmer trainee))
     (unique (job (Reasoner Louis) (computer programmer trainee))))
(and (job (Tweakit Lem E) (computer technician))
     (unique (job (Tweakit Lem E) (computer technician))))
(and (job (Bitdiddle Ben) (computer wizard))
     (unique (job (Bitdiddle Ben) (computer wizard))))