test.ss
(module test mzscheme

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

  ;; 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 unbox=?
    (make-equiv
     (add-binary-equiv-rule
      (lambda (a b) (box? a))
      (lambda (=? a b) (=? (unbox a) b))
      default-equiv-rules)))

  (define test
    (test-suite "Extensible Recursive Equivalence"
      (test-suite "default equivalence"
        (test-suite "mismatched types"
          (test-case "null != pair"
            (check-false (=? null (cons null null))))
          (test-case "void != box"
            (check-false (=? (void) (box (void)))))
          (test-case "boolean != vector"
            (check-false (=? #t (vector #t #f))))
          (test-case "symbol != hash table"
            (check-false (=? 'sym (make-hash-table))))
          (test-case "character != string"
            (check-false (=? #\c "string")))
          (test-case "number != byte string"
            (check-false (=? 1 (bytes 1 2 3))))
          (test-case "transparent1 != transparent2"
            (check-false (=? (make-alpha 1 2) (make-beta 1 2))))
          (test-case "opaque1 != opaque2"
            (check-false (=? (make-gamma 1 2) (make-delta 1 2)))))
        (test-suite "leaf types"
          (test-case "null"
            (check-true (=? null null)))
          (test-case "void"
            (check-true (=? (void) (void))))
          (test-suite "boolean"
            (test-case "true = true"
              (check-true (=? #t #t)))
            (test-case "false = false"
              (check-true (=? #f #f)))
            (test-case "false != true"
              (check-false (=? #f #t)))
            (test-case "true != false"
              (check-false (=? #t #f))))
          (test-suite "symbol"
            (test-case "same"
              (check-true (=? 'same 'same)))
            (test-case "different"
              (check-false (=? 'same 'different))))
          (test-suite "character"
            (test-case "same"
              (check-true (=? #\a #\a)))
            (test-case "different"
              (check-false (=? #\a #\b))))
          (test-suite "number"
            (test-case "same"
              (check-true (=? 100 100)))
            (test-case "exact = inexact"
              (check-true (=? 1/2 0.5)))
            (test-case "bignum = bignum"
              (check-true (=? (expt 10 1000) (expt 10 1000))))
            (test-case "different"
              (check-false (=? 0 1))))
          (test-suite "string"
            (test-case "same"
              (let ([str "string"])
                (check-true (=? str str))))
            (test-case "copy = copy"
              (let ([str "string"])
                (check-true (=? str (string-copy str)))))
            (test-case "different"
              (check-false (=? "cat" "dog"))))
          (test-suite "byte string"
            (test-case "same"
              (let ([b (bytes 1 2 3)])
                (check-true (=? b b))))
            (test-case "copy = copy"
              (let ([b (bytes 1 2 3)])
                (check-true (=? b (bytes-copy b)))))
            (test-case "different"
              (check-false (=? (bytes 1 2 3) (bytes 2 3 4))))))
        (test-suite "node types"
          (test-suite "pair"
            (test-case "same"
              (let* ([p (cons 1 2)])
                (check-true (=? p p))))
            (test-case "copy"
              (check-true (=? (cons 1 2) (cons 1 2))))
            (test-case "different car"
              (check-false (=? (cons 1 2) (cons 0 2))))
            (test-case "different cdr"
              (check-false (=? (cons 1 2) (cons 1 3))))
            (test-case "recursive same"
              (check-true
               (=? '((1 . 2) . (3 . 4)) '((1 . 2) . (3 . 4)))))
            (test-case "recursive different"
              (check-false
               (=? '((1 . 2) . (3 . 4)) '((4 . 3) . (2 . 1))))))
          (test-suite "box"
            (test-case "same"
              (let* ([b (box 1)])
                (check-true (=? b b))))
            (test-case "copy"
              (check-true (=? (box 1) (box 1))))
            (test-case "different"
              (check-false (=? (box 1) (box 2))))
            (test-case "recursive same"
              (check-true (=? (box (box 1)) (box (box 1)))))
            (test-case "recursive different"
              (check-false (=? (box (box 1)) (box (box 2))))))
          (test-suite "vector"
            (test-case "same"
              (let* ([v (vector 1 2 3)])
                (check-true (=? v v))))
            (test-case "copy"
              (check-true (=? (vector 1 2 3) (vector 1 2 3))))
            (test-case "different"
              (check-false (=? (vector 1 2 3) (vector 2 3 4))))
            (test-case "recursive same"
              (check-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)))))
            (test-case "recursive different"
              (check-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))))))
          (test-suite "hash table"
            (test-case "same"
              (let* ([h (hash-table ['a 1] ['b 2] ['c 3])])
                (check-true (=? h h))))
            (test-case "copy"
              (check-true (=? (hash-table ['a 1] ['b 2] ['c 3])
                              (hash-table ['a 1] ['b 2] ['c 3]))))
            (test-case "different"
              (check-false (=? (hash-table ['a 1] ['b 2])
                               (hash-table ['b 2] ['c 3]))))
            (test-case "recursive same"
              (check-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])]))))
            (test-case "recursive different"
              (check-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])]))))))
        (test-suite "opaque types"
          (test-case "same"
            (let* ([o (make-gamma 1 2)])
              (check-true (=? o o))))
          (test-case "different"
            (check-false (=? (make-gamma 1 2) (make-gamma 1 2)))))
        (test-suite "transparent types"
          (test-case "same"
            (let* ([t (make-alpha 1 2)])
              (check-true (=? t t))))
          (test-case "copy"
            (check-true (=? (make-alpha 1 2) (make-alpha 1 2))))
          (test-case "different"
            (check-false (=? (make-alpha 1 2) (make-alpha 3 4))))
          (test-case "recursive same"
            (check-true (=? (make-alpha (make-alpha 1 2)
                                        (make-alpha 3 4))
                            (make-alpha (make-alpha 1 2)
                                        (make-alpha 3 4)))))
          (test-case "recursive different"
            (check-false (=? (make-alpha (make-alpha 1 2)
                                         (make-alpha 3 4))
                             (make-alpha (make-alpha 4 3)
                                         (make-alpha 2 1))))))
        (test-suite "circular equivalence"
          (test-case "same"
            (let* ([b (box null)])
              (check-true (=? b b))))
          (test-case "copy"
            (let* ([a (box null)]
                   [b (box null)])
              (set-box! a a)
              (set-box! b b)
              (check-true (=? a b))))
          (test-case "different"
            (let* ([a (cons null 1)]
                   [b (cons null 2)])
              (set-car! a a)
              (set-car! b b)
              (check-false (=? a b))))
          (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)
              (check-true (=? c1 c2))))
          (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)
              (check-false (=? c1 c2))))
          (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)
              (check-true (=? c1 c2))))))
      (test-suite "unboxing equivalence"
        (test-case "unboxed flat same"
          (check-true (unbox=? 1 1)))
        (test-case "unboxed flat diff"
          (check-false (unbox=? 1 2)))
        (test-case "unboxed recursive same"
          (check-true (unbox=? '(1 (2 3) 4) '(1 (2 3) 4))))
        (test-case "unboxed recursive diff"
          (check-false (unbox=? '(1 (2 3) 4) '(1 (3 2) 4))))
        (test-case "symmetric boxed same"
          (check-true (unbox=? (box 1) (box 1))))
        (test-case "symmetric boxed diff"
          (check-false (unbox=? (box 1) (box 2))))
        (test-case "asymmetric boxed same"
          (check-true (unbox=? (box (list (box (box 1)) 2))
                               (box (box (list (box 1) (box 2)))))))
        (test-case "asymmetric boxed diff"
          (check-false (unbox=? (box (list (box (box 1)) 2))
                                (box (box (list (box 1) (box 1))))))))))

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

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

  )