From 237c6e380aebdcbc70bd1c9ecf7d3f6effca2752 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:34 -0800
Subject: Import Upstream version 3a3

---
 peanosfc.scm | 51 +++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 43 insertions(+), 8 deletions(-)

(limited to 'peanosfc.scm')

diff --git a/peanosfc.scm b/peanosfc.scm
index 4a4039a..5cac088 100644
--- a/peanosfc.scm
+++ b/peanosfc.scm
@@ -19,17 +19,20 @@
 
 (require 'array)
 
+;;@code{(require 'peano-fill)}
+;;@ftindex peano-fill
+
 ;;; A. R. Butz.
 ;;; Space filling curves and mathematical programming.
 ;;; Information and Control, 12:314-330, 1968. 
 
-(define (integer->tet-array scalar rank)
+(define (natural->tet-array scalar rank)
   (do ((tets '() (cons (modulo scl 3) tets))
        (scl scalar (quotient scl 3)))
       ((zero? scl)
        (let* ((len (length tets))
 	      (depth (quotient (+ len rank -1) rank)))
-	 (define tra (make-array (A:fixN8b 0) rank depth))
+	 (define tra (make-array (A:fixZ8b 0) rank depth))
 	 (set! tets (reverse tets))
 	 (do ((idx (+ -1 depth) (+ -1 idx)))
 	     ((negative? idx))
@@ -40,7 +43,7 @@
 			 (set! tets (cdr tets))))))
 	 tra))))
 
-(define (tet-array->integer tra)
+(define (tet-array->natural tra)
   (define rank (car (array-dimensions tra)))
   (define depth (cadr (array-dimensions tra)))
   (define val 0)
@@ -88,22 +91,54 @@
 	(do ((idx (+ -1 idx) (+ -1 idx)))
 	    ((negative? idx))
 	  (set! tpar (+ (array-ref tra rdx idx) tpar)))
-	(array-set! tra (if (odd? tpar) (- 2 v_ij) v_ij) rdx idx)
+	(if (odd? tpar) (array-set! tra (- 2 v_ij) rdx idx))
 	(set! parity (modulo (+ parity v_ij) 2))))))
 
 ;;@body
 ;;Returns a list of @2 nonnegative integer coordinates corresponding
 ;;to exact nonnegative integer @1.  The lists returned by @0 for @1
 ;;arguments 0 and 1 will differ in the first element.
-(define (integer->peano-coordinates scalar rank)
-  (define tra (integer->tet-array scalar rank))
+(define (natural->peano-coordinates scalar rank)
+  (define tra (natural->tet-array scalar rank))
   (peano-flip! tra)
   (tet-array->coordinates tra))
 
 ;;@body
 ;;Returns an exact nonnegative integer corresponding to @1, a list of
 ;;nonnegative integer coordinates.
-(define (peano-coordinates->integer coords)
+(define (peano-coordinates->natural coords)
   (define tra (coordinates->tet-array coords))
   (peano-flip! tra)
-  (tet-array->integer tra))
+  (tet-array->natural tra))
+
+;;@body
+;;Returns a list of @2 integer coordinates corresponding to exact
+;;integer @1.  The lists returned by @0 for @1 arguments 0 and 1 will
+;;differ in the first element.
+(define (integer->peano-coordinates scalar rank)
+  (define three^rank (expt 3 rank))
+  (do ((edx 1 (* edx three^rank))
+       (m 0 (+ 1 m)))
+      ((>= (quotient edx 2) (abs scalar))
+       (let ((tra (natural->tet-array (+ scalar (quotient edx 2)) rank))
+	     (offset (quotient (expt 3 m) 2)))
+	 (peano-flip! tra)
+	 (map (lambda (k) (* (if (odd? m) -1 1) (- k offset)))
+	      (tet-array->coordinates tra))))))
+
+;;@body
+;;Returns an exact integer corresponding to @1, a list of integer
+;;coordinates.
+(define (peano-coordinates->integer coords)
+  (define cobs (apply max (map abs coords)))
+  (let loop ((xpo 1))
+    (define offset (quotient (expt 3 xpo) 2))
+    (if (>= offset cobs)
+	(let ((tra (coordinates->tet-array
+		    (map (lambda (elt) (+ elt offset))
+			 coords))))
+	  (peano-flip! tra)
+	  ((if (odd? xpo) - +)
+	   (- (tet-array->natural tra)
+	      (quotient (expt 3 (* (length coords) xpo)) 2))))
+	(loop (+ 1 xpo)))))
-- 
cgit v1.2.3