Artifact c1fbdb91be70aeb491cb38b56ebf9c41f825d0275ef766c35e0c37e3be992937:
- Executable file
r37/packages/defint/definth.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: 6834) [annotate] [blame] [check-ins using] [more...]
module definth; fluid '(mellin!-transforms!* mellin!-coefficients!*); algebraic << operator indefint2; indefint2_rules := { indefint2((~f1+~~f2)/~~f3,~x,~y) => indefint2(f1/f3,x,y)+indefint2(f2/f3,x,y) when not(f2=0), indefint2(~n,~f1-~f2,~x,~y) => indefint2(n,f1,x,y)-indefint2(n,f2,x,y), indefint2(~n,~f1+~f2,~x,~y) => indefint2(n,f1,x,y)+indefint2(n,f2,x,y), indefint2(1/~x^(~~a),~f,~x,~y) => transf(defint_choose(f,x),-a,y,x), indefint2(~x^(~~b)*sqrt(~x),~f,~x,~y) => transf(defint_choose(f,x),b+1/2,y,x), indefint2(sqrt(~x),~f,~x,~y) => transf(defint_choose(f,x),1/2,y,x), indefint2(~x^(~~a),~f,~x,~y) => transf(defint_choose(f,x),a,y,x), indefint2(~b*~ff,~f,~x,~y) => b*indefint2(ff,f,x,y) when freeof (b,x), indefint2(~b/(~~c*~ff),~f,~x,~y) => b/c*indefint2(1/ff,f,x,y) when freeof (b,x) and freeof (c,x) and not(b=1 and c=1), indefint2(~ff/~b,~f,~x,~y) => 1/b*indefint2(ff,f,x,y) when freeof (b,x), indefint2(~b*~ff,~f,~x,~y) => b*indefint2(ff,f,x,y) when freeof (b,x), indefint2(~ff/~b,~f,~x,~y) => 1/b*indefint2(ff,f,x,y) when freeof (b,x), indefint2(~~b,~f,~x,~y) => b*indefint2(f,x,y) when freeof (b,x) and not(b=1), indefint2(~f,~x,~y) => transf(defint_choose(f,x),0,y,x) }; let indefint2_rules; symbolic procedure simpinteg(u); begin scalar ff1,alpha,y,var,chosen_num,coef,!*uncached; !*uncached := t; ff1 := prepsq simp car u; if ff1 = 'UNKNOWN then return simp 'UNKNOWN; alpha := cadr u; y := caddr u; var := cadddr u; chosen_num := cadr ff1; if chosen_num = 0 then << alpha := caddr ff1; return simp reval algebraic(alpha*y)>> else << put('f1,'g,getv(mellin!-transforms!*,chosen_num)); coef := getv(mellin!-coefficients!*,chosen_num); if coef then MELLINCOEF:= coef else MELLINCOEF :=1; return simp list('new_mei,'f1 . cddr ff1,alpha,y,var)>>; end$ put('new_mei,'simpfn,'new_meijer)$ symbolic procedure new_meijer(u); begin scalar f,y,mellin,new_mellin,m,n,p,q,old_num,old_denom,temp,a1, b1,a2,b2,alpha,num,denom,n1,temp1,temp2,coeff,v,var,new_var,new_y, new_v,k; f := prepsq simp car u; y := caddr u; mellin := bastab(car f,cddr f); temp := car cddddr mellin; var := cadr f; if not idp VAR then RETURN error(99,'FAIL); % something is rotten, if not... % better give up temp := reval algebraic(sub(x=var,temp)); mellin := {car mellin,cadr mellin,caddr mellin,cadddr mellin,temp}; temp := reduce_var(cadr u,mellin,var); alpha := simp!* car temp; new_mellin := cdr temp; if car cddddr new_mellin neq car cddddr mellin then << k := car cddddr mellin; y := reval algebraic(sub(var=y,k)); new_y := simp y>> else << new_var := car cddddr new_mellin; new_y := simp reval algebraic(sub(x=y,new_var))>>; n1 := addsq(alpha,'(1 . 1)); temp1 := {'expt,y,prepsq n1}; temp2 := cadddr new_mellin; coeff := simp!* reval algebraic(temp1*temp2); m := caar new_mellin; n := cadar new_mellin; p := caddar new_mellin; q := car cdddar new_mellin; old_num := cadr new_mellin; old_denom := caddr new_mellin; for i:=1 :n do << if old_num = nil then a1 := append(a1,{simp!* old_num }) else << a1 := append(a1,{simp!* car old_num}); old_num := cdr old_num>>; >>; for j:=1 :m do << if old_denom = nil then b1 := append(b1,{simp!* old_denom }) else << b1 := append(b1,{simp!* car old_denom}); old_denom := cdr old_denom>>; >>; a2 := listsq old_num; b2 := listsq old_denom; if a1 = nil and a2 = nil then num := list({negsq alpha}) else if a2 = nil then num := list(append(a1,{negsq alpha})) else << num := append(a1,{negsq alpha}); num := append({num},a2)>>; if b1 = nil and b2 = nil then denom := list({subtrsq(negsq alpha,'(1 . 1))}) else if b2 = nil then denom := list(b1,subtrsq(negsq alpha,'(1 . 1))) else << denom := list(b1,subtrsq(negsq alpha,'(1 . 1))); denom := append(denom,b2)>>; v := gfmsq(num,denom,new_y); if v = 'fail then return simp 'fail else v := prepsq v; if eqcar(v,'meijerg) then new_v := v else new_v := simp v; return multsq(new_v,coeff); end$ symbolic procedure reduce_var(u,v,var1); % Reduce Meijer G functions of powers of x to x begin scalar var,m,n,coef,alpha,beta,alpha1,alpha2,expt_flag,k,temp1, temp2,const,new_k; var := car cddddr(v); beta := 1; % If the Meijer G-function is is a function of a variable which is not % raised to a power then return initial function if length var = 0 then return u . v else << k := u; coef := cadddr v; for each i in var do << if listp i then << if car i = 'expt then << alpha := caddr i; expt_flag := 't>> else if car i = 'sqrt then << beta := 2; alpha := 1; expt_flag := 't>> else if car i = 'times then << temp1 := cadr i; temp2 := caddr i; if listp temp1 then << if car temp1 = 'sqrt then << beta := 2; alpha1 := 1; expt_flag := 't>> else if car temp1 = 'expt and listp caddr temp1 then << beta := cadr cdaddr temp1; alpha1 := car cdaddr temp1; expt_flag := 't>>; >>; if listp temp2 and car temp2 = 'expt then << alpha2 := caddr temp2; expt_flag := 't>>; if alpha1 neq 'nil then alpha := reval algebraic(alpha1 + beta*alpha2) else alpha := alpha2; >>; >> else << if i = 'expt then << alpha := caddr var; expt_flag := 't>>; >>; >>; % If the Meijer G-function is is a function of a variable which is not % raised to a power then return initial function if expt_flag = nil then return u . v % Otherwise reduce the power by using the following formula :- % % y (c*y)^(m/n) % / / % | n | % |t^k*F((c*t)^(m/n))dt = --------- |z^[((k + 1)*n - m)/m]*F(z)dz % | m*c^(k+1) | % / / % 0 0 else << if listp alpha then << m := cadr alpha; n := caddr alpha; n := reval algebraic(beta*n)>> else << m := alpha; n := beta>>; const := reval algebraic(sub(var1=1,var)); const := reval algebraic(1/(const^(n/m))); new_k := reval algebraic(((k + 1)*n - m)/m); coef := reval algebraic((n/m)*coef*(const)^(k+1)); var := reval algebraic(var^(n/m)); return {new_k,car v,cadr v, caddr v,coef,var}>>; >>; end$ >>; endmodule; end;