Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-02 - decus/20-0039/int2.l
There are 2 other files named int2.l in the archive. Click here to see a list.
 	(DEFPROP P1E T SPECIAL)
(DEFPROP P2E T SPECIAL)
(DEFPROP A1E T SPECIAL)
(DEFPROP A2E T SPECIAL)
(DEFPROP A3E T SPECIAL)
(DEFPROP DISCRIM T SPECIAL)
(DEFPROP RNK T SPECIAL)
(DEFPROP NCC T SPECIAL)
(DEFPROP DCC T SPECIAL)
(DEFPROP ALLCC T SPECIAL)
(DEFPROP REPART T SPECIAL)
(DEFPROP SIGN T SPECIAL)
(DEFPROP FLIST T SPECIAL)
(DEFPROP ROOTFACTOR T SPECIAL)
(DEFPROP PARDENOM T SPECIAL)
(DEFPROP WHOLEPART T SPECIAL)
(DEFPROP PARNUMER T SPECIAL)
(DEFPROP LOGPTDX T SPECIAL)
(DEFPROP SWITCH1 T SPECIAL)
(DEFPROP VARLIST T SPECIAL)
(QUOTE (FILE MINTG))

(DEFPROP ROOTFAC
 (LAMBDA (Q)
  (PROG (NTHDQ NTHDQ1 SIMPROOTS ANS)
   (SETQ NTHDQ (POLGCD Q (POLDERIVATIVE Q)))
   (SETQ SIMPROOTS (PPQUOTIENT Q NTHDQ))
   (SETQ ANS
	 (LIST 
	 (PPQUOTIENT 
	  SIMPROOTS 
	   (POLGCD NTHDQ SIMPROOTS))))
   AMEN
   (COND ((NULL (CDR NTHDQ))
	 (RETURN (REV ANS))))
   (SETQ NTHDQ1 
	(POLGCD (POLDERIVATIVE  NTHDQ)
		NTHDQ))
   (SETQ ANS
	(CONS (PPQUOTIENT 
		(POLGCD NTHDQ SIMPROOTS)
		(POLGCD NTHDQ1 SIMPROOTS)) 
	ANS))
   (SETQ NTHDQ NTHDQ1)
   (GO AMEN)))
 EXPR)

(DEFPROP APROG
 (LAMBDA (Q)
  (PROG (RF PD N)
	(SETQ N 1)
	(SETQ RF (ROOTFAC Q))
	(SETQ ROOTFACTOR
	      (CONS (POLCMULT (RINGGCD Q)
			      (CAR RF))
		    (CDR RF)))
	(SETQ PD (LIST (CAR ROOTFACTOR)))
   THE	(COND ((NULL (CDR RF)) (GO HO)))
	(SETQ N (ADD1 N))
	(SETQ RF (CDR RF))
	(SETQ PD (CONS (POLEXPT (CAR RF) N)
		       PD))
	(GO THE)
   HO	(SETQ PARDENOM (REV PD))
	(RETURN (REVERSE ROOTFACTOR))))
 EXPR)

(DEFPROP BPROG
 (LAMBDA (R S)
  (PROG
   (P1B P2B
	P3B
	COEF1R
	COEF2R
	ONE
	FAC
	COEF3R
	COEF1S
	COEF2S
	COEF3S
	ZEROPOLB
	F1
	F2)
   (SETQ ONE (FORMCONST 1 (RANK R)))
   (SETQ COEF1R ONE)
   (SETQ COEF2S ONE)
   (SETQ P1B (NUMERATORF R))
   (SETQ P2B (NUMERATORF S))
B10(COND ((LESSP (LENGTH P1B) (LENGTH P2B))
	  (GO B20)))
   (GO B30)
B20(SETQ P3B P2B)
   (SETQ P2B P1B)
   (SETQ P1B P3B)
   (SETQ COEF3R COEF2R)
   (SETQ COEF2R COEF1R)
   (SETQ COEF1R COEF3R)
   (SETQ COEF3S COEF2S)
   (SETQ COEF2S COEF1S)
   (SETQ COEF1S COEF3S)
B30(COND
    ((ONEP (LENGTH P2B))
     (RETURN
      (CONS
       (QUOTIENTF (TIMESF (DENOMINATORF R)
			  COEF2R)
		  P2B)
       (QUOTIENTF (TIMESF (DENOMINATORF S)
			  COEF2S)
		  P2B)))))
   (SETQ
    ZEROPOLB
    (ZEROLISTF (DIFFERENCE (LENGTH P1B)
			   (LENGTH P2B))
	       (RANK R)))
   (SETQ FAC (POLGCD (CAR P1B) (CAR P2B)))
   (SETQ F1 (PPQUOTIENT (CAR P1B) FAC))
   (SETQ F2 (PPQUOTIENT (CAR P2B) FAC))
   (SETQ
    P1B
    (SIMPOL
     (LISTPLUS
      (POLCMULT F2 (CDR P1B))
      (POLMINUS (POLCMULT F1 (CDR P2B))))))
   (SETQ
    COEF1R
    (POLDIFFERENCE (POLCMULT F2 COEF1R)
		   (APPEND (POLCMULT F1
				     COEF2R)
			   ZEROPOLB)))
   (SETQ
    COEF1S
    (POLDIFFERENCE (POLCMULT F2 COEF1S)
		   (APPEND (POLCMULT F1
				     COEF2S)
			   ZEROPOLB)))
   (GO B10)))
 EXPR)

