Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Simplifying and fixing some edge cases in iset-union.

Browse source 
Fixes issue #212.
This commit is contained in:
Alex Shinn 2014-03-01 12:30:01 +09:00
parent 1678c6aa47
commit a0854df2ca
2 changed files with 88 additions and 104 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

126
lib/chibi/iset/constructors.scm
View file

@ -130,92 +130,54 @@
;; aaaa... ;; aaaa...
;; ...bbbb ;; ...bbbb
((< b-end a-start) ((< b-end a-start)
(let ((near-diff (- a-start b-end)) (iset-adjoin-node-left! a b))
(start-diff (- a-start b-start))
(far-diff (- a-end b-start)))
(if (let* ((left (iset-left a))
(m-end (and left (iset-max-end left))))
(and m-end
(or (< b-end m-end)
(< (- b-end m-end) near-diff))))
(iset-adjoin-node! (iset-left a) b)
(cond
((and (< near-diff bits-thresh)
(< far-diff bits-max))
(let ((bits (arithmetic-shift
(or a-bits (range->bits a-start a-end))
start-diff))
(lo-bits (or b-bits (range->bits b-start b-end))))
(iset-start-set! a b-start)
(iset-bits-set! a (bitwise-ior bits lo-bits))
(iset-squash-bits! a)))
(else (iset-insert-left! a (iset-copy-node b)))))))
;; ...aaaa ;; ...aaaa
;; bbbb... ;; bbbb...
((> b-start a-end) ((> b-start a-end)
(let ((near-diff (- b-start a-end)) (iset-adjoin-node-right! a b))
(start-diff (- b-start a-start)) ;; ...aaaaa...
(far-diff (- b-end a-start))) ;; ...bb...
(if (let* ((right (iset-right a)) ((and (>= b-start a-start) (<= b-end a-end))
(m-start (and right (iset-min-start right)))) (if a-bits
(and m-start (let ((b-bits (arithmetic-shift
(or (> b-start m-start) (or b-bits (range->bits b-start b-end))
(> (- b-start m-start) near-diff)))) (- b-start a-start))))
(iset-adjoin-node! (iset-right a) b) (iset-bits-set! a (bitwise-ior a-bits b-bits)))))
(cond
((and (< near-diff bits-thresh)
(< far-diff bits-max))
(iset-end-set! a b-end)
(iset-bits-set!
a
(bitwise-ior
(or a-bits (range->bits a-start a-end))
(arithmetic-shift
(or b-bits (range->bits b-start b-end))
start-diff)))
(iset-squash-bits! a))
(else (iset-insert-right! a (iset-copy-node b)))))))
;; aaaa...
;; bbbb...
((> b-start a-start)
(iset-end-set! a (max a-end b-end))
(cond
((or a-bits b-bits)
(iset-bits-set!
a
(bitwise-ior
(or a-bits (range->bits a-start a-end))
(arithmetic-shift
(or b-bits (range->bits b-start b-end))
(- b-start a-start))))
(iset-squash-bits! a))))
;; aaaa...
;; bbbb...
((< b-start a-start)
(iset-start-set! a b-start)
(iset-end-set! a (max a-end b-end))
(cond
((or a-bits b-bits)
(iset-bits-set!
a
(bitwise-ior
(arithmetic-shift
(or a-bits (range->bits a-start a-end))
(- a-start b-start))
(or b-bits (range->bits b-start b-end))))
(iset-squash-bits! a))))
;; aaaa...
;; bbbb...
(else (else
(iset-end-set! a (max a-end b-end)) ;; general case: split, recurse, join sides
(cond (let ((ls (iset-node-split b a-start a-end)))
((or a-bits b-bits) (if (car ls)
(iset-bits-set! (iset-adjoin-node-left! a (car ls)))
a (iset-adjoin-node! a (cadr ls))
(bitwise-ior (if (car (cddr ls))
(or a-bits (range->bits a-start a-end)) (iset-adjoin-node-right! a (car (cddr ls)))))))))))
(or b-bits (range->bits b-start b-end))))
(iset-squash-bits! a))))))))) (define (iset-adjoin-node-left! iset node)
(if (iset-left iset)
(iset-adjoin-node! (iset-left iset) node)
(iset-left-set! iset node)))
(define (iset-adjoin-node-right! iset node)
(if (iset-right iset)
(iset-adjoin-node! (iset-right iset) node)
(iset-right-set! iset node)))
;; start and/or end are inside the node, split into:
;; 1. node before start, if any
;; 2. node between start and end
;; 3. node after end, if any
(define (iset-node-split node start end)
(list (and (< (iset-start node) start)
(iset-node-extract node (iset-start node) (- start 1)))
(iset-node-extract node start end)
(and (> (iset-end node) end)
(iset-node-extract node (+ end 1) (iset-end node)))))
(define (iset-node-extract node start end)
(let ((bits (and (iset-bits node)
(arithmetic-shift (iset-bits node)
(- (iset-start node) start)))))
(%make-iset start end bits #f #f)))
(define (iset-adjoin! iset . ls) (define (iset-adjoin! iset . ls)
(list->iset! ls iset)) (list->iset! ls iset))

66
tests/iset-tests.scm
View file

@ -4,6 +4,15 @@
(import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test))) (import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test)))
(else #f)) (else #f))
(define (test-name iset op)
(call-with-output-string
(lambda (out)
(let* ((ls (iset->list iset))
(ls (if (> (length ls) 10)
`(,@(take ls 5) ... ,@(take-right ls 5))
ls)))
(write `(,(car op) (iset ,@ls) ,@(cdr op)) out)))))
(test-begin "iset") (test-begin "iset")
(let ((tests (let ((tests
@ -23,6 +32,7 @@
(() (u: 349 680) (u: 682 685)) (() (u: 349 680) (u: 682 685))
(() (u: 64434 64449) (u: 65020 65021) (u #xFE62)) (() (u: 64434 64449) (u: 65020 65021) (u #xFE62))
(() (u: 716 747) (u: 750 1084)) (() (u: 716 747) (u: 750 1084))
(() (u: 48 57) (u: 65 90) (u: 97 122) (u 45 46 95 126) (? 119))
))) )))
(for-each (for-each
(lambda (tst) (lambda (tst)
@ -39,29 +49,36 @@
;; additional operations ;; additional operations
(for-each (for-each
(lambda (op) (lambda (op)
(case (car op) (let ((name (test-name is op)))
((+) (case (car op)
(iset-adjoin! is (cadr op)) ((+)
(test-assert (iset-contains? is (cadr op)))) (iset-adjoin! is (cadr op))
((-) (test-assert name (iset-contains? is (cadr op))))
(iset-delete! is (cadr op)) ((-)
(test-assert (not (iset-contains? is (cadr op))))) (iset-delete! is (cadr op))
((?) (test-assert name (not (iset-contains? is (cadr op)))))
(test (if (pair? (cddr op)) (car (cddr op)) #t) ((?)
(test name (if (pair? (cddr op)) (car (cddr op)) #t)
(iset-contains? is (cadr op)))) (iset-contains? is (cadr op))))
((d) ((d)
(set! is (iset-difference is (list->iset (cdr op)))) (set! is (iset-difference is (list->iset (cdr op))))
(for-each (lambda (x) (test-assert (iset-contains? is x))) (cdr op))) (for-each (lambda (x) (test-assert name (iset-contains? is x)))
((i) (set! is (iset-intersection is (list->iset (cdr op))))) (cdr op)))
((s) (test (iset-size is) (cadr op))) ((i) (set! is (iset-intersection is (list->iset (cdr op)))))
((u) ((s) (test (iset-size is) (cadr op)))
(set! is (iset-union is (list->iset (cdr op)))) ((u u:)
(for-each (lambda (x) (test-assert (iset-contains? is x))) (cdr op))) (let ((arg (cond ((eq? 'u: (car op))
((u:) (make-iset (cadr op) (car (cddr op))))
(set! is (iset-union is (make-iset (cadr op) (car (cddr op))))) ((iset? (cadr op)) (cadr op))
(for-each (lambda (x) (test-assert (iset-contains? is x))) (cdr op))) (else (list->iset (cdr op))))))
((z) (test (iset-empty? is) (if (pair? (cdr op)) (cadr op) #t))) (set! is (iset-union is arg)))
(else (error "unknown operation" (car op))))) (for-each
(lambda (x)
(if (integer? x)
(test-assert name (iset-contains? is x))))
(cdr op)))
((z) (test (iset-empty? is) (if (pair? (cdr op)) (cadr op) #t)))
(else (error "unknown operation" (car op))))))
(cdr tst)) (cdr tst))
;; optimization ;; optimization
(let* ((is2 (iset-optimize is)) (let* ((is2 (iset-optimize is))
@ -72,4 +89,9 @@
(test-assert (iset= is is4))))) (test-assert (iset= is is4)))))
tests)) tests))
(let ((a (%make-iset 65 90 #f #f (%make-iset 97 122 #f #f #f)))
(b (list->iset '(45 46 95 126))))
(test-assert (iset-contains? (iset-union a b) 119))
(test-assert (iset-contains? (iset-union b a) 119)))
(test-end) (test-end)