ikarus/scheme/ikarus.equal.ss

164 lines
5.3 KiB
Scheme

;;; Copied from
;;; Efficient Nondestructive Equality Checking for Trees and Graphs
;;; Michael D. Adams and R. Kent Dybvig
;;; ICFP 2008
(library (ikarus.equal)
(export equal?)
(import (except (ikarus) equal?))
(module UNSAFE
(< <= > >= = + - vector-ref vector-length car cdr)
(import
(rename (ikarus system $vectors)
($vector-length vector-length)
($vector-ref vector-ref))
(rename (ikarus system $pairs)
($car car)
($cdr cdr))
(rename (ikarus system $fx)
($fx+ +)
($fx- -)
($fx< <)
($fx> >)
($fx>= >=)
($fx<= <=)
($fx= =))))
(define (union-find ht x y)
(import UNSAFE)
(define-struct box (content))
(define eq-hashtable-ref hashtable-ref)
(define eq-hashtable-set! hashtable-set!)
(define (find b)
(let ([n (box-content b)])
(if (box? n)
(let loop ([b b] [n n])
(let ([nn (box-content n)])
(if (box? nn) (begin (set-box-content! b nn) (loop n nn)) n)))
b)))
(let ([bx (eq-hashtable-ref ht x #f)]
[by (eq-hashtable-ref ht y #f)])
(if (not bx)
(if (not by)
(let ([b (make-box 1)])
(eq-hashtable-set! ht x b)
(eq-hashtable-set! ht y b)
#f)
(let ([ry (find by)]) (eq-hashtable-set! ht x ry) #f))
(if (not by)
(let ([rx (find bx)]) (eq-hashtable-set! ht y rx) #f)
(let ([rx (find bx)] [ry (find by)])
(or (eq? rx ry)
(let ([nx (box-content rx)] [ny (box-content ry)])
(if (> nx ny)
(begin
(set-box-content! ry rx)
(set-box-content! rx (+ nx ny))
#f)
(begin
(set-box-content! rx ry)
(set-box-content! ry (+ ny nx))
#f)))))))))
(define (pre? x y k)
(import UNSAFE)
(cond
[(eq? x y) k]
[(pair? x)
(and (pair? y)
(if (<= k 0)
k
(let ([k (pre? (car x) (car y) (- k 1))])
(and k (pre? (cdr x) (cdr y) k)))))]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (= (vector-length y) n)
(let f ([i 0] [k k])
(if (or (= i n) (<= k 0))
k
(let ([k (pre?
(vector-ref x i)
(vector-ref y i)
(- k 1))])
(and k (f (+ i 1) k))))))))]
[(string? x) (and (string? y) (string=? x y) k)]
[else (and (eqv? x y) k)]))
(define (interleave? x y k)
(import UNSAFE)
(let ([ht #f])
(define (call-union-find x y)
(unless ht (set! ht (make-eq-hashtable)))
(union-find ht x y))
(define (e? x y k)
(if (<= k 0)
(if (= k kb) (fast? x y (random (* 2 k0))) (slow? x y k))
(fast? x y k)))
(define (slow? x y k)
(cond
[(eq? x y) k]
[(pair? x)
(and (pair? y)
(if (call-union-find x y)
0
(let ([k (e? (car x) (car y) (- k 1))])
(and k (e? (cdr x) (cdr y) k)))))]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (= (vector-length y) n)
(if (call-union-find x y)
0
(let f ([i 0] [k (- k 1)])
(if (= i n)
k
(let ([k (e? (vector-ref x i)
(vector-ref y i)
k)])
(and k (f (+ i 1) k)))))))))]
[(string? x) (and (string? y) (string=? x y) k)]
[else (and (eqv? x y) k)]))
(define (fast? x y k)
(let ([k (- k 1)])
(cond
[(eq? x y) k]
[(pair? x)
(and (pair? y)
(let ([k (e? (car x) (car y) k)])
(and k (e? (cdr x) (cdr y) k))))]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (= (vector-length y) n)
(let f ([i 0] [k k])
(if (= i n)
k
(let ([k (e? (vector-ref x i)
(vector-ref y i)
k)])
(and k (f (+ i 1) k))))))))]
[(string? x) (and (string? y) (string=? x y) k)]
[else (and (eqv? x y) k)])))
(and (e? x y k) #t)))
(define k0 400)
(define kb -40)
(define (interleave-equal? x y)
(interleave? x y k0))
(define (precheck/interleave-equal? x y)
(let ([k (pre? x y k0)])
(and k (or (> k 0) (interleave? x y 0)))))
(define (equal? x y)
(precheck/interleave-equal? x y))
)