mirror of
https://github.com/PDP-10/its.git
synced 2026-03-29 19:08:01 +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.
580 lines
21 KiB
Common Lisp
580 lines
21 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module trigi)
|
||
|
||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||
|
||
(DECLARE (GENPREFIX TRI)
|
||
(SPECIAL VARLIST ERRORSW $DEMOIVRE)
|
||
(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 EXPAND1
|
||
TIMESK ADDK INTEGERP EVOD LOGARC
|
||
MEVENP EQTEST HALFANGLE COEFF))
|
||
|
||
(DEFMVAR $%PIARGS T)
|
||
(DEFMVAR $%IARGS T)
|
||
(DEFMVAR $TRIGINVERSES '$ALL)
|
||
(DEFMVAR $TRIGEXPAND NIL)
|
||
(DEFMVAR $TRIGEXPANDPLUS T)
|
||
(DEFMVAR $TRIGEXPANDTIMES T)
|
||
(DEFMVAR $TRIGSIGN T)
|
||
(DEFMVAR $EXPONENTIALIZE NIL)
|
||
(DEFMVAR $LOGARC NIL)
|
||
(DEFMVAR $HALFANGLES NIL)
|
||
|
||
(DEFMVAR 1//2 '((RAT SIMP) 1 2))
|
||
(DEFMVAR -1//2 '((RAT SIMP) -1 2))
|
||
(DEFMVAR %PI//4 '((MTIMES SIMP) ((RAT SIMP) 1 4.) $%PI))
|
||
(DEFMVAR %PI//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) $%PI))
|
||
(DEFMVAR SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
|
||
((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
|
||
(DEFMVAR -SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
|
||
((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
|
||
(DEFMVAR SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
|
||
((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
|
||
(DEFMVAR -SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
|
||
((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
|
||
|
||
;;; Arithmetic utilities.
|
||
|
||
(DEFMFUN SQRT1-X^2 (X) (POWER (SUB 1 (POWER X 2)) 1//2))
|
||
|
||
(DEFMFUN SQRT1+X^2 (X) (POWER (ADD 1 (POWER X 2)) 1//2))
|
||
|
||
(DEFMFUN SQRTX^2-1 (X) (POWER (ADD (POWER X 2) -1) 1//2))
|
||
|
||
(DEFMFUN SQ-SUMSQ (X Y) (POWER (ADD (POWER X 2) (POWER Y 2)) 1//2))
|
||
|
||
(DEFMFUN TRIGP (FUNC) (MEMQ FUNC '(%SIN %COS %TAN %CSC %SEC %COT
|
||
%SINH %COSH %TANH %CSCH %SECH %COTH)))
|
||
|
||
(DEFMFUN ARCP (FUNC) (MEMQ FUNC '(%ASIN %ACOS %ATAN %ACSC %ASEC %ACOT
|
||
%ASINH %ACOSH %ATANH %ACSCH %ASECH %ACOTH)))
|
||
|
||
(DEFPROP %SIN SIMP-%SIN OPERATORS)
|
||
(DEFPROP %COS SIMP-%COS OPERATORS)
|
||
(DEFPROP %TAN SIMP-%TAN OPERATORS)
|
||
(DEFPROP %COT SIMP-%COT OPERATORS)
|
||
(DEFPROP %CSC SIMP-%CSC OPERATORS)
|
||
(DEFPROP %SEC SIMP-%SEC OPERATORS)
|
||
(DEFPROP %SINH SIMP-%SINH OPERATORS)
|
||
(DEFPROP %COSH SIMP-%COSH OPERATORS)
|
||
(DEFPROP %TANH SIMP-%TANH OPERATORS)
|
||
(DEFPROP %COTH SIMP-%COTH OPERATORS)
|
||
(DEFPROP %CSCH SIMP-%CSCH OPERATORS)
|
||
(DEFPROP %SECH SIMP-%SECH OPERATORS)
|
||
(DEFPROP %ASIN SIMP-%ASIN OPERATORS)
|
||
(DEFPROP %ACOS SIMP-%ACOS OPERATORS)
|
||
(DEFPROP %ATAN SIMP-%ATAN OPERATORS)
|
||
(DEFPROP %ACOT SIMP-%ACOT OPERATORS)
|
||
(DEFPROP %ACSC SIMP-%ACSC OPERATORS)
|
||
(DEFPROP %ASEC SIMP-%ASEC OPERATORS)
|
||
(DEFPROP %ASINH SIMP-%ASINH OPERATORS)
|
||
(DEFPROP %ACOSH SIMP-%ACOSH OPERATORS)
|
||
(DEFPROP %ATANH SIMP-%ATANH OPERATORS)
|
||
(DEFPROP %ACOTH SIMP-%ACOTH OPERATORS)
|
||
(DEFPROP %ACSCH SIMP-%ACSCH OPERATORS)
|
||
(DEFPROP %ASECH SIMP-%ASECH OPERATORS)
|
||
|
||
(DEFMFUN SIMP-%SIN (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SIN Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS Y)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SINH (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||
(COND ((EQ '%ASIN (SETQ Z (CAAR Y))) (CADR Y))
|
||
((EQ '%ACOS Z) (SQRT1-X^2 (CADR Y)))
|
||
((EQ '%ATAN Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
|
||
((EQ '%ACOT Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
|
||
((EQ '%ASEC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
|
||
((EQ '%ACSC Z) (DIV 1 (CADR Y)))
|
||
((EQ '$ATAN2 Z) (DIV (CADR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%SIN Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%SIN Y))
|
||
((AND $HALFANGLES (HALFANGLE '%SIN Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SIN (NEG Y))))
|
||
(T (EQTEST (LIST '(%SIN) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%COS (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COS Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS (ADD %PI//2 Y))))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COSH (COEFF Y '$%I 1)))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||
(COND ((EQ '%ACOS (SETQ Z (CAAR Y))) (CADR Y))
|
||
((EQ '%ASIN Z) (SQRT1-X^2 (CADR Y)))
|
||
((EQ '%ATAN Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
|
||
((EQ '%ACOT Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
|
||
((EQ '%ASEC Z) (DIV 1 (CADR Y)))
|
||
((EQ '%ACSC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
|
||
((EQ '$ATAN2 Z) (DIV (CADDR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%COS Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%COS Y))
|
||
((AND $HALFANGLES (HALFANGLE '%COS Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COS (NEG Y)))
|
||
(T (EQTEST (LIST '(%COS) Y) FORM))))
|
||
|
||
(DEFUN %PIARGS-SIN\COS (X)
|
||
(LET ($FLOAT COEFF RATCOEFF REM)
|
||
(SETQ RATCOEFF (COEFFICIENT X '$%PI 1)
|
||
COEFF (LINEARIZE RATCOEFF) REM (COEFFICIENT X '$%PI 0))
|
||
(COND ((ZEROP1 REM) (%PIARGS COEFF RATCOEFF))
|
||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||
((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%SIN REM))
|
||
((EQUAL 1 X) (NEG (CONS-EXP '%SIN REM)))
|
||
((ALIKE1 1//2 X) (CONS-EXP '%COS REM))
|
||
((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%COS REM))))))
|
||
|
||
(DEFMFUN SIMP-%TAN (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TAN Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-TAN\COT Y)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TANH (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||
(COND ((EQ '%ATAN (SETQ Z (CAAR Y))) (CADR Y))
|
||
((EQ '%ASIN Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
|
||
((EQ '%ACOS Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
|
||
((EQ '%ACOT Z) (DIV 1 (CADR Y)))
|
||
((EQ '%ASEC Z) (SQRTX^2-1 (CADR Y)))
|
||
((EQ '%ACSC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
|
||
((EQ '$ATAN2 Z) (DIV (CADDR Y) (CADR Y))))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%TAN Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%TAN Y))
|
||
((AND $HALFANGLES (HALFANGLE '%TAN Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TAN (NEG Y))))
|
||
(T (EQTEST (LIST '(%TAN) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%COT (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COT Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'COT))
|
||
((AND (LINEARP Y '$%PI) (SETQ Z (%PIARGS-TAN\COT (ADD %PI//2 Y)))) (NEG Z)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||
(COND ((EQ '%ACOT (SETQ Z (CAAR Y))) (CADR Y))
|
||
((EQ '%ASIN Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
|
||
((EQ '%ACOS Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
|
||
((EQ '%ATAN Z) (DIV 1 (CADR Y)))
|
||
((EQ '%ASEC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
|
||
((EQ '%ACSC Z) (SQRTX^2-1 (CADR Y))))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%COT Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%COT Y))
|
||
((AND $HALFANGLES (HALFANGLE '%COT Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COT (NEG Y))))
|
||
(T (EQTEST (LIST '(%COT) Y) FORM))))
|
||
|
||
(DEFUN %PIARGS-TAN\COT (X)
|
||
(PROG ($FLOAT COEFF REM)
|
||
(SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0))
|
||
(RETURN (COND ((AND (ZEROP1 REM)
|
||
(SETQ REM (%PIARGS COEFF NIL))
|
||
(SETQ COEFF (%PIARGS (CONS (CAR COEFF) (RPLUS 1//2 (CDR COEFF)))
|
||
NIL)))
|
||
(DIV REM COEFF))
|
||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||
((FIXP (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%TAN REM))
|
||
((OR (ALIKE1 1//2 X) (ALIKE1 '((RAT) 3 2) X)) (NEG (CONS-EXP '%COT REM)))))))
|
||
|
||
(DEFMFUN SIMP-%CSC (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSC Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSC))
|
||
((LINEARP Y '$%PI) (%PIARGS-CSC\SEC Y)))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSCH (COEFF Y '$%I 1))))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||
(COND ((EQ '%ACSC (SETQ Z (CAAR Y))) (CADR Y))
|
||
((EQ '%ASIN Z) (DIV 1 (CADR Y)))
|
||
((EQ '%ACOS Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
|
||
((EQ '%ATAN Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
|
||
((EQ '%ACOT Z) (SQRT1+X^2 (CADR Y)))
|
||
((EQ '%ASEC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y)))))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%CSC Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%CSC Y))
|
||
((AND $HALFANGLES (HALFANGLE '%CSC Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSC (NEG Y))))
|
||
|
||
(T (EQTEST (LIST '(%CSC) Y) FORM))))
|
||
|
||
(DEFMFUN SIMP-%SEC (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SEC Y))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC (ADD %PI//2 Y))))))
|
||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SECH (COEFF Y '$%I 1)))
|
||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||
(COND ((EQ '%ASEC (SETQ Z (CAAR Y))) (CADR Y))
|
||
((EQ '%ASIN Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
|
||
((EQ '%ACOS Z) (DIV 1 (CADR Y)))
|
||
((EQ '%ATAN Z) (SQRT1+X^2 (CADR Y)))
|
||
((EQ '%ACOT Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
|
||
((EQ '%ACSC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y)))))))
|
||
((AND $TRIGEXPAND (TRIGEXPAND '%SEC Y)))
|
||
($EXPONENTIALIZE (EXPONENTIALIZE '%SEC Y))
|
||
((AND $HALFANGLES (HALFANGLE '%SEC Y)))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SEC (NEG Y)))
|
||
|
||
(T (EQTEST (LIST '(%SEC) Y) FORM))))
|
||
|
||
(DEFUN %PIARGS-CSC\SEC (X)
|
||
(PROG ($FLOAT COEFF REM)
|
||
(SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0))
|
||
(RETURN (COND ((AND (ZEROP1 REM) (SETQ REM (%PIARGS COEFF NIL))) (DIV 1 REM))
|
||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||
((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%CSC REM))
|
||
((EQUAL 1 X) (NEG (CONS-EXP '%CSC REM)))
|
||
((ALIKE1 1//2 X) (CONS-EXP '%SEC REM))
|
||
((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%SEC REM)))))))
|
||
|
||
(DEFMFUN SIMP-%ATAN (FORM Y Z)
|
||
(ONEARGCHECK FORM)
|
||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y)))
|
||
(SETQ Z (ATAN1 Y)))
|
||
(($BFLOATP Y) ($BFLOAT FORM))
|
||
((AND $%PIARGS
|
||
(COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4)))))
|
||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||
(IF (EQ '%TAN (CAAR Y)) (CADR Y))))
|
||
($LOGARC (LOGARC '%ATAN Y))
|
||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATAN (NEG Y))))
|
||
(T (EQTEST (LIST '(%ATAN) Y) FORM))))
|
||
|
||
(DEFUN %PIARGS (X RATCOEFF)
|
||
(COND ((AND (FIXP (CAR X)) (FIXP (CDR X))) 0)
|
||
((NOT (MEVENP (CAR X)))
|
||
(COND ((NULL RATCOEFF) NIL)
|
||
((ALIKE1 (CDR X) '((RAT) 1 2))
|
||
(POWER -1 (ADD RATCOEFF -1//2)))))
|
||
((OR (ALIKE1 '((RAT) 1 6) (SETQ X (MMOD (CDR X) 2))) (ALIKE1 '((RAT) 5 6) X)) 1//2)
|
||
((OR (ALIKE1 '((RAT) 1 4) X) (ALIKE1 '((RAT) 3 4) X)) (DIV (POWER 2 1//2) 2))
|
||
((OR (ALIKE1 '((RAT) 1 3) X) (ALIKE1 '((RAT) 2 3) X)) (DIV (POWER 3 1//2) 2))
|
||
((ALIKE1 1//2 X) 1)
|
||
((OR (ALIKE1 '((RAT) 7 6) X) (ALIKE1 '((RAT) 11 6) X)) -1//2)
|
||
((OR (ALIKE1 '((RAT) 4 3) X) (ALIKE1 '((RAT) 5 3) X)) (DIV (POWER 3 1//2) -2))
|
||
((OR (ALIKE1 '((RAT) 5 4) X) (ALIKE1 '((RAT) 7 4) X)) (MUL -1//2 (POWER 2 1//2)))
|
||
((ALIKE1 '((RAT) 3 2) X) -1)))
|
||
|
||
(DEFUN LINEARIZE (FORM)
|
||
(COND ((FIXP FORM) (CONS 0 FORM))
|
||
((NUMBERP FORM) NIL)
|
||
((ATOM FORM)
|
||
(LET (DUM)
|
||
(COND ((SETQ DUM (EVOD FORM))
|
||
(IF (EQ '$EVEN DUM) '(2 . 0) '(2 . 1)))
|
||
((INTEGERP FORM) '(1 . 0)))))
|
||
((EQ 'RAT (CAAR FORM)) (CONS 0 FORM))
|
||
((EQ 'MPLUS (CAAR FORM)) (LIN-MPLUS FORM))
|
||
((EQ 'MTIMES (CAAR FORM)) (LIN-MTIMES FORM))
|
||
((EQ 'MEXPT (CAAR FORM)) (LIN-MEXPT FORM))))
|
||
|
||
(DEFUN LIN-MPLUS (FORM)
|
||
(DO ((TL (CDR FORM) (CDR TL)) (DUMMY) (COEFF 0) (REM 0))
|
||
((NULL TL) (CONS COEFF (MMOD REM COEFF)))
|
||
(SETQ DUMMY (LINEARIZE (CAR TL)))
|
||
(IF (NULL DUMMY) (RETURN NIL)
|
||
(SETQ COEFF (RGCD (CAR DUMMY) COEFF) REM (RPLUS (CDR DUMMY) REM)))))
|
||
|
||
(DEFUN LIN-MTIMES (FORM)
|
||
(DO ((FL (CDR FORM) (CDR FL)) (DUMMY) (COEFF 0) (REM 1))
|
||
((NULL FL) (CONS COEFF (MMOD REM COEFF)))
|
||
(SETQ DUMMY (LINEARIZE (CAR FL)))
|
||
(COND ((NULL DUMMY) (RETURN NIL))
|
||
(T (SETQ COEFF (RGCD (RTIMES COEFF (CAR DUMMY))
|
||
(RGCD (RTIMES COEFF (CDR DUMMY)) (RTIMES REM (CAR DUMMY))))
|
||
REM (RTIMES (CDR DUMMY) REM))))))
|
||
|
||
(DEFUN LIN-MEXPT (FORM)
|
||
(PROG (DUMMY)
|
||
(COND ((AND (FIXP (CADDR FORM)) (NOT (MINUSP (CADDR FORM)))
|
||
(NOT (NULL (SETQ DUMMY (LINEARIZE (CADR FORM))))))
|
||
(RETURN (CONS (CAR DUMMY) (MMOD (CDR DUMMY) (CADDR FORM))))))))
|
||
|
||
|
||
(DEFUN LCM (X Y) (QUOTIENT (TIMES X Y) (GCD X Y)))
|
||
|
||
(DEFUN RGCD (X Y)
|
||
(COND ((FIXP X)
|
||
(COND ((FIXP Y) (GCD X Y))
|
||
(T (LIST '(RAT) (GCD X (CADR Y)) (CADDR Y)))))
|
||
((FIXP Y) (LIST '(RAT) (GCD (CADR X) Y) (CADDR X)))
|
||
(T (LIST '(RAT) (GCD (CADR X) (CADR Y)) (LCM (CADDR X) (CADDR Y))))))
|
||
|
||
(DEFUN REDUCE (X Y)
|
||
(PROG (GCD)
|
||
(SETQ GCD (GCD X Y) X (QUOTIENT X GCD) Y (QUOTIENT Y GCD))
|
||
(IF (MINUSP Y) (SETQ X (MINUS X) Y (MINUS Y)))
|
||
(RETURN (IF (EQUAL Y 1) X (LIST '(RAT SIMP) X Y)))))
|
||
|
||
;; The following four functions are generated in code by TRANSL. - JPG 2/1/81
|
||
|
||
(DEFMFUN RPLUS (X Y) (ADDK X Y))
|
||
|
||
(DEFMFUN RDIFFERENCE (X Y) (ADDK X (TIMESK -1 Y)))
|
||
|
||
(DEFMFUN RTIMES (X Y) (TIMESK X Y))
|
||
|
||
(DEFMFUN RREMAINDER (X Y)
|
||
(COND ((EQUAL 0 Y) (DBZ-ERR))
|
||
((FIXP X)
|
||
(COND ((FIXP Y) (REDUCE X Y))
|
||
(T (REDUCE (TIMES X (CADDR Y)) (CADR Y)))))
|
||
((FIXP Y) (REDUCE (CADR X) (TIMES (CADDR X) Y)))
|
||
(T (REDUCE (TIMES (CADR X) (CADDR Y)) (TIMES (CADDR X) (CADR Y))))))
|
||
|
||
(DEFMFUN $EXPONENTIALIZE (EXP)
|
||
(LET ($DEMOIVRE)
|
||
(COND ((ATOM EXP) EXP)
|
||
((TRIGP (CAAR EXP))
|
||
(EXPONENTIALIZE (CAAR EXP) ($EXPONENTIALIZE (CADR EXP))))
|
||
(T (RECUR-APPLY #'$EXPONENTIALIZE EXP)))))
|
||
|
||
(DEFMFUN EXPONENTIALIZE (OP ARG)
|
||
(COND ((EQ '%SIN OP)
|
||
(DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
|
||
(MUL 2 '$%I)))
|
||
((EQ '%COS OP)
|
||
(DIV (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) 2))
|
||
((EQ '%TAN OP)
|
||
(DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
|
||
(MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
|
||
(POWER '$%E (MUL -1 '$%I ARG))))))
|
||
((EQ '%COT OP)
|
||
(DIV (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
|
||
(POWER '$%E (MUL -1 '$%I ARG))))
|
||
(SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||
((EQ '%CSC OP)
|
||
(DIV (MUL 2 '$%I)
|
||
(SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||
((EQ '%SEC OP)
|
||
(DIV 2 (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||
((EQ '%SINH OP)
|
||
(DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))) 2))
|
||
((EQ '%COSH OP)
|
||
(DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))) 2))
|
||
((EQ '%TANH OP)
|
||
(DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))
|
||
(ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))
|
||
((EQ '%COTH OP)
|
||
(DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))
|
||
(SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
|
||
((EQ '%CSCH OP)
|
||
(DIV 2 (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
|
||
((EQ '%SECH OP)
|
||
(DIV 2 (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))))
|
||
|
||
(DEFUN COEFFICIENT (EXP VAR POW) (COEFF (EXPAND1 EXP 1 0) VAR POW))
|
||
|
||
(DEFUN MMOD (X MOD)
|
||
(COND ((FIXP X) (IF (MINUSP (SETQ X (- X (* MOD (// X MOD))))) (+ X MOD) X))
|
||
((AND (NOT (ATOM X)) (EQ 'RAT (CAAR X)))
|
||
(LIST '(RAT) (MMOD (CADR X) (* MOD (CADDR X))) (CADDR X)))))
|
||
|
||
(DEFUN MULTIPLEP (EXP VAR)
|
||
(AND (NOT (ZEROP1 EXP)) (ZEROP1 (SUB EXP (MUL VAR (COEFF EXP VAR 1))))))
|
||
|
||
(DEFUN LINEARP (EXP VAR)
|
||
(AND (SETQ EXP (ISLINEAR (EXPAND1 EXP 1 0) VAR)) (NOT (EQUAL (CAR EXP) 0))))
|
||
|
||
(DEFMFUN MMINUSP (X) (= -1 (SIGNUM1 X)))
|
||
|
||
(DEFMFUN MMINUSP* (X)
|
||
(LET (SIGN)
|
||
(SETQ SIGN (CSIGN X))
|
||
(OR (MEMQ SIGN '($NEG $NZ))
|
||
(AND (MMINUSP X) (NOT (MEMQ SIGN '($POS $PZ)))))))
|
||
|
||
;; This should give more information somehow.
|
||
|
||
(DEFUN DBZ-ERR ()
|
||
(COND ((NOT ERRORSW) (MERROR "Division by zero"))
|
||
(T (*THROW 'ERRORSW T))))
|
||
|
||
(DEFUN DBZ-ERR1 (FUNC)
|
||
(COND ((NOT ERRORSW) (MERROR "Division by zero in ~A function" FUNC))
|
||
(T (*THROW 'ERRORSW T))))
|
||
|
||
;; Only used by LAP code right now.
|
||
|
||
#+PDP10
|
||
(DEFUN NUMERIC-ERR (X MSG) (MERROR "~A in ~A function" MSG X))
|
||
|
||
;; Trig, hyperbolic functions, and inverses, which take real floating args
|
||
;; and return real args. Checks made for overflow and out of range args.
|
||
;; The following are read-time constants.
|
||
;; This seems bogus. Probably want (FSC (LSH 1 26.) 0) for the PDP10. -cwh
|
||
|
||
#.(SETQ EPS #+PDP10 (FSC 1.0 -26.) #-PDP10 1.4E-8)
|
||
#.(SETQ PI (ATAN 0.0 -1.0) PIBY2 (//$ PI 2.0))
|
||
|
||
;; This function is in LAP for PDP10 systems. On the Lisp Machine and
|
||
;; in NIL, this should CONDITION-BIND the appropriate arithmetic overflow
|
||
;; signals and do whatever NUMERIC-ERR or DBZ-ERR does. Fix later.
|
||
|
||
#-(OR PDP10 LISPM) (DEFMACRO T//$ (X Y FUNCTION) FUNCTION ;Ignored
|
||
`(//$ ,X ,Y))
|
||
#+LISPM
|
||
(DEFMACRO T//$ (X Y FUNCTION)
|
||
(IF (EQUAL Y 0.0)
|
||
;; DEFEAT INCOMPETENTLY DONE COMPILER:OPTIMIZATION.
|
||
`(T//$-FOO ,X ,Y ,FUNCTION)
|
||
`(//$ ,X ,Y)))
|
||
#+LISPM
|
||
(DEFUN T//$-FOO (X Y FUNCTION) FUNCTION
|
||
(//$ X Y))
|
||
|
||
#+PDP10 (LAP-A-LIST '(
|
||
|
||
(LAP T//$ SUBR)
|
||
(ARGS T//$ (NIL . 3))
|
||
(PUSH P (% 0 0 FLOAT1))
|
||
(JRST 2 @ (% 0 0 NEXTA))
|
||
NEXTA (MOVE TT 0 A)
|
||
(FDVR TT 0 B) ;DIVIDE TT BY SECOND ARG
|
||
(JFCL 10 UFLOW)
|
||
ANS (POPJ P)
|
||
UFLOW (MOVE A C)
|
||
(SKIPN 0 0 B)
|
||
(JCALL 1 'DBZ-ERR1)
|
||
(MOVEI B 'OVERFLOW)
|
||
(JSP T NEXTB)
|
||
NEXTB (TLNN T 64.)
|
||
(JCALL 2 'NUMERIC-ERR)
|
||
(MOVEI B 'UNDERFLOW)
|
||
(SKIPN 0 (SPECIAL ZUNDERFLOW))
|
||
(JCALL 2 'NUMERIC-ERR)
|
||
(MOVEI TT 0)
|
||
(JRST 0 ANS)
|
||
NIL ))
|
||
|
||
;; Numeric functions (SIN, COS, LOG, EXP are built in to Lisp).
|
||
|
||
(DEFMFUN TAN (X) (T//$ (SIN X) (COS X) 'TAN))
|
||
|
||
(DEFMFUN COT (X) (T//$ (COS X) (SIN X) 'COT))
|
||
|
||
(DEFMFUN SEC (X) (T//$ 1.0 (COS X) 'SEC))
|
||
|
||
(DEFMFUN CSC (X) (T//$ 1.0 (SIN X) 'CSC))
|
||
|
||
;; #.<form> means to evaluate <form> at read-time.
|
||
|
||
(DECLARE (FLONUM YY YFLO))
|
||
|
||
(DEFMFUN ASIN (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(COND ((> (ABS YFLO) 1.0) (LOGARC '%ASIN YFLO))
|
||
((< (ABS YFLO) #.(SQRT EPS)) YFLO)
|
||
(T (*$ (ATAN (ABS YFLO) (SQRT (-$ 1.0 (*$ YFLO YFLO))))
|
||
(IF (< YFLO 0.0) -1.0 1.0))))))
|
||
|
||
(DEFMFUN ACOS (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(COND ((> (ABS YFLO) 1.0) (LOGARC '%ACOS YFLO))
|
||
((< (ABS YFLO) #.(SQRT EPS)) (-$ #.PIBY2 YFLO))
|
||
(T (ATAN (SQRT (-$ 1.0 (*$ YFLO YFLO))) YFLO)))))
|
||
|
||
#+MACLISP
|
||
(DEFUN ATAN2 (Y X)
|
||
(LET ((YFLO (ATAN (ABS Y) X))) (IF (MINUSP Y) (-$ YFLO) YFLO)))
|
||
|
||
(DEFMFUN ATAN1 (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(*$ (ATAN (ABS YFLO) 1.0) (IF (MINUSP YFLO) -1.0 1.0))))
|
||
|
||
(DEFMFUN ACOT (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(*$ (ATAN 1.0 (ABS YFLO)) (IF (MINUSP YFLO) -1.0 1.0))))
|
||
|
||
(DEFMFUN ASEC (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(IF (< (ABS YFLO) 1.0) (LOGARC '%ASEC YFLO)) (ACOS (//$ YFLO))))
|
||
|
||
(DEFMFUN ACSC (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(IF (< (ABS YFLO) 1.0) (LOGARC '%ACSC YFLO)) (ASIN (//$ YFLO))))
|
||
|
||
(DEFMFUN SINH (NUM)
|
||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||
(T (SETQ YFLO (EXP (ABS YY)) YFLO (//$ (-$ YFLO (//$ YFLO)) 2.0))
|
||
(IF (< YY 0.0) (-$ YFLO) YFLO)))))
|
||
|
||
(DEFMFUN COSH (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(SETQ YFLO (EXP (ABS YFLO))) (//$ (+$ YFLO (//$ YFLO)) 2.0)))
|
||
|
||
(DEFMFUN TANH (NUM)
|
||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) YFLO (//$ (1-$ YFLO) (1+$ YFLO)))
|
||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||
|
||
(DEFMFUN COTH (NUM)
|
||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||
(COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY))
|
||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) YFLO (T//$ (1+$ YFLO) (1-$ YFLO) 'COTH))
|
||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||
|
||
(DEFMFUN CSCH (NUM)
|
||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||
(COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY))
|
||
(T (SETQ YFLO (EXP (-$ (ABS YY)))
|
||
YFLO (T//$ (*$ 2.0 YFLO)
|
||
(1-$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))) 'CSCH))
|
||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||
|
||
(DEFMFUN SECH (NUM)
|
||
(LET ((YFLO (FLOAT NUM))) (SETQ YFLO (EXP (-$ (ABS YFLO))))
|
||
(//$ YFLO 0.5 (1+$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))))))
|
||
|
||
(DEFMFUN ACOSH (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(COND ((< YFLO 1.0) (LOGARC '%ACOSH YFLO))
|
||
((> YFLO #.(SQRT (//$ EPS))) (LOG (*$ 2.0 YFLO)))
|
||
(T (LOG (+$ (SQRT (1-$ (*$ YFLO YFLO))) YFLO))))))
|
||
|
||
(DEFMFUN ASINH (NUM)
|
||
(LET* ((YY (FLOAT NUM))
|
||
(YFLO (ABS YY)))
|
||
(COND ((< YFLO #.(SQRT EPS)) YFLO)
|
||
(T (SETQ YFLO (LOG (COND ((> YFLO #.(SQRT (//$ EPS))) (*$ 2.0 YFLO))
|
||
(T (+$ (SQRT (1+$ (*$ YFLO YFLO))) YFLO)))))
|
||
(COND ((MINUSP YY) (-$ YFLO)) (T YFLO))))))
|
||
|
||
(DEFMFUN ATANH (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(COND ((< (ABS YFLO) #.(SQRT EPS)) YFLO)
|
||
((< (ABS YFLO) 1.0) (//$ (LOG (T//$ (1+$ YFLO) (-$ 1.0 YFLO) 'ATANH)) 2.0))
|
||
((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ATANH))
|
||
(T (LOGARC '%ATANH YFLO)))))
|
||
|
||
(DEFMFUN ACOTH (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(COND ((> (ABS YFLO) 1.0) (//$ (LOG (//$ (-$ 1.0 YFLO) (1+$ YFLO))) 2.0))
|
||
((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ACOTH))
|
||
(T (LOGARC '%ACOTH YFLO)))))
|
||
|
||
(DEFMFUN ASECH (NUM)
|
||
(LET ((YFLO (FLOAT NUM)))
|
||
(COND ((OR (MINUSP YFLO) (> YFLO 1.0)) (LOGARC '%ASECH YFLO)))
|
||
(ACOSH (T//$ 1.0 YFLO 'ASECH))))
|
||
|
||
(DEFMFUN ACSCH (NUM) (ASINH (T//$ 1.0 (FLOAT NUM) 'ACSCH)))
|