'("$Id: match.lsp.txt,v 1.1.1.1 1997/05/04 18:48:00 # rurban Exp $")

;;;* MATCH.LSP

;;; Based on Winston/Horn 24matchi.lsp from "Lisp"

;;;; This software is licensed by Patrick H. Winston and Berthold K. P. Horn

;;;; (licensors) for instructional use with the textbooks ``Lisp,'' by Patrick

;;;; H. Winston and Berthold K. P. Horn, and ``Artificial Intelligence,'' by

;;;; Patrick H. Winston.  Your are free to make copies of this software and

;;;; modify it for such instructional use as long as:

;;;; 1. You keep this notice intact.

;;;; 2. You cause any modified files to carry a prominent notice stating

;;;;    that you modified the files and the date of your modifications.

;;;; This software is licensed ``AS IS'' without warranty and the licensor

;;;; shall have no liability for any alleged defect or damages.

;;;; ----------------------------------------------------------------------

;;;; Converted April 1997 by Reini URBAN to AutoLisp. 

;;;;  <rurban@xarch.tu-graz.ac.a> http://xarch.tu-graz.ac.at/autocad/lisp/match.lsp

;;;;

;;;; Also changed the behaviour to return dotted association lists instead of

;;;; plain lists. Just a matter of taste :)

;;;; Highly recommended to read the book to understand its strength.

;;;; ----------------------------------------------------------------------



;;; (MATCH  pattern expr)	- CL matching (=> Winston/Horn "Lisp")

;;; returns FAIL if no match,

;;; Samples:

;|

(match  '(color (? x) red)

        '(color apple red))

   => ((X . apple))

(match  '(color (? x) (? y))

	'(color apple red))

   => ((X . apple)(Y . red))

(match 	'(((? p) is-a person) with (hair (? h)))

	'((patrick is-a person) with (hair blond)))

  => ((H . BLOND) (P . PATRICK)) 

|;



;;; helper funcs

(defun add-binding (pattern-variable-expression datum bindings)

 (if (eq '\_ (extract-variable pattern-variable-expression))

     bindings

     (cons (make-binding

             (extract-variable pattern-variable-expression)

             datum)

           bindings)))



(defun extract-variable (pattern-variable-expression)

  (cadr pattern-variable-expression))



(defun make-binding (variable datum)

  (cons variable datum))	;was: (list) but I prefer dotted lists



(defun find-binding (pattern-variable-expression binding)

  (if (not (eq '\_ (extract-variable pattern-variable-expression)))

    (assoc (extract-variable pattern-variable-expression) binding)))



(defun extract-key (binding)

  (car binding))



(defun extract-value (binding)

  (cdr binding))	;was: cadr



(defun match-atoms (p d bindings)

  ;;See if \sy{P} and \sy{D} are the same:

  (if (equal p d)	;was: eql

      ;;If so, return the value of BINDINGS:

      bindings

      ;;Otherwise, return FAIL.

      'fail))



(defun match-variable (p d bindings / binding)

  (setq binding (find-binding p bindings))

  ;;See if the pattern variable is known:

  (if binding 

        ;;If it is, substitute its value and try again:

        (match-hlp (extract-value binding) d bindings)      

        ;;Otherwise, add new binding:

        (add-binding p d bindings)))



(defun match-pieces (p d bindings / result)

  (setq result (match-hlp (car p) (car d) bindings))

  ;;See if the car parts match producing new bindings:

  (if (eq 'fail result)

    ;;If they do not match, fail.

    'fail

    ;;If they do match, try the rest parts using the resulting bindings:

    (match-hlp (cdr p) (cdr d) result)))



(defun elements-p (p d) 

  (and (atom p) (atom d)))



(defun variable-p (p)

  (and (listp p) (eq '? (car p))))



(defun recursive-p (p d)

  (and (listp p) (listp d)))



;;; added as workaround for the lack of &optional

(defun match-hlp (p d bindings)

  (cond ((elements-p p d)  (match-atoms p d bindings))

        ((variable-p p)    (match-variable p d bindings))

        ((recursive-p p d) (match-pieces p d bindings))

        (t 'fail)))



;;; call this

(defun match (p d)

  (cond ((elements-p p d)  (match-atoms p d nil))

        ((variable-p p)    (match-variable p d nil))

        ((recursive-p p d) (match-pieces p d nil))

        (t 'fail)))