Implement till 4.75
parent
4f57cfe87e
commit
823f0e34dd
|
@ -42,11 +42,49 @@
|
|||
|
||||
(display "[answered]\n")
|
||||
|
||||
(display "\nex-4.74\n")
|
||||
(display "\nex-4.74 - simple-stream-flatmap\n")
|
||||
|
||||
(define (simple-stream-flatmap proc s)
|
||||
(simple-flatten (stream-map proc s)))
|
||||
|
||||
(define (stream-not-null? x)
|
||||
(not (stream-null? x)))
|
||||
|
||||
(define (simple-flatten stream)
|
||||
(stream-map stream-car
|
||||
(stream-filter stream-not-null? stream)))
|
||||
|
||||
(eval-query
|
||||
'(and (salary (Bitdiddle Ben) ?ben-amount)
|
||||
(salary ?person ?amount)
|
||||
(lisp-value > ?amount ?ben-amount)))
|
||||
(newline)
|
||||
|
||||
; The query system's behavior does not change because interleaving does not
|
||||
; have an effect for empty and singleton streams.
|
||||
|
||||
(display "\nex-4.75 - unique\n")
|
||||
|
||||
(eval-query
|
||||
'(unique (job ?x (computer wizard))))
|
||||
(newline)
|
||||
|
||||
(eval-query
|
||||
'(unique (job ?x (computer programmer))))
|
||||
(newline)
|
||||
|
||||
(eval-query
|
||||
'(and (job ?x ?j) (unique (job ?anyone ?j))))
|
||||
(newline)
|
||||
|
||||
(eval-query
|
||||
'(and (job ?p ?j) (unique (supervisor ?s ?p))))
|
||||
(newline)
|
||||
|
||||
(display "\nex-4.76\n")
|
||||
|
||||
(display "\nex-4.77\n")
|
||||
|
||||
;(display "\nex-4.75\n")
|
||||
;(display "\nex-4.76\n")
|
||||
;(display "\nex-4.77\n")
|
||||
;(display "\nex-4.78\n")
|
||||
;(display "\nex-4.79\n")
|
||||
|
||||
|
|
|
@ -66,6 +66,7 @@
|
|||
;;;Simple queries
|
||||
|
||||
(define (simple-query query-pattern frame-stream)
|
||||
;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
|
||||
(stream-flatmap
|
||||
(lambda (frame)
|
||||
(stream-append-delayed
|
||||
|
@ -106,6 +107,15 @@
|
|||
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)
|
||||
|
@ -539,7 +549,7 @@
|
|||
((eq? m 'insert-proc!) insert!)
|
||||
(else (error "Unknown operation -- TABLE" m))))
|
||||
dispatch))
|
||||
|
||||
|
||||
;;;; From instructor's manual
|
||||
|
||||
(define get '())
|
||||
|
@ -570,6 +580,7 @@
|
|||
(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 '() '()))
|
||||
|
|
Loading…
Reference in New Issue