src/trigo.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module trigo)
  14
  15 (load-macsyma-macros mrgmac)
  16
  17 (defun simp-%sinh (form y z)
  18   (oneargcheck form)
  19   (setq y (simpcheck (cadr form) z))
  20   (cond ((flonum-eval (mop form) y))
  21         ((big-float-eval (mop form) y))
  22         ((taylorize (mop form) (second form)))
  23         ((and $%piargs (if (zerop1 y) 0)))
  24         ((and $%iargs (multiplep y '$%i)) (mul '$%i (cons-exp '%sin (coeff y '$%i 1))))
  25         ((and $triginverses (not (atom y))
  26               (let ((fcn (caar y))
  27                     (arg (cadr y)))
  28                 (cond ((eq '%asinh fcn)
  29                        arg)
  30                       ((eq '%acosh fcn)
  31                        ;; ratsimp(logarc(exponentialize(sinh(acosh(x))))),algebraic;
  32                        ;; -> sqrt(x-1)*sqrt(x+1)
  33                        (mul (power (sub arg 1) 1//2)
  34                             (power (add arg 1) 1//2)))
  35                       ((eq '%atanh fcn)
  36                        ;; radcan(logarc(exponentialize(sinh(atanh(x)))));
  37                        ;; -> x/(sqrt(1-x)*sqrt(1+x))
  38                        (div arg
  39                             (mul (power (sub 1 arg) 1//2)
  40                                  (power (add 1 arg) 1//2))))))))
  41         ((and $trigexpand (trigexpand '%sinh y)))
  42         ($exponentialize (exponentialize '%sinh y))
  43         ((and $halfangles (halfangle '%sinh y)))
  44         ((apply-reflection-simp (mop form) y $trigsign))
  45         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%sinh (neg y))))
  46         (t (eqtest (list '(%sinh) y) form))))
  47
  48 (defun simp-%cosh (form y z)
  49   (oneargcheck form)
  50   (setq y (simpcheck (cadr form) z))
  51   (cond ((flonum-eval (mop form) y))
  52         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
  53         ((taylorize (mop form) (second form)))
  54         ((and $%piargs (if (zerop1 y) 1)))
  55         ((and $%iargs (multiplep y '$%i)) (cons-exp '%cos (coeff y '$%i 1)))
  56         ((and $triginverses (not (atom y))
  57               (let ((fcn (caar y))
  58                     (arg (cadr y)))
  59                 (cond ((eq '%acosh fcn)
  60                        arg)
  61                       ((eq '%asinh fcn)
  62                        ;; ex: cosh(asinh(x));
  63                        ;; ex,exponentialize,logarc;
  64                        ;; ratsimp(%),algebraic
  65                        ;; -> sqrt(x^2+1)
  66                        ;;
  67                        (sqrt1+x^2 arg))
  68                       ((eq '%atanh fcn)
  69                        ;; ex: cosh(atanh(x))
  70                        ;; radcan(logarc(exponentialize(ex)))
  71                        ;; -> 1/sqrt(1-x)/sqrt(1+x)
  72                        (div 1
  73                             (mul (power (sub 1 arg) 1//2)
  74                                  (power (add 1 arg) 1//2))))))))
  75         ((and $trigexpand (trigexpand '%cosh y)))
  76         ($exponentialize (exponentialize '%cosh y))
  77         ((and $halfangles (halfangle '%cosh y)))
  78         ((apply-reflection-simp (mop form) y $trigsign))
  79         ;((and $trigsign (mminusp* y)) (cons-exp '%cosh (neg y)))
  80         (t (eqtest (list '(%cosh) y) form))))
  81
  82 (defun simp-%tanh (form y z)
  83   (oneargcheck form)
  84   (setq y (simpcheck (cadr form) z))
  85   (cond ((flonum-eval (mop form) y))
  86         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
  87         ((taylorize (mop form) (second form)))
  88         ((and $%piargs (if (zerop1 y) 0)))
  89         ((and $%iargs (multiplep y '$%i)) (mul '$%i (cons-exp '%tan (coeff y '$%i 1))))
  90         ((and $triginverses (not (atom y))
  91               (let ((fcn (caar y))
  92                     (arg (cadr y)))
  93                 (cond ((eq '%atanh fcn)
  94                        arg)
  95                       ((eq '%asinh fcn)
  96                        ;; ratsimp(logarc(exponentialize(tanh(asinh(x))))),algebraic;
  97                        ;; --> x/sqrt(1+x^2)
  98                        (div arg (sqrt1+x^2 arg)))
  99                       ((eq '%acosh fcn)
 100                        ;; ratsimp(logarc(exponentialize(tanh(acosh(x))))),algebraic;
 101                        ;; sqrt(x-1)*sqrt(x+1)/x
 102                        (div (mul (power (sub arg 1) 1//2)
 103                                  (power (add arg 1) 1//2))
 104                             arg))))))
 105         ((and $trigexpand (trigexpand '%tanh y)))
 106         ($exponentialize (exponentialize '%tanh y))
 107         ((and $halfangles (halfangle '%tanh y)))
 108         ((apply-reflection-simp (mop form) y $trigsign))
 109         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%tanh (neg y))))
 110         (t (eqtest (list '(%tanh) y) form))))
 111
 112 (defun simp-%coth (form y z)
 113   (oneargcheck form)
 114   (setq y (simpcheck (cadr form) z))
 115   (cond ((flonum-eval (mop form) y))
 116         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 117         ((taylorize (mop form) (second form)))
 118         ((and $%piargs (if (zerop1 y) (domain-error y 'coth))))
 119         ((and $%iargs (multiplep y '$%i)) (mul -1 '$%i (cons-exp '%cot (coeff y '$%i 1))))
 120         ((and $triginverses (not (atom y)) (if (eq '%acoth (caar y)) (cadr y))))
 121         ((and $trigexpand (trigexpand '%coth y)))
 122         ($exponentialize (exponentialize '%coth y))
 123         ((and $halfangles (halfangle '%coth y)))
 124         ((apply-reflection-simp (mop form) y $trigsign))
 125         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%coth (neg y))))
 126         (t (eqtest (list '(%coth) y) form))))
 127
 128 (defun simp-%csch (form y z)
 129   (oneargcheck form)
 130   (setq y (simpcheck (cadr form) z))
 131   (cond ((flonum-eval (mop form) y))
 132         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 133         ((taylorize (mop form) (second form)))
 134         ((and $%piargs (cond ((zerop1 y) (domain-error y 'csch)))))
 135         ((and $%iargs (multiplep y '$%i)) (mul -1 '$%i (cons-exp '%csc (coeff y '$%i 1))))
 136         ((and $triginverses (not (atom y)) (if (eq '%acsch (caar y)) (cadr y))))
 137         ((and $trigexpand (trigexpand '%csch y)))
 138         ($exponentialize (exponentialize '%csch y))
 139         ((and $halfangles (halfangle '%csch y)))
 140         ((apply-reflection-simp (mop form) y $trigsign))
 141         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%csch (neg y))))
 142         (t (eqtest (list '(%csch) y) form))))
 143
 144 (defun simp-%sech (form y z)
 145   (oneargcheck form)
 146   (setq y (simpcheck (cadr form) z))
 147   (cond ((flonum-eval (mop form) y))
 148         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 149         ((taylorize (mop form) (second form)))
 150         ((and $%piargs (zerop1 y)) 1)
 151         ((and $%iargs (multiplep y '$%i)) (cons-exp '%sec (coeff y '$%i 1)))
 152         ((and $triginverses (not (atom y)) (if (eq '%asech (caar y)) (cadr y))))
 153         ((and $trigexpand (trigexpand '%sech y)))
 154         ($exponentialize (exponentialize '%sech y))
 155         ((and $halfangles (halfangle '%sech y)))
 156         ((apply-reflection-simp (mop form) y $trigsign))
 157         ;((and $trigsign (mminusp* y)) (cons-exp '%sech (neg y)))
 158         (t (eqtest (list '(%sech) y) form))))
 159
 160 (defun simp-%asin (form y z)
 161   (oneargcheck form)
 162   (setq y (simpcheck (cadr form) z))
 163   (cond ((flonum-eval (mop form) y))
 164         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 165         ((taylorize (mop form) (second form)))
 166         ((and $%piargs
 167               ;; Recognize some special values
 168               (cond ((zerop1 y)
 169                      0)
 170                     ((equal 1 y)
 171                      (div '$%pi 2))
 172                     ((equal -1 y)
 173                      (div '$%pi -2))
 174                     ((alike1 y 1//2)
 175                      (div '$%pi 6))
 176                     ((alike1 y -1//2)
 177                      (div '$%pi -6))
 178                     ;; 1/sqrt(2)
 179                     ((alike1 y (power* 2 -1//2))
 180                      (div '$%pi 4))
 181                     ;; sqrt(3)/2
 182                     ((alike1 y (div (power* 3 1//2) 2))
 183                      (div '$%pi 3))
 184                     ;; -sqrt(3)/2
 185                     ((alike1 y (div (power* 3 1//2) -2))
 186                      (div '$%pi -3)))))
 187         ((and $%iargs (multiplep y '$%i)) (mul '$%i (cons-exp '%asinh (coeff y '$%i 1))))
 188         ((and (not (atom y)) (member (caar y) '(%cos %sin))
 189               (if ($constantp (cadr y))
 190                   (let ((y-val (mfuncall '$mod
 191                                          (if (eq (caar y) '%sin) (cadr y) (m- %pi//2 (cadr y)))
 192                                          (m* 2 '$%pi))))
 193                     (cond ((eq (mlsp y-val %pi//2) t) y-val)
 194                           ((eq (mlsp y-val (m* 3 %pi//2)) t) (m- '$%pi y-val))
 195                           ((eq (mlsp y-val (m* 2 '$%pi)) t) (m- y-val (m* 2 '$%pi))))))))
 196         ((and (eq $triginverses t) (not (atom y)) (eq (caar y) '%sin)
 197               (if (and (member (csign (m- (cadr y) %pi//2)) '($nz $neg) :test #'eq)
 198                        (member (csign (m+ (cadr y) %pi//2)) '($pz $pos) :test #'eq))
 199                   (cadr y))))
 200         ((and (eq $triginverses '$all) (not (atom y))
 201               (if (eq '%sin (caar y)) (cadr y))))
 202         ($logarc (logarc '%asin y))
 203         ((apply-reflection-simp (mop form) y $trigsign))
 204         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%asin (neg y))))
 205         (t (eqtest (list '(%asin) y) form))))
 206
 207 (defun simp-%acos (form y z)
 208   (oneargcheck form)
 209   (setq y (simpcheck (cadr form) z))
 210   (cond ((flonum-eval (mop form) y))
 211         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 212         ((taylorize (mop form) (second form)))
 213         ((and $%piargs
 214               ;; Recognize some special values
 215               (cond ((zerop1 y)
 216                      (div '$%pi 2))
 217                     ((equal 1 y)
 218                      0)
 219                     ((equal -1 y)
 220                      '$%pi)
 221                     ((alike1 y 1//2)
 222                      (div '$%pi 3))
 223                     ((alike1 y -1//2)
 224                      (mul '$%pi (div 2 3)))
 225                     ;; 1/sqrt(2)
 226                     ((alike1 y (power* 2 -1//2))
 227                      (div '$%pi 4))
 228                     ;; sqrt(3)/2
 229                     ((alike1 y (div (power* 3 1//2) 2))
 230                      (div '$%pi 6))
 231                     ;; -sqrt(3)/2
 232                     ((alike1 y (div (power* 3 1//2) -2))
 233                      (mul '$%pi (div 5 6))))))
 234         ((and (not (atom y)) (member (caar y) '(%cos %sin))
 235               (if ($constantp (cadr y))
 236                   (let ((y-val (mfuncall '$mod
 237                                          (if (eq (caar y) '%cos) (cadr y) (m- %pi//2 (cadr y)))
 238                                          (m* 2 '$%pi))))
 239                     (cond ((eq (mlsp y-val '$%pi) t) y-val)
 240                           ((eq (mlsp y-val (m* 2 '$%pi)) t) (m- (m* 2 '$%pi) y-val)))))))
 241         ((and (eq $triginverses '$all) (not (atom y))
 242               (if (eq '%cos (caar y)) (cadr y))))
 243         ((and (eq $triginverses t) (not (atom y)) (eq (caar y) '%cos)
 244               (if (and (member (csign (m- (cadr y) '$%pi)) '($nz $neg) :test #'eq)
 245                        (member (csign (cadr y)) '($pz $pos) :test #'eq))
 246                   (cadr y))))
 247         ($logarc (logarc '%acos y))
 248         ((apply-reflection-simp (mop form) y $trigsign))
 249         ;((and $trigsign (mminusp* y)) (sub '$%pi (cons-exp '%acos (neg y))))
 250         (t (eqtest (list '(%acos) y) form))))
 251
 252 (defun simp-%acot (form y z)
 253   (oneargcheck form)
 254   (setq y (simpcheck (cadr form) z))
 255   (cond ((flonum-eval (mop form) y))
 256         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 257         ((taylorize (mop form) (second form)))
 258         ((and $%piargs
 259               (cond ((zerop1 y) (div '$%pi 2))
 260                     ((equal 1 y) (div '$%pi 4))
 261                     ((equal -1 y) (div '$%pi -4))
 262                     ;; 1/sqrt(3)
 263                     ((alike1 y '((mexpt) 3 ((rat) -1 2))) (div '$%pi 3))
 264                     ;; sqrt(3)
 265                     ((alike1 y '((mexpt) 3 ((rat) 1 2))) (div '$%pi 6)))))
 266         ((and $%iargs (multiplep y '$%i)) (mul -1 '$%i (cons-exp '%acoth (coeff y '$%i 1))))
 267         ((and (not (atom y)) (member (caar y) '(%cot %tan))
 268               (if ($constantp (cadr y))
 269                   (let ((y-val (mfuncall '$mod
 270                                          (if (eq (caar y) '%cot) (cadr y) (m- %pi//2 (cadr y)))
 271                                          '$%pi)))
 272                     (cond ((eq (mlsp y-val %pi//2) t) y-val)
 273                           ((eq (mlsp y-val '$%pi) t) (m- y-val '$%pi)))))))
 274         ((and (eq $triginverses '$all) (not (atom y))
 275               (if (eq '%cot (caar y)) (cadr y))))
 276         ((and (eq $triginverses t) (not (atom y)) (eq (caar y) '%cot)
 277               (if (and (member (csign (m- (cadr y) %pi//2)) '($nz $neg) :test #'eq)
 278                        (member (csign (m+ (cadr y) %pi//2)) '($pz $pos) :test #'eq))
 279                   (cadr y))))
 280         ($logarc (logarc '%acot y))
 281         ((apply-reflection-simp (mop form) y $trigsign))
 282         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%acot (neg y))))
 283         (t (eqtest (list '(%acot) y) form))))
 284
 285 (defun simp-%acsc (form y z)
 286   (oneargcheck form)
 287   (setq y (simpcheck (cadr form) z))
 288   (cond ((flonum-eval (mop form) y))
 289         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 290         ((taylorize (mop form) (second form)))
 291         ((and $%piargs
 292               (cond ((equal 1 y) (div '$%pi 2))
 293                     ((equal -1 y) (div '$%pi -2))
 294                     ((equal y 2) (div '$%pi 6))
 295                     ;; sqrt(2)
 296                     ((alike1 y '((mexpt) 2 ((rat) 1 2))) (div '$%pi 4))
 297                     ;; 2*sqrt(3)/3
 298                     ((alike1 y '((mtimes) 2 ((mexpt) 3 ((rat) -1 2))))
 299                      (div '$%pi 3)))))
 300         ((and $%iargs (multiplep y '$%i)) (mul -1 '$%i (cons-exp '%acsch (coeff y '$%i 1))))
 301         ((and (not (atom y)) (eq '%csc (caar y))
 302               (if ($constantp (cadr y))
 303                   (let ((y-val (mfuncall '$mod (cadr y) (m* 2 '$%pi))))
 304                     (cond ((eq (mlsp y-val %pi//2) t) y-val)
 305                           ((eq (mlsp y-val (m* 3 %pi//2)) t) (m- '$%pi y-val))
 306                           ((eq (mlsp y-val (m* 2 '$%pi)) t) (m- y-val (m* 2 '$%pi))))))))
 307         ((and (eq $triginverses '$all) (not (atom y))
 308               (if (eq '%csc (caar y)) (cadr y))))
 309         ($logarc (logarc '%acsc y))
 310         ((apply-reflection-simp (mop form) y $trigsign))
 311         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%acsc (neg y))))
 312         (t (eqtest (list '(%acsc) y) form))))
 313
 314 (defun simp-%asec (form y z)
 315   (oneargcheck form)
 316   (setq y (simpcheck (cadr form) z))
 317   (cond ((flonum-eval (mop form) y))
 318         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 319         ((taylorize (mop form) (second form)))
 320         ((and $%piargs
 321               (cond ((equal 1 y) 0)
 322                     ((equal -1 y) '$%pi)
 323                     ((equal 2 y) (div '$%pi 3))
 324                     ;; sqrt(2)
 325                     ((alike1 y '((mexpt) 2 ((rat) 1 2))) (div '$%pi 4))
 326                     ;; 2/sqrt(3)
 327                     ((alike1 y '((mtimes) 2 ((mexpt) 3 ((rat) -1 2))))
 328                      (div '$%pi 6)))))
 329         ((and (not (atom y)) (eq '%sec (caar y))
 330               (if ($constantp (cadr y))
 331                   (let ((y-val (mfuncall '$mod (cadr y) (m* 2 '$%pi))))
 332                     (cond ((eq (mlsp y-val '$%pi) t) y-val)
 333                           ((eq (mlsp y-val (m* 2 '$%pi)) t) (m- (m* 2 '$%pi) y-val)))))))
 334         ((and (eq $triginverses '$all) (not (atom y))
 335               (if (eq '%sec (caar y)) (cadr y))))
 336         ($logarc (logarc '%asec y))
 337         ((apply-reflection-simp (mop form) y $trigsign))
 338         ;;((and $trigsign (mminusp* y)) (sub '$%pi (cons-exp '%asec (neg y))))
 339         (t (eqtest (list '(%asec) y) form))))
 340
 341 (defun simp-%asinh (form y z)
 342   (oneargcheck form)
 343   (setq y (simpcheck (cadr form) z))
 344   (cond ((flonum-eval (mop form) y))
 345         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 346         ((taylorize (mop form) (second form)))
 347         ((and $%piargs (if (zerop1 y) y)))
 348         ((and $%iargs (multiplep y '$%i)) (mul '$%i (cons-exp '%asin (coeff y '$%i 1))))
 349         ((and (eq $triginverses '$all) (not (atom y))
 350               (if (eq '%sinh (caar y)) (cadr y))))
 351         ($logarc (logarc '%asinh y))
 352         ((apply-reflection-simp (mop form) y $trigsign))
 353         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%asinh (neg y))))
 354         (t (eqtest (list '(%asinh) y) form))))
 355
 356 (defun simp-%acosh (form y z)
 357   (oneargcheck form)
 358   (setq y (simpcheck (cadr form) z))
 359   (cond ((flonum-eval (mop form) y))
 360         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 361         ((taylorize (mop form) (second form)))
 362         ((and $%piargs (if (equal y 1) 0)))
 363         ((and (eq $triginverses '$all) (not (atom y))
 364               (if (eq '%cosh (caar y)) (cadr y))))
 365         ($logarc (logarc '%acosh y))
 366         (t (eqtest (list '(%acosh) y) form))))
 367
 368 (defun simp-%atanh (form y z)
 369   (oneargcheck form)
 370   (setq y (simpcheck (cadr form) z))
 371   (cond ((flonum-eval (mop form) y))
 372         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 373         ((taylorize (mop form) (second form)))
 374         ((and $%piargs (cond ((zerop1 y) 0)
 375                              ((or (equal y 1) (equal y -1)) (domain-error y 'atanh)))))
 376         ((and $%iargs (multiplep y '$%i)) (mul '$%i (cons-exp '%atan (coeff y '$%i 1))))
 377         ((and (eq $triginverses '$all) (not (atom y))
 378               (if (eq '%tanh (caar y)) (cadr y))))
 379         ($logarc (logarc '%atanh y))
 380         ((apply-reflection-simp (mop form) y $trigsign))
 381         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%atanh (neg y))))
 382         (t (eqtest (list '(%atanh) y) form))))
 383
 384 (defun simp-%acoth (form y z)
 385   (oneargcheck form)
 386   (setq y (simpcheck (cadr form) z))
 387   (cond ((flonum-eval (mop form) y))
 388         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 389         ((taylorize (mop form) (second form)))
 390         ((and $%piargs (if (or (equal y 1) (equal y -1)) (domain-error y 'acoth))))
 391         ((and $%iargs (multiplep y '$%i)) (mul -1 '$%i (cons-exp '%acot (coeff y '$%i 1))))
 392         ((and (eq $triginverses '$all) (not (atom y))
 393               (if (eq '%coth (caar y)) (cadr y))))
 394         ($logarc (logarc '%acoth y))
 395         ((apply-reflection-simp (mop form) y $trigsign))
 396         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%acoth (neg y))))
 397         (t (eqtest (list '(%acoth) y) form))))
 398
 399 (defun simp-%acsch (form y z)
 400   (oneargcheck form)
 401   (setq y (simpcheck (cadr form) z))
 402   (cond ((flonum-eval (mop form) y))
 403         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 404         ((taylorize (mop form) (second form)))
 405         ((and $%piargs (if (zerop1 y) (domain-error y 'acsch))))
 406         ((and $%iargs (multiplep y '$%i)) (mul -1 '$%i (cons-exp '%acsc (coeff y '$%i 1))))
 407         ((and (eq $triginverses '$all) (not (atom y))
 408               (if (eq '%csch (caar y)) (cadr y))))
 409         ($logarc (logarc '%acsch y))
 410         ((apply-reflection-simp (mop form) y $trigsign))
 411         ;((and $trigsign (mminusp* y)) (neg (cons-exp '%acsch (neg y))))
 412         (t (eqtest (list '(%acsch) y) form))))
 413
 414 (defun simp-%asech (form y z)
 415   (oneargcheck form)
 416   (setq y (simpcheck (cadr form) z))
 417   (cond ((flonum-eval (mop form) y))
 418         ((and (not (member 'simp (car form))) (big-float-eval (mop form) y)))
 419         ((taylorize (mop form) (second form)))
 420         ((and $%piargs (cond ((equal y 1) 0)
 421                              ((zerop1 y) (domain-error y 'asech)))))
 422         ((and (eq $triginverses '$all) (not (atom y))
 423               (if (eq '%sech (caar y)) (cadr y))))
 424         ($logarc (logarc '%asech y))
 425         ((apply-reflection-simp (mop form) y $trigsign))
 426         ;((and $trigsign (mminusp* y)) (cons-exp '%asech (neg y)))
 427         (t (eqtest (list '(%asech) y) form))))
 428
 429 (declare-top (special $trigexpandplus $trigexpandtimes))
 430
 431 (defmfun $trigexpand (e)
 432   (cond ((atom e) e)
 433         ((specrepp e) ($trigexpand (specdisrep e)))
 434         ((trigexpand (caar e) (cadr e)))
 435         (t (recur-apply #'$trigexpand e))))
 436
 437 (defun trigexpand (op arg)
 438   (cond ((atom arg) nil)
 439         ((and $trigexpandplus (eq 'mplus (caar arg)))
 440          (cond ((eq '%sin op) (sin/cos-plus (cdr arg) 1 '%sin '%cos -1))
 441                ((eq '%cos op) (sin/cos-plus (cdr arg) 0 '%sin '%cos -1))
 442                ((eq '%tan op) (tan-plus (cdr arg) '%tan -1))
 443                ((eq '%cot op) (cot-plus (cdr arg) '%cot -1))
 444                ((eq '%csc op) (csc/sec-plus (cdr arg) 1 '%csc '%sec -1))
 445                ((eq '%sec op) (csc/sec-plus (cdr arg) 0 '%csc '%sec -1))
 446                ((eq '%sinh op) (sin/cos-plus (cdr arg) 1 '%sinh '%cosh 1))
 447                ((eq '%cosh op) (sin/cos-plus (cdr arg) 0 '%sinh '%cosh 1))
 448                ((eq '%tanh op) (tan-plus (cdr arg) '%tanh 1))
 449                ((eq '%coth op) (cot-plus (cdr arg) '%coth 1))
 450                ((eq '%csch op) (csc/sec-plus (cdr arg) 1 '%csch '%sech 1))
 451                ((eq '%sech op) (csc/sec-plus (cdr arg) 0 '%csch '%sech 1))))
 452         ((and $trigexpandtimes (eq 'mtimes (caar arg)) (fixnump (cadr arg)))
 453          (cond ((eq '%sin op) (sin/cos-times (cddr arg) 1 (cadr arg) '%sin '%cos -1))
 454                ((eq '%cos op) (sin/cos-times (cddr arg) 0 (cadr arg) '%sin '%cos -1))
 455                ((eq '%tan op) (tan-times (cddr arg) (cadr arg) '%tan -1))
 456                ((eq '%cot op) (cot-times (cddr arg) (cadr arg) '%cot -1))
 457                ((eq '%csc op) (csc/sec-times (cddr arg) 1 (cadr arg) '%csc '%sec -1))
 458                ((eq '%sec op) (csc/sec-times (cddr arg) 0 (cadr arg) '%csc '%sec -1))
 459                ((eq '%sinh op) (sin/cos-times (cddr arg) 1 (cadr arg) '%sinh '%cosh 1))
 460                ((eq '%cosh op) (sin/cos-times (cddr arg) 0 (cadr arg) '%sinh '%cosh 1))
 461                ((eq '%tanh op) (tan-times (cddr arg) (cadr arg) '%tanh 1))
 462                ((eq '%coth op) (cot-times (cddr arg) (cadr arg) '%coth 1))
 463                ((eq '%csch op) (csc/sec-times (cddr arg) 1 (cadr arg) '%csch '%sech 1))
 464                ((eq '%sech op) (csc/sec-times (cddr arg) 0 (cadr arg) '%csch '%sech 1))))))
 465
 466 (defun sin/cos-plus (l n f1 f2 flag)
 467   (do ((i n (+ 2 i))
 468        (len (length l))
 469        (sign 1 (* flag sign))
 470        (result))
 471       ((> i len) (simplify (cons '(mplus) result)))
 472     (setq result (mpc (cond ((minusp sign) '(-1 (mtimes)))
 473                             (t '((mtimes)))) l result f1 f2 len i))))
 474
 475 (defun tan-plus (l f flag)
 476   (do ((i 1 (+ 2 i))
 477        (sign 1 (* flag sign))
 478        (len (length l))
 479        (num)
 480        (den (list 1)))
 481       ((> i len) (div* (cons '(mplus) num) (cons '(mplus) den)))
 482     (setq num (mpc1 (list sign '(mtimes)) l num f len i)
 483           den (cond ((= len i) den)
 484                     (t (mpc1 (list (* flag sign) '(mtimes)) l den f len (1+ i)))))))
 485
 486 (defun cot-plus (l f flag)
 487   (do ((i (length l) (- i 2)) (len (length l)) (sign 1 (* flag sign)) (num) (den))
 488       ((< i 0) (div* (cons '(mplus) num) (cons '(mplus) den)))
 489     (setq num (mpc1 (list sign '(mtimes)) l num f len i)
 490           den (cond ((= 0 i) den)
 491                     (t (mpc1 (list sign '(mtimes)) l den f len (1- i)))))))
 492
 493 (defun csc/sec-plus (l n f1 f2 flag)
 494   (div* (do ((l l (cdr l))
 495              (result))
 496             ((null l) (cons '(mtimes) result))
 497           (setq result (cons (cons-exp f1 (car l)) (cons (cons-exp f2 (car l)) result))))
 498         (sin/cos-plus l n f2 f1 flag)))
 499
 500 (defun sin/cos-times (l m n f1 f2 flag)
 501   ;; Assume m,n < 2^17, but Binom may become big
 502   ;; Flag is 1 or -1
 503   (setq f1 (cons-exp f1 (cons '(mtimes) l)) f2 (cons-exp f2 (cons '(mtimes) l)))
 504   (do ((i m (+ 2 i))
 505        (end (abs n))
 506        (result)
 507        (binom (cond ((= 0 m) 1)
 508                     (t (abs n)))
 509               (quotient (* flag (- end i 1) (- end i) binom) (* (+ 2 i) (1+ i)))))
 510       ((> i end) (setq result (simplify (cons '(mplus) result)))
 511        (cond ((and (= 1 m) (minusp n)) (neg result)) (t result)))
 512     (setq result (cons (mul binom (power f1 i) (power f2 (- end i))) result))))
 513
 514 (defun tan-times (l n f flag)
 515   (setq f (cons-exp f (cons '(mtimes) l)))
 516   (do ((i 1 (+ 2 i))
 517        (end (abs n))
 518        (num)
 519        (den (list 1))
 520        (binom (abs n) (quotient (* (- end i 1) binom) (+ 2 i))))
 521       ((> i end) (setq num (div* (cons '(mplus) num) (cons '(mplus) den)))
 522        (cond ((minusp n) (neg num))
 523              (t num)))
 524     (setq num (cons (mul binom (power f i)) num)
 525           den (cond ((= end i) den)
 526                     (t (cons (mul (setq binom (truncate (* flag (- end i) binom) (1+ i)))
 527                                   (power f (1+ i)))
 528                              den))))))
 529
 530 (defun cot-times (l n f flag)
 531   (setq f (cons-exp f (cons '(mtimes) l)))
 532   (do ((i (abs n) (- i 2))
 533        (end (abs n))
 534        (num)
 535        (den)
 536        (binom 1 (truncate (* flag (1- i) binom) (- end i -2))))
 537       ((< i 0) (setq num (div* (cons '(mplus) num) (cons '(mplus) den)))
 538        (if (minusp n) (neg num) num))
 539     (setq num (cons (mul binom (power f i)) num)
 540           den (if (= 0 i)
 541                   den
 542                   (cons (mul (setq binom (truncate (* i binom) (- end i -1))) (power f (1- i))) den)))))
 543
 544 (defun csc/sec-times (l m n f1 f2 flag)
 545   (div* (mul (power (cons-exp f1 (cons '(mtimes) l)) (abs n))
 546              (power (cons-exp f2 (cons '(mtimes) l)) (abs n)))
 547         (sin/cos-times l m n f2 f1 flag)))
 548
 549 (defun mpc (dl ul result f1 f2 di ui)
 550   (cond ((= 0 ui)
 551          (cons (revappend dl (mapcar #'(lambda (l) (cons-exp f2 l)) ul)) result))
 552         ((= di ui)
 553          (cons (revappend dl (mapcar #'(lambda (l) (cons-exp f1 l)) ul)) result))
 554         (t (mpc (cons (cons-exp f1 (car ul)) dl) (cdr ul)
 555                 (mpc (cons (cons-exp f2 (car ul)) dl)
 556                      (cdr ul) result f1 f2 (1- di) ui) f1 f2
 557                 (1- di) (1- ui)))))
 558
 559 (defun mpc1 (dl ul result f di ui)
 560   (cond ((= 0 ui) (cons (reverse dl) result))
 561         ((= di ui)
 562          (cons (revappend dl (mapcar #'(lambda (l) (cons-exp f l)) ul)) result))
 563         (t (mpc1 (cons (cons-exp f (car ul)) dl) (cdr ul)
 564                  (mpc1 dl (cdr ul) result f (1- di) ui) f
 565                  (1- di) (1- ui)))))
 566
 567 ;; Local Modes:
 568 ;; Mode: LISP
 569 ;; Comment Col: 40
 570 ;; End: