%*********************************************************************
%*********************************************************************
% REDUCE BASIC ALGEBRAIC PROCESSOR (PART 1)
%*********************************************************************
%********************************************************************;
%Copyright (c) 1983 The Rand Corporation;
SYMBOLIC;
%*********************************************************************
% NON-LOCAL VARIABLES REFERENCED IN THIS SECTION
%********************************************************************;
FLUID '(ALGLIST!* ARBL!* !*EXP !*GCD !*INTSTR !*LCM !*MCD !*MODE);
GLOBAL '(ASYMPLIS!* CURSYM!* DMODE!* DOMAINLIST!* EXLIST!* EXPTL!*
EXPTP!* FRASC!* FRLIS!* INITL!* KORD!* KPROPS!* LETL!* MCHFG!*
MCOND!* MOD!* MUL!* NAT!*!* NCMP!* OFL!* POSN!* POWLIS!*
POWLIS1!* SPLIS!* SUBFG!* TSTACK!* TYPL!* WS WTL!* !*EZGCD
!*FLOAT !*FORT !*GROUP !*INT !*MATCH !*MSG !*NAT !*NERO
!*NOSUBS !*NUMVAL !*OUTP !*PERIOD !*PRI !*RESUBS !*SQVAR!*
!*SUB2 !*VAL !*XDN);
GLOBAL '(DSUBL!* SUBL!*); %not used at moment;
ALGLIST!* := NIL; %association list for previously simplified
%expressions;
ARBL!* := NIL; %used for storage of arbitrary vars in LET
%statements;
ASYMPLIS!* := NIL; %association list of asymptotic replacements;
% CURSYM!* current symbol (i. e. identifier, parenthesis,
% delimiter, e.t.c,) in input line;
DMODE!* := NIL; %name of current polynomial domain mode if not
%integer;
DOMAINLIST!* := NIL; %list of currently supported poly domain modes;
%DSUBL!* := NIL; %list of previously calculated derivatives of
% expressions;
EXLIST!* := '((!*)); %property list for standard forms used as
% kernels;
EXPTL!* := NIL; %list of exprs with non-integer exponents;
EXPTP!* := NIL; %flag telling EXPTs appear in LET statements;
FRASC!* := NIL; %association list for free variables in
%substitution rules;
FRLIS!* := NIL; %list of renamed free variables to be found in
%substitutions;
INITL!* := APPEND('(FRASC!* MCOND!* SUBFG!* !*SUB2 TSTACK!*),INITL!*);
KORD!* := NIL; %kernel order in standard forms;
KPROPS!* := NIL; %list of active non-atomic kernel plists;
LETL!* := '(LET MATCH CLEAR SAVEAS SUCH); %special delimiters;
MCHFG!* := NIL; %indicates that a pattern match occurred during
%a cycle of the matching routines;
MCOND!* := NIL; %used for temporary storage of a conditional
%expression in a substitution;
MOD!* := NIL; %modular base, NIL for integer arithmetic;
MUL!* := NIL; %list of additional evaluations needed in a
%given multiplication;
NAT!*!* := NIL; %temporary variable used in algebraic mode;
NCMP!* := NIL; %flag indicating non-commutative multiplication
%mode;
OFL!* := NIL; %current output file name;
POSN!* := NIL; %used to store output character position in
%printing functions;
POWLIS!* := NIL; %association list of replacements for powers;
POWLIS1!* := NIL; %association list of conditional replacements
%for powers;
SPLIS!* := NIL; %substitution list for sums and products;
SUBFG!* := T; %flag to indicate whether substitution
%is required during evaluation;
%SUBL!* := NIL; %list of previously evaluated expressions;
TSTACK!* := 0; %stack counter in SIMPTIMES;
% TYPL!*;
WTL!* := NIL; %tells that a WEIGHT assignment has been made;
!*EXP := T; %expansion control flag;
!*EZGCD := NIL; %ezgcd calculation flag;
!*FLOAT := NIL; %floating arithmetic mode flag;
!*FORT := NIL; %specifies FORTRAN output;
!*GCD := NIL; %greatest common divisor mode flag;
!*GROUP := NIL; %causes expressions to be grouped when EXP off;
!*INTSTR := NIL; %makes expression arguments structured;
%!*INT indicates interactive system use;
!*LCM := T; %least common multiple computation flag;
!*MATCH := NIL; %list of pattern matching rules;
!*MCD := T; %common denominator control flag;
!*MODE := 'SYMBOLIC; %current evaluation mode;
!*MSG := T; %flag controlling message printing;
!*NAT := T; %specifies natural printing mode;
!*NERO := NIL; %flag to suppress printing of zeros;
!*NOSUBS := NIL; %internal flag controlling substitution;
!*NUMVAL := NIL; %used to indicate that numerical expressions
%should be converted to a real value;
!*OUTP := NIL; %holds prefix output form for extended output
%package;
!*PERIOD := T; %prints a period after a fixed coefficient
%when FORT is on;
!*PRI := NIL; %indicates that fancy output is required;
!*RESUBS := T; %external flag controlling resubstitution;
!*SQVAR!*:='(T); %variable used by *SQ expressions to control
%resimplification;
!*SUB2 := NIL; %indicates need for call of RESIMP;
!*VAL := T; %controls operator argument evaluation;
!*XDN := T; %flag indicating that denominators should be
%expanded;
%initial values of some global variables in BEGIN1 loops;
PUT('TSTACK!*,'INITL,0);
PUT('SUBFG!*,'INITL,T);
%Old name for the expression workspace;
%PUT('!*ANS,'NEWNAM,'WS);
%*********************************************************************
% GENERAL FUNCTIONS
%********************************************************************;
SYMBOLIC PROCEDURE ATOMLIS U;
NULL U OR (ATOM CAR U AND ATOMLIS CDR U);
SYMBOLIC PROCEDURE CARX(U,V);
IF NULL CDR U THEN CAR U
ELSE REDERR LIST("Wrong number of arguments to",V);
SYMBOLIC PROCEDURE DELASC(U,V);
IF NULL V THEN NIL
ELSE IF ATOM CAR V OR U NEQ CAAR V THEN CAR V . DELASC(U,CDR V)
ELSE CDR V;
SYMBOLIC PROCEDURE LENGTHC U;
%gives character length of U excluding string and escape chars;
BEGIN INTEGER N; SCALAR X;
N := 0;
X := EXPLODE U;
IF CAR X EQ '!" THEN RETURN LENGTH X-2;
WHILE X DO
<<IF CAR X EQ '!! THEN X := CDR X;
N := N+1;
X := CDR X>>;
RETURN N
END;
SYMBOLIC PROCEDURE GET!*(U,V);
IF NUMBERP U THEN NIL ELSE GET(U,V);
SYMBOLIC PROCEDURE MAPCONS(U,V);
FOR EACH J IN U COLLECT V . J;
SYMBOLIC PROCEDURE MAPPEND(U,V);
FOR EACH J IN U COLLECT APPEND(V,J);
SYMBOLIC PROCEDURE NLIST(U,N);
IF N=0 THEN NIL ELSE U . NLIST(U,N-1);
SYMBOLIC PROCEDURE NTH(U,N);
CAR PNTH(U,N);
SYMBOLIC PROCEDURE PNTH(U,N);
IF NULL U THEN REDERR "Index out of range"
ELSE IF N=1 THEN U
ELSE PNTH(CDR U,N-1);
SYMBOLIC PROCEDURE PERMP(U,V);
IF NULL U THEN T
ELSE IF CAR U EQ CAR V THEN PERMP(CDR U,CDR V)
ELSE NOT PERMP(CDR U,SUBST(CAR V,CAR U,CDR V));
SYMBOLIC PROCEDURE REMOVE(X,N);
%Returns X with Nth element removed;
IF NULL X THEN NIL
ELSE IF N=1 THEN CDR X
ELSE CAR X . REMOVE(CDR X,N-1);
SYMBOLIC PROCEDURE REVPR U;
CDR U . CAR U;
SYMBOLIC PROCEDURE REPEATS X;
IF NULL X THEN NIL
ELSE IF CAR X MEMBER CDR X THEN CAR X . REPEATS CDR X
ELSE REPEATS CDR X;
SYMBOLIC PROCEDURE SMEMBER(U,V);
%determines if S-expression U is a member of V at any level;
IF U=V THEN T
ELSE IF ATOM V THEN NIL
ELSE SMEMBER(U,CAR V) OR SMEMBER(U,CDR V);
SYMBOLIC PROCEDURE SMEMQ(U,V);
%true if id U is a member of V at any level (excluding
%quoted expressions);
IF ATOM V THEN U EQ V
ELSE IF CAR V EQ 'QUOTE THEN NIL
ELSE SMEMQ(U,CAR V) OR SMEMQ(U,CDR V);
SYMBOLIC PROCEDURE SMEMQL(U,V);
%Returns those members of id list U contained in V at any
%level (excluding quoted expressions);
IF NULL U THEN NIL
ELSE IF SMEMQ(CAR U,V) THEN CAR U . SMEMQL(CDR U,V)
ELSE SMEMQL(CDR U,V);
SYMBOLIC PROCEDURE SMEMQLP(U,V);
%True if any member of id list U is contained at any level
%in V (exclusive of quoted expressions);
IF NULL V THEN NIL
ELSE IF ATOM V THEN V MEMQ U
ELSE IF CAR V EQ 'QUOTE THEN NIL
ELSE SMEMQLP(U,CAR V) OR SMEMQLP(U,CDR V);
SYMBOLIC PROCEDURE SPACES N; FOR I:= 1:N DO PRIN2 " ";
SYMBOLIC PROCEDURE SUBLA(U,V);
BEGIN SCALAR X;
IF NULL U OR NULL V THEN RETURN V
ELSE IF ATOM V
THEN RETURN IF X:= ATSOC(V,U) THEN CDR X ELSE V
ELSE RETURN(SUBLA(U,CAR V) . SUBLA(U,CDR V))
END;
SYMBOLIC PROCEDURE XNP(U,V);
%returns true if the atom lists U and V have at least one common
%element;
U AND (CAR U MEMQ V OR XNP(CDR U,V));
%*********************************************************************
% FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES
%********************************************************************;
SYMBOLIC PROCEDURE MSGPRI(U,V,W,X,Y);
BEGIN SCALAR NAT1,Z;
IF NULL Y AND NULL !*MSG THEN RETURN;
NAT1 := !*NAT;
!*NAT := NIL;
IF OFL!* AND (!*FORT OR NOT NAT1) THEN GO TO C;
A: TERPRI();
LPRI ((IF NULL Y THEN "***" ELSE "*****")
. IF U AND ATOM U THEN LIST U ELSE U);
POSN!* := POSN();
MAPRIN V;
PRIN2 " ";
LPRI IF W AND ATOM W THEN LIST W ELSE W;
POSN!* := POSN();
MAPRIN X;
IF NOT Y OR Y EQ 'HOLD THEN TERPRI();
IF NULL Z THEN GO TO B;
WRS CDR Z;
GO TO D;
B: IF NULL OFL!* THEN GO TO D;
C: Z := OFL!*;
WRS NIL;
GO TO A;
D: !*NAT := NAT1;
IF Y THEN IF Y EQ 'HOLD THEN ERFG!* := Y ELSE ERROR1()
END;
SYMBOLIC PROCEDURE ERRACH U;
BEGIN
TERPRI!* T;
LPRIE "CATASTROPHIC ERROR *****";
PRINTTY U;
LPRIW(" ",NIL);
REDERR "Please send output and input listing to A. C. Hearn"
END;
SYMBOLIC PROCEDURE ERRPRI1 U;
MSGPRI("Substitution for",U,"not allowed",NIL,'HOLD);
SYMBOLIC PROCEDURE ERRPRI2(U,V);
MSGPRI("Syntax error:",U,"invalid",NIL,V);
SYMBOLIC PROCEDURE REDMSG(U,V);
IF NULL !*MSG THEN NIL
ELSE IF TERMINALP() THEN YESP LIST("Declare",U,V,"?") OR ERROR1()
ELSE LPRIM LIST(U,"declared",V);
SYMBOLIC PROCEDURE TYPERR(U,V);
<<TERPRI!* T;
PRIN2!* "***** ";
IF NOT ATOM U AND ATOM CAR U AND ATOM CADR U AND NULL CDDR U
THEN <<PRIN2!* CAR U; PRIN2!* " "; PRIN2!* CADR U>>
ELSE MAPRIN U;
PRIN2!* " invalid as "; PRIN2!* V;
TERPRI!* NIL; ERFG!* := T; ERROR1()>>;
%*********************************************************************
% ALGEBRAIC MODE FUNCTIONS AND DECLARATIONS REFERENCED IN SECTION 1
%********************************************************************;
%SYMBOLIC PROCEDURE APROC(U,V);
% IF NULL U THEN NIL
% ELSE IF ATOM U
% THEN IF NUMBERP U AND FIXP U THEN U ELSE LIST(V,MKARG U)
% ELSE IF FLAGP(CAR U,'NOCHANGE) OR GET(CAR U,'STAT) THEN U
% ELSE IF FLAGP(CAR U,'BOOLEAN)
% THEN CAR U . FOR EACH J IN CDR U COLLECT APROC(J,'REVAL)
% ELSE IF CDR U AND EQCAR(CADR U,'QUOTE) THEN U
% ELSE LIST(V,MKARG U);
SYMBOLIC PROCEDURE FORMINPUT(U,VARS,MODE);
BEGIN SCALAR X;
IF X := ASSOC(CAR U,INPUTBUFLIS!*) THEN RETURN CDR X
ELSE REDERR LIST("Entry",CAR U,"not found")
END;
PUT('INPUT,'FORMFN,'FORMINPUT);
SYMBOLIC PROCEDURE FORMWS(U,VARS,MODE);
BEGIN SCALAR X;
IF X := ASSOC(CAR U,RESULTBUFLIS!*) THEN RETURN MKQUOTE CDR X
ELSE REDERR LIST("Entry",CAR U,"not found")
END;
PUT('WS,'FORMFN,'FORMWS);
FLAG ('(AEVAL ARRAYFN COND FLAG GETEL GO PROG PROGN PROG2 RETURN
SETQ SETK SETEL VARPRI),'NOCHANGE);
%NB: FLAG IS NEEDED IN ALGEBRAIC PROC/OPERATOR DEFINITION;
FLAG ('(OR AND NOT MEMBER MEMQ EQUAL NEQ EQ GEQ GREATERP LEQ
FIXP LESSP NUMBERP ORDP),'BOOLEAN);
FLAG ('(OR AND NOT),'BOOLARGS);
DEFLIST ('((SUM (ADDSQ . (NIL . 1))) (PRODUCT (MULTSQ . (1 . 1)))),
'BIN);
FLAG ('(SUM PRODUCT),'DELIM);
FLAG ('(SUM PRODUCT),'NODEL);
DEFLIST ('((EXP ((NIL (RMSUBS1)) (T (RMSUBS))))
(FACTOR ((NIL (SETQ !*EXP T))
(T (SETQ !*EXP NIL) (RMSUBS))))
(FORT ((NIL (SETQ !*NAT NAT!*!*)) (T (SETQ !*NAT NIL))))
(GCD ((T (RMSUBS))))
(MCD ((NIL (RMSUBS)) (T (RMSUBS))))
(NAT ((NIL (SETQ NAT!*!* NIL)) (T (SETQ NAT!*!* T))))
(NUMVAL ((T (RMSUBS)) (NIL (SETDMODE NIL))))
(VAL ((T (RMSUBS))))
(FLOAT ((T (RMSUBS))))),'SIMPFG);
%*********************************************************************
% SELECTORS AND CONSTRUCTORS USED IN ALGEBRAIC CALCULATIONS
%********************************************************************;
NEWTOK '((!. !+) ADD);
NEWTOK '((!. !*) MULT);
NEWTOK '((!. !* !*) TO);
NEWTOK '((!. !/) OVER);
INFIX TO,.*,.+,./;
SMACRO PROCEDURE U.+V; %standard (polynomial) addition constructor;
U . V;
SMACRO PROCEDURE LC U; %leading coefficient of standard form;
CDAR U;
SMACRO PROCEDURE LDEG U; %leading degree of standard form;
CDAAR U;
SMACRO PROCEDURE LT U; %leading term of standard form;
CAR U;
SMACRO PROCEDURE U.*V; %standard form multiplication constructor;
U . V;
SMACRO PROCEDURE MVAR U; %main variable of standard form;
CAAAR U;
SMACRO PROCEDURE LPOW U; %leading power of standard form;
CAAR U;
SMACRO PROCEDURE PDEG U;
%returns the degree of the power U;
CDR U;
SMACRO PROCEDURE RED U; %reductum of standard form;
CDR U;
SMACRO PROCEDURE TC U; %coefficient of standard term;
CDR U;
SMACRO PROCEDURE TDEG U; %degree of standard term;
CDAR U;
SMACRO PROCEDURE TPOW U; %power of standard term;
CAR U;
SMACRO PROCEDURE TVAR U; %main variable of a standard term;
CAAR U;
SMACRO PROCEDURE NUMR U; %numerator of standard quotient;
CAR U;
SMACRO PROCEDURE DENR U; %denominator of standard quotient;
CDR U;
SMACRO PROCEDURE U ./ V; %constructor for standard quotient;
U . V;
%*********************************************************************
% MACROS AND PROCEDURES FOR CONVERTING BETWEEN VARIOUS FORMS
%********************************************************************;
SYMBOLIC PROCEDURE !*A2F U;
%U is an algebraic expression. Value is the equivalent form
%or an error if conversion is not possible;
!*Q2F SIMP!* U;
SYMBOLIC PROCEDURE !*A2K U;
%U is an algebraic expression. Value is the equivalent kernel
%or an error if conversion is not possible.
%earlier versions used SIMP0;
BEGIN SCALAR X;
IF KERNP(X := SIMP!* U) THEN RETURN MVAR NUMR X
ELSE TYPERR(U,'kernel)
END;
SMACRO PROCEDURE !*F2A U; PREPF U;
SMACRO PROCEDURE !*F2Q U;
%U is a standard form, value is a standard quotient;
U . 1;
SMACRO PROCEDURE !*K2F U;
%U is a kernel, value is a standard form;
LIST (TO(U,1) . 1);
SMACRO PROCEDURE !*K2Q U;
%U is a kernel, value is a standard quotient;
LIST(TO(U,1) . 1) . 1;
SYMBOLIC PROCEDURE !*N2F U;
%U is a number. Value is a standard form;
IF ZEROP U THEN NIL ELSE U;
SMACRO PROCEDURE !*P2F U;
%U is a standard power, value is a standard form;
LIST (U . 1);
SMACRO PROCEDURE !*P2Q U;
%U is a standard power, value is a standard quotient;
LIST(U . 1) . 1;
SYMBOLIC PROCEDURE !*Q2F U;
%U is a standard quotient, value is a standard form;
IF DENR U=1 THEN NUMR U ELSE TYPERR(PREPSQ U,'polynomial);
SYMBOLIC PROCEDURE !*Q2K U;
%U is a standard quotient, value is a kernel or an error if
%conversion not possible;
IF KERNP U THEN MVAR NUMR U
ELSE TYPERR(PREPSQ U,'kernel);
SMACRO PROCEDURE !*T2F U;
%U is a standard term, value is a standard form;
LIST U;
SMACRO PROCEDURE !*T2Q U;
%U is a standard term, value is a standard quotient;
LIST U . 1;
%*********************************************************************
% FUNCTIONS FOR ALGEBRAIC EVALUATION OF PREFIX FORMS
%********************************************************************;
SYMBOLIC PROCEDURE REVAL U;
REVAL1(U,T);
SYMBOLIC PROCEDURE AEVAL U;
REVAL1(U,NIL);
SYMBOLIC PROCEDURE REVAL1(U,V);
BEGIN SCALAR ALGLIST!*,X,Y;
LOOP:
IF STRINGP U THEN RETURN U
ELSE IF NUMBERP U AND FIXP U
THEN IF MOD!* THEN GO TO B ELSE RETURN U
ELSE IF ATOM U THEN NIL
ELSE IF CAR U EQ '!*COMMA!* THEN ERRPRI2(U,T)
ELSE IF CAR U EQ '!*SQ THEN GO TO B
ELSE IF ARRAYP CAR U
THEN <<U := GETELV U; GO TO LOOP>>;
X := LIST U;
Y := TYPL!*;
A: IF NULL Y THEN GO TO B
ELSE IF APPLY(CAR Y,X)
THEN RETURN APPLY(GET(CAR Y,'EVFN),X);
Y := CDR Y;
GO TO A;
B: U := SIMP!* U;
IF NULL V THEN RETURN MK!*SQ U;
U := PREPSQX U;
RETURN IF EQCAR(U,'MINUS) AND NUMBERP CADR U THEN -CADR U
ELSE U
END;
SYMBOLIC PROCEDURE PREPSQX U;
IF !*INTSTR THEN PREPSQ!* U ELSE PREPSQ U;
SYMBOLIC PROCEDURE IEVAL U;
%returns algebraic value of U if U is an integer or an error;
BEGIN
IF NUMBERP U
THEN IF FIXP U THEN RETURN U ELSE TYPERR(U,"integer")
ELSE IF NOT ATOM U AND ARRAYP CAR U THEN U := GETELV U;
U := SIMP!* U;
IF DENR U NEQ 1 OR NOT ATOM NUMR U
THEN TYPERR(PREPSQ U,"integer");
U := NUMR U;
IF NULL U THEN U := 0;
RETURN U
END;
SYMBOLIC PROCEDURE GETELV U;
%returns the value of the array element U;
GETEL(CAR U . FOR EACH X IN CDR U COLLECT IEVAL X);
SYMBOLIC PROCEDURE SETELV(U,V);
SETEL(CAR U . FOR EACH X IN CDR U COLLECT IEVAL X,V);
SYMBOLIC PROCEDURE REVLIS U; FOR EACH J IN U COLLECT REVAL J;
SYMBOLIC PROCEDURE REVOP1 U;
IF !*VAL THEN CAR U . REVLIS CDR U ELSE U;
SYMBOLIC PROCEDURE MK!*SQ U;
IF NULL NUMR U THEN 0
ELSE IF ATOM NUMR U AND DENR U=1 THEN NUMR U
ELSE '!*SQ . EXPCHK U . IF !*RESUBS THEN !*SQVAR!* ELSE LIST NIL;
SYMBOLIC PROCEDURE EXPCHK U;
IF !*EXP THEN U ELSE CANPROD(MKPROD!* NUMR U,MKPROD!* DENR U);
%*********************************************************************
% EVALUATION FUNCTIONS FOR BOOLEAN OPERATORS
%********************************************************************;
SYMBOLIC PROCEDURE EVALEQUAL(U,V);
(LAMBDA X; NUMBERP X AND ZEROP X) REVAL LIST('DIFFERENCE,U,V);
PUT('EQUAL,'BOOLFN,'EVALEQUAL);
SYMBOLIC PROCEDURE EVALGREATERP(U,V);
(LAMBDA X;
ATOM DENR X AND DOMAINP NUMR X AND NUMR X AND !:MINUSP NUMR X)
SIMP!* LIST('DIFFERENCE,V,U);
PUT('GREATERP,'BOOLFN,'EVALGREATERP);
SYMBOLIC PROCEDURE EVALGEQ(U,V); NOT EVALLESSP(U,V);
PUT('GEQ,'BOOLFN,'EVALGEQ);
SYMBOLIC PROCEDURE EVALLESSP(U,V);
(LAMBDA X;
ATOM DENR X AND DOMAINP NUMR X AND NUMR X AND !:MINUSP NUMR X)
SIMP!* LIST('DIFFERENCE,U,V);
PUT('LESSP,'BOOLFN,'EVALLESSP);
SYMBOLIC PROCEDURE EVALLEQ(U,V); NOT EVALGREATERP(U,V);
PUT('LEQ,'BOOLFN,'EVALLEQ);
SYMBOLIC PROCEDURE EVALNEQ(U,V); NOT EVALEQUAL(U,V);
PUT('NEQ,'BOOLFN,'EVALNEQ);
SYMBOLIC PROCEDURE EVALNUMBERP U;
(LAMBDA X; ATOM DENR X AND DOMAINP NUMR X) SIMP!* U;
PUT('NUMBERP,'BOOLFN,'EVALNUMBERP);
%*********************************************************************
% FUNCTIONS FOR CONVERTING PREFIX FORMS INTO CANONICAL FORM
%********************************************************************;
SYMBOLIC PROCEDURE SIMP!* U;
BEGIN SCALAR X;
IF EQCAR(U,'!*SQ) AND CADDR U THEN RETURN CADR U;
X := MUL!* . !*SUB2; %save current environment;
MUL!* := NIL;
U:= SIMP U;
A: IF NULL MUL!* THEN GO TO B;
U:= APPLY(CAR MUL!*,LIST U);
MUL!*:= CDR MUL!*;
GO TO A;
B: MUL!* := CAR X;
U := SUBS2 U;
!*SUB2 := CDR X;
RETURN U
END;
SYMBOLIC PROCEDURE SUBS2 U;
BEGIN SCALAR XEXP;
IF NULL SUBFG!* THEN RETURN U
ELSE IF !*SUB2 OR POWLIS1!* THEN U := SUBS2Q U;
IF NULL !*MATCH AND NULL SPLIS!* THEN RETURN U
ELSE IF NULL !*EXP
THEN <<XEXP:= T; !*EXP := T; U := RESIMP U>>;
IF !*MATCH THEN U := SUBS3Q U;
IF SPLIS!* THEN U := SUBS4Q U;
IF XEXP THEN !*EXP := NIL;
RETURN U
END;
SYMBOLIC PROCEDURE SIMP U;
BEGIN SCALAR X;
IF ATOM U THEN RETURN SIMPATOM U
ELSE IF CAR U EQ '!*SQ AND CADDR U THEN RETURN CADR U
ELSE IF X := ASSOC(U,ALGLIST!*) THEN RETURN CDR X
ELSE IF NOT IDP CAR U THEN GO TO E
ELSE IF FLAGP(CAR U,'OPFN)
THEN RETURN !*SSAVE(SIMP EVAL(CAR U . FOR EACH J IN
(IF FLAGP(CAR U,'NOVAL) THEN CDR U
ELSE REVLIS CDR U) COLLECT MKQUOTE J),U)
ELSE IF X := GET(CAR U,'POLYFN)
THEN RETURN !*SSAVE(!*F2Q APPLY(X,
FOR EACH J IN CDR U COLLECT !*Q2F SIMP!* J),
U)
ELSE IF GET(CAR U,'OPMTCH)
AND NOT(GET(CAR U,'SIMPFN) EQ 'SIMPIDEN)
AND (X := OPMTCH REVOP1 U)
THEN RETURN SIMP X
ELSE IF X := GET(CAR U,'SIMPFN)
THEN RETURN !*SSAVE(IF FLAGP(CAR U,'FULL) OR X EQ 'SIMPIDEN
THEN APPLY(X,LIST U)
ELSE APPLY(X,LIST CDR U),U)
ELSE IF ARRAYP CAR U
THEN RETURN !*SSAVE(SIMP GETELV U,U)
ELSE IF (X := GET(CAR U,'MATRIX)) THEN GO TO M
ELSE IF FLAGP(CAR U,'BOOLEAN)
THEN TYPERR(GETINFIX CAR U,"algebraic operator")
ELSE IF GET(CAR U,'INFIX) THEN GO TO E
ELSE IF FLAGP(CAR U,'NOCHANGE)
THEN RETURN !*SSAVE(SIMP EVAL U,U)
ELSE <<REDMSG(CAR U,"operator"); MKOP CAR U; RETURN SIMP U>>;
M: IF NOT EQCAR(X,'MAT) THEN REDERR LIST("Matrix",CAR U,"not set")
ELSE IF NOT NUMLIS (U := REVLIS CDR U) OR LENGTH U NEQ 2
THEN GO TO E;
RETURN !*SSAVE(SIMP NTH(NTH(CDR X,CAR U),CADR U),U);
E: IF EQCAR(CAR U,'MAT) THEN <<X := CAR U; GO TO M>>
ELSE ERRPRI2(GETINFIX U,T)
END;
SYMBOLIC PROCEDURE GETINFIX U;
%finds infix symbol for U if it exists;
BEGIN SCALAR X;
RETURN IF X := GET(U,'PRTCH) THEN CAR X ELSE U
END;
SYMBOLIC PROCEDURE !*SSAVE(U,V);
BEGIN
ALGLIST!* := (V . U) . ALGLIST!*;
RETURN U
END;
SYMBOLIC PROCEDURE NUMLIS U;
NULL U OR (NUMBERP CAR U AND NUMLIS CDR U);
SYMBOLIC PROCEDURE SIMPATOM U;
IF NULL U THEN NIL ./ 1
ELSE IF NUMBERP U
THEN IF ZEROP U THEN NIL ./ 1
ELSE IF NOT FIXP U
THEN !*D2Q IF NULL DMODE!* THEN !*FT2RN MKFLOAT U
ELSE IF DMODE!* EQ '!:FT!: THEN MKFLOAT U
ELSE APPLY(GET('!:FT!:,DMODE!*),LIST MKFLOAT U)
ELSE IF DMODE!* AND FLAGP(DMODE!*,'CONVERT)
THEN !*D2Q APPLY(GET(DMODE!*,'I2D),LIST U)
ELSE U ./ 1
ELSE IF FLAGP(U,'SHARE) THEN SIMP EVAL U
ELSE BEGIN SCALAR Z;
IF !*NUMVAL AND (Z := GET(U,'DOMAINFN))
THEN <<SETDMODE GET(U,'TARGETMODE);
RETURN !*D2Q APPLY(Z,NIL)>>;
FOR EACH X IN TYPL!* DO IF APPLY(X,LIST U) THEN TYPERR(U,'scalar);
RETURN MKSQ(U,1)
END;
SYMBOLIC PROCEDURE MKOP U;
BEGIN SCALAR X;
IF NULL U THEN TYPERR("Local variable","operator")
ELSE IF (X := GETTYPE U) EQ 'OPERATOR
THEN LPRIM LIST(U,"already defined as operator")
ELSE IF X AND NOT X EQ 'PROCEDURE THEN TYPERR(U,'operator)
ELSE IF U MEMQ FRLIS!* THEN TYPERR(U,"free variable")
ELSE PUT(U,'SIMPFN,'SIMPIDEN)
END;
SYMBOLIC PROCEDURE SIMPCAR U;
SIMP CAR U;
PUT('QUOTE,'SIMPFN,'SIMPCAR);
FLAGOP SHARE;
FLAG('(WS !*MODE),'SHARE);
%*********************************************************************
% SIMPLIFICATION FUNCTIONS FOR EXPLICIT OPERATORS
%********************************************************************;
SYMBOLIC PROCEDURE SIMPABS U;
(LAMBDA X; ABSF NUMR X ./ DENR X) SIMPCAR U;
PUT('ABS,'SIMPFN,'SIMPABS);
SYMBOLIC PROCEDURE SIMPEXPT U;
BEGIN SCALAR FLG,M,N,X;
IF DMODE!* EQ '!:MOD!: THEN <<X := T; DMODE!* := NIL>>;
%exponents must not use modular arithmetic;
N := SIMP!* CARX(CDR U,'EXPT);
IF X THEN DMODE!* := '!:MOD!:;
U := CAR U;
A: M := NUMR N;
IF NOT ATOM M OR DENR N NEQ 1 THEN GO TO NONUMEXP
ELSE IF NULL M
THEN RETURN IF NUMBERP U AND ZEROP U
THEN REDERR " 0**0 formed"
ELSE 1 ./ 1
ELSE IF ONEP U THEN RETURN 1 ./ 1;
X := SIMP U;
%we could use simp!* here, except that it messes up the
%handling of gamma matrix expressions;
IF !*NUMVAL AND DOMAINP NUMR X AND DOMAINP DENR X
AND NOT (ATOM NUMR X AND ATOM DENR X)
THEN RETURN NUMEXPT(MK!*SQ X,M,1)
ELSE IF NOT M<0 THEN RETURN EXPTSQ(X,M)
ELSE IF !*MCD THEN RETURN INVSQ EXPTSQ(X,-M)
ELSE RETURN EXPSQ(X,M); %using OFF EXP code here;
%there may be a pattern matching problem though;
NONUMEXP:
IF ONEP U THEN RETURN 1 ./ 1
ELSE IF ATOM U THEN GO TO A2
ELSE IF CAR U EQ 'TIMES
THEN <<N := PREPSQ N;
X := 1 ./ 1;
FOR EACH Z IN CDR U DO
X := MULTSQ(SIMPEXPT LIST(Z,N),X);
RETURN X>>
ELSE IF CAR U EQ 'QUOTIENT
THEN <<IF NOT FLG AND !*MCD THEN GO TO A2;
N := PREPSQ N;
RETURN MULTSQ(SIMPEXPT LIST(CADR U,N),
SIMPEXPT LIST(CADDR U,LIST('MINUS,N)))>>
ELSE IF CAR U EQ 'EXPT
THEN <<N := MULTSQ(SIMP CADDR U,N);
U := CADR U;
X := NIL;
GO TO A>>
ELSE IF CAR U EQ 'MINUS AND NUMBERP M AND DENR N=1
THEN RETURN MULTSQ(SIMPEXPT LIST(-1,M),
SIMPEXPT LIST(CADR U,M));
A2: IF NULL FLG
THEN <<FLG := T;
U := PREPSQ IF NULL X THEN (X := SIMP!* U) ELSE X;
GO TO NONUMEXP>>
ELSE IF NUMBERP U AND ZEROP U THEN RETURN NIL ./ 1
ELSE IF NOT NUMBERP M THEN M := PREPF M;
IF M MEMQ FRLIS!* THEN RETURN LIST ((U . M) . 1) . 1;
%"power" is not unique here;
N := PREPF CDR N;
IF !*MCD OR CDR X NEQ 1 OR NOT NUMBERP M OR N NEQ 1
OR ATOM U THEN GO TO C
% ELSE IF MINUSF CAR X THEN RETURN MULTSQ(SIMPEXPT LIST(-1,M),
% SIMPEXPT LIST(PREPF NEGF CAR X,M));
ELSE IF CAR U EQ 'PLUS OR NOT !*MCD AND N=1
THEN RETURN MKSQ(U,M); %to make pattern matching work;
C: IF !*NUMVAL AND NUMTYPEP U AND NUMTYPEP M AND NUMTYPEP N
THEN RETURN NUMEXPT(U,M,N)
ELSE RETURN SIMPX1(U,M,N)
END;
SYMBOLIC PROCEDURE NUMEXPT(U,M,N);
%U,M and N are all numbers. Result is standard quotient for U**(M/N);
BEGIN SCALAR X;
RETURN IF X := TARGETCONV(LIST(U,M,N),'BIGFLOAT)
THEN !*D2Q IF N=1 AND ATOM M AND FIXP M THEN TEXPT!:(CAR X,M)
ELSE TEXPT!:ANY(CAR X,
IF N=1 THEN CADR X
ELSE BFQUOTIENT!:(CADR X,CADDR X))
ELSE SIMPX1(U,M,N)
END;
SYMBOLIC PROCEDURE IEXPT(U,N);
IF NULL MOD!* THEN U**N
ELSE IF N<0 THEN CEXPT(CRECIP U,-N)
ELSE CEXPT(U,N);
PUT('EXPT,'SIMPFN,'SIMPEXPT);
SYMBOLIC PROCEDURE SIMPX1(U,M,N);
%U,M and N are prefix expressions;
%Value is the standard quotient expression for U**(M/N);
BEGIN SCALAR FLG,X,Z;
IF NUMBERP M AND NUMBERP N
OR NULL SMEMQLP(FRLIS!*,M) OR NULL SMEMQLP(FRLIS!*,N)
THEN GO TO A;
EXPTP!* := T;
RETURN !*K2Q LIST('EXPT,U,IF N=1 THEN M
ELSE LIST('QUOTIENT,M,N));
A: IF NUMBERP M THEN IF MINUSP M THEN <<M := -M; GO TO MNS>>
ELSE IF FIXP M THEN GO TO E
ELSE GO TO B
ELSE IF ATOM M THEN GO TO B
ELSE IF CAR M EQ 'MINUS THEN <<M := CADR M; GO TO MNS>>
ELSE IF CAR M EQ 'PLUS THEN GO TO PLS
ELSE IF CAR M EQ 'TIMES AND NUMBERP CADR M AND FIXP CADR M
AND NUMBERP N
THEN GO TO TMS;
B: Z := 1;
C: IF IDP U AND NOT FLAGP(U,'USED!*) THEN FLAG(LIST U,'USED!*);
U := LIST('EXPT,U,IF N=1 THEN M ELSE LIST('QUOTIENT,M,N));
IF NOT U MEMBER EXPTL!* THEN EXPTL!* := U . EXPTL!*;
D: RETURN MKSQ(U,IF FLG THEN -Z ELSE Z); %U is already in lowest
%terms;
E: IF NUMBERP N AND FIXP N THEN GO TO INT;
Z := M;
M := 1;
GO TO C;
MNS: IF !*MCD THEN RETURN INVSQ SIMPX1(U,M,N);
FLG := NOT FLG;
GO TO A;
PLS: Z := 1 ./ 1;
PL1: M := CDR M;
IF NULL M THEN RETURN Z;
Z := MULTSQ(SIMPEXPT LIST(U,
LIST('QUOTIENT,IF FLG THEN LIST('MINUS,CAR M)
ELSE CAR M,N)),
Z);
GO TO PL1;
TMS: Z := GCDN(N,CADR M);
N := N/Z;
Z := CADR M/Z;
M := RETIMES CDDR M;
GO TO C;
INT:Z := DIVIDE(M,N);
IF CDR Z<0 THEN Z:= (CAR Z - 1) . (CDR Z+N);
X := SIMPEXPT LIST(U,CAR Z);
IF CDR Z=0 THEN RETURN X
ELSE IF N=2 THEN RETURN MULTSQ(X,SIMPSQRT LIST U)
ELSE RETURN MULTSQ(X,EXPTSQ(SIMPRAD(SIMP!* U,N),CDR Z))
END;
SYMBOLIC PROCEDURE EXPSQ(U,N);
%RAISES STANDARD QUOTIENT U TO NEGATIVE POWER N WITH EXP OFF;
MULTF(EXPF(NUMR U,N),MKSFPF(DENR U,-N)) ./ 1;
SYMBOLIC PROCEDURE EXPF(U,N);
%U is a standard form. Value is standard form of U raised to
%negative integer power N. MCD is assumed off;
%what if U is invertable?;
IF NULL U THEN NIL
ELSE IF ATOM U THEN MKRN(1,U**(-N))
ELSE IF DOMAINP U THEN !:EXPT(U,N)
ELSE IF RED U THEN MKSP!*(U,N)
ELSE (LAMBDA X; IF X>0 AND SFP MVAR U
THEN MULTF(EXPTF(MVAR U,X),EXPF(LC U,N))
ELSE MVAR U TO X .* EXPF(LC U,N) .+ NIL)
(LDEG U*N);
SYMBOLIC PROCEDURE SIMPRAD(U,N);
%simplifies radical expressions;
BEGIN SCALAR X,Y,Z;
X := RADF(NUMR U,N);
Y := RADF(DENR U,N);
Z := MULTSQ(CAR X ./ 1,1 ./ CAR Y);
Z := MULTSQ(MULTSQ(MKROOTLF(CDR X,N) ./ 1,
1 ./ MKROOTLF(CDR Y,N)),
Z);
RETURN Z
END;
SYMBOLIC PROCEDURE MKROOTLF(U,N);
%U is a list of prefix expressions, N an integer.
%Value is standard form for U**(1/N);
IF NULL U THEN 1 ELSE MULTF(MKROOTF(CAR U,N),MKROOTLF(CDR U,N));
SYMBOLIC PROCEDURE MKROOTF(U,N);
%U is a prefix expression, N an integer.
%Value is a standard form for U**(1/N);
!*P2F IF EQCAR(U,'EXPT) AND FIXP CADDR U
THEN MKSP(IF N=2 THEN MKSQRT CADR U
ELSE LIST('EXPT,CADR U,LIST('QUOTIENT,1,N)),CADDR U)
ELSE MKSP(IF N=2 THEN MKSQRT U
ELSE LIST('EXPT,U,LIST('QUOTIENT,1,N)),1);
COMMENT The following three procedures return a partitioned root
expression, which is a dotted pair of integral part (a standard
form) and radical part (a list of prefix expressions). The whole
structure represents U**(1/N);
SYMBOLIC PROCEDURE RADF(U,N);
%U is a standard form, N a positive integer. Value is a partitioned
%root expression for U**(1/N);
BEGIN SCALAR IPART,RPART,X,Y,!*GCD;
IF NULL U THEN RETURN LIST U;
!*GCD := T;
IPART := 1;
WHILE NOT DOMAINP U DO
<<Y := COMFAC U;
IF CAR Y
THEN <<X := DIVIDE(PDEG CAR Y,N);
IF CAR X NEQ 0
THEN IPART:=MULTF(!*P2F(MVAR U TO CAR X),IPART);
IF CDR X NEQ 0
THEN RPART :=
MKEXPT(IF SFP MVAR U THEN PREPF MVAR U
ELSE MVAR U,CDR X) . RPART>>;
X := QUOTF1(U,COMFAC!-TO!-POLY Y);
U := CDR Y;
IF MINUSF X THEN <<X := NEGF X; U := NEGF U>>;
IF X NEQ 1
THEN <<X := RADF1(SQFRF X,N);
IPART := MULTF(CAR X,IPART);
RPART := APPEND(RPART,CDR X)>>>>;
IF U NEQ 1
THEN <<X := RADD(U,N);
IPART := MULTF(CAR X,IPART);
RPART := APPEND(CDR X,RPART)>>;
RETURN IPART . RPART
END;
SYMBOLIC PROCEDURE RADF1(U,N);
%U is a form_power list, N a positive integer. Value is a
%partitioned root expression for U**(1/N);
BEGIN SCALAR IPART,RPART,X;
IPART := 1;
FOR EACH Z IN U DO
<<X := DIVIDE(CDR Z,N);
IF NOT(CAR X=0)
THEN IPART := MULTF(EXPTF(CAR Z,CAR X),IPART);
IF NOT(CDR X=0)
THEN RPART := MKEXPT(PREPSQ!*(CAR Z ./ 1),CDR X)
. RPART>>;
RETURN IPART . RPART
END;
SYMBOLIC PROCEDURE RADD(U,N);
%U is a domain element, N an integer.
%Value is a partitioned root expression for U**(1/N);
BEGIN SCALAR IPART,X;
IPART := 1;
IF NOT ATOM U THEN RETURN LIST(1,U)
ELSE IF U<0
THEN IF N=2 THEN <<IPART := !*K2F 'I; U := -U>>
ELSE IF REMAINDER(N,2)=1 THEN <<IPART := -1; U := -U>>
ELSE RETURN LIST(1,U);
X := NROOTN(U,N);
RETURN IF CDR X=1 THEN LIST MULTD(CAR X,IPART)
ELSE LIST(MULTD(CAR X,IPART),CDR X)
END;
SYMBOLIC PROCEDURE IROOT(M,N);
%M and N are positive integers.
%If M**(1/N) is an integer, this value is returned, otherwise NIL;
BEGIN SCALAR X,X1,BK;
IF M=0 THEN RETURN M;
X := 10**CEILING(LENGTHC M,N); %first guess;
A: X1 := X**(N-1);
BK := X-M/X1;
IF BK<0 THEN RETURN NIL
ELSE IF BK=0 THEN RETURN IF X1*X=M THEN X ELSE NIL;
X := X-CEILING(BK,N);
GO TO A
END;
SYMBOLIC PROCEDURE CEILING(M,N);
%M and N are positive integers. Value is ceiling of (M/N) (i.e.,
%least integer greater or equal to M/N);
(LAMBDA X; IF CDR X=0 THEN CAR X ELSE CAR X+1) DIVIDE(M,N);
SYMBOLIC PROCEDURE MKEXPT(U,N);
IF N=1 THEN U ELSE LIST('EXPT,U,N);
SYMBOLIC PROCEDURE NROOTN(N,X);
%N is an integer, X a positive integer. Value is a pair
%of integers I,J such that I*J**(1/X)=N**(1/X);
BEGIN SCALAR I,J,R,SIGNN;
R := 1;
IF N<0
THEN <<N := -N;
IF REMAINDER(X,2)=0 THEN SIGNN := T ELSE R := -1>>;
J := 2**X;
WHILE REMAINDER(N,J)=0 DO <<N := N/J; R := R*2>>;
I := 3;
J := 3**X;
WHILE J<=N DO
<<WHILE REMAINDER(N,J)=0 DO <<N := N/J; R := R*I>>;
IF REMAINDER(I,3)=1 THEN I := I+4 ELSE I := I+2;
J := I**X>>;
IF SIGNN THEN N := -N;
RETURN R . N
END;
SYMBOLIC PROCEDURE SIMPIDEN U;
BEGIN SCALAR Y,Z;
U:= REVOP1 U;
IF FLAGP(CAR U,'NONCOM) THEN NCMP!* := T;
IF NULL SUBFG!* THEN GO TO C
ELSE IF FLAGP(CAR U,'LINEAR) AND (Z := FORMLNR U) NEQ U
THEN RETURN SIMP Z
ELSE IF Z := OPMTCH U THEN RETURN SIMP Z
ELSE IF Z := NUMVALCHK U THEN RETURN Z;
C: IF FLAGP(CAR U,'SYMMETRIC) THEN U := CAR U . ORDN CDR U
ELSE IF FLAGP(CAR U,'ANTISYMMETRIC)
THEN <<IF REPEATS CDR U THEN RETURN (NIL ./ 1)
ELSE IF NOT PERMP(Z:= ORDN CDR U,CDR U) THEN Y := T;
U := CAR U . Z>>;
U := MKSQ(U,1);
RETURN IF Y THEN NEGSQ U ELSE U
END;
SYMBOLIC PROCEDURE NUMVALCHK U;
BEGIN SCALAR Y,Z;
IF NULL !*NUMVAL THEN RETURN NIL
ELSE IF ATOM U THEN RETURN NIL
ELSE IF (Z := GET(CAR U,'DOMAINFN))
AND DOMAINLISP CDR U
AND (Y := TARGETCONV(CDR U,GET(CAR U,'TARGETMODE)))
THEN <<SETDMODE GET(CAR U,'TARGETMODE);
RETURN !*D2Q APPLY(Z,Y)>>
ELSE RETURN NIL
END;
SYMBOLIC PROCEDURE NUMTYPEP U;
%returns true if U is a possible number, NIL otherwise;
IF ATOM U THEN NUMBERP U
ELSE IF GET(CAR U,'DNAME) THEN U
ELSE IF CAR U EQ 'MINUS THEN NUMTYPEP CADR U
ELSE IF CAR U EQ 'QUOTIENT THEN NUMTYPEP CADR U AND NUMTYPEP CADDR U
ELSE NIL;
SYMBOLIC PROCEDURE DOMAINLISP U;
%true if U is a list of domain element numbers, NIL otherwise;
IF NULL U THEN T ELSE NUMTYPEP CAR U AND DOMAINLISP CDR U;
SYMBOLIC PROCEDURE TARGETCONV(U,V);
%U is a list of domain elements, V a domain mode;
%if all elements of U can be converted to mode V, a list of the
%converted elements is returned, otherwise NIL is returned;
BEGIN SCALAR X,Y,Z;
V := GET(V,'TAG);
A: IF NULL U THEN RETURN REVERSIP X
ELSE IF ATOM (Z := NUMR SIMPCAR U)
THEN X := APPLY(GET(V,'I2D),LIST IF NULL Z THEN 0 ELSE Z) . X
ELSE IF CAR Z EQ V THEN X := Z . X
ELSE IF Y := GET(CAR Z,V)
THEN X := APPLY(Y,LIST Z) . X
ELSE RETURN NIL;
U := CDR U;
GO TO A
END;
SYMBOLIC PROCEDURE SIMPDIFF U;
ADDSQ(SIMPCAR U,SIMPMINUS CDR U);
PUT('DIFFERENCE,'SIMPFN,'SIMPDIFF);
SYMBOLIC PROCEDURE SIMPMINUS U;
NEGSQ SIMP CARX(U,'MINUS);
PUT('MINUS,'SIMPFN,'SIMPMINUS);
SYMBOLIC PROCEDURE SIMPPLUS U;
BEGIN SCALAR Z;
Z := NIL ./ 1;
A: IF NULL U THEN RETURN Z;
Z := ADDSQ(SIMPCAR U,Z);
U := CDR U;
GO TO A
END;
PUT('PLUS,'SIMPFN,'SIMPPLUS);
SYMBOLIC PROCEDURE SIMPQUOT U;
MULTSQ(SIMPCAR U,SIMPRECIP CDR U);
PUT('QUOTIENT,'SIMPFN,'SIMPQUOT);
SYMBOLIC PROCEDURE SIMPRECIP U;
IF NULL !*MCD THEN SIMPEXPT LIST(CARX(U,'RECIP),-1)
ELSE INVSQ SIMP CARX( U,'RECIP);
PUT('RECIP,'SIMPFN,'SIMPRECIP);
SYMBOLIC PROCEDURE SIMPSQRT U;
BEGIN SCALAR X,Y;
X := XSIMP CAR U;
RETURN IF !*NUMVAL AND (Y := NUMVALCHK MKSQRT PREPSQ!* X)
THEN Y
ELSE SIMPRAD(X,2)
END;
SYMBOLIC PROCEDURE XSIMP U; EXPCHK SIMP!* U;
SYMBOLIC PROCEDURE SIMPTIMES U;
BEGIN SCALAR X,Y;
IF TSTACK!* NEQ 0 OR NULL MUL!* THEN GO TO A0;
Y := MUL!*;
MUL!* := NIL;
A0: TSTACK!* := TSTACK!*+1;
X := SIMPCAR U;
A: U := CDR U;
IF NULL NUMR X THEN GO TO C
ELSE IF NULL U THEN GO TO B;
X := MULTSQ(X,SIMPCAR U);
GO TO A;
B: IF NULL MUL!* OR TSTACK!*>1 THEN GO TO C;
X:= APPLY(CAR MUL!*,LIST X);
MUL!*:= CDR MUL!*;
GO TO B;
C: TSTACK!* := TSTACK!*-1;
IF TSTACK!* = 0 THEN MUL!* := Y;
RETURN X;
END;
PUT('TIMES,'SIMPFN,'SIMPTIMES);
SYMBOLIC PROCEDURE SIMPSUB U;
BEGIN SCALAR X,Z,Z1;
A: IF NULL CDR U THEN GO TO D
ELSE IF NOT EQEXPR CAR U THEN ERRPRI2(CAR U,T);
X := CADAR U;
Z1 := TYPL!*;
B: IF NULL Z1 THEN GO TO B1
ELSE IF APPLY(CAR Z1,LIST X) THEN GO TO C;
Z1 := CDR Z1;
GO TO B;
B1: X := !*A2K X;
C: Z := (X . CADDAR U) . Z;
U := CDR U;
GO TO A;
D: U := SIMP!* CAR U;
RETURN QUOTSQ(SUBF(NUMR U,Z),SUBF(DENR U,Z))
END;
SYMBOLIC PROCEDURE RESIMP U;
%U is a standard quotient.
%Value is the resimplified standard quotient;
QUOTSQ(SUBF1(NUMR U,NIL),SUBF1(DENR U,NIL));
PUT('SUB,'SIMPFN,'SIMPSUB);
SYMBOLIC PROCEDURE EQEXPR U;
NOT ATOM U
AND CAR U MEMQ '(EQ EQUAL) AND CDDR U AND NULL CDDDR U;
SYMBOLIC PROCEDURE SIMP!*SQ U;
IF NULL CADR U THEN RESIMP CAR U ELSE CAR U;
PUT('!*SQ,'SIMPFN,'SIMP!*SQ);
%*********************************************************************
% FUNCTIONS FOR DEFINING AND MANIPULATING POLYNOMIAL DOMAIN MODES
%********************************************************************;
GLOBAL '(DMODE!* DOMAINLIST!*);
SYMBOLIC PROCEDURE INITDMODE U;
%checks that U is a valid domain mode, and sets up appropriate
%interfaces to the system;
BEGIN
DMODECHK U;
PUT(U,'SIMPFG,LIST(LIST(T,LIST('SETDMODE,MKQUOTE U)),
'(NIL (SETDMODE NIL))))
END;
SYMBOLIC PROCEDURE SETDMODE U;
%Sets polynomial domain mode to U. If U is NIL, integers are used;
BEGIN SCALAR X;
IF NULL U THEN RETURN <<RMSUBS(); DMODE!* := NIL>>
ELSE IF NULL(X := GET(U,'TAG))
THEN REDERR LIST("Domain mode error:",U,"is not a domain mode")
ELSE IF DMODE!* EQ X THEN RETURN NIL;
RMSUBS();
IF DMODE!*
THEN LPRIM LIST("Domain mode",
GET(DMODE!*,'DNAME),"changed to",U);
IF U := GET(U,'MODULE!-NAME) THEN LOAD!-MODULE U;
DMODE!* := X
END;
SYMBOLIC PROCEDURE DMODECHK U;
%checks to see if U has complete specification for a domain mode;
BEGIN SCALAR Z;
IF NOT(Z := GET(U,'TAG))
THEN REDERR LIST("Domain mode error:","No tag for",Z)
ELSE IF NOT(GET(Z,'DNAME) EQ U)
THEN REDERR LIST("Domain mode error:",
"Inconsistent or missing DNAME for",Z)
ELSE IF NOT Z MEMQ DOMAINLIST!*
THEN REDERR LIST("Domain mode error:",
Z,"not on domain list");
U := Z;
FOR EACH X IN DOMAINLIST!*
DO IF U=X THEN NIL
ELSE IF NOT(GET(U,X) OR GET(X,U))
THEN REDERR LIST("Domain mode error:",
"No conversion defined between",U,"and",X);
Z := '(DIFFERENCE I2D MINUSP PLUS PREPFN QUOTIENT SPECPRN TIMES
ZEROP);
IF NOT FLAGP(U,'FIELD) THEN Z := 'DIVIDE . 'GCD . Z;
FOR EACH X IN Z DO IF NOT GET(U,X)
THEN REDERR LIST("Domain mode error:",
X,"is not defined for",U)
END;
COMMENT *** General Support Functions ***;
SYMBOLIC PROCEDURE !*D2Q U;
%converts domain element U into a standard quotient;
IF EQCAR(U,'!:RN!:) AND !*MCD THEN CDR U ELSE U ./ 1;
SYMBOLIC PROCEDURE FIELDP U;
%U is a domain element. Value is T if U is invertable, NIL
%otherwise;
NOT ATOM U AND FLAGP(CAR U,'FIELD);
SYMBOLIC PROCEDURE !:EXPT(U,N);
%raises domain element U to power N. Value is a domain element;
IF NULL U THEN IF N=0 THEN REDERR "0/0 formed" ELSE NIL
ELSE IF N=0 THEN 1
ELSE IF N<0
THEN !:RECIP !:EXPT(IF NOT FIELDP U THEN MKRATNUM U ELSE U,-N)
ELSE IF ATOM U THEN U**N
ELSE BEGIN SCALAR V,W,X;
V := APPLY(GET(CAR U,'I2D),LIST 1); %unit element;
X := GET(CAR U,'TIMES);
A: W := DIVIDE(N,2);
IF CDR W=1 THEN V := APPLY(X,LIST(U,V));
IF CAR W=0 THEN RETURN V;
U := APPLY(X,LIST(U,U));
N := CAR W;
GO TO A
END;
SYMBOLIC PROCEDURE !:MINUS U;
%U is a domain element. Value is -U;
IF ATOM U THEN -U ELSE DCOMBINE(U,-1,'TIMES);
SYMBOLIC PROCEDURE !:MINUSP U;
IF ATOM U THEN MINUSP U ELSE APPLY(GET(CAR U,'MINUSP),LIST U);
GLOBAL '(!:PREC!:);
SYMBOLIC PROCEDURE !:ONEP U;
%Allow for round-up of two in the last place in bigfloats;
IF ATOM U THEN U=1
ELSE IF !:ZEROP DCOMBINE(U,1,'DIFFERENCE) THEN T
ELSE CAR U EQ '!:BF!:
AND !:ZEROP DCOMBINE(BFPLUS!:(U,'!:BF!: . 2 . -!:PREC!:),
1,'DIFFERENCE);
SYMBOLIC PROCEDURE !:RECIP U;
%U is an invertable domain element. Value is 1/U;
IF NUMBERP U AND ABS U=1 THEN U ELSE DCOMBINE(1,U,'QUOTIENT);
SYMBOLIC PROCEDURE !:ZEROP U;
%returns T if domain element U is 0, NIL otherwise;
IF ATOM U THEN U=0 ELSE APPLY(GET(CAR U,'ZEROP),LIST U);
SYMBOLIC PROCEDURE DCOMBINE(U,V,FN);
%U and V are domain elements, but not both atoms (integers).
%FN is a binary function on domain elements;
%Value is the domain element representing FN(U,V);
IF ATOM U
THEN APPLY(GET(CAR V,FN),LIST(APPLY(GET(CAR V,'I2D),LIST U),V))
ELSE IF ATOM V
THEN APPLY(GET(CAR U,FN),LIST(U,APPLY(GET(CAR U,'I2D),LIST V)))
ELSE IF CAR U EQ CAR V THEN APPLY(GET(CAR U,FN),LIST(U,V))
ELSE BEGIN SCALAR X;
IF NOT(X := GET(CAR U,CAR V))
THEN <<V := APPLY(GET(CAR V,CAR U),LIST V);
X := GET(CAR U,FN)>>
ELSE <<U := APPLY(X,LIST U); X := GET(CAR V,FN)>>;
RETURN APPLY(X,LIST(U,V))
END;
COMMENT *** Tables for Various domain arithmetics ***:
Syntactically, such elements have the following form:
<domain element> := integer|(<domain identifier> . <domain structure>).
To introduce a new domain, we need to define:
1) A conversion function from integer to the given mode.
2) A conversion function from new mode to or from every other mode.
3) Particular instance of the binary operations +,- and * for this mode.
4) Particular instance of ZEROP, MINUSP for this mode.
5) If domain is a field, a quotient must be defined.
If domain is a ring, a gcd and divide must be defined, and
also a quotient function which returns NIL if the division fails.
6) A printing function for this mode.
7) A function to convert structure to an appropriate prefix form.
8) A reading function for this mode.
9) A DNAME property for the tag, and a TAG property for the DNAME
To facilitate this, all such modes should be listed in the global
variable DOMAINLIST!*;
COMMENT *** Tables for rational numbers ***;
FLUID '(!*RATIONAL);
DOMAINLIST!* := UNION('(!:RN!:),DOMAINLIST!*);
PUT('RATIONAL,'TAG,'!:RN!:);
PUT('!:RN!:,'DNAME,'RATIONAL);
FLAG('(!:RN!:),'FIELD);
PUT('!:RN!:,'I2D,'!*I2RN);
PUT('!:RN!:,'MINUSP,'RNMINUSP!:);
PUT('!:RN!:,'PLUS,'RNPLUS!:);
PUT('!:RN!:,'TIMES,'RNTIMES!:);
PUT('!:RN!:,'DIFFERENCE,'RNDIFFERENCE!:);
PUT('!:RN!:,'QUOTIENT,'RNQUOTIENT!:);
PUT('!:RN!:,'ZEROP,'RNZEROP!:);
PUT('!:RN!:,'PREPFN,'RNPREP!:);
PUT('!:RN!:,'SPECPRN,'RNPRIN);
SYMBOLIC PROCEDURE MKRATNUM U;
%U is a domain element. Value is equivalent rational number;
IF ATOM U THEN !*I2RN U ELSE APPLY(GET(CAR U,'!:RN!:),LIST U);
SYMBOLIC PROCEDURE MKRN(U,V);
%converts two integers U and V into a rational number, an integer
%or NIL;
IF U=0 THEN NIL
ELSE IF V<0 THEN MKRN(-U,-V)
ELSE (LAMBDA M;
(LAMBDA (N1,N2); IF N2=1 THEN N1 ELSE '!:RN!: . (N1 . N2))
(U/M,V/M))
GCDN(U,V);
SYMBOLIC PROCEDURE !*I2RN U;
%converts integer U to rational number;
'!:RN!: . (U . 1);
SYMBOLIC PROCEDURE RNMINUSP!: U; CADR U<0;
SYMBOLIC PROCEDURE RNPLUS!:(U,V);
MKRN(CADR U*CDDR V+CDDR U*CADR V,CDDR U*CDDR V);
SYMBOLIC PROCEDURE RNTIMES!:(U,V);
MKRN(CADR U*CADR V,CDDR U*CDDR V);
SYMBOLIC PROCEDURE RNDIFFERENCE!:(U,V);
MKRN(CADR U*CDDR V-CDDR U*CADR V,CDDR U*CDDR V);
SYMBOLIC PROCEDURE RNQUOTIENT!:(U,V);
MKRN(CADR U*CDDR V,CDDR U*CADR V);
SYMBOLIC PROCEDURE RNZEROP!: U; CADR U=0;
SYMBOLIC PROCEDURE RNPREP!: U;
IF CDDR U=1 THEN CADR U ELSE LIST('QUOTIENT,CADR U,CDDR U);
SYMBOLIC PROCEDURE RNPRIN U; MAPRIN RNPREP!: U;
INITDMODE 'RATIONAL;
COMMENT *** Tables for floats ***;
DOMAINLIST!* := UNION('(!:FT!:),DOMAINLIST!*);
PUT('FLOAT,'TAG,'!:FT!:);
PUT('!:FT!:,'DNAME,'FLOAT);
FLAG('(!:FT!:),'FIELD);
PUT('!:FT!:,'I2D,'!*I2FT);
PUT('!:FT!:,'!:RN!:,'!*FT2RN);
PUT('!:FT!:,'MINUSP,'FTMINUSP!:);
PUT('!:FT!:,'PLUS,'FTPLUS!:);
PUT('!:FT!:,'TIMES,'FTTIMES!:);
PUT('!:FT!:,'DIFFERENCE,'FTDIFFERENCE!:);
PUT('!:FT!:,'QUOTIENT,'FTQUOTIENT!:);
PUT('!:FT!:,'ZEROP,'FTZEROP!:);
PUT('!:FT!:,'PREPFN,'FTPREP!:);
PUT('!:FT!:,'SPECPRN,'PRIN2!*);
SYMBOLIC PROCEDURE MKFLOAT U;
'!:FT!: . U;
SYMBOLIC PROCEDURE !*I2FT U;
%converts integer U to floating point form or NIL;
IF U=0 THEN NIL ELSE '!:FT!: . FLOAT U;
SYMBOLIC PROCEDURE !*FT2RN U;
BEGIN INTEGER M; SCALAR X;
U := CDR U; %pick up actual number;
M := FIX(1000000*U);
X := GCDN(1000000,M);
X := (M/X) . (1000000/X);
MSGPRI(NIL,U,"represented by",LIST('QUOTIENT,CAR X,CDR X),NIL);
RETURN '!:RN!: . X
END;
SYMBOLIC PROCEDURE FTMINUSP!: U; CDR U<0;
SYMBOLIC PROCEDURE FTPLUS!:(U,V);
(LAMBDA X; IF ABS(X/CDR U)<0.000001 AND ABS(X/CDR V)<0.000001 THEN 0
ELSE '!:FT!: . X)
(CDR U+CDR V);
SYMBOLIC PROCEDURE FTTIMES!:(U,V); CAR U . (CDR U*CDR V);
SYMBOLIC PROCEDURE FTDIFFERENCE!:(U,V); CAR U .(CDR U-CDR V);
SYMBOLIC PROCEDURE FTQUOTIENT!:(U,V); CAR U . (CDR U/CDR V);
SYMBOLIC PROCEDURE FTZEROP!: U; CDR U=0.0;
SYMBOLIC PROCEDURE FTPREP!: U; CDR U;
INITDMODE 'FLOAT;
COMMENT *** Entry points for the bigfloat package ***;
FLUID '(!*BIGFLOAT);
PUT('BIGFLOAT,'SIMPFG,'((T (RMSUBS) (SETDMODE (QUOTE BIGFLOAT)))
(NIL (SETDMODE NIL))));
PUT('NUMVAL,'SIMPFG,'((T (RMSUBS) (SETDMODE (QUOTE BIGFLOAT)))));
PUT('BIGFLOAT,'TAG,'!:BF!:);
COMMENT *** Tables for modular integers ***;
FLUID '(!*MODULAR);
DOMAINLIST!* := UNION('(!:MOD!:),DOMAINLIST!*);
PUT('MODULAR,'TAG,'!:MOD!:);
PUT('!:MOD!:,'DNAME,'MODULAR);
FLAG('(!:MOD!:),'FIELD);
FLAG('(!:MOD!:),'CONVERT);
PUT('!:MOD!:,'I2D,'!*I2MOD);
PUT('!:MOD!:,'!:BF!:,'MODCNV);
PUT('!:MOD!:,'!:FT!:,'MODCNV);
PUT('!:MOD!:,'!:RN!:,'MODCNV);
PUT('!:MOD!:,'MINUSP,'MODMINUSP!:);
PUT('!:MOD!:,'PLUS,'MODPLUS!:);
PUT('!:MOD!:,'TIMES,'MODTIMES!:);
PUT('!:MOD!:,'DIFFERENCE,'MODDIFFERENCE!:);
PUT('!:MOD!:,'QUOTIENT,'MODQUOTIENT!:);
PUT('!:MOD!:,'ZEROP,'MODZEROP!:);
PUT('!:MOD!:,'PREPFN,'MODPREP!:);
PUT('!:MOD!:,'SPECPRN,'MODPRIN);
SYMBOLIC PROCEDURE !*I2MOD U;
%converts integer U to modular form;
IF (U := CMOD U)=0 THEN NIL ELSE '!:MOD!: . U;
SYMBOLIC PROCEDURE MODCNV U;
REDERR LIST("Conversion between modular integers and",
GET(CAR U,'DNAME),"not defined");
SYMBOLIC PROCEDURE MODMINUSP!: U; NIL; %what else can one do?;
SYMBOLIC PROCEDURE MODPLUS!:(U,V);
(LAMBDA X; IF X=0 THEN NIL ELSE IF X=1 THEN 1 ELSE CAR U . X)
CPLUS(CDR U,CDR V);
SYMBOLIC PROCEDURE MODTIMES!:(U,V);
(LAMBDA X; IF X=1 THEN 1 ELSE CAR U . X) CTIMES(CDR U,CDR V);
SYMBOLIC PROCEDURE MODDIFFERENCE!:(U,V);
CAR U . CPLUS(CDR U,MOD!*-CDR V);
SYMBOLIC PROCEDURE MODQUOTIENT!:(U,V);
CAR U . CTIMES(CDR U,CRECIP CDR V);
SYMBOLIC PROCEDURE MODZEROP!: U; CDR U=0;
SYMBOLIC PROCEDURE MODPREP!: U; CDR U;
SYMBOLIC PROCEDURE MODPRIN U; PRIN2!* CDR U;
INITDMODE 'MODULAR;
%*********************************************************************
% FUNCTIONS FOR MODULAR ARITHMETIC
%********************************************************************;
COMMENT This section defines routines for modular integer arithmetic.
It assumes that such numbers are normalized in the range 0<=n<p,
where p is the modular base;
COMMENT The actual modulus is stored in MOD!*;
SYMBOLIC PROCEDURE CEXPT(M,N);
%returns the normalized value of M**N;
BEGIN INTEGER P;
P := 1;
WHILE N>0 DO
<<IF REMAINDER(N,2)=1 THEN P := CTIMES(P,M);
N := N/2;
IF N>0 THEN M := CTIMES(M,M)>>;
RETURN P
END;
SYMBOLIC PROCEDURE CPLUS(M,N);
%returns the normalized sum of U and V;
(LAMBDA L; IF L>=MOD!* THEN L-MOD!* ELSE L) (M+N);
SYMBOLIC PROCEDURE CMINUS(M);
%returns the negative of M;
IF M=0 THEN M ELSE MOD!*-M;
SYMBOLIC PROCEDURE CDIF(M,N);
%returns the normalized difference of M and N;
(LAMBDA L; IF L<0 THEN L+MOD!* ELSE L) (M-N);
SYMBOLIC PROCEDURE CRECIP M;
%returns the normalized reciprocal of M modulo MOD!*
%provided M is non-zero mod MOD!*, and M and MOD!* are co-prime.
%If not, an error results;
CRECIP1(MOD!*,M,0,1);
SYMBOLIC PROCEDURE CRECIP1(A,B,X,Y);
%This is essentially the same as RECIPROCAL-BY-GCD in the Norman/
%Moore factorizer;
IF B=0 THEN REDERR "Invalid modular division"
ELSE IF B=1 THEN IF Y<0 THEN Y+MOD!* ELSE Y
ELSE BEGIN SCALAR W;
W := A/B; %truncated integer division;
RETURN CRECIP1(B,A-B*W,Y,X-Y*W)
END;
SYMBOLIC PROCEDURE CTIMES(M,N);
%returns the normalized product of M and N;
REMAINDER(M*N,MOD!*);
SYMBOLIC PROCEDURE SETMOD U;
%always returns value of MOD!* on entry.
%if U=0, no other action, otherwise MOD!* is set to U;
IF U=0 THEN MOD!* ELSE (LAMBDA N; <<MOD!* := U; N>>) MOD!*;
FLAG('(SETMOD),'OPFN); %to make it a symbolic operator;
SYMBOLIC PROCEDURE CMOD M;
%returns normalized M;
(LAMBDA N; IF N<0 THEN N+MOD!* ELSE N) REMAINDER(M,MOD!*);
%A more general definition;
%SYMBOLIC PROCEDURE CMOD M;
%returns normalized M;
% (LAMBDA N; %IF N<0 THEN N+MOD!* ELSE N)
% IF ATOM M THEN REMAINDER(M,MOD!*)
% ELSE BEGIN SCALAR X;
% X := DCOMBINE(M,MOD!*,'DIVIDE);
% RETURN CDR X
% END;
%*********************************************************************
% FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD QUOTIENTS
%********************************************************************;
SYMBOLIC PROCEDURE ADDSQ(U,V);
%U and V are standard quotients.
%Value is canonical sum of U and V;
IF NULL NUMR U THEN V
ELSE IF NULL NUMR V THEN U
ELSE IF DENR U=1 AND DENR V=1 THEN ADDF(NUMR U,NUMR V) ./ 1
ELSE BEGIN SCALAR X,Y,Z;
IF NULL !*EXP THEN <<U := NUMR U ./ MKPROD!* DENR U;
V := NUMR V ./ MKPROD!* DENR V>>;
IF !*LCM THEN X := GCDF!*(DENR U,DENR V)
ELSE X := GCDF(DENR U,DENR V);
Z := CANSQ1(QUOTF(DENR U,X) ./ QUOTF(DENR V,X));
Y := ADDF(MULTF(NUMR U,DENR Z),MULTF(NUMR V,NUMR Z));
IF NULL Y THEN RETURN NIL ./ 1;
Z := MULTF(DENR U,DENR Z);
IF ONEP X THEN RETURN Y ./ Z;
X := GCDF(Y,X);
RETURN IF X=1 THEN Y ./ Z
ELSE CANSQ1(QUOTF(Y,X) ./ QUOTF(Z,X))
END;
SYMBOLIC PROCEDURE MULTSQ(U,V);
%U and V are standard quotients.
%Value is canonical product of U and V;
IF NULL NUMR U OR NULL NUMR V THEN NIL ./ 1
ELSE IF DENR U=1 AND DENR V=1 THEN MULTF(NUMR U,NUMR V) ./ 1
ELSE BEGIN SCALAR X,Y;
X := GCDF(NUMR U,DENR V);
Y := GCDF(NUMR V,DENR U);
RETURN CANSQ1(MULTF(QUOTF(NUMR U,X),QUOTF(NUMR V,Y))
./ MULTF(QUOTF(DENR U,Y),QUOTF(DENR V,X)))
END;
SYMBOLIC PROCEDURE NEGSQ U;
NEGF NUMR U ./ DENR U;
SMACRO PROCEDURE MULTPQ(U,V);
MULTSQ(!*P2Q U,V);
SYMBOLIC PROCEDURE CANCEL U;
%returns canonical form of non-canonical standard form U;
IF !*MCD OR DENR U=1 THEN CANONSQ MULTSQ(NUMR U ./ 1,1 ./ DENR U)
ELSE MULTSQ(NUMR U ./ 1,SIMPEXPT LIST(MK!*SQ(DENR U ./ 1),-1));
%*********************************************************************
% FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD FORMS
%********************************************************************;
SYMBOLIC SMACRO PROCEDURE PEQ(U,V);
%tests for equality of powers U and V;
U = V;
SYMBOLIC PROCEDURE ADDF(U,V);
%U and V are standard forms. Value is standard form for U+V;
IF NULL U THEN V
ELSE IF NULL V THEN U
ELSE IF DOMAINP U THEN ADDD(U,V)
ELSE IF DOMAINP V THEN ADDD(V,U)
ELSE IF PEQ(LPOW U,LPOW V)
THEN (LAMBDA (X,Y); IF NULL X THEN Y ELSE LPOW U .* X .+ Y)
(ADDF(LC U,LC V),ADDF(RED U,RED V))
ELSE IF ORDPP(LPOW U,LPOW V) THEN LT U .+ ADDF(RED U,V)
ELSE LT V .+ ADDF(U,RED V);
SYMBOLIC PROCEDURE ADDD(U,V);
%U is a domain element, V a standard form.
%Value is a standard form for U+V;
IF NULL V THEN U
ELSE IF DOMAINP V THEN ADDDM(U,V)
ELSE LT V .+ ADDD(U,RED V);
SYMBOLIC PROCEDURE ADDDM(U,V);
%U and V are both domain elements.
%Value is standard form for U+V;
IF ATOM U AND ATOM V THEN !*N2F PLUS2(U,V)
ELSE BEGIN SCALAR X;
RETURN IF !:ZEROP(X := DCOMBINE(U,V,'PLUS)) THEN NIL ELSE X
END;
SYMBOLIC PROCEDURE DOMAINP U;
ATOM U OR ATOM CAR U;
SYMBOLIC PROCEDURE NONCOMP U;
NOT ATOM U AND FLAGP!*!*(CAR U,'NONCOM);
SYMBOLIC PROCEDURE MULTF(U,V);
%U and V are standard forms.
%Value is standard form for U*V;
BEGIN SCALAR X,Y;
A: IF NULL U OR NULL V THEN RETURN NIL
ELSE IF ONEP U THEN RETURN V
ELSE IF ONEP V THEN RETURN U
ELSE IF DOMAINP U THEN RETURN MULTD(U,V)
ELSE IF DOMAINP V THEN RETURN MULTD(V,U)
ELSE IF NOT(!*EXP OR NCMP!* OR WTL!* OR X)
THEN <<U := MKPROD U; V := MKPROD V; X := T; GO TO A>>;
X := MVAR U;
Y := MVAR V;
IF NONCOMP X AND NONCOMP Y THEN RETURN MULTFNC(U,V)
ELSE IF X EQ Y
THEN <<X := MKSPM(X,LDEG U+LDEG V);
Y := ADDF(MULTF(!*T2F LT U,RED V),MULTF(RED U,V));
RETURN IF NULL X OR NULL(U := MULTF(LC U,LC V)) THEN Y
ELSE IF NULL !*MCD
THEN ADDF(IF X=1 THEN U ELSE !*T2F(X .* U),Y)
ELSE X .* U .+ Y>>
ELSE IF ORDOP(X,Y)
THEN <<X := MULTF(LC U,V);
Y := MULTF(RED U,V);
RETURN IF NULL X THEN Y ELSE LPOW U .* X .+ Y>>;
X := MULTF(U,LC V);
Y := MULTF(U,RED V);
RETURN IF NULL X THEN Y ELSE LPOW V .* X .+ Y
END;
SYMBOLIC PROCEDURE MULTFNC(U,V);
%returns canonical product of U and V, with both main vars non-
%commutative;
BEGIN SCALAR X,Y;
X := MULTF(LC U,!*T2F LT V);
RETURN ADDF((IF NOT DOMAINP X AND MVAR X EQ MVAR U
THEN ADDF(!*T2F(MKSPM(MVAR U,LDEG U+LDEG V)
.* LC X),
MULTF(!*P2F LPOW U,RED X))
ELSE !*T2F(LPOW U .* X)),
ADDF(MULTF(RED U,V),MULTF(!*T2F LT U,RED V)))
END;
SYMBOLIC PROCEDURE MULTD(U,V);
%U is a domain element, V a standard form.
%Value is standard form for U*V;
IF NULL V THEN NIL
ELSE IF DOMAINP V THEN MULTDM(U,V)
ELSE LPOW V .* MULTD(U,LC V) .+ MULTD(U,RED V);
SYMBOLIC PROCEDURE MULTDM(U,V);
%U and V are both domain elements. Value is standard form for U*V;
IF ATOM U AND ATOM V THEN TIMES2(U,V)
ELSE BEGIN SCALAR X;
RETURN IF !:ONEP(X := DCOMBINE(U,V,'TIMES)) THEN 1 ELSE X
END;
SMACRO PROCEDURE MULTPF(U,V);
MULTF(!*P2F U,V);
GLOBAL '(!*FACTOR); %used to call a factorizing routine if it exists;
SYMBOLIC PROCEDURE MKPROD U;
BEGIN SCALAR W,X,Y,Z,!*EXP;
IF NULL U OR KERNLP U THEN RETURN U;
%first make sure there are no further simplifications;
IF DENR(X := SUBS2(U ./ 1)) = 1 AND NUMR X NEQ U
THEN <<U := NUMR X; IF NULL U OR KERNLP U THEN RETURN U>>;
!*EXP := T;
W := CKRN U;
U := QUOTF(U,W);
X := EXPND U;
IF NULL X OR KERNLP X THEN RETURN MULTF(W,X);
%after this point, U is not KERNLP;
IF !*FACTOR OR !*GCD THEN Y := FCTRF X
ELSE <<Y := CKRN X;
X := QUOTF(X,Y);
Y := LIST(Y,X . 1)>>;
IF CDADR Y>1 OR CDDR Y
THEN <<Z := CAR Y;
FOR EACH J IN CDR Y DO
Z := MULTF(MKSP!*(CAR J,CDR J),Z)>>
ELSE IF NOT !*GROUP AND TMSF U>TMSF CAADR Y
THEN Z := MULTF(MKSP!*(CAADR Y,CDADR Y),CAR Y)
ELSE Z := MKSP!*(U,1);
RETURN MULTF(W,Z)
END;
SYMBOLIC PROCEDURE MKSP!*(U,N);
%Returns a standard form for U**N, in which U is first made
%positive and then converted into a kernel;
BEGIN SCALAR B;
IF MINUSF U THEN <<B := T; U := NEGF U>>;
U := !*P2F MKSP(U,N);
RETURN IF B AND NOT ZEROP REMAINDER(N,2) THEN NEGF U ELSE U
END;
SYMBOLIC PROCEDURE TMSF U;
%U is a standard form.
%Value is number of terms in U (including kernel structure);
BEGIN INTEGER N; SCALAR X;
N := 0;
A: IF NULL U THEN RETURN N ELSE IF DOMAINP U THEN RETURN N+1;
N := N+(IF SFP(X := MVAR U) THEN TMSF X ELSE 1)+TMSF!* LC U;
IF LDEG U NEQ 1 THEN N := N+2;
U := RED U;
IF U THEN N := N+1;
GO TO A
END;
SYMBOLIC PROCEDURE TMSF!* U;
IF NUMBERP U AND ABS FIX U=1 THEN 0 ELSE TMSF U+1;
SYMBOLIC PROCEDURE TMS U;
TMSF NUMR SIMP!* U;
FLAG('(TMS),'OPFN);
FLAG('(TMS),'NOVAL);
SYMBOLIC PROCEDURE EXPND U;
IF DOMAINP U THEN U
ELSE ADDF(IF NOT SFP MVAR U OR LDEG U<0
THEN MULTPF(LPOW U,EXPND LC U)
ELSE MULTF(EXPTF(EXPND MVAR U,LDEG U),EXPND LC U),
EXPND RED U);
SYMBOLIC PROCEDURE MKPROD!* U;
IF DOMAINP U THEN U ELSE MKPROD U;
SYMBOLIC PROCEDURE CANPROD(P,Q);
%P and Q are kernel product standard forms, value is P/Q;
BEGIN SCALAR V,W,X,Y,Z;
IF DOMAINP Q THEN RETURN CANCEL(P ./ Q);
WHILE NOT DOMAINP P OR NOT DOMAINP Q DO
IF SFPF P THEN
<<Z := CPROD1(MVAR P,LDEG P,V,W);
V := CAR Z; W := CDR Z; P := LC P>>
ELSE IF SFPF Q THEN <<Z := CPROD1(MVAR Q,LDEG Q,W,V);
W := CAR Z; V := CDR Z; Q := LC Q>>
ELSE IF DOMAINP P THEN <<Y := LPOW Q . Y; Q := LC Q>>
ELSE IF DOMAINP Q THEN <<X := LPOW P . X; P := LC P>>
ELSE <<X := LPOW P . X; Y := LPOW Q . Y;
P := LC P; Q := LC Q>>;
V := REPROD(V,REPROD(X,P));
W := REPROD(W,REPROD(Y,Q));
IF MINUSF W THEN <<V := NEGF V; W := NEGF W>>;
W := CANCEL(V ./ W);
V := NUMR W;
IF NOT DOMAINP V AND NULL RED V AND ONEP LC V
AND LDEG V=1 AND SFP(X := MVAR V)
THEN V := X;
RETURN CANSQ1(V ./ DENR W)
END;
SYMBOLIC PROCEDURE SFPF U;
NOT DOMAINP U AND SFP MVAR U;
SYMBOLIC PROCEDURE SFP U;
%determines if mvar U is a standard form;
NOT ATOM U AND NOT ATOM CAR U;
SYMBOLIC PROCEDURE REPROD(U,V);
%U is a list of powers,V a standard form;
%value is product of terms in U with V;
<<WHILE U DO <<V := MULTPF(CAR U,V); U := CDR U>>; V>>;
SYMBOLIC PROCEDURE CPROD1(P,M,V,W);
%U is a standard form, which occurs in a kernel raised to power M.
%V is a list of powers multiplying P**M, W a list dividing it.
%Value is a dotted pair of lists of powers after all possible kernels
%have been cancelled;
BEGIN SCALAR Z;
Z := CPROD2(P,M,W,NIL);
W := CADR Z;
V := APPEND(CDDR Z,V);
Z := CPROD2(CAR Z,M,V,T);
V := CADR Z;
W := APPEND(CDDR Z,W);
IF CAR Z NEQ 1 THEN V := MKSP(CAR Z,M) . V;
RETURN V . W
END;
SYMBOLIC PROCEDURE CPROD2(P,M,U,B);
%P and M are as in CPROD1. U is a list of powers. B is true if P**M
%multiplies U, false if it divides.
%Value has three parts: the first is the part of P which does not
%have any common factors with U, the second a list of powers (plus
%U) which multiply U, and the third a list of powers which divide U;
%it is implicit here that the kernel standard forms are positive;
BEGIN SCALAR N,V,W,Y,Z;
WHILE U AND P NEQ 1 DO
<<IF (Z := GCDF(P,CAAR U)) NEQ 1
THEN
<<P := QUOTF(P,Z);
Y := QUOTF(CAAR U,Z);
IF Y NEQ 1 THEN V := MKSP(Y,CDAR U) . V;
IF B THEN V := MKSP(Z,M+CDAR U) . V
ELSE IF (N := M-CDAR U)>0 THEN W := MKSP(Z,N) . W
ELSE IF N<0 THEN V := MKSP(Z,-N) . V>>
ELSE V := CAR U . V;
U := CDR U>>;
RETURN (P . NCONC(U,V) . W)
END;
SYMBOLIC PROCEDURE MKSPM(U,P);
%U is a unique kernel, P an integer;
%value is 1 if P=0 and not the weight variable K!*,
%NIL if U**P is 0 or standard power of U**P otherwise;
IF P=0 AND NOT(U EQ 'K!*) THEN 1
ELSE BEGIN SCALAR X;
IF SUBFG!* AND (X:= ATSOC(U,ASYMPLIS!*)) AND CDR X<=P
THEN RETURN NIL;
SUB2CHK U;
RETURN U TO P
END;
SYMBOLIC PROCEDURE SUB2CHK U;
%determines if kernel U is such that a power substitution i
%necessary;
IF SUBFG!* AND(ATSOC(U,POWLIS!*)
OR NOT ATOM U AND CAR U MEMQ '(EXPT SQRT)
AND ASSOC(CADR U,POWLIS!*))
THEN !*SUB2 := T;
SYMBOLIC PROCEDURE NEGF U;
MULTD(-1,U);
%*********************************************************************
% FUNCTIONS FOR DIVIDING STANDARD FORMS
%********************************************************************;
SYMBOLIC PROCEDURE QUOTSQ(U,V);
MULTSQ(U,INVSQ V);
SYMBOLIC PROCEDURE QUOTF!*(U,V);
IF NULL U THEN NIL
ELSE (LAMBDA X; IF NULL X THEN ERRACH LIST("DIVISION FAILED",U,V)
ELSE X)
QUOTF(U,V);
SYMBOLIC PROCEDURE QUOTF(U,V);
BEGIN SCALAR XEXP;
XEXP := !*EXP;
!*EXP := T;
U := QUOTF1(U,V);
!*EXP := XEXP;
RETURN U
END;
SYMBOLIC PROCEDURE QUOTF1(P,Q);
%P and Q are standard forms
%Value is the quotient of P and Q if it exists or NIL;
IF NULL P THEN NIL
ELSE IF P=Q THEN 1
ELSE IF Q=1 THEN P
ELSE IF DOMAINP Q THEN QUOTFD(P,Q)
ELSE IF DOMAINP P THEN NIL
ELSE IF MVAR P EQ MVAR Q
THEN BEGIN SCALAR U,V,W,X,Y,Z,Z1; INTEGER N;
A:IF IDP(U := RANK P) OR IDP(V := RANK Q) OR U<V THEN RETURN NIL;
%the above IDP test is because of the possibility of a free
%variable in the degree position from LET statements;
U := LT!* P;
V := LT!* Q;
W := MVAR Q;
X := QUOTF1(TC U,TC V);
IF NULL X THEN RETURN NIL;
N := TDEG U-TDEG V;
IF N NEQ 0 THEN Y := W TO N;
P := ADDF(P,MULTF(IF N=0 THEN Q
ELSE MULTPF(Y,Q),NEGF X));
%leading terms of P and Q do not cancel if MCD is off;
%however, there may be a problem with off exp;
IF P AND (DOMAINP P OR MVAR P NEQ W) THEN RETURN NIL
ELSE IF N=0 THEN GO TO B;
Z := ACONC(Z,Y .* X);
%provided we have a non-zero power of X, terms
%come out in right order;
IF NULL P THEN RETURN IF Z1 THEN NCONC(Z,Z1) ELSE Z;
GO TO A;
B: IF NULL P THEN RETURN NCONC(Z,X)
ELSE IF !*MCD THEN RETURN NIL
ELSE Z1 := X;
GO TO A
END
ELSE IF ORDOP(MVAR P,MVAR Q) THEN QUOTK(P,Q)
ELSE NIL;
SYMBOLIC PROCEDURE QUOTFD(P,Q);
%P is a standard form, Q a domain element;
%Value is P/Q if division is exact or NIL otherwise;
IF FIELDP Q THEN MULTD(!:RECIP Q,P)
ELSE IF DOMAINP P THEN QUOTDD(P,Q)
ELSE QUOTK(P,Q);
SYMBOLIC PROCEDURE QUOTDD(U,V);
%U and V are domain elements, value is U/V if division is exact,
%NIL otherwise;
IF ATOM U THEN IF ATOM V
THEN IF REMAINDER(U,V)=0 THEN U/V ELSE NIL
ELSE QUOTDD(APPLY(GET(CAR V,'I2D),LIST U),V)
ELSE IF ATOM V THEN QUOTDD(U,APPLY(GET(CAR U,'I2D),LIST V))
ELSE DCOMBINE(U,V,'QUOTIENT);
SYMBOLIC PROCEDURE QUOTK(P,Q);
(LAMBDA W;
IF W THEN IF NULL RED P THEN LIST (LPOW P .* W)
ELSE (LAMBDA Y;IF Y THEN LPOW P .* W .+ Y ELSE NIL)
QUOTF1(RED P,Q)
ELSE NIL)
QUOTF1(LC P,Q);
SYMBOLIC PROCEDURE RANK P;
%P is a standard form
%Value is the rank of P;
IF !*MCD THEN LDEG P
ELSE BEGIN INTEGER M,N; SCALAR Y;
N := LDEG P;
Y := MVAR P;
A: M := LDEG P;
IF NULL RED P THEN RETURN N-M;
P := RED P;
IF DEGR(P,Y)=0 THEN RETURN IF M<0 THEN IF N<0 THEN -M
ELSE N-M ELSE N;
GO TO A
END;
SYMBOLIC PROCEDURE LT!* P;
%Returns true leading term of polynomial P;
IF !*MCD OR LDEG P>0 THEN CAR P
ELSE BEGIN SCALAR X,Y;
X := LT P;
Y := MVAR P;
A: P := RED P;
IF NULL P THEN RETURN X
ELSE IF DEGR(P,Y)=0 THEN RETURN (Y . 0) .* P;
GO TO A
END;
SYMBOLIC PROCEDURE REMF(U,V);
%returns the remainder of U divided by V;
CDR QREMF(U,V);
PUT('REMAINDER,'POLYFN,'REMF);
SYMBOLIC PROCEDURE QREMF(U,V);
%returns the quotient and remainder of U divided by V;
BEGIN INTEGER N; SCALAR X,Y,Z;
IF DOMAINP V THEN RETURN QREMD(U,V);
Z := LIST NIL; %final value;
A: IF DOMAINP U THEN RETURN PRADDF(Z,NIL . U)
ELSE IF MVAR U EQ MVAR V
THEN IF (N := LDEG U-LDEG V)<0 THEN RETURN PRADDF(Z,NIL . U)
ELSE <<X := QREMF(LC U,LC V);
Y := MULTPF(LPOW U,CDR X);
Z := PRADDF(Z,(IF N=0 THEN CAR X
ELSE MULTPF(MVAR U TO N,CAR X))
. Y);
U := IF NULL CAR X THEN RED U
ELSE ADDF(ADDF(U,MULTF(IF N=0 THEN V
ELSE MULTPF(MVAR U TO N,V),
NEGF CAR X)), NEGF Y);
GO TO A>>
ELSE IF NOT ORDOP(MVAR U,MVAR V)
THEN RETURN PRADDF(Z,NIL . U);
X := QREMF(LC U,V);
Z := PRADDF(Z,MULTPF(LPOW U,CAR X) . MULTPF(LPOW U,CDR X));
U := RED U;
GO TO A
END;
SYMBOLIC PROCEDURE PRADDF(U,V);
%U and V are dotted pairs of standard forms;
ADDF(CAR U,CAR V) . ADDF(CDR U,CDR V);
SYMBOLIC PROCEDURE QREMD(U,V);
%Returns a dotted pair of quotient and remainder of form U
%divided by domain element V;
IF NULL U THEN U . U
ELSE IF V=1 THEN LIST U
ELSE IF NOT ATOM V AND FLAGP(CAR V,'FIELD)
THEN LIST MULTDM(!:RECIP V,U)
ELSE IF DOMAINP U THEN QREMDD(U,V)
ELSE BEGIN SCALAR X;
X := QREMF(LC U,V);
RETURN PRADDF(MULTPF(LPOW U,CAR X) . MULTPF(LPOW U,CDR X),
QREMD(RED U,V))
END;
SYMBOLIC PROCEDURE QREMDD(U,V);
%returns a dotted pair of quotient and remainder of non-invertable
%domain element U divided by non-invertable domain element V;
IF ATOM U AND ATOM V THEN DIVIDEF(U,V) ELSE DCOMBINE(U,V,'DIVIDE);
SYMBOLIC PROCEDURE DIVIDEF(M,N);
(LAMBDA X; (IF CAR X=0 THEN NIL ELSE CAR X).
IF CDR X=0 THEN NIL ELSE CDR X)
DIVIDE(M,N);
SYMBOLIC PROCEDURE LQREMF(U,V);
%returns a list of coeffs of powers of V in U, constant term first;
BEGIN SCALAR X,Y;
Y := LIST U;
WHILE CAR(X := QREMF(CAR Y,V)) DO Y := CAR X . CDR X . CDR Y;
RETURN REVERSIP Y
END;
%*********************************************************************
% GREATEST COMMON DIVISOR ROUTINES
%********************************************************************;
SYMBOLIC PROCEDURE GCDN(P,Q);
%P and Q are integers. Value is absolute value of gcd of P and Q;
IF Q = 0 THEN ABS P ELSE GCDN(Q,REMAINDER(P,Q));
SYMBOLIC PROCEDURE COMFAC P;
%P is a non-atomic standard form
%CAR of result is lowest common power of leading kernel in
%every term in P (or NIL). CDR is gcd of all coefficients of
%powers of leading kernel;
BEGIN SCALAR X,Y;
IF NULL RED P THEN RETURN LT P;
X := LC P;
Y := MVAR P; %leading kernel;
A: P := RED P;
IF DEGR(P,Y)=0 THEN RETURN NIL . GCDF1(X,P)
ELSE IF NULL RED P THEN RETURN LPOW P . GCDF1(X,LC P)
ELSE X := GCDF1(LC P,X);
GO TO A
END;
SYMBOLIC PROCEDURE DEGR(U,VAR);
IF DOMAINP U OR NOT MVAR U EQ VAR THEN 0 ELSE LDEG U;
PUT('GCD,'POLYFN,'GCDF!*);
SYMBOLIC PROCEDURE GCDF!*(U,V);
BEGIN SCALAR !*GCD; !*GCD := T; RETURN GCDF(U,V) END;
SYMBOLIC PROCEDURE GCDF(U,V);
%U and V are standard forms.
%Value is the gcd of U and V, complete only if *GCD is true;
BEGIN SCALAR !*EXP,Y,Z;
!*EXP := T;
IF NULL U THEN RETURN ABSF V
ELSE IF NULL V THEN RETURN ABSF U
ELSE IF U=1 OR V=1 THEN RETURN 1
ELSE IF !*GCD AND !*EZGCD THEN RETURN EZGCDF(U,V);
IF QUOTF1(U,V) THEN Z := V
ELSE IF QUOTF1(V,U) THEN Z := U
ELSE <<IF !*GCD THEN <<Y := SETKORDER KERNORD(U,V);
U := REORDER U; V := REORDER V>>;
Z := GCDF1(U,V);
IF !*GCD
THEN <<IF U AND V
AND (NULL QUOTF1(U,Z) OR NULL QUOTF1(V,Z))
THEN ERRACH LIST("GCDF FAILED",PREPSQ U,PREPSQ V);
%this probably implies that integer overflow occurred;
SETKORDER Y;
Z := REORDER Z>>>>;
RETURN ABSF Z
END;
SYMBOLIC PROCEDURE GCDF1(U,V);
IF NULL U THEN V
ELSE IF NULL V THEN U
ELSE IF ONEP U OR ONEP V THEN 1
ELSE IF DOMAINP U THEN GCDFD(U,V)
ELSE IF DOMAINP V THEN GCDFD(V,U)
ELSE IF QUOTF1(U,V) THEN V
ELSE IF QUOTF1(V,U) THEN U
ELSE IF MVAR U EQ MVAR V
THEN BEGIN SCALAR X,Y,Z;
X := COMFAC U;
Y := COMFAC V;
Z := GCDF1(CDR X,CDR Y);
IF !*GCD
THEN Z := MULTF(GCDK(QUOTF1(U,COMFAC!-TO!-POLY X),
QUOTF1(V,COMFAC!-TO!-POLY Y)),
Z);
IF CAR X AND CAR Y
THEN IF PDEG CAR X>PDEG CAR Y
THEN Z := MULTPF(CAR Y,Z)
ELSE Z := MULTPF(CAR X,Z);
RETURN Z
END
ELSE IF ORDOP(MVAR U,MVAR V) THEN GCDF1(CDR COMFAC U,V)
ELSE GCDF1(CDR COMFAC V,U);
SYMBOLIC PROCEDURE GCDFD(U,V);
%U is a domain element, V a form;
%Value is gcd of U and V;
IF NOT ATOM U AND FLAGP(CAR U,'FIELD) THEN 1 ELSE GCDFD1(U,V);
SYMBOLIC PROCEDURE GCDFD1(U,V);
IF NULL V THEN U
ELSE IF DOMAINP V THEN GCDDD(U,V)
ELSE GCDFD1(GCDFD1(U,LC V),RED V);
SYMBOLIC PROCEDURE GCDDD(U,V);
%U and V are domain elements. If they are invertable, value is 1
%otherwise the gcd of U and V as a domain element;
IF U=1 OR V=1 THEN 1
ELSE IF ATOM U THEN IF NOT FIELDP V THEN GCDDD1(U,V) ELSE 1
ELSE IF ATOM V
THEN IF NOT FLAGP(CAR U,'FIELD) THEN GCDDD1(U,V) ELSE 1
ELSE IF FLAGP(CAR U,'FIELD) OR FLAGP(CAR V,'FIELD) THEN 1
ELSE GCDDD1(U,V);
SYMBOLIC PROCEDURE GCDDD1(U,V);
%U and V are non-invertable domain elements. Value is gcd of U and V;
IF ATOM U AND ATOM V THEN GCDN(U,V) ELSE DCOMBINE(U,V,'GCD);
SYMBOLIC PROCEDURE GCDK(U,V);
%U and V are primitive polynomials in the main variable VAR;
%result is gcd of U and V;
BEGIN SCALAR LCLST,VAR,W,X;
IF U=V THEN RETURN U
ELSE IF DOMAINP U OR DEGR(V,(VAR := MVAR U))=0 THEN RETURN 1
ELSE IF LDEG U<LDEG V THEN <<W := U; U := V; V := W>>;
IF QUOTF1(U,V) THEN RETURN V ELSE IF LDEG V=1 THEN RETURN 1;
A: W := REMK(U,V);
IF NULL W THEN RETURN V
ELSE IF DEGR(W,VAR)=0 THEN RETURN 1;
LCLST := ADDLC(V,LCLST);
IF X := QUOTF1(W,LC W) THEN W := X
ELSE FOR EACH Y IN LCLST DO WHILE (X := QUOTF1(W,Y)) DO W := X;
U := V; V := PP W;
IF DEGR(V,VAR)=0 THEN RETURN 1 ELSE GO TO A
END;
SYMBOLIC PROCEDURE ADDLC(U,V);
IF U=1 THEN V
ELSE (LAMBDA X;
IF X=1 OR X=-1 OR NOT ATOM X AND FLAGP(CAR X,'FIELD) THEN V
ELSE X . V)
LC U;
SYMBOLIC PROCEDURE DELALL(U,V);
IF NULL V THEN NIL
ELSE IF U EQ CAAR V THEN DELALL(U,CDR V)
ELSE CAR V . DELALL(U,CDR V);
SYMBOLIC PROCEDURE KERNORD(U,V);
BEGIN SCALAR X,Y,Z;
X := APPEND(POWERS(U,NIL),POWERS(V,NIL));
WHILE X DO
<<Y := MAXDEG(CDR X,CAR X);
X := DELALL(CAR Y,X);
Z := CAR Y . Z>>;
RETURN Z
END;
SYMBOLIC PROCEDURE MAXDEG(U,V);
IF NULL U THEN V
ELSE IF CDAR U>CDR V THEN MAXDEG(CDR U,CAR U)
ELSE MAXDEG(CDR U,V);
SYMBOLIC PROCEDURE POWERS(FORM,POWLST);
IF NULL FORM OR DOMAINP FORM THEN POWLST
ELSE BEGIN SCALAR X;
IF (X := ATSOC(MVAR FORM,POWLST))
THEN LDEG FORM>CDR X AND RPLACD(X,LDEG FORM)
ELSE POWLST := (MVAR FORM . LDEG FORM) . POWLST;
RETURN POWERS(RED FORM,POWERS(LC FORM,POWLST))
END;
SYMBOLIC PROCEDURE LCM(U,V);
%U and V are standard forms. Value is lcm of U and V;
IF NULL U OR NULL V THEN NIL
ELSE IF ONEP U THEN V
ELSE IF ONEP V THEN U
ELSE MULTF(U,QUOTF(V,GCDF(U,V)));
SYMBOLIC PROCEDURE REMK(U,V);
%modified pseudo-remainder algorithm
%U and V are polynomials, value is modified prem of U and V;
BEGIN SCALAR F1,VAR,X; INTEGER K,N;
F1 := LC V;
VAR := MVAR V;
N := LDEG V;
WHILE (K := DEGR(U,VAR)-N)>=0 DO
<<X := NEGF MULTF(LC U,RED V);
IF K>0 THEN X := MULTPF(VAR TO K,X);
U := ADDF(MULTF(F1,RED U),X)>>;
RETURN U
END;
SYMBOLIC PROCEDURE PP U;
%returns the primitive part of the polynomial U wrt leading var;
QUOTF1(U,COMFAC!-TO!-POLY COMFAC U);
SYMBOLIC PROCEDURE COMFAC!-TO!-POLY U;
IF NULL CAR U THEN CDR U ELSE LIST U;
SYMBOLIC PROCEDURE LNC U;
%U is a standard form.
%Value is the leading numerical coefficient;
IF NULL U THEN 0
ELSE IF DOMAINP U THEN U
ELSE LNC LC U;
COMMENT In this sub-section, we consider the manipulation of factored
forms. These have the structure
<monomial> . <form-power-list>
where the monomial is itself a standard form (satisfying the
KERNLP test) and a form-power is a dotted pair whose car is a
standard form and cdr an integer>0. We have thus represented the
form as a product of a monomial and powers of non-monomial
factors;
SYMBOLIC PROCEDURE FCTRF U;
%U is a standard form. Value is a standard factored form;
%The function FACTORF is an assumed entry point to a factorization
%module which itself returns a form power list;
BEGIN SCALAR X,Y,!*GCD;
!*GCD := T;
IF DOMAINP U THEN RETURN LIST U
ELSE IF !*FACTOR THEN RETURN FACTORF U;
X := COMFAC U;
U := QUOTF(U,COMFAC!-TO!-POLY X);
Y := FCTRF CDR X;
IF CAR X THEN Y := MULTPF(CAR X,CAR Y) . CDR Y;
IF DOMAINP U THEN RETURN MULTF(U,CAR Y) . CDR Y
ELSE IF MINUSF U
THEN <<U := NEGF U; Y := NEGF CAR Y . CDR Y>>;
RETURN CAR Y . FACMERGE(SQFRF U,CDR Y)
END;
SYMBOLIC PROCEDURE FACMERGE(U,V);
%Returns the merge of the form_power_lists U and V;
APPEND(U,V);
SYMBOLIC PROCEDURE SQFRF U;
%U is a non-trivial form which is primitive in its main variable
%and has a positive leading numerical coefficient.
%SQFRF performs square free factorization on U and returns a
%form power list;
BEGIN INTEGER K,N; SCALAR V,W,X,Z,!*GCD;
N := 1;
X := MVAR U;
!*GCD := T;
A: V := GCDF(U,DIFF(U,X));
K := DEGR(V,X);
IF K>0 THEN U := QUOTF(U,V);
IF W
THEN <<IF U NEQ W
THEN Z := FACMERGE(LIST(QUOTF(W,U) . N),Z);
N := N+1>>;
IF K=0 THEN RETURN FACMERGE(LIST(U . N),Z);
W := U;
U := V;
GO TO A
END;
SYMBOLIC PROCEDURE DIFF(U,V);
%a polynomial differentation routine which does not check
%indeterminate dependences;
IF DOMAINP U THEN NIL
ELSE ADDF(ADDF(MULTPF(LPOW U,DIFF(LC U,V)),
MULTF(LC U,DIFFP1(LPOW U,V))),
DIFF(RED U,V));
SYMBOLIC PROCEDURE DIFFP1(U,V);
IF NOT CAR U EQ V THEN NIL
ELSE IF CDR U=1 THEN 1
ELSE MULTD(CDR U,!*P2F(CAR U TO (CDR U-1)));
SYMBOLIC PROCEDURE MINUSF U;
%U is a non-zero standard form.
%Value is T if U has a negative leading numerical coeff,
%NIL otherwise;
IF NULL U THEN NIL
ELSE IF DOMAINP U
THEN IF ATOM U THEN U<0 ELSE APPLY(GET(CAR U,'MINUSP),LIST U)
ELSE MINUSF LC U;
SYMBOLIC PROCEDURE ABSF U;
%U is a standard form
%value is a standard form in which the leading power has a
%positive coefficient;
IF MINUSF U THEN NEGF U ELSE U;
SYMBOLIC PROCEDURE CANONSQ U;
%U is a standard quotient
%value is a standard quotient in which the leading power
%of the denominator has a positive numerical coefficient.
%If FLOAT is true, then denom is given LNC of 1;
BEGIN
IF NULL NUMR U THEN RETURN NIL ./ 1
ELSE IF MINUSF DENR U THEN U:= NEGF NUMR U ./ NEGF DENR U;
RETURN CANSQ1 U
END;
SYMBOLIC PROCEDURE CANSQ1 U;
%Normalizes denominator of standard quotient U where possible
%returning normalized quotient;
IF DENR U=1 THEN U
ELSE IF DOMAINP DENR U AND !:ONEP DENR U THEN NUMR U ./ 1
ELSE IF NULL DMODE!* OR NULL FLAGP(DMODE!*,'FIELD) THEN U
ELSE BEGIN SCALAR X;
X := LNC DENR U;
IF !:ONEP X THEN RETURN U;
IF ATOM X THEN X := APPLY(GET(DMODE!*,'I2D),LIST X);
X := DCOMBINE(1,X,'QUOTIENT);
U := MULTD(X,NUMR U) ./ MULTD(X,DENR U);
RETURN IF DOMAINP DENR U AND !:ONEP DENR U THEN NUMR U ./ 1
ELSE U
END;
SYMBOLIC PROCEDURE INVSQ U;
IF NULL NUMR U THEN REDERR "Zero denominator" ELSE CANONSQ REVPR U;
%*********************************************************************
% FUNCTIONS FOR SUBSTITUTING IN STANDARD FORMS
%********************************************************************;
SYMBOLIC PROCEDURE SUBF(U,L);
BEGIN SCALAR X;
%domain may have changed, so next line uses simpatom;
IF DOMAINP U THEN RETURN !*D2Q U
ELSE IF NCMP!* AND NONCOMEXPF U THEN RETURN SUBF1(U,L);
X := REVERSE XN(FOR EACH Y IN L COLLECT CAR Y,
KERNORD(U,NIL));
X := SETKORDER X;
U := SUBF1(REORDER U,L);
SETKORDER X;
RETURN REORDER NUMR U ./ REORDER DENR U
END;
SYMBOLIC PROCEDURE NONCOMEXPF U;
NOT DOMAINP U
AND (NONCOMP MVAR U OR NONCOMEXPF LC U OR NONCOMEXPF RED U);
SYMBOLIC PROCEDURE SUBF1(U,L);
%U is a standard form,
%L an association list of substitutions of the form
%(<kernel> . <substitution>).
%Value is the standard quotient for substituted expression.
%Algorithm used is essentially the straight method.
%Procedure depends on explicit data structure for standard form;
IF DOMAINP U
THEN IF ATOM U THEN IF NULL DMODE!* THEN U ./ 1 ELSE SIMPATOM U
ELSE IF DMODE!* EQ CAR U THEN !*D2Q U
ELSE SIMP PREPF U
ELSE BEGIN INTEGER N; SCALAR KERN,M,W,X,XEXP,Y,Y1,Z;
Z := NIL ./ 1;
A0: KERN := MVAR U;
IF M := ASSOC(KERN,ASYMPLIS!*) THEN M := CDR M;
A: IF NULL U OR (N := DEGR(U,KERN))=0 THEN GO TO B
ELSE IF NULL M OR N<M THEN Y := LT U . Y;
U := RED U;
GO TO A;
B: IF NOT ATOM KERN AND NOT ATOM CAR KERN THEN KERN := PREPF KERN;
IF NULL L THEN XEXP := IF KERN EQ 'K!* THEN 1 ELSE KERN
ELSE IF (XEXP := SUBSUBLIS(L,KERN)) = KERN
AND NOT ASSOC(KERN,ASYMPLIS!*)
THEN GO TO F;
C: W := 1 ./ 1;
N := 0;
IF Y AND CDAAR Y<0 THEN GO TO H;
X := SIMP!* XEXP;
IF NULL L AND KERNP X AND MVAR NUMR X EQ KERN THEN GO TO F
ELSE IF NULL NUMR X THEN GO TO E; %Substitution of 0;
FOR EACH J IN Y DO
<<M := CDAR J;
W := MULTSQ(EXPTSQ(X,M-N),W);
N := M;
Z := ADDSQ(MULTSQ(W,SUBF1(CDR J,L)),Z)>>;
E: Y := NIL;
IF NULL U THEN RETURN Z
ELSE IF DOMAINP U THEN RETURN ADDSQ(!*D2Q U,Z);
GO TO A0;
F: SUB2CHK KERN;
FOR EACH J IN Y DO Z := ADDSQ(MULTPQ(CAR J,SUBF1(CDR J,L)),Z);
GO TO E;
H: %Substitution for negative powers;
X := SIMPRECIP LIST XEXP;
J: Y1 := CAR Y . Y1;
Y := CDR Y;
IF Y AND CDAAR Y<0 THEN GO TO J;
K: M := -CDAAR Y1;
W := MULTSQ(EXPTSQ(X,M-N),W);
N := M;
Z := ADDSQ(MULTSQ(W,SUBF1(CDAR Y1,L)),Z);
Y1 := CDR Y1;
IF Y1 THEN GO TO K ELSE IF Y THEN GO TO C ELSE GO TO E
END;
SYMBOLIC PROCEDURE SUBSUBLIS(U,V);
BEGIN SCALAR X;
RETURN IF X := ASSOC(V,U) THEN CDR X
ELSE IF ATOM V THEN V
ELSE IF NOT IDP CAR V
THEN FOR EACH J IN V COLLECT SUBSUBLIS(U,J)
ELSE IF FLAGP(CAR V,'SUBFN) THEN SUBSUBF(U,V)
ELSE IF GET(CAR V,'DNAME) THEN V
ELSE FOR EACH J IN V COLLECT SUBSUBLIS(U,J)
END;
SYMBOLIC PROCEDURE SUBSUBF(L,EXPN);
%Sets up a formal SUB expression when necessary;
BEGIN SCALAR X,Y;
FOR EACH J IN CDDR EXPN DO
IF (X := ASSOC(J,L)) THEN <<Y := X . Y; L := DELETE(X,L)>>;
EXPN := SUBLIS(L,CAR EXPN)
. FOR EACH J IN CDR EXPN COLLECT SUBSUBLIS(L,J);
%to ensure only opr and individual args are transformed;
IF NULL Y THEN RETURN EXPN;
EXPN := ACONC(FOR EACH J IN REVERSIP Y
COLLECT LIST('EQUAL,CAR J,CDR J),EXPN);
RETURN MK!*SQ IF L THEN SIMPSUB EXPN
ELSE !*P2Q MKSP('SUB . EXPN,1)
END;
FLAG('(INT DF),'SUBFN);
SYMBOLIC PROCEDURE KERNP U;
DENR U=1 AND NOT DOMAINP(U := NUMR U)
AND NULL RED U AND ONEP LC U AND LDEG U=1;
%*********************************************************************
% FUNCTIONS FOR RAISING CANONICAL FORMS TO A POWER
%********************************************************************;
SYMBOLIC PROCEDURE EXPTSQ(U,N);
BEGIN SCALAR X;
IF N=1 THEN RETURN U
ELSE IF N=0
THEN RETURN IF NULL NUMR U THEN REDERR " 0**0 formed"
ELSE 1 ./ 1
ELSE IF NULL NUMR U THEN RETURN U
ELSE IF N<0 THEN RETURN SIMPEXPT LIST(MK!*SQ U,N)
ELSE IF NULL !*EXP
THEN RETURN MKSFPF(NUMR U,N) ./ MKSFPF(DENR U,N)
ELSE IF KERNP U THEN RETURN MKSQ(MVAR NUMR U,N)
ELSE IF DOMAINP NUMR U
THEN RETURN MULTSQ(!:EXPT(NUMR U,N) ./ 1,
1 ./ EXPTF(DENR U,N))
ELSE IF DENR U=1 THEN RETURN EXPTF(NUMR U,N) ./ 1;
X := U;
WHILE (N := N-1)>0 DO X := MULTSQ(U,X);
RETURN X
END;
SYMBOLIC PROCEDURE EXPTF(U,N);
IF DOMAINP U THEN !:EXPT(U,N)
ELSE IF !*EXP OR KERNLP U THEN EXPTF1(U,N)
ELSE MKSFPF(U,N);
SYMBOLIC PROCEDURE EXPTF1(U,N);
%iterative multiplication seems to be faster than a binary sub-
%division algorithm, probably because multiplying a small polynomial
%by a large one is cheaper than multiplying two medium sized ones;
BEGIN SCALAR X;
X: = U;
WHILE (N := N-1)>0 DO X := MULTF(U,X);
RETURN X
END;
%*********************************************************************
% FUNCTIONS FOR MAKING STANDARD POWERS
%********************************************************************;
SYMBOLIC SMACRO PROCEDURE GETPOWER(U,N);
%U is a list (<kernel> . <properties>), N a positive integer.
%Value is the standard power of U**N;
CAR U . N;
% BEGIN SCALAR V;
% V := CADR U;
% IF NULL V THEN RETURN CAAR RPLACA(CDR U,LIST (CAR U . N));
% A: IF N=CDAR V THEN RETURN CAR V
% ELSE IF N<CDAR V
% THEN RETURN CAR RPLACW(V,(CAAR V . N) . (CAR V . CDR V))
% ELSE IF NULL CDR V
% THEN RETURN CADR RPLACD(V,LIST (CAAR V . N));
% V := CDR V;
% GO TO A
% END;
SYMBOLIC PROCEDURE MKSP(U,P);
%U is a (non-unique) kernel and P a non-zero integer
%Value is the standard power for U**P;
GETPOWER(FKERN U,P);
SYMBOLIC PROCEDURE U TO P;
%U is a (unique) kernel and P a non-zero integer;
%Value is the standard power of U**P;
U . P;
% GETPOWER(FKERN U,P);
SYMBOLIC PROCEDURE FKERN U;
%finds the unique "p-list" reference to the kernel U. The choice of
%the search and merge used here has a strong influence on some
%timings. The ordered list used here is also used by Prepsq* to
%order factors in printed output, so cannot be unilaterally changed;
BEGIN SCALAR X,Y;
IF ATOM U THEN RETURN LIST(U,NIL);
Y := IF ATOM CAR U THEN GET(CAR U,'KLIST) ELSE EXLIST!*;
IF NOT (X := ASSOC(U,Y))
THEN <<X := LIST(U,NIL);
Y := ORDAD(X,Y);
IF ATOM CAR U
THEN <<KPROPS!* := UNION(LIST CAR U,KPROPS!*);
PUT(CAR U,'KLIST,Y)>>
ELSE EXLIST!* := Y>>;
RETURN X
END;
SYMBOLIC PROCEDURE MKSFPF(U,N);
%raises form U to power N with EXP off. Returns a form;
% IF DOMAINP U THEN !:EXPT(U,N)
% ELSE IF N>=0 AND KERNLP U
% THEN IF NULL RED U AND ONEP LC U THEN !*P2F MKSP(MVAR U,LDEG U*N)
% ELSE EXPTF1(U,N)
% ELSE IF N=1 OR NULL SUBFG!* THEN MKSP!*(U,N)
% ELSE (LAMBDA X; %IF X AND CDR X<=N THEN NIL ELSE MKSP!*(U,N))
% ASSOC(U,ASYMPLIS!*);
EXPTF(MKPROD!* U,N);
SYMBOLIC PROCEDURE MKSQ(U,N);
%U is a kernel, N a non-zero integer;
%Value is a standard quotient of U**N, after making any
%possible substitutions for U;
BEGIN SCALAR X,Y,Z;
IF NULL SUBFG!* THEN GO TO A1
ELSE IF (Y := ASSOC(U,WTL!*))
AND NULL CAR(Y := MKSQ('K!*,N*CDR Y)) THEN RETURN Y
ELSE IF NOT ATOM U THEN GO TO B
ELSE IF NULL !*NOSUBS AND (Z:= GET(U,'AVALUE)) THEN GO TO D;
FLAG(LIST U,'USED!*); %tell system U used as algebraic var;
A: IF !*NOSUBS OR N=1 THEN GO TO A1
ELSE IF (Z:= ASSOC(U,ASYMPLIS!*)) AND CDR Z<=N
THEN RETURN NIL ./ 1
ELSE IF ((Z:= ASSOC(U,POWLIS!*))
OR NOT ATOM U AND CAR U MEMQ '(EXPT SQRT)
AND (Z := ASSOC(CADR U,POWLIS!*)))
AND NOT(N*CADR Z)<0
%implements explicit sign matching;
THEN !*SUB2 := T;
A1: IF NULL X THEN X := FKERN U;
X := !*P2F GETPOWER(X,N) ./ 1;
RETURN IF Y THEN MULTSQ(Y,X) ELSE X;
B: IF NULL !*NOSUBS AND ATOM CAR U
AND (Z:= ASSOC(U,GET(CAR U,'KVALUE)))
THEN GO TO C
ELSE IF NOT('USED!* MEMQ CDDR (X := FKERN U))
THEN ACONC(X,'USED!*);
GO TO A;
C: Z := CDR Z;
D: %optimization is possible as shown if all expression
%dependency is known;
%IF CDR Z THEN RETURN EXPTSQ(CDR Z,N); %value already computed;
IF NULL !*RESUBS THEN !*NOSUBS := T;
X := SIMPCAR Z;
!*NOSUBS := NIL;
%RPLACD(Z,X); %save simplified value;
%SUBL!* := Z . SUBL!*;
RETURN EXPTSQ(X,N)
END;
%*********************************************************************
% FUNCTIONS FOR INTERNAL ORDERING OF EXPRESSIONS
%********************************************************************;
SYMBOLIC PROCEDURE ORDAD(A,U);
IF NULL U THEN LIST A
ELSE IF ORDP(A,CAR U) THEN A . U
ELSE CAR U . ORDAD(A,CDR U);
SYMBOLIC PROCEDURE ORDN U;
IF NULL U THEN NIL
ELSE IF NULL CDR U THEN U
ELSE IF NULL CDDR U THEN ORD2(CAR U,CADR U)
ELSE ORDAD(CAR U,ORDN CDR U);
SYMBOLIC PROCEDURE ORD2(U,V);
IF ORDP(U,V) THEN LIST(U,V) ELSE LIST(V,U);
SYMBOLIC PROCEDURE ORDP(U,V);
%returns TRUE if U ordered ahead or equal to V, NIL otherwise.
%an expression with more structure at a given level is ordered
%ahead of one with less;
IF NULL U THEN NULL V
ELSE IF NULL V THEN T
ELSE IF ATOM U
THEN IF ATOM V
THEN IF NUMBERP U THEN NUMBERP V AND NOT U<V
ELSE IF NUMBERP V THEN T ELSE ORDERP(U,V)
ELSE NIL
ELSE IF ATOM V THEN T
ELSE IF CAR U=CAR V THEN ORDP(CDR U,CDR V)
ELSE ORDP(CAR U,CAR V);
SYMBOLIC PROCEDURE ORDPP(U,V);
IF CAR U EQ CAR V THEN CDR U>CDR V
ELSE IF NCMP!* THEN NCMORDP(CAR U,CAR V)
ELSE ORDOP(CAR U,CAR V);
SYMBOLIC PROCEDURE ORDOP(U,V);
BEGIN SCALAR X;
X := KORD!*;
A: IF NULL X THEN RETURN ORDP(U,V)
ELSE IF U EQ CAR X THEN RETURN T
ELSE IF V EQ CAR X THEN RETURN;
X := CDR X;
GO TO A
END;
SYMBOLIC PROCEDURE NCMORDP(U,V);
IF NONCOMP U THEN IF NONCOMP V THEN ORDOP(U,V) ELSE T
ELSE IF NONCOMP V THEN NIL
ELSE ORDOP(U,V);
%*********************************************************************
% FUNCTIONS FOR REORDERING STANDARD FORMS
%*********************************************************************;
SYMBOLIC PROCEDURE REORDER U;
%reorders a standard form so that current kernel order is used;
IF DOMAINP U THEN U
ELSE RADDF(RMULTPF(LPOW U,REORDER LC U),REORDER RED U);
SYMBOLIC PROCEDURE RADDF(U,V);
%adds reordered forms U and V;
IF NULL U THEN V
ELSE IF NULL V THEN U
ELSE IF DOMAINP U THEN ADDD(U,V)
ELSE IF DOMAINP V THEN ADDD(V,U)
ELSE IF PEQ(LPOW U,LPOW V)
THEN (LPOW U .* RADDF(LC U,LC V)) .+ RADDF(RED U,RED V)
ELSE IF ORDPP(LPOW U,LPOW V) THEN LT U . RADDF(RED U,V)
ELSE LT V . RADDF(U,RED V);
SYMBOLIC PROCEDURE RMULTPF(U,V);
%multiplies power U by reordered form V;
IF NULL V THEN NIL
ELSE IF DOMAINP V OR ORDOP(CAR U,MVAR V) THEN !*T2F(U .* V)
ELSE (LPOW V .* RMULTPF(U,LC V)) .+ RMULTPF(U,RED V);
SYMBOLIC PROCEDURE KORDER U;
<<KORD!* := IF U = '(NIL) THEN NIL
ELSE FOR EACH X IN U COLLECT !*A2K X;
RMSUBS()>>;
RLISTAT '(KORDER);
SYMBOLIC PROCEDURE SETKORDER U;
BEGIN SCALAR V; V := KORD!*; KORD!* := U; RETURN V END;
%*********************************************************************
% FUNCTIONS WHICH APPLY BASIC PATTERN MATCHING RULES
%********************************************************************;
SYMBOLIC PROCEDURE EMTCH U;
IF ATOM U THEN U ELSE (LAMBDA X; IF X THEN X ELSE U) OPMTCH U;
SYMBOLIC PROCEDURE OPMTCH U;
BEGIN SCALAR X,Y,Z;
X := GET(CAR U,'OPMTCH);
IF NULL X THEN RETURN NIL
ELSE IF NULL SUBFG!* THEN RETURN NIL; %NULL(!*SUB2 := T);
Z := FOR EACH J IN CDR U COLLECT EMTCH J;
A: IF NULL X THEN RETURN;
Y := MCHARG(Z,CAAR X,CAR U);
B: IF NULL Y THEN GO TO C
ELSE IF EVAL SUBLA(CAR Y,CDADAR X)
THEN RETURN SUBLA(CAR Y,CADDAR X);
Y := CDR Y;
GO TO B;
C: X := CDR X;
GO TO A
END;
SYMBOLIC PROCEDURE MCHARG(U,V,W);
%procedure to determine if an argument list matches given template;
%U is argument list of operator W;
%V is argument list template being matched against;
%if there is no match, value is NIL,
%otherwise a list of lists of free variable pairings;
IF NULL U AND NULL V THEN LIST NIL
ELSE BEGIN INTEGER M,N;
M := LENGTH U;
N := LENGTH V;
IF FLAGP(W,'NARY) AND M>2
THEN IF M<6 AND FLAGP(W,'SYMMETRIC)
THEN RETURN MCHCOMB(U,V,W)
ELSE IF N=2 THEN <<U := CDR MKBIN(W,U); M := 2>>
ELSE RETURN NIL; %we cannot handle this case;
RETURN IF M NEQ N THEN NIL
ELSE IF FLAGP(W,'SYMMETRIC) THEN MCHSARG(U,V)
ELSE IF MTP V THEN LIST PAIR(V,U)
ELSE MCHARG2(U,V,LIST NIL)
END;
SYMBOLIC PROCEDURE MCHCOMB(U,V,OP);
BEGIN INTEGER N;
N := LENGTH U - LENGTH V +1;
IF N<1 THEN RETURN NIL
ELSE IF N=1 THEN RETURN MCHSARG(U,V)
ELSE IF NOT SMEMQLP(FRLIS!*,V) THEN RETURN NIL;
RETURN FOR EACH X IN COMB(U,N) CONC
MCHSARG((OP . X) . SETDIFF(U,X),V)
END;
SYMBOLIC PROCEDURE COMB(U,N);
%value is list of all combinations of N elements from the list U;
BEGIN SCALAR V; INTEGER M;
IF N=0 THEN RETURN LIST NIL
ELSE IF (M:=LENGTH U-N)<0 THEN RETURN;
A: IF M=0 THEN RETURN U . V;
V := NCONC(V,MAPCONS(COMB(CDR U,N-1),CAR U));
U := CDR U;
M := M-1;
GO TO A
END;
SYMBOLIC PROCEDURE MCHARG2(U,V,W);
%matches compatible list U against template V;
BEGIN SCALAR Y;
IF NULL U THEN RETURN W;
Y := MCHK(CAR U,CAR V);
U := CDR U;
V := CDR V;
RETURN FOR EACH J IN Y
CONC MCHARG2(U,UPDTEMPLATE(J,V),MAPPEND(W,J))
END;
SYMBOLIC PROCEDURE UPDTEMPLATE(U,V);
BEGIN SCALAR X,Y;
RETURN FOR EACH J IN V COLLECT
IF (X := SUBLA(U,J)) = J THEN J
ELSE IF (Y := REVAL X) NEQ X THEN Y
ELSE X
END;
SYMBOLIC PROCEDURE MCHK(U,V);
IF U=V THEN LIST NIL
ELSE IF ATOM V
THEN IF V MEMQ FRLIS!* THEN LIST LIST (V . U) ELSE NIL
ELSE IF ATOM U %special check for negative number match;
THEN IF NUMBERP U AND U<0 THEN MCHK(LIST('MINUS,-U),V)
ELSE NIL
ELSE IF CAR U EQ CAR V THEN MCHARG(CDR U,CDR V,CAR U)
ELSE NIL;
SYMBOLIC PROCEDURE MKBIN(U,V);
IF NULL CDDR V THEN U . V ELSE LIST(U,CAR V,MKBIN(U,CDR V));
SYMBOLIC PROCEDURE MTP V;
NULL V OR (CAR V MEMQ FRLIS!* AND NOT CAR V MEMBER CDR V
AND MTP CDR V);
SYMBOLIC PROCEDURE MCHSARG(U,V);
REVERSIP IF MTP V
THEN FOR EACH J IN PERMUTATIONS V COLLECT PAIR(J,U)
ELSE FOR EACH J IN PERMUTATIONS U CONC MCHARG2(J,V,LIST NIL);
SYMBOLIC PROCEDURE PERMUTATIONS U;
IF NULL U THEN LIST U
ELSE FOR EACH J IN U CONC MAPCONS(PERMUTATIONS DELETE(J,U),J);
FLAGOP ANTISYMMETRIC,SYMMETRIC;
FLAG ('(PLUS TIMES CONS),'SYMMETRIC);
%*********************************************************************
% FUNCTIONS FOR CONVERTING CANONICAL FORMS INTO PREFIX FORMS
%********************************************************************;
SYMBOLIC PROCEDURE PREPSQ U;
IF NULL NUMR U THEN 0 ELSE SQFORM(U,FUNCTION PREPF);
SYMBOLIC PROCEDURE SQFORM(U,V);
(LAMBDA (X,Y); IF Y=1 THEN X ELSE LIST('QUOTIENT,X,Y))
(APPLY(V,LIST NUMR U),APPLY(V,LIST DENR U));
SYMBOLIC PROCEDURE PREPF U;
REPLUS PREPF1(U,NIL);
SYMBOLIC PROCEDURE PREPF1(U,V);
IF NULL U THEN NIL
ELSE IF DOMAINP U
THEN LIST RETIMES((IF ATOM U
THEN IF U<0 THEN LIST('MINUS,-U) ELSE U
ELSE IF APPLY(GET(CAR U,'MINUSP),LIST U)
THEN LIST('MINUS,PREPD !:MINUS U)
ELSE PREPD U)
. EXCHK(V,NIL,NIL))
ELSE NCONC(PREPF1(LC U,IF MVAR U EQ 'K!* THEN V ELSE LPOW U .* V)
,PREPF1(RED U,V));
SYMBOLIC PROCEDURE PREPD U; APPLY(GET(CAR U,'PREPFN),LIST U);
SYMBOLIC PROCEDURE EXCHK(U,V,W);
IF NULL U
THEN IF NULL W THEN V
ELSE EXCHK(U,LIST('EXPT,CAAR W,PREPSQX CDAR W) . V,CDR W)
ELSE IF EQCAR(CAAR U,'EXPT)
THEN EXCHK(CDR U,V,
BEGIN SCALAR X,Y;
X := ASSOC(CADAAR U,W);
Y := SIMP LIST('TIMES,CDAR U,CADDAR CAR U);
IF X THEN RPLACD(X,ADDSQ(Y,CDR X))
ELSE W := (CADAAR U . Y) . W;
RETURN W
END)
ELSE IF CDAR U=1 THEN EXCHK(CDR U, SQCHK CAAR U . V,W)
ELSE EXCHK(CDR U,LIST('EXPT,SQCHK CAAR U,CDAR U) . V,W);
SYMBOLIC PROCEDURE REPLUS U;
IF ATOM U THEN U ELSE IF NULL CDR U THEN CAR U ELSE 'PLUS . U;
SYMBOLIC PROCEDURE RETIMES U;
BEGIN SCALAR X,Y;
A: IF NULL U THEN GO TO D
ELSE IF ONEP CAR U THEN GO TO C
ELSE IF NOT EQCAR(CAR U,'MINUS) THEN GO TO B;
X := NOT X;
IF ONEP CADAR U THEN GO TO C
ELSE U := CADAR U . CDR U;
B: Y := CAR U . Y;
C: U := CDR U;
GO TO A;
D: Y := IF NULL Y THEN 1
ELSE IF CDR Y THEN 'TIMES . REVERSE Y ELSE CAR Y;
RETURN IF X THEN LIST('MINUS,Y) ELSE Y
END;
SYMBOLIC PROCEDURE SQCHK U;
IF ATOM U THEN U
ELSE IF CAR U EQ '!*SQ THEN PREPSQ CADR U
ELSE IF CAR U EQ 'EXPT AND CADDR U=1 THEN CADR U
ELSE IF ATOM CAR U THEN U ELSE PREPF U;
%*********************************************************************
% BASIC OUTPUT PACKAGE FOR CANONICAL FORMS
%********************************************************************;
%Global variables referenced in this section;
GLOBAL '(VARNAM!* ORIG!* YCOORD!* YMIN!* SPARE!*);
SPARE!* := 5; %RIGHT MARGIN, TO AVOID TROUBLE WITH PREMATURE
%LINE-BREAKS INSERTED BY LISP;
VARNAM!* := 'ANS;
ORIG!*:=0;
POSN!* := 0;
YCOORD!* := 0;
YMIN!* := 0;
DEFLIST ('((!*SQ !*SQPRINT)),'SPECPRN);
SYMBOLIC PROCEDURE !*SQPRINT U; SQPRINT CAR U;
SYMBOLIC PROCEDURE SQPRINT U;
%mathprints the standard quotient U;
BEGIN SCALAR Z;
Z := ORIG!*;
IF !*NAT AND POSN!*<20 THEN ORIG!* := POSN!*;
IF !*PRI OR WTL!* THEN GO TO C
ELSE IF CDR U NEQ 1 THEN GO TO B
ELSE XPRINF(CAR U,NIL,NIL);
A: RETURN (ORIG!* := Z);
B: PRIN2!* "(";
XPRINF(CAR U,NIL,NIL);
PRIN2!* ") / (";;
XPRINF(CDR U,NIL,NIL);
PRIN2!* ")";
GO TO A;
C: MAPRIN(!*OUTP := U := PREPSQ!* U);
GO TO A
END;
SYMBOLIC PROCEDURE VARPRI(U,V,W);
BEGIN SCALAR X,Y;
%U is expression being printed
%V is a list of expressions assigned to U
%W is a flag which is true if expr is last in current set;
IF NULL U THEN U := 0; %allow for unset array elements;
IF !*NERO AND U=0 THEN RETURN;
IF W MEMQ '(FIRST ONLY) THEN TERPRI!* T;
X := TYPL!*;
A: IF NULL X THEN GO TO B
ELSE IF APPLY(CAR X,LIST U) AND (Y:= GET(CAR X,'PRIFN))
THEN RETURN APPLY(Y,LIST(U,V,W));
X := CDR X;
GO TO A;
B: IF !*FORT THEN RETURN FVARPRI(U,V,W)
ELSE IF NULL V THEN GO TO C;
INPRINT('SETQ,GET('SETQ,'INFIX),MAPCAR(V,FUNCTION EVAL));
OPRIN 'SETQ;
C: MAPRIN U;
IF NULL W OR W EQ 'FIRST THEN RETURN NIL
ELSE IF NOT !*NAT THEN PRIN2!* "$";
TERPRI!*(NOT !*NAT);
RETURN
END;
SYMBOLIC PROCEDURE XPRINF(U,V,W);
%U is a standard form.
%V is a flag which is true if a term has preceded current form.
%W is a flag which is true if form is part of a standard term;
%Procedure prints the form and returns NIL;
BEGIN
A: IF NULL U THEN RETURN NIL
ELSE IF DOMAINP U THEN RETURN XPRID(U,V,W);
XPRINT(LT U,V);
U := RED U;
V := T;
GO TO A
END;
SYMBOLIC PROCEDURE XPRID(U,V,W);
%U is a domain element.
%V is a flag which is true if a term has preceded element.
%W is a flag which is true if U is part of a standard term.
%Procedure prints element and returns NIL;
BEGIN
IF MINUSF U THEN <<OPRIN 'MINUS; U := !:MINUS U>>
ELSE IF V THEN OPRIN 'PLUS;
IF NOT W OR U NEQ 1
THEN IF ATOM U THEN PRIN2!* U ELSE MAPRIN U
END;
SYMBOLIC PROCEDURE XPRINT(U,V);
%U is a standard term.
%V is a flag which is true if a term has preceded this term.
%Procedure prints the term and returns NIL;
BEGIN SCALAR FLG,W;
FLG := NOT ATOM TC U AND RED TC U;
IF NOT FLG THEN GO TO A ELSE IF V THEN OPRIN 'PLUS;
PRIN2!* "(";
A: XPRINF(TC U,IF FLG THEN NIL ELSE V,NOT FLG);
IF FLG THEN PRIN2!* ")";
IF NOT ATOM TC U OR NOT ABS FIX TC U=1 THEN OPRIN 'TIMES;
W := TPOW U;
IF ATOM CAR W THEN PRIN2!* CAR W
ELSE IF NOT ATOM CAAR W OR CAAR W EQ '!*SQ THEN GO TO C
ELSE IF CAAR W EQ 'PLUS THEN MAPRINT(CAR W,100)
ELSE MAPRIN CAR W;
B: IF CDR W=1 THEN RETURN;
OPRIN 'EXPT;
PRIN2!* CDR W;
IF NOT !*NAT THEN RETURN;
YCOORD!* := YCOORD!*-1;
IF YMIN!*>YCOORD!* THEN YMIN!* := YCOORD!*;
RETURN;
C: PRIN2!* "(";
IF NOT ATOM CAAR W THEN XPRINF(CAR W,NIL,NIL)
ELSE SQPRINT CADAR W;
PRIN2!* ")";
GO TO B
END;
%*********************************************************************
% FUNCTIONS FOR PRINTING PREFIX EXPRESSIONS
%********************************************************************;
%Global variables referenced in this sub-section;
GLOBAL '(OBRKP!* PLINE!* !*FORT !*LIST !*NAT YMAX!*);
OBRKP!* := T;
PLINE!* := NIL;
!*FORT:=NIL;
!*LIST := NIL;
!*NAT := NAT!*!* := T;
YMAX!* := 0;
INITL!* := APPEND('(ORIG!* PLINE!*),INITL!*);
PUT('ORIG!*,'INITL,0);
FLAG('(LINELENGTH),'OPFN); %to make it a symbolic operator;
SYMBOLIC PROCEDURE MATHPRINT L;
BEGIN TERPRI!* T; MAPRIN L; TERPRI!* T END;
SYMBOLIC PROCEDURE MAPRIN U;
MAPRINT(U,0);
SYMBOLIC PROCEDURE MAPRINT(L,P);
BEGIN SCALAR X,Y;
IF NULL L THEN RETURN NIL
ELSE IF ATOM L THEN GO TO B
ELSE IF STRINGP L THEN RETURN PRIN2!* L
ELSE IF NOT ATOM CAR L THEN MAPRINT(CAR L,P)
ELSE IF X := GET(CAR L,'SPECPRN)
THEN RETURN APPLY(X,LIST CDR L)
ELSE IF X := GET(CAR L,'INFIX) THEN GO TO A
ELSE PRIN2!* CAR L;
PRIN2!* "(";
OBRKP!* := NIL;
IF CDR L THEN INPRINT('!*COMMA!*,0,CDR L);
OBRKP!* := T;
E: RETURN PRIN2!* ")";
B: IF NUMBERP L THEN GO TO D;
C: RETURN PRIN2!* L;
D: IF NOT L<0 THEN GO TO C;
PRIN2!* "(";
PRIN2!* L;
GO TO E;
A: P := NOT X>P;
IF NOT P THEN GO TO G;
Y := ORIG!*;
PRIN2!* "(";
ORIG!* := IF POSN!*<18 THEN POSN!* ELSE ORIG!*+3;
G: INPRINT(CAR L,X,CDR L);
IF NOT P THEN RETURN;
PRIN2!* ")";
ORIG!* := Y
END;
SYMBOLIC PROCEDURE INPRINT(OP,P,L);
BEGIN
IF GET(OP,'ALT) THEN GO TO A
ELSE IF OP EQ 'EXPT AND !*NAT
AND FLATSIZEC CAR L+FLATSIZEC CADR L>
(LINELENGTH NIL-SPARE!*)-POSN!*
THEN TERPRI!* T; %to avoid breaking exponent over line;
MAPRINT(CAR L,P);
A0: L := CDR L;
A: IF NULL L THEN RETURN NIL
ELSE IF NOT ATOM CAR L AND OP EQ GET!*(CAAR L,'ALT)
THEN GO TO B;
OPRIN OP;
B: MAPRINT(CAR L,P);
IF NOT !*NAT OR NOT OP EQ 'EXPT THEN GO TO A0;
YCOORD!* := YCOORD!*-1;
IF YMIN!*>YCOORD!* THEN YMIN!* := YCOORD!*;
GO TO A0
END;
SYMBOLIC PROCEDURE FLATSIZEC U;
IF NULL U THEN 0
ELSE IF ATOM U THEN LENGTHC U
ELSE FLATSIZEC CAR U + FLATSIZEC CDR U;
SYMBOLIC PROCEDURE OPRIN OP;
(LAMBDA X;
IF NULL X THEN PRIN2!* OP
ELSE IF !*FORT THEN PRIN2!* CADR X
ELSE IF !*LIST AND OBRKP!* AND OP MEMQ '(PLUS MINUS)
THEN BEGIN TERPRI!* T; PRIN2!* CAR X END
ELSE IF !*NAT AND OP EQ 'EXPT
THEN BEGIN
YCOORD!* := YCOORD!*+1;
IF YCOORD!*>YMAX!* THEN YMAX!* := YCOORD!*
END
ELSE PRIN2!* CAR X)
GET(OP,'PRTCH);
SYMBOLIC PROCEDURE PRIN2!* U;
BEGIN INTEGER M,N;
IF !*FORT THEN RETURN FPRIN2 U;
N := LENGTHC U;
IF N>(LINELENGTH NIL-SPARE!*) THEN GO TO D;
M := POSN!*+N;
A: IF M>(LINELENGTH NIL-SPARE!*) THEN GO TO C
ELSE IF NOT !*NAT THEN PRIN2 U
ELSE PLINE!* := (((POSN!* . M) . YCOORD!*) . U) . PLINE!*;
B: RETURN (POSN!* := M);
C: TERPRI!* T;
IF (M := POSN!*+N)<=(LINELENGTH NIL-SPARE!*) THEN GO TO A;
D: %identifier longer than one line;
IF !*FORT THEN REDERR LIST(U,"too long for FORTRAN");
%let LISP print the atom;
TERPRI!* NIL;
PRIN2T U;
M := REMAINDER(N,(LINELENGTH NIL-SPARE!*));
GO TO B
END;
SYMBOLIC PROCEDURE TERPRI!* U;
BEGIN INTEGER N;
IF !*FORT THEN RETURN FTERPRI(U)
ELSE IF NOT PLINE!* OR NOT !*NAT THEN GO TO B;
N := YMAX!*;
PLINE!* := REVERSE PLINE!*;
A: SCPRINT(PLINE!*,N);
TERPRI();
IF N= YMIN!* THEN GO TO B;
N := N-1;
GO TO A;
B: IF U THEN TERPRI();
C: PLINE!* := NIL;
POSN!* := ORIG!*;
YCOORD!* := YMAX!* := YMIN!* := 0
END;
SYMBOLIC PROCEDURE SCPRINT(U,N);
BEGIN SCALAR M;
POSN!* := 0;
A: IF NULL U THEN RETURN NIL
ELSE IF NOT CDAAR U=N THEN GO TO B
ELSE IF NOT (M:= CAAAAR U-POSN!*)<0 THEN SPACES M;
PRIN2 CDAR U;
POSN!* := CDAAAR U;
B: U := CDR U;
GO TO A
END;
COMMENT ***** FORTRAN OUTPUT PACKAGE *****;
GLOBAL '(CARDNO!* FORTWIDTH!*);
FLAG ('(CARDNO!* FORTWIDTH!*),'SHARE);
CARDNO!*:=20;
FORTWIDTH!* := 70;
FLUID '(FBRKT); %bracket level counter;
SYMBOLIC PROCEDURE VARNAME U;
%sets the default variable assignment name;
VARNAM!* := CAR U;
RLISTAT '(VARNAME);
SYMBOLIC PROCEDURE FLENGTH(U,CHARS);
IF CHARS<0 THEN CHARS
ELSE IF ATOM U
THEN CHARS-IF NUMBERP U THEN IF FIXP U THEN FLATSIZEC U+1
ELSE FLATSIZEC U
ELSE FLATSIZEC((LAMBDA X; IF X THEN CADR X ELSE U)
GET(U,'PRTCH))
ELSE FLENGTH(CAR U,FLENLIS(CDR U,CHARS)-2);
SYMBOLIC PROCEDURE FLENLIS(U,CHARS);
IF NULL U THEN CHARS
ELSE IF CHARS<0 THEN CHARS
ELSE IF ATOM U THEN FLENGTH(U,CHARS)
ELSE FLENLIS(CDR U,FLENGTH(CAR U,CHARS));
SYMBOLIC PROCEDURE FMPRINT(L,P);
BEGIN SCALAR X;
IF NULL L THEN RETURN NIL
ELSE IF ATOM L THEN GO TO B
ELSE IF STRINGP L THEN RETURN FPRIN2 L
ELSE IF NOT ATOM CAR L THEN FMPRINT(CAR L,P)
ELSE IF X := GET(CAR L,'INFIX) THEN GO TO A
ELSE IF X := GET(CAR L,'SPECPRN)
THEN RETURN APPLY(X,LIST CDR L) ELSE FPRIN2 CAR L;
FPRIN2 "(";
FBRKT := NIL . FBRKT;
X := !*PERIOD; !*PERIOD := NIL; %turn off . inside an op exp;
IF CDR L THEN FNPRINT('!*COMMA!*,0,CDR L);
!*PERIOD := X;
E: FPRIN2 ")";
RETURN FBRKT := CDR FBRKT;
B: IF NUMBERP L THEN GO TO D;
C: RETURN FPRIN2 L;
D: IF NOT L<0 THEN GO TO C;
FPRIN2 "(";
FBRKT := NIL . FBRKT;
FPRIN2 L;
GO TO E;
A: P := NOT X>P;
IF P THEN <<FPRIN2 "("; FBRKT := NIL . FBRKT>>;
FNPRINT(CAR L,X,CDR L);
IF P THEN <<FPRIN2 ")"; FBRKT := CDR FBRKT>>
END;
SYMBOLIC PROCEDURE FNPRINT(OP,P,L);
BEGIN
IF OP EQ 'EXPT THEN RETURN FEXPPRI(P,L)
ELSE IF GET(OP,'ALT) THEN GO TO A;
FMPRINT(CAR L,P);
A0: L := CDR L;
A: IF NULL L THEN RETURN NIL
ELSE IF NOT ATOM CAR L AND OP EQ GET!*(CAAR L,'ALT)
THEN GO TO B;
FOPRIN OP;
B: FMPRINT(CAR L,P);
GO TO A0
END;
SYMBOLIC PROCEDURE FEXPPRI(P,L);
BEGIN SCALAR PPERIOD;
FMPRINT(CAR L,P);
FOPRIN 'EXPT;
PPERIOD := !*PERIOD;
IF NUMBERP CADR L THEN !*PERIOD := NIL ELSE !*PERIOD := T;
FMPRINT(CADR L,P);
!*PERIOD := PPERIOD
END;
SYMBOLIC PROCEDURE FOPRIN OP;
(LAMBDA X; IF NULL X THEN FPRIN2 OP ELSE FPRIN2 CADR X)
GET(OP,'PRTCH);
FLUID '(COUNTR EXPLIS FVAR NCHARS VAR);
SYMBOLIC PROCEDURE FVARPRI(U,V,W);
%prints an assignment in FORTRAN notation;
BEGIN INTEGER COUNTR,LLENGTH,NCHARS; SCALAR EXPLIS,FVAR,VAR;
LLENGTH := LINELENGTH NIL;
LINELENGTH FORTWIDTH!*;
IF STRINGP U
THEN RETURN <<FPRIN2 U; IF W EQ 'ONLY THEN FTERPRI(T)>>;
IF EQCAR(U,'!*SQ) THEN U := PREPSQ!* CADR U;
COUNTR := 0;
NCHARS := ((LINELENGTH NIL-SPARE!*)-12)*CARDNO!*;
%12 is to allow for indentation and end of line effects;
VAR := VARNAM!*;
FVAR := IF NULL V THEN VAR ELSE EVAL CAR V;
IF POSN!*=0 AND W THEN FORTPRI(FVAR,U)
ELSE <<FMPRINT(U,0); IF W THEN FTERPRI W>>;
%means that expression preceded by a string;
LINELENGTH LLENGTH;
END;
SYMBOLIC PROCEDURE FORTPRI(FVAR,XEXP);
BEGIN SCALAR FBRKT;
IF FLENGTH(XEXP,NCHARS)<0
THEN XEXP := CAR XEXP . FOUT(CDR XEXP,CAR XEXP);
POSN!* := 0;
FPRIN2 " ";
FMPRINT(FVAR,0);
FPRIN2 "=";
FMPRINT(XEXP,0);
FTERPRI(T)
END;
SYMBOLIC PROCEDURE FOUT(ARGS,OP);
BEGIN INTEGER NCHARSL; SCALAR DISTOP,X,Z;
NCHARSL := NCHARS;
IF OP MEMQ '(PLUS TIMES) THEN DISTOP := OP;
WHILE ARGS DO
<<X := CAR ARGS;
IF ATOM X AND (NCHARSL := FLENGTH(X,NCHARSL))
OR (NULL CDR ARGS OR DISTOP)
AND (NCHARSL := FLENGTH(X,NCHARSL))>0
THEN Z := X . Z
ELSE IF DISTOP AND FLENGTH(X,NCHARS)>0
THEN <<Z := FOUT1(DISTOP . ARGS) . Z;
ARGS := LIST NIL>>
ELSE <<Z := FOUT1 X . Z;
NCHARSL := FLENGTH(OP,NCHARSL)>>;
NCHARSL := FLENGTH(OP,NCHARSL);
ARGS := CDR ARGS>>;
RETURN REVERSIP Z
END;
SYMBOLIC PROCEDURE FOUT1 XEXP;
BEGIN SCALAR FVAR;
FVAR := GENVAR();
EXPLIS := (XEXP . FVAR) . EXPLIS;
FORTPRI(FVAR,XEXP);
RETURN FVAR
END;
SYMBOLIC PROCEDURE FPRIN2 U;
% FORTRAN output of U;
BEGIN INTEGER M,N;
N := FLATSIZEC U;
M := POSN!*+N;
IF NUMBERP U AND FIXP U AND !*PERIOD THEN M := M+1;
IF M<(LINELENGTH NIL-SPARE!*) THEN POSN!* := M
ELSE <<TERPRI(); SPACES 5; PRIN2 ". "; POSN!* := N+7>>;
PRIN2 U;
IF NUMBERP U AND FIXP U AND !*PERIOD THEN PRIN2 "."
END;
SYMBOLIC PROCEDURE FTERPRI(U);
<<IF NOT POSN!*=0 AND U THEN TERPRI();
POSN!* := 0>>;
SYMBOLIC PROCEDURE GENVAR;
INTERN COMPRESS APPEND(EXPLODE VAR,EXPLODE(COUNTR := COUNTR + 1));
UNFLUID '(EXPLIS FBRKT FVAR NCHARS);
%*********************************************************************
% FOR ALL COMMAND
%********************************************************************;
SYMBOLIC PROCEDURE FORALLSTAT;
BEGIN SCALAR ARBL,CONDS;
IF CURSYM!* MEMQ LETL!* THEN SYMERR('forall,T);
FLAG(LETL!*,'DELIM);
ARBL := REMCOMMA XREAD NIL;
IF CURSYM!* EQ 'SUCH THEN
<<IF NOT SCAN() EQ 'THAT THEN SYMERR('let,T);
CONDS := XREAD NIL>>;
REMFLAG(LETL!*,'DELIM);
RETURN IFLET1(ARBL,CONDS)
END;
SYMBOLIC PROCEDURE IFLET U; IFLET1(NIL,U);
SYMBOLIC PROCEDURE IFLET1(ARBL,CONDS);
IF NOT CURSYM!* MEMQ LETL!* THEN SYMERR('let,T)
ELSE LIST('FORALL,ARBL,CONDS,XREAD1 T);
SYMBOLIC PROCEDURE FORMARB(U,VARS,MODE);
<<ARBL!* := CAR U . ARBL!*; MKQUOTE CAR U>>;
PUT('ARB,'FORMFN,'FORMARB);
PUT('FORALL,'STAT,'FORALLSTAT);
SYMBOLIC FEXPR PROCEDURE FORALL U;
BEGIN SCALAR X,Y;
X := FOR EACH J IN CAR U COLLECT NEWVAR J;
Y := PAIR(CAR U,X);
MCOND!* := SUBLA(Y,CADR U);
FRASC!* := Y;
FRLIS!* := UNION(X,FRLIS!*);
RETURN EVAL CADDR U
END;
SYMBOLIC PROCEDURE FORMFORALL(U,VARS,MODE);
BEGIN SCALAR ARBL!*,X;
% VARS := APPEND(CAR U,VARS); %semantics are different;
IF NULL CADR U THEN X := T ELSE X := FORMBOOL(CADR U,VARS,MODE);
RETURN LIST('FORALL,UNION(ARBL!*,CAR U),
X,FORM1(CADDR U,VARS,MODE))
END;
PUT('FORALL,'FORMFN,'FORMFORALL);
SYMBOLIC PROCEDURE NEWVAR U;
IF NOT IDP U THEN TYPERR(U,"free variable")
ELSE INTERN COMPRESS APPEND(EXPLODE '!=,EXPLODE U);
%*********************************************************************
% 2.19 SUBSTITUTION COMMANDS
%********************************************************************;
SYMBOLIC PROCEDURE FORMLET1(U,VARS,MODE);
'LIST . FOR EACH X IN U COLLECT
IF EQEXPR X
THEN LIST('LIST,MKQUOTE 'EQUAL,FORM1(CADR X,VARS,MODE),
!*S2ARG(FORM1(CADDR X,VARS,MODE),VARS))
ELSE ERRPRI2(X,T);
SYMBOLIC PROCEDURE !*S2ARG(U,VARS);
%makes all NOCHANGE operators into their listed form;
IF ATOM U THEN U
ELSE IF NOT IDP CAR U OR NOT FLAGP(CAR U,'NOCHANGE)
THEN FOR EACH J IN U COLLECT !*S2ARG(J,VARS)
ELSE MKARG(U,VARS);
PUT('LET,'FORMFN,'FORMLET);
PUT('CLEAR,'FORMFN,'FORMCLEAR);
PUT('MATCH,'FORMFN,'FORMMATCH);
SYMBOLIC PROCEDURE FORMCLEAR(U,VARS,MODE);
LIST('CLEAR,FORMCLEAR1(U,VARS,MODE));
SYMBOLIC PROCEDURE FORMCLEAR1(U,VARS,MODE);
'LIST . FOR EACH X IN U COLLECT FORM1(X,VARS,MODE);
SYMBOLIC PROCEDURE FORMLET(U,VARS,MODE);
LIST('LET,FORMLET1(U,VARS,MODE));
SYMBOLIC PROCEDURE FORMMATCH(U,VARS,MODE);
LIST('MATCH,FORMLET1(U,VARS,MODE));
SYMBOLIC PROCEDURE LET U;
LET0(U,NIL);
SYMBOLIC PROCEDURE LET0(U,V);
BEGIN
FOR EACH X IN U DO LET2(CADR X,CADDR X,V,T);
MCOND!* := FRASC!* := NIL
END;
SYMBOLIC PROCEDURE LET2(U,V,W,B);
BEGIN SCALAR FLG,X,Y,Z;
%FLG is set true if free variables are found in following;
X := SUBLA(FRASC!*,U);
IF X NEQ U
THEN IF ATOM X THEN GO TO LER1 %an atom cannot be free;
ELSE <<FLG := T; U := X>>;
X := SUBLA(FRASC!*,V);
IF X NEQ V
THEN <<V := X;
IF EQCAR(V,'!*SQ!*) THEN V := PREPSQ!* CADR V>>;
%to ensure no kernels or powers are copied during
%pattern matching process;
%check for unmatched free variables;
X := SMEMQL(FRLIS!*,MCOND!*);
Y := SMEMQL(FRLIS!*,U);
IF (Z := SETDIFF(X,Y))
OR (Z := SETDIFF(SETDIFF(SMEMQL(FRLIS!*,V),X),
SETDIFF(Y,X)))
THEN <<LPRIE ("Unmatched free variable(s)" . Z);
ERFG!* := 'HOLD;
RETURN NIL>>
ELSE IF EQCAR(U,'GETEL) THEN U := EVAL CADR U;
A: X := U;
IF NUMBERP X THEN GO TO LER1
ELSE IF IDP X AND FLAGP(X,'RESERVED)
THEN REDERR LIST(X,"is a reserved identifier");
Y := TYPL!*;
B: IF NULL Y THEN GO TO C
ELSE IF (Z := APPLY(CAR Y,LIST X)) OR APPLY(CAR Y,LIST V)
THEN RETURN APPLY(GET(CAR Y,'LETFN),
LIST(X,V,GET(CAR Y,'NAME),B,Z));
Y := CDR Y;
GO TO B;
C: IF NOT ATOM X THEN GO TO NONATOM;
IF B OR W THEN GO TO D;
%We remove all conceivable properties when an atom is cleared;
REMPROP(X,'AVALUE);
REMPROP(X,'OPMTCH);
% REMPROP(X,'KLIST); %since the relevant objects may still
%exist;
REMPROP(X,'MATRIX);
IF ARRAYP X
THEN <<REMPROP(X,'ARRAY); REMPROP(X,'DIMENSION)>>;
WTL!* := DELASC(X,WTL!*);
RMSUBS(); %since all kernel lists are gone;
RETURN;
D: X := SIMP0 X;
IF NOT DENR X=1 OR DOMAINP (X := NUMR X) THEN GO TO LER1;
D1: IF W OR FLG OR DOMAINP X OR RED X OR LC X NEQ 1 OR LDEG X NEQ 1
OR EXPTP!*
THEN GO TO PRODCT;
Y := MVAR X;
IF ATOM Y THEN IF FLAGP(Y,'USED!*) THEN RMSUBS() ELSE NIL
ELSE IF 'USED!* MEMQ CDDR FKERN Y THEN RMSUBS();
SETK1(Y,V,B);
RETURN;
NONATOM: %replacement for non-atomic expression;
IF NOT IDP CAR X THEN GO TO LER2
ELSE IF ARRAYP CAR X THEN GO TO ARR
ELSE IF CAR X EQ 'DF THEN GO TO DIFF
ELSE IF (Y := GET(CAR X,'MATRIX)) THEN RETURN LETMTR(U,V,Y)
ELSE IF NOT GET(CAR X,'SIMPFN) THEN GO TO LER3
ELSE GO TO D;
PRODCT: %replacement of powers and products;
IF EXPTP!* THEN W:= T;
%to allow for normal form for exponent expressions;
EXPTP!* := NIL;
RMSUBS();
IF NULL FLG AND RED X
THEN RETURN SPLIS!* := XADD(LIST(X,W . T,V,NIL),
SPLIS!*,U,B);
Y := KERNLP X;
IF Y=-1
THEN BEGIN X:= NEGF X; V:= LIST('MINUS,V) END
ELSE IF Y NEQ 1 THEN GO TO LER1;
X := KLISTT X;
Y := LIST(W . (IF MCOND!* THEN MCOND!* ELSE T),V,NIL);
IF CDR X
THEN RETURN (!*MATCH := XADD!*(X . Y,!*MATCH,U,B))
ELSE IF NULL W AND ONEP CDAR X THEN GO TO P1;
IF V=0 AND NULL W AND NOT FLG
THEN <<ASYMPLIS!* := XADD(CAR X,ASYMPLIS!*,U,B);
POWLIS!* := XADD(CAAR X . CDAR X . Y,POWLIS!*,U,NIL)>>
ELSE IF W OR NOT CDAR Y EQ T OR FRASC!*
THEN POWLIS1!* := XADD(CAR X . Y,POWLIS1!*,U,B)
ELSE IF NULL B AND (Z := ASSOC(CAAR X,ASYMPLIS!*)) AND Z=CAR X
THEN ASYMPLIS!* := DELASC(CAAR X,ASYMPLIS!*)
ELSE <<POWLIS!* := XADD(CAAR X . CDAR X . Y,POWLIS!*,U,B);
ASYMPLIS!* := DELASC(CAAR X,ASYMPLIS!*)>>;
RETURN;
P1: X := CAAR X;
IF ATOM X THEN GO TO LER1;
RETURN PUT(CAR X,
'OPMTCH,
XADD!*(CDR X . Y,GET(CAR X,'OPMTCH),U,B));
DIFF: %rules for differentiation;
IF NULL LETDF(U,V,W,X,B) THEN GO TO D ELSE RETURN;
ARR: %array replacements;
SETELV(X,V);
RETURN;
LER1:EXPTP!* := NIL;
RETURN ERRPRI1 U;
LER2:RETURN ERRPRI2(U,'HOLD);
LER3:REDMSG(CAR X,"operator");
MKOP CAR X;
GO TO A
END;
SYMBOLIC PROCEDURE SIMP0 U;
BEGIN SCALAR X;
IF EQCAR(U,'!*SQ) THEN RETURN SIMP0 PREPSQ!* CADR U;
X := SUBFG!* . !*SUB2;
SUBFG!* := NIL;
IF ATOM U OR CAR U MEMQ '(EXPT MINUS PLUS TIMES QUOTIENT)
THEN U := SIMP U
ELSE U := SIMPIDEN U;
SUBFG!* := CAR X;
!*SUB2 := CDR X;
RETURN U
END;
SYMBOLIC PROCEDURE MATCH U;
LET0(U,T);
SYMBOLIC PROCEDURE CLEAR U;
BEGIN
RMSUBS();
FOR EACH X IN U DO <<LET2(X,NIL,NIL,NIL); LET2(X,NIL,T,NIL)>>;
MCOND!* := FRASC!* := NIL
END;
SYMBOLIC PROCEDURE SETK(U,V);
<<LET2(U,V,NIL,T); V>>;
%U is a literal atom or a pseudo-kernel, V an expression
%SETK associates value V with U and returns V;
% IF ATOM U THEN SETK1(U,V,T)
% ELSE IF ARRAYP CAR U
% THEN <<SETELV(U,V); %V>>
% ELSE !*A2K REVOP1 U;
SYMBOLIC PROCEDURE SETK1(U,V,B);
BEGIN SCALAR X,Y;
IF NOT ATOM U THEN GO TO C
ELSE IF NULL B THEN GO TO B1
ELSE IF (X := GET(U,'AVALUE)) THEN GO TO A;
X := NIL . NIL;
PUT(U,'AVALUE,X);
A: RPLACD(RPLACA(X,V),NIL);
RETURN V;
B1: IF NOT GET(U,'AVALUE) THEN MSGPRI(NIL,U,"not found",NIL,NIL)
ELSE REMPROP(U,'AVALUE);
RETURN;
C: IF NOT ATOM CAR U
THEN REDERR "Invalid syntax: improper assignment"
ELSE IF NULL B THEN GO TO B2
ELSE IF NOT (Y := GET(CAR U,'KVALUE)) THEN GO TO E
ELSE IF X := ASSOC(U,Y) THEN GO TO D;
X := NIL . NIL;
ACONC(Y,U . X);
GO TO A;
D: X := CDR X;
GO TO A;
E: X := NIL . NIL;
PUT(CAR U,'KVALUE,LIST(U . X));
GO TO A;
B2: IF NOT(Y := GET(CAR U,'KVALUE)) OR NOT (X := ASSOC(U,Y))
THEN MSGPRI(NIL,U,"not found",NIL,NIL)
ELSE PUT(CAR U,'KVALUE,DELETE(X,Y));
RETURN;
END;
SYMBOLIC PROCEDURE KLISTT U;
IF ATOM U THEN NIL ELSE CAAR U . KLISTT CDR CARX(U,'LIST);
SYMBOLIC PROCEDURE KERNLP U;
IF DOMAINP U THEN U ELSE IF NULL CDR U THEN KERNLP CDAR U ELSE NIL;
SYMBOLIC PROCEDURE RMSUBS;
<<RMSUBS1(); RMSUBS2()>>;
SYMBOLIC PROCEDURE RMSUBS2;
BEGIN
RPLACA(!*SQVAR!*,NIL); !*SQVAR!* := LIST T;
% WHILE KPROPS!* DO
% <<REMPROP(CAR KPROPS!*,'KLIST); %KPROPS!* := CDR KPROPS!*>>;
% EXLIST!* := LIST '(!*);
%This is too dangerous: someone else may have constructed a
%standard form;
ALGLIST!* := NIL
END;
SYMBOLIC PROCEDURE RMSUBS1;
NIL;
% BEGIN
% A: IF NULL SUBL!* THEN GO TO B;
% RPLACD(CAR SUBL!*,NIL);
% SUBL!* := CDR SUBL!*;
% GO TO A;
% B: IF NULL DSUBL!* THEN RETURN;
% RPLACA(CAR DSUBL!*,NIL);
% DSUBL!* := CDR DSUBL!*;
% GO TO B
% END;
SYMBOLIC PROCEDURE XADD(U,V,W,B);
%adds replacement U to table V, with new rule at head;
BEGIN SCALAR X;
X := ASSOC(CAR U,V);
IF NULL X THEN GO TO C;
V := DELETE(X,V);
IF B THEN BEGIN RMSUBS1(); V := U . V END;
A: RETURN V;
C: IF B THEN V := U . V;
GO TO A
END;
SYMBOLIC PROCEDURE XADD!*(U,V,W,B);
%adds replacement U to table V, with new rule at head;
%also checks boolean part for equality;
BEGIN SCALAR X;
X := V;
WHILE X AND NOT(CAR U=CAAR X AND CADR U=CADAR X) DO X := CDR X;
IF X THEN <<V := DELETE(CAR X,V); IF B THEN RMSUBS1()>>;
IF B THEN V := U . V;
RETURN V
END;
RLISTAT '(CLEAR LET MATCH);
FLAG ('(CLEAR LET MATCH),'QUOTE);
%*********************************************************************
% VARIOUS DECLARATIONS
%********************************************************************;
PUT('OPERATOR,'FORMFN,'FORMOPR);
SYMBOLIC PROCEDURE FORMOPR(U,VARS,MODE);
IF MODE EQ 'SYMBOLIC
THEN MKPROG(NIL,LIST LIST('FLAG,MKQUOTE U,MKQUOTE 'OPFN))
ELSE LIST('OPERATOR,MKARG(U,VARS));
SYMBOLIC PROCEDURE OPERATOR U; FOR EACH J IN U DO MKOP J;
RLISTAT '(OPERATOR);
SYMBOLIC PROCEDURE DEN U;
MK!*SQ (DENR SIMP!* U ./ 1);
SYMBOLIC PROCEDURE NUM U;
MK!*SQ (NUMR SIMP!* U ./ 1);
FLAG ('(DEN NUM ABS MAX MIN),'OPFN);
FLAG('(DEN NUM),'NOVAL);
PUT('SAVEAS,'FORMFN,'FORMSAVEAS);
SYMBOLIC PROCEDURE FORMSAVEAS(U,VARS,MODE);
LIST('SAVEAS,FORMCLEAR1(U,VARS,MODE));
SYMBOLIC PROCEDURE SAVEAS U;
LET0(LIST LIST('EQUAL,CAR U,
IF FRASC!* AND EQCAR(WS,'!*SQ) THEN PREPSQ CADR WS ELSE WS),
NIL);
RLISTAT '(SAVEAS);
SYMBOLIC PROCEDURE TERMS U; TERMSF NUMR SIMP!* U;
FLAG ('(TERMS),'OPFN);
FLAG('(TERMS),'NOVAL);
SYMBOLIC PROCEDURE TERMSF U;
%U is a standard form.
%Value is number of terms in U (excluding kernel structure);
BEGIN INTEGER N;
N := 0;
A: IF NULL U THEN RETURN N ELSE IF DOMAINP U THEN RETURN N+1;
N := N + TERMSF LC U;
U := RED U;
GO TO A
END;
%*********************************************************************
%*********************************************************************
%*********************************************************************
% SECTION 3
% SPECIFIC ALGEBRAIC PACKAGES
%*********************************************************************
%*********************************************************************
%********************************************************************;
%*********************************************************************
%All these packages except where noted are self-contained and any or
%all may be omitted as required;
%********************************************************************;
%*********************************************************************
%*********************************************************************
% DIFFERENTIATION PACKAGE
%*********************************************************************
%********************************************************************;
% REQUIRES EXPRESSION DEPENDENCY MODULE;
SYMBOLIC PROCEDURE SIMPDF U;
%U is a list of forms, the first an expression and the remainder
%kernels and numbers.
%Value is derivative of first form wrt rest of list;
BEGIN SCALAR V,X,Y;
IF NULL SUBFG!* THEN RETURN MKSQ('DF . U,1);
V := CDR U;
U := SIMP!* CAR U;
A: IF NULL V OR NULL NUMR U THEN RETURN U;
X := IF NULL Y OR Y=0 THEN SIMP!* CAR V ELSE Y;
IF NULL KERNP X THEN TYPERR(PREPSQ X,"kernel");
X := CAAAAR X;
V := CDR V;
IF NULL V THEN GO TO C;
Y := SIMP!* CAR V;
IF NULL NUMR Y THEN <<V := CDR V; Y := NIL; GO TO A>>
ELSE IF NOT DENR Y=1 OR NOT NUMBERP NUMR Y THEN GO TO C;
V := CDR V;
B: FOR I:=1:CAR Y DO U := DIFFSQ(U,X);
Y := NIL;
GO TO A;
C: U := DIFFSQ(U,X);
GO TO A
END;
PUT('DF,'SIMPFN,'SIMPDF);
SYMBOLIC PROCEDURE DIFFSQ(U,V);
%U is a standard quotient, V a kernel.
%Value is the standard quotient derivative of U wrt V.
%Algorithm: df(x/y,z)= (x'-(x/y)*y')/y;
MULTSQ(ADDSQ(DIFFF(NUMR U,V),NEGSQ MULTSQ(U,DIFFF(DENR U,V))),
1 ./ DENR U);
SYMBOLIC PROCEDURE DIFFF(U,V);
%U is a standard form, V a kernel.
%Value is the standard quotient derivative of U wrt V;
IF DOMAINP U THEN NIL ./ 1
ELSE ADDSQ(ADDSQ(MULTPQ(LPOW U,DIFFF(LC U,V)),
MULTSQ(LC U ./ 1,DIFFP(LPOW U,V))),
DIFFF(RED U,V));
SYMBOLIC PROCEDURE DIFFP(U,V);
%U is a standard power, V a kernel.
%Value is the standard quotient derivative of U wrt V;
BEGIN SCALAR W,X,Y,Z; INTEGER N;
N := CDR U; %integer power;
U := CAR U; %main variable;
IF U EQ V AND (W := 1 ./ 1) THEN GO TO E
ELSE IF ATOM U THEN GO TO F
%ELSE IF (X := ASSOC(U,DSUBL!*)) AND (X := ATSOC(V,CDR X))
% AND (W := CDR X) THEN GO TO E %deriv known;
%DSUBL!* not used for now;
ELSE IF (NOT ATOM CAR U AND (W:= DIFFF(U,V)))
OR (CAR U EQ '!*SQ AND (W:= DIFFSQ(CADR U,V)))
THEN GO TO C %extended kernel found;
ELSE IF (X:= GET!*(CAR U,'DFN)) THEN NIL
ELSE IF CAR U EQ 'PLUS AND (W:=DIFFSQ(SIMP U,V))
THEN GO TO C
ELSE GO TO H; %unknown derivative;
Y := X;
Z := CDR U;
A: W := DIFFSQ(SIMP CAR Z,V) . W;
IF CAAR W AND NULL CAR Y THEN GO TO H; %unknown deriv;
Y := CDR Y;
Z := CDR Z;
IF Z AND Y THEN GO TO A
ELSE IF Z OR Y THEN GO TO H; %arguments do not match;
Y := REVERSE W;
Z := CDR U;
W := NIL ./ 1;
B: %computation of kernel derivative;
IF CAAR Y
THEN W := ADDSQ(MULTSQ(CAR Y,SIMP SUBLA(PAIR(CAAR X,Z),
CDAR X)),
W);
X := CDR X;
Y := CDR Y;
IF Y THEN GO TO B;
C: %save calculated deriv in case it is used again;
%IF X := ATSOC(U,DSUBL!*) THEN GO TO D
%ELSE X := U . NIL;
%DSUBL!* := X . DSUBL!*;
D: %RPLACD(X,XADD(V . W,CDR X,NIL,T));
E: %allowance for power;
%first check to see if kernel has weight;
IF (X := ATSOC(U,WTL!*))
THEN W := MULTPQ('K!* TO (-CDR X),W);
RETURN IF N=1 THEN W ELSE MULTSQ(!*T2Q((U TO (N-1)) .* N),W);
F: %check for possible unused substitution rule;
IF NOT DEPENDS(U,V)
AND (NOT (X:= ATSOC(U,POWLIS!*))
OR NOT CAR DIFFSQ(SIMP CADDDR X,V))
THEN RETURN NIL ./ 1;
W := MKSQ(LIST('DF,U,V),1);
GO TO E;
H: %final check for possible kernel deriv;
IF CAR U EQ 'DF
THEN IF DEPENDS(CADR U,V)
THEN W := 'DF . CADR U . DERAD(V,CDDR U)
ELSE RETURN NIL ./ 1
ELSE IF DEPENDS(U,V) THEN W := LIST('DF,U,V)
ELSE RETURN NIL ./ 1;
W := IF X := OPMTCH W THEN SIMP X ELSE MKSQ(W,1);
GO TO E
END;
SYMBOLIC PROCEDURE DERAD(U,V);
IF NULL V THEN LIST U
ELSE IF NUMBERP CAR V THEN CAR V . DERAD(U,CDR V)
ELSE IF U=CAR V THEN IF CDR V AND NUMBERP CADR V
THEN U . (CADR V + 1) . CDDR V
ELSE U . 2 . CDR V
ELSE IF ORDP(U,CAR V) THEN U . V
ELSE CAR V . DERAD(U,CDR V);
SYMBOLIC PROCEDURE LETDF(U,V,W,X,B);
BEGIN SCALAR Z;
IF ATOM CADR X THEN GO TO E
ELSE IF NOT GETTYPE CAADR X EQ 'OPERATOR THEN GO TO LER3;
A: RMSUBS();
IF NOT FRLP CDADR X
OR NULL CDDR X
OR CDDDR X
OR NOT FRLP CDDR X
OR NOT CADDR X MEMBER CDADR X
THEN GO TO E;
Z := LPOS(CADDR X,CDADR X);
IF NOT GET(CAADR X,'DFN)
THEN PUT(CAADR X,
'DFN,
NLIST(NIL,LENGTH CDADR X));
W := GET(CAADR X,'DFN);
B1: IF NULL W OR Z=0 THEN RETURN ERRPRI1 U
ELSE IF Z NEQ 1 THEN GO TO C
ELSE IF NULL B THEN GO TO D;
% ELSE IF CAR W
% THEN MSGPRI("Assignment for",X,"redefined",NIL,NIL);
RETURN RPLACA(W,CDADR X . V);
C: W := CDR W;
Z := Z-1;
GO TO B1;
D: %IF NULL CAR W THEN MSGPRI(NIL,X,"not found",NIL,NIL);
RETURN RPLACA(W,NIL);
LER3:REDMSG(CAADR X,"operator");
MKOP CAADR X;
GO TO A;
E: %check for dependency;
IF CADDR X MEMQ FRLIS!* THEN RETURN NIL
ELSE IF IDP CADR X AND NOT(CADR X MEMQ FRLIS!*)
THEN DEPEND1(CADR X,CADDR X,T)
ELSE IF NOT ATOM CADR X AND IDP CAADR X AND FRLP CDADR X
THEN DEPEND1(CAADR X,CADDR X,T);
RETURN NIL
END;
SYMBOLIC PROCEDURE FRLP U;
NULL U OR (CAR U MEMQ FRLIS!* AND FRLP CDR U);
SYMBOLIC PROCEDURE LPOS(U,V);
IF U EQ CAR V THEN 1 ELSE LPOS(U,CDR V)+1;
END;