<<NC`

<<NCAlgebra`

tau::usage="The main variable in unmodified equation";
tildetau::usage="GBDT-modified tau";
r::usage="The greatest power of spectral parameter (z) in G(7.64)";
R::usage="The greatest power of spectral parameter (z) in F(7.65)";
rp::usage="Denote r_s in G (7.64)";
Rp::usage="Denote R_s in F (7.65)";
equation::usage="The expression that equals 0 for the solutions of equation";
dtaut::usage="The expression for the derivative of tau by t, obtained from equation";

listOfVariables={};
listOfConstants={Id,r,z}
SetCommutative[r,z]
r=0
R=0
l=0
rp[x_]=0
Rp[x_]=0
SNC[S,P1,P2star,P1,A1,A2star,A2,tau,tildetau,jot,B,X,Y,q,Q,delta,Delta,rp,Rp,c,d,equation]
B:=NCP[jot,p]
dtaut:={}

f[tau_,n_]:=0;
F[tau_,n_]:=0;
q[n_]:=f[tau,n];
Q[n_]:=F[tau,n];
qtt[n_]:=f[tildetau,n];
Qtt[n_]:=F[tildetau,n];

tauFormulas={
jot**jot:>Id,
jot**tau:>-tau**jot,
jot**d[tau,a_]:>-d[tau, a]**jot,
jot**d[d[tau,a_],b_]:>-d[d[tau,a],b]**jot,
jot**d[d[d[tau,a_],b_],c_]:>-d[d[d[tau,a],b],c]**jot
};

noPole:=Module[{},
ClearAll[chapter7formulas];
chapter7formulas={
d[inv[S],x]:>-inv[S]**d[S,x]**inv[S],
d[inv[S],t]:>-inv[S]**d[S,t]**inv[S],
(*7.16,  simplified no-poles case*)
d[P1,x]:>Sum[NCP[A1,k]**P1**q[k], {k, 0, r}],
(*d[P2,x]:>-Sum[NCP[A2star,k]**P2**qstar[k], {k, 0, r}],*)
d[P2star,x]:>-Sum[q[k]**P2star**NCP[A2,k], {k, 0, r}],
(*7.17, no poles*)
d[S,x]:>
Sum[
Sum[NCP[A1, k-j]**P1**q[k]**P2star**NCP[A2,j-1],{j,k}
], {k,r}
],
(*7.68,no poles*)
d[P1,t]:>
Sum[NCP[A1, k]**P1**Q[k],{k, 0, R}],
(*7.69,no poles*)
d[P2star,t]:>
-Sum[Q[k]**P2star**NCP[A2,k],{k,0, R}],
(*7.70, no poles*)
d[S,t]:>
Sum[
Sum[
NCP[A1,k-j]**P1**Q[k]**P2star**NCP[A2,j-1],{j,k}
],{k, R}
],
(*S-NODE formula*)
NonCommutativeMultiply[a___,A2,inv[S],b___]:>NonCommutativeMultiply[a]**(-inv[S]**P1**P2star**inv[S]+inv[S]**A1)**NonCommutativeMultiply[b]
};
]

