pA Talk
September-24-08
4:19 PM
        (* Variable Equivalences *)
ReductionRules[Times[]] = {};
ReductionRules[Equal[a_, b__]] := (# -> a) & /@ {b}; 
ReductionRules[eqs_Times] := Join @@ (ReductionRules /@ List @@ eqs)

        (* Wedge Multiply *)
WExpand[expr_] := Expand[expr /. w_W :> Signature[w]*Sort[w]];
WM[___, 0, ___] = 0;
a_ ~WM~ b_ := WExpand[Distribute[a ** b] /.  (c1_. * w1_W) ** (c2_. * w2_W) :> c1 c2 Join[w1, w2]];
WM[a_, b_, c__] := a ~WM~ WM[b, c];

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

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

        (* pA on Crossings *)
pA[Xp[i_, j_, k_, l_]] := AHD[{i, l}, W[j, k], (t[i] == t[k]) (t[j] == t[l]),
   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[{i, j}, W[k, l], (t[i] == t[k]) (t[j] == t[l]),
  t[j] W[i, j] - t[j] W[i, l] + W[j, k] + (t[i] - 1) W[j, l] + W[k, l] ]

        (* pA on Circuit Diagrams *)
pA[cd_CircuitDiagram] := pA[cd, {}, 1];
pA[cd_CircuitDiagram, inside_, ahd_] := Module[
   {pos = First[Ordering[Length[Complement[List @@ #, inside]] & /@ cd]]},
   pA[Delete[cd, pos], Union[inside, List @@ cd[[pos]]], ahd*pA[cd[[pos]]]]
   ];
pA[CircuitDiagram[], _, ahd_] := ahd

Pasted from <[link]> 