home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / sin.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  37.5 KB  |  1,346 lines
  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. (macsyma-module sin)
  13.  
  14. (DECLARE-TOP (SPECIAL RATFORM EXPTSUM $RADEXPAND $%E_TO_NUMLOG
  15.           EXPTIND QUOTIND SPLIST L ANS SPLIST ARCPART COEF
  16.           AA DICT EXPTFLAG BASE* POWERLIST A B K STACK
  17.           RATROOT ROOTLIST SQUARE E W Y EXPRES ARG VAR
  18.           POWERL C D EXP CHEBYFORM RATROOTFORM TRIGARG
  19.           NOTSAME YY B1 YZ VARLIST GENVAR REPSWITCH $LIFLAG
  20.           NOPARTS TOP MAXPARTS NUMPARTS BLANK $OPSUBST)
  21.      (*EXPR POWERLIST RATROOT)
  22.      (*LEXPR $FACTOR $EXPAND)
  23.      (GENPREFIX SIN))
  24.  
  25. (DEFMVAR $INTEGRATION_CONSTANT_COUNTER 0)
  26.  
  27. (DEFUN SASSQ1 (ARG LIST FN)
  28.   (or (zl-ASSOC arg list) (funcall fn))
  29.   #|(COND ((NULL LIST) (FUNCALL FN))
  30.       ((EQUAL (CAAR LIST) ARG) (CAR LIST))
  31.       (T (SASSQ1 ARG (CDR LIST) FN)))
  32.     |#
  33.   )
  34.      
  35.  
  36. (defmacro op (frob)
  37.   `(get ,frob 'operators))
  38.  
  39. (DEFUN INTEGERP1 (X) (INTEGERP2 (MUL2* 2 X)))
  40.  
  41. (DEFUN SUPEREXPT (EXP VAR BASE*) 
  42.   (PROG (EXPTFLAG Y W) 
  43.     (SETQ Y (ELEMXPT EXP))
  44.     (COND (EXPTFLAG (RETURN NIL)))
  45.     (RETURN
  46.      (SUBSTINT
  47.       (LIST '(MEXPT) BASE* VAR)
  48.       VAR
  49.       (INTEGRATOR (DIV Y (MUL2 VAR (SIMPLOG (LIST BASE*)))) VAR)))))
  50.  
  51. (DEFUN ELEMXPT (EXP) 
  52.      (COND ((FREEVAR EXP) EXP)
  53.            ((ATOM EXP) (SETQ EXPTFLAG T))
  54.            ((NOT (EQ (CAAR EXP) 'MEXPT))
  55.         (CONS (CAR EXP)
  56.               (MAPCAR 
  57.                (FUNCTION (LAMBDA (C) (ELEMXPT C)))
  58.                (CDR EXP))))
  59.            ((NOT (FREEVAR (CADR EXP)))
  60.         (LIST '(MEXPT)
  61.               (ELEMXPT (CADR EXP))
  62.               (ELEMXPT (CADDR EXP))))
  63.            ((NOT (EQ (CADR EXP) BASE*))
  64.         (ELEMXPT (LIST '(MEXPT)
  65.                    BASE*
  66.                    (SIMPLIFY (LIST '(MTIMES)
  67.                            (list '(mexpt)
  68.                              (list '(%log) base*) -1)                       (LIST '(%LOG)
  69.                          (CADR EXP))
  70.                        (CADDR EXP))))))
  71.            ((NOT (SETQ W
  72.                (M2 (CADDR EXP)
  73.                    '((MPLUS)
  74.                  ((COEFFPT) (A FREEVAR) (VAR VARP))
  75.                  ((COEFFPT) (B FREEVAR)))
  76.                    NIL)))
  77.         (LIST (CAR EXP) BASE* (ELEMXPT (CADDR EXP))))
  78.            (T (MAXIMA-SUBSTITUTE BASE*
  79.                   'BASE*
  80.                   (SUBLISS W
  81.                        '((MTIMES)
  82.                      ((MEXPT) BASE* B)
  83.                      ((MEXPT) VAR A)))))))
  84.  
  85. (DEFUN SUBST10 (EX) 
  86.   (COND ((ATOM EX) EX)
  87.     ((AND (EQ (CAAR EX) 'MEXPT) (EQ (CADR EX) VAR))
  88.      (LIST '(MEXPT) VAR (INTEGERP2 (QUOTIENT (CADDR EX) D))))
  89.     (T (CONS (NCONS (CAAR EX))
  90.          (MAPCAR #'(LAMBDA (C) (SUBST10 C)) (CDR EX))))))
  91.  
  92. (DEFUN CHOICESIN (X1 X2) 
  93.   (IF (EQ X1 (CAR X2)) (CDR X2) (CONS (CAR X2) (CHOICESIN X1 (CDR X2)))))
  94.      
  95. (DEFUN RATIONALIZER (X)
  96.  (LET ((EX (SIMPLIFY ($FACTOR X)))) (IF (NOT (ALIKE1 EX X)) EX)))
  97.  
  98. (DEFUN INTFORM (EXPRES) 
  99.   (COND
  100.    ((FREEVAR EXPRES) NIL)
  101.    ((ATOM EXPRES) NIL)
  102.    ((MEMQ (CAAR EXPRES) '(MPLUS MTIMES))
  103.     ((LAMBDA (L) (PROG (Y) 
  104.           LOOP (COND ((SETQ Y (INTFORM (CAR L))) (RETURN Y))
  105.                  ((NOT (SETQ L (CDR L))) (RETURN NIL))
  106.                  (T (GO LOOP)))))
  107.      (CDR EXPRES)))
  108.    ((OR (EQ (CAAR EXPRES) '%LOG) (ARCP (CAAR EXPRES)))
  109.     (COND
  110.      ((SETQ ARG (M2 EXP 
  111. ;;; (LIST '(MTIMES) (CONS (LIST (CAAR EXPRES)) '((B RAT8)))'((COEFFTT)(C RAT8PRIME)))
  112.             `((MTIMES) (( ,(CAAR EXPRES) ) (B RAT8)) ((COEFFTT) (C RAT8PRIME)) )
  113.             NIL))
  114.       (RATLOG EXP VAR (CONS (CONS 'A EXPRES) ARG)))
  115.      (T
  116.       (PROG (Y Z) 
  117.         (COND
  118.          ((SETQ Y (INTFORM (CADR EXPRES))) (RETURN Y))
  119.          ((AND (EQ (CAAR EXPRES) '%LOG)
  120.            (SETQ Z (M2 (CADR EXPRES) C NIL))
  121.            (SETQ Y (M2 EXP
  122.                    '((MTIMES)
  123.                  ((COEFFTT) (C RAT8))
  124.                  ((COEFFTT) (D ELEM)))
  125.                    NIL)))
  126.           (RETURN
  127.            ((LAMBDA (A B C D) 
  128.          (SUBSTINT
  129.           EXPRES
  130.           VAR
  131.           (INTEGRATOR
  132.            (MULN
  133.             (LIST (MAXIMA-SUBSTITUTE
  134.                               `((MQUOTIENT) ((MPLUS) ((MEXPT) $%E ,VAR)
  135.                                                      ((MTIMES) -1 ,A))
  136.                                             ,B)
  137.                               VAR
  138.                               C)
  139.                           `((MQUOTIENT) ((MEXPT) $%E ,VAR) ,B)
  140.               (MAXIMA-SUBSTITUTE VAR EXPRES D))
  141.             NIL)
  142.            VAR)))
  143.         (CDR (SASSQ 'A Z 'NILL))
  144.         (CDR (SASSQ 'B Z 'NILL))
  145.         (CDR (SASSQ 'C Y 'NILL))
  146.         (CDR (SASSQ 'D Y 'NILL)))))
  147.          (T (RETURN NIL)))))))
  148.    ((OPTRIG (CAAR EXPRES))
  149.     (COND ((NOT (SETQ W (M2 (CADR EXPRES) C NIL)))
  150.        (INTFORM (CADR EXPRES)))
  151.       (T (PROG2 (SETQ POWERL T)
  152.             (MONSTERTRIG EXP VAR (CADR EXPRES))))))
  153.    ((AND (EQ (CAAR EXPRES) '%DERIVATIVE)
  154.      (EQ (CAAR EXP) (CAAR EXPRES))
  155.      (OR (ATOM (CADR EXP)) (NOT (EQ (CAAADR EXP) 'MQAPPLY))
  156.          (merror "Invalid arg to INTEGRATE:~%~M" EXP))
  157.      (CHECKDERIV EXP)))
  158.    ((NOT (EQ (CAAR EXPRES) 'MEXPT)) NIL)
  159.    ((INTEGERP (CADDR EXPRES)) (INTFORM (CADR EXPRES)))
  160.    ((FREEVAR (CADR EXPRES))
  161.     (COND ((M2 (CADDR EXPRES) C NIL)
  162.        (SUPEREXPT EXP VAR (CADR EXPRES)))
  163.       ((INTFORM (CADDR EXPRES)))
  164.       (T (LET* (($%E_TO_NUMLOG T) (NEXP (RESIMPLIFY EXP)))
  165.            (COND ((ALIKE1 EXP NEXP) NIL)
  166.              (T (INTFORM (SETQ EXP NEXP))))))))
  167.    ((NOT (RAT8 (CADR EXPRES))) (INTFORM (CADR EXPRES)))
  168.    ((AND (SETQ W (M2 (CADR EXPRES) RATROOTFORM NIL))    ;e*(a*x+b) / (c*x+d)
  169.      (DENOMFIND (CADDR EXPRES)))            ;expon is ratnum
  170.     (COND((SETQ W(PROG2 (SETQ POWERL T) (RATROOT EXP VAR (CADR EXPRES) W))) W)
  171.      (T(INTE EXP VAR))))
  172.    ((NOT (INTEGERP1 (CADDR EXPRES)))            ;2*exponent not integer
  173.     (COND ((M2 EXP CHEBYFORM NIL) (CHEBYF EXP VAR))
  174.       (T (INTFORM (CADR EXPRES)))))
  175.    ((SETQ W (M2 (CADR EXPRES) D NIL))            ;sqrt(c*x^2+b*x+a)
  176.     (INTE EXP VAR))
  177.    ((M2 EXP CHEBYFORM NIL) (CHEBYF EXP VAR))
  178.    ((NOT (M2 (SETQ W ($EXPAND (CADR EXPRES))) (CADR EXPRES) NIL))
  179.     (PROG2 (SETQ EXP (MAXIMA-SUBSTITUTE W (CADR EXPRES) EXP))
  180.        (INTFORM (SIMPLIFY (LIST '(MEXPT) W (CADDR EXPRES))))))
  181.    ((SETQ W (RATIONALIZER (CADR EXPRES)))
  182.     (PROG2 (SETQ EXP (LET (($RADEXPAND '$ALL))
  183.               (MAXIMA-SUBSTITUTE W (CADR EXPRES) EXP)))
  184.        (INTFORM (LET (($RADEXPAND '$ALL))
  185.              (SIMPLIFY (LIST '(MEXPT) W (CADDR EXPRES)))))))))
  186.  
  187. (DEFUN SEPARC (EX)
  188.        (COND ((ARCFUNCP EX) (SETQ ARCPART EX COEF 1))
  189.          ((EQ (CAAR EX) 'MTIMES)
  190.           (ARCLIST (CDR EX))
  191.           (SETQ COEF (COND ((NULL (CDR COEF)) (CAR COEF))
  192.                    (T (SETQ COEF (CONS (CAR EX) COEF))))))))
  193. (DEFUN ARCLIST (LIST)
  194.        (COND ((NULL LIST) NIL)
  195.          ((AND (ARCFUNCP (CAR LIST)) (NULL ARCPART))
  196.           (SETQ ARCPART (CAR LIST)) (ARCLIST (CDR LIST)))
  197.          (T (SETQ COEF (CONS (CAR LIST) COEF))
  198.         (ARCLIST (CDR LIST)))))
  199.  
  200. (DEFUN ARCFUNCP (EX)
  201.        (AND (NOT (ATOM EX))
  202.         (OR (ARCP (CAAR EX))
  203.         (EQ (CAAR EX) '%LOG)  ; Experimentally treat logs also.
  204.         (AND (EQ (CAAR EX) 'MEXPT)
  205.              (INTEGERP2 (CADDR EX))
  206.              (GREATERP (INTEGERP2 (CADDR EX)) 0)
  207.              (ARCFUNCP (CADR EX))))))
  208.  
  209. (DEFUN INTEGRATOR (EXP VAR)
  210.   (PROG (Y ARG POWERL CONST B W C D E RATROOTFORM
  211.        CHEBYFORM ARCPART COEF INTEGRAND)
  212.     (IF (FREEVAR EXP) (RETURN (MUL2* EXP VAR)))
  213.     (SETQ W (PARTITION EXP VAR 1))
  214.     (SETQ CONST (CAR W))
  215.     (SETQ EXP (CDR W))
  216.     (COND ((MPLUSP EXP) (RETURN (MUL2* CONST (INTEGRATE1 (CDR EXP)))))
  217.           ((AND (NOT (ATOM EXP)) (EQ (CAAR EXP) '$ATAN2))
  218.            (RETURN (MUL2* CONST (INTEGRATOR
  219.                      (SIMPLIFYA (LIST '(%ATAN) (DIV (CADR EXP) (CADDR EXP))) T)
  220.                      VAR))))
  221.           ((AND (NOT (ATOM EXP)) (EQ (CAAR EXP) '%SUM))
  222.            (RETURN (MUL2* CONST (INTSUM EXP VAR)))))
  223.         (COND ((SETQ Y (DIFFDIV EXP VAR)) (RETURN (MUL2* CONST Y))))
  224.     (SETQ Y (COND ((EQ (CAAR EXP) 'MTIMES) (CDR EXP)) (T (LIST EXP))))
  225.     (SETQ C '((MPLUS)
  226.           ((COEFFPT) (B FREEVAR) (X VARP))
  227.           ((COEFFPT) (A FREEVAR))))
  228.     (SETQ RATROOTFORM '((MTIMES)
  229.                 ((COEFFTT) (E FREEVAR))
  230.                 ((MPLUS)
  231.                  ((COEFFPT) (A FREEVAR) (VAR VARP))
  232.                  ((COEFFPT) (B FREEVAR)))
  233.                 ((MEXPT)
  234.                  ((MPLUS)
  235.                   ((COEFFPT) (C FREEVAR) (VAR VARP))
  236.                   ((COEFFPT) (D FREEVAR)))
  237.                  -1)))
  238.     (SETQ CHEBYFORM '((MTIMES)
  239.               ((MEXPT) (VAR VARP) (R1 NUMBERP))
  240.               ((MEXPT)
  241.                ((MPLUS)
  242.                 ((MTIMES)
  243.                  ((COEFFTT) (C2 FREEVAR))
  244.                  ((MEXPT) (VAR VARP) (Q FREE1)))
  245.                 ((COEFFPP) (C1 FREEVAR)))
  246.                (R2 NUMBERP))
  247.               ((COEFFTT) (A FREEVAR))))
  248.     (SETQ D '((MPLUS)
  249.           ((COEFFPT) (C FREEVAR) ((MEXPT) (X VARP) 2))
  250.           ((COEFFPT) (B FREEVAR) (X VARP))
  251.           ((COEFFPT) (A FREEVAR))))
  252.     (SETQ E '((MTIMES)
  253.           ((MPLUS)
  254.            ((COEFFPT) (A FREEVAR) (VAR VARP))
  255.            ((COEFFPT) (B FREEVAR)))
  256.           ((MPLUS)
  257.            ((COEFFPT) (C FREEVAR) (VAR VARP))
  258.            ((COEFFPT) (D FREEVAR)))))
  259.    LOOP (COND ((RAT8 (CAR Y)) (GO SKIP))
  260.           ((SETQ W (INTFORM (CAR Y))) (RETURN (MUL2* CONST W)))
  261.           (T (GO SPECIAL)))
  262.    SKIP (SETQ Y (CDR Y))
  263.     (COND ((NULL Y)
  264.            (RETURN (MUL2* CONST (COND ((SETQ Y (POWERLIST EXP VAR)) Y)
  265.                       (T (RATINT EXP VAR)))))))
  266.     (GO LOOP)
  267.    SPECIAL
  268.        (SEPARC EXP)    ;SEPARC SETQS ARCPART AND COEF SUCH THAT
  269.                        ;COEF*ARCEXP=EXP WHERE ARCEXP IS OF THE FORM
  270.                            ;ARCFUNC^N AND COEF IS ITS ALGEBRAIC COEFFICIENT
  271.        (COND ((AND (NOT (NULL ARCPART))
  272.                (DO  ((STACKLIST STACK (CDR STACKLIST)))
  273.                 ((NULL STACKLIST) T)
  274.                 (COND ((ALIKE1 (CAR STACKLIST) COEF)
  275.                    (RETURN NIL))))
  276.                (NOT (ISINOP (SETQ W ((LAMBDA (STACK)
  277.                           (INTEGRATOR COEF VAR))
  278.                          (CONS COEF STACK)))
  279.                     '%INTEGRATE))
  280.                (SETQ INTEGRAND (MUL2 W (SDIFF ARCPART VAR)))
  281.                (DO ((STACKLIST STACK (CDR STACKLIST)))
  282.                ((NULL STACKLIST) T)
  283.                (COND ((ALIKE1 (CAR STACKLIST) INTEGRAND)
  284.                   (RETURN NIL))))
  285.                (NOT (ISINOP
  286.                  (SETQ Y
  287.                    ((LAMBDA (STACK INTEG)
  288.                         (INTEGRATOR INTEG VAR))
  289.                     (CONS INTEGRAND STACK)
  290.                     INTEGRAND))
  291.                  '%INTEGRATE)))
  292.           (RETURN (ADD2* (LIST '(MTIMES) CONST W ARCPART)
  293.                  (LIST '(MTIMES) -1 CONST Y))))
  294.          (T (RETURN
  295.              (MUL2 CONST
  296.                (COND ((SETQ Y (SCEP EXP VAR))
  297.                   (COND ((CDDR Y)
  298.                      (INTEGRATOR ($TRIGREDUCE EXP) VAR))
  299.                     (T (SCE-INT (CAR Y) (CADR Y) VAR))))
  300.                  ((NOT (ALIKE1 EXP (SETQ Y ($EXPAND EXP))))
  301.                   (INTEGRATOR Y VAR))
  302.                  ((AND (NOT POWERL)
  303.                        (SETQ Y (POWERLIST EXP VAR)))
  304.                   Y)
  305.                  ((SETQ Y (RISCHINT EXP VAR)) Y)
  306.                  (T (LIST '(%INTEGRATE) EXP VAR)))))))))
  307.  
  308. (DEFUN RAT8 (EX)
  309.   (COND ((OR (ALIKE1 EX VAR) (FREEVAR EX)) T)
  310.     ((MEMQ (CAAR EX) '(MPLUS MTIMES))
  311.      (DO ((U (CDR EX) (CDR U))) ((NULL U) T)
  312.          (IF (NOT (RAT8 (CAR U))) (RETURN NIL))))
  313.     ((NOT (EQ (CAAR EX) 'MEXPT)) NIL)
  314.     ((INTEGERP (CADDR EX)) (RAT8 (CADR EX)))))
  315.      
  316. (DEFUN OPTRIG (X) (MEMQ X '(%SIN %COS %SEC %TAN %CSC %COT)))
  317.      
  318. ;after finding a non-integrable summand usually better to pass rest to risch
  319. (DEFUN INTEGRATE1 (EXP)
  320.   (DO ((TERMS EXP (CDR TERMS)) (ANS))
  321.       ((NULL TERMS) (ADDN ANS NIL))
  322.     (LET ($LIFLAG)                    ;don't gen li's for
  323.       (PUSH (INTEGRATOR (CAR TERMS) VAR) ANS))        ;parts of integrand
  324.     (WHEN (AND (NOT (FREE (CAR ANS) '%INTEGRATE)) (CDR TERMS))
  325.       (RETURN (ADDN (CONS (RISCHINT (CONS '(MPLUS) TERMS) VAR) (CDR ANS))
  326.             NIL)))))
  327.  
  328. ;(DEFUN ABSSUBST (EXP)
  329. ; (COND ((ATOM EXP) EXP)
  330. ;       ((EQ (CAAR EXP) 'MABS) (CADR EXP))
  331. ;       (T (CONS (CAR EXP) (MAPCAR #'ABSSUBST (CDR EXP))))))
  332.  
  333. (DEFUN SCEP (EXPR VAR &AUX TRIGL EXP)  ; Product of SIN, COS, EXP
  334.   (AND (MTIMESP EXPR)               ;    of linear args.
  335.        (SLOOP FOR FAC IN (CDR EXPR) DO
  336.          (COND ((ATOM FAC) (RETURN NIL))
  337.            ((TRIG1 (CAR FAC))
  338.             (IF (LINEARP (CADR FAC) VAR) (PUSH FAC TRIGL)
  339.             (RETURN NIL)))
  340.            ((AND (MEXPTP FAC)
  341.              (EQ (CADR FAC) '$%E)
  342.              (LINEARP (CADDR FAC) VAR))
  343.             ; should be only one exponential factor
  344.             (SETQ EXP FAC))
  345.            (T (RETURN NIL)))
  346.          FINALLY (RETURN (CONS EXP TRIGL)))))
  347.  
  348. ; Integrates exponential * sin or cos, all with linear args.
  349. (DEFUN SCE-INT (EXP S-C VAR)        ; EXP is non-trivial
  350.   (LET ((E-COEF (CAR (ISLINEAR (CADDR EXP) VAR)))
  351.     (SC-COEF (CAR (ISLINEAR (CADR S-C) VAR)))
  352.     (SC-ARG (CADR S-C)))
  353.        (MUL (DIV EXP (ADD (POWER E-COEF 2) (POWER SC-COEF 2)))
  354.         (ADD (MUL E-COEF S-C)
  355.          (IF (EQ (CAAR S-C) '%SIN)
  356.              (MUL* (NEG SC-COEF) `((%COS) ,SC-ARG))
  357.              (MUL* SC-COEF `((%SIN) ,SC-ARG)))))))
  358.  
  359. (defun checkderiv (expr)
  360.   (checkderiv1 (cadr expr) (cddr expr) () ))
  361.  
  362. ;; CHECKDERIV1 gets called on the expression being differentiated,
  363. ;; an alternating list of variables being differentiated with
  364. ;; respect to and powers thereof, and a reversed list of the latter
  365. ;; that have already been examined.  It returns either the antiderivative
  366. ;; or (), saying this derivative isn't wrt the variable of integration.
  367.  
  368. (defun checkderiv1 (expr wrt old-wrt)
  369.   (cond ((alike1 (car wrt) var)
  370.      (if (equal (cadr wrt) 1)        ;Power = 1?
  371.          (if (null (cddr wrt))        ;single or partial
  372.          (if (null old-wrt)
  373.              expr                     ;single
  374.            `((%derivative), expr    ;partial in old-wrt
  375.              ,.(nreverse old-wrt)))
  376.          `((%derivative) ,expr        ;Partial, return rest
  377.            ,.(nreverse old-wrt)
  378.            ,@(cddr wrt)))
  379.          `((%derivative) ,expr            ;Higher order, reduce order
  380.            ,.(nreverse old-wrt)
  381.            ,(car wrt) ,(add2* (cadr wrt) -1)
  382.            ,@ (cddr wrt))))
  383.     ((null (cddr wrt)) () )            ;Say it doesn't apply here
  384.     (t (checkderiv1 expr (cddr wrt)        ;Else we check later terms
  385.             (list* (cadr wrt) (car wrt) old-wrt)))))
  386.  
  387. (DEFUN ELEM (A) 
  388.   (COND ((FREEVAR A) T)
  389.     ((ATOM A) NIL)
  390.     ((M2 A EXPRES NIL) T)
  391.     (T (EVAL (CONS 'AND (MAPCAR #'ELEM (CDR A)))))))
  392.  
  393. (DEFUN FREEVAR (A) 
  394.        (COND ((ATOM A) (NOT (EQ A VAR)))
  395.          ((ALIKE1 A VAR) NIL)
  396.          ((AND (NOT (ATOM (CAR A)))
  397.            (MEMQ 'array (CDAR A)))
  398.           (COND ((FREEVAR (CDR A)) T)
  399.             (T (MERROR "Variable of integration appeared in subscript"))))
  400.          (T (AND (FREEVAR (CAR A)) (FREEVAR (CDR A))))))
  401.  
  402. (DEFUN VARP (X) (ALIKE1 X VAR)) 
  403.  
  404. (DEFUN INTEGRALLOOKUPS (EXP) 
  405.      (COND ((EQ (CAAR EXP) '%LOG)
  406.         (MAXIMA-SUBSTITUTE (CADR EXP)
  407.                 'X
  408.                 '((MPLUS)
  409.                   ((MTIMES) X ((%LOG) X))
  410.                   ((MTIMES) -1 X))))
  411.            ((EQ (CAAR EXP) 'MPLUS)
  412.         (MULN (LIST '((RAT SIMP) 1 2) EXP EXP) NIL))
  413.            ((EQ (CAAR EXP) 'MEXPT)
  414.         (COND ((FREEVAR (CADR EXP))
  415.                (SIMPLIFYA (MAXIMA-SUBSTITUTE EXP
  416.                           'A
  417.                           (MAXIMA-SUBSTITUTE (CADR EXP)
  418.                               'B
  419.                               '((MTIMES)
  420.                                 A
  421.                                 ((MEXPT)
  422.                                  ((%LOG)
  423.                                   B)
  424.                                  -1))))
  425.                   NIL))
  426.               ((OR (EQUAL (CADDR EXP) -1)
  427.                (AND (NOT (MNUMP (CADDR EXP)))
  428.                 (FREEOF '$%I (CADDR EXP))
  429.                 (EQ (ASKSIGN (POWER (ADD2 (CADDR EXP) 1) 2)) '$ZERO)))
  430.                (MAXIMA-SUBSTITUTE (CADR EXP) 'X (LOGMABS 'X)))
  431.               (T (MAXIMA-SUBSTITUTE (ADD2* (CADDR EXP) 1)
  432.                      'N
  433.                      (MAXIMA-SUBSTITUTE (CADR EXP)
  434.                          'X
  435.                          '((MTIMES)
  436.                            ((MEXPT) N -1)
  437.                            ((MEXPT) X N)))))))
  438.            (T (MAXIMA-SUBSTITUTE (CADR EXP)
  439.                   'X
  440.                   (CDR (SASSQ (CAAR EXP)
  441.                       '((%SIN (MTIMES) -1 ((%COS) X))
  442.                         (%COS (%SIN) X)
  443.                         (%TAN (%LOG)
  444.                           ((%SEC) X))
  445.                         (%SEC (%LOG) ((MPLUS) ((%SEC) X) ((%TAN) X)))
  446.                         (%COT (%LOG)
  447.                           ((%SIN) X))
  448.                         (%SINH (%COSH) X)
  449.                         (%COSH (%SINH) X)
  450.                         (%TANH (%LOG)
  451.                            ((%COSH) X))
  452.                         (%COTH (%LOG) ((%SINH) X))
  453.                         (%SECH (%ATAN)
  454.                            ((%SINH) X))
  455.                         (%CSCH
  456.                          (%LOG) ((%TANH) ((MTIMES) ((RAT SIMP) 1 2) X)))
  457.                         (%CSC (MTIMES)
  458.                           -1
  459.                           ((%LOG)
  460.                            ((MPLUS)
  461.                             ((%CSC) X)
  462.                             ((%COT)
  463.                              X)))))
  464.                       'NILL))))))
  465.  
  466. (DEFUN TRUE (IGNOR) IGNOR T) 
  467.  
  468. (DEFUN RAT10 (EX) 
  469.   (COND ((FREEVAR EX) T)
  470.     ((ALIKE1 EX VAR) NIL)
  471.     ((EQ (CAAR EX) 'MEXPT)
  472.      (IF (ALIKE1 (CADR EX) VAR)
  473.          (IF (INTEGERP2 (CADDR EX))
  474.          (SETQ POWERLIST (CONS (CADDR EX) POWERLIST)))
  475.          (AND (RAT10 (CADR EX)) (RAT10 (CADDR EX)))))
  476.     ((MEMQ (CAAR EX) '(MPLUS MTIMES))
  477.      (DO ((U (CDR EX) (CDR U))) ((NULL U) T)
  478.          (IF (NOT (RAT10 (CAR U))) (RETURN NIL))))
  479.     (T
  480.      (let ((examine (margs ex)))
  481.        (if (atom (first examine))
  482.            (do* ((element examine (rest element))
  483.              (result (rat10 (first examine))
  484.                  (and result (rat10 (first element)))))
  485.            ((or (null result) (null element)) result))
  486.          (rat10 (first examine)))))))
  487.  
  488. (DEFUN LISTGCD (POWERLIST)
  489.   (PROG (P)
  490.     (SETQ P (CAR POWERLIST))
  491.    LOOP (SETQ POWERLIST (CDR POWERLIST))
  492.     (IF (EQUAL P 1) (RETURN NIL))
  493.     (IF (NULL POWERLIST) (RETURN P))
  494.     (SETQ P (GCD P (CAR POWERLIST)))
  495.     (GO LOOP)))
  496.      
  497. (DEFUN INTEGRATE5 (EX VAR)
  498.   (IF (RAT8 EX) (RATINT EX VAR) (INTEGRATOR EX VAR)))
  499.      
  500. (DEFUN INTEGERP2 (X)
  501.   (LET (U)
  502.     (COND ((NOT (NUMBERP X)) NIL)
  503.       ((NOT (FLOATP X)) X)
  504.       ((PROG2 (SETQ U (MAXIMA-RATIONALIZE X)) (EQUAL (CDR U) 1)) (CAR U)))))
  505.  
  506. (DEFUN RAT3 (EX IND) 
  507.   (COND ((FREEVAR EX) T)
  508.     ((ATOM EX) IND)
  509.     ((MEMQ (CAAR EX) '(MTIMES MPLUS))
  510.      (DO ((U (CDR EX) (CDR U))) ((NULL U) T)
  511.          (IF (NOT (RAT3 (CAR U) IND)) (RETURN NIL))))
  512.     ((NOT (EQ (CAAR EX) 'MEXPT)) (RAT3 (CAR (MARGS EX)) T))
  513.     ((FREEVAR (CADR EX)) (RAT3 (CADDR EX) T))
  514.     ((INTEGERP (CADDR EX)) (RAT3 (CADR EX) IND))
  515.     ((AND (M2 (CADR EX) RATROOT NIL) (DENOMFIND (CADDR EX)))
  516.      (SETQ ROOTLIST (CONS (DENOMFIND (CADDR EX)) ROOTLIST)))
  517.     (T (RAT3 (CADR EX) NIL))))
  518.  
  519. (DEFUN SUBST4 (EX) 
  520.   (COND ((FREEVAR EX) EX)
  521.     ((ATOM EX) A)
  522.     ((NOT (EQ (CAAR EX) 'MEXPT))
  523.      (MAPCAR #'(LAMBDA (U) (SUBST4 U)) EX))
  524.     ((M2 (CADR EX) RATROOT NIL)
  525.      (LIST (CAR EX) B (INTEGERP2 (TIMESK K (CADDR EX)))))
  526.     (T (LIST (CAR EX) (SUBST4 (CADR EX)) (SUBST4 (CADDR EX))))))
  527.  
  528. (DEFUN FINDINGK (LIST)
  529.        (DO ((KK 1) (L LIST (CDR L))) ((NULL L) KK)
  530.        (SETQ KK (LCM KK (CAR L)))))
  531.  
  532. (DEFUN DENOMFIND (X) 
  533.   (COND ((RATNUMP X) (CADDR X))
  534.     ((NOT (NUMBERP X)) NIL)
  535.     ((NOT (FLOATP X)) 1)
  536.     (T (CDR (MAXIMA-RATIONALIZE X)))))
  537.  
  538. (DEFUN RATROOT (EXP VAR RATROOT W) 
  539.      (PROG (ROOTLIST K Y W1) 
  540.            (COND ((SETQ Y (CHEBYF EXP VAR)) (RETURN Y)))
  541.            (COND ((NOT (RAT3 EXP T)) (RETURN NIL)))
  542.            (SETQ K (FINDINGK ROOTLIST))
  543.            (SETQ W1 (CONS (CONS 'K K) W))
  544.            (SETQ Y
  545.              (SUBST41
  546.               EXP
  547.               (SIMPLIFY
  548.                (SUBLISS W1
  549.                 '((MQUOTIENT)
  550.                   ((MPLUS) ((MTIMES) B E)
  551.                        ((MTIMES) -1 D ((MEXPT) VAR K)))
  552.                   ((MPLUS) ((MTIMES) C ((MEXPT) VAR K))
  553.                        ((MTIMES) -1 E A)))))
  554.               VAR))
  555.            (SETQ Y
  556.              (INTEGRATOR
  557.               (SIMPLIFY
  558.                (LIST '(MTIMES)
  559.                  Y
  560.                  (SUBLISS
  561.                   W1 '((MQUOTIENT)
  562.                    ((MTIMES)
  563.                     E ((MPLUS)
  564.                        ((MTIMES) A D K
  565.                          ((MEXPT) VAR ((MPLUS) -1 K)))
  566.                        ((MTIMES)
  567.                     -1
  568.                     ((MTIMES) B C K
  569.                           ((MEXPT) VAR ((MPLUS) -1 K))))))
  570.                    ((MEXPT) ((MPLUS)
  571.                          ((MTIMES) C ((MEXPT) VAR K))
  572.                          ((MTIMES) -1 A))
  573.                         2)))))
  574.               VAR))
  575.            (RETURN (SUBSTINT (SIMPLIFY (LIST '(MEXPT)
  576.                          RATROOT
  577.                          (LIST '(MEXPT) K -1)))
  578.                  VAR
  579.                  Y))))
  580.  
  581. (DEFUN SUBST41 (EXP A B) (SUBST4 EXP)) 
  582.  
  583. (DEFUN CHEBYF (EXP VAR) 
  584.   (PROG (R1 R2 D1 D2 N1 N2 W Q) 
  585.     (COND ((NOT (SETQ W
  586.               (M2 EXP
  587.                   '((MTIMES)
  588.                 ((MEXPT) (VAR VARP) (R1 NUMBERP))
  589.                 ((MEXPT)
  590.                  ((MPLUS)
  591.                   ((MTIMES)
  592.                    ((COEFFTT) (C2 FREEVAR))
  593.                    ((MEXPT) (VAR VARP) (Q FREE1)))
  594.                   ((COEFFPP) (C1 FREEVAR)))
  595.                  (R2 NUMBERP))
  596.                 ((COEFFTT) (A FREEVAR)))
  597.                   NIL)))
  598.            (RETURN NIL)))
  599.     (SETQ Q (CDR (SASSQ 'Q W 'NILL)))
  600.     (SETQ 
  601.      W
  602.      (LIST*
  603.       (CONS 'A (DIV* (CDR (SASSQ 'A W 'NILL)) Q))
  604.       (CONS
  605.        'R1
  606.        (DIV* (ADDN (LIST 1 (NEG (SIMPLIFY Q)) (CDR (SASSQ 'R1 W 'NILL))) NIL) Q))
  607.       W))
  608.     (SETQ R1 (CDR (SASSQ 'R1 W 'NILL)) R2 (CDR (SASSQ 'R2 W 'NILL)))
  609.     (COND
  610.      ((NOT (AND (SETQ D1 (DENOMFIND R1))
  611.             (SETQ D2 (DENOMFIND R2))
  612.             (SETQ N1 (INTEGERP2 (TIMESK R1 D1)))
  613.             (SETQ N2 (INTEGERP2 (TIMESK R2 D2)))
  614.             (SETQ W (LIST* (CONS 'D1 D1) (CONS 'D2 D2)
  615.                    (CONS 'N1 N1) (CONS 'N2 N2)
  616.                    W))))
  617.       (RETURN NIL))
  618.      ((AND (INTEGERP2 R1) (GREATERP R1 0))
  619.       (RETURN
  620.        (SUBSTINT
  621.         (SUBLISS W '((MPLUS) C1 ((MTIMES) C2 ((MEXPT) VAR Q))))
  622.         VAR
  623.         (INTEGRATOR
  624.          (EXPANDS (LIST (SUBLISS W
  625.                      '((MTIMES)
  626.                        A
  627.                        ((MEXPT) VAR R2)
  628.                        ((MEXPT)
  629.                     C2
  630.                     ((MTIMES)
  631.                      -1
  632.                      ((MPLUS) R1 1))))))
  633.               (CDR (EXPANDEXPT (SUBLISS W
  634.                          '((MPLUS)
  635.                            VAR
  636.                            ((MTIMES) -1 C1)))
  637.                     R1)))
  638.          VAR))))
  639.      ((INTEGERP2 R2)
  640.       (RETURN
  641.        (SUBSTINT (SUBLISS W '((MEXPT) VAR ((MQUOTIENT) Q D1)))
  642.                VAR
  643.                (RATINT (SIMPLIFY (SUBLISS W
  644.                             '((MTIMES)
  645.                               D1 A
  646.                               ((MEXPT)
  647.                                VAR
  648.                                ((MPLUS)
  649.                             N1 D1 -1))
  650.                               ((MEXPT)
  651.                                ((MPLUS)
  652.                             ((MTIMES)
  653.                              C2
  654.                              ((MEXPT)
  655.                               VAR D1))
  656.                             C1)
  657.                                R2))))
  658.          VAR))))
  659.      ((AND (INTEGERP2 R1) (LESSP R1 0))
  660.       (RETURN
  661.        (SUBSTINT (SUBLISS W
  662.                 '((MEXPT)
  663.                   ((MPLUS)
  664.                    C1
  665.                    ((MTIMES) C2 ((MEXPT) VAR Q)))
  666.                   ((MQUOTIENT) 1 D2)))
  667.                VAR
  668.                (RATINT (SIMPLIFY (SUBLISS W
  669.                             '((MTIMES)
  670.                               A D2
  671.                               ((MEXPT)
  672.                                C2
  673.                                ((MTIMES)
  674.                             -1
  675.                             ((MPLUS)
  676.                              R1 1)))
  677.                               ((MEXPT)
  678.                                VAR
  679.                                ((MPLUS)
  680.                             N2 D2 -1))
  681.                               ((MEXPT)
  682.                                ((MPLUS)
  683.                             ((MEXPT)
  684.                              VAR D2)
  685.                             ((MTIMES) -1 C1))
  686.                                R1))))
  687.             VAR))))
  688.      ((INTEGERP2 (ADD2* R1 R2))
  689.       (RETURN
  690.        (SUBSTINT (SUBLISS W
  691.                 '((MEXPT)
  692.                   ((MQUOTIENT)
  693.                    ((MPLUS)
  694.                     C1
  695.                     ((MTIMES) C2 ((MEXPT) VAR Q)))
  696.                    ((MEXPT) VAR Q))
  697.                   ((MQUOTIENT) 1 D1)))
  698.                VAR
  699.                (RATINT (SIMPLIFY (SUBLISS W
  700.                             '((MTIMES)
  701.                               -1 A D1
  702.                               ((MEXPT)
  703.                                C1
  704.                                ((MPLUS)
  705.                             R1 R2 1))
  706.                               ((MEXPT)
  707.                                VAR
  708.                                ((MPLUS)
  709.                             N2 D1 -1))
  710.                               ((MEXPT)
  711.                                ((MPLUS)
  712.                             ((MEXPT)
  713.                              VAR D1)
  714.                             ((MTIMES)
  715.                              -1 C2))
  716.                                ((MTIMES)
  717.                             -1
  718.                             ((MPLUS)
  719.                              R1 R2
  720.                              2))))))
  721.             VAR))))
  722.      (T (RETURN (LIST '(%INTEGRATE) EXP VAR))))))
  723.  
  724. (DEFUN GREATERRATP (X1 X2) 
  725.        (COND ((AND (NUMBERP X1) (NUMBERP X2)) (GREATERP X1 X2))
  726.          ((RATNUMP X1)
  727.           (GREATERRATP (QUOTIENT (FLOAT (CADR X1)) (CADDR X1)) X2))
  728.          ((RATNUMP X2)
  729.           (GREATERRATP X1 (QUOTIENT (FLOAT (CADR X2)) (CADDR X2))))))
  730.  
  731. (DEFUN TRIG1 (X) (MEMQ (CAR X) '(%SIN %COS))) 
  732.  
  733. (DEFUN SUPERTRIG (EXP) 
  734.          (COND ((FREEVAR EXP) T)
  735.                ((ATOM EXP) NIL)
  736.                ((MEMQ (CAAR EXP) '(MPLUS MTIMES))
  737.             (AND (SUPERTRIG (CADR EXP))
  738.                  (OR (NULL (CDDR EXP))
  739.                  (SUPERTRIG (CONS (CAR EXP)
  740.                           (CDDR EXP))))))
  741.                ((EQ (CAAR EXP) 'MEXPT)
  742.             (AND (SUPERTRIG (CADR EXP))
  743.                  (SUPERTRIG (CADDR EXP))))
  744.                ((EQ (CAAR EXP) '%LOG)
  745.             (SUPERTRIG (CADR EXP)))
  746.                ((MEMQ (CAAR EXP)
  747.                   '(%SIN %COS %TAN %SEC %COT %CSC))
  748.             (COND ((M2 (CADR EXP) TRIGARG NIL) T)
  749.                   ((M2 (CADR EXP)
  750.                    '((MPLUS)
  751.                      ((COEFFPT) (B FREEVAR) (X VARP))
  752.                      ((COEFFPT) (A FREEVAR)))
  753.                    NIL)
  754.                    (AND (SETQ NOTSAME T) NIL))
  755.                   (T (SUPERTRIG (CADR EXP)))))
  756.                (T (SUPERTRIG (CADR EXP)))))
  757.      
  758. (DEFUN SUBST2S (EX PAT)
  759.   (COND ((NULL EX) NIL)
  760.     ((M2 EX PAT NIL) VAR)
  761.     ((ATOM EX) EX)
  762.     (T (CONS (SUBST2S (CAR EX) PAT) (SUBST2S (CDR EX) PAT)))))
  763.  
  764. (DEFUN MONSTERTRIG (EXP VAR TRIGARG)
  765.   (if (not (atom trigarg)) (return-from monstertrig (rischint exp var)))
  766.   (PROG (NOTSAME W A B Y D) 
  767.     (COND
  768.      ((SUPERTRIG EXP) (GO A))
  769.      ((NULL NOTSAME) (RETURN NIL))
  770.      ((NOT (SETQ Y (M2 EXP
  771.                '((MTIMES)
  772.                  ((COEFFTT) (A FREEVAR))
  773.                  (((B TRIG1))
  774.                   ((MTIMES)
  775.                    (X VARP)
  776.                    ((COEFFTT) (M FREEVAR))))
  777.                  (((D TRIG1))
  778.                   ((MTIMES)
  779.                    (X VARP)
  780.                    ((COEFFTT) (N FREEVAR)))))
  781.                NIL)))
  782.       (GO B))
  783.      ((NOT (AND (MEMQ (CAR (SETQ B
  784.                      (CDR (SASSQ 'B
  785.                          Y
  786.                          'NILL))))
  787.               '(%SIN %COS))
  788.             (MEMQ (CAR (SETQ D
  789.                      (CDR (SASSQ 'D
  790.                          Y
  791.                          'NILL))))
  792.               '(%SIN %COS))))
  793.       (RETURN NIL))
  794.      ((AND (EQ (CAR B) '%SIN) (EQ (CAR D) '%SIN))
  795.       (RETURN (SUBVAR (SUBLISS Y
  796.                    '((MTIMES)
  797.                      A
  798.                      ((MPLUS)
  799.                       ((MQUOTIENT)
  800.                        ((%SIN)
  801.                     ((MTIMES)
  802.                      ((MPLUS) M ((MTIMES) -1 N))
  803.                      X))
  804.                        ((MTIMES)
  805.                     2
  806.                     ((MPLUS) M ((MTIMES) -1 N))))
  807.                       ((MTIMES)
  808.                        -1
  809.                        ((MQUOTIENT)
  810.                     ((%SIN)
  811.                      ((MTIMES) ((MPLUS) M N) X))
  812.                     ((MTIMES)
  813.                      2
  814.                      ((MPLUS) M N))))))))))
  815.      ((AND (EQ (CAR B) '%COS) (EQ (CAR D) '%COS))
  816.       (RETURN (SUBVAR (SUBLISS Y
  817.                    '((MTIMES)
  818.                      A
  819.                      ((MPLUS)
  820.                       ((MQUOTIENT)
  821.                        ((%SIN)
  822.                     ((MTIMES)
  823.                      ((MPLUS) M ((MTIMES) -1 N))
  824.                      X))
  825.                        ((MTIMES)
  826.                     2
  827.                     ((MPLUS) M ((MTIMES) -1 N))))
  828.                       ((MQUOTIENT)
  829.                        ((%SIN)
  830.                     ((MTIMES) ((MPLUS) M N) X))
  831.                        ((MTIMES)
  832.                     2
  833.                     ((MPLUS) M N)))))))))
  834.      ((OR (AND (EQ (CAR B) '%COS)
  835.            (SETQ W (CDR (SASSQ 'M Y 'NILL)))
  836.            (RPLACD (SASSQ 'M Y 'NILL)
  837.                (CDR (SASSQ 'N Y 'NILL)))
  838.            (RPLACD (SASSQ 'N Y 'NILL) W))
  839.           T)
  840.       (RETURN (SUBVAR (SUBLISS Y
  841.                    '((MTIMES)
  842.                      -1
  843.                      A
  844.                      ((MPLUS)
  845.                       ((MQUOTIENT)
  846.                        ((%COS)
  847.                     ((MTIMES)
  848.                      ((MPLUS) M ((MTIMES) -1 N))
  849.                      X))
  850.                        ((MTIMES)
  851.                     2
  852.                     ((MPLUS) M ((MTIMES) -1 N))))
  853.                       ((MQUOTIENT)
  854.                        ((%COS)
  855.                     ((MTIMES) ((MPLUS) M N) X))
  856.                        ((MTIMES)
  857.                     2
  858.                     ((MPLUS) M N))))))))))
  859.    B    (COND ((NOT (SETQ Y (PROG2 (SETQ TRIGARG VAR)
  860.                    (M2 EXP
  861.                        '((MTIMES)
  862.                      ((COEFFTT) (A FREEVAR))
  863.                      (((B TRIG1))
  864.                       ((MTIMES)
  865.                        (X VARP)
  866.                        ((COEFFTT) (N INTEGERP2))))
  867.                      ((COEFFTT) (C SUPERTRIG)))
  868.                        NIL))))
  869.            (RETURN NIL)))
  870.     (RETURN
  871.      (INTEGRATOR
  872.       ($EXPAND
  873.        (LIST '(MTIMES)
  874.          (SCH-REPLACE Y 'A)
  875.          (SCH-REPLACE Y 'C)
  876.          (COND ((EQ (CAR (SETQ B (SCH-REPLACE Y 'B))) '%COS)
  877.             (MAXIMA-SUBSTITUTE VAR
  878.                     'X
  879.                     (SUPERCOSNX (SCH-REPLACE Y 'N))))
  880.                (T (MAXIMA-SUBSTITUTE VAR
  881.                       'X
  882.                       (SUPERSINX (SCH-REPLACE Y 'N)))))))
  883.       VAR))
  884.    A    (SETQ W (SUBST2S EXP TRIGARG))
  885.     (SETQ B (CDR (SASSQ 'B
  886.                 (M2 TRIGARG
  887.                 '((MPLUS)
  888.                   ((COEFFPT) (B FREEVAR) (X VARP))
  889.                   ((COEFFPT) (A FREEVAR)))
  890.                 NIL)
  891.                 'NILL)))
  892.     (SETQ A (SUBSTINT TRIGARG
  893.                 VAR
  894.                 (TRIGINT (DIV* W B) VAR)))
  895.    (COND((M2 A '((MTIMES)((COEFFTT)(D FREEVAR))
  896.          ((%INTEGRATE ) (B TRUE) (C TRUE)))NIL) 
  897.      (RETURN(LIST '(%INTEGRATE) EXP VAR))))
  898.    (RETURN A)))
  899.  
  900. (DEFUN TRIG2 (X) (MEMQ (CAR X) '(%SIN %COS %TAN %COT %SEC %CSC)))
  901.  
  902. (DEFUN SUPERSINX (N) ((LAMBDA (I) 
  903.                   ($EXPAND (LIST '(MTIMES)
  904.                           I
  905.                           (SINNX (TIMESK I N)))))
  906.               (COND ((LESSP N 0) -1) (T 1))))
  907.      
  908.  
  909. (DEFUN SUPERCOSNX (N) ((LAMBDA (I) ($EXPAND (COSNX (TIMESK I N))))
  910.               (COND ((LESSP N 0) -1) (T 1))))
  911.      
  912.  
  913. (DEFUN SINNX (N) (COND ((EQUAL N 1) '((%SIN) X))
  914.                (T (LIST '(MPLUS)
  915.                     (LIST '(MTIMES)
  916.                       '((%SIN) X)
  917.                       (COSNX (SUB1 N)))
  918.                     (LIST '(MTIMES)
  919.                       '((%COS) X)
  920.                       (SINNX (SUB1 N)))))))
  921.      
  922.  
  923. (DEFUN COSNX (N) (COND ((EQUAL N 1) '((%COS) X))
  924.                (T (LIST '(MPLUS)
  925.                     (LIST '(MTIMES)
  926.                       '((%COS) X)
  927.                       (COSNX (SUB1 N)))
  928.                     (LIST '(MTIMES)
  929.                       -1
  930.                       '((%SIN) X)
  931.                       (SINNX (SUB1 N)))))))
  932.      
  933.  
  934. (DEFUN POSEVEN (X) (AND (EVEN X) (GREATERP X -1))) 
  935.  
  936. (DEFUN TRIGFREE (X) 
  937.      (COND ((ATOM X) (NOT (MEMQ X '(SIN* COS* SEC* TAN*))))
  938.            (T (AND (TRIGFREE (CAR X)) (TRIGFREE (CDR X))))))
  939.  
  940. (DEFUN RAT1 (EXP) (PROG (B1 NOTSAME) 
  941.                  (COND ((AND (NUMBERP EXP) (ZEROP EXP))
  942.                     (RETURN NIL)))
  943.                  (SETQ B1 (SUBST B 'B '((MEXPT) B (N EVEN))))
  944.                  (RETURN (PROG2 (SETQ YY (RATS EXP))
  945.                         (COND ((NOT NOTSAME) YY))))))
  946.  
  947. (DEFUN RATS (EXP) 
  948.   (PROG (Y) 
  949.     (RETURN
  950.      (COND ((EQ EXP A) 'X)
  951.            ((ATOM EXP)
  952.         (COND ((MEMQ EXP '(SIN* COS* SEC* TAN*))
  953.                (SETQ NOTSAME T))
  954.               (T EXP)))
  955.            ((SETQ Y (M2 EXP B1 NIL)) (F3 Y))
  956.            (T (CONS (CAR EXP)
  957.             (MAPCAR 
  958.              (FUNCTION (LAMBDA (G) (RATS G)))
  959.              (CDR EXP))))))))
  960.  
  961.  
  962. (DEFUN F3 (Y) 
  963.      (MAXIMA-SUBSTITUTE C
  964.              'C
  965.              (MAXIMA-SUBSTITUTE (QUOTIENT (CDR (SASSQ 'N Y NIL)) 2)
  966.                  'N
  967.                  '((MEXPT)
  968.                    ((MPLUS)
  969.                     1
  970.                     ((MTIMES)
  971.                      C
  972.                      ((MEXPT) X 2)))
  973.                    N))))
  974.  
  975. (DEFUN ODD1 (N) 
  976.      (COND ((NOT (NUMBERP N)) NIL)
  977.            ((NOT (EQUAL (REMAINDER N 2) 0))
  978.         (SETQ YZ
  979.               (MAXIMA-SUBSTITUTE C
  980.                   'C
  981.                   (LIST '(MEXPT)
  982.                     '((MPLUS)
  983.                       1
  984.                       ((MTIMES)
  985.                        C
  986.                        ((MEXPT) X 2)))
  987.                     (QUOTIENT (SUB1 N) 2)))))
  988.            (T NIL)))
  989.  
  990. (DEFUN SUBVAR (X) (MAXIMA-SUBSTITUTE VAR 'X X)) 
  991.  
  992. (DEFUN SUBVARDLG (X) 
  993.        (MAPCAR #'(LAMBDA (M) (CONS (MAXIMA-SUBSTITUTE VAR 'X (CAR M))
  994.                    (CDR M)))
  995.            X))
  996.  
  997. (DEFUN TRIGINT (EXP VAR) 
  998.   (PROG (Y REPL Y1 Y2 YY Z M N C YZ A B ) 
  999.     (SETQ Y2
  1000.           (SUBLISS (SUBVARDLG '((((%SIN) X) . SIN*)
  1001.                     (((%COS) X) . COS*)
  1002.                     (((%TAN) X) . TAN*)
  1003.                     (((%COT) X) (MEXPT) TAN* -1)
  1004.                     (((%SEC) X) . SEC*)
  1005.                     (((%CSC) X) (MEXPT) SIN* -1)))
  1006.                (SIMPLIFYA EXP NIL)))
  1007.     (SETQ Y1 (SETQ Y (SIMPLIFY (SUBLISS '((TAN* (MTIMES)
  1008.                         SIN*
  1009.                         ((MEXPT) COS* -1))
  1010.                       (SEC* (MEXPT) COS* -1))
  1011.                     Y2))))
  1012.     (COND ((NULL (SETQ Z (M2 Y
  1013.                  '((MTIMES)
  1014.                    ((COEFFTT) (B TRIGFREE))
  1015.                    ((MEXPT) SIN* (M POSEVEN))
  1016.                    ((MEXPT) COS* (N POSEVEN)))
  1017.                  NIL)))
  1018.            (GO L1)))
  1019.     (SETQ M (CDR (SASSQ 'M Z 'NILL)))
  1020.     (SETQ N (CDR (SASSQ 'N Z 'NILL)))
  1021.     (SETQ A (INTEGERP2 (TIMES 0.5
  1022.                  (COND ((LESSP M N) 1) (T -1))
  1023.                  (PLUS N (TIMES -1 M)))))
  1024.     (SETQ Z (CONS (CONS 'A A) Z))
  1025.     (RETURN
  1026.      (SIMPLIFY
  1027.       (LIST
  1028.        '(MTIMES)
  1029.        (CDR (SASSQ 'B Z 'NILL))
  1030.        '((RAT SIMP) 1 2)
  1031.        (SUBSTINT
  1032.         (LIST '(MTIMES) 2 VAR)
  1033.         'X
  1034.         (INTEGRATOR (SIMPLIFY (COND ((LESSP M N)
  1035.                      (SUBLISS Z
  1036.                           '((MTIMES)
  1037.                         ((MEXPT)
  1038.                          ((MTIMES)
  1039.                           ((RAT SIMP) 1 2)
  1040.                           ((%SIN) X))
  1041.                          M)
  1042.                         ((MEXPT)
  1043.                          ((MPLUS)
  1044.                           ((RAT SIMP) 1 2)
  1045.                           ((MTIMES)
  1046.                            ((RAT SIMP) 1 2)
  1047.                            ((%COS) X)))
  1048.                          A))))
  1049.                     (T (SUBLISS Z
  1050.                         '((MTIMES)
  1051.                           ((MEXPT)
  1052.                            ((MTIMES)
  1053.                             ((RAT SIMP) 1 2)
  1054.                             ((%SIN) X))
  1055.                            N)
  1056.                           ((MEXPT)
  1057.                            ((MPLUS)
  1058.                             ((RAT SIMP) 1 2)
  1059.                             ((MTIMES)
  1060.                              ((RAT SIMP)
  1061.                               -1
  1062.                               2)
  1063.                              ((%COS) X)))
  1064.                            A))))))
  1065.             'X)))))
  1066.    L1   (SETQ C -1)
  1067.     (SETQ A 'SIN*)
  1068.     (SETQ B 'COS*)
  1069.     (COND ((AND (M2 Y
  1070.             '((COEFFPT) (C RAT1) ((MEXPT) COS* (N ODD1)))
  1071.             NIL)
  1072.             (SETQ REPL (LIST '(%SIN) VAR)))
  1073.            (GO GETOUT)))
  1074.     (SETQ A B)
  1075.     (SETQ B 'SIN*)
  1076.     (COND ((AND (M2 Y
  1077.             '((COEFFPT) (C RAT1) ((MEXPT) SIN* (N ODD1)))
  1078.             NIL)
  1079.             (SETQ REPL (LIST '(%COS) VAR)))
  1080.            (GO GET3)))
  1081.     (SETQ Y
  1082.           (SIMPLIFY (SUBLISS '((SIN* (MTIMES) TAN* ((MEXPT) SEC* -1))
  1083.                    (COS* (MEXPT) SEC* -1))
  1084.                  Y2)))
  1085.     (SETQ C 1)
  1086.     (SETQ A 'TAN*)
  1087.     (SETQ B 'SEC*)
  1088.     (COND ((AND (RAT1 Y) (SETQ REPL (LIST '(%TAN) VAR)))
  1089.            (GO GET1)))
  1090.     (SETQ A B)
  1091.     (SETQ B 'TAN*)
  1092.     (COND ((AND (M2 Y
  1093.             '((COEFFPT) (C RAT1) ((MEXPT) TAN* (N ODD1)))
  1094.             NIL)
  1095.             (SETQ REPL (LIST '(%SEC) VAR)))
  1096.            (GO GETOUT)))
  1097.  (COND((NOT (ALIKE1(SETQ REPL ($EXPAND EXP))EXP))(RETURN(INTEGRATOR REPL VAR))))
  1098.     (SETQ Y
  1099.           (SIMPLIFY (SUBLISS '((SIN* (MTIMES)
  1100.                      2
  1101.                      X
  1102.                      ((MEXPT)
  1103.                       ((MPLUS) 1 ((MEXPT) X 2))
  1104.                       -1))
  1105.                    (COS* (MTIMES)
  1106.                      ((MPLUS)
  1107.                       1
  1108.                       ((MTIMES) -1 ((MEXPT) X 2)))
  1109.                      ((MEXPT)
  1110.                       ((MPLUS) 1 ((MEXPT) X 2))
  1111.                       -1)))
  1112.                  Y1)))
  1113.     (SETQ Y (LIST '(MTIMES)
  1114.               Y
  1115.               '((MTIMES)
  1116.             2
  1117.             ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))))
  1118.     (SETQ REPL (SUBVAR '((MQUOTIENT)
  1119.                  ((%SIN) X)
  1120.                  ((MPLUS) 1 ((%COS) X)))))
  1121.     (GO GET2)
  1122.    GET3 (SETQ Y (LIST '(MTIMES) -1 YY YZ))
  1123.     (GO GET2)
  1124.    GET1 (SETQ Y (LIST '(MTIMES)
  1125.               '((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)
  1126.               YY))
  1127.     (GO GET2)
  1128.    GETOUT
  1129.     (SETQ Y (LIST '(MTIMES) YY YZ))
  1130.    GET2 (SETQ Y (SIMPLIFY Y))
  1131.     (RETURN (SUBSTINT REPL 'X (INTEGRATOR Y 'X)))))
  1132.  
  1133. (DEFMFUN SININT (EXP VAR)
  1134.  (FIND-FUNCTION 'RATINT)  ; Make sure that RATINT is in core.
  1135.  (COND ((MNUMP VAR) (MERROR "Attempt to integrate wrt a number: ~:M" VAR))
  1136.        (($RATP VAR) (SININT EXP (RATDISREP VAR)))
  1137.        (($RATP EXP) (SININT (RATDISREP EXP) VAR))
  1138.        ((MXORLISTP EXP)
  1139.     (CONS (CAR EXP) (MAPCAR #'(LAMBDA (Y) (SININT Y VAR)) (CDR EXP))))
  1140.        ((MEQUALP EXP)
  1141.     (LIST (CAR EXP) (SININT (CADR EXP) VAR)
  1142.             (ADD2 (SININT (CADDR EXP) VAR)
  1143.                   (CONCAT '$INTEGRATIONCONSTANT
  1144.                       (SETQ $INTEGRATION_CONSTANT_COUNTER 
  1145.                         (f1+ $INTEGRATION_CONSTANT_COUNTER))))))
  1146.        ((AND (ATOM VAR) (ISINOP EXP VAR)) (LIST '(%INTEGRATE) EXP VAR))
  1147.        ((LET
  1148.      ((ANS (SIMPLIFY
  1149.         (LET ($OPSUBST VARLIST GENVAR STACK) (INTEGRATOR EXP VAR)))))
  1150.      (IF (SUM-OF-INTSP ANS) (LIST '(%INTEGRATE) EXP VAR) ANS)))))
  1151.  
  1152. (DEFUN SUM-OF-INTSP (ANS)
  1153.        (COND ((ATOM ANS) (NOT (EQ ANS VAR)))
  1154.          ((MPLUSP ANS) (ANDMAPC #'SUM-OF-INTSP (CDR ANS)))
  1155.          ((EQ (CAAR ANS) '%INTEGRATE) T)
  1156.          ((MTIMESP ANS)
  1157.           (DO ((FACS (CDR ANS) (CDR FACS))
  1158.            (INTS))
  1159.           ((NULL FACS) (< (LENGTH INTS) 2))
  1160.           (UNLESS (FREEOF VAR (CAR FACS))
  1161.               (IF (SUM-OF-INTSP (CAR FACS)) (PUSH (CAR FACS) INTS)
  1162.                   (RETURN NIL)))))
  1163.          ((FREEOF VAR ANS) T)
  1164.          (T NIL)))
  1165.  
  1166. (DEFUN INTSUM (FORM VAR)
  1167.  (PROG (EXP IDX LL UL PAIR VAL)
  1168.        (SETQ EXP (CADR FORM) IDX (CADDR FORM)
  1169.          LL (CADDDR FORM) UL (CAR (CDDDDR FORM)))
  1170.        (IF (OR (NOT (ATOM VAR)) (NOT (FREE IDX VAR))
  1171.            (NOT (FREE LL VAR)) (NOT (FREE UL VAR)))
  1172.        (RETURN (LIST '(%INTEGRATE) FORM VAR)))
  1173.        (SETQ PAIR (PARTITION EXP VAR 1))
  1174.        (WHEN (AND (MEXPTP (CDR PAIR)) (EQ (CADDR PAIR) VAR))
  1175.          (SETQ VAL (MAXIMA-SUBSTITUTE LL IDX (CADDDR PAIR)))
  1176.          (COND ((EQUAL VAL -1)
  1177.             (RETURN (ADD2 (INTEGRATOR (MAXIMA-SUBSTITUTE LL IDX EXP) VAR)
  1178.                   (INTSUM1 EXP IDX (ADD2 1 LL) UL VAR))))
  1179.            ((MLSP VAL -1)
  1180.             (RETURN (LIST '(%INTEGRATE) FORM VAR)))))
  1181.        (RETURN (INTSUM1 EXP IDX LL UL VAR))))
  1182.  
  1183. (DEFUN INTSUM1 (EXP IDX LL UL VAR)
  1184.  (ASSUME (LIST '(MGEQP) IDX LL))
  1185.  (IF (NOT (EQ UL '$INF)) (ASSUME (LIST '(MGEQP) UL IDX)))
  1186.  (SIMPLIFYA (LIST '(%SUM) (INTEGRATOR EXP VAR) IDX LL UL) T))
  1187.  
  1188. (DEFUN RAT8PRIME (C) (AND (RAT8 C) (OR (NOT (MNUMP C)) (NOT (ZEROP1 C)))))
  1189.  
  1190. (DEFUN FINDS (X) 
  1191.  (IF (ATOM X) (MEMQ X '(%LOG %INTEGRATE %ATAN))
  1192.           (OR (FINDS (CAR X)) (FINDS (CDR X)))))
  1193.  
  1194. (DEFUN RATLOG (EXP VAR FORM) 
  1195.   (PROG (A B C D Y Z W) 
  1196.     (SETQ Y FORM)
  1197.     (SETQ B (CDR (SASSQ 'B Y 'NILL)))
  1198.     (SETQ C (CDR (SASSQ 'C Y 'NILL)))
  1199.     (SETQ Y (INTEGRATOR C VAR))
  1200.     (COND ((FINDS Y) (RETURN NIL)))
  1201.     (SETQ D (SDIFF (CDR (SASSQ 'A FORM 'NILL))
  1202.                VAR))
  1203.  
  1204.         (SETQ Z (INTEGRATOR (MUL2* Y D) VAR))
  1205.         (SETQ D (CDR (SASSQ 'A FORM 'NILL)))
  1206.     (RETURN (SIMPLIFY (LIST '(MPLUS)
  1207.                 (LIST '(MTIMES) Y D)
  1208.                 (LIST '(MTIMES) -1 Z))))))
  1209.  
  1210. (DEFUN FIND1 (Y A) 
  1211.      (COND ((EQ Y A) T)
  1212.            ((ATOM Y) NIL)
  1213.            (T (OR (FIND1 (CAR Y) A) (FIND1 (CDR Y) A)))))
  1214.  
  1215. (DEFUN MATCHSUM (ALIST BLIST) 
  1216.   (PROG (R S C D) 
  1217.     (SETQ S (M2 (CAR ALIST)
  1218.             '((MTIMES)
  1219.               ((COEFFTT) (A FREEVAR))
  1220.               ((COEFFTT) (C TRUE)))
  1221.             NIL))
  1222.     (SETQ C (CDR (SASSQ 'C S 'NILL)))
  1223.     (COND ((NOT (SETQ R
  1224.               (M2 (CONS '(MPLUS) BLIST)
  1225.                   (LIST '(MPLUS)
  1226.                     (CONS '(MTIMES)
  1227.                       (CONS '((COEFFTT) (B FREE1))
  1228.                         (COND ((MTIMESP C)
  1229.                                (CDR C))
  1230.                               (T (LIST C)))))
  1231.                     '(D TRUE))
  1232.                   NIL)))
  1233.            (RETURN NIL)))
  1234.     (SETQ D (SIMPLIFY (LIST '(MTIMES)
  1235.                 (SUBLISS S 'A)
  1236.                 (LIST '(MEXPT)
  1237.                   (SUBLISS R 'B)
  1238.                   -1))))
  1239.     (COND ((M2 (CONS '(MPLUS) ALIST)
  1240.            (TIMESLOOP D BLIST)
  1241.            NIL)
  1242.            (RETURN D))
  1243.           (T (RETURN NIL)))))
  1244.  
  1245. (DEFUN TIMESLOOP (A B)
  1246.  (CONS '(MPLUS) (MAPCAR (FUNCTION (LAMBDA (C) (MUL2* A C))) B)))   
  1247.  
  1248. (DEFUN SIMPLOG (A) (SIMPLIFYA (CONS '(%LOG) A) NIL))
  1249.  
  1250. (DEFUN EXPANDS (AA B) 
  1251.  (ADDN (MAPCAR (FUNCTION (LAMBDA (C) (TIMESLOOP C AA))) B) NIL))
  1252.  
  1253. (DEFUN POWERLIST (EXP VAR) 
  1254.   (PROG (Y Z C D POWERLIST B) 
  1255.     (SETQ Y (M2 EXP
  1256.             '((MTIMES)
  1257.               ((MEXPT) (VAR VARP) (C INTEGERP2))
  1258.               ((COEFFTT) (A FREEVAR))
  1259.               ((COEFFTT) (B TRUE)))
  1260.             NIL))
  1261.     (SETQ B (CDR (SASSQ 'B Y 'NILL)))
  1262.     (SETQ C (CDR (SASSQ 'C Y 'NILL)))
  1263.     (COND ((NOT (SETQ Z (RAT10 B))) (RETURN NIL)))
  1264.     (SETQ D (LISTGCD (CONS (ADD1 C) POWERLIST)))
  1265.     (COND ((OR (NULL D) (ZEROP D)) (RETURN NIL)))
  1266.     (RETURN
  1267.      (SUBSTINT
  1268.       (LIST '(MEXPT) VAR D)
  1269.       VAR
  1270.       (INTEGRATE5 (SIMPLIFY (LIST '(MTIMES)
  1271.                   (POWER* D -1)
  1272.                   (CDR (SASSQ 'A
  1273.                           Y
  1274.                           'NILL))
  1275.                   (LIST '(MEXPT)
  1276.                     VAR
  1277.                     (SUB1 (QUOTIENT (ADD1 C) D)))
  1278.                   (SUBST10 B)))
  1279.               VAR)))))
  1280.  
  1281. (DEFUN DIFFDIV (EXP VAR) 
  1282.   (PROG (Y A X V D Z W R) 
  1283.     (COND
  1284.      ((AND (MEXPTP EXP)
  1285.            (MPLUSP (CADR EXP))
  1286.            (INTEGERP2 (CADDR EXP))
  1287.            (LESSP (CADDR EXP) 6)
  1288.            (GREATERP (CADDR EXP) 0))
  1289.       (RETURN (INTEGRATOR (EXPANDEXPT (CADR EXP) (CADDR EXP)) VAR))))
  1290.     (SETQ EXP (COND ((MTIMESP EXP) EXP) (T (LIST '(MTIMES) EXP))))
  1291.     (SETQ Z (CDR EXP))
  1292.    A    (SETQ Y (CAR Z))
  1293.     (SETQ R (LIST '(MPLUS)
  1294.               (CONS '(COEFFPT)
  1295.                 (CONS '(C FREE1)
  1296.                   (CHOICESIN Y (CDR EXP))))))
  1297.     (COND
  1298.      ((SETQ W (M2 (SDIFF Y VAR) R NIL))
  1299.       (RETURN (MULN (LIST Y Y (POWER* (MUL2* 2 (CDR (SASSQ 'C W 'NILL))) -1)) NIL))))
  1300.     (SETQ W (COND ((OR (ATOM Y) (MEMQ (CAAR Y) '(MPLUS MTIMES))) Y)
  1301.               ((EQ (CAAR Y) 'MEXPT)
  1302.                (COND ((FREEVAR (CADR Y)) (CADDR Y))
  1303.                  ((FREEVAR (CADDR Y)) (CADR Y))
  1304.                  (T 0)))
  1305.               (T (CADR Y))))
  1306.     (COND
  1307.      ((SETQ W (COND ((AND (SETQ X (SDIFF W VAR))
  1308.                   (MPLUSP X)
  1309.                   (SETQ D (CHOICESIN Y (CDR EXP)))
  1310.                   (SETQ V (CAR D))
  1311.                   (MPLUSP V)
  1312.                   (NOT (CDR D)))
  1313.              (COND ((SETQ D (MATCHSUM (CDR X) (CDR V)))
  1314.                 (LIST (CONS 'C D)))
  1315.                    (T NIL)))
  1316.             (T (M2 X R NIL))))
  1317.       (RETURN (COND ((NULL (SETQ X (INTEGRALLOOKUPS Y))) NIL)
  1318.             ((EQ W T) X)
  1319.             (T (MUL2* X (POWER* (CDR (SASSQ 'C W 'NILL)) -1)))))))
  1320.     (SETQ Z (CDR Z))
  1321.     (COND ((NULL Z) (RETURN NIL)))
  1322.     (GO A)))
  1323.  
  1324. (DEFUN SUBLISS (A B) 
  1325.        (PROG (X Y Z) 
  1326.          (SETQ X B)
  1327.          (SETQ Z A)
  1328.     LOOP (COND ((NULL Z) (RETURN X)))
  1329.          (SETQ Y (CAR Z))
  1330.          (SETQ X (MAXIMA-SUBSTITUTE (CDR Y) (CAR Y) X))
  1331.          (SETQ Z (CDR Z))
  1332.          (GO LOOP)))
  1333.  
  1334. (DEFUN SUBSTINT (X Y EXPRES)
  1335.        (COND ((AND (NOT (ATOM EXPRES)) (EQ (CAAR EXPRES) '%INTEGRATE))
  1336.           (LIST (CAR EXPRES) EXP VAR))
  1337.          (T (SUBSTINT1 (MAXIMA-SUBSTITUTE X Y EXPRES)))))
  1338.  
  1339. (DEFUN SUBSTINT1 (EXP)
  1340.        (COND ((ATOM EXP) EXP)
  1341.          ((AND (EQ (CAAR EXP) '%INTEGRATE) (NULL (CDDDR EXP))
  1342.            (NOT (SYMBOLP (CADDR EXP))) (NOT (FREE (CADDR EXP) VAR)))
  1343.           (SIMPLIFY (LIST '(%INTEGRATE) (MUL2 (CADR EXP) (SDIFF (CADDR EXP) VAR))
  1344.                    VAR)))
  1345.          (T (RECUR-APPLY #'SUBSTINT1 EXP))))
  1346.