mirror of
https://github.com/correl/sicp.git
synced 2024-11-23 19:19:56 +00:00
27 KiB
27 KiB
4.4 - Logic Programming
- COMMENT Set up source file
- Deductive Information Retrieval
- How the Query System Works
- Is Logic Programming Mathematical Logic?
- Implementing the Query System
This section seems to describe all the cool things that turned me on to Prolog.
COMMENT Set up source file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 4.4 - Logic Programming
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load "3-5.scheme") ;; Stream functions
(load "4-3.scheme") ;; All the things so farDeductive Information Retrieval
A sample data base
;; The personnel data base for Microshaft contains "assertions" about
;; company personnel. Here is the information about Ben Bitdiddle, the
;; resident computer wizard:
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
(job (Bitdiddle Ben) (computer wizard))
(salary (Bitdiddle Ben) 60000)
;; Each assertion is a list (in this case a triple) whose elements can
;; themselves be lists.
;; As resident wizard, Ben is in charge of the company's computer
;; division, and he supervises two programmers and one technician. Here
;; is the information about them:
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
(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))
(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))
(job (Tweakit Lem E) (computer technician))
(salary (Tweakit Lem E) 25000)
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
;; There is also a programmer trainee, who is supervised by Alyssa:
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(job (Reasoner Louis) (computer programmer trainee))
(salary (Reasoner Louis) 30000)
(supervisor (Reasoner Louis) (Hacker Alyssa P))
;; All of these people are in the computer division, as indicated by
;; the word `computer' as the first item in their job descriptions.
;; Ben is a high-level employee. His supervisor is the company's big
;; wheel himself:
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
(address (Warbucks Oliver) (Swellesley (Top Heap Road)))
(job (Warbucks Oliver) (administration big wheel))
(salary (Warbucks Oliver) 150000)
;; Besides the computer division supervised by Ben, the company has an
;; accounting division, consisting of a chief accountant and his assistant:
(address (Scrooge Eben) (Weston (Shady Lane) 10))
(job (Scrooge Eben) (accounting chief accountant))
(salary (Scrooge Eben) 75000)
(supervisor (Scrooge Eben) (Warbucks Oliver))
(address (Cratchet Robert) (Allston (N Harvard Street) 16))
(job (Cratchet Robert) (accounting scrivener))
(salary (Cratchet Robert) 18000)
(supervisor (Cratchet Robert) (Scrooge Eben))
;; There is also a secretary for the big wheel:
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(job (Aull DeWitt) (administration secretary))
(salary (Aull DeWitt) 25000)
(supervisor (Aull DeWitt) (Warbucks Oliver))
;; The data base also contains assertions about which kinds of jobs can
;; be done by people holding other kinds of jobs. For instance, a
;; computer wizard can do the jobs of both a computer programmer and a
;; computer technician:
(can-do-job (computer wizard) (computer programmer))
(can-do-job (computer wizard) (computer technician))
;; A computer programmer could fill in for a trainee:
(can-do-job (computer programmer)
(computer programmer trainee))
;; Also, as is well known,
(can-do-job (administration secretary)
(administration big wheel))Prolog
For the sake of having something to play with, the knowledgebase is converted to prolog below:
%% -*- mode: prolog -*-
<<gen-pl-knowledgebase()>>Simple queries
Queries are performed by unifying patterns against known facts and rules. Variables in patterns are bound as the pattern is matched, and results are returned for all successful matches.
Compound queries
Simple queries form the primitive operations of the query language. In order to form compound operations, the query language provides means of combination.
As for simple queries, the system processes a compound query by finding all assignments to the pattern variables that satisfy the query, then displaying instantiations of the query with those values.
Exercise 4.56
Formulate compound queries that retrieve the following information:
-
the names of all people who are supervised by Ben Bitdiddle, together with their addresses;
(and (supervisor ?person (Bitdiddle Ben)) (address ?person ?where)) -
all people whose salary is less than Ben Bitdiddle's, together with their salary and Ben Bitdiddle's salary;
(and (salary (Bitdiddle Ben) ?salary-ben) (salary ?person ?salary-person) (< ?salary-person ?salary-ben)) -
all people who are supervised by someone who is not in the computer division, together with the supervisor's name and job.
(and (supervisor ?person ?supervisor) (job ?supervisor ?supervisor-job) (not (job ?supervisor (computer . ?))))
Rules
Rules are a tool for abstracting queries
(rule (lives-near ?person-1 ?person-2)
(and (address ?person-1 (?town . ?rest-1))
(address ?person-2 (?town . ?rest-2))
(not (same ?person-1 ?person-2))))The same rule would be expressed in Prolog as:
lives_near(Person1, Person2) :-
address(Person1, [Town|_]),
address(Person2, [Town|_]),
Person1 \= Person2.Exercise 4.57
Define a rule that says that person 1 can replace person 2 if either person 1 does the same job as person 2 or someone who does person 1's job can also do person 2's job, and if person 1 and person 2 are not the same person. Using your rule, give queries that find the following:
- all people who can replace Cy D. Fect;
- all people who can replace someone who is being paid more than they are, together with the two salaries.
(rule (can-replace ?person-1 ?person-2)
(and (job ?person-1 ?job-1)
(job ?person-2 ?job-2)
(not (same ?person-1 ?person-2))
(or (same ?job-1 ?job-2)
(can-do-job ?job-1 ?job-2))))
(can-replace ?person (Cy D Fect))
(and (can-replace ?person-1 ?person-2)
(salary ?person-1 ?salary-1)
(salary ?person-2 ?salary-2)
(< ?salary-1 ?salary-2)) can_replace(P1, P2) :-
job(P1, J1),
job(P2, J2),
(J1 == J2; can_do_job(J1, J2)),
P1 \= P2.
can_replace_for_cheap(P1, P2, S1, S2) :-
can_replace(P1, P2),
salary(P1, S1),
salary(P2, S2),
S1 > S2.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.
(rule (big-shot ?person)
(job ?person (?division . ?))
(supervisor ?person ?supervisor)
(not (job ?supervisor (?division . ?)))) big_shot(Person) :-
job(Person, [Division|_]),
supervisor(Person, Supervisor),
job(Supervisor, [SDivision|_]),
Division \= SDivision.Exercise 4.59
Ben Bitdiddle has missed one meeting too many. Fearing that his habit of forgetting meetings could cost him his job, Ben decides to do something about it. He adds all the weekly meetings of the firm to the Microshaft data base by asserting the following:
(meeting accounting (Monday 9am))
(meeting administration (Monday 10am))
(meeting computer (Wednesday 3pm))
(meeting administration (Friday 1pm)) meeting(accounting, [monday, '9am']).
meeting(administration, [monday, '10am']).
meeting(computer, [wednesday, '3pm']).
meeting(administration, [friday, '1pm']).Each of the above assertions is for a meeting of an entire division. Ben also adds an entry for the company-wide meeting that spans all the divisions. All of the company's employees attend this meeting.
(meeting whole-company (Wednesday 4pm)) meeting(whole_company, [wednesday, '4pm']).-
On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use?
(meeting ?who (Friday ?when))meeting(Who, [friday, When]). -
Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all `whole-company' meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule.
(rule (meeting-time ?person ?day-and-time) <RULE-BODY>)
(rule (meeting-time ?person ?day-and-time) (and (job ?person (?department . ?)) (or (meeting whole-company ?day-and-time) (meeting ?department ?day-and-time))))meeting_time(Person, DayAndTime) :- job(Person, [Department|_]), (meeting(whole_company, DayAndTime); meeting(Department, DayAndTime)). -
Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out?
(meeting-time (Hacker Alyssa P) (Wednesday ?))meeting_time([hacker, alyssa, p], [wednesday, _]).
Exercise 4.60
By giving the query
(lives-near ?person (Hacker Alyssa P))Alyssa P. Hacker is able to find people who live near her, with whom she can ride to work. On the other hand, when she tries to find all pairs of people who live near each other by querying
(lives-near ?person-1 ?person-2)she notices that each pair of people who live near each other is listed twice; for example,
(lives-near (Hacker Alyssa P) (Fect Cy D))
(lives-near (Fect Cy D) (Hacker Alyssa P))Why does this happen? Is there a way to find a list of people who live near each other, in which each pair appears only once? Explain.
Logic as programs
(rule (append-to-form () ?y ?y))
(rule (append-to-form (?u . ?v) ?y (?u . ?z))
(append-to-form ?v ?y ?z)) append([], L, L).
append([H|T], L2, [H|L3]) :-
append(T, L2, L3).How the Query System Works
Pattern matching
Streams of frames
Compound queries
Unification
Applying rules
Simple queries
The query evaluator and the driver loop
Is Logic Programming Mathematical Logic?
Infinite loops
Problems with `not'
Implementing the Query System
The Driver Loop and Instantiation
(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 (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))The Evaluator
(define (qeval query frame-stream)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))Simple queries
(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))Compound queries
(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)Filters
(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 (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 (execute exp)
(apply (eval (predicate exp) user-initial-environment)
(args exp))) (define (always-true ignore frame-stream) frame-stream)
(put 'always-true 'qeval always-true)Finding Assertions by Pattern Matching
(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))))Rules and Unification
(define (apply-rules pattern frame)
(stream-flatmap (lambda (rule)
(apply-a-rule rule pattern frame))
(fetch-rules pattern frame))) (define (apply-a-rule rule query-pattern query-frame)
(let ((clean-rule (rename-variables-in rule)))
(let ((unify-result
(unify-match query-pattern
(conclusion clean-rule)
query-frame)))
(if (eq? unify-result 'failed)
the-empty-stream
(qeval (rule-body clean-rule)
(singleton-stream unify-result)))))) (define (rename-variables-in rule)
(let ((rule-application-id (new-rule-application-id)))
(define (tree-walk exp)
(cond ((var? exp)
(make-new-variable exp rule-application-id))
((pair? exp)
(cons (tree-walk (car exp))
(tree-walk (cdr exp))))
(else exp)))
(tree-walk rule))) (define (unify-match p1 p2 frame)
(cond ((eq? frame 'failed) 'failed)
((equal? p1 p2) frame)
((var? p1) (extend-if-possible p1 p2 frame))
((var? p2) (extend-if-possible p2 p1 frame)) ; ***
((and (pair? p1) (pair? p2))
(unify-match (cdr p1)
(cdr p2)
(unify-match (car p1)
(car p2)
frame)))
(else 'failed))) (define (extend-if-possible var val frame)
(let ((binding (binding-in-frame var frame)))
(cond (binding
(unify-match
(binding-value binding) val frame))
((var? val) ; ***
(let ((binding (binding-in-frame val frame)))
(if binding
(unify-match
var (binding-value binding) frame)
(extend var val frame))))
((depends-on? val var frame) ; ***
'failed)
(else (extend var val frame))))) (define (depends-on? exp var frame)
(define (tree-walk e)
(cond ((var? e)
(if (equal? var e)
true
(let ((b (binding-in-frame e frame)))
(if b
(tree-walk (binding-value b))
false))))
((pair? e)
(or (tree-walk (car e))
(tree-walk (cdr e))))
(else false)))
(tree-walk exp))Maintaining the Data Base
(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)))Stream Operations
(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)))))) (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)))))) (define (singleton-stream x)
(cons-stream x the-empty-stream))Query Syntax Procedures
(define (type exp)
(if (pair? exp)
(car exp)
(error "Unknown expression TYPE" exp)))
(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))))))Frames and Bindings
(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))