From 5eb7a2468775281bcef9d3c4dd94e240c746cde0 Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Sun, 28 Feb 2021 09:23:03 -0500
Subject: [PATCH] Implement 4.57 and update eval-query to support rules

---
 ex-4_55-xx.scm | 42 +++++++++++++++++++++++++++++++++++++++---
 1 file changed, 39 insertions(+), 3 deletions(-)

diff --git a/ex-4_55-xx.scm b/ex-4_55-xx.scm
index 4196d87..e06ebf1 100644
--- a/ex-4_55-xx.scm
+++ b/ex-4_55-xx.scm
@@ -3,10 +3,15 @@
 
 (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
@@ -15,19 +20,21 @@
                             frame
                             (lambda (v f)
                               (contract-question-mark v))))
-             (qeval q (singleton-stream '())))))))
-  (newline))
+             (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")
 
@@ -36,6 +43,7 @@
 (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;
@@ -43,6 +51,7 @@
   '(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.
@@ -50,7 +59,34 @@
   '(and (supervisor ?person ?supervisor)
         (not (job ?supervisor (computer . ?supervisor-title)))
         (job ?supervisor ?job)))
+(newline)
 
-(display "\nex-4.57\n")
+(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")