Changeset 4706 in project


Ignore:
Timestamp:
06/27/07 08:34:11 (13 years ago)
Author:
felix winkelmann
Message:

sparse vector fix by Ivan Raikov

Location:
sparse-vectors
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • sparse-vectors/sparse-vectors.scm

    r4140 r4706  
    2424
    2525(define-record-type sparse-vector
    26   (make-hilbert height root)
     26  (make-hilbert height root default)
    2727  sparse-vector?
    2828  (height hilbert-height set-hilbert-height!)
    29   (root hilbert-root set-hilbert-root!))
     29  (root hilbert-root set-hilbert-root!)
     30  (default hilbert-default set-hilbert-default!))
    3031
    3132(define-record-printer (sparse-vector x p)
    3233  (fprintf p "#~s" (sparse-vector->list x)) )
    3334
    34 (define (make-sparse-vector)
    35   (make-hilbert 1 (make-vector hilbert-node-size #f)))
     35(define-record hilbert-default value)
    3636
    37 (define (sparse-vector-ref hilbert index)
     37(define (make-sparse-vector . rest)
     38  (let-optionals rest ((default #f))
     39    (make-hilbert 1 (make-vector hilbert-node-size (make-hilbert-default default))
     40                  (make-hilbert-default default))))
     41
     42(define (sparse-vector-ref1 hilbert index)
    3843  (let recur ((height (hilbert-height hilbert))
    3944              (index index))
     
    4247          (if (< index (vector-length root))
    4348              (vector-ref root index)
    44               #f))
     49              (hilbert-default hilbert)))
    4550        (let ((node (recur (- height 1)
    4651                           (arithmetic-shift index minus-hilbert-log))))
    47           (if node
     52          (if (vector? node)
    4853              (vector-ref node (bitwise-and index hilbert-mask))
    49               #f)))))
     54              (hilbert-default hilbert))))))
     55
     56(define (sparse-vector-ref hilbert index)
     57  (let ((val (sparse-vector-ref1 hilbert index)))
     58    (if (hilbert-default? val)
     59        (hilbert-default-value val)
     60        val)))
    5061               
    5162(define (sparse-vector-set! hilbert index value)
     
    5869           (make-node-if-necessary
    5970            (recur (- height 1) index)
    60             (bitwise-and index hilbert-mask)))))
     71            (bitwise-and index hilbert-mask)
     72            (hilbert-default hilbert)))))
    6173   (bitwise-and index hilbert-mask)
    6274   value))
     
    6577  (if (< index hilbert-node-size)
    6678      (hilbert-root hilbert)
    67       (let ((new-root (make-vector hilbert-node-size #f)))
     79      (let ((new-root (make-vector hilbert-node-size (hilbert-default hilbert))))
    6880        (vector-set! new-root 0 (hilbert-root hilbert))
    6981        (set-hilbert-root! hilbert new-root)
     
    7183        (let ((index (arithmetic-shift index minus-hilbert-log)))
    7284          (make-node-if-necessary (make-higher-if-necessary hilbert index)
    73                                   (bitwise-and index hilbert-mask))))))
     85                                  (bitwise-and index hilbert-mask)
     86                                  (hilbert-default hilbert))))))
    7487
    75 (define (make-node-if-necessary node index)
    76   (or (vector-ref node index)
    77       (let ((new (make-vector hilbert-node-size #f)))
    78         (vector-set! node index new)
    79         new)))
     88(define (make-node-if-necessary node index default)
     89  (let ((v (vector-ref node index)))
     90    (if (vector? v) v
     91        (let ((new (make-vector hilbert-node-size default)))
     92          (vector-set! node index new)
     93          new))))
    8094
    8195; For debugging
     
    86100              (more '()))
    87101    (if (= height 0)
    88         (if (or node (pair? more))
    89             (cons node more)
     102        (if (or (vector? node) (pair? more))
     103            (cons (if (hilbert-default? node) (hilbert-default-value node) node) more)
    90104            '())
    91105        (do ((i (- hilbert-node-size 1) (- i 1))
    92              (more more (recur (if node
    93                                    (vector-ref node i)
    94                                    #f)
     106             (more more (recur (if (vector? node)
     107                                   (let ((val (vector-ref node i)))
     108                                     (if (hilbert-default? val)
     109                                         (hilbert-default-value val)
     110                                         val))
     111                                   (hilbert-default h))
    95112                               (- height 1) more)))
    96113            ((< i 0) more)))))
  • sparse-vectors/sparse-vectors.setup

    r4140 r4706  
    1 (compile -s sparse-vectors.scm -O2 -d1)
     1
     2(define has-exports? (string>=? (chicken-version) "2.310"))
     3
     4(compile -s
     5         ,@(if has-exports? '(-check-imports -emit-exports sparse-vectors.exports) '())
     6         sparse-vectors.scm -d2)
    27
    38(when (extension-information 'numbers)
    4   (compile -s sparse-vectors.scm -R numbers -O2 -d1 -o big-sparse-vectors.so) )
     9  (compile -s sparse-vectors.scm
     10           ,@(if has-exports? '(-check-imports -emit-exports sparse-vectors.exports) '())
     11           -R numbers -O2 -d1 -o big-sparse-vectors.so) )
    512
    613(install-extension
    714 'sparse-vectors
    815 `("sparse-vectors.so"
     16   ,@(if has-exports? '("sparse-vectors.exports") (list))
    917   ,@(if (extension-information 'numbers)
    1018         '("big-sparse-vectors.so")
    1119         '() ) )
    12  '((version 0.1)
     20 '((version 0.2)
    1321   (documentation "sparse-vectors.html")
    14    (export make-sparse-vector
    15            sparse-vector?
    16            sparse-vector-ref
    17            sparse-vector-set!
    18            sparse-vector->list) ) )
     22   ,@(if has-exports? `((exports "sparse-vectors.exports")) (list)) ))
     23
Note: See TracChangeset for help on using the changeset viewer.