(DEFPROP CPROG
 (LAMBDA (TOP BOTTOM)
  (PROG
   (FRPART PARDENOMC PPDENOM THEBPG)
   (SETQ FRPART (POLDIVIDE TOP BOTTOM))
   (SETQ WHOLEPART (CAR FRPART))
   (SETQ FRPART (CDR FRPART))
   (COND ((ONEP (LENGTH PARDENOM))
	  (RETURN (SETQ PARNUMER
			(LIST FRPART)))))
   (SETQ PARDENOMC (CDR PARDENOM))
   (SETQ PPDENOM (LIST (CAR PARDENOM)))
DSEQ
   (COND ((ONEP (LENGTH PARDENOMC))
	  (GO OK)))
   (SETQ PPDENOM
	 (CONS (POLTIMES (CAR PPDENOM)
			 (CAR PARDENOMC))
	       PPDENOM))
   (SETQ PARDENOMC (CDR PARDENOMC))
   (GO DSEQ)
OK (SETQ PARDENOMC (REVERSE PARDENOM))
NUMC
   (SETQ THEBPG (BPROG (CAR PARDENOMC)
		       (CAR PPDENOM)))
   (SETQ
    PARNUMER
    (CONS (PFREMAINDER (TIMESF FRPART
			       (CDR THEBPG))
		       (CAR PARDENOMC))
	  PARNUMER))
   (SETQ FRPART
	 (PFREMAINDER (TIMESF FRPART
			      (CAR THEBPG))
		      (CAR PPDENOM)))
   (SETQ PARDENOMC (CDR PARDENOMC))
   (SETQ PPDENOM (CDR PPDENOM))
   (COND ((NULL PPDENOM)
	  (RETURN (SETQ PARNUMER
			(CONS FRPART
			      PARNUMER)))))
   (GO NUMC)))
 EXPR)

(DEFPROP DPROG
 (LAMBDA (RATARG)
  (PROG
   (KLTH KX
	 AROOTF
	 DERIV
	 THEBPG
	 RNK
	 THETOP
	 THEBOT
	 PROD1
	 PROD2
	 ANS)
   (COND
    ((PFP RATARG)
     (RETURN (TRANS (PFINTEGRAL RATARG)))))
   (SETQ RNK (RANK RATARG))
   (APROG (DENOMINATORF RATARG))
   (CPROG (NUMERATORF RATARG)
	  (DENOMINATORF RATARG))
   (SETQ ROOTFACTOR (REVERSE ROOTFACTOR))
   (SETQ PARNUMER (REVERSE PARNUMER))
   (SETQ KLTH (LENGTH ROOTFACTOR))
INTG
   (COND ((ONEP KLTH) (GO SIMP)))
   (SETQ AROOTF (CAR ROOTFACTOR))
   (COND ((ONEP (LENGTH AROOTF))
	  (GO RESET)))
   (SETQ DERIV (POLDERIVATIVE AROOTF))
   (SETQ THEBPG (BPROG AROOTF DERIV))
   (SETQ KX (SUB1 KLTH))
   (SETQ THETOP (CAR PARNUMER))
ITER
   (SETQ PROD1 (TIMESF THETOP (CAR THEBPG)))
   (SETQ PROD2 (TIMESF THETOP (CDR THEBPG)))
   (SETQ THEBOT (POLEXPT AROOTF KX))
   (SETQ
    ANS
    (PLUSF
     ANS
     (QUOTIENTF (MINUSF PROD2)
		(TIMESF (FORMCONST KX RNK)
			THEBOT))))
   (SETQ
    THETOP
    (PLUSF PROD1
	   (QUOTIENTF (PFDERIVATIVE PROD2)
		      (FORMCONST KX RNK))))
   (SETQ THETOP (PFREMAINDER THETOP THEBOT))
   (COND ((ONEP KX) (GO LOGSET)))
   (SETQ KX (SUB1 KX))
   (GO ITER)
LOGSET
   (SETQ LOGPTDX
	 (CONS (QUOTIENTF THETOP AROOTF)
	       LOGPTDX))
RESET
   (SETQ ROOTFACTOR (CDR ROOTFACTOR))
   (SETQ PARNUMER (CDR PARNUMER))
   (SETQ KLTH (SUB1 KLTH))
   (GO INTG)
SIMP
   (SETQ LOGPTDX
	 (CONS (QUOTIENTF (CAR PARNUMER)
			  (CAR ROOTFACTOR))
	       LOGPTDX))
   (COND
    ((NULL ANS)
     (RETURN
      (TRANS (PFINTEGRAL WHOLEPART)))))
   (SETQ THETOP
	 (POLREMAINDER (NUMERATORF ANS)
		       (DENOMINATORF ANS)))
   (SETQ ANS (QUOTIENTF THETOP
			(DENOMINATORF ANS)))
   (SETQ
    ANS
    (LIST (QUOTE PLUS)
	  (TRANS (PFINTEGRAL WHOLEPART))
	  (TRANS ANS)))
   (RETURN ANS)))
 EXPR)
