;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : match? ;;
;; Parameters : pat, exp, env ;;
;; Returns : the unifying environment, if matching succeeds ;;
;; Description : General matching function. Given a pattern with ;;
;; variables and an expression without variables, returns ;;
;; the matching environment or FAIL. ;;
;; Pattern can contain variables (start with ?), the wildcard;;
;; ? that represents a single atom, or ?? that can represent ;;
;; Any sequence of zero or more atoms. ;;
;; Different variables can have same value. ;;
;; Different occurrences of ? can have different values ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq fail 'fail)
(defun match (pat exp)
(match? pat exp nil))
(defun match? (pat exp env)
(cond
((and (null pat) (null exp))
env)
((and (null pat) (not (null exp)))
FAIL)
((and (not (null pat)) (null exp))
(cond
((variable? pat) (add-binding pat exp env))
((is-?? (car pat)) env)
(t FAIL)))
((and (listp pat) (not (listp exp))
(is-? (car pat)) (member exp (cdr pat)))
env)
((and (listp pat) (not (listp exp))
(variable? (car pat)) (member exp (cdr pat)))
(if (bound? (car pat) env)
(if (equal (get-binding (car pat) env) exp)
env
FAIL)
(add-binding (car pat) exp env)))
((and (listp pat) (is-?? (car pat)))
(if (null (cdr pat))
env
(match?? (cdr pat) exp env)))
((not (listp pat))
(cond
((is-? pat)
env)
((variable? pat)
(if (bound? pat env)
(if (equal (get-binding pat env) exp)
env
FAIL)
(add-binding pat exp env)))
(t
(if (equal pat exp)
env
FAIL))))
((not (listp exp)) FAIL)
(t (let ((carmatch (match? (car pat) (car exp) env)))
(if (eq carmatch FAIL)
FAIL
(match? (cdr pat) (cdr exp) carmatch))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : match?? ;;
;; Parameters : pat, exp, env ;;
;; Returns : the unifying environment, if matching succeeds ;;
;; Description : handle the case of ?? wildcard ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun match?? (pat exp env)
(cond
((null exp)
FAIL)
(t
(let ((temp-match (match? pat exp env)))
(if (not (fail? temp-match))
temp-match
(match?? pat (cdr exp) env))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : fail? ;;
;; Parameters : var ;;
;; Returns : true if var is equal to FAIL ;;
;; Description : ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fail? (var)
(eq var FAIL))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : is-? ;;
;; Parameters : pat ;;
;; Returns : true if pat is equal to '? ;;
;; Description : ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun is-? (pat)
(eq pat '?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : is-?? ;;
;; Parameters : pat ;;
;; Returns : true if pat is equal to '?? ;;
;; Description : ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun is-?? (pat)
(eq pat '??))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : variable? ;;
;; Parameters : exp ;;
;; Returns : true if exp is a variable ;;
;; Description : A variable is an atom whose name starts with "?" ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun variable? (exp)
(and (symbolp exp)
(eq (char (string exp) 0) #\?)))
(defun model-var? (exp)
(or (stringp exp)
(confluence-var? exp)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : bound? ;;
;; Parameters : var, env ;;
;; Returns : (var . value) ;;
;; Description : If var is bound in the environment, a pair is returned ;;
;; otherwise, nil is returned ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bound? (var env)
(assoc var env))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : add-binding ;;
;; Parameters : var, value, env ;;
;; Returns : new environment ;;
;; Description : the new pair (var . value) is added to the environment ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun add-binding (var value env)
(cons (cons var value) env))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function : get-binding ;;
;; Parameters : var, env ;;
;; Returns : var's value in environment ;;
;; Description : if var is bound in env, (var . value) is returned, ;;
;; otherwise, nil is returned ;;
;; Date : 12/22/95 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-binding (var env)
(cdr (assoc var env)))