;;; Fundamental

(define dto (make-parameter eqv-alist-dto))
(define empty-dict (make-parameter '()))

(define backtrack-stack (make-parameter '()))

(define (fail)
  (let* ((stack (begin
                  (unless (pair? (backtrack-stack))
                    (error 'fail "no place to backtrack to"))
                  (backtrack-stack)))
         (pair (begin
                 (unless (pair? (car stack))
                   (error 'fail "malformed stack" stack))
                 (car stack)))
         (k (begin
              (unless (procedure? (cdr pair))
                (error 'fail "malformed escape procedure" stack))
              (cdr pair))))
    (k #f)))

(define-syntax setup-backtrack
  (syntax-rules ()
    ((_ marker c1 c2)
     (or (call/cc (lambda (return)
                    (parameterize ((backtrack-stack
                                    (cons (cons marker return)
                                          (backtrack-stack))))
                      c1)))
         c2))))

;;; ;;;;;;;;;;;;
;;; Matcher procedures

(define-record-type <matcher-procedure>
  (matcher-procedure proc)
  matcher-procedure?
  (proc matcher-procedure-proc))

(define-syntax lambda-matcher
  (syntax-rules ()
    ((_ (dict input) body ...)
     (matcher-procedure (lambda (dict input) body ...)))
    ((_ (formals dict input) body ...)
     (lambda formals (lambda-matcher (dict input) body ...)))))

(define-syntax define-matcher
  (syntax-rules ()
    ((_ (head dict input) body ...)
     (define head (lambda-matcher (dict input) body ...)))))

(define-syntax define-recpat
  (syntax-rules ()
    ((_ head body ...)
     (define head (lambda-matcher (dict input)
                    (mt (let () body ...) dict input))))))

;;; ;;;;;;;;;;;;;;
;;; Matching drivers

(define (mt matcher dict input)
  (cond
    ((matcher-procedure? matcher)
     ((matcher-procedure-proc matcher) dict input))
    ((procedure? matcher) (error 'mt "passed bare procedure"
                                 matcher dict input))
    ((equal? matcher input) dict)
    (else (fail))))

(define-syntax match-rev
  (syntax-rules ()
    ((_ "loop" input output (pattern~ body ...) rest ...)
     (let ((tmp (setup-backtrack #f (mt pattern~ (empty-dict) input)
                                 #f)))
       (if tmp
           (let ((output tmp)) body ...)
           (match-rev "loop" input output rest ...))))
    ((_ "loop" input output) (error 'match "exhausted match" input))
    ((_ %input output rest ...)
     (let ((input %input))
       (match-rev "loop" input output rest ...)))))

(define-syntax match
  (syntax-rules ()
    ((_ input output (pattern~ body ...) ...)
     (match-rev input tmp
       (pattern~ (let ((output (dict-map (dto)
                                         (lambda (k v)
                                           (reverse v))
                                         tmp)))
                   body ...))
       ...))))

(define-syntax match-pr
  (syntax-rules ()
    ((_ input (r r1) (pattern~ body ...) ...)
     (match input tmp
       (pattern~ (letrec ((r (case-lambda
                               ((x) (r x '()))
                               ((x d) (dict-ref/default (dto)
                                                        tmp
                                                        x
                                                        d))))
                          (r1 (case-lambda
                                ((x) (r1 x #f))
                                ((x d)
                                 (dict-ref (dto)
                                           tmp
                                           x
                                           (lambda () d)
                                           car)))))
                   body ...))
       ...))))

;;; ;;;;;;;;;;;
;;; Wrappers
;;; ;;;;;;;;;;;

(define-syntax matcher-wrapper
  (syntax-rules ()
    ((_ (predicate? accessor1~ accessor ...))
     (matcher-wrapper "generate-temporaries"
                      ((pat1~ accessor1~))
                      (accessor ...)
                      predicate?))
    ((_ "generate-temporaries" (previous ...) (a1 a2 ...) orig)
     (matcher-wrapper "generate-temporaries"
                      ((tmp~ a1) previous ...) (a2 ...) orig))
    ((_ "generate-temporaries" (last-tmp tmps ...) () predicate?)
     (matcher-wrapper "reverse" () (tmps ...) last-tmp predicate?))
    ((_ "reverse" (rev ...) (tmp1 tmps ...) last-tmp predicate?)
     (matcher-wrapper "reverse"
                      (tmp1 rev ...)
                      (tmps ...)
                      last-tmp
                      predicate?))
    ((_ "reverse" ((pat~ accessor) ...) () (last-pat~ last-accessor) predicate?)
     (lambda-matcher ((pat~ ... last-pat~) dict input)
       (if (predicate? input)
           ;; Evaluate the "pat~ ..." and "accessor"s in order, collecting
           ;; the dictionary for each use and passing it to the next.
           (let* ((dict (mt pat~ dict (accessor input)))
                  ...)
             (mt last-pat~ dict (last-accessor input)))
           (fail))))))

;;; ;;;;;;;;;;;;;;;
;;; Unconditional expressions

(define b~
  (case-lambda
    ((id) (b~ id values))
    ((id xfrm)
     (lambda-matcher (dict input)
       (dict-update/default! (dto)
                             dict
                             id
                             (lambda (cdr)
                               (cons (xfrm input) cdr))
                             '())))))
(define-matcher (_~ dict input) dict)
(define-matcher (fail~ dict input) (fail))

;;; ;;;;;;;;;;;;;;;;;;;
;;; Conditional expressions

(define if~
  (case-lambda
    ((test~ consequent~ alternative~)
     (if~ #f test~ consequent~ alternative~))
    ((marker test~ consequent~ alternative~)
     (lambda-matcher (dict input)
       (let ((new-dict (setup-backtrack marker
                                        (mt test~ dict input)
                                        #f)))
         (if new-dict
             (mt consequent~ new-dict input)
             (mt alternative~ dict input)))))))

(define (if*~ . spats)
  (cond
    ((null? spats) fail~)
    ((null? (cdr spats)) spats)
    (else (if~ (car spats) (cadr spats)
               (apply if*~ (cddr spats))))))

(define (and~ . rest)
  (let loop ((rest rest))
    (cond
      ((null? rest) _~)
      ((null? (cdr rest)) (car rest))
      (else (if~ (car rest)
                 (loop (cdr rest))
                 fail~)))))

(define (or~ . rest)
  (let loop ((rest rest))
    (cond
      ((null? rest) fail~)
      ((null? (cdr rest)) (car rest))
      (else (if~ (car rest)
                 _~
                 (loop (cdr rest)))))))

(define (not~ pat~)
  (if~ pat~ fail~ _~))

(define (opt~ pat~)
  (or~ pat~ _~))

(define (as-many~ . rest)
  (let loop ((rest rest))
    (if (null? rest)
        _~
        (let ((next (loop (cdr rest))))
          (if~ (car rest) next next)))))

;;; ;;;;;;;;;;;;;;;;;
;;; Projection.

(define-matcher ((?~ proc) dict input)
  (if (proc input)
      dict
      (fail)))

(define-matcher ((inspect~ pred) dict input)
  (if (pred dict) dict (fail)))

(define-matcher ((xfrm~ proc subpat~) dict input)
  (mt subpat~ dict (proc input)))

;;; ;;;;;;;;;;;;;;;;;
;;; Control of backtracking.

(define-matcher ((cut~ marker pat~) dict input)
  (let loop ((stack (backtrack-stack)))
    (cond
      ((null? stack) (error 'cut!~ "unknown marker" marker
                            (backtrack-stack)))
      ((eqv? (caar stack) marker)
       (parameterize ((backtrack-stack stack))
         (mt pat~ dict input)))
      (else (loop (cdr stack))))))

;;; ;;;;;;;;;;;;;;;;;;
;;; Numbers.
;;; ;;;;;;;;;;;;;;;;;;

(define-matcher ((=~ x) dict input)
  (if (and (number? input) (= x input))
      dict
      (fail)))

(define-matcher ((=Reps~ eps x) dict input)
  (if (and (number? input) (<= (abs (- x input)) eps))
      dict
      (fail)))

(define signmag~
  (matcher-wrapper (real? (lambda (x)
                            (cond
                              ((eqv? x +0.0) 1)
                              ((eqv? x -0.0) -1)
                              ((zero? x) +1)
                              ((positive? x) 1)
                              ((negative? x) -1)
                              (else (error 'signmag~
                                           "internal error"
                                           x))))
                          abs)))

;;; ;;;;;;;;;;;;;;;;;;;
;;; List and pairs.

(define cons~ (matcher-wrapper (pair? car cdr)))

(define (cons*~ x~ . rest)
  (let loop ((rest (cons x~ rest)))
    (cond
      ((null? (cdr rest)) (car rest))
      (else (cons~ (car rest) (loop (cdr rest)))))))

(define (list~ . spats)
  (apply cons*~ (append spats (list '()))))

(define (list-tail~ n pat~)
  (cond
    ((or (not (exact-integer? n)) (negative? n))
     (error 'list-tail~ "invalid n" n))
    ((zero? n) pat~)
    (else (cons~ _~ (list-tail~ (- n 1) pat~)))))

(define (list-ref~ n pat~)
  (list-tail~ n (cons~ pat~ _~)))

(define-recpat (member-tail~ pat~)
  (or~ pat~ (cons~ _~ (member-tail~ pat~))))

(define (member~ pat~)
  (member-tail~ (cons~ pat~ _~)))

(define assoc~
  (case-lambda
    ((key~) (assoc~ key~ _~))
    ((key~ val~) (member~ (cons~ key~ val~)))))

(define-recpat (every~ pat~)
  (or~ (?~ null?) (cons~ pat~ (every~ pat~))))

(define-recpat (list*~ pat~ rest~)
  (if~ (cons~ pat~ _~)
       (cons~ _~ (list*~ pat~ rest~))
       rest~))

;;; ;;;;;;;;;;;;;;;;;;;
;;; Vectors
;;; ;;;;;;;;;;;;;;;;;;;

(define-matcher ((vector~ . spats) dict input)
  (if (not (vector? input))
      (fail)
      (let loop ((spats spats)
                 (i 0)
                 (dict dict))
        (cond
          ((null? spats) (if (= i (vector-length input))
                             dict
                             (fail)))
          ((= i (vector-length input)) (fail))
          ((= i (- (vector-length input) 1))
           (if (null? (cdr spats))
               (mt (car spats) dict (vector-ref input i))
               (fail)))
          (else (loop (cdr spats)
                      (+ i 1)
                      (mt (car spats) dict (vector-ref input i))))))))

(define (vector-ref~ n pat~)
  (unless (and (exact-integer? n) (not (negative? n)))
    (error 'vector-ref~ "not a valid index" n))
  (lambda-matcher (dict input)
    (cond
      ((not (vector? input)) (fail))
      ((>= n (vector-length input)) (fail))
      (else (mt pat~ dict (vector-ref input n))))))