(QUOTE (FILE LOGINT))

(DEFPROP EPROG
 (LAMBDA (P)
  (PROG (P1E P2E
	     A1E
	     A2E
	     A3E
	     DISCRIM
	     RNK
	     REPART
	     SIGN
	     NCC
	     DCC
	     ALLCC)
	(COND ((OR (NULL P) (NULL (CAR P)))
	       (RETURN NIL)))
	(SETQ RNK (SUB1 (RANK P)))
	(SETQ P1E (NUMERATORF P))
	(SETQ P2E (DENOMINATORF P))
	(COND (SWITCH1 (RETURN (EFAC))))
	(SETQ A1E (INTFACTOR P2E))
	(COND ((GREATERP (LENGTH A1E) 1)
	       (RETURN (E40))))
	(RETURN (EFAC))))
 EXPR)

(DEFPROP EFAC
 (LAMBDA NIL
	 (PROG NIL
	       (SETQ NCC (RINGGCD P1E))
	       (SETQ P1E (PPCQUOT NCC P1E))
	       (SETQ DCC (RINGGCD P2E))
	       (SETQ P2E (PPCQUOT DCC P2E))
	       (SETQ ALLCC
		     (QUOTIENTF NCC DCC))
	       (RETURN (E5))))
 EXPR)

(DEFPROP E5
 (LAMBDA NIL
  (PROG
   NIL
   (COND ((EQUAL (LENGTH P2E) 2)
	  (RETURN (E10)))
	 ((EQUAL (LENGTH P2E) 3)
	  (RETURN (E20))))
   (SETQ A1E (POLDERIVATIVE P2E))
   (SETQ A2E (QUOTIENTF (LIST (CAR P1E))
			(LIST (CAR A1E))))
   (COND
    ((EQUAL (TIMESF A2E A1E) P1E)
     (RETURN
      (LIST
       (QUOTE TIMES)
       (TRANS (TIMESF (UNMONIC (LIST ALLCC))
		      A2E))
       (LIST (QUOTE LOG) (TRANS P2E))))))
   (RETURN
    (LIST (QUOTE TIMES)
	  (TRANS ALLCC)
	  (LIST (QUOTE INTEGRATE)
		(LIST (QUOTE QUOTIENT)
		      (TRANS P1E)
		      (TRANS P2E))
		(CAR (LAST VARLIST)))))))
 EXPR)

(DEFPROP E10
 (LAMBDA NIL
  (PROG
   NIL
   (RETURN
    (LIST
     (QUOTE TIMES)
     (TRANS (TIMESF ALLCC
		    (QUOTIENTF (CAR P1E)
			       (CAR P2E))))
     (LIST (QUOTE LOG) (TRANS P2E))))))
 EXPR)

