pm.tst 4.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213
  1. % Tests of PM.
  2. % TESTS OF BASIC CONSTRUCTS.
  3. operator f, h$
  4. % A "literal" template.
  5. m(f(a),f(a));
  6. % Not literally equal.
  7. m(f(a),f(b));
  8. %Nested operators.
  9. m(f(a,h(b)),f(a,h(b)));
  10. % A "generic" template.
  11. m(f(a,b),f(a,?a));
  12. m(f(a,b),f(?a,?b));
  13. % ??a takes "rest" of arguments.
  14. m(f(a,b),f(??a));
  15. % But ?a does not.
  16. m(f(a,b),f(?a));
  17. % Conditional matches.
  18. m(f(a,b),f(?a,?b _=(?a=?b)));
  19. m(f(a,a),f(?a,?b _=(?a=?b)));
  20. % "plus" is symmetric.
  21. m(a+b+c,c+?a+?b);
  22. %It is also associative.
  23. m(a+b+c,c+?a);
  24. % Note the effect of using multi-generic symbol is different.
  25. m(a+b+c,c+??c);
  26. %Flag h as associative.
  27. flag('(h),'assoc);
  28. m(h(a,b,d,e),h(?a,d,?b));
  29. % Substitution tests.
  30. s(f(a,b),f(a,?b)->?b^2);
  31. s(a+b,a+b->a*b);
  32. % "associativity" is used to group a+b+c in to (a+b) + c.
  33. s(a+b+c,a+b->a*b);
  34. % Only substitute top at top level.
  35. s(a+b+f(a+b),a+b->a*b,inf,0);
  36. % SIMPLE OPERATOR DEFINITIONS.
  37. % Numerical factorial.
  38. operator nfac$
  39. s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},1);
  40. s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},2);
  41. si(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});
  42. % General factorial.
  43. operator gamma,fac;
  44. fac(?x _=Natp(?x)) ::- ?x*fac(?x-1);
  45. fac(0) :- 1;
  46. fac(?x) :- Gamma(?x+1);
  47. fac(3);
  48. fac(3/2);
  49. % Legendre polynomials in ?x of order ?n, ?n a natural number.
  50. operator legp;
  51. legp(?x,0) :- 1;
  52. legp(?x,1) :- ?x;
  53. legp(?x,?n _=natp(?n))
  54. ::- ((2*?n-1)*?x*legp(?x,?n-1)-(?n-1)*legp(?x,?n-2))/?n;
  55. legp(z,5);
  56. legp(a+b,3);
  57. legp(x,y);
  58. % TESTS OF EXTENSIONS TO BASIC PATTERN MATCHER.
  59. comment *: MSet[?exprn,?val] or ?exprn ::: ?val
  60. assigns the value ?val to the projection ?exprn in such a way
  61. as to store explicitly each form of ?exprn requested. *;
  62. Nosimp('mset,(t t));
  63. Newtok '((!: !: !: !-) Mset);
  64. infix :::-;
  65. precedence Mset,RSetd;
  66. ?exprn :::- ?val ::- (?exprn ::- (?exprn :- ?val ));
  67. scs := sin(?x)^2 + Cos(?x)^2 -> 1;
  68. % The following pattern substitutes the rule sin^2 + cos^2 into a sum of
  69. % such terms. For 2n terms (ie n sin and n cos) the pattern has a worst
  70. % case complexity of O(n^3).
  71. operator trig,u;
  72. trig(?i) :::- Ap(+, Ar(?i,sin(u(?1))^2+Cos(u(?1))^2));
  73. if si(trig 1,scs) = 1 then write("Pm ok") else Write("PM failed");
  74. if si(trig 10,scs) = 10 then write("Pm ok") else Write("PM failed");
  75. % The next one takes about 70 seconds on an HP 9000/350, calling UNIFY
  76. % 1927 times.
  77. % if si(trig 50,scs) = 50 then write("Pm ok") else Write("PM failed");
  78. % Hypergeometric Function simplification.
  79. newtok '((!#) !#);
  80. flag('(#), 'symmetric);
  81. operator #,@,ghg;
  82. xx := ghg(4,3,@(a,b,c,d),@(d,1+a-b,1+a-c),1);
  83. S(xx,sghg(3));
  84. s(ws,sghg(2));
  85. yy := ghg(3,2,@(a-1,b,c/2),@((a+b)/2,c),1);
  86. S(yy,sghg(1));
  87. yy := ghg(3,2,@(a-1,b,c/2),@(a/2+b/2,c),1);
  88. S(yy,sghg(1));
  89. % Some Ghg theorems.
  90. flag('(@), 'symmetric);
  91. % Watson's Theorem.
  92. SGhg(1) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=(1+?a+?b)/2,?e _=?e=2*?c),1) ->
  93. Gamma(1/2)*Gamma(?c+1/2)*Gamma((1+?a+?b)/2)*Gamma((1-?a-?b)/2+?c)/
  94. (Gamma((1+?a)/2)*Gamma((1+?b)/2)*Gamma((1-?a)/2+?c)
  95. *Gamma((1-?b)/2+?c));
  96. % Dixon's theorem.
  97. SGhg(2) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=1+?a-?b,?e _=?e=1+?a-?c),1) ->
  98. Gamma(1+?a/2)*Gamma(1+?a-?b)*Gamma(1+?a-?c)*Gamma(1+?a/2-?b-?c)/
  99. (Gamma(1+?a)*Gamma(1+?a/2-?b)*Gamma(1+?a/2-?c)*Gamma(1+?a-?b-?c));
  100. SGhg(3) := Ghg(?p,?q,@(?a,??b),@(?a,??c),?z)
  101. -> Ghg(?p-1,?q-1,@(??b),@(??c),?z);
  102. SGhg(9) := Ghg(1,0,@(?a),?b,?z ) -> (1-?z)^(-?a);
  103. SGhg(10) := Ghg(0,0,?a,?b,?z) -> E^?z;
  104. SGhg(11) := Ghg(?p,?q,@(??t),@(??b),0) -> 1;
  105. % If one of the bottom parameters is zero or a negative integer the
  106. % hypergeometric functions may be singular, so the presence of a
  107. % functions of this type causes a warning message to be printed.
  108. % Note it seems to have an off by one level spec., so this may need
  109. % changing in future.
  110. %
  111. % Reference: AS 15.1; Slater, Generalized Hypergeometric Functions,
  112. % Cambridge University Press,1966.
  113. s(Ghg(3,2,@(a,b,c),@(b,c),z),SGhg(3));
  114. si(Ghg(3,2,@(a,b,c),@(b,c),z),{SGhg(3),Sghg(9)});
  115. S(Ghg(3,2,@(a-1,b,c),@(a-b,a-c),1),sghg 2);
  116. end;