ref: 93e8ec486116f772eef858ec35135e78d8ca1af6
dir: /test/equal.scm/
; Terminating equal predicate
; by Jeff Bezanson
;
; This version only considers pairs and simple atoms.
; equal?, with bounded recursion. returns 0 if we suspect
; nontermination, otherwise #t or #f for the correct answer.
(define (bounded-equal a b N)
(cond ((<= N 0) 0)
((and (pair? a) (pair? b))
(let ((as
(bounded-equal (car a) (car b) (- N 1))))
(if (number? as)
0
(and as
(bounded-equal (cdr a) (cdr b) (- N 1))))))
(else (eq? a b))))
; union-find algorithm
; find equivalence class of a cons cell, or #f if not yet known
; the root of a class is a cons that is its own class
(define (class table key)
(let ((c (hashtable-ref table key #f)))
(if (or (not c) (eq? c key))
c
(class table c))))
; move a and b to the same equivalence class, given c and cb
; as the current values of (class table a) and (class table b)
; Note: this is not quite optimal. We blindly pick 'a' as the
; root of the new class, but we should pick whichever class is
; larger.
(define (union! table a b c cb)
(let ((ca (if c c a)))
(if cb
(hashtable-set! table cb ca))
(hashtable-set! table a ca)
(hashtable-set! table b ca)))
; cyclic equal. first, attempt to compare a and b as best
; we can without recurring. if we can't prove them different,
; set them equal and move on.
(define (cyc-equal a b table)
(cond ((eq? a b) #t)
((not (and (pair? a) (pair? b))) (eq? a b))
(else
(let ((aa (car a)) (da (cdr a))
(ab (car b)) (db (cdr b)))
(cond ((or (not (eq? (atom? aa) (atom? ab)))
(not (eq? (atom? da) (atom? db)))) #f)
((and (atom? aa)
(not (eq? aa ab))) #f)
((and (atom? da)
(not (eq? da db))) #f)
(else
(let ((ca (class table a))
(cb (class table b)))
(if (and ca cb (eq? ca cb))
#t
(begin (union! table a b ca cb)
(and (cyc-equal aa ab table)
(cyc-equal da db table)))))))))))
(define (equal a b)
(let ((guess (bounded-equal a b 2048)))
(if (boolean? guess) guess
(cyc-equal a b (make-eq-hashtable)))))