;;;;;;;;;;;;;;;;;;;;;;;;;;;;; match.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for matching, comparing, and testing structures.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 , The Regents of the University of California.
; Authors: Joseph Faletti and Michael Deering.
; Unification added by David Chin.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions which accomplish unification of two variables.
; Turns on unification (irrevocably).
; sets all variables in the var list of the equiv class (first arg) which are
; still bound to the equiv class to the new value (second arg).
(defmacro setequivclass (equiv value)
(cond ((dtpr var) ; a local var cell
; If bound to equiv class, then save the old value
; and set the var to value.
(and (eq (cdr var) ,equiv)
(push (cons var (cdr var)) *equivsavestack*)
( t ; otherwise a global var.
(and (eq (eval var) ,equiv)
(push (cons var (eval var)) *equivsavestack*)
; unifies two unbound variables (0, one or both may already be equiv classes).
'(progn (setq xval (cond ((dtpr xvar) (cdr xvar))
(setq yval (cond ((dtpr yvar) (cdr yvar))
; Same variable, so leave xvar and yvar alone.
; Both values are unbound so create a new equiv class.
((and (eq xval (punbound))
(setq newval (cons (equivclass) (list xvar yvar))))
; Same equiv class (not "unbound"), so leave xvar & yvar alone.
; Both are equiv classes, so merge into a new equiv class.
(cond ((<& (length (cdr xval))
(append (cdr xval) (cdr yval)))
( t (append (cdr yval) (cdr xval))))))
; And change the equiv class for the other vars in the list.
(setequivclass xval newval)
(setequivclass yval newval))
((punboundatomp xval) ; xvar is not an equiv class.
(cond ((memq xvar (cdr yval)) ; but used to be in yvar's.
( t ; else build a new equiv class with yvar added.
(setq newval (cons (equivclass)
(setequivclass yval newval))))
( t ; otherwise yvar is not an equiv class.
(cond ((memq yvar (cdr xval)) ; but used to be in xvar's.
( t ; else build a new equiv class with xvar added.
(setq newval (cons (equivclass)
(setequivclass xval newval)))))
; Set the variables to a new equiv class created above.
; Save the old values in case match fails
(push (cons xvar xval) *equivsavestack*)
(push (cons yvar yval) *equivsavestack*)
; And set variables (either local or global).
(cond ((dtpr xvar) (rplacd xvar newval))
(cond ((dtpr yvar) (rplacd yvar newval))
( t (set yvar newval)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Low level macros for matching.
; Fast macro for minimum of two lengths.
; Unbind all vars on the item's assoc list
(defmacro unbindvars (item)
`(mapc (funl (cell) (rplacd cell (punbound))) (getalist ,item)))
; Set the GLOBAL or VAR variable to the value.
(defmacro varset (var val)
(setq savevarval (cdr localvar))
(rplacd localvar localval))
( t (push localvar *globalsavestack*)
(setq savevarval (eval localvar))
(set localvar localval)))
(setequivclass savevarval localval))))
; Set the GLOBAL or VAR adjunct variable to the value.
(defmacro adjvarset (var val)
(progn (cond ((dtpr localvar)
(setq savevarval (cdr localvar))
(rplacd localvar localval))
( t (push localvar *globalsavestack*)
(setq savevarval (eval localvar))
(set localvar localval)))
(setequivclass savevarval localval))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Macros for matching individual values.
; Check whether VAL is consistent with the predicates in PREDLIST.
(defmacro consistentvalue (val predlist type item defblock)
(cond ((null ,predlist) (return t)) ; all predicates were true.
; Otherwise, execute the next one.
((cond ((reallitatom (setq restriction (pop ,predlist)))
; The name of a function to be applied.
(apply* restriction (ncons ,val)))
; An s-expression predicate -- fill in and execute.
(eval (fillin1 restriction ,val ,item ,defblock)))
(0 (or (let ((def (getdefinition ,val)))
(disguisedas ,val restriction)))
(1 (disguisedas ,val restriction))
(2 (\=& restriction ,val))
(3 (eq restriction ,val))
; A better way needed ?? Never done????
(eq restriction (car ,val))))))
; Otherwise this predicate failed, so we fail.
; Check two values for "equality".
(defmacro equalvalue (xval yval type)
(0 (basicmatch ,xval ,yval))
; A better way needed!!!!!!!!!!!!!!!!!!! something like:
; (mapcar (function equalvalue) ,xval ,yval (strip ,type)))
; Check to see if two slots whose number is passed are matchable,
; binding any variables and running any predicates.
; Assumes slotnum, item1, item2, def1, def2 already set and others declared
; in main PROG. The local PROG is necessary for slothooks processing.
; *val and *var are both set by these calls.
; *var are set to nil if no local, global, or adjunct variable.
(setq xval (getvarandvalue slotnum item1 'xvar))
(setq yval (getvarandvalue slotnum item2 'yvar))
(and (or (eq xvar *any*conscell*)
(eq yvar *any*conscell*))
; If both are unbound, return *matchunboundsresult* (initially nil).
(setq xvalunbound (punboundatomp xval))
(setq yvalunbound (punboundatomp yval))
(setq bothunbound (and xvalunbound yvalunbound))
(return *matchunboundsresult*)))
; Get the slots' common type and individual predicates.
(setq slottype (getslottype slotnum def1))
(setq xpredlist (getpred slotnum item1))
(setq ypredlist (getpred slotnum item2))
(doslothooks2< '<match *runmatchhooks*)
; Otherwise we check to see if one of the slots can be
(cond (bothunbound ; Two unbound variables to be unified.
(xvalunbound ; Match x's variable against y's value.
(consistentvalue yval xpredlist slottype item2 def2))
(yvalunbound ; Match y's variable against x's value.
(consistentvalue xval ypredlist slottype item1 def1))
( t ; both are bound values -- check "equality".
(and (setq result (equalvalue xval yval slottype))
; and set the adjunct variables (if any)
(progn (adjvarset xvar yval)
(adjvarset yvar xval)))))
(doslothooks2> '>match *runmatchhooks*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Principle match functions.
; Match two structures slot by slot, WITHOUT unbinding variables first,
; but binding along the way.
(de basicmatch (item1 item2)
(prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
xvalunbound yvalunbound length
newxval newyval xpredlist ypredlist xhooks yhooks
(setq def1 (getdefinition item1))
(setq def2 (getdefinition item2))
(setq length (getstructlength def1))
(dobasehooks2< '<match *runmatchhooks*)
(cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
; Not even related -> nil.
((not (eq def1 def2)) (setq result nil))
((\=& 0 length) (setq result t))
; Otherwise, compare slot by slot.
(dobasehooks2> '>match *runmatchhooks*)
; Match two structures slot by slot, unbinding variables first.
(de standardmatch (item1 item2)
(prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
xvalunbound yvalunbound length *globalsavestack*
newxval newyval xpredlist ypredlist xhooks yhooks
newval bothunbound *equivsavestack*)
(setq def1 (getdefinition item1))
(setq def2 (getdefinition item2))
(setq length (getstructlength def1))
(dobasehooks2< '<match *runmatchhooks*)
(cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
; Not even related -> nil.
((not (eq def1 def2)) (setq result nil))
((\=& 0 length) (setq result t))
; Otherwise, compare slot by slot.
(dobasehooks2> '>match *runmatchhooks*)
; Clean up the variables because of the failure.
(progn (unbindvars item1)
; *equivsavestack* is only non-nil when *unifyunbounds* is t.
(rplacd (car pair) (cdr pair)))
( t (set (car pair) (cdr pair)))))
(aliasdef 'match 'standardmatch)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions similar to above but for expanded structures.
; Check to see either defblock is an expansion of the other.
(defmacro relatedhier (defblock1 defblock2)
`(or (eq ,defblock1 ,defblock2)
(memq ,defblock2 (getexpansionlist ,defblock1))
(memq ,defblock1 (getexpansionlist ,defblock2))))
; Check whether VAL is consistent with the predicates in PREDLIST.
(defmacro expconsistentvalue (val predlist type item defblock)
(cond ((null ,predlist) (return t)) ; all predicates were true.
; Otherwise, execute the next one.
((cond ((reallitatom (setq restriction (pop ,predlist)))
; The name of a function to be applied.
(apply* restriction (ncons ,val)))
; An s-expression predicate -- fill in and execute.
(eval (fillin1 restriction ,val ,item ,defblock)))
(0 (or (let ((def (getdefinition ,val)))
(relatedhier restriction def))
(disguisedas ,val restriction)))
(1 (disguisedas ,val restriction))
(2 (\=& restriction ,val))
(3 (eq restriction ,val))
; A better way needed ?? Never done????
(eq restriction (car ,val))))))
; Otherwise this predicate failed, so we fail.
; Check two values for "equality".
(defmacro expequalvalue (xval yval type)
(0 (basicexpandedmatch ,xval ,yval))
; A better way needed!!!!!!!!!!!!!!!!!!! something like:
; (mapcar (function expequalvalue) ,xval ,yval (strip ,type)))
; Check to see if two slots whose number is passed are matchable,
; binding any variables and running any predicates.
; Assumes slotnum, item1, item2, def1, def2 already set and others declared
; in main PROG. The local PROG is necessary for slothooks processing.
; *val and *var are both set by these calls.
; *var are set to nil if no local, global, or adjunct variable.
(setq xval (getvarandvalue slotnum item1 'xvar))
(setq yval (getvarandvalue slotnum item2 'yvar))
(and (or (eq xvar *any*conscell*)
(eq yvar *any*conscell*))
; If both are unbound, return *matchunboundsresult* (initially nil).
(setq xvalunbound (punboundatomp xval))
(setq yvalunbound (punboundatomp yval))
(setq bothunbound (and xvalunbound yvalunbound))
(return *matchunboundsresult*)))
; Get the slots' common type and individual predicates.
(setq slottype (getslottype slotnum def1))
(setq xpredlist (getpred slotnum item1))
(setq ypredlist (getpred slotnum item2))
(doslothooks2< '<match *runmatchhooks*)
; Otherwise we check to see if one of the slots can be
(cond (bothunbound ; Two unbound variables to be unified.
(xvalunbound ; Match x's variable against y's value.
(expconsistentvalue yval xpredlist slottype
(yvalunbound ; Match y's variable against x's value.
(expconsistentvalue xval ypredlist slottype
( t ; both are bound values -- check "equality".
(and (setq result (expequalvalue xval yval slottype))
; and set the adjunct variables (if any)
(progn (adjvarset xvar yval)
(adjvarset yvar xval)))))
(doslothooks2> '>match *runmatchhooks*)
; Match two structures slot by slot, WITHOUT unbinding variables first,
; but binding along the way.
(de basicexpandedmatch (item1 item2)
(prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
xvalunbound yvalunbound length
newxval newyval xpredlist ypredlist xhooks yhooks
(setq def1 (getdefinition item1))
(setq def2 (getdefinition item2))
(setq length (min& (getstructlength def1)
(dobasehooks2< '<match *runmatchhooks*)
(cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
; Not even related hierarchically -> nil.
((not (relatedhier def1 def2)) (setq result nil))
((\=& 0 length) (setq result t))
; Otherwise, compare slot by slot.
(dobasehooks2> '>match *runmatchhooks*)
; Match two structures slot by slot, unbinding variables first.
(de standardexpandedmatch (item1 item2)
(prog (newitem1 newitem2 result slottype xvar yvar xval yval def1 def2
xvalunbound yvalunbound length *globalsavestack*
newxval newyval xpredlist ypredlist xhooks yhooks
newval bothunbound *equivsavestack*)
(setq def1 (getdefinition item1))
(setq def2 (getdefinition item2))
(setq length (min& (getstructlength def1)
(dobasehooks2< '<match *runmatchhooks*)
(cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
; Not even related hierarchically -> nil.
((not (relatedhier def1 def2)) (setq result nil))
((\=& 0 length) (setq result t))
; Otherwise, compare slot by slot.
(dobasehooks2> '>match *runmatchhooks*)
; Clean up the variables because of the failure.
(progn (unbindvars item1)
; *equivsavestack is only non-nil when *unifyunbounds* is t.
(rplacd (car var) (cdr var)))
( t (set (car var) (cdr var)))))
(aliasdef 'expandedmatch 'standardexpandedmatch)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for testing for equality and other comparisons.
; Check to see if two slots passed (with a type number) are EQUAL,
; NOT binding any variables OR checking any predicates.
; *val and *var are both set by these calls.
; *var are set to nil if no local, global, or adjunct variable.
(setq xval (getvarandvalue slotnum item1 'xvar))
(setq yval (getvarandvalue slotnum item2 'yvar))
; If the slot of the first ITEM is unbound, fail
(and (punboundatomp xval)
(progn (msg t "Unbound variables not allowed in STREQUAL" t)
; If the slot of the second ITEM is unbound, fail
(and (punboundatomp yval)
(progn (msg t "Unbound variables not allowed in STREQUAL" t)
; Get the slots' common type.
(setq slottype (getslottype slotnum def1))
(doslothooks2< '<strequal *runstrequalhooks*)
; A better way needed!!!!!!!!!!!!!!!!!!!
(doslothooks2> '>strequal *runstrequalhooks*)
; Test two structures for "EQUAL"ity slot by slot, without unbinding
; variables first, and NOT binding along the way.
(de strequal (item1 item2)
(prog (newitem1 newitem2 result slottype xvar yvar xval yval
def1 def2 length newxval newyval xhooks yhooks)
(setq def1 (getdefinition item1))
(setq def2 (getdefinition item2))
(setq length (getstructlength def1))
(dobasehooks2< '<strequal *runmatchhooks*)
(cond ((eq item1 item2) (setq result t)) ; Same structure -> t.
; Not even same type -> nil.
((neq def1 def2) (setq result nil))
((\=& 0 length) (setq result t))
; Otherwise, compare slot by slot.
(dobasehooks2> '>strequal *runmatchhooks*)
; Check to see if ITEM1 is an expansion of ITEM2.
(de isanexpanded (item1 item2)
(let ((defblock1 (getdefinition item1))
(defblock2 (getdefinition item2)))
(or (eq defblock1 defblock2)
(memq defblock1 (getexpansionlist defblock2)))))
; Check to see if ITEM1 is (an expansion of) the base with name NAME.
(let ((defblock (getdefinition item1))
(typedef (eval (defatom name))))
(or (eq defblock typedef)
(memq defblock (getexpansionlist typedef)))))
; Test item to see if it's a nilstruct.
(eval (defatom 'nilstruct))))
; Test item to see if it's a nilsym.
(eval (symatom 'nilsym))))
((match item (car list)) list)
( t (memmatch item (cdr list)))))
(de memstrequal (item list)
((strequal item (car list)) list)
( t (memstrequal item (cdr list)))))