summaryrefslogtreecommitdiffstats
path: root/Transcen.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
commit5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (patch)
tree9b744b9dbf39e716e56daa620e2f3041968caf19 /Transcen.scm
downloadscm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.tar.gz
scm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.zip
Import Upstream version 4e6upstream/4e6
Diffstat (limited to 'Transcen.scm')
-rw-r--r--Transcen.scm133
1 files changed, 133 insertions, 0 deletions
diff --git a/Transcen.scm b/Transcen.scm
new file mode 100644
index 0000000..896f77f
--- /dev/null
+++ b/Transcen.scm
@@ -0,0 +1,133 @@
+;; Copyright (C) 1992, 1993, 1995 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
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Transcen.scm", Complex trancendental functions for SCM.
+;;; Author: Jerry D. Hedden.
+
+(define compile-allnumbers #t) ;for HOBBIT compiler
+
+(define (exp z)
+ (if (real? z) ($exp z)
+ (make-polar ($exp (real-part z)) (imag-part z))))
+
+(define (log z)
+ (if (and (real? z) (>= z 0))
+ ($log z)
+ (make-rectangular ($log (magnitude z)) (angle z))))
+
+(define (sqrt z)
+ (if (real? z)
+ (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
+ ($sqrt z))
+ (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
+
+(define expt
+ (let ((integer-expt integer-expt))
+ (lambda (z1 z2)
+ (cond ((exact? z2)
+ (integer-expt z1 z2))
+ ((and (real? z2) (real? z1) (>= z1 0))
+ ($expt z1 z2))
+ (else
+ (exp (* z2 (log z1))))))))
+
+(define (sinh z)
+ (if (real? z) ($sinh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sinh x) ($cos y))
+ (* ($cosh x) ($sin y))))))
+(define (cosh z)
+ (if (real? z) ($cosh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cosh x) ($cos y))
+ (* ($sinh x) ($sin y))))))
+(define (tanh z)
+ (if (real? z) ($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)))))
+
+(define (asinh z)
+ (if (real? z) ($asinh z)
+ (log (+ z (sqrt (+ (* z z) 1))))))
+
+(define (acosh z)
+ (if (and (real? z) (>= z 1))
+ ($acosh z)
+ (log (+ z (sqrt (- (* z z) 1))))))
+
+(define (atanh z)
+ (if (and (real? z) (> z -1) (< z 1))
+ ($atanh z)
+ (/ (log (/ (+ 1 z) (- 1 z))) 2)))
+
+(define (sin z)
+ (if (real? z) ($sin z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sin x) ($cosh y))
+ (* ($cos x) ($sinh y))))))
+(define (cos z)
+ (if (real? z) ($cos z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cos x) ($cosh y))
+ (- (* ($sin x) ($sinh y)))))))
+(define (tan z)
+ (if (real? z) ($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)))))
+
+(define (asin z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($asin z)
+ (* -i (asinh (* +i z)))))
+
+(define (acos z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($acos z)
+ (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
+
+(define (atan z . y)
+ (if (null? y)
+ (if (real? z) ($atan z)
+ (/ (log (/ (- +i z) (+ +i z))) +2i))
+ ($atan2 z (car y))))