REDUCE 3.4, 15-Jul-91 ...
1:
*** ~ already defined as operator
(PMRULES)
% Tests of PM.
% TESTS OF BASIC CONSTRUCTS.
operator f, h$
% A "literal" template.
m(f(a),f(a));
T
% Not literally equal.
m(f(a),f(b));
%Nested operators.
m(f(a,h(b)),f(a,h(b)));
T
% A "generic" template.
m(f(a,b),f(a,?a));
{?A->B}
m(f(a,b),f(?a,?b));
{?A->A,?B->B}
% ??a takes "rest" of arguments.
m(f(a,b),f(??a));
{??A->[A,B]}
% But ?a does not.
m(f(a,b),f(?a));
% Conditional matches.
m(f(a,b),f(?a,?b _=(?a=?b)));
m(f(a,a),f(?a,?b _=(?a=?b)));
{?A->A,?B->A}
% "plus" is symmetric.
m(a+b+c,c+?a+?b);
{?A->A,?B->B}
%It is also associative.
m(a+b+c,c+?a);
{?A->A + B}
% Note the effect of using multi-generic symbol is different.
m(a+b+c,c+??c);
{??C->[A,B]}
%Flag h as associative.
flag('(h),'assoc);
m(h(a,b,d,e),h(?a,d,?b));
{?A->H(A,B),?B->E}
% Substitution tests.
s(f(a,b),f(a,?b)->?b^2);
2
B
s(a+b,a+b->a*b);
A*B
% "associativity" is used to group a+b+c in to (a+b) + c.
s(a+b+c,a+b->a*b);
A*B + C
% Only substitute top at top level.
s(a+b+f(a+b),a+b->a*b,inf,0);
F(A + B) + A*B
% SIMPLE OPERATOR DEFINITIONS.
% Numerical factorial.
operator nfac$
s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},1);
3*NFAC(2)
s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},2);
6*NFAC(1)
si(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});
6
% General factorial.
operator gamma,fac;
fac(?x _=Natp(?x)) ::- ?x*fac(?x-1);
HOLD(?X*FAC(?X - 1))
fac(0) :- 1;
1
fac(?x) :- Gamma(?x+1);
GAMMA(?X + 1)
fac(3);
6
fac(3/2);
5
GAMMA(---)
2
% Legendre polynomials in ?x of order ?n, ?n a natural number.
operator legp;
legp(?x,0) :- 1;
1
legp(?x,1) :- ?x;
?X
legp(?x,?n _=natp(?n))
::- ((2*?n-1)*?x*legp(?x,?n-1)-(?n-1)*legp(?x,?n-2))/?n;
(2*?N - 1)*?X*LEGP(?X,?N - 1) - (?N - 1)*LEGP(?X,?N - 2)
HOLD(----------------------------------------------------------)
?N
legp(z,5);
4 2
Z*(63*Z - 70*Z + 15)
------------------------
8
legp(a+b,3);
3 2 2 3
5*A + 15*A *B + 15*A*B - 3*A + 5*B - 3*B
---------------------------------------------
2
legp(x,y);
LEGP(X,Y)
% TESTS OF EXTENSIONS TO BASIC PATTERN MATCHER.
comment *: MSet[?exprn,?val] or ?exprn ::: ?val
assigns the value ?val to the projection ?exprn in such a way
as to store explicitly each form of ?exprn requested. *;
Nosimp('mset,(t t));
Newtok '((!: !: !: !-) Mset);
infix :::-;
precedence Mset,RSetd;
?exprn :::- ?val ::- (?exprn ::- (?exprn :- ?val ));
HOLD(?EXPRN::-(?EXPRN:-?VAL))
scs := sin(?x)^2 + Cos(?x)^2 -> 1;
2 2
SCS := SIN(?X) + COS(?X) ->1
% The following pattern substitutes the rule sin^2 + cos^2 into a sum of
% such terms. For 2n terms (ie n sin and n cos) the pattern has a worst
% case complexity of O(n^3).
operator trig,u;
trig(?i) :::- Ap(+, Ar(?i,sin(u(?1))^2+Cos(u(?1))^2));
2 2
HOLD(TRIG(?I):-AP(PLUS,AR(?I,SIN(U(?1)) + COS(U(?1)) )))
if si(trig 1,scs) = 1 then write("Pm ok") else Write("PM failed");
Pm ok
if si(trig 10,scs) = 10 then write("Pm ok") else Write("PM failed");
Pm ok
% The next one takes about 70 seconds on an HP 9000/350, calling UNIFY
% 1927 times.
% if si(trig 50,scs) = 50 then write("Pm ok") else Write("PM failed");
% Hypergeometric Function simplification.
newtok '((!#) !#);
*** # redefined
flag('(#), 'symmetric);
operator #,@,ghg;
xx := ghg(4,3,@(a,b,c,d),@(d,1+a-b,1+a-c),1);
XX := GHG(4,3,@(A,B,C,D),@(D,A - B + 1,A - C + 1),1)
S(xx,sghg(3));
*** SGHG declared operator
GHG(4,3,@(A,B,C,D),@(D,A - B + 1,A - C + 1),1)
s(ws,sghg(2));
GHG(4,3,@(A,B,C,D),@(D,A - B + 1,A - C + 1),1)
yy := ghg(3,2,@(a-1,b,c/2),@((a+b)/2,c),1);
C A + B
YY := GHG(3,2,@(A - 1,B,---),@(-------,C),1)
2 2
S(yy,sghg(1));
C A + B
GHG(3,2,@(A - 1,B,---),@(-------,C),1)
2 2
yy := ghg(3,2,@(a-1,b,c/2),@(a/2+b/2,c),1);
C A + B
YY := GHG(3,2,@(A - 1,B,---),@(-------,C),1)
2 2
S(yy,sghg(1));
C A + B
GHG(3,2,@(A - 1,B,---),@(-------,C),1)
2 2
% Some Ghg theorems.
flag('(@), 'symmetric);
% Watson's Theorem.
SGhg(1) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=(1+?a+?b)/2,?e _=?e=2*?c),1) ->
Gamma(1/2)*Gamma(?c+1/2)*Gamma((1+?a+?b)/2)*Gamma((1-?a-?b)/2+?c)/
(Gamma((1+?a)/2)*Gamma((1+?b)/2)*Gamma((1-?a)/2+?c)
*Gamma((1-?b)/2+?c));
SGHG(1) := GHG(3,2,@(?A,?B,?C),
1 + ?A + ?B
@(?D _= ?D=-------------,?E _= ?E=2*?C),1)->(
2
- ?A - ?B + 2*?C + 1 2*?C + 1
GAMMA(-----------------------)*GAMMA(----------)
2 2
?A + ?B + 1 1
*GAMMA(-------------)*GAMMA(---))/(
2 2
- ?A + 2*?C + 1 - ?B + 2*?C + 1
GAMMA(------------------)*GAMMA(------------------)
2 2
?A + 1 ?B + 1
*GAMMA(--------)*GAMMA(--------))
2 2
% Dixon's theorem.
SGhg(2) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=1+?a-?b,?e _=?e=1+?a-?c),1) ->
Gamma(1+?a/2)*Gamma(1+?a-?b)*Gamma(1+?a-?c)*Gamma(1+?a/2-?b-?c)/
(Gamma(1+?a)*Gamma(1+?a/2-?b)*Gamma(1+?a/2-?c)*Gamma(1+?a-?b-?c));
SGHG(2) := GHG(3,2,@(?A,?B,?C),
@(?D _= ?D=1 + ?A - ?B,?E _= ?E=1 + ?A - ?C),1)->(
?A - 2*?B - 2*?C + 2 ?A + 2
GAMMA(----------------------)*GAMMA(--------)
2 2
*GAMMA(?A - ?B + 1)*GAMMA(?A - ?C + 1))/(
?A - 2*?B + 2 ?A - 2*?C + 2
GAMMA(---------------)*GAMMA(---------------)
2 2
*GAMMA(?A - ?B - ?C + 1)*GAMMA(?A + 1))
SGhg(3) := Ghg(?p,?q,@(?a,??b),@(?a,??c),?z)
-> Ghg(?p-1,?q-1,@(??b),@(??c),?z);
SGHG(3) := GHG(?P,?Q,@(??B,?A),@(?A,??C),?Z)
->GHG(?P - 1,?Q - 1,@(??B),@(??C),?Z)
SGhg(9) := Ghg(1,0,@(?a),?b,?z ) -> (1-?z)^(-?a);
1
SGHG(9) := GHG(1,0,@(?A),?B,?Z)->---------------
?A
( - ?Z + 1)
SGhg(10) := Ghg(0,0,?a,?b,?z) -> E^?z;
?Z
SGHG(10) := GHG(0,0,?A,?B,?Z)->E
SGhg(11) := Ghg(?p,?q,@(??t),@(??b),0) -> 1;
SGHG(11) := GHG(?P,?Q,@(??T),@(??B),0)->1
% If one of the bottom parameters is zero or a negative integer the
% hypergeometric functions may be singular, so the presence of a
% functions of this type causes a warning message to be printed.
% Note it seems to have an off by one level spec., so this may need
% changing in future.
%
% Reference: AS 15.1; Slater, Generalized Hypergeometric Functions,
% Cambridge University Press,1966.
s(Ghg(3,2,@(a,b,c),@(b,c),z),SGhg(3));
GHG(2,1,@(A,B),@(B),Z)
si(Ghg(3,2,@(a,b,c),@(b,c),z),{SGhg(3),Sghg(9)});
1
-------------
A
( - Z + 1)
S(Ghg(3,2,@(a-1,b,c),@(a-b,a-c),1),sghg 2);
A - 2*B - 2*C + 1 A + 1
GAMMA(-------------------)*GAMMA(-------)*GAMMA(A - B)*GAMMA(A - C)
2 2
---------------------------------------------------------------------
A - 2*B + 1 A - 2*C + 1
GAMMA(-------------)*GAMMA(-------------)*GAMMA(A - B - C)*GAMMA(A)
2 2
end;
Quitting