diff options
Diffstat (limited to 'phil-spc.scm')
| -rw-r--r-- | phil-spc.scm | 77 |
1 files changed, 23 insertions, 54 deletions
diff --git a/phil-spc.scm b/phil-spc.scm index 65863da..ec0bc0f 100644 --- a/phil-spc.scm +++ b/phil-spc.scm @@ -1,5 +1,5 @@ ; "phil-spc.scm": Hilbert space filling mapping -; Copyright (C) 2003 Aubrey Jaffer +; Copyright (C) 2003, 2005 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -95,21 +95,28 @@ ;;of non-negative integer coordinates. (define (hilbert-coordinates->integer coords . nbits) (define rank (length coords)) - (let ((lst (delaminate-list rank (map integer->gray-code coords))) - (rnkhib (ash 1 (+ -1 rank)))) - (define (loop lst rotation flipbit scalar) - (if (null? lst) - (gray-code->integer scalar) - (let ((chnk (rotate-bit-field (logxor flipbit (car lst)) - (- rotation) 0 rank))) - (loop (cdr lst) - (modulo (+ (log2-binary-factors chnk) 2 rotation) rank) - (ash 1 rotation) - (logior (logxor rnkhib chnk) (ash scalar rank)))))) - (loop (cdr lst) - (modulo (+ (log2-binary-factors (car lst)) 2) rank) - 1 - (car lst)))) + (set! nbits (if (null? nbits) + (* (quotient (+ -1 rank (integer-length (apply max coords))) + rank) + rank) + (car nbits))) + (if (zero? nbits) + 0 + (let ((lst (delaminate-list nbits (map integer->gray-code coords))) + (rnkhib (ash 1 (+ -1 rank)))) + (define (loop lst rotation flipbit scalar) + (if (null? lst) + (gray-code->integer scalar) + (let ((chnk (rotate-bit-field (logxor flipbit (car lst)) + (- rotation) 0 rank))) + (loop (cdr lst) + (modulo (+ (log2-binary-factors chnk) 2 rotation) rank) + (ash 1 rotation) + (logior (logxor rnkhib chnk) (ash scalar rank)))))) + (loop (cdr lst) + (modulo (+ (log2-binary-factors (car lst)) 2) rank) + 1 + (car lst))))) ;;@subsubsection Gray code ;; @@ -183,44 +190,6 @@ ;;@subsubsection Bitwise Lamination ;;@cindex lamination -;;@args k1 @dots{} -;;Returns an integer composed of the bits of @var{k1} @dots{} interlaced -;;in argument order. Given @var{k1}, @dots{} @var{kn}, the n low-order -;;bits of the returned value will be the lowest-order bit of each -;;argument. -;; -;;@args count k -;;Returns a list of @var{count} integers comprised of every @var{count}h -;;bit of the integer @var{k}. -;; -;;@example -;;(map (lambda (k) (number->string k 2)) -;; (bitwise-delaminate 4 #x7654)) -;; @result{} ("0" "1111" "1100" "1010") -;;(number->string (bitwise-laminate 0 #b1111 #b1100 #b1010) 16) -;; @result{} "7654" -;@end example -;; -;;For any non-negative integers @var{k} and @var{count}: -;;@example -;;(eqv? k (bitwise-laminate (bitwise-delaminate count k))) -;;@end example -(define (bitwise-laminate . ks) - (define nks (length ks)) - (define nbs (apply max (map integer-length ks))) - (do ((kdx (+ -1 nbs) (+ -1 kdx)) - (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks)) - (arithmetic-shift ibs nks)))) - ((negative? kdx) ibs))) -(define (bitwise-delaminate count k) - (define nbs (* count (+ 1 (quotient (integer-length k) count)))) - (do ((kdx (- nbs count) (- kdx count)) - (lst (vector->list (make-vector count 0)) - (map (lambda (k bool) (+ (if bool 1 0) (arithmetic-shift k 1))) - lst - (integer->list (arithmetic-shift k (- kdx)) count)))) - ((negative? kdx) lst))) - ;;@body ;; ;;Returns a list of @var{count} integers comprised of the @var{j}th |