"Fossies" - the Fresh Open Source Software Archive

Member "scm/Transcen.scm" (10 Jan 2018, 5556 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "Transcen.scm": 5f2_vs_5f3.

    1 ;;;; "Transcen.scm", Complex transcendental functions for SCM.
    2 ;; Copyright (C) 1992, 1993, 1995, 1997, 2005, 2006, 2018 Free Software Foundation, Inc.
    3 ;;
    4 ;; This program is free software: you can redistribute it and/or modify
    5 ;; it under the terms of the GNU Lesser General Public License as
    6 ;; published by the Free Software Foundation, either version 3 of the
    7 ;; License, or (at your option) any later version.
    8 ;;
    9 ;; This program is distributed in the hope that it will be useful, but
   10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
   11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12 ;; Lesser General Public License for more details.
   13 ;;
   14 ;; You should have received a copy of the GNU Lesser General Public
   15 ;; License along with this program.  If not, see
   16 ;; <http://www.gnu.org/licenses/>.
   17 
   18 ;;; Author: Jerry D. Hedden.
   19 
   20 ;;;; 2005-05 SRFI-70 extensions.
   21 ;;; Author: Aubrey Jaffer
   22 
   23 (define compile-allnumbers #t)      ;for HOBBIT compiler
   24 
   25 ;;;; Legacy real function names
   26 (cond
   27  ((defined? $exp)
   28   (define real-sqrt $sqrt)
   29   (define real-exp $exp)
   30   (define real-expt $expt)
   31   (define real-ln $log)
   32   (define real-log10 $log10)
   33 
   34   (define real-sin $sin)
   35   (define real-cos $cos)
   36   (define real-tan $tan)
   37   (define real-asin $asin)
   38   (define real-acos $acos)
   39   (define real-atan $atan)
   40 
   41   (define real-sinh $sinh)
   42   (define real-cosh $cosh)
   43   (define real-tanh $tanh)
   44   (define real-asinh $asinh)
   45   (define real-acosh $acosh)
   46   (define real-atanh $atanh))
   47 
   48  (else
   49   (define $sqrt real-sqrt)
   50   (define $exp real-exp)
   51   (define $expt real-expt)
   52   (define $log real-ln)
   53   (define $log10 real-log10)
   54 
   55   (define $sin real-sin)
   56   (define $cos real-cos)
   57   (define $tan real-tan)
   58   (define $asin real-asin)
   59   (define $acos real-acos)
   60   (define $atan real-atan)
   61 
   62   (define $sinh real-sinh)
   63   (define $cosh real-cosh)
   64   (define $tanh real-tanh)
   65   (define $asinh real-asinh)
   66   (define $acosh real-acosh)
   67   (define $atanh real-atanh)))
   68 
   69 (define (real-log base x)
   70   (if (and (real? x) (not (negative? x)) (real? base) (positive? base))
   71       (/ (real-ln x) (real-ln base))
   72       (slib:error 'real-log base x)))
   73 
   74 (define $pi (* 4 (real-atan 1)))
   75 (define pi $pi)
   76 (define (pi* z) (* $pi z))
   77 (define (pi/ z) (/ $pi z))
   78 
   79 ;;;; Complex functions
   80 
   81 (define (exp z)
   82   (if (real? z) (real-exp z)
   83       (make-polar (real-exp (real-part z)) (imag-part z))))
   84 
   85 (define (ln z)
   86   (if (and (real? z) (>= z 0))
   87       (real-ln z)
   88       (make-rectangular (real-ln (magnitude z)) (angle z))))
   89 (define log ln)
   90 
   91 (define (sqrt z)
   92   (if (real? z)
   93       (if (negative? z) (make-rectangular 0 (real-sqrt (- z)))
   94       (real-sqrt z))
   95       (make-polar (real-sqrt (magnitude z)) (/ (angle z) 2))))
   96 
   97 (define (sinh z)
   98   (if (real? z) (real-sinh z)
   99       (let ((x (real-part z)) (y (imag-part z)))
  100     (make-rectangular (* (real-sinh x) (real-cos y))
  101               (* (real-cosh x) (real-sin y))))))
  102 (define (cosh z)
  103   (if (real? z) (real-cosh z)
  104       (let ((x (real-part z)) (y (imag-part z)))
  105     (make-rectangular (* (real-cosh x) (real-cos y))
  106               (* (real-sinh x) (real-sin y))))))
  107 (define (tanh z)
  108   (if (real? z) (real-tanh z)
  109       (let* ((x (* 2 (real-part z)))
  110          (y (* 2 (imag-part z)))
  111          (w (+ (real-cosh x) (real-cos y))))
  112     (make-rectangular (/ (real-sinh x) w) (/ (real-sin y) w)))))
  113 
  114 (define (asinh z)
  115   (if (real? z) (real-asinh z)
  116       (log (+ z (sqrt (+ (* z z) 1))))))
  117 
  118 (define (acosh z)
  119   (if (and (real? z) (>= z 1))
  120       (real-acosh z)
  121       (log (+ z (sqrt (- (* z z) 1))))))
  122 
  123 (define (atanh z)
  124   (if (and (real? z) (> z -1) (< z 1))
  125       (real-atanh z)
  126       (/ (log (/ (+ 1 z) (- 1 z))) 2)))
  127 
  128 (define (sin z)
  129   (if (real? z) (real-sin z)
  130       (let ((x (real-part z)) (y (imag-part z)))
  131     (make-rectangular (* (real-sin x) (real-cosh y))
  132               (* (real-cos x) (real-sinh y))))))
  133 (define (cos z)
  134   (if (real? z) (real-cos z)
  135       (let ((x (real-part z)) (y (imag-part z)))
  136     (make-rectangular (* (real-cos x) (real-cosh y))
  137               (- (* (real-sin x) (real-sinh y)))))))
  138 (define (tan z)
  139   (if (real? z) (real-tan z)
  140       (let* ((x (* 2 (real-part z)))
  141          (y (* 2 (imag-part z)))
  142          (w (+ (real-cos x) (real-cosh y))))
  143     (make-rectangular (/ (real-sin x) w) (/ (real-sinh y) w)))))
  144 
  145 (define (asin z)
  146   (if (and (real? z) (>= z -1) (<= z 1))
  147       (real-asin z)
  148       (* -i (asinh (* +i z)))))
  149 
  150 (define (acos z)
  151   (if (and (real? z) (>= z -1) (<= z 1))
  152       (real-acos z)
  153       (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
  154 
  155 (define (atan z . y)
  156   (if (null? y)
  157       (if (real? z)
  158       (real-atan z)
  159       (/ (log (/ (- +i z) (+ +i z))) +2i))
  160       ($atan2 z (car y))))
  161 
  162 ;;;; SRFI-70
  163 (define (expt z1 z2)
  164   (cond ((and (exact? z2) (not (and (zero? z1) (negative? z2))))
  165      (integer-expt z1 z2))
  166     ((zero? z2) (+ 1 (* z1 z2)))
  167     ((and (real? z2) (real? z1) (positive? z1))
  168      (real-expt z1 z2))
  169     (else
  170      (exp (* (if (zero? z1) (real-part z2) z2) (log z1))))))
  171 
  172 (define (quo x1 x2)
  173   (if (and (exact? x1) (exact? x2))
  174       (quotient x1 x2)
  175       (truncate (/ x1 x2))))
  176 
  177 (define (rem x1 x2)
  178   (if (and (exact? x1) (exact? x2))
  179       (remainder x1 x2)
  180       (- x1 (* x2 (quo x1 x2)))))
  181 
  182 (define (mod x1 x2)
  183   (if (and (exact? x1) (exact? x2))
  184       (modulo x1 x2)
  185       (- x1 (* x2 (floor (/ x1 x2))))))
  186 
  187 (define (exact-round x) (inexact->exact (round x)))
  188 (define (exact-floor x) (inexact->exact (floor x)))
  189 (define (exact-ceiling x) (inexact->exact (ceiling x)))
  190 (define (exact-truncate x) (inexact->exact (truncate x)))
  191 
  192 (define (infinite? z) (and (= z (* 2 z)) (not (zero? z))))
  193 (define (finite? z) (not (infinite? z)))
  194 
  195 (provide 'math-real)
  196 (provide 'srfi-94)