Pensieve Header: Alexander blobs Results.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\w-Computations"];
<< "AlexanderBlobs-Program.m"

b[r[1,2],r[1,3]] + b[r[1,2],r[2,3]]

b[r[1,2],r[1,3]] + b[r[1,2],r[2,3]] + b[r[1,3],r[2,3]]

ModDegree[4, R[1,2]]

ModDegree[7, R[1,2]**R[1,3]**R[2,3] - R[2,3]**R[1,3]**R[1,2]]

v[0]=0;

d=1; ModDegree[d+1,
Print[
v[d]=v[d-1]+c1 Diag[1,ar[1,2]]+ c2 Diag[1,ar[2,1]]
];
V[d]=DExp[v[d]];
{R4Eqn[V[d]], TwistEqn[V[d]]}
]

Solve[{-1/2-c1+c2==0, 1/2+c1-c2==0}, {c1,c2}]

d=1; ModDegree[d+1,
Print[
v[d]=v[d-1]+c1 Diag[1,ar[1,2]]+ (1/2+c1) Diag[1,ar[2,1]]
];
V[d]=DExp[v[d]];
{R4Eqn[V[d]], TwistEqn[V[d]]}
]

d=2; ModDegree[d+1,
Print[
v[d]=v[d-1]
];
V[d]=DExp[v[d]];
{R4Eqn[V[d]], TwistEqn[V[d]]}
]

d=2; ModDegree[d+1,
Print[
v[d] = (v[d-1] /. c1->-1/4)
];
V[d]=DExp[v[d]];
{R4Eqn[V[d]], TwistEqn[V[d]]}
]

d=3; ModDegree[d+1,
Print[
v[d] = v[d-1]+c21 r12**r12+c22 r12**r21+c23 r21**r12+c24 r21**r21+c25 Diag[h[1],ar[1,2]]+c26 Diag[h[2], ar[1,2]]+c27 Diag[h[1],ar[2,1]]+c28 Diag[h[2],ar[2,1]]
];
V[d]=DExp[v[d]];
{R4Eqn[V[d]], TwistEqn[V[d]]}
] // PullDiags

Solve[{(-(1/48)-c21+c23-c25+c27) ==0, ((1/48)+c23-c24-c26+c28)==0, (-2 c21+c22+c23)==0, (-c22-c23+2 c24)==0, (-c25+c28)==0, (c22-c23+c26-c27)==0, (c22-c23)==0, (c21-c24)==0}, {c21,c22,c23,c24,c25,c26,c27,c28}]

d=3; ModDegree[d+1,
Print[
v[d] = v[d-1]+0 r12**r12+0 r12**r21+0 r21**r12+0 r21**r21+c25 Diag[h[1],ar[1,2]]+((1/48)+c25) Diag[h[2], ar[1,2]]+((1/48)+c25) Diag[h[1],ar[2,1]]+c25 Diag[h[2],ar[2,1]] /. c25 -> 1/32
];
V[d]=DExp[v[d]];
{R4Eqn[V[d]], TwistEqn[V[d]]}
] // PullDiags

While[True,
Print["At d=", ++d];
ModDegree[d+1,
v[d]=v[d-1]+ Sum[c[2k]Diag[h[1]^k h[2]^(d-2-k), ar[1,2]]+ c[2k+1]Diag[h[1]^k h[2]^(d-2-k), ar[2,1]], {k,0,d-2}];
V[d]=DExp[v[d]];
eq1=R4Eqn[V[d]];
diags= Union[Cases[eq1, _Diag, Infinity]];
eqns = Union[Coefficient[eq1, #]& /@ diags];
eq2=TwistEqn[V[d]];
diags= Union[Cases[eq2, _Diag, Infinity]];
eqns = Union[eqns, Coefficient[eq2, #]& /@ diags];
Print[eqns];
{sol} = Solve[(#==0)& /@eqns, c /@ Range[0,2d-3]];
Print["sol is ",sol];
v[d] = (v[d] /. sol);
Print["v is ", v[d]];
Print["pol is ", Series[
-4v[d] /. {Diag[_, ar[2,1]] -> 0,Diag[hs_, ar[1,2]] :> hs} /. {h[1] -> h x, h[2] -> h y},
{h,0,d-2}]
];
V[d]=DExp[v[d]];
Print["{R4Eqn[V[d]], TwistEqn[V[d]]}=", {R4Eqn[V[d]], TwistEqn[V[d]]}];
]
]

Clear[Phi];
Phi[d_] := ModDegree[d+1,
V[d] = DExp[v[d]];
Phi[d] = PutOn[{1,2},3, Adjoint[V[d]]]**Adjoint[V[d]]**PutOn[2,3, V[d]]**PutOn[1,{2,3},V[d]]
]

Phi[2]

Pentagon[Phi_] := Phi**PutOn[1,{2,3},4, Phi]**PutOn[2,3,4, Phi]-PutOn[{1,2},3,4, Phi]**PutOn[1,2,{3,4}, Phi];
RR[d_] := ModDegree[d+1, DExp[1/2 (r[1,2]+r[2,1])]];
Hexagon[Phi_, RR_] := PutOn[{1,2},3,RR] - Phi**PutOn[2,3,RR]**PutOn[1,3,2, DInvert[Phi]]**PutOn[1,3,RR]**PutOn[3,1,2, Phi];

ModDegree[3, Pentagon[Phi[2]]]

ModDegree[3, Hexagon[Phi[2], RR[2]]]

Phi[3]

ModDegree[4, Pentagon[Phi[3]]]

v[3]

V[3]

ModDegree[4, V[3]**Adjoint[V[3]]]

ModDegree[4, Hexagon[Phi[3], RR[3]]]

Phi[4]

ModDegree[5, Pentagon[Phi[4]]]

ModDegree[5, Hexagon[Phi[4], RR[4]]]

Exploration - can the inverse of V be written in terms of V?

ModDegree[4, PutOn[2,1,V[3]]**DExp[r[1,2]/2]-Adjoint[V[3]]]