diff options
Diffstat (limited to 'Transcen.scm')
| -rw-r--r-- | Transcen.scm | 170 |
1 files changed, 105 insertions, 65 deletions
diff --git a/Transcen.scm b/Transcen.scm index 3b87837..fe0330d 100644 --- a/Transcen.scm +++ b/Transcen.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1992, 1993, 1995, 1997, 2005 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1995, 1997, 2005, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -45,122 +45,162 @@ (define compile-allnumbers #t) ;for HOBBIT compiler -(define $pi (* 4 ($atan 1))) +;;;; Legacy real function names +(cond + ((defined? $exp) + (define real-sqrt $sqrt) + (define real-exp $exp) + (define real-expt $expt) + (define real-ln $log) + (define real-log10 $log10) + + (define real-sin $sin) + (define real-cos $cos) + (define real-tan $tan) + (define real-asin $asin) + (define real-acos $acos) + (define real-atan $atan) + + (define real-sinh $sinh) + (define real-cosh $cosh) + (define real-tanh $tanh) + (define real-asinh $asinh) + (define real-acosh $acosh) + (define real-atanh $atanh)) + + (else + (define $sqrt real-sqrt) + (define $exp real-exp) + (define $expt real-expt) + (define $log real-ln) + (define $log10 real-log10) + + (define $sin real-sin) + (define $cos real-cos) + (define $tan real-tan) + (define $asin real-asin) + (define $acos real-acos) + (define $atan real-atan) + + (define $sinh real-sinh) + (define $cosh real-cosh) + (define $tanh real-tanh) + (define $asinh real-asinh) + (define $acosh real-acosh) + (define $atanh real-atanh))) + +(define $pi (* 4 (real-atan 1))) (define pi $pi) (define (pi* z) (* $pi z)) (define (pi/ z) (/ $pi z)) +;;;; Complex functions + (define (exp z) - (if (real? z) ($exp z) - (make-polar ($exp (real-part z)) (imag-part z)))) + (if (real? z) (real-exp z) + (make-polar (real-exp (real-part z)) (imag-part z)))) -(define (log z) +(define (ln z) (if (and (real? z) (>= z 0)) - ($log z) - (make-rectangular ($log (magnitude z)) (angle z)))) + (real-ln z) + (make-rectangular (real-ln (magnitude z)) (angle z)))) +(define log ln) (define (sqrt z) (if (real? z) - (if (negative? z) (make-rectangular 0 ($sqrt (- z))) - ($sqrt z)) - (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) + (if (negative? z) (make-rectangular 0 (real-sqrt (- z))) + (real-sqrt z)) + (make-polar (real-sqrt (magnitude z)) (/ (angle z) 2)))) (define (sinh z) - (if (real? z) ($sinh z) + (if (real? z) (real-sinh z) (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($sinh x) ($cos y)) - (* ($cosh x) ($sin y)))))) + (make-rectangular (* (real-sinh x) (real-cos y)) + (* (real-cosh x) (real-sin y)))))) (define (cosh z) - (if (real? z) ($cosh z) + (if (real? z) (real-cosh z) (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($cosh x) ($cos y)) - (* ($sinh x) ($sin y)))))) + (make-rectangular (* (real-cosh x) (real-cos y)) + (* (real-sinh x) (real-sin y)))))) (define (tanh z) - (if (real? z) ($tanh z) + (if (real? z) (real-tanh z) (let* ((x (* 2 (real-part z))) (y (* 2 (imag-part z))) - (w (+ ($cosh x) ($cos y)))) - (make-rectangular (/ ($sinh x) w) (/ ($sin y) w))))) + (w (+ (real-cosh x) (real-cos y)))) + (make-rectangular (/ (real-sinh x) w) (/ (real-sin y) w))))) (define (asinh z) - (if (real? z) ($asinh z) + (if (real? z) (real-asinh z) (log (+ z (sqrt (+ (* z z) 1)))))) (define (acosh z) (if (and (real? z) (>= z 1)) - ($acosh z) + (real-acosh z) (log (+ z (sqrt (- (* z z) 1)))))) (define (atanh z) (if (and (real? z) (> z -1) (< z 1)) - ($atanh z) + (real-atanh z) (/ (log (/ (+ 1 z) (- 1 z))) 2))) (define (sin z) - (if (real? z) ($sin z) + (if (real? z) (real-sin z) (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($sin x) ($cosh y)) - (* ($cos x) ($sinh y)))))) + (make-rectangular (* (real-sin x) (real-cosh y)) + (* (real-cos x) (real-sinh y)))))) (define (cos z) - (if (real? z) ($cos z) + (if (real? z) (real-cos z) (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($cos x) ($cosh y)) - (- (* ($sin x) ($sinh y))))))) + (make-rectangular (* (real-cos x) (real-cosh y)) + (- (* (real-sin x) (real-sinh y))))))) (define (tan z) - (if (real? z) ($tan z) + (if (real? z) (real-tan z) (let* ((x (* 2 (real-part z))) (y (* 2 (imag-part z))) - (w (+ ($cos x) ($cosh y)))) - (make-rectangular (/ ($sin x) w) (/ ($sinh y) w))))) + (w (+ (real-cos x) (real-cosh y)))) + (make-rectangular (/ (real-sin x) w) (/ (real-sinh y) w))))) (define (asin z) (if (and (real? z) (>= z -1) (<= z 1)) - ($asin z) + (real-asin z) (* -i (asinh (* +i z))))) (define (acos z) (if (and (real? z) (>= z -1) (<= z 1)) - ($acos z) + (real-acos z) (+ (/ (angle -1) 2) (* +i (asinh (* +i z)))))) (define (atan z . y) (if (null? y) - (if (real? z) ($atan z) + (if (real? z) + (real-atan z) (/ (log (/ (- +i z) (+ +i z))) +2i)) ($atan2 z (car y)))) ;;;; SRFI-70 -(define expt - (let ((integer-expt integer-expt)) - (lambda (z1 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)))))))) - -(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 (expt z1 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)) + (real-expt z1 z2)) + (else + (exp (* (if (zero? z1) (real-part z2) z2) (log z1)))))) + +(define (quo x1 x2) + (if (and (exact? x1) (exact? x2)) + (quotient x1 x2) + (truncate (/ x1 x2)))) + +(define (rem x1 x2) + (if (and (exact? x1) (exact? x2)) + (remainder x1 x2) + (- x1 (* x2 (quo x1 x2))))) + +(define (mod x1 x2) + (if (and (exact? x1) (exact? x2)) + (modulo x1 x2) + (- x1 (* x2 (floor (/ x1 x2)))))) (define (exact-round x) (inexact->exact (round x))) (define (exact-floor x) (inexact->exact (floor x))) |