/[emacs]/emacs/lisp/calc/calc-math.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-math.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by jpb, Tue Nov 30 17:16:50 2004 UTC revision 1.11 by jpb, Tue Feb 15 19:25:20 2005 UTC
# Line 144  Line 144 
144    (calc-hyperbolic-func)    (calc-hyperbolic-func)
145    (calc-sin arg))    (calc-sin arg))
146    
147    (defun calc-sec (arg)
148      (interactive "P")
149      (calc-slow-wrapper
150       (if (calc-is-hyperbolic)
151           (calc-unary-op "sech" 'calcFunc-sech arg)
152         (calc-unary-op "sec" 'calcFunc-sec arg))))
153    
154    (defun calc-sech (arg)
155      (interactive "P")
156      (calc-hyperbolic-func)
157      (calc-sec arg))
158    
159  (defun calc-cos (arg)  (defun calc-cos (arg)
160    (interactive "P")    (interactive "P")
161    (calc-slow-wrapper    (calc-slow-wrapper
# Line 171  Line 183 
183    (calc-hyperbolic-func)    (calc-hyperbolic-func)
184    (calc-cos arg))    (calc-cos arg))
185    
186    (defun calc-csc (arg)
187      (interactive "P")
188      (calc-slow-wrapper
189       (if (calc-is-hyperbolic)
190           (calc-unary-op "csch" 'calcFunc-csch arg)
191         (calc-unary-op "csc" 'calcFunc-csc arg))))
192    
193    (defun calc-csch (arg)
194      (interactive "P")
195      (calc-hyperbolic-func)
196      (calc-csc arg))
197    
198  (defun calc-sincos ()  (defun calc-sincos ()
199    (interactive)    (interactive)
200    (calc-slow-wrapper    (calc-slow-wrapper
# Line 205  Line 229 
229    (calc-hyperbolic-func)    (calc-hyperbolic-func)
230    (calc-tan arg))    (calc-tan arg))
231    
232    (defun calc-cot (arg)
233      (interactive "P")
234      (calc-slow-wrapper
235       (if (calc-is-hyperbolic)
236           (calc-unary-op "coth" 'calcFunc-coth arg)
237         (calc-unary-op "cot" 'calcFunc-cot arg))))
238    
239    (defun calc-arctan (arg)
240      (interactive "P")
241      (calc-invert-func)
242      (calc-tan arg))
243    
244    (defun calc-tanh (arg)
245      (interactive "P")
246      (calc-hyperbolic-func)
247      (calc-tan arg))
248    
249    (defun calc-arctanh (arg)
250      (interactive "P")
251      (calc-invert-func)
252      (calc-hyperbolic-func)
253      (calc-tan arg))
254    
255  (defun calc-arctan2 ()  (defun calc-arctan2 ()
256    (interactive)    (interactive)
257    (calc-slow-wrapper    (calc-slow-wrapper
# Line 220  Line 267 
267    (calc-slow-wrapper    (calc-slow-wrapper
268     (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1)))))     (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1)))))
269    
   
   
270  (defun calc-to-degrees (arg)  (defun calc-to-degrees (arg)
271    (interactive "P")    (interactive "P")
272    (calc-wrapper    (calc-wrapper
# Line 794  Line 839 
839          (t (calc-record-why 'scalarp x)          (t (calc-record-why 'scalarp x)
840             (list 'calcFunc-tan x))))             (list 'calcFunc-tan x))))
841    
842    (defun calcFunc-sec (x)
843      (cond ((and (integerp x)
844                  (eq calc-angle-mode 'deg)
845                  (= (% x 180) 0))
846             (if (= (% x 360) 0)
847                 1
848               -1))
849            ((and (integerp x)
850                  (eq calc-angle-mode 'rad)
851                  (= x 0))
852             1)
853            ((Math-scalarp x)
854             (math-with-extra-prec 2
855               (math-sec-raw (math-to-radians (math-float x)))))
856            ((eq (car x) 'sdev)
857             (if (math-constp x)
858                 (math-with-extra-prec 2
859                   (let* ((xx (math-to-radians (math-float (nth 1 x))))
860                          (xs (math-to-radians (math-float (nth 2 x))))
861                          (sc (math-sin-cos-raw xx)))
862                     (if (and (math-zerop (cdr sc))
863                              (not calc-infinite-mode))
864                         (progn
865                           (calc-record-why "*Division by zero")
866                           (list 'calcFunc-sec x))
867                       (math-make-sdev (math-div-float '(float 1 0) (cdr sc))
868                                       (math-div-float
869                                        (math-mul xs (car sc))
870                                        (math-sqr (cdr sc)))))))
871               (math-make-sdev (calcFunc-sec (nth 1 x))
872                               (math-div
873                                (math-mul (nth 2 x)
874                                          (calcFunc-sin (nth 1 x)))
875                                (math-sqr (calcFunc-cos (nth 1 x)))))))
876            ((and (eq (car x) 'intv)
877                  (math-intv-constp x))
878             (math-with-extra-prec 2
879               (let* ((xx (math-to-radians (math-float x)))
880                      (na (math-floor (math-div (math-sub (nth 2 xx)
881                                                          (math-pi-over-2))
882                                                (math-pi))))
883                      (nb (math-floor (math-div (math-sub (nth 3 xx)
884                                                          (math-pi-over-2))
885                                                (math-pi))))
886                      (naa (math-floor (math-div (nth 2 xx) (math-pi-over-2))))
887                      (nbb (math-floor (math-div (nth 3 xx) (math-pi-over-2))))
888                      (span (math-sub nbb naa)))
889                 (if (not (equal na nb))
890                     '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
891                   (let ((int (math-sort-intv (nth 1 x)
892                                              (math-sec-raw (nth 2 xx))
893                                              (math-sec-raw (nth 3 xx)))))
894                     (if (eq span 1)
895                         (if (math-evenp (math-div (math-add naa 1) 2))
896                             (math-make-intv (logior (nth 1 int) 2)
897                                             1
898                                             (nth 3 int))
899                           (math-make-intv (logior (nth 1 int) 1)
900                                           (nth 2 int)
901                                           -1))
902                       int))))))
903            ((equal x '(var nan var-nan))
904             x)
905            (t (calc-record-why 'scalarp x)
906               (list 'calcFunc-sec x))))
907    
908    (defun calcFunc-csc (x)
909      (cond ((and (integerp x)
910                  (eq calc-angle-mode 'deg)
911                  (= (% (- x 90) 180) 0))
912             (if (= (% (- x 90) 360) 0)
913                 1
914               -1))
915            ((Math-scalarp x)
916             (math-with-extra-prec 2
917               (math-csc-raw (math-to-radians (math-float x)))))
918            ((eq (car x) 'sdev)
919             (if (math-constp x)
920                 (math-with-extra-prec 2
921                   (let* ((xx (math-to-radians (math-float (nth 1 x))))
922                          (xs (math-to-radians (math-float (nth 2 x))))
923                          (sc (math-sin-cos-raw xx)))
924                     (if (and (math-zerop (car sc))
925                              (not calc-infinite-mode))
926                         (progn
927                           (calc-record-why "*Division by zero")
928                           (list 'calcFunc-csc x))
929                       (math-make-sdev (math-div-float '(float 1 0) (car sc))
930                                       (math-div-float
931                                        (math-mul xs (cdr sc))
932                                        (math-sqr (car sc)))))))
933               (math-make-sdev (calcFunc-csc (nth 1 x))
934                               (math-div
935                                (math-mul (nth 2 x)
936                                          (calcFunc-cos (nth 1 x)))
937                                (math-sqr (calcFunc-sin (nth 1 x)))))))
938            ((and (eq (car x) 'intv)
939                  (math-intv-constp x))
940             (math-with-extra-prec 2
941               (let* ((xx (math-to-radians (math-float x)))
942                      (na (math-floor (math-div (nth 2 xx) (math-pi))))
943                      (nb (math-floor (math-div (nth 3 xx) (math-pi))))
944                      (naa (math-floor (math-div (nth 2 xx) (math-pi-over-2))))
945                      (nbb (math-floor (math-div (nth 3 xx) (math-pi-over-2))))
946                      (span (math-sub nbb naa)))
947                 (if (not (equal na nb))
948                     '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
949                   (let ((int (math-sort-intv (nth 1 x)
950                                              (math-csc-raw (nth 2 xx))
951                                              (math-csc-raw (nth 3 xx)))))
952                     (if (eq span 1)
953                         (if (math-evenp (math-div naa 2))
954                             (math-make-intv (logior (nth 1 int) 2)
955                                             1
956                                             (nth 3 int))
957                           (math-make-intv (logior (nth 1 int) 1)
958                                           (nth 2 int)
959                                           -1))
960                       int))))))
961            ((equal x '(var nan var-nan))
962             x)
963            (t (calc-record-why 'scalarp x)
964               (list 'calcFunc-csc x))))
965    
966    (defun calcFunc-cot (x)   ; [N N] [Public]
967      (cond ((and (integerp x)
968                  (if (eq calc-angle-mode 'deg)
969                      (= (% (- x 90) 180) 0)
970                    (= x 0)))
971             0)
972            ((Math-scalarp x)
973             (math-with-extra-prec 2
974               (math-cot-raw (math-to-radians (math-float x)))))
975            ((eq (car x) 'sdev)
976             (if (math-constp x)
977                 (math-with-extra-prec 2
978                   (let* ((xx (math-to-radians (math-float (nth 1 x))))
979                          (xs (math-to-radians (math-float (nth 2 x))))
980                          (sc (math-sin-cos-raw xx)))
981                     (if (and (math-zerop (car sc)) (not calc-infinite-mode))
982                         (progn
983                           (calc-record-why "*Division by zero")
984                           (list 'calcFunc-cot x))
985                       (math-make-sdev (math-div-float (cdr sc) (car sc))
986                                       (math-div-float xs (math-sqr (car sc)))))))
987               (math-make-sdev (calcFunc-cot (nth 1 x))
988                               (math-div (nth 2 x)
989                                         (math-sqr (calcFunc-sin (nth 1 x)))))))
990            ((and (eq (car x) 'intv) (math-intv-constp x))
991             (or (math-with-extra-prec 2
992                   (let* ((xx (math-to-radians (math-float x)))
993                          (na (math-floor (math-div (nth 2 xx) (math-pi))))
994                          (nb (math-floor (math-div (nth 3 xx) (math-pi))))
995                     (and (equal na nb)
996                          (math-sort-intv (nth 1 x)
997                                          (math-cot-raw (nth 2 xx))
998                                          (math-cot-raw (nth 3 xx)))))))
999                 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))))
1000            ((equal x '(var nan var-nan))
1001             x)
1002            (t (calc-record-why 'scalarp x)
1003               (list 'calcFunc-cot x))))
1004    
1005  (defun math-sin-raw (x)   ; [N N]  (defun math-sin-raw (x)   ; [N N]
1006    (cond ((eq (car x) 'cplx)    (cond ((eq (car x) 'cplx)
1007           (let* ((expx (math-exp-raw (nth 2 x)))           (let* ((expx (math-exp-raw (nth 2 x)))
# Line 819  Line 1027 
1027        (math-polar (math-cos-raw (math-complex x)))        (math-polar (math-cos-raw (math-complex x)))
1028      (math-sin-raw (math-sub (math-pi-over-2) x))))      (math-sin-raw (math-sub (math-pi-over-2) x))))
1029    
1030    (defun math-sec-raw (x)   ; [N N]
1031      (cond ((eq (car x) 'cplx)
1032             (let* ((x (math-mul x '(float 1 0)))
1033                    (expx (math-exp-raw (nth 2 x)))
1034                    (expmx (math-div-float '(float 1 0) expx))
1035                    (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1)))
1036                    (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1)))
1037                    (sc (math-sin-cos-raw (nth 1 x)))
1038                    (d (math-add-float
1039                        (math-mul-float (math-sqr (car sc))
1040                                        (math-sqr sh))
1041                        (math-mul-float (math-sqr (cdr sc))
1042                                        (math-sqr ch)))))
1043               (and (not (eq (nth 1 d) 0))
1044                    (list 'cplx
1045                          (math-div-float (math-mul-float (cdr sc) ch) d)
1046                          (math-div-float (math-mul-float (car sc) sh) d)))))
1047            ((eq (car x) 'polar)
1048             (math-polar (math-sec-raw (math-complex x))))
1049            (t
1050             (let ((cs (math-cos-raw x)))
1051               (if (eq cs 0)
1052                   (math-div 1 0)
1053                 (math-div-float '(float 1 0) cs))))))
1054    
1055    (defun math-csc-raw (x)   ; [N N]
1056      (cond ((eq (car x) 'cplx)
1057             (let* ((x (math-mul x '(float 1 0)))
1058                    (expx (math-exp-raw (nth 2 x)))
1059                    (expmx (math-div-float '(float 1 0) expx))
1060                    (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1)))
1061                    (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1)))
1062                    (sc (math-sin-cos-raw (nth 1 x)))
1063                    (d (math-add-float
1064                        (math-mul-float (math-sqr (car sc))
1065                                        (math-sqr ch))
1066                        (math-mul-float (math-sqr (cdr sc))
1067                                        (math-sqr sh)))))
1068               (and (not (eq (nth 1 d) 0))
1069                    (list 'cplx
1070                          (math-div-float (math-mul-float (car sc) ch) d)
1071                          (math-div-float (math-mul-float (cdr sc) sh) d)))))
1072            ((eq (car x) 'polar)
1073             (math-polar (math-sec-raw (math-complex x))))
1074            (t
1075             (let ((sn (math-sin-raw x)))
1076               (if (eq sn 0)
1077                   (math-div 1 0)
1078                 (math-div-float '(float 1 0) sn))))))
1079    
1080    (defun math-cot-raw (x)   ; [N N]
1081      (cond ((eq (car x) 'cplx)
1082             (let* ((x (math-mul x '(float 1 0)))
1083                    (expx (math-exp-raw (nth 2 x)))
1084                    (expmx (math-div-float '(float 1 0) expx))
1085                    (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1)))
1086                    (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1)))
1087                    (sc (math-sin-cos-raw (nth 1 x)))
1088                    (d (math-add-float
1089                        (math-sqr (car sc))
1090                        (math-sqr sh))))
1091               (and (not (eq (nth 1 d) 0))
1092                    (list 'cplx
1093                          (math-div-float
1094                           (math-mul-float (car sc) (cdr sc))
1095                           d)
1096                          (math-neg
1097                           (math-div-float
1098                            (math-mul-float sh ch)
1099                            d))))))
1100            ((eq (car x) 'polar)
1101             (math-polar (math-cot-raw (math-complex x))))
1102            (t
1103             (let ((sc (math-sin-cos-raw x)))
1104               (if (eq (nth 1 (car sc)) 0)
1105                   (math-div (cdr sc) 0)
1106                 (math-div-float (cdr sc) (car sc)))))))
1107    
1108    
1109  ;;; This could use a smarter method:  Reduce x as in math-sin-raw, then  ;;; This could use a smarter method:  Reduce x as in math-sin-raw, then
1110  ;;;   compute either sin(x) or cos(x), whichever is smaller, and compute  ;;;   compute either sin(x) or cos(x), whichever is smaller, and compute
1111  ;;;   the other using the identity sin(x)^2 + cos(x)^2 = 1.  ;;;   the other using the identity sin(x)^2 + cos(x)^2 = 1.
# Line 1537  Line 1824 
1824             (list 'calcFunc-tanh x))))             (list 'calcFunc-tanh x))))
1825  (put 'calcFunc-tanh 'math-expandable t)  (put 'calcFunc-tanh 'math-expandable t)
1826    
1827    (defun calcFunc-sech (x)   ; [N N] [Public]
1828      (cond ((eq x 0) 1)
1829            (math-expand-formulas
1830             (math-normalize
1831              (list '/ 2 (list '+ (list 'calcFunc-exp x)
1832                               (list 'calcFunc-exp (list 'neg x))))))
1833            ((Math-numberp x)
1834             (if calc-symbolic-mode (signal 'inexact-result nil))
1835             (math-with-extra-prec 2
1836               (let ((expx (math-exp-raw (math-float x))))
1837                 (math-div '(float 2 0) (math-add expx (math-div 1 expx))))))
1838            ((eq (car-safe x) 'sdev)
1839             (math-make-sdev (calcFunc-sech (nth 1 x))
1840                             (math-mul (nth 2 x)
1841                                       (math-mul (calcFunc-sech (nth 1 x))
1842                                                 (calcFunc-tanh (nth 1 x))))))
1843            ((and (eq (car x) 'intv) (math-intv-constp x))
1844             (setq x (math-abs x))
1845             (math-sort-intv (nth 1 x)
1846                             (calcFunc-sech (nth 2 x))
1847                             (calcFunc-sech (nth 3 x))))
1848            ((or (equal x '(var inf var-inf))
1849                 (equal x '(neg (var inf var-inf))))
1850             0)
1851            ((equal x '(var nan var-nan))
1852             x)
1853            (t (calc-record-why 'numberp x)
1854               (list 'calcFunc-sech x))))
1855    (put 'calcFunc-sech 'math-expandable t)
1856    
1857    (defun calcFunc-csch (x)   ; [N N] [Public]
1858      (cond ((eq x 0) (math-div 1 0))
1859            (math-expand-formulas
1860             (math-normalize
1861              (list '/ 2 (list '- (list 'calcFunc-exp x)
1862                               (list 'calcFunc-exp (list 'neg x))))))
1863            ((Math-numberp x)
1864             (if calc-symbolic-mode (signal 'inexact-result nil))
1865             (math-with-extra-prec 2
1866               (let ((expx (math-exp-raw (math-float x))))
1867                 (math-div '(float 2 0) (math-add expx (math-div -1 expx))))))
1868            ((eq (car-safe x) 'sdev)
1869             (math-make-sdev (calcFunc-csch (nth 1 x))
1870                             (math-mul (nth 2 x)
1871                                       (math-mul (calcFunc-csch (nth 1 x))
1872                                                 (calcFunc-coth (nth 1 x))))))
1873            ((eq (car x) 'intv)
1874             (if (and (Math-negp (nth 2 x))
1875                      (Math-posp (nth 3 x)))
1876                 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1877               (math-sort-intv (nth 1 x)
1878                               (calcFunc-csch (nth 2 x))
1879                               (calcFunc-csch (nth 3 x)))))
1880            ((or (equal x '(var inf var-inf))
1881                 (equal x '(neg (var inf var-inf))))
1882             0)
1883            ((equal x '(var nan var-nan))
1884             x)
1885            (t (calc-record-why 'numberp x)
1886               (list 'calcFunc-csch x))))
1887    (put 'calcFunc-csch 'math-expandable t)
1888    
1889    (defun calcFunc-coth (x)   ; [N N] [Public]
1890      (cond ((eq x 0) (math-div 1 0))
1891            (math-expand-formulas
1892             (math-normalize
1893              (let ((expx (list 'calcFunc-exp x))
1894                    (expmx (list 'calcFunc-exp (list 'neg x))))
1895                (math-normalize
1896                 (list '/ (list '+ expx expmx) (list '- expx expmx))))))
1897            ((Math-numberp x)
1898             (if calc-symbolic-mode (signal 'inexact-result nil))
1899             (math-with-extra-prec 2
1900               (let* ((expx (calcFunc-exp (math-float x)))
1901                      (expmx (math-div 1 expx)))
1902                 (math-div (math-add expx expmx)
1903                           (math-sub expx expmx)))))
1904            ((eq (car-safe x) 'sdev)
1905             (math-make-sdev (calcFunc-coth (nth 1 x))
1906                             (math-div (nth 2 x)
1907                                       (math-sqr (calcFunc-sinh (nth 1 x))))))
1908            ((eq (car x) 'intv)
1909             (if (and (Math-negp (nth 2 x))
1910                      (Math-posp (nth 3 x)))
1911                 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1912               (math-sort-intv (nth 1 x)
1913                               (calcFunc-coth (nth 2 x))
1914                               (calcFunc-coth (nth 3 x)))))
1915            ((equal x '(var inf var-inf))
1916             1)
1917            ((equal x '(neg (var inf var-inf)))
1918             -1)
1919            ((equal x '(var nan var-nan))
1920             x)
1921            (t (calc-record-why 'numberp x)
1922               (list 'calcFunc-coth x))))
1923    (put 'calcFunc-coth 'math-expandable t)
1924    
1925  (defun calcFunc-arcsinh (x)   ; [N N] [Public]  (defun calcFunc-arcsinh (x)   ; [N N] [Public]
1926    (cond ((eq x 0) 0)    (cond ((eq x 0) 0)
1927          (math-expand-formulas          (math-expand-formulas

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26