summaryrefslogtreecommitdiffstats
path: root/Transcen.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
commitae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 (patch)
treeeee15e02ae016333546d3841712be591b2bcb06f /Transcen.scm
parent302e3218b7d487539ec305bf23881a6ee7d5be99 (diff)
downloadscm-ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7.tar.gz
scm-ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7.zip
Import Upstream version 5e2upstream/5e2
Diffstat (limited to 'Transcen.scm')
-rw-r--r--Transcen.scm134
1 files changed, 27 insertions, 107 deletions
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))))))))