reduce-historical/r37/packages/defint/defint0.red

module defint0;  % Rules for definite integration.

global '(unknown_tst product_tst transform_tst transform_lst);

transform_lst := '();

fluid '(!*precise);

global '(spec_cond);

symbolic smacro procedure mynumberp(n);

begin; if numberp n then t

else if listp n and car n = 'quotient and (numberp cadr n or 
mynumberp cadr n) and (numberp caddr n or mynumberp caddr n) then 't

else if listp n and car n = 'sqrt and (numberp cadr n or cadr n = 'pi)
	 then t else nil;
end;

symbolic operator mynumberp;


put('intgggg,'simpfn,'simpintgggg);

% put('defint,'psopfn,'new_defint);

symbolic procedure new_defint(lst);
   begin scalar var,result,n1,n2,n3,n4,!*precise;
      if eqcar(car lst,'times)
	then return new_defint append(cdar lst,cdr lst);
      unknown_tst := nil;
      var := nth(lst,length lst);
      if length lst = 2 and listp car lst then
	      lst := test_prod(lst,var);
      transform_tst := reval algebraic(transform_tst);
      if transform_tst neq t then lst := hyperbolic_test(lst);
      for each i in lst do specfn_test(i);
      if length lst = 5 then
	 <<n1 := car lst;
	   n2 := cadr lst;
	   n3 := caddr lst;
	   n4 := cadddr lst;
	   result := reval algebraic defint2(n1,n2,n3,n4,var)>>
      else if length lst = 4 then
	 <<n1 := car lst;
	   n2 := cadr lst;
	   n3 := caddr lst;
	   result := reval algebraic defint2(n1,n2,n3,var)>>
      else if length lst = 3 then
	 <<n1 := car lst;
	   n2 := cadr lst;
	   result := reval algebraic defint2(n1,n2,var)>>
      else if length lst = 2 then
	 <<n1 := car lst;
	   result := reval algebraic defint2(n1,var)>>;
      algebraic(transform_tst := nil);
      if pairp result then <<for each i in result do test_unknown(i);
	     % Tidy up result by ensuring that just unknown is returned
	     % and not multiples of it.
	    if unknown_tst then return 'UNKNOWN else return result>>
       else return result
   end;

symbolic procedure specfn_test(n);

begin;
if listp n and car n = 'times then
<< if listp caddr n and (car caddr n = 'm_gegenbauerp or 
      	       	     	   car caddr n = 'm_jacobip)
    then off exp; >>;
end;

symbolic procedure test_prod(lst,var);

begin scalar temp,ls;

temp := caar lst;

if temp = 'times then
   << if listp caddar lst then

% test for special cases of Meijer G-functions of compoud functions 

      << if car caddar lst neq 'm_chebyshevt and 
      	    car caddar lst neq 'm_chebyshevu and 
	    car caddar lst neq 'm_gegenbauerp and  
	    car caddar lst neq 'm_jacobip then
            ls := append(cdar lst,{var})

%else returned without change
         else ls := lst;>>
      else ls := append(cdar lst,{var});
   >>

else if temp = 'minus and caadar lst = 'times then
<< if length cadar lst = 3 then 
      ls := {{'minus,car cdadar lst},cadr cdadar lst,var}
   else if length cadar lst = 4 then 
      ls := {{'minus,car cdadar lst},cadr cdadar lst,
	       	     	      	       	     caddr cdadar lst,var}>>
else ls := lst;
return ls;
end;

symbolic procedure test_unknown(n);

% A procedure to test for unknown as the result of the integration 
% process 

if pairp n then << for each i in n do test_unknown(i)>>
else if n = 'unknown then unknown_tst := 't;

algebraic<<
heaviside_rules := 

{ heaviside(~x) => 1 when numberp x and x >= 0,
  heaviside(~x) => 0 when numberp x and x < 0 };

let heaviside_rules;

operator defint2,defint_choose;

SHARE MELLINCOEF$

defint2_rules:=

{ defint2(~n,cos((~x*~~A)/~~C)-cos((~x*~~B)/~~D),~x) =>
                defint2(-2,n,sin((A/C+B/D)*x/2),sin((A/C-B/D)*x/2),x),
  defint2(cos((~x*~~A)/~~C)-cos((~x*~~B)/~~D),~x) =>
                defint2(-2,sin((A/C+B/D)*x/2),sin((A/C-B/D)*x/2),x),

  defint2(~b,~f1,~f2,~x) => b*defint2(f1,f2,x) when freeof (b,x),

  defint2(~~b*~f1,~~c*~f2,~x) => b*c*defint2(f1,f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~b/~f1,~c/~f2,~x) => c*b*defint2(1/f1,1/f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~~b*~f1,~c/~f2,~x) => c*b*defint2(f1,1/f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~b/~f1,~~c*~f2,~x) => c*b*defint2(1/f1,f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~f1/~~b,~~c*~f2,~x) => c/b*defint2(f1,f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~b/~f1,~x) => b*defint2(1/f1,x)
	when freeof (b,x) and not(b = 1),

  defint2(~~b*~f1,~x) => b*defint2(f1,x)
        when freeof (b,x) and not(b = 1),

  defint2(~f1/~~b,~x) => 1/b*defint2(f1,x)
        when freeof (b,x) and not(b = 1),

  defint2((~f2+ ~~f1)/~~f3,~x) => defint2(f2/f3,x) + defint2(f1/f3,x)
			when not(f1=0),
  defint2(-~f1,~x) =>  - defint2(f1,x),
  defint2((~f2+ ~~f1)/~~f3,~n,~x) =>
		 defint2(f2/f3,n,x) + defint2(f1/f3,n,x)
		when not(f1=0),
  defint2(-~f1,~n,~x) =>  - defint2(f1,n,x),
  defint2(~n,(~f2+ ~~f1)/~~f3,~x) =>
		 defint2(n,f2/f3,x) + defint2(n,f1/f3,x)
		when not(f1=0),
  defint2(~n,-~f1,~x) =>  - defint2(n,f1,x),
  defint2(~n,(~f2+ ~~f1)/~~f3,~nn,~x) =>
                 defint2(n,f2/f3,nn,x) + defint2(n,f1/f3,nn,x)
		when not(f1=0),
  defint2(~n,-~f1,~nn,~x) =>  - defint2(n,f1,nn,x),
  defint2(~n,~nn,(~f2+ ~~f1)/~~f3,~x) =>
                 defint2(n,nn,f2/f3,x) + defint2(n,nn,f1/f3,x)
		when not(f1=0),
  defint2(~n,~nn,-~f1,~x) =>  - defint2(n,nn,f1,x),

  defint2(~n,~x^~a,~f1,~f2,~x) => 
     	      	 n*intgggg(defint_choose(f1,x),defint_choose(f2,x),a,x)
   when numberp n ,

  defint2(~n,~x,~f1,~f2,~x) =>
                 n*intgggg(defint_choose(f1,x),defint_choose(f2,x),1,x)
   when numberp n ,
  defint2(~n,1/~x^~~a,~f1,~f2,~x) =>
     	      	 n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-a,x)
   when numberp n ,
  defint2(~n,1/~x,~f1,~f2,~x) => 
     	      	n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1,x)
   when numberp n ,
  defint2(~n,sqrt(~x),~f1,~f2,~x) => 
     	      	n*intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2,x)
   when numberp n ,
  defint2(~n,sqrt(~x)*~x,~f1,~f2,~x) => 
     	      	n*intgggg(defint_choose(f1,x),defint_choose(f2,x),3/2,x)
   when numberp n ,
  defint2(~n,sqrt(~x)*~x^~a,~f1,~f2,~x) => 
	      n*intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2+a,x)
   when numberp n ,
  defint2(~n,1/sqrt(~x),~f1,~f2,~x) => 
	       n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2,x)
   when numberp n ,
  defint2(~n,1/(sqrt(~x)*~x),~f1,~f2,~x) => 
	       n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-3/2,x)
   when numberp n ,
  defint2(~n,1/(sqrt(~x)*~x^~a),~f1,~f2,~x) =>
	     n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2-a,x)
   when numberp n ,

  defint2(~n,1/~x,~f1,~x) => n*intgggg(defint_choose(f1,x),0,-1,x)
   when numberp n ,
  defint2(~n,1/~x^(~a),~f1,~x) => n*intgggg(defint_choose(f1,x),0,-a,x)
   when numberp n ,
  defint2(~n,1/sqrt(~x),~f1,~x) =>
		 n*intgggg(defint_choose(f1,x),0,-1/2,x) when numberp n,
  defint2(~n,1/(sqrt(~x)*~x),~f1,~x) => 
     	      	 n*intgggg(defint_choose(f1,x),0,-3/2,x)
   when numberp n ,
  defint2(~n,1/(sqrt(~x)*~x^~a),~f1,~x) =>
     	      	 n*intgggg(defint_choose(f1,x),0,-1/2-a,x)
   when numberp n ,
  defint2(~n,~x**(~a),~f1,~x) => n*intgggg(defint_choose(f1,x),0,a,x)
   when numberp n ,
  defint2(~n,~x,~f1,~x) => n*intgggg(defint_choose(f1,x),0,1,x)
   when numberp n ,
  defint2(~n,sqrt(~x),~f1,~x) => n*intgggg(defint_choose(f1,x),0,1/2,x)
    when numberp n ,
 defint2(~n,sqrt(~x)*~x,~f1,~x) =>
    n*intgggg(defint_choose(f1,x),0,3/2,x)
   when numberp n ,
  defint2(~n,sqrt(~x)*~x^~a,~f1,~x) => 
     	      	n*intgggg(defint_choose(f1,x),0,1/2+a,x)
   when numberp n ,

  defint2(~~b*~x^~~a/~~c,~f1,~f2,~x) =>
	b/c*intgggg(defint_choose(f1,x),defint_choose(f2,x),a,x)
			when freeof(b,x) and freeof (c,x),
  defint2(~b/(~~c*~x^~~a),~f1,~f2,~x) =>
        b/c*intgggg(defint_choose(f1,x),defint_choose(f2,x),-a,x)
			when freeof(b,x) and freeof(c,x),
  defint2(sqrt(~x),~f1,~f2,~x) => 
     	        intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2,x),
  defint2(sqrt(~x)*~x^~~a,~f1,~f2,~x) => 
	       intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2+a,x),
  defint2(~b/(~~c*sqrt(~x)),~f1,~f2,~x) => 
	    b/c*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2,x),
  defint2(1/(sqrt(~x)*~x^~~a),~f1,~f2,~x) =>
      intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2-a,x),

  defint2(1/~x^(~~a),~f1,~x) => intgggg(defint_choose(f1,x),0,-a,x),
  defint2(1/sqrt(~x),~f1,~x) => intgggg(defint_choose(f1,x),0,-1/2,x),
  defint2(1/(sqrt(~x)*~x^~~a),~f1,~x) =>
      	       	intgggg(defint_choose(f1,x),0,-1/2-a,x),
  defint2(~x**(~~a),~f1,~x) => intgggg(defint_choose(f1,x),0,a,x),
  defint2(sqrt(~x),~f1,~x) => intgggg(defint_choose(f1,x),0,1/2,x),
  defint2(sqrt(~x)*~x^~~a,~f1,~x) =>
		 intgggg(defint_choose(f1,x),0,1/2+a,x),

  defint2(~b,~f1,~x) => b*defint2(f1,x) when freeof(b,x),
  defint2(~f1,~f2,~x) => 
	intgggg(defint_choose(f1,x),defint_choose(f2,x),0,x),

  defint2(~n,~f1,~x) => n*intgggg(defint_choose(f1,x),0,0,x),

  defint2(~f1,~x) => intgggg(defint_choose(f1,x),0,0,x),

  defint2((~f1-~f2)/~f3,~f4,~x) => 
     	      	       	     defint2(f1/f3,f4,x) - defint2(f2/f3,f4,x),
  defint2(-~b,~f1,~f2,~x) => -b*defint2(f1,f2,x) when freeof(b,x)

};

let defint2_rules;
>>;
endmodule;
end;