[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