;; 使い方 以下のプログラムを(load "プログラム")し(query-driver-loop)を実行する

(define (stream-map proc s)
  (if (stream-null? s)
      the-empty-stream
      (cons-stream (proc (stream-car s))
                   (stream-map proc (stream-cdr s)))))

(define (stream-for-each proc s)
  (if (stream-null? s)
      'done
      (begin (proc (stream-car s))
             (stream-for-each proc (stream-cdr s)))))

(define (display-stream s)
  (stream-for-each display-line s))

(define (display-line x)
  (newline)
  (display x))

(define (stream-append s1 s2)
  (if (stream-null? s1)
      s2
      (cons-stream (stream-car s1)
                   (stream-append (stream-cdr s1) s2))))

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  false))
            false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)    
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))

;; 4.4.4.1 駆動ループと具体化
(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define input-prompt ";;; Query input:")
(define output-prompt ";;; Query results:")

(define (query-driver-loop)
  (prompt-for-input input-prompt)
  (let ((q (query-syntax-process (read))))
    (cond ((assertion-to-be-added? q)
           (add-rule-or-assertion! (add-assertion-body q))
           (newline)
           (display "Assertion added to data base.")
           (query-driver-loop))
          (else
           (newline)
           (display output-prompt)
           (display-stream
            (stream-map
             (lambda (frame)
               (instantiate q
                            frame
                            (lambda (v f)
                              (contract-question-mark v))))
             (qeval q (singleton-stream '()))))
           (query-driver-loop)))))

(define (instantiate exp frame unbound-var-handler)
  (define (copy exp)
    (cond ((var? exp)
           (let ((binding (binding-in-frame exp frame)))
             (if binding
                 (copy (binding-value binding))
                 (unbound-var-handler exp frame))))
          ((pair? exp)
           (cons (copy (car exp)) (copy (cdr exp))))
          (else exp)))
  (copy exp))

;;4.4.4.2 評価器
(define (qeval query frame-stream)
  (let ((qproc (get (type query) 'qeval)))
    (if qproc
        (qproc (contents query) frame-stream)
        (simple-query query frame-stream))))

(define (simple-query query-pattern frame-stream)
  (stream-flatmap
   (lambda (frame)
     (stream-append-delayed
      (find-assertions query-pattern frame)
      (delay (apply-rules query-pattern frame))))
   frame-stream))

(define (conjoin conjuncts frame-stream)
  (if (empty-conjunction? conjuncts)
      frame-stream
      (conjoin (rest-conjuncts conjuncts)
               (qeval (first-conjunct conjuncts)
                      frame-stream))))

(put 'and 'qeval conjoin)

(define (disjoin disjuncts frame-stream)
  (if (empty-disjunction? disjuncts)
      the-empty-stream
      (interleave-delayed
       (qeval (first-disjunct disjuncts) frame-stream)
       (delay (disjoin (rest-disjuncts disjuncts)
                       frame-stream)))))

(put 'or 'qeval disjoin)

(define (negate operands frame-stream)
  (stream-flatmap
   (lambda (frame)
     (if (stream-null? (qeval (negated-query operands)
                              (singleton-stream frame)))
         (singleton-stream frame)
         the-empty-stream))
   frame-stream))

(put 'not 'qeval negate)

(define (lisp-value call frame-stream)
  (stream-flatmap
   (lambda (frame)
     (if (execute
          (instantiate
           call
           frame
           (lambda (v f)
             (error "Unknown pat var -- LISP-VALUE" v))))
         (singleton-stream frame)
         the-empty-stream))
   frame-stream))

(put 'lisp-value 'qeval lisp-value)

(define (execute exp)
  (apply (eval (predicate exp) user-initial-environment)
         (args exp)))

(define (always-true ignore frame-stream) frame-stream)

(put 'always-true 'qeval always-true)

;;4.4.4.3 パターンマッチにより表明を見つける
(define (find-assertions pattern frame)
  (stream-flatmap (lambda (datum)
                    (check-an-assertion datum pattern frame))
                  (fetch-assertions pattern frame)))

(define (check-an-assertion assertion query-pat query-frame)
  (let ((match-result
         (pattern-match query-pat assertion query-frame)))
    (if (eq? match-result 'failed)
        the-empty-stream
        (singleton-stream match-result))))

(define (pattern-match pat dat frame)
  (cond ((eq? frame 'failed) 'failed)
        ((equal? pat dat) frame)
        ((var? pat) (extend-if-consistent pat dat frame))
        ((and (pair? pat) (pair? dat))
         (pattern-match (cdr pat)
                        (cdr dat)
                        (pattern-match (car pat)
                                       (car dat)
                                       frame)))
        (else 'failed)))

(define (extend-if-consistent var dat frame)
  (let ((binding (binding-in-frame var frame)))
    (if binding
        (pattern-match (binding-value binding) dat frame)
        (extend var dat frame))))

;;4.4.4.4 規則とユニフィケーション
(define (apply-rules pattern frame)
  (stream-flatmap (lambda (rule)
                    (apply-a-rule rule pattern frame))
                  (fetch-rules pattern frame)))

(define (apply-a-rule rule query-pattern query-frame)
  (let ((clean-rule (rename-variables-in rule)))
    (let ((unify-result
           (unify-match query-pattern
                        (conclusion clean-rule)
                        query-frame)))
      (if (eq? unify-result 'failed)
          the-empty-stream
          (qeval (rule-body clean-rule)
                 (singleton-stream unify-result))))))

(define (rename-variables-in rule)
  (let ((rule-application-id (new-rule-application-id)))
    (define (tree-walk exp)
      (cond ((var? exp)
             (make-new-variable exp rule-application-id))
            ((pair? exp)
             (cons (tree-walk (car exp))
                   (tree-walk (cdr exp))))
            (else exp)))
    (tree-walk rule)))

(define (unify-match p1 p2 frame)
  (cond ((eq? frame 'failed) 'failed)
        ((equal? p1 p2) frame)
        ((var? p1) (extend-if-possible p1 p2 frame))
        ((var? p2) (extend-if-possible p2 p1 frame))
        ((and (pair? p1) (pair? p2))
         (unify-match (cdr p1)
                      (cdr p2)
                      (unify-match (car p1)
                                   (car p2)
                                   frame)))
        (else 'failed)))

(define (extend-if-possible var val frame)
  (let ((binding (binding-in-frame var frame)))
    (cond (binding
           (unify-match
            (binding-value binding) val frame))
          ((var? val)
           (let ((binding (binding-in-frame val frame)))
             (if binding
                 (unify-match
                  var (binding-value binding) frame)
                 (extend var val frame))))
          ((depends-on? val var frame)
           'failed)
          (else (extend var val frame)))))

(define (depends-on? exp var frame)
  (define (tree-walk e)
    (cond ((var? e)
           (if (equal? var e)
               true
               (let ((b (binding-in-frame e frame)))
                 (if b
                     (tree-walk (binding-value b))
                     false))))
          ((pair? e)
           (or (tree-walk (car e))
               (tree-walk (cdr e))))
          (else false)))
  (tree-walk exp))

;;4.4.4.5 データベースの保守
(define THE-ASSERTIONS the-empty-stream)

(define (fetch-assertions pattern frame)
  (if (use-index? pattern)
      (get-indexed-assertions pattern)
      (get-all-assertions)))

(define (get-all-assertions) THE-ASSERTIONS)

(define (get-indexed-assertions pattern)
  (get-stream (index-key-of pattern) 'assertion-stream))

(define (get-stream key1 key2)
  (let ((s (get key1 key2)))
    (if s s the-empty-stream)))

(define THE-RULES the-empty-stream)

(define (fetch-rules pattern frame)
  (if (use-index? pattern)
      (get-indexed-rules pattern)
      (get-all-rules)))

(define (get-all-rules) THE-RULES)

(define (get-indexed-rules pattern)
  (stream-append
   (get-stream (index-key-of pattern) 'rule-stream)
   (get-stream '? 'rule-stream)))

(define (add-rule-or-assertion! assertion)
  (if (rule? assertion)
      (add-rule! assertion)
      (add-assertion! assertion)))

(define (add-assertion! assertion)
  (store-assertion-in-index assertion)
  (let ((old-assertions THE-ASSERTIONS))
    (set! THE-ASSERTIONS
          (cons-stream assertion old-assertions))
    'ok))

(define (add-rule! rule)
  (store-rule-in-index rule)
  (let ((old-rules THE-RULES))
    (set! THE-RULES (cons-stream rule old-rules))
    'ok))

(define (store-assertion-in-index assertion)
  (if (indexable? assertion)
      (let ((key (index-key-of assertion)))
        (let ((current-assertion-stream
               (get-stream key 'assertion-stream)))
          (put key
               'assertion-stream
               (cons-stream assertion
                            current-assertion-stream))))))

(define (store-rule-in-index rule)
  (let ((pattern (conclusion rule)))
    (if (indexable? pattern)
        (let ((key (index-key-of pattern)))
          (let ((current-rule-stream
                 (get-stream key 'rule-stream)))
            (put key
                 'rule-stream
                 (cons-stream rule
                              current-rule-stream)))))))

(define (indexable? pat)
  (or (constant-symbol? (car pat))
      (var? (car pat))))

(define (index-key-of pat)
  (let ((key (car pat)))
    (if (var? key) '? key)))

(define (use-index? pat)
  (constant-symbol? (car pat)))

;;4.4.4.6 ストリーム演算
(define (stream-append-delayed s1 delayed-s2)
  (if (stream-null? s1)
      (force delayed-s2)
      (cons-stream
       (stream-car s1)
       (stream-append-delayed (stream-cdr s1) delayed-s2))))

(define (interleave-delayed s1 delayed-s2)
  (if (stream-null? s1)
      (force delayed-s2)
      (cons-stream
       (stream-car s1)
       (interleave-delayed (force delayed-s2)
                           (delay (stream-cdr s1))))))

(define (stream-flatmap proc s)
  (flatten-stream (stream-map proc s)))

(define (flatten-stream stream)
  (if (stream-null? stream)
      the-empty-stream
      (interleave-delayed
       (stream-car stream)
       (delay (flatten-stream (stream-cdr stream))))))

(define (singleton-stream x)
  (cons-stream x the-empty-stream))

;;4.4.4.7 質問の構文手続き
(define (type exp)
  (if (pair? exp)
      (car exp)
      (error "Unknown expression TYPE" exp)))

(define (contents exp)
  (if (pair? exp)
      (cdr exp)
      (error "Unknown expression CONTENTS" exp)))

(define (assertion-to-be-added? exp)
  (eq? (type exp) 'assert!))

(define (add-assertion-body exp)
  (car (contents exp)))

(define (empty-conjunction? exps) (null? exps))
(define (first-conjunct exps) (car exps))
(define (rest-conjuncts exps) (cdr exps))

(define (empty-disjunction? exps) (null? exps))
(define (first-disjunct exps) (car exps))
(define (rest-disjuncts exps) (cdr exps))

(define (negated-query exps) (car exps))

(define (predicate exps) (car exps))
(define (args exps) (cdr exps))

(define (rule? statement)
  (tagged-list? statement 'rule))

(define (conclusion rule) (cadr rule))

(define (rule-body rule)
  (if (null? (cddr rule))
      '(always-true)
      (caddr rule)))

(define (query-syntax-process exp)
  (map-over-symbols expand-question-mark exp))

(define (map-over-symbols proc exp)
  (cond ((pair? exp)
         (cons (map-over-symbols proc (car exp))
               (map-over-symbols proc (cdr exp))))
        ((symbol? exp) (proc exp))
        (else exp)))

(define (expand-question-mark symbol)
  (let ((chars (symbol->string symbol)))
    (if (string=? (substring chars 0 1) "?")
        (list '?
              (string->symbol
               (substring chars 1 (string-length chars))))
        symbol)))

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

(define (constant-symbol? exp) (symbol? exp))

(define rule-counter 0)

(define (new-rule-application-id)
  (set! rule-counter (+ 1 rule-counter))
  rule-counter)

(define (make-new-variable var rule-application-id)
  (cons '? (cons rule-application-id (cdr var))))

(define (contract-question-mark variable)
  (string->symbol
   (string-append "?" 
     (if (number? (cadr variable))
         (string-append (symbol->string (caddr variable))
                        "-"
                        (number->string (cadr variable)))
         (symbol->string (cadr variable))))))

;;4.4.4.8 フレームと束縛
(define (make-binding variable value)
  (cons variable value))

(define (binding-variable binding)
  (car binding))

(define (binding-value binding)
  (cdr binding))

(define (binding-in-frame variable frame)
  (assoc variable frame))

(define (extend variable value frame)
  (cons (make-binding variable value) frame))

(assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
(assert! (job (Bitdiddle Ben) (computer wizard)))
(assert! (salary (Bitdiddle Ben) 60000))

(assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
(assert! (job (Hacker Alyssa P) (computer programmer)))
(assert! (salary (Hacker Alyssa P) 40000))
(assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))

(assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(assert! (job (Fect Cy D) (computer programmer)))
(assert! (salary (Fect Cy D) 35000))
(assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))

(assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(assert! (job (Tweakit Lem E) (computer technician)))
(assert! (salary (Tweakit Lem E) 25000))
(assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))

(assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
(assert! (job (Reasoner Louis) (computer programmer trainee)))
(assert! (salary (Reasoner Louis) 30000))
(assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))

(assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))

(assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
(assert! (job (Warbucks Oliver) (administration big wheel)))
(assert! (salary (Warbucks Oliver) 150000))

(assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
(assert! (job (Scrooge Eben) (accounting chief accountant)))
(assert! (salary (Scrooge Eben) 75000))
(assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))

(assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
(assert! (job (Cratchet Robert) (accounting scrivener)))
(assert! (salary (Cratchet Robert) 18000))
(assert! (supervisor (Cratchet Robert) (Scrooge Eben)))

(assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
(assert! (job (Aull DeWitt) (administration secretary)))
(assert! (salary (Aull DeWitt) 25000))
(assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))

;; 実行例
;; ;;; Query input:
;; (supervisor ?x (Bitdiddle Ben))
;; 
;; ;;; Query results:
;; (supervisor (tweakit lem e) (bitdiddle ben))
;; (supervisor (fect cy d) (bitdiddle ben))
;; (supervisor (hacker alyssa p) (bitdiddle ben))
;; 
;; ;;; Query input:
;; (job ?x (accounting . ?y))
;; 
;; ;;; Query results:
;; (job (cratchet robert) (accounting scrivener))
;; (job (scrooge eben) (accounting chief accountant))
;; 
;; ;;; Query input:
;; (address ?x (Slumerville . ?y))
;; 
;; ;;; Query results:
;; (address (aull dewitt) (slumerville (onion square) 5))
;; (address (reasoner louis) (slumerville (pine tree road) 80))
;; (address (bitdiddle ben) (slumerville (ridge road) 10))
;; 

実行例
;; ;;; Query input:
;; (supervisor ?x (Bitdiddle Ben))
;; 
;; ;;; Query results:
;; (supervisor (tweakit lem e) (bitdiddle ben))
;; (supervisor (fect cy d) (bitdiddle ben))
;; (supervisor (hacker alyssa p) (bitdiddle ben))
;; 
;; ;;; Query input:
;; (and (salary (Bitdiddle Ben) ?x)
;;      (salary ?y ?z)
;;      (lisp-value < ?z ?x))
;; 
;; ;;; Query results:
;; (and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000)
;;  (lisp-value < 25000 60000))
;; (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000)
;;  (lisp-value < 18000 60000))
;; (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000)
;;  (lisp-value < 30000 60000))
;; (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000)
;;  (lisp-value < 25000 60000))
;; (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000)
;;  (lisp-value < 35000 60000))
;; (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000)
;;  (lisp-value < 40000 60000))
;; 
;; ;;; Query input:
;; (and (supervisor ?x ?y)
;;      (job ?y ?w)
;;      (not (job ?y (computer . ?z))))
;; 
;; ;;; Query results:
;; (and (supervisor (aull dewitt) (warbucks oliver))
;;  (job (warbucks oliver) (administration big wheel))
;;  (not (job (warbucks oliver) (computer . ?z))))
;; (and (supervisor (cratchet robert) (scrooge eben))
;;  (job (scrooge eben) (accounting chief accountant))
;;  (not (job (scrooge eben) (computer . ?z))))
;; (and (supervisor (scrooge eben) (warbucks oliver))
;;  (job (warbucks oliver) (administration big wheel))
;;  (not (job (warbucks oliver) (computer . ?z))))
;; (and (supervisor (bitdiddle ben) (warbucks oliver))
;;  (job (warbucks oliver) (administration big wheel))
;;  (not (job (warbucks oliver) (computer . ?z))))

(assert! (can-do-job (computer wizard) (computer programmer)))
(assert! (can-do-job (computer wizard) (computer technician)))
(assert! (can-do-job (administration secretary)
                     (administration big wheel)))

(assert! (rule (same ?x ?x)))

(assert! (rule (replace ?p1 ?p2)
                 (and   (or (and (job ?p1 ?j) (job ?p2 ?j))
                            (and (job ?p1 ?j1) (job ?p2 ?j2)
                             (can-do-job ?j1 ?j2)))
                        (not (same ?p1 ?p2)))))

;; (not (same ?p1 ?p2))は条件の最後におく. 

(replace ?x (fect cy d))

(assert! (rule (ex4.57.b ?p1 ?s1 ?p2 ?s2)
(and (replace ?p1 ?p2)
     (salary ?p1 ?s1)
     (salary ?p2 ?s2)
     (lisp-value < ?s2 ?s1))))

実行結果
;; ;;; Query input:
;; (replace ?x (fect cy d))
;; 
;; ;;; Query results:
;; (replace (bitdiddle ben) (fect cy d))
;; (replace (hacker alyssa p) (fect cy d))
;; 
;; ;;; Query input:
;; (ex4.57.b ?p ?q ?r ?s)
;; 
;; ;;; Query results:
;; (ex4.57.b (bitdiddle ben) 60000 (tweakit lem e) 25000)
;; (ex4.57.b (bitdiddle ben) 60000 (fect cy d) 35000)
;; (ex4.57.b (bitdiddle ben) 60000 (hacker alyssa p) 40000)
;; (ex4.57.b (hacker alyssa p) 40000 (fect cy d) 35000)

(assert! (rule (big-shot ?p ?j)
           (and (job ?p (?j . ?x))
                (supervisor ?p ?q)
                (job ?q (?k . ?y))
                (not (same ?j ?k)))))

;; 実行例
;; ;;; Query input:
;; (big-shot ?p ?j)
;; 
;; ;;; Query results:
;; (big-shot (scrooge eben) accounting)
;; (big-shot (bitdiddle ben) computer)
;; 

(assert! (meeting accounting (Monday 9am)))
(assert! (meeting administration (Monday 10am)))
(assert! (meeting computer (Wednesday 3pm)))
(assert! (meeting administration (Friday 1pm)))
(assert! (meeting whole-company (Wednesday 4pm)))

(assert! (rule (meeting-time ?person ?day-and-time)
   (and (job ?person (?x . ?y))
        (or (meeting ?x ?day-and-time)
            (meeting whole-company ?day-and-time)))))

;; 実行結果
;; ;;; Query input:
;; 
;; (meeting ?x (Friday . ?y))
;; 
;; ;;; Query results:
;; (meeting administration (friday 1pm))
;; 
;; ;;; Query input:
;; (meeting-time (hacker alyssa p) ?day-and-time) 
;; 
;; ;;; Query results:
;; (meeting-time (hacker alyssa p) (wednesday 3pm))
;; (meeting-time (hacker alyssa p) (wednesday 4pm))
;; 
;; ;;; Query input:
;; 
;; (meeting-time (hacker alyssa p) (wednesday . ?t))
;; 
;; ;;; Query results:
;; (meeting-time (hacker alyssa p) (wednesday 3pm))
;; (meeting-time (hacker alyssa p) (wednesday 4pm))

(define (s= a b)
  (string=? (symbol->string a) (symbol->string b)))
(define (s< a b)
  (stringstring a) (symbol->string b)))

(define (l< a b)
 (cond ((null? a) (not (null? b)))
       ((null? b) #f)
       ((s= (car a) (car b)) (l< (cdr a) (cdr b)))
       (else (s< (car a) (car b)))))

(assert! (rule (same ?x ?x)))

(assert! (rule (lives-near ?p1 ?p2)
(and (address ?p1 (?t1 . ?x1))
     (address ?p2 (?t1 . ?x2))
     (not (same ?p1 ?p2))
     (lisp-value l< ?p1 ?p2))))

(assert! (rule (?x next-to ?y in (?x ?y . ?u))))
(assert! (rule (?x next-to ?y in (?v . ?z))
               (?x next-to ?y in ?z)))
;; 実行例
;; ;;; Query input:
;; (?x next-to ?y in (1 (2 3) 4))
;; 
;; ;;; Query results:
;; ((2 3) next-to 4 in (1 (2 3) 4))
;; (1 next-to (2 3) in (1 (2 3) 4))
;; 
;; ;;; Query input:
;; (?x next-to 1 in (2 1 3 1))
;; 
;; ;;; Query results:
;; (3 next-to 1 in (2 1 3 1))
;; (2 next-to 1 in (2 1 3 1))
;; 

(assert! (rule (last-pair (?x) (?x))))
(assert! (rule (last-pair (?x . ?y) ?z)
               (last-pair ?y ?z)))

実行例

;;; Query input:
(last-pair (3) ?x)

;;; Query results:
(last-pair (3) (3))

;;; Query input:
(last-pair (1 2 3) ?x)

;;; Query results:
(last-pair (1 2 3) (3))

;;; Query input:
(last-pair (2 ?x) (3))

;;; Query results:
(last-pair (2 3) (3))

;;; Query input:
(last-pair ?x (3))

;;; Query results:
;Aborting!: out of memory
GC #38: took:   0.20  (11%) CPU time,   0.10   (5%) real time; free: 243167
GC #39: took:   0.20 (100%) CPU time,   0.10   (9%) real time; free: 243167

(assert! (son Adam Cain))
(assert! (son Cain Enoch))
(assert! (son Enoch Irad))
(assert! (son Irad Mehujael))
(assert! (son Mehujael Methushael))
(assert! (son Methushael Lamech))
(assert! (wife Lamech Ada))
(assert! (son Ada Jabal))
(assert! (son Ada Jubal))

(assert! (rule (grandson ?g ?s) (and (son ?f ?s) (son ?g ?f))))
(assert! (rule (son ?m ?s) (and (wife ?m ?w) (son ?w ?s))))

;; 実行例
;; ;;; Query input:
;; (grandson Cain ?x)
;; 
;; ;;; Query results:
;; (grandson cain irad)
;; 
;; ;;; Query input:
;; (son Lamech ?x)
;; 
;; ;;; Query results:
;; (son lamech jubal)
;; (son lamech jabal)
;; 

;もともとの規則は
(assert! (rule (outranked-by ?staff-person ?boss)
               (or (supervisor ?staff-person ?boss)
                   (and (supervisor ?staff-person ?middle-manager)
                        (outranked-by ?middle-manager ?boss)))))

;;; Query input:

(outranked-by (hacker alyssa p) ?x)

;;; Query results:
(outranked-by (hacker alyssa p) (bitdiddle ben))
(outranked-by (hacker alyssa p) (warbucks oliver))

;;; Query input:
(outranked-by (reasoner louis) ?x)

;;; Query results:
(outranked-by (reasoner louis) (hacker alyssa p))
(outranked-by (reasoner louis) (bitdiddle ben))
(outranked-by (reasoner louis) (warbucks oliver))

;新しい定義
(assert! (rule (outranked-by2 ?staff-person ?boss)
               (or (supervisor ?staff-person ?boss)
                   (and (outranked-by2 ?middle-manager ?boss)
                        (supervisor ?staff-person ?middle-manager)))))

;outranked-by2がout-ranked-by2を再帰呼び出しするので無限に走る. 

(assert! (rule (wheel ?person)
               (and (supervisor ?middle-manager ?person)
                    (supervisor ?x ?middle-manager))))

(wheel ?who)


((?person) warbucks oliver) (?middle-manager) aull dewitt) (?who) ?person))
((?person) scrooge eben) (?middle-manager) cratchet robert) (?who) ?person))
((?person) warbucks oliver) (?middle-manager) scrooge eben) (?who) ?person))
((?person) warbucks oliver) (?middle-manager) bitdiddle ben) (?who) ?person))
((?person) hacker alyssa p) (?middle-manager) reasoner louis) (?who) ?person))
((?person) bitdiddle ben) (?middle-manager) tweakit lem e) (?who) ?person))
((?person) bitdiddle ben) (?middle-manager) fect cy d) (?who) ?person))
((?person) bitdiddle ben) (?middle-manager) hacker alyssa p) (?who) ?person))

(supervisor ?middle-manager ?person)
でデーターベースを見ると上の8つのフレームが出来る. 
その環境で
パターンを
(supervisor ?x ?middle-manager)
としてデーターベースを見直す. 

1行目 フェイル
2行目 フェイル
3行目 (supervisor (Cratchet Robert) (Scrooge Eben)) でマッチ
→ ((?person) warbucks oliver))を出力
4行目 (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) でマッチ
→ ((?person) warbucks oliver))を出力
      (supervisor (Fect Cy D) (Bitdiddle Ben)) でマッチ
→ ((?person) warbucks oliver))を出力
      (supervisor (Tweakit Lem E) (Bitdiddle Ben))) でマッチ
→ ((?person) warbucks oliver))を出力
5行目 フェイル
6行目 フェイル
7行目 フェイル
8行目 (supervisor (Reasoner Louis) (Hacker Alyssa P)) でマッチ
→ ((?person) bitdiddle ben))を出力

結果として warbucks oliver が 4回 bitdiddle ben が1回 出力される. 

問題4.65の結果からわかるように, 例えばwheelの給料の和を計算しようとすると, 
Warbucks Oliverの給料を4回加算してしまう. 

フレイムに同一の内容は1回しかあらわれないようにしたい. 

(assert! (rule (outranked-by ?sp ?b)
               (or (supervisor ?sp ?b)
                   (and (outranked-by ?mm ?b)
                        (supervisor ?sp ?mm) ))))

と定義して

(outranked-by (bitdiddle ben) ?w)

(assert! (rule (append-to-form () ?y ?y)))
(assert! (rule (append-to-form (?u . ?v) ?y (?u . ?w))
               (append-to-form ?v ?y ?w)))
(append-to-form (a b) (c d) ?x)



を実行するとループに入る. これを防ぐには
(define qhistory '())
とし, query-loopに入る度に(set! qhistory '())とリセットし, 
queryのなかで queryがqhistoryのメンバーであるかを調べる. 
ただし変数には番号がついているので, それを無視したい. そのため

(define (hmember a l)
  (if (null? l) '()
       (or (hequal? a (car l)) (hmember a (cdr l)))))

(define (hequal? a b)
  (or (eq? a b)
      (and (number? a) (number? b))
      (and (pair? a) (pair? b) (hequal? (car a) (car b))
           (hequal? (cdr a) (cdr b)))))

を使う. 

(define (qeval query frame-stream)
(cond ((not (hmember query qhistory))   ;;queryがqhistoryになければ
(set! qhistory (cons query qhistory))   ;;queryをqhistoryに追加し
  (let ((qproc (get (type query) 'qeval))) ;;通常に実行する. 
    (if qproc
        (qproc (contents query) frame-stream)
        (simple-query query frame-stream))))
(else (error "query loop" query))))     ;;qhistoryにあればerrorでとまる. 


実行すると
;;; Query input:
(outranked-by (bitdiddle ben) ?w)

;;; Query results:
(outranked-by (bitdiddle ben) (warbucks oliver))

そのうち

;;qeval 
(or (supervisor (? 2 sp) (? 2 b)) (and (outranked-by (? 2 mm) (? 2 b)) (supervisor (? 2 sp) (? 2 mm))))

を評価しようとし, 

;;qhist (
(outranked-by (? 1 mm) (? 1 b)) 
(and (outranked-by (? 1 mm) (? 1 b)) (supervisor (? 1 sp) (? 1 mm))) 
(supervisor (? 1 sp) (? 1 b)) 
(or (supervisor (? 1 sp) (? 1 b)) (and (outranked-by (? 1 mm) (? 1 b)) (supervisor (? 1 sp) (? 1 mm)))) 
(outranked-by (bitdiddle ben) (? w))
)
のようにqhistoryにあるので停止する. 

;query loop (or (supervisor ... ...) (and ... ...))
;To continue, call RESTART with an option number:
; (RESTART 1) => Return to read-eval-print level 1.

(assert! (rule (append-to-form () ?y ?y)))

(assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
               (append-to-form ?v ?y ?z)))

(assert! (rule (reverse () ())))
(assert! (rule (reverse (?x . ?y) ?z)
               (and (reverse ?y ?w)
                    (append-to-form ?w (?x) ?z))))


(append-to-form (a b) (c d) ?z)

(reverse (1 2 3) ?x)

;; データーベース
(assert! (son Adam Cain))
(assert! (son Cain Enoch))
(assert! (son Enoch Irad))
(assert! (son Irad Mehujael))
(assert! (son Mehujael Methushael))
(assert! (son Methushael Lamech))
(assert! (wife Lamech Ada))
(assert! (son Ada Jabal))
(assert! (son Ada Jubal))

;; grandsonの規則を書き直す((grandson) ?x ?y)の形にする. 

(assert! (rule ((grandson) ?g ?s) (and (son ?f ?s) (son ?g ?f))))

;; リストの最後がgrandsonで終ることを見る規則

(assert! (rule (gsl (grandson))))
(assert! (rule (gsl (?x . ?y))
               (gsl ?y)))

;; (great . ?rel)の規則

(assert! (rule ((great . ?rel) ?x ?y)
               (and (son ?z ?y) (?rel ?x ?z) (gsl ?rel))))

;; 実行結果
;; ;;; Query input:
;; ((great grandson) ?g ?ggs)
;; 
;; ;;; Query results:
;; ((great grandson) irad lamech)
;; ((great grandson) enoch methushael)
;; ((great grandson) cain mehujael)
;; ((great grandson) adam irad)
;; 
;; ;;; Query input:
;; (?relationship Adam Irad)
;; 
;; ;;; Query results:
;; ((great grandson) adam irad)
;; 
;; ;;; Query input:
;; (?relationship adam lamech)
;; 
;; ;;; Query results:
;; ((great great great great grandson) adam lamech)
;; 

(define ones (cons-stream 1 ones))で1 1 1...ができたように, letを使わないと
あたらしい表明の列ができてしまう. 

(assert! (n 0))
(assert! (rule (n (s ?x))
      (n ?x)))

(define (uniquely-asserted contents frame-stream)
 (stream-flatmap
   (lambda (frame)
     (let ((qq (qeval (car contents)
                      (singleton-stream frame))))
       (cond ((stream-null? qq) the-empty-stream)
             ((stream-null? (stream-cdr qq)) qq)
             (else the-empty-stream))))
  frame-stream))

(put 'unique 'qeval uniquely-asserted)

;;実行結果
;;
;;;;; Query input:
;;(unique (job ?x (computer wizard)))
;;
;;;;; Query results:
;;(unique (job (bitdiddle ben) (computer wizard)))
;;
;;;;; Query input:
;;(unique (job ?x (computer programmer)))
;;
;;;;; Query results:
;;
;;;;; Query input:
;;(and (job ?x ?j) (unique (job ?anyone ?j)))
;;
;;;;; Query results:
;;(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))))
;;
;;;;; Query input:
;;(and (job ?x ?j) (unique (supervisor ?y ?x)))
;;
;;;;; Query results:
;;(and (job (scrooge eben) (accounting chief accountant)) (unique (supervisor (cratchet robert) (scrooge eben))))
;;(and (job (hacker alyssa p) (computer programmer)) (unique (supervisor (reasoner louis) (hacker alyssa p))))
;;