procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)

Browse source 
(calcFunc-sec, calcFunc-csc, calcFunc-cot, calcFunc-sech)
(calcFunc-csch, calcFunc-coth, math-sec-raw, math-csc-raw)
(math-cot-raw): New functions.
This commit is contained in:
Jay Belanger 2005-02-15 19:25:20 +00:00
parent 86c88be7eb
commit f53e6c20ff
1 changed files with 387 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

389
lisp/calc/calc-math.el
View file

@ -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