mirror of
https://github.com/PDP-10/its.git
synced 2026-03-26 02:05:51 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
384 lines
15 KiB
Common Lisp
384 lines
15 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1981 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))
|
||
|
||
;;; Arithmetic utilities.
|
||
|
||
|
||
;(DEFMFUN $FACTOROUT (X EXP)
|
||
; (COND ((ATOM EXP) EXP)
|
||
; ((EQ 'MPLUS (CAAR EXP))
|
||
; (MUL2 X (ADDN (MAPCAR #'(LAMBDA (L) (DIV L X)) (CDR EXP)) NIL)))
|
||
; ((EQ 'MTIMES (CAAR EXP))
|
||
; (MULN (MAPCAR #'(LAMBDA (L) ($FACTOROUT X L)) (CDR EXP)) NIL))
|
||
; (T EXP)))
|
||
|
||
|
||
(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)))))
|
||
((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))))
|
||
((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 (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 (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 (COND ((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 (COND ((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 (COND ((OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ACOTH)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOS (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)
|
||
(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))) (// (* 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) (// (* (- 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 (// (* 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 (// (* 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 (// (* 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:
|