;;; -*- Mode:LISP; Package:(EK201 USE (GLOBAL) SHADOW (ASSERT)); Readtable:ZL; Base:10 -*-

  EK201 HAND OUT #12 APRIL 15, 1987

  Time: 7:30-9:30 MON, 7:30-8:30 WED
  Instructor: George Carrette
  Office:     room 171, sociology building
  Hours:      6:30-7:30 Wed, on-line during evening hours

* concepts: translation and substitution. table lookup.

* pattern matching as a two stage operation.
  1. compilation or translation of the pattern
  2. matching.

* database search using pattern matching.

* "production rules" which can be used to
  infer new facts from other old facts in the
  database.

* PROBLEM: (Homework to think about for monday)
  How can we make RUN-RULE-ONCE be more efficient?

Our input pattern language:

* Symbols and expressions such as X, Y, (A B), 3.3, 5
  are called litterals and must match the data exactly
  using EQUAL.
* The symbol ? is a wild-card which matches anything.
* A symbol ?x or ?foo is a wild-card which matches anything
  and "binds" X or FOO to the item matched.

We first start with the definition of MATCH that is a
copy of the definition of EQUAL.

(defun match (p x)
  (cond ((atom p)
	 (cond ((numberp p)
		(and (numberp x) (= p x)))
	       ('else
		(eq p x))))
	((atom x)
	 nil)
	('else
	 (and (match (car p) (car x))
	      (match (cdr p) (cdr x))))))

Therefore:
 (match 'x 'y) => NIL
 (match '(x) '(x)) => T
 (match '(a b (3)) '(a b (3))) => T

* To support the simple ? wild-card in our pattern language:

