69 lines
2.0 KiB
Scheme
69 lines
2.0 KiB
Scheme
|
; 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)))))
|