Artifact ae7b0027d7a1f6a4a1190cda7e088be51afd055be0d766f420f4092e78ef9509:
- Executable file
r38/packages/alg/forall.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 32868) [annotate] [blame] [check-ins using] [more...]
module forall; % FOR ALL and LET-related commands. % Author: Anthony C. Hearn. % Modifications by: Herbert Melenk. % Copyright (c) 1993 RAND. All rights reserved. fluid '(!*resimp !*sub2 alglist!* arbl!* asymplis!* frasc!* wtl!*); fluid '(!*!*noremove!*!* frlis!* newrule!* oldrules!* props!* subfg!*); fluid '(!*reduce4 !*sqrtrulep powlis!* powlis1!*); global '(!*match cursym!* erfg!* letl!* mcond!*); letl!* := '(let match clear saveas such); % Special delimiters. % Contains two RPLAC references commented out. remprop('forall,'stat); remprop('forall,'formfn); 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); if not(cursym!* memq letl!*) then symerr('let,t) else return list('forall,arbl,conds,xread1 t) end; symbolic 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); % mcond!* := formbool(subla(y,eval cadr u),nil,'algebraic); frasc!* := y; frlis!* := union(x,frlis!*); return lispeval caddr u end; symbolic procedure arbstat; <<lpriw("*****","ARB no longer supported"); symerr('if,t)>>; put('arb,'stat,'arbstat); symbolic procedure newvar u; if not idp u then typerr(u,"free variable") % else if flagp(u,'reserved) % then typerr(list("Reserved variable",u),"free variable") else intern compress append(explode '!=,explode u); symbolic procedure formforall(u,vars,mode); begin scalar arbl!*,x,y; u := cdr u; % vars := append(car u,vars); % Semantics are different. if null cadr u then x := t else x := formbool(cadr u,vars,mode); % if null cadr u then x := t else x := form1(cadr u,vars,mode); y := form1(caddr u,vars,mode); % Allow for a LET or MATCH call during a similar evaluation. % This might occur in autoloading. if eqcar(y,'let) then y := 'let00 . cdr y else if eqcar(y,'match) then y := 'match00 . cdr y; return list('forall,list('list,mkquote union(arbl!*,car u), mkquote x,mkquote y)) end; symbolic procedure def u; % Defines a list of operators. <<lprim "Please do not use the DEF operator; it is no longer supported"; for each x in u do if not eqexpr x or not idlistp cadr x then errpri2(x,t) else <<mkop caadr x; forall list(cdadr x,t,list('let,mkarg(list x,nil)))>>>>; put('def,'stat,'rlis); deflist('((forall formforall)),'formfn); deflist('((forall forallstat)),'stat); flag ('(clear let match),'quote); symbolic procedure formlet1(u,vars,mode); requote ('list . for each x in u collect if eqexpr x then list('list,mkquote car x,form1(cadr x,vars,mode), !*s2arg(form1(caddr x,vars,mode),vars)) else form1(x,vars,mode)); symbolic procedure requote u; if atom u or not(car u eq 'list) then u else (if x then mkquote x else u) where x=requote1 cdr u; symbolic procedure requote1 u; begin scalar x,y; a: if null u then return reversip x else if numberp car u or car u memq '(nil t) then x := car u . x else if atom car u then return nil else if caar u eq 'quote then x := cadar u . x else if caar u eq 'list and (y := requote1 cdar u) then x := y . x else return nil; u := cdr u; go to a end; symbolic procedure !*s2arg(u,vars); %makes all NOCHANGE operators into their listed form; if atom u or eq(car u,'quote) 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(cdr u,vars,mode)); symbolic procedure formclear1(u,vars,mode); 'list . for each x in u collect if flagp(x,'share) then mkquote x else form1(x,vars,mode); symbolic procedure formlet(u,vars,mode); list('let,formlet1(cdr u,vars,mode)); symbolic procedure formmatch(u,vars,mode); list('match,formlet1(cdr u,vars,mode)); symbolic procedure let u; let0 u; % to distinguish between operator % and function. symbolic procedure let0 u; let00 u where frasc!* = nil; symbolic procedure let00 u; begin u := errorset!*(list('let1,mkquote u),t); frasc!* := mcond!* := nil; if errorp u then error1() else return car u end; symbolic procedure let1 u; begin scalar x,y; u := reverse u; % So that rules are added in order given. while u do <<if idp u then typerr(u,"rule list") else if eqcar(y := listeval0(x := car u),'list) then rule!-list(reverse cdr y,t) else if idp x then revalruletst x else if car x eq 'replaceby then if frasc!* then rerror(alg,100, "=> invalid in FOR ALL statement") else rule!-list(list x,t) else if car x eq 'equal then if smemq('!~,x) then if frasc!* then typerr(x,"rule") else rule!-list(list x,t) else let2(cadr x,caddr x,nil,t) else revalruletst x; u := cdr u>> end; symbolic procedure revalruletst u; (if u neq v then let1 list v else typerr(u,"rule list")) where v = reval u; symbolic procedure let2(u,v,w,b); begin scalar flgg,x,y,z; % FLGG is set true if free variables are found. if (y := getrtype u) and (z := get(y,'typeletfn)) and flagp(z,'direct) then return lispapply(z,list(u,v,y,b,getrtype v)) else if (y := getrtype v) and (z := get(y,'typeletfn)) and flagp(z,'direct) then return lispapply(z,list(u,v,nil,b,y)); x := subla(frasc!*,u); if x neq u then if atom x then return errpri1 u else <<flgg := 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 are replaced by uneq copies % 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 atom u then nil else if car u eq 'getel then u := lispeval cadr u else if flagp(car u,'immediate) then u := reval u; return let3(u,v,w,b,flgg) end; symbolic procedure let3(u,v,w,b,flgg); % U is left-hand-side of a rule, v the right-hand-side. % W is true if a match, NIL otherwise. % B is true if the rule is being added, NIL if being removed. % Flgg is true if there are free variables in the rule. begin scalar x,y1,y2,z; x := u; if null x then <<u := 0; return errpri1 u>> else if numberp x then return errpri1 u; % Allow redefinition of id's, regardless of type. % The next line allows type of LHS to be redefined. y2 := getrtype v; if b and idp x then <<remprop(x,'rtype); remprop(x,'avalue)>>; % else if idp x and flagp(x,'reserved) % then rederr list(x,"is a reserved identifier"); if (y1 := getrtype x) then return if z := get(y1,'typeletfn) then lispapply(z,list(x,v,y1,b,getrtype v)) else typelet(x,v,y1,b,getrtype v) else if y2 and not(y2 eq 'yetunknowntype) then return if z := get(y2,'typeletfn) then lispapply(z,list(x,v,nil,b,y2)) else typelet(x,v,nil,b,y2) else letscalar(u,v,w,x,b,flgg) end; symbolic procedure letscalar(u,v,w,x,b,flgg); begin if not atom x then if not idp car x then return errpri2(u,'hold) else if car x eq 'df then if null letdf(u,v,w,x,b) then nil else return nil else if getrtype car x then return let2(reval x,v,w,b) else if not get(car x,'simpfn) then <<redmsg(car x,"operator"); mkop car x; return let3(u,v,w,b,flgg)>> else nil else if null b and null w then <<remprop(x,'avalue); remprop(x,'rtype); % just in case remflag(list x,'antisymmetric); remprop(x,'infix); % remprop(x,'klist); % commented out: the relevant objects may still exist. remprop(x,'kvalue); remflag(list x,'linear); remflag(list x,'noncom); remprop(x,'op); remprop(x,'opmtch); remprop(x,'simpfn); remflag(list x,'symmetric); wtl!* := delasc(x,wtl!*); if flagp(x,'opfn) then <<remflag(list x,'opfn); remd x>>; rmsubs(); % since all kernel lists are gone. return nil>>; if eqcar(x,'expt) and caddr x memq frlis!* then letexprn(u,v,w,!*k2q x,b,flgg) % Special case of a non-integer exponent match. else if eqcar(x,'sqrt) then <<!*sqrtrulep := t; let2({'expt,cadr x,'(quotient 1 2)},v,w,b)>>; % Since SQRTs can be converted into EXPTs. x := simp0 x where !*precise = t; % We don't want to break % up exponents. return if not domainp numr x then letexprn(u,v,w,x,b,flgg) else errpri1 u end; symbolic procedure letexprn(u,v,w,x,b,flgg); % Replacement of scalar expressions. begin scalar y,z; if denr x neq 1 then return let2(let!-prepf numr x, list('times,let!-prepf denr x,v),w,b) else if red(x := numr x) then return let2(let!-prepf !*t2f lt x, list('difference,v,let!-prepf red x),w,b) else if null (y := kernlp x) then <<y := term!-split x; return let2(let!-prepf car y, list('difference,v,let!-prepf cdr y),w,b)>> else if y neq 1 then return let2(let!-prepf quotf!*(x,y), list('quotient,v,let!-prepf y),w,b); x := klistt x; y := list(w . (if mcond!* then mcond!* else t),v,nil); if cdr x then return <<rmsubs(); !*match:= xadd!*(x . y,!*match,b)>> else if null w and cdar x=1 % ONEP then <<x := caar x; if null flgg and (null mcond!* or mcond!* eq 't or not smember(x,mcond!*)) then <<if atom x then if flagp(x,'used!*) then rmsubs() else nil else if 'used!* memq cddr fkern x then rmsubs(); setk1(x,v,b)>> else if atom x then return errpri1 u else <<rmsubs(); % if get(car x,'klist) then rmsubs(); % the "get" is always true currently. put(car x, 'opmtch, xadd!*(cdr x . y,get(car x,'opmtch),b))>>>> else <<rmsubs(); if v=0 and null w and not flgg then <<asymplis!* := xadd(car x,asymplis!*,b); powlis!* := xadd(caar x . cdar x . y,powlis!*,'replace)>> else if w or not(cdar y eq t) or frasc!* then powlis1!* := xadd(car x . y,powlis1!*,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!*,b); if b then asymplis!* := delasc(caar x,asymplis!*)>>>> end; rlistat '(clear let match); % Further support for rule lists and local rule applications. symbolic procedure clearrules u; rule!-list(u,nil) where !*sqrtrulep=nil; % symbolic procedure letrules u; rule!-list(u,t); rlistat '(clearrules); % letrules. symbolic procedure rule!-list(u,type); % Type is true if the rule is being added, NIL if being removed. begin scalar v,x,y,z; a: frasc!* := nil; % Since free variables must be declared in each % rule. if null u or u = {{}} then return (mcond!* := nil); mcond!* := t; v := car u; if idp v then if (x := get(v,'avalue)) and car x eq 'list then <<u := append(reverse cdadr x,cdr u); go to a>> else typerr(v,"rule list") else if car v eq 'list then <<u := append(cdr v,cdr u); go to a>> else if car v eq 'equal then lprim "Please use => instead of = in rules" else if not(car v eq 'replaceby) then typerr(v,"rule"); y := remove!-free!-vars cadr v; if eqcar(caddr v,'when) then <<mcond!* := formbool(remove!-free!-vars!* caddr caddr v, nil,'algebraic); z := remove!-free!-vars!* cadr caddr v>> else z := remove!-free!-vars!* caddr v; rule!*(y,z,frasc!*,mcond!*,type); u := cdr u; go to a end; symbolic procedure rule!*(u,v,frasc,mcond,type); % Type is T if a rule is being added, OLD if an old rule is being % reinstalled, or NIL if a rule is being removed. begin scalar x; frasc!* := frasc; mcond!* := mcond eq t or subla(frasc,mcond); if type and type neq 'old then <<newrule!* := list(u,v,frasc,mcond); % prin2t list("newrule:",newrule!*); if idp u then <<if x := get(u,'rtype) then <<props!*:= (u . ('rtype . x)) . props!*; remprop(u,'rtype)>>; if x := get(u,'avalue) then <<updoldrules(x,nil); remprop(u,'avalue)>>>>; % Asymptotic case. if v=0 and eqcar(u,'expt) and idp cadr u and numberp caddr u and (x := assoc(cadr u,asymplis!*)) then updoldrules(x,nil)>>; return rule(u,v,frasc,if type eq 'old then t else type) end; symbolic procedure rule(u,v,frasc,type); begin scalar flg,frlis,x,y,z; % FLGG is set true if free variables are found. % x := subla(frasc,u); if x neq u then if atom x then return errpri1 u 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 are replaced by uneq copies % during pattern matching process. % Check for unmatched free variables. frlis := for each j in frasc collect cdr j; 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 := lispeval cadr u; return let3(u,v,nil,type,flg) end; mkop '!~; % Declare as algebraic operator. put('!~,'prifn,'tildepri); symbolic procedure tildepri u; <<prin2!* "~"; prin2!* cadr u>>; newtok '((!= !>) replaceby); infix =>; precedence =>,to; symbolic procedure equalreplaceby u; 'replaceby . u; put('replaceby,'psopfn,'equalreplaceby); flag('(replaceby),'equalopr); % Make LHS, RHS etc work. flag('(replaceby),'spaced); % Make it print with spaces. symbolic procedure formreplaceby(u,vars,mode); list('list,mkquote car u,form1(cadr u,vars,mode), !*s2arg(form1(caddr u,vars,mode),vars)); put('replaceby,'formfn,'formreplaceby); infix when; precedence when,=>; symbolic procedure formwhen(u,vars,mode); list('list,algid('when,vars),form1(cadr u,vars,mode), % We exclude formbool in following so that rules print prettily. % mkarg(formbool(caddr u,vars,mode),vars)); mkarg(caddr u,vars)); put('when,'formfn,'formwhen); flag('(whereexp),'listargp); % letsub. % put('letsub,'simpfn,'simpletsub); put('whereexp,'psopfn,'evalwhereexp); % symbolic procedure simpletsub u; simp evalletsub1(u,t); symbolic procedure evalwhereexp u; % We assume that the arguments of this function are well-formed, as % they would be if produced from a "where" parse. % It looks like there is a spurious simplification, but it's needed % in x:= (e^(12i*pi/5) - e^(8i*pi/5) + 4e^(6i*pi/5) - e^(4i*pi/5) % - 2e^(2i*pi/5) - 1)/(16e^(6i*pi/5)); y:= {e^(~a*i*pi/~(~ b)) % => e^((a - b)/b*i*pi) when numberp a and numberp b and a>b}; % x where y; evalletsub({cdar u,{'aeval,mkquote{'aeval,carx(cdr u,'where)}}},nil); flag('(aeval),'opfn); % To make the previous procedure work. % symbolic procedure evalletsub1(u,v); % begin scalar x; % x := car u; % u := carx(cdr u,'simpletsub); % if eqcar(x,'list) then x := cdr x else errach 'simpletsub; % return evalletsub2({x,{'aeval,mkquote u}},v) % end; symbolic procedure evalletsub(u,v); if errorp(u := evalletsub2(u,v)) then rerror(alg,24,"Invalid simplification") else car u; symbolic procedure evalletsub2(u,v); % car u is an untagged list of rules or ruleset names, % cadr u is an expression to be evaluated by errorset* with the % rules activated locally, % v should be nil unless the rules contain equations. % Returns the expression value corresponding to the % errorset protocol. begin scalar newrule!*,oldrules!*,props!*,w; w := set_rules(car u,v); % We need resimp on since u may contain (*SQ ... T). u := errorset!*(cadr u,nil); % where !*resimp = t; % Restore previous environment, if changed. restore_rules w; return u end; symbolic procedure set_rules(u,v); begin scalar !*resimp,x,y,z; for each j in u do % The "v" check in next line causes "a where a=>4" to fail. if eqcar(j,'replaceby) then y := j . y else if null v and eqcar(j,'equal) then <<lprim "Please use => instead of = in rules"; y := ('replaceby . cdr j) . y>> else if (x := validrule j) or idp j and (x := validrule reval j) then (x := reverse car x) and <<rule!-list(x,t); z := x . z>> else typerr(j,"rule list"); rule!-list(y,t); return y . z end; symbolic procedure restore_rules u; <<for each j in u do rule!-list(j,nil); for each j in oldrules!* do if atom cdar j then if idp cdar j then if cdar j eq 'scalar then let3(caar j,cadr j,nil,t,nil) else typelet(caar j,cadr j,nil,t,cdar j) else nil else rule!*(car j,cadr j,caddr j,cadddr j,'old); restore_props()>> where !*resimp := nil; symbolic procedure restore_props; % At present, the only thing props!* can contain is an RTYPE % property. However, it is in this form to handle any other cases % that arise. for each j in props!* do if pairp cdr j then put(car j,cadr j,cddr j) else flag({car j},cdr j); symbolic procedure resimpcar u; resimp car u; symbolic procedure validrule u; (if null x then nil else list x) where x=validrule1 u; symbolic procedure validrule1 u; if atom u then nil else if car u eq 'list then if null cdr u then {{}} else for each j in cdr u collect validrule1 j else if car u eq 'replaceby then u else if car u eq 'equal then 'replaceby . cdr u else nil; symbolic procedure remove!-free!-vars!* u; remove!-free!-vars u where !*!*noremove!*!* := t; symbolic procedure remove!-free!-vars u; begin scalar x,w; return if atom u then u else if car u eq '!~ then if !*!*noremove!*!* then if (x := atsoc(cadr u,frasc!*)) or eqcar(cadr u,'!~) and (x := atsoc(cadadr u,frasc!*)) then cdr x else u else if atom cdr u then typerr(u,"free variable") % Allow for the substitution of a free variable. else if numberp(w := cadr u) then u else if idp w or eqcar(w,'!~) and (w:=cadr w) then <<frlis!* := union(list get!-free!-form cadr u, frlis!*); w>> else if idp caadr u % Free operator. then <<frlis!* := union(list get!-free!-form caadr u, frlis!*); caadr u . remove!-free!-vars!-l cdadr u>> else typerr(u,"free variable") else remove!-free!-vars!-l u end; symbolic procedure remove!-free!-vars!-l u; if atom u then u else if car u eq '!*sq then remove!-free!-vars!-l prepsq!* cadr u else (if x=u then u else x) where x=remove!-free!-vars car u . remove!-free!-vars!-l cdr u; symbolic procedure get!-free!-form u; begin scalar x,opt; if x := atsoc(u,frasc!*) then return cdr x; if eqcar(u,'!~) then <<u:= cadr u; x := '(!! !~ !! !~); opt := t>> else x := '(!! !~); x := intern compress append(x,explode u); frasc!* := (u . x) . frasc!*; if opt then flag({x},'optional); return x end; symbolic procedure term!-split u; % U is a standard form which is not a kernel list (i.e., kernlp % is false). Result is the dotted pair of the leading part of the % expression for which kernlp is true, and the remainder; begin scalar x; while null red u do <<x := lpow u . x; u := lc u>>; return tpowadd(x,!*t2f lt u) . tpowadd(x,red u) end; symbolic procedure tpowadd(u,v); <<for each j in u do v := !*t2f(j .* v); v>>; symbolic procedure frvarsof(u,l); % Extract the free variables in u in their left-to-right order. if memq(u,frlis!*) then if memq(u,l) then l else append(l,{u}) else if atom u then l else frvarsof(cdr u,frvarsof(car u,l)); symbolic procedure simp0 u; begin scalar !*factor,x,y,z; if eqcar(u,'!*sq) then return simp0 prepsq!* cadr u; y := setkorder frvarsof(u,nil); x := subfg!* . !*sub2; alglist!* := nil . nil; % Since assignments will change. subfg!* := nil; if atom u or idp car u and (flagp(car u,'simp0fn) or get(car u,'rtype)) then z := simp u else z := simpiden u; rplaca(alglist!*,delasc(u,car alglist!*)); % Since we don't want to keep this value. subfg!* := car x; !*sub2 := cdr x; setkorder y; return z end; flag('(cons difference eps expt minus plus quotient times),'simp0fn); symbolic procedure let!-prepf u; subla(for each x in frasc!* collect (cdr x . car x),prepf u); symbolic procedure match u; match00 u where frasc!* = nil; symbolic procedure match00 u; <<for each x in u do let2(cadr x,caddr x,t,t); frasc!* := mcond!* := nil>>; symbolic procedure clear u; begin rmsubs(); u := errorset!*(list('clear1,mkquote u),t); mcond!* := frasc!* := nil; if errorp u then error1() else return car u end; symbolic procedure clear1 u; begin scalar x,y; while u do <<if flagp(x := car u,'share) then if not flagp(x,'reserved) then set(x,x) else rsverr x % if argument is an explicit list, clear each element. else if eqcar(x,'list) then u := nil . append(cdr x,cdr u) % The following two cases allow for rules or the lhs of % rules as arguments to CLEAR. else if eqcar(x,'replaceby) then rule!-list(list x,nil) else if smemq('!~,x) then if eqcar(x,'equal) then rule!-list(list x,nil) else rule!-list(list list('replaceby,x,nil),nil) % Hook for a generalized "clear" facility. else if (y := get(if atom x then x else car x,'clearfn)) then apply1(y,x) else <<let2(x,nil,nil,nil); let2(x,nil,t,nil)>>; u := cdr u>> end; symbolic procedure typelet(u,v,ltype,b,rtype); % General function for setting up rules for typed expressions. % LTYPE is the type of the left hand side U, RTYPE, that of RHS V. % B is a flag that is true if this is an update, nil for a removal. begin scalar ls; if null rtype then rtype := 'scalar; if ltype eq rtype then go to a else if null b then go to c else if ltype then if ltype eq 'list and rtype eq 'scalar then <<ls := t; go to l>> else typerr(list(ltype,u),rtype) else if not atom u then if arrayp car u then go to a else typerr(u,rtype); redmsg(u,rtype); l: put(u,'rtype,rtype); ltype := rtype; a: if b and (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),b)) else if null b then <<remprop(u,'avalue); remprop(u,'rtype); if ltype eq 'array then remprop(u,'dimension)>> else if ls then <<remprop(u,'rtype); put!-avalue(u,rtype,v)>> else <<if (b := get(u,'avalue)) then if not(rtype eq car b) and (not(car b memq(ls := '(scalar list))) or not(rtype memq ls)) then typerr(list(car b,u),rtype); put!-avalue(u,rtype,v)>> end; symbolic procedure setk(u,v); if not atom u then (if x then setk0(car u . apply1(x,cdr u),v) else if get(car u,'rtype) eq 'matrix then setk0(u,v) else setk0(car u . revlis cdr u,v)) where x=get(car u,'evalargfn) else setk0(u,v); symbolic procedure setk0(u,v); % Clear frasc!* to allow for autoloading within LET constructs. begin scalar x,frasc!*; % We need to reset alglist!* for structures on the left or right % hand side. if (x := getrtype v) and get(x,'setelemfn) then <<alglist!* := nil . nil; let2(u,v,nil,t)>> else if not atom u and idp car u % Excalc currently needs getrtype to check for free indices. % Getrtype *must* be called as first argument in OR below. and ((x := getrtype u or get(car u,'rtype)) and (x := get(x,'setelemfn)) or (x := get(car u,'setkfn))) % We must update alglist!* when an element is defined. then <<alglist!* := nil . nil; apply2(x,u,v)>> % alglist!* is updated here in simp0. else let2(u,v,nil,t); return v end; symbolic procedure setk1(u,v,b); begin scalar x,y,z,!*uncached; !*uncached := t; if atom u then <<if null b then <<if not get(u,'avalue) then msgpri(nil,u,"not found",nil,nil) else remprop(u,'avalue); return nil>> else if (x:= get(u,'avalue)) then put!-avalue(u,car x,v) else put!-avalue(u,'scalar,v); return v>> else if not atom car u then rerror(alg,25,"Invalid syntax: improper assignment"); u := car u . revlis cdr u; if null b then <<z:=assoc(u,wtl!*); if not(y := get(car u,'kvalue)) or not (x := assoc(u,y)) then <<if null z and null !*sqrtrulep then msgpri(nil,u,"not found",nil,nil)>> else put(car u,'kvalue,delete(x,y)); if z then wtl!*:=delasc(u,wtl!*); return nil>> else if not (y := get(car u,'kvalue)) then put!-kvalue(car u,nil,u,v) else <<if x := assoc(u,y) then <<updoldrules(u,v); y := delasc(car x,y)>>; put!-kvalue(car u,y,u,v)>>; return v end; % symbolic procedure put!-avalue(u,v,w); % if smember(u,w) then recursiveerror u % else put(u,'avalue,{v,w}); symbolic procedure put!-avalue(u,v,w); % This definition allows for an assignment such as a := a 4. if v eq 'scalar then if eqcar(w,'!*sq) and sq_member(u,cadr w) then recursiveerror u else if !*reduce4 then putobject(u,w,'generic) else put(u,'avalue,{v,w}) else if smember(u,w) then recursiveerror u else put(u,'avalue,{v,w}); symbolic procedure sq_member(u,v); sf_member(u,numr v) or sf_member(u,denr v); symbolic procedure sf_member(u,v); null domainp v and (mvar_member(u,mvar v) or sf_member(u,lc v) or sf_member(u,red v)); symbolic procedure mvar_member(u,v); % This and arglist member have to cater for the funny forms we % find in packages like TAYLOR. u = v or (null atom v and arglist_member(u,cdr v)); symbolic procedure arglist_member(u,v); null atom v and (mvar_member(u,car v) or arglist_member(u,cdr v)); % symbolic procedure put!-kvalue(u,v,w,x); % if smember(w,x) then recursiveerror w % else put(u,'kvalue,aconc(v,{w,x})); symbolic procedure put!-kvalue(u,v,w,x); % This definition is needed to allow p(2) := sqrt(1-p^2). if (if eqcar(x,'!*sq) then sq_member(w,cadr x) else smember(w,x)) then recursiveerror w else put(u,'kvalue,aconc(v,{w,x})); symbolic procedure klistt u; if atom u then nil else caar u . klistt cdr carx(u,'list); symbolic procedure kernlp u; % Returns leading domain coefficient if U is a monomial product % of kernels, NIL otherwise. if domainp u then u else if null red u then kernlp lc u else nil; symbolic procedure xadd(u,v,b); % Adds replacement U to table V, with new rule at head. % Note that format of u and v depends on whether a free variable % occurs in the expression or asymplis* is being updated!!. begin scalar x; x := assoc(car u,v); if null x then if b and not(b eq 'replace) then v := u . v else nil else if b then <<v := delete(x,v); if not atom cdr x and length x=5 then x := cdr x; % No free variable. if not atom cdr x % atom is asymplis update. then updoldrules(caddr x,cdadr x); if not(b eq 'replace) then v := u . v>> % else if cadr x=cadr u then v := delete(x,v); else if atom cdr x and cdr x=cdr u or not atom cdr x and cadr x=cadr u then v := delete(x,v); return v end; symbolic procedure updoldrules(v,w); (if null u then nil else oldrules!* := append( (if not atom v and numberp cdr v % asymptotic case. then list list(list('expt,car v,cdr v),0,nil,t) else if atom car u then list list(car u . car v,cadr v,nil,t) else (if car u neq y then list list(car u,y,x,rsubla(x,w)) else nil) where y=rsubla(x,v)), oldrules!*) where x=caddr u) where u=newrule!*; symbolic procedure xadd!*(u,v,b); % Adds replacement U to table V, with new rule at head. % Also checks boolean part for equality. % Note, in an earlier version, we removed all rules in the CLEAR mode % regardless of whether they came from a LET or a MATCH, or had % boolean constraints. However, this made the fps tests not work. begin scalar x,y; x := v; % while x and not(car u=caar x and (cadr u=cadar x or null b)) 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); x := car x; % If this section is entered, then car x and car % newrule!* should be the same. If not, a rule of the % form a+b => c might have occurred, in which case we % need to adjust the form of the replaced value. if b and newrule!* then if car x neq (y := car newrule!*) and powlisp car x then updoldrules(prepsq simp {'plus,y, {'difference,caddr x,'times . for each j in car x collect {'expt,car j,cdr j}}}, cdadr x) else updoldrules(caddr x,cdadr x)>>; if b then v := u . v; return v end; symbolic procedure powlisp u; null u or not atom car u and numberp cdar u and powlisp cdr u; symbolic procedure rsubla(u,v); begin scalar x; if null u or null v then return v else if atom v then return if x:= rassoc(v,u) then car x else v else return(rsubla(u,car v) . rsubla(u,cdr v)) end; endmodule; end;