Pensieve Header: Checking if PfBn (Pure Flat Braids) has a homomorphic expansion.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Quadraticity2"];
<< ../Mathematica/LinAlg.m

Unprotect[NonCommutativeMultiply];
0**_ = 0;
_**0 = 0;
(c_*w_W)**x_ := Expand[c(w**x)];
x_ ** (c_*w_W) := Expand[c(x**w)];
x_Plus ** y_ := (#**y)& /@ x;
x_ ** y_Plus := (x**#)& /@ y;
w1_W ** w2_W := Join[w1,w2];

b[a1_a,a2_a] := W[a1,a2]-W[a2,a1];
pfb[n_]@Generators := Sort[Flatten[Table[
a[i,j], {i,n-1}, {j,i+1,n}
]]];
pfb[n_]@Relations := Flatten[{
Table[
b[a[i,j],a[i,k]]+b[a[i,j],a[j,k]]+b[a[i,k],a[j,k]],
{i,n-2}, {j,i+1,n-1}, {k,j+1,n}
],
Table[
{
b[a[i,j],a[k,l]], b[a[i,k], a[j,l]], b[a[i,l],a[j,k]]
},
{i,n-3}, {j,i+1,n-2}, {k,j+1,n-1}, {l,k+1,n}
]
}];
pfb[n_][m_Integer] = pfb[n,m];
pfb[n_,0]@Generators := {W[]};
pfb[n_,m_]@Generators := Sort[
Flatten[Outer[W, Sequence@@Table[pfb[n]@Generators, {m}]]
] /. a[i_, j_] :> 10i+j
];
pfb[n_,m_]@Relations := Flatten[Table[
Outer[NonCommutativeMultiply,
pfb[n,k][Generators], pfb[n][Relations], pfb[n,m-2-k][Generators]
],
{k,0,m-2}
]] /. a[i_, j_] :> 10i+j;

pfb[n_,m_]@ReducedMatrix := pfb[n,m]@ReducedMatrix = Module[
{gens, rels},
gens=pfb[n,m]@Generators;
rels = pfb[n,m]@Relations;
 RowReduce[
CoefficientArrays[rels, gens][[2]]  // Normal
]
];
pfb[n_,m_]@Basis := Module[
{gens},
gens=pfb[n,m]@Generators;
Delete[gens, List /@ Flatten[
Position[#, Except[0], {1}, 1, Heads->False]& /@ pfb[n,m]@ReducedMatrix
]
] 
];
ToBasis[pfb[n_,0]] := {};
ToBasis[pfb[n_,1]] := {};
ToBasis[pfb[n_,m_]] := ToBasis[pfb[n,m]] = Module[
{gens},
gens=pfb[n,m]@Generators;
Dispatch[Flatten[Replace[
(pfb[n,m]@ReducedMatrix).gens,
{
0 -> {},
r_Plus :> {First[r] -> Expand[-Rest[r]]},
r_ :> {r->0}
},
{1}
]]]
];

ASeries /: c_?NumberQ * a_ASeries := Expand[c#]& /@ a;
ASeries /: a1_ASeries + a2_ASeries := Module[
{m=Min[Length[a1], Length[a2]]},
ASeries@@(Take[List@@a1,m]+Take[List@@a2,m])
];
ASeries /: a1_ASeries ** a2_ASeries := Module[
{m=Min[Length[a1], Length[a2]]-1, P1, P2},
ASeries @@ Table[
Sum[a1[[d1+1]]**a2[[d-d1+1]],
{d1, 0, d}
],
{d, 0, m}
]
];
ASeries /: Expand[a_ASeries] := Expand /@ a;
pfb[n_][Reduce][a_ASeries]:= ASeries @@ Table[
Expand[a[[d+1]] /. ToBasis[pfb[n,d]]],
{d,0,Length[a]-1}
];

pfb[4,3][Relations] /. ToBasis[pfb[4,3]]

ASeries[W[], W[12]]**ASeries[W[], -W[12]]

ASeries[W[], W[12],0]**ASeries[W[], W[23],0] // pfb[3]@Reduce

pfb[3,2][Basis]

ASeries[W[], W[12],0]**ASeries[W[], W[13],0]// pfb[3]@Reduce

GradedSolve[params__] := Module[
{
alg = Algebra /. {params},
dr = DegreeRange /. {params},
us = Unknowns /. {params},
ivs = InitialValues /. {params},
eqs = Equations /. {params},
cvs, d, bas, dim, k, cs, er, sol
},
cvs=ivs; cs={};
For[d=dr[[1]], d≤dr[[2]], ++d,
bas= alg[d][Basis];
dim=Length[bas];
k=0;
cvs=Append[#, Table[c[d,++k], {dim}].bas]& /@ cvs;
cs=Join[cs, Table[c[d,i], {i,k}]];
er = alg[Reduce] /@ (eqs /. Thread[us -> (Append[#, 0]& /@ cvs)]);
er = Collect[Last[#], _W]& /@ er;
sol=Solve[
(#==0)& /@ Cases[er, eq_*_W :> eq, Infinity],
cs
];
If[sol=={},
Print["No solution in degree ",d],
sol=First[sol]
];
cvs=Expand[cvs/. sol];
cs=Complement[cs, First /@ sol];
(* cvs=Expand[cvs/. ((#->0)& /@ cs)]; cs={}; *)
];
cvs
]

GradedSolve[
Algebra -> pfb[3],
DegreeRange -> {2,6},
Unknowns -> {s12,s13,s23},
InitialValues -> {ASeries[W[],W[12]], ASeries[W[],W[13]], ASeries[W[],W[23]]},
Equations -> {s12**s13**s23-s23**s13**s12}
]

n=4;
GradedSolve[
Algebra -> pfb[n],
DegreeRange -> {2,3},
Unknowns -> Flatten[Table[
s[i,j], {i,n-1}, {j,i+1,n}
]],
InitialValues -> Flatten[Table[
ASeries[W[],W[10i+j]], {i,n-1}, {j,i+1,n}
]],
Equations -> Flatten[{
Table[
s[i,j]**s[i,k]**s[j,k]-s[j,k]**s[i,k]**s[i,j],
 {i,n-2}, {j,i+1,n-1}, {k,j+1,n}
],
Table[
{
s[i,j]**s[k,l]-s[k,l]**s[i,j],
s[i,k]**s[j,l]-s[j,l]**s[i,k],
s[i,l]**s[j,k]-s[j,k]**s[i,l]
},
 {i,n-3}, {j,i+1,n-2}, {k,j+1,n-1}, {l,k+1,n}
]
}
]
]