Trailing-Edge
-
PDP-10 Archives
-
decuslib10-02
-
43,50216/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)