ikarus/scheme/ikarus.equal.ss

;;; 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)]
      [(bytevector? x) (and (bytevector? y) (bytevector=? 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)]
          [(bytevector? x) (and (bytevector? y) (bytevector=? 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)]
            [(bytevector? x) (and (bytevector? y) (bytevector=? 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))

  )