Pensieve header: The “top” strand deletion for $V$.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-05\\beta5.0"];
<< betaCalculus.m
Clear[ℏ]; Unprotect[C];
$PerturbativeDegree=6;
βSimplify[expr_]:= Replace[
Series[Normal[expr], {ℏ, 0, $PerturbativeDegree}],sd_SeriesData :> MapAt[Expand, sd, 3]
];
βCollect[B[ω_, μ_]] := B[
βSimplify[ω],
βSimplify[μ]
];
{V, C, sol} = Get["SolutionToDegree6-120501.m"];

V// dS[2] // dm[1,2,1]

R[1,1,-1/2]

C

R[1,1,-1/2] // dS[1]

{V0,C0} ={
β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]]
] /. {
(ϵ:(α|β|γ|δ|ω|κ))[___] :> (Subscript[ϵ, 0]), Derivative[k___][(ϵ:(α|β|γ|δ|ω|κ))][___] :> (Subscript[ϵ, FromDigits[{k}]])
},
βCollect[B[κ[ℏ (Subscript[c, 1])],0]] /. {
(ϵ:(α|β|γ|δ|ω|κ))[___] :> (Subscript[ϵ, 0]), Derivative[k___][(ϵ:(α|β|γ|δ|ω|κ))][___] :> (Subscript[ϵ, FromDigits[{k}]])
}
} /. sol

Er=V0 // dS[2] // dm[1,2,1]

Er**(Er // dS[1])

R[1,1,-1] // dS[1]

((Er // dS[1])**Er ) // dcap[1]

{ser=Series[(E^x-1)/x, {x,0,6}], Exp[ser], Log[ser]} // ColumnForm

{
Er[[1]] /. (Subscript[c, 1])-> 1,
Er[[1]] /. (Subscript[c, 1])-> -1,
(Er[[1]] /. (Subscript[c, 1])-> 1)(Er[[1]] /. (Subscript[c, 1])-> -1),
Series[((Sinh[ℏ/2])/(ℏ/2)), {ℏ,0,6}],
(Er[[1]] /. (Subscript[c, 1])-> -1)/(Er[[1]] /. (Subscript[c, 1])-> 1),
Series[(E^(-ℏ/2))(Sqrt[((Sinh[ℏ/2])/(ℏ/2))]), {ℏ,0,6}]
} // ColumnForm

Solve[f*f*E^ℏ == ((Sinh[ℏ/2])/(ℏ/2)), {f}]

C0

C0 /. {(Subscript[c, 1])->1, (Subscript[κ, 1])->1/4, (Subscript[δ, 10])-> -1/48}

Series[(Sqrt[(((E^ℏ)-1)/ℏ)]), {ℏ,0,6}]

SolveAlways[Normal[Series[(Sqrt[(((E^ℏ)-1)/ℏ)]), {ℏ,0,6}]-(C0[[1]] /. (Subscript[c, 1])->1)] == 0, {ℏ}]

SolveAlways[Normal[Series[Cosh[ℏ], {ℏ,0,6}]-(C0[[1]] /. (Subscript[c, 1])->1)] == 0, {ℏ}]

SolveAlways[Normal[Series[1, {ℏ,0,6}]-(C0[[1]] /. (Subscript[c, 1])->1)] == 0, {ℏ}]

rules={(Subscript[κ, 1])->0, (Subscript[δ, 10])->-1/16};
(((V0/.rules)//Inverse)((C0/.rules)//dP[3])) // dm[2,3,2] // dcap[2] // tη[1]

sol=SolveAlways[
(((V0//Inverse)(C0//dP[3])) // dm[2,3,2] // dcap[2] // tη[1]) == B[1,0],
{ℏ, (Subscript[c, 2])}
]

{sol}=Union[sol]

{V1,C1}={V0,C0} /. sol

Φ1=Φ[V1]

Φ1 // dΔ[1,0,1] // dS[2] // dS[3] // dm[0,3,0] // dm[1,2,1]