home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / scm / Transcen < prev    next >
Text File  |  1994-05-11  |  3KB  |  95 lines
  1. ;;;; "Transcen.scm", Complex trancendental functions for SCM.
  2. ;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
  3. ;;; See the file `COPYING' for terms applying to this program.
  4.  
  5. (define compile-allnumbers #t)        ;for HOBBIT compiler
  6.  
  7. (define (exp z)
  8.   (if (real? z) ($exp z)
  9.       (make-polar ($exp (real-part z)) (imag-part z))))
  10.  
  11. (define (log z)
  12.   (if (and (real? z) (>= z 0))
  13.       ($log z)
  14.       (make-rectangular ($log (magnitude z)) (angle z))))
  15.  
  16. (define (sqrt z)
  17.   (if (real? z)
  18.       (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
  19.       ($sqrt z))
  20.       (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
  21.  
  22. (define expt
  23.   (let ((integer-expt integer-expt))
  24.     (lambda (z1 z2)
  25.       (cond ((exact? z2)
  26.          (integer-expt z1 z2))
  27.         ((and (real? z2) (real? z1) (>= z1 0))
  28.          ($expt z1 z2))
  29.         (else
  30.          (exp (* z2 (log z1))))))))
  31.  
  32. (define (sinh z)
  33.   (if (real? z) ($sinh z)
  34.       (let ((x (real-part z)) (y (imag-part z)))
  35.     (make-rectangular (* ($sinh x) ($cos y))
  36.               (* ($cosh x) ($sin y))))))
  37. (define (cosh z)
  38.   (if (real? z) ($cosh z)
  39.       (let ((x (real-part z)) (y (imag-part z)))
  40.     (make-rectangular (* ($cosh x) ($cos y))
  41.               (* ($sinh x) ($sin y))))))
  42. (define (tanh z)
  43.   (if (real? z) ($tanh z)
  44.       (let* ((x (* 2 (real-part z)))
  45.          (y (* 2 (imag-part z)))
  46.          (w (+ ($cosh x) ($cos y))))
  47.     (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
  48.  
  49. (define (asinh z)
  50.   (if (real? z) ($asinh z)
  51.       (log (+ z (sqrt (+ (* z z) 1))))))
  52.  
  53. (define (acosh z)
  54.   (if (and (real? z) (>= z 1))
  55.       ($acosh z)
  56.       (log (+ z (sqrt (- (* z z) 1))))))
  57.  
  58. (define (atanh z)
  59.   (if (and (real? z) (> z -1) (< z 1))
  60.       ($atanh z)
  61.       (/ (log (/ (+ 1 z) (- 1 z))) 2)))
  62.  
  63. (define (sin z)
  64.   (if (real? z) ($sin z)
  65.       (let ((x (real-part z)) (y (imag-part z)))
  66.     (make-rectangular (* ($sin x) ($cosh y))
  67.               (* ($cos x) ($sinh y))))))
  68. (define (cos z)
  69.   (if (real? z) ($cos z)
  70.       (let ((x (real-part z)) (y (imag-part z)))
  71.     (make-rectangular (* ($cos x) ($cosh y))
  72.               (- (* ($sin x) ($sinh y)))))))
  73. (define (tan z)
  74.   (if (real? z) ($tan z)
  75.       (let* ((x (* 2 (real-part z)))
  76.          (y (* 2 (imag-part z)))
  77.          (w (+ ($cos x) ($cosh y))))
  78.     (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
  79.  
  80. (define (asin z)
  81.   (if (and (real? z) (>= z -1) (<= z 1))
  82.       ($asin z)
  83.       (* -i (asinh (* +i z)))))
  84.  
  85. (define (acos z)
  86.   (if (and (real? z) (>= z -1) (<= z 1))
  87.       ($acos z)
  88.       (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
  89.  
  90. (define (atan z . y)
  91.   (if (null? y)
  92.       (if (real? z) ($atan z)
  93.       (/ (log (/ (- +i z) (+ +i z))) +2i))
  94.       ($atan2 z (car y))))
  95.