#| Match.lisp

Clark Elliott 2019-04-23

Quick throw-away matching code for CSC594 Topics in AI course.

Pieces swiped from ARWM RETE Working Memory implementation, but without the RETE implementation.
This is just the match with variables algorithm.

Examples:

CL-USER(13): (match '(a) '(?X))
T
(((*VAR* X) A))

CL-USER(14): (match '(a ?X) '(?x a))
T
(((*VAR* X) A))

CL-USER(15): 
(match '(a ?x z) '(?x a ?y))
T
(((*VAR* Y) Z) ((*VAR* X) A))

CL-USER(16): 

(match '(?p (b ?z) ?z (b 4)) '(?x ?y 4 ?x))

(match '(B 3 (?y ?B)) '(?X 3 (?y ?X)))

(match '(B 3 (?y ?B)) '(?X 3 (y ?X)))

(match '(B 3 (Y B)) '(?X 3 (?x ?x)))

(match '(y 3 (?y x)) '(?X 3 (?y ?X)))

Some of these functions may not be necessary. This is throw-away utility code.

|#

#|

VARIABLE READ MACRO   BE CAREFUL!!

Translates ?x into (*var* x) for easy of writing statements.

This read macro is not in effect when in debug mode. This means that interactively loaded functions will
not be correctly interpreted regarding the variables when in a sub-error-level.

|#

(set-macro-character #\?
  #'(lambda(stream char)         
      (list '*var* (read stream t nil t))))


;;; General data structure:
;;;    a   (emotion ...)
;;;       b  ((static event match test) ((persistent match) ...))
;;;       c  (threshold or other numbers test)
;;;       d  ((intensity variable for emotion, calculation for intensity)
;;;           (other variable,  other calculation)...)

;;; General Algorithm:
;;; if match b's (with sigma substitution) then
;;;   if sigma(c) succeeds then
;;;      (1) create bindings for the (intensity type) variables to the values
;;;           returned by calling sigma(d) for each (d).
;;;      (2) replace intensity variables in (a) with values from bindings
;;;      (3) Create a new emotion instance for the specified emo.

;;; THE MATCHER FUNCTIONS:

;;; 2018-05-05: Return T or nil. When T then T/bindings are returned as multiple values, else just nil.
   
(defun match (pat1 pat2)
  (match-with-bindings pat1 pat2 nil))

(defun match-with-bindings (pat1 pat2 bb)
  (cond
    ((pattern-var-p pat1)
     (variable-match pat1 pat2 bb))
    ((pattern-var-p pat2)
     (variable-match pat2 pat1 bb))
    ((atom pat1)
     (when (eq pat1 pat2) (values t bb)))
    ((atom pat2) nil)
    (t
     (multiple-value-bind
	   (flag carbindings)
	 (match-with-bindings (car pat1) (car pat2) bb)
       (and flag
	    (match-with-bindings (cdr pat1) (cdr pat2) carbindings))))))
     
 
(defun variable-match (pattern-var item bb)
  (if (equal pattern-var item) (values t bb)      ; var/var
      (let ((var-binding (get-binding pattern-var bb)))
	(cond
	  ((is-binding pattern-var bb)
	   (match-with-bindings var-binding item bb))
	  ((not (contained-in pattern-var item bb))    ;; occurs check
	   (values t (add-binding pattern-var item bb)))))))
	 
(defun contained-in (pattern-var item bb)
  (cond
    ((atom item) nil)
    ((pattern-var-p item)
     (or (equal pattern-var item)
	 (contained-in pattern-var (get-binding item bb) bb)))
    (t
     (or (contained-in pattern-var (car item) bb)
	 (contained-in pattern-var (cdr item) bb)))))

;;; Example: CL-USER(38): (subst-vars '(a (*var* b)) '(((*var* b) 44)))
;;; (A 44)


(defun subst-vars (item bindings)
  (cond ((atom item) item)
	((pattern-var-p item)
	 (let ((binding (get-binding item bindings)))
	   ;(format t "bb / binding is>>: ~s ~S~%" bind binding)
	   (if (is-binding item bindings)
	       (subst-vars binding bindings)
	       item)))
	(t (cons (subst-vars (car item) bindings)
		 (subst-vars (cdr item) bindings)))))

(defun add-binding (pattern-var item bindings)
  (cons (list pattern-var item) bindings))

(defun add-whole-binding (bind-cell bindings)
  (cons bind-cell bindings))


;;; GET-BIINDING
;;;     Problem here. If variable is bound to nil, then we don't know
;;; if there is a binding or not. The above code has been altered to
;;; allow retrieval of "nil" from the variable bindings. IS-BINDING
;;; is used to discriminate between un-bound vabiables, and those
;;; bound to nil. The code seems to be running fine, but the WM code
;;; has not been checked yet. 7-13-91

(defun get-binding (pattern-var bindings)
  (cadr (assoc pattern-var bindings :test #'equal)))

;;; So...

(defun is-binding (pattern-var bindings)
  (assoc pattern-var bindings :test #'equal))


(defun pattern-var-p (item)      ; test is good enough unless foolish.
  (cond
    ((and
     (listp item)
     (equal (car item) '*var*)))))

;;; ACCESSOR FUNCTIONS FOR AR PRODUCTIONS: