Pensieve header: Perturbative β-calculations.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-03"];
<< betaCalculus.m

Clear[ℏ];
$PerturbativeDegree=4;
βSimplify[expr_]:= Replace[
Series[Normal[expr], {ℏ, 0, $PerturbativeDegree}],sd_SeriesData :> MapAt[Expand, sd, 3]
];
βCollect[B[ω_, μ_]] := B[
βSimplify[ω],
βSimplify[μ]
];

The Knot-Theoretic Equations

R2, OC, R3 and easy R4

{R[1,2]Ri[3,4],
R[1,2]Ri[3,4] // dm[1,3,1] // dm[2,4,2],
R[1,2]Ri[3,4] // dm[1,3,1] // dm[4,2,2]
} // ColumnForm

{
R[1,2]**Ri[1,2],
R[1,3]**R[2,3],
R[1,3]**R[2,3] == R[2,3]**R[1,3]// Expand ,
R[3,1]**R[3,2] == R[3,2]**R[3,1],
R[1,2]**R[1,3]**R[2,3],
R[1,2]**R[1,3]**R[2,3] == R[2,3]**R[1,3]**R[1,2]
} // ColumnForm

{
R[3,1]**R[3,2],
R[3,1],
R[3,1] // dΔ[1,1,2],
R[3,1]**R[3,2] == (R[3,1] // dΔ[1,1,2])
}

R[1,2,p1]**R[1,2,p2]==R[1,2,p1+p2] // Simplify

Hard R4

{
R[1,3]**R[2,3],
R[1,3] // dΔ[1,1,2],
R[1,3]**R[2,3] == (R[1,3] // dΔ[1,1,2])
}

{
V0=B[(Subscript[V, 0])[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])],Sum[(Subscript[V, 10i+j])[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])]t[i]h[j], {i,2}, {j,2}]],
R[1,3]**R[2,3]**V0,
V0**(R[1,3] // dΔ[1,1,2]),
eqns1=HardR4[V0]
}  // ColumnForm

sol=Solve[eqns1&&(Subscript[V, 21])[(Subscript[c, 1]),(Subscript[c, 2])]==0, (Subscript[V, 12])[(Subscript[c, 1]),(Subscript[c, 2])]]

V1=V0 /. {(Subscript[V, 21])[(Subscript[c, 1]),(Subscript[c, 2])]->0, (Subscript[V, 11])[(Subscript[c, 1]),(Subscript[c, 2])]->0, (Subscript[V, 22])[(Subscript[c, 1]),(Subscript[c, 2])]->0, (Subscript[V, 0])[(Subscript[c, 1]),(Subscript[c, 2])]->1} /. sol[[1]]

sol2={(Subscript[V, 11])[(Subscript[c, 1]),(Subscript[c, 2])]->-((-1+(E^((Subscript[c, 2])/2))) ((E^((Subscript[c, 1])/2)) (Subscript[c, 1])-(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])-2 (E^(((Subscript[c, 1])/2)+((Subscript[c, 2])/2))) (Subscript[c, 2])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])+(E^((Subscript[c, 2])/2)) (Subscript[c, 2])-2 (E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 2])+2 (E^((Subscript[c, 1])+(Subscript[c, 2]))) (Subscript[c, 2])))/(((Subscript[c, 1])+(Subscript[c, 2])) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))),(Subscript[V, 12])[(Subscript[c, 1]),(Subscript[c, 2])]->((E^((Subscript[c, 1])/2)) (Subscript[c, 1])-(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))/(((Subscript[c, 1])+(Subscript[c, 2])) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))),(Subscript[V, 21])[(Subscript[c, 1]),(Subscript[c, 2])]->((E^((Subscript[c, 1])/2)) (Subscript[c, 1])-2 (E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 1])-(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+2 (E^((Subscript[c, 1])+((3 (Subscript[c, 2]))/2))) (Subscript[c, 1])-(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])+(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))/(((Subscript[c, 1])+(Subscript[c, 2])) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))),(Subscript[V, 22])[(Subscript[c, 1]),(Subscript[c, 2])]->0,(Subscript[V, 11])[(Subscript[c, 2]),(Subscript[c, 1])]->((-1+(E^((Subscript[c, 1])/2))) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+2 (E^(((Subscript[c, 1])/2)+((Subscript[c, 2])/2))) (Subscript[c, 1])+2 (E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 1])-(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])-2 (E^((Subscript[c, 1])+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2])))/(((Subscript[c, 1])+(Subscript[c, 2])) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))),(Subscript[V, 12])[(Subscript[c, 2]),(Subscript[c, 1])]->-((E^((Subscript[c, 1])/2)) (Subscript[c, 1])-(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))/(((Subscript[c, 1])+(Subscript[c, 2])) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))),(Subscript[V, 21])[(Subscript[c, 2]),(Subscript[c, 1])]->-(-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2])+2 (E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 2])-2 (E^(((3 (Subscript[c, 1]))/2)+(Subscript[c, 2]))) (Subscript[c, 2]))/(((Subscript[c, 1])+(Subscript[c, 2])) (-(E^((Subscript[c, 1])/2)) (Subscript[c, 1])+(E^(((Subscript[c, 1])/2)+(Subscript[c, 2]))) (Subscript[c, 1])+(E^((Subscript[c, 1])+((Subscript[c, 2])/2))) (Subscript[c, 2])-(E^((Subscript[c, 2])/2)) (Subscript[c, 2]))),(Subscript[V, 22])[(Subscript[c, 2]),(Subscript[c, 1])]->0} /. (Subscript[c, i_]) :> ℏ (Subscript[c, i]);

V2=βCollect[V0/. sol2 /. (Subscript[V, 0])[__] -> 1]

HardR4[V2]

Simplify[(V2 // dP[2,1])**Θ[1,2]==R[1,2]**V2]

Simplify[(V2 // dP[2,1])**Θ[1,2]==R[2,1]**V2]

Φ2=Φ[V2]

Pentagon[Φ2]

Hexagon[+1, Φ2]

Hexagon[-1, Φ2]