;;; -*-  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 pois3)

;; GENERAL POISSON SERIES

(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 FUMCHECK (X)
   (NOT (AND (ATOM X) (INTEGERP X) (LESSP (ABS X) POISTSM))))

(DEFUN CHECKENCODE(R)
  (PROG(Q)
       (SETQ Q ($COEFF R '$U))
       (COND ((FUMCHECK Q) (RETURN NIL))
	     (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1  '$U Q)) NIL))))
       (SETQ Q ($COEFF R '$V))
       (COND ((FUMCHECK Q)(RETURN NIL))
	     (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1  '$V Q)) NIL))))
       (SETQ Q ($COEFF R '$W))
       (COND ((FUMCHECK Q)(RETURN NIL))
	     (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1  '$W Q)) NIL))))
       (SETQ Q ($COEFF R '$X))
       (COND ((FUMCHECK Q)(RETURN NIL))
	     (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1  '$X Q)) NIL))))
       (SETQ Q ($COEFF R '$Y))
       (COND ((FUMCHECK Q)(RETURN NIL))
	     (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1  '$Y Q)) NIL))))
       (SETQ Q ($COEFF R '$Z))
       (COND ((FUMCHECK Q)(RETURN NIL))
	     (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1  '$Z Q)) NIL))))
       (COND ((EQUAL R 0)(RETURN T))
	     (T (RETURN NIL)))))

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

;;;********

(DECLARE-TOP(FIXNUM AE POISHIFT POISTSM POISSIZ POISTS))
;; ABOVE ASSUMES POISLIM(5) OR LESS ALSO REDEFINE ORDER< AND ORDER= TO BE < AND =

;;; THIS TELLS THE EVALUATOR TO KEEP OUT OF POISSON $SERIES.

(DEFPROP MPOIS (LAMBDA (X) X) MFEXPR*) 

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

(DECLARE-TOP (SPECIAL $U $V $W $X $Y $Z)) 

(DEFUN POISENCODE (H*)					;
   (COND ((NOT (CHECKENCODE H*))
	  (merror "Illegal arg to POISSIMP:~%~M" H*)))
   (APPLY #'(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))

(PROG (N)
      (SETQ N 5)
      (SETQ POISVALS NIL)
      (SETQ POISTS (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) 
       (PROG (ARG H) 
	     (SETQ H M)
	     (SETQ ARG (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$U))
	     (SETQ H (QUOTIENT H POISTS))
	     (SETQ ARG
		   (LIST '(MPLUS)
			 ARG
			 (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$V)))
	     (SETQ H (QUOTIENT H POISTS))
	     (SETQ ARG
		   (LIST '(MPLUS)
			 ARG
			 (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$W)))
	     (SETQ H (QUOTIENT H POISTS))
	     (SETQ ARG
		   (LIST '(MPLUS)
			 ARG
			 (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$X)))
	     (SETQ H (QUOTIENT H POISTS))
	     (SETQ ARG
		   (LIST '(MPLUS)
			 ARG
			 (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$Y)))
	     (SETQ H (QUOTIENT H POISTS))
	     (SETQ ARG
		   (LIST '(MPLUS)
			 ARG
			 (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$Z)))
	     (RETURN (SIMPLIFYA ARG NIL)))) 


;;; THIS PROGRAM MULTIPLIES A POISSON SERIES P BY A NON-SERIES, C,
;;; WHICH IS FREE OF SINES AND COSINES .

(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 SINES
	     (DO ((M
		 (CADR P)
		 (CDDR M)))(
		 (NULL M))
		 (SETQ ANS (CONS (LIST '(MTIMES)
				       (POISCDECODE (CADR M))
				       (LIST '(%SIN) (POISDECODEC (CAR M))))
				 ANS)))

	     ;; DO COSINES
	     (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 NIL 
	     (SETQ P (INTOPOIS P))

	     ;; DO SINES
	     (DO ((M
		 (CADR P)
		 (CDDR M)))(
		 (NULL M))
		 (DISPLA (SIMPLIFYA (LIST '(MTIMES)
					  (POISCDECODE (CADR M))
					  (LIST '(%SIN) (POISDECODEC (CAR M))))
				    T))
		 (TERPRI))

	     ;; DO COSINES
	     (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))) 


;;; $POISDIFF DIFFERENTIATES A POISSON SERIES WRT X, Y, Z, U, V, W, OR A COEFF VAR.


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

 


;;; COSDIF DIFFERENTIATES COSINES TO GET SINES

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




;;; AVL BALANCED TREE SEARCH AND INSERTION.
;;; NODE LOOKS LIKE (KEY (LLINK .  RLKINK) BALANCEFACTOR .  RECORD)
;;; PROGRAM FOLLOWS ALGORITHM GIVEN IN KNUTH VOL. 3 455-57

(DECLARE-TOP (SPECIAL ANS)) 


;; MACROS TO EXTRACT FIELDS FROM NODE

(defMACRO KEY  (&rest L) (CONS 'CAR L)) 

(defMACRO LLINK  (&rest L) (CONS 'CAADR L)) 

(defMACRO RLINK  (&rest L) (CONS 'CDADR L)) 

(defMACRO BP  (&rest L) (CONS 'CADDR L)) 

(defMACRO REC  (&rest L) (CONS 'CDDDR L)) 


;;  FOR ORDERING KEYS

(defMACRO ORDER<  (&rest L) (CONS '<  L))
(defMACRO ORDER=  (&rest L) (CONS '=  L))

;; MACROS TO SET FIELDS IN NODE

(defMACRO SETRLINK  (&rest L) (setq l (cons nil l))
  (LIST 'RPLACD (LIST 'CADR (CADR L)) (CADDR L))) 

(defMACRO SETLLINK  (&rest L) (setq l (cons nil l))
  (LIST 'RPLACA (LIST 'CADR (CADR L)) (CADDR L))) 

(defMACRO SETBP  (&rest L) (setq l (cons nil l))
  (LIST 'RPLACA (LIST 'CDDR (CADR L)) (CADDR L))) 

(defMACRO SETREC  (&rest L)(setq l (cons nil 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 (CONS NIL 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 (CONS NIL 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 (CONS NIL NIL) (CONS 0. REC)))) (CONS 0. NIL)))) 


;; UNTREE CONVERTS THE TREE TO A LIST WHICH LOOKS LIKE ( SmALLEST-KEY RECORD NEXT-SMALLEST-KEY RECORD ....  LARGEST-KEY
;;RECORD)

(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)				       ; SINE(0) IS 0
	     ((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)				       ; SINE(0) IS 0
	     ((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-FUN '$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.))) 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))) T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))(cond(trim(setq f1(trimf t1) f2 (trimf t2)))
(t (setq f1 nil f2 nil))
)
                     (COND 
                           (T (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))) T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))(cond(trim(setq f1(trimf t1) f2 (trimf t2)))
(t (setq f1 nil f2 nil))
)
                     (COND 
                           (T (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))


;;; $POISINT INTEGRATES A POISSON SERIES WRT X,Y, Z, U, V, W.  THE VARIABLE OF
;;; INTEGRATION MUST OCCUR ONLY IN THE ARGUMENTS OF SIN OR COS,
;;; OR ONLY IN THE COEFFICIENTS.  POISCOINTEG IS CALLED TO INTEGRATE COEFFS.

;;; NON-PERIODIC TERMS ARE REMOVED.

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

;;;COSINT* INTEGRATES COSINES TO GET SINES

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


;;; $POISSUBST SUBSTITUTES AN EXPRESSION FOR A VARIABLE IN ARGUMENT OF TRIG FUNCTIONS OR
;;; COEFFICIENTS.

(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.)))))) 



(DECLARE-TOP (unSPECIAL $U $V $W $X $Y $Z)) 

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

       ;;SUBSTITUTES A+D FOR B IN C, WHERE D IS EXPANDED IN POWERSERIES TO ORDER 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) 				       ; DP IS LAST POWER: D^(N-1), LIM IS HIGHEST TO
       (COND ((GREATERP N LIM) NIL)				       ;GO
	     (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) 				       ; DP IS LAST POWER: D^(N-1), LIM IS HIGHEST TO
       (COND ((GREATERP N LIM) NIL)				       ;GO
	     (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)))) 


;;; COS(R+K*B) ==> K*COS(R+K*A)*DC - K*SIN(R+K*A)*DS
;;; SIN(R+K*B) ==> K*COS(R+K*A)*DS + K*SIN(R+K*A)*DC 

(DECLARE-TOP (SPECIAL *ARGC *COEF)) 

(DEFUN FANCYPAC (C) 
       (PROG NIL 
	     (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 NIL 
	     (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)))) 

								       ;ARGUMENT  DO NOT EXCEED 15 IN ABSOLUTE VALUE


;;; THESE ARE THE ONLY COEFFICIENT DEPENDENT ROUTINES. RATIONAL FORM IS
;;; DEFINED IN FILE RATPOI >.

;;; POISCDECODE DECODES A COEFFICIENT

(DEFUN POISCDECODE (X) X) 


;;; INTOPOISCO PUTS AN EXPRESSION INTO POISSON COEFFICIENT FORM

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


;;; POISCO+ ADDS 2 COEFFICIENTS

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


;;; POISCO* MULTIPLIES 2 COEFFICIENTS

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


;;; HALVE DIVIDES A COEFFICIENT BY 2

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


;;; POISSUBSTCO SUBSTITUTES AN EXPRESSION FOR A VARIABLE IN A COEFFICIENT.

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

;;; THIS DIFFERENTIATES A COEFFICIENT

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

;;; THIS INTEGRATES A COEFFICIENT
(DEFUN POISCOINTEG (H VAR)(INTOPOISCO($INTEGRATE (POISCDECODE H) VAR)))

;;; TEST FOR ZERO

(DEFUN POISPZERO (X) (ZEROP1 X)) 


;;; THE NUMBER 1 IN COEFFICIENT ARITHMETIC, THE NUMBER -1

(SETQ POISCO1 1. POISCOM1 -1.) 

 


;; THE FOLLOWING PROGRAMS FOLLOW THE SUGGESTIONS OF W.H.JEFFERYS, FOR
;; FASTER POISSON SERIES MULTIPLICATION THAN JUST STRAIGHT INSERTION.
;; THEY ARE NOT AS FAST AS THE AVL TREE INSERTION, HOWEVER.  WE KEEP
;; THEM HERE FOR THE RECORD.

;(COMMENT(DECLARE (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)			       ; SINE(0) IS 0
;		       ((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)			       ; SINE(0) IS 0
;		       ((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))))
;	       ;; PROCEED THROUGH ALL THE SINES IN ARGUMENT 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))
;		 ;; 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 ((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)))))))
;		 ;; 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 ((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))
	       
;	       ;; PROCEED THROUGH ALL THE COSINES IN ARGUMENT A
;	       (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))
;		 ;; COSINE*SINE ==> SINE - SINE
;		 (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)))))))
;		 ;; COSINE*COSINE ==> COSINE + COSINE
;		 (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)))) 
;)