← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/logarc.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/logarc.lisp
8
8
;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
(macsyma-module logarc)
13
13
 
14
14
;;;  Logarc and Halfangles
15
15
 
16
16
(defmfun $logarc (exp)
17
 
         (cond ((atom exp) exp)
18
 
               ((arcp (caar exp)) (logarc (caar exp) ($logarc (cadr exp))))
19
 
               ((eq (caar exp) '$atan2)
20
 
                (logarc '%atan ($logarc (div (cadr exp) (caddr exp)))))
21
 
               (t (recur-apply #'$logarc exp))))
 
17
  (cond ((atom exp) exp)
 
18
        ((arcp (caar exp)) (logarc (caar exp) ($logarc (cadr exp))))
 
19
        ((eq (caar exp) '$atan2)
 
20
         (logarc '%atan ($logarc (div (cadr exp) (caddr exp)))))
 
21
        (t (recur-apply #'$logarc exp))))
22
22
 
23
23
(defmfun logarc (f x)
24
 
  ;;Gives logarithmic form of arc trig and hyperbolic functions
25
 
 (let ((s (memq f '(%acos %atan %asinh %atanh))))
26
 
   (cond 
27
 
    ((memq f '(%acos %asin))
28
 
     (mul (min%i)
29
 
          (take '(%log)
30
 
                (add (mul (if s '$%i 1)
31
 
                           (root (add 1 (neg (power x 2))) 2))
32
 
                     (mul (if s 1 '$%i) x)))))
33
 
    ((memq f '(%atan %acot))
34
 
     (mul (i//2)
35
 
          (take '(%log) (div (add 1 (morp s (mul '$%i x)))
36
 
                             (add (mul '$%i x) (porm s 1))))))
37
 
    ((memq f '(%asinh %acosh))
38
 
     (take '(%log) (add x (root (add (power x 2) (porm s 1)) 2))))
39
 
    ((memq f '(%atanh %acoth))
40
 
     (mul (half) (take '(%log) (div (add 1 x) (morp s (add x -1))))))
41
 
    ((memq f '(%asec %acsc %asech %acsch))
42
 
     (logarc (oldget (oldget (get f '$inverse) 'recip) '$inverse) (inv x)))
43
 
    (t (merror "Bad argument to Logarc")))))
 
24
  ;;Gives the logarithmic form of arc trig and hyperbolic functions
 
25
 
 
26
  (cond ((eq f '%acos)
 
27
         ;; -%i * log(x + %i*sqrt(1-x^2))
 
28
         (mul -1 '$%i (take '(%log) (add x (mul '$%i (root (sub 1 (power x 2)) 2))))))
 
29
        ((eq f '%asin)
 
30
         ;; -%i * log(sqrt(1-x^2)+%i*x)
 
31
         (mul -1 '$%i (take '(%log) (add (mul '$%i x) (root (sub 1 (power x 2)) 2)))))
 
32
        ((eq f '%atan)
 
33
         ;; (log(1 + %i*x) - log(1 - %i*x)) /(2 %i)
 
34
         (div (sub (take '(%log) (add 1 (mul '$%i x))) (take '(%log) (sub 1 (mul '$%i x))))
 
35
              (mul 2 '$%i)))
 
36
        ((eq f '%asinh)
 
37
         ;; log(sqrt(x^2+1)+x)
 
38
         (take '(%log) (add x (root (add 1 (power x 2)) 2))))
 
39
        ((eq f '%acosh)
 
40
         ;; 2 * log(sqrt((x+1)/2)+sqrt((x-1)/2))
 
41
         (mul 2 (take '(%log) (add (root (div (add x 1) 2) 2) (root (div (add x -1) 2) 2)))))
 
42
        ((eq f '%atanh)
 
43
         ;;  (log(x+1)-log(1-x))/2
 
44
         (div (sub (take '(%log) (add 1 x)) (take '(%log) (sub 1 x))) 2))
 
45
        ((memq f '(%asec %acsc %acot %asech %acsch %acoth))
 
46
         ;; asec(x) = acos(1/x), and etc.
 
47
         (logarc (oldget (oldget (get f '$inverse) 'recip) '$inverse) (inv x)))
 
48
        (t (merror "Bad argument to 'logarc'"))))
44
49
 
45
50
(defmfun halfangle (f a)
46
 
       (and (mtimesp a)
47
 
            (ratnump (cadr a))
48
 
            (equal (caddr (cadr a)) 2)
49
 
            (halfangleaux f (mul 2 a))))
 
51
  (and (mtimesp a)
 
52
       (ratnump (cadr a))
 
53
       (equal (caddr (cadr a)) 2)
 
54
       (halfangleaux f (mul 2 a))))
50
55
 
51
 
(defun halfangleaux (f a)  ;; f=function; a=twice argument
52
 
   (let ((sw (memq f '(%cos %cot %coth %cosh))))
53
 
     (cond ((memq f '(%sin %cos))
54
 
            (power (div (add 1 (porm sw (take '(%cos) a))) 2) (1//2)))
55
 
           ((memq f '(%tan %cot))
56
 
            (div (add 1 (porm sw (take '(%cos) a))) (take '(%sin) a)))
57
 
           ((memq f '(%sinh %cosh))
58
 
            (power (div (add (take '(%cosh) a) (porm sw 1)) 2) (1//2)))
59
 
           ((memq f '(%tanh %coth))
60
 
            (div (add (take '(%cosh) a) (porm sw 1)) (take '(%sinh) a)))
61
 
           ((memq f '(%sec %csc %sech %csch))
62
 
            (inv (halfangleaux (get f 'recip) a))))))
 
56
(defun halfangleaux (f a) ;; f=function; a=twice argument
 
57
  (let ((sw (memq f '(%cos %cot %coth %cosh))))
 
58
    (cond ((memq f '(%sin %cos))
 
59
           (power (div (add 1 (porm sw (take '(%cos) a))) 2) (1//2)))
 
60
          ((memq f '(%tan %cot))
 
61
           (div (add 1 (porm sw (take '(%cos) a))) (take '(%sin) a)))
 
62
          ((memq f '(%sinh %cosh))
 
63
           (power (div (add (take '(%cosh) a) (porm sw 1)) 2) (1//2)))
 
64
          ((memq f '(%tanh %coth))
 
65
           (div (add (take '(%cosh) a) (porm sw 1)) (take '(%sinh) a)))
 
66
          ((memq f '(%sec %csc %sech %csch))
 
67
           (inv (halfangleaux (get f 'recip) a))))))
63
68