694 lines
19 KiB
Scheme
694 lines
19 KiB
Scheme
(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 (require p)
|
|
(if (null? p) (amb)))
|
|
|
|
(define (instantiate exp frame unbound-var-handler)
|
|
(define (copy exp)
|
|
(cond ((var? exp)
|
|
(let ((binding (binding-in-frame exp frame)))
|
|
(if binding
|
|
(copy (binding-value binding))
|
|
(unbound-var-handler exp frame))))
|
|
((pair? exp)
|
|
(cons (copy (car exp)) (copy (cdr exp))))
|
|
(else exp)))
|
|
(copy exp))
|
|
|
|
(define (qeval query frame)
|
|
(let ((qproc (get (type query) 'qeval)))
|
|
(if qproc
|
|
(qproc (contents query) frame)
|
|
(simple-query query frame))))
|
|
|
|
(define (simple-query query-pattern frame)
|
|
;;(display "SIMPLE-QUERY ") (display query-pattern) (newline)
|
|
(let ((r (apply-rules query-pattern frame)))
|
|
(let ((a (find-assertions query-pattern frame)))
|
|
(let ((result (append a r)))
|
|
(require result)
|
|
result))))
|
|
|
|
(define (conjoin conjuncts frame)
|
|
(if (empty-conjunction? conjuncts)
|
|
frame
|
|
(conjoin (rest-conjuncts conjuncts)
|
|
(qeval (first-conjunct conjuncts) frame))))
|
|
|
|
(define (disjoin disjuncts frame)
|
|
(if (empty-disjunction? disjuncts)
|
|
(amb)
|
|
(let ((r1 (qeval (first-disjunct disjuncts) frame)))
|
|
(if (null? r1)
|
|
(disjoin (rest-disjuncts disjuncts) frame)
|
|
(amb r1 (disjoin (rest-disjuncts disjuncts) frame))))))
|
|
|
|
;;(put 'or 'qeval disjoin)
|
|
|
|
;;;Filters
|
|
|
|
(define (negate operands frame)
|
|
(if (null? (qeval (negated-query operands) frame))
|
|
frame
|
|
(amb)))
|
|
|
|
(define (uniquely-asserted query frame-list)
|
|
(flatmap
|
|
(lambda (frame)
|
|
(let ((matches (qeval (car query) (singleton-list frame))))
|
|
(cond ((null? matches) matches)
|
|
((null? (cdr matches)) matches)
|
|
(else '()))))
|
|
frame-list))
|
|
|
|
;;(put 'not 'qeval negate)
|
|
|
|
(define (lisp-value call frame)
|
|
(if (execute
|
|
(instantiate
|
|
call
|
|
frame
|
|
(lambda (v f)
|
|
(error "Unknown pat var -- LISP-VALUE" v))))
|
|
frame
|
|
(amb)))
|
|
;;(put 'lisp-value 'qeval lisp-value)
|
|
|
|
(define (execute exp)
|
|
(let ((op (car exp)))
|
|
(cond
|
|
((eq? op '<) (< (cadr exp) (cadr (cdr exp))))
|
|
((eq? op '>) (> (cadr exp) (cadr (cdr exp))))
|
|
(else
|
|
(display "list-value OP not supported ")
|
|
(display op)
|
|
(newline)
|
|
#f))))
|
|
|
|
(define (always-true ignore frame-list) frame-list)
|
|
|
|
;;(put 'always-true 'qeval always-true)
|
|
|
|
(define (find-assertions pattern frame)
|
|
;; (display "FIND-ASSERTIONS ") (display pattern) (newline)
|
|
(define (check xs)
|
|
(if (null? xs)
|
|
xs
|
|
(if (null? (car xs))
|
|
(check (cdr xs))
|
|
(cons (car xs) (check (cdr xs))))))
|
|
|
|
(lamb ;(check
|
|
(map (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)
|
|
'()
|
|
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)
|
|
(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)
|
|
'()
|
|
(qeval (rule-body clean-rule)
|
|
(singleton-list 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 '())
|
|
|
|
(define (fetch-assertions pattern frame)
|
|
;; (display "FETCH-ASSERTIONS ") (display pattern) (newline)
|
|
(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 '())))
|
|
|
|
(define THE-RULES '())
|
|
|
|
(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)
|
|
(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 assertion old-assertions))
|
|
'ok))
|
|
|
|
(define (add-rule! rule)
|
|
(store-rule-in-index rule)
|
|
(let ((old-rules THE-RULES))
|
|
(set! THE-RULES (cons 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 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 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-null? null?)
|
|
|
|
(define (interleave s1 s2)
|
|
(if (null? s1)
|
|
s2
|
|
(cons
|
|
(car s1)
|
|
(interleave s2 (cdr s1)))))
|
|
|
|
(define (flatmap proc xs)
|
|
(flatten (map proc xs)))
|
|
|
|
(define (map proc xs)
|
|
(if (null? xs)
|
|
'()
|
|
(cons (proc (car xs))
|
|
(map proc (cdr xs)))))
|
|
|
|
|
|
(define (flatten stream)
|
|
(if (null? stream)
|
|
'()
|
|
(interleave
|
|
(car stream)
|
|
(flatten (cdr stream)))))
|
|
|
|
(define (singleton-list x)
|
|
(cons x '()))
|
|
|
|
;;;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 (display-list s)
|
|
(map display-line s))
|
|
|
|
(define (display-line x)
|
|
(display x)
|
|
(newline))
|
|
|
|
;;;;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 assertions)
|
|
(set! THE-RULES 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)
|
|
|
|
))
|
|
|
|
(define (rule-to-be-added? exp)
|
|
(eq? (car exp) 'rule))
|
|
|
|
(define (eval-query input)
|
|
(let ((q (query-syntax-process input)))
|
|
(cond ((assertion-to-be-added? q)
|
|
(add-rule-or-assertion! (add-assertion-body q)))
|
|
((rule-to-be-added? q)
|
|
(add-rule-or-assertion! q))
|
|
(else
|
|
(instantiate
|
|
q
|
|
(qeval q '())
|
|
(lambda (v f) (contract-question-mark v)))))))
|
|
|
|
(display "\nex-4.78 - non-deterministic-query\n")
|
|
(display "[installed-query-system]\n")
|
|
(initialize-data-base microshaft-data-base)
|
|
(display "[installed-microshaft-data-base]\n")
|
|
|
|
;(eval-query '(supervisor ?x (bitdiddle ben)))
|
|
|
|
;(eval-query
|
|
; '(and (supervisor ?person (Bitdiddle Ben))
|
|
; (address ?person ?address)))
|
|
|
|
;(eval-query
|
|
; '(rule (big-shot ?p)
|
|
; (and (job ?p (?div1 . ?rest1))
|
|
; (supervisor ?p ?boss)
|
|
; (job ?boss (?div2 . ?rest2))
|
|
; (not (same ?div1 ?div2)))))
|
|
|
|
(eval-query
|
|
'(and (salary (Bitdiddle Ben) ?ben-amount)
|
|
(salary ?person ?amount)
|
|
(lisp-value > ?amount ?ben-amount)))
|
|
|
|
|
|
;(eval-query '(big-shot ?x))
|
|
|
|
)) ;; Enf of non-deterministic evaluator
|
|
|
|
(define (display-line x)
|
|
(display x)
|
|
(newline))
|
|
(map display-line result)
|
|
|
|
; Regular queries work, but rules don't. I have to admit that this exercise is
|
|
; at the limit of my current capabilities and I have already spent a
|
|
; significantly longer time than I need for a regular exercise. I move on for
|
|
; now. Honestly, I am pretty proud that I was able to set up the query language
|
|
; within the non-deterministic evaluator. To make further progress I would need
|
|
; to understand the query-rule application better.
|
|
|
|
(display "\nex-4.79\n")
|
|
|
|
(display "[skipped]\n")
|
|
|
|
; I throw the towel on this one. 4.78 was challenging enough and I want to move
|
|
; on.
|