;; -*- Mode: Lisp; Package: Macsyma; -*-

;; (c) Copyright 1976, 1984 Massachusetts Institute of Technology
;; All Rights Reserved.

;; Enhancements (c) Copyright 1984 Symbolics Inc.
;; All Rights Reserved.
 
;; The data and information in the Enhancements are proprietary to, and 
;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. 
;; They are given in confidence by SYMBOLICS, pursuant to the license 
;; agreement between Symbolics and their recipient, and may not be used, 
;; reproduced, or copied, or distributed to any other party, in whole or 
;; in part, without the prior written consent of SYMBOLICS except as 
;; permitted by the license agreement.

(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 (CADR Y) (CADDR 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)))
		    ((EQ '$ATAN2 Z) (DIV (CADDR Y) (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))))
		    ((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (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))))
		    ((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADDR 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))) (ATAN1 Y))
	(($BFLOATP Y) ($BFLOAT FORM))
	((AND $%PIARGS
	      (COND ((ZEROP1 Y) 0)
		    ((EQUAL Y 1) (SIMPLIFY FOURTH%PI))
		    ((EQUAL Y -1) (NEG (SIMPLIFY FOURTH%PI))))))
	((AND $%IARGS (MULTIPLEP Y '$%I))
	 (MUL '$%I (CONS-EXP '%ATANH (COEFF Y '$%I 1))))
	((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
	      (COND ((EQ (CAAR Y) '%TAN) (CADR Y))
		    ((EQ (CAAR Y) '%COT) (SUB (SIMPLIFY HALF%PI) (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) (IF (FIXNUMP COEFF) (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) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF))))
    (SETQ DUMMY (LINEARIZE (CAR FL)))
    (IF (NULL DUMMY)
	(RETURN NIL)
	(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)
  (LET (DUMMY)
    (IF (AND (FIXNUMP (CADDR FORM))
	     (NOT (MINUSP (CADDR FORM)))
	     (NOT (NULL (SETQ DUMMY (LINEARIZE (CADR FORM))))))
        (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)
  (LET ($NUMER $FLOAT) (COEFF (EXPAND1 EXP 1 0) VAR POW)))

(DEFUN LINEARP (EXP VAR)
  (LET ($NUMER $FLOAT)
    (AND (SETQ EXP (ISLINEAR (EXPAND1 EXP 1 0) VAR))
	 (NOT (EQUAL (CAR EXP) 0)))))

(DEFUN MMOD (X MOD)
  (COND ((FIXNUMP X)
	 (IF (MINUSP (SETQ X (- X (* MOD (// X MOD))))) (+ X MOD) X))
	((RATNUMP 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))))))

(DEFMFUN MMINUSP (X) (= -1 (SIGNUM1 X)))

(DEFMFUN MMINUSP* (X) (MMINUSP X))  ;; This could be done by a macro in
				    ;; LIBMAX;MAXMAC . - JPG

;; The following definition for MMINUSP* was used experimentally to test 
;; for e.g. SIN(-X) -> -SIN(X) using the Macsyma database.  However, this 
;; approach was found to be very slow in many cases.  Instead the syntactic 
;; check offered by MMINUSP should be quite sufficient. - JPG

;;(DEFMFUN MMINUSP* (X)
;;  (LET (SIGN)
;;    (SETQ SIGN (CSIGN X))
;;    (OR (MEMQ SIGN '($NEG $NZ))
;;	  (AND (MMINUSP X) (NOT (MEMQ SIGN '($POS $PZ)))))))

(DEFUN DBZ-ERR ()
  (IF (NOT ERRORSW) (MERROR "Division by zero") (*THROW 'ERRORSW T)))

(DEFUN DBZ-ERR1 (FUNC)
  (IF (NOT ERRORSW) (MERROR "Division by zero in ~A function" FUNC)
		    (*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.)
	    #+LispM (ASH 1.0 #+3600 -24. #-3600 -31.)
            #-(or PDP10 LispM) 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))

;; We don't use the built-in Franz definitions of ASIN and ACOS because 
;; they obviously don't know about LOGARC. - JPG

(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)))))
#-LispM
(DEFMFUN 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)))

#-Lispm
(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)))))

#+Lispm
(DEFMFUN TANH (NUM)
  (LET ((YY (FLOAT NUM)) (YFLO 0.0))
    (COND ((< (ABS YY) #.(SQRT EPS)) YY)
	  (T (LET ((ANSWER 0.0))
	       (SETQ ANSWER 
		     (COND ((> (ABS YY) #.(//$ (-$ (LOG EPS)) 2.0)) -1.0)
			   (T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
				    ANSWER (//$ (1-$ YFLO) (1+$ YFLO))))))
	       (IF (PLUSP YY) (-$ ANSWER) ANSWER))))))

(DEFMFUN COTH (NUM)
  (LET ((YY (FLOAT NUM)) (YFLO 0.0))
    (COND ((< (ABS YY) #.(SQRT EPS)) (T//$ 1.0 YY 'COTH))
	  (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)))