(cond-expand
  (chicken-5 (import r7rs)
             (load "lib/kiss-test.sld"))
  (else))
(import (scheme base) (scheme write) (srfi 225) (kiss-test) (nitrate))
(cond-expand
  ((or (library (scheme complex)) full-numeric-tower)
   (import (scheme complex) (nitrate complex)))
  (else))
(cond-expand
  ;; Add your implementation here. Also make sure to add your
  ;; implementation to the cond-expand for the include of "rational.scm".
  ((not (or tr7 skint)) (import (nitrate rational)))
  (else))

(define-record-type <test-record>
  (test-record val1 val2)
  test-record?
  (val1 test-record-val1 set-test-record-val1!)
  (val2 test-record-val2 set-test-record-val2!))

(test-group "Dictionaries"
  (test-assert "dto" (dto? (dto)))
  (test-assert "empty-dict is a dictionary" (dictionary? (dto) (empty-dict)))
  (test-assert "empty-dict is empty" (dict-empty? (dto) (empty-dict))))

(test-group "Backtracking"
  (test-eqv "setup-backtrack and return normally"
            (setup-backtrack #f 10 20)
            10)
  (test-eqv "setup-backtrack and fail"
            (setup-backtrack #f (begin (fail) 10) 20)
            20))

(test-group "Creating Matching Procedures"
  (test-assert "matcher-procedure"
               (matcher-procedure? (matcher-procedure (lambda (dict input)
                                                        input))))
  (let ((x (lambda (dict input) input)))
    (test-eqv "matcher-procedure-proc"
              (matcher-procedure-proc (matcher-procedure x))
              x))
  (test-assert "lambda matcher without formals"
               (matcher-procedure? (lambda-matcher (dict input) input)))
  (test-assert "lambda matcher with formals"
               (matcher-procedure? (let ((f
                                          (lambda-matcher ((a) dict input)
                                            dict)))
                                     (f 0))))
  (test-assert "define-matcher without formals"
               (let ()
                 (define-matcher (f dict input) dict)
                 (matcher-procedure? f)))
  (test-assert "define-matcher with formals"
               (let ()
                 (define-matcher ((f a) dict input) dict)
                 (matcher-procedure? (f 0))))
  (test-assert "matcher wrapper"
               (matcher-procedure? ((matcher-wrapper (test-record?
                                                      test-record-val1
                                                      test-record-val2))
                                    #t #f))))

;;; ;;;;;;;;;;;;;
;;; Testing macros

(define (dict=alist? alist dict)
  (call/cc (lambda (return)
             (for-each (lambda (pair)
                         (or (dict-ref (dto) dict
                                       (car pair)
                                       (lambda () #f)
                                       (lambda (x) (equal? x (cdr pair))))
                             (return #f)))
                       alist)
             #t)))

(define (alist? x)
  (or (null? x)
      (and (pair? x)
           (pair? (car x))
           (alist? (cdr x)))))

(define-syntax test-dict=alist
  (syntax-rules ()
    ((_ name %alist %dict)
     (let ((alist %alist)
           (dict %dict))
       (unless (alist? alist)
         (error 'test-dict=alist "not an alist" alist))
       (call-as-test (lambda () (dict=alist? alist dict))
                     (lambda (x)
                       (increment-tests-passed! 1))
                     (lambda (x)
                       (display (list (test-group+ name) alist
                                      '!=
                                      (dict->alist (dto) dict)))
                       (newline)
                       (increment-tests-failed! 1))
                     (lambda (ex)
                       (display (list (test-group+ name)
                                      'exception ex))
                       (newline)))))))

(define-syntax test-matches
  (syntax-rules ()
    ((_ name expected pattern input)
     (test-group name
       (let ((output #f))
         (test-assert "matches"
                      (begin
                        (set! output (setup-backtrack #f (mt pattern
                                                             (empty-dict)
                                                             input)
                                                      #f))
                        (dictionary? (dto) output)))
         (test-dict=alist "stored in dictionary"
                          expected
                          output))))))

(define-syntax test-not-match
  (syntax-rules ()
    ((_ name pattern input)
     (test-eq name (setup-backtrack #f (mt pattern (empty-dict) input) #t)
              #t))))

;;; ;;;;;;;;;;;;;
;;; End testing macros

(test-group "Matching atoms"
  (test-matches "Matching strings"
                '()
                (string #\a #\b #\c #\d)
                (string #\a #\b #\c #\d))
  (test-not-match "Non-matching strings"
                  "abcd"
                  "efgh")
  (test-matches "Matching lists"
                '()
                (list 1 2 3 4)
                (list 1 2 3 4))
  (test-not-match "Non-matching lists"
                  '(1 2 3 4)
                  '(5 6 7 8))
  (test-matches "Matching vectors"
                '()
                '#(1 2 3 4)
                '#(1 2 3 4))
  (test-not-match "Non-matching vectors"
                  '#(1 2 3 4)
                  '#(5 6 7 8))
  (test-matches "Matching numbers" '() 100 100)
  (test-not-match "Non-matching numbers" 100 200)
  (test-matches "Matching symbols" '() 'abcd 'abcd)
  (test-not-match "Non-matching-symbols" 'abcd 'efgh)
  (test-matches "Matching booleans" '() #t #t)
  (test-not-match "Non-matching booleans" #t #f)
  (test-matches "Matching chars" '() #\a #\a)
  (test-not-match "Non-matching chars" #\a #\A)
  (test-matches "Matching null" '() '() '())
  (test-not-match "Disjoint types" '() '(1)))

(test-group "b~"
  (test-matches "null" '((name . (()))) (b~ 'name) '())
  (test-matches "string" '((name . ("abcd"))) (b~ 'name) "abcd")
  (test-matches "list" '((name . ((1 2 3 4)))) (b~ 'name) '(1 2 3 4))
  (test-matches "vector" '((name . (#(1 2 3 4)))) (b~ 'name) '#(1 2 3 4))
  (test-matches "char" '((name . (#\a))) (b~ 'name) #\a)
  (test-matches "boolean" '((name . (#t))) (b~ 'name) #t)
  (test-matches "number" '((name . (10))) (b~ 'name) 10)
  (test-matches "transform"
                '((name . ((#\a #\b #\c #\d)))) (b~ 'name string->list)
                "abcd")
  (test-group "record type"
    (let ((output #f)
          (value (test-record "abcd" "efgh")))
      (test-assert "matches"
                   (begin
                     (set! output (setup-backtrack #f (mt (b~ 'name)
                                                          (empty-dict)
                                                          value)
                                                   #f))
                     (dictionary? (dto) output)))
      (test-eqv "stored in dictionary"
                value
                (dict-ref (dto) output 'name (lambda () #f) car)))))

(define tr~ (matcher-wrapper (test-record? test-record-val1
                                           test-record-val2)))

(test-group "matching matcher-wrapper"
  (test-matches "simple predicates"
                '()
                (tr~ #t #f)
                (test-record #t #f))
  (test-not-match "failure on the first predicate"
                  (tr~ #t #f)
                  (test-record #f #f))
  (test-not-match "failure on the second predicate"
                  (tr~ #t #t)
                  (test-record #t #f))
  (test-matches "matching separate symbols"
                '((a . (#t)) (b . (#f)))
                (tr~ (b~ 'a) (b~ 'b))
                (test-record #t #f))
  (test-matches "matches from left to right"
                '((a . (y x)))
                (tr~ (b~ 'a) (b~ 'a))
                (test-record 'x 'y)))

(test-group "_~"
  (for-each (lambda (name in)
              (test-matches name '() _~ in))
            '("string" "char" "list" "vector" "boolean" "null")
            '("abcd" #\a (1 2 3 4) #(1 2 3 4) #t ())))

(test-group "fail~"
  (for-each (lambda (name in)
              (test-not-match name fail~ in))
            '("string" "char" "list" "vector" "boolean" "null")
            '("abcd" #\a (1 2 3 4) #(1 2 3 4) #t ())))

(test-group "if~"
  (test-matches "matches test and consequent"
                '((a . (b a)))
                (if~ (tr~ (b~ 'a) 'b)
                     (tr~ _~ (b~ 'a))
                     (tr~ _~ (b~ 'b)))
                (test-record 'a 'b))
  (test-not-match "matches test, does not match consequent"
                  (if~ (tr~ 'a _~)
                       (tr~ _~ 'a)
                       (tr~ _~ 'b))
                  (test-record 'a 'b))
  (test-not-match "does not match test"
                  (if~ #t
                       (tr~ #f #f)
                       (tr~ #t #t))
                  (test-record #f #f))
  (test-matches "does not match test, matches alternative"
                '()
                (if~ (tr~ 'a _~)
                     (tr~ _~ 'b)
                     (tr~ 'b 'b))
                (test-record 'b 'b)))

(test-group "if*~"
  (test-matches "matches first test and consequent"
                '((b . (b)))
                (if*~ (tr~ 'a _~) (tr~ _~ (b~ 'b))
                      #f #f)
                (test-record 'a 'b))
  (test-matches "matches second test and consequent"
                '((b . (b)))
                (if*~ #t #t
                      (tr~ 'a _~) (tr~ _~ (b~ 'b)))
                (test-record 'a 'b))
  (test-not-match "matches first test, fails consequent"
                  (if*~ (tr~ 'a _~) (tr~ 'a 'b)
                        (tr~ 'a _~) (tr~ 'a 'a))
                  (test-record 'a 'a))
  (test-not-match "matches second test, fails consequent"
                  (if*~ (tr~ 'b _~) (tr~ 'a 'a)
                        (tr~ 'a _~) (tr~ 'a 'b)
                        (tr~ 'a _~) (tr~ 'a 'a))
                  (test-record 'a 'a))
  (test-not-match "matches no test"
                  (if*~ #t #t)
                  (test-record 'a 'a)))

(test-group "and~"
  (test-matches "empty always matches"
                '()
                (and~)
                #f)
  (test-matches "matching first"
                '((a . (b a)))
                (and~ (tr~ (b~ 'a) (b~ 'a)))
                (test-record 'a 'b))
  (test-matches "matching first and second"
                '((a . (b a)))
                (and~ (tr~ (b~ 'a) _~)
                      (tr~ _~ (b~ 'a)))
                (test-record 'a 'b))
  (test-not-match "matches first, fails second"
                  (and~ (tr~ 'a _~)
                        (tr~ _~ 'a))
                  (test-record 'a 'b)))

(test-group "or~"
  (test-not-match "empty always fails" (or~) #f)
  (test-matches "matching single"
                '((a . (b a)))
                (or~ (tr~ (b~ 'a) (b~ 'a)))
                (test-record 'a 'b))
  (test-matches "matches first and skips the rest"
                '((a . (a)))
                (or~ (tr~ (b~ 'a) _~) (tr~ (b~ 'a) (b~ 'a)))
                (test-record 'a 'b))
  (test-matches "fail to match first, matches second"
                '((a . (b a)))
                (or~ (tr~ (b~ 'c) 'c) (tr~ (b~ 'a) (b~ 'a)))
                (test-record 'a 'b))
  (test-not-match "fails to match any"
                  (or~ (tr~ (b~ 'c) 'c) #t)
                  (test-record 'a 'b)))

(test-group "not~"
  (test-not-match "fails when matching"
                  (not~ (tr~ _~ _~))
                  (test-record 'a 'b))
  (test-matches "matches with input dictionary"
                '()
                (not~ (tr~ _~ _~))
                '(a b c d)))

(test-group "opt~"
  (test-matches "always matches"
                '()
                (opt~ (tr~ (b~ 'a) (b~ 'a)))
                '(a b c d))
  (test-matches "matches and outputs dictionary"
                '((a . (b a)))
                (opt~ (tr~ (b~ 'a) (b~ 'a)))
                (test-record 'a 'b)))

(test-group "as-many~"
  (test-matches "empty always matches"
                '()
                (as-many~)
                (tr~ 'a 'b))
  (test-matches "matches single"
                '((a . (b a)))
                (as-many~ (tr~ (b~ 'a) (b~ 'a)))
                (test-record 'a 'b))
  (test-matches "matches even if subpattern doesn't match, single"
                '()
                (as-many~ (tr~ (b~ 'a) 'a))
                (test-record 'a 'b))
  (test-matches "matches first and second"
                '((a . (b a)))
                (as-many~ (tr~ (b~ 'a) _~)
                          (tr~ _~ (b~ 'a)))
                (test-record 'a 'b))
  (test-matches "matches first, does not match second"
                '((a . (a)))
                (as-many~ (tr~ (b~ 'a) _~)
                          (tr~ _~ (and~ 'a (b~ 'a))))
                (test-record 'a 'b))
  (test-matches "matches second, does not match first"
                '((a . (b)))
                (as-many~ (tr~ 'b _~)
                          (tr~ _~ (and~ 'b (b~ 'a))))
                (test-record 'a 'b)))

(test-group "?~"
  (test-matches "predicate"
                '()
                (?~ pair?)
                '(1 2))
  (test-not-match "does not satisfy predicate"
                  (?~ vector?)
                  '(1 2)))

(test-group "inspect~"
  (test-matches "inspecting the dictionary"
                '()
                (and~ (or~ (tr~ (b~ 'a) (b~ 'b))
                           #t)
                      (inspect~ (lambda (dict)
                                  (not (dict-empty? (dto) dict)))))
                (test-record 'a 'b))
  (test-not-match "fails when the predicate fails"
                  (and~ (or~ (tr~ (b~ 'a) (b~ 'b))
                             #t)
                        (inspect~ (lambda (dict)
                                    (not (dict-empty? (dto) dict)))))
                  #t))

(test-group "xfrm~"
  (test-matches "match after transform"
                '((a . (b a)))
                (xfrm~ test-record-val1 (tr~ (b~ 'a) (b~ 'a)))
                (test-record (test-record 'a 'b)
                             (test-record 'c 'd)))
  (test-not-match "does not match after transforms"
                  (xfrm~ test-record-val1 (tr~ 'a 'b))
                  (test-record 'a 'b)))

(test-group "cut~"
  (test-matches "cut back, successful"
                '()
                (let ((m (vector 0)))
                  (if~ m
                       (or~ (tr~ 'a (cut~ m 'b))
                            (tr~ 'a 'a))
                       _~
                       fail~))
                (test-record 'a 'b))
  (test-not-match "cut back will skip other branches"
                  (let ((m (vector 0)))
                    (if~ m
                         (or~ (tr~ 'a (cut~ m 'b))
                              (tr~ 'a 'a))
                         _~ fail~))
                  (test-record 'a 'a)))

(test-group "=~"
  (test-matches "numerically equal" '() (=~ 100) 100)
  (test-not-match "numerically unequal" (=~ 100) 200)
  (test-matches "signed zero" '() (=~ 0.0) -0.0))

(test-group "=Reps~"
  (test-matches "Equal within" '() (=Reps~ 0.01 100.0) 100.001)
  (test-not-match "Not equal within" (=Reps~ 0.01 100.0) 10.0))

(test-group "signmag~"
  (test-matches "exact zero" '() (signmag~ 1 0) 0)
  (test-matches "inexact zero" '() (signmag~ 1 (=Reps~ 0.01 0)) 0)
  (test-matches "positive number" '() (signmag~ 1 10) 10)
  (test-matches "negative number" '() (signmag~ -1 10) -10)
  (test-not-match "positive for negative" (signmag~ -1 _~) 100)
  (test-not-match "negative for positive" (signmag~ 1 _~) -100)
  (test-not-match "wrong magnitude" (signmag~ _~ 10) 20))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; SKINT and TR7 do not support rational or complex numbers. Worse,
;;; their readers don't support them, so code using complex/rationals
;;; cannot be included in this file directly.

(cond-expand
  ;; If your implementation supports complex number, it probably
  ;; supports this library.
  ((or (library (scheme complex)) full-numeric-tower)
   (include "complex.scm"))
  (else (display "Skipped complex number tests: not supported\n")))

(cond-expand
  ;; Add your implementation here.
  ((not (or tr7 skint)) (include "rational.scm"))
  (else (display "Skipped rational number tests: not supported\n")))

(test-group "Lists and Pairs"
  (test-matches "cons~"
                '((a . (1)) (b . (2)))
                (cons~ (b~ 'a) (b~ 'b))
                (cons 1 2))
  (test-not-match "cons~ on null"
                  (cons _~ _~)
                  '())
  (test-matches "cons*~"
                '()
                (cons*~ 1 2 3 4 5)
                '(1 2 3 4 . 5))
  (test-matches "cons*~ on a proper list"
                '((rest . ((5))))
                (cons*~ 1 2 3 4 (b~ 'rest))
                '(1 2 3 4 5))
  (test-matches "cons*~ matching order"
                '((b . (4 3)) (a . (2 1)))
                (cons*~ (b~ 'a) (b~ 'a) (b~ 'b) (b~ 'b))
                '(1 2 3 . 4))
  (test-not-match "cons* on a list that is too short"
                  (cons*~ _~ _~ _~ _~)
                  '(1 2))
  (test-matches "list~"
                '()
                (list~ 1 2 3 4)
                '(1 2 3 4))
  (test-matches "list~ matching order"
                '((a . (3 1)) (b . (2)))
                (list~ (b~ 'a) (b~ 'b) (b~ 'a))
                '(1 2 3))
  (test-not-match "list~ does not match longer"
                  (list~ 1 2 3)
                  '(1 2 3 4))
  (test-not-match "list~ does not match shorter"
                  (list~ 1 2 3)
                  '(1 2))
  (test-not-match "list~ on improper list"
                  (list~ 1 2 3)
                  '(1 2 . 3))
  (test-not-match "list~ on different type"
                  (list~ 1)
                  '#(1))
  (test-matches "list-tail~ zero"
              '()
              10
              (list-tail~ 0 10))
  (test-matches "list-tail~ 1"
              '()
              (list-tail~ 1 (list~ 1 2))
              '(0 1 2))
  (test-matches "list-tail~ 2"
              '((a . (x)))
              (list-tail~ 2 (list~ 1 (b~ 'a)))
              '(0 0 1 x))
  (test-not-match "list larger than n in list-tail"
                  (list-tail~ 2 '())
                  '(1))
  (test-matches "list-ref~"
              '((three . (3)))
              (list-ref~ 2 (b~ 'three))
              '(1 2 3))
  (test-matches "list-ref~ on longer lists"
              '()
              (list-ref~ 3 4)
              '(1 2 3 4 5))
  (test-not-match "list-ref~ on smaller lists"
                  (list-ref~ 3 3)
                  '(1 2))
  (test-matches "member-tail~"
              '((rest . ((6 7))))
              (member-tail~ (cons~ 5 (b~ 'rest)))
              '(4 5 6 7))
  (test-matches "member-tail~ matches first"
              '((rest . ((5 5))))
              (member-tail~ (cons~ 5 (b~ 'rest)))
              '(3 4 5 5 5))
  (test-matches "member-tail~ on improper list"
              '()
              (member-tail~ 5)
              '(1 2 3 4 . 5))
  (test-not-match "member-tail~ not finding element"
                  (member-tail~ (cons~ 5 _~))
                  '(1 2 3 4))
  (test-matches "member~"
              '()
              (member~ 3)
              '(1 2 3 4 5))
  (test-matches "member~ matches first and once"
              '((match . (5)))
              (member~ (and~ 5 (b~ 'match)))
              '(3 4 5 5 5))
  (test-not-match "member~ where element is not in list"
                  (member~ (cons~ 3 _~))
                  '(1 2 3 4 5))
  (test-matches "assoc~"
              '((val . (6)))
              (assoc~ 5 (b~ 'val))
              '((1 . 2) (3 . 4) (5 . 6) (7 . 8)))
  (test-matches "assoc~ matches first and once"
              '((val . (6)))
              (assoc~ 5 (b~ 'val))
              '((3 . 4) (5 . 6) (5 . 7) (5 . 8)))
  (test-not-match "assoc~ where key is not found"
                  (assoc~ 5 (b~ 'val))
                  '((1 . 2) (3 . 4)))
  (test-matches "every~"
              '()
              (every~ (?~ number?))
              '(1 2 3 4 5))
  (test-matches "every~ matching order"
              '((value . (5 4 3 2 1)))
              (every~ (and (?~ number?) (b~ 'value)))
              '(1 2 3 4 5))
  (test-not-match "not every~"
                  (every~ (?~ number?))
                  '(1 2 3 4 x))
  (test-matches "list*~"
              '((rest . ((x y z))))
              (list*~ (?~ number?) (b~ 'rest))
              '(1 2 3 4 x y z))
  (test-matches "list*~ always succeeds"
              '((rest . ((x y z))))
              (list*~ (?~ number?) (b~ 'rest))
              '(x y z))
  (test-matches "list*~ succeeding for all elements"
              '((rest . (())))
              (list*~ (?~ number?) (b~ 'rest))
              '(1 2 3)))

(test-group "vector~"
  (test-matches "vector~"
                '()
                (vector~ 1 2 3)
                '#(1 2 3))
  (test-matches "vector~ match order"
                '((a . (3 2 1)))
                (vector~ (b~ 'a) (b~ 'a) (b~ 'a))
                '#(1 2 3))
  (test-not-match "vector~ fails on too short length"
                  (vector~ 1 2 3)
                  '#(1 2))
  (test-not-match "vector~ fails on too long length"
                  (vector~ 1 2 3)
                  '#(1 2 3 4))
  (test-not-match "vector~ on other types"
                  (vector~ 1 2)
                  '(1 2))
  (test-matches "vector-ref~"
                '((second . (2)))
                (vector-ref~ 1 (b~ 'second))
                '#(1 2))
  (test-not-match "vector-ref~ fails on too short vector"
                  (vector-ref~ 1 (b~ 'second))
                  '#(1))
  (test-not-match "vector-ref~ fails on other types"
                  (vector-ref~ 1 (b~ 'second))
                  '(1 2)))

(test-group "match"
  (test-assert "simple match"
               (match '(1 2 3 4) dict
                 ((list~ 1 2 3) #f)
                 ((list~ 1 2 3 4) #t)
                 (_~ #f)))
  (test-assert "binding values in reverse"
               (match-rev '(1 2 3 4) dict
                 ((list~ (b~ 'a) (b~ 'b) (b~ 'c)) #f)
                 ((list~ (b~ 'a) (b~ 'a) (b~ 'a) 4)
                  (equal? (dict-ref (dto) dict 'a) '(3 2 1)))))
  (test-eqv "binding values"
            2
            (match '(1 2 3 4) dict
              ((list~ (b~ 'a) (b~ 'b) (b~ 'c)) 1)
              ((list~ (b~ 'a) (b~ 'a) (b~ 'b) 4)
               (and (equal? (dict-ref (dto) dict 'a) '(1 2))
                    (equal? (dict-ref (dto) dict 'b) '(3))
                    2))))
  (test-assert "binding values, procedure"
               (match-pr '(1 2 3 4) (r r1)
                 ((list~ (b~ 'a) (b~ 'b) (b~ 'c)) #f)
                 ((list~ (b~ 'a) (b~ 'a) (b~ 'b) 4)
                  (and (equal? (r 'a) '(1 2))
                       (equal? (r1 'b) 3))))))

(test-exit)