From 766eb7f5392842d64d9d5a6e6fc8753d4a5025a3 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 11 Nov 2008 00:39:02 -0500
Subject: [PATCH] - fixed equal? to terminate on all inputs as mandated by
 R6RS.   (thanks to Michael Adams and Kent Dybvig for making the code   
 available in its entirety in their ICFP 2008 paper)

---
 scheme/Makefile.am          |   2 +-
 scheme/Makefile.in          |   2 +-
 scheme/ikarus.equal.ss      | 166 ++++++++++++++++++++++++++++++++++++
 scheme/ikarus.predicates.ss |  37 +-------
 scheme/last-revision        |   2 +-
 scheme/makefile.ss          |   1 +
 6 files changed, 172 insertions(+), 38 deletions(-)
 create mode 100644 scheme/ikarus.equal.ss

diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index e7fa6c3..45ce157 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -28,7 +28,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
   ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
   ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
-  ikarus.reader.annotated.ss ikarus.pointers.ss
+  ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss
  
 all: $(nodist_pkglib_DATA)
 
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index e64a161..35f7a0d 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -183,7 +183,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
   ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
   ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
-  ikarus.reader.annotated.ss ikarus.pointers.ss
+  ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss
 
 revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
 sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g")
diff --git a/scheme/ikarus.equal.ss b/scheme/ikarus.equal.ss
new file mode 100644
index 0000000..ad68ca6
--- /dev/null
+++ b/scheme/ikarus.equal.ss
@@ -0,0 +1,166 @@
+
+
+;;; 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 eq-hashtable-ref hashtable-ref)
+  (define eq-hashtable-set! hashtable-set!)
+
+  (define-struct box (content))
+
+  (define (union-find ht x y)
+    (import UNSAFE)
+    (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))
+
+  )
diff --git a/scheme/ikarus.predicates.ss b/scheme/ikarus.predicates.ss
index e861ba5..476b255 100644
--- a/scheme/ikarus.predicates.ss
+++ b/scheme/ikarus.predicates.ss
@@ -20,7 +20,7 @@
           number? complex? real? rational?
           integer? exact? inexact? eof-object? bwp-object? immediate?
           boolean? char? vector? bytevector? string? procedure? null? pair?
-          symbol? code? not weak-pair? eq? eqv? equal? boolean=?
+          symbol? code? not weak-pair? eq? eqv? boolean=?
           symbol=? finite? infinite? nan? real-valued?
           rational-valued? integer-valued? transcoder?)
   (import 
@@ -28,7 +28,7 @@
             number? complex? real?
             rational? integer? exact? inexact? eof-object? bwp-object?
             immediate? boolean? char? vector? bytevector? string? procedure?
-            null? pair? weak-pair? symbol? code? not eq? eqv? equal?
+            null? pair? weak-pair? symbol? code? not eq? eqv? 
             transcoder? boolean=? symbol=?
             finite? infinite? nan? real-valued? rational-valued? 
             integer-valued?)
@@ -313,39 +313,6 @@
   (define-pred symbol=? sys:symbol? "not a symbol")
   (define-pred boolean=? sys:boolean? "not a boolean")
 
-  (module (equal?)
-    (define vector-loop
-      (lambda (x y i n)
-        (or ($fx= i n)
-            (and (equal? ($vector-ref x i) ($vector-ref y i))
-                 (vector-loop x y ($fxadd1 i) n)))))
-    (define string-loop
-      (lambda (x y i n)
-        (or ($fx= i n)
-            (and ($char= ($string-ref x i) ($string-ref y i))
-                 (string-loop x y ($fxadd1 i) n)))))
-    (define equal?
-      (lambda (x y)
-        (cond
-          [(sys:eq? x y) #t]
-          [(pair? x) 
-           (and (pair? y)
-                (equal? ($car x) ($car y))
-                (equal? ($cdr x) ($cdr y)))]
-          [(vector? x)
-           (and (vector? y)
-                (let ([n ($vector-length x)])
-                  (and ($fx= n ($vector-length y))
-                       (vector-loop x y 0 n))))]
-          [(string? x)
-           (and (string? y)
-                (let ([n ($string-length x)])
-                  (and ($fx= n ($string-length y))
-                       (string-loop x y 0 n))))]
-          [(sys:bytevector? x)
-           (and (sys:bytevector? y) (bytevector=? x y))]
-          [(number? x) (eqv? x y)]
-          [else #f]))))
 
 
   )
diff --git a/scheme/last-revision b/scheme/last-revision
index 8912fa1..a8a4f74 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1665
+1666
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 7f18925..22efd2e 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -58,6 +58,7 @@
     "ikarus.collect.ss"
     "ikarus.apply.ss"
     "ikarus.predicates.ss"
+    "ikarus.equal.ss"
     "ikarus.pairs.ss"
     "ikarus.lists.ss"
     "ikarus.fixnums.ss"