Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0039/brats1.l
There are 2 other files named brats1.l in the archive. Click here to see a list.
(DEFPROP P** T SPECIAL)
(DEFPROP Q** T SPECIAL)
(DEFPROP VARLIST T SPECIAL)
(DEFPROP VARS T SPECIAL)
(DEFPROP VARNUM T SPECIAL)
(DEFPROP REPSWITCH T SPECIAL)
(DEFPROP KF T SPECIAL)
(DEFPROP KL T SPECIAL)
(DEFPROP RRNK T SPECIAL)
(DEFPROP KK T SPECIAL)
(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
(DEFPROP MCONS
(LAMBDA (L)
(COND ((NULL (CDDR L)) (CADR L))
(T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
MACRO)
(DEFPROP ONEP
(LAMBDA (X) (MCONS (Q EQ) 1 (CDR X)))
MACRO)
(QUOTE FIELD)
(DEFPROP NUMBERPRL
(LAMBDA (X)
(OR (NUMBERP X)
(AND (NUMBERP (CAR X))
(NUMBERP (CDR X)))))
EXPR)
(DEFPROP RANK
(LAMBDA (P)
(COND ((NULL P)
(ERLIST (QUOTE (RANK OF
NIL))))
((NUMBERPRL P) 0)
((NUMBERP (CAR P)) 1)
((OR (NULL (CDR P))
(NULL (CADR P)))
(RANK1 P))
(T (RANK1 (CDR P)))))
EXPR)
(DEFPROP RANK1
(LAMBDA (P)
(PROG (K)
(SETQ K 0)
A (COND ((NUMBERP P)
(RETURN K)))
(SETQ K (ADD1 K))
(SETQ P (CAR P))
(GO A)))
EXPR)
(DEFPROP POLP
(LAMBDA (P)
(OR (NUMBERP P)
(NULL P)
(NULL (CDR P))
(AND (NOT (NUMBERP (CDR P)))
(ZEROPF (CADR P)))
(NOT (EQUAL (RANK1 (CAR P))
(RANK1 (CDR P))))))
EXPR)
(DEFPROP RATFUNP
(LAMBDA (P) (NOT (POLP P)))
EXPR)
(DEFPROP PFP
(LAMBDA (P)
(OR (POLP P)
(AND (NOT (NUMBERP (CDR P)))
(NULL (CDDR P)))))
EXPR)
(DEFPROP ONEPF
(LAMBDA (R) (EQ (STRIPPAREN R) 1))
EXPR)
(DEFPROP SIMPOL
(LAMBDA (Q)
(PROG NIL
BACK (COND ((NULL Q) (RETURN NIL))
((NOT (ZEROPF (CAR Q)))
(RETURN Q)))
(SETQ Q (CDR Q))
(GO BACK)))
EXPR)
(DEFPROP LISTPLUS
(LAMBDA (Q R)
(PROG (LSUM)
LTH (COND ((NULL Q)
(RETURN (NCONC (REV LSUM)
R)))
((NULL R)
(RETURN (NCONC (REV LSUM)
Q))))
(SETQ LSUM (CONS (POLPLUS (CAR Q)
(CAR R))
LSUM))
(SETQ Q (CDR Q))
(SETQ R (CDR R))
(GO LTH)))
EXPR)
(DEFPROP POLPLUS
(LAMBDA (Q R)
(PROG
(LQ LR)
(COND ((NUMBERP R) (RETURN (*PLUS Q R))))
(SETQ LQ Q)
(SETQ LR R)
LOOP
(COND ((AND (NULL LQ) (NULL LR))
(RETURN (SIMPOL (LISTPLUS Q R))))
((NULL LQ)
(RETURN (SIMPOL (MAPL1 LR R Q))))
((NULL LR)
(RETURN (SIMPOL (MAPL1 LQ Q R)))))
(SETQ LQ (CDR LQ))
(SETQ LR (CDR LR))
(GO LOOP)))
EXPR)
(DEFPROP MAPL1
(LAMBDA (LR R Q)
(PROG (ANS)
LOOP (COND ((NULL LR) (GO L1)))
(SETQ LR (CDR LR))
(SETQ ANS (CONS (CAR R) ANS))
(SETQ R (CDR R))
(GO LOOP)
L1 (RETURN (NCONC (REV ANS)
(LISTPLUS Q R)))))
EXPR)
(DEFPROP POLMINUS
(LAMBDA (Q)
(COND
((NUMBERP Q) (MINUS Q))
(T
(MAPCAR
(FUNCTION (LAMBDA (XX) (POLMINUS XX)))
Q))))
EXPR)
(DEFPROP POLDIFFERENCE
(LAMBDA (Q R)
(POLPLUS Q (POLMINUS R)))
EXPR)
(DEFPROP POLCMULT
(LAMBDA (KK Q)
(COND
((ONEPF KK) Q)
(T
(MAPCAR (FUNCTION (LAMBDA (P)
(POLTIMES KK
P)))
Q))))
EXPR)
(DEFPROP POLTIMES
(LAMBDA (P Q)
(PROG (PSUM ANSWER TEMP)
(COND ((NUMBERP P)
(RETURN (*TIMES P Q)))
((NOT (LESSP (LENGTH P)
(LENGTH Q)))
(GO CONST)))
(SETQ TEMP P)
(SETQ P Q)
(SETQ Q TEMP)
CONST(COND ((NULL (CDR Q))
(RETURN (POLCMULT (CAR Q)
P))))
LOOP (COND ((NULL Q)
(RETURN (NCONC (REV ANSWER)
PSUM))))
(SETQ PSUM
(LISTPLUS PSUM
(POLCMULT (CAR Q)
P)))
RESET(SETQ ANSWER
(CONS (CAR PSUM) ANSWER))
(SETQ PSUM (CDR PSUM))
(SETQ Q (CDR Q))
(GO LOOP)))
EXPR)
(DEFPROP POLDIVIDE
(LAMBDA (P Q)
(PROG
(TCAR ANS CHK FAC MULT)
(COND ((ZEROPF P) (RETURN (CONS P P)))
((NUMBERP P)
(RETURN (DDIVIDE P Q)))
((NULL (CDR Q))
(RETURN (LIST (QUOTIENTF P Q)))))
(SETQ MULT (FORMCONST 1 (SUB1 (RANK P))))
(SETQ CHK (LENGTH Q))
PLIT
(COND
((LESSP (LENGTH P) CHK)
(RETURN
(CONS (QUOTIENTF (REVERSE ANS)
(LIST MULT))
(QUOTIENTF (SIMPOL P)
(LIST MULT))))))
(SETQ TCAR (QUOTIENTF (CAR P) (CAR Q)))
(COND ((RATFUNP TCAR) (GO FIX)))
KIZ(SETQ ANS (CONS TCAR ANS))
(SETQ
P
(LISTPLUS
(CDR P)
(POLMINUS (POLCMULT TCAR (CDR Q)))))
(GO PLIT)
FIX(SETQ FAC (CDR TCAR))
(SETQ TCAR (CAR TCAR))
(SETQ ANS (POLCMULT FAC ANS))
(SETQ P (POLCMULT FAC P))
(SETQ MULT (POLTIMES FAC MULT))
(GO KIZ)))
EXPR)
(DEFPROP POLQUOTIENT
(LAMBDA (P Q)
(CAR (POLDIVIDE P Q)))
EXPR)
(DEFPROP POLREMAINDER
(LAMBDA (P Q)
(CDR (POLDIVIDE P Q)))
EXPR)
(DEFPROP PPQUOTIENT
(LAMBDA (P Q)
(PROG
(TCAR ANS MOO CHK)
(COND ((ZEROPF P) (RETURN P))
((NUMBERP P)
(RETURN (QUOTIENT P Q)))
((NULL (CDR Q))
(RETURN (PPCQUOT (CAR Q) P))))
(SETQ CHK (LENGTH Q))
PLIT
(SETQ TCAR (PPQUOTIENT (CAR P) (CAR Q)))
(SETQ ANS (CONS TCAR ANS))
(SETQ MOO (LENGTH P))
(COND
((EQUAL MOO CHK) (RETURN (REV ANS)))
((LESSP MOO CHK)
(ERLIST (QUOTE (PPQUOTIENT ERROR)))))
(SETQ
P
(LISTPLUS
(CDR P)
(POLMINUS (POLCMULT TCAR (CDR Q)))))
(GO PLIT)))
EXPR)
(DEFPROP PPCQUOT
(LAMBDA (KL Q)
(COND
((ONEPF KL) Q)
(T
(MAPCAR
(FUNCTION (LAMBDA (J)
(PPQUOTIENT J KL)))
Q))))
EXPR)
(DEFPROP PFDIVIDE
(LAMBDA (P Q)
(PROG (ANS THAT SHAT)
(COND ((ZEROPF P)
(RETURN (CONS P P)))
((AND (POLP P) (POLP Q))
(RETURN (POLDIVIDE P Q))))
(SETQ SHAT (DENOMINATORF P))
(SETQ THAT
(QUOTIENTF (DENOMINATORF Q)
SHAT))
(SETQ P (NUMERATORF P))
(SETQ Q (NUMERATORF Q))
(SETQ ANS (POLDIVIDE P Q))
(RETURN (CONS (TIMESF THAT
(CAR ANS))
(QUOTIENTF (CDR ANS)
SHAT)))))
EXPR)
(DEFPROP PFQUOTIENT
(LAMBDA (P Q) (CAR (PFDIVIDE P Q)))
EXPR)
(DEFPROP PFREMAINDER
(LAMBDA (P Q) (CDR (PFDIVIDE P Q)))
EXPR)
(DEFPROP POLEXPT
(LAMBDA (P K)
(PROG
(ANS)
(COND
((NUMBERP P) (RETURN (EXPT P K)))
((ZEROP K)
(RETURN (FORMCONST 1 (RANK P))))
((MINUSP K)
(ERLIST (QUOTE (NEGATIVE EXPONENT
GIVEN
TO
POLEXPT)))))
(SETQ ANS P)
LOOP
(COND ((ONEP K) (RETURN ANS)))
(SETQ ANS (POLTIMES P ANS))
(SETQ K (SUB1 K))
(GO LOOP)))
EXPR)
(DEFPROP REDUCEF
(LAMBDA (R)
(PROG
(GCDLOC NUM DEM)
(COND ((ZEROPF (CAR R))
(RETURN (CAR R))))
(SETQ NUM (CAR R))
(SETQ DEM (CDR R))
(SETQ GCDLOC (POLGCD NUM DEM))
(COND
((EQUAL DEM GCDLOC)
(RETURN (PPQUOTIENT NUM GCDLOC)))
((EQUAL (POLMINUS DEM) GCDLOC)
(RETURN
(POLMINUS (PPQUOTIENT NUM GCDLOC))))
((POLMINUSP DEM)
(CONS (SETQ NUM (POLMINUS NUM))
(SETQ DEM (POLMINUS DEM)))))
(RETURN (CONS (PPQUOTIENT NUM GCDLOC)
(PPQUOTIENT DEM GCDLOC)))))
EXPR)
(DEFPROP FORMRATFUN
(LAMBDA (P)
(PROG
NIL
(COND ((RATFUNP P) (RETURN P)))
(RETURN (CONS P
(FORMCONST 1 (RANK P))))))
EXPR)
(DEFPROP FORMCONST
(LAMBDA (N RNK)
(PROG NIL
LOOP (COND ((ZEROP RNK)
(RETURN N))
((EQUAL N 0)
(RETURN NIL)))
(SETQ N (LIST N))
(SETQ RNK (SUB1 RNK))
(GO LOOP)))
EXPR)
(DEFPROP MINUSF
(LAMBDA (R)
(COND ((POLP R) (POLMINUS R))
(T (CONS (POLMINUS (CAR R))
(CDR R)))))
EXPR)
(DEFPROP INVERTF
(LAMBDA (R)
(PROG ()
(COND ((ONEPF R) (RETURN R))
((POLP R)
(SETQ R (FORMRATFUN R))))
(COND ((ONEPF (CAR R))
(RETURN (CDR R))))
(RETURN (CONS (CDR R) (CAR R)))))
EXPR)
(DEFPROP PLUSF
(LAMBDA (R S)
(PROG
(THEGCD)
(COND ((NULL R) (RETURN S))
((NULL S) (RETURN R))
((AND (POLP R) (POLP S))
(RETURN (POLPLUS R S)))
((POLP R) (SETQ R (FORMRATFUN R)))
((POLP S) (SETQ S (FORMRATFUN S))))
(SETQ THEGCD (POLGCD (CDR R) (CDR S)))
(COND
((ONEPF THEGCD)
(RETURN
(CONS (POLPLUS (POLTIMES (CAR R)
(CDR S))
(POLTIMES (CDR R)
(CAR S)))
(POLTIMES (CDR R) (CDR S))))))
(RETURN
(REDUCEF
(CONS
(POLPLUS
(POLTIMES (CAR R)
(PPQUOTIENT (CDR S)
THEGCD))
(POLTIMES (CAR S)
(PPQUOTIENT (CDR R)
THEGCD)))
(POLTIMES (CDR R)
(PPQUOTIENT (CDR S)
THEGCD)))))))
EXPR)
(DEFPROP DIFFERENCEF
(LAMBDA (R S) (PLUSF R (MINUSF S)))
EXPR)
(DEFPROP TIMESF
(LAMBDA (R S)
(PROG
(CANCEL1 CANCEL2)
(COND ((OR (NULL R) (NULL S))
(RETURN NIL))
((ONEPF R) (RETURN S))
((ONEPF S) (RETURN R))
((AND (POLP R) (POLP S))
(RETURN (POLTIMES R S)))
((POLP R) (SETQ R (FORMRATFUN R)))
((POLP S) (SETQ S (FORMRATFUN S))))
(SETQ CANCEL1
(REDUCEF (CONS (CAR R) (CDR S))))
(SETQ CANCEL2
(REDUCEF (CONS (CAR S) (CDR R))))
(RETURN
(COND
((AND (POLP CANCEL1) (POLP CANCEL2))
(POLTIMES CANCEL1 CANCEL2))
((POLP CANCEL1)
(CONS (POLTIMES CANCEL1 (CAR CANCEL2))
(CDR CANCEL2)))
((POLP CANCEL2)
(CONS (POLTIMES CANCEL2 (CAR CANCEL1))
(CDR CANCEL1)))
(T (CONS (POLTIMES (CAR CANCEL1)
(CAR CANCEL2))
(POLTIMES (CDR CANCEL1)
(CDR CANCEL2))))))))
EXPR)
(DEFPROP QUOTIENTF
(LAMBDA (R S)
(TIMESF R (INVERTF S)))
EXPR)
(DEFPROP EXPTF
(LAMBDA (R K)
(COND ((POLP R) (POLEXPT R K))
(T (CONS (POLEXPT (CAR R) K)
(POLEXPT (CDR R)
K)))))
EXPR)
(QUOTE AFIELD)
(DEFPROP POLABSOLUTE
(LAMBDA (X)
(COND ((NUMBERP X) (ABS X))
((POLMINUSP X)
(POLMINUS X))
(T X)))
EXPR)
(DEFPROP ZEROLISTF
(LAMBDA (N RNK)
(PROG (Z ZL)
(COND ((ONEP RNK)
(SETQ Z 0)))
ZAG (COND ((ZEROP N)
(RETURN ZL)))
(SETQ ZL (CONS Z ZL))
(SETQ N (SUB1 N))
(GO ZAG)))
EXPR)
(DEFPROP NUMERATORF
(LAMBDA (R) (COND ((POLP R) R)
(T (CAR R))))
EXPR)
(DEFPROP DENOMINATORF
(LAMBDA (R) (COND ((POLP R)
(FORMCONST 1 (RANK R)))
(T (CDR R))))
EXPR)
(DEFPROP POLDERIVATIVE
(LAMBDA (P)
(PROG
(DER RNK N)
(COND ((NULL P) (RETURN NIL)))
(SETQ RNK (SUB1 (RANK P)))
(SETQ N 1)
(SETQ P (CDR (REVERSE P)))
LAG(COND ((NULL P) (RETURN DER)))
(SETQ DER
(CONS (POLTIMES (CAR P)
(FORMCONST N RNK))
DER))
(SETQ N (ADD1 N))
(SETQ P (CDR P))
(GO LAG)))
EXPR)
(DEFPROP POLINTEGRAL
(LAMBDA (P)
(PROG
(INT RNK N)
(COND ((NULL P) (RETURN NIL)))
(SETQ RNK (SUB1 (RANK P)))
(SETQ N 1)
(SETQ INT (ZEROLISTF 1 (ADD1 RNK)))
(SETQ P (REVERSE P))
HAG(COND ((NULL P) (RETURN (UNMONIC INT))))
(SETQ
INT
(CONS (TIMESF (CAR P)
(INVERTF (FORMCONST N
RNK)))
INT))
(SETQ N (ADD1 N))
(SETQ P (CDR P))
(GO HAG)))
EXPR)
(DEFPROP PFDERIVATIVE
(LAMBDA (P)
(COND
((POLP P) (POLDERIVATIVE P))
(T (QUOTIENTF (POLDERIVATIVE (CAR P))
(CDR P)))))
EXPR)
(DEFPROP PFINTEGRAL
(LAMBDA (P)
(COND ((POLP P) (POLINTEGRAL P))
(T (QUOTIENTF (POLINTEGRAL (CAR P))
(CDR P)))))
EXPR)
(DEFPROP POLGCD
(LAMBDA (P Q)
(PROG
(TEMP CONFAC
PCONF
QCONF
QMULT
P1
PT
QT
RRNK
QFIND
LP
LQ
DELTA
DELTA1
CC)
(COND
((NUMBERP P) (RETURN (GCD P Q)))
((NULL Q) (RETURN P))
((NULL P) (RETURN Q))
((OR (ONEPF P) (ONEPF Q))
(RETURN (FORMCONST 1 (RANK P))))
((OR (NULL (CDR P)) (NULL (CDR Q)))
(RETURN (LIST (RINGGCD (APPEND P
Q))))))
(SETQ PCONF (RINGGCD P))
(SETQ QCONF (RINGGCD Q))
(SETQ CONFAC (POLGCD PCONF QCONF))
(SETQ P (PPCQUOT PCONF P))
(SETQ Q (PPCQUOT QCONF Q))
(SETQ RRNK (RANK P))
(COND ((NOT (ONEP RRNK)) (GO TEST)))
LTST
(COND ((NOT (LESSP (LENGTH P)
(LENGTH Q)))
(GO INIT)))
(SETQ TEMP P)
(SETQ P Q)
(SETQ Q TEMP)
INIT
(SETQ DELTA 0)
(SETQ LQ (LENGTH Q))
(SETQ DELTA1
(ADD1 (DIFFERENCE (LENGTH P) LQ)))
(GO WFL)
REV(SETQ LP (LENGTH P1))
(SETQ TEMP Q)
(SETQ Q (PPCQUOT (POLEXPT CC DELTA) P1))
(SETQ P TEMP)
(SETQ DELTA DELTA1)
(SETQ DELTA1 (ADD1 (DIFFERENCE LQ LP)))
(SETQ LQ LP)
WFL(SETQ CC (CAR P))
(SETQ QMULT (CAR Q))
(SETQ QFIND (POLMINUS (CDR Q)))
(COND ((NULL QFIND)
(RETURN (LIST CONFAC))))
STEP
(SETQ P
(LISTPLUS (POLCMULT QMULT (CDR P))
(POLCMULT (CAR P)
QFIND)))
(SETQ P1 (SIMPOL P))
(COND
((NULL P1)
(RETURN
(POLABSOLUTE
(POLCMULT CONFAC (PPCQUOT (RINGGCD Q)
Q))))))
(COND ((LESSP (LENGTH P) LQ) (GO REV)))
(GO STEP)
TEST
(SETQ PT (HMORPH P))
(SETQ QT (HMORPH Q))
(COND
((AND (ZEROP (CAR PT)) (ZEROP (CAR QT)))
(GO LTST))
((ONEP (LENGTH (POLGCD (SIMPOL PT)
(SIMPOL QT))))
(RETURN (LIST CONFAC))))
(GO LTST)))
EXPR)
(DEFPROP HMORPH
(LAMBDA (X)
(MAPCAR (FUNCTION (LAMBDA (J)
(MORPH J RRNK)))
X))
EXPR)
(DEFPROP MORPH
(LAMBDA (X RNKP1)
(PROG (ANS ME)
(COND ((NULL X) (RETURN 0))
((NUMBERP X) (RETURN X)))
(SETQ ANS 0)
(SETQ ME
(*TIMES (EXPT -1 RNKP1)
(QUOTIENT RNKP1 2)))
BLIP (SETQ ANS
(*PLUS (MORPH (CAR X)
(SUB1 RNKP1))
(*TIMES ME ANS)))
(SETQ X (CDR X))
(COND (X (GO BLIP)))
(RETURN ANS)))
EXPR)
(DEFPROP RCONFAC
(LAMBDA (X)
(PPCQUOT (RINGGCD X) X))
EXPR)
(DEFPROP POLMINUSP
(LAMBDA (R) (COND ((NULL R) NIL)
((NUMBERP R) (MINUSP R))
(T (POLMINUSP (CAR R)))))
EXPR)
(DEFPROP MINUSPF
(LAMBDA (R) (COND ((POLP R) (POLMINUSP R))
(T (POLMINUSP (CAR R)))))
EXPR)
(DEFPROP UNMONIC
(LAMBDA (R)
(PROG
(DOIT CDOIT)
(COND
((OR (NULL R)
(NUMBERPRL R)
(AND (NOT (NULL (CDR R)))
(NOT (NULL (CADR R)))
(GREATERP (RANK (CAR R))
(RANK (CADR R)))))
(RETURN R)))
(SETQ
DOIT
(REVERSE
(CONS (FORMCONST 1 (SUB1 (RANK R)))
R)))
TODO
(SETQ CDOIT (CAR DOIT))
(COND
((ONEP (LENGTH DOIT)) (GO RET))
((POLP CDOIT) (SETQ DOIT (CDR DOIT)))
(T (SETQ DOIT
(PFCMULT (DENOMINATORF CDOIT)
(CDR DOIT)))))
(GO TODO)
RET(COND ((ONEPF CDOIT) (RETURN R)))
(RETURN (CONS (PFCMULT CDOIT R)
(LIST CDOIT)))))
EXPR)
(DEFPROP PFCMULT
(LAMBDA (KF Q)
(COND
((ONEPF KF) Q)
(T (MAPCAR (FUNCTION (LAMBDA (P)
(TIMESF KF P)))
Q))))
EXPR)
(DEFPROP RINGGCD
(LAMBDA (X)
(PROG
(ONE ANS)
(COND ((NULL X) (RETURN NIL))
((NOT (NUMBERP (CAR X)))
(SETQ X (ELIMNIL X))))
(COND ((NULL (CDR X))
(RETURN (POLABSOLUTE (CAR X))))
((NULL (CDDR X))
(RETURN (POLGCD (CAR X)
(CADR X)))))
(SETQ ONE (FORMCONST 1 (SUB1 (RANK X))))
(COND ((MEMBER ONE X) (RETURN ONE)))
(COND ((NOT (NUMBERP ONE))
(SETQ X (ORDERLTH X))))
(SETQ ANS (CAR X))
(SETQ X (CDR X))
SPEW
(SETQ ANS (POLGCD ANS (CAR X)))
(SETQ X (CDR X))
(COND ((EQUAL ANS ONE) (RETURN ONE))
((NULL X) (RETURN ANS)))
(GO SPEW)))
EXPR)
(DEFPROP ORDERLTH
(LAMBDA (X)
(PROG
(PR CHK FILE LNTH)
(COND ((OR (NULL X) (NULL (CDR X)))
(RETURN X)))
(SETQ
PR
(MAPCAR
(FUNCTION (LAMBDA (J)
(CONS J (LENGTH J))))
X))
RESE
(SETQ CHK (NCONC (REV FILE)
(CONS (CAR PR) CHK)))
(SETQ PR (CDR PR))
(COND ((NULL PR)
(RETURN (MAPCAR (FUNCTION CAR)
CHK))))
(SETQ LNTH (CDAR PR))
(SETQ FILE NIL)
COMP
(COND ((NOT (GREATERP LNTH (CDAR CHK)))
(GO RESE)))
(SETQ FILE (CONS (CAR CHK) FILE))
(SETQ CHK (CDR CHK))
(COND ((NULL CHK) (GO RESE)))
(GO COMP)))
EXPR)
(DEFPROP ELIMNIL
(LAMBDA (X)
(PROG (ANS)
A (COND ((NULL X) (RETURN ANS))
((CAR X)
(SETQ ANS
(CONS (CAR X)
ANS))))
(SETQ X (CDR X))
(GO A)))
EXPR)
(DEFPROP UPLEVEL
(LAMBDA (LST)
(PROG (ANS)
SOLD (COND ((NULL LST)
(RETURN (REV ANS))))
(SETQ ANS
(APPEND (CAR LST) ANS))
(SETQ LST (CDR LST))
(GO SOLD)))
EXPR)
(DEFPROP SQRTF
(LAMBDA (R)
(PROG
(NUMRT DENOMRT)
(COND ((NUMBERP R) (RETURN (NSQRT R))))
(COND ((POLP R) (RETURN (RINGSQRT R))))
FRCT
(SETQ NUMRT (RINGSQRT (CAR R)))
(SETQ DENOMRT (RINGSQRT (CDR R)))
(RETURN
(CONS (QUOTIENTF (CAR NUMRT)
(CAR DENOMRT))
(QUOTIENTF (CDR NUMRT)
(CDR DENOMRT))))))
EXPR)
(DEFPROP RINGSQRT
(LAMBDA (Q)
(PROG
(COEF MULTS SINGLES ANS SQCOEF)
(COND ((ONEPF Q) (RETURN (CONS Q Q)))
((NUMBERP Q) (RETURN (NSQRT Q)))
((ONEP (LENGTH Q)) (GO LONE)))
(SETQ COEF (RINGGCD Q))
(COND ((POLMINUSP Q)
(SETQ COEF (POLMINUS COEF))))
(SETQ Q (PPCQUOT COEF Q))
(SETQ ANS (FORMCONST 1 (RANK Q)))
LUCK
(SETQ MULTS (POLGCD (POLDERIVATIVE Q) Q))
(COND ((ONEP (LENGTH MULTS)) (GO SUCK)))
(SETQ SINGLES (POLQUOTIENT Q MULTS))
(SETQ ANS
(POLTIMES ANS
(POLGCD MULTS SINGLES)))
(SETQ Q
(POLQUOTIENT Q (POLTIMES ANS ANS)))
(GO LUCK)
SUCK
(SETQ SQCOEF (RINGSQRT COEF))
(RETURN (CONS (POLCMULT (CAR SQCOEF) ANS)
(POLCMULT (CDR SQCOEF) Q)))
LONE
(SETQ SQCOEF (RINGSQRT (CAR Q)))
(RETURN (CONS (LIST (CAR SQCOEF))
(LIST (CDR SQCOEF))))))
EXPR)
(DEFPROP NSQRT
(LAMBDA (N)
(PROG
(RT TRY SQUD)
(SETQ RT 1)
TWO(COND ((NOT (ZEROP (REMAINDER N 4)))
(GO NEXT)))
(SETQ RT (TIMES 2 RT))
(SETQ N (QUOTIENT N 4))
(GO TWO)
NEXT
(SETQ TRY 3)
(SETQ SQUD 11)
LOOP
(COND ((GREATERP SQUD (ABS N))
(RETURN (CONS RT N)))
((NOT (ZEROP (REMAINDER N SQUD)))
(GO RSET)))
(SETQ RT (TIMES TRY RT))
(SETQ N (QUOTIENT N SQUD))
(GO LOOP)
RSET
(SETQ TRY (PLUS TRY 2))
(SETQ SQUD (TIMES TRY TRY))
(GO LOOP)))
EXPR)
(QUOTE NEWREP)
(SETQ REPSWITCH NIL)
(DEFPROP REP
(LAMBDA (W)
(PROG
(ANS)
(COND ((EQUAL W 0)
(RETURN (COND ((NULL VARLIST) 0)
(T NIL)))))
(SETQ
ANS
(COND
((NUMBERP W) (MAKERANK VARNUM W))
((MEMBER W VARLIST) (REPVAR W))
((EQUAL (CAR W) (QUOTE PLUS))
(PLUSF (REP (CADR W))
(REP (CADDR W))))
((EQUAL (CAR W) (QUOTE DIFFERENCE))
(DIFFERENCEF (REP (CADR W))
(REP (CADDR W))))
((EQUAL (CAR W) (QUOTE TIMES))
(TIMESF (REP (CADR W))
(REP (CADDR W))))
((EQUAL (CAR W) (QUOTE QUOTIENT))
(QUOTIENTF (REP (CADR W))
(REP (CADDR W))))
((EQUAL (CAR W) (QUOTE EXPT))
(COND
((MINUSP (CADDR W))
(EXPTF (QUOTIENTF (MAKERANK VARNUM
1)
(REP (CADR W)))
(MINUS (CADDR W))))
(T (EXPTF (REP (CADR W))
(CADDR W)))))
((EQUAL (CAR W) (QUOTE MINUS))
(MINUSF (REP (CADR W))))
(T
(ERLIST
(QUOTE (INADMISSABLE CHARACTERS))))))
(COND ((NOT REPSWITCH) (RETURN ANS)))
(FORMFLIST ANS)
(RETURN ANS)))
EXPR)
(DEFPROP MAKERANK
(LAMBDA (RNK EXPRESSION)
(COND ((GREATERP (RANK EXPRESSION) RNK)
(ERLIST (QUOTE (VARNUM IS
INCORRECT))))
((EQUAL (RANK EXPRESSION) RNK)
EXPRESSION)
(T (MAKERANK RNK
(LIST EXPRESSION)))))
EXPR)
(DEFPROP NEWVAR1
(LAMBDA (X)
(COND ((MEMBER X VARLIST) NIL)
((NUMBERP X) NIL)
((ATOM X)
(SETQ VARLIST (CONS X VARLIST)))
((MEMBER (CAR X)
(QUOTE (PLUS DIFFERENCE
TIMES
QUOTIENT)))
(LIST (NEWVAR (CADR X))
(NEWVAR (CADDR X))))
((EQ (CAR X) (QUOTE MINUS))
(NEWVAR (CADR X)))
((AND (EQ (CAR X) (QUOTE EXPT))
(NUMBERP (CADDR X)))
(NEWVAR (CADR X)))
(T (SETQ VARLIST
(CONS X VARLIST)))))
EXPR)
(DEFPROP NEWVAR
(LAMBDA (X) (PROG NIL
(NEWVAR1 X)
(SETQ VARNUM
(LENGTH VARLIST))))
EXPR)
(DEFPROP REPVAR
(LAMBDA (X)
(PROG
(VARS RNK)
(SETQ VARS VARLIST)
(SETQ RNK 0)
SNRK
(COND ((EQUAL X (CAR VARS)) (GO MVAR)))
(SETQ VARS (CDR VARS))
(SETQ RNK (ADD1 RNK))
(GO SNRK)
MVAR
(COND
((ZEROP RNK)
(RETURN (MAKERANK VARNUM
(QUOTE (1 0))))))
(RETURN (MAKERANK VARNUM
(LIST (FORMCONST 1 RNK)
NIL)))))
EXPR)
(QUOTE DISREP)
(DEFPROP SIMPSIMP
(LAMBDA (X)
(COND
((AND(NUMBERP X)(MINUSP X))
(LIST(QUOTE MINUS)(MINUS X)))
((ATOM X) X)
((EQ (CAR X) (QUOTE MINUS))
((LAMBDA (A)
(COND ((AND (NOT (ATOM A))
(EQ (CAR A)
(QUOTE MINUS)))
(CADR A))
(T (LIST (QUOTE MINUS) A))))
(SIMPSIMP (CADR X))))
((EQ (CAR X) (QUOTE PLUS))
(PLUSSIMP X))
((EQ (CAR X) (QUOTE DIFFERENCE))
((LAMBDA (A B)
(COND ((EQ A 0)
(LIST (QUOTE MINUS) B))
((EQ B 0) A)
((AND (NOT (ATOM B))
(EQ (CAR B)
(QUOTE MINUS)))
(LIST (QUOTE PLUS) A (CADR B)))
(T (LIST (QUOTE DIFFERENCE)
A
B))))
(SIMPSIMP (CADR X))
(SIMPSIMP (CADDR X))))
((AND(EQ(CAR X)(Q TIMES))(CDDDR X))
(SIMPSIMP(LIST(Q TIMES)(CADR X)(CONS(Q TIMES)(CDDR X)))))
((EQ (CAR X) (QUOTE TIMES))
((LAMBDA (A B)
(COND
((OR (EQ A 0) (EQ B 0)) 0)
((EQ A 1) B)
((EQ B 1) A)
((AND (NOT (ATOM A))
(NOT (ATOM B))
(EQ (CAR A)
(QUOTE MINUS))
(EQ (CAR B)
(QUOTE MINUS)))
(COND((EQ(CADR A)1)(CADR B))
((EQ(CADR B)1)(CADR A))
((LIST(Q TIMES)(CADR A)(CADR B)))
))
((AND (NOT (ATOM A))
(EQ (CAR A)
(QUOTE MINUS)))
(LIST (QUOTE MINUS)
(COND((EQ(CADR A)1)B)
((LIST(Q TIMES)(CADR A)B))
)))
((AND (NOT (ATOM B))
(EQ (CAR B)
(QUOTE MINUS)))
(LIST (QUOTE MINUS)
(COND((EQ(CADR B)1)A)
((LIST(Q TIMES)A(CADR B)))
)))
(T (LIST (QUOTE TIMES) A B))))
(SIMPSIMP (CADR X))
(SIMPSIMP (CADDR X))))
((EQ (CAR X) (QUOTE QUOTIENT))
((LAMBDA (A B)
(COND
((EQ A 0) 0)
((EQ B 1) A)
((AND(NOT(ATOM B))(EQ(CAR B)(Q MINUS))(EQ(CADR B)1))
(COND((AND(NOT(ATOM A))(EQ(CAR A)(Q MINUS)))(CADR A))
((LIST(Q MINUS)A))))
((AND (NOT (ATOM A))
(NOT (ATOM B))
(EQ (CAR A)
(QUOTE MINUS))
(EQ (CAR B)
(QUOTE MINUS)))
(LIST (QUOTE QUOTIENT)
(CADR A)
(CADR B)))
((AND (NOT (ATOM A))
(EQ (CAR A)
(QUOTE MINUS)))
(LIST (QUOTE MINUS)
(LIST (QUOTE QUOTIENT)
(CADR A)
B)))
((AND (NOT (ATOM B))
(EQ (CAR B)
(QUOTE MINUS)))
(LIST (QUOTE MINUS)
(LIST (QUOTE QUOTIENT)
A
(CADR B))))
(T (LIST (QUOTE QUOTIENT)
A
B))))
(SIMPSIMP (CADR X))
(SIMPSIMP (CADDR X))))
(T (CONS (SIMPSIMP (CAR X))
(SIMPSIMP (CDR X))))))
EXPR)
(DEFPROP PLUSSIMP
(LAMBDA (X)
(COND
((CDDDR X)
(PLUSSIMP (LIST (QUOTE PLUS)
(CADR X)
(CONS (QUOTE PLUS)
(CDDR X)))))
(T
((LAMBDA (A B)
(COND ((EQ A 0) B)
((EQ B 0) A)
((AND (NOT (ATOM B))
(EQ (CAR B)
(QUOTE MINUS)))
(LIST (QUOTE DIFFERENCE)
A
(CADR B)))
(T (LIST (QUOTE PLUS) A B))))
(SIMPSIMP (CADR X))
(SIMPSIMP (CADDR X))))))
EXPR)
(DEFPROP POLDISREP
(LAMBDA (P VARS)
(PROG (POL ANS PON MV NEXT)
(COND ((NULL P) (RETURN 0))
((NUMBERP P) (RETURN P))
((NULL (CDR P))
(RETURN (POLDISREP (CAR P)
(CDR VARS)))))
(SETQ MV (CAR VARS))
(SETQ POL
(REV
(MAPCAR
(FUNCTION
(LAMBDA (J) (POLDISREP J
(CDR VARS))))
P)))
(SETQ ANS (CAR POL))
(SETQ POL (CDR POL))
(SETQ NEXT (CAR POL))
(SETQ PON 2)
(COND ((EQ NEXT 0) (GO TRIT)))
(SETQ ANS
(CHPLUS (CHTIMES NEXT MV)
ANS))
TRIT (SETQ POL (CDR POL))
(COND ((NULL POL) (RETURN ANS)))
(SETQ NEXT (CAR POL))
(COND ((EQ NEXT 0) (GO CLIN)))
(SETQ ANS
(CHPLUS
(CHTIMES NEXT
(LIST (QUOTE EXPT)
MV
PON))
ANS))
CLIN (SETQ PON (ADD1 PON))
(GO TRIT)))
EXPR)
(DEFPROP CHPLUS
(LAMBDA (A B)
(COND
((EQ B 0) A)
((LIST (QUOTE PLUS) A B))))
EXPR)
(DEFPROP CHTIMES
(LAMBDA (A B)
(COND
((EQ A 1) B)
((LIST (QUOTE TIMES) A B))))
EXPR)
(DEFPROP DISREP
(LAMBDA (R VARS)
(PROG NIL
(SETQ VARS (CHOP R VARS))
(RETURN
(COND
((POLP R) (POLDISREP R VARS))
((LIST (QUOTE QUOTIENT)
(POLDISREP (CAR R) VARS)
(POLDISREP (CDR R)
VARS)))))))
EXPR)
(DEFPROP CHOP
(LAMBDA (R VARS)
(PROG (N)
(COND ((NULL R) (RETURN 0)))
(SETQ N (RANK R))
LOOP (COND ((EQUAL (LENGTH VARS) N)
(RETURN VARS)))
(SETQ VARS (CDR VARS))
(GO LOOP)))
EXPR)
(DEFPROP TRANS
(LAMBDA (R)
(DISREP R (REVERSE VARLIST)))
EXPR)
(DEFPROP FIELDTRANS
(LAMBDA (R) (TRANS R))
EXPR)
(DEFPROP POLTRANS
(LAMBDA (R) (TRANS R))
EXPR)