(module test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "contract.ss")
(lib "etc.ss")
"equiv.ss")
(define-struct alpha (left right) #f)
(define-struct beta (left right) #f)
(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))
)