; tree regular expression pattern matching
; by Jeff Bezanson

(define (unique lst)
  (if (null lst)
      ()
    (cons (car lst)
          (filter (lambda (x) (not (eq x (car lst))))
                  (unique (cdr lst))))))

; list of special pattern symbols that cannot be variable names
(define metasymbols '(_ ...))

; expression tree pattern matching
; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
; mapping variables to captured subexpressions, or #f if no match.
; when a match succeeds, __ is always bound to the whole matched expression.
;
; p is an expression in the following pattern language:
;
; _       match anything, not captured
; <func>  any scheme function; matches if (func expr) returns #t
; <var>   match anything and capture as <var>. future occurrences of <var> in the pattern
;         must match the same thing.
; (head <p1> <p2> etc)   match an s-expr with 'head' matched literally, and the rest of the
;                        subpatterns matched recursively.
; (-/ <ex>)  match <ex> literally
; (-^ <p>)   complement of pattern <p>
; (-- <var> <p>)  match <p> and capture as <var> if match succeeds
;
; regular match constructs:
; ...                 match any number of anything
; (-$ <p1> <p2> etc)  match any of subpatterns <p1>, <p2>, etc
; (-* <p>)            match any number of <p>
; (-? <p>)            match 0 or 1 of <p>
; (-+ <p>)            match at least 1 of <p>
; all of these can be wrapped in (-- var   ) for capturing purposes
; This is NP-complete. Be careful.
;
(define (match- p expr state)
  (cond ((symbolp p)
	 (cond ((eq p '_) state)
	       (T
		(let ((capt (assoc p state)))
		  (if capt
		      (and (equal expr (cdr capt)) state)
                    (cons (cons p expr) state))))))
	
	((functionp p)
	 (and (p expr) state))
	
	((consp p)
	 (cond ((eq (car p) '-/)  (and (equal (cadr p) expr)             state))
	       ((eq (car p) '-^)  (and (not (match- (cadr p) expr state)) state))
	       ((eq (car p) '--)
		(and (match- (caddr p) expr state)
		     (cons (cons (cadr p) expr) state)))
	       ((eq (car p) '-$)  ; greedy alternation for toplevel pattern
		(match-alt (cdr p) () (list expr) state nil 1))
	       (T
		(and (consp expr)
		     (equal (car p) (car expr))
		     (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
	
	(T
	 (and (equal p expr) state))))

; match an alternation
(define (match-alt alt prest expr state var L)
  (if (null alt) nil  ; no alternatives left
    (let ((subma (match- (car alt) (car expr) state)))
      (or (and subma
               (match-seq prest (cdr expr)
                          (if var
                              (cons (cons var (car expr))
                                    subma)
                            subma)
                          (- L 1)))
          (match-alt (cdr alt) prest expr state var L)))))

; match generalized kleene star (try consuming min to max)
(define (match-star- p prest expr state var min max L sofar)
  (cond ; case 0: impossible to match
   ((> min max) nil)
    ; case 1: only allowed to match 0 subexpressions
   ((= max 0) (match-seq prest expr
                         (if var (cons (cons var (reverse sofar)) state)
                           state)
                         L))
    ; case 2: must match at least 1
   ((> min 0)
    (and (match- p (car expr) state)
         (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
                      (cons (car expr) sofar))))
    ; otherwise, must match either 0 or between 1 and max subexpressions
   (T
    (or (match-star- p prest expr state var 0 0   L sofar)
        (match-star- p prest expr state var 1 max L sofar)))))
(define (match-star p prest expr state var min max L) 
  (match-star- p prest expr state var min max L ()))

; match sequences of expressions
(define (match-seq p expr state L)
  (cond ((not state) nil)
	((null p) (if (null expr) state nil))
	(T
	 (let ((subp (car p))
	       (var  nil))
	   (if (and (consp subp)
		    (eq (car subp) '--))
	       (progn (setq var (cadr subp))
                      (setq subp (caddr subp)))
             nil)
	   (let ((head (if (consp subp) (car subp) ())))
	     (cond ((eq subp '...)
		    (match-star '_ (cdr p) expr state var 0 L L))
		   ((eq head '-*)
		    (match-star (cadr subp) (cdr p) expr state var 0 L L))
		   ((eq head '-+)
		    (match-star (cadr subp) (cdr p) expr state var 1 L L))
		   ((eq head '-?)
		    (match-star (cadr subp) (cdr p) expr state var 0 1 L))
		   ((eq head '-$)
		    (match-alt (cdr subp) (cdr p) expr state var L))
		   (T
		    (and (consp expr)
			 (match-seq (cdr p) (cdr expr)
				    (match- (car p) (car expr) state)
				    (- L 1))))))))))

(define (match p expr) (match- p expr (list (cons '__ expr))))

; given a pattern p, return the list of capturing variables it uses
(define (patargs- p)
  (cond ((and (symbolp p)
              (not (member p metasymbols)))
         (list p))
        
        ((consp p)
         (if (eq (car p) '-/)
             ()
           (unique (apply append (map patargs- (cdr p))))))
        
        (T ())))
(define (patargs p)
  (cons '__ (patargs- p)))

; try to transform expr using a pattern-lambda from plist
; returns the new expression, or expr if no matches
(define (apply-patterns plist expr)
  (if (null plist) expr
    (if (functionp plist)
        (let ((enew (plist expr)))
          (if (not enew)
              expr
            enew))
      (let ((enew ((car plist) expr)))
        (if (not enew)
            (apply-patterns (cdr plist) expr)
          enew)))))

; top-down fixed-point macroexpansion. this is a typical algorithm,
; but it may leave some structure that matches a pattern unexpanded.
; the advantage is that non-terminating cases cannot arise as a result
; of expression composition. in other words, if the outer loop terminates
; on all inputs for a given set of patterns, then the whole algorithm
; terminates. pattern sets that violate this should be easier to detect,
; for example
; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
; TODO: ignore quoted expressions
(define (pattern-expand plist expr)
  (if (not (consp expr))
      expr
    (let ((enew (apply-patterns plist expr)))
      (if (eq enew expr)
	  ; expr didn't change; move to subexpressions
          (cons (car expr)
                (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
	  ; expr changed; iterate

        (pattern-expand plist enew)))))