[gambit-list] Implementation of equal? for recursive structures
Adam
adam.mlmb at gmail.com
Thu Sep 14 07:22:49 EDT 2017
Nice idea!
What about also adding an equality-hashing algorithm for cyclical
structures this way also, so hashtables could work also?
2017-09-14 16:15 GMT+08:00 Dimitris Vyzovitis <vyzo at hackzen.org>:
> Marc,
>
> Can we get an implementation of equal? that works for recursive structures
> per r7rs?
> It doesn't need to be called equal?, it can be called equal-shared? for
> instance.
>
> I have an initial implementation that works with shared structures, but
> there is an edge case:
> If there is a shared object in the structure (without recursion) it needs
> to be eq? to its counterpart.
>
> (def (r7rs-equal? obj1 obj2)
> (def ht (make-hash-table-eq))
>
> (def (equal obj1 obj2)
> (cond
> ((##eq? obj1 obj2))
> ((immediate? obj1) #f) ; should be eq?
> ((number? obj1)
> (##eqv? obj1 obj2))
> ((##table-ref ht obj1 #f)
> => (cut ##eq? <> obj2)) ; edge case mentioned above
> ((##pair? obj1)
> (and (##pair? obj2)
> (begin
> (##table-set! ht obj1 obj2)
> (and (equal (##car obj1) (##car obj2))
> (equal (##cdr obj1) (##cdr obj2))))))
> ((##vector? obj1)
> (and (##vector? obj2)
> (let (len (##vector-length obj1))
> (and (##fx= len (##vector-length obj2))
> (begin (##table-set! ht obj1 obj2)
> (vector-equal obj1 obj2 0 len))))))
> ((##string? obj2)
> (and (##string? obj2)
> (##string-equal? obj1 obj2)))
> ((##u8vector? obj1)
> (and (##u8vector? obj2)
> (##u8vector-equal? obj1 obj2)))
> ((##s8vector? obj1)
> (and (##s8vector? obj2)
> (##s8vector-equal? obj1 obj2)))
> ((##u16vector? obj1)
> (and (##u16vector? obj2)
> (##u16vector-equal? obj1 obj2)))
> ((##s16vector? obj1)
> (and (##s16vector? obj2)
> (##s16vector-equal? obj1 obj2)))
> ((##u32vector? obj1)
> (and (##u32vector? obj2)
> (##u32vector-equal? obj1 obj2)))
> ((##s32vector? obj1)
> (and (##s32vector? obj2)
> (##s32vector-equal? obj1 obj2)))
> ((##u64vector? obj1)
> (and (##u64vector? obj2)
> (##u64vector-equal? obj1 obj2)))
> ((##s64vector? obj1)
> (and (##s64vector? obj2)
> (##s64vector-equal? obj1 obj2)))
> ((##f32vector? obj1)
> (and (##f32vector? obj2)
> (##f32vector-equal? obj1 obj2)))
> ((##f64vector? obj1)
> (and (##f64vector? obj2)
> (##f64vector-equal? obj1 obj2)))
> ((table? obj1)
> (and (table? obj2)
> (begin
> (##table-set! ht obj1 obj2)
> (table-equal obj1 obj2))))
> ((##structure? obj1)
> (and (##structure? obj2)
> (let* ((t1 (##structure-type obj1))
> (t2 (##structure-type obj2))
> (tid1 (##type-id t1))
> (tid2 (##type-id t2)))
> (and (##eq? tid1 tid2)
> (let (len (##vector-length obj1))
> (and (##fx= len (##vector-length obj2))
> (##fx= (##fxand (##type-flags t1) 1) 0) ; not
> opaque
> (begin
> (##table-set! ht obj1 obj2)
> (vector-equal obj1 obj2 1 len))))))))
> ((##box? obj1)
> (and (##box? obj2)
> (begin
> (##table-set! ht obj1 obj2)
> (equal (##unbox obj1) (##unbox obj2)))))
> (else #f)))
>
> (def (vector-equal obj1 obj2 i len)
> (let lp ((i i))
> (if (##fx< i len)
> (and (equal (##vector-ref obj1 i) (##vector-ref obj2 i))
> (lp (##fx+ i 1)))
> #t)))
>
> (def (table-equal obj1 obj2)
> (and (##fx= (##vector-ref obj1 1) ; flags
> (##vector-ref obj2 1))
> (##eq? (##vector-ref obj1 2) ; test
> (##vector-ref obj2 2))
> (##eq? (##vector-ref obj1 3) ; hash
> (##vector-ref obj2 3))
> (##fx= (##table-length obj1)
> (##table-length obj2))
> (not (##table-search
> (lambda (k1 v1)
> (let (v2 (##table-ref obj2 k1 nil))
> (not (equal v1 v2))))
> obj1))))
>
> (equal obj1 obj2))
>
> -- vyzo
>
> _______________________________________________
> Gambit-list mailing list
> Gambit-list at iro.umontreal.ca
> https://webmail.iro.umontreal.ca/mailman/listinfo/gambit-list
>
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mailman.iro.umontreal.ca/pipermail/gambit-list/attachments/20170914/ef17b497/attachment.htm>
More information about the Gambit-list
mailing list