Artifact e88e070b24271733b5030bf1244a8c20b4aa6e14831aa6b15dbce44f6f271291:
- File
r34.1/lib/showrules.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: 12646) [annotate] [blame] [check-ins using] [more...]
- File
r34/lib/showrules.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: 12646) [annotate] [blame] [check-ins using]
module showrules; % Display rules known for an operator. % Author: Herbert Melenk, ZIB, Berlin. E-mail: melenk@sc.zib-berlin.de. % Copyright (c) 1988 ZIB Berlin. All rights reserved. % Revisions: % % 10 Mar 89. Missing declaration for "rule" added to showrulesdfn2. % % 1 Mar 89. Includes differentiation rules in output. Removes % calls to first, second and third. global '(!*match ); fluid '(asymplis!*); % All let-rules for an operator are printed. % Usage in algebraic mode: % e.g. SHOWRULES SIN; % The rules for exponentiation can be listed by % SHOWRULES 'EXPT; symbolic procedure showrules (opr); begin scalar rules,vars,test,svars,target,pattern,!*lower; !*lower := t; for i:=1:72 do prin2 "="; terpri(); for i:=1:72 do prin2 "="; terpri(); prin2 "rules for >>>"; prin2 opr; prin2t "<<<"; showruleskvalue opr; showrulesopmtch opr; showrules!*match opr; showrulesdfn opr; if opr = 'expt then <<showrulespowlis!*(); showrulespowlis1!*(); showrulesasymplis!*()>>; for i:=1:72 do prin2 "="; terpri(); end; symbolic procedure showruleskvalue opr; begin scalar rules,pattern,vars,svars,target; rules := get(opr,'KVALUE); for each rule in rules do << for i:=1:72 do prin2 "-"; terpri(); terpri(); pattern := car rule; vars := selectletvars pattern; svars := for each var in vars collect var . compress cddr explode var; pattern := subla(svars,pattern); target := cadr rule; target := subla (svars,target); prin2!* "let "; mathprint (list('equal, pattern,target)); >>; end; symbolic procedure showrulesopmtch opr; begin scalar rules,pattern,vars,svars,target,test; rules := get(opr,'opmtch); for each rule in rules do showrulesopmtch1 (opr,rule); end; symbolic procedure showrulesopmtch1 (opr,rule); % print one single rule begin scalar rules,pattern,vars,svars,target,test; for i:=1:72 do prin2 "-"; terpri(); terpri(); pattern := car rule; vars := selectletvars pattern; test := cdadr rule; target := caddr rule; svars := for each var in vars collect var . compress cddr explode var; pattern := subla(svars,pattern); test := subla(svars,test); target := subla (svars,target); vars := for each var in svars collect cdr var; svars := vars; test := simpletsymbolic test; target := simpletsymbolic target; prin2 "for all "; while svars do <<prin2 car svars; svars := cdr svars; if svars then prin2 " , ">>; if test and not test = t then <<prin2t " such that "; printest test; terpri (); prin2t "let">> else prin2t " let"; mathprint (list('equal,opr . pattern,target)); end; symbolic procedure showrulesdfn opr; <<showrulesdfn1 opr; showrulesdfn2 opr>>; symbolic procedure showrulesdfn1 opr; % simple derivatives begin scalar rules,pattern,vars,svars,target,test; rules := get(opr,'dfn); for each rule in rules do << for i:=1:72 do prin2 "-"; terpri(); terpri(); pattern := car rule; vars := selectletvars pattern; target := cdr rule; svars := for each var in vars collect var . compress cddr explode var; pattern := subla(svars, append(list('df,opr . pattern) , pattern)); target := subla (svars,target); vars := for each var in svars collect cdr var; svars := vars; target := simpletsymbolic target; prin2 "for all "; while svars do <<prin2 car svars; svars := cdr svars; if svars then prin2 " , ">>; prin2t " let"; mathprint (list('equal,pattern,target)); >>; end; symbolic procedure showrulesdfn2 opr; % collect possible rules from df begin scalar rule,rules; rules := get('df,'opmtch); while rules do <<rule := car rules; rules := cdr rules; if eqcar(caar rule,opr) then showrulesopmtch1 ('df,rule); >>; end; symbolic procedure showrules!*match opr; begin scalar rules,pattern,vars,svars,target,test,p1,p2; for each rule in !*match do if smemb (opr,rule) then << for i:=1:72 do prin2 "-"; terpri(); terpri(); pattern := car rule; p1 := car pattern; p2 := cadr pattern; pattern := list ('times,prepsq !*p2q p1, prepsq !*p2q p2); vars := selectletvars pattern; test := cdadr rule; target := caddr rule; svars := for each var in vars collect var . compress cddr explode var; pattern := subla(svars,pattern); test := subla(svars,test); target := subla (svars,target); vars := for each var in svars collect cdr var; svars := vars; test := simpletsymbolic test; target := simpletsymbolic target; if svars then <<prin2 "for all "; while svars do <<prin2 car svars; svars := cdr svars; if svars then prin2 " , ">>; >>; if test and not test = t then <<prin2t " such that "; printest test; terpri (); prin2t "let">> else prin2t " let"; mathprint (list('equal,pattern,target)); >>; end; symbolic procedure showrulespowlis!*(); begin scalar rules,pattern,vars,svars,target,test; for each rule in powlis!* do << for i:=1:72 do prin2 "-"; terpri(); terpri(); pattern := list ('expt,car rule,cadr rule); target := cadddr rule; prin2t " let"; mathprint (list('equal,pattern,target)); >>; end; symbolic procedure showrulespowlis1!*(); begin scalar rules,pattern,vars,svars,target,test,p1,p2; for each rule in powlis1!* do << for i:=1:72 do prin2 "-"; terpri(); terpri(); pattern := car rule; p1 := car pattern; p2 := cdr pattern; pattern := list ('expt, p1, p2); vars := selectletvars pattern; test := cdadr rule; target := caddr rule; svars := for each var in vars collect var . compress cddr explode var; pattern := subla(svars,pattern); test := subla(svars,test); target := subla (svars,target); vars := for each var in svars collect cdr var; svars := vars; test := simpletsymbolic test; target := simpletsymbolic target; prin2 "for all "; while svars do <<prin2 car svars; svars := cdr svars; if svars then prin2 " , ">>; if test and not test = t then <<prin2t " such that "; printest test; terpri (); prin2t "let">> else prin2t " let"; mathprint (list('equal,pattern,target)); >>; end; symbolic procedure showrulesasymplis!*(); for each rule in asymplis!* do << for i:=1:72 do prin2 "-"; terpri(); terpri(); prin2 " let "; prin2 car rule; prin2 "**"; prin2 cdr rule; prin2t " = 0;" >>; symbolic procedure smemb(opr,ls); if opr = ls then t else if atom ls then nil else smemb(opr,car ls) or smemb(opr,cdr ls); symbolic procedure selectletvars u; if null u then nil else if idp u then begin scalar bus; bus := explode u; if cdr bus and cadr bus = '!= then return list u else return nil; end 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 = 'quote then simpletsymbolic cadr u else if car u = 'aeval then simpletsymbolic cadr u else if car u = 'reval then simpletsymbolic cadr u else if car u = 'list then simpletsymbolic cdr u else if car u = 'cond then 'SHOWCOND . simpletsymbolic cdr u else if isevalfn car u then simpletsymbolic (isevalfn car u . cdr u) else simpletsymbolic car u . simpletsymbolic cdr u; symbolic procedure isevalfn u; if idp u then begin scalar bus,!*lower; bus := explode u; if car bus = 'E and cadr bus = 'V and caddr bus = 'A and cadddr bus = 'L then return intern compress cddddr bus else return nil; end else nil; symbolic procedure printest u; if atom u then <<prin2 " "; prin2 u, prin2 " ">> else if car u = 'NOT then <<prin2 " not("; printest cadr u; prin2 ") ";>> else if car u = 'EQUAL then <<prin2 " ("; printest cadr u; prin2 " = "; printest caddr u; prin2 ") ">> else if car u = 'NEQ then <<prin2 " ("; printest cadr u; prin2 " neq "; printest caddr u; prin2 ") ">> else if car u = 'AND then <<prin2 " ("; u := cdr u; while cdr u do <<printest car u; prin2 " and "; u := cdr u>>; printest car u; prin2 ") ">> else if car u = 'OR then <<prin2 " ("; u := cdr u; while cdr u do <<printest car u; prin2 " or "; u := cdr u>>; printest car u; prin2 ") ">> else if get(car u,'prtch) then <<prin2 " ("; printest cadr u; prin2 get(car u,'prtch) ; printest caddr u; prin2 ") ">> else if length u = 2 then <<prin2 car u; prin2 " "; printest cadr u; >> else <<prin2 " "; prin2 car u; prin2 "("; u := cdr u; while u do <<printest car u; u := cdr u; if u then prin2 ",">>; prin2 ") "; >>; symbolic procedure condprin (u); begin; prin2!* " if "; u := cdr u; maprin caar u; prin2!* " then "; maprin cadar u; u := cdr u; loop: if caar u = t then <<prin2!* " else "; maprin cadar u>> else <<prin2!* " else if "; maprin caar u; prin2!* " then "; maprin cadar u; >>; u := cdr u; if u then goto loop; end; put ('SHOWCOND,'prifn,'condprin); symbolic operator showrules; endmodule; end;