From 5bea21e81ed516440e34e480f2c33ca41aa8c597 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:36 -0800 Subject: Import Upstream version 3a4 --- peanosfc.scm | 78 ++++++++++++++++++++++++++++-------------------------------- 1 file changed, 37 insertions(+), 41 deletions(-) (limited to 'peanosfc.scm') diff --git a/peanosfc.scm b/peanosfc.scm index 5cac088..388be9f 100644 --- a/peanosfc.scm +++ b/peanosfc.scm @@ -1,5 +1,5 @@ ; "peanospc.scm": Peano space filling mapping -; Copyright (C) 2005 Aubrey Jaffer +; Copyright (C) 2005, 2006 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 @@ -26,24 +26,23 @@ ;;; Space filling curves and mathematical programming. ;;; Information and Control, 12:314-330, 1968. -(define (natural->tet-array scalar rank) - (do ((tets '() (cons (modulo scl 3) tets)) +(define (natural->trit-array scalar rank) + (do ((trits '() (cons (modulo scl 3) trits)) (scl scalar (quotient scl 3))) ((zero? scl) - (let* ((len (length tets)) - (depth (quotient (+ len rank -1) rank))) + (let ((depth (quotient (+ (length trits) rank -1) rank))) (define tra (make-array (A:fixZ8b 0) rank depth)) - (set! tets (reverse tets)) + (set! trits (reverse trits)) (do ((idx (+ -1 depth) (+ -1 idx))) ((negative? idx)) (do ((rdx 0 (+ 1 rdx))) ((>= rdx rank)) - (cond ((null? tets)) - (else (array-set! tra (car tets) rdx idx) - (set! tets (cdr tets)))))) + (cond ((null? trits)) + (else (array-set! tra (car trits) rdx idx) + (set! trits (cdr trits)))))) tra)))) -(define (tet-array->natural tra) +(define (trit-array->natural tra) (define rank (car (array-dimensions tra))) (define depth (cadr (array-dimensions tra))) (define val 0) @@ -53,22 +52,20 @@ ((negative? rdx)) (set! val (+ (array-ref tra rdx idx) (* 3 val)))))) -(define (tet-array->coordinates tra) - (define rank (car (array-dimensions tra))) +(define (trit-array->natural-coordinates tra) (define depth (cadr (array-dimensions tra))) - (do ((rdx (+ -1 rank) (+ -1 rdx)) + (do ((rdx (+ -1 (car (array-dimensions tra))) (+ -1 rdx)) (lst '() (cons (do ((idx 0 (+ 1 idx)) (val 0 (+ (array-ref tra rdx idx) (* 3 val)))) ((>= idx depth) val)) lst))) ((negative? rdx) lst))) -(define (coordinates->tet-array coords) +(define (natural-coordinates->trit-array coords) (define depth (do ((scl (apply max coords) (quotient scl 3)) (dpt 0 (+ 1 dpt))) ((zero? scl) dpt))) - (define rank (length coords)) - (let ((tra (make-array (A:fixN8b 0) rank depth))) + (let ((tra (make-array (A:fixN8b 0) (length coords) depth))) (do ((rdx 0 (+ 1 rdx)) (cds coords (cdr cds))) ((null? cds)) @@ -82,63 +79,62 @@ (define parity 0) (define rank (car (array-dimensions tra))) (define depth (cadr (array-dimensions tra))) + (define rra (make-array (A:fixN8b 0) (car (array-dimensions tra)))) (do ((idx 0 (+ 1 idx))) ((>= idx depth)) (do ((rdx (+ -1 rank) (+ -1 rdx))) ((negative? rdx)) - (let ((v_ij (array-ref tra rdx idx)) - (tpar parity)) - (do ((idx (+ -1 idx) (+ -1 idx))) - ((negative? idx)) - (set! tpar (+ (array-ref tra rdx idx) tpar))) - (if (odd? tpar) (array-set! tra (- 2 v_ij) rdx idx)) - (set! parity (modulo (+ parity v_ij) 2)))))) + (let ((v_ij (array-ref tra rdx idx))) + (if (odd? (+ parity (array-ref rra rdx))) + (array-set! tra (- 2 v_ij) rdx idx)) + (set! parity (modulo (+ v_ij parity) 2)) + (array-set! rra (modulo (+ v_ij (array-ref rra rdx)) 2) rdx))))) ;;@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 (natural->peano-coordinates scalar rank) - (define tra (natural->tet-array scalar rank)) + (define tra (natural->trit-array scalar rank)) (peano-flip! tra) - (tet-array->coordinates tra)) + (trit-array->natural-coordinates tra)) ;;@body ;;Returns an exact nonnegative integer corresponding to @1, a list of ;;nonnegative integer coordinates. (define (peano-coordinates->natural coords) - (define tra (coordinates->tet-array coords)) + (define tra (natural-coordinates->trit-array coords)) (peano-flip! tra) - (tet-array->natural tra)) + (trit-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))) + (define nine^rank (expt 9 rank)) + (do ((edx 1 (* edx nine^rank)) + (cdx 1 (* cdx 9))) ((>= (quotient edx 2) (abs scalar)) - (let ((tra (natural->tet-array (+ scalar (quotient edx 2)) rank)) - (offset (quotient (expt 3 m) 2))) + (let ((tra (natural->trit-array (+ scalar (quotient edx 2)) rank)) + (offset (quotient cdx 2))) (peano-flip! tra) - (map (lambda (k) (* (if (odd? m) -1 1) (- k offset))) - (tet-array->coordinates tra)))))) + (map (lambda (k) (- k offset)) + (trit-array->natural-coordinates tra)))))) ;;@body ;;Returns an exact integer corresponding to @1, a list of integer ;;coordinates. (define (peano-coordinates->integer coords) + (define nine^rank (expt 9 (length coords))) (define cobs (apply max (map abs coords))) - (let loop ((xpo 1)) - (define offset (quotient (expt 3 xpo) 2)) + (let loop ((edx 1) (cdx 1)) + (define offset (quotient cdx 2)) (if (>= offset cobs) - (let ((tra (coordinates->tet-array + (let ((tra (natural-coordinates->trit-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))))) + (- (trit-array->natural tra) + (quotient edx 2))) + (loop (* nine^rank edx) (* 9 cdx))))) -- cgit v1.2.3