Implement till 4.61

ex-4_55-60.scm

@@ -3,25 +3,6 @@
 
 (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;
@@ -52,10 +33,7 @@
         (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
+; 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)))
@@ -63,8 +41,6 @@
 
 (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))
@@ -86,7 +62,57 @@
         (lisp-value < ?s1 ?s2)))
 (newline)
 
-(display "\nex-4.58\n")
+(display "\nex-4.58 - big-shot\n")
 
-(display "\nex-4.59\n")
+; Exercise 4.58.  Define a rule that says that a person is a ``big shot'' in a
+; division if the person works in the division but does not have a supervisor
+; who works in the division.
+
+(eval-query
+  '(rule (big-shot ?p)
+    (and (job ?p (?div1 . ?rest1))
+         (supervisor ?p ?boss)
+         (job ?boss (?div2 . ?rest2))
+         (not (same ?div1 ?div2)))))
+
+(eval-query '(big-shot ?x))
+(newline)
+
+(display "\nex-4.59 - meetings\n")
+
+; a. On Friday morning, Ben wants to query the data base for all the meetings
+; that occur that day. What query should he use?
+(eval-query
+  '(meeting ?department (Friday . ?time)))
+(newline)
+
+(eval-query
+  '(rule (meeting-time ?person ?day-and-time)
+         (and (job ?person (?department . ?title))
+              (or (meeting ?department ?day-and-time)
+                  (meeting whole-company ?day-and-time)))))
+
+(eval-query
+  '(meeting-time (hacker alyssa p) (Wednesday . ?time)))
+(newline)
+
+(display "\nex-4.60 - double-pair\n")
+
+; Each pair of people who live close to each other is listed twice:
+;(eval-query '(lives-near ?person-1 ?person-2))
+
+; This happens because the query does not impose an order on the two arguments.
+; Each variable can assign to either person. One way to avoid this would be to
+; impose an ordering on the persons, for example alphabetical or by id.
+
+(eval-query
+ '(rule (lives-near-unique ?person-1 ?person-2)
+        (and (address ?person-1 (?town . ?rest-1))
+             (address ?person-2 (?town . ?rest-2))
+             (id ?person-1 ?id-1)
+             (id ?person-2 ?id-2)
+             (lisp-value > ?id-2 ?id-1)
+             (not (same ?person-1 ?person-2)))))
+
+(eval-query '(lives-near-unique ?person-1 ?person-2))
 

ex-4_61-xx.scm

@@ -0,0 +1,40 @@
+(load "util.scm")
+(load "misc/sicp-query.scm")
+
+(initialize-data-base microshaft-data-base)
+
+(display "\nex-4.61 - next-to\n")
+
+(eval-query '(append-to-form x y z))
+(eval-query '(rule (append-to-form () ?y ?y)))
+(eval-query
+  '(rule (append-to-form (?u . ?v) ?y (?u . ?z))
+         (append-to-form ?v ?y ?z)))
+
+(eval-query '(append-to-form (a b) (c d) ?z)) (newline)
+; (eval-query '(append-to-form (a b) ?y (a b c d))) (newline)
+; (eval-query '(append-to-form ?x ?y (a b c d))) (newline)
+
+(eval-query '(rule (?x next-to ?y in (?x ?y . ?u))))
+
+(eval-query
+  '(rule (?x next-to ?y in (?v . ?z))
+         (?x next-to ?y in ?z)))
+
+; (eval-query '(?x next-to ?y in (1 (2 3) 4))) (newline)
+; (1 next-to (2 3))
+; ((2 3) next-to  4)
+
+; (eval-query '(?x next-to 1 in (2 1 3 1))) (newline)
+; (2 next-to 1)
+; (3 next-to 1)
+
+(display "[answered]\n")
+
+(display "\nex-4.62 - last-pair\n")
+
+(display "\nex-4.63\n")
+
+;(display "\nex-4.64\n")
+;(display "\nex-4.65\n")
+

misc/sicp-query.scm

@@ -582,25 +582,30 @@
   '(
 ;; from section 4.4.1
 (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
+(id (Bitdiddle Ben) 0)
 (job (Bitdiddle Ben) (computer wizard))
 (salary (Bitdiddle Ben) 60000)
 
 (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
+(id (Hacker Alyssa P) 1)
 (job (Hacker Alyssa P) (computer programmer))
 (salary (Hacker Alyssa P) 40000)
 (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
 
 (address (Fect Cy D) (Cambridge (Ames Street) 3))
+(id (Fect Cy D) 2)
 (job (Fect Cy D) (computer programmer))
 (salary (Fect Cy D) 35000)
 (supervisor (Fect Cy D) (Bitdiddle Ben))
 
 (address (Tweakit Lem E) (Boston (Bay State Road) 22))
+(id (Tweakit Lem E) 3)
 (job (Tweakit Lem E) (computer technician))
 (salary (Tweakit Lem E) 25000)
 (supervisor (Tweakit Lem E) (Bitdiddle Ben))
 
 (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
+(id (Reasoner Louis) 4)
 (job (Reasoner Louis) (computer programmer trainee))
 (salary (Reasoner Louis) 30000)
 (supervisor (Reasoner Louis) (Hacker Alyssa P))
@@ -608,24 +613,34 @@
 (supervisor (Bitdiddle Ben) (Warbucks Oliver))
 
 (address (Warbucks Oliver) (Swellesley (Top Heap Road)))
+(id (Warbucks Oliver) 5)
 (job (Warbucks Oliver) (administration big wheel))
 (salary (Warbucks Oliver) 150000)
 
 (address (Scrooge Eben) (Weston (Shady Lane) 10))
+(id (Scrooge Eben) 6)
 (job (Scrooge Eben) (accounting chief accountant))
 (salary (Scrooge Eben) 75000)
 (supervisor (Scrooge Eben) (Warbucks Oliver))
 
 (address (Cratchet Robert) (Allston (N Harvard Street) 16))
+(id (Cratchet Robert) 7)
 (job (Cratchet Robert) (accounting scrivener))
 (salary (Cratchet Robert) 18000)
 (supervisor (Cratchet Robert) (Scrooge Eben))
 
 (address (Aull DeWitt) (Slumerville (Onion Square) 5))
+(id (Aull DeWitt) 8)
 (job (Aull DeWitt) (administration secretary))
 (salary (Aull DeWitt) 25000)
 (supervisor (Aull DeWitt) (Warbucks Oliver))
 
+(meeting accounting (Monday 9am))
+(meeting administration (Monday 10am))
+(meeting computer (Wednesday 3pm))
+(meeting administration (Friday 1pm))
+(meeting whole-company (Wednesday 4pm))
+
 (can-do-job (computer wizard) (computer programmer))
 (can-do-job (computer wizard) (computer technician))
 
@@ -651,3 +666,24 @@
           (and (supervisor ?staff-person ?middle-manager)
                (outranked-by ?middle-manager ?boss))))
 ))
+
+;; felixm: for easier use from MIT-Scheme
+(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 '()))))))))
+