(* WP: Wedge Product *)
WSort[expr_] := Expand[expr /. w_W :> Signature[w]*Sort[w]];
WP[0, _] = WP[_, 0] = 0;
WP[a_, b_] := WSort[Distribute[a ** b] /.
    (c1_. * w1_W) ** (c2_. * w2_W) :> c1 c2 Join[w1, w2]];

        (* IM: Interior Multiplication *)
IM[{}, expr_] := expr;
IM[i_, w_W] := If[FreeQ[w, i], 0,
    -(-1)^Position[w, i][[1,1]]*DeleteCases[w, i] ];
IM[{is___, i_}, w_W] := IM[{is}, IM[i, w]];
IM[is_List, expr_] := expr /. w_W :> IM[is, w]

        (* pA on Crossings *)
pA[Xp[i_,j_,k_,l_]] := AHD[(t[i]==t[k])(t[j]==t[l]), {i,l}, W[j,k],
    W[l,i] + (t[i]-1)W[l,j] - t[l]W[l,k] + W[i,j] + t[l]W[j,k] ];
pA[Xm[i_,j_,k_,l_]] := AHD[(t[i]==t[k])(t[j]==t[l]), {i,j}, W[k,l],
    t[j]W[i,j] - t[j]W[i,l] + W[j,k] + (t[i]-1)W[j,l] + W[k,l] ]

        (* Variable Equivalences *)
ReductionRules[Times[]] = {};
ReductionRules[Equal[a_, b__]] := (# -> a)& /@ {b}; 
ReductionRules[eqs_Times] := Join @@ (ReductionRules /@ List@@eqs)

        (* AHD: Alexander Half Densities *)
AHD[eqs_, is_, -os_, p_] := AHD[eqs, is, os, Expand[-p]];
AHD /: Reduce[AHD[eqs_, is_, os_, p_]] := 
  AHD[eqs, Sort[is], WSort[os], WSort[p /. ReductionRules[eqs]]];
AHD /: AHD[eqs1_,is1_,os1_,p1_] AHD[eqs2_,is2_,os2_,p2_] := Module[
  {glued = Intersection[Union[is1, is2], List@@Union[os1, os2]]}, 
  Reduce[AHD[
    eqs1*eqs2 //. eq1_Equal*eq2_Equal /; 
      Intersection[List@@eq1, List@@eq2] =!= {} :> Union[eq1, eq2],
    Complement[Union[is1, is2], glued],
    IM[glued, WP[os1, os2]],
    IM[glued, WP[p1, p2]]
]] ]

        (* pA on Circuit Diagrams *)
pA[cd_CircuitDiagram, eqs___] := pA[cd, {}, AHD[Times[eqs], {}, W[], W[]]];
pA[cd_CircuitDiagram, done_, ahd_AHD] := Module[
  {pos = First[Ordering[Length[Complement[List @@ #, done]] & /@ cd]]},
  pA[Delete[cd, pos], Union[done, List @@ cd[[pos]]], ahd*pA[cd[[pos]]]]
];
pA[CircuitDiagram[], _, ahd_AHD] := ahd