reduce-historical/r34/lib/pmrules.log

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