mirror of
https://github.com/PDP-10/its.git
synced 2026-04-17 16:53:08 +00:00
bf8f96b837
Also updates a bunch of Macsyma sources to latest versions, which was needed to get declare working with consistent sources. Resolves #960.
378 lines
16 KiB
Common Lisp
378 lines
16 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module trigo)
|
||
|
||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||
|
||
(DECLARE (GENPREFIX TRI)
|
||
(SPECIAL VARLIST ERRORSW)
|
||
(FLONUM (TAN) (COT) (SEC) (CSC)
|
||
(ATAN2) (ATAN1) (ACOT)
|
||
(SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
|
||
(ASINH) (ACSCH)
|
||
(T//$ FLONUM FLONUM NOTYPE))
|
||
(*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR
|
||
TIMESK ADDK INTEGERP EVOD LOGARC MEVENP HALFANGLE COEFF))
|
||
|
||
(DECLARE (SPLITFILE HYPER))
|
||
|
||
(DEFMFUN SIMP-%SINH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SINH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (ZEROP1 Y) 0)))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SIN (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASINH (CAAR Y)) (CADR Y))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%SINH Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%SINH Y))
|
||
((AND $HALFANGLES (HALFANGLE '%SINH Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SINH (NEG Y))))
|
||
(T (EQTEST (LIST '(%SINH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%COSH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COSH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (ZEROP1 Y) 1)))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COS (COEFF Y '$%I 1)))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOSH (CAAR Y)) (CADR Y))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%COSH Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%COSH Y))
|
||
((AND $HALFANGLES (HALFANGLE '%COSH Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COSH (NEG Y)))
|
||
(T (EQTEST (LIST '(%COSH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%TANH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TANH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (ZEROP1 Y) 0)))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TAN (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ATANH (SETQ Z (CAAR Y))) (CADR Y))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%TANH Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%TANH Y))
|
||
((AND $HALFANGLES (HALFANGLE '%TANH Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TANH (NEG Y))))
|
||
(T (EQTEST (LIST '(%TANH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%COTH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COTH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'COTH))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOTH (CAAR Y)) (CADR Y))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%COTH Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%COTH Y))
|
||
((AND $HALFANGLES (HALFANGLE '%COTH Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COTH (NEG Y))))
|
||
(T (EQTEST (LIST '(%COTH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%CSCH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSCH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSCH)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSC (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACSCH (CAAR Y)) (CADR Y))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%CSCH Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%CSCH Y))
|
||
((AND $HALFANGLES (HALFANGLE '%CSCH Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSCH (NEG Y))))
|
||
(T (EQTEST (LIST '(%CSCH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%SECH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SECH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (ZEROP1 Y)) 1)
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SEC (COEFF Y '$%I 1)))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASECH (CAAR Y)) (CADR Y))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%SECH Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%SECH Y))
|
||
((AND $HALFANGLES (HALFANGLE '%SECH Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SECH (NEG Y)))
|
||
(T (EQTEST (LIST '(%SECH) Y) FORM))))
|
||
|
||
(DECLARE (SPLITFILE ATRIG))
|
||
|
||
(DEFMFUN SIMP-%ASIN (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASIN Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS
|
||
(COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2))
|
||
((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 6) '$%PI)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASINH (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) (IF (EQ '%SIN (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ASIN Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASIN (NEG Y))))
|
||
(T (EQTEST (LIST '(%ASIN) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ACOS (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOS Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS
|
||
(COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI)
|
||
((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 3) '$%PI)))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%COS (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ACOS Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ACOS (NEG Y))))
|
||
(T (EQTEST (LIST '(%ACOS) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ACOT (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOT Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS
|
||
(COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOTH (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%COT (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ACOT Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOT (NEG Y))))
|
||
(T (EQTEST (LIST '(%ACOT) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ACSC (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSC Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS
|
||
(COND ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSCH (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%CSC (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ACSC Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSC (NEG Y))))
|
||
(T (EQTEST (LIST '(%ACSC) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ASEC (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASEC Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS
|
||
(COND ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%SEC (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ASEC Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ASEC (NEG Y))))
|
||
(T (EQTEST (LIST '(%ASEC) Y) FORM))))
|
||
|
||
(DECLARE (SPLITFILE AHYPER))
|
||
|
||
(DEFMFUN SIMP-%ASINH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASINH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (ZEROP1 Y) Y)))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASIN (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%SINH (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ASINH Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASINH (NEG Y))))
|
||
(T (EQTEST (LIST '(%ASINH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ACOSH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOSH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (EQUAL Y 1) 0)))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%COSH (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ACOSH Y))
|
||
(T (EQTEST (LIST '(%ACOSH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ATANH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATANH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) 0)
|
||
((OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ATANH)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ATAN (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%TANH (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ATANH Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATANH (NEG Y))))
|
||
(T (EQTEST (LIST '(%ATANH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ACOTH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOTH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ACOTH))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOT (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%COTH (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ACOTH Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOTH (NEG Y))))
|
||
(T (EQTEST (LIST '(%ACOTH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ACSCH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSCH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'ACSCH))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSC (COEFF Y '$%I 1))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%CSCH (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ACSCH Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSCH (NEG Y))))
|
||
(T (EQTEST (LIST '(%ACSCH) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%ASECH (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASECH Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((EQUAL Y 1) 0)
|
||
((ZEROP1 Y) (DBZ-ERR1 'ASECH)))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%SECH (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ASECH Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%ASECH (NEG Y)))
|
||
(T (EQTEST (LIST '(%ASECH) Y) FORM))))
|
||
|
||
(DECLARE (SPLITFILE TRIGEX) (SPECIAL $TRIGEXPANDPLUS $TRIGEXPANDTIMES))
|
||
|
||
(DEFMFUN $TRIGEXPAND (E)
|
||
(COND ((ATOM E) E)
|
||
((SPECREPP E) ($TRIGEXPAND (SPECDISREP E)))
|
||
((TRIGEXPAND (CAAR E) (CADR E)))
|
||
(T (RECUR-APPLY #'$TRIGEXPAND E))))
|
||
|
||
(DEFMFUN TRIGEXPAND (OP ARG)
|
||
(COND ((ATOM ARG) NIL)
|
||
((AND $TRIGEXPANDPLUS (EQ 'MPLUS (CAAR ARG)))
|
||
(COND ((EQ '%SIN OP) (SIN\COS-PLUS (CDR ARG) 1 '%SIN '%COS -1))
|
||
((EQ '%COS OP) (SIN\COS-PLUS (CDR ARG) 0 '%SIN '%COS -1))
|
||
((EQ '%TAN OP) (TAN-PLUS (CDR ARG) '%TAN -1))
|
||
((EQ '%COT OP) (COT-PLUS (CDR ARG) '%COT -1))
|
||
((EQ '%CSC OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSC '%SEC -1))
|
||
((EQ '%SEC OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSC '%SEC -1))
|
||
((EQ '%SINH OP) (SIN\COS-PLUS (CDR ARG) 1 '%SINH '%COSH 1))
|
||
((EQ '%COSH OP) (SIN\COS-PLUS (CDR ARG) 0 '%SINH '%COSH 1))
|
||
((EQ '%TANH OP) (TAN-PLUS (CDR ARG) '%TANH 1))
|
||
((EQ '%COTH OP) (COT-PLUS (CDR ARG) '%COTH 1))
|
||
((EQ '%CSCH OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSCH '%SECH 1))
|
||
((EQ '%SECH OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSCH '%SECH 1))))
|
||
((AND $TRIGEXPANDTIMES (EQ 'MTIMES (CAAR ARG)) (EQ (TYPEP (CADR ARG)) 'FIXNUM))
|
||
(COND ((EQ '%SIN OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SIN '%COS -1))
|
||
((EQ '%COS OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SIN '%COS -1))
|
||
((EQ '%TAN OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TAN -1))
|
||
((EQ '%COT OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COT -1))
|
||
((EQ '%CSC OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSC '%SEC -1))
|
||
((EQ '%SEC OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSC '%SEC -1))
|
||
((EQ '%SINH OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SINH '%COSH 1))
|
||
((EQ '%COSH OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SINH '%COSH 1))
|
||
((EQ '%TANH OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TANH 1))
|
||
((EQ '%COTH OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COTH 1))
|
||
((EQ '%CSCH OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSCH '%SECH 1))
|
||
((EQ '%SECH OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSCH '%SECH 1))))))
|
||
|
||
|
||
(DEFUN SIN\COS-PLUS (L N F1 F2 FLAG)
|
||
(DO ((I N (+ 2 I)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (RESULT))
|
||
((> I LEN) (SIMPLIFY (CONS '(MPLUS) RESULT)))
|
||
(SETQ RESULT (MPC (COND ((MINUSP SIGN) '(-1 (MTIMES))) (T '((MTIMES)))) L RESULT F1 F2 LEN I))))
|
||
|
||
(DEFUN TAN-PLUS (L F FLAG)
|
||
(DO ((I 1 (+ 2 I)) (SIGN 1 (* FLAG SIGN)) (LEN (LENGTH L)) (NUM) (DEN (LIST 1)))
|
||
((> I LEN) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||
(SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
|
||
DEN (COND ((= LEN I) DEN)
|
||
(T (MPC1 (LIST (* FLAG SIGN) '(MTIMES)) L DEN F LEN (1+ I)))))))
|
||
|
||
(DEFUN COT-PLUS (L F FLAG)
|
||
(DO ((I (LENGTH L) (- I 2)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (NUM) (DEN))
|
||
((< I 0) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||
(SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
|
||
DEN (COND ((= 0 I) DEN)
|
||
(T (MPC1 (LIST SIGN '(MTIMES)) L DEN F LEN (1- I)))))))
|
||
|
||
(DEFUN CSC\SEC-PLUS (L N F1 F2 FLAG)
|
||
(DIV* (DO ((L L (CDR L)) (RESULT)) ((NULL L) (CONS '(MTIMES) RESULT))
|
||
(SETQ RESULT (CONS (CONS-EXP F1 (CAR L)) (CONS (CONS-EXP F2 (CAR L)) RESULT))))
|
||
(SIN\COS-PLUS L N F1 F2 FLAG)))
|
||
|
||
(DEFUN SIN\COS-TIMES (L M N F1 F2 FLAG)
|
||
;; Assume m,n < 2^17, but Binom may become big
|
||
;; Flag is 1 or -1
|
||
(SETQ F1 (CONS-EXP F1 (CONS '(MTIMES) L)) F2 (CONS-EXP F2 (CONS '(MTIMES) L)))
|
||
(DO ((I M (+ 2 I)) (END (ABS N)) (RESULT)
|
||
(BINOM (COND ((= 0 M) 1) (T (ABS N))) (quotient (times (* FLAG (- END I 1) (- END I)) BINOM) (* (+ 2 I) (1+ I)))))
|
||
((> I END) (SETQ RESULT (SIMPLIFY (CONS '(MPLUS) RESULT)))
|
||
(COND ((AND (= 1 M) (MINUSP N)) (NEG RESULT)) (T RESULT)))
|
||
(SETQ RESULT (CONS (MUL BINOM (POWER F1 I) (POWER F2 (- END I))) RESULT))))
|
||
|
||
(DEFUN TAN-TIMES (L N F FLAG)
|
||
(SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
|
||
(DO ((I 1 (+ 2 I)) (END (ABS N)) (NUM) (DEN (LIST 1))
|
||
(BINOM (ABS N) (quotient (times (- END I 1) BINOM) (+ 2 I))))
|
||
((> I END) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||
(COND ((MINUSP N) (NEG NUM)) (T NUM)))
|
||
(SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
|
||
DEN (COND ((= END I) DEN)
|
||
(T (CONS (MUL (SETQ BINOM (quotient (times (* FLAG (- END I)) BINOM) (1+ I)))
|
||
(POWER F (1+ I)))
|
||
DEN))))))
|
||
|
||
(DEFUN COT-TIMES (L N F FLAG)
|
||
(SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
|
||
(DO ((I (ABS N) (- I 2)) (END (ABS N)) (NUM) (DEN)
|
||
(BINOM 1 (quotient (times (* FLAG (1- I)) BINOM) (- END I -2))))
|
||
((< I 0) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||
(IF (MINUSP N) (NEG NUM) NUM))
|
||
(SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
|
||
DEN (IF (= 0 I) DEN
|
||
(CONS (MUL (SETQ BINOM (quotient (times I BINOM) (- END I -1))) (POWER F (1- I))) DEN)))))
|
||
|
||
(DEFUN CSC\SEC-TIMES (L M N F1 F2 FLAG)
|
||
(DIV* (MUL (POWER (CONS-EXP F1 (CONS '(MTIMES) L)) (ABS N))
|
||
(POWER (CONS-EXP F2 (CONS '(MTIMES) L)) (ABS N)))
|
||
(SIN\COS-TIMES L M N F1 F2 FLAG)))
|
||
|
||
(DEFUN MPC (DL UL RESULT F1 F2 DI UI)
|
||
(COND ((= 0 UI)
|
||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F2 L)) UL))
|
||
RESULT))
|
||
((= DI UI)
|
||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F1 L)) UL))
|
||
RESULT))
|
||
(T (MPC (CONS (CONS-EXP F1 (CAR UL)) DL) (CDR UL)
|
||
(MPC (CONS (CONS-EXP F2 (CAR UL)) DL)
|
||
(CDR UL) RESULT F1 F2 (1- DI) UI) F1 F2
|
||
(1- DI) (1- UI)))))
|
||
|
||
(DEFUN MPC1 (DL UL RESULT F DI UI)
|
||
(COND ((= 0 UI) (CONS (REVERSE DL) RESULT))
|
||
((= DI UI)
|
||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F L)) UL)) RESULT))
|
||
(T (MPC1 (CONS (CONS-EXP F (CAR UL)) DL) (CDR UL)
|
||
(MPC1 DL (CDR UL) RESULT F (1- DI) UI) F
|
||
(1- DI) (1- UI)))))
|
||
|
||
;; Local Modes:
|
||
;; Mode: LISP
|
||
;; Comment Col: 40
|
||
;; End:
|
||
|