home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / ABE&SUS4.ZIP / A&S_4.LSP
Encoding:
Text File  |  1987-04-06  |  31.9 KB  |  1,128 lines
  1.  
  2. ;;; Section 4.1.1
  3.  
  4. (define (eval exp env)
  5.   (cond ((self-evaluating? exp) exp)
  6.         ((quoted? exp) (text-of-quotation exp))
  7.         ((variable? exp) (lookup-variable-value exp env))
  8.         ((definition? exp) (eval-definition exp env))
  9.         ((assignment? exp) (eval-assignment exp env))
  10.         ((lambda? exp) (make-procedure exp env))
  11.         ((conditional? exp) (eval-cond (clauses exp) env))
  12.         ((application? exp)
  13.          (apply (eval (operator exp) env)
  14.                 (list-of-values (operands exp) env)))
  15.         (else (error "Unknown expression type -- EVAL" exp))))
  16.  
  17. (define (apply procedure arguments)
  18.   (cond ((primitive-procedure? procedure)
  19.          (apply-primitive-procedure procedure arguments))
  20.         ((compound-procedure? procedure)
  21.          (eval-sequence (procedure-body procedure)
  22.                         (extend-environment
  23.                          (parameters procedure)
  24.                          arguments
  25.                          (procedure-environment procedure))))
  26.         (else
  27.          (error "Unknown procedure type -- APPLY" procedure))))
  28.  
  29. (define (list-of-values exps env)
  30.   (cond ((no-operands? exps) '())
  31.         (else (cons (eval (first-operand exps) env)
  32.                     (list-of-values (rest-operands exps)
  33.                                     env)))))
  34.  
  35. (define (eval-cond clist env)
  36.   (cond ((no-clauses? clist) nil)
  37.         ((else-clause? (first-clause clist))
  38.          (eval-sequence (actions (first-clause clist)) env))
  39.         ((true? (eval (predicate (first-clause clist)) env))
  40.          (eval-sequence (actions (first-clause clist)) env))
  41.         (else (eval-cond (rest-clauses clist) env))))
  42.  
  43. (define (eval-sequence exps env)
  44.   (cond ((last-exp? exps) (eval (first-exp exps) env))
  45.         (else (eval (first-exp exps) env)
  46.               (eval-sequence (rest-exps exps) env))))
  47.  
  48. (define (eval-assignment exp env)
  49.   (let ((new-value (eval (assignment-value exp) env)))
  50.     (set-variable-value! (assignment-variable exp)
  51.                          new-value
  52.                          env)
  53.     new-value))
  54.  
  55. (define (eval-definition exp env)
  56.   (define-variable! (definition-variable exp)
  57.                     (eval (definition-value exp) env)
  58.                     env)
  59.   (definition-variable exp))
  60.  
  61. ;;; Section 4.1.2 -- Representing expressions
  62.  
  63. ;;; numbers
  64.  
  65. (define (self-evaluating? exp) (number? exp))
  66.  
  67. ;;; quote
  68.  
  69. (define (quoted? exp)
  70.   (if (atom? exp)
  71.       nil
  72.       (eq? (car exp) 'quote)))
  73.  
  74. (define (text-of-quotation exp) (cadr exp))
  75.  
  76. ;;; variables
  77.  
  78. (define (variable? exp) (symbol? exp))
  79.  
  80. ;;; assignment
  81.  
  82. (define (assignment? exp)
  83.   (if (atom? exp)
  84.       nil
  85.       (eq? (car exp) 'set!)))
  86.  
  87. (define (assignment-variable exp) (cadr exp))
  88.  
  89. (define (assignment-value exp) (caddr exp))
  90.  
  91. ;;; definitions
  92.  
  93. (define (definition? exp)
  94.   (if (atom? exp)
  95.       nil
  96.       (eq? (car exp) 'define)))
  97.  
  98. (define (definition-variable exp)
  99.   (if (variable? (cadr exp))
  100.       (cadr exp)
  101.       (caadr exp)))
  102.  
  103. (define (definition-value exp) 
  104.   (if (variable? (cadr exp))
  105.       (caddr exp)
  106.       (cons 'lambda
  107.             (cons (cdadr exp)     ;formal parameters
  108.                   (cddr exp)))))  ;body
  109.  
  110. ;;; lambda expressions
  111.  
  112. (define (lambda? exp)
  113.   (if (atom? exp)
  114.       nil
  115.       (eq? (car exp) 'lambda)))
  116.  
  117. ;;; conditionals
  118. (define (conditional? exp)
  119.   (if (atom? exp)
  120.       nil
  121.       (eq? (car exp) 'cond)))
  122.  
  123. (define (clauses exp) (cdr exp))
  124.  
  125. (define (no-clauses? clauses) (null? clauses))
  126.  
  127. (define (first-clause clauses) (car clauses))
  128.  
  129. (define (rest-clauses clauses) (cdr clauses))
  130.  
  131. (define (predicate clause) (car clause))
  132.  
  133. (define (actions clause) (cdr clause))
  134.  
  135. (define (true? x) (not (null? x)))
  136.  
  137. (define (else-clause? clause)
  138.   (eq? (predicate clause) 'else))
  139.  
  140. ;;; sequences
  141.  
  142. (define (last-exp? seq) (null? (cdr seq)))
  143.  
  144. (define (first-exp seq) (car seq))
  145.  
  146. (define (rest-exps seq) (cdr seq))
  147.  
  148. ;;; procedure applications
  149.  
  150. (define (application? exp) (not (atom? exp)))
  151.  
  152. (define (operator app) (car app))
  153.  
  154. (define (operands app) (cdr app))
  155.  
  156. (define (no-operands? args) (null? args))
  157.  
  158. (define (first-operand args) (car args))
  159.  
  160. (define (rest-operands args) (cdr args))
  161.  
  162. ;;; Representation of procedure objects
  163. ;;; (This is actually not part of the represenation of expressions)
  164.  
  165. (define (make-procedure lambda-exp env)
  166.   (list 'procedure lambda-exp env))
  167.  
  168. (define (compound-procedure? proc)
  169.   (if (atom? proc)
  170.       nil
  171.       (eq? (car proc) 'procedure)))
  172.  
  173. (define (parameters proc) (cadr (cadr proc)))
  174.  
  175. (define (procedure-body proc) (cddr (cadr proc)))
  176.  
  177. (define (procedure-environment proc) (caddr proc))
  178.  
  179. ;;; Section 4.1.3
  180.  
  181. ;;; Operations on environments
  182.  
  183. (define (lookup-variable-value var env)
  184.   (let ((b (binding-in-env var env)))
  185.     (if (found-binding? b)
  186.         (binding-value b)
  187.         (error "Unbound variable" var))))
  188.  
  189. (define (binding-in-env var env)
  190.   (if (no-more-frames? env)
  191.       no-binding
  192.       (let ((b (binding-in-frame var (first-frame env))))
  193.         (if (found-binding? b)
  194.             b
  195.             (binding-in-env var (rest-frames env))))))
  196.  
  197. (define (extend-environment variables values base-env)
  198.   (adjoin-frame (make-frame variables values) base-env))
  199.  
  200. (define (set-variable-value! var val env)
  201.   (let ((b (binding-in-env var env)))
  202.     (if (found-binding? b)
  203.         (set-binding-value! b val)
  204.         (error "Unbound variable" var))))
  205.  
  206. (define (define-variable! var val env)
  207.   (let ((b (binding-in-frame var (first-frame env))))
  208.     (if (found-binding? b)
  209.         (set-binding-value! b val)
  210.         (set-first-frame!
  211.           env
  212.           (adjoin-binding (make-binding var val)
  213.                           (first-frame env))))))
  214.  
  215. ;;; Representing environments
  216.  
  217. (define (first-frame env) (car env))
  218.  
  219. (define (rest-frames env) (cdr env))
  220.  
  221. (define (no-more-frames? env) (null? env))
  222.  
  223. (define (adjoin-frame frame env) (cons frame env))
  224.  
  225. (define (set-first-frame! env new-frame)
  226.   (set-car! env new-frame))
  227.  
  228. ;;; Representing frames
  229.  
  230. (define (make-frame variables values)
  231.   (cond ((and (null? variables) (null? values)) '())
  232.         ((null? variables)
  233.          (error "Too many values supplied" values))
  234.         ((null? values)
  235.          (error "Too few values supplied" variables))
  236.         (else
  237.          (cons (make-binding (car variables) (car values))
  238.                (make-frame (cdr variables) (cdr values))))))
  239.  
  240. (define (adjoin-binding binding frame)
  241.   (cons binding frame))
  242.  
  243. (define (assq key bindings)
  244.   (cond ((null? bindings) no-binding)
  245.         ((eq? key (binding-variable (car bindings))) 
  246.          (car bindings))
  247.         (else (assq key (cdr bindings)))))
  248.  
  249. (define (binding-in-frame var frame)
  250.   (assq var frame))
  251.  
  252. (define (found-binding? b)
  253.   (not (eq? b no-binding)))
  254.  
  255. (define no-binding nil)
  256.  
  257. ;;; Representing bindings
  258.  
  259. (define (make-binding variable value)
  260.   (cons variable value))
  261.  
  262. (define (binding-variable binding)
  263.   (car binding))
  264.  
  265. (define (binding-value binding)
  266.   (cdr binding))
  267.  
  268. (define (set-binding-value! binding value)
  269.   (set-cdr! binding value))
  270.  
  271. ;;; Section 4.1.4 Running the evaluator
  272.  
  273. (define primitive-procedure-names
  274.   '(car cdr cons
  275.         ;;** add names of more primitives
  276.         ))
  277.  
  278. (define primitive-procedure-objects
  279.   '((primitive car)
  280.     (primitive cdr)
  281.     (primitive cons)
  282.     ;;** add more primitives
  283.     ))
  284.  
  285. (define (setup-environment)
  286.   (let ((initial-env
  287.          (extend-environment primitive-procedure-names
  288.                              primitive-procedure-objects
  289.                              '())))
  290.     (define-variable! 'nil nil initial-env)
  291.     (define-variable! 't (not nil) initial-env)
  292.     initial-env))
  293.  
  294. (define the-global-environment (setup-environment))
  295.  
  296. (define (primitive-procedure? proc)
  297.   (if (atom? proc)
  298.       nil
  299.       (eq? (car proc) 'primitive)))
  300.  
  301. (define (primitive-id proc) (cadr proc))
  302.  
  303. (define (apply-primitive-procedure proc args)
  304.   (let ((p (primitive-id proc)))
  305.     (cond ((eq? p 'car) (car (car args)))
  306.           ((eq? p 'cdr) (cdr (car args)))
  307.           ((eq? p 'cons) (cons (car args) (cadr args)))
  308.           ;;** add more primitives
  309.           (else (error "Unknown primitive procedure" proc)))))
  310.  
  311. ;;; Driver loop
  312.  
  313. (define (driver-loop)
  314.   (newline)
  315.   (princ "MC-EVAL==> ")
  316.   (user-print (eval (read) the-global-environment))
  317.   (driver-loop))
  318.  
  319. (define (user-print object)
  320.   (cond ((compound-procedure? object)
  321.          (print (list 'compound-procedure
  322.                       (parameters object)
  323.                       (procedure-body object)
  324.                       '[procedure-env])))
  325.         (else (print object))))
  326.  
  327. ;;; Section 4.2.1 -- Normal-order evaluation
  328.  
  329. (define (try a b)
  330.   (cond ((= a 0) 1)
  331.         (else b)))
  332.  
  333. ;;; IF as a procedure with delayed arguments
  334.  
  335. (define (if pred (delayed consequent) (delayed alternative))
  336.   (cond (pred consequent)
  337.         (else alternative)))
  338.  
  339. ;;; Exercise 4.9
  340.  
  341. (define (unless pred (delayed default-action) (delayed exception))
  342.   (if (not pred)
  343.       default-action
  344.       exception))
  345.  
  346. (define (factorial n)
  347.   (unless (= n 1)
  348.           (* (factorial (- n 1)) n)
  349.           1))
  350.  
  351. ;;; Exercise 4.10
  352.  
  353. (define (foo (delayed x))
  354.   (cond (x 0)
  355.         (else 1)))
  356.  
  357. ;;; Section 4.2.2  -- Binding disciplines
  358.  
  359. ;;; SUM from section 1.3.1
  360.  
  361. (define (sum term a next b)
  362.   (if (> a b)
  363.       0
  364.       (+ (term a)
  365.          (sum term (next a) next b))))
  366.  
  367. (define (cube x)
  368.   (expt x 3))
  369.  
  370. (define (sum-cubes a b)
  371.   (sum cube a 1+ b))
  372.  
  373. (define (sum-powers a b n)
  374.   (define (nth-power x)
  375.     (expt x n))
  376.   (sum nth-power a 1+ b))
  377.  
  378. ;;; Dynamic binding
  379.  
  380. (define (sum-powers a b n)
  381.   (sum nth-power a 1+ b))
  382.  
  383. (define (product-powers a b n)
  384.   (product nth-power a 1+ b))
  385.  
  386. (define (nth-power x)
  387.     (expt x n))
  388.  
  389. ;;; Versions of EVAL and APPLY that implement dynamic binding
  390.  
  391. (define (eval exp env)
  392.   (cond ((self-evaluating? exp) exp)
  393.         ((quoted? exp) (text-of-quotation exp))
  394.         ((variable? exp) (lookup-variable-value exp env))
  395.         ((definition? exp) (eval-definition exp env))
  396.         ((assignment? exp) (eval-assignment exp env))
  397.         ((lambda? exp) (make-procedure exp env))
  398.         ((conditional? exp) (eval-cond (clauses exp) env))
  399.         ((application? exp)
  400.          (apply (eval (operator exp) env)
  401.                 (list-of-values (operands exp) env)
  402.                 env))                    ;***
  403.         (else (error "Unknown expression type -- EVAL" exp))))
  404.  
  405. (define (apply procedure arguments env)  ;***
  406.   (cond ((primitive-procedure? procedure)
  407.          (apply-primitive-procedure procedure arguments))
  408.         ((compound-procedure? procedure)
  409.          (eval-sequence (procedure-body procedure)
  410.                         (extend-environment
  411.                          (parameters procedure)
  412.                          arguments
  413.                          env)))          ;***
  414.         (else
  415.          (error "Unknown procedure type -- APPLY" 
  416.                 procedure))))
  417.  
  418. ;;; Exercise 4.17
  419.  
  420. (define (make-adder increment)
  421.   (lambda (x) (+ x increment)))
  422.  
  423. ;;; Exercise 4.19
  424.  
  425. (define (with-new-radix new-radix proc)
  426.   (let ((old-radix radix))
  427.     (set! radix new-radix)
  428.     (let ((value (proc)))
  429.       (set! radix old-radix)
  430.       value)))
  431.  
  432. (define (with-new-radix new-radix proc)
  433.   (fluid-let ((radix new-radix))
  434.     (proc)))
  435.  
  436. ;;; Section 4.3.2 -- Packages
  437.  
  438. ;;; Manifest-type support, from section 2.3
  439.  
  440. (define (attach-type type contents)
  441.   (cons type contents))
  442.  
  443. (define (type datum) (car datum))
  444.  
  445. (define (contents datum) (cdr datum))
  446.  
  447. ;;; Generic operators
  448.  
  449. (define (make-generic-operator-1 operator)
  450.   (lambda (arg)
  451.     ((eval operator (type arg)) (contents arg))))
  452.  
  453. (define real-part (make-generic-operator-1 'real-part))
  454. (define imag-part (make-generic-operator-1 'imag-part))
  455. (define magnitude (make-generic-operator-1 'magnitude))
  456. (define angle (make-generic-operator-1 'angle))
  457.  
  458. (define (make-generic-operator-2 operator)
  459.   (lambda (arg1 arg2)
  460.     (let ((t1 (type arg1)))
  461.       (if (eq? t1 (type arg2))
  462.           ((eval operator t1) (contents arg1) 
  463.                               (contents arg2))
  464.           (error "Operands not of same type"
  465.                  (list operator arg1 arg2))))))
  466.  
  467. (define add (make-generic-operator-2 'add))
  468. (define sub (make-generic-operator-2 'sub))
  469. (define mul (make-generic-operator-2 'mul))
  470. (define div (make-generic-operator-2 'div))
  471.  
  472. ;;; Two versions of generic constructor
  473.  
  474. (define (make type object-parts)
  475.   (attach-type type (apply (eval 'maker type) object-parts)))
  476.  
  477. (define (make type . object-parts)
  478.   (attach-type type (apply (eval 'maker type) object-parts)))
  479.  
  480.  
  481. (define (restrict-1 operator type-pack)
  482.   (let ((proc (eval operator type-pack)))
  483.     (lambda (arg)
  484.       (if (eq? type-pack (type arg))
  485.           (proc (contents arg))
  486.           (error "Type mismatch -- restricted operator" 
  487.                  (list operator type-pack arg))))))
  488.  
  489. ;;; generic SQUARE operator
  490.  
  491. (define (square x) (mul x x))      
  492.  
  493. ;;; definition of REAL goes here
  494.  
  495. (define complex
  496.   ;; First we declare the imported procedures.
  497.   (let ((+ (restrict-2 'add real))
  498.         (- (restrict-2 'sub real))
  499.         (* (restrict-2 'mul real))
  500.         (/ (restrict-2 'div real)))
  501.  
  502.     ;; Next, we define the subpackages.
  503.     (define rectangular          
  504.       (let ((sqrt (restrict-1 'sqrt real))
  505.             (atan (restrict-2 'atan real)))
  506.         (make-environment
  507.          (define (real-part z) (car z))
  508.          (define (imag-part z) (cdr z))
  509.          (define (magnitude z)
  510.            (sqrt (+ (square (car z)) (square (cdr z)))))
  511.          (define (angle z)
  512.            (atan (cdr z) (car z)))
  513.          (define (maker x y) (cons x y))
  514.          )))
  515.  
  516.     ;; definition of POLAR goes here
  517.  
  518.     ;; Next we define the body of the COMPLEX manipulations.
  519.     (define (add z1 z2)                      
  520.       (make rectangular
  521.             (+ (real-part z1) (real-part z2))
  522.             (+ (imag-part z1) (imag-part z2))))
  523.     (define (sub z1 z2)
  524.       (make rectangular
  525.             (- (real-part z1) (real-part z2))
  526.             (- (imag-part z1) (imag-part z2))))
  527.     (define (mul z1 z2)
  528.       (make polar
  529.             (* (magnitude z1) (magnitude z2))
  530.             (+ (angle z1) (angle z2))))
  531.     (define (div z1 z2)
  532.       (make polar
  533.             (/ (magnitude z1) (magnitude z2))
  534.             (- (angle z1) (angle z2))))
  535.  
  536.     ;; Finally, we define the exports from the COMPLEX package.
  537.     (let ((+ add) (- sub) (* mul) (/ div))
  538.       (make-environment
  539.        (define (add z1 z2)
  540.          (attach-type complex (+ z1 z2)))
  541.        (define (sub z1 z2)
  542.          (attach-type complex (- z1 z2)))
  543.        (define (mul z1 z2)
  544.          (attach-type complex (* z1 z2)))
  545.        (define (div z1 z2)
  546.          (attach-type complex (/ z1 z2)))
  547.  
  548.        ;; We choose (somewhat arbitrarily) to make complex numbers
  549.        ;; initially in rectangular form.
  550.        (define (maker real imag)
  551.          (make rectangular real imag))
  552.        ;; End of COMPLEX package
  553.        ))))
  554.  
  555. ;;; Section 4.4.1
  556.  
  557. ;;; The Itsey Bitsey Machine Corporation's personnel data base
  558.  
  559. (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
  560. (job (Bitdiddle Ben) (computer wizard))
  561. (salary (Bitdiddle Ben) 40000)
  562.  
  563. (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
  564. (job (Hacker Alyssa P) (computer programmer))
  565. (salary (Hacker Alyssa P) 35000)
  566. (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
  567.  
  568. (address (Fect Cy D) (Cambridge (Ames Street) 3))
  569. (job (Fect Cy D) (computer programmer))
  570. (salary (Fect Cy D) 32000)
  571. (supervisor (Fect Cy D) (Bitdiddle Ben))
  572.  
  573. (address (Tweakit Lem E) (Boston (Bay State Road) 22))
  574. (job (Tweakit Lem E) (computer technician))
  575. (salary (Tweakit Lem E) 15000)
  576. (supervisor (Tweakit Lem E) (Bitdiddle Ben))
  577.  
  578. (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
  579. (job (Reasoner Louis) (computer programmer trainee))
  580. (salary (Reasoner Louis) 20000)
  581. (supervisor (Reasoner Louis) (Hacker Alyssa P))
  582.  
  583. (supervisor (Bitdiddle Ben) (Warbucks Oliver))
  584.  
  585. (address (Warbucks Oliver) (Swellesley (Top Heap Road)))
  586. (job (Warbucks Oliver) (administration big wheel))
  587. (salary (Warbucks Oliver) 100000)
  588.  
  589. (address (Scrooge Eben) (Weston (Shady Lane) 10))
  590. (job (Scrooge Eben) (accounting chief accountant))
  591. (salary (Scrooge Eben) 69000)
  592. (supervisor (Scrooge Eben) (Warbucks Oliver))
  593.  
  594. (address (Cratchet Robert) (Allston (N Harvard Street) 16))
  595. (job (Cratchet Robert) (accounting scrivener))
  596. (salary (Cratchet Robert) 12000)
  597. (supervisor (Cratchet Robert) (Scrooge Eben))
  598.  
  599. (address (Forrest Rosemary) (Slumerville (Onion Square) 5))
  600. (job (Forrest Rosemary) (administration secretary))
  601. (salary (Forrest Rosemary) 15000)
  602. (supervisor (Forrest Rosemary) (Warbucks Oliver))
  603.  
  604. (can-do-job (computer wizard) (computer programmer))
  605. (can-do-job (computer wizard) (computer technician))
  606.  
  607. (can-do-job (computer programmer)
  608.             (computer programmer trainee))
  609.  
  610. (can-do-job (administration secretary)
  611.             (administration big wheel))
  612.  
  613. ;;; end of data-base assertions
  614.  
  615. ;;; Some rules
  616.  
  617. ;;; This version of lives-near is from the text
  618. (rule (lives-near ?person-1 ?person-2)
  619.       (and (address ?person-1 (?town . ?rest-1))
  620.            (address ?person-2 (?town . ?rest-2))
  621.            (not (lisp-value equal? ?person-1 ?person-2))))
  622.  
  623. ;;; This improved version of lives-near is not in the text
  624. ;;; (see instructor's manual)
  625. (rule (lives-near ?person-1 ?person-2)
  626.       (and (address ?person-1 (?town . ?rest-1))
  627.            (address ?person-2 (?town . ?rest-2))
  628.            (not (same ?person-1 ?person-2))))
  629.  
  630. ;;; This is not in the text (see instructor's manual)
  631. (rule (same ?x ?x))
  632.  
  633. (rule (wheel ?person)
  634.       (and (supervisor ?middle-manager ?person)
  635.            (supervisor ?x ?middle-manager)))
  636.  
  637. (rule (outranked-by ?staff-person ?boss)
  638.       (or (supervisor ?staff-person ?boss)
  639.           (and (supervisor ?staff-person ?middle-manager)
  640.                (outranked-by ?middle-manager ?boss))))
  641.  
  642. ;;; Logic as programs
  643.  
  644. (rule (append-to-form () ?y ?y))
  645.  
  646. (rule (append-to-form (?u . ?v) ?y (?u . ?z))
  647.       (append-to-form ?v ?y ?z))
  648.  
  649. ;;; Exercise 4.33
  650.  
  651. (son Adam Cain)
  652. (son Cain Enoch)
  653. (son Enoch Irad)
  654. (son Irad Mehujael)
  655. (son Mehujael Methushael)
  656. (son Methushael Lamech)
  657. (wife Lamech Ada)
  658. (son Ada Jabal)
  659. (son Ada Jubal)
  660.  
  661. ;;; Section 4.5 -- Query system implementation
  662.  
  663. ;;; Section 4.5.1 -- Driver loop
  664.  
  665. (define (query-driver-loop)
  666.   (newline)
  667.   (princ "query==> ")
  668.   (let ((q (query-syntax-process (read))))
  669.     (if (assertion-to-be-added? q)
  670.         (sequence (add-rule-or-assertion!
  671.                    (add-assertion-body q))
  672.                   (print "assertion added to data base")
  673.                   (query-driver-loop))
  674.         (sequence
  675.          (print-stream-elements-on-separate-lines
  676.           (map (lambda (frame)
  677.                  (instantiate q
  678.                               frame
  679.                               (lambda (v f) 
  680.                                 (contract-question-mark v))))
  681.                (qeval q (singleton '()))))
  682.          (query-driver-loop)))))
  683.  
  684. ;;; Section 4.5.1 -- Instantiation
  685.  
  686. (define (instantiate exp frame unbound-var-handler)
  687.   (define (copy exp)
  688.     (cond ((constant? exp) exp)
  689.           ((var? exp)
  690.            (let ((vcell (binding-in-frame exp frame)))
  691.              (if (null? vcell)             
  692.                  (unbound-var-handler exp frame)
  693.                  (copy (binding-value vcell)))))
  694.           (else (cons (copy (car exp))
  695.                       (copy (cdr exp))))))
  696.   (copy exp))
  697.  
  698. ;;; Section 4.5.2 -- query evaluator
  699.  
  700. (define (qeval query frame-stream)
  701.   (let ((qproc (get (type query) 'qeval)))
  702.     (if (not (null? qproc))
  703.         (qproc (contents query) frame-stream)
  704.         (asserted? query frame-stream))))
  705.  
  706. ;;; Section 4.5.2 -- simple queries
  707.  
  708. ;;; The first version is from early printings of the text
  709. (define (asserted? query-pattern frame-stream)
  710.   (append-streams 
  711.    (flatmap (lambda (frame)
  712.               (find-assertions query-pattern frame))
  713.             frame-stream)
  714.    (flatmap (lambda (frame)
  715.               (apply-rules query-pattern frame))
  716.             frame-stream)))
  717.  
  718. ;;; The following improved version is from later printings of the text
  719. ;;; (see also the instructor's manual)
  720. (define (asserted? query-pattern frame-stream)
  721.   (flatmap
  722.    (lambda (frame)
  723.      (append-delayed
  724.       (find-assertions query-pattern frame)
  725.       (delay (apply-rules query-pattern frame))))
  726.    frame-stream))
  727.  
  728. ;;; For use by the new version of Asserted?
  729. (define (append-delayed s1 delayed-s2)
  730.   (if (empty-stream? s1)
  731.       (force delayed-s2)
  732.       (cons-stream (head s1)
  733.                    (append-delayed (tail s1) delayed-s2))))
  734.  
  735. ;;; Section 4.5.2 -- compound queries
  736.  
  737. (define (conjoin conjuncts frame-stream)
  738.   (if (empty-conjunction? conjuncts)
  739.       frame-stream
  740.       (conjoin (rest-conjuncts conjuncts)
  741.                (qeval (first-conjunct conjuncts)
  742.                       frame-stream))))
  743.  
  744. (put 'and 'qeval conjoin)
  745.  
  746. ;;; The first version is from early printings of the text
  747. (define (disjoin disjuncts frame-stream)
  748.   (if (empty-disjunction? disjuncts)
  749.       the-empty-stream
  750.       (interleave (qeval (first-disjunct disjuncts)
  751.                          frame-stream)
  752.                   (disjoin (rest-disjuncts disjuncts)
  753.                            frame-stream))))
  754.  
  755. ;;; The following improved version is from later printings of the text
  756. ;;; (see also the instructor's manual)
  757. (define (disjoin disjuncts frame-stream)
  758.   (if (empty-disjunction? disjuncts)
  759.       the-empty-stream
  760.       (interleave-delayed
  761.        (qeval (first-disjunct disjuncts) frame-stream)
  762.        (delay (disjoin (rest-disjuncts disjuncts)
  763.                        frame-stream)))))
  764.  
  765. (put 'or 'qeval disjoin)
  766.  
  767. ;;; Section 4.5.2 -- Filters
  768.  
  769. (define (negate a frame-stream)
  770.   (flatmap
  771.    (lambda (frame)
  772.      (if (empty-stream? (qeval (negated-query a)
  773.                                (singleton frame)))
  774.          (singleton frame)
  775.          the-empty-stream))
  776.    frame-stream))
  777.  
  778. (put 'not 'qeval negate)
  779.  
  780. (define (lisp-value call frame-stream)
  781.   (flatmap
  782.    (lambda (frame)
  783.      (if (execute
  784.           (instantiate call
  785.                        frame
  786.                        (lambda (v f)
  787.                          (error "Unknown pat var--LISP-VALUE"
  788.                                 v))))
  789.          (singleton frame)
  790.          the-empty-stream))
  791.    frame-stream))
  792.  
  793. (put 'lisp-value 'qeval lisp-value)
  794.  
  795. (define (execute exp)
  796.   (apply (eval (predicate exp) user-initial-environment)
  797.          (args exp)))
  798.  
  799. (define (always-true ignore frame-stream)
  800.   frame-stream)                                        
  801.  
  802. (put 'always-true 'qeval always-true)
  803.  
  804. ;;;Section 4.5.3 -- Assertions and pattern matching
  805.  
  806. (define (find-assertions pattern frame)
  807.   (flatmap (lambda (datum)
  808.              (pattern-match pattern datum frame))
  809.            (fetch-assertions pattern frame)))
  810.  
  811. (define (pattern-match pat dat frame)
  812.   (let ((result (internal-match pat dat frame)))
  813.     (if (eq? result 'failed)
  814.         the-empty-stream
  815.         (singleton result))))
  816.  
  817. (define (internal-match pat dat frame)
  818.   (cond ((eq? frame 'failed) 'failed)
  819.         ((var? pat) (extend-if-consistent pat dat frame))
  820.         ((constant? pat)
  821.          (if (constant? dat)
  822.              (if (same-constant? pat dat) frame 'failed)
  823.              'failed))
  824.         ((constant? dat) 'failed)
  825.         (else (internal-match (cdr pat)
  826.                               (cdr dat)
  827.                               (internal-match (car pat)
  828.                                               (car dat)
  829.                                               frame)))))
  830.  
  831. (define (extend-if-consistent var dat frame)
  832.   (let ((value (binding-in-frame var frame)))
  833.     (if (null? value)
  834.         (extend var dat frame)
  835.         (internal-match (binding-value value) dat frame))))
  836.  
  837. ;;; Section 4.5.4 -- Rules and unification
  838.  
  839. (define (apply-rules pattern frame)
  840.   (flatmap (lambda (rule)
  841.              (apply-a-rule rule pattern frame))
  842.            (fetch-rules pattern frame)))
  843.  
  844. (define (apply-a-rule rule query-pattern query-frame)
  845.   (let ((clean-rule (rename-variables-in rule)))
  846.     (let ((unify-result (unify-match query-pattern
  847.                                      (conclusion clean-rule)
  848.                                      query-frame)))
  849.       (if (empty-stream? unify-result)
  850.           the-empty-stream
  851.           (qeval (rule-body clean-rule) unify-result)))))
  852.  
  853. (define (rename-variables-in rule)
  854.   (let ((rule-application-id (new-rule-application-id)))
  855.     (define (tree-walk exp)
  856.       (cond ((constant? exp) exp)
  857.             ((var? exp)
  858.              (make-new-variable exp rule-application-id))
  859.             (else (cons (tree-walk (car exp))
  860.                         (tree-walk (cdr exp))))))
  861.     (tree-walk rule)))
  862.  
  863. (define (unify-match p1 p2 frame)
  864.   (let ((result (internal-unify p1 p2 frame)))
  865.     (if (eq? result 'failed)
  866.         the-empty-stream
  867.         (singleton result))))
  868.  
  869. (define (internal-unify p1 p2 frame)
  870.   (cond ((eq? frame 'failed) 'failed)
  871.         ((var? p1) (extend-if-possible p1 p2 frame))
  872.         ((var? p2) (extend-if-possible p2 p1 frame))   ;***
  873.         ((constant? p1)
  874.          (if (constant? p2)
  875.              (if (same-constant? p1 p2) frame 'failed)
  876.              'failed))
  877.         ((constant? p2) 'failed)
  878.         (else (internal-unify (cdr p1)
  879.                               (cdr p2)
  880.                               (internal-unify (car p1)
  881.                                               (car p2)
  882.                                               frame)))))
  883.  
  884. (define (extend-if-possible var val frame)
  885.   (if (equal? var val)                         ;***
  886.       frame
  887.       (let ((value-cell (binding-in-frame var frame)))
  888.         (if (null? value-cell)
  889.             (if (freefor? var val frame)       ;***
  890.                 (extend var val frame)
  891.                 'failed)
  892.             (internal-unify (binding-value value-cell)
  893.                             val
  894.                             frame)))))
  895.  
  896. (define (freefor? var exp frame)
  897.   (define (freewalk e)
  898.     (cond ((constant? e) t)
  899.           ((var? e)
  900.            (if (equal? var e)
  901.                nil
  902.                (freewalk (lookup-in-frame e frame))))
  903.           ((freewalk (car e)) (freewalk (cdr e)))
  904.           (else nil)))
  905.   (freewalk exp))
  906.  
  907. ;;; Section 4.5.5 -- The query data base
  908.  
  909. (define THE-ASSERTIONS the-empty-stream)
  910.  
  911. (define (fetch-assertions pattern frame)
  912.   (if (use-index? pattern)
  913.       (get-indexed-assertions pattern)
  914.       (get-all-assertions)))
  915.  
  916. (define (get-all-assertions) THE-ASSERTIONS)
  917.  
  918. (define (get-indexed-assertions pattern)
  919.   (get-stream (index-key-of pattern) 'assertion-stream))
  920.  
  921. (define (get-stream key1 key2)
  922.   (let ((s (get key1 key2)))
  923.     (if (null? s) the-empty-stream s)))
  924.  
  925. (define THE-RULES the-empty-stream)
  926.  
  927. (define (fetch-rules pattern frame)
  928.   (if (use-index? pattern)
  929.       (get-indexed-rules pattern)
  930.       (get-all-rules)))
  931.  
  932. (define (get-all-rules) THE-RULES)
  933.  
  934. (define (get-indexed-rules pattern)
  935.   (append-streams
  936.    (get-stream (index-key-of pattern) 'rule-stream)
  937.    (get-stream '? 'rule-stream)))
  938.  
  939. ;;; Adding rules and assertions to the data base
  940.  
  941. (define (add-rule-or-assertion! assertion)
  942.   (if (rule? assertion)
  943.       (add-rule! assertion)
  944.       (add-assertion! assertion)))
  945.  
  946. (define (add-assertion! assertion)
  947.   (store-assertion-in-index assertion)
  948.   (let ((old-assertions THE-ASSERTIONS))
  949.     (set! THE-ASSERTIONS
  950.           (cons-stream assertion old-assertions))
  951.     'ok))
  952.  
  953. (define (add-rule! rule)
  954.   (store-rule-in-index rule)
  955.   (let ((old-rules THE-RULES))
  956.     (set! THE-RULES (cons-stream rule old-rules))
  957.     'ok))
  958.  
  959. (define (store-assertion-in-index assertion)
  960.   (if (indexable? assertion)
  961.       (let ((key (index-key-of assertion)))
  962.         (let ((current-assertion-stream
  963.                (get-stream key 'assertion-stream)))
  964.           (put key
  965.                'assertion-stream
  966.                (cons-stream assertion
  967.                             current-assertion-stream))))))
  968.  
  969. (define (store-rule-in-index rule)
  970.   (let ((pattern (conclusion rule)))
  971.     (if (indexable? pattern)
  972.         (let ((key (index-key-of pattern)))
  973.           (let ((current-rule-stream
  974.                  (get-stream key 'rule-stream)))
  975.             (put key
  976.                  'rule-stream
  977.                  (cons-stream rule
  978.                               current-rule-stream)))))))
  979.  
  980. ;;; The data-base index
  981.  
  982. (define (indexable? pat)
  983.   (or (constant-symbol? (car pat))
  984.       (var? (car pat))))
  985.  
  986. (define (index-key-of pat)
  987.   (let ((key (car pat)))
  988.     (if (var? key) '? key)))
  989.  
  990. (define (use-index? pat)
  991.   (constant-symbol? (car pat)))
  992.  
  993. ;;; Exercise 4.40 -- a bad version of add-assertion!
  994.  
  995. (define (add-assertion! assertion)
  996.   (store-assertion-in-index assertion)
  997.   (set! THE-ASSERTIONS
  998.         (cons-stream assertion THE-ASSERTIONS))
  999.   'ok)
  1000.  
  1001. ;;; Section 4.5.6
  1002.  
  1003. ;;; The syntax of queries
  1004.  
  1005. (define (type exp)
  1006.   (if (atom? exp) 
  1007.       (error "Unknown expression TYPE" exp)
  1008.       (if (symbol? (car exp)) (car exp) nil)))
  1009.  
  1010. (define (contents exp)
  1011.   (if (atom? exp) 
  1012.       (error "Unknown expression CONTENTS" exp)
  1013.       (cdr exp)))
  1014.  
  1015. (define (assertion-to-be-added? exp)
  1016.   (eq? (type exp) 'assert!))
  1017.  
  1018. (define (add-assertion-body exp) 
  1019.   (car (contents exp)))
  1020.  
  1021. (define empty-conjunction? null?)
  1022. (define first-conjunct car)
  1023. (define rest-conjuncts cdr)
  1024.  
  1025. (define empty-disjunction? null?)
  1026. (define first-disjunct car)
  1027. (define rest-disjuncts cdr)
  1028.  
  1029. (define negated-query car)
  1030.  
  1031. (define predicate car)
  1032. (define args cdr)
  1033.  
  1034. (define (rule? statement)
  1035.   (if (atom? statement)
  1036.       nil
  1037.       (eq? (car statement) 'rule)))
  1038.  
  1039. (define conclusion cadr)
  1040.  
  1041. (define (rule-body rule)
  1042.   (if (null? (cddr rule))
  1043.       '(always-true)
  1044.       (caddr rule)))
  1045.  
  1046. ;;; Internal representation of variables
  1047.  
  1048. (define (query-syntax-process exp)
  1049.   (map-over-atoms expand-question-mark exp))
  1050.  
  1051. (define (map-over-atoms proc exp)
  1052.   (if (atom? exp)
  1053.       (proc exp)
  1054.       (cons (map-over-atoms proc (car exp))
  1055.             (map-over-atoms proc (cdr exp)))))
  1056.  
  1057. (define (expand-question-mark atom)
  1058.   (if (symbol? atom)
  1059.       (let ((characters (explode atom)))
  1060.         (if (eq? (car characters) '?)
  1061.             (list '? (implode (cdr characters)))
  1062.             atom))
  1063.       atom))
  1064.  
  1065. (define (var? exp)
  1066.   (if (atom? exp)
  1067.       nil
  1068.       (eq? (car exp) '?)))
  1069.  
  1070. (define constant? atom?)
  1071. (define constant-symbol? symbol?)
  1072. (define same-constant? equal?)
  1073.  
  1074.  
  1075. (define rule-counter 0)
  1076.  
  1077. (define (new-rule-application-id)
  1078.   (set! rule-counter (1+ rule-counter))
  1079.   rule-counter)
  1080.  
  1081. (define (make-new-variable var rule-application-id)
  1082.   (cons '? (cons rule-application-id (cdr var))))
  1083.  
  1084. (define (contract-question-mark variable)
  1085.   (implode (cons '? (explode (if (number? (cadr variable))
  1086.                                  (caddr variable)
  1087.                                  (cadr variable))))))
  1088.  
  1089. ;;; The following (not in the text) retains the version number of the variable.
  1090. ;;; It assumes that Explode can work on integers.
  1091. (define (contract-question-mark variable)
  1092.   (if (number? (cadr variable))  ;rule application id
  1093.       (implode (append '(?)
  1094.                        (explode (caddr variable))
  1095.                        '(-)
  1096.                        (explode (cadr variable))))
  1097.       (implode (append '(?) (explode (cadr variable))))))
  1098.  
  1099. ;;; Frames
  1100.  
  1101. (define (make-binding variable value)
  1102.   (cons variable value))
  1103.  
  1104. (define (binding-variable binding)
  1105.   (car binding))
  1106.  
  1107. (define (binding-value binding)
  1108.   (cdr binding))
  1109.  
  1110. (define (binding-in-frame variable frame)
  1111.   (assoc variable frame))
  1112.  
  1113. (define (extend variable value frame)
  1114.   (cons (make-binding variable value) frame))
  1115.  
  1116. (define (lookup-in-frame variable frame)
  1117.   (binding-value (binding-in-frame variable frame)))
  1118.  
  1119. ;;; Printer
  1120.  
  1121. (define (print-stream-elements-on-separate-lines s)
  1122.   (if (empty-stream? s)
  1123.       (print "done")
  1124.       (sequence (print (head s))
  1125.                 (print-stream-elements-on-separate-lines
  1126.                  (tail s)))))
  1127.  
  1128. (44)%