Mercurial > emacs

changeset 60079:b676ef11ff65

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth) (calcFunc-sec, calcFunc-csc, calcFunc-cot, calcFunc-sech) (calcFunc-csch, calcFunc-coth, math-sec-raw, math-csc-raw) (math-cot-raw): New functions.
author Jay Belanger <jay.p.belanger@gmail.com>
date Tue, 15 Feb 2005 19:25:20 +0000
parents 3482f7594027
children c3660f1897f5
files lisp/calc/calc-math.el
diffstat 1 files changed, 387 insertions(+), 2 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/calc/calc-math.el	Tue Feb 15 19:24:49 2005 +0000
+++ b/lisp/calc/calc-math.el	Tue Feb 15 19:25:20 2005 +0000
@@ -144,6 +144,18 @@
   (calc-hyperbolic-func)
   (calc-sin arg))
 
+(defun calc-sec (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-unary-op "sech" 'calcFunc-sech arg)
+     (calc-unary-op "sec" 'calcFunc-sec arg))))
+
+(defun calc-sech (arg)
+  (interactive "P")
+  (calc-hyperbolic-func)
+  (calc-sec arg))
+
 (defun calc-cos (arg)
   (interactive "P")
   (calc-slow-wrapper
@@ -171,6 +183,18 @@
   (calc-hyperbolic-func)
   (calc-cos arg))
 
+(defun calc-csc (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-unary-op "csch" 'calcFunc-csch arg)
+     (calc-unary-op "csc" 'calcFunc-csc arg))))
+
+(defun calc-csch (arg)
+  (interactive "P")
+  (calc-hyperbolic-func)
+  (calc-csc arg))
+
 (defun calc-sincos ()
   (interactive)
   (calc-slow-wrapper
@@ -205,6 +229,29 @@
   (calc-hyperbolic-func)
   (calc-tan arg))
 
+(defun calc-cot (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (calc-unary-op "coth" 'calcFunc-coth arg)
+     (calc-unary-op "cot" 'calcFunc-cot arg))))
+
+(defun calc-arctan (arg)
+  (interactive "P")
+  (calc-invert-func)
+  (calc-tan arg))
+
+(defun calc-tanh (arg)
+  (interactive "P")
+  (calc-hyperbolic-func)
+  (calc-tan arg))
+
+(defun calc-arctanh (arg)
+  (interactive "P")
+  (calc-invert-func)
+  (calc-hyperbolic-func)
+  (calc-tan arg))
+
 (defun calc-arctan2 ()
   (interactive)
   (calc-slow-wrapper
@@ -220,8 +267,6 @@
   (calc-slow-wrapper
    (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1)))))
 
-
-
 (defun calc-to-degrees (arg)
   (interactive "P")
   (calc-wrapper
@@ -794,6 +839,169 @@
 	(t (calc-record-why 'scalarp x)
 	   (list 'calcFunc-tan x))))
 
+(defun calcFunc-sec (x)
+  (cond ((and (integerp x)
+              (eq calc-angle-mode 'deg)
+              (= (% x 180) 0))
+         (if (= (% x 360) 0)
+             1
+           -1))
+        ((and (integerp x)
+              (eq calc-angle-mode 'rad)
+              (= x 0))
+         1)
+        ((Math-scalarp x)
+         (math-with-extra-prec 2
+           (math-sec-raw (math-to-radians (math-float x)))))
+        ((eq (car x) 'sdev)
+         (if (math-constp x)
+             (math-with-extra-prec 2
+               (let* ((xx (math-to-radians (math-float (nth 1 x))))
+                      (xs (math-to-radians (math-float (nth 2 x))))
+                      (sc (math-sin-cos-raw xx)))
+                 (if (and (math-zerop (cdr sc))
+                          (not calc-infinite-mode))
+                     (progn
+                       (calc-record-why "*Division by zero")
+                       (list 'calcFunc-sec x))
+                   (math-make-sdev (math-div-float '(float 1 0) (cdr sc))
+                                   (math-div-float
+                                    (math-mul xs (car sc))
+                                    (math-sqr (cdr sc)))))))
+           (math-make-sdev (calcFunc-sec (nth 1 x))
+                           (math-div 
+                            (math-mul (nth 2 x)
+                                      (calcFunc-sin (nth 1 x)))
+                            (math-sqr (calcFunc-cos (nth 1 x)))))))
+        ((and (eq (car x) 'intv)
+              (math-intv-constp x))
+         (math-with-extra-prec 2
+           (let* ((xx (math-to-radians (math-float x)))
+                  (na (math-floor (math-div (math-sub (nth 2 xx)
+                                                      (math-pi-over-2))
+                                            (math-pi))))
+                  (nb (math-floor (math-div (math-sub (nth 3 xx)
+                                                      (math-pi-over-2))
+                                            (math-pi))))
+                  (naa (math-floor (math-div (nth 2 xx) (math-pi-over-2))))
+                  (nbb (math-floor (math-div (nth 3 xx) (math-pi-over-2))))
+                  (span (math-sub nbb naa)))
+             (if (not (equal na nb))
+                 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+               (let ((int (math-sort-intv (nth 1 x)
+                                          (math-sec-raw (nth 2 xx))
+                                          (math-sec-raw (nth 3 xx)))))
+                 (if (eq span 1)
+                     (if (math-evenp (math-div (math-add naa 1) 2))
+                         (math-make-intv (logior (nth 1 int) 2)
+                                         1
+                                         (nth 3 int))
+                       (math-make-intv (logior (nth 1 int) 1)
+                                       (nth 2 int)
+                                       -1))
+                   int))))))
+        ((equal x '(var nan var-nan))
+         x)
+        (t (calc-record-why 'scalarp x)
+           (list 'calcFunc-sec x))))
+
+(defun calcFunc-csc (x)
+  (cond ((and (integerp x)
+              (eq calc-angle-mode 'deg)
+              (= (% (- x 90) 180) 0))
+         (if (= (% (- x 90) 360) 0)
+             1
+           -1))
+        ((Math-scalarp x)
+         (math-with-extra-prec 2
+           (math-csc-raw (math-to-radians (math-float x)))))
+        ((eq (car x) 'sdev)
+         (if (math-constp x)
+             (math-with-extra-prec 2
+               (let* ((xx (math-to-radians (math-float (nth 1 x))))
+                      (xs (math-to-radians (math-float (nth 2 x))))
+                      (sc (math-sin-cos-raw xx)))
+                 (if (and (math-zerop (car sc))
+                          (not calc-infinite-mode))
+                     (progn
+                       (calc-record-why "*Division by zero")
+                       (list 'calcFunc-csc x))
+                   (math-make-sdev (math-div-float '(float 1 0) (car sc))
+                                   (math-div-float
+                                    (math-mul xs (cdr sc))
+                                    (math-sqr (car sc)))))))
+           (math-make-sdev (calcFunc-csc (nth 1 x))
+                           (math-div 
+                            (math-mul (nth 2 x)
+                                      (calcFunc-cos (nth 1 x)))
+                            (math-sqr (calcFunc-sin (nth 1 x)))))))
+        ((and (eq (car x) 'intv)
+              (math-intv-constp x))
+         (math-with-extra-prec 2
+           (let* ((xx (math-to-radians (math-float x)))
+                  (na (math-floor (math-div (nth 2 xx) (math-pi))))
+                  (nb (math-floor (math-div (nth 3 xx) (math-pi))))
+                  (naa (math-floor (math-div (nth 2 xx) (math-pi-over-2))))
+                  (nbb (math-floor (math-div (nth 3 xx) (math-pi-over-2))))
+                  (span (math-sub nbb naa)))
+             (if (not (equal na nb))
+                 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+               (let ((int (math-sort-intv (nth 1 x)
+                                          (math-csc-raw (nth 2 xx))
+                                          (math-csc-raw (nth 3 xx)))))
+                 (if (eq span 1)
+                     (if (math-evenp (math-div naa 2))
+                         (math-make-intv (logior (nth 1 int) 2)
+                                         1
+                                         (nth 3 int))
+                       (math-make-intv (logior (nth 1 int) 1)
+                                       (nth 2 int)
+                                       -1))
+                   int))))))
+        ((equal x '(var nan var-nan))
+         x)
+        (t (calc-record-why 'scalarp x)
+           (list 'calcFunc-csc x))))
+
+(defun calcFunc-cot (x)   ; [N N] [Public]
+  (cond ((and (integerp x)
+	      (if (eq calc-angle-mode 'deg)
+		  (= (% (- x 90) 180) 0)
+		(= x 0)))
+	 0)
+	((Math-scalarp x)
+	 (math-with-extra-prec 2
+	   (math-cot-raw (math-to-radians (math-float x)))))
+	((eq (car x) 'sdev)
+	 (if (math-constp x)
+	     (math-with-extra-prec 2
+	       (let* ((xx (math-to-radians (math-float (nth 1 x))))
+		      (xs (math-to-radians (math-float (nth 2 x))))
+		      (sc (math-sin-cos-raw xx)))
+		 (if (and (math-zerop (car sc)) (not calc-infinite-mode))
+		     (progn
+		       (calc-record-why "*Division by zero")
+		       (list 'calcFunc-cot x))
+		   (math-make-sdev (math-div-float (cdr sc) (car sc))
+				   (math-div-float xs (math-sqr (car sc)))))))
+	   (math-make-sdev (calcFunc-cot (nth 1 x))
+			   (math-div (nth 2 x)
+				     (math-sqr (calcFunc-sin (nth 1 x)))))))
+	((and (eq (car x) 'intv) (math-intv-constp x))
+	 (or (math-with-extra-prec 2
+	       (let* ((xx (math-to-radians (math-float x)))
+		      (na (math-floor (math-div (nth 2 xx) (math-pi))))
+		      (nb (math-floor (math-div (nth 3 xx) (math-pi))))
+		 (and (equal na nb)
+		      (math-sort-intv (nth 1 x)
+				      (math-cot-raw (nth 2 xx))
+				      (math-cot-raw (nth 3 xx)))))))
+	     '(intv 3 (neg (var inf var-inf)) (var inf var-inf))))
+	((equal x '(var nan var-nan))
+	 x)
+	(t (calc-record-why 'scalarp x)
+	   (list 'calcFunc-cot x))))
+
 (defun math-sin-raw (x)   ; [N N]
   (cond ((eq (car x) 'cplx)
 	 (let* ((expx (math-exp-raw (nth 2 x)))
@@ -819,6 +1027,85 @@
       (math-polar (math-cos-raw (math-complex x)))
     (math-sin-raw (math-sub (math-pi-over-2) x))))
 
+(defun math-sec-raw (x)   ; [N N]
+  (cond ((eq (car x) 'cplx)
+	 (let* ((x (math-mul x '(float 1 0)))
+                (expx (math-exp-raw (nth 2 x)))
+		(expmx (math-div-float '(float 1 0) expx))
+                (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1)))
+                (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1)))
+		(sc (math-sin-cos-raw (nth 1 x)))
+		(d (math-add-float 
+                    (math-mul-float (math-sqr (car sc))
+                                    (math-sqr sh))
+                    (math-mul-float (math-sqr (cdr sc))
+                                    (math-sqr ch)))))
+	   (and (not (eq (nth 1 d) 0))
+		(list 'cplx
+		      (math-div-float (math-mul-float (cdr sc) ch) d)
+		      (math-div-float (math-mul-float (car sc) sh) d)))))
+	((eq (car x) 'polar)
+	 (math-polar (math-sec-raw (math-complex x))))
+	(t
+	 (let ((cs (math-cos-raw x)))
+           (if (eq cs 0)
+               (math-div 1 0)
+	     (math-div-float '(float 1 0) cs))))))
+
+(defun math-csc-raw (x)   ; [N N]
+  (cond ((eq (car x) 'cplx)
+	 (let* ((x (math-mul x '(float 1 0)))
+                (expx (math-exp-raw (nth 2 x)))
+		(expmx (math-div-float '(float 1 0) expx))
+                (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1)))
+                (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1)))
+		(sc (math-sin-cos-raw (nth 1 x)))
+		(d (math-add-float 
+                    (math-mul-float (math-sqr (car sc))
+                                    (math-sqr ch))
+                    (math-mul-float (math-sqr (cdr sc))
+                                    (math-sqr sh)))))
+	   (and (not (eq (nth 1 d) 0))
+		(list 'cplx
+		      (math-div-float (math-mul-float (car sc) ch) d)
+		      (math-div-float (math-mul-float (cdr sc) sh) d)))))
+	((eq (car x) 'polar)
+	 (math-polar (math-sec-raw (math-complex x))))
+	(t
+	 (let ((sn (math-sin-raw x)))
+           (if (eq sn 0)
+               (math-div 1 0)
+	     (math-div-float '(float 1 0) sn))))))
+
+(defun math-cot-raw (x)   ; [N N]
+  (cond ((eq (car x) 'cplx)
+	 (let* ((x (math-mul x '(float 1 0)))
+                (expx (math-exp-raw (nth 2 x)))
+		(expmx (math-div-float '(float 1 0) expx))
+                (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1)))
+                (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1)))
+		(sc (math-sin-cos-raw (nth 1 x)))
+		(d (math-add-float 
+                    (math-sqr (car sc))
+                    (math-sqr sh))))
+	   (and (not (eq (nth 1 d) 0))
+		(list 'cplx
+		      (math-div-float 
+                       (math-mul-float (car sc) (cdr sc))
+                       d)
+                      (math-neg
+                       (math-div-float 
+                        (math-mul-float sh ch) 
+                        d))))))
+	((eq (car x) 'polar)
+	 (math-polar (math-cot-raw (math-complex x))))
+	(t
+	 (let ((sc (math-sin-cos-raw x)))
+	   (if (eq (nth 1 (car sc)) 0)
+	       (math-div (cdr sc) 0)
+	     (math-div-float (cdr sc) (car sc)))))))
+
+
 ;;; This could use a smarter method:  Reduce x as in math-sin-raw, then
 ;;;   compute either sin(x) or cos(x), whichever is smaller, and compute
 ;;;   the other using the identity sin(x)^2 + cos(x)^2 = 1.
@@ -1537,6 +1824,104 @@
 	   (list 'calcFunc-tanh x))))
 (put 'calcFunc-tanh 'math-expandable t)
 
+(defun calcFunc-sech (x)   ; [N N] [Public]
+  (cond ((eq x 0) 1)
+	(math-expand-formulas
+	 (math-normalize
+	  (list '/ 2 (list '+ (list 'calcFunc-exp x)
+                           (list 'calcFunc-exp (list 'neg x))))))
+	((Math-numberp x)
+	 (if calc-symbolic-mode (signal 'inexact-result nil))
+	 (math-with-extra-prec 2
+	   (let ((expx (math-exp-raw (math-float x))))
+	     (math-div '(float 2 0) (math-add expx (math-div 1 expx))))))
+	((eq (car-safe x) 'sdev)
+	 (math-make-sdev (calcFunc-sech (nth 1 x))
+			 (math-mul (nth 2 x)
+                                   (math-mul (calcFunc-sech (nth 1 x))
+                                             (calcFunc-tanh (nth 1 x))))))
+	((and (eq (car x) 'intv) (math-intv-constp x))
+	 (setq x (math-abs x))
+	 (math-sort-intv (nth 1 x)
+			 (calcFunc-sech (nth 2 x))
+			 (calcFunc-sech (nth 3 x))))
+	((or (equal x '(var inf var-inf))
+	     (equal x '(neg (var inf var-inf))))
+         0)
+        ((equal x '(var nan var-nan))
+         x)
+	(t (calc-record-why 'numberp x)
+	   (list 'calcFunc-sech x))))
+(put 'calcFunc-sech 'math-expandable t)
+
+(defun calcFunc-csch (x)   ; [N N] [Public]
+  (cond ((eq x 0) (math-div 1 0))
+	(math-expand-formulas
+	 (math-normalize
+	  (list '/ 2 (list '- (list 'calcFunc-exp x)
+                           (list 'calcFunc-exp (list 'neg x))))))
+	((Math-numberp x)
+	 (if calc-symbolic-mode (signal 'inexact-result nil))
+	 (math-with-extra-prec 2
+	   (let ((expx (math-exp-raw (math-float x))))
+	     (math-div '(float 2 0) (math-add expx (math-div -1 expx))))))
+	((eq (car-safe x) 'sdev)
+	 (math-make-sdev (calcFunc-csch (nth 1 x))
+			 (math-mul (nth 2 x) 
+                                   (math-mul (calcFunc-csch (nth 1 x))
+                                             (calcFunc-coth (nth 1 x))))))
+	((eq (car x) 'intv)
+         (if (and (Math-negp (nth 2 x))
+                  (Math-posp (nth 3 x)))
+             '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+           (math-sort-intv (nth 1 x)
+                           (calcFunc-csch (nth 2 x))
+                           (calcFunc-csch (nth 3 x)))))
+	((or (equal x '(var inf var-inf))
+	     (equal x '(neg (var inf var-inf))))
+         0)
+        ((equal x '(var nan var-nan))
+         x)
+	(t (calc-record-why 'numberp x)
+	   (list 'calcFunc-csch x))))
+(put 'calcFunc-csch 'math-expandable t)
+
+(defun calcFunc-coth (x)   ; [N N] [Public]
+  (cond ((eq x 0) (math-div 1 0))
+	(math-expand-formulas
+	 (math-normalize
+	  (let ((expx (list 'calcFunc-exp x))
+		(expmx (list 'calcFunc-exp (list 'neg x))))
+	    (math-normalize
+	     (list '/ (list '+ expx expmx) (list '- expx expmx))))))
+	((Math-numberp x)
+	 (if calc-symbolic-mode (signal 'inexact-result nil))
+	 (math-with-extra-prec 2
+	   (let* ((expx (calcFunc-exp (math-float x)))
+		  (expmx (math-div 1 expx)))
+	     (math-div (math-add expx expmx)
+		       (math-sub expx expmx)))))
+	((eq (car-safe x) 'sdev)
+	 (math-make-sdev (calcFunc-coth (nth 1 x))
+			 (math-div (nth 2 x)
+				   (math-sqr (calcFunc-sinh (nth 1 x))))))
+	((eq (car x) 'intv)
+         (if (and (Math-negp (nth 2 x))
+                  (Math-posp (nth 3 x)))
+             '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
+           (math-sort-intv (nth 1 x)
+                           (calcFunc-coth (nth 2 x))
+                           (calcFunc-coth (nth 3 x)))))
+	((equal x '(var inf var-inf))
+	 1)
+	((equal x '(neg (var inf var-inf)))
+	 -1)
+	((equal x '(var nan var-nan))
+	 x)
+	(t (calc-record-why 'numberp x)
+	   (list 'calcFunc-coth x))))
+(put 'calcFunc-coth 'math-expandable t)
+
 (defun calcFunc-arcsinh (x)   ; [N N] [Public]
   (cond ((eq x 0) 0)
 	(math-expand-formulas