summaryrefslogtreecommitdiffstats
path: root/peanosfc.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 /peanosfc.scm
parent5145dd3aa0c02c9fc496d1432fc4410674206e1d (diff)
downloadslib-237c6e380aebdcbc70bd1c9ecf7d3f6effca2752.tar.gz
slib-237c6e380aebdcbc70bd1c9ecf7d3f6effca2752.zip
Import Upstream version 3a3upstream/3a3
Diffstat (limited to 'peanosfc.scm')
-rw-r--r--peanosfc.scm51
1 files changed, 43 insertions, 8 deletions
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)))))