From ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:31 -0800
Subject: Import Upstream version 5e2

---
 Transcen.scm | 134 ++++++++++++-----------------------------------------------
 1 file changed, 27 insertions(+), 107 deletions(-)

(limited to 'Transcen.scm')

diff --git a/Transcen.scm b/Transcen.scm
index dd869a7..3b87837 100644
--- a/Transcen.scm
+++ b/Transcen.scm
@@ -133,119 +133,39 @@
 (define expt
   (let ((integer-expt integer-expt))
     (lambda (z1 z2)
-      (cond ((and (exact? z2) (not (and (zero? z1) (not (positive? z2)))))
+      (cond ((and (exact? z2) (not (and (zero? z1) (negative? z2))))
 	     (integer-expt z1 z2))
+	    ((zero? z2) (+ 1 (* z1 z2)))
 	    ((and (real? z2) (real? z1) (positive? z1))
 	     ($expt z1 z2))
 	    (else
 	     (exp (* (if (zero? z1) (real-part z2) z2) (log z1))))))))
 
-(set! quotient
-      (let ((integer-quotient quotient))
-	(lambda (x1 x2)
-	  (if (and (exact? x1) (exact? x2))
-	      (integer-quotient x1 x2)
-	      (truncate (/ x1 x2))))))
-
-(set! remainder
-      (let ((integer-remainder remainder))
-	(lambda (x1 x2)
-	  (if (and (exact? x1) (exact? x2))
-	      (integer-remainder x1 x2)
-	      (- x1 (* x2 (quotient x1 x2)))))))
-
-(set! modulo
-      (let ((integer-modulo modulo))
-	(lambda (x1 x2)
-	  (if (and (exact? x1) (exact? x2))
-	      (integer-modulo x1 x2)
-	      (- x1 (* x2 (floor (/ x1 x2))))))))
+(define quo
+  (let ((integer-quotient quotient))
+    (lambda (x1 x2)
+      (if (and (exact? x1) (exact? x2))
+	  (integer-quotient x1 x2)
+	  (truncate (/ x1 x2))))))
+
+(define rem
+  (let ((integer-remainder remainder))
+    (lambda (x1 x2)
+      (if (and (exact? x1) (exact? x2))
+	  (integer-remainder x1 x2)
+	  (- x1 (* x2 (quotient x1 x2)))))))
+
+(define mod
+  (let ((integer-modulo modulo))
+    (lambda (x1 x2)
+      (if (and (exact? x1) (exact? x2))
+	  (integer-modulo x1 x2)
+	  (- x1 (* x2 (floor (/ x1 x2))))))))
+
+(define (exact-round x) (inexact->exact (round x)))
+(define (exact-floor x) (inexact->exact (floor x)))
+(define (exact-ceiling x) (inexact->exact (ceiling x)))
+(define (exact-truncate x) (inexact->exact (truncate x)))
 
 (define (infinite? z) (and (= z (* 2 z)) (not (zero? z))))
 (define (finite? z) (not (infinite? z)))
-
-(define (invintp f1 f2 f3)
-  (define f1^2 (* f1 f1))
-  (define f2^2 (* f2 f2))
-  (define f3^2 (expt f3 2))
-  (let ((c (+ (* -3 f1^2 f2)
-	      (* 3 f1 f2^2)
-	      (* (- (* 2 f1^2) f2^2) f3)
-	      (* (- f2 (* 2 f1)) f3^2)))
-	(b (+ (- f1^2 (* 2 f2^2)) f3^2))
-	(a (- (* 2 f2) f1 f3)))
-    (define disc (- (* b b) (* 4 a c)))
-    (if (negative? (real-part disc))
-	(/ b -2 a)
-	(let ((sqrt-disc (sqrt disc)))
-	  (define root+ (/ (- sqrt-disc b) 2 a))
-	  (define root- (/ (+ sqrt-disc b) -2 a))
-	  (if (< (magnitude (- root+ f1)) (magnitude (- root- f1)))
-	      root+
-	      root-)))))
-
-(define (extrapolate-0 fs)
-  (define n (length fs))
-  (define (choose n k)
-    (do ((kdx 1 (+ 1 kdx))
-	 (prd 1 (/ (* (- n kdx -1) prd) kdx)))
-	((> kdx k) prd)))
-  (do ((k 1 (+ 1 k))
-       (lst fs (cdr lst))
-       (L 0 (+ (* -1 (expt -1 k) (choose n k) (car lst)) L)))
-      ((null? lst) L)))
-
-(define (sequence->limit proc sequence)
-  (define lval (proc (car sequence)))
-  (if (finite? lval)
-      (let ((val (proc (cadr sequence))))
-	(define h_n*nsamps (* (length sequence) (magnitude (- val lval))))
-	(if (finite? val)
-	    (let loop ((sequence (cddr sequence))
-		       (fxs (list val lval))
-		       (trend #f)
-		       (ldelta (- val lval))
-		       (jdx (+ -1 (length sequence))))
-	      (cond ((null? sequence)
-		     (case trend
-		       ((diverging) (and (real? val) (* ldelta 1/0)))
-		       ((bounded) (invintp val lval (caddr fxs)))
-		       (else (cond ((zero? ldelta) val)
-				   ((not (real? val)) #f)
-				   (else (extrapolate-0 fxs))))))
-		    (else
-		     (set! lval val)
-		     (set! val (proc (car sequence)))
-		     (if (finite? val)
-			 (let ((delta (- val lval)))
-			   (define h_j (/ h_n*nsamps jdx))
-			   (cond ((case trend
-				    ((converging) (<= (magnitude delta) h_j))
-				    ((bounded)    (<= (magnitude ldelta) (magnitude delta)))
-				    ((diverging)  (>= (magnitude delta) h_j))
-				    (else #f))
-				  (loop (cdr sequence) (cons val fxs) trend delta (+ -1 jdx)))
-				 (trend #f)
-				 (else
-				  (loop (cdr sequence) (cons val fxs)
-					(cond ((> (magnitude delta) h_j) 'diverging)
-					      ((< (magnitude ldelta) (magnitude delta)) 'bounded)
-					      (else 'converging))
-					delta (+ -1 jdx)))))
-			 (and (eq? trend 'diverging) val)))))
-	    (and (real? val) val)))
-      (and (real? lval) lval)))
-
-(define (limit proc x1 x2 . k)
-  (set! k (if (null? k) 8 (car k)))
-  (cond ((not (finite? x2)) (slib:error 'limit 'infinite 'x2 x2))
-	((not (finite? x1))
-	 (or (positive? (* x1 x2)) (slib:error 'limit 'start 'mismatch x1 x2))
-	 (limit (lambda (x) (proc (/ x))) 0.0 (/ x2) k))
-	((= x1 (+ x1 x2)) (slib:error 'limit 'null 'range x1 (+ x1 x2)))
-	(else (let ((dec (/ x2 k)))
-		(do ((x (+ x1 x2 0.0) (- x dec))
-		     (cnt (+ -1 k) (+ -1 cnt))
-		     (lst '() (cons x lst)))
-		    ((negative? cnt)
-		     (sequence->limit proc (reverse lst))))))))
-- 
cgit v1.2.3