Pensieve header: Exact β-calculations.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-05\\beta5.1"];
<< betaCalculus.m
Clear[ℏ]

The Knot-Theoretic Equations

{
V0=βCollect[
B[ω[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])],α[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])]t[1]h[1]+β[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])]t[1]h[2]+γ[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])]t[2]h[1]+δ[ℏ (Subscript[c, 1]),ℏ (Subscript[c, 2])]t[2]h[2]]
],
C0=βCollect[B[κ[ℏ (Subscript[c, 1])],0]],
eqns0 = GroupLikeQ[V0, 1/2 (Subscript[c, 1])h[2]],
eqns1=HardR4[V0],
eqns2=TwistEq[V0],
eqns3 = And[(V0 // dη[1])==B[1,0], (V0 // dη[2])==B[1,0]],
eqns4 = V0**(V0 // dA[1] // dA[2]) == B[1,0],
eqns5 = CapEquation[V0, C0],
eqns6 = (C0 // tη[1])==B[1,0],
eqns7 = (V0 == Rot120[V0]),
eqns8 = V0**(V0 // dS[1] // dS[2]) == R[1,2]
}  // ColumnForm

eqns = FullSimplify[(eqns0&&eqns1&&eqns2&&eqns3&&eqns4&&eqns5&&eqns6&&eqns8) /. ℏ -> 1];

eqns

red1=Simplify[eqns /. (rule0=α[x_,y_] :> -y/x γ[x,y])]

Length[red1]

red2=Simplify[red1 /. (rule1=δ[x_,y_] :> (E^(x/2)-1-x β[x,y])/y)]

Length[red2]

Solve[((1-(E^((Subscript[c, 1])+(Subscript[c, 2]))))/((Subscript[c, 1])+(Subscript[c, 2])))+(((E^(Subscript[c, 2])) (-1+(E^(Subscript[c, 1]))) (1+(Subscript[c, 2]) γ[(Subscript[c, 1]),(Subscript[c, 2])]))/(Subscript[c, 1]))==(-1+(E^(Subscript[c, 2]))) β[(Subscript[c, 1]),(Subscript[c, 2])], γ[(Subscript[c, 1]),(Subscript[c, 2])]] /. {(Subscript[c, 1])->x, (Subscript[c, 2])->y}

red3=FullSimplify[red2 /. (rule2=γ[x_,y_] :>((E^(-y)) (-x+(E^y) x+(E^y) y-(E^(x+y)) y-(x^2) β[x,y]+(E^y) (x^2) β[x,y]-x y β[x,y]+(E^y) x y β[x,y]))/((-1+(E^x)) y (x+y)))]

Length[red3]

red4=FullSimplify[red3 /. β[(Subscript[c, 2]),(Subscript[c, 1])] ->((-(Subscript[c, 2])+Csch[((Subscript[c, 1])/2)] Sinh[((Subscript[c, 2])/2)] (Subscript[c, 1]) (1+((Subscript[c, 1])+(Subscript[c, 2])) β[(Subscript[c, 1]),(Subscript[c, 2])]))/((Subscript[c, 2]) ((Subscript[c, 1])+(Subscript[c, 2]))))]

Length[red4]

Series[(((((Sinh[x/2])/(x/2))))^(-1/4)), {x,0,4}]

red5=FullSimplify[red4 /. (rule4={κ[0]->1, κ[x_]:>(((((Sinh[x/2])/(x/2))))^(-1/4))})]

Length[red5]

red6=FullSimplify[red5 /. (rule5=ω[x_,y_] :> κ[x+y]((κ[x])^(-1))((κ[y])^(-1))) /. rule4]

Length[red6]

Solve[((Sqrt[2]) (E^(-((Subscript[c, 1])/2)-(Subscript[c, 2]))) (-1+(E^((Subscript[c, 1])+(Subscript[c, 2])))) (Sqrt[((Sinh[((Subscript[c, 1])/2)])/(Subscript[c, 1]))]) (Subscript[c, 1]) (Sqrt[((Sinh[((Subscript[c, 2])/2)])/(Subscript[c, 2]))]) (1+((Subscript[c, 1])+(Subscript[c, 2])) β[(Subscript[c, 1]),(Subscript[c, 2])]))/((-1+(E^(Subscript[c, 1]))) (Sqrt[((Sinh[(1/2) ((Subscript[c, 1])+(Subscript[c, 2]))])/((Subscript[c, 1])+(Subscript[c, 2])))]) ((Subscript[c, 1])+(Subscript[c, 2])))==1,  β[(Subscript[c, 1]),(Subscript[c, 2])]] /. {(Subscript[c, 1])->x, (Subscript[c, 2])->y}

FullSimplify[((E^((x/2)+y)) (-1+(E^x)) (Sqrt[((Sinh[((x+y)/2)])/(x+y))]) (1-(((Sqrt[2]) (E^(-(x/2)-y)) (-1+(E^(x+y))) x (Sqrt[((Sinh[(x/2)])/x)]) (Sqrt[((Sinh[(y/2)])/y)]))/((-1+(E^x)) (x+y) (Sqrt[((Sinh[((x+y)/2)])/(x+y))])))))/((Sqrt[2]) (-1+(E^(x+y))) x (Sqrt[((Sinh[(x/2)])/x)]) (Sqrt[((Sinh[(y/2)])/y)]))]

FullSimplify[red6 /. (rule6=β[x_, y_] :> (-(Sqrt[2]) (-1+(E^(x+y))) x (Sqrt[((Sinh[(x/2)])/x)]) (Sqrt[((Sinh[(y/2)])/y)])+(E^((x/2)+y)) (-1+(E^x)) y (Sqrt[((Sinh[((x+y)/2)])/(x+y))])+2 (E^(x+y)) x Sinh[(x/2)] (Sqrt[((Sinh[((x+y)/2)])/(x+y))]))/((Sqrt[2]) (-1+(E^(x+y))) x (x+y) (Sqrt[((Sinh[(x/2)])/x)]) (Sqrt[((Sinh[(y/2)])/y)])))]

FullSimplify[(-(Sqrt[2]) (-1+(E^(x+y))) x (Sqrt[((Sinh[(x/2)])/x)]) (Sqrt[((Sinh[(y/2)])/y)])+(E^((x/2)+y)) (-1+(E^x)) y (Sqrt[((Sinh[((x+y)/2)])/(x+y))])+2 (E^(x+y)) x Sinh[(x/2)] (Sqrt[((Sinh[((x+y)/2)])/(x+y))]))/((Sqrt[2]) (-1+(E^(x+y))) x (x+y) (Sqrt[((Sinh[(x/2)])/x)]) (Sqrt[((Sinh[(y/2)])/y)])) /. {x->2x, y->2y}]

unknowns={α[(Subscript[c, 1]),(Subscript[c, 2])], β[(Subscript[c, 1]),(Subscript[c, 2])], γ[(Subscript[c, 1]),(Subscript[c, 2])], δ[(Subscript[c, 1]),(Subscript[c, 2])], ω[(Subscript[c, 1]),(Subscript[c, 2])], κ[(Subscript[c, 1])]};
sol=Thread[unknowns -> FullSimplify[
unknowns /. rule0 /. rule1 /. rule2 /. rule5 /. rule4 /. rule6
]]

V=V0 /. ℏ->1 /. sol

Unprotect[C];
C=C0 /. ℏ->1 /. sol

False && Put[{V, C, sol}, "ExactSolution-120528.m"]

FullSimplify[R[2,3]**R[1,3]**V==V**(R[1,3] // dΔ[1,1,2])/. ℏ->1 ]

FullSimplify[V**Θ[1,2]==R[1,2]**(V // dP[2,1])/. ℏ->1 ]

FullSimplify[V**(V // dA[1] // dA[2]) == B[1,0]/. ℏ->1 ]

FullSimplify[V**(V // dS[1] // dS[2]) == R[1,2]/. ℏ->1 ]

FullSimplify[(V**(C // dP[12])  // dcap[1] // dcap[2]) == (C*(C // dP[2]) // dcap[1] // dcap[2])/. ℏ->1 ]