Working on 4.78
parent
f1d0c83ebc
commit
0d0fc72d8a
|
@ -209,46 +209,3 @@
|
|||
(salary ?p1 ?s1)
|
||||
(salary ?p2 ?s2)))
|
||||
(newline)
|
||||
|
||||
(display "\nex-4.78 - non-deterministic-query\n")
|
||||
|
||||
; Exercise 4.78. Redesign the query language as a nondeterministic program to
|
||||
; be implemented using the evaluator of section 4.3, rather than as a stream
|
||||
; process. In this approach, each query will produce a single answer (rather
|
||||
; than the stream of all answers) and the user can type try-again to see more
|
||||
; answers. You should find that much of the mechanism we built in this section
|
||||
; is subsumed by nondeterministic search and backtracking. You will probably
|
||||
; also find, however, that your new query language has subtle differences in
|
||||
; behavior from the one implemented here. Can you find examples that illustrate
|
||||
; this difference?
|
||||
|
||||
(display "\nex-4.79 - rule-application-environment\n")
|
||||
|
||||
; Exercise 4.79. When we implemented the Lisp evaluator in section 4.1, we saw
|
||||
; how to use local environments to avoid name conflicts between the parameters
|
||||
; of procedures. For example, in evaluating
|
||||
|
||||
; (define (square x)
|
||||
; (* x x))
|
||||
; (define (sum-of-squares x y)
|
||||
; (+ (square x) (square y)))
|
||||
; (sum-of-squares 3 4)
|
||||
|
||||
; there is no confusion between the x in square and the x in sum-of-squares,
|
||||
; because we evaluate the body of each procedure in an environment that is
|
||||
; specially constructed to contain bindings for the local variables. In the
|
||||
; query system, we used a different strategy to avoid name conflicts in
|
||||
; applying rules. Each time we apply a rule we rename the variables with new
|
||||
; names that are guaranteed to be unique. The analogous strategy for the Lisp
|
||||
; evaluator would be to do away with local environments and simply rename the
|
||||
; variables in the body of a procedure each time we apply the procedure.
|
||||
|
||||
; Implement for the query language a rule-application method that uses
|
||||
; environments rather than renaming. See if you can build on your environment
|
||||
; structure to create constructs in the query language for dealing with large
|
||||
; systems, such as the rule analog of block-structured procedures. Can you
|
||||
; relate any of this to the problem of making deductions in a context (e.g.,
|
||||
; ``If I supposed that P were true, then I would be able to deduce A and B.'')
|
||||
; as a method of problem solving? (This problem is open-ended. A good answer is
|
||||
; probably worth a Ph.D.)
|
||||
|
|
@ -0,0 +1,719 @@
|
|||
(load "util.scm")
|
||||
(load "misc/sicp-ambeval.scm")
|
||||
|
||||
(define the-global-environment (setup-environment))
|
||||
(define result '())
|
||||
|
||||
; Copied from 4.45
|
||||
(define result '())
|
||||
(define (amball exp)
|
||||
(set! result '()) ; reset result
|
||||
(ambeval exp
|
||||
the-global-environment
|
||||
(lambda (value next)
|
||||
(set! result (cons value result))
|
||||
(next))
|
||||
(lambda () result))
|
||||
(set! result (reverse result))
|
||||
result)
|
||||
|
||||
(amball '(begin
|
||||
|
||||
(define input-prompt ";;; Query input:")
|
||||
(define output-prompt ";;; Query results:")
|
||||
|
||||
(define (query-driver-loop)
|
||||
(prompt-for-input input-prompt)
|
||||
(let ((q (query-syntax-process (read))))
|
||||
(cond ((assertion-to-be-added? q)
|
||||
(add-rule-or-assertion! (add-assertion-body q))
|
||||
(newline)
|
||||
(display "Assertion added to data base.")
|
||||
(query-driver-loop))
|
||||
(else
|
||||
(newline)
|
||||
(display output-prompt)
|
||||
;; [extra newline at end] (announce-output 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))
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.2
|
||||
;;;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)
|
||||
;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
|
||||
(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))
|
||||
|
||||
(define (uniquely-asserted query frame-stream)
|
||||
(stream-flatmap
|
||||
(lambda (frame)
|
||||
(let ((matches (qeval (car query) (singleton-stream frame))))
|
||||
(cond ((stream-null? matches) matches)
|
||||
((stream-null? (stream-cdr matches)) matches)
|
||||
(else 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)
|
||||
|
||||
;;;SECTION 4.4.4.3
|
||||
;;;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))))
|
||||
|
||||
;;;SECTION 4.4.4.4
|
||||
;;;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)) ; {\em ; ***}
|
||||
((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) ; {\em ; ***}
|
||||
(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) ; {\em ; ***}
|
||||
'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))
|
||||
|
||||
;;;SECTION 4.4.4.5
|
||||
;;;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)))
|
||||
|
||||
;;;SECTION 4.4.4.6
|
||||
;;;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))
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.7
|
||||
;;;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))))))
|
||||
|
||||
|
||||
;;;SECTION 4.4.4.8
|
||||
;;;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))
|
||||
|
||||
;;;;From Section 4.1
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? (car exp) tag)
|
||||
false))
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline) (display string) (newline))
|
||||
|
||||
|
||||
;;;;Stream support from Chapter 3
|
||||
|
||||
(define (stream-map proc s)
|
||||
(if (stream-null? s)
|
||||
the-empty-stream
|
||||
(cons-stream (proc (stream-car s))
|
||||
(stream-map proc (stream-cdr s)))))
|
||||
|
||||
(define (stream-for-each proc s)
|
||||
(if (stream-null? s)
|
||||
'done
|
||||
(begin (proc (stream-car s))
|
||||
(stream-for-each proc (stream-cdr s)))))
|
||||
|
||||
(define (display-stream s)
|
||||
(stream-for-each display-line s))
|
||||
(define (display-line x)
|
||||
(newline)
|
||||
(display x))
|
||||
|
||||
(define (stream-filter pred stream)
|
||||
(cond ((stream-null? stream) the-empty-stream)
|
||||
((pred (stream-car stream))
|
||||
(cons-stream (stream-car stream)
|
||||
(stream-filter pred
|
||||
(stream-cdr stream))))
|
||||
(else (stream-filter pred (stream-cdr stream)))))
|
||||
|
||||
(define (stream-append s1 s2)
|
||||
(if (stream-null? s1)
|
||||
s2
|
||||
(cons-stream (stream-car s1)
|
||||
(stream-append (stream-cdr s1) s2))))
|
||||
|
||||
(define (interleave s1 s2)
|
||||
(if (stream-null? s1)
|
||||
s2
|
||||
(cons-stream (stream-car s1)
|
||||
(interleave s2 (stream-cdr s1)))))
|
||||
|
||||
;;;;Table support from Chapter 3, Section 3.3.3 (local tables)
|
||||
|
||||
(define (make-table)
|
||||
(let ((local-table (list '*table*)))
|
||||
(define (lookup key-1 key-2)
|
||||
(let ((subtable (assoc key-1 (cdr local-table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record
|
||||
(cdr record)
|
||||
false))
|
||||
false)))
|
||||
(define (insert! key-1 key-2 value)
|
||||
(let ((subtable (assoc key-1 (cdr local-table))))
|
||||
(if subtable
|
||||
(let ((record (assoc key-2 (cdr subtable))))
|
||||
(if record
|
||||
(set-cdr! record value)
|
||||
(set-cdr! subtable
|
||||
(cons (cons key-2 value)
|
||||
(cdr subtable)))))
|
||||
(set-cdr! local-table
|
||||
(cons (list key-1
|
||||
(cons key-2 value))
|
||||
(cdr local-table)))))
|
||||
'ok)
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup-proc) lookup)
|
||||
((eq? m 'insert-proc!) insert!)
|
||||
(else (error "Unknown operation -- TABLE" m))))
|
||||
dispatch))
|
||||
|
||||
;;;; From instructor's manual
|
||||
|
||||
(define get '())
|
||||
|
||||
(define put '())
|
||||
|
||||
(define (initialize-data-base rules-and-assertions)
|
||||
(define (deal-out r-and-a rules assertions)
|
||||
(cond ((null? r-and-a)
|
||||
(set! THE-ASSERTIONS (list->stream assertions))
|
||||
(set! THE-RULES (list->stream rules))
|
||||
'done)
|
||||
(else
|
||||
(let ((s (query-syntax-process (car r-and-a))))
|
||||
(cond ((rule? s)
|
||||
(store-rule-in-index s)
|
||||
(deal-out (cdr r-and-a)
|
||||
(cons s rules)
|
||||
assertions))
|
||||
(else
|
||||
(store-assertion-in-index s)
|
||||
(deal-out (cdr r-and-a)
|
||||
rules
|
||||
(cons s assertions))))))))
|
||||
(let ((operation-table (make-table)))
|
||||
(set! get (operation-table 'lookup-proc))
|
||||
(set! put (operation-table 'insert-proc!)))
|
||||
(put 'and 'qeval conjoin)
|
||||
(put 'or 'qeval disjoin)
|
||||
(put 'not 'qeval negate)
|
||||
(put 'unique 'qeval uniquely-asserted)
|
||||
(put 'lisp-value 'qeval lisp-value)
|
||||
(put 'always-true 'qeval always-true)
|
||||
(deal-out rules-and-assertions '() '()))
|
||||
|
||||
;; Do following to reinit the data base from microshaft-data-base
|
||||
;; in Scheme (not in the query driver loop)
|
||||
;; (initialize-data-base microshaft-data-base)
|
||||
|
||||
(define microshaft-data-base
|
||||
'(
|
||||
;; from section 4.4.1
|
||||
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
|
||||
(id (Bitdiddle Ben) 0)
|
||||
(job (Bitdiddle Ben) (computer wizard))
|
||||
(salary (Bitdiddle Ben) 60000)
|
||||
|
||||
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
|
||||
(id (Hacker Alyssa P) 1)
|
||||
(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))
|
||||
(id (Fect Cy D) 2)
|
||||
(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))
|
||||
(id (Tweakit Lem E) 3)
|
||||
(job (Tweakit Lem E) (computer technician))
|
||||
(salary (Tweakit Lem E) 25000)
|
||||
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
|
||||
|
||||
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
|
||||
(id (Reasoner Louis) 4)
|
||||
(job (Reasoner Louis) (computer programmer trainee))
|
||||
(salary (Reasoner Louis) 30000)
|
||||
(supervisor (Reasoner Louis) (Hacker Alyssa P))
|
||||
|
||||
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
|
||||
|
||||
(address (Warbucks Oliver) (Swellesley (Top Heap Road)))
|
||||
(id (Warbucks Oliver) 5)
|
||||
(job (Warbucks Oliver) (administration big wheel))
|
||||
(salary (Warbucks Oliver) 150000)
|
||||
|
||||
(address (Scrooge Eben) (Weston (Shady Lane) 10))
|
||||
(id (Scrooge Eben) 6)
|
||||
(job (Scrooge Eben) (accounting chief accountant))
|
||||
(salary (Scrooge Eben) 75000)
|
||||
(supervisor (Scrooge Eben) (Warbucks Oliver))
|
||||
|
||||
(address (Cratchet Robert) (Allston (N Harvard Street) 16))
|
||||
(id (Cratchet Robert) 7)
|
||||
(job (Cratchet Robert) (accounting scrivener))
|
||||
(salary (Cratchet Robert) 18000)
|
||||
(supervisor (Cratchet Robert) (Scrooge Eben))
|
||||
|
||||
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
|
||||
(id (Aull DeWitt) 8)
|
||||
(job (Aull DeWitt) (administration secretary))
|
||||
(salary (Aull DeWitt) 25000)
|
||||
(supervisor (Aull DeWitt) (Warbucks Oliver))
|
||||
|
||||
(meeting accounting (Monday 9am))
|
||||
(meeting administration (Monday 10am))
|
||||
(meeting computer (Wednesday 3pm))
|
||||
(meeting administration (Friday 1pm))
|
||||
(meeting whole-company (Wednesday 4pm))
|
||||
|
||||
(can-do-job (computer wizard) (computer programmer))
|
||||
(can-do-job (computer wizard) (computer technician))
|
||||
|
||||
(can-do-job (computer programmer)
|
||||
(computer programmer trainee))
|
||||
|
||||
(can-do-job (administration secretary)
|
||||
(administration big wheel))
|
||||
|
||||
(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))))
|
||||
|
||||
(rule (same ?x ?x))
|
||||
|
||||
(rule (wheel ?person)
|
||||
(and (supervisor ?middle-manager ?person)
|
||||
(supervisor ?x ?middle-manager)))
|
||||
|
||||
(rule (outranked-by ?staff-person ?boss)
|
||||
(or (supervisor ?staff-person ?boss)
|
||||
(and (supervisor ?staff-person ?middle-manager)
|
||||
(outranked-by ?middle-manager ?boss))))
|
||||
|
||||
; From 4.63
|
||||
(son Adam Cain)
|
||||
(son Cain Enoch)
|
||||
(son Enoch Irad)
|
||||
(son Irad Mehujael)
|
||||
(son Mehujael Methushael)
|
||||
(son Methushael Lamech)
|
||||
(wife Lamech Ada)
|
||||
(son Ada Jabal)
|
||||
(son Ada Jubal)
|
||||
|
||||
(married Mickey Minnie)
|
||||
|
||||
))
|
||||
|
||||
(initialize-data-base microshaft-data-base)
|
||||
|
||||
(display "[done]\n")
|
||||
))
|
||||
|
||||
(display "\nex-4.78 - non-deterministic-query\n")
|
||||
|
||||
; I am trying to get the query evaluator working within the non-deterministic
|
||||
; evaluator. The next step is to implement analyze-or in the non-deterministic
|
||||
; evaluator.
|
||||
|
||||
; Exercise 4.78. Redesign the query language as a nondeterministic program to
|
||||
; be implemented using the evaluator of section 4.3, rather than as a stream
|
||||
; process. In this approach, each query will produce a single answer (rather
|
||||
; than the stream of all answers) and the user can type try-again to see more
|
||||
; answers. You should find that much of the mechanism we built in this section
|
||||
; is subsumed by nondeterministic search and backtracking. You will probably
|
||||
; also find, however, that your new query language has subtle differences in
|
||||
; behavior from the one implemented here. Can you find examples that illustrate
|
||||
; this difference?
|
||||
|
||||
(display "\nex-4.79\n")
|
||||
|
|
@ -372,6 +372,14 @@
|
|||
(define (ramb? exp) (tagged-list? exp 'ramb))
|
||||
(define (ramb-choices exp) (cdr exp))
|
||||
|
||||
; The lamb statement takes a single list and treats each item as a value. So
|
||||
; its the equivalent of (apply amb list) in Scheme. Since our evaluator does
|
||||
; not support that expression we use lamb. Analyze-lamb calls analyze-amb.
|
||||
(define (lamb? exp) (tagged-list? exp 'lamb))
|
||||
(define (lamb-choices exp) (cdr exp))
|
||||
(define (analyze-lamb exp)
|
||||
(analyze-amb (cons (car exp) (cadr exp))))
|
||||
|
||||
;; analyze from 4.1.6, with clause from 4.3.3 added
|
||||
;; and also support for Let
|
||||
(define (analyze exp)
|
||||
|
@ -390,6 +398,8 @@
|
|||
((let? exp) (analyze (let->combination exp))) ;**
|
||||
((amb? exp) (analyze-amb exp)) ;**
|
||||
((ramb? exp) (analyze-ramb exp)) ;**
|
||||
((lamb? exp) (analyze-lamb exp)) ;**
|
||||
((or? exp) (analyze-or exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else
|
||||
(error "Unknown expression type -- ANALYZE" exp))))
|
||||
|
@ -420,8 +430,14 @@
|
|||
(succeed (make-procedure vars bproc env)
|
||||
fail))))
|
||||
|
||||
;;;Conditionals and sequences
|
||||
(define (or? exp) (tagged-list? exp 'or))
|
||||
(define (clauses exp) (cdr exp))
|
||||
(define (no-clauses? exp) (null? exp))
|
||||
(define (first-clause exp) (car exp))
|
||||
(define (rest-clauses exp) (cdr exp))
|
||||
; TODO: (define (analyze-or exp) ...)
|
||||
|
||||
;;;Conditionals and sequences
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
|
@ -615,8 +631,6 @@
|
|||
(let-body exp))
|
||||
(map let-val bindings))))
|
||||
|
||||
|
||||
|
||||
;; A longer list of primitives -- suitable for running everything in 4.3
|
||||
;; Overrides the list in ch4-mceval.scm
|
||||
;; Has Not to support Require; various stuff for code in text (including
|
||||
|
@ -624,30 +638,37 @@
|
|||
;; eq? for ex. solution
|
||||
|
||||
(define primitive-procedures
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list 'list list)
|
||||
(list 'memq memq)
|
||||
(list 'member member)
|
||||
(list 'not not)
|
||||
(list 'display display)
|
||||
(list (list '* *)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '<= <=)
|
||||
(list '= =)
|
||||
(list '> >)
|
||||
(list '>= >=)
|
||||
(list '<= <=)
|
||||
(list 'abs abs)
|
||||
(list 'remainder remainder)
|
||||
(list 'integer? integer?)
|
||||
(list 'sqrt sqrt)
|
||||
(list 'assoc assoc)
|
||||
(list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'display display)
|
||||
(list 'eq? eq?)
|
||||
(list 'integer? integer?)
|
||||
(list 'list list)
|
||||
(list 'member member)
|
||||
(list 'memq memq)
|
||||
(list 'newline newline)
|
||||
;; more primitives
|
||||
(list 'not not)
|
||||
(list 'null? null?)
|
||||
(list 'pair? pair?)
|
||||
(list 'remainder remainder)
|
||||
(list 'set-car! set-car!)
|
||||
(list 'set-cdr! set-cdr!)
|
||||
(list 'sqrt sqrt)
|
||||
(list 'string=? string=?)
|
||||
(list 'substring substring)
|
||||
(list 'symbol->string symbol->string)
|
||||
(list 'symbol? symbol?)
|
||||
(list 'the-empty-stream the-empty-stream)
|
||||
))
|
||||
|
||||
|
||||
'AMB-EVALUATOR-LOADED
|
||||
|
|
Loading…
Reference in New Issue