(module test mzscheme

  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 (= 2)))
           (lib "contract.ss")
           (lib "etc.ss")
           "equiv.ss")

  (provide/contract
   [test test-suite?])

  ;; Transparent
  (define-struct alpha (left right) #f)
  (define-struct beta (left right) #f)

  ;; Opaque
  (define-struct gamma (left right))
  (define-struct delta (left right))

  (define =? (make-equiv default-equiv-rules))

  (define test
    (make-test-suite "Extensible Recursive Equivalence"
      (make-test-suite "default equivalence"
        (make-test-suite "mismatched types"
          (make-test-case "null != pair"
            (assert-false (=? null (cons null null))))
          (make-test-case "void != box"
            (assert-false (=? (void) (box (void)))))
          (make-test-case "boolean != vector"
            (assert-false (=? #t (vector #t #f))))
          (make-test-case "symbol != hash table"
            (assert-false (=? 'sym (make-hash-table))))
          (make-test-case "character != string"
            (assert-false (=? #\c "string")))
          (make-test-case "number != byte string"
            (assert-false (=? 1 (bytes 1 2 3))))
          (make-test-case "transparent1 != transparent2"
            (assert-false (=? (make-alpha 1 2) (make-beta 1 2))))
          (make-test-case "opaque1 != opaque2"
            (assert-false (=? (make-gamma 1 2) (make-delta 1 2)))))
        (make-test-suite "leaf types"
          (make-test-case "null"
            (assert-true (=? null null)))
          (make-test-case "void"
            (assert-true (=? (void) (void))))
          (make-test-suite "boolean"
            (make-test-case "true = true"
              (assert-true (=? #t #t)))
            (make-test-case "false = false"
              (assert-true (=? #f #f)))
            (make-test-case "false != true"
              (assert-false (=? #f #t)))
            (make-test-case "true != false"
              (assert-false (=? #t #f))))
          (make-test-suite "symbol"
            (make-test-case "same"
              (assert-true (=? 'same 'same)))
            (make-test-case "different"
              (assert-false (=? 'same 'different))))
          (make-test-suite "character"
            (make-test-case "same"
              (assert-true (=? #\a #\a)))
            (make-test-case "different"
              (assert-false (=? #\a #\b))))
          (make-test-suite "number"
            (make-test-case "same"
              (assert-true (=? 100 100)))
            (make-test-case "exact = inexact"
              (assert-true (=? 1/2 0.5)))
            (make-test-case "bignum = bignum"
              (assert-true (=? (expt 10 1000) (expt 10 1000))))
            (make-test-case "different"
              (assert-false (=? 0 1))))
          (make-test-suite "string"
            (make-test-case "same"
              (let ([str "string"])
                (assert-true (=? str str))))
            (make-test-case "copy = copy"
              (let ([str "string"])
                (assert-true (=? str (string-copy str)))))
            (make-test-case "different"
              (assert-false (=? "cat" "dog"))))
          (make-test-suite "byte string"
            (make-test-case "same"
              (let ([b (bytes 1 2 3)])
                (assert-true (=? b b))))
            (make-test-case "copy = copy"
              (let ([b (bytes 1 2 3)])
                (assert-true (=? b (bytes-copy b)))))
            (make-test-case "different"
              (assert-false (=? (bytes 1 2 3) (bytes 2 3 4))))))
        (make-test-suite "node types"
          (make-test-suite "pair"
            (make-test-case "same"
              (let* ([p (cons 1 2)])
                (assert-true (=? p p))))
            (make-test-case "copy"
              (assert-true (=? (cons 1 2) (cons 1 2))))
            (make-test-case "different car"
              (assert-false (=? (cons 1 2) (cons 0 2))))
            (make-test-case "different cdr"
              (assert-false (=? (cons 1 2) (cons 1 3))))
            (make-test-case "recursive same"
              (assert-true
               (=? '((1 . 2) . (3 . 4)) '((1 . 2) . (3 . 4)))))
            (make-test-case "recursive different"
              (assert-false
               (=? '((1 . 2) . (3 . 4)) '((4 . 3) . (2 . 1))))))
          (make-test-suite "box"
            (make-test-case "same"
              (let* ([b (box 1)])
                (assert-true (=? b b))))
            (make-test-case "copy"
              (assert-true (=? (box 1) (box 1))))
            (make-test-case "different"
              (assert-false (=? (box 1) (box 2))))
            (make-test-case "recursive same"
              (assert-true (=? (box (box 1)) (box (box 1)))))
            (make-test-case "recursive different"
              (assert-false (=? (box (box 1)) (box (box 2))))))
          (make-test-suite "vector"
            (make-test-case "same"
              (let* ([v (vector 1 2 3)])
                (assert-true (=? v v))))
            (make-test-case "copy"
              (assert-true (=? (vector 1 2 3) (vector 1 2 3))))
            (make-test-case "different"
              (assert-false (=? (vector 1 2 3) (vector 2 3 4))))
            (make-test-case "recursive same"
              (assert-true (=? (vector (vector 1 2 3)
                                       (vector 4 5 6)
                                       (vector 7 8 9))
                               (vector (vector 1 2 3)
                                       (vector 4 5 6)
                                       (vector 7 8 9)))))
            (make-test-case "recursive different"
              (assert-false (=? (vector (vector 1 2 3)
                                        (vector 4 5 6)
                                        (vector 7 8 9))
                                (vector (vector 1 4 7)
                                        (vector 2 5 8)
                                        (vector 3 6 9))))))
          (make-test-suite "hash table"
            (make-test-case "same"
              (let* ([h (hash-table ['a 1] ['b 2] ['c 3])])
                (assert-true (=? h h))))
            (make-test-case "copy"
              (assert-true (=? (hash-table ['a 1] ['b 2] ['c 3])
                               (hash-table ['a 1] ['b 2] ['c 3]))))
            (make-test-case "different"
              (assert-false (=? (hash-table ['a 1] ['b 2])
                                (hash-table ['b 2] ['c 3]))))
            (make-test-case "recursive same"
              (assert-true
               (=? (hash-table ['a (hash-table ['i 1] ['j 2])]
                               ['b (hash-table ['x 3] ['y 4])])
                   (hash-table ['a (hash-table ['i 1] ['j 2])]
                               ['b (hash-table ['x 3] ['y 4])]))))
            (make-test-case "recursive different"
              (assert-false
               (=? (hash-table ['a (hash-table ['i 1] ['j 2])]
                               ['b (hash-table ['x 3] ['y 4])])
                   (hash-table ['a (hash-table ['i 5] ['j 6])]
                               ['b (hash-table ['x 7] ['y 8])]))))))
        (make-test-suite "opaque types"
          (make-test-case "same"
            (let* ([o (make-gamma 1 2)])
              (assert-true (=? o o))))
          (make-test-case "different"
            (assert-false (=? (make-gamma 1 2) (make-gamma 1 2)))))
        (make-test-suite "transparent types"
          (make-test-case "same"
            (let* ([t (make-alpha 1 2)])
              (assert-true (=? t t))))
          (make-test-case "copy"
            (assert-true (=? (make-alpha 1 2) (make-alpha 1 2))))
          (make-test-case "different"
            (assert-false (=? (make-alpha 1 2) (make-alpha 3 4))))
          (make-test-case "recursive same"
            (assert-true (=? (make-alpha (make-alpha 1 2)
                                         (make-alpha 3 4))
                             (make-alpha (make-alpha 1 2)
                                         (make-alpha 3 4)))))
          (make-test-case "recursive different"
            (assert-false (=? (make-alpha (make-alpha 1 2)
                                          (make-alpha 3 4))
                              (make-alpha (make-alpha 4 3)
                                          (make-alpha 2 1))))))
        (make-test-suite "circular equivalence"
          (make-test-case "same"
            (let* ([b (box null)])
              (assert-true (=? b b))))
          (make-test-case "copy"
            (let* ([a (box null)]
                   [b (box null)])
              (set-box! a a)
              (set-box! b b)
              (assert-true (=? a b))))
          (make-test-case "different"
            (let* ([a (cons null 1)]
                   [b (cons null 2)])
              (set-car! a a)
              (set-car! b b)
              (assert-false (=? a b))))
          (make-test-case "heterogenous same"
            (let* ([a1 (box null)]
                   [b1 (box a1)]
                   [c1 (cons a1 b1)]
                   [a2 (box null)]
                   [b2 (box a2)]
                   [c2 (cons a2 b2)])
              (set-box! a1 c1)
              (set-box! a2 c2)
              (assert-true (=? c1 c2))))
          (make-test-case "heterogenous different"
            (let* ([a1 (box null)]
                   [b1 (cons a1 1)]
                   [c1 (cons a1 b1)]
                   [a2 (box null)]
                   [b2 (cons a2 2)]
                   [c2 (cons a2 b2)])
              (set-box! a1 c1)
              (set-box! a2 c2)
              (assert-false (=? c1 c2))))
          (make-test-case "different graph structure"
            (let* ([a1 (box null)]
                   [c1 (cons a1 a1)]
                   [a2 (box null)]
                   [b2 (box null)]
                   [c2 (cons a2 b2)])
              (set-car! c1 a1)
              (set-cdr! c1 a1)
              (set-car! c2 a2)
              (set-cdr! c2 b2)
              (assert-true (=? c1 c2))))))))

  (define (test/text)
    ((dynamic-require
      '(planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 (= 2)))
      'test/text-ui)
     test))

  (define (test/gui)
    ((dynamic-require
      '(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1 (= 2)))
      'test/graphical-ui)
     test))

  )