; XEmacs: This file contains -*-Scheme-*- source code.

;;; Unification

;;; John David Stone
;;; Department of Mathematics and Computer Science
;;; Grinnell College
;;; stone@cs.grinnell.edu

;;; created November 29, 1999
;;; last revised November 29, 2000

;;; We define a pattern, generally and abstractly, as either
;;;
;;;     (1) a literal constant,
;;;     (2) a variable, or
;;;     (3) a list of zero or more patterns.

(define (pattern? something)
  (or (literal-constant? something)
      (variable? something)
      (and (list? something)
           (every? pattern? something))))

;;; The purpose of the unification algorithm is to determine, given two
;;; patterns, whether they can be made to match by consistently replacing
;;; the variables they contain with other patterns.  If the patterns cannot
;;; be unified in this way, there is no more to be said; if, however, a
;;; uniform replacement of variables throughout both patterns can result in
;;; a match, the unification algorithm constructs and returns a ``unifier''
;;; -- a table in which the keys are variables and the corresponding data
;;; are the patterns that should replace them.

;;; More specifically, we wish to construct a ``most general unifier,'' a
;;; replacement table containing as few keys as possible and data of the
;;; simplest and most general structure possible.

;;; In this implementation, we use natural numbers to represent literal
;;; constants and symbols to represent variables.

(define literal-constant? natural-number?)

(define variable? symbol?)

;;; The UNIFY procedure provides the external interface to the unification
;;; algorithm.  It takes the two patterns to be unified as arguments and
;;; returns their most general unifier; if the patterns cannot be unified
;;; at all, it raises an exception.

;;; The real work of unification begins inside the call to UNIFY-PATTERNS
;;; procedure.  UNIFY provides it initially with a null unifier, to which
;;; variables and their replacements will be added when the need for those
;;; replacements is detected.

(define (unify left right)
  (handle-exceptions signal-value (signal unify)
    (unify-patterns left right (null-table))))

;;; UNIFY-PATTERNS compares two given patterns, applying the variable
;;; replacements already recorded in a given unifier, and tries to unify
;;; them.

(define (unify-patterns left right unifier)

  ;; Patterns that are identical match without requiring any additional
  ;; variable replacements.

  (if (pattern=? left right)
      unifier

      ;; If either pattern is a variable, invoke UNIFY-VARIABLE to
      ;; determine whether it is acceptable to replace it with the other
      ;; pattern.

      (if (variable? left)
          (handle-exceptions signal-value (signal unify-patterns)
            (unify-variable left right unifier))
          (if (variable? right)
              (handle-exceptions signal-value (signal unify-patterns)
                (unify-variable right left unifier))

              ;; At this point, we know that the patterns are not identical
              ;; and that neither of them is a variable.  So if either of
              ;; them is a literal constant, unification fails -- a literal
              ;; constant cannot match any list or any other literal
              ;; constant.

              (if (or (literal-constant? left)
                      (literal-constant? right))
                  (signal unify-patterns)

                  ;; At this point, we know that both patterns are lists.
                  ;; Invoke UNIFY-LISTS to determine whether corresponding
                  ;; elements can be unified.

                  (handle-exceptions signal-value (signal unify-patterns)
                    (unify-lists left right unifier)))))))

;;; Two patterns count as equal, for purposes of this algorithm, if they
;;; are the same literal constant, if they are the same variable, or if
;;; they are both lists of the same length with equal patterns in
;;; corresponding positions.

(define (pattern=? left right)
  (or (and (literal-constant? left)
           (literal-constant? right)
           (identical? left right))
      (and (variable? left)
           (variable? right)
           (identical? left right))
      (and (list? left)
           (list? right)
           (= (length left) (length right))
           (every? pattern=? left right))))

;;; SUCCESS-TABLE-GET, like TABLE-GET, takes two arguments, a table and a
;;; value to be used as a key.  If there is no entry in the table with the
;;; specified key, SUCCESS-TABLE-GET returns #F; if there is such an entry,
;;; SUCCESS-TABLE-GET returns #T as its first value and the corresponding
;;; datum as its second.

(define (success-table-get tabula tag)
  (handle-exceptions signal-value #f
    (values #t (table-get tabula tag))))

;;; The UNIFY-VARIABLE procedure first determines whether a given variable
;;; VAR is already known (in UNIFIER) to require a replacement.  If so,
;;; that existing replacement must unify with the new proposed replacement,
;;; and any further replacements required in that unification process must
;;; be added to the most general unifier that is returned.  If VAR is not
;;; already a key in UNIFIER, then (a) if the replacement is a variable, it
;;; too must be looked up in UNIFIER -- if it is found, then its
;;; replacement in turn must be unified with VAR; if not, the fact that VAR
;;; can be replaced with the new variable is simply recorded in the
;;; variable that is returned.  On the other hand, if (b) the replacement
;;; is not a variable, then the unification succeeds if the variable does
;;; not already occur anywhere inside the replacement, but fails if the
;;; variable does occur in there (since the whole cannot match the part).

(define (unify-variable var replacement unifier)
  (receive var-match (success-table-get unifier var)
    (if (first var-match)
        (handle-exceptions signal-value (signal unify-variable)
          (unify-patterns (first (rest var-match)) replacement unifier))
        (if (variable? replacement)
            (receive replacement-match
                     (success-table-get unifier replacement)
              (if (first replacement-match)
                  (handle-exceptions signal-value (signal unify-variable)
                    (unify-patterns var
                                    (first (rest replacement-match))
                                    unifier))
                  (table-put unifier var replacement)))
            (if (occurs-in-binding? var replacement unifier)
                (signal unify-variable)
                (table-put unifier var replacement))))))

;;; OCCURS-IN-BINDING? determines whether a given variable occurs as a
;;; proper part of its proposed replacement.

(define (occurs-in-binding? var replacement unifier)
  (if (literal-constant? replacement)
      #f
      (if (variable? replacement)
          (or (identical? var replacement)
              (handle-exceptions signal-value #f
                (occurs-in-binding? var
                                    (table-get unifier replacement)
                                    unifier)))
          (if (list? replacement)
              (any? (lambda (subpattern)
                      (occurs-in-binding? var subpattern unifier))
                    replacement)
              #f))))

;;; UNIFY-LISTS determines whether two lists can be unified by comparing
;;; corresponding elements, taking variable replacements required by one
;;; such comparison into account when comparing subsequent elements.  Lists
;;; of different lengths cannot be unified.

(define (unify-lists left right unifier)
  (if (and (null-list? left) (null-list? right))
      unifier
      (if (or (null-list? left) (null-list? right))
          (signal unify-lists)
          (unify-lists (rest left)
                       (rest right)
                       (handle-exceptions signal-value (signal unify-lists)
                         (unify-patterns (first left)
                                         (first right)
                                         unifier))))))