/usr/share/scheme48-1.9/big/hilbert.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees
; Hilbert vectors are like vectors that grow as large as they need to.
; That is, they can be indexed by arbitrarily large nonnegative integers.
; The implementation allows for arbitrarily large gaps by arranging
; the entries in a tree.
; So-called because they live in an infinite-dimensional vector
; space...
(define hilbert-log 8)
(define hilbert-node-size (arithmetic-shift 1 hilbert-log))
(define hilbert-mask (- hilbert-node-size 1))
(define minus-hilbert-log (- 0 hilbert-log))
(define-record-type hilbert :hilbert
(make-hilbert height root)
(height hilbert-height set-hilbert-height!)
(root hilbert-root set-hilbert-root!))
(define-record-discloser :hilbert
(lambda (h)
'(sparse-vector)))
(define (make-sparse-vector)
(make-hilbert 1 (make-vector hilbert-node-size #f)))
(define (sparse-vector-ref hilbert index)
(let recur ((height (hilbert-height hilbert))
(index index))
(if (= height 1)
(let ((root (hilbert-root hilbert)))
(if (< index (vector-length root))
(vector-ref root index)
#f))
(let ((node (recur (- height 1)
(arithmetic-shift index minus-hilbert-log))))
(if node
(vector-ref node (bitwise-and index hilbert-mask))
#f)))))
(define (sparse-vector-set! hilbert index value)
(vector-set!
(let recur ((height (hilbert-height hilbert))
(index index))
(if (= height 1)
(make-higher-if-necessary hilbert index)
(let ((index (arithmetic-shift index minus-hilbert-log)))
(make-node-if-necessary
(recur (- height 1) index)
(bitwise-and index hilbert-mask)))))
(bitwise-and index hilbert-mask)
value))
(define (make-higher-if-necessary hilbert index)
(if (< index hilbert-node-size)
(hilbert-root hilbert)
(let ((new-root (make-vector hilbert-node-size #f)))
(vector-set! new-root 0 (hilbert-root hilbert))
(set-hilbert-root! hilbert new-root)
(set-hilbert-height! hilbert (+ (hilbert-height hilbert) 1))
(let ((index (arithmetic-shift index minus-hilbert-log)))
(make-node-if-necessary (make-higher-if-necessary hilbert index)
(bitwise-and index hilbert-mask))))))
(define (make-node-if-necessary node index)
(or (vector-ref node index)
(let ((new (make-vector hilbert-node-size #f)))
(vector-set! node index new)
new)))
; For debugging
(define (sparse-vector->list h)
(let recur ((node (hilbert-root h))
(height (hilbert-height h))
(more '()))
(if (= height 0)
(if (or node (pair? more))
(cons node more)
'())
(do ((i (- hilbert-node-size 1) (- i 1))
(more more (recur (if node
(vector-ref node i)
#f)
(- height 1) more)))
((< i 0) more)))))
|