Artifact 63bc0160db38d3c59144b5f784d8b413353fee4fae244834990b28069fd89402:
- File
perq-pascal-lisp-project/poly.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 19386) [annotate] [blame] [check-ins using] [more...]
OFF ECHO,RAISE$ LISP; % Simple POLY, RAT AND ALG system, based on POLY by Fitch and Marti. % Modifed by GRISS and GALWAY % September 1980. % Further modified by MORRISON % October 1980. % Parser modified by OTTENHEIMER % February 1981, to be left associative March 1981. % Current bug: print routines print as if right associative. % MORRISON again, March 1981. % Parses INFIX expressions to PREFIX, then SIMPlifies and PRINTs % Handles also PREFIX expressions % RUNNING: After loading POLY.RED, run function ALGG(); % This accepts a sequence of expressions: % <exp> ; (Semicolon terminator) % <exp> ::= <term> [+ <exp> | - <exp>] % <term> ::= <primary> [* <term> | / <term>] % <primary> ::= <primary0> [^ <primary0> | ' <primary0> ] % ^ is exponentiation, ' is derivative % <primary0> ::= <number> | <variable> | ( <exp> ) % PREFIX Format: <number> | <id> | (op arg1 arg2) % + -> PLUS2 % - -> DIFFERENCE (or MINUS) % * -> TIMES2 % / -> QUOTIENT % ^ -> EXPT % ' -> DIFF % Canonical Formats: Polynomial: integer | (term . polynomial) % term : (power . polynomial) % power : (variable . integer) % Rational : (polynomial . polynomial) %******************** Selectors and Constructors ********************** SYMBOLIC SMACRO PROCEDURE RATNUM X; % parts of Rational CAR X; SYMBOLIC SMACRO PROCEDURE RATDEN X; CDR X; SYMBOLIC SMACRO PROCEDURE MKRAT(X,Y); CONS(X,Y); SYMBOLIC SMACRO PROCEDURE POLTRM X; % parts of Poly CAR X; SYMBOLIC SMACRO PROCEDURE POLRED X; CDR X; SYMBOLIC SMACRO PROCEDURE MKPOLY(X,Y); CONS(X,Y); SYMBOLIC SMACRO PROCEDURE TRMPWR X; % parts of TERM CAR X; SYMBOLIC SMACRO PROCEDURE TRMCOEF X; CDR X; SYMBOLIC SMACRO PROCEDURE MKTERM(X,Y); CONS(X,Y); SYMBOLIC SMACRO PROCEDURE PWRVAR X; % parts of Poly CAR X; SYMBOLIC SMACRO PROCEDURE PWREXPT X; CDR X; SYMBOLIC SMACRO PROCEDURE MKPWR(X,Y); CONS(X,Y); SYMBOLIC SMACRO PROCEDURE POLVAR X; PWRVAR TRMPWR POLTRM X; SYMBOLIC SMACRO PROCEDURE POLEXPT X; PWREXPT TRMPWR POLTRM X; SYMBOLIC SMACRO PROCEDURE POLCOEF X; TRMCOEF POLTRM X; %*********************** Utility Routines ***************************** SYMBOLIC PROCEDURE VARP X; IDP X OR (PAIRP X AND IDP CAR X); %*********************** Entry Point ********************************** GLOBAL '(!*RBACKTRACE !*RECHO REXPRESSION!* !*RMESSAGE); !*RECHO := !*RMESSAGE := T; SYMBOLIC PROCEDURE ALGG(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV; ALGINIT(); CLEARTOKEN(); % Initialize scanner LOOP: VVV := ERRORSET('(RPARSE),T,!*RBACKTRACE); IF ATOM VVV THEN % What about resetting the Scanner? <<PRINT LIST('ALGG, 'error, VVV); CLEARTOKEN();GO TO LOOP>>; REXPRESSION!* := CAR VVV; IF !*RECHO THEN PRINT REXPRESSION!*; IF REXPRESSION!* EQ 'QUIT THEN << PRINT 'QUITTING; RETURN >>; ERRORSET('(PREPRINT (PRESIMP REXPRESSION!*)),T,!*RBACKTRACE); GO TO LOOP END ALGG; SYMBOLIC PROCEDURE ALGINIT(); %. Called to INIT tables BEGIN INITTOKEN(); PUT('TIMES2,'RSIMP,'R!*); %. Simplifier Tables PUT('PLUS2,'RSIMP,'R!+); PUT('DIFFERENCE,'RSIMP,'R!-); PUT('QUOTIENT,'RSIMP,'R!/); PUT('EXPT,'RSIMP,'R!^); PUT('DIFF,'RSIMP,'R!'); PUT('MINUS,'RSIMP,'R!.NEG); PUT('!+,'REXP,'PLUS2); % Use corresponding 'R!xx in EVAL mode PUT('!-,'REXP,'DIFFERENCE); PUT('!*,'RTERM,'TIMES2);; PUT('!/,'RTERM,'QUOTIENT); PUT('!^,'RPRIMARY,'EXPT); PUT('!','RPRIMARY,'DIFF); PUT('PLUS2,'PRINOP,'PLUSPRIN); %. Output funs PUT('DIFFERENCE,'PRINOP,'DIFFERENCEPRIN); PUT('TIMES2,'PRINOP,'TIMESPRIN); PUT('QUOTIENT,'PRINOP,'QUOTPRIN); PUT('EXPT,'PRINOP,'EXPPRIN); END; SYMBOLIC PROCEDURE RSIMP X; %. Simplify Prefix Form to Canonical IF ATOM X THEN RCREATE X ELSE BEGIN SCALAR Y,OP; OP:=CAR X; IF (Y:=GET(OP,'RSIMP)) THEN RETURN XAPPLY(Y,RSIMPL CDR X); Y:=PRESIMP X; % As "variable" ? IF ATOM Y OR NOT(X=Y) THEN RETURN RSIMP Y; RETURN RCREATE Y; END; SYMBOLIC PROCEDURE RSIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE RSIMP(CAR X) . RSIMPL CDR X; SYMBOLIC PROCEDURE PRESIMP X; %. Simplify Prefix Form to PREFIX IF ATOM X THEN X ELSE BEGIN SCALAR Y,OP; OP:=CAR X; IF (Y:=GET(OP,'RSIMP)) THEN RETURN RAT2PRE XAPPLY(Y,RSIMPL CDR X); X:=PRESIMPL CDR X; IF (Y:=GET(OP,'PRESIMP)) THEN RETURN XAPPLY(Y,X); RETURN (OP . X); END; SYMBOLIC PROCEDURE PRESIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE PRESIMP(CAR X) . PRESIMPL CDR X; %**************** Simplification Routines for Rationals *************** SYMBOLIC PROCEDURE R!+(A,B); %. RAT addition IF RATDEN A = RATNUM B THEN MAKERAT(P!+(RATNUM A,RATNUM B),CDR A) ELSE MAKERAT(P!+(P!*(RATNUM A,RATDEN B), P!*(RATDEN A,RATNUM B)), P!*(RATDEN A,RATDEN B)); SYMBOLIC PROCEDURE R!-(A,B); %. RAT subtraction R!+(A,R!.NEG B); SYMBOLIC PROCEDURE R!.NEG A; %. RAT negation MKRAT(P!.NEG RATNUM A,RATDEN A); SYMBOLIC PROCEDURE R!*(A,B); %. RAT multiplication BEGIN SCALAR X,Y; X:=MAKERAT(RATNUM A,RATDEN B); Y:=MAKERAT(RATNUM B,RATDEN A); IF RATNUM X=0 OR RATNUM Y=0 THEN RETURN 0 . 1; RETURN MKRAT(P!*(RATNUM X,RATNUM Y), P!*(RATDEN X,RATDEN Y)) END; SYMBOLIC PROCEDURE R!.RECIP A; %. RAT inverse IF RATNUM A=0 THEN ERROR(777,'(ZERO DIVISOR)) ELSE MKRAT(RATDEN A,RATNUM A); SYMBOLIC PROCEDURE R!/(A,B); %. RAT division R!*(A,R!.RECIP B); SYMBOLIC PROCEDURE R!.LVAR A; %. Leading VARIABLE of RATIONAL BEGIN SCALAR P; P:=RATNUM A; IF NUMBERP P THEN RETURN ERROR(99,'(non structured polynomial)); P:=POLVAR P; RETURN P; END; SYMBOLIC PROCEDURE R!'(A,X); %. RAT derivative <<X:=R!.LVAR X; IF RATDEN A=1 THEN MKRAT(PDIFF(RATNUM A,X),1) ELSE R!-(MAKERAT(PDIFF(RATNUM A,X),RATDEN A), MAKERAT(P!*(RATNUM A,PDIFF(RATDEN A,X)), P!*(RATDEN A,RATDEN A) ) ) >>; SYMBOLIC PROCEDURE RCREATE X; %. RAT create IF NUMBERP X THEN X . 1 ELSE IF VARP X THEN (PCREATE X) . 1 ELSE ERROR(100,LIST(X, '(non kernel))); SYMBOLIC PROCEDURE MAKERAT(A,B); IF A=B THEN MKRAT(1,1) ELSE IF A=0 THEN 0 . 1 ELSE IF B=0 THEN ERROR(777,'(ZERO DIVISOR)) ELSE IF NUMBERP A AND NUMBERP B THEN BEGIN SCALAR GG; GG:=NUMGCD(A,B); IF B<0 THEN <<B:=-B; A := -A>>; RETURN MKRAT(A/GG,B/GG) END ELSE BEGIN SCALAR GG,NN; GG:=PGCD(A,B); IF GG=1 THEN RETURN MKRAT(A,B); NN:=GG; LL: IF NUMBERP NN THEN NN:=GCDPT(GG,NN) ELSE << NN:=POLCOEF GG; GOTO LL >>; GG:=CAR PDIVIDE(GG,NN); RETURN MKRAT(DIVIDEOUT(A,GG),DIVIDEOUT(B,GG)) END; SYMBOLIC PROCEDURE R!^(A,N); %. RAT Expt BEGIN SCALAR AA; N:=RATNUM N; IF NOT NUMBERP N THEN RETURN ERROR(777,'(Non numeric exponent)) ELSE IF N=0 THEN RETURN RCREATE 1; IF N<0 THEN <<A:=R!.RECIP A; N:=-N>>; AA:=1 . 1; FOR I:=1:N DO AA:=R!*(AA,A); RETURN AA END; %**************** Simplification Routines for Polynomials ************* SYMBOLIC PROCEDURE P1!+(A, B); % Fix for UCSD pascal to cut down proc size BEGIN SCALAR AA,BB; AA:=P!+(POLCOEF A,POLCOEF B); IF AA=0 THEN RETURN P!+(POLRED A,POLRED B); AA:=MKPOLY(TRMPWR POLTRM A,AA); AA:=ZCONS AA; BB:=P!+(POLRED A,POLRED B); RETURN P!+(AA,BB) END P1!+; SYMBOLIC PROCEDURE P!+(A,B); %. POL addition IF A=0 THEN B ELSE IF B=0 THEN A ELSE IF NUMBERP A AND NUMBERP B THEN PLUS2(A,B) ELSE IF NUMBERP A THEN MKPOLY(POLTRM B,P!+(A,POLRED B)) ELSE IF NUMBERP B THEN MKPOLY(POLTRM A,P!+(B,POLRED A)) ELSE BEGIN SCALAR ORD; ORD:=PORDERP(POLVAR A,POLVAR B); IF ORD=1 THEN RETURN MKPOLY(POLTRM A,P!+(POLRED A,B)); IF ORD=-1 THEN RETURN MKPOLY(POLTRM B,P!+(POLRED B,A)); IF POLEXPT A=POLEXPT B THEN RETURN P1!+(A, B); IF POLEXPT A>POLEXPT B THEN RETURN MKPOLY(POLTRM A,P!+(POLRED A,B)); RETURN MKPOLY(POLTRM B,P!+(POLRED B,A)) END; SYMBOLIC PROCEDURE PORDERP(A,B); %. POL variable ordering IF A EQ B THEN 0 ELSE IF ORDERP(A,B) THEN 1 ELSE -1; SYMBOLIC PROCEDURE P!*(A,B); %. POL multiply IF NUMBERP A THEN IF A=0 THEN 0 ELSE IF NUMBERP B THEN TIMES2(A,B) ELSE CONS(CONS(CAAR B,PNTIMES(CDAR B,A)), PNTIMES(CDR B,A)) ELSE IF NUMBERP B THEN PNTIMES(A,B) ELSE P!+(PTTIMES(CAR A,B),P!*(CDR A,B)); SYMBOLIC PROCEDURE PTTIMES(TT,A); %. POL term mult IF NUMBERP A THEN IF A=0 THEN 0 ELSE ZCONS CONS(CAR TT,PNTIMES(CDR TT,A)) ELSE P!+(TTTIMES(TT,CAR A),PTTIMES(TT,CDR A)); SYMBOLIC PROCEDURE PNTIMES(A,N); %. POL numeric coef mult IF N=0 THEN 0 ELSE IF NUMBERP A THEN TIMES2(A,N) ELSE CONS(CONS(CAAR A,PNTIMES(CDAR A,N)),PNTIMES(CDR A,N)); SYMBOLIC PROCEDURE TTTIMES(TA,TB); %. TERM Mult BEGIN SCALAR ORD; ORD:=PORDERP(CAAR TA,CAAR TB); RETURN IF ORD=0 THEN ZCONS(CONS(CONS(CAAR TA,PLUS2(CDAR TA,CDAR TB)), P!*(CDR TA,CDR TB))) ELSE IF ORD=1 THEN ZCONS(CONS(CAR TA,P!*(ZCONS TB,CDR TA))) ELSE ZCONS(CONS(CAR TB,P!*(ZCONS TA,CDR TB))) END; SYMBOLIC PROCEDURE ZCONS A; %. Make single term POL CONS(A,0); SYMBOLIC PROCEDURE PCREATE1(X); %. Create POLY from Variable/KERNEL ZCONS(CONS(CONS(X,1),1)); SYMBOLIC PROCEDURE PCREATE X; IF IDP X THEN PCREATE1 X ELSE IF PAIRP X AND IDP CAR X THEN PCREATE1 MKKERNEL X ELSE ERROR(1000,LIST(X, '(bad kernel))); SYMBOLIC PROCEDURE PGCD(A,B); %. POL Gcd % A and B must be primitive. IF A=1 OR B=1 THEN 1 ELSE IF NUMBERP A AND NUMBERP B THEN NUMGCD(A,B) ELSE IF NUMBERP A THEN GCDPT(B,A) ELSE IF NUMBERP B THEN GCDPT(A,B) ELSE BEGIN SCALAR ORD; ORD:=PORDERP(CAAAR A,CAAAR B); IF ORD=0 THEN RETURN GCDPP(A,B); IF ORD>0 THEN RETURN GCDPT(A,B); RETURN GCDPT(B,A) END; SYMBOLIC PROCEDURE NUMGCD(A,B); %. Numeric GCD IF A=0 THEN ABS B ELSE NUMGCD(REMAINDER(B,A),A); SYMBOLIC PROCEDURE GCDPT(A,B); %. POL GCD, non-equal vars IF NUMBERP A THEN IF NUMBERP B THEN NUMGCD(A,B) ELSE GCDPT(B,A) ELSE BEGIN SCALAR ANS,ANS1; ANS:=PGCD(CDAR A,B); A:=CDR A; WHILE NOT NUMBERP A DO << ANS1:=PGCD(CDAR A,B); ANS:=PGCD(ANS,ANS1); A:=CDR A; IF ANS=1 THEN RETURN ANS >>; RETURN IF A=0 THEN ANS ELSE GCDPT(ANS,A) END; SYMBOLIC PROCEDURE GCDPP(A,B); %. POL GCD, equal vars BEGIN SCALAR TT,PA,ALPHA,PREVALPHA; IF POLEXPT B>POLEXPT A THEN << TT := A; A := B; B := TT >>; ALPHA := 1; LOOP: PREVALPHA := ALPHA; ALPHA := POLCOEF B; PA := POLEXPT A - POLEXPT B; IF PA<0 THEN << PRINT A; PRINT B; PRINT PA; ERROR(999,'(WRONG)) >>; WHILE NOT (PA=0) DO << PA := PA-1; ALPHA := P!*(POLCOEF B,ALPHA) >>; A := P!*(A,ALPHA); % to ensure no fractions; TT := CDR PDIVIDE(A,B); % quotient and remainder of polynomials; IF TT=0 THEN RETURN B; % which is the GCD; A := B; B := PDIVIDE(TT,PREVALPHA); IF NOT(CDR B=0) THEN ERROR(12,'(REDUCED PRS FAILS)); B := CAR B; IF NUMBERP B OR NOT (POLVAR A EQ POLVAR B) THEN RETURN 1; % Lost leading VAR we started with. /MLG GO TO LOOP END; SYMBOLIC PROCEDURE DIVIDEOUT(A,B); %. POL exact division CAR PDIVIDE(A,B); SYMBOLIC PROCEDURE PDIVIDE(A,B); %. POL (quotient.remainder) IF NUMBERP A THEN IF NUMBERP B THEN DIVIDE(A,B) ELSE CONS(0,A) ELSE IF NUMBERP B THEN BEGIN SCALAR SS,TT; SS:=PDIVIDE(CDR A,B); TT:=PDIVIDE(CDAR A,B); RETURN CONS( P!+(P!*(ZCONS CONS(CAAR A,1),CAR TT),CAR SS), P!+(P!*(ZCONS CONS(CAAR A,1),CDR TT),CDR SS)) END ELSE BEGIN SCALAR QQ,BB,CC,TT; IF NOT(POLVAR A EQ POLVAR B) OR POLEXPT A < POLEXPT B THEN RETURN CONS(0,A); % Not same var/MLG, degree check/DFM QQ:=PDIVIDE(POLCOEF A,POLCOEF B); % Look for leading term; IF NOT(CDR QQ=0) THEN RETURN CONS(0,A); QQ:=CAR QQ; %Get the quotient; BB:=P!*(B,QQ); IF CDAAR A > CDAAR B THEN << TT:=ZCONS CONS(CONS(CAAAR A,CDAAR A-CDAAR B),1); BB:=P!*(BB,TT); QQ:=P!*(QQ,TT) >>; CC:=P!-(A,BB); %Take it off; BB:=PDIVIDE(CC,B); RETURN CONS(P!+(QQ,CAR BB),CDR BB) END; SYMBOLIC PROCEDURE P!-(A,B); %. POL subtract P!+(A,P!.NEG B); SYMBOLIC PROCEDURE P!.NEG(A); %. POL Negate IF NUMBERP A THEN -A ELSE CONS(CONS(CAAR A,P!.NEG CDAR A),P!.NEG CDR A); SYMBOLIC PROCEDURE PDIFF(A,X); %. POL derivative (to variable) IF NUMBERP A THEN 0 ELSE BEGIN SCALAR ORD; ORD:=PORDERP(POLVAR A,X); RETURN IF ORD=-1 THEN 0 ELSE IF ORD=0 THEN IF CDAAR A=1 THEN CDAR A ELSE P!+(ZCONS CONS(CONS(X,CDAAR A-1),P!*(CDAAR A,CDAR A)), PDIFF(CDR A,X)) ELSE P!+(P!*(ZCONS CONS(CAAR A,1),PDIFF(CDAR A,X)),PDIFF(CDR A,X)) END; SYMBOLIC PROCEDURE MKKERNEL X; BEGIN SCALAR KERNELS,K,OP; K:=KERNELS:=GET(OP:=CAR X,'KERNELS); L: IF NULL K THEN RETURN<<PUT(OP,'KERNELS,X.KERNELS);X>>; IF X=CAR K THEN RETURN CAR K; K:=CDR K; GOTO L END; %***************************** Parser ********************************* % Simple parser creates expressions to be evaluated by the % rational polynomial routines. % J. Marti, August 1980. % Modified and Extended by GRISS and GALWAY % Rewritten to be left associative by OTTENHEIMER, March 1981 GLOBAL '(TOK!*); SYMBOLIC PROCEDURE RPARSE(); %. PARSE Infix to Prefix BEGIN SCALAR X; NTOKEN(); IF TOK!* EQ '!; THEN RETURN NIL; % Fix for null exp RBO 9 Feb 81 IF NULL(X := REXP()) THEN RETURN ERROR(105, '(Unparsable Expression)); IF TOK!* NEQ '!; THEN RETURN ERROR(106, '(Missing !; at end of expression)); RETURN X END RPARSE; SYMBOLIC PROCEDURE REXP(); %. Parse an EXP and rename OP BEGIN SCALAR LEFT, RIGHT,OP; IF NOT (LEFT := RTERM()) THEN RETURN NIL; WHILE (OP := GET(TOK!*,'REXP)) DO << NTOKEN(); IF NOT(RIGHT := RTERM()) THEN RETURN ERROR(100, '(Missing Term in Exp)); LEFT := LIST(OP, LEFT, RIGHT) >>; RETURN LEFT END REXP; SYMBOLIC PROCEDURE RTERM(); %. PARSE a TERM BEGIN SCALAR LEFT, RIGHT, OP; IF NOT (LEFT := RPRIMARY()) THEN RETURN NIL; WHILE (OP := GET(TOK!*,'RTERM)) DO << NTOKEN(); IF NOT (RIGHT := RPRIMARY()) THEN RETURN ERROR (101, '(Missing Primary in Term)); LEFT := LIST(OP, LEFT, RIGHT) >>; RETURN LEFT END RTERM; SYMBOLIC PROCEDURE RPRIMARY(); %. RPRIMARY, allows "^" and "'" BEGIN SCALAR LEFT, RIGHT, OP; IF TOK!* EQ '!+ THEN RETURN <<NTOKEN(); RPRIMARY0()>>; IF TOK!* EQ '!- THEN RETURN << NTOKEN(); IF (LEFT := RPRIMARY0()) THEN LIST('MINUS, LEFT) ELSE RETURN ERROR(200,'(Missing Primary0 after MINUS)) >>; IF NOT (LEFT := RPRIMARY0()) THEN RETURN NIL; WHILE (OP := GET(TOK!*,'RPRIMARY)) DO << NTOKEN(); IF NOT (RIGHT := RPRIMARY0()) THEN RETURN ERROR(200, '(Missing Primary0 in Primary)); LEFT := LIST(OP, LEFT, RIGHT) >>; RETURN LEFT; END RPRIMARY; SYMBOLIC PROCEDURE RPRIMARY0(); %. Variables, etc BEGIN SCALAR EXP, ARGS; IF TOK!* EQ '!( THEN << NTOKEN(); IF NOT (EXP := REXP()) THEN RETURN ERROR(102, '(Missing Expression)); IF TOK!* NEQ '!) THEN RETURN ERROR(103, '(Missing Right Parenthesis)); NTOKEN(); RETURN EXP >>; IF NUMBERP(EXP := TOK!*) THEN RETURN <<NTOKEN(); EXP>>; IF NOT IDP EXP THEN RETURN NIL; NTOKEN(); IF ARGS := RARGS(EXP) THEN RETURN ARGS; RETURN EXP; END RPRIMARY0; SYMBOLIC PROCEDURE RARGS(X); BEGIN SCALAR ARGS,ARG; IF TOK!* NEQ '!( THEN RETURN NIL; NTOKEN(); IF TOK!* EQ '!) THEN RETURN <<NTOKEN();X . NIL>>; L: IF NOT (ARG :=REXP()) THEN ERROR(104,'(Not expression in ARGLST)); ARGS := ARG . ARGS; IF TOK!* EQ '!, THEN <<NTOKEN(); GOTO L>>; IF TOK!* EQ '!) THEN RETURN <<NTOKEN();X . REVERSE ARGS>>; ERROR(105,'(Missing !) or !, in ARGLST)); END; SYMBOLIC PROCEDURE MKATOM X; % Use LIST('RCREATE, LIST('QUOTE,x)); if doing EVAL mode X; %******************* Printing Routines ******************************** SYMBOLIC PROCEDURE PPRINT A; % Print internal canonical form in Infix notation. IF NUMBERP A THEN PRIN2 A ELSE BEGIN IF NUMBERP CDAR A THEN IF CDAR A = 0 THEN << PRIN2 '0; RETURN NIL >> ELSE IF CDAR A NEQ 1 THEN << PRIN2 CDAR A; PRIN2 '!* >> ELSE ELSE IF RPREC!* CDAR A THEN << PPRINT CDAR A; PRIN2 '!* >> ELSE <<PRIN2 '!(; PPRINT CDAR A; PRIN2 '!)!* >>; IF CDAAR A = 0 THEN PRIN2 1 ELSE IF CDAAR A = 1 THEN PRIN2 CAAAR A ELSE << PRIN2 CAAAR A; PRIN2 '!^; IF RPREC!^ CDAAR A THEN PPRINT CDAAR A ELSE <<PRIN2 '!(; PPRINT CAAAR A; PRIN2 '!) >> >>; IF NUMBERP CDR A THEN IF CDR A> 0 THEN <<PRIN2 '!+ ; PRIN2 CDR A; RETURN NIL>> ELSE IF CDR A < 0 THEN <<PRIN2 '!-! ; PRIN2 (-CDR A); RETURN NIL>> ELSE RETURN NIL; IF ATOM CDR A THEN <<PRIN2 '!+ ; PRIN2 CDR A; RETURN NIL>>; PRIN2 '!+ ; PPRINT CDR A; END; SYMBOLIC PROCEDURE RPREC!* X; %. T if there is no significant addition in X. ATOM X OR (NUMBERP POLRED X AND POLRED X = 0); SYMBOLIC PROCEDURE RPREC!^ X; %. T if there is not significant addition or multiplication in X. RPREC!* X AND (ATOM X OR (ATOM CDAR X AND NUMBERP CDAR X)); SYMBOLIC PROCEDURE SIMPLE X; %. POL that doest need () ATOM X OR ((POLRED X=0) AND (POLEXPT X=1) AND (POLCOEF X =1)); SYMBOLIC PROCEDURE RATPRINT A; %. Print a RAT BEGIN IF CDR A = 1 THEN PPRINT CAR A ELSE <<NPRINT CAR A; PRIN2 '!/; NPRINT CDR A>>; TERPRI() END; SYMBOLIC PROCEDURE NPRINT A; %. Add parens, if needed IF NOT SIMPLE A THEN <<PRIN2 '!( ; PPRINT A; PRIN2 '!) >> ELSE PPRINT A; %. Convert RCAN back to PREFIX form SYMBOLIC PROCEDURE RAT2PRE X; %. RATIONAL to Prefix IF RATDEN X = 1 THEN POL2PRE RATNUM X ELSE LIST('QUOTIENT,POL2PRE RATNUM X, POL2PRE RATDEN X); SYMBOLIC PROCEDURE POL2PRE X; %. Polynomial to Prefix BEGIN SCALAR TT,RR; IF NOT PAIRP X THEN RETURN X; TT:=TRM2PRE POLTRM X; RR:=POL2PRE POLRED X; IF RR = 0 THEN RETURN TT; IF NUMBERP RR AND RR <0 THEN RETURN LIST('DIFFERENCE,TT,-RR); RETURN LIST('PLUS2,TT,RR); END; SYMBOLIC PROCEDURE TRM2PRE X; %. Term to Prefix IF TRMCOEF X = 1 THEN PWR2PRE TRMPWR X ELSE IF TRMCOEF X = (-1) THEN LIST('MINUS,PWR2PRE TRMPWR X) ELSE LIST('TIMES2,POL2PRE TRMCOEF X,PWR2PRE TRMPWR X); SYMBOLIC PROCEDURE PWR2PRE X; %. Power to Prefix IF PWREXPT X = 1 THEN PWRVAR X ELSE LIST('EXPT,PWRVAR X,PWREXPT X); %. prefix Pretty print SYMBOLIC PROCEDURE PREPRIN(A,PARENS); %. Print PREFIX form in Infix notation. BEGIN SCALAR PRINOP; IF ATOM A THEN RETURN PRIN2 A; IF (PRINOP:=GET(CAR A,'PRINOP)) THEN RETURN XAPPLY(PRINOP,LIST(A,PARENS)); PRIN2(CAR A); PRINARGS CDR A; RETURN A; END; SYMBOLIC PROCEDURE PRINARGS A; %. Print ArgLIST IF NOT PAIRP A THEN PRIN2 '!(!) ELSE <<PRIN2 '!(; WHILE PAIRP A DO <<PREPRIN(CAR A,NIL); IF PAIRP (A:=CDR A) THEN PRIN2 '!,>>; PRIN2 '!)>>; SYMBOLIC PROCEDURE PREPRINT A; <<PREPRIN(A,NIL); TERPRI(); A>>; SYMBOLIC PROCEDURE NARYPRIN(OP,ARGS,PARENS); IF NOT PAIRP ARGS THEN NIL ELSE IF NOT PAIRP CDR ARGS THEN PREPRIN(CAR ARGS,PARENS) ELSE <<IF PARENS THEN PRIN2 '!(; WHILE PAIRP ARGS DO <<PREPRIN(CAR ARGS,T); % Need precedence here IF PAIRP(ARGS:=CDR ARGS) THEN PRIN2 OP>>; IF PARENS THEN PRIN2 '!)>>; SYMBOLIC PROCEDURE PLUSPRIN(A,PARENS); NARYPRIN('! !+! ,CDR A,PARENS); SYMBOLIC PROCEDURE DIFFERENCEPRIN(A,PARENS); NARYPRIN('! !-! ,CDR A,PARENS); SYMBOLIC PROCEDURE TIMESPRIN(A,PARENS); NARYPRIN('!*,CDR A,PARENS); SYMBOLIC PROCEDURE QUOTPRIN(A,PARENS); NARYPRIN('!/,CDR A,PARENS); SYMBOLIC PROCEDURE EXPPRIN(A,PARENS); NARYPRIN('!^,CDR A,PARENS); ON RAISE; END;