Changeset 4706 in project
 Timestamp:
 06/27/07 08:34:11 (13 years ago)
 Location:
 sparsevectors
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

sparsevectors/sparsevectors.scm
r4140 r4706 24 24 25 25 (definerecordtype sparsevector 26 (makehilbert height root )26 (makehilbert height root default) 27 27 sparsevector? 28 28 (height hilbertheight sethilbertheight!) 29 (root hilbertroot sethilbertroot!)) 29 (root hilbertroot sethilbertroot!) 30 (default hilbertdefault sethilbertdefault!)) 30 31 31 32 (definerecordprinter (sparsevector x p) 32 33 (fprintf p "#~s" (sparsevector>list x)) ) 33 34 34 (define (makesparsevector) 35 (makehilbert 1 (makevector hilbertnodesize #f))) 35 (definerecord hilbertdefault value) 36 36 37 (define (sparsevectorref hilbert index) 37 (define (makesparsevector . rest) 38 (letoptionals rest ((default #f)) 39 (makehilbert 1 (makevector hilbertnodesize (makehilbertdefault default)) 40 (makehilbertdefault default)))) 41 42 (define (sparsevectorref1 hilbert index) 38 43 (let recur ((height (hilbertheight hilbert)) 39 44 (index index)) … … 42 47 (if (< index (vectorlength root)) 43 48 (vectorref root index) 44 #f))49 (hilbertdefault hilbert))) 45 50 (let ((node (recur ( height 1) 46 51 (arithmeticshift index minushilbertlog)))) 47 (if node52 (if (vector? node) 48 53 (vectorref node (bitwiseand index hilbertmask)) 49 #f))))) 54 (hilbertdefault hilbert)))))) 55 56 (define (sparsevectorref hilbert index) 57 (let ((val (sparsevectorref1 hilbert index))) 58 (if (hilbertdefault? val) 59 (hilbertdefaultvalue val) 60 val))) 50 61 51 62 (define (sparsevectorset! hilbert index value) … … 58 69 (makenodeifnecessary 59 70 (recur ( height 1) index) 60 (bitwiseand index hilbertmask))))) 71 (bitwiseand index hilbertmask) 72 (hilbertdefault hilbert))))) 61 73 (bitwiseand index hilbertmask) 62 74 value)) … … 65 77 (if (< index hilbertnodesize) 66 78 (hilbertroot hilbert) 67 (let ((newroot (makevector hilbertnodesize #f)))79 (let ((newroot (makevector hilbertnodesize (hilbertdefault hilbert)))) 68 80 (vectorset! newroot 0 (hilbertroot hilbert)) 69 81 (sethilbertroot! hilbert newroot) … … 71 83 (let ((index (arithmeticshift index minushilbertlog))) 72 84 (makenodeifnecessary (makehigherifnecessary hilbert index) 73 (bitwiseand index hilbertmask)))))) 85 (bitwiseand index hilbertmask) 86 (hilbertdefault hilbert)))))) 74 87 75 (define (makenodeifnecessary node index) 76 (or (vectorref node index) 77 (let ((new (makevector hilbertnodesize #f))) 78 (vectorset! node index new) 79 new))) 88 (define (makenodeifnecessary node index default) 89 (let ((v (vectorref node index))) 90 (if (vector? v) v 91 (let ((new (makevector hilbertnodesize default))) 92 (vectorset! node index new) 93 new)))) 80 94 81 95 ; For debugging … … 86 100 (more '())) 87 101 (if (= height 0) 88 (if (or node(pair? more))89 (cons nodemore)102 (if (or (vector? node) (pair? more)) 103 (cons (if (hilbertdefault? node) (hilbertdefaultvalue node) node) more) 90 104 '()) 91 105 (do ((i ( hilbertnodesize 1) ( i 1)) 92 (more more (recur (if node 93 (vectorref node i) 94 #f) 106 (more more (recur (if (vector? node) 107 (let ((val (vectorref node i))) 108 (if (hilbertdefault? val) 109 (hilbertdefaultvalue val) 110 val)) 111 (hilbertdefault h)) 95 112 ( height 1) more))) 96 113 ((< i 0) more))))) 
sparsevectors/sparsevectors.setup
r4140 r4706 1 (compile s sparsevectors.scm O2 d1) 1 2 (define hasexports? (string>=? (chickenversion) "2.310")) 3 4 (compile s 5 ,@(if hasexports? '(checkimports emitexports sparsevectors.exports) '()) 6 sparsevectors.scm d2) 2 7 3 8 (when (extensioninformation 'numbers) 4 (compile s sparsevectors.scm R numbers O2 d1 o bigsparsevectors.so) ) 9 (compile s sparsevectors.scm 10 ,@(if hasexports? '(checkimports emitexports sparsevectors.exports) '()) 11 R numbers O2 d1 o bigsparsevectors.so) ) 5 12 6 13 (installextension 7 14 'sparsevectors 8 15 `("sparsevectors.so" 16 ,@(if hasexports? '("sparsevectors.exports") (list)) 9 17 ,@(if (extensioninformation 'numbers) 10 18 '("bigsparsevectors.so") 11 19 '() ) ) 12 '((version 0. 1)20 '((version 0.2) 13 21 (documentation "sparsevectors.html") 14 (export makesparsevector 15 sparsevector? 16 sparsevectorref 17 sparsevectorset! 18 sparsevector>list) ) ) 22 ,@(if hasexports? `((exports "sparsevectors.exports")) (list)) )) 23
Note: See TracChangeset
for help on using the changeset viewer.