(defun match (p x)
  (cond ((atom p)
	 (cond ((eq p '?))
	       ((numberp p)
		(and (numberp x) (= p x)))
	       ('else
		(eq p x))))
	((atom x)
	 nil)
	('else
	 (and (match (car p) (car x))
	      (match (cdr p) (cdr x))))))

Therefore:
 (match '? '(a b)) => T
 (match '((?) b) '(a b)) => NIL
 (match '((?) b) '((a) b)) => T

* To support wild-cards such as ?x and ?y, which we call
  variable wild-cards we need to introduce a predicate
  variablep.

(defun variable-p (x)
  (eq (type-of x) 'variable))

(defstruct (variable #+lispm :named)
  variable-name
  variable-?name
  variable-bound-p
  variable-value)

* patterns will be translated with ?x and ?y being turned into
  variables. Translate-pattern will return a list of two
  things, the new pattern and the variables contained in the
  pattern. Notice how the code makes sure that if a pattern
  contains two reference to a symbol ?x that these get
  replaced with identical copies of the "variable" containing "x".
  These is accomplished by the use of a global variable called
  *variables-found*. A function LOOKUP is used to find a previous
   copy of the variable in this list.

(defvar *variables-found* nil)
 
(defun translate-pattern (p)
  (let ((*variables-found* nil))
    (list (translate-pattern-1 p)
	  *variables-found*)))

(defun translate-pattern-1 (p)
  (cond ((atom p)
	 (cond ((eq p '?)
		p)
	       ((symbolp p)
		(let ((pname (explode p)))
		  (cond ((eq (car pname) '?)
			 (let ((name (implode (cdr pname))))
			   (cond ((lookup name *variables-found*))
				 ('else
				  (let ((var (make-variable variable-name name
							    variable-?name p)))
				    (push var *variables-found*)
				    var)))))
			('else
			 p))))
	       ('else
		p)))
	('else
	 (cons (translate-pattern-1 (car p))
	       (translate-pattern-1 (cdr p))))))

(defun lookup (name vars)
  (do ((l vars (cdr l)))
      ((null l)
	nil)
    (when (eq name (variable-name (car l)))
      (return (car l)))))


* Then match is a two step process, translate, then match-1.
  For patterns without variables it will return T or NIL
  And for those with variables it will return a list of variables
  or NIL.

(defun match (p x)
  (let ((tr (translate-pattern p)))
    (cond ((not (match-1 (car tr) x))
	   nil)
	  ((not (cadr tr))
	   t)
	  ('else
	   (cadr tr)))))


* and match-1 is only a slightly modified version of our previous
  MATCH, with the use of VARIABLE-P included.
* Note WELL: once a variable has been "bound" to a particular item
  it acts as a literal in the pattern from then on.

(defun match-1 (p x)
  (cond ((atom p)
	 (cond ((eq p '?))
	       ((numberp p)
		(and (numberp x) (= p x)))
	       ((variable-p p)
		(cond ((variable-bound-p p)
		       (equal (variable-value p) x))
		      ('else
		       (setf (variable-value p) x)
		       (setf (variable-bound-p p) t))))
	       ('else
		(eq p x))))
	((atom x)
	 nil)
	('else
	 (and (match-1 (car p) (car x))
	      (match-1 (cdr p) (cdr x))))))

* A database query system.
		
(defvar *database* nil)

* Facts are put into the database with the function ASSERT.
  Note that assert returns T if the fact is new, and NIL if
  the fact is already know. We will use this feature later.

(defun assert (fact)
  (cond ((member fact *database*)
	 nil)
	('else
	 (push fact *database*)
	 t)))

* assert some facts.

(assert '(john is male))
(assert '(john has (son mike)))
(assert '(john is (age 55)))
(assert '(mike has (wife jill)))
(assert '(mike has (daughter ellen)))
(assert '(mike is (age 30)))

* implement a query system, to print out all facts in the
  database that match a pattern.

(defun query (pattern)
  (do ((facts *database* (cdr facts)))
      ((null facts))
    (let ((m (match pattern (car facts))))
      (cond ((not m))
	    ((eq m t)
	     (format t "~& ~S~%" (car facts)))
	    ('else
	     (format t "~& ~S~%" (car facts))
	     (dolist (var m)
	       (format t "  ~S = ~S~%" (variable-name var) (variable-value var))))))))

* we could then make the following queries:

(query '?)
 (MIKE IS (AGE 30))
 (MIKE HAS (DAUGHTER ELLEN))
 (MIKE HAS (WIFE JILL))
 (JOHN IS (AGE 55))
 (JOHN HAS (SON MIKE))
 (JOHN IS MALE)
NIL

(query '(john is ?))
 (JOHN IS (AGE 55))
 (JOHN IS MALE)
NIL

(query '(?person is ?something))
 (MIKE IS (AGE 30))
  SOMETHING = (AGE 30)
  PERSON = MIKE
 (JOHN IS (AGE 55))
  SOMETHING = (AGE 55)
  PERSON = JOHN
 (JOHN IS MALE)
  SOMETHING = MALE
  PERSON = JOHN
NIL

* Instead of a QUERY that prints out information we can have one that
  runs a function on every correct match.

(defun query-run (pattern f)
  (do ((facts *database* (cdr facts)))
      ((null facts))
    (let ((m (match pattern (car facts))))
      (cond ((not m))
	    ((eq m t)
	     (funcall f (car facts) nil))
	    ('else
	     (funcall f (car facts) m))))))

* then our old QUERY could be written

(defun query (pattern)
  (query-run pattern
	     #'(lambda (fact vars)
		 (format t "~& ~S~%" fact)
		 (dolist (var vars)
		   (format t "  ~S = ~S~%"
			   (variable-name var) (variable-value var))))))


* A production rule is a list of patterns that match facts
  which imply other facts. We would write a simple rule like
  so: (old-fact1 old-fact2 => new-fact)
 
* We want a function RUN-RULE-ONCE that will take a rule of this
  kind and try to match old facts in the database. If
  all the facts can be match then the new-facts are asserted
  into the database. If any new facts are asserted then we return
  T otherwise NIL.

(defun run-rule-once (rule)
  (run-rule-once-loop (collect-facts rule)
		      (collect-assertions rule)
		      nil))

(defun run-rule-once-loop (patterns assertions bindings)
  (cond ((null patterns)
	 (do ((l assertions (cdr l))
	      (flag nil))
	     ((null l)
	      flag)
	   (if (assert (substitute-vars bindings (car l)))
	       (setq flag t))))
	('else
	 (do ((facts *database* (cdr facts))
	      (pattern (car patterns))
	      (flag nil))
	     ((null facts)
	      flag)
	   (let ((m (match pattern (car facts))))
	     (cond ((not m))
		   ((eq m t)
		    (if (run-rule-once-loop (cdr patterns)
					    assertions
					    bindings)
			(setq flag t)))
		   ('else
		    (if (run-rule-once-loop (substitute-vars m (cdr patterns))
					    assertions
					    (append m bindings))
			(setq flag t)))))))))
    

(defun collect-facts (rule)
  (do ((facts nil (cons (car l) facts))
       (l rule (cdr l)))
      ((or (null l) (eq (car l) '=>))
       (reverse facts))))

(defun collect-assertions (rule)
  (cdr (memq '=> rule)))


(defun ?lookup (?name vars)
  (do ((l vars (cdr l)))
      ((null l)
	nil)
    (when (eq ?name (variable-?name (car l)))
      (return (car l)))))


(defun substitute-vars (l expression)
  (cond ((atom expression)
	 (cond ((symbolp expression)
		(let ((var (?lookup expression l)))
		  (cond (var
			 (variable-value var))
			('else
			 expression))))
	       ('else
		expression)))
	('else
	 (cons (substitute-vars l (car expression))
	       (substitute-vars l (cdr expression))))))

* Now, RUN-RULE will keep running a rule once until there
  or no new assertions. This is needed because a new assertion
  make cause the rule to want to run again.

(defun run-rule (x)
  (do ()
      ((not (run-rule-once x)))))


Lets start with our database and run a simple rule, tracing ASSERT.

(run-rule '( (?x has (wife ?y))
	    =>
	     (?y is female)
	     (?y has (husband ?x))
	     ))

(1 ENTER ASSERT: (JILL IS FEMALE))
(1 EXIT ASSERT: T)
(1 ENTER ASSERT: (JILL HAS (HUSBAND MIKE)))
(1 EXIT ASSERT: T)
(1 ENTER ASSERT: (JILL IS FEMALE))
(1 EXIT ASSERT: NIL)
(1 ENTER ASSERT: (JILL HAS (HUSBAND MIKE)))
(1 EXIT ASSERT: NIL)
NIL

Then lets run a rule that has two required facts, (technically
called anticedents) before being able to assert the implied facts,
(technically called concequents).

(run-rule '( (?x has (son ?y))
	     (?y has (daughter ?z))
            =>
	     (?x has (granddaughter ?z))
	     ))

(1 ENTER ASSERT: (JOHN HAS (GRANDDAUGHTER ELLEN)))
(1 EXIT ASSERT: T)
(1 ENTER ASSERT: (JOHN HAS (GRANDDAUGHTER ELLEN)))
(1 EXIT ASSERT: NIL)

* Now we can run queries and get new facts implied by
  running the rules.

(query '(?person is ?something))
 (JILL IS FEMALE)
  SOMETHING = FEMALE
  PERSON = JILL
 (MIKE IS (AGE 30))
  SOMETHING = (AGE 30)
  PERSON = MIKE
 (JOHN IS (AGE 55))
  SOMETHING = (AGE 55)
  PERSON = JOHN
 (JOHN IS MALE)
  SOMETHING = MALE
  PERSON = JOHN

(query '(? has ?))
 (JOHN HAS (GRANDDAUGHTER ELLEN))
 (JILL HAS (HUSBAND MIKE))
 (MIKE HAS (DAUGHTER ELLEN))
 (MIKE HAS (WIFE JILL))
 (JOHN HAS (SON MIKE))