Pensieve Header: bb-calculus, revision 2.

bbSimplify=Simplify;
SetAttributes[bbCollect, Listable];
bbCollect[B[ω_, σ_, μ_]] := B[
bbSimplify[ω], σ,
Collect[μ, _h, Collect[#, _t, bbSimplify]&]
];
hL[b_] := Union[Cases[b, h[s_] :> s, Infinity]];
tL[b_] := Union[Cases[b, t[s_]|(Subscript[T, s_]) :> s, Infinity]];
dL[b_] := Union[hL[b], tL[b]];
σ_ ⊢h_ := ((∂_h)σ /. 0->1);
bbForm[B[ω_, σ_, μ_]] := Module[
{tails, heads, mat},
tails = tL[B[ω, σ, μ]]; heads = hL[B[ω, σ, μ]];
mat = Outer[bbSimplify[(∂_(h[#1],t[#2]))μ]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Join[
{Prepend[h /@ heads, ω]},
Transpose[mat],
{Prepend[(σ⊢h[#])& /@ heads, "1+Σ/ω"]}
];
MatrixForm[mat]
];
bbForm[else_] := else /. b_B :> bbForm[b];
Format[b_B, StandardForm] := bbForm[b];
B /: B[ω1_, σ1_, μ1_] == B[ω2_, σ2_, μ2_] := Module[
{heads, tails},
tails = tL[{B[ω1, σ1, μ1], B[ω2, σ2, μ2]}];
heads = hL[{B[ω1, σ1, μ1], B[ω2, σ2, μ2]}];
(ω1 == ω2) && (σ1==σ2) && (
And @@ Flatten[Outer[
(Coefficient[μ1, t[#1]h[#2]] == Coefficient[μ2, t[#1]h[#2]])&,
tails, heads
]]
)
];

tm[x_, y_, z_][b_] := b /. {t[x]->t[z], t[y]->t[z], (Subscript[T, x])->(Subscript[T, z]), (Subscript[T, y])->(Subscript[T, z])};
hm[x_, y_, z_][B[ω_, σ_, μ_]] := B[ω, 
h[z](σ⊢h[x])(σ⊢h[y])+(σ /. h[x]|h[y] -> 0),
h[z](D[μ, h[x]] + (σ⊢h[x])(∂_(h[y]))μ) + (μ /. h[x]|h[y] -> 0)
] // bbCollect;
swapth[y_,x_][B[ω_, σ_, μ_]] := Module[
{α, β, γ, δ},
(({{α, β}, {γ, δ}}))=(({{Coefficient[μ, t[y]h[x]], D[μ, t[y]] /. h[x] -> 0}, {D[μ, h[x]] /. t[y] -> 0, μ /. h[x]|t[y] -> 0}}));
B[ω+α, σ, {(σ⊢h[x])t[y], 1}.(({{α, β}, {γ, ((ω+α)δ-γ*β)/ω}})).{h[x], 1}] // bbCollect
];
dm[x_,y_,z_][b_] := b // swapth[x,y] // hm[x,y,z] // tm[x,y,z];
B /: B[ω1_, σ1_, μ1_]B[ω2_, σ2_, μ2_] := B[ω1*ω2, σ1+σ2, ω2 μ1+ω1 μ2];

Unprotect[NonCommutativeMultiply];
b1_B ** b2_B := Module[
{ρ, σ, labels},
ρ = b1*(b2 /. {h[s_] :> h[σ[s]], t[s_] :> t[σ[s]], (Subscript[T, s_]) :> (Subscript[T, σ[s]])});
labels = dL[{b1,b2}];
Do[ρ = ρ // dm[s, σ[s], s], {s, labels}];
ρ
];

Rp[x_, y_] := B[1, (Subscript[T, x])h[y], ((Subscript[T, x])-1)*t[x]h[y]];
Rm[x_, y_] := B[1, h[y]/(Subscript[T, x]), (1/(Subscript[T, x])-1)*t[x]h[y]];

{Rp[1,2], Rm[1,2]}

{Rp[1,2]**Rp[1,3]**Rp[2,3], Rp[2,3]**Rp[1,3]**Rp[1,2]}

<< KnotTheory`
{b=Times@@(PD[Knot[8,17]] /.
X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]], Rp[l,i], Rm[j,i]]);
Do[b=dm[1,k,1][b], {k,2,16}]; b,
Alexander[Knot[8,17]][(Subscript[T, 1])] // bbSimplify
}

{n=4;
b=B[ω, Sum[(Subscript[σ, j])h[j], {j,n}], Sum[(Subscript[α, 10i+j])t[i]h[j], {i,n}, {j,n}]],
b // dm[1,2,1]
} // ColumnForm

{n=4;
b=B[ω, Sum[(Subscript[σ, j])h[j], {j,n}], Sum[(Subscript[α, 10i+j])t[i]h[j], {i,n}, {j,n}]],
t1=b // dm[1,2,1] // dm[1,3,1],
t2=b // dm[2,3,2] // dm[1,2,1],
t1==t2 // Simplify
} // ColumnForm