;;;; Matcher based on match combinators, CPH/GJS style.
;;;     Idea is in Hewitt's PhD thesis (1969).

(declare (usual-integrations))

;;; There are match procedures that can be applied to data items.  A
;;; match procedure either accepts or rejects the data it is applied
;;; to.  Match procedures can be combined to apply to compound data
;;; items.

;;; A match procedure takes a list containing a data item, a
;;; dictionary, and a success continuation.  The dictionary
;;; accumulates the assignments of match variables to values found in
;;; the data.  The success continuation takes two arguments: the new
;;; dictionary, and the number of items absorbed from the list by the
;;; match.  If a match procedure fails it returns #f.

;;; Primitive match procedures:

(define (match:equal pattern-constant)
  (define (equal-match data dictionary succeed)
    (if *debugging-match* (and (pair? data) (pp `(match:eqv ,(car data)))))
    (and (pair? data)
	 (let ((ndict
		(match:unify (car data)
			     pattern-constant
			     dictionary)))
	   (and ndict (succeed ndict 1)))))
  equal-match)


;;; We have optional restriction argument for conditional matches.

(define (match:element variable #!optional restriction?)
  (if (default-object? restriction?)
      (set! restriction? (lambda (x) #t)))
  (define (element-match data dictionary succeed)
    (and (pair? data)
	 (restriction? (car data))
	 (let ((vcell (match:lookup variable dictionary)))
	   (if *debugging-match*
	       (pp `(match:element ,(car data) ,vcell)))
	   (if vcell
	       (let ((ndict
		      (match:unify (car data)
				   (match:value vcell)
				   dictionary)))
		 
		 (and ndict (succeed ndict 1)))
	       (succeed (match:bind variable
				    (car data)
				    dictionary)
			1)))))
  element-match)

(define (match:segment variable)
  (define (segment-match data dictionary succeed)
    (if *debugging-match* (pp `(match:segment ,data)))
    (and (list? data)
	 (let ((vcell (match:lookup variable dictionary)))
	   (if vcell
	       (let lp ((data data)
			(pattern (match:value vcell))
			(n 0)
			(dictionary dictionary))
		 (cond ((pair? pattern)
			(and (pair? data)
			     (let ((ndict
				    (match:unify (car data)
						 (car pattern)
						 dictionary)))
			       (and ndict
				    (lp (cdr data)
					(cdr pattern)
					(+ n 1)
					ndict)))))
		       ((not (null? pattern)) #f)
		       (else (succeed dictionary n))))
	       (let ((n (length data)))
		 (let lp ((i 0))
		   (if (<= i n)
		       (or (succeed (match:bind variable
						(list-head data i)
						dictionary)
				    i)
			   (lp (+ i 1)))
		       #f)))))))
  segment-match)

(define (match:list . match-combinators)
  (define (list-match data dictionary succeed)
    (if *debugging-match*
	(and (pair? data) (pp `(match:list ,(car data)))))
    (and (pair? data)
	 (let lp ((items (car data))
		  (matchers match-combinators)
		  (dictionary dictionary))
	   (cond ((pair? matchers)
		  ((car matchers) items dictionary
		      (lambda (new-dictionary n)
			(if (> n (length items))
			    (error "Matcher ate too much." n))
			(lp (list-tail items n)
			    (cdr matchers)
			    new-dictionary))))
		 ((pair? items) #f)
		 (else (succeed dictionary 1))))))
  list-match)

(define *debugging-match* #f)

(define *unknown* (list '*unknown*))

;;; Support for the dictionary.

(define (match:bind variable data-object dictionary)
  (cons (list variable data-object) dictionary))

(define (match:lookup variable dictionary)
  (assq variable dictionary))

(define (match:value vcell)
  (cadr vcell))

#|
;;; Syntax of matching is determined here.
;;; Subsumed by rule compiler...

(define (match:->combinators pattern)
  (define (compile pattern)
    (cond ((match:element? pattern)
	   (match:element (match:variable-name pattern)))
	  ((match:segment? pattern)
	   (match:segment (match:variable-name pattern)))
	  ((list? pattern)
	   (apply match:list (map compile pattern)))
	  (else (match:eqv pattern))))
  (compile pattern))



(define (match:element? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?)))

(define (match:segment? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '??)))

(define (match:variable-name pattern)
  (cadr pattern))



(define (matcher pattern)
  (let ((match-combinator (match:->combinators pattern)))
    (lambda (datum)
      (match-combinator
       (list datum)
       '()
       (lambda (dictionary number-of-items-eaten)
	 (and (= number-of-items-eaten 1)
	      dictionary))))))
|#

#|
((match:->combinators '(a ((? b) 2 3) 1 c))
 '((a (1 2 3) 1 c))
 '()
  (lambda (x y) `(succeed ,x ,y)))
;Value: (succeed ((b 1)) 1)

((match:->combinators '(a ((? b) 2 3) (? b) c))
 '((a (1 2 3) 2 c))
 '()
  (lambda (x y) `(succeed ,x ,y)))
;Value: #f

((match:->combinators '(a ((? b) 2 3) (? b) c))
 '((a (1 2 3) 1 c))
 '()
  (lambda (x y) `(succeed ,x ,y)))
;Value: (succeed ((b 1)) 1)


((match:->combinators '(a (?? x) (?? y) (?? x) c))
 '((a b b b b b b c))
 '()
 (lambda (x y)
   (pp `(succeed ,x ,y))
   #f))
(succeed ((y (b b b b b b)) (x ())) 1)
(succeed ((y (b b b b)) (x (b))) 1)
(succeed ((y (b b)) (x (b b))) 1)
(succeed ((y ()) (x (b b b))) 1)
;Value: #f

((matcher '(a ((? b) 2 3) (? b) c))
 '(a (1 2 3) 1 c))
;Value: ((b 1))
|#