DataMuseum.dk

top - download

    Length: 15397 (0x3c25)
    Types: TextFile
    Names: »ps9query.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/ps9query.scm« 

TextFile

;;-*-scheme-*-
;;this is the file ps9-query.scm
;;It contains the query language interpreter as it appears in Chapter 4

;; Some magic to make things run faster ....
(declare (compile-usual-primitive-functions)
	 (compilable-primitive-variables
	  car null? cdr))

;;First, we implement PUT and GET

(define (make-table)
  (let ((local-table (list '*table*)))

    (define (lookup key-1 key-2)
      (let ((subtable (assq key-1 (cdr local-table))))
	(if (null? subtable)
	    '()
	    (let ((pair (assq key-2 (cdr subtable))))
	      (if (null? pair)
		  '()
		  (cdr pair))))))

    (define (insert! key-1 key-2 value)
      (let ((subtable (assq key-1 (cdr local-table))))
	(if (null? subtable)
	    (set-cdr! local-table
		      (cons (cons key-1
				  (cons (cons key-2 value) '()))
			    (cdr local-table)))
	    (let ((pair (assq key-2 (cdr subtable))))
	      (if (null? pair)
		  (set-cdr! subtable
			    (cons (cons key-2 value)
				  (cdr subtable)))
		  (set-cdr! pair value))))))

    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
	    ((eq? m 'insert-proc!) insert!)
	    (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define get ())
(define put ())

;;Then some stream functions
(define the-empty-stream '())

(define (empty-stream? s) (null? s))

(define (map proc s)
  (if (empty-stream? s)
      the-empty-stream
      (cons-stream (proc (head s))
                   (map proc (tail s)))))


(define (flatmap proc stream)
  (if (empty-stream? stream)
      the-empty-stream
      (let ((p (proc (head stream))))
        (if (empty-stream? p)
	    (flatmap proc (tail stream))
	    (cons-stream (head p)
			 (interleave (flatmap proc (tail stream))
				     (tail p)))))))

(define (singleton s) (cons-stream s the-empty-stream))
(define (interleave s1 s2)
  (if (empty-stream? s1)
      s2
      (cons-stream (head s1)
		   (interleave s2
			       (tail s1)))))

(define (append-streams s1 s2)
  (if (empty-stream? s1)
      s2
      (cons-stream (head s1)
                   (append-streams (tail s1) s2))))

;; Something to ease the pain...

;(enable-language-features)    ; That means magic ....
;
;(define get-query-from-editor
;  (let ((editor-zap-filename (access editor-zap-filename '()))
;	(editor-crunch-volume (access editor-crunch-volume '()))
;	(crunch (access crunch '()))
;	(unwind-protect (access unwind-protect '()))
;	(quit (access quit '())))
;    (named-lambda (get-query-from-editor)
;      (let ((form '())
;	    (file-channel '()))
;	(newline)
;	(princ "==> Editor")
;	(quit)
;	(tyo #o14)	      ;Homes cursor and clears screen
;	(if (file-exists? editor-zap-filename)
;	    (unwind-protect
;	     (lambda ()
;	       (set! file-channel
;		     (open-reader-channel
;		      editor-zap-filename))
;	       (let ((query (read file-channel)))
;		 (newline)
;		 (princ "QUERY from editor: ")
;		 (pp query)
;		 (newline)
;		 (set! form query)))
;	     (lambda ()
;	       (if file-channel
;		   (sequence
;		    (close-channel file-channel)
;		    (delete-file editor-zap-filename)
;		    (crunch editor-crunch-volume))))))
;	form))))
;
;(disable-language-features)   ; End of magic, for now

;;Now, the query system from Section 4.4

(define (query-driver-loop)
  (newline)
  (princ "QUERY--> ")
  (let ((q (read)))
    (if (equal? q '(EDIT))
	(set! q (get-query-from-editor)))
    (if q (process-query q)))
  (newline)
  (query-driver-loop))

(define (process-query query)
  (newline)
  (princ "Responses to query:")
  (let ((q (query-syntax-process query)))
    (if (assertion-to-be-added? q)
        (sequence (add-assertion! (add-assertion-body q))
                  (print "assertion added to data base")
                  (query-driver-loop))
        (sequence
         (print-stream-elements-on-separate-lines
          (map (lambda (frame) (instantiate q frame))
               (qeval q (singleton '()))))))))

(define (query-syntax-process exp)
  (map-over-atoms expand-question-mark exp))

(define (expand-question-mark symbol)
  (if (number? symbol)
      symbol
      (let ((characters (explode symbol)))
	(if (eq? (car characters) '?)
	    (list '? (implode (cdr characters)))
	    symbol))))

(define (map-over-atoms proc exp)
  (cond ((null? exp) '())
        ((pair? exp) (cons (map-over-atoms proc (car exp))
                           (map-over-atoms proc (cdr exp))))
        ((atom? exp) (proc exp))
        (else (error "unknown expression -- Map over atoms"
                     exp))))

(define (qeval query frame-stream)
  (let ((qproc (get (type query) 'qeval))) 
    (if (not (null? qproc))
	(qproc (contents query) frame-stream)
	(asserted? (make-arg-list query)
		   frame-stream))))

(define (asserted? a frame-stream)
  (append-streams 
   (flatmap (lambda (frame)
	      (find-assertions (pattern-of a) frame))
	    frame-stream)
   (flatmap (lambda (frame)
	      (apply-rules (pattern-of a) frame))
	    frame-stream)))

(define (conjoin conjuncts frame-stream)
  (if (empty-conjunction? conjuncts)
      frame-stream
      (conjoin (rest-conjuncts conjuncts)
	       (qeval (first-conjunct conjuncts)
		      frame-stream))))

(define (disjoin disjuncts frame-stream)
  (if (empty-disjunction? disjuncts)
      the-empty-stream
      (append-streams (qeval (first-disjunct disjuncts)
			     frame-stream)
		      (disjoin (rest-disjuncts disjuncts)
			       frame-stream))))

(define (negate a frame-stream)
  (flatmap
   (lambda (frame)
     (if (empty-stream? (qeval (expression-argument a)
			       (singleton frame)))
         (singleton frame)
         the-empty-stream))
   frame-stream))

(define (lisp-value call frame-stream)
  (flatmap
   (lambda (frame)
     (let ((lcall (instantiate call frame)))
       (if (execute lcall)
	   (singleton frame)
	   the-empty-stream)))
   frame-stream))

(define (always-true ignore frame-stream)
  frame-stream)					

(define (pattern-match pat dat frame)
  (let ((result (internal-match pat dat frame)))
    (if (eq? result 'failed)
	the-empty-stream
	(singleton result))))

(define (internal-match pat dat frame)
  (cond ((eq? frame 'failed) 'failed)
        ((and (number? pat) (number? dat))
         (cond ((= pat dat) frame)
               (else 'failed)))
        ((atom? pat)
         (cond ((eq? pat dat) frame)
               (else 'failed)))
        ((var? pat)
         (extend-if-consistent pat
                               dat
                               frame))
        ((atom? dat) 'failed)
        (else (internal-match (cdr pat)
                             (cdr dat)
                             (internal-match (car pat)
					     (car dat)
					     frame)))))

(define (extend-if-consistent var dat frame)
  (let ((value-cell (binding-in-frame var frame)))
    (if (null? value-cell)
	(extend var dat frame)
	(internal-match (binding-value value-cell) dat frame))))

(define (find-assertions pattern frame)
  (flatmap (lambda (datum)
	     (pattern-match pattern datum frame))
	   (fetch-assertions pattern frame)))

(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
				     (rule-conclusion clean-rule)
				     query-frame)))	    
      (if (empty-stream? unify-result)
          the-empty-stream
          (qeval (rule-condition clean-rule)
                 unify-result)))))

(define (rename-variables-in rule)
  (define (tree-walk exp)
    (cond ((atom? exp) exp)
	  ((var? exp) (make-new-variable exp))
	  (else (cons (tree-walk (car exp))
                      (tree-walk (cdr exp))))))
  (increment-rule-counter)
  (tree-walk rule))

(define rule-counter 0)

(define (increment-rule-counter)
  (set! rule-counter (1+ rule-counter)))

(define (make-new-variable var)
  (cons '? (cons rule-counter (cdr var))))

(define (unify-match p1 p2 frame)
  (let ((result (internal-unify p1 p2 frame)))
    (if (eq? result 'failed)
	the-empty-stream
	(singleton result))))

(define (internal-unify p1 p2 frame)
  (cond ((eq? frame 'failed) 'failed)
        ((equal? p1 p2) frame)
        ((atom? p1)
         (cond ((atom? p2) 'failed)
               ((var? p2) (extend-if-possible p2 p1 frame))
               (else 'failed)))
        ((var? p1) (extend-if-possible p1 p2 frame))
        ((atom? p2) 'failed)
        ((var? p2) (extend-if-possible p2 p1 frame))
        (else (internal-unify (cdr p1)
			      (cdr p2)
			      (internal-unify (car p1)
					      (car p2)
					      frame)))))

(define (extend-if-possible var val frame)
  (if (equal? var val)
      frame
      (let ((value-cell (binding-in-frame var frame)))
	(if (null? value-cell)
	    (if (freefor? var val frame)
		(extend var val frame)
		'failed)
	    (internal-unify (binding-value value-cell)
			    val
			    frame)))))

(define (freefor? var exp frame)
  (define (freewalk e)
    (cond ((atom? e) t)
	  ((var? e)
	   (if (equal? var e)
	       '()
	       (freewalk (lookup-in-frame e frame))))
	  ((freewalk (car e)) (freewalk (cdr e)))
	  (else '())))
  (freewalk exp))

(define THE-ASSERTIONS the-empty-stream)
(define ASSERTIONS-WITH-NON-ATOMIC-CARS the-empty-stream)

(define (fetch-assertions pattern frame)
  (if (atom? (car pattern))
      (get-assertions-on-list (car pattern))
      (get-all-assertions)))

(define (get-all-assertions) THE-ASSERTIONS)

(define (get-assertions-on-list symbol)
  (append-streams
   ASSERTIONS-WITH-NON-ATOMIC-CARS
   (let ((assertion-stream (get symbol 'assertion-stream)))
     (if (null? assertion-stream)
	 the-empty-stream
	 assertion-stream))))

(define THE-RULES the-empty-stream)
(define RULES-WITH-NON-ATOMIC-CARS the-empty-stream)

(define (fetch-rules pattern frame)
  (if (atom? (car pattern))
      (get-rules-on-list (car pattern))
      (get-all-rules)))

(define (get-all-rules) THE-RULES)

(define (get-rules-on-list symbol)
  (append-streams
   RULES-WITH-NON-ATOMIC-CARS
   (let ((rule-stream (get symbol 'rule-stream)))
     (if (null? rule-stream)
	 the-empty-stream
	 rule-stream))))

(define (initialize-data-base big-list)
  (define (deal-out statements rules assertions)
    (if (null? statements)
        (sequence (set! THE-ASSERTIONS assertions)
                  (set! THE-RULES rules)
                  'done)
        (let ((s (query-syntax-process (car statements))))
          (if (rule? s)
              (sequence (store-rule-according-to-car s)
                        (deal-out (cdr statements)
                                  (cons s rules)
                                  assertions))
              (sequence
               (store-assertion-according-to-car s)
               (deal-out (cdr statements)
                         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 'lisp-value 'qeval lisp-value)
  (put 'always-true 'qeval always-true)
  (deal-out big-list '() '()))

(define (add-assertion! assertion)
  (if (rule? assertion)
      (add-rule! assertion)
      (add-simple-assertion! assertion)))

(define (add-simple-assertion! assertion)
  (store-assertion-according-to-car assertion)
  (let ((old-assertions THE-ASSERTIONS))
    (set! THE-ASSERTIONS (cons-stream assertion old-assertions))
    'ok))

(define (add-rule! rule)
  (cond
   ((rule? rule)
    (store-rule-according-to-car rule)
    (let ((old-rules the-rules))
      (set! THE-RULES (cons-stream rule old-rules))
      'ok))
   (else (error "badly formed rule"))))

(define (store-assertion-according-to-car assertion)
  (cond ((not (atom? (car assertion)))
         (let ((old-assertions ASSERTIONS-WITH-NON-ATOMIC-CARS))
           (set! ASSERTIONS-WITH-NON-ATOMIC-CARS
                 (cons-stream assertion old-assertions))))
        (else
         (let ((current-assertion-stream
                (get (car assertion) 'assertion-stream)))
           (cond ((null? current-assertion-stream)
                  (put (car assertion)
                       'assertion-stream
                       (singleton assertion)))
                 (else
                  (put (car assertion)
                       'assertion-stream
                       (cons-stream assertion
                                    current-assertion-stream))))))))

(define (store-rule-according-to-car rule)
  (let ((pattern (rule-conclusion rule)))
    (cond ((not (atom? (car pattern)))
           (let ((old-rules RULES-WITH-NON-ATOMIC-CARS))
             (set! RULES-WITH-NON-ATOMIC-CARS
                   (cons-stream rule old-rules))))
        (else
         (let ((current-rule-stream
                (get (car pattern) 'rule-stream)))
           (cond ((null? current-rule-stream)
                  (put (car pattern)
                           'rule-stream
                           (cons-stream rule
                                        the-empty-stream)))
                 (else
                  (put (car pattern)
                       'rule-stream
                       (cons-stream rule
                                    current-rule-stream)))))))))

(define (instantiate exp frame)
  (define (copy exp)
    (cond ((atom? exp) exp)
	  ((var? exp)
	   (let ((vcell (binding-in-frame exp frame)))
	     (cond ((not (null? vcell))
		    (copy (binding-value vcell)))
		   (else exp))))
	  (else (cons (copy (car exp))
		   (copy (cdr exp))))))
  (copy exp))

(define (execute exp)
  (apply (eval (car exp)
               (the-environment))
         (cdr exp)))

(define (binding-in-frame variable frame)
  (assoc variable frame))

(define (extend variable datum frame)
  (cons (make-binding variable datum) frame))

(define (make-binding variable datum)
  (cons variable datum))

(define (unbound? var frame)
  (null? (binding-in-frame var frame)))

(define (binding-variable binding)
  (car binding))

(define (binding-value binding)
  (cdr binding))

(define (lookup-in-frame variable frame)
  (binding-value (binding-in-frame variable frame)))

(define (type exp)
  (cond ((not (atom? exp))
         (cond ((atom? (car exp)) (car exp))
               (else '())))
	(else (error "unknown expression type" exp))))

(define (contents exp)
  (cond ((not (atom? exp)) (cdr exp))
	(else (error "unknown expression contents" exp))))

(define (assertion-to-be-added? exp)
  (eq? (type exp) 'assert!))

(define (add-assertion-body exp) (cadr exp))

(define pattern-of car)
(define expression-argument car)
(define (make-arg-list arg) (list arg))

(define empty-conjunction? null?)
(define first-conjunct car)
(define rest-conjuncts cdr)

(define empty-disjunction? null?)
(define first-disjunct car)
(define rest-disjuncts cdr)

(define (rule? statement)
  (and (not (atom? statement))
       (eq? (car statement) 'rule)))

(define rule-conclusion cadr)

(define (rule-condition rule)
  (if (null? (cddr rule))
      '(always-true)
      (caddr rule)))

(define (var? exp) (eq? (car exp) '?))

(define (print-stream-elements-on-separate-lines s)
  (if (empty-stream? s)
      (print "done")
      (sequence (pp (head s))
                (print-stream-elements-on-separate-lines
                 (tail s)))))