Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0039/fact6.l
There are 2 other files named fact6.l in the archive. Click here to see a list.
(DEFPROP ZEROP(LAMBDA(X)(MCONS(QUOTE EQ)0(CDR X)))MACRO)
(DEFPROP PAIR(LAMBDA(X Y)(COND
((NULL X)NIL)
(T(CONS(CONS(CAR X)(CAR Y))(PAIR(CDR X)(CDR Y))))
))EXPR)
(DEFPROP MIN(LAMBDA(X)(COND
((NULL(CDR X))(CAR X))
((LESSP (CADR X)(CAR X))(EVAL(CONS(QUOTE MIN)(CDR X))))
(T(EVAL(CONS(QUOTE MIN)(CONS(CAR X)(CDDR X)))))
))FEXPR)
(DEFPROP CPLIST T SPECIAL)
(DEFPROP MAXLIST T SPECIAL)
(DEFPROP CPPLACE T SPECIAL)
(DEFPROP NM T SPECIAL)
(DEFPROP FF T SPECIAL)
(DEFPROP NNN T SPECIAL)
(DEFPROP FACLIST T SPECIAL)
(DEFPROP FAC2OR T SPECIAL)
(DEFPROP RNNNNK T SPECIAL)
(DEFPROP FAC3OR T SPECIAL)
(DEFPROP RNNNK T SPECIAL)
(DEFPROP PFAC T SPECIAL)
(DEFPROP FST T SPECIAL)
(DEFPROP SPOL T SPECIAL)
(DEFPROP *POL T SPECIAL)
(QUOTE (FILE FACT1))
(DEFPROP FINDARGS
(LAMBDA (K)
(PROG (NN ROW UNO)
(SETQ ROW (LIST 0))
(SETQ NN 1)
LEGS (COND ((EQUAL NN (ADD1 K))
(RETURN (REV ROW)))
((EVEN NN) (GO SKP)))
(SETQ UNO
(ADD1 (QUOTIENT NN 2)))
(GO SKP1)
SKP (SETQ UNO
(MINUS (QUOTIENT NN
2)))
SKP1 (SETQ ROW (CONS UNO ROW))
(SETQ NN (ADD1 NN))
(GO LEGS)))
EXPR)
(DEFPROP CONLISTP
(LAMBDA (STRNG)
(PROG (TOM)
MOP (SETQ TOM (CAR STRNG))
(SETQ STRNG (CDR STRNG))
(COND ((NULL STRNG)
(RETURN T))
((EQUAL TOM
(CAR STRNG))
(GO MOP)))
(RETURN NIL)))
EXPR)
(DEFPROP ELIMCONS
(LAMBDA (LOFL)
(PROG (PRIMO ANS)
ABE (SETQ PRIMO (CAR LOFL))
(COND ((NULL (CONLISTP PRIMO))
(GO BOM)))
(GO CAT)
BOM (SETQ ANS (CONS PRIMO ANS))
CAT (COND ((NULL (CDR LOFL))
(RETURN (REV ANS))))
(SETQ LOFL (CDR LOFL))
(GO ABE)))
EXPR)
(DEFPROP SIMPB
(LAMBDA (ROW LOFL)(PROG(ANS)
LOOP (COND((NULL ROW)(RETURN(REV ANS))))
(SETQ ANS(CONS(SIMP3(CAR ROW)(CAR LOFL))ANS))
(SETQ ROW(CDR ROW))
(SETQ LOFL(CDR LOFL))
(GO LOOP)
))EXPR)
(DEFPROP SIMP3
(LAMBDA (NO ROW)
(PROG
(M3 ANS)
(SETQ M3 (MODULO 3 NO))
PIPE
(COND ((NULL ROW) (RETURN (REV ANS)))
((NOT (EQUAL M3
(MODULO 3 (CAR ROW))))
(GO SAVY)))
(SETQ ANS (CONS (CAR ROW) ANS))
SAVY
(SETQ ROW (CDR ROW))
(GO PIPE)))
EXPR)
(DEFPROP ELIMDUP
(LAMBDA (LST)
(PROG (AA ANS)
MIL (SETQ AA (CAR LST))
(COND ((NULL LST)
(RETURN (REV ANS)))
((MEMBER AA (CDR LST))
(GO LIM)))
(SETQ ANS (CONS AA ANS))
LIM (SETQ LST (CDR LST))
(GO MIL)))
EXPR)
(DEFPROP ARGVALFACT
(LAMBDA (K POL)
(PROG
(ARGS VAL AFAC LEN WE TEM CA ANS)
(COND ((NOT (ONEP (RANK POL)))
(GO MORE)))
(SETQ ARGS (FINDARGS (TIMESF K 3)))
(SETQ VAL (FINDVALS POL ARGS))
CONT
(SETQ
AFAC
(MAPCAR
(FUNCTION POSFACTORS)
VAL))
(SETQ
LEN
(MAPCAR (FUNCTION LENGTH)
AFAC
))
(SETQ WE (PAIR LEN (PAIR ARGS AFAC)))
TOP(SETQ CA (CAR WE))
SEE(SETQ WE (CDR WE))
(COND ((NULL WE) (GO SET))
((NOT (GREATERP (CAR CA)
(CAAR WE)))
(GO HUMP)))
(SETQ TEM (CONS CA TEM))
(GO TOP)
HUMP
(SETQ TEM (CONS (CAR WE) TEM))
(GO SEE)
SET(SETQ ANS (CONS CA ANS))
(COND ((EQUAL (LENGTH ANS) (ADD1 K))
(GO HOME)))
(SETQ WE TEM)
(SETQ TEM NIL)
(GO TOP)
MORE
(SETQ ARGS (FINDARGS K))
(SETQ VAL (FINDVALS POL ARGS))
(RETURN
(LIST
ARGS
(MAPCAR
(FUNCTION ALLFACTORSR)
VAL)))
HOME
(RETURN
(LIST
(MAPCAR
(FUNCTION (LAMBDA (Z)
(CADR Z)))
ANS)
(MAPCAR
(FUNCTION
(LAMBDA (Z)
(ADDNEGSR (CDDR Z))))
ANS)))))
EXPR)
(DEFPROP ALLFACPOL
(LAMBDA (NM LPOL)
(PROG
(FF SPANS RK1)
(SETQ RK1 (SUB1 (RANK LPOL)))
(SETQ SPANS (LIST (FORMCONST 1 RK1)
(CAR LPOL)))
STAR
(SETQ LPOL (CDR LPOL))
(COND ((NULL LPOL) (RETURN SPANS)))
(SETQ FF (CAR LPOL))
(COND ((ZEROP NM) (GO PINT)))
(SETQ
SPANS
(APPEND
SPANS
(MAPCAR
(FUNCTION
(LAMBDA (Z)
(SIMPOL
(POLMOD NM
(POLTIMES FF
Z)))))
SPANS)))
(GO STAR)
PINT
(SETQ
SPANS
(APPEND
SPANS
(MAPCAR
(FUNCTION
(LAMBDA (Z) (TIMESF FF Z)))
SPANS)))
(GO STAR)))
EXPR)
(DEFPROP RIGHTLEN
(LAMBDA (N LOFL)
(PROG
(ANS)
DUN(COND ((NULL LOFL) (RETURN (REV ANS)))
((NOT (EQUAL N
(LENGTH (CAR LOFL))))
(GO PENN)))
(SETQ ANS (CONS (CAR LOFL) ANS))
PENN
(SETQ LOFL (CDR LOFL))
(GO DUN)))
EXPR)
(DEFPROP RIGHTLEN1
(LAMBDA (N LOFL)
(PROG (ANS)
MIX (COND ((NULL LOFL)
(RETURN (REV ANS)))
((GREATERP (LENGTH (CAR LOFL))
N)
(GO FILL)))
(SETQ ANS (CONS (CAR LOFL) ANS))
FILL (SETQ LOFL (CDR LOFL))
(GO MIX)))
EXPR)
(QUOTE (FILE FACT2))
(DEFPROP MINLIST
(LAMBDA (Y)
(EVAL(CONS(QUOTE MIN)Y)))
EXPR)
(DEFPROP LINEUP
(LAMBDA (LOVN)
(PROG (ANS SHM)
BA (COND ((NULL LOVN)
(RETURN (REV ANS))))
(SETQ SHM (MINLIST LOVN))
(SETQ ANS (CONS SHM ANS))
(SETQ LOVN (FFACE SHM LOVN))
(GO BA)))
EXPR)
(DEFPROP FFACE
(LAMBDA (X Y)
(PROG (ANS)
A (COND ((NULL Y)
(RETURN (REV ANS)))
((NOT (EQUAL (CAR Y)
X))
(SETQ ANS
(CONS (CAR Y)
ANS))))
(SETQ Y (CDR Y))
(GO A)))
EXPR)
(DEFPROP NEWTONPOL
(LAMBDA (ARGS NEWT)
(PROG
(CNEWT PROD ANS RK1 UNO APROD)
(SETQ RK1 (SUB1 (RANK NEWT)))
(SETQ UNO (FORMCONST 1 RK1))
(SETQ PROD
(LIST UNO
(FORMCONST (MINUS (CAR ARGS))
RK1)))
(COND ((AND (LESSP 0 RK1)
(ZEROP (CAR ARGS)))
(SETQ PROD (LIST UNO NIL))))
(SETQ CNEWT (CDR NEWT))
(SETQ ANS (POLCMULT (CAR CNEWT) PROD))
FACE
(COND ((NULL (CDR CNEWT))
(RETURN (POLPLUS (LIST (CAR NEWT))
ANS))))
(SETQ CNEWT (CDR CNEWT))
(SETQ ARGS (CDR ARGS))
(SETQ APROD
(LIST UNO
(FORMCONST (MINUS (CAR ARGS))
RK1)))
(COND ((AND (LESSP 0 RK1)
(ZEROP (CAR ARGS)))
(SETQ APROD (LIST UNO NIL))))
(SETQ PROD (TIMESF PROD APROD))
(SETQ ANS (POLPLUS ANS
(POLCMULT (CAR CNEWT)
PROD)))
(GO FACE)))
EXPR)
(DEFPROP TRYNEWTON
(LAMBDA (K POL POL3)
(PROG
(P NEWT N
AVF
TRYPOL
TRYVAL3
TRYFACS
CAT
DOG)
(COND ((ONEP K) (RETURN (LINFAC POL))))
(SETQ AVF (ARGVALFACT K POL))
(COND ((NUMBERP POL3) (GO SCAR)))
(SETQ TRYVAL3 (FINDVALS POL3 (CAR AVF)))
(SETQ TRYFACS (SIMPB TRYVAL3 (CADR AVF)))
(COND ((MEMBER NIL TRYFACS)
(RETURN NIL)))
(SETQ CAT (CAR TRYFACS))
(SETQ DOG (CDR TRYFACS))
PRE (CARPROD
(MAPCAR
(FUNCTION
(LAMBDA (Z) (LINEUP Z)))
(CONS (LIST (CAR CAT)) DOG)))
(SETQ N(LENGTH MAXLIST))
BACK
(SETQ P(PULSE))
(COND((NOT(EQUAL(LENGTH P)N))(GO ZEEK))
((CONLISTP P)(GO BACK)) )
(SETQ NEWT (NEWTON (CAR AVF)P))
(COND
((OR (NULL NEWT)
(ZEROPF (CAR (LAST NEWT))))
(GO CIRCLE))
((ZEROPF
(REMAINDER1 (CAR POL)
(CAR (LAST NEWT))))
(GO ON)))
(GO CIRCLE)
ON (SETQ TRYPOL (NEWTONPOL (CAR AVF) NEWT))
(COND
((NOT
(ZEROPF
(REMAINDER1 (CAR (LAST POL))
(CAR (LAST TRYPOL)))))
(GO CIRCLE)))
(COND
((OR (NUMBERP POL3)
(LESSP 4 (LENGTH POL3))
(EQUAL (SIMPOL (POLMOD 3 TRYPOL))
POL3))
(GO FINI)))
(GO CIRCLE)
SCAR
(SETQ CAT (CAR (CADR AVF)))
(SETQ DOG (CDR (CADR AVF)))
SCAR1 (CARPROD (CONS (LIST (CAR CAT)) DOG))
(SETQ N(LENGTH MAXLIST))
(GO BACK)
ZEEK
(SETQ CAT (CDR CAT))
(COND ((NULL CAT) (RETURN NIL))
((NUMBERP POL3) (GO SCAR1)))
(GO PRE)
FINI
(SETQ TRYFACS (POLDIVIDE POL TRYPOL))
(COND ((AND (NULL (CDR TRYFACS))
(POLP (CAR TRYFACS)))
(RETURN TRYPOL)))
CIRCLE
(GO BACK)))
EXPR)
(DEFPROP FACTRK
(LAMBDA (*POL)
(PROG
(RANS ANS GC HPOL CPLIST MAXLIST CPPLACE)
(COND ((NUMBERP (STRIPPAREN *POL))
(RETURN (LIST *POL))))
(SETQ GC (RINGGCD *POL))
(COND ((ONEPF GC) (GO BUP)))
(SETQ *POL (PPCQUOT GC *POL))
(SETQ
RANS
(MAPCAR
(FUNCTION (LAMBDA (Z)
(LIST Z)))
(FACTRK GC)))
BUP(SETQ HPOL *POL)
(SETQ ANS (MASSOC FACLIST HPOL))
(COND ((NULL ANS) (GO WO)))
(SETQ ANS (CDAR ANS))
(GO BOX)
WO (SETQ
ANS
(ELIMC
(RCONSIT
(MAPCAR
(FUNCTION UPFAC)
((LAMBDA(J)(COND((NULL J)(LIST *POL))((CAR J))))(ERRSET(ROOTFAC *POL)NIL)) ))))
(SETQ FACLIST
(NCONC FACLIST
(LIST (CONS HPOL ANS))))
BOX(RETURN (APPEND RANS ANS))))
EXPR)
(DEFPROP UPFAC
(LAMBDA (POL)
(PROG (K N STP F2 F3 AF TNT ANS VR)
(COND ((NULL (CDR POL))
(RETURN (LIST POL))))
UP (SETQ K 1)
(SETQ AF (QUOTE (NIL)))
UP1 (SETQ N (LENGTH POL))
(SETQ STP (QUOTIENT (SUB1 N) 2))
(SETQ VR (RANK POL))
(COND ((LESSP STP K) (GO LOX)))
(COND ((NOT (ONEP VR)) (GO YERN)))
BRAK (SETQ F2 (SIMPOL (POLMOD2 POL)))
(COND ((LESSP (LENGTH F2) N)
(GO YERN))
((NOT (NULL (IRREDM2 F2)))
(GO LOX)))
(SETQ F3 (SIMPOL (POLMOD 3 POL)))
(SETQ F2(ALLFACPOL 3(FACTMOD3 F3)))
(GO YERN)
DELT (SETQ K (ADD1 K))
SNEZ (COND ((LESSP STP K) (GO LOX))
((NOT (ONEP VR)) (GO MERE)))
LAF (COND ((LESSP (LENGTH F3) N)
(GO MERE)))
(SETQ AF (RIGHTLEN (ADD1 K) F2))
(GO YERN)
MERE (SETQ AF (LIST 0))
(GO YERN)
NESS (SETQ AF (RIGHTLEN1 (ADD1 K) F2))
YERN (COND((AND(NULL AF)(GREATERP N 10)(GREATERP K 4))(GO MERE)))
(COND ((NULL AF) (GO DELT)))
(SETQ TNT
(TRYNEWTON K POL (CAR AF)))
(COND((AND(NULL TNT)(ZEROP(CAR AF)))(GO DELT)))
(COND ((NULL TNT) (GO TELL)))
FORD (SETQ ANS (CONS TNT ANS))
(SETQ POL (POLQUOTIENT POL TNT))
(GO UP1)
TELL (SETQ AF (CDR AF))
(GO YERN)
LOX (RETURN (CONS POL ANS))))
EXPR)
(DEFPROP MASSOC
(LAMBDA (X R)
(PROG NIL
BLOP (COND ((NULL X) (RETURN NIL))
((EQUAL (CAAR X) R)
(RETURN X)))
(SETQ X (CDR X))
(GO BLOP)))
EXPR)
(DEFPROP RCONSIT
(LAMBDA (X)
(PROG (ANS TEM)
A (COND ((NULL X)
(RETURN ANS)))
(SETQ TEM X)
(SETQ X (CDR X))
B (SETQ ANS
(APPEND (CAR TEM) ANS))
(SETQ TEM (CDR TEM))
(COND ((NULL TEM) (GO A)))
(GO B)))
EXPR)
(DEFPROP ELIMC
(LAMBDA (LST)
(PROG (ANS)
A (COND ((NULL LST)
(RETURN ANS))
((CDAR LST)
(SETQ ANS
(CONS (CAR LST)
ANS))))
(SETQ LST (CDR LST))
(GO A)))
EXPR)
(DEFPROP FACTOR
(LAMBDA (POL) (PROG (FACLIST)
(COND((NULL POL)(RETURN(LIST NIL))))
(RETURN((LAMBDA(J)(COND
((AND(NOT(ATOM POL))(NULL(CDR POL))
(POLMINUSP POL))
(CONS(POLMINUS(CAR J))(CDR J)))
(J)))
(FACTRK POL))) ))
EXPR)
(DEFPROP MOD2
(LAMBDA (N)
(REMAINDER (ABS N) 2))
EXPR)
(DEFPROP POLMOD2
(LAMBDA (POL)
(MAPCAR
(FUNCTION (LAMBDA (Z) (MOD2 Z)))
POL))
EXPR)
(DEFPROP MODULO
(LAMBDA (N Z)
(PROG (REM)
(SETQ REM (REMAINDER Z N))
(COND ((OR (ZEROP REM)
(LESSP 0 REM))
(RETURN REM)))
(RETURN (PLUS N REM))))
EXPR)
(DEFPROP POLMOD
(LAMBDA (NNN POL)
(MAPCAR
(FUNCTION (LAMBDA (Z)
(MODULO NNN
Z)))
POL))
EXPR)
(DEFPROP SUMLIST
(LAMBDA (POL)
(COND ((NULL POL) 0)
(T (PLUS (CAR POL)
(SUMLIST (CDR POL))))))
EXPR)
(DEFPROP IRREDM2
(LAMBDA (POL2)
(PROG (K HALT WFAC LFAC ANS REM)
GIN (SETQ K 1)
(SETQ HALT
(QUOTIENT (SUB1 (LENGTH POL2))
2))
(COND ((ZEROP (CAR (REVERSE POL2)))
(RETURN NIL))
((EVEN (SUMLIST POL2))
(RETURN NIL)))
(SETQ WFAC FAC2OR)
HAHA (SETQ K (ADD1 K))
(COND
((EQ K 7)(RETURN NIL))
((LESSP HALT K)
(RETURN (CONS POL2 ANS))))
(SETQ LFAC (CAR WFAC))
LEFT (SETQ REM (POLREMAINDER POL2
(CAR LFAC)))
(COND ((NULL (SIMPOL (POLMOD2 REM)))
(RETURN NIL))
((NULL (CDR LFAC)) (GO ABOT)))
(SETQ LFAC (CDR LFAC))
(GO LEFT)
ABOT (SETQ WFAC (CDR WFAC))
(COND((NULL WFAC)(RETURN NIL)))
(GO HAHA)))
EXPR)
(SETQ FAC2OR
(QUOTE (((1 1 1))
((1 0 1 1) (1 1 0 1))
((1 1 1 1 1) (1 1 0 0 1) (1 0 0 1 1))
((1 1 1 1 0 1) (1 0 1 1 1 1)
(1 1 1 0 1 1)
(1 1 0 1 1 1)
(1 0 1 0 0 1)
(1 0 0 1 0 1))
((1 0 1 0 1 1 1) (1 0 1 1 0 1 1)
(1 1 0 0 1 1 1)
(1 1 0 1 1 0 1)
(1 1 1 0 0 1 1)
(1 1 1 0 1 0 1)
(1 1 0 0 0 0 1)
(1 0 0 1 0 0 1)
(1 0 0 0 0 1 1)))))
(QUOTE (FILE FACT3))
(DEFPROP FACTOR1
(LAMBDA (POL)
(PROG (GC)
(SETQ GC (RINGGCD POL))
(SETQ POL (PPCQUOT GC POL))
(RETURN (CONS GC (FACTOR POL)))))
EXPR)
(DEFPROP POSFACTORSR
(LAMBDA (POL)
(PROG
(GC POS PFAC ANS RNNNK)
(SETQ RNNNK (RANK POL))
(COND ((NUMBERP POL)
(RETURN (POSFACTORS POL))))
(COND
((NUMBERP (STRIPPAREN POL))
(RETURN
(MAPCAR
(FUNCTION
(LAMBDA (Z) (FORMCONST Z
RNNNK)))
(POSFACTORS (STRIPPAREN POL))))))
(SETQ GC (RINGGCD POL))
(COND ((NOT (NUMBERP (STRIPPAREN GC)))
(GO TRIZ)))
(SETQ POS (POSFACTORSR GC))
(SETQ PFAC
(ALLFACPOL 0
(FACTRK (PPCQUOT GC
POL))))
BEAT
(SETQ
ANS
(APPEND
(MAPCAR
(FUNCTION
(LAMBDA (Z) (TIMESF (LIST Z)
(CAR PFAC))))
POS)
ANS))
(COND ((NULL (CDR PFAC))
(RETURN (ELIMDUP ANS))))
(SETQ PFAC (CDR PFAC))
(GO BEAT)
TRIZ
(RETURN
(ELIMDUP
(CONS (FORMCONST 1 (RANK POL))
(ALLFACPOL 0 (FACTRK POL)))))))
EXPR)
(DEFPROP ADDNEGSR
(LAMBDA (POL)
(PROG (ANS RNNNNK)
(SETQ RNNNNK (RANK POL))
ROND (COND ((NULL POL)
(RETURN (REV ANS))))
(SETQ ANS (CONS (CAR POL) ANS))
(SETQ ANS
(CONS (MINUSF (CAR ANS)) ANS))
(SETQ POL (CDR POL))
(GO ROND)))
EXPR)
(DEFPROP ALLFACTORSR
(LAMBDA (POL)
(PROG
(RNNNNK)
(SETQ RNNNNK (RANK POL))
(RETURN
(COND
((NUMBERP POL) (ALLFACTORS POL))
((NUMBERP (STRIPPAREN POL))
(MAPCAR
(FUNCTION
(LAMBDA (Z) (FORMCONST Z
RNNNNK)))
(ALLFACTORS (STRIPPAREN POL))))
(T (ADDNEGSR (POSFACTORSR POL)))))))
EXPR)
(DEFPROP REMAINDER1
(LAMBDA (POL1 POL2)
(PROG (TRY)
(COND ((NUMBERP POL1)
(RETURN (REMAINDER POL1
POL2))))
(SETQ TRY (POLDIVIDE POL1 POL2))
(COND ((AND (NULL (CDR TRY))
(POLP (CAR TRY)))
(RETURN 0)))
(RETURN (CDR TRY))))
EXPR)
(DEFPROP LINFAC
(LAMBDA (POL)
(PROG
(CON AA BB N P)
(SETQ CON (CAR (LAST POL)))
(COND ((ZEROPF CON) (GO SIAM)))
(SETQ AA (POSFACTORSR (CAR POL)))
(SETQ BB (ALLFACTORSR CON))
(CARPROD (LIST AA BB))
(SETQ N(LENGTH MAXLIST))
SAM(SETQ P(PULSE))
(COND
((NOT( EQUAL(LENGTH P)N)) (RETURN NIL))
(((LAMBDA(J)(AND(POLP(CAR J))(NULL(CDR J))))
(POLDIVIDE POL P))
(RETURN P)))
(GO SAM)
SIAM
(COND ((ONEP (RANK POL))
(RETURN (LIST 1 0))))
(RETURN
(LIST (FORMCONST 1 (SUB1 (RANK POL)))
NIL))))
EXPR)
(DEFPROP FACTMOD3
(LAMBDA (POL3)
(PROG
(K HALT WFAC LFAC REM ANS)
CLOC
(SETQ K 1)
(SETQ HALT
(QUOTIENT (SUB1 (LENGTH POL3)) 2))
(COND ((ZEROP HALT)
(RETURN (CONS POL3 ANS)))
((ZEROP (CAR (LAST POL3)))
(GO WAC1))
((ZEROP (MODULO 3 (SUMLIST POL3)))
(GO WAC2))
((ZEROP (MODULO 3
(POLEVAL 2 POL3)))
(GO WAC3)))
(SETQ WFAC FAC3OR)
HEHE
(SETQ K (ADD1 K))
(COND ((OR(NULL WFAC)(LESSP HALT K))
(RETURN (CONS POL3 ANS))))
(SETQ LFAC (CAR WFAC))
FELT
(SETQ REM (POLREMAINDER POL3 (CAR LFAC)))
(COND ((NULL (SIMPOL (POLMOD 3 REM)))
(GO VASE))
((NULL (CDR LFAC)) (GO TABU)))
(SETQ LFAC (CDR LFAC))
(GO FELT)
VASE
(SETQ ANS (CONS (CAR LFAC) ANS))
(SETQ POL3
(POLMOD 3
(POLQUOTIENT POL3
(CAR LFAC))))
(GO CLOC)
TABU
(SETQ WFAC (CDR WFAC))
(GO HEHE)
WAC1
(SETQ ANS (CONS (LIST 1 0) ANS))
(SETQ POL3
(POLMOD 3
(POLQUOTIENT POL3
(LIST 1 0))))
(GO CLOC)
WAC2
(SETQ ANS (CONS (LIST 1 2) ANS))
(SETQ POL3
(POLMOD 3
(POLQUOTIENT POL3
(LIST 1 2))))
(GO CLOC)
WAC3
(SETQ ANS (CONS (LIST 1 1) ANS))
(SETQ POL3
(POLMOD 3
(POLQUOTIENT POL3
(LIST 1 1))))
(GO CLOC)))
EXPR)
(SETQ FAC3OR
(QUOTE(((1 0 1) (1 2 2) (1 1 2))
((1 0 2 1) (1 0 2 2)
(1 1 0 2)
(1 2 0 1)
(1 1 1 2)
(1 1 2 1)
(1 2 1 1)
(1 2 2 2))
((1 0 0 1 2) (1 0 0 2 2)
(1 0 1 0 2)
(1 0 2 0 2)
(1 1 0 0 2)
(1 2 0 0 2)
(1 1 0 2 1)
(1 2 0 1 1)
(1 1 1 0 1)
(1 2 1 0 1)
(1 1 1 1 1)
(1 1 2 1 2)
(1 2 1 1 2)
(1 2 1 2 1)))))
(QUOTE (FILE CFACT))
(DEFPROP POLEVAL
(LAMBDA (R POL)
(PROG
(ANS)
(COND ((ZEROP R)
(RETURN (CAR (LAST POL)))))
(SETQ R (FORMCONST R (SUB1 (RANK POL))))
(SETQ ANS (CAR POL))
EAR(SETQ POL (CDR POL))
(COND ((NULL POL) (RETURN ANS)))
(SETQ ANS
(PLUSF (TIMESF ANS R) (CAR POL)))
(GO EAR)))
EXPR)
(DEFPROP FINDVALS
(LAMBDA (SPOL ARGS)
(MAPCAR
(FUNCTION (LAMBDA (Z) (POLEVAL Z
SPOL)))
ARGS))
EXPR)
(DEFPROP LISTDIVIDE
(LAMBDA (STRNG BYROW)
(PROG
(ANS CST CROW)
GONT
(COND ((CAR STRNG) (GO FONT)))
(SETQ ANS (CONS NIL ANS))
(GO BO)
FONT
(SETQ CST (FORMCONST (CAR BYROW)
(RANK (CAR STRNG))))
(SETQ ANS
(CONS (QUOTIENTF (CAR STRNG) CST)
ANS))
BO (COND ((NULL (CDR STRNG))
(RETURN (REV ANS))))
(SETQ STRNG (CDR STRNG))
(SETQ BYROW (CDR BYROW))
(GO GONT)))
EXPR)
(DEFPROP LISTADD
(LAMBDA (LROW SROW)
(PROG (ANS)
BALL (SETQ ANS (CONS (PLUSF (CAR LROW)
(CAR SROW))
ANS))
(COND ((NULL (CDR SROW))
(RETURN (REVERSE ANS))))
(SETQ LROW (CDR LROW))
(SETQ SROW (CDR SROW))
(GO BALL)))
EXPR)
(DEFPROP NEWTON
(LAMBDA (ARGS VALS)
(PROG (VAL SROW PANS ANS)
(SETQ VAL (FIRSTDIF VALS))
(SETQ ARGS (FIRSTDIF ARGS))
(SETQ SROW (CDR ARGS))
(SETQ PANS (LISTDIVIDE VAL ARGS))
(SETQ ANS (CONS (CAR PANS) ANS))
EYE (COND ((NULL (PUREPOLP PANS))
(RETURN NIL))
((NULL (CDR VAL))
(RETURN (CONS (CAR VALS)
(REV ANS)))))
(SETQ VAL (FIRSTDIF PANS))
(SETQ ARGS (LISTADD ARGS SROW))
(SETQ SROW (CDR SROW))
(SETQ PANS (LISTDIVIDE VAL ARGS))
(SETQ ANS (CONS (CAR PANS) ANS))
(GO EYE)))
EXPR)
(DEFPROP PUREPOLP
(LAMBDA (X)
(COND ((NULL X) T)
((POLP (CAR X))
(PUREPOLP (CDR X)))
(T NIL)))
EXPR)
(DEFPROP FIRSTDIF
(LAMBDA (X)
(PROG (ANS)
HERE (COND ((NULL (CDR X))
(RETURN (REV ANS))))
(SETQ ANS
(CONS (DIFFERENCEF (CADR X)
(CAR X))
ANS))
(SETQ X (CDR X))
(GO HERE)))
EXPR)
(QUOTE RAT)
(DEFPROP DDIVIDE
(LAMBDA (A B)
(PROG (C)
(SETQ C (DIVIDE A B))
(RETURN (CONS (CAR C)
(CADR C)))))
EXPR)
(DEFPROP ALLFACTORS
(LAMBDA (X)
((LAMBDA (Q)
(NCONC (MAPCAR (FUNCTION MINUS)
Q)
Q))
(POSFACTORS X)))
EXPR)
(DEFPROP POLCONST
(LAMBDA (Q) (CAR (LAST Q)))
EXPR)
(DEFPROP CARPROD(LAMBDA(X)(PROG()
(SETQ CPLIST X)
(SETQ MAXLIST(MAPCAR(FUNCTION LENGTH)X))
(SETQ CPPLACE(ONELIST(LENGTH X)))
))EXPR)
(DEFPROP ONELIST(LAMBDA(N)(COND((ZEROP N)NIL)((CONS 1(ONELIST(SUB1 N))))))EXPR)
(DEFPROP PULSE(LAMBDA()(PROG(HOLD)
(SETQ HOLD(NFIND CPPLACE CPLIST))
(SETQ CPPLACE(CPADD1 CPPLACE MAXLIST))
(RETURN HOLD)
))EXPR)
(DEFPROP NFIND(LAMBDA(NVECT LISTVECT)(PROG(TOP K)
(COND((NULL NVECT)(RETURN NIL)))
(SETQ K 1)
(SETQ TOP(CAR LISTVECT))
LOOP (COND((EQUAL K(CAR NVECT))(RETURN(CONS
(CAR TOP)(NFIND(CDR NVECT)(CDR LISTVECT))))))
(SETQ K(ADD1 K))
(SETQ TOP(CDR TOP))
(GO LOOP)
))EXPR)
(DEFPROP CPADD1(LAMBDA(VECTOR MAX)(COND
((NULL VECTOR)NIL)
((AND(NULL(CDR VECTOR))(EQUAL(CAR VECTOR)(CAR MAX)))
NIL)
((LESSP(CAR VECTOR)(CAR MAX))
(CONS(ADD1(CAR VECTOR))(CDR VECTOR)))
((CONS 1(CPADD1(CDR VECTOR)(CDR MAX))))
))EXPR)
(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)