multiPole:=Module[{},
ClearAll[chapter7formulas];
chapter7formulas={
d[inv[S],x]:>-inv[S]**d[S,x]**inv[S],
d[inv[S],t]:>-inv[S]**d[S,t]**inv[S],
(*7.53,analogue of 7.16(1)*)
d[P1,x]:>Sum[NCP[A1,k]**P1**q[k],{k,0,r}]+Sum[Sum[NCP[A1-c[s]**Id,-k]**P1**q[s,k],{k,rp[s]}],{s,l}],
(*7.54,analogue of 7.16(2)*)
d[P2star,x]:>-Sum[q[k]**P2star**NCP[A2,k],{k,0,r}]+Sum[Sum[q[s,k]**P2star**NCP[A2-c[s]**Id,-k],{k,rp[s]}],{s,l}],
(*7.55,analogue of 7.17 with poles*)d[S,x]:>Sum[Sum[NCP[A1,k-j]**P1**q[k]**P2star**NCP[A2,j-1],{j,k}],{k,r}]-Sum[Sum[Sum[NCP[A1-c[s],j-k-1]**P1**q[s,k]**P2star**NCP[A2-c[s],-j],{j,k}],{k,rp[s]}],{s,l}],
(*7.68,with poles*)
d[P1,t]:>Sum[NCP[A1,k]**P1**Q[k],{k,0,R}]+Sum[Sum[NCP[A1-C[s]**Id,-k]**P1**Q[s,k],{k,Rp[s]}],{s,L}],
(*7.69,with poles*)
d[P2star,t]:>-Sum[Q[k]**P2star**NCP[A2,k],{k,0,R}]+Sum[Sum[Q[s,k]**P2star**NCP[A2-C[s]**Id,-k],{k,Rp[s]}],{s,L}],
(*7.70,no poles*)
d[S,t]:>Sum[Sum[NCP[A1,k-j]**P1**Q[k]**P2star**NCP[A2,j-1],{j,k}],{k,R}],
(*S-NODE formula*)NonCommutativeMultiply[a___,A2,inv[S],b___]:>NonCommutativeMultiply[a]**(-inv[S]**P1**P2star**inv[S]+inv[S]**A1)**NonCommutativeMultiply[b]
};
]

(*Raising non-commutative elements to power*)
NCP[var_,power_]:=If[power>0,positiveNCPower[var,power],positiveNCPower[inv[var],-power]]
positiveNCPower[var_,power_]:=var**positiveNCPower[var,power-1]
positiveNCPower[var_,1]=var;
positiveNCPower[var_,0]=Id;

d[a__**b_,x_]:=d[NonCommutativeMultiply[a],x]**NonCommutativeMultiply[b]+NonCommutativeMultiply[a]**d[NonCommutativeMultiply[b],x]
d[a_+b_,x_]:=d[a,x]+d[b,x]
d[a_,x_]:=0/;MemberQ[listOfConstants,a]||Element[a, Complexes](*Change to FreeQ[...listOfFunctions...]*)
(*added for cases like d[Ix]*)
d[a__*b_,x_]:=d[NonCommutativeMultiply[a],x]**NonCommutativeMultiply[b]+NonCommutativeMultiply[a]**d[NonCommutativeMultiply[b],x]

(*7.25*)
X[k_]:=P2star**inv[S]**NCP[A1,k]**P1
Y[k_]:=P2star**NCP[A2,k]**inv[S]**P1
(*7.58*)
tildeq[k_]:=q[k]-Sum[q[j]**Y[j-k-1]-X[j-k-1]**q[j]+Sum[X[j-i]**q[j]**Y[i-k-2],{i,k+2,j}],{j,k+1,r}]
tildeQ[k_]:=Q[k]-Sum[Q[j]**Y[j-k-1]-X[j-k-1]**Q[j]+Sum[X[j-i]**Q[j]**Y[i-k-2],{i,k+2,j}],{j,k+1,R}]

Delta[k_]:=Qtt[k]-tildeQ[k]
delta[k_]:=qtt[k]-tildeq[k]

c7e[expr_:expr,rules_:Join[chapter7formulas, tauFormulas,dtaut]]:=Module[{iterOld=0,stepnumber=1,iter=expr},While[iterOld=!=iter,(iterOld=iter;
iter=NCExpand[Substitute[iter,rules]];
Print["Here is the result of the step ",stepnumber,": ",iter];
stepnumber++)];
iter]
(*The error message Optional::opdef is expected!*)

