File psl-1983/3-1/util/poly.red artifact cd130098a1 on branch master


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 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;



REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]