Pensieve Header: Experimenting the “reverse double” in β-calculus.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-01"];
<< betaCalculus.m
<< KnotTheory`
GC[K_] := GC @@ (
PD[K] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],
Ar[l,i,+1], Ar[j,i,-1]
]
)

bm[x_,y_,z_][β_] := β // conj[x,y] // hm[x,y,z] // tm[x,y,z];

(β_)~BB~(ν_) := Module[
{ρ, σ, labels},
ρ = β + (ν /. {h[s_] :> h[σ[s]], t[s_] :> t[σ[s]], c[s_] :> c[σ[s]]});
labels = Union[Cases[{β,ν}, h[s_]|t[s_]|c[s_] :> s, Infinity]];
Do[
ρ = ρ // bm[s, σ[s], s],
{s, labels}
];
ρ
]

(W[1]+ar[1,2])~BB~(W[1]+ar[1,3]) // βForm

{(W[1]+ar[1,3])~BB~(W[1]+ar[2,3]),  (W[1]+ar[2,3])~BB~(W[1]+ar[1,3])} // βForm

(W[1]+ar[1,2])**(W[1]+ar[2,3])// βForm

(W[1]+ar[1,2])~BB~(W[1]+ar[2,3])// βForm

(W[1]+ar[2,3])~BB~(W[1]+ar[1,2]) // βForm

{ar[1,2]~BB~ar[1,3]~BB~ar[2,3], ar[2,3]~BB~ar[1,3]~BB~ar[1,2]} // βForm

{β3 = W[1]+Sum[(Subscript[α, 10i+j])[c[1], c[2], c[3]] ar[i,j], {i,3}, {j,3}],
β3 // bm[1,2,1]
} /. e_[c[1], c[1], c[3]] :> e // βForm // ColumnForm

(W[1]+ar[1,2])~BB~(W[1]+((-1)/(1+c[1])) ar[1,2]) // βForm

{β1=W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,3}, {j,3}]+ar[5,6],
β1  // bm[1,5,1],
β1  // bm[2,6,2],
β1  // bm[1,5,1] // dm[2,6,2]
} /. c[i_] :> (Subscript[c, i]) // βForm // ColumnForm

{β1=W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,3}, {j,3}],
β1 ~BB~ ar[1,2],
β1 ~BB~ (((-1)/(1+c[1])) ar[1,2])
} /. c[i_] :> (Subscript[c, i]) // βForm // ColumnForm

{β1=W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,3}, {j,3}],
ar[1,2] ~BB~ β1,
(((-1)/(1+c[1])) ar[1,2]) ~BB~ β1
} /. c[i_] :> (Subscript[c, i]) // βForm // ColumnForm

n=2;
{
α1=W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}],
β1=W[1]+Sum[(Subscript[β, 10i+j]) ar[i,j], {i,n}, {j,n}],
α1~BB~β1
} /. c[i_] :> (Subscript[c, i]) // βForm // ColumnForm

n=3;
{
α1=W[1]+Sum[(Subscript[α, 10i+j]) ar[i,j], {i,n}, {j,n}],
β1=W[1]+Sum[(Subscript[β, 10i+j]) ar[i,j], {i,n}, {j,n}],
α1~BB~β1
} /. c[i_] :> (Subscript[c, i]) // βForm // ColumnForm

{K=Knot[8,17];
Alexander[K][X], GC[K]
}

βAlex[K_] := Module[
{gc, β},
gc = GC[K];
β = βCollect[Plus@@(gc /. {Ar[i_, j_, +1] :> R[i,j], Ar[i_, j_, -1] :> RInv[i,j]})];
Do[β = bm[1,k,1][β], {k, 2, 2Length[gc]}];
Expand[β /. h[1] -> 0 /. E^(n_. c[1]) :> X^n /. W[a_] :> a]
]

βAlex[K]

βSimplify=Factor;
gc = GC[K];
Join[{β =βCollect[
W[1]+Plus@@(gc /. {Ar[i_, j_, +1] :> ar[i,j], Ar[i_, j_, -1] :>-(1/(1+c[i])) ar[i,j]})
]},
Table[β = bm[1,k,1][β], {k, 2, 2Length[gc]}]
]  /. _c -> c-1 //βCollect // βForm // ColumnForm