;;; Fundamental

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

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

(define-syntax define-recpat
  (syntax-rules ()
    ((_ (name pattern ...) body ...)
     (define (name pattern ...)
       (lambda (dict dyn input)
         ((let () body ...) dict dyn input))))))

(define (mt matcher dict dyn input)
  (cond
    ((procedure? matcher) (matcher dict dyn input))
    (else (and (equal? matcher input) dict))))

(define-syntax match-rev
  (syntax-rules ()
    ((_ "loop" input output (pattern~ body ...) rest ...)
     (let ((tmp (mt pattern~ empty-dict empty-dict input)))
       (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 (pat~ ... last-pat~)
       (lambda (dict dyn input)
         (and (predicate? input)
              ;; Evaluate the "pat~ ..." and "accessor"s in order, collecting
              ;; the dictionary for each use and passing it to the next.
              (let* ((dict (and dict (mt pat~ dict dyn (accessor input))))
                     ...)
                (and dict
                     (mt last-pat~ dict dyn (last-accessor input))))))))))

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

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

(define (_~ dict dyn input) dict)
(define (fail~ dict dyn input) #f)

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

(define (if~ test~ consequent~ alternative~)
  (lambda (dict dyn input)
    (let ((new-dict (mt test~ dict dyn input)))
      (if new-dict
          (mt consequent~ new-dict dyn input)
          (mt alternative~ dict dyn input)))))

(define (if*~ . spats)
  (let loop ((spats spats))
    (cond
      ((null? spats) fail~)
      ((null? (cdr spats)) spats)
      (else (if~ (car spats) (cadr spats)
                 (loop (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 (?~ proc)
  (lambda (dict dyn input)
    (and (proc input) dict)))

(define (inspect~ pred)
  (lambda (dict dyn input)
    (and (pred dict) dict)))

(define (xfrm~ proc subpat~)
  (lambda (dict dyn input)
    (mt subpat~ dict dyn (proc input))))

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

(define (=~ x)
  (?~ (lambda (input) (and (number? input)
                           (= x input)))))

(define (=Reps~ eps x)
  (?~ (lambda (input)
        (and (number? input)
             (<= (abs (- x input)) eps)))))

(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 (vector~ . spats)
  (lambda (dict dyn input)
    (and (vector? input)
         (let loop ((spats spats)
                    (i 0)
                    (dict dict))
           (cond
             ((null? spats) (and (= i (vector-length input))
                                 dict))
             ((= i (vector-length input)) #f)
             ((= i (- (vector-length input) 1))
              (and (null? (cdr spats))
                   (mt (car spats)
                       dict
                       dyn
                       (vector-ref input i))))
             (else (loop (cdr spats)
                         (+ i 1)
                         (mt (car spats)
                             dict
                             dyn
                             (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 (dict dyn input)
    (cond
      ((not (vector? input)) #f)
      ((>= n (vector-length input)) #f)
      (else (mt pat~ dict dyn (vector-ref input n))))))

;;; ;;;;;;;;;;;;;;;;;;;;;
;;; Monadic parameterization

(define (parameterize~ pat~ key val . rest)
  (lambda (dict dyn input)
    (mt pat~
        dict
        (apply dict-set! dto dyn key val rest)
        input)))

(define (parameter-update~ pat~ key updater default)
  (lambda (dict dyn input)
    (mt pat~
        dict
        (dict-update/default! dto dyn key updater default)
        input)))