diff --git a/lib/chibi/iset/constructors.scm b/lib/chibi/iset/constructors.scm index ba43c58c..508124ed 100644 --- a/lib/chibi/iset/constructors.scm +++ b/lib/chibi/iset/constructors.scm @@ -130,92 +130,54 @@ ;; aaaa... ;; ...bbbb ((< b-end a-start) - (let ((near-diff (- a-start b-end)) - (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))))))) + (iset-adjoin-node-left! a b)) ;; ...aaaa ;; bbbb... ((> b-start a-end) - (let ((near-diff (- b-start a-end)) - (start-diff (- b-start a-start)) - (far-diff (- b-end a-start))) - (if (let* ((right (iset-right a)) - (m-start (and right (iset-min-start right)))) - (and m-start - (or (> b-start m-start) - (> (- b-start m-start) near-diff)))) - (iset-adjoin-node! (iset-right a) b) - (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... + (iset-adjoin-node-right! a b)) + ;; ...aaaaa... + ;; ...bb... + ((and (>= b-start a-start) (<= b-end a-end)) + (if a-bits + (let ((b-bits (arithmetic-shift + (or b-bits (range->bits b-start b-end)) + (- b-start a-start)))) + (iset-bits-set! a (bitwise-ior a-bits b-bits))))) (else - (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)) - (or b-bits (range->bits b-start b-end)))) - (iset-squash-bits! a))))))))) + ;; general case: split, recurse, join sides + (let ((ls (iset-node-split b a-start a-end))) + (if (car ls) + (iset-adjoin-node-left! a (car ls))) + (iset-adjoin-node! a (cadr ls)) + (if (car (cddr ls)) + (iset-adjoin-node-right! a (car (cddr ls))))))))))) + +(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) (list->iset! ls iset)) diff --git a/tests/iset-tests.scm b/tests/iset-tests.scm index 0c3c072c..9c0887f5 100644 --- a/tests/iset-tests.scm +++ b/tests/iset-tests.scm @@ -4,6 +4,15 @@ (import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test))) (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") (let ((tests @@ -23,6 +32,7 @@ (() (u: 349 680) (u: 682 685)) (() (u: 64434 64449) (u: 65020 65021) (u #xFE62)) (() (u: 716 747) (u: 750 1084)) + (() (u: 48 57) (u: 65 90) (u: 97 122) (u 45 46 95 126) (? 119)) ))) (for-each (lambda (tst) @@ -39,29 +49,36 @@ ;; additional operations (for-each (lambda (op) - (case (car op) - ((+) - (iset-adjoin! is (cadr op)) - (test-assert (iset-contains? is (cadr op)))) - ((-) - (iset-delete! is (cadr op)) - (test-assert (not (iset-contains? is (cadr op))))) - ((?) - (test (if (pair? (cddr op)) (car (cddr op)) #t) + (let ((name (test-name is op))) + (case (car op) + ((+) + (iset-adjoin! is (cadr op)) + (test-assert name (iset-contains? is (cadr op)))) + ((-) + (iset-delete! is (cadr op)) + (test-assert name (not (iset-contains? is (cadr op))))) + ((?) + (test name (if (pair? (cddr op)) (car (cddr op)) #t) (iset-contains? is (cadr op)))) - ((d) - (set! is (iset-difference is (list->iset (cdr op)))) - (for-each (lambda (x) (test-assert (iset-contains? is x))) (cdr op))) - ((i) (set! is (iset-intersection is (list->iset (cdr op))))) - ((s) (test (iset-size is) (cadr op))) - ((u) - (set! is (iset-union is (list->iset (cdr op)))) - (for-each (lambda (x) (test-assert (iset-contains? is x))) (cdr op))) - ((u:) - (set! is (iset-union is (make-iset (cadr op) (car (cddr op))))) - (for-each (lambda (x) (test-assert (iset-contains? is x))) (cdr op))) - ((z) (test (iset-empty? is) (if (pair? (cdr op)) (cadr op) #t))) - (else (error "unknown operation" (car op))))) + ((d) + (set! is (iset-difference is (list->iset (cdr op)))) + (for-each (lambda (x) (test-assert name (iset-contains? is x))) + (cdr op))) + ((i) (set! is (iset-intersection is (list->iset (cdr op))))) + ((s) (test (iset-size is) (cadr op))) + ((u u:) + (let ((arg (cond ((eq? 'u: (car op)) + (make-iset (cadr op) (car (cddr op)))) + ((iset? (cadr op)) (cadr op)) + (else (list->iset (cdr op)))))) + (set! is (iset-union is arg))) + (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)) ;; optimization (let* ((is2 (iset-optimize is)) @@ -72,4 +89,9 @@ (test-assert (iset= is is4))))) 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)