(define (row-heads-width p) (vector-ref p 0)) (define (col-heads-height p) (vector-ref p 1)) (define (height p) (vector-ref p 2)) (define (set-height! p h) (vector-set! p 2 h)) (define (row-headers p) (vector-ref p 3)) (define (set-row-headers! p r) (vector-set! p 3 r)) (define (width p) (vector-ref p 4)) (define (set-width! p w) (vector-set! p 4 w)) (define (col-headers p) (vector-ref p 5)) (define (set-col-headers! p c) (vector-set! p 5 c)) (define (cells p) (vector-ref p 6)) (define (set-cells! p c) (vector-set! p 6 c)) (define (set-empty-rows! c s e w) (if (< s e) (begin (vector-set! c s (make-vector w)) (set-empty-rows! c (+ s 1) e w)))) (define (make-pivot r c w h) (letrec ((cells (make-vector h))) (set-empty-rows! cells 0 h w) (vector r c 0 (make-vector h) 0 (make-vector w) cells))) (define (vector-copy! sv dv a z o) (if (>= z a) (begin (vector-set! dv (+ z o) (vector-ref sv z)) (vector-copy! sv dv a (- z 1) o)))) (define (vector-compare a b s e bs) (if (= s e) 0 (let ((sa (vector-ref a s)) (sb (vector-ref b bs))) (cond ((string? sa sb) 1) (else (vector-compare a b (+ s 1) e (+ bs 1))))))) (define (vector-insert! v s k h) (if (= h (vector-length v)) (let ((nv (make-vector (+ (* h 2) 1)))) (vector-copy! v nv s (- h 1) 1) (vector-copy! v nv 0 (- s 1) 0) (vector-set! nv s k) nv) (begin (vector-copy! v v s (- h 1) 1) (vector-set! v s k) v))) (define (vector-search v s e k ks ke) (if (>= s e) (cons #f s) (let ((m (quotient (+ e s) 2))) (case (vector-compare k (vector-ref v m) ks ke 0) ((-1) (vector-search v s m k ks ke)) ((1) (vector-search v (+ m 1) e k ks ke)) (else (cons #t m)))))) (define found car) (define search-index cdr) (define (measure-replace o n) n) (define (measure-sum o n) (if o (+ o n) n)) (define measure measure-sum) (define (pivot-set-cell! p y x k) (let ((r (vector-ref (cells p) y))) (vector-set! r x (measure (vector-ref r x) k)))) (define (pivot-insert-row! p y) (let ((h (height p))) (set-cells! p (vector-insert! (cells p) y (make-vector (width p)) h)) (set-height! p (+ h 1)))) (define (pivot-insert-col! p x) (let ((c (cells p)) (w (width p))) (letrec ((e (height p)) (insert (lambda (s) (if (< s e) (begin (vector-set! c s (vector-insert! (vector-ref c s) x #f w)) (insert (+ s 1))))))) (insert 0) (set-width! p (+ w 1))))) (define (pivot-new-row! p y v) (let* ((rw (row-heads-width p)) (nr (make-vector rw))) (vector-copy! v nr 0 (- rw 1) 0) (set-row-headers! p (vector-insert! (row-headers p) y nr (height p)))) (pivot-insert-row! p y)) (define (pivot-new-col! p x v) (let ((rw (row-heads-width p)) (ch (col-heads-height p))) (let ((nc (make-vector ch))) (vector-copy! v nc rw (- (+ rw ch) 1) (- rw)) (set-col-headers! p (vector-insert! (col-headers p) x nc (width p))))) (pivot-insert-col! p x)) (define (pivot-insert! p v data) (let* ((rw (row-heads-width p)) (d (+ rw (col-heads-height p))) (rs (vector-search (row-headers p) 0 (height p) v 0 rw)) (cs (vector-search (col-headers p) 0 (width p) v rw d)) (x (search-index cs)) (y (search-index rs))) (if (not (found rs)) (pivot-new-row! p y v)) (if (not (found cs)) (pivot-new-col! p x v)) (pivot-set-cell! p y x data))) (define (pivot-get-cell p v) (let* ((rw (row-heads-width p)) (d (+ rw (col-heads-height p))) (rs (vector-search (row-headers p) 0 (height p) v 0 rw)) (cs (vector-search (col-headers p) 0 (width p) v rw d))) (if (and (found rs) (found cs)) (vector-ref (vector-ref (cells p) (search-index rs)) (search-index cs))))) (define (pivot-for-each-row thunk p) (let ((h (height p)) (rows (row-headers p)) (c (cells p))) (letrec ((pivot-for-each-row-range (lambda (s) (if (< s h) (begin (thunk (vector-ref rows s) (vector-ref c s)) (pivot-for-each-row-range (+ s 1))))))) (pivot-for-each-row-range 0))))