Artifact 95a91c908ac0fbe19e9827f23ed990740e28c130d08b8072f6587f079da46c2d:
- File
r30/alg2.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 41380) [annotate] [blame] [check-ins using] [more...]
%********************************************************************* %********************************************************************* % REDUCE BASIC ALGEBRAIC PROCESSOR (PART 2) %********************************************************************* %********************************************************************; %Copyright (c) 1983 The Rand Corporation; SYMBOLIC; COMMENT The following free variables are referenced in this module; FLUID '(!*MCD); GLOBAL '(ASYMPLIS!* FRLIS!* KORD!* MCHFG!* MCOND!* POWLIS!* POWLIS1!* SPLIS!* SUBFG!* TYPL!* VARNAM!* WTL!* !*FLOAT !*FORT !*MATCH !*NAT !*PRI !*RESUBS !*SUB2); %********************************************************************* %********************************************************************* % FUNCTIONS WHICH APPLY MORE GENERAL PATTERN MATCHING RULES %********************************************************************* %********************************************************************; %********************************************************************* % FUNCTIONS FOR MATCHING POWERS %********************************************************************; COMMENT Fluid variable used in this section; FLUID '(!*STRUCTURE); !*STRUCTURE := NIL; COMMENT If STRUCTURE is ON, then expressions like (a**(b/2))**2 are not simplified, to allow some attempt at a structure theorem use, especially in the integrator; SYMBOLIC PROCEDURE SUBS2Q U; QUOTSQ(SUBS2F NUMR U,SUBS2F DENR U); SYMBOLIC PROCEDURE SUBS2F U; BEGIN SCALAR X; !*SUB2 := NIL; X := SUBS2F1 U; IF (!*SUB2 OR POWLIS1!*) AND !*RESUBS THEN IF NUMR X=U AND DENR X=1 THEN !*SUB2 := NIL ELSE X := SUBS2Q X; RETURN X; END; SYMBOLIC PROCEDURE SUBS2F1 U; IF DOMAINP U THEN !*D2Q U ELSE BEGIN SCALAR KERN,V,W,X,Y,Z; KERN := MVAR U; Z := NIL ./ 1; A: IF NULL U OR DEGR(U,KERN)=0 THEN GO TO A1; Y := LT U .+ Y; U := RED U; GO TO A; A1: X := POWLIS!*; A2: IF NULL X THEN GO TO B ELSE IF CAAAR Y = CAAR X THEN <<W := SUBS2P(CAAR Y,CADAR X,CADDDR CAR X); GO TO E1>> % ELSE IF EQCAR(KERN,'SQRT) AND CADR KERN = CAAR X % THEN <<W := RADDSQ(SUBS2P(CADR KERN . CDAAR Y, % CADAR X,CADDDR CAR X),2);% GO TO E1>>; ELSE IF EQCAR(KERN,'EXPT) AND CADR KERN = CAAR X AND EQCAR(CADDR KERN,'QUOTIENT) AND CADR CADDR KERN = 1 AND NUMBERP CADDR CADDR KERN THEN <<V := DIVIDE(CDAAR Y,CADDR CADDR KERN); IF CAR V NEQ 0 THEN W := MKSQ(CADR KERN,CAR V) ELSE W := 1 ./ 1; IF CDR V NEQ 0 THEN <<V := CANCEL(CDR V.CADDR CADDR KERN); W := MULTSQ(RADDSQ(SUBS2P(CADR KERN . CAR V, CADAR X,CADDDR CAR X), CDR V),W)>>; GO TO E1>>; X := CDR X; GO TO A2; B: X := POWLIS1!*; L2: IF NULL X THEN GO TO L3 ELSE IF W:= MTCHP(CAAR Y,CAAR X,CADDAR X,CAADAR X,CDADAR X) THEN GO TO E1; X := CDR X; GO TO L2; L3: IF EQCAR(KERN,'EXPT) AND NOT !*STRUCTURE THEN GO TO L1; Z := ADDSQ(MULTPQ(CAAR Y,SUBS2F1 CDAR Y),Z); C: Y := CDR Y; IF Y THEN GO TO A1; D: RETURN ADDSQ(Z,SUBS2F1 U); E1: Z := ADDSQ(MULTSQ(W,SUBS2F1 CDAR Y),Z); GO TO C; L1: IF ONEP CDAAR Y THEN W := MKSQ(KERN,1) ELSE W := SIMPEXPT LIST(CADR KERN, LIST('TIMES,CADDR KERN,CDAAR Y)); Z := ADDSQ(MULTSQ(W,SUBS2F1 CDAR Y),Z); Y := CDR Y; IF Y THEN GO TO L1 ELSE GO TO D; END; SYMBOLIC PROCEDURE SUBS2P(U,V,W); %U is a power, V an integer, and W an algebraic expression, such %that CAR U**V=W. Value is standard quotient for U with this %substitution; BEGIN V := DIVIDE(CDR U,V); IF CAR V=0 THEN RETURN !*P2Q U; W := EXPTSQ(SIMP W,CAR V); RETURN IF CDR V=0 THEN W ELSE MULTPQ(CAR U TO CDR V,W) END; SYMBOLIC PROCEDURE RADDSQ(U,N); %U is a standard quotient, N and integer. Value is sq for U**(1/N); SIMPEXPT LIST(MK!*SQ U,LIST('QUOTIENT,1,N)); SYMBOLIC PROCEDURE MTCHP(U,V,W,FLG,BOOL); %U is a standard power, V a power to be matched against. %W is the replacement expression. %FLG is a flag which is T if an exact power match required. %BOOL is a boolean expression to be satisfied for substitution. %Value is the substitution standard quotient if a match found, %NIL otherwise; BEGIN SCALAR X; X := MTCHP1(U,V,FLG,BOOL); A: IF NULL X THEN RETURN NIL ELSE IF EVAL SUBLA(CAR X,BOOL) THEN GO TO B; X := CDR X; GO TO A; B: V := DIVIDE(CDR U,SUBLA(CAR X,CDR V)); W := EXPTSQ(SIMP SUBLA(CAR X,W),CAR V); IF CDR V NEQ 0 THEN W := MULTPQ(CAR U TO CDR V,W); RETURN W END; SYMBOLIC PROCEDURE MTCHP1(U,V,FLG,BOOL); %U is a standard power, V a power to be matched against. %FLG is a flag which is T if an exact power match required. %BOOL is a boolean expression to be satisfied for substitution. %Value is a list of possible free variable pairings which %match conditions; BEGIN SCALAR X; IF U=V THEN RETURN LIST NIL ELSE IF NOT (X:= MCHK(CAR U,CAR V)) THEN RETURN NIL ELSE IF CDR V MEMQ FRLIS!* THEN RETURN MAPCONS(X,CDR V . CDR U) ELSE IF (FLG AND NOT CDR U=CDR V) OR (IF !*MCD THEN CDR U<CDR V ELSE (CDR U*CDR V)<0 OR %implements explicit sign matching; ABS CDR U<ABS CDR V) THEN RETURN NIL ELSE RETURN X END; %********************************************************************* % FUNCTIONS FOR MATCHING PRODUCTS %********************************************************************; SYMBOLIC PROCEDURE SUBS3Q U; %U is a standard quotient. %Value is a standard quotient with all product substitutions made; BEGIN SCALAR X; X := MCHFG!*; %save value in case we are in inner loop; MCHFG!* := NIL; U := QUOTSQ(SUBS3F NUMR U,SUBS3F DENR U); MCHFG!* := X; RETURN U END; SYMBOLIC PROCEDURE SUBS3F U; %U is a standard form. %Value is a standard quotient with all product substitutions made; SUBS3F1(U,!*MATCH,T); SYMBOLIC PROCEDURE SUBS3F1(U,L,BOOL); %U is a standard form. %L is a list of possible matches. %BOOL is a boolean variable which is true if we are at top level. %Value is a standard quotient with all product substitutions made; BEGIN SCALAR X,Z; Z := NIL ./ 1; A: IF NULL U THEN RETURN Z ELSE IF DOMAINP U THEN RETURN ADDSQ(Z,U ./ 1) ELSE IF BOOL AND DOMAINP LC U THEN GO TO C; X := SUBS3T(LT U,L); IF NOT BOOL %not top level; OR NOT MCHFG!* THEN GO TO B; %no replacement made; MCHFG!* := NIL; IF NULL !*RESUBS THEN GO TO B ELSE IF !*SUB2 OR POWLIS1!* THEN X := SUBS2Q X; %make another pass; X := SUBS3Q X; B: Z := ADDSQ(Z,X); U := CDR U; GO TO A; C: X := LIST LT U ./ 1; GO TO B END; SYMBOLIC PROCEDURE SUBS3T(U,V); %U is a standard term, V a list of matching templates. %Value is a standard quotient for the substituted term; BEGIN SCALAR X,Y,Z; X := MTCHK(CAR U,IF DOMAINP CDR U THEN SIZCHK(V,1) ELSE V); IF NULL X THEN GO TO A %lpow doesn't match; ELSE IF NULL CAAR X THEN GO TO B; %complete match found; Y := SUBS3F1(CDR U,X,NIL); %check tc for match; IF MCHFG!* THEN RETURN MULTPQ(CAR U,Y); A: RETURN LIST U . 1; %no match; B: X := CDDAR X; %list(<subst value>,<denoms>); Z := CAADR X; %leading denom; MCHFG!* := NIL; %initialize for tc check; Y := SUBS3F1(CDR U,!*MATCH,NIL); MCHFG!* := T; IF CAR Z NEQ CAAR U THEN GO TO E ELSE IF Z NEQ CAR U %powers don't match; THEN Y := MULTPQ(CAAR U TO (CDAR U-CDR Z),Y); B1: Y := MULTSQ(SIMPCAR X,Y); X := CDADR X; IF NULL X THEN RETURN Y; Z := 1; %unwind remaining denoms; C: IF NULL X THEN GO TO D; Z:=LIST(MKSP(CAAR X, %was IF ATOM CAAR X OR SFP CAAR X THEN CAAR X ELSE REVOP1 CAAR X; IF !*MCD THEN CDAR X ELSE -CDAR X) . Z); %kernel CAAR X is not unique here; X := CDR X; GO TO C; D: RETURN IF !*MCD THEN CAR Y . MULTF(Z,CDR Y) ELSE MULTF(Z,CAR Y) . CDR Y; E: IF SIMP CAR Z NEQ SIMP CAAR U THEN ERRACH LIST('SUBS3T,U,X,Z); %maybe arguments were in different order, otherwise it's fatal; IF CDR Z NEQ CDAR U THEN Y:= MULTPQ(CAAR U TO (CDAR U-CDR Z),Y); GO TO B1 END; SYMBOLIC PROCEDURE SIZCHK(U,N); IF NULL U THEN NIL ELSE IF LENGTH CAAR U>N THEN SIZCHK(CDR U,N) ELSE CAR U . SIZCHK(CDR U,N); SYMBOLIC PROCEDURE MTCHK(U,V); %U is a standard power, V a list of matching templates. %If a match is made, value is of the form: %list list(NIL,<boolean form>,<subst value>,<denoms>), %otherwise value is an updated list of templates; BEGIN SCALAR FLG,V1,W,X,Y,Z; FLG := NONCOMP CAR U; A0: IF NULL V THEN RETURN Z; V1 := CAR V; W := CAR V1; A: IF NULL W THEN GO TO D; X := MTCHP1(U,CAR W,CAADR V1,CDADR V1); B: IF NULL X THEN GO TO C ELSE IF CAR (Y := SUBLA(CAR X,DELETE(CAR W,CAR V1)) . LIST(SUBLA(CAR X,CADR V1), SUBLA(CAR X,CADDR V1), SUBLA(CAR X,CAR W) . CADDDR V1)) THEN Z := Y . Z ELSE IF EVAL SUBLA(CAR X,CDADR V1) THEN RETURN LIST Y; X := CDR X; GO TO B; C: IF FLG THEN GO TO C1; W := CDR W; GO TO A; C1: IF CADDDR V1 AND NOT NOCP CADDDR V1 THEN GO TO E; D: Z := APPEND(Z,LIST V1); E: V := CDR V; GO TO A0 END; SYMBOLIC PROCEDURE NOCP U; NULL U OR (NONCOMP CAAR U AND NOCP CDR U); %********************************************************************* % FUNCTIONS FOR MATCHING SUMS %********************************************************************; SYMBOLIC PROCEDURE SUBS4Q U; QUOTSQ(SUBS4F NUMR U,SUBS4F DENR U); SYMBOLIC PROCEDURE SUBS4F U; BEGIN SCALAR W,X,Y,Z; X := SPLIS!*; A: IF NULL X THEN RETURN U ./ 1; W := LQREMF!*(U,CAAR X); IF NULL CDR W THEN <<X := CDR X; GO TO A>>; X := SIMP CADDAR X; Y := 1 ./ 1; Z := NIL ./ 1; WHILE W DO <<IF CAR W THEN Z := ADDSQ(MULTSQ(CAR W ./ 1,Y),Z); Y := MULTSQ(X,Y); W := CDR W>>; RETURN IF DENR Z=1 AND NUMR Z=U THEN U ./ 1 ELSE SUBS4Q Z; %one could test on size here and only change if smaller; END; SYMBOLIC PROCEDURE LQREMF!*(U,V); IF DOMAINP U THEN LIST U ELSE LQREMF(U,REORDER V); %********************************************************************* %********************************************************************* % EXTENDED OUTPUT PACKAGE FOR EXPRESSIONS %********************************************************************* %********************************************************************; %Global variables used in this Section; GLOBAL '(DNL!* FACTORS!* ORDL!* UPL!* !*ALLFAC !*DIV !*RAT); DNL!* := NIL; %output control flag: puts powers in denom; FACTORS!* := NIL; %list of output factors; ORDL!* := NIL; %list of kernels introduced by ORDER statement; UPL!* := NIL; %output control flag: puts denom powers in %numerator; !*ALLFAC := T; %factoring option for this package; !*DIV := NIL; %division option in this package; !*RAT := NIL; %flag indicating rational mode for output; !*PRI := T; %to activate this package; SYMBOLIC PROCEDURE FACTOR U; FACTOR1(U,T,'FACTORS!*); SYMBOLIC PROCEDURE FACTOR1(U,V,W); BEGIN SCALAR X,Y; Y := EVAL W; FOR EACH J IN U DO <<X := !*A2K J; IF V THEN Y := ACONC(DELETE(X,Y),X) ELSE IF NOT X MEMBER Y THEN MSGPRI(NIL,J,"not found",NIL,NIL) ELSE Y := DELETE(X,Y)>>; SET(W,Y) END; SYMBOLIC PROCEDURE REMFAC U; FACTOR1(U,NIL,'FACTORS!*); RLISTAT '(FACTOR REMFAC); SYMBOLIC PROCEDURE ORDER U; IF U AND NULL CAR U AND NULL CDR U THEN (ORDL!* := NIL) ELSE FOR EACH X IN U DO <<IF (X := !*A2K X) MEMBER ORDL!* THEN ORDL!* := DELETE(X,ORDL!*); ORDL!* := ACONC(ORDL!*,X)>>; RLISTAT '(ORDER); SYMBOLIC PROCEDURE UP U; FACTOR1(U,T,'UPL!*); SYMBOLIC PROCEDURE DOWN U; FACTOR1(U,T,'DNL!*); RLISTAT '(UP DOWN); SYMBOLIC PROCEDURE FORMOP U; IF DOMAINP U THEN U ELSE RADDF(MULTOP(LPOW U,FORMOP LC U),FORMOP RED U); SYMBOLIC PROCEDURE MULTOP(U,V); IF NULL KORD!* THEN MULTPF(U,V) ELSE IF CAR U EQ 'K!* THEN V ELSE RMULTPF(U,V); SYMBOLIC SMACRO PROCEDURE LCX U; %returns leading coefficient of a form with zero reductum, or an %error otherwise; CDR CARX U; SYMBOLIC PROCEDURE QUOTOF(P,Q); %P is a standard form, Q a standard form which is either a domain %element or has zero reductum. %returns the quotient of P and Q for output purposes; IF NULL P THEN NIL ELSE IF P=Q THEN 1 ELSE IF Q=1 THEN P ELSE IF DOMAINP Q THEN QUOTOFD(P,Q) ELSE IF DOMAINP P THEN MKSP(MVAR Q,-LDEG Q) .* QUOTOF(P,LCX Q) .+ NIL ELSE (LAMBDA (X,Y); IF CAR X EQ CAR Y THEN (LAMBDA (N,W,Z); IF N=0 THEN RADDF(W,Z) ELSE ((CAR Y TO N) .* W) .+ Z) (CDR X-CDR Y,QUOTOF(LC P,LCX Q),QUOTOF(RED P,Q)) ELSE IF ORDOP(CAR X,CAR Y) THEN (X .* QUOTOF(LC P,Q)) .+ QUOTOF(RED P,Q) ELSE MKSP(CAR Y,- CDR Y) .* QUOTOF(P,LCX Q) .+ NIL) (LPOW P,LPOW Q); SYMBOLIC PROCEDURE QUOTOFD(P,Q); %P is a form, Q a domain element. Value is quotient of P and Q %for output purposes; IF NULL P THEN NIL ELSE IF DOMAINP P THEN QUOTODD(P,Q) ELSE (LPOW P .* QUOTOFD(LC P,Q)) .+ QUOTOFD(RED P,Q); SYMBOLIC PROCEDURE QUOTODD(P,Q); %P and Q are domain elements. Value is domain element for P/Q; IF ATOM P AND ATOM Q THEN MKRN(P,Q) ELSE LOWEST!-TERMS(P,Q); SYMBOLIC PROCEDURE LOWEST!-TERMS(U,V); %reduces compatible domain elements U and V to a ratio in lowest %terms. Value as a rational may contain domain arguments rather than %just integers; IF FLAGP(CAR V,'FIELD) OR FLAGP(CAR U,'FIELD) THEN MULTDM(U,!:EXPT(V,-1)) ELSE BEGIN SCALAR X; X := DCOMBINE(U,V,'GCD); U := DCOMBINE(U,X,'QUOTIENT); V := DCOMBINE(V,X,'QUOTIENT); RETURN IF !:ONEP V THEN U ELSE '!:RN!: . (U . V) END; SYMBOLIC PROCEDURE CKRN U; BEGIN SCALAR X; IF DOMAINP U THEN RETURN U; A: X := GCK2(CKRN CDAR U,X); IF NULL CDR U THEN RETURN IF NONCOMP MVAR U THEN X ELSE LIST(CAAR U . X) ELSE IF DOMAINP CDR U OR NOT CAAAR U EQ CAAADR U THEN RETURN GCK2(CKRN CDR U,X); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE GCK2(U,V); %U and V are domain elements or forms with a zero reductum. %Value is the gcd of U and V; IF NULL V THEN U ELSE IF U=V THEN U ELSE IF DOMAINP U THEN IF DOMAINP V THEN GCDDD(U,V) ELSE GCK2(U,CDARX V) ELSE IF DOMAINP V THEN GCK2(CDARX U,V) ELSE (LAMBDA (X,Y); IF CAR X EQ CAR Y THEN LIST((IF CDR X>CDR Y THEN Y ELSE X) . GCK2(CDARX U,CDARX V)) ELSE IF ORDOP(CAR X,CAR Y) THEN GCK2(CDARX U,V) ELSE GCK2(U,CDARX V)) (CAAR U,CAAR V); SYMBOLIC PROCEDURE CDARX U; CDR CARX U; SYMBOLIC PROCEDURE PREPSQ!* U; BEGIN SCALAR X; IF NULL NUMR U THEN RETURN 0; X := KORD!*; KORD!* := APPEND((FOR EACH J IN FACTORS!* CONC IF NOT IDP J THEN NIL ELSE FOR EACH K IN GET(J,'KLIST) COLLECT CAR K), APPEND(FACTORS!*,ORDL!*)); IF KORD!* NEQ X OR WTL!* THEN U := FORMOP NUMR U . FORMOP DENR U; U := IF !*RAT OR (NOT !*FLOAT AND !*DIV) OR UPL!* OR DNL!* THEN REPLUS PREPSQ!*1(NUMR U,DENR U,NIL) ELSE SQFORM(U,FUNCTION(LAMBDA J; REPLUS PREPSQ!*1(J,1,NIL))); KORD!* := X; RETURN U END; SYMBOLIC PROCEDURE PREPSQ!*0(U,V); %U is a standard quotient, but not necessarily in lowest terms. %V a list of factored powers; %Value is equivalent list of prefix expressions (an implicit sum); BEGIN SCALAR X; RETURN IF NULL NUMR U THEN NIL ELSE IF (X := GCDF(NUMR U,DENR U)) NEQ 1 THEN PREPSQ!*1(QUOTF(NUMR U,X),QUOTF(DENR U,X),V) ELSE PREPSQ!*1(NUMR U,DENR U,V) END; SYMBOLIC PROCEDURE PREPSQ!*1(U,V,W); %U and V are the numerator and denominator expression resp, %in lowest terms. %W is a list of powers to be factored from U; BEGIN SCALAR X,Y,Z; %look for "factors" in the numerator; IF NOT DOMAINP U AND (MVAR U MEMBER FACTORS!* OR (NOT ATOM MVAR U AND CAR MVAR U MEMBER FACTORS!*)) THEN RETURN NCONC(IF V=1 THEN PREPSQ!*0(LC U ./ V,LPOW U . W) ELSE (BEGIN SCALAR N,V1,Z1; %see if the same "factor" appears in denominator; N := LDEG U; V1 := V; Z1 := !*K2F MVAR U; WHILE (Z := QUOTF(V1,Z1)) DO <<V1 := Z; N := N-1>>; RETURN PREPSQ!*0(LC U ./ V1, IF N>0 THEN (MVAR U .** N) . W ELSE IF N<0 THEN MKSP(LIST('EXPT,MVAR U,N),1) . W ELSE W) END), PREPSQ!*0(RED U ./ V,W)); %now see if there are any remaining "factors" in denominator %(KORD!* contains all potential kernel factors); IF NOT DOMAINP V THEN FOR EACH J IN KORD!* DO BEGIN INTEGER N; SCALAR Z1; N := 0; Z1 := !*K2F J; WHILE Z := QUOTF(V,Z1) DO <<N := N-1; V := Z>>; IF N<0 THEN W := MKSP(LIST('EXPT,J,N),1) . W END; %now all "factors" have been removed; IF KERNLP U THEN <<U := MKKL(W,U); W := NIL>>; IF DNL!* THEN <<X := IF NULL !*ALLFAC THEN 1 ELSE CKRN U; Z := CKRN!*(X,DNL!*); X := QUOTOF(X,Z); U := QUOTOF(U,Z); V := QUOTOF(V,Z)>>; Y := CKRN V; IF UPL!* THEN <<Z := CKRN!*(Y,UPL!*); Y := QUOTOF(Y,Z); U := QUOTOF(U,Z); V := QUOTOF(V,Z)>>; IF NULL !*DIV AND NULL !*FLOAT THEN Y := 1; U := CANONSQ (U . QUOTOF(V,Y)); % IF !*GCD THEN U := CANCEL U; U := QUOTOF(NUMR U,Y) ./ DENR U; IF NULL !*ALLFAC THEN X := 1 ELSE X := CKRN NUMR U; IF !*ALLFAC AND X NEQ CAR U THEN GO TO B ELSE IF W THEN <<W := EXCHK(W,NIL,NIL); GO TO C>>; D: U := PREPSQ U; RETURN IF EQCAR(U,'PLUS) THEN CDR U ELSE LIST U; B: IF ONEP X AND NULL W THEN GO TO D ELSE IF !*FLOAT THEN X := QUOTOF(X,KERNLP X); U := QUOTOF(NUMR U,X) . DENR U; W := PREPF MKKL(W,X); IF U = (1 ./ 1) THEN RETURN W ELSE IF EQCAR(W,'TIMES) THEN W := CDR W ELSE W := LIST W; C: RETURN LIST RETIMES ACONC(W,PREPSQ U) END; SYMBOLIC PROCEDURE MKKL(U,V); IF NULL U THEN V ELSE MKKL(CDR U,LIST (CAR U . V)); SYMBOLIC PROCEDURE CKRN!*(U,V); IF NULL U THEN ERRACH 'CKRN!* ELSE IF DOMAINP U THEN 1 ELSE IF CAAAR U MEMBER V THEN LIST (CAAR U . CKRN!*(CDR CARX U,V)) ELSE CKRN!*(CDR CARX U,V); COMMENT Procedures for printing the structure of expressions; FLUID '(COUNTR VAR VARLIS); SYMBOLIC PROCEDURE STRUCTR U; BEGIN SCALAR COUNTR,FVAR,VAR,VARLIS; %VARLIS is a list of elements of form: %(<unreplaced expression> . <newvar> . <replaced exp>); COUNTR :=0; FVAR := VAR := VARNAM!*; IF CDR U THEN FVAR := CADR U; U := SIMPCAR U; U := STRUCTF NUMR U./ STRUCTF DENR U; IF NULL !*FORT THEN MATHPRINT MK!*SQ U; IF COUNTR=0 AND NULL !*FORT THEN RETURN NIL; IF NULL !*FORT THEN <<IF NULL !*NAT THEN TERPRI(); PRIN2T " WHERE">> ELSE VARLIS := REVERSIP VARLIS; FOR EACH X IN VARLIS DO <<TERPRI!* T; IF NULL !*FORT THEN PRIN2!* " "; VARPRI(CDDR X,LIST MKQUOTE CADR X,T)>>; IF !*FORT THEN VARPRI(MK!*SQ U,LIST MKQUOTE FVAR,T) END; RLISTAT '(STRUCTR); SYMBOLIC PROCEDURE STRUCTF U; IF NULL U THEN NIL ELSE IF DOMAINP U THEN U ELSE BEGIN SCALAR X,Y; X := MVAR U; IF SFP X THEN IF Y := ASSOC(X,VARLIS) THEN X := CADR Y ELSE X := STRUCTK(PREPSQ!*(STRUCTF X ./ 1),GENVAR(),X) ELSE IF NOT ATOM X AND NOT ATOMLIS CDR X THEN IF Y := ASSOC(X,VARLIS) THEN X := CADR Y ELSE X := STRUCTK(X,GENVAR(),X); RETURN X .** LDEG U .* STRUCTF LC U .+ STRUCTF RED U END; SYMBOLIC PROCEDURE STRUCTK(U,ID,V); BEGIN SCALAR X; IF X := SUBCHK1(U,VARLIS,ID) THEN RPLACD(X,(V . ID . U) . CDR X) ELSE IF X := SUBCHK2(U,VARLIS) THEN VARLIS := (V . ID . X) . VARLIS ELSE VARLIS := (V . ID . U) . VARLIS; RETURN ID END; SYMBOLIC PROCEDURE SUBCHK1(U,V,ID); BEGIN SCALAR W; WHILE V DO <<SMEMBER(U,CDDAR V) AND <<W := V; RPLACD(CDAR V,SUBST(ID,U,CDDAR V))>>; V := CDR V>>; RETURN W END; SYMBOLIC PROCEDURE SUBCHK2(U,V); BEGIN SCALAR BOOL; FOR EACH X IN V DO SMEMBER(CDDR X,U) AND <<BOOL := T; U := SUBST(CADR X,CDDR X,U)>>; IF BOOL THEN RETURN U ELSE RETURN NIL END; UNFLUID '(COUNTR VAR VARLIS); %********************************************************************* %********************************************************************* % COEFF OPERATOR PACKAGE %********************************************************************* %********************************************************************; %********************************************************************* % REQUIRES EXTENDED OUTPUT PACKAGE %********************************************************************; FLAG ('(HIPOW!* LOWPOW!*),'SHARE); GLOBAL '(HIPOW!* LOWPOW!*); SYMBOLIC PROCEDURE COEFF(U,V,W); BEGIN SCALAR X,Y,Z; V := !*A2K V; IF ATOM W THEN (IF NOT ARRAYP W THEN (IF NUMBERP(W := REVAL W) THEN TYPERR(W,'ID))) ELSE IF NOT ARRAYP CAR W THEN TYPERR(CAR W,'array) ELSE W := CAR W . FOR EACH X IN CDR W COLLECT IF X EQ 'TIMES THEN X ELSE REVAL X; U := !*Q2F SIMP!* U; X := SETKORDER LIST V; Y := REORDER U; SETKORDER X; IF NULL Y THEN GO TO B0; WHILE NOT DOMAINP Y AND MVAR Y=V DO <<Z := (LDEG Y . MK!*SQ1 CANCEL (LC Y ./ 1)) . Z; Y := RED Y>>; B: IF NULL Y THEN GO TO B1; B0: Z := (0 . MK!*SQ1 CANCEL (Y ./ 1)) . Z; B1: LOWPOW!* := CAAR Z; IF (NOT ATOM W AND ATOM CAR W AND (Y := DIMENSION CAR W)) OR ((Y := DIMENSION W) AND NULL CDR Y) THEN GO TO G; Y := EXPLODE W; W := NIL; C: W := INTERN COMPRESS APPEND(Y,EXPLODE CAAR Z) . W; SETK1(CAR W,CDAR Z,T); IF NULL CDR Z THEN GO TO D; Z := CDR Z; GO TO C; D: HIPOW!* := CAAR Z; LPRIM ACONC(W,"are non zero"); E: RETURN HIPOW!*; G: Z := REVERSE Z; IF ATOM W THEN <<IF CAAR Z NEQ (CAR Y-1) THEN <<Y := LIST(CAAR Z+1); PUT(W,'ARRAY,MKARRAY Y); PUT(W,'DIMENSION,Y)>>; W := LIST(W,'TIMES)>>; HIPOW!* := CAAR Z; Y := PAIR(CDR W,Y); G0: WHILE NOT SMEMQ('TIMES,CAAR Y) DO Y := CDR Y; Y := CDAR Y-REVAL SUBST(0,'TIMES,CAAR Y)-1; %-1 needed since DIMENSION gives length, not highest index; IF CAAR Z>Y THEN REDERR LIST("Index",CAAR Z,"out of range"); H: IF NULL Z OR Y NEQ CAAR Z THEN SETELV(SUBST(Y,'TIMES,W),0) ELSE <<SETELV(SUBST(Y,'TIMES,W),CDAR Z); Z := CDR Z>>; IF Y=0 THEN GO TO E; Y := Y-1; GO TO H END; SYMBOLIC PROCEDURE MK!*SQ1 U; IF WTL!* THEN PREPSQ U ELSE MK!*SQ U; FLAG ('(COEFF),'OPFN); FLAG ('(COEFF),'NOVAL); %********************************************************************* %********************************************************************* % ASYMPTOTIC COMMAND PACKAGE %********************************************************************; %********************************************************************; SYMBOLIC PROCEDURE WEIGHT U; BEGIN SCALAR Y,Z; RMSUBS(); FOR EACH X IN U DO IF NOT EQEXPR X THEN ERRPRI2(X,'HOLD) ELSE <<Y := !*A2K CADR X; Z := REVAL CADDR X; IF NOT (NUMBERP Z AND FIXP Z AND Z>0) THEN TYPERR(Z,"weight"); WTL!* := (Y . Z) . DELASC(Y,WTL!*)>> END; SYMBOLIC PROCEDURE WTLEVEL U; BEGIN INTEGER N; SCALAR X; N := REVAL CAR U; IF NOT(NUMBERP N AND FIXP N AND NOT N<0) THEN ERRPRI2(N,'HOLD); N := N+1; X := ATSOC('K!*,ASYMPLIS!*); IF N=CDR X THEN RETURN NIL ELSE IF N<=CDR X THEN RMSUBS2(); RMSUBS1(); RPLACD(X,N) END; RLISTAT '(WEIGHT WTLEVEL); ALGEBRAIC LET K!***2=0; %********************************************************************* %********************************************************************* % LINEAR OPERATOR PACKAGE %********************************************************************* %********************************************************************; %Global variables referenced in this Section; GLOBAL '(DEPL!*); %list of dependencies among kernels; %********************************************************************* % FUNCTIONS FOR DEFINING AND CHECKING EXPRESSION DEPENDENCY %********************************************************************; SYMBOLIC PROCEDURE DEPEND U; FOR EACH X IN CDR U DO DEPEND1(CAR U,X,T); SYMBOLIC PROCEDURE NODEPEND U; <<RMSUBS(); FOR EACH X IN CDR U DO DEPEND1(CAR U,X,NIL)>>; RLISTAT '(DEPEND NODEPEND); SYMBOLIC PROCEDURE DEPEND1(U,V,BOOL); BEGIN SCALAR Y,Z; U := !*A2K U; V := !*A2K V; IF U EQ V THEN RETURN NIL; Y := ASSOC(U,DEPL!*); IF Y THEN IF BOOL THEN RPLACD(Y,UNION(LIST V,CDR Y)) ELSE IF (Z := DELETE(V,CDR Y)) THEN RPLACD(Y,Z) ELSE DEPL!* := DELETE(Y,DEPL!*) ELSE IF NULL BOOL THEN LPRIM LIST(U,"has no prior dependence on",V) ELSE DEPL!* := LIST(U,V) . DEPL!* END; SYMBOLIC PROCEDURE DEPENDS(U,V); IF NULL U OR NUMBERP U OR NUMBERP V THEN NIL ELSE IF U=V THEN U ELSE IF ATOM U AND U MEMQ FRLIS!* THEN T %to allow the most general pattern matching to occur; ELSE IF (LAMBDA X; X AND LDEPENDS(CDR X,V)) ASSOC(U,DEPL!*) THEN T ELSE IF NOT ATOM U AND (LDEPENDS(CDR U,V) OR DEPENDS(CAR U,V)) THEN T ELSE IF ATOM V THEN NIL ELSE DEPENDSL(U,CDR V); SYMBOLIC PROCEDURE LDEPENDS(U,V); U AND (DEPENDS(CAR U,V) OR LDEPENDS(CDR U,V)); SYMBOLIC PROCEDURE DEPENDSL(U,V); V AND (DEPENDS(U,CAR V) OR DEPENDSL(U,CDR V)); SYMBOLIC PROCEDURE FREEOF(U,V); NOT(SMEMBER(V,U) OR V MEMBER ASSOC(U,DEPL!*)); FLAG('(FREEOF),'BOOLEAN); INFIX FREEOF; PRECEDENCE FREEOF,LESSP; %put it above all boolean operators; %********************************************************************* % FUNCTIONS FOR SIMPLIFYING LINEAR OPERATORS %********************************************************************; SYMBOLIC PROCEDURE LINEAR U; FOR EACH X IN U DO <<IF NOT IDP X THEN TYPERR(X,'operator); FLAG(LIST X,'LINEAR); MKOP X>>; RLISTAT '(LINEAR); PUT('LINEAR,'SIMPFG,'((RMSUBS))); SYMBOLIC PROCEDURE FORMLNR U; (LAMBDA (X,Y,Z); IF Y = 1 THEN U ELSE IF NOT DEPENDS(Y,CAR Z) THEN LIST('TIMES,Y,X . 1 . Z) ELSE IF ATOM Y THEN U ELSE IF CAR Y EQ 'PLUS THEN 'PLUS . FOR EACH J IN CDR Y COLLECT FORMLNR(X . J. Z) ELSE IF CAR Y EQ 'MINUS THEN LIST('MINUS,FORMLNR(X . CADR Y . Z)) ELSE IF CAR Y EQ 'DIFFERENCE THEN LIST('DIFFERENCE,FORMLNR(X . CADR Y . Z), FORMLNR(X . CADDR Y . Z)) ELSE IF CAR Y EQ 'TIMES THEN FORMLNTMS(X,CDR Y,Z,U) ELSE IF CAR Y EQ 'QUOTIENT THEN FORMLNQUOT(X,CDR Y,Z,U) ELSE IF CAR Y EQ 'RECIP AND NOT DEPENDS(CADR Y,CAR Z) THEN LIST('QUOTIENT,X . 1 . Z,CADR Y) ELSE (LAMBDA V; IF V THEN LIST('TIMES,CAR V,X . CDR V . Z) ELSE U) EXPT!-SEPARATE(Y,CAR Z)) (CAR U,CADR U,!*A2K CADDR U . CDDDR U); SYMBOLIC PROCEDURE FORMSEPARATE(U,V); %separates U into two parts, and returns a dotted pair of them: those %which are not commutative and do not depend on V, and the remainder; BEGIN SCALAR W,X,Y; FOR EACH Z IN U DO IF NOT NONCOMP Z AND NOT DEPENDS(Z,V) THEN X := Z . X ELSE IF (W := EXPT!-SEPARATE(Z,V)) THEN <<X := CAR W . X; Y := CDR W . Y>> ELSE Y := Z . Y; RETURN REVERSIP X . REVERSIP Y END; SYMBOLIC PROCEDURE EXPT!-SEPARATE(U,V); %determines if U is an expression in EXPT that can be separated into %two parts, one that does not depend on V and one that does, %except if there is no non-dependent part, NIL is returned; IF NOT EQCAR(U,'EXPT) OR DEPENDS(CADR U,V) OR NOT EQCAR(CADDR U,'PLUS) THEN NIL ELSE EXPT!-SEPARATE1(CDADDR U,CADR U,V); SYMBOLIC PROCEDURE EXPT!-SEPARATE1(U,V,W); BEGIN SCALAR X; X := FORMSEPARATE(U,W); RETURN IF NULL CAR X THEN NIL ELSE LIST('EXPT,V,REPLUS CAR X) . IF NULL CDR X THEN 1 ELSE LIST('EXPT,V,REPLUS CDR X) END; SYMBOLIC PROCEDURE FORMLNTMS(U,V,W,X); %U is a linear operator, V its first argument with TIMES removed, %W the rest of the arguments and X the whole expression. %Value is the transformed expression; BEGIN SCALAR Y; Y := FORMSEPARATE(V,CAR W); RETURN IF NULL CAR Y THEN X ELSE 'TIMES . ACONC(CAR Y, IF NULL CDDR Y THEN FORMLNR(U . CADR Y . W) ELSE U . ('TIMES . CDR Y) . W) END; SYMBOLIC PROCEDURE FORMLNQUOT(FN,QUOTARGS,REST,WHOLE); %FN is a linear operator, QUOTARGS its first argument with QUOTIENT %removed, REST the remaining arguments, WHOLE the whole expression. %Value is the transformed expression; BEGIN SCALAR X; RETURN IF NOT DEPENDS(CADR QUOTARGS,CAR REST) THEN LIST('QUOTIENT,FORMLNR(FN . CAR QUOTARGS . REST), CADR QUOTARGS) ELSE IF NOT DEPENDS(CAR QUOTARGS,CAR REST) AND CAR QUOTARGS NEQ 1 THEN LIST('TIMES,CAR QUOTARGS, FORMLNR(FN . LIST('RECIP,CADR QUOTARGS) . REST)) ELSE IF EQCAR(CAR QUOTARGS,'PLUS) THEN 'PLUS . FOR EACH J IN CDAR QUOTARGS COLLECT FORMLNR(FN . ('QUOTIENT . J . CDR QUOTARGS) . REST) ELSE IF EQCAR(CAR QUOTARGS,'MINUS) THEN LIST('MINUS,FORMLNR(FN . ('QUOTIENT . CADAR QUOTARGS . CDR QUOTARGS) . REST)) ELSE IF EQCAR(CAR QUOTARGS,'TIMES) AND CAR(X := FORMSEPARATE(CDAR QUOTARGS,CAR REST)) THEN 'TIMES . ACONC(CAR X, FORMLNR(FN . LIST('QUOTIENT,MKTIMES CDR X, CADR QUOTARGS) . REST)) ELSE IF EQCAR(CADR QUOTARGS,'TIMES) AND CAR(X := FORMSEPARATE(CDADR QUOTARGS,CAR REST)) THEN LIST('TIMES,LIST('RECIP,MKTIMES CAR X), FORMLNR(FN . LIST('QUOTIENT,CAR QUOTARGS,MKTIMES CDR X) . REST)) ELSE IF X := EXPT!-SEPARATE(CAR QUOTARGS,CAR REST) THEN LIST('TIMES,CAR X,FORMLNR(FN . LIST('QUOTIENT,CDR X,CADR QUOTARGS) . REST)) ELSE IF X := EXPT!-SEPARATE(CADR QUOTARGS,CAR REST) THEN LIST('TIMES,LIST('RECIP,CAR X), FORMLNR(FN . LIST('QUOTIENT,CAR QUOTARGS,CDR X) . REST)) ELSE IF (X := REVAL!* CADR QUOTARGS) NEQ CADR QUOTARGS THEN FORMLNQUOT(FN,LIST(CAR QUOTARGS,X),REST,WHOLE) ELSE WHOLE END; SYMBOLIC PROCEDURE MKTIMES U; IF NULL CDR U THEN CAR U ELSE 'TIMES . U; SYMBOLIC PROCEDURE REVAL!* U; %like REVAL, except INTSTR is always ON; BEGIN SCALAR !*INTSTR; !*INTSTR := T; RETURN REVAL U END; %********************************************************************* % FUNCTIONS FOR ALGEBRAIC MODE OPERATIONS ON POLYNOMIALS %********************************************************************; SYMBOLIC PROCEDURE POLPART(EXPRN,KERN,FN); BEGIN SCALAR X,Y; EXPRN := !*A2F EXPRN; KERN := !*A2K KERN; IF DOMAINP EXPRN THEN RETURN NIL ELSE IF MVAR EXPRN EQ KERN THEN RETURN !*F2A APPLY(FN,LIST EXPRN); X := SETKORDER LIST KERN; EXPRN := REORDER EXPRN; IF NOT(MVAR EXPRN EQ KERN) THEN EXPRN := NIL ELSE EXPRN := APPLY(FN,LIST EXPRN); SETKORDER X; RETURN !*F2A EXPRN END; SYMBOLIC PROCEDURE DEG(U,KERN); POLPART(U,KERN,'CDAAR); SYMBOLIC PROCEDURE LCOF(U,KERN); POLPART(U,KERN,'CDAR); SYMBOLIC PROCEDURE LTERM(U,KERN); POLPART(U,KERN,'!*LTERM); SYMBOLIC PROCEDURE !*LTERM U; LT U .+ NIL; SYMBOLIC PROCEDURE MAINVAR U; IF DOMAINP(U := !*A2F U) THEN NIL ELSE IF SFP(U := MVAR U) THEN PREPF U ELSE U; SYMBOLIC PROCEDURE REDUCT(EXPRN,KERN); BEGIN SCALAR X,Y; EXPRN := !*A2F EXPRN; KERN := !*A2K KERN; IF DOMAINP EXPRN THEN RETURN EXPRN ELSE IF MVAR EXPRN EQ KERN THEN RETURN !*F2A CDR EXPRN; X := SETKORDER LIST KERN; EXPRN := REORDER EXPRN; IF MVAR EXPRN EQ KERN THEN EXPRN := CDR EXPRN; SETKORDER X; RETURN !*F2A EXPRN END; SYMBOLIC OPERATOR DEG,LCOF,LTERM,MAINVAR,REDUCT; %********************************************************************* % SIMPLIFICATION RULES FOR ELEMENTARY FUNCTIONS %********************************************************************; ALGEBRAIC; COMMENT RULE FOR I**2; REMFLAG('(I),'RESERVED); LET I**2= -1; FLAG('(E I NIL PI T),'RESERVED); COMMENT LOGARITHMS; OPERATOR LOG; LET LOG(E)= 1, LOG(1)= 0; FOR ALL X LET LOG(E**X)=X; FOR ALL X LET DF(LOG(X),X) = 1/X; COMMENT TRIGONOMETRICAL FUNCTIONS; SYMBOLIC PROCEDURE SIMPTRIG U; %This is a basic simplification function for trigonometrical %functions. The prefix expression U is of the form (<trig-function> % <argument>). It is assumed that the trig-function is either even %or odd, with even the default (and the odd case a flag "odd"). %The value is a standard quotient for the simplified expression; BEGIN SCALAR BOOL,FN,X,Y,Z; FN := CAR U; U := CDR U; IF NULL U OR CDR U THEN REDERR LIST("Wrong number of arguments to",FN); U := SIMP!* CAR U; IF NULL NUMR U AND FLAGP(FN,'ODD) THEN RETURN NIL ./ 1; X := LIST(FN,PREPSQ!* U); IF SUBFG!* AND (Z := OPMTCH X) THEN RETURN SIMP Z ELSE IF Z := NUMVALCHK X THEN RETURN Z ELSE IF MINUSF NUMR U THEN <<IF FLAGP(FN,'ODD) THEN BOOL := T; X := LIST(FN,PREPSQ!*(NEGF NUMR U ./ DENR U)); IF SUBFG!* AND (Z := OPMTCH X) THEN RETURN SIMP Z>>; X := MKSQ(X,1); RETURN IF BOOL THEN NEGSQ X ELSE X END; DEFLIST('((ACOS SIMPTRIG) (ASIN SIMPTRIG) (ATAN SIMPTRIG) (ACOSH SIMPTRIG) (ASINH SIMPTRIG) (ATANH SIMPTRIG) (COS SIMPTRIG) (SIN SIMPTRIG) (TAN SIMPTRIG) (COT SIMPTRIG)(ACOT SIMPTRIG)(COTH SIMPTRIG)(ACOTH SIMPTRIG) (COSH SIMPTRIG) (SINH SIMPTRIG) (TANH SIMPTRIG) ),'SIMPFN); %The following declaration causes the simplifier to pass the full %expression (including the function) to SIMPTRIG; FLAG ('(ACOS ASIN ATAN ACOSH ASINH ATANH COS SIN TAN COSH SINH TANH COT ACOT COTH ACOTH), 'FULL); FLAG('(ASIN ATAN ASINH ATANH SIN TAN SINH TANH COT ACOT COTH ACOTH), 'ODD); %In the following rules, it is not necessary to let f(0)=0, when f %is odd, since SIMPTRIG already does this; LET COS(0)= 1, COS(PI/2)= 0, SIN(PI/2)= 1, SIN(PI)= 0, COS(PI)=-1, COSH 0=1; FOR ALL X LET COS ACOS X=X, SIN ASIN X=X, TAN ATAN X=X, COSH ACOSH X=X, SINH ASINH X=X, TANH ATANH X=X, COT ACOT X=X, COTH ACOTH X=X; FOR ALL N SUCH THAT NUMBERP N AND FIXP N LET SIN(N*PI)=0, COS(N*PI) = (-1)**N; FOR ALL X LET DF(ACOS(X),X)= -SQRT(1-X**2)/(1-X**2), DF(ASIN(X),X)= SQRT(1-X**2)/(1-X**2), DF(ATAN(X),X)= 1/(1+X**2), DF(ACOSH(X),X)= SQRT(X**2-1)/(X**2-1), DF(ASINH(X),X)= SQRT(X**2+1)/(X**2+1), DF(ATANH(X),X)= 1/(1-X**2), DF(COS X,X)= -SIN(X), DF(SIN(X),X)= COS(X), DF(TAN X,X)=1+TAN X**2, DF(SINH X,X)=COSH X, DF(COSH X,X)=SINH X, DF(TANH X,X)=1-TANH X**2, DF(COT X,X)=-1-COT X**2, DF(COTH X,X)=1-COTH X**2; LET E**(I*PI/2) = I, E**(I*PI) = -1, E**(3*I*PI/2)=-I; %FOR ALL X LET E**LOG X=X; %requires every power to be checked; FOR ALL X,Y LET DF(X**Y,X)= Y*X**(Y-1), DF(X**Y,Y)= LOG X*X**Y; COMMENT SQUARE ROOTS; DEFLIST('((SQRT SIMPSQRT)),'SIMPFN); %FOR ALL X LET SQRT X**2=X; FLUID '(!*!*SQRT); %Used to indicate that SQRTs have been used; SYMBOLIC PROCEDURE MKSQRT U; <<IF NULL !*!*SQRT THEN <<!*!*SQRT := T; ALGEBRAIC FOR ALL X LET SQRT X**2=X>>; LIST('SQRT,U)>>; FOR ALL X LET DF(SQRT X,X)=SQRT X/(2*X); COMMENT ERF,EXP, EXPINT AND DILOG; OPERATOR ERF,EXP,EXPINT,DILOG; LET ERF 0=0; LET DILOG(0)=PI**2/6; FOR ALL X LET ERF(-X)=-ERF X; FOR ALL X LET DF(ERF X,X)=2*SQRT(PI)*E**(-X**2/2)/PI; FOR ALL X LET EXP(X)=E**X; FOR ALL X LET DF(EXPINT(X),X)=E**X/X; FOR ALL X LET DF(DILOG X,X)=-LOG X/(X-1); SYMBOLIC; %********************************************************************* %********************************************************************* % SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES %********************************************************************* %********************************************************************; SYMBOLIC PROCEDURE NSSIMP(U,V); %U is a prefix expression involving non-commuting %quantities. Result is an expression of the form % SUM R(I)*PRODUCT M(I,J) where the R(I) are standard %quotients and the M(I,J) non-commuting expressions; %N. B: the products in M(I,J) are returned in reverse order %(to facilitate, e.g., matrix augmentation); BEGIN SCALAR W,X,Y,Z; U := DSIMP(U,V); A: IF NULL U THEN RETURN Z; W := CAR U; C: IF NULL W THEN GO TO D ELSE IF NUMBERP CAR W OR NOT(EQCAR(CAR W,'!*DIV) OR APPLY(V,LIST CAR W)) THEN X := ACONC(X,CAR W) ELSE Y := ACONC(Y,CAR W); W := CDR W; GO TO C; D: IF NULL Y THEN GO TO ER; E: Z := ADDNS(((IF NULL X THEN 1 ./ 1 ELSE SIMPTIMES X) . Y),Z); U := CDR U; X := Y:= NIL; GO TO A; ER: Y := GET(V,'NAME); IF IDP CAR X THEN IF NOT FLAGP(CAR X,GET(Y,'FN)) THEN REDMSG(CAR X,Y) ELSE REDERR LIST(Y,X,"not set") ELSE IF Y EQ 'MATRIX THEN <<Y:= '((MAT (1))); GO TO E>> %to allow a scalar to be a 1 by 1 matrix; ELSE REDERR LIST("Missing",Y,X); PUT(CAR X,Y,Y); Y := LIST CAR X; X := CDR X; GO TO E END; SYMBOLIC PROCEDURE DSIMP(U,V); %result is a list of lists representing a sum of products; %N. B: symbols are in reverse order in product list; IF NUMBERP U THEN LIST LIST U ELSE IF ATOM U THEN (LAMBDA W; (LAMBDA X; IF X AND NOT X EQ W AND SUBFG!* THEN DSIMP(X,V) ELSE IF FLAGP(U,'SHARE) THEN DSIMP(EVAL U,V) ELSE <<FLAG(LIST U,'USED!*); LIST LIST U>>) GET(U,W)) GET(V,'NAME) ELSE IF CAR U EQ 'PLUS THEN FOR EACH J IN CDR U CONC DSIMP(J,V) ELSE IF CAR U EQ 'DIFFERENCE THEN NCONC(DSIMP(CADR U,V), DSIMP('MINUS . CDDR U,V)) ELSE IF CAR U EQ 'MINUS THEN DSIMPTIMES(LIST(-1,CARX CDR U),V) ELSE IF CAR U EQ 'TIMES THEN DSIMPTIMES(CDR U,V) ELSE IF CAR U EQ 'QUOTIENT THEN DSIMPTIMES(LIST(CADR U, LIST('RECIP,CARX CDDR U)),V) ELSE IF NOT APPLY(V,LIST U) THEN LIST LIST U ELSE IF CAR U EQ 'RECIP THEN LIST LIST LIST('!*DIV,CARX CDR U) ELSE IF CAR U EQ 'EXPT THEN (LAMBDA Z; IF NOT NUMBERP Z OR NOT FIXP Z THEN ERRPRI2(U,T) ELSE IF Z<0 THEN LIST LIST LIST('!*DIV,'TIMES . NLIST(CADR U,-Z)) ELSE IF Z=0 THEN LIST LIST LIST('!*DIV,CADR U,1) ELSE DSIMPTIMES(NLIST(CADR U,Z),V)) REVAL CADDR U ELSE IF CAR U EQ 'MAT THEN LIST LIST U ELSE IF ARRAYP CAR U THEN DSIMP(GETELV U,V) ELSE (LAMBDA X; IF X THEN DSIMP(X,V) ELSE (LAMBDA Y; IF Y THEN DSIMP(Y,V) ELSE LIST LIST U) OPMTCH REVOP1 U) OPMTCH U; SYMBOLIC PROCEDURE DSIMPTIMES(U,V); IF NULL U THEN ERRACH 'DSIMPTIMES ELSE IF NULL CDR U THEN DSIMP(CAR U,V) ELSE (LAMBDA J; FOR EACH K IN DSIMPTIMES(CDR U,V) CONC MAPPEND(J,K)) DSIMP(CAR U,V); SYMBOLIC PROCEDURE ADDNS(U,V); IF NULL V THEN LIST U ELSE IF CDR U=CDAR V THEN (LAMBDA X; IF NULL CAR X THEN CDR V ELSE (X . CDR U) . CDR V) ADDSQ(CAR U,CAAR V) ELSE IF ORDP(CDR U,CDAR V) THEN U . V ELSE CAR V . ADDNS(U,CDR V); SYMBOLIC PROCEDURE NSLET(U,V,W,B,FLG); BEGIN IF FLG THEN GO TO A ELSE IF NOT ATOM U THEN IF ARRAYP CAR U THEN GO TO A ELSE TYPERR(U,"array"); REDMSG(U,W); PUT(U,W,W); A: IF NULL B THEN GO TO C ELSE IF NOT ATOM U OR FLAGP(U,'USED!*) THEN RMSUBS(); C: IF NOT ATOM U THEN IF ARRAYP CAR U THEN SETELV(U,IF B THEN V ELSE NIL) ELSE PUT(CAR U,'OPMTCH,XADD!*(CDR U . LIST(NIL . (IF MCOND!* THEN MCOND!* ELSE T),V,NIL), GET(CAR U,'OPMTCH),U,B)) ELSE IF NULL B THEN REMPROP(U,W) ELSE IF W EQ 'MATRIX AND NOT EQCAR(V,'MAT) THEN PUT(U,W,IF MATP V THEN GET(V,'MATRIX) ELSE LIST('MAT,LIST V)) %1 by 1 matrix case; ELSE PUT(U,W,V) END; SYMBOLIC PROCEDURE NSP(U,V); IF NUMBERP U THEN NIL ELSE IF ATOM U THEN GET(U,V) OR (FLAGP(U,'SHARE) AND NSP(EVAL U,V)) ELSE IF CAR U MEMQ '(TIMES QUOTIENT) THEN NSOR(CDR U,V) ELSE IF CAR U MEMQ '(PLUS DIFFERENCE MINUS EXPT RECIP) THEN NSP(CADR U,V) ELSE IF ARRAYP CAR U THEN NSP(GETELX U,V) ELSE FLAGP(CAR U,GET(V,'FN)); SYMBOLIC PROCEDURE GETELX U; %to take care of free variables in LET statements; IF SMEMQLP(FRLIS!*,CDR U) THEN NIL ELSE IF NULL(U := GETELV U) THEN 0 ELSE REVAL U; SYMBOLIC PROCEDURE NSOR(U,V); U AND (NSP(CAR U,V) OR NSOR(CDR U,V)); %********************************************************************* %********************************************************************* % MATRIX PACKAGE %********************************************************************* %********************************************************************; %********************************************************************* % REQUIRES SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES %********************************************************************; SYMBOLIC PROCEDURE MATRIX U; %declares list U as matrices; BEGIN SCALAR V,W; INTEGER N; TYPL!* := UNION('(MATP),TYPL!*); A: IF NULL U THEN RETURN NIL ELSE IF ATOM CAR U AND NOT TYPECHK(CAR U,'MATRIX) THEN PUT(CAR U,'MATRIX,'MATRIX) ELSE IF NOT IDP CAAR U OR LENGTH (V := REVLIS CDAR U) NEQ 2 OR NOT NUMLIS V THEN GO TO ER ELSE IF NOT TYPECHK(CAAR U,'MATRIX) THEN GO TO C; B: U := CDR U; GO TO A; C: N := CAR V; D: IF N=0 THEN GO TO E; W := NZERO CADR V . W; N := N-1; GO TO D; E: PUT(CAAR U,'MATRIX,'MAT . W); W := NIL; GO TO B; ER: ERRPRI2(CAR U,'HOLD); GO TO B END; RLISTAT '(MATRIX); SYMBOLIC PROCEDURE NZERO N; %returns a list of N zeros; IF N=0 THEN NIL ELSE 0 . NZERO(N-1); SYMBOLIC PROCEDURE FORMMAT(U,VARS,MODE); 'LIST . MKQUOTE 'MAT . FOR EACH X IN U COLLECT('LIST . FORMLIS(X,VARS,MODE)); PUT('MAT,'FORMFN,'FORMMAT); SYMBOLIC PROCEDURE MATP U; %predicate which tests for matrix expressions; NSP(U,'MATRIX); FLAG('(MAT TP),'MATFLG); PUT('TP,'MSIMPFN,'TP); PUT('MATP,'LETFN,'NSLET); PUT('MATP,'NAME,'MATRIX); PUT('MATRIX,'FN,'MATFLG); PUT('MATP,'EVFN,'MATSM!*); PUT('MATP,'PRIFN,'MATPRI!*); END;