Needs["GUIKit`"]
SetDirectory["//users//sakhnov//Desktop//NCAlg"]
(*SetDirectory["//users//popovych//Work//TestOfFiles//"]*)
<<LaTeXify`

KaupNewell:=Module[{},
ClearAll[f,F,tildetau,dtaut];
p=0;
r=2;
R=4;
f[tau_,n_]:=0;
F[tau_,n_]:=0;
f[tau_,0]:=0;
f[tau_,1]:=-tau;
f[tau_,2]:=I**jot;
F[tau_,0]:=0;
F[tau_,1]:=I**d[tau,x]**jot-tau**tau**tau;
F[tau_,2]:=I**tau**tau**jot;
F[tau_,3]:=-2**tau;
F[tau_,4]:=2**I**jot;
tildetau:=tau+I**(jot**P2star**inv[S]**P1-P2star**inv[S]**P1**jot);
equation[a_]:=d[a,t]+I**d[d[a,x],x]**jot-d[a**a**a,x];
dtaut:={d[tau,t]:>-I**d[d[tau,x],x]**jot+d[tau**tau**tau,x]};
]

test761:=Module[{},
ClearAll[f,F,tildetau,dtaut];
r=5;
R=1;
lhside:=d[P2star**inv[S],x];
rhside:=-Sum[tildeq[k]**P2star**inv[S]**NCP[A1,k],{k,0,r}];
expr:=lhside-rhside;
]

DNLSGI:=Module[{},
ClearAll[f,F,tildetau,dtaut];
p=0;
r=3;
R=5;
(*q and Q are defined in 7.64,7.65*)
f[tau_,n_]:=0;
F[tau_,n_]:=0;
f[tau_,0]:=I**inv[2]**tau**tau**jot;
f[tau_,1]:=-tau;
f[tau_,2]:=I**jot;
F[tau_,0]:=-I**inv[4]**NCP[tau,4]**jot+inv[2]**(tau**d[tau,x]-d[tau,x]**tau);
F[tau_,1]:=I**d[tau,x]**jot;
F[tau_,2]:=I**tau**tau**jot;
F[tau_,3]:=-2**tau;
F[tau_,4]:=2**I**jot;
tildetau:=tau+I**(jot**P2star**inv[S]**P1-P2star**inv[S]**P1**jot);
equation[a_]:=d[a,t]+I**d[d[a,x],x]**jot+I**inv[2]**NCP[a,5]**jot+a**d[a,x]**a;
dtaut:={d[tau,t]:>-(I**d[d[tau,x],x]**jot+I**inv[2]**NCP[tau,5]**jot+tau**d[tau,x]**tau)};
]

KDV:=Module[{},
ClearAll[f,F,tildetau,dtaut];
p=1;
r=3;
R=4;
f[tau_,n_]:=0;
F[tau_,n_]:=0;
f[tau_,0]:=-tau**B;
f[tau_,1]:=-I**jot;
F[tau_,0]:=-(d[d[tau,x],x]**B-(-1)^p**(2**tau**tau**tau**B+d[tau,x]**tau-tau**d[tau,x]))**inv[4];
F[tau_,1]:=I**inv[2]**d[tau,x]**B**jot+(-1)^p**I**inv[2]**tau**tau**jot;
F[tau_,2]:=tau**B;
F[tau_,3]:=I**jot;
tildetau:=tau-(-1)^p**I**(jot**B**P2star**inv[S]**P1-B**P2star**inv[S]**P1**jot);
equation[a_]:=4**d[a,t]-d[d[d[a,x],x],x]+3**(-1)^p**(a**a**d[a,x]+d[a,x]**a**a);
dtaut:={d[tau,t]:>( d[d[d[tau,x],x],x]-3**(-1)^p**(tau**tau**d[tau,x]+d[tau,x]**tau**tau))**inv[4]};
]

Schrodinger:=Module[{},
ClearAll[f,F,tildetau,dtaut];
p=1;
r=2;
R=2;
f[tau_,n_]:=0;
F[tau_,n_]:=0;
f[tau_,0]:=-tau**B;
f[tau_,1]:=-I**jot;
F[tau_,0]:=I**jot**d[tau,x]**B**inv[2]-I**(-1)^p**tau**tau**jot**inv[2];
F[tau_,1]:=-tau**B;
F[tau_,2]:=-I**jot;
tildetau:=tau+I**(jot**B**P2star**inv[S]**P1-B**P2star**inv[S]**P1**jot);
equation[a_]:=d[a,t]-I**d[d[a,x],x]**jot**inv[2]+(-1)^p**I**a**a**a**jot;
dtaut:={d[tau,t]:> I**d[d[tau,x],x]**jot**inv[2]-(-1)^p**I**tau**tau**tau**jot};
]