Best Scripts for 4.0
1. Partial derivatives beauty (23.02.10)
rul7[xt_]:=Block[{a}, a=(xt//Head)[[1]]; Which[a//AtomQ, figase="", MatchQ[a,_@_],
figase=a[[1]]//ToString;a=a//Head]; a];
stf[xt_]:= Block[{a,i,k,st}, st=figase<>",";
a=List@@(xt//Head//Head); Do[st=st<>ToString[xt[[i,1]]
],{i,Length[a]},{k,a[[i]]}];st ];
ww := xt:Derivative[__][(yt_/;AtomQ[yt])|_@_][__] :> SB[xt//rul7, xt//stf];
2. Most optimal calculator for Riemann
Do[R[i,k,l,m]=0,{i,0,n},{k,0,n},{l,0,n},{m,0,n}];
Do[R[i,k,l,m]=(D[ng[i,m],x[k],x[l]]+D[ng[k,l],x[i],x[m]]-
D[ng[i,l],x[k],x[m]]-D[ng[k,m],x[i],x[l]])/2+
Sum[ng[n,p](G[k,l,n]G[i,m,p]-G[k,m,n]G[i,l,p]),{p,0,n},{n,0,n}];
,{i,0,2},{k,i+1,3},{l,i,2},{m,Max[k,l+1],3}];
3. Marinochkalapochka
(* don't use: a, b, i, j, k, m, n, ww, at, it, JJ, eq, SS, Bak, zav, sliv, nezav *)
Clear["`*"];
n=6; (* number of terms in eq *)
(* set yuor functions as rules a[1]->... ,b[1]->... , ... *)
JJ={
a[1]->A[2]'[x],
a[2]->B[2]'[x],
a[3]->C[2]'[x],
a[4]->C[2][x] B[2]'[x]-B[2][x] C[2]'[x],
a[5]->A[2][x] C[2]'[x]-C[2][x] A[2]'[x],
a[6]->B[2][x] A[2]'[x]-A[2][x] B[2]'[x],
b[1]->B[3][y] C[3]'[y]-C[3][y] B[3]'[y],
b[2]->C[3][y] A[3]'[y]-A[3][y] C[3]'[y],
b[3]->A[3][y] B[3]'[y]-B[3][y] A[3]'[y],
b[4]->A[3]'[y],
b[5]->B[3]'[y],
b[6]->C[3]'[y]
};
(*JJ={};*) (* unblock for general view *)
ww={at_==it_->StringForm["`` = ``",at,it],
al[it_,at_]->Subscript[\[Alpha],StringForm["````",it,at]],
it_[x]->it,it_[y]->it,
A[it_]->Subscript[a,it],
B[it_]->Subscript[b,it],
C[it_]->Subscript[c,it]};
Print["The original equation, f = f(x), g = g(y)"];
SS=Sum[a[j]b[j],{j,n}];
Print[SS/.JJ//.ww," = 0"];
Print[];
Print["Different equation sets with separated variables"];
(*---------------------- Solving block --------------------------*)
Bak[0] = {Range[n]};
sliv={};
Do[ Bak[k]={};
Do[ Bak[k]=Bak[k]~Union~{Delete[Bak[k-1][[j]],m]},{j,Length[Bak[k-1]]},{m,n-k+1}];
Do[ nezav=Bak[k][[i]];
zav=Range[n]~Complement~nezav;
eq={};
Do[eq=eq~Join~{a[nezav[[j]]]==Sum[al[nezav[[j]],zav[[m]]]*a[zav[[m]]],{m,k}]},{j,n-k}];
Do[eq=eq~Join~{b[zav[[m]]]+Sum[al[nezav[[j]],zav[[m]]]*b[nezav[[j]]],{j,n-k}]==0},{m,k}];
Print[k,".",i,". Basic vectors: ",b/@nezav/.JJ//.ww];
Print[];
Print[eq/.JJ//.ww//TableForm];
Print[];
sliv=sliv~Join~{eq};
,{i,Length[Bak[k]]}]; (* replace this by 1 for short form *)
,{k,n-1}];
(*---------------------------------------------------------------*)
(* k - number of indenpedent vectors *)
(* Bak[k] - list of variants of choosing n-k independent vectors *)
(* i - number of variant of choosing indep. vectors from list Bak[k] *)
(* nezav - list of numbers of indenpedent vectors *)
(* zav - list of dependent vectors *)
(* eq - k,i's set of eq-ns *)
(* sliv - all sets of eq-ns *)
(* JJ - recent functions *)
(* al - separation constants *)
4. (2.0) second derivative equations
wq={A->(a[x[2]]+a[x[3]]),B->(b[x[2]]+b[x[3]]),C->(c[x[2]]+c[x[3]])};
q1=-3*B*C*(a'[x[2]]^2-ep a'[x[3]]^2)+3*(2*B^2+A*C)*(a'[x[2]]*b'[x[2]]-ep a'[x[3]]*b'[x[3]])-6*A*B*(b'[x[2]]^2-ep b'[x[3]]^2)-3*A*B*(a'[x[2]]*c'[x[2]]-
ep a'[x[3]]*c'[x[3]])+3*A^2*(b'[x[2]]*c'[x[2]]-ep b'[x[3]]*c'[x[3]])+2*(-B^2+A*(c[x[2]]+c[x[3]]))*(B*(a''[x[2]]-ep a''[x[3]])-
A*(b''[x[2]]-ep b''[x[3]]))/.wq;
q2=-3*C^2*(a'[x[2]]^2-ep a'[x[3]]^2)+6*B*C*(a'[x[2]]*b'[x[2]]-ep a'[x[3]]*b'[x[3]])-6*A*B*(b'[x[2]]*c'[x[2]]-ep b'[x[3]]*c'[x[3]])+3*A^2*
(c'[x[2]]^2-ep c'[x[3]]^2)+2*(B^2-A*C)*(-(C*(a''[x[2]]-ep a''[x[3]]))+A*(c''[x[2]]-ep c''[x[3]]))/.wq;
q3=-3*B^2*C*a'[x[3]]^2+6*B*(B^2+A*C)*a'[x[3]]*b'[x[3]]-4*A*(2*B^2+A*C)*b'[x[3]]^2+A*(-7*B^2+A*C)*a'[x[3]]*c'[x[3]]+12*A^2*B*b'[x[3]]*c'[x[3]]-
3*A^3*c'[x[3]]^2+(B^2-A*C)*(2(B^2-A*C)*ep*a''[x[2]]-2B^2*a''[x[3]]+4*A*B*b''[x[3]]-2A^2*c''[x[3]]+ep*(3*C*a'[x[2]]^2-6*B*a'[x[2]]*b'[x[2]]+
4*A*b'[x[2]]^2-A*a'[x[2]]*c'[x[2]]))/.wq;
(* you can resolve it, for example, relative a2'',c2'',c3'' *)
s1 = Solve[q1 == 0, a''[x[2]]][[1, 1]];
s2 = Solve[q2 == 0, c''[x[2]]][[1, 1]] /. s1;
s3 = Solve[q3 == 0, c''[x[3]]][[1, 1]] /. s1;
Do[W1[i,k,l,m]=W[i,k,l,m]/.s1/.s2/.s3//FS;Print[i,k,l,m," ",W1[i,k,l,m]//.w],{i,0,2},{k,i+1,3},{l,i,2},{m,Max[k,l+1],3}];
