; The match function takes two lists as input, one representing an 
; "object", the other representing a "pattern", and returns true if 
; the pattern matches the object.
;
; An object is a list of atoms representing words.
;
; A pattern is a list of pattern elements.  Each pattern element 
; may match zero or more elements of the object list. Legal pattern 
; elements are the following.
;    * matches a sequence of zero or more elements in the object.
;    A positive integer k matches whatever was matched by the kth 
;        occurrence of * in the pattern (numbering starts at 1).
;    Any other atom matches itself in the object.
;
; Some examples:
;    pattern                   object                   result
;    (A B C)                   (A B C)                  match
;    (A B C)                   (Z A B C)                no match
;    (A B C)                   (A B C Z)                no match
;    (A B C *)                 (A B C)                  match
;    (A B C *)                 (A B C Z)                match
;    (A * C)                   (A C)                    match
;    (A * C)                   (A C B)                  no match
;    (A * C)                   (A B B C)                match
;    (A * C)                   (A B C C)                match
;    (A * C 1)                 (A B C B)                match
;    (A * C 1)                 (A C)                    match
;    (A * C 1)                 (A B C D)                no match
;    (A * C 1)                 (A C D)                  no match
;    (A * C 1)                 (A B C)                  no match
;    (A * C 1)                 (A B C C B C)            match
;    (A * C 1 1)               (A B C B)                no match
;    (A * C 1 1)               (A B C B B)              match
;    (A * C * B 1 2)           (A B C X B B X)          match

(define (match pattern object)
  (match-with-*-list pattern object '( )) )

(define (match-with-*-list pattern object *-list)
  (cond
   ((null? pattern) (null? object))
   ((prev-ref? (car pattern))
    (match-with-*-list
     (append (matched-value (car pattern) *-list) (cdr pattern))
     object *-list ) )
   ((null? object)
    (and (arb-sequence? (car pattern))
         (match-with-*-list (cdr pattern) object 
                            (add-*-entry *-list '( )) ) ) )
   ((arb-sequence? (car pattern))
    (or
     (match-with-*-list (cdr pattern) object (add-*-entry *-list '( )))
     (extend-match pattern (cdr object)
       (add-*-entry *-list (car object)) ) ) )
   ((object-symbol? (car pattern))
    (and (equal? (car pattern) (car object))
         (match-with-*-list (cdr pattern) (cdr object) *-list) ) )
   (else 'INVALID-PATTERN ) ) )

(define (extend-match pattern object *-list)
  (cond
   ((match-with-*-list (cdr pattern) object *-list))
   ((null? object) #f)
   (else (extend-match pattern (cdr object)
                     (extend-*-entry *-list (car object)) )) ) )

; Functions that check for various pattern elements.

(define (arb-sequence? pattern-elem)
  (equal? pattern-elem '*) )

(define (object-symbol? pattern-elem)
  (and (atom? pattern-elem)
       (not (arb-sequence? pattern-elem))
       (not (prev-ref? pattern-elem)) ) )

(define (prev-ref? pattern-elem)
  (number? pattern-elem) )

; Functions that add, extend, and access a value matched by a *.

(define (add-*-entry *-list item)
  (if (null? item) (cons item *-list)
      (cons (list item) *-list) ) )

(define (extend-*-entry *-list item)
  (cons (append (car *-list) (list item)) (cdr *-list)) )

(define (matched-value n *-list)
  (list-ref (reverse *-list) (- n 1)) )