SICP/ex-4_55-xx.scm

(load "util.scm")
(load "misc/sicp-query.scm")

(initialize-data-base microshaft-data-base)

(define (rule-to-be-added? exp)
  (eq? (car exp) 'rule))

(define (eval-query input)
  (let ((q (query-syntax-process input)))
    (cond ((assertion-to-be-added? q)
           (add-rule-or-assertion! (add-assertion-body q)))
          ((rule-to-be-added? q)
           (add-rule-or-assertion! q))
          (else
           (display-stream
            (stream-map
             (lambda (frame)
               (instantiate q
                            frame
                            (lambda (v f)
                              (contract-question-mark v))))
             (qeval q (singleton-stream '()))))))))

(display "\nex-4.55 - simple-queries\n")

; a. all people supervised by Ben Bitdiddle;
(eval-query '(supervisor ?x (bitdiddle ben)))
(newline)

; b. the names and jobs of all people in the accounting division;
(eval-query '(job ?x (accounting . ?y)))
(newline)

; c. the names and addresses of all people who live in Slumerville.
(eval-query '(address ?x (slumerville . ?y)))
(newline)

(display "\nex-4.56 - joint-queries\n")

; a. the names of all people who are supervised by Ben Bitdiddle, together with
; their addresses;
(eval-query
  '(and (supervisor ?person (Bitdiddle Ben))
        (address ?person  ?address)))
(newline)

; b. all people whose salary is less than Ben Bitdiddle's, together with their
; salary and Ben Bitdiddle's salary;
(eval-query
  '(and (salary (Bitdiddle Ben) ?ben-amount)
        (salary ?person ?amount)
        (lisp-value > ?amount ?ben-amount)))
(newline)

; c. all people who are supervised by someone who is not in the computer
; division, together with the supervisor's name and job.
(eval-query
  '(and (supervisor ?person ?supervisor)
        (not (job ?supervisor (computer . ?supervisor-title)))
        (job ?supervisor ?job)))
(newline)

(display "\nex-4.57 - rules\n")

(eval-query '(rule (same ?x ?x)))

(eval-query
  '(rule (can-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)))))

; a.  all people who can replace Cy D. Fect;
(eval-query '(can-replace (fect cy d) ?x))
(newline)

; b.  all people who can replace someone who is being paid more than they are,
; together with the two salaries.
(eval-query
  '(and (can-replace ?p1 ?p2)
        (salary ?p1 ?s1)
        (salary ?p2 ?s2)
        (lisp-value < ?s1 ?s2)))
(newline)

(display "\nex-4.58\n")

(display "\nex-4.59\n")