I found section 4-4 incredibly difficult to read. This section is my supplement to 4-4. Instead of taking the approach of describing the abstract ideas up-front and leaving the concrete code to the end of the chapter, I instead try to make everything concrete from the get-go and build systems from scratch.
Still a WIP. But I imagine that what I'll have to do is that some pieces of the system will be fully-featured or are verbatim what is in the book. At other times it might make sense to build systems which are less general or fail at certain edge cases. So hopefully I can make it clear which code blocks are flawed or not fully featured.
I think it's natural to divide this into two sections: First, we cover the
construction of a database system that handles simple and compound queries,
with and and or. After this, we deal with the topic of rules and
unification.
A frame is an association list with keys '(? variable) and values
representing the bound value of the variable. For example in the process
of matching the query '(a b ?x) to datum '(a b c),
we generate the frame '(((? x) . c)). Note that the symbol ?x is expanded
into '(? x) by the procedures in expand-question-mark and query-syntax-process (4.4.4.7).
Running some examples (with the code in 4.4.4.8), we can get a feel for how things work. We define two frames by extending the empty frame '().
(define frame1 (extend '(? x) 'a '()))
(define frame2 (extend '(? y) 'b frame1))
Looking up behaves as expected:
frame2
;; (((? y) . b) ((? x) . a))
(binding-in-frame '(? x) frame2)
;; ((? x) . a)
(binding-in-frame '(? y) frame2)
;; ((? y) . b)
and we note that we haven't done anything special to prevent inconsistent frame extensions! This has to be checked for elsewhere.
(extend '(? x) 'b frame2)
;; (((? x) . b) ((? y) . b) ((? x) . a))
Note that extending a frame makes things more specific, because we specify
that the placeholder '?x has to be bound to a specific value. This means that
later on, the and operator will have a simple implementation because each
time we extend the frame in all possible ways we add more conditions on
what matches we'll accept.
#lang sicp
;ch2 assoc
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
;4.4.4.8 definitions
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
(define frame1 (extend '(? x) 'a '()))
(define frame2 (extend '(? y) 'b frame1))
frame2
(binding-in-frame '(? x) frame2)
(binding-in-frame '(? y) frame2)
(extend '(? x) 'b frame2)
(((? y) . b) ((? x) . a)) ((? x) . a) ((? y) . b) (((? x) . b) ((? y) . b) ((? x) . a))
Next we consider the simple pattern matching algorithm.
"Simple" means that we don't handle
and, or, not, or 'lisp-value yet.
Our function pattern-match is going to take three arguments:
pat, dat and frame and is going to traverse the whole datum dat recursively. If we can satisfy the given pattern, then we'll return the correct frame extension. For example:
(pattern-match '((? x) (? x) (? y) (? y))
'(foo foo bar bar)
'(((? x) . foo)))
;; (((? y) . bar) ((? x) . foo))
(pattern-match '((? x) (? x) (? y) (? y))
'(bar bar bar bar)
'(((? x) . foo)))
;; 'failed
#lang sicp
(define (tagged-list? exp tag) (and (pair? exp) (eq? (car exp) tag)))
(define (var? exp) (tagged-list? exp '?))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat)
(extend-if-consistent
pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match
(cdr pat)
(cdr dat)
(pattern-match
(car pat) (car dat) frame)))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match
(binding-value binding) dat frame)
(extend var dat frame))))
;ch2 assoc
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
;4.4.4.8 definitions
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
(pattern-match '((? x) (? x) (? y) (? y))
'(foo foo bar bar)
'(((? x) . foo)))
(pattern-match '((? x) (? x) (? y) (? y))
'(bar bar bar bar)
'(((? x) . foo)))
(((? y) . bar) ((? x) . foo)) failed
The implementation is fairly straightforward.
pattern-match and extend-if-consistent are functions which call each other.
extend-if-consistent is a helper function which actually does the symbol lookup and the
extension to the frame. In order to determine if the pattern matching has failed or not, it calls
extend-if-consistent with the pattern found by substitution from the database.
To test understanding, I recommend trying to remember what the missing pattern <...> should be in the following code
snippet.
(define (tagged-list? exp tag) (and (pair? exp) (eq? (car exp) tag)))
(define (var? exp) (tagged-list? exp '?))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat) (extend-if-consistent pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match <...>))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match
(binding-value binding) dat frame)
(extend var dat frame))))
One weird thing: I notice that in extend-if-consistent, we call pattern-match using a pattern which is the
result of substituting user data. This means if our database contains malicious patterns like '(? new-rule)
then we would start running checks based on user-provided rules! This is super funky, but whatever.
For this section, we need to mash together code from section 4.4.4.3, 4.4.4.5, and 4.4.4.8. However, it's really all just bookkeeping.
The new stuff is in 4.4.4.5. The book discusses that the indexing trick
is just so that if we have a pattern (job ?a ?b) this is never even
checked against queries of the form (address ?a ?b).
It takes a lot of helper functions to make this easy, and in the code example below
I included all of the bookkeeping for the rule code even though it is not used.
Section 4.4.4.4 is skipped because it is not needed for simple or compound queries, or for database construction or traversal.
Finally, we already discussed the meat of section 4.4.4.3, extend-if-consistent and pattern-match.
Two more bookkeeping functions are added here:
check-an-assertion just wraps pattern-match so that it returns a singleton stream or the empty stream;
find-assertions just maps this across the database.
So, we define all of this code, we add a whole bunch of assertions...
(define (build-database)
(begin
(add-assertion! '(address (Bitdiddle Ben)
(Slumerville (Ridge Road) 10)))
(add-assertion! '(job (Bitdiddle Ben) (computer wizard)))
(add-assertion! '(salary (Bitdiddle Ben) 60000))
... ))
And finally, we run the code. Let's take the examples in exercise 4.55, and keep in mind that
the outputs are not going to be what is referred to as the "instantiated" query, we are just
outputting the relevant list of frames. Also, keep in mind that we have to expand the symbols
'?x to the tagged list '(? x) by hand, since this is what our system expects.
(build-database)
;; 'ok
(display-stream
(find-assertions '(supervisor (? x) (Bitdiddle Ben)) '()))
;; (((? x) Tweakit Lem E))
;; (((? x) Fect Cy D))
;; (((? x) Hacker Alyssa P))
(display-stream
(find-assertions '(job (? name) (accounting . (? type))) '()))
;; (((? type) scrivener) ((? name) Cratchet Robert))
;; (((? type) chief accountant) ((? name) Scrooge Eben))
(display-stream
(find-assertions '(address (? name) (Slumerville . (? address))) '()))
;; (((? address) (Onion Square) 5) ((? name) Aull DeWitt))
;; (((? address) (Pine Tree Road) 80) ((? name) Reasoner Louis))
;; (((? address) (Ridge Road) 10) ((? name) Bitdiddle Ben))
#lang sicp
;; ===================================================================
;; =========================== ch2 Tools =============================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; ===================================================================
;; =================== ch3 (stream) Tools ============================
;; ===================================================================
(define (stream-car stream)
(car stream))
(define (stream-cdr stream)
(force (cdr stream)))
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map (cons proc (map stream-cdr argstreams))))))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream
(stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1)
delayed-s2))))
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(interleave-delayed
(force delayed-s2)
(delay (stream-cdr s1))))))
; singleton-stream
(define (singleton-stream x)
(cons-stream x the-empty-stream))
(define (stream-for-each proc s)
(if (not (stream-null? s))
(begin
(proc (stream-car s))
(stream-for-each proc
(stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
; stream-flatmap
(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed
(stream-car stream)
(delay (flatten-stream
(stream-cdr stream))))))
;; ===================================================================
;; ========================= ch4 Stuff ===============================
;; ===================================================================
; =============== 4.4.4.8
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
; =============== 4.4.4.5
(define THE-ASSERTIONS the-empty-stream)
(define (fetch-assertions pattern frame)
(if (use-index? pattern)
(get-indexed-assertions pattern)
(get-all-assertions)))
(define (get-all-assertions) THE-ASSERTIONS)
(define (get-indexed-assertions pattern)
(get-stream (index-key-of pattern)
'assertion-stream))
(define (get-stream key1 key2)
(let ((s (get key1 key2)))
(if s s the-empty-stream)))
(define THE-RULES the-empty-stream)
(define (fetch-rules pattern frame)
(if (use-index? pattern)
(get-indexed-rules pattern)
(get-all-rules)))
(define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern)
(stream-append
(get-stream (index-key-of pattern)
'rule-stream)
(get-stream '? 'rule-stream)))
(define (add-rule-or-assertion! assertion)
(if (rule? assertion)
(add-rule! assertion)
(add-assertion! assertion)))
(define (add-assertion! assertion)
(store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS
(cons-stream assertion
old-assertions))
'ok))
(define (add-rule! rule)
(store-rule-in-index rule)
(let ((old-rules THE-RULES))
(set! THE-RULES
(cons-stream rule old-rules))
'ok))
(define (store-assertion-in-index assertion)
(if (indexable? assertion)
(let ((key (index-key-of assertion)))
(let ((current-assertion-stream
(get-stream
key 'assertion-stream)))
(put key
'assertion-stream
(cons-stream
assertion
current-assertion-stream))))))
(define (store-rule-in-index rule)
(let ((pattern (conclusion rule)))
(if (indexable? pattern)
(let ((key (index-key-of pattern)))
(let ((current-rule-stream
(get-stream
key 'rule-stream)))
(put key
'rule-stream
(cons-stream
rule
current-rule-stream)))))))
(define (indexable? pat)
(or (constant-symbol? (car pat))
(var? (car pat))))
(define (index-key-of pat)
(let ((key (car pat)))
(if (var? key) '? key)))
(define (use-index? pat)
(constant-symbol? (car pat)))
; =============== 4.4.4.3 ================
(define (find-assertions pattern frame)
(stream-flatmap
(lambda (datum)
(check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
(define (check-an-assertion
assertion query-pat query-frame)
(let ((match-result
(pattern-match
query-pat assertion query-frame)))
(if (eq? match-result 'failed)
the-empty-stream
(singleton-stream match-result))))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat)
(extend-if-consistent
pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match
(cdr pat)
(cdr dat)
(pattern-match
(car pat) (car dat) frame)))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match
(binding-value binding) dat frame)
(extend var dat frame))))
;; Placeholders so the interpreter doesn't complain
(define (rule? statement)
(tagged-list? statement 'rule))
(define (conclusion rule) (cadr rule))
(define (var? exp) (tagged-list? exp '?))
(define (constant-symbol? exp) (symbol? exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
;; Relevant Code
(define (build-database)
(begin
(add-assertion! '(address (Bitdiddle Ben)
(Slumerville (Ridge Road) 10)))
(add-assertion! '(job (Bitdiddle Ben) (computer wizard)))
(add-assertion! '(salary (Bitdiddle Ben) 60000))
(add-assertion! '(address (Hacker Alyssa P)
(Cambridge (Mass Ave) 78)))
(add-assertion! '(job (Hacker Alyssa P) (computer programmer)))
(add-assertion! '(salary (Hacker Alyssa P) 40000))
(add-assertion! '(supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
(add-assertion! '(address (Fect Cy D)
(Cambridge (Ames Street) 3)))
(add-assertion! '(job (Fect Cy D) (computer programmer)))
(add-assertion! '(salary (Fect Cy D) 35000))
(add-assertion! '(supervisor (Fect Cy D) (Bitdiddle Ben)))
(add-assertion! '(address (Tweakit Lem E)
(Boston (Bay State Road) 22)))
(add-assertion! '(job (Tweakit Lem E) (computer technician)))
(add-assertion! '(salary (Tweakit Lem E) 25000))
(add-assertion! '(supervisor (Tweakit Lem E) (Bitdiddle Ben)))
(add-assertion! '(address (Reasoner Louis)
(Slumerville (Pine Tree Road) 80)))
(add-assertion! '(job (Reasoner Louis)
(computer programmer trainee)))
(add-assertion! '(salary (Reasoner Louis) 30000))
(add-assertion! '(supervisor (Reasoner Louis)
(Hacker Alyssa P)))
(add-assertion! '(supervisor (Bitdiddle Ben) (Warbucks Oliver)))
(add-assertion! '(address (Warbucks Oliver)
(Swellesley (Top Heap Road))))
(add-assertion! '(job (Warbucks Oliver)
(administration big wheel)))
(add-assertion! '(salary (Warbucks Oliver) 150000))
(add-assertion! '(address (Scrooge Eben)
(Weston (Shady Lane) 10)))
(add-assertion! '(job (Scrooge Eben)
(accounting chief accountant)))
(add-assertion! '(salary (Scrooge Eben) 75000))
(add-assertion! '(supervisor (Scrooge Eben) (Warbucks Oliver)))
(add-assertion! '(address (Cratchet Robert)
(Allston (N Harvard Street) 16)))
(add-assertion! '(job (Cratchet Robert) (accounting scrivener)))
(add-assertion! '(salary (Cratchet Robert) 18000))
(add-assertion! '(supervisor (Cratchet Robert) (Scrooge Eben)))
(add-assertion! '(address (Aull DeWitt)
(Slumerville (Onion Square) 5)))
(add-assertion! '(job (Aull DeWitt) (administration secretary)))
(add-assertion! '(salary (Aull DeWitt) 25000))
(add-assertion! '(supervisor (Aull DeWitt) (Warbucks Oliver)))))
(build-database)
(display-line "Query (supervisor ?x (Bitdiddle Ben)):")
(display-stream
(find-assertions '(supervisor (? x) (Bitdiddle Ben)) '()))
(newline)
;; (((? x) Tweakit Lem E))
;; (((? x) Fect Cy D))
;; (((? x) Hacker Alyssa P))
(display-line "Query (job ?name (accounting . ?type)):")
(display-stream
(find-assertions '(job (? name) (accounting . (? type))) '()))
(newline)
;; (((? type) scrivener) ((? name) Cratchet Robert))
;; (((? type) chief accountant) ((? name) Scrooge Eben))
(display-line "Query (address ?name (Slumerville . ?address)):")
(display-stream
(find-assertions '(address (? name) (Slumerville . (? address))) '()))
(newline)
;; (((? address) (Onion Square) 5) ((? name) Aull DeWitt))
;; (((? address) (Pine Tree Road) 80) ((? name) Reasoner Louis))
;; (((? address) (Ridge Road) 10) ((? name) Bitdiddle Ben))
ok Query (supervisor ?x (Bitdiddle Ben)): (((? x) Tweakit Lem E)) (((? x) Fect Cy D)) (((? x) Hacker Alyssa P)) Query (job ?name (accounting . ?type)): (((? type) scrivener) ((? name) Cratchet Robert)) (((? type) chief accountant) ((? name) Scrooge Eben)) Query (address ?name (Slumerville . ?address)): (((? address) (Onion Square) 5) ((? name) Aull DeWitt)) (((? address) (Pine Tree Road) 80) ((? name) Reasoner Louis)) (((? address) (Ridge Road) 10) ((? name) Bitdiddle Ben))
Next, we include all of the functions from 4.4.4.7. This is all trivial stuff and helper functions. The interesting stuff forming the driver loop is in 4.4.4.1, and most of it is not necessary.
qeval provides a layer of indirection, so that it looks up the proper function using get. This will
be used later for rules and for compound queries, but not right now.
simple-query makes sure to append all possibilities from applying both assertions and rules, but if
we only have assertions, it does nothing. I make sure to define a placeholder apply-rules that does nothing:
(define (apply-rules query-pattern frame) the-empty-stream)
Next, instantiate is interesting. In the last section we noted that our output was in terms of frames,
instantiate makes our output in terms of instantiated queries (with the variables replaced with the
variable in each frame).
Finally, the driver loop just dispatches things nicely, as well as expanding the question marks for us.
Instead of a REPL, I define a run-query function that does basically the same thing as query-driver-loop.
(define (query-driver-loop) ...)
(define (instantiate exp frame unbound-var-handler) ...)
(define (qeval query frame-stream) ...)
(define (simple-query query-pattern frame-stream) ...)
Our code can then be run more simply. The only features we use are expanding the question marks automatically
and instantiating our outputs instead of listing frames, however because we have qeval which can dispatch
to more functions, and the call to apply-rules which can later be filled in, we have all the flexibility
we need.
(build-database)
(display-line "Query (supervisor ?x (Bitdiddle Ben)):")
(display-stream
(run-query '(supervisor ?x (Bitdiddle Ben))))
(newline)
;; (supervisor (Tweakit Lem E) (Bitdiddle Ben))
;; (supervisor (Fect Cy D) (Bitdiddle Ben))
;; (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(display-line "Query (job ?name (accounting . ?type)):")
(display-stream
(run-query '(job ?name (accounting . ?type))))
(newline)
;; (job (Cratchet Robert) (accounting scrivener))
;; (job (Scrooge Eben) (accounting chief accountant))
(display-line "Query (address ?name (Slumerville . ?address)):")
(display-stream
(run-query '(address ?name (Slumerville . ?address))))
(newline)
;; (address (Aull DeWitt) (Slumerville (Onion Square) 5))
;; (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
;; (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
#lang sicp
;; ===================================================================
;; =========================== ch2 Tools =============================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; ===================================================================
;; =================== ch3 (stream) Tools ============================
;; ===================================================================
(define (stream-car stream)
(car stream))
(define (stream-cdr stream)
(force (cdr stream)))
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map (cons proc (map stream-cdr argstreams))))))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream
(stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1)
delayed-s2))))
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(interleave-delayed
(force delayed-s2)
(delay (stream-cdr s1))))))
; singleton-stream
(define (singleton-stream x)
(cons-stream x the-empty-stream))
(define (stream-for-each proc s)
(if (not (stream-null? s))
(begin
(proc (stream-car s))
(stream-for-each proc
(stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
; stream-flatmap
(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed
(stream-car stream)
(delay (flatten-stream
(stream-cdr stream))))))
;; ===================================================================
;; ========================= ch4 Stuff ===============================
;; ===================================================================
; =============== 4.4.4.8
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
; =============== 4.4.4.5
(define THE-ASSERTIONS the-empty-stream)
(define (fetch-assertions pattern frame)
(if (use-index? pattern)
(get-indexed-assertions pattern)
(get-all-assertions)))
(define (get-all-assertions) THE-ASSERTIONS)
(define (get-indexed-assertions pattern)
(get-stream (index-key-of pattern)
'assertion-stream))
(define (get-stream key1 key2)
(let ((s (get key1 key2)))
(if s s the-empty-stream)))
(define THE-RULES the-empty-stream)
(define (fetch-rules pattern frame)
(if (use-index? pattern)
(get-indexed-rules pattern)
(get-all-rules)))
(define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern)
(stream-append
(get-stream (index-key-of pattern)
'rule-stream)
(get-stream '? 'rule-stream)))
(define (add-rule-or-assertion! assertion)
(if (rule? assertion)
(add-rule! assertion)
(add-assertion! assertion)))
(define (add-assertion! assertion)
(store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS
(cons-stream assertion
old-assertions))
'ok))
(define (add-rule! rule)
(store-rule-in-index rule)
(let ((old-rules THE-RULES))
(set! THE-RULES
(cons-stream rule old-rules))
'ok))
(define (store-assertion-in-index assertion)
(if (indexable? assertion)
(let ((key (index-key-of assertion)))
(let ((current-assertion-stream
(get-stream
key 'assertion-stream)))
(put key
'assertion-stream
(cons-stream
assertion
current-assertion-stream))))))
(define (store-rule-in-index rule)
(let ((pattern (conclusion rule)))
(if (indexable? pattern)
(let ((key (index-key-of pattern)))
(let ((current-rule-stream
(get-stream
key 'rule-stream)))
(put key
'rule-stream
(cons-stream
rule
current-rule-stream)))))))
(define (indexable? pat)
(or (constant-symbol? (car pat))
(var? (car pat))))
(define (index-key-of pat)
(let ((key (car pat)))
(if (var? key) '? key)))
(define (use-index? pat)
(constant-symbol? (car pat)))
; =============== 4.4.4.3 ================
(define (find-assertions pattern frame)
(stream-flatmap
(lambda (datum)
(check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
(define (check-an-assertion
assertion query-pat query-frame)
(let ((match-result
(pattern-match
query-pat assertion query-frame)))
(if (eq? match-result 'failed)
the-empty-stream
(singleton-stream match-result))))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat)
(extend-if-consistent
pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match
(cdr pat)
(cdr dat)
(pattern-match
(car pat) (car dat) frame)))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match
(binding-value binding) dat frame)
(extend var dat frame))))
;; ======================== 4.4.4.1
;; (define input-prompt ";;; Query input:")
;; (define output-prompt ";;; Query results:")
;;
;; (define (query-driver-loop)
;; (prompt-for-input input-prompt)
;; (let ((q (query-syntax-process (read))))
;; (cond ((assertion-to-be-added? q)
;; (add-rule-or-assertion!
;; (add-assertion-body q))
;; (newline)
;; (display
;; "Assertion added to data base.")
;; (query-driver-loop))
;; (else
;; (newline)
;; (display output-prompt)
;; (display-stream
;; (stream-map
;; (lambda (frame)
;; (instantiate
;; q
;; frame
;; (lambda (v f)
;; (contract-question-mark v))))
;; (qeval q (singleton-stream '()))))
;; (query-driver-loop)))))
(define (run-query input)
(let ((q (query-syntax-process input)))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion!
(add-assertion-body q)))
(else
(stream-map
(lambda (frame)
(instantiate
q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-stream '())))))))
(define (instantiate
exp frame unbound-var-handler)
(define (copy exp)
(cond ((var? exp)
(let ((binding
(binding-in-frame
exp frame)))
(if binding
(copy
(binding-value binding))
(unbound-var-handler
exp frame))))
((pair? exp)
(cons (copy (car exp))
(copy (cdr exp))))
(else exp)))
(copy exp))
(define (qeval query frame-stream)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))
(define (simple-query query-pattern
frame-stream)
(stream-flatmap
(lambda (frame)
(stream-append-delayed
(find-assertions query-pattern frame)
(delay
(apply-rules query-pattern frame))))
frame-stream))
;; ======================= 4.4.4.7
(define (type exp)
(if (pair? exp)
(car exp)
(error "Unknown expression TYPE"
exp)))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (contents exp)
(if (pair? exp)
(cdr exp)
(error "Unknown expression CONTENTS"
exp)))
(define (assertion-to-be-added? exp)
(eq? (type exp) 'assert!))
(define (add-assertion-body exp)
(car (contents exp)))
(define (empty-conjunction? exps) (null? exps))
(define (first-conjunct exps) (car exps))
(define (rest-conjuncts exps) (cdr exps))
(define (empty-disjunction? exps) (null? exps))
(define (first-disjunct exps) (car exps))
(define (rest-disjuncts exps) (cdr exps))
(define (negated-query exps) (car exps))
(define (predicate exps) (car exps))
(define (args exps) (cdr exps))
(define (rule? statement)
(tagged-list? statement 'rule))
(define (conclusion rule) (cadr rule))
(define (rule-body rule)
(if (null? (cddr rule))
'(always-true)
(caddr rule)))
(define (query-syntax-process exp)
(map-over-symbols expand-question-mark exp))
(define (map-over-symbols proc exp)
(cond ((pair? exp)
(cons (map-over-symbols
proc (car exp))
(map-over-symbols
proc (cdr exp))))
((symbol? exp) (proc exp))
(else exp)))
(define (expand-question-mark symbol)
(let ((chars (symbol->string symbol)))
(if (string=? (substring chars 0 1) "?")
(list '? (string->symbol
(substring
chars
1
(string-length chars))))
symbol)))
(define (var? exp) (tagged-list? exp '?))
(define (constant-symbol? exp) (symbol? exp))
(define rule-counter 0)
(define (new-rule-application-id)
(set! rule-counter (+ 1 rule-counter))
rule-counter)
(define (make-new-variable
var rule-application-id)
(cons '? (cons rule-application-id
(cdr var))))
(define (contract-question-mark variable)
(string->symbol
(string-append "?"
(if (number? (cadr variable))
(string-append
(symbol->string (caddr variable))
"-"
(number->string (cadr variable)))
(symbol->string (cadr variable))))))
; placeholder for rules
(define (apply-rules query-pattern frame) the-empty-stream)
;; Relevant Code
(define (build-database)
(begin
(add-assertion! '(address (Bitdiddle Ben)
(Slumerville (Ridge Road) 10)))
(add-assertion! '(job (Bitdiddle Ben) (computer wizard)))
(add-assertion! '(salary (Bitdiddle Ben) 60000))
(add-assertion! '(address (Hacker Alyssa P)
(Cambridge (Mass Ave) 78)))
(add-assertion! '(job (Hacker Alyssa P) (computer programmer)))
(add-assertion! '(salary (Hacker Alyssa P) 40000))
(add-assertion! '(supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
(add-assertion! '(address (Fect Cy D)
(Cambridge (Ames Street) 3)))
(add-assertion! '(job (Fect Cy D) (computer programmer)))
(add-assertion! '(salary (Fect Cy D) 35000))
(add-assertion! '(supervisor (Fect Cy D) (Bitdiddle Ben)))
(add-assertion! '(address (Tweakit Lem E)
(Boston (Bay State Road) 22)))
(add-assertion! '(job (Tweakit Lem E) (computer technician)))
(add-assertion! '(salary (Tweakit Lem E) 25000))
(add-assertion! '(supervisor (Tweakit Lem E) (Bitdiddle Ben)))
(add-assertion! '(address (Reasoner Louis)
(Slumerville (Pine Tree Road) 80)))
(add-assertion! '(job (Reasoner Louis)
(computer programmer trainee)))
(add-assertion! '(salary (Reasoner Louis) 30000))
(add-assertion! '(supervisor (Reasoner Louis)
(Hacker Alyssa P)))
(add-assertion! '(supervisor (Bitdiddle Ben) (Warbucks Oliver)))
(add-assertion! '(address (Warbucks Oliver)
(Swellesley (Top Heap Road))))
(add-assertion! '(job (Warbucks Oliver)
(administration big wheel)))
(add-assertion! '(salary (Warbucks Oliver) 150000))
(add-assertion! '(address (Scrooge Eben)
(Weston (Shady Lane) 10)))
(add-assertion! '(job (Scrooge Eben)
(accounting chief accountant)))
(add-assertion! '(salary (Scrooge Eben) 75000))
(add-assertion! '(supervisor (Scrooge Eben) (Warbucks Oliver)))
(add-assertion! '(address (Cratchet Robert)
(Allston (N Harvard Street) 16)))
(add-assertion! '(job (Cratchet Robert) (accounting scrivener)))
(add-assertion! '(salary (Cratchet Robert) 18000))
(add-assertion! '(supervisor (Cratchet Robert) (Scrooge Eben)))
(add-assertion! '(address (Aull DeWitt)
(Slumerville (Onion Square) 5)))
(add-assertion! '(job (Aull DeWitt) (administration secretary)))
(add-assertion! '(salary (Aull DeWitt) 25000))
(add-assertion! '(supervisor (Aull DeWitt) (Warbucks Oliver)))))
(build-database)
(display-line "Query (supervisor ?x (Bitdiddle Ben)):")
(display-stream
(run-query '(supervisor ?x (Bitdiddle Ben))))
(newline)
;; (supervisor (Tweakit Lem E) (Bitdiddle Ben))
;; (supervisor (Fect Cy D) (Bitdiddle Ben))
;; (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(display-line "Query (job ?name (accounting . ?type)):")
(display-stream
(run-query '(job ?name (accounting . ?type))))
(newline)
;; (job (Cratchet Robert) (accounting scrivener))
;; (job (Scrooge Eben) (accounting chief accountant))
(display-line "Query (address ?name (Slumerville . ?address)):")
(display-stream
(run-query '(address ?name (Slumerville . ?address))))
(newline)
;; (address (Aull DeWitt) (Slumerville (Onion Square) 5))
;; (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
;; (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
ok Query (supervisor ?x (Bitdiddle Ben)): (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (supervisor (Fect Cy D) (Bitdiddle Ben)) (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) Query (job ?name (accounting . ?type)): (job (Cratchet Robert) (accounting scrivener)) (job (Scrooge Eben) (accounting chief accountant)) Query (address ?name (Slumerville . ?address)): (address (Aull DeWitt) (Slumerville (Onion Square) 5)) (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)) (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
#lang sicp
;; ===================================================================
;; =========================== ch2 Tools =============================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; ===================================================================
;; =================== ch3 (stream) Tools ============================
;; ===================================================================
(define (stream-car stream)
(car stream))
(define (stream-cdr stream)
(force (cdr stream)))
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map (cons proc (map stream-cdr argstreams))))))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream
(stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1)
delayed-s2))))
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(interleave-delayed
(force delayed-s2)
(delay (stream-cdr s1))))))
; singleton-stream
(define (singleton-stream x)
(cons-stream x the-empty-stream))
(define (stream-for-each proc s)
(if (not (stream-null? s))
(begin
(proc (stream-car s))
(stream-for-each proc
(stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
; stream-flatmap
(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed
(stream-car stream)
(delay (flatten-stream
(stream-cdr stream))))))
;; ===================================================================
;; ========================= ch4 Stuff ===============================
;; ===================================================================
; =============== 4.4.4.8
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
; =============== 4.4.4.5
(define THE-ASSERTIONS the-empty-stream)
(define (fetch-assertions pattern frame)
(if (use-index? pattern)
(get-indexed-assertions pattern)
(get-all-assertions)))
(define (get-all-assertions) THE-ASSERTIONS)
(define (get-indexed-assertions pattern)
(get-stream (index-key-of pattern)
'assertion-stream))
(define (get-stream key1 key2)
(let ((s (get key1 key2)))
(if s s the-empty-stream)))
(define THE-RULES the-empty-stream)
(define (fetch-rules pattern frame)
(if (use-index? pattern)
(get-indexed-rules pattern)
(get-all-rules)))
(define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern)
(stream-append
(get-stream (index-key-of pattern)
'rule-stream)
(get-stream '? 'rule-stream)))
(define (add-rule-or-assertion! assertion)
(if (rule? assertion)
(add-rule! assertion)
(add-assertion! assertion)))
(define (add-assertion! assertion)
(store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS
(cons-stream assertion
old-assertions))
'ok))
(define (add-rule! rule)
(store-rule-in-index rule)
(let ((old-rules THE-RULES))
(set! THE-RULES
(cons-stream rule old-rules))
'ok))
(define (store-assertion-in-index assertion)
(if (indexable? assertion)
(let ((key (index-key-of assertion)))
(let ((current-assertion-stream
(get-stream
key 'assertion-stream)))
(put key
'assertion-stream
(cons-stream
assertion
current-assertion-stream))))))
(define (store-rule-in-index rule)
(let ((pattern (conclusion rule)))
(if (indexable? pattern)
(let ((key (index-key-of pattern)))
(let ((current-rule-stream
(get-stream
key 'rule-stream)))
(put key
'rule-stream
(cons-stream
rule
current-rule-stream)))))))
(define (indexable? pat)
(or (constant-symbol? (car pat))
(var? (car pat))))
(define (index-key-of pat)
(let ((key (car pat)))
(if (var? key) '? key)))
(define (use-index? pat)
(constant-symbol? (car pat)))
; =============== 4.4.4.3 ================
(define (find-assertions pattern frame)
(stream-flatmap
(lambda (datum)
(check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
(define (check-an-assertion
assertion query-pat query-frame)
(let ((match-result
(pattern-match
query-pat assertion query-frame)))
(if (eq? match-result 'failed)
the-empty-stream
(singleton-stream match-result))))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat)
(extend-if-consistent
pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match
(cdr pat)
(cdr dat)
(pattern-match
(car pat) (car dat) frame)))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match
(binding-value binding) dat frame)
(extend var dat frame))))
;; ======================== 4.4.4.1
;; (define input-prompt ";;; Query input:")
;; (define output-prompt ";;; Query results:")
;;
;; (define (query-driver-loop)
;; (prompt-for-input input-prompt)
;; (let ((q (query-syntax-process (read))))
;; (cond ((assertion-to-be-added? q)
;; (add-rule-or-assertion!
;; (add-assertion-body q))
;; (newline)
;; (display
;; "Assertion added to data base.")
;; (query-driver-loop))
;; (else
;; (newline)
;; (display output-prompt)
;; (display-stream
;; (stream-map
;; (lambda (frame)
;; (instantiate
;; q
;; frame
;; (lambda (v f)
;; (contract-question-mark v))))
;; (qeval q (singleton-stream '()))))
;; (query-driver-loop)))))
(define (run-query input)
(let ((q (query-syntax-process input)))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion!
(add-assertion-body q)))
(else
(stream-map
(lambda (frame)
(instantiate
q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-stream '())))))))
(define (instantiate
exp frame unbound-var-handler)
(define (copy exp)
(cond ((var? exp)
(let ((binding
(binding-in-frame
exp frame)))
(if binding
(copy
(binding-value binding))
(unbound-var-handler
exp frame))))
((pair? exp)
(cons (copy (car exp))
(copy (cdr exp))))
(else exp)))
(copy exp))
(define (qeval query frame-stream)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))
(define (simple-query query-pattern
frame-stream)
(stream-flatmap
(lambda (frame)
(stream-append-delayed
(find-assertions query-pattern frame)
(delay
(apply-rules query-pattern frame))))
frame-stream))
;; ======================= 4.4.4.7
(define (type exp)
(if (pair? exp)
(car exp)
(error "Unknown expression TYPE"
exp)))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (contents exp)
(if (pair? exp)
(cdr exp)
(error "Unknown expression CONTENTS"
exp)))
(define (assertion-to-be-added? exp)
(eq? (type exp) 'assert!))
(define (add-assertion-body exp)
(car (contents exp)))
(define (empty-conjunction? exps) (null? exps))
(define (first-conjunct exps) (car exps))
(define (rest-conjuncts exps) (cdr exps))
(define (empty-disjunction? exps) (null? exps))
(define (first-disjunct exps) (car exps))
(define (rest-disjuncts exps) (cdr exps))
(define (negated-query exps) (car exps))
(define (predicate exps) (car exps))
(define (args exps) (cdr exps))
(define (rule? statement)
(tagged-list? statement 'rule))
(define (conclusion rule) (cadr rule))
(define (rule-body rule)
(if (null? (cddr rule))
'(always-true)
(caddr rule)))
(define (query-syntax-process exp)
(map-over-symbols expand-question-mark exp))
(define (map-over-symbols proc exp)
(cond ((pair? exp)
(cons (map-over-symbols
proc (car exp))
(map-over-symbols
proc (cdr exp))))
((symbol? exp) (proc exp))
(else exp)))
(define (expand-question-mark symbol)
(let ((chars (symbol->string symbol)))
(if (string=? (substring chars 0 1) "?")
(list '? (string->symbol
(substring
chars
1
(string-length chars))))
symbol)))
(define (var? exp) (tagged-list? exp '?))
(define (constant-symbol? exp) (symbol? exp))
(define rule-counter 0)
(define (new-rule-application-id)
(set! rule-counter (+ 1 rule-counter))
rule-counter)
(define (make-new-variable
var rule-application-id)
(cons '? (cons rule-application-id
(cdr var))))
(define (contract-question-mark variable)
(string->symbol
(string-append "?"
(if (number? (cadr variable))
(string-append
(symbol->string (caddr variable))
"-"
(number->string (cadr variable)))
(symbol->string (cadr variable))))))
;; ======================== 4.4.4.2 Compound Queries
(define user-initial-environment (scheme-report-environment 5))
(define (always-true ignore frame-stream)
frame-stream)
(put 'always-true 'qeval always-true)
(define (execute exp)
(apply (eval (predicate exp)
user-initial-environment)
(args exp)))
(define (lisp-value call frame-stream)
(stream-flatmap
(lambda (frame)
(if (execute
(instantiate
call
frame
(lambda (v f)
(error
"Unknown pat var: LISP-VALUE"
v))))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(put 'lisp-value 'qeval lisp-value)
(define (negate operands frame-stream)
(stream-flatmap
(lambda (frame)
(if (stream-null?
(qeval (negated-query operands)
(singleton-stream frame)))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(put 'not 'qeval negate)
(define (conjoin conjuncts frame-stream)
(if (empty-conjunction? conjuncts)
frame-stream
(conjoin (rest-conjuncts conjuncts)
(qeval
(first-conjunct conjuncts)
frame-stream))))
(put 'and 'qeval conjoin)
(define (disjoin disjuncts frame-stream)
(if (empty-disjunction? disjuncts)
the-empty-stream
(interleave-delayed
(qeval (first-disjunct disjuncts)
frame-stream)
(delay (disjoin
(rest-disjuncts disjuncts)
frame-stream)))))
(put 'or 'qeval disjoin)
; placeholder for rules
(define (apply-rules query-pattern frame) the-empty-stream)
;; Relevant Code
(define (build-database)
(begin
(add-assertion! '(address (Bitdiddle Ben)
(Slumerville (Ridge Road) 10)))
(add-assertion! '(job (Bitdiddle Ben) (computer wizard)))
(add-assertion! '(salary (Bitdiddle Ben) 60000))
(add-assertion! '(address (Hacker Alyssa P)
(Cambridge (Mass Ave) 78)))
(add-assertion! '(job (Hacker Alyssa P) (computer programmer)))
(add-assertion! '(salary (Hacker Alyssa P) 40000))
(add-assertion! '(supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
(add-assertion! '(address (Fect Cy D)
(Cambridge (Ames Street) 3)))
(add-assertion! '(job (Fect Cy D) (computer programmer)))
(add-assertion! '(salary (Fect Cy D) 35000))
(add-assertion! '(supervisor (Fect Cy D) (Bitdiddle Ben)))
(add-assertion! '(address (Tweakit Lem E)
(Boston (Bay State Road) 22)))
(add-assertion! '(job (Tweakit Lem E) (computer technician)))
(add-assertion! '(salary (Tweakit Lem E) 25000))
(add-assertion! '(supervisor (Tweakit Lem E) (Bitdiddle Ben)))
(add-assertion! '(address (Reasoner Louis)
(Slumerville (Pine Tree Road) 80)))
(add-assertion! '(job (Reasoner Louis)
(computer programmer trainee)))
(add-assertion! '(salary (Reasoner Louis) 30000))
(add-assertion! '(supervisor (Reasoner Louis)
(Hacker Alyssa P)))
(add-assertion! '(supervisor (Bitdiddle Ben) (Warbucks Oliver)))
(add-assertion! '(address (Warbucks Oliver)
(Swellesley (Top Heap Road))))
(add-assertion! '(job (Warbucks Oliver)
(administration big wheel)))
(add-assertion! '(salary (Warbucks Oliver) 150000))
(add-assertion! '(address (Scrooge Eben)
(Weston (Shady Lane) 10)))
(add-assertion! '(job (Scrooge Eben)
(accounting chief accountant)))
(add-assertion! '(salary (Scrooge Eben) 75000))
(add-assertion! '(supervisor (Scrooge Eben) (Warbucks Oliver)))
(add-assertion! '(address (Cratchet Robert)
(Allston (N Harvard Street) 16)))
(add-assertion! '(job (Cratchet Robert) (accounting scrivener)))
(add-assertion! '(salary (Cratchet Robert) 18000))
(add-assertion! '(supervisor (Cratchet Robert) (Scrooge Eben)))
(add-assertion! '(address (Aull DeWitt)
(Slumerville (Onion Square) 5)))
(add-assertion! '(job (Aull DeWitt) (administration secretary)))
(add-assertion! '(salary (Aull DeWitt) 25000))
(add-assertion! '(supervisor (Aull DeWitt) (Warbucks Oliver)))))
(build-database)
(display-line "Query (and (supervisor ?x (Bitdiddle Ben))
(address ?x ?address)):")
(display-stream
(run-query
'(and (supervisor ?x (Bitdiddle Ben))
(address ?x ?address))))
(newline)
(display-line "Query (and (supervisor ?person ?super)
(job ?super (?division . ?type))
(not (job ?super (computer . ?type)))):")
(display-stream
(run-query '(and (supervisor ?person ?super)
(job ?super (?division . ?type))
(not (job ?super (computer . ?type))))))
(newline)
(display-line "Query (and (salary (Bitdiddle Ben) ?benamount)
(salary ?person ?personamount)
(lisp-value < ?personamount ?benamount)):")
(display-stream
(run-query '(and (salary (Bitdiddle Ben) ?benamount)
(salary ?person ?personamount)
(lisp-value < ?personamount ?benamount))))
(newline)
ok
Query (and (supervisor ?x (Bitdiddle Ben))
(address ?x ?address)):
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
Query (and (supervisor ?person ?super)
(job ?super (?division . ?type))
(not (job ?super (computer . ?type)))):
(and (supervisor (Aull DeWitt) (Warbucks Oliver)) (job (Warbucks Oliver) (administration big wheel)) (not (job (Warbucks Oliver) (computer big wheel))))
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (job (Scrooge Eben) (accounting chief accountant)) (not (job (Scrooge Eben) (computer chief accountant))))
(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (job (Warbucks Oliver) (administration big wheel)) (not (job (Warbucks Oliver) (computer big wheel))))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (job (Warbucks Oliver) (administration big wheel)) (not (job (Warbucks Oliver) (computer big wheel))))
Query (and (salary (Bitdiddle Ben) ?benamount)
(salary ?person ?personamount)
(lisp-value < ?personamount ?benamount)):
(and (salary (Bitdiddle Ben) 60000) (salary (Aull DeWitt) 25000) (lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Cratchet Robert) 18000) (lisp-value < 18000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Reasoner Louis) 30000) (lisp-value < 30000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Tweakit Lem E) 25000) (lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Fect Cy D) 35000) (lisp-value < 35000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Hacker Alyssa P) 40000) (lisp-value < 40000 60000))
In 4.4.1, we give the example of the query:
(and (job ?person (computer programmer))
(address ?person ?where))
giving the output
(and (job (Hacker Alyssa P)
(computer programmer))
(address (Hacker Alyssa P)
(Cambridge (Mass Ave) 78)))
(and (job (Fect Cy D) (computer programmer))
(address (Fect Cy D)
(Cambridge (Ames Street) 3)))
The book also says "the output of the query is a stream of frames."
You might think this means that our two (and ...) statements are the
two elements in the stream of frames, but this is incorrect! In my opinion
the book's phrasing is highly misleading here, the stream of frames which is
relevant to our query has two elements, which are:
'(((? person) . (Hacker Alyssa P)) ((? where) . (Cambridge (Mass Ave) 78)))
'(((? person) . (Fect Cy D)) ((? where) . (Cambridge (Ames Street) 3)))
Later (in 4.4.4.1) we instantiate those frames using the input query expression, the
frame, and a function to handle unbound variables:
(define (instantiate
exp frame unbound-var-handler) ...)