archive/src/trgsmp.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;Translated on: 6/08/85 17:56:35;;Maxima System version 16
   3 ;;** Variable settings were **
   4
   5 (in-package :maxima)
   6 ;;TRANSCOMPILE:FALSE;
   7 ;;TR_SEMICOMPILE:FALSE;
   8 ;;TRANSLATE_FAST_ARRAYS:TRUE;
   9 ;;TR_WARN_UNDECLARED:COMPILE;
  10 ;;TR_WARN_MEVAL:COMPFILE;
  11 ;;TR_WARN_FEXPR:COMPFILE;
  12 ;;TR_WARN_MODE:ALL;
  13 ;;TR_WARN_UNDEFINED_VARIABLE:ALL;
  14 ;;TR_FUNCTION_CALL_DEFAULT:GENERAL;
  15 ;;TR_ARRAY_AS_REF:TRUE;
  16 ;;TR_NUMER:FALSE;
  17 ;;DEFINE_VARIABLE:FALSE;
  18 nil
  19 (eval-when (compile eval load)
  20   (meval* '(($modedeclare) $bestlength $fixnum))
  21   (meval* '(($declare) $bestlength $special))
  22   (defprop $bestlength assign-mode-check assign)
  23   (def-mtrvar $bestlength 0))
  24 (eval-when (compile eval load)
  25   (meval* '(($modedeclare) $trylength $fixnum))
  26   (meval* '(($declare) $trylength $special))
  27   (defprop $trylength assign-mode-check assign)
  28   (def-mtrvar $trylength 0))
  29 (eval-when (compile eval load)
  30   (proclaim '(special $ans ))
  31
  32   (simplify ($put '%sin '%cos '$complement_function))
  33   (simplify ($put '%cos '%sin '$complement_function))
  34   (simplify ($put '%sinh '%cosh '$complement_function))
  35   (simplify ($put '%cosh '%sinh '$complement_function))
  36   (simplify ($put '%cos 1 '$unitcof))
  37   (simplify ($put '%sin 1 '$unitcof))
  38   (simplify ($put '%cosh 1 '$unitcof))
  39   (simplify ($put '%sinh -1 '$unitcof))
  40   (simplify ($put '%cos -1 '$complement_cof))
  41   (simplify ($put '%sin -1 '$complement_cof))
  42   (simplify ($put '%cosh 1 '$complement_cof))
  43   (simplify ($put '%sinh 1 '$complement_cof))
  44   (simplify ($put '%sin '$trigonometric '$type))
  45   (simplify ($put '%cos '$trigonometric '$type))
  46   (simplify ($put '%sinh '$hyper_trigonometric '$type))
  47   (simplify ($put '%cosh '$hyper_trigonometric '$type))
  48   )
  49 nil
  50 (eval-when (compile load eval) (meval* '(($declare) $list2
  51                                          $special)))
  52 (eval-when (compile eval load)
  53   (defprop $trigonometricp t translated)
  54   (add2lnc '$trigonometricp $props)
  55   (defmtrfun ($trigonometricp $boolean mdefine nil nil)
  56       ($exp)
  57     nil
  58     (or (like (simplify ($get (simplify ($inpart $exp 0))
  59                               '$type))
  60               '$trigonometric)
  61         (like (simplify ($get (trd-msymeval $piece '$piece)
  62                               '$type))
  63               '$hyper_trigonometric))))
  64 (eval-when (compile eval load)
  65   (defun $trigrule0
  66       (|tr-gensym~0|)
  67     (catch 'match
  68       (prog ($a |tr-gensym~1| |tr-gensym~2|)
  69          (declare (special $a |tr-gensym~1| |tr-gensym~2|))
  70          (cond ((not (equal (kar (kar |tr-gensym~0|))
  71                             '%tan))
  72                 (matcherr)))
  73          (setq |tr-gensym~1| (kdr |tr-gensym~0|))
  74          (setq |tr-gensym~2| (kar |tr-gensym~1|))
  75          (setq $a |tr-gensym~2|)
  76          (cond ((nthkdr |tr-gensym~1| 1)
  77                 (matcherr)))
  78          (return (mul* (power (simplify (list '(%cos) $a))
  79                               -1)
  80                        (simplify (list '(%sin) $a)))))))
  81   (mdefprop $trigrule0
  82             ((mequal) ((%tan simp) $a)
  83              ((mtimes simp) ((mexpt simp) ((%cos simp) $a) -1)
  84               ((%sin simp) $a)))
  85             $rule)
  86   (mdefprop $trigrule0 $defrule $ruletype))
  87 (eval-when (compile eval load)
  88   (defun $trigrule1
  89       (|tr-gensym~3|)
  90     (catch 'match
  91       (prog ($a |tr-gensym~4| |tr-gensym~5|)
  92          (declare (special $a |tr-gensym~4| |tr-gensym~5|))
  93          (cond ((not (equal (kar (kar |tr-gensym~3|))
  94                             '%tan))
  95                 (matcherr)))
  96          (setq |tr-gensym~4| (kdr |tr-gensym~3|))
  97          (setq |tr-gensym~5| (kar |tr-gensym~4|))
  98          (setq $a |tr-gensym~5|)
  99          (cond ((nthkdr |tr-gensym~4| 1)
 100                 (matcherr)))
 101          (return (mul* (power (simplify (list '(%cos) $a))
 102                               -1)
 103                        (simplify (list '(%sin) $a)))))))
 104   (mdefprop $trigrule1
 105             ((mequal) ((%tan simp) $a)
 106              ((mtimes simp) ((mexpt simp) ((%cos simp) $a) -1)
 107               ((%sin simp) $a)))
 108             $rule)
 109   (mdefprop $trigrule1 $defrule $ruletype))
 110 (eval-when (compile eval load)
 111   (defun $trigrule2
 112       (|tr-gensym~6|)
 113     (catch 'match
 114       (prog ($a |tr-gensym~7| |tr-gensym~8|)
 115          (declare (special $a |tr-gensym~7| |tr-gensym~8|))
 116          (cond ((not (equal (kar (kar |tr-gensym~6|))
 117                             '%sec))
 118                 (matcherr)))
 119          (setq |tr-gensym~7| (kdr |tr-gensym~6|))
 120          (setq |tr-gensym~8| (kar |tr-gensym~7|))
 121          (setq $a |tr-gensym~8|)
 122          (cond ((nthkdr |tr-gensym~7| 1)
 123                 (matcherr)))
 124          (return (power (simplify (list '(%cos) $a)) -1)))))
 125   (mdefprop $trigrule2
 126             ((mequal) ((%sec simp) $a) ((mexpt simp) ((%cos simp) $a) -1))
 127             $rule)
 128   (mdefprop $trigrule2 $defrule $ruletype))
 129 (eval-when (compile eval load)
 130   (defun $trigrule3
 131       (|tr-gensym~9|)
 132     (catch 'match
 133       (prog ($a |tr-gensym~10| |tr-gensym~11|)
 134          (declare (special $a
 135                            |tr-gensym~10|
 136                            |tr-gensym~11|))
 137          (cond ((not (equal (kar (kar |tr-gensym~9|))
 138                             '%csc))
 139                 (matcherr)))
 140          (setq |tr-gensym~10| (kdr |tr-gensym~9|))
 141          (setq |tr-gensym~11| (kar |tr-gensym~10|))
 142          (setq $a |tr-gensym~11|)
 143          (cond ((nthkdr |tr-gensym~10| 1)
 144                 (matcherr)))
 145          (return (power (simplify (list '(%sin) $a)) -1)))))
 146   (mdefprop $trigrule3
 147             ((mequal) ((%csc simp) $a) ((mexpt simp) ((%sin simp) $a) -1))
 148             $rule)
 149   (mdefprop $trigrule3 $defrule $ruletype))
 150 (eval-when (compile eval load)
 151   (defun $trigrule4
 152       (|tr-gensym~12|)
 153     (catch 'match
 154       (prog ($a |tr-gensym~13| |tr-gensym~14|)
 155          (declare (special $a
 156                            |tr-gensym~13|
 157                            |tr-gensym~14|))
 158          (cond ((not (equal (kar (kar |tr-gensym~12|))
 159                             '%cot))
 160                 (matcherr)))
 161          (setq |tr-gensym~13| (kdr |tr-gensym~12|))
 162          (setq |tr-gensym~14| (kar |tr-gensym~13|))
 163          (setq $a |tr-gensym~14|)
 164          (cond ((nthkdr |tr-gensym~13| 1)
 165                 (matcherr)))
 166          (return (mul* (simplify (list '(%cos) $a))
 167                        (power (simplify (list '(%sin)
 168                                               $a))
 169                               -1))))))
 170   (mdefprop $trigrule4
 171             ((mequal) ((%cot simp) $a)
 172              ((mtimes simp) ((%cos simp) $a)
 173               ((mexpt simp) ((%sin simp) $a) -1)))
 174             $rule)
 175   (mdefprop $trigrule4 $defrule $ruletype))
 176 (eval-when (compile eval load)
 177   (defun $htrigrule1
 178       (|tr-gensym~15|)
 179     (catch 'match
 180       (prog ($a |tr-gensym~16| |tr-gensym~17|)
 181          (declare (special $a
 182                            |tr-gensym~16|
 183                            |tr-gensym~17|))
 184          (cond ((not (equal (kar (kar |tr-gensym~15|))
 185                             '%tanh))
 186                 (matcherr)))
 187          (setq |tr-gensym~16| (kdr |tr-gensym~15|))
 188          (setq |tr-gensym~17| (kar |tr-gensym~16|))
 189          (setq $a |tr-gensym~17|)
 190          (cond ((nthkdr |tr-gensym~16| 1)
 191                 (matcherr)))
 192          (return (mul* (power (simplify (list '(%cosh)
 193                                               $a))
 194                               -1)
 195                        (simplify (list '(%sinh) $a)))))))
 196   (mdefprop $htrigrule1
 197             ((mequal) ((%tanh simp) $a)
 198              ((mtimes simp) ((mexpt simp) ((%cosh simp) $a) -1)
 199               ((%sinh simp) $a)))
 200             $rule)
 201   (mdefprop $htrigrule1 $defrule $ruletype))
 202 (eval-when (compile eval load)
 203   (defun $htrigrule2
 204       (|tr-gensym~18|)
 205     (catch 'match
 206       (prog ($a |tr-gensym~19| |tr-gensym~20|)
 207          (declare (special $a
 208                            |tr-gensym~19|
 209                            |tr-gensym~20|))
 210          (cond ((not (equal (kar (kar |tr-gensym~18|))
 211                             '%sech))
 212                 (matcherr)))
 213          (setq |tr-gensym~19| (kdr |tr-gensym~18|))
 214          (setq |tr-gensym~20| (kar |tr-gensym~19|))
 215          (setq $a |tr-gensym~20|)
 216          (cond ((nthkdr |tr-gensym~19| 1)
 217                 (matcherr)))
 218          (return (power (simplify (list '(%cosh) $a)) -1)))))
 219   (mdefprop $htrigrule2
 220             ((mequal) ((%sech simp) $a)
 221              ((mexpt simp) ((%cosh simp) $a) -1))
 222             $rule)
 223   (mdefprop $htrigrule2 $defrule $ruletype))
 224 (eval-when (compile eval load)
 225   (defun $htrigrule3
 226       (|tr-gensym~21|)
 227     (catch 'match
 228       (prog ($a |tr-gensym~22| |tr-gensym~23|)
 229          (declare (special $a
 230                            |tr-gensym~22|
 231                            |tr-gensym~23|))
 232          (cond ((not (equal (kar (kar |tr-gensym~21|))
 233                             '%csch))
 234                 (matcherr)))
 235          (setq |tr-gensym~22| (kdr |tr-gensym~21|))
 236          (setq |tr-gensym~23| (kar |tr-gensym~22|))
 237          (setq $a |tr-gensym~23|)
 238          (cond ((nthkdr |tr-gensym~22| 1)
 239                 (matcherr)))
 240          (return (power (simplify (list '(%sinh) $a)) -1)))))
 241   (mdefprop $htrigrule3
 242             ((mequal) ((%csch simp) $a)
 243              ((mexpt simp) ((%sinh simp) $a) -1))
 244             $rule)
 245   (mdefprop $htrigrule3 $defrule $ruletype))
 246 (eval-when (compile eval load)
 247   (defun $htrigrule4
 248       (|tr-gensym~24|)
 249     (catch 'match
 250       (prog ($a |tr-gensym~25| |tr-gensym~26|)
 251          (declare (special $a
 252                            |tr-gensym~25|
 253                            |tr-gensym~26|))
 254          (cond ((not (equal (kar (kar |tr-gensym~24|))
 255                             '%coth))
 256                 (matcherr)))
 257          (setq |tr-gensym~25| (kdr |tr-gensym~24|))
 258          (setq |tr-gensym~26| (kar |tr-gensym~25|))
 259          (setq $a |tr-gensym~26|)
 260          (cond ((nthkdr |tr-gensym~25| 1)
 261                 (matcherr)))
 262          (return (mul* (simplify (list '(%cosh) $a))
 263                        (power (simplify (list '(%sinh)
 264                                               $a))
 265                               -1))))))
 266   (mdefprop $htrigrule4
 267             ((mequal) ((%coth simp) $a)
 268              ((mtimes simp) ((%cosh simp) $a)
 269               ((mexpt simp) ((%sinh simp) $a) -1)))
 270             $rule)
 271   (mdefprop $htrigrule4 $defrule $ruletype))
 272 (eval-when (compile eval load)
 273   (defprop $trigsimp t translated)
 274   (add2lnc '$trigsimp $props)
 275   (defmtrfun
 276       ($trigsimp $any mdefine nil nil)
 277       ($x)
 278     nil
 279     (simplify
 280      ($trigsimp3
 281       (simplify ($radcan (do ((|tr-gensym~27| $x
 282                                               (apply1 |tr-gensym~27|
 283                                                       (car |tr-gensym~28|)
 284                                                       0))
 285                               (|tr-gensym~28| '($trigrule1 $trigrule2
 286                                                 $trigrule3 $trigrule4
 287                                                 $htrigrule1 $htrigrule2
 288                                                 $htrigrule3 $htrigrule4)
 289                                               (cdr |tr-gensym~28|)))
 290                              ((null |tr-gensym~28|) |tr-gensym~27|)
 291                            )))))))
 292 (eval-when (compile eval load)
 293   (defprop $trigsimp3 t translated)
 294   (add2lnc '$trigsimp3 $props)
 295   (defmtrfun
 296       ($trigsimp3 $any mdefine nil nil)
 297       ($expn)
 298     nil
 299     (progn (setq $expn (simplify ($totaldisrep $expn)))
 300            (simplify ($ratsimp (div (simplify ($trigsimp1 ($num $expn)))
 301                                     (simplify ($trigsimp1 ($denom $expn)))))))))
 302 (eval-when (compile eval load)
 303   (defprop $trigsimp1 t translated)
 304   (add2lnc '$trigsimp1 $props)
 305   (defmtrfun ($trigsimp1 $any mdefine nil nil)
 306       ($expn)
 307     nil
 308     ((lambda ($listoftrigsq $bestlength $trylength)
 309        nil
 310        (assign-mode-check '$trylength $trylength)
 311        (assign-mode-check '$bestlength $bestlength)
 312        (setq $listoftrigsq (simplify ($listoftrigsq $expn)))
 313        (progn (assign-mode-check '$bestlength 999999)
 314               (setq $bestlength 999999))
 315        (cond ((not (like $listoftrigsq '((mlist))))
 316               (simplify ($improve $expn
 317                                   $expn
 318                                   $listoftrigsq)))
 319              (t $expn)))
 320      '$listoftrigsq
 321      0
 322      0)))
 323 (eval-when (compile eval load)
 324   (defprop $improve t translated)
 325   (add2lnc '$improve $props)
 326   (defmtrfun
 327       ($improve $any mdefine nil nil)
 328       ($expn $subsofar $listoftrigsq)
 329     nil
 330     (cond
 331       ((like $listoftrigsq '((mlist)))
 332        (cond ((< ((lambda (|tr-gensym~31|)
 333                     (progn (assign-mode-check '$trylength |tr-gensym~31|)
 334                            (setq $trylength |tr-gensym~31|)))
 335                   ($expnlength $subsofar))
 336                  (trd-msymeval $bestlength 0))
 337               ((lambda (|tr-gensym~30|)
 338                  (progn (assign-mode-check '$bestlength |tr-gensym~30|)
 339                         (setq $bestlength |tr-gensym~30|)))
 340                (trd-msymeval $trylength 0))
 341               $subsofar)
 342              (t $expn)))
 343       (t
 344        (setq $subsofar (simplify ($improve $expn
 345                                            $subsofar
 346                                            (simplify ($rest $listoftrigsq)))))
 347        (do
 348         (($alt) (mdo (cdr (simplify ($first $listoftrigsq))) (cdr mdo)))
 349         ((null mdo) '$done)
 350          (setq $alt (car mdo))
 351          (setq
 352           $subsofar
 353           (simplify
 354            ($improve
 355             $subsofar
 356             (simplify
 357              ($ratsubst
 358               (add*
 359                (simplify ($get (simplify ($inpart $alt 0)) '$unitcof))
 360                (mul*
 361                 (simplify ($get (trd-msymeval $piece '$piece)
 362                                 '$complement_cof))
 363                 (power
 364                  (simplify (mapply (simplify ($get (trd-msymeval $piece
 365                                                                  '$piece)
 366                                                    '$complement_function))
 367                                    (list (simplify ($first $alt)))
 368                                    '(($get) $piece
 369                                      ((mquote) $complement_function))))
 370                  2)))
 371               (power $alt 2)
 372               $subsofar))
 373             (simplify ($rest $listoftrigsq))))))
 374        $subsofar))))
 375 (eval-when (compile eval load)
 376   (defprop $listoftrigsq t translated)
 377   (add2lnc '$listoftrigsq $props)
 378   (defmtrfun
 379       ($listoftrigsq $any mdefine nil nil)
 380       ($expn)
 381     nil
 382     (cond
 383       (($atom $expn) '((mlist)))
 384       (t
 385        ((lambda
 386             ($inflag $ans)
 387           nil
 388           (prog
 389               nil
 390              (cond ((and (like (simplify ($inpart $expn 0)) '&^)
 391                          ($integerp (simplify ($inpart $expn 2)))
 392                          (not (is-boole-check (mlsp (trd-msymeval $piece
 393                                                                   '$piece)
 394                                                     2))))
 395                     (cond (($atom (setq $expn (simplify ($inpart $expn 1))))
 396                            (return '((mlist))))
 397                           (($trigonometricp $expn)
 398                            (return (list '(mlist) (list '(mlist) $expn)))))))
 399              (setq $inflag t)
 400              (do
 401               (($arg) (mdo (cdr $expn) (cdr mdo)))
 402               ((null mdo) '$done)
 403                (setq $arg (car mdo))
 404                (setq
 405                 $ans
 406                 (simplify ($specialunion (simplify ($listoftrigsq $arg))
 407                                          (trd-msymeval $ans '$ans)))))
 408              (return (trd-msymeval $ans '$ans))))
 409         '$inflag
 410         '((mlist)))))))
 411 (eval-when (compile eval load)
 412   (defprop $specialunion t translated)
 413   (add2lnc '$specialunion $props)
 414   (defmtrfun
 415       ($specialunion $any mdefine nil nil)
 416       ($list1 $list2)
 417     nil
 418     (cond
 419       ((like $list1 '((mlist))) (trd-msymeval $list2 '$list2))
 420       ((like (trd-msymeval $list2 '$list2) '((mlist))) $list1)
 421       (t
 422        ((lambda
 423             ($alternates)
 424           nil
 425           (do
 426            (($alt) (mdo (cdr $alternates) (cdr mdo)))
 427            ((null mdo) '$done)
 428             (setq $alt (car mdo))
 429             (setq
 430              $list2
 431              (simplify ($update $alt
 432                                 (simplify ($get (simplify ($inpart $alt 0))
 433                                                 '$complement_function))))))
 434           (simplify ($specialunion (simplify ($rest $list1))
 435                                    (trd-msymeval $list2 '$list2))))
 436         (simplify ($first $list1)))))))
 437 (eval-when (compile eval load)
 438   (defprop $update t translated)
 439   (add2lnc '$update $props)
 440   (defmtrfun
 441       ($update $any mdefine nil nil)
 442       ($form $complement)
 443     nil
 444     ((lambda
 445          ($ans)
 446        (declare (special $ans))
 447        nil
 448        nil
 449        (setq $complement (simplify (mfuncall $complement
 450                                              (simplify ($inpart $form 1)))))
 451        (setq
 452         $ans
 453         (do (($element)
 454              (mdo (cdr (trd-msymeval $list2 '$list2)) (cdr mdo)))
 455             ((null mdo) '$done)
 456           (setq $element (car mdo))
 457           (cond (($member $form $element)
 458                  (return '$found))
 459                 (($member $complement $element)
 460                  (return ($cons (list '(mlist) $form $complement)
 461                                 (simplify ($delete $element
 462                                                    (trd-msymeval $list2
 463                                                                  '$list2)))))))))
 464        (cond ((like (trd-msymeval $ans '$ans) '$found)
 465               (trd-msymeval $list2 '$list2))
 466              ((like (trd-msymeval $ans '$ans) '$done)
 467               ($cons (list '(mlist) $form) (trd-msymeval $list2 '$list2)))
 468              (t (trd-msymeval $ans '$ans))))
 469      '$ans)))
 470 (eval-when (compile eval load)
 471   (defprop $expnlength t translated)
 472   (add2lnc '$expnlength $props)
 473   (defmtrfun ($expnlength $fixnum mdefine nil nil)
 474       ($expr)
 475     nil
 476     ((lambda ($inflag)
 477        nil
 478        (cond (($atom $expr) 1)
 479              (t (f+ 1
 480                     ($argslength (simplify ($args $expr)))))))
 481      t)))
 482 (eval-when (compile eval load)
 483   (defprop $argslength t translated)
 484   (add2lnc '$argslength $props)
 485   (defmtrfun ($argslength $any mdefine nil nil)
 486       ($args)
 487     nil
 488     (simplify (mapply-tr '&+
 489                          (simplify (map1 (getopr '$expnlength)
 490                                          $args))))))