;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     The data in this file contains enhancments.                    ;;;;;
;;;                                                                    ;;;;;
;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "MAXIMA")
(macsyma-module pois2)

(DECLARE-top (SPECIAL *ARGC *COEF POISVALS POISCO1 POISCOM1 B* A* *A SS
		  CC H* POISHIFT POISTSM POISSIZ POISTS $WTLVL $POISZ $POIS1)
	 (*LEXPR $PRINT $COEFF)
	 (GENPREFIX \P)) 

(DEFVAR TRIM NIL)

;;(DEFUN CHECKENCODE (R) ; any relation to checkenman?
;;       (PROG (Q)
;;	     (MAPC
;;	      #'(LAMBDA (U)
;;			(SETQ Q ($COEFF R U))
;;			(COND ((AND (INTEGERP Q)
;;				    (LESSP (ABS Q) POISTSM))
;;			       (SETQ R (ADD R (MUL -1 U Q))))
;;			      (T (RETURN NIL))))
;;	      '($U $V $W $X $Y $Z))
;;	     (RETURN (EQUAL R 0))))

;(DEFMFUN $POISSIMP (X)
; (IF (MBAGP X) (CONS (CAR X) (MAPCAR #'$POISSIMP (CDR X))) ($OUTOFPOIS X))) 

;(DEFPROP MPOIS (LAMBDA (X) X) MFEXPR*) 
(defmspec mpois (x) x)


;(DEFMFUN $POISPLUS (A B)
;   (SETQ A (INTOPOIS A) B (INTOPOIS B))
;   (LIST '(MPOIS SIMP)
;	 (POISMERGE22 (CADR A) (CADR B))
;	 (POISMERGE22 (CADDR A) (CADDR B))))
 
(declare-top (SPECIAL *B *FN)) 
;(DEFMFUN $POISMAP (P SINFN COSFN)
;   (PROG (*B *FN)
;	(SETQ P (INTOPOIS P))
;	(SETQ *FN (LIST SINFN))
;	(RETURN (LIST (CAR P) (POISMAP (CADR P))
;		      (PROG2 (SETQ *FN (LIST COSFN))
;			     (POISMAP (CADDR P))))))) 

;(DEFUN POISMAP (Y)
;   (COND ((NULL Y) NIL)
;	 (T (SETQ *B (MEVAL (LIST *FN
;				  (POISCDECODE (CADR Y))
;				  (POISDECODEC (CAR Y)))))
;	    (TCONS3 (CAR Y) (INTOPOISCO *B) (POISMAP (CDDR Y))))))

;(DEFUN POISMERGE22 (R S)
;   (COND ((NULL R) S)
;	 ((NULL S) R)
;	 ((EQUAL (CAR R) (CAR S))
;	  (PROG (TT)
;	     (SETQ TT (POISCO+ (CADR R) (CADR S)))
;	     (RETURN (COND ((POISPZERO TT) (POISMERGE22 (CDDR R) (CDDR S)))
;			   (T (CONS (CAR S)
;				    (CONS TT (POISMERGE22 (CDDR R) (CDDR S)))))))))
;	 ((LESSP (CAR R) (CAR S))
;	  (CONS (CAR R) (CONS (CADR R) (POISMERGE22 (CDDR R) S))))
;	 (T (CONS (CAR S) (CONS (CADR S) (POISMERGE22 (CDDR S) R)))))) 

;(DEFUN POISCOSINE (M)
;   (SETQ M (POISENCODE M))
;   (COND ((POISNEGPRED M) (SETQ M (POISCHANGESIGN M))))
;   (LIST '(MPOIS SIMP) NIL (LIST M POISCO1))) 

;(DEFUN POISSINE (M)
;   (SETQ M (POISENCODE M))
;   (COND ((POISNEGPRED M) (LIST '(MPOIS SIMP)
;				(LIST (POISCHANGESIGN M) POISCOM1)
;				NIL))
;	 (T (LIST '(MPOIS SIMP)
;		  (LIST M POISCO1)
;		  NIL))))

;(DEFMFUN $INTOPOIS (X)
;    (PROG (*A) (RETURN (INTOPOIS X)))) 

;(DEFUN INTOPOIS (A)
;   (COND ((ATOM A) (COND ((EQUAL A 0) $POISZ)
;			 (T (LIST '(MPOIS SIMP) NIL (LIST POISHIFT (INTOPOISCO A))))))
;	 ((EQ (CAAR A) 'MPOIS) A)
;	 ((EQ (CAAR A) '%SIN) (POISSINE (CADR A)))
;	 ((EQ (CAAR A) '%COS) (POISCOSINE (CADR A)))
;	 ((AND (EQ (CAAR A) 'MEXPT)
;	       (NUMBERP (CADDR A))
;	       (GREATERP (CADDR A) 0))
;	  ($POISEXPT (INTOPOIS (CADR A)) (CADDR A)))
;	 ((EQ (CAAR A) 'MPLUS)
;	  (SETQ *A (INTOPOIS (CADR A)))
;	  (MAPC (FUNCTION
;		 (LAMBDA (Z) (SETQ *A ($POISPLUS *A (INTOPOIS Z)))))
;		(CDDR A))
;	   *A)
;	 ((EQ (CAAR A) 'MTIMES)
;	  (SETQ *A (INTOPOIS (CADR A)))
;	  (MAPC (FUNCTION
;		 (LAMBDA (Z) (SETQ *A ($POISTIMES *A (INTOPOIS Z)))))
;		(CDDR A))
;	    *A)
;	 ((EQ (CAAR A) 'MRAT)
;	  (INTOPOIS (RATDISREP A)))
;	 (T (LIST '(MPOIS SIMP) NIL (LIST POISHIFT (INTOPOISCO A)))))) 

;(DEFUN TCONS (R S)
;       (COND ((POISPZERO (CAR S)) (CDR S))
;	     (T (CONS R S)))) 

;(DEFUN POISNEGPRED ($N)
;   (PROG  ($R)
;    $LOOP (COND ((EQUAL $N 0) (RETURN NIL))
;		(T NIL))
;          (SETQ $R (DIFFERENCE (REMAINDER $N POISTS) POISTSM))
;	  (COND ((GREATERP $R 0) (RETURN NIL))
;		((GREATERP 0 $R) (RETURN T))
;		(T (SETQ $N (QUOTIENT $N POISTS))))
;	  (GO $LOOP))) 

;(DEFUN POISCHANGESIGN ($N)
;       (DIFFERENCE (TIMES POISHIFT 2) $N))

;(DEFUN POISENCODE (H*)
;   (COND ((NOT (CHECKENCODE H*))
;	  (merror "Illegal arg to POISSIMP:~%~M" H*)))
;   (APPLY (FUNCTION (LAMBDA ($Z $Y $X $W $V $U)
;		      (DECLARE (SPECIAL $U $V $W $X $Y $Z)) 
;			(SETQ H* (MEVAL H*))
;			(COND ((NOT (INTEGERP H*))
;			       (merror  "Illegal trig arg to POISSON form")))
;			(PLUS POISHIFT H*)))
;	  POISVALS))

(DEFUN POISLIM1 (U N)
   U ;Ignored
   (COND ((NOT (fixnump N))
	  (merror "Improper argument to POISLIM:~%~M" N)))
   (SETQ POISVALS NIL)
   (SETQ POISTS #+NIL (ash 1 n) #-NIL (EXPT 2 N))
   (DO ((J 0 (f1+ J))) ((> J 5))
     (SETQ POISVALS (CONS (EXPT POISTS J) POISVALS)))
   (SETQ POISSIZ N
	 POISTSM (EXPT 2 (SUB1 N))
	 POISHIFT (PROG (SUM)
		     (SETQ SUM 0)
		     (DO ((I 0 (f1+ I))) ((> I 5))
		       (SETQ SUM (PLUS SUM (TIMES POISTSM (EXPT POISTS I)))))
		     (RETURN SUM))
	 $POISZ '((MPOIS SIMP) NIL NIL)
	 $POIS1 (LIST '(MPOIS SIMP) NIL (LIST POISHIFT 1)))
   N)

;(DEFUN POISDECODEC (M &AUX ARG H)
;   (SETQ ARG 0)
;   (SETQ H M)
;   (MAPC
;    #'(LAMBDA (V)
;         (SETQ ARG (ADD ARG (MUL (DIFFERENCE (REMAINDER H POISTS) POISTSM)
;				 V)))
;	 (SETQ H (QUOTIENT H POISTS)))
;    '($U $V $W $X $Y $Z))
;   ARG) 

;(DEFMFUN $POISCTIMES (C P)
;   (LIST '(MPOIS SIMP)
;	 (POISCTIMES1 (SETQ C (INTOPOISCO C))
;		      (CADR P))
;	 (POISCTIMES1 C (CADDR P))))

;(DEFMFUN $OUTOFPOIS (P)
;   (PROG (ANS)
;	(COND ((OR (ATOM P) (NOT (EQ (CAAR P) 'MPOIS)))
;	       (SETQ P (INTOPOIS P))))
;	(DO M (CADR P) (CDDR M) (NULL M)
;	  (SETQ ANS (CONS (LIST '(MTIMES) (POISCDECODE (CADR M))
;			     (LIST '(%SIN) (POISDECODEC (CAR M))))
;			  ANS)))
;	(DO M (CADDR P) (CDDR M) (NULL M)
;	  (SETQ ANS (CONS (LIST '(MTIMES) (POISCDECODE (CADR M))
;				(COND ((EQUAL (CAR M) POISHIFT) 1)
;				      (T (LIST '(%COS) (POISDECODEC (CAR M))))))
;			  ANS)))
;	(RETURN (COND ((NULL ANS) 0)
;		      (T (SIMPLIFYA (CONS '(MPLUS) ANS) NIL)))))) 

;(DEFMFUN $PRINTPOIS (P)
;   (PROG ()
;      (SETQ P (INTOPOIS P))
;      (DO M (CADR P) (CDDR M) (NULL M)
;	 (DISPLA (SIMPLIFYA (LIST '(MTIMES) (POISCDECODE (CADR M))
;			       (LIST '(%SIN) (POISDECODEC (CAR M))))
;			     T))
;	 (TERPRI))
;      (DO M (CADDR P) (CDDR M) (NULL M)
;	 (DISPLA (SIMPLIFYA (LIST '(MTIMES) (POISCDECODE (CADR M))
;				  (COND ((EQUAL (CAR M) POISHIFT) 1)
;					(T (LIST '(%COS) (POISDECODEC (CAR M))))))
;			    T))
;	 (TERPRI))
;      (RETURN '$DONE)))

;(DEFMFUN $POISDIFF (P M)
;  (DECLARE (SPECIAL M)) 
;   (COND ((MEMQ M '($U $V $W $X $Y $Z))
;	  (LIST (CAR P)
;		(COSDIF (CADDR P) M)
;		(SINDIF (CADR P) M)))
;	 (T (LIST (CAR P)
;		  (POISDIF4 (CADR P))
;		  (POISDIF4 (CADDR P))))))

;(DEFUN POISDIF4 (Y)
;  (declare (special m))
;   (COND ((NULL Y) NIL)
;	 (T (TCONS3 (CAR Y)
;		    (POISCODIF (CADR Y) M)
;		    (POISDIF4 (CDDR Y)))))) 

;(DEFUN COSDIF (H M)
;   (COND ((NULL H) NIL)
;	 (T (TCONS (CAR H)
;		   (CONS (POISCO* (INTOPOISCO (MINUS (POISXCOEF (CAR H) M))) (CADR H))
;			 (COSDIF (CDDR H) M))))))

;(DEFUN SINDIF (H M)
;   (COND ((NULL H) NIL)
;	 (T (TCONS (CAR H)
;		   (CONS (POISCO* (INTOPOISCO (POISXCOEF (CAR H) M)) (CADR H))
;			 (SINDIF (CDDR H) M)))))) 

;(DEFUN POISXCOEF (H M)
;   (DIFFERENCE
;      (REMAINDER (QUOTIENT H (EXPT POISTS
;				   (CADR (MEMQ M '($U 0 $V 1 $W 2 $X 3 $Y 4 $Z 5)))))
;		 POISTS)
;      POISTSM))

(DEFUN NONPERIOD (P)
   (AND (NULL (CADR P))
	(EQUAL (CAADDR P) POISHIFT)
	(NULL (CDDR (CADDR P))))) 

(DECLARE-top (SPECIAL ANS)) 

;(MACRO KEY  (L) (CONS 'CAR (CDR L))) 

;(MACRO LLINK  (L) (CONS 'CAADR (CDR L))) 

;(MACRO RLINK  (L) (CONS 'CDADR (CDR L))) 

;(MACRO BP  (L) (CONS 'CADDR (CDR L))) 

;(MACRO REC  (L) (CONS 'CDDDR (CDR L))) 

;(MACRO ORDER<  (L) (CONS 'LESSP (CDR L))) 

;(MACRO ORDER=  (L) (CONS 'EQUAL (CDR L))) 

;(MACRO SETRLINK  (L) (LIST 'RPLACD (LIST 'CADR (CADR L)) (CADDR L))) 

;(MACRO SETLLINK  (L) (LIST 'RPLACA (LIST 'CADR (CADR L)) (CADDR L))) 

;(MACRO SETBP  (L) (LIST 'RPLACA (LIST 'CDDR (CADR L)) (CADDR L))) 

;(MACRO SETREC  (L) (LIST 'RPLACD (LIST 'CDDR (CADR L)) (CADDR L))) 

;(DEFUN INSERT-IT (PP NEWREC) (SETREC PP (POISCO+ (REC PP) NEWREC))) 

;(DEFUN AVLINSERT (K NEWREC HEAD)
; (PROG (QQ TT SS PP RR)
;     (SETQ TT HEAD)
;     (SETQ SS (SETQ PP (RLINK HEAD)))
; A2  (COND ((ORDER< K (KEY PP)) (GO A3))
;	   ((ORDER< (KEY PP) K) (GO A4))
;	   (T (INSERT-IT PP NEWREC) (RETURN HEAD)))
; A3  (SETQ QQ (LLINK PP))
;     (COND ((NULL QQ)
;	    (SETLLINK PP (CONS K (CONS (NCONS NIL) (CONS 0 NEWREC))))
;	    (GO A6))
;	   ((ORDER= 0 (BP QQ)) NIL)
;	   (T (SETQ TT PP SS QQ)))
;     (SETQ PP QQ)
;     (GO A2)
; A4  (SETQ QQ (RLINK PP))
;     (COND ((NULL QQ)
;	    (SETRLINK PP (CONS K (CONS (NCONS NIL) (CONS 0 NEWREC))))
;	    (GO A6))
;	   ((ORDER= 0 (BP QQ)) NIL)
;	   (T (SETQ TT PP SS QQ)))
;     (SETQ PP QQ)
;     (GO A2)
; A6  (COND ((ORDER< K (KEY SS)) (SETQ RR (SETQ PP (LLINK SS))))
;	   (T (SETQ RR (SETQ PP (RLINK SS)))))
; A6LOOP
;     (COND ((ORDER< K (KEY PP)) (SETBP PP -1) (SETQ PP (LLINK PP)))
;	   ((ORDER< (KEY PP) K) (SETBP PP 1) (SETQ PP (RLINK PP)))
;	   ((ORDER= K (KEY PP)) (GO A7)))
;     (GO A6LOOP)
; A7  (COND ((ORDER< K (KEY SS)) (GO A7L)) (T (GO A7R)))
; A7L (COND ((ORDER= 0 (BP SS)) (SETBP SS -1) (SETLLINK HEAD (f1+ (LLINK HEAD))) (RETURN HEAD))
;	   ((ORDER= (BP SS) 1) (SETBP SS 0) (RETURN HEAD)))
;     (COND ((ORDER= (BP RR) -1) NIL)
;	   (T (GO A9L)))
;     (SETQ PP RR)
;     (SETLLINK SS (RLINK RR))
;     (SETRLINK RR SS)
;     (SETBP SS 0)
;     (SETBP RR 0)
;     (GO A10)
; A9L (SETQ PP (RLINK RR))
;     (SETRLINK RR (LLINK PP))
;     (SETLLINK PP RR)
;     (SETLLINK SS (RLINK PP))
;     (SETRLINK PP SS)
;     (COND ((ORDER= (BP PP) -1) (SETBP SS 1) (SETBP RR 0))
;	   ((ORDER= (BP PP) 0) (SETBP SS 0) (SETBP RR 0))
;	   ((ORDER= (BP PP) 1) (SETBP SS 0) (SETBP RR -1)))
;     (SETBP PP 0)
;     (GO A10)
; A7R (COND ((ORDER= 0 (BP SS)) (SETBP SS 1) (SETLLINK HEAD (f1+ (LLINK HEAD))) (RETURN HEAD))
;	   ((ORDER= (BP SS) -1) (SETBP SS 0) (RETURN HEAD)))
;     (COND ((ORDER= (BP RR) 1) NIL)
;	   (T (GO A9R)))
;     (SETQ PP RR)
;     (SETRLINK SS (LLINK RR))
;     (SETLLINK RR SS)
;     (SETBP SS 0)
;     (SETBP RR 0)
;     (GO A10)
; A9R (SETQ PP (LLINK RR))
;     (SETLLINK RR (RLINK PP))
;     (SETRLINK PP RR) 
;     (SETRLINK SS (LLINK PP))
;     (SETLLINK PP SS)
;     (COND ((ORDER= (BP PP) 1) (SETBP SS -1) (SETBP RR 0))
;	   ((ORDER= (BP PP) 0) (SETBP SS 0) (SETBP RR 0))
;	   ((ORDER= (BP PP) -1) (SETBP SS 0) (SETBP RR 1)))
;     (SETBP PP 0)
; A10 (COND ((EQ SS (RLINK TT)) (SETRLINK TT PP))
;	   (T (SETLLINK TT PP)))
;     (RETURN HEAD))) 

;(DEFUN AVLINIT (KEY REC)
;   (CONS 'TOP (CONS (CONS 0 (CONS KEY (CONS (NCONS NIL) (CONS 0 REC))))
;		    (CONS 0 NIL)))) 

;(DEFUN UNTREE (H)
;   (PROG (ANS)
;     (UNTREE1 (RLINK H))
;     (RETURN ANS))) 

;(DEFUN UNTREE1 (H)
;   (COND ((NULL H) ANS)
;	 ((NULL (RLINK H))
;	  (SETQ ANS (TCONS3 (KEY H) (REC H) ANS))
;	  (UNTREE1 (LLINK H)))
;	 (T (SETQ ANS (TCONS3 (KEY H) (REC H) (UNTREE1 (RLINK H))))
;	    (UNTREE1 (LLINK H))))) 

;(DEFUN TCONS3 (R S TT)
;   (COND ((POISPZERO S) TT)
;	 (T (CONS R (CONS S TT))))) 

;(DEFUN POISMERGES (A AE L)
;   (COND ((EQUAL POISHIFT AE) L)
;	 ((POISNEGPRED AE) (POISMERGE (POISCO* POISCOM1 A)
;				      (POISCHANGESIGN AE) L))
;	 (T (POISMERGE A AE L)))) 

;(DEFUN POISMERGEC (A AE L)
;   (COND ((POISNEGPRED AE) (POISMERGE A (POISCHANGESIGN AE) L))
;	 (T (POISMERGE A AE L)))) 

;(DEFUN POISMERGE (A AE L)
;       (COND ((POISPZERO A) NIL)
;	     (T (MERGE11 A AE L)))) 

;(DEFUN POISMERGE2 (R S)
;   (COND ((NULL R) S)
;	 ((NULL S) R)
;	 (T (PROG (M N TT)
;	      (SETQ M (SETQ N (CONS 0 R)))
;	 A    (COND ((NULL R) (RPLACD M S) (RETURN (CDR N)))
;		    ((NULL S) (RETURN (CDR N)))
;		    ((EQUAL (CAR R) (CAR S))
;		       (SETQ TT (POISCO+ (CADR R) (CADR S)))
;		       (COND ((POISPZERO TT)
;			      (RPLACD M (CDDR R))
;			      (SETQ R (CDDR R) S (CDDR S)))
;			     (T (RPLACA (CDR R) TT)
;				(SETQ S (CDDR S) R (CDDR R) M (CDDR M)))))
;		    ((GREATERP (CAR R) (CAR S))
;		       (RPLACD M S)
;		       (SETQ S (CDDR S))
;		       (RPLACD (CDDR M) R)
;		       (SETQ M (CDDR M)))
;		    (T (SETQ R (CDDR R))
;		       (SETQ M (CDDR M))))
;	      (GO A))))) 

;(DEFUN MERGE11 (A AE L)
;       (POISMERGE2 (LIST AE A) L)) 

;(DEFUN POISMERGESX (A AE L)
;   (COND ((EQUAL POISHIFT AE) L)
;	 ((POISNEGPRED AE)
;	  (AVLINSERT (POISCHANGESIGN AE)
;		     (POISCO* POISCOM1 A)
;		     L))
;	 (T (AVLINSERT AE A L)))) 

;(DEFUN POISMERGECX (A AE L)
;   (COND ((POISNEGPRED AE)
;	  (AVLINSERT (POISCHANGESIGN AE) A L))
;	 (T (AVLINSERT AE A L)))) 

(DECLARE-TOP (SPECIAL TRIM POISCOM1 POISHIFT)) 
;(DEFUN POISCTIMES1 (C H)
;   (COND ((NULL H) NIL)
;	 ((AND TRIM (TRIMF (CAR H))) (POISCTIMES1 C (CDDR H)))
;	 (T (TCONS (CAR H)
;		   (CONS (POISCO* C (CADR H))
;			 (POISCTIMES1 C (CDDR H))))))) 

;(DEFUN TRIMF (M)
;   (MEVAL (LIST '($POISTRIM) (POISXCOEF M '$U) (POISXCOEF M '$V)
;		(POISXCOEF M '$W) (POISXCOEF M '$X) (POISXCOEF M '$Y) (POISXCOEF M '$Z)))) 

;(DEFMFUN $POISTIMES (A B) 
;       (PROG (SLC CLC TEMP AE AA ZERO TRIM T1 T2 F1 F2) 
;             (SETQ A (INTOPOIS A) B (INTOPOIS B))
;             (COND ((OR (GETL '$POISTRIM '(EXPR SUBR)) (MGET '$POISTRIM 'MEXPR))
;                    (SETQ TRIM T)))
;             (COND ((NONPERIOD A) (RETURN ($POISCTIMES (CADR (CADDR A)) B)))
;                   ((NONPERIOD B) (RETURN ($POISCTIMES (CADR (CADDR B)) A))))
;             (SETQ SLC (AVLINIT POISHIFT (SETQ ZERO (INTOPOISCO 0.))))
;	     (SETQ CLC (AVLINIT POISHIFT ZERO))
;             ;; PROCEED THROUGH ALL THE SINES IN ARGUMENT A
;             (DO SLA
;                 (CADR A)
;                 (CDDR SLA)
;                 (NULL SLA)
;                 (SETQ AA (HALVE (CADR SLA)) AE (CAR SLA))
;                 ;; SINE(U)*SINE(V) ==> (-COSINE(U+V) + COSINE(U-V))/2
;                 (DO SLB
;                     (CADR B)
;                     (CDDR SLB)
;                     (NULL SLB)
;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
;			   T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
;		     (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
;			   (T (SETQ F1 NIL F2 NIL)))
;                            (SETQ TEMP (POISCO* AA (CADR SLB)))
;                              (COND ((POISPZERO TEMP) NIL)
;                                    (T (OR F1 (POISMERGECX TEMP T1 CLC))
;                                       (OR F2 (POISMERGECX (POISCO* POISCOM1 TEMP) T2 CLC)))))
;                 ;; SINE*COSINE ==> SINE + SINE
;                 (DO CLB
;                     (CADDR B)
;                     (CDDR CLB)
;                     (NULL CLB)
;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB)))
;			   T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
;		     (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
;			   (T (SETQ F1 NIL F2 NIL)))
;                      (SETQ TEMP (POISCO* AA (CADR CLB)))
;                        (COND ((POISPZERO TEMP) NIL)
;                              (T (OR F1 (POISMERGESX TEMP T1 SLC))
;				 (OR F2 (POISMERGESX TEMP T2 SLC))))))
;             ;; PROCEED THROUGH ALL THE COSINES IN ARGUMENT A
;             (DO CLA
;                 (CADDR A)
;                 (CDDR CLA)
;                 (NULL CLA)
;                 (SETQ AA (HALVE (CADR CLA)) AE (CAR CLA))
;                 ;; COSINE*SINE ==> SINE - SINE
;                 (DO SLB
;                     (CADR B)
;                     (CDDR SLB)
;                     (NULL SLB)
;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB))))
;		     (SETQ T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
;		     (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
;			   (T (SETQ F1 NIL F2 NIL)))
;		     (SETQ TEMP (POISCO* AA (CADR SLB)))
;		     (COND ((POISPZERO TEMP) NIL)
;			   (T (OR F1 (POISMERGESX (POISCO* POISCOM1 TEMP) T1 SLC))
;			      (OR F2 (POISMERGESX TEMP T2 SLC)))))
;		 ;; COSINE*COSINE ==> COSINE + COSINE
;                 (DO CLB
;                     (CADDR B)
;                     (CDDR CLB)
;                     (NULL CLB)
;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB))))
;		     (SETQ T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
;		     (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
;			   (T (SETQ F1 NIL F2 NIL)))
;		     (SETQ TEMP (POISCO* AA (CADR CLB)))
;		     (COND ((POISPZERO TEMP) NIL)
;			   (T (OR F1 (POISMERGECX TEMP T1 CLC))
;			      (OR F2 (POISMERGECX TEMP T2 CLC))))))
;             (RETURN (LIST '(MPOIS SIMP) (UNTREE SLC) (UNTREE CLC)))))

;(DEFMFUN $POISEXPT (P N) 
;       (PROG (U H) 
;	     (COND ((ODDP N) (SETQ U P)) (T (SETQ U (SETQ H (INTOPOIS 1.)))))
;	A    (SETQ N (LSH N -1.))
;	     (COND ((ZEROP N) (RETURN U)))
;	     (setq p ($POISTIMES P P))
;	     (COND ((ODDP N) (SETQ U (COND ((EQUAL U H) P) (T ($POISTIMES U P))))))
;	     (GO A))) 

;(DEFMFUN $POISSQUARE (A) ($POISEXPT A 2))

;(DEFMFUN $POISINT (P M)
;  (DECLARE (SPECIAL M)) 
;   (PROG (B*)
;     (SETQ P (INTOPOIS P))
;     (COND ((MEMQ M '($U $V $W $X $Y $Z))
;	    (RETURN (LIST (CAR P) (COSINT* (CADDR P) M) (SININT* (CADR P) M))))
;	   (T (RETURN (LIST (CAR P) (POISINT4 (CADR P)) (POISINT4 (CADDR P)))))))) 

;(DEFUN POISINT4 (Y)
;  (DECLARE (SPECIAL M)) 
;   (COND ((NULL Y) NIL)
;	 (T (TCONS3 (CAR Y)
;		    (POISCOINTEG (CADR Y) M)
;		    (POISINT4 (CDDR Y)))))) 

;(DEFUN COSINT* (H M)
;   (COND ((NULL H) NIL)
;	 ((EQUAL 0 (SETQ B* (POISXCOEF (CAR H) M)))
;	  (COSINT* (CDDR H) M))
;	 (T (TCONS (CAR H)
;		   (CONS (POISCO* (INTOPOISCO (LIST '(MEXPT) B* -1)) (CADR H))
;			 (COSINT* (CDDR H) M)))))) 

;(DEFUN SININT* (H M)
;   (COND ((NULL H) NIL)
;	 ((EQUAL 0 (SETQ B* (POISXCOEF (CAR H) M)))
;	  (SININT* (CDDR H) M))
;	 (T (TCONS (CAR H)
;		   (CONS (POISCO* (INTOPOISCO (LIST '(MEXPT) (MINUS (POISXCOEF (CAR H) M)) -1))
;				  (CADR H))
;			 (SININT* (CDDR H) M)))))) 

;(DEFUN POISSUBSTA (A B* C)
;   (PROG (SS CC)
;      (SETQ H* (DIFFERENCE (POISENCODE (LIST '(MPLUS) A (LIST '(MTIMES) -1 B*))) POISHIFT))
;      (POISSUBST1S (CADR C))
;      (POISSUBST1C (CADDR C))
;      (RETURN (LIST (CAR C) SS CC)))) 

;(DEFUN POISSUBST1S (C)
;   (COND ((NULL C) NIL)
;	 (T (SETQ SS (POISMERGES (CADR C) (ARGSUBST (CAR C)) SS))
;	    (POISSUBST1S (CDDR C))))) 

;(DEFUN POISSUBST1C (C)
;   (COND ((NULL C) NIL)
;	 (T (SETQ CC (POISMERGEC (CADR C) (ARGSUBST (CAR C)) CC))
;	    (POISSUBST1C (CDDR C))))) 

;(DEFUN ARGSUBST (C)
;       (PLUS C (TIMES H* (POISXCOEF C B*)))) 

;(DEFMFUN $POISSUBST N
;   (COND ((NOT (OR (EQUAL N 3) (EQUAL N 5)))
;	  (merror "WRONG NUMBER OF ARGS TO POISSUBST"))
;	 ((EQUAL N 5)
;	  (FANCYPOISSUBST (ARG 1) (ARG 2) (INTOPOIS (ARG 3)) (INTOPOIS (ARG 4)) (ARG 5)))
;	 (T ((LAMBDA (A* B* C)
;		 (COND ((MEMQ B* '($U $V $W $X $Y $Z)) (POISSUBSTA A* B* C))
;		       (T (LIST (CAR C) (POISSUBSTCO1 (CADR C)) (POISSUBSTCO1 (CADDR C))))))
;	       (ARG 1) (ARG 2) (INTOPOIS (ARG 3)))))) 

;(DEFUN POISSUBSTCO1 (C)
;   (COND ((NULL C) NIL)
;	 (T (TCONS (CAR C)
;		   (CONS (POISSUBSTCO A* B* (CADR C))
;			 (POISSUBSTCO1 (CDDR C))))))) 

(DECLARE-TOP (SPECIAL DC DS *ANS)) 
;(DEFUN FANCYPOISSUBST (A B* C D N)
;   (PROG (H* DC DS *ANS)
;     (SETQ *ANS (LIST '(MPOIS SIMP) NIL NIL)
;	   D (INTOPOIS D)
;	   DC (INTOPOIS 1)
;	   DS (INTOPOIS 0))
;     (COND ((EQUAL N 0) (RETURN ($POISSUBST A B* C))))
;     (FANCYPOIS1S D 1 1 N)
;     (SETQ H* (DIFFERENCE (POISENCODE (LIST '(MPLUS) A (LIST '(MTIMES) -1 B*))) POISHIFT))
;     (FANCYPAS (CADR C))
;     (FANCYPAC (CADDR C))
;     (RETURN *ANS))) 

;(DEFUN FANCYPOIS1S (D DP N LIM)
;   (COND ((GREATERP N LIM) NIL)
;	 (T (SETQ DS ($POISPLUS DS
;				($POISCTIMES (LIST '(RAT)
;						   (EXPT -1 (QUOTIENT (SUB1 N) 2))
;						   (FACTORIAL N))
;					     (SETQ DP ($POISTIMES DP D)))))
;	    (FANCYPOIS1C D DP (f1+ N) LIM))))

;(DEFUN FANCYPOIS1C (D DP N LIM)
;   (COND ((GREATERP N LIM) NIL)
;	 (T (SETQ DC ($POISPLUS DC
;				($POISCTIMES (LIST '(RAT)
;						   (EXPT -1 (QUOTIENT N 2))
;						   (FACTORIAL N))
;					     (SETQ DP ($POISTIMES DP D)))))
;	    (FANCYPOIS1S D DP (f1+ N) LIM))))

(DECLARE-TOP (SPECIAL *ARGC *COEF)) 
;(DEFUN FANCYPAC (C)
;   (PROG ()
;     (COND ((NULL C) (RETURN NIL)))
;     (SETQ *COEF (POISXCOEF (CAR C) B*))
;     (COND ((EQUAL *COEF 0)
;	    (SETQ *ANS ($POISPLUS *ANS (LIST '(MPOIS SIMP) NIL (LIST (CAR C) (CADR C)))))
;	    (GO END)))
;     (COND ((POISPZERO (SETQ *COEF (POISCO* (CADR C) (INTOPOISCO *COEF)))) (GO END)))
;     (SETQ *ARGC (ARGSUBST (CAR C)))
;     (SETQ *ANS ($POISPLUS *ANS
;			   ($POISPLUS ($POISTIMES (LIST '(MPOIS SIMP)
;							NIL
;							(POISMERGEC *COEF *ARGC NIL))
;						  DC)
;				      ($POISTIMES (LIST '(MPOIS SIMP)
;							(POISMERGES (POISCO* POISCOM1 *COEF)
;								    *ARGC
;								    NIL)
;							NIL)
;						  DS))))
; END (FANCYPAC (CDDR C))))

;(DEFUN FANCYPAS (C)
;   (PROG ()
;     (COND ((NULL C) (RETURN NIL)))
;     (SETQ *COEF (POISXCOEF (CAR C) B*))
;     (COND ((EQUAL *COEF 0)
;	    (SETQ *ANS ($POISPLUS *ANS (LIST '(MPOIS SIMP) (LIST (CAR C) (CADR C)) NIL)))
;	    (GO END)))
;     (COND ((POISPZERO (SETQ *COEF (POISCO* (CADR C) (INTOPOISCO *COEF))))
;	    (GO END)))
;     (SETQ *ARGC (ARGSUBST (CAR C)))
;     (SETQ *ANS ($POISPLUS *ANS
;			   ($POISPLUS ($POISTIMES (LIST '(MPOIS SIMP)
;							NIL
;							(POISMERGEC *COEF *ARGC NIL))
;						  DS)
;				      ($POISTIMES (LIST '(MPOIS SIMP)
;							(POISMERGES *COEF *ARGC NIL)
;							NIL)
;						  DC))))
; END (FANCYPAS (CDDR C)))) 

;; On the VAX, this should be smaller than on the 10.

(POISLIM1 NIL #-Franz 5 #+Franz 4)

;(DEFUN POISCDECODE (X) X) 

;(DEFUN INTOPOISCO (X) (SIMPLIFYA X NIL)) 

;(DEFUN POISCO+ (R S) (SIMPLIFYA (LIST '(MPLUS) R S) NIL)) 

;(DEFUN POISCO* (R S) (SIMPLIFYA (LIST '(MTIMES) R S) NIL)) 

;(DEFUN HALVE (R) (SIMPLIFYA (LIST '(MTIMES) '((RAT) 1 2) R) NIL)) 

;(DEFUN POISSUBSTCO (A B C) (MAXIMA-SUBSTITUTE A B C)) 

;(DEFUN POISCODIF (H VAR) ($DIFF H VAR)) 

;(DEFUN POISCOINTEG (H VAR) (INTOPOISCO ($INTEGRATE (POISCDECODE H) VAR))) 

;(DEFUN POISPZERO (X) (ZEROP1 X)) 

(SETQ POISCO1 1 POISCOM1 -1) 

;(COMMENT

; (DECLARE-TOP (SPECIAL SLCX CLCX LASTPTR TRIM POISCOM1 POISHIFT CLC SLC CLCPTR SLCPTR))
 
; (DEFUN POISMERGE2K (S R)
;   (COND ((NULL R) (SETQ LASTPTR S))
;	 ((NULL S) (SETQ LASTPTR R))
;	 (T (PROG (M N TT)
;		  (SETQ M (SETQ N (CONS 0 R)))
;		A (COND ((NULL R) (RPLACD M S) (SETQ LASTPTR S) (RETURN (CDR N)))
;			((NULL S) (SETQ LASTPTR R) (RETURN (CDR N)))
;			((EQUAL (CAR R) (CAR S))
;			 (SETQ TT (POISCO+ (CADR R) (CADR S)))
;			 (COND ((POISPZERO TT) (RPLACD M (CDDR R))
;					       (SETQ R (CDDR R) S (CDDR S)))
;			       (T (RPLACA (CDR R) TT)
;				  (SETQ S (CDDR S) R (CDDR R) M (CDDR M)))))
;			((GREATERP (CAR R) (CAR S))
;			 (RPLACD M S) (SETQ S (CDDR S))
;			 (RPLACD (CDDR M) R) (SETQ M (CDDR M)))
;			(T (SETQ R (CDDR R)) (SETQ M (CDDR M))))
;		  (GO A)))))
 
; (DEFUN POISMERGESQ (A AE L)
;	(SETQ SLCX
;	      (COND ((EQUAL POISHIFT AE) L)
;		    ((POISNEGPRED AE) (POISMERGE (POISCO* POISCOM1 A) (POISCHANGESIGN AE) L))
;		    (T (POISMERGE A AE L)))))
 
; (DEFUN POISMERGECQ (A AE L)
;     (SETQ CLCX (COND ((POISNEGPRED AE) (POISMERGE A (POISCHANGESIGN AE) L))
;		      (T (POISMERGE A AE L)))))
 
; (DEFUN POISMERGESY (A AE L)
;     (SETQ SLC
;	   (COND ((EQUAL POISHIFT AE) L)
;		 ((POISNEGPRED AE) (POISMERGESY1 (POISCO* POISCOM1 A) (POISCHANGESIGN AE) L))
;		 (T (POISMERGESY1 A AE L)))))
  
; (DEFUN POISMERGECY (A AE L)
;     (SETQ CLC (COND ((POISNEGPRED AE) (POISMERGECY1 A (POISCHANGESIGN AE) L))
;		     (T (POISMERGECY1 A AE L)))))
  
; (DEFUN POISMERGECY1 (A AE L)
;     (COND ((POISPZERO A) NIL)
;	   ((OR (NULL CLCPTR) (LESSP AE (CAR CLCPTR)))
;	      (SETQ CLC (POISMERGE2K (LIST AE A) L)) (SETQ CLCPTR LASTPTR))
;	   (T (POISMERGE2K (LIST AE A) CLCPTR) (SETQ CLCPTR LASTPTR)))
;     CLC)
  
; (DEFUN POISMERGESY1 (A AE L)
;     (COND ((POISPZERO A) NIL)
;	   ((OR (NULL SLCPTR) (LESSP AE (CAR SLCPTR)))
;	      (SETQ SLC (POISMERGE2K (LIST AE A) L)) (SETQ SLCPTR LASTPTR))
;	   (T (POISMERGE2K (LIST AE A) SLCPTR) (SETQ SLCPTR LASTPTR)))
;     SLC)
  
; (DEFMFUN $POISTIMESL (A B)
;    (PROG (SLC SLCPTR CLC CLCPTR TEMP AE AA TRIM T1 T2 F1 F2 LASTPTR SLCX CLCX)
;	(SETQ A (INTOPOIS A) B (INTOPOIS B))
;	(COND ((OR (GETL '$POISTRIM '(EXPR SUBR)) (MGET '$POISTRIM 'MEXPR)) (SETQ TRIM T)))
;	(COND ((NONPERIOD A) (RETURN ($POISCTIMES (CADR (CADDR A)) B)))
;	      ((NONPERIOD B) (RETURN ($POISCTIMES (CADR (CADDR B)) A))))
;	(SETQ SLCPTR SLC CLCPTR CLC CLCX NIL SLCX NIL)
;	(DO SLA (CADR A) (CDDR SLA) (NULL SLA)
;	  (SETQ AA (HALVE (CADR SLA)) AE (CAR SLA))
;	  (DO SLB (CADR B) (CDDR SLB) (NULL SLB)
;	    (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
;		  T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
;	    (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
;		  (T (SETQ TEMP (POISCO* AA (CADR SLB)))
;		     (COND ((POISPZERO TEMP) NIL)
;			   (T (OR F1 (POISMERGECQ TEMP T1 CLCX))
;			      (OR F2 (POISMERGECY (POISCO* POISCOM1 TEMP) T2 CLC)))))))
;	  (DO CLB (CADDR B) (CDDR CLB) (NULL CLB)
;	    (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB)))
;		  T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
;	    (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
;		  (T (SETQ TEMP (POISCO* AA (CADR CLB)))
;		     (COND ((POISPZERO TEMP) NIL) (T (OR F1 (POISMERGESQ TEMP T1 SLCX))
;						     (OR F2 (POISMERGESY TEMP T2 SLC))))))))
;	(SETQ CLC (POISMERGE2 CLC CLCX) SLC (POISMERGE2 SLC SLCX))
;	(SETQ SLCPTR SLC CLCPTR CLC SLCX NIL CLCX NIL)
;	(DO CLA (CADDR A) (CDDR CLA) (NULL CLA)
;	  (SETQ AA (HALVE (CADR CLA)) AE (CAR CLA))
;	  (DO SLB (CADR B) (CDDR SLB) (NULL SLB)
;	    (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
;		  T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
;	    (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
;		  (T (SETQ TEMP (POISCO* AA (CADR SLB)))
;		     (COND ((POISPZERO TEMP) NIL)
;			   (T (OR F1 (POISMERGESQ (POISCO* POISCOM1 TEMP) T1 SLCX))
;			      (OR F2 (POISMERGESY TEMP T2 SLC)))))))
;	  (DO CLB (CADDR B) (CDDR CLB) (NULL CLB)
;	    (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB)))
;		  T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
;	    (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
;		  (T (SETQ TEMP (POISCO* AA (CADR CLB)))
;		     (COND ((POISPZERO TEMP) NIL) (T (OR F1 (POISMERGECQ TEMP T1 CLCX))
;						     (OR F2 (POISMERGECY TEMP T2 CLC))))))))
;	(SETQ CLC (POISMERGE2 CLC CLCX) SLC (POISMERGE2 SLC SLCX))
;	(RETURN (LIST '(MPOIS SIMP) SLC CLC))))

;) ;End of commented out code