336 lines
12 KiB
Scheme
336 lines
12 KiB
Scheme
;;; 5_1.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; type and generic predicates
|
|
|
|
(begin
|
|
(define boolean?
|
|
(lambda (x)
|
|
(or (eq? x #t) (eq? x #f))))
|
|
|
|
(define not
|
|
(lambda (x)
|
|
(if x #f #t)))
|
|
|
|
(define eqv?
|
|
(lambda (x y)
|
|
(eqv? x y)))
|
|
|
|
(define (equal? x y)
|
|
(define k0 200)
|
|
(define kb -20)
|
|
|
|
#;(define (union-find ht x y) ; hashtable-ref/set! version
|
|
(define (find b) ; splitting
|
|
(let ([n (car b)]) ; next or census
|
|
(if (pair? n)
|
|
(let loop ([b b] [n n])
|
|
(let ([nn (car n)])
|
|
(if (pair? nn)
|
|
(begin (set-car! 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 (list 1)])
|
|
(eq-hashtable-set! ht x b)
|
|
(eq-hashtable-set! ht y b)
|
|
#f)
|
|
(begin
|
|
(eq-hashtable-set! ht x (find by))
|
|
#f))
|
|
(if (not by)
|
|
(begin
|
|
(eq-hashtable-set! ht y (find bx))
|
|
#f)
|
|
(let ([rx (find bx)] [ry (find by)])
|
|
(or (eq? rx ry)
|
|
(let ([nx (car rx)] [ny (car ry)])
|
|
(if (fx> nx ny)
|
|
(begin
|
|
(set-car! ry rx)
|
|
(set-car! rx (fx+ nx ny))
|
|
#f)
|
|
(begin
|
|
(set-car! rx ry)
|
|
(set-car! ry (fx+ ny nx))
|
|
#f)))))))))
|
|
|
|
(define (union-find ht x y) ; htcell version
|
|
(define (find p n) ; splitting
|
|
(if (pair? n)
|
|
(let loop ([p p] [n n])
|
|
(let ([nn (cdr n)])
|
|
(if (pair? nn)
|
|
(begin (set-cdr! p nn) (loop n nn))
|
|
n)))
|
|
p))
|
|
(let ([ax (eq-hashtable-cell ht x 0)]
|
|
[ay (eq-hashtable-cell ht y 0)])
|
|
(let ([nx (cdr ax)] [ny (cdr ay)])
|
|
(if (eq? nx 0)
|
|
(if (eq? ny 0)
|
|
(begin
|
|
(set-cdr! ax ay)
|
|
(set-cdr! ay 1)
|
|
#f)
|
|
(begin
|
|
(set-cdr! ax (find ay ny))
|
|
#f))
|
|
(if (eq? ny 0)
|
|
(begin
|
|
(set-cdr! ay (find ax nx))
|
|
#f)
|
|
(let ([rx (find ax nx)] [ry (find ay ny)])
|
|
(or (eq? rx ry)
|
|
(let ([nx (cdr rx)] [ny (cdr ry)])
|
|
(if (fx> nx ny)
|
|
(begin
|
|
(set-cdr! ry rx)
|
|
(set-cdr! rx (fx+ nx ny))
|
|
#f)
|
|
(begin
|
|
(set-cdr! rx ry)
|
|
(set-cdr! ry (fx+ ny nx))
|
|
#f))))))))))
|
|
|
|
(define (interleave? x y k)
|
|
(let ([ht (make-eq-hashtable)])
|
|
(define (e? x y k)
|
|
(if (fx<= k 0)
|
|
(if (fx= 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 (union-find ht x y)
|
|
0
|
|
(let ([k (e? (car x) (car y) (fx- k 1))])
|
|
(and k (e? (cdr x) (cdr y) k)))))]
|
|
[(vector? x)
|
|
(and (vector? y)
|
|
(let ([n (vector-length x)])
|
|
(and (fx= (vector-length y) n)
|
|
(if (union-find ht x y)
|
|
0
|
|
(let f ([i 0] [k (fx- k 1)])
|
|
(if (fx= i n)
|
|
k
|
|
(let ([k (e? (vector-ref x i) (vector-ref y i) k)])
|
|
(and k (f (fx+ i 1) k)))))))))]
|
|
[(string? x) (and (string? y) (string=? x y) k)]
|
|
[(flonum? x) (and (flonum? y) ($fleqv? x y) k)]
|
|
[($inexactnum? x)
|
|
(and ($inexactnum? y)
|
|
($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
|
|
($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y))
|
|
k)]
|
|
[(bignum? x) (and (bignum? y) (= x y) k)]
|
|
[(ratnum? x) (and (ratnum? y) (= x y) k)]
|
|
[($exactnum? x) (and ($exactnum? y) (= x y) k)]
|
|
[(bytevector? x) (and (bytevector? y) (bytevector=? x y) k)]
|
|
[(fxvector? x)
|
|
(and (fxvector? y)
|
|
(fx= (fxvector-length x) (fxvector-length y))
|
|
(let f ([i (fx- (fxvector-length x) 1)])
|
|
(if (fx< i 0)
|
|
k
|
|
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
|
|
(f (fx1- i))))))]
|
|
[(box? x)
|
|
(and (box? y)
|
|
(if (union-find ht x y)
|
|
0
|
|
(e? (unbox x) (unbox y) (fx- k 1))))]
|
|
[($record? x)
|
|
(and ($record? y)
|
|
(let ([rec-equal? ($record-equal-procedure x y)])
|
|
(and rec-equal?
|
|
(if (union-find ht x y)
|
|
0
|
|
(let ([next-k k] [decr 1])
|
|
(and (rec-equal? x y
|
|
(lambda (x1 y1)
|
|
; decrementing only on first subfield, if any, like vectors and pairs
|
|
(let ([k (e? x1 y1 (fx- next-k decr))])
|
|
(and k
|
|
(begin
|
|
(set! next-k k)
|
|
(set! decr 0)
|
|
#t)))))
|
|
next-k))))))]
|
|
[else (and (eqv? x y) k)]))
|
|
(define (fast? x y k)
|
|
(let ([k (fx- 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 (fx= (vector-length y) n)
|
|
(let f ([i 0] [k k])
|
|
(if (fx= i n)
|
|
k
|
|
(let ([k (e? (vector-ref x i) (vector-ref y i) k)])
|
|
(and k (f (fx+ i 1) k))))))))]
|
|
[(string? x) (and (string? y) (string=? x y) k)]
|
|
[(flonum? x) (and (flonum? y) ($fleqv? x y) k)]
|
|
[($inexactnum? x)
|
|
(and ($inexactnum? y)
|
|
($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
|
|
($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y))
|
|
k)]
|
|
[(bignum? x) (and (bignum? y) (= x y) k)]
|
|
[(ratnum? x) (and (ratnum? y) (= x y) k)]
|
|
[($exactnum? x) (and ($exactnum? y) (= x y) k)]
|
|
[(bytevector? x) (and (bytevector? y) (bytevector=? x y) k)]
|
|
[(fxvector? x)
|
|
(and (fxvector? y)
|
|
(fx= (fxvector-length x) (fxvector-length y))
|
|
(let f ([i (fx- (fxvector-length x) 1)])
|
|
(if (fx< i 0)
|
|
k
|
|
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
|
|
(f (fx1- i))))))]
|
|
[(box? x) (and (box? y) (e? (unbox x) (unbox y) k))]
|
|
[($record? x)
|
|
(and ($record? y)
|
|
(let ([rec-equal? ($record-equal-procedure x y)])
|
|
(and rec-equal?
|
|
(let ([next-k k])
|
|
(and (rec-equal? x y
|
|
(lambda (x1 y1)
|
|
(let ([k (e? x1 y1 next-k)])
|
|
(and k
|
|
(begin
|
|
(set! next-k k)
|
|
#t)))))
|
|
next-k)))))]
|
|
[else (and (eqv? x y) k)])))
|
|
(and (e? x y k) #t)))
|
|
|
|
(define (precheck? x y k)
|
|
(cond
|
|
[(eq? x y) k]
|
|
[(pair? x)
|
|
(and (pair? y)
|
|
(if (fx<= k 0)
|
|
k
|
|
(let ([k (precheck? (car x) (car y) (fx- k 1))])
|
|
(and k (precheck? (cdr x) (cdr y) k)))))]
|
|
[(vector? x)
|
|
(and (vector? y)
|
|
(let ([n (vector-length x)])
|
|
(and (fx= (vector-length y) n)
|
|
(let f ([i 0] [k k])
|
|
(if (or (fx= i n) (fx<= k 0))
|
|
k
|
|
(let ([k (precheck?
|
|
(vector-ref x i)
|
|
(vector-ref y i)
|
|
(fx- k 1))])
|
|
(and k (f (fx+ i 1) k))))))))]
|
|
[(string? x) (and (string? y) (string=? x y) k)]
|
|
[(flonum? x) (and (flonum? y) ($fleqv? x y) k)]
|
|
[($inexactnum? x)
|
|
(and ($inexactnum? y)
|
|
($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
|
|
($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y))
|
|
k)]
|
|
[(bignum? x) (and (bignum? y) (= x y) k)]
|
|
[(ratnum? x) (and (ratnum? y) (= x y) k)]
|
|
[($exactnum? x) (and ($exactnum? y) (= x y) k)]
|
|
[(bytevector? x) (and (bytevector? y) (bytevector=? x y) k)]
|
|
[(fxvector? x)
|
|
(and (fxvector? y)
|
|
(fx= (fxvector-length x) (fxvector-length y))
|
|
(let f ([i (fx- (fxvector-length x) 1)])
|
|
(if (fx< i 0)
|
|
k
|
|
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
|
|
(f (fx1- i))))))]
|
|
[(box? x)
|
|
(and (box? y)
|
|
(if (fx<= k 0)
|
|
k
|
|
(precheck? (unbox x) (unbox y) (fx- k 1))))]
|
|
[($record? x)
|
|
(and ($record? y)
|
|
(let ([rec-equal? ($record-equal-procedure x y)])
|
|
(and rec-equal?
|
|
(if (fx<= k 0)
|
|
k
|
|
(let ([next-k k])
|
|
(and (rec-equal? x y
|
|
(lambda (x1 y1)
|
|
; decrementing k for each field, like vectors but unlike pairs
|
|
(let ([k (precheck? x1 y1 (fx- next-k 1))])
|
|
(and k
|
|
(begin
|
|
(set! next-k k)
|
|
#t)))))
|
|
next-k))))))]
|
|
[else (and (eqv? x y) k)]))
|
|
|
|
(let ([k (precheck? x y k0)])
|
|
(and k (or (fx> k 0) (interleave? x y 0)))))
|
|
|
|
(define boolean=?
|
|
(case-lambda
|
|
[(b1 b2)
|
|
(unless (boolean? b1) ($oops 'boolean=? "~s is not a boolean" b1))
|
|
(unless (boolean? b2) ($oops 'boolean=? "~s is not a boolean" b2))
|
|
(#3%boolean=? b1 b2)]
|
|
[(b1 b2 . b*)
|
|
(unless (boolean? b1) ($oops 'boolean=? "~s is not a boolean" b1))
|
|
(unless (boolean? b2) ($oops 'boolean=? "~s is not a boolean" b2))
|
|
(for-each
|
|
(lambda (b) (unless (boolean? b) ($oops 'boolean=? "~s is not a boolean" b)))
|
|
b*)
|
|
(and (#3%boolean=? b1 b2)
|
|
(let f ([b* b*])
|
|
(or (null? b*)
|
|
(and (#3%boolean=? (car b*) b1)
|
|
(f (cdr b*))))))]))
|
|
|
|
(define symbol=?
|
|
(case-lambda
|
|
[(s1 s2)
|
|
(unless (symbol? s1) ($oops 'symbol=? "~s is not a symbol" s1))
|
|
(unless (symbol? s2) ($oops 'symbol=? "~s is not a symbol" s2))
|
|
(#3%symbol=? s1 s2)]
|
|
[(s1 s2 . s*)
|
|
(unless (symbol? s1) ($oops 'symbol=? "~s is not a symbol" s1))
|
|
(unless (symbol? s2) ($oops 'symbol=? "~s is not a symbol" s2))
|
|
(for-each
|
|
(lambda (s) (unless (symbol? s) ($oops 'symbol=? "~s is not a symbol" s)))
|
|
s*)
|
|
(and (#3%symbol=? s1 s2)
|
|
(let f ([s* s*])
|
|
(or (null? s*)
|
|
(and (#3%symbol=? (car s*) s1)
|
|
(f (cdr s*))))))]))
|
|
)
|