(DEFPROP E20
 (LAMBDA NIL
  (PROG
   NIL
   (SETQ
    DISCRIM
    (DIFFERENCEF
     (EXPTF (CADR P2E) 2)
     (TIMESF (FORMCONST 4 RNK)
	     (TIMESF (CAR P2E)
		     (CADDR P2E)))))
   (SETQ A2E (TIMESF (CAR P2E)
		     (FORMCONST 2 RNK)))
   (SETQ SIGN (ASKSIGN DISCRIM))
   (COND ((EQUAL SIGN (QUOTE NEGATIVE))
	  (RETURN (E30)))
	 ((EQUAL SIGN (QUOTE ZERO))
	  (RETURN (ZIP))))
   (SETQ A1E (SQRTF DISCRIM))
   (COND ((NOT (ONEPF (CDR A1E)))
	  (RETURN (LGSQ))))
   (SETQ A1E (CONS (CAR A1E) 1))
   (SETQ
    A3E
    (LIST
     (QUOTE LOG)
     (TRANS
      (QUOTIENTF
       (LIST A2E (DIFFERENCEF (CADR P2E)
			      (CAR A1E)))
       (LIST A2E (PLUSF (CADR P2E)
			(CAR A1E)))))))
   (RETURN (TLOG))))
 EXPR)

(DEFPROP TLOG
 (LAMBDA NIL
  (PROG
   NIL
   (COND
    ((ONEP (LENGTH P1E))
     (RETURN
      (LIST
       (QUOTE TIMES)
       (LIST
	(QUOTE QUOTIENT)
	(TRANS (TIMESF (QUOTIENTF (CAR P1E)
				  (CAR A1E))
		       ALLCC))
	(CDR A1E))
       A3E))))
   (RETURN
    (LIST
     (QUOTE PLUS)
     (LIST
      (QUOTE TIMES)
      (TRANS (TIMESF ALLCC
		     (QUOTIENTF (CAR P1E)
				A2E)))
      (LIST (QUOTE LOG) (TRANS P2E)))
     (LIST
      (QUOTE TIMES)
      (LIST
       (QUOTE QUOTIENT)
       (TRANS
	(TIMESF
	 ALLCC
	 (QUOTIENTF
	  (QUOTIENTF
	   (DIFFERENCEF (TIMESF A2E
				(CADR P1E))
			(TIMESF (CADR P2E)
				(CAR P1E)))
	   A2E)
	  (CAR A1E))))
       (CDR A1E))
      A3E)))))
 EXPR)

(DEFPROP E30
 (LAMBDA NIL
  (PROG
   NIL
   (SETQ A1E (SQRTF (MINUSF DISCRIM)))
   (SETQ
    A1E
    (COND
     ((ONEPF (CDR A1E)) (CONS (CAR A1E) 1))
     (T (CONS (CAR A1E)
	      (LIST (QUOTE EXPT)
		    (TRANS (CDR A1E))
	      (QUOTE (QUOTIENT 1 2)))))))
   (SETQ
    REPART
    (QUOTIENTF
     (COND
      ((ONEP (LENGTH P1E))
       (TIMESF A2E (CAR P1E)))
      (T (DIFFERENCEF (TIMESF A2E
			      (CADR P1E))
		      (TIMESF (CADR P2E)
			      (CAR P1E)))))
     (CAR P2E)))
   (SETQ
    A3E
    (LIST
     (QUOTE TIMES)
     (LIST
      (QUOTE QUOTIENT)
      (TRANS (TIMESF ALLCC
		     (QUOTIENTF REPART
				(CAR A1E))))
      (CDR A1E))
     (LIST
      (QUOTE ARCTAN)
      (LIST
       (QUOTE QUOTIENT)
       (TRANS (QUOTIENTF (POLDERIVATIVE P2E)
			 (LIST (CAR A1E))))
       (CDR A1E)))))
   (COND ((ONEP (LENGTH P1E)) (RETURN A3E)))
   (RETURN
    (LIST
     (QUOTE PLUS)
     (LIST
      (QUOTE TIMES)
      (TRANS (TIMESF ALLCC
		     (QUOTIENTF (CAR P1E)
				A2E)))
      (LIST (QUOTE LOG) (TRANS P2E)))
     A3E))))
 EXPR)

