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;