Import Upstream version 3a3upstream/3a3

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