(DEFPROP LGSQ
 (LAMBDA NIL
  (PROG
   NIL
   (SETQ A1E
	 (CONS (CAR A1E)
	       (LIST (QUOTE EXPT)
		     (TRANS (CDR A1E))
		(QUOTE (QUOTIENT 1 2)))))
   (SETQ
    A3E
    (LIST
     (QUOTE LOG)
     (LIST
      (QUOTE QUOTIENT)
      (LIST (QUOTE PLUS)
	    (LIST (QUOTE TIMES)
		  (TRANS A2E)
		  (CAR (REVERSE VARLIST)))
	    (LIST (QUOTE DIFFERENCE)
		  (TRANS (CADR P2E))
		  (LIST (QUOTE TIMES)
			(TRANS (CAR A1E))
			(CDR A1E))))
      (LIST (QUOTE PLUS)
	    (LIST (QUOTE TIMES)
		  (TRANS A2E)
		  (CAR (REVERSE VARLIST)))
	    (LIST (QUOTE PLUS)
		  (TRANS (CADR P2E))
		  (LIST (QUOTE TIMES)
			(TRANS (CAR A1E))
			(CDR A1E)))))))
   (RETURN (TLOG))))
 EXPR)

(DEFPROP ZIP
 (LAMBDA NIL
  (PROG
   NIL
   (SETQ
    P2E
    (UNMONIC
     (LIST (CAR P2E)
	   (CADR P2E)
	   (QUOTIENTF (POLEXPT (CADR P2E) 2)
		      (FORMCONST 4 RNK)))))
   (RETURN
    (FPROG (TIMESF ALLCC
		   (QUOTIENTF P1E P2E))))))
 EXPR)

(DEFPROP E40
 (LAMBDA NIL
  (PROG
   NIL
   (SETQ PARNUMER NIL)
   (SETQ PARDENOM A1E)
   (SETQ SWITCH1 T)
   (CPROG P1E P2E)
   (SETQ
    A2E
    (MAPCAR
     (FUNCTION
      (LAMBDA (Y)
       (EPROG (QUOTIENTF (CAR Y)
			 (CDR Y)))))
     (PAIR PARNUMER PARDENOM)))
   (SETQ SWITCH1 NIL)
   (RETURN (CONS (QUOTE PLUS) A2E))))
 EXPR)

(DEFPROP FPROG
 (LAMBDA (RAT)
  (PROG (DONE ROOTFACTOR
	      PARDENOM
	      PARNUMER
	      LOGPTDX
	      WHOLEPART
	      SWITCH1)
	(SETQ DONE (DPROG RAT))
   WEE	(COND ((NULL LOGPTDX) (RETURN DONE))
	      ((NULL (CAR LOGPTDX))
	       (GO SKIP)))
	(SETQ DONE
	      (LIST (QUOTE PLUS)
		    DONE
		    (EPROG (CAR LOGPTDX))))
   SKIP	(SETQ LOGPTDX (CDR LOGPTDX))
	(GO WEE)))
 EXPR)
(QUOTE AUXFUN)

(DEFPROP INTFACTOR1
 (LAMBDA (POL)
  (PROG
   (HINTS GOSH)
   (SETQ HINTS FLIST)
HOPE
   (COND ((NULL HINTS) (RETURN (LIST POL)))
	 ((NOT (LESSP (LENGTH (CAR HINTS))
		      (LENGTH POL)))
	  (GO NOPE)))
   (SETQ GOSH (POLDIVIDE POL (CAR HINTS)))
   (COND
    ((NULL (CDR GOSH))
     (RETURN
      (APPEND
       (INTFACTOR1
	(PPCQUOT
	 (CAR (DENOMINATORF (CAR GOSH)))
	 (CAR HINTS)))
       (INTFACTOR1
	(NUMERATORF (CAR GOSH)))))))
NOPE
   (SETQ HINTS (CDR HINTS))
   (GO HOPE)))
 EXPR)

(DEFPROP INTFACTOR
 (LAMBDA (POL)
  (PROG (A B C)
	(SETQ A (INTFACTOR1 POL))
   MI	(COND ((NULL A) (RETURN C)))
	(SETQ B (CAR A))
	(SETQ A (CDR A))
	(COND ((LESSP (LENGTH B) 3)
	       (GO EASY)))
	(SETQ B (FACTOR1 B))
	(SETQ B (CONS (POLCMULT (CAR B)
				(CADR B))
		      (CDDR B)))
	(SETQ C (APPEND B C))
	(GO MI)
   EASY	(SETQ C (CONS B C))
	(GO MI)))
 EXPR)

(DEFPROP FORMFLIST
 (LAMBDA (THEREP)
	 (COND ((NUMBERPRL THEREP) NIL)
	       ((LESSP (LENGTH THEREP) 2)
		NIL)
	       ((RATFUNP THEREP) NIL)
	       (T (SETQ FLIST
			(CONS THEREP
			      FLIST)))))
 EXPR)