AAL sources (6 of 8)

[Jonathan Amsterdam]

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-

;;; The deducer for AAL.
;;; Copyright 1988 by Jonathan Amsterdam.  All Rights Reserved.

(provide 'deducer)

(require 'initial "initial.lisp")
(require 'streams "streams.lisp")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deductive retriever.

(defun assert (stmt)
  ;; Clobbers the Common-Lisp assert macro.
  ;; When a fact is asserted, it's translated into a b-rule to simplify the
  ;; rest of the deducer.
  (if (not (eq (car stmt) 'b-rule))
      (setq stmt `(b-rule ,stmt)))
  (when (add-to-database stmt)
    (report "~&Asserting ~a~%" stmt)
    (if (null (antecedent-of stmt))
	;; run rules only for facts
	(run-forward-rules *assertion-rules* (consequent-of stmt))))
    stmt)

(defun retract (stmt)
  (if (not (eq (car stmt) 'b-rule))
      (setq stmt `(b-rule ,stmt)))
  (when (remove-from-database stmt)
    (report "~&Retracting ~a~%" stmt)
    (if (null (antecedent-of stmt))
	;; run rules only for facts
	(run-forward-rules *retraction-rules* (consequent-of stmt))))
    stmt)

(defun run-forward-rules (rules fact)
  ;; Run a rule if its pattern matches the fact.
  (dolist (frule rules)
    (let ((bindings (unify fact (pattern-of frule) *globals*)))
      (when (not (eq bindings :fail))
	(report "~&Firing rule ~a~%" frule)
	(execute-action (action-of frule) bindings)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deduce.

;;; A pattern is a list.  The following cars are special:

;;; (not <pattern>)
;;; (or <pattern>*)
;;; (and <pattern>*)
;;; (do <action>*)			the actions areis executed; always
;;; 					  succeeds
;;; any action				The action is executed; succeeds if its
;;; 					 result is non-NIL.  All free variables
;;; 					 in the action must be instantiated.

(defun deduce (pattern bindings)
  ;; Returns a stream of bindings (variable lists) for things that match the
  ;; pattern, or the empty stream if there are none. 
  (let ((func (get (car pattern) 'deduce)))
    (cond
      (func
       (funcall func pattern bindings))
      ((aal-action? (car pattern))
       (deduce-action pattern bindings))
      (t
       (deduce-pattern pattern bindings (find-possible-unifiers pattern))))))
  
(defunp (deduce nil) (pattern bindings)
  ;; The null pattern always succeeds.
  (declare (ignore pattern))
  (stream bindings))

(defunp (deduce not) (pattern bindings)
  ;; Pattern should be fully instantiated.  Returns a stream consisting of
  ;; bindings if the pattern is not satisfied, the empty stream if it is.
  (if (stream-empty? (deduce (second pattern) bindings))
      (stream bindings)
      *empty-stream*))

(defunp (deduce or) (pattern bindings)
  ;; Returns a stream of all bindings satisfying any pattern in the list.
  (stream-mapcan #'(lambda (p) (deduce p bindings)) 
		 (list->stream (cdr pattern))))

(defunp (deduce and) (pattern bindings)
  ;; Returns a stream of bindings (variable lists) for things that match all
  ;; the patterns, or the empty stream if there are none.
  (deduce-list (cdr pattern) bindings))

(defun deduce-list (pattern-list bindings)
  (if (null pattern-list)
      (stream bindings)
      (let ((bindings-stream (deduce (car pattern-list) bindings)))
	(stream-mapcan #'(lambda (b) (deduce-list (cdr pattern-list) b))
		       bindings-stream))))

(defunp (deduce do) (pattern bindings)
  ;; The action is executed and the result ignored.  Always succeeds.
  (execute-action (second pattern) bindings)
  (stream bindings))

(defun deduce-action (action bindings)
  ;; The action is executed and succeeds if the result is non-NIL.  It also
  ;; augments the bindings.
  (multiple-value-bind (result new-bindings)
      (execute-action action bindings)
    (if result
      (stream new-bindings)
      *empty-stream*)))

(defun deduce-pattern (pattern bindings possibilities)
  ;; This is the only place "real work" gets done.
  (if (null possibilities)
      *empty-stream*
      (let* ((rule (rename-rule (car possibilities)))
	     (bindings1 (unify pattern (consequent-of rule) bindings)))
	      (if (eq bindings1 :fail)
		  (deduce-pattern pattern bindings (cdr possibilities))
		  (stream-append
		    (deduce (antecedent-of rule) bindings1)
		    (deduce-pattern pattern bindings (cdr possibilities)))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Unifier.
;;; This is a simplified unifier.  It doesn't do nested patterns, and it also
;;; doesn't do the "occur check".  See Abelson & Sussman for a full-blooded
;;; unifier.

(defun unify (pat1 pat2 bindings)
  ;;Returns :FAIL if it can't unify, a list of bindings if it can.
  (cond
    ((and (null pat1) (null pat2))
     bindings)
    ((or (null pat1) (null pat2))
     :fail)
    ((let* ((el1 (car pat1))
	    (el2 (car pat2))
	    (new-bindings (if (var? el1)
			      (unify-var el1 el2 bindings)
			      (unify-const el1 el2 bindings))))
       (if (eq new-bindings :fail)
	   :fail
	   (unify (cdr pat1) (cdr pat2) new-bindings))))))

(defun unify-var (v el bindings)
  (let ((val (var-value v bindings)))
    (if (eq val :unbound)
	(if (eq v '*)
	    ;; The * variable, like the underscore in Prolog, indicates a
	    ;; "don't care".  It matches, but we create no binding for it.
	    bindings
	    (add-binding v el bindings))
	(unify-const val el bindings))))

(defun unify-const (const el bindings)
  (if (var? el)
      (unify-var el const bindings)
      (if (eql const el) bindings :fail)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun find-possible-unifiers (pattern)
  (if (var? (car pattern))
      *db*
      (append  (get '* 'database)
	       (get (car pattern) 'database))))

(defun add-to-database (rule)
  ;; Returns NIL iff not added (because already present)
  (let ((index (index-of rule)))
    (cond
      ((member rule (get index 'database) :test #'equal)
       nil)
      (t
       (push rule (get index 'database))
       (push rule *db*)
       (pushnew index *indices*)
       t))))

(defun remove-from-database (rule)
  ;; Returns NIL iff not removed (because not present)
  (let* ((index (index-of rule))
	 (the-rule (car (member rule (get index 'database) :test #'equal))))
    (cond
      (the-rule
       (setf (get index 'database) (delete the-rule (get index 'database) :test #'eq))
       (setq *db* (delete the-rule *db* :test #'eq))
       t)
      (t nil))))

(defun index-of (rule)
  (car (consequent-of rule)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun var? (thing)
  ;; A variable is a lisp symbol that begins with a *, but does not end with
  ;; one (except for the single-character variable "*").  We institute this
  ;; last requirement so that lisp globals, traditionally written as *symbol*,
  ;; can be accessed from AAL.
  (if (symbolp thing) 
      (let* ((name (symbol-name thing))
	     (length (length name)))
	(and
	  (char= (char name 0) #\*)
	  (or (= length 1)
	      (not (char= (char name (1- length)) #\*)))))
      nil))

(defun add-binding (var value bindings)
  (cons (cons var value) bindings))

(defun var-value (var bindings)
  ;; Follow the chain of bindings to the end.
  (let ((val-pair (assoc var bindings)))
    (if (not val-pair)
	:unbound
	(let ((val (cdr val-pair)))
	  (if (var? val)
	      (var-value val bindings)
	      val)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Renaming variables in a rule.  
;;; This needs to be done so that variables with the same name from two
;;; different rules (or two instantiations of the same, recursive, rule) don't
;;; interact.

(defun rename-rule (rule)
  ;; Renames all the variables in rule.
  (copy-pattern rule nil))

(defun copy-pattern (pattern correspondences)
  ;; Copy pattern, renaming variables.  So that textually distinct occurrences
  ;; of the same variable are renamed the same way, we need to keep a list of
  ;; the old-var/new-var correspondences.  We first build up an a-list of
  ;; the correspondences, then let sublis do the work.
  (let ((new-correspondences (create-correspondences pattern correspondences)))
    (if new-correspondences
	(sublis new-correspondences pattern)
	;; nothing to substitute (i.e. pat has no variables) so no need to copy
	pattern)))

(defun create-correspondences (pattern correspondences)
  ;; Avoid renaming global and local variables.
  (cond
    ((null pattern)
     correspondences)
    ((atom pattern)
     (if (and (var? pattern) 
	      (not (assoc pattern correspondences))
	      (not (assoc pattern (or *protected-vars* *globals*))))
	 (add-binding pattern (rename-var pattern) correspondences)
	 correspondences))
    (t
     (create-correspondences (cdr pattern)
			     (create-correspondences (car pattern)
						     correspondences)))))


(defun rename-var (var)
  ;; Generate a new symbol.
  (gentemp (symbol-name var)))

  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; For testing.

(defun dedp (p)
  ;; for testing only
  (let ((uvars (reverse (unbound-vars-in-pattern p *globals* nil))))
    (mapcar #'(lambda (b) (extract-bindings b uvars))
	    (stream->list (deduce p *globals*)))))

(defun extract-bindings (bindings var-names)
  (mapcar #'(lambda (name) (cons name (var-value name bindings)))
	  var-names))

(defun unbound-vars-in-pattern (pattern bindings unbound-vars)
  (cond
    ((null pattern)
     unbound-vars)
    ((atom pattern)
     (if (and (var? pattern) (unbound? pattern bindings))
	 (adjoin pattern unbound-vars)
	 unbound-vars))
    (t
     (unbound-vars-in-pattern
       (cdr pattern) bindings
       (unbound-vars-in-pattern (car pattern) 
				bindings unbound-vars)))))

(defun unbound? (var bindings)
  (eq (var-value var bindings) :unbound))

(defun asserts (list)
  (dolist (pat list)
    (assert pat)))

(defun show-db (&optional predicate)
  (fresh-line)
  (dolist (stmt (if predicate (get predicate 'database) *db*))
    (format t "~s~%" (if (null (antecedent-of stmt))
			 (consequent-of stmt)
			 stmt))))

;;; End deducer.lisp.