Pensieve Header: Work on the "infinitesimal Alexander module"; continues 2008-09/AlexanderEulerSpaces.nb. See also <a href=http://katlas.math.toronto.edu/drorbn/bbs/show?shot=KAL-090701-153823.jpg>http://katlas.math.toronto.edu/drorbn/bbs/show?shot=KAL-090701-153823.jpg</a>.

<< KnotTheory`

{Alexander[Knot[4,1]][t], Alexander[Knot[7,7]][t]}

K=Knot[7,7]; pd = PD[K];
gc=GC @@ pd /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]], Ar[l,i,+1], Ar[j,i,-1]];
False&& (gc = GC[Ar[1,3, +1], Ar[4,2,-1]]);
gc

Conventions for red objects:
  1. Legs start just to the right of the index; ar[0,7] means a red arrow starting to the right of position 0 (that is, to the left of everything) and ending to the right of position 7).
  2. If two (red) indices are the same, the heads are to the right of the tails.
  3. w[] is the legless wheel object.
  3. y[i,j,k] means "red Y with tails are i and j and head at k".

n = 2 Length[gc]; range=Range[0,n];
Short[AllRedObjects=Flatten[{
Outer[ar, range, range], Outer[y, range, range, range], w[]
}]]

The relations associated with a red objects involve all the ways of "pulling one leg one unit to the left" :

ar[d[i_], j_] := ar[i,j] - ar[i-1, j] + If[i-1==j, w[], 0];
ar[i_,d[j_]] := ar[i,j] - ar[i, j-1]  + If[i==j,  -w[], 0];
y[d[i_], j_, k_] := y[i,j,k] - y[i-1,j,k] +If[i-1==k, -w[], 0];
y[i_,j_,d[k_]] := y[i,j,k] - y[i,j,k-1]+If[i==k, w[], 0]+ If[j==k, -w[],0];

Now let's form all the red relations; starting with the anti-symmetry of y:

RedRelations = {};
RR[rel_RuleDelayed] := AppendTo[RedRelations, rel];
SetAttributes[RR, Listable];
RR[y[t1_, t2_, h_] * _. :> y[t1,t2,h] + y[t2,t1,h]];

Import["http://katlas.math.toronto.edu/drorbn/AcademicPensieve/2009-06/IAMRelations.png"]

RR@(({{ , Ar Tail, Ar Head}, {ar
Tail, ar[i_, h_]Ar[i_,j_, s_]*_. :>
ar[d[i], h], ar[j_,h_]Ar[i_, j_, s_]*_. :>
ar[d[j], h]-(X^s-1) y[i,j,h]}, {ar
Head, ar[t_,i_]Ar[i_, j_, s_]*_. :>
ar[t,d[i]]-(X^s-1) y[i,t,j-1], ar[t_,j_]Ar[i_, j_, s_]*_. :>
ar[t,d[j]]+(X^s-1)y[i,t,j-1]}}));

RR@(({{ , Ar Tail, Ar Head}, {y
Tail, y[i_, t_, h_]Ar[i_,j_, s_]*_. :>
y[d[i], t, h], y[j_,t_,h_]Ar[i_, j_, s_]*_. :>
y[d[j],t,h]-(X^s-1) y[i,j,h]}, {y
Head, y[t1_,t2_,i_]Ar[i_,j_,s_]*_. :>
y[t1,t2,d[i]]+(X^s-1) y[t1,t2,j-1], y[t1_,t2_,j_]Ar[i_,j_,s_]*_. :>
y[t1,t2,d[j]]-(X^s-1) y[t1,t2,j-1]}}));

RelationsIn[gc_GC, red_] := ReplaceList[
red*(Times @@ Select[gc, (Intersection[List@@#, List@@red] =!= {})&]), RedRelations
]

AllRedRelations = Flatten[RelationsIn[gc, #]& /@ AllRedObjects];
rule = Thread[Rule[AllRedObjects, IdentityMatrix[Length[AllRedObjects]]]];
Short[RedRules=Map[
(
p = First@Part[AllRedObjects, First@Position[#, 1, {1}]];
p -> p-(#.AllRedObjects)
)&,
DeleteCases[mat=Simplify[RowReduce[AllRedRelations /. rule]], {0...}]
]]

Simplify[RedRules[[Table[Random[Integer, {1,Length[RedRules]}], {10}]]]]

RedZ=Plus @@ gc /. Ar[i_, j_, s_] :> s*ar[i,j]

Simplify[RedZ /. RedRules]