mirror of
https://github.com/correl/sicp.git
synced 2024-11-23 11:09:57 +00:00
4.4 WIP
This commit is contained in:
parent
9fd6165df1
commit
4b9c9d6412
2 changed files with 918 additions and 19 deletions
38
4-1.org
38
4-1.org
|
|
@ -408,40 +408,40 @@ Borrowed from [[http://wqzhang.wordpress.com/2009/09/17/sicp-exercise-4-3/][Weiq
|
||||||
;; Exercise 4.3
|
;; Exercise 4.3
|
||||||
;; -------------------------------------------------------------------
|
;; -------------------------------------------------------------------
|
||||||
|
|
||||||
(define eval-table (make-eq-hash-table))
|
(define *op-table* (make-eq-hash-table))
|
||||||
(define (get key)
|
(define (get op type)
|
||||||
(hash-table/get eval-table key #f))
|
(hash-table/get *op-table* (list op type) #f))
|
||||||
(define (put key proc)
|
(define (put op type proc)
|
||||||
(hash-table/put! eval-table key proc))
|
(hash-table/put! *op-table* (list op type) proc))
|
||||||
|
|
||||||
(define (eval exp env)
|
(define (eval exp env)
|
||||||
(cond ((self-evaluating? exp) exp)
|
(cond ((self-evaluating? exp) exp)
|
||||||
((variable? exp) (lookup-variable-value exp env))
|
((variable? exp) (lookup-variable-value exp env))
|
||||||
((get (car exp))
|
((get (car exp) 'eval)
|
||||||
((get (car exp)) exp env))
|
((get (car exp) 'eval) exp env))
|
||||||
((application? exp)
|
((application? exp)
|
||||||
(apply (eval (operator exp) env)
|
(apply (eval (operator exp) env)
|
||||||
(list-of-values (operands exp) env)))
|
(list-of-values (operands exp) env)))
|
||||||
(else
|
(else
|
||||||
(error "Unknown expression type -- EVAL" exp))))
|
(error "Unknown expression type -- EVAL" exp))))
|
||||||
|
|
||||||
(put 'quote
|
(put 'quote 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(text-of-quotation exp)))
|
(text-of-quotation exp)))
|
||||||
(put 'set!
|
(put 'set! 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(eval-assignment exp env)))
|
(eval-assignment exp env)))
|
||||||
(put 'define eval-definition)
|
(put 'define 'eval eval-definition)
|
||||||
(put 'if eval-if)
|
(put 'if 'eval eval-if)
|
||||||
(put 'lambda
|
(put 'lambda 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(make-procedure (lambda-parameters exp)
|
(make-procedure (lambda-parameters exp)
|
||||||
(lambda-body exp)
|
(lambda-body exp)
|
||||||
env)))
|
env)))
|
||||||
(put 'begin
|
(put 'begin 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(eval-sequence (begin-actions exp) env)))
|
(eval-sequence (begin-actions exp) env)))
|
||||||
(put 'cond
|
(put 'cond 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(eval (cond->if exp) env)))
|
(eval (cond->if exp) env)))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
@ -496,8 +496,8 @@ and ~or~ as derived expressions.
|
||||||
(eval-or-operands rest)))))
|
(eval-or-operands rest)))))
|
||||||
(eval-or-operands (operands exp)))
|
(eval-or-operands (operands exp)))
|
||||||
|
|
||||||
(put 'and eval-and)
|
(put 'and 'eval eval-and)
|
||||||
(put 'or eval-or)
|
(put 'or 'eval eval-or)
|
||||||
|
|
||||||
;; Derived expressions
|
;; Derived expressions
|
||||||
|
|
||||||
|
|
@ -588,7 +588,7 @@ expressions.
|
||||||
(map cadr var-alist))))
|
(map cadr var-alist))))
|
||||||
|
|
||||||
|
|
||||||
(put 'let
|
(put 'let 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(eval (let->combination exp) env)))
|
(eval (let->combination exp) env)))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
@ -646,7 +646,7 @@ expressions?
|
||||||
(nested-let (cadr exp)
|
(nested-let (cadr exp)
|
||||||
(cddr exp)))
|
(cddr exp)))
|
||||||
|
|
||||||
(put 'let*
|
(put 'let* 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(eval (let*->nested-lets exp) env)))
|
(eval (let*->nested-lets exp) env)))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
@ -708,7 +708,7 @@ Modify ~let->combination~ of [[Exercise 4.6]] to also support named ~let~.
|
||||||
(cdddr exp)))
|
(cdddr exp)))
|
||||||
(else (error "Invalid expression -- LET"))))
|
(else (error "Invalid expression -- LET"))))
|
||||||
|
|
||||||
(put 'let
|
(put 'let 'eval
|
||||||
(lambda (exp env)
|
(lambda (exp env)
|
||||||
(eval (let->combination exp) env)))
|
(eval (let->combination exp) env)))
|
||||||
#+END_SRC
|
#+END_SRC
|
||||||
|
|
|
||||||
899
4-4.org
Normal file
899
4-4.org
Normal file
|
|
@ -0,0 +1,899 @@
|
||||||
|
#+TITLE: 4.4 - Logic Programming
|
||||||
|
#+STARTUP: indent
|
||||||
|
#+OPTIONS: num:nil
|
||||||
|
|
||||||
|
- [[file:4-4.org][Raw org source]]
|
||||||
|
- [[file:4-4.org.html][Htmlized org source]]
|
||||||
|
|
||||||
|
This section seems to describe all the cool things that turned me on
|
||||||
|
to Prolog.
|
||||||
|
* COMMENT Set up source file
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; 4.4 - Logic Programming
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(load "3-5.scheme") ;; Stream functions
|
||||||
|
(load "4-3.scheme") ;; All the things so far
|
||||||
|
|
||||||
|
#+END_SRC
|
||||||
|
* Deductive Information Retrieval
|
||||||
|
|
||||||
|
** A sample data base
|
||||||
|
#+name: knowledgebase
|
||||||
|
#+BEGIN_SRC scheme :tangle 4-4-1-kb.scheme
|
||||||
|
;; 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))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
*** Prolog
|
||||||
|
#+name: gen-pl-knowledgebase
|
||||||
|
#+BEGIN_SRC emacs-lisp :noweb yes :exports none
|
||||||
|
(defun pl-symbol (symbol)
|
||||||
|
(->> symbol
|
||||||
|
symbol-name
|
||||||
|
s-downcase
|
||||||
|
(s-replace "-" "_")))
|
||||||
|
|
||||||
|
(defun pl-sequence (sequence)
|
||||||
|
(s-join ", " (mapcar #'pl-term sequence)))
|
||||||
|
|
||||||
|
(defun pl-list (sequence)
|
||||||
|
(s-concat "["
|
||||||
|
(pl-sequence sequence)
|
||||||
|
"]"))
|
||||||
|
|
||||||
|
(defun pl-term (term)
|
||||||
|
(cond ((symbolp term) (pl-symbol term))
|
||||||
|
((listp term) (pl-list term))
|
||||||
|
(t (format "%s" term))))
|
||||||
|
|
||||||
|
(defun pl-fact (sequence)
|
||||||
|
(s-concat (pl-symbol (car sequence))
|
||||||
|
"("
|
||||||
|
(pl-sequence (cdr sequence))
|
||||||
|
")."))
|
||||||
|
|
||||||
|
(let ((facts (mapcar #'pl-fact (quote (
|
||||||
|
<<knowledgebase>>
|
||||||
|
)))))
|
||||||
|
(s-join "\n" (sort facts #'string-lessp)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
For the sake of having something to play with, the knowledgebase is
|
||||||
|
converted to prolog below:
|
||||||
|
|
||||||
|
#+name: pl-knowledgebase
|
||||||
|
#+caption: [[file:4-4-kb.pl]]
|
||||||
|
#+BEGIN_SRC prolog :noweb yes :tangle yes :exports code
|
||||||
|
%% -*- mode: prolog -*-
|
||||||
|
|
||||||
|
<<gen-pl-knowledgebase()>>
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** 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
|
||||||
|
|
||||||
|
#+BEGIN_QUOTE
|
||||||
|
Simple queries form the primitive operations of the query language.
|
||||||
|
In order to form compound operations, the query language provides
|
||||||
|
means of combination.
|
||||||
|
#+END_QUOTE
|
||||||
|
|
||||||
|
#+BEGIN_QUOTE
|
||||||
|
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.
|
||||||
|
#+END_QUOTE
|
||||||
|
|
||||||
|
*** Exercise 4.56
|
||||||
|
Formulate compound queries that retrieve the following information:
|
||||||
|
|
||||||
|
a. the names of all people who are supervised by Ben Bitdiddle,
|
||||||
|
together with their addresses;
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(and (supervisor ?person (Bitdiddle Ben))
|
||||||
|
(address ?person ?where))
|
||||||
|
#+END_SRC
|
||||||
|
b. all people whose salary is less than Ben Bitdiddle's,
|
||||||
|
together with their salary and Ben Bitdiddle's salary;
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(and (salary (Bitdiddle Ben) ?salary-ben)
|
||||||
|
(salary ?person ?salary-person)
|
||||||
|
(< ?salary-person ?salary-ben))
|
||||||
|
#+END_SRC
|
||||||
|
c. all people who are supervised by someone who is not in the
|
||||||
|
computer division, together with the supervisor's name and
|
||||||
|
job.
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(and (supervisor ?person ?supervisor)
|
||||||
|
(job ?supervisor ?supervisor-job)
|
||||||
|
(not (job ?supervisor (computer . ?))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** Rules
|
||||||
|
Rules are a tool for abstracting queries
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(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))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
The same rule would be expressed in Prolog as:
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog :tangle yes
|
||||||
|
lives_near(Person1, Person2) :-
|
||||||
|
address(Person1, [Town|_]),
|
||||||
|
address(Person2, [Town|_]),
|
||||||
|
Person1 \= Person2.
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
*** 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:
|
||||||
|
|
||||||
|
a. all people who can replace Cy D. Fect;
|
||||||
|
|
||||||
|
b. all people who can replace someone who is being paid more
|
||||||
|
than they are, together with the two salaries.
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog :tangle yes
|
||||||
|
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.
|
||||||
|
#+END_SRC
|
||||||
|
*** 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.
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(rule (big-shot ?person)
|
||||||
|
(job ?person (?division . ?))
|
||||||
|
(supervisor ?person ?supervisor)
|
||||||
|
(not (job ?supervisor (?division . ?))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog
|
||||||
|
big_shot(Person) :-
|
||||||
|
job(Person, [Division|_]),
|
||||||
|
supervisor(Person, Supervisor),
|
||||||
|
job(Supervisor, [SDivision|_]),
|
||||||
|
Division \= SDivision.
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
*** 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:
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(meeting accounting (Monday 9am))
|
||||||
|
(meeting administration (Monday 10am))
|
||||||
|
(meeting computer (Wednesday 3pm))
|
||||||
|
(meeting administration (Friday 1pm))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog :tangle yes
|
||||||
|
meeting(accounting, [monday, '9am']).
|
||||||
|
meeting(administration, [monday, '10am']).
|
||||||
|
meeting(computer, [wednesday, '3pm']).
|
||||||
|
meeting(administration, [friday, '1pm']).
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
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.
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(meeting whole-company (Wednesday 4pm))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog :tangle yes
|
||||||
|
meeting(whole_company, [wednesday, '4pm']).
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
a. On Friday morning, Ben wants to query the data base for all
|
||||||
|
the meetings that occur that day. What query should he use?
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(meeting ?who (Friday ?when))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog
|
||||||
|
meeting(Who, [friday, When]).
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
b. 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.
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(rule (meeting-time ?person ?day-and-time)
|
||||||
|
<RULE-BODY>)
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(rule (meeting-time ?person ?day-and-time)
|
||||||
|
(and (job ?person (?department . ?))
|
||||||
|
(or (meeting whole-company ?day-and-time)
|
||||||
|
(meeting ?department ?day-and-time))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog :tangle yes
|
||||||
|
meeting_time(Person, DayAndTime) :-
|
||||||
|
job(Person, [Department|_]),
|
||||||
|
(meeting(whole_company, DayAndTime);
|
||||||
|
meeting(Department, DayAndTime)).
|
||||||
|
#+END_SRC
|
||||||
|
c. 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?
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(meeting-time (Hacker Alyssa P) (Wednesday ?))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog
|
||||||
|
meeting_time([hacker, alyssa, p], [wednesday, _]).
|
||||||
|
#+END_SRC
|
||||||
|
*** Exercise 4.60
|
||||||
|
By giving the query
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(lives-near ?person (Hacker Alyssa P))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(lives-near ?person-1 ?person-2)
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
she notices that each pair of people who live near each other is
|
||||||
|
listed twice; for example,
|
||||||
|
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(lives-near (Hacker Alyssa P) (Fect Cy D))
|
||||||
|
(lives-near (Fect Cy D) (Hacker Alyssa P))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
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
|
||||||
|
#+BEGIN_SRC scheme
|
||||||
|
(rule (append-to-form () ?y ?y))
|
||||||
|
|
||||||
|
(rule (append-to-form (?u . ?v) ?y (?u . ?z))
|
||||||
|
(append-to-form ?v ?y ?z))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC prolog :tangle yes
|
||||||
|
append([], L, L).
|
||||||
|
append([H|T], L2, [H|L3]) :-
|
||||||
|
append(T, L2, L3).
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* 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
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
** The Evaluator
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (qeval query frame-stream)
|
||||||
|
(let ((qproc (get (type query) 'qeval)))
|
||||||
|
(if qproc
|
||||||
|
(qproc (contents query) frame-stream)
|
||||||
|
(simple-query query frame-stream))))
|
||||||
|
#+END_SRC
|
||||||
|
*** Simple queries
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
*** Compound queries
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)
|
||||||
|
#+END_SRC
|
||||||
|
*** Filters
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (execute exp)
|
||||||
|
(apply (eval (predicate exp) user-initial-environment)
|
||||||
|
(args exp)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (always-true ignore frame-stream) frame-stream)
|
||||||
|
|
||||||
|
(put 'always-true 'qeval always-true)
|
||||||
|
#+END_SRC
|
||||||
|
** Finding Assertions by Pattern Matching
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (find-assertions pattern frame)
|
||||||
|
(stream-flatmap (lambda (datum)
|
||||||
|
(check-an-assertion datum pattern frame))
|
||||||
|
(fetch-assertions pattern frame)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))
|
||||||
|
#+END_SRC
|
||||||
|
** Rules and Unification
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (apply-rules pattern frame)
|
||||||
|
(stream-flatmap (lambda (rule)
|
||||||
|
(apply-a-rule rule pattern frame))
|
||||||
|
(fetch-rules pattern frame)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
** Maintaining the Data Base
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (get-stream key1 key2)
|
||||||
|
(let ((s (get key1 key2)))
|
||||||
|
(if s s the-empty-stream)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (indexable? pat)
|
||||||
|
(or (constant-symbol? (car pat))
|
||||||
|
(var? (car pat))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (index-key-of pat)
|
||||||
|
(let ((key (car pat)))
|
||||||
|
(if (var? key) '? key)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (use-index? pat)
|
||||||
|
(constant-symbol? (car pat)))
|
||||||
|
#+END_SRC
|
||||||
|
** Stream Operations
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (singleton-stream x)
|
||||||
|
(cons-stream x the-empty-stream))
|
||||||
|
#+END_SRC
|
||||||
|
** Query Syntax Procedures
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (assertion-to-be-added? exp)
|
||||||
|
(eq? (type exp) 'assert!))
|
||||||
|
|
||||||
|
(define (add-assertion-body exp)
|
||||||
|
(car (contents exp)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (rule? statement)
|
||||||
|
(tagged-list? statement 'rule))
|
||||||
|
|
||||||
|
(define (conclusion rule) (cadr rule))
|
||||||
|
|
||||||
|
(define (rule-body rule)
|
||||||
|
(if (null? (cddr rule))
|
||||||
|
'(always-true)
|
||||||
|
(caddr rule)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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)))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(define (var? exp)
|
||||||
|
(tagged-list? exp '?))
|
||||||
|
|
||||||
|
(define (constant-symbol? exp) (symbol? exp))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))
|
||||||
|
#+END_SRC
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))))))
|
||||||
|
#+END_SRC
|
||||||
|
** Frames and Bindings
|
||||||
|
#+BEGIN_SRC scheme :tangle yes
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
Loading…
Reference in a new issue