Artifact cd130098a1bb85af3467da41498202d857381507baa0bf890ef12c64dc247b91:
- File
psl-1983/3-1/util/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: 20440) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/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: 20440) [annotate] [blame] [check-ins using]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Simple POLY, RAT AND ALG system, based on POLY by Fitch and Marti. % Edit by Cris Perdue, 28 Jan 1983 2045-PST % "Dipthong" -> "Diphthong", order of revision history reversed % Modified by GRISS, JUly 1982 for PSL % MORRISON again, March 1981. % Parses INFIX expressions to PREFIX, then SIMPlifies and PRINTs % Handles also PREFIX expressions % Parser modified by OTTENHEIMER % February 1981, to be left associative March 1981. % Further modified by MORRISON % October 1980. % Modifed by GRISS and GALWAY % September 1980. % 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 ********************** smacro procedure RATNUM X; % parts of Rational CAR X; smacro procedure RATDEN X; CDR X; smacro procedure MKRAT(X,Y); CONS(X,Y); smacro procedure POLTRM X; % parts of Poly CAR X; smacro procedure POLRED X; CDR X; smacro procedure MKPOLY(X,Y); CONS(X,Y); smacro procedure TRMPWR X; % parts of TERM CAR X; smacro procedure TRMCOEF X; CDR X; smacro procedure MKTERM(X,Y); CONS(X,Y); smacro procedure PWRVAR X; % parts of Poly CAR X; smacro procedure PWREXPT X; CDR X; smacro procedure MKPWR(X,Y); CONS(X,Y); smacro procedure POLVAR X; PWRVAR TRMPWR POLTRM X; smacro procedure POLEXPT X; PWREXPT TRMPWR POLTRM X; smacro procedure POLCOEF X; TRMCOEF POLTRM X; %*********************** Utility Routines ***************************** procedure VARP X; IDP X OR (PAIRP X AND IDP CAR X); %*********************** Entry Point ********************************** FLUID '(!*RBACKTRACE !*RECHO REXPRESSION!* !*RMESSAGE PromptString!* TOK!* CurrentScantable!* ); !*RECHO := NIL; % No echo of parse !*RMESSAGE := T; % Do Print messages procedure RAT(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV,PromptString!*; Prin2T "Canonical Rational Evaluator"; PromptString!*:="poly> "; ALGINIT(); CLEARTOKEN(); % Initialize scanner LOOP: VVV := ERRORSET('(RPARSE),T,!*RBACKTRACE); IF ATOM VVV THEN % What about resetting the Scanner? <<PRINT LIST('RATT, 'error, VVV); CLEARTOKEN();GO TO LOOP>>; REXPRESSION!* := CAR VVV; IF !*RECHO THEN PRINT LIST('parse,REXPRESSION!*); IF REXPRESSION!* EQ 'QUIT THEN << PRINT 'QUITTING; RETURN >>; ERRORSET('(RATPRINT (RSIMP REXPRESSION!*)),T,!*RBACKTRACE); GOTO LOOP END RAT; procedure ALGG(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV,PromptString!*; prin2t "non-canonical rational evaluator"; alginit(); promptstring!* := "poly> "; 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; procedure alginit(); %. called to init tables begin inittoken(); prin2t "quit; to exit"; 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; procedure cleartoken; nil; procedure inittoken; << AlgScantable!* := '[17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 Algdiphthong]; AlgScanTable!*[char '!+]:=11; AlgScanTable!*[char '!-]:=11; >>; procedure NTOKEN; Begin Scalar CurrentScantable!*; CurrentScanTable!* := AlgScanTable!*; TOK!* := RATOM(); Return Tok!*; End; 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 APPLY(Y,RSIMPL CDR X); Y:=PRESIMP X; % As "variable" ? IF ATOM Y OR NOT(X=Y) THEN RETURN RSIMP Y; RETURN RCREATE Y; END; procedure RSIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE RSIMP(CAR X) . RSIMPL CDR X; 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 APPLY(Y,RSIMPL CDR X); X:=PRESIMPL CDR X; IF (Y:=GET(OP,'PRESIMP)) THEN RETURN APPLY(Y,X); RETURN (OP . X); END; procedure PRESIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE PRESIMP(CAR X) . PRESIMPL CDR X; %**************** Simplification Routines for Rationals *************** procedure R!+(A,B); %. RAT addition IF RATDEN A = RATDEN B THEN %/ Risa MAKERAT(P!+(RATNUM A,RATNUM B),RATDEN A) ELSE MAKERAT(P!+(P!*(RATNUM A,RATDEN B), P!*(RATDEN A,RATNUM B)), P!*(RATDEN A,RATDEN B)); procedure R!-(A,B); %. RAT subtraction R!+(A,R!.NEG B); procedure R!.NEG A; %. RAT negation MKRAT(P!.NEG RATNUM A,RATDEN A); 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; procedure R!.RECIP A; %. RAT inverse IF RATNUM A=0 THEN ERROR(777,'(ZERO DIVISOR)) ELSE MKRAT(RATDEN A,RATNUM A); procedure R!/(A,B); %. RAT division R!*(A,R!.RECIP B); 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; 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) ) ) >>; 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))); 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; 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 ************* 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 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; IF POLEXPT A>POLEXPT B THEN RETURN MKPOLY(POLTRM A,P!+(POLRED A,B)); RETURN MKPOLY(POLTRM B,P!+(POLRED B,A)) END; procedure PORDERP(A,B); %. POL variable ordering IF A EQ B THEN 0 ELSE IF ORDERP(A,B) THEN 1 ELSE -1; 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)); 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)); 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)); 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; procedure ZCONS A; %. Make single term POL CONS(A,0); procedure PCREATE1(X); %. Create POLY from Variable/KERNEL ZCONS(CONS(CONS(X,1),1)); 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))); 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; procedure NUMGCD(A,B); %. Numeric GCD IF A=0 THEN ABS B ELSE NUMGCD(REMAINDER(B,A),A); 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; 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; procedure DIVIDEOUT(A,B); %. POL exact division CAR PDIVIDE(A,B); 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; procedure P!-(A,B); %. POL subtract P!+(A,P!.NEG B); procedure P!.NEG(A); %. POL Negate IF NUMBERP A THEN -A ELSE CONS(CONS(CAAR A,P!.NEG CDAR A),P!.NEG CDR A); 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; 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 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; 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; 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; 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; 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; 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; procedure MKATOM X; % Use LIST('RCREATE, LIST('QUOTE,x)); if doing EVAL mode X; %******************* Printing Routines ******************************** 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 NIL 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; procedure RPREC!* X; %. T if there is no significant addition in X. ATOM X OR (NUMBERP POLRED X AND POLRED X = 0); 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)); procedure SIMPLE X; %. POL that doest need () ATOM X OR ((POLRED X=0) AND (POLEXPT X=1) AND (POLCOEF X =1)); 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; 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 procedure RAT2PRE X; %. RATIONAL to Prefix IF RATDEN X = 1 THEN POL2PRE RATNUM X ELSE LIST('QUOTIENT,POL2PRE RATNUM X, POL2PRE RATDEN X); 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; 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); procedure PWR2PRE X; %. Power to Prefix IF PWREXPT X = 1 THEN PWRVAR X ELSE LIST('EXPT,PWRVAR X,PWREXPT X); %. prefix Pretty print 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 APPLY(PRINOP,LIST(A,PARENS)); PRIN2(CAR A); PRINARGS CDR A; RETURN A; END; 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 '!)>>; procedure PREPRINT A; <<PREPRIN(A,NIL); TERPRI(); A>>; 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 '!)>>; procedure PLUSPRIN(A,PARENS); NARYPRIN('! !+! ,CDR A,PARENS); procedure DIFFERENCEPRIN(A,PARENS); NARYPRIN('! !-! ,CDR A,PARENS); procedure TIMESPRIN(A,PARENS); NARYPRIN('!*,CDR A,PARENS); procedure QUOTPRIN(A,PARENS); NARYPRIN('!/,CDR A,PARENS); procedure EXPPRIN(A,PARENS); NARYPRIN('!^,CDR A,PARENS); procedure OrderP(x,y); % ordering of ID's as VARS Id2int(x) <= Id2Int (y); End;