;;; -*- LISP -*-
;;; PATTERN: A Library of Pattern Matching Routines

;;; MATCH
;;;  This function allows the following syntax
;;;
;;;	(MATCH <Pattern> <Thing>)
;;;
;;;  Returns T iff <Thing> is of the form specified by <Pattern>
;;;
;;;  <Pattern> is a list with the description...
;;;
;;;	( <Specifier> <Specifier> ...) 
;;;
;;;  <Specifier> is one of the following forms:
;;;
;;;     <atom>			Matches an atom that is EQ to it
;;;
;;;     (?)			Matches any single S-Expression
;;;
;;;     (? <tag>) 		Matches any single S-Expression and assigns
;;;				 to tag the value of the thing matched
;;;
;;;	(?= <pred>)		Matches any single S-Expression for which 
;;;				 <pred> is true
;;;
;;;	(?= <pred> <tag>)	Matches any single S-Expression for which 
;;;				 <pred> is true, assigns matched thing to <tag>
;;;
;;;	($)			Matches a single S-Expression or none.
;;;
;;;	($ <tag>)		Matches a single S-Expression or none,
;;;				 assigning matched item to <tag>.
;;;
;;;	($= <pred>)		Matches a single S-Expression if it makes 
;;;				 <pred> true, or none.
;;;
;;;	($= <pred> <tag>)	Matches a single S-Expression if it makes
;;;				 <pred> true, or none, assigns thing
;;;                              matched to <tag>
;;;
;;;     (*)			Matches any series of S-Expressions.
;;;
;;;	(* <tag>)		Matches any series of S-Expressions, assigning
;;;				 to <tag> a list of the matched things.
;;;
;;;	(*= <pred>)		Matches any series of things that return true
;;;				 for <pred>
;;;
;;;	(*= <pred> <tag>)	Matches any series of things that return true
;;;				 for <pred>; <tag> gets list of things matched
;;;
;;;  <Thing> is a list
;;;

;;; MATCH
;;;  This function looks at all constant terms in a pattern, and makes
;;;  sure they at least occur in the same order in item being tested.
;;;  If they don't, the match fails. If they do, the normal (hairy) 
;;;  matching scheme is attempted.

(DEFUN MATCH (PP XX)
       (DO ((P PP (CDR P))
	    (X XX))
	   ((NULL P) (MATCH1 PP XX))
	   (COND ((ATOM (CAR P))
		  (SETQ X (MEMQ (CAR P) X))
		  (COND ((NULL X) (RETURN NIL)))))))

;;; Macros needed for making my code size below a bit more compressed

 ;; (TAILSTRIP <expression>)
 ;;  removes the last element of a list.
 ;;  Equivalent to (DEFUN TAILSTRIP (X) (NREVERSE (CDR (REVERSE X))))
 ;;  but a slight bit faster.

(DEFUN TAILSTRIP (X)
       ((LAMBDA (R)
		(DO ((X X (CDR X))
		     (L (SETQ R (NCONS ())) (CDR L)))
		    ((NULL (CDR X)) (CDR R))
		    (RPLACD L (NCONS (CAR X)))))
	NIL))

 ;; (POP* <var1> <var2> ...)
 ;; Same as (PROGN (POP <var1>) (POP <var2>) ...)

(DEFUN POP* MACRO (X)
	`(PROGN ,@(MAPCAR (FUNCTION (LAMBDA (X) `(SETQ ,X (CDR ,X))))
			  (CDR X))))

;;; MATCH1
;;;  This is the real brains behind the matcher. It is called only from
;;;  MATCH, however, which does some preprocessing.

(DEFUN MATCH1 (P X)
       (DO ((PATTERN)
	    (FUNCTION-VALUE)
	    (STARFLAG))
	   ((NULL P) (NULL X))
	   (COND ((ATOM (CAR P))		; Atom must match exactly
		  (COND ((NULL X) (RETURN NIL))); This can't match a null list
		  (COND ((EQ (CAR P) (CAR X))   ; If matched...
			 (POP* P X)		;    Pop pattern & test list
			 (SETQ STARFLAG NIL))   ; Terminate * search
			(T			; Else (no atomic match)
			 (RETURN NIL))))	;    Match failed
		 ((EQ (CAAR P) '?)		; ? may match any single thing
		  (COND ((NULL X) (RETURN NIL))); This can't match a null list
		  (COND ((CDAR P)		; Maybe assign match to a var
			 (SET (CADAR P) (CAR X))))
		  (POP* P X)			; Pop pattern & test list
		  (SETQ STARFLAG NIL))		; Terminate * search
		 ((EQ (CAAR P) '?=)		; Match w/ predication
		  (COND ((NULL X) (RETURN NIL))); This can't match a null list
		  (COND ((NOT (FUNCALL (CADAR P) (CAR X))) ; Try predicate
			 (RETURN NIL)))		; Fail if predicate loses
		  (COND ((CDDAR P)		; Maybe assign match to a var
			 (SET (CADDAR P) (CAR X))))
		  (POP* P X)			; Pop pattern & test list
		  (SETQ STARFLAG NIL))		; Terminate * search
		 (T
		  (SETQ PATTERN (CAR (LAST P)))	; Work on last elements for
						; a while...
		  (COND ((ATOM PATTERN)		; If last element is an atom
			 (COND ((NULL X)	; This can't match a null list
				(RETURN NIL)))
			 (COND ((NOT (EQ (CAR (LAST X)) PATTERN))
				(RETURN NIL)))	; Fail if doesn't match
			 (SETQ P (TAILSTRIP P)) ; Pop last element of pattern
			 (SETQ X (TAILSTRIP X)) ; Pop last element of test list
			 (SETQ STARFLAG NIL))	; Terminate * search
			((EQ (CAR PATTERN) '?)	; Last element of ? matches!
			 (COND ((NULL X)	; This can't match a null list
				(RETURN NIL)))
			 (COND ((CDR PATTERN)	; Maybe assign match to a var
				(SET (CADR PATTERN) (CAR (LAST X)))))
			 (SETQ P (TAILSTRIP P)) ; Pop last element of pattern
			 (SETQ X (TAILSTRIP X)) ; Pop last element of test list
			 (SETQ STARFLAG NIL))	; Terminate * search
			((EQ (CAR PATTERN) '?=) ; Predicated match last element
			 (COND ((NULL X)	; This can't match a null list
				(RETURN NIL)))
			 (COND ((NOT (FUNCALL (CADR PATTERN) (CAR (LAST X))))
				(RETURN NIL)))	; If pred fails, match fails
			 (COND ((CDDR PATTERN)  ; Maybe assign match to a var
				(SET (CADDR PATTERN) (CAR (LAST X)))))
			 (SETQ P (TAILSTRIP P)) ; Pop last element of pattern
			 (SETQ X (TAILSTRIP X))	; Pop last of element test list
			 (SETQ STARFLAG NIL))   ; Terminate * search
			((EQ (CAR (SETQ PATTERN (CAR P))) '$) 
						; $ can optionally match
			 (COND ((MATCH1 (CDR P) X) ; Test first ignoring $
				(COND ((CDR PATTERN) ; Maybe set a variable
				       (SET (CADR PATTERN) NIL))) ; to match
				(RETURN T)))    ; We won without it
			 (COND ((CDR PATTERN)	; Maybe set a variable to
				(SET (CADR PATTERN) (CAR X)))) ; thing matched
			 (POP* P X)		; Pop pattern and test list
			 (SETQ STARFLAG NIL))	; Terminate * search
			((EQ (CAR PATTERN) '$=)	; Match 1 or 0 with predication
			 (COND ((MATCH1 (CDR P) X) ; Try first without using $=
				(COND ((CDDR PATTERN) ; Maybe set variable to
				       (SET (CADDR PATTERN) NIL))) ; match
				(RETURN T)))	; We won
			 (COND ((NOT (FUNCALL (CADR PATTERN) (CAR X))) ; Apply
				(RETURN NIL)))	; predicate - if NIL then fail
			 (COND ((CDDR PATTERN)	; Maybe set variable to 
				(SET (CADDR PATTERN) (CAR X)))) ; thing matched
			 (POP* P X)		; Pop pattern and test list
			 (SETQ STARFLAG NIL))	; Terminate * search
			((EQ (CAR PATTERN) '*)	; * matches any sequence
			 (COND ((NULL X)	; If no more elements, 
				(RETURN         ;  make sure no pending 
				 (MATCH1 (CDR P) NIL))) ; patterns lose.
			       ((MATCH1 (CDR P) X) ; Else match first without *
				(COND ((AND (NOT STARFLAG)
					    (CDR PATTERN)) ;Maybe clear
				       (SET (CADR PATTERN) NIL))) ; variable
				(RETURN T)))     ; We won
			 (COND ((CDR PATTERN) ; If there's a var to set
				(COND (STARFLAG ; add element to end of var
				       (SET (CADR PATTERN) ; add to var's val
					    (NCONC (EVAL (CADR PATTERN))
						   (NCONS (CAR X)))))
				      (T	; if var not initialized
				       (SET (CADR PATTERN) ;set to (<match>)
					    (NCONS (CAR X)))))))
			 (POP* X)		; Pop test list
			 (SETQ STARFLAG T))	; Note * search in effect
			((EQ (CAR PATTERN) '*=) ; Match any predicated sequence
			 (COND ((NULL X)	; If no more test list
				(RETURN		; Insure no pending patterns
				 (MATCH1 (CDR P) NIL)))	; are violated
			       ((MATCH1 (CDR P) X)  ; Else try wihtout
				(COND ((AND (NOT STARFLAG) (CDDR PATTERN))
				       (SET (CADDR PATTERN) NIL)))
				(RETURN T)))
			 (SETQ FUNCTION-VALUE (FUNCALL (CADR PATTERN) (CAR X)))
			 (COND ((NOT FUNCTION-VALUE) (RETURN NIL)))
			 (COND ((CDDR PATTERN)
				(COND (STARFLAG
				       (SET (CADDR PATTERN)
					    (NCONC (EVAL (CADDR PATTERN))
						   (NCONS (CAR X)))))
				      (T
				       (SET (CADDR PATTERN)
					    (NCONS (CAR X)))))))
			 (SETQ X (CDR X))
			 (SETQ STARFLAG T))
			(T			; Unknown pattern form? 
			 (RETURN NIL)))))))	; Fail

(DEFUN MATCH-VAR-GET (X)
       (COND ((ATOM X) NIL)
	     ((MEMQ (CAR X) '(* ?)) (AND (CDR X) (LIST (CADR X) NIL)))
	     (T (AND (CDDR X) (LIST (CADDR X) NIL)))))

(DEFUN ELIMINATE-REDUNDANCIES (X)
       (DO ((L X (CDDR L))
	    (R NIL))
	   ((NULL L) (NREVERSE R))
	   (COND ((NOT (MEMQ (CAR L) R))
		  (SETQ R (CONS (CADR L) (CONS (CAR L) R)))))))

(DEFUN MATCH-VARS (L)
       (APPLY 'NCONC
	      (MAPCAR (FUNCTION (LAMBDA (P) (MAPCAN 'MATCH-VAR-GET P))) L)))
		      
;;; MATCHES
;;;  This is a convenience macro that takes the syntax:
;;;
;;;  (MATCHES <form> <pattern1> <pattern2> <pattern3> ... <patternM>)
;;;
;;;  <form> will be EVAL'ed
;;;  <pattern>'s will not be EVAL'd
;;;  
;;;  It will expand to the following:
;;;
;;;  (PROGN (SETQ <var1> NIL <var2> NIL <var3> NIL ... <varN> NIL)
;;;         (OR (MATCH '<pattern1> <form>)
;;;		(MATCH '<pattern2> <form>)
;;;		(MATCH '<pattern3> <form>)
;;;		...
;;;		(MATCH '<patternM> <form>)
;;;		(SETQ <var1> NIL <var2> NIL ... <varN> NIL)))
;;;
;;;  <var1> ... <varN> are the variables that may be set by the Matcher.
;;;  The are initialized to NIL and if the Matches fail, they are
;;;  re-initialized to NIL to avoid chance of getting garbage left over in
;;;  them.

(DEFUN (MATCHES MACRO) (X)
       (LET* (((OBJECT . PATTERNS) (CDR X))
	      (INITS (ELIMINATE-REDUNDANCIES (MATCH-VARS PATTERNS))))
	     (COND (INITS (PUSH 'SETQ INITS)))
	     (COND ((NULL PATTERNS) NIL)
		   ((> (LENGTH PATTERNS) 1.)
		    `(OR ,@(MAPCAN
			    (FUNCTION
			     (LAMBDA (X)
				     (COND (INITS
					    `(,INITS (MATCH ',X ,OBJECT)))
					   (T
					    `((MATCH ',X ,OBJECT))))))
			    PATTERNS)
			 ,@(COND (INITS (NCONS INITS)))))
		   (T
		    (COND (INITS
			   `(OR ,INITS
				(MATCH ',(CAR PATTERNS) ,OBJECT)
				,INITS))
			  (T
			   `(MATCH ',(CAR PATTERNS) ,OBJECT)))))))


;;; Note this package has loaded

(SSTATUS FEATURE PATTERN)