/usr/share/scsh-0.6/misc/hilbert.scm is in scsh-common-0.6 0.6.7-8.
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 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | ; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
;Date: Thu, 4 Nov 93 14:34:04 EST
;Subject: binary search trees
;From: kelsey@research.nj.nec.com
;
;If you want to add the Hilbert tables I think you should change
;the name and add some documentation. Neither the name nor the
;only comment in the file are particulary informative. They are
;not infinite dimensional vectors, just arbitrarily large one
;dimensional ones.
;
;How about make-big-vector etc.?
; 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...
; ,open bitwise define-record-types
(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
(really-make-hilbert height root)
(height hilbert-height set-hilbert-height!)
(root hilbert-root set-hilbert-root!))
(define (make-hilbert)
(really-make-hilbert 1 (make-vector hilbert-node-size #f)))
(define (hilbert-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 (hilbert-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)))
(write `(higher ,index)) (newline)
(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)))
;; (write `(wider ,index)) (newline)
(vector-set! node index new)
new)))
; For debugging
;(define (hilbert->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)))))
|