Implement till 4.61

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 '()))))))))
+