Artifact f3e4492c1d13a142cd8c01b8540044532e40f78e8eaa73732318ae7e7a85c6f5:
- Executable file
r38/packages/alg/showrule.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: 7428) [annotate] [blame] [check-ins using] [more...]
module showrule; % Display rules for an operator. % Author: Herbert Melenk, ZIB, Berlin. E-mail: melenk@zib.de. % Copyright (c) 1992 ZIB Berlin. All rights reserved. % Modified by: Francis J. Wright <F.J.Wright@Maths.QMW.ac.uk> % Time-stamp: <10 November 1998> % $Id: showrule.red 1.2 1998-11-10 08:33:09+00 fjw Exp $ global '(!*match); fluid '(asymplis!* powlis!*); % All let-rules for an operator are collected as rule set. % Usage in algebraic mode: % e.g. SHOWRULES SIN; % The rules for exponentiation can be listed by % SHOWRULES EXPT; symbolic procedure showrules opr; begin scalar r; r := showruleskvalue opr; r:=append(r,showrulesopmtch opr); r:=append(r,showrules!*match opr); r:=append(r,showrulesdfn opr); if opr eq 'expt then <<r:=append(r,showrulespowlis!*()); r:=append(r,showrulespowlis1!*()); r:=append(r,showrulesasymplis!*())>> else %% FJW: Show rules for powers of opr: <<r:=append(r,showrulespowlis!*opr opr); r:=append(r,showrulespowlis1!*opr opr); r:=append(r,showrulesasymplis!*opr opr)>>; return 'list.r; end; symbolic procedure showruleskvalue opr; for each rule in get(opr,'kvalue) collect begin scalar pattern, vars, target; pattern := car rule; vars := selectletvars pattern; vars := arbvars vars; pattern := subla(vars,pattern); target := cadr rule; target := subla(vars,target); return mkrule(nil,pattern,target) end; symbolic procedure showonerule(test,pattern,target); % central routine produces one rule. begin scalar vars; vars := selectletvars pattern; vars := arbvars vars; pattern := subla(vars,pattern); test := subla(vars,test); target := subla(vars,target); test := simpletsymbolic test; if test=t then test:=nil; %% target := simpletsymbolic target; %% FJW: mangles lists in target, e.g. for hypergeometric, but %% not applying simpletsymbolic might not be the right fix! return mkrule(test,pattern,target) end; symbolic procedure showrulesopmtch opr; for each rule in get(opr,'opmtch) collect showonerule(cdadr rule,opr . car rule,caddr rule); symbolic procedure showrulesdfn opr; append(showrulesdfn1 opr, showrulesdfn2 opr); symbolic procedure showrulesdfn1 opr; for i:=1:5 join showrulesdfn1!*(opr,i); symbolic procedure showrulesdfn1!*(opr,n); % simple derivatives begin scalar dfn,pl,rule,pattern,target; dfn:=dfn_prop(for j:=0:n collect j); if(pl:=get(opr,dfn)) then return for j:=1:n join if (rule:=nth(pl,j)) then << pattern := car rule; pattern := {'df,opr . pattern,nth(pattern,j)}; target := cdr rule; {showonerule(nil,pattern,target)} >>; end; symbolic procedure mkrule(c,a,b); <<b:=strip!~ b; c:=strip!~ c; {'replaceby,separate!~ a,if c then {'when,b,c} else b}>>; symbolic procedure strip!~ u; if null u then u else if idp u then (if eqcar(w,'!~) then intern compress cdr w else u) where w=explode2 u else if atom u then u else if car u = '!~ then strip!~ cadr u else strip!~ car u . strip!~ cdr u; symbolic procedure separate!~ u; if null u or u='!~ then u else if idp u then (if eqcar(w,'!~) then {'!~,intern compress cdr w} else u) where w=explode2 u else if atom u then u else separate!~ car u . separate!~ cdr u; symbolic procedure showrulesdfn2 opr; % collect possible rules from df for each rule in get('df,'opmtch) join if eqcar(caar rule,opr) then {showonerule(cdadr rule,'df . car rule,caddr rule)}; symbolic procedure showrules!*match opr; for each rule in !*match join if smember(opr,rule) then begin scalar pattern,target,test,p1,p2; pattern := car rule; p1 := car pattern; p2 := cadr pattern; pattern := list('times,prepsq !*p2q p1, prepsq !*p2q p2); test := cdadr rule; target := caddr rule; return {showonerule(test,pattern,target)} end; symbolic procedure showrulespowlis!*(); for each rule in powlis!* collect begin scalar pattern,target; pattern := list ('expt,car rule,cadr rule); target := cadddr rule; return mkrule(nil,pattern,target); end; symbolic procedure showrulespowlis1!*(); for each rule in powlis1!* collect begin scalar pattern,target,test,p1,p2; pattern := car rule; p1 := car pattern; p2 := cdr pattern; pattern := list ('expt, p1, p2); test := cdadr rule; target := caddr rule; return showonerule(test,pattern,target); end; symbolic procedure showrulesasymplis!*(); for each rule in asymplis!* collect mkrule(nil,{'expt,car rule,cdr rule},0); symbolic procedure showrulespowlis!*opr opr; %% FJW: Pick rules in powlis!* for operator opr: for each rule in powlis!* join if eqcar(car rule, opr) then begin scalar pattern,target; pattern := list ('expt,car rule,cadr rule); target := cadddr rule; return mkrule(nil,pattern,target) . nil end; symbolic procedure showrulespowlis1!*opr opr; %% FJW: Pick rules in powlis1!* for operator opr: for each rule in powlis1!* join if eqcar(caar rule, opr) then begin scalar pattern,target,test,p1,p2; pattern := car rule; p1 := car pattern; p2 := cdr pattern; pattern := list ('expt, p1, p2); test := cdadr rule; target := caddr rule; return showonerule(test,pattern,target) . nil end; symbolic procedure showrulesasymplis!*opr opr; %% FJW: Pick rules in asymplis!* for operator opr: for each rule in asymplis!* join if eqcar(car rule, opr) then mkrule(nil,{'expt,car rule,cdr rule},0) . nil; symbolic procedure selectletvars u; if null u then nil else if memq(u,frlis!*) then {u} else if atom u then nil else union (selectletvars car u, selectletvars cdr u); symbolic procedure simpletsymbolic u; if atom u then u else if car u eq 'quote then simpletsymbolic cadr u else if car u memq '(aeval reval revalx boolvalue!*) then if needs!-lisp!-tag cadr u then {'symbolic,simpletsymbolic cadr u} else simpletsymbolic cadr u else if car u eq 'list then simpletsymbolic cdr u else if isboolfn car u then simpletsymbolic (isboolfn car u . cdr u) else simpletsymbolic car u . simpletsymbolic cdr u; symbolic procedure needs!-lisp!-tag u; if numberp u then nil else if atom u then t else if car u memq '(aeval reval revalx boolvalue!* quote) then nil else if car u eq 'list then needs!-lisp!-tag1 cdr u else if car u eq 'cons then needs!-lisp!-tag cadr u or needs!-lisp!-tag caddr u else t; symbolic procedure needs!-lisp!-tag1 u; if null u then nil else needs!-lisp!-tag car u or needs!-lisp!-tag1 cdr u; fluid '(bool!-functions!*); bool!-functions!* := for each x in {'equal,'greaterp,'lessp,'geq,'leq,'neq,'numberp} collect get(x,'boolfn).x; symbolic procedure isboolfn u; if idp u and (u:=assoc(u,bool!-functions!*)) then cdr u; symbolic procedure arbvars vars; for each var in vars collect var . {'!~, intern compress cddr explode var}; symbolic operator showrules; endmodule; end;