felixm/SICP
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement 4.57 and update eval-query to support rules

Browse Source
This commit is contained in:
Felix Martin
2021-02-28 09:23:03 -05:00
parent 186bab6569
commit 5eb7a24687
1 changed files with 39 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
ex-4_55-xx.scm
View File

@@ -3,10 +3,15 @@
(initialize-data-base microshaft-data-base) (initialize-data-base microshaft-data-base)
(define (rule-to-be-added? exp)
(eq? (car exp) 'rule))
(define (eval-query input) (define (eval-query input)
(let ((q (query-syntax-process input))) (let ((q (query-syntax-process input)))
(cond ((assertion-to-be-added? q) (cond ((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q))) (add-rule-or-assertion! (add-assertion-body q)))
((rule-to-be-added? q)
(add-rule-or-assertion! q))
(else (else
(display-stream (display-stream
(stream-map (stream-map
@@ -15,19 +20,21 @@
frame frame
(lambda (v f) (lambda (v f)
(contract-question-mark v)))) (contract-question-mark v))))
(qeval q (singleton-stream '()))))))) (qeval q (singleton-stream '()))))))))
(newline))
(display "\nex-4.55 - simple-queries\n") (display "\nex-4.55 - simple-queries\n")
; a. all people supervised by Ben Bitdiddle; ; a. all people supervised by Ben Bitdiddle;
(eval-query '(supervisor ?x (bitdiddle ben))) (eval-query '(supervisor ?x (bitdiddle ben)))
(newline)
; b. the names and jobs of all people in the accounting division; ; b. the names and jobs of all people in the accounting division;
(eval-query '(job ?x (accounting . ?y))) (eval-query '(job ?x (accounting . ?y)))
(newline)
; c. the names and addresses of all people who live in Slumerville. ; c. the names and addresses of all people who live in Slumerville.
(eval-query '(address ?x (slumerville . ?y))) (eval-query '(address ?x (slumerville . ?y)))
(newline)
(display "\nex-4.56 - joint-queries\n") (display "\nex-4.56 - joint-queries\n")
@@ -36,6 +43,7 @@
(eval-query (eval-query
'(and (supervisor ?person (Bitdiddle Ben)) '(and (supervisor ?person (Bitdiddle Ben))
(address ?person ?address))) (address ?person ?address)))
(newline)
; b. all people whose salary is less than Ben Bitdiddle's, together with their ; b. all people whose salary is less than Ben Bitdiddle's, together with their
; salary and Ben Bitdiddle's salary; ; salary and Ben Bitdiddle's salary;
@@ -43,6 +51,7 @@
'(and (salary (Bitdiddle Ben) ?ben-amount) '(and (salary (Bitdiddle Ben) ?ben-amount)
(salary ?person ?amount) (salary ?person ?amount)
(lisp-value > ?amount ?ben-amount))) (lisp-value > ?amount ?ben-amount)))
(newline)
; c. all people who are supervised by someone who is not in the computer ; c. all people who are supervised by someone who is not in the computer
; division, together with the supervisor's name and job. ; division, together with the supervisor's name and job.
@@ -50,7 +59,34 @@
'(and (supervisor ?person ?supervisor) '(and (supervisor ?person ?supervisor)
(not (job ?supervisor (computer . ?supervisor-title))) (not (job ?supervisor (computer . ?supervisor-title)))
(job ?supervisor ?job))) (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")