Pensieve Header: β-better calculus with explicit dm, continues bbCalculus.nb of pensieve://2012-05/.

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
]]
)
];

B /: B[ω1_, σ1_, μ1_]B[ω2_, σ2_, μ2_] := B[ω1*ω2, σ1+σ2, ω2 μ1+ω1 μ2];
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
];
dm0[x_,y_,z_][b_] := b // swapth[x,y] // hm[x,y,z] // tm[x,y,z];
dm[x_,y_,z_][B[ω0_, σ_, μ_]] := Module[
{ω,α,β,γ,δ,θ,ϵ,ϕ,ψ,Ξ,σx,σy},
ω=ω0 /. {(Subscript[T, x])->(Subscript[T, z]), (Subscript[T, y])->(Subscript[T, z])};
{σx,σy} = {σ⊢h[x], σ⊢h[y]} /. {(Subscript[T, x])->(Subscript[T, z]), (Subscript[T, y])->(Subscript[T, z])};
(({{α, β, θ}, {γ, δ, ϵ}, {ϕ, ψ, Ξ}}))=(({{(∂_(t[x],h[x]))μ, (∂_(t[x],h[y]))μ, (∂_(t[x]))μ /. h[x]|h[y] -> 0}, {(∂_(t[y],h[x]))μ, (∂_(t[y],h[y]))μ, (∂_(t[y]))μ /. h[x]|h[y] -> 0}, {(∂_(h[x]))μ /. t[x]|t[y] -> 0, (∂_(h[y]))μ /. t[x]|t[y] -> 0, μ /. t[x]|t[y]|h[x]|h[y] -> 0}})) /. {(Subscript[T, x])->(Subscript[T, z]), (Subscript[T, y])->(Subscript[T, z])};
B[ω+β,
h[z]σx σy+(σ /. h[x]|h[y] -> 0 /. {(Subscript[T, x])->(Subscript[T, z]), (Subscript[T, y])->(Subscript[T, z])}),
{t[z],1}.(({{σy α+γ+((β γ - δ α)/ω)+σx σy β+σx δ, σy θ+ϵ+((β ϵ-δ θ)/ω)}, {ϕ+((β ϕ-ψ α)/ω)+σx ψ, Ξ+((β Ξ-ψ θ)/ω)}})).{h[z],1}
] // bbCollect
]

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[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
}

(({{σy α+γ+((β γ - δ α)/ω)+σx σy β+σx δ, σy θ+ϵ+((β ϵ-δ θ)/ω)}, {ϕ+((β ϕ-ψ α)/ω)+σx ψ, Ξ+((β Ξ-ψ θ)/ω)}})) // FullSimplify // MatrixForm

B0=B[ω, {(Subscript[σ, a]),(Subscript[σ, b]),σ}.{h@a, h@b, h@S},{t@a,t@b,t@S}.(({{α, β, θ}, {γ, δ, ϵ}, {ϕ, ψ, Ξ}})).{h@a, h@b, h@S}]

B0 // swapth[a,b] // hm[a,b,c] // tm[a,b,c]

(({{β+ω, h[c], h[S]}, {t[c], (Subscript[σ, a]) (δ+β (Subscript[σ, b]))+((β γ-α δ+γ ω+α ω (Subscript[σ, b]))/ω), ((β ϵ-δ θ+ϵ ω+θ ω (Subscript[σ, b]))/ω)}, {t[S], ((β ϕ-α ψ+ϕ ω+ψ ω (Subscript[σ, a]))/ω), ((β Ξ-θ ψ+Ξ ω)/ω)}, {"1+Σ/ω", (Subscript[σ, a]) (Subscript[σ, b]), σ}})) // FullSimplify // MatrixForm