(module tl-test mzscheme
  (require "../reduction-semantics.ss"
           "test-util.ss")
  
  (reset-count)
  
  
;                                                          
;                                                          
;    ;;                                                    
;     ;                                                    
;     ;     ;;;  ;; ;;    ;; ;;;;  ;;   ;;;    ;; ;;  ;;;  
;     ;    ;   ;  ;;  ;  ;  ;;  ;   ;  ;   ;  ;  ;;  ;   ; 
;     ;     ;;;;  ;   ;  ;   ;  ;   ;   ;;;;  ;   ;  ;;;;; 
;     ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;  ;     
;     ;    ;   ;  ;   ;  ;   ;  ;  ;;  ;   ;  ;   ;  ;     
;   ;;;;;   ;;;;;;;; ;;;  ;;;;   ;; ;;  ;;;;;  ;;;;   ;;;; 
;                            ;                    ;        
;                         ;;;                  ;;;         
;                                                          
;                                                          

  
  (define-language empty-language)
  
  (define-language grammar
    (M (M M)
       number)
    (E hole
       (E M)
       (number E))
    (X (number any)
       (any number))
    (Q (Q ...)
       variable)
    (UN (add1 UN)
        zero))
  
  (test (pair? (redex-match grammar M '(1 1))) #t)
  (test (pair? (redex-match grammar M '(1 1 1))) #f)
  (test (pair? (redex-match grammar
                            (side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
                            '(1 1)))
        #t)
  (test (pair? (redex-match grammar
                           (side-condition (M_1 M_2) (equal? (term M_1) (term M_2))) 
                           '(1 2)))
        #f)
  
  (test (pair? ((redex-match grammar M) '(1 1)))
        #t)

  ;; next 3: test naming of subscript-less non-terminals
  (test (pair? (redex-match grammar (M M) (term (1 1)))) #t)
  (test (pair? (redex-match grammar (M M) (term (1 2)))) #f)
  (test (pair? (redex-match grammar (M_1 M_2) (term (1 2)))) #t)
  
  (define-language base-grammar
    (q 1)
    (e (+ e e) number)
    (x (variable-except +)))
  
  (define-extended-language extended-grammar
    base-grammar 
    (e .... (* e e))
    (x (variable-except + *))
    (r 2))
  
  (test (pair? (redex-match extended-grammar e '(+ 1 1))) #t)
  (test (pair? (redex-match extended-grammar e '(* 2 2))) #t)
  (test (pair? (redex-match extended-grammar r '2)) #t)
  (test (pair? (redex-match extended-grammar q '1)) #t)
  (test (pair? (redex-match extended-grammar x '*)) #f)
  (test (pair? (redex-match extended-grammar x '+)) #f)
  (test (pair? (redex-match extended-grammar e '....)) #f)
  
  ;; make sure that `language' with a four period ellipses signals an error
  (test (regexp-match #rx"[.][.][.][.]" (with-handlers ([exn? exn-message]) 
                                          (let ()
                                            (define-language x (e ....))
                                            12)))
        '("...."))
  

  
  ;; test multiple variable non-terminals
  (let ()
    (define-language lang
      ((l m) (l m) x)
      (x variable-not-otherwise-mentioned))
    (test (pair? (redex-match lang m (term x)))
          #t))
  
  ;; test multiple variable non-terminals
  (let ()
    (define-language lang
      ((l m) (l m) x)
      (x variable-not-otherwise-mentioned))
    (test (pair? (redex-match lang l (term x)))
          #t))
  
  (let ()
    (define-language lang
      ((x y) 1 2 3))
    (define-extended-language lang2 lang
      (x .... 4))
    (test (pair? (redex-match lang2 x 4)) #t)
    (test (pair? (redex-match lang2 y 4)) #t)
    (test (pair? (redex-match lang2 x 1)) #t)
    (test (pair? (redex-match lang2 y 2)) #t))
  
  ;; test that the variable "e" is not bound in the right-hand side of a side-condition
  ;; this one signaled an error at some point
  (let ()
    (define-language bad
      (e 2 (side-condition (e) #t)))
    (test (pair? (redex-match bad e '(2)))
          #t))

  ;; test that the variable "e" is not bound in the right-hand side of a side-condition
  ;; this one tests to make sure it really isn't bound
  (let ([x #f])
    (define-language bad
      (e 2 (side-condition (e) (set! x (term e)))))
    (redex-match bad e '(2))
    (test x 'e))
  
  ;; test multiple variable non-terminals being extended
  (let ()
    (define-language lang
      ((x y) 1 2 3))
    (define-extended-language lang2 lang
      (x .... 4))
    (test (pair? (redex-match lang2 x 4)) #t)
    (test (pair? (redex-match lang2 y 4)) #t)
    (test (pair? (redex-match lang2 x 1)) #t)
    (test (pair? (redex-match lang2 y 2)) #t))
  
  ;; test multiple variable non-terminals in an extended language
  (let ()
    (define-language lang
      ((x y) 1 2 3))
    (define-extended-language lang2 lang
      ((z w) 5 6 7))
    (test (pair? (redex-match lang2 z 5)) #t)
    (test (pair? (redex-match lang2 w 6)) #t))
  
  ;; test cases that ensure that extending any one of a
  ;; multiply defined non-terminal gets extended properly
  (let ()
    (define-language iswim
      ((V U W) AA))

    (define-extended-language iswim-cont
      iswim
      (W .... QQ))

    (test (pair? (redex-match iswim-cont U (term QQ)))
          #t))
  
  (let ()
    (define-language iswim
      ((V U W) AA))

    (define-extended-language iswim-cont
      iswim
      (W .... QQ))

    (test (pair? (redex-match iswim-cont V (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont U (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont W (term QQ)))
          #t))
  
  (let ()
    (define-language iswim
      ((V U W) AA))
    
    (define-extended-language iswim-cont
      iswim
      (V .... QQ))
    
    (test (pair? (redex-match iswim-cont V (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont U (term QQ)))
          #t)
    (test (pair? (redex-match iswim-cont W (term QQ)))
          #t))
  
  
;                                                                                             
;                                                                                             
;                                 ;;;                                ;                        
;                  ;             ;                           ;                                
;  ;;; ;    ;;;   ;;;;;   ;;;   ;;;;; ;;  ;; ;; ;;    ;;;;  ;;;;;  ;;;     ;;;  ;; ;;    ;;;; 
;   ; ; ;  ;   ;   ;     ;   ;   ;     ;   ;  ;;  ;  ;   ;   ;       ;    ;   ;  ;;  ;  ;   ; 
;   ; ; ;  ;;;;;   ;      ;;;;   ;     ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;   ;;;  
;   ; ; ;  ;       ;     ;   ;   ;     ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;      ; 
;   ; ; ;  ;       ;   ; ;   ;   ;     ;  ;;  ;   ;  ;   ;   ;   ;   ;    ;   ;  ;   ;  ;   ; 
;  ;;;;;;;  ;;;;    ;;;   ;;;;; ;;;;;   ;; ;;;;; ;;;  ;;;     ;;;  ;;;;;   ;;;  ;;; ;;; ;;;;  
;                                                                                             
;                                                                                             
;                                                                                             
;                                                                                             

  
  (define-metafunction grammar
    [(f (side-condition (number_1 number_2)
                        (< (term number_1)
                           (term number_2))))
     x]
    [(f (number 1)) y]
    [(f (number_1 2)) ,(+ (term number_1) 2)]
    [(f (4 4)) q]
    [(f (4 4)) r])

  (define-metafunction grammar
    [(g X) x])
  
  (test (term (f (1 17))) 'x)
  (test (term (f (11 1))) 'y)
  (test (term (f (11 2))) 13)
  
  
  ;; match two clauess => take first one
  (test (term (f (4 4))) 'q)
  
  ;; match one clause two ways => error
  (let ()
    (define-metafunction empty-language
      [(ll (number_1 ... number_2 ...)) 4])
    (test (with-handlers ((exn? (λ (x) 'exn-raised))) 
            (term (ll ()))
            'no-exn)
          'no-exn)
    (test (with-handlers ((exn? (λ (x) 'exn-raised))) 
            (term (ll (4 4)))
            'no-exn)
          'exn-raised))
  
  ;; match no ways => error
  (test (with-handlers ((exn? (λ (x) 'exn-raised))) (term (f mis-match)) 'no-exn)
        'exn-raised)

  (define-metafunction grammar
    [(h (M_1 M_2)) ((h M_2) (h M_1))]
    [(h number_1) ,(+ (term number_1) 1)])
  
  (test (term (h ((1 2) 3)))
        (term (4 (3 2))))
  
  (define-metafunction grammar
    [(h2 (Q_1 ...)) ((h2 Q_1) ...)]
    [(h2 variable) z])
  
  (test (term (h2 ((x y) a b c)))
        (term ((z z) z z z)))
  
  (let ()
    (define-metafunction empty-language
      [(f (1)) 1]
      [(f (2)) 2]
      [(f 3) 3])
    (test (in-domain? (f 1)) #f)
    (test (in-domain? (f (1))) #t)
    (test (in-domain? (f ((1)))) #f)
    (test (in-domain? (f 3)) #t)
    (test (in-domain? (f 4)) #f))
  
  (let ()
    (define-metafunction empty-language
      f : number -> number
      [(f 1) 1])
    (test (in-domain? (f 1)) #t)
    (test (in-domain? (f 2)) #t)
    (test (in-domain? (f x)) #f))
  
  (let ()
    (define-metafunction empty-language
      [(f x) x])
    (test 
     (term-let ((y 'x))
               (in-domain? (f y)))
     #t)
    (test 
     (term-let ((y 'z))
               (in-domain? (f y)))
     #f))
  
  ;; mutually recursive metafunctions
  (define-metafunction grammar
    [(odd zero) #f]
    [(odd (add1 UN_1)) (even UN_1)])
  
  (define-metafunction grammar
    [(even zero) #t]
    [(even (add1 UN_1)) (odd UN_1)])
  
  (test (term (odd (add1 (add1 (add1 (add1 zero))))))
        (term #f))
    
  (let ()
    (define-metafunction empty-language
      [(pRe xxx) 1])
    
    (define-metafunction empty-language
      [(Merge-Exns any_1) any_1])
    
    (test (term (pRe (Merge-Exns xxx)))
          1))
  
  (let ()
    (define-metafunction empty-language
      [(f (x)) ,(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup)))]
      [(f y) y]
      [(f var-should-be-lookedup) var-should-be-lookedup]) ;; taking this case is bad!
    
    (test (term (f (x))) (term y)))
  
  (let ()
    (define-metafunction empty-language
      [(f (x)) (x ,@(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup))) x)]
      [(f y) (y)]
      [(f var-should-be-lookedup) (var-should-be-lookedup)]) ;; taking this case is bad!
    
    (test (term (f (x))) (term (x y x))))
  
  (let ()
    (define-metafunction empty-language
      [(f (any_1 any_2))
       case1
       (side-condition (not (equal? (term any_1) (term any_2))))
       (side-condition (not (equal? (term any_1) 'x)))]
      [(f (any_1 any_2))
       case2
       (side-condition (not (equal? (term any_1) (term any_2))))]
      [(f (any_1 any_2))
       case3])
    (test (term (f (q r))) (term case1))
    (test (term (f (x y))) (term case2))
    (test (term (f (x x))) (term case3)))

  (let ()
    (define-metafunction empty-language
      [(f (n number)) (n number)]
      [(f (a any)) (a any)]
      [(f (v variable)) (v variable)]
      [(f (s string)) (s string)])
    (test (term (f (n 1))) (term (n 1)))
    (test (term (f (a (#f "x" whatever)))) (term (a (#f "x" whatever))))
    (test (term (f (v x))) (term (v x)))
    (test (term (f (s "x"))) (term (s "x"))))
  
  ;; test ..._1 patterns
  (let ()
    (define-metafunction empty-language
      [(zip ((variable_id ..._1) (number_val ..._1)))
       ((variable_id number_val) ...)])
    
    (test (term (zip ((a b) (1 2)))) (term ((a 1) (b 2)))))
  
  (let ()
    (define-metafunction empty-language
      [(f any_1 any_2 any_3) (any_3 any_2 any_1)])
    (test (term (f 1 2 3)) 
          (term (3 2 1))))
  
  (let ()
    (define-metafunction empty-language
      [(f (any_1 any_2 any_3)) 3])
    (define-metafunction/extension f empty-language
      [(g (any_1 any_2)) 2])
    (test (term (g (1 2))) 2)
    (test (term (g (1 2 3))) 3))
  
  (let ()
    (define-metafunction empty-language
      [(f any_1 any_2 any_3) 3])
    (define-metafunction/extension f empty-language
      [(g any_1 any_2) 2])
    (test (term (g 1 2)) 2)
    (test (term (g 1 2 3)) 3))
  
  (let ()
    (define-metafunction empty-language
      [(f number_1 number_2) (f number_1)])
    (define-metafunction/extension f empty-language
      [(g number_1) number_1])
    (define-metafunction empty-language
      [(h number_1 number_2) (h number_1)]
      [(h number_1) number_1])
    (test (term (g 11 17)) 11)
    (test (term (h 11 17)) 11))
  
  (let ()
    (define-metafunction empty-language
      [(f (number_1 number_2))
       number_3
       (where number_3 ,(+ (term number_1) (term number_2)))])
    (test (term (f (11 17))) 28))
  
  (let ()
    (define-metafunction empty-language
      [(f variable) 
       (x x)
       (where x (variable variable))])
    (test (term (f z)) 
          (term ((z z) (z z)))))
  
  (let ()
    (define-language x-lang
      (x variable))
    (define-metafunction x-lang
      f : x x -> x
      [(f x_1 x_2) x_1])
    (test (term (f p q)) (term p))
    (test (in-domain? (f p q)) #t))
  
  (let ()
    (define-metafunction empty-language
      [(err number_1 ... number_2 ...) 1])
    (test (term (err)) 1)
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 2))
            'no-exn)
          'right-exn))
  
  (let ()
    (define-metafunction empty-language
      err : number ... -> number
      [(err number ...) 1])
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err #f #t))
            'no-exn)
          'right-exn))
  
  (let ()
    (define-metafunction empty-language
      err : number ... -> number
      [(err number ...) #f])
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 2))
            'no-exn)
          'right-exn))
  
  (let ()
    (define-metafunction empty-language
      err : number ... -> (number number)
      [(err number ...) (number ...)])
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 2))
            'no-exn)
          'no-exn)
    (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                          ((λ (x) #t) (λ (x) 'wrong-exn)))
            (term (err 1 1))
            'no-exn)
          'no-exn))
    
  

;                                                                                                                                
;                                                                                                                                
;                    ;;                         ;                                        ;;                    ;                 
;                     ;                 ;                                                 ;            ;                         
;   ;; ;;   ;;;    ;; ; ;;  ;;   ;;;;  ;;;;;  ;;;     ;;;  ;; ;;          ;; ;;   ;;;     ;     ;;;   ;;;;;  ;;;     ;;;  ;; ;;  
;    ;;    ;   ;  ;  ;;  ;   ;  ;   ;   ;       ;    ;   ;  ;;  ;          ;;    ;   ;    ;    ;   ;   ;       ;    ;   ;  ;;  ; 
;    ;     ;;;;;  ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;  ;;;;;   ;     ;;;;;    ;     ;;;;   ;       ;    ;   ;  ;   ; 
;    ;     ;      ;   ;  ;   ;  ;       ;       ;    ;   ;  ;   ;          ;     ;        ;    ;   ;   ;       ;    ;   ;  ;   ; 
;    ;     ;      ;   ;  ;  ;;  ;   ;   ;   ;   ;    ;   ;  ;   ;          ;     ;        ;    ;   ;   ;   ;   ;    ;   ;  ;   ; 
;   ;;;;;   ;;;;   ;;;;;  ;; ;;  ;;;     ;;;  ;;;;;   ;;;  ;;; ;;;        ;;;;;   ;;;;  ;;;;;   ;;;;;   ;;;  ;;;;;   ;;;  ;;; ;;;
;                                                                                                                                
;                                                                                                                                
;                                                                                                                                
;                                                                                                                                

  
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (--> (in-hole E_1 (number_1 number_2))
               (in-hole E_1 ,(* (term number_1) (term number_2)))))
         '((2 3) (4 5)))
        (list '(6 (4 5))))

  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (~~> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (in-hole E_1 a) (in-hole E_1 b)) (~~> a b)])
         '((2 3) (4 5)))
        (list '(6 (4 5))))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (==> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (M_1 a) (M_1 b)) (~~> a b)]
          [(~~> (M_1 a) (M_1 b)) (==> a b)])
         '((1 2) ((2 3) (4 5))))
        (list '((1 2) ((2 3) 20))))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (~~> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          (==> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (M_1 a) (M_1 b)) (~~> a b)]
          [(--> (a M_1) (b M_1)) (==> a b)])
         '((2 3) (4 5)))
        (list '(6 (4 5))
              '((2 3) 20)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (--> (M_1 (number_1 number_2))
               (M_1 ,(* (term number_1) (term number_2))))
          (==> (number_1 number_2)
               ,(* (term number_1) (term number_2)))
          with
          [(--> (a M_1) (b M_1)) (==> a b)])
         '((2 3) (4 5)))
        (list '((2 3) 20)
              '(6 (4 5))))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (--> (number_1 number_2) 
               ,(* (term number_1) (term number_2))
               mul))
         '(4 5))
        (list (list "mul" 20)))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (--> (number_1 number_2) 
               ,(* (term number_1) (term number_2))
               "mul"))
         '(4 5))
        (list (list "mul" 20)))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (--> (number_1 number_2) 
               ,(* (term number_1) (term number_2))))
         '(4 5))
        (list (list #f 20)))
  
  (test (apply-reduction-relation/tag-with-names
         (reduction-relation 
          grammar
          (==> (number_1 number_2) 
               ,(* (term number_1) (term number_2))
               mult)
          with
          [(--> (M_1 a) (M_1 b)) (==> a b)])
         '((2 3) (4 5)))
        (list (list "mult" '((2 3) 20))))
  
  (test (apply-reduction-relation
         (union-reduction-relations
          (reduction-relation empty-language
                              (--> x a)
                              (--> x b))
          (reduction-relation empty-language
                              (--> x c)
                              (--> x d)))
         'x)
        (list 'a 'b 'c 'd))
  
  (test (apply-reduction-relation
         (union-reduction-relations
          (reduction-relation empty-language (--> x a))
          (reduction-relation empty-language (--> x b))
          (reduction-relation empty-language (--> x c))
          (reduction-relation empty-language (--> x d)))
         'x)
        (list 'a 'b 'c 'd))
  
  (test (apply-reduction-relation
         (reduction-relation 
          empty-language
          (--> (number_1 number_2) 
               number_2
               (side-condition (< (term number_1) (term number_2))))
          (--> (number_1 number_2) 
               number_1
               (side-condition (< (term number_2) (term number_1)))))
         '(1 2))
        (list 2))
  
  (test (apply-reduction-relation
         (reduction-relation 
          empty-language
          (--> x #f))
         (term x))
        (list #f))
  
  (define-language x-language
    (x variable))
  
  (test (apply-reduction-relation
         (reduction-relation 
          x-language
          (--> x (x x)))
         'y)
        (list '(y y)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          x-language
          (--> (x ...) ((x ...))))
         '(p q r))
        (list '((p q r))))

  (parameterize ([current-namespace syn-err-test-namespace])
    (eval (quote-syntax
           (define-language grammar
             (M (M M)
                number)
             (E hole
                (E M)
                (number E))
             (X (number any)
                (any number))
             (Q (Q ...)
                variable)
             (UN (add1 UN)
                 zero)))))
  
  (test-syn-err (reduction-relation 
                 grammar
                 (~~> (number_1 number_2)
                      ,(* (term number_1) (term number_2)))
                 with
                 [(--> (M a) (M b)) (~~> a b)]
                 [(~~> (M a) (M b)) (==> a b)])
                #rx"no rules")
  
  (test-syn-err (reduction-relation grammar)
                #rx"no rules use -->")
  
  (test-syn-err (reduction-relation 
                 grammar
                 (~~> (number_1 number_2)
                      ,(* (term number_1) (term number_2))))
                #rx"~~> relation is not defined")
  
  (test-syn-err (reduction-relation 
                 grammar
                 (--> (number_1 number_2) 
                      ,(* (term number_1) (term number_2))
                      mult)
                 (--> (number_1 number_2) 
                      ,(* (term number_1) (term number_2))
                      mult))
                #rx"same name on multiple rules")
  
  (test-syn-err (reduction-relation 
                 grammar
                 (--> 1 2)
                 (==> 3 4))
                #rx"not defined.*==>")
  
  (test-syn-err  (reduction-relation 
                  empty-language
                  (--> 1 2)
                  (==> 3 4)
                  with
                  [(~> a b) (==> a b)])
                 #rx"not defined.*~>")
  
  (test-syn-err (define-language bad-lang1 (e name)) #rx"name")
  (test-syn-err (define-language bad-lang2 (name x)) #rx"name")
  (test-syn-err (define-language bad-lang3 (x_y x)) #rx"x_y")
  
  ;; expect union with duplicate names to fail
  (test (with-handlers ((exn? (λ (x) 'passed)))
          (union-reduction-relations
           (reduction-relation 
            grammar
            (--> (number_1 number_2) 
                 ,(* (term number_1) (term number_2))
                 mult))
           (reduction-relation 
            grammar
            (--> (number_1 number_2) 
                 ,(* (term number_1) (term number_2))
                 mult)))
          'failed)
        'passed)
  
  (test (with-handlers ((exn? (λ (x) 'passed)))
          (union-reduction-relations
           (union-reduction-relations
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult))
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult3)))
           
           (union-reduction-relations
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult))
            (reduction-relation 
             grammar
             (--> (number_1 number_2) 
                  ,(* (term number_1) (term number_2))
                  mult2))))
          'passed)
        'passed)
  
  ;; sorting in this test case is so that the results come out in a predictable manner.
  (test (sort
         (apply-reduction-relation
          (compatible-closure 
           (reduction-relation 
            grammar
            (--> (number_1 number_2) 
                 ,(* (term number_1) (term number_2))
                 mult))
           grammar
           M)
          '((2 3) (4 5)))
         (λ (x y) (string<=? (format "~s" x) (format "~s" y))))
        (list '((2 3) 20)
              '(6 (4 5))))
  
  (test (apply-reduction-relation
         (compatible-closure 
          (reduction-relation 
           grammar
           (--> (number_1 number_2) 
                ,(* (term number_1) (term number_2))
                mult))
          grammar
          M)
         '(4 2))
        (list '8))
  
  (test (apply-reduction-relation
         (context-closure 
          (context-closure 
           (reduction-relation grammar (--> 1 2))
           grammar
           (y hole))
          grammar
          (x hole))
         '(x (y 1)))
        (list '(x (y 2))))

  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (--> (variable_1 variable_2) 
               (variable_1 variable_2 x)
               mul
               (fresh x)))
         '(x x1))
        (list '(x x1 x2)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          grammar
          (~~> number 
               x
               (fresh x))
          with 
          [(--> (variable_1 variable_2 a) (variable_1 variable_2 b)) (~~> a b)])
         '(x x1 2))
        (list '(x x1 x2)))
  
  (test (apply-reduction-relation
         (reduction-relation 
          x-language
          (--> (x_1 ...)
               (x ...)
               (fresh ((x ...) (x_1 ...)))))
         '(x y x1))
        (list '(x2 x3 x4)))

  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> (variable_1 ...)
               (x ... variable_1 ...)
               (fresh ((x ...) (variable_1 ...) (variable_1 ...)))))
         '(x y z))
        (list '(x1 y1 z1 x y z)))
  
  (test (apply-reduction-relation
         (reduction-relation
          empty-language
          (--> variable_1
               (x variable_1)
               (fresh (x variable_1))))
         'q)
        (list '(q1 q)))
  
  (test (apply-reduction-relation
         (extend-reduction-relation (reduction-relation empty-language (--> 1 2))
                                    empty-language
                                    (--> 1 3))
         1)
        '(3 2))
  
  (let ()
    (define-language e1
      (e 1))
    (define-language e2
      (e 2))
    (define red1 (reduction-relation e1 (--> e (e e))))
    (define red2 (extend-reduction-relation red1 e2 (--> ignoreme ignoreme)))
    (test (apply-reduction-relation red1 1) '((1 1)))
    (test (apply-reduction-relation red1 2) '())
    (test (apply-reduction-relation red2 1) '())
    (test (apply-reduction-relation red2 2) '((2 2))))
  
  (let ()
    (define red1 (reduction-relation empty-language
                                     (--> a (a a) 
                                          a)
                                     (--> b (b b) 
                                          b)
                                     (--> q x)))
    (define red2 (extend-reduction-relation red1
                                            empty-language
                                            (--> a (c c)
                                                 a)
                                            (--> q z)))
    (test (apply-reduction-relation red1 (term a)) (list (term (a a))))
    (test (apply-reduction-relation red1 (term b)) (list (term (b b))))
    (test (apply-reduction-relation red1 (term q)) (list (term x)))
    (test (apply-reduction-relation red2 (term a)) (list (term (c c))))
    (test (apply-reduction-relation red2 (term b)) (list (term (b b))))
    (test (apply-reduction-relation red2 (term q)) (list (term z) (term x))))
  
  (let ()
    (define red1 
      (reduction-relation
       empty-language
       (==> a (a a) 
            a)
       (==> b (b b) 
            b)
       (==> q w)
       with
       [(--> (X a) (X b)) (==> a b)]))
    
    (define red2 
      (extend-reduction-relation
       red1
       empty-language
       (==> a (c c)
            a)
       (==> q z)
       with
       [(--> (X a) (X b)) (==> a b)]))
    
    (test (apply-reduction-relation red1 (term (X a))) (list (term (X (a a)))))
    (test (apply-reduction-relation red1 (term (X b))) (list (term (X (b b)))))
    (test (apply-reduction-relation red1 (term (X q))) (list (term (X w))))
    (test (apply-reduction-relation red2 (term (X a))) (list (term (X (c c)))))
    (test (apply-reduction-relation red2 (term (X b))) (list (term (X (b b)))))
    (test (apply-reduction-relation red2 (term (X q))) (list (term (X z)) 
                                                             (term (X w)))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; examples from doc.txt
  ;;
  
  (define-language lc-lang
    (e (e e ...)
       x
       v)
    (c (v ... c e ...)
       hole)
    (v (lambda (x ...) e))
    (x variable-not-otherwise-mentioned))
  
  (test (let ([m (redex-match lc-lang e (term (lambda (x) x)))])
          (and m (length m)))
        1)
  
  (define-extended-language qabc-lang lc-lang (q a b c))
  
  (test (redex-match qabc-lang
                     e
                     (term (lambda (a) a)))
        #f)
  
  (test (let ([m (redex-match qabc-lang
                              e
                              (term (lambda (z) z)))])
          (and m (length m)))
        1)
  
  (require (lib "list.ss"))
  (let ()
    (define-metafunction lc-lang
      free-vars : e -> (x ...)
      [(free-vars (e_1 e_2 ...))
       (∪ (free-vars e_1) (free-vars e_2) ...)]
      [(free-vars x) (x)]
      [(free-vars (lambda (x ...) e))
       (- (free-vars e) (x ...))])
    
    (define-metafunction lc-lang
      ∪ : (x ...) ... -> (x ...)
      [(∪ (x_1 ...) (x_2 ...) (x_3 ...) ...)
       (∪ (x_1 ... x_2 ...) (x_3 ...) ...)]
      [(∪ (x_1 ...))
       (x_1 ...)]
      [(∪) ()])
    
    (define-metafunction lc-lang
      - : (x ...) (x ...) -> (x ...)
      [(- (x ...) ()) (x ...)]
      [(- (x_1 ... x_2 x_3 ...) (x_2 x_4 ...))
       (- (x_1 ... x_3 ...) (x_2 x_4 ...))
       (side-condition (not (memq (term x_2) (term (x_3 ...)))))]
      [(- (x_1 ...) (x_2 x_3 ...))
       (- (x_1 ...) (x_3 ...))])
    
    (test (term (∪)) (term ()))
    (test (term (∪ (x y) (z a) (b c))) (term (x y z a b c)))
    
    (test (term (- (x y) ())) (term (x y)))
    (test (term (- (x y) (x))) (term (y)))
    (test (term (- (y x) (x))) (term (y)))
    (test (term (- (x x x x x) (x))) (term ()))
    
    (test (term (free-vars (lambda (x) (x y)))) (list 'y))
    (test (term (free-vars (a (b (c (d e)))))) (term (a b c d e))))

  (test (variable-not-in (term (x y z)) 'x)
        (term x1))
  
  (test (variable-not-in (term (y z)) 'x)
        (term x))
  (test (variable-not-in (term (x x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) 'x)
        (term x11))
  (test (variable-not-in (term (x x11)) 'x)
        (term x1))
  (test (variable-not-in (term (x x1 x2 x3)) 'x1)
        (term x4))
  (test (variable-not-in (term (x x1 x1 x2 x2)) 'x)
        (term x3))
  
  (test (variables-not-in (term (x y z)) '(x))
        '(x1))
  (test (variables-not-in (term (x2 y z)) '(x x x))
        '(x x1 x3))
  
  (test ((term-match/single empty-language
                            [(variable_x variable_y)
                             (cons (term variable_x)
                                   (term variable_y))])
         '(x y))
        '(x . y))
  
  (test ((term-match/single empty-language
                            [(side-condition (variable_x variable_y)
                                             (eq? (term variable_x) 'x))
                             (cons (term variable_x)
                                   (term variable_y))])
         '(x y))
        '(x . y))
  

  (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                        ((λ (x) #t) (λ (x) 'wrong-exn)))
          ((term-match/single empty-language
                              [(number_1 ... number_2 ...) 1])
           '(1 2 3))
          'no-exn)
        'right-exn)
  
  (test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
                        ((λ (x) #t) (λ (x) 'wrong-exn)))
          ((term-match/single empty-language
                              [(number_1 ... number_2 ...) 1])
           'x)
          'no-exn)
        'right-exn)
  
  (test ((term-match empty-language
                     [(number_1 ... number_2 ...) 1])
         'x)
        '())
                             
  (define-language x-is-1-language
    [x 1])
  
  (test ((term-match/single x-is-1-language
                            [(x x)
                             1])
         '(1 1))
        1)
  
  (test (let ([x 0])
          (cons ((term-match empty-language
                             [(any_a ... number_1 any_b ...)
                              (begin (set! x (+ x 1))
                                     (term number_1))])
                 '(1 2 3))
                x))
        '((3 2 1) . 3))
  
  (test ((term-match empty-language
                     [number_1
                      (term number_1)]
                     [number_1
                      (term number_1)])
         '1)
        '(1 1))
  
  (test (apply-reduction-relation
         (reduction-relation
          x-language
          (--> (x_one x_!_one x_!_one x_!_one)
               (x_one x_!_one)))
         (term (a a b c)))
        (list (term (a x_!_one))))
  
  ;; tests `where' clauses in reduction relation
  (test (apply-reduction-relation
         (reduction-relation empty-language
                             (--> number_1 
                                  y
                                  (where y ,(+ 1 (term number_1)))))
         3)
        '(4))
  
  ;; tests `where' clauses scoping
  (test (let ([x 5])
          (apply-reduction-relation
           (reduction-relation empty-language
                               (--> any 
                                    z
                                    (where y ,x)
                                    (where x 2)
                                    (where z ,(+ (term y) (term x)))))
           'whatever))
        '(7))
  
  ;; test that where clauses bind in side-conditions that follow
  (let ([save1 #f]
        [save2 #f])
    (term-let ([y (term outer-y)])
              (test (begin (apply-reduction-relation
                            (reduction-relation empty-language
                                                (--> number_1 
                                                     y
                                                     (side-condition (set! save1 (term y)))
                                                     (where y inner-y)
                                                     (side-condition (set! save2 (term y)))))
                            3)
                           (list save1 save2))
                    (list 'outer-y 'inner-y))))
  
  (test (apply-reduction-relation
         (reduction-relation empty-language
                             (--> any 
                                  y
                                  (fresh x)
                                  (where y x)))
         'x)
        '(x1))
  
  (print-tests-passed 'tl-test.ss))