summaryrefslogtreecommitdiffstats
path: root/phil-spc.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:34 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:34 -0800
commit237c6e380aebdcbc70bd1c9ecf7d3f6effca2752 (patch)
tree9832fbdd6fbeedf3fc7f0e7923fe20b7d35b1499 /phil-spc.scm
parent5145dd3aa0c02c9fc496d1432fc4410674206e1d (diff)
downloadslib-237c6e380aebdcbc70bd1c9ecf7d3f6effca2752.tar.gz
slib-237c6e380aebdcbc70bd1c9ecf7d3f6effca2752.zip
Import Upstream version 3a3upstream/3a3
Diffstat (limited to 'phil-spc.scm')
-rw-r--r--phil-spc.scm77
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