Whitehead := function(x,y)
local n, wdata, F, gens, pass, Comp, pairs, Label, MyDegree, Edges, Rem,
 w, nwords,
 edges, reduced, G, Components, Ncomps, cg, redvert, redverti, redcomp1,
 redcomp2, IsCutVertex, CutComponents, cutvertex, i,j, ccg, k, newedges,
 z, busts,V, isbusting,newV, newrow;
n := x;
wdata := y;
busts := 0;





##  Data  ##


F := FreeGroup(n);
gens := GeneratorsOfGroup(F);



##  Some functions ##

pass := 0;


Comp := function(x,y)
local t,z;
for t in [1 .. Length(x)] do
if y in x[t] then
z := t;
fi;
od;
return z;
end;

pairs := [1 .. 2*n];

for i in [1 .. n] do
pairs[i] := [gens[i],i];
od;
for i in [1 .. n] do
pairs[n+i] := [gens[i]^-1, n+i];
od;


Label := function(x)
local t;
for t in [1 .. 2*n] do
if pairs[t][1] = x then return pairs[t][2];
fi;
if pairs[t][2] = x then return pairs[t][1];
fi;
od;
end;


## This gives the degree of the yth vertex in graph x

MyDegree := function(x,y)
local d;
d := Length(x[y]);
return d;
end;

Edges := function(x)
local s,t,z;
z := [];
for s in [1 .. Length(x)] do
if Length(x[s]) > 0 then
for t in [1 .. Length(x[s])] do
if x[s][t] > s then
Add(z, [s,x[s][t]]);
fi;
od;
fi;
od;
return z;
end;

Rem := function(x,j)
local z;
z := ((x-1) mod j) +1;
return z;
end;

w := [1 .. Length(wdata)];
for i in [1 .. Length(wdata)] do
w[i] := List(wdata[i], t -> Label(t));
od;
nwords := Length(w);

edges := [1 .. nwords];
for i in [1 .. nwords] do
edges[i] := [];
for j in [1 .. Length(w[i])] do
Add(edges[i], [Label(w[i][j]), Label(w[i][Rem(j+1,Length(w[i]))]^-1)]);
od;
od;

reduced := 0;


V := IdentityMat(n, 1);


# Start routine #


while reduced = 0 do



#Form Graph#


G := [1 .. 2*n];
for i in [1 .. 2*n] do G[i] := []; od;

for i in [1 .. nwords] do
for j in [1 .. Length(edges[i])] do
Add(G[edges[i][j][1]], edges[i][j][2]);
Add(G[edges[i][j][2]], edges[i][j][1]);
od;
od;


#Compute components of graph#
#Components(x) gives components of arbitrary graph G.

Components := function(x)
local c, e, t, check ,compssofar, ncompssofar;
check := 0;
e := Edges(x);
ncompssofar := 0;
compssofar := [1 .. Length(x)];
for t in [1 .. Length(x)] do
compssofar[t] := [];
od;

t := 1;

while t < Length(e) +1 do
if check = 0 and
 not e[t][1] in Union(compssofar) and not e[t][2] in Union(compssofar) then
Add(compssofar[ncompssofar+1], e[t][1]);
Add(compssofar[ncompssofar+1], e[t][2]);
t := t+1;
ncompssofar := ncompssofar +1;
check := 1;
fi;

if check = 0 and
not e[t][1] in Union(compssofar) and e[t][2] in Union(compssofar) then
Add(compssofar[Comp(compssofar,e[t][2])], e[t][1]);
t := t+1;
check := 1;
fi;

if check = 0 and
e[t][1] in Union(compssofar) and not e[t][2] in Union(compssofar) then
Add(compssofar[Comp(compssofar,e[t][1])], e[t][2]);
t := t+1;
check := 1;
fi;

if check = 0 and
 e[t][1] in Union(compssofar) and e[t][2] in Union(compssofar)
and not Comp(compssofar,e[t][1]) = Comp(compssofar,e[t][2]) then
compssofar[Minimum(Comp(compssofar,e[t][1]), Comp(compssofar,e[t][2]))] :=
 Union([compssofar[Comp(compssofar,e[t][1])],compssofar[Comp(compssofar,e[t][2])]]);
compssofar[Maximum(Comp(compssofar,e[t][1]), Comp(compssofar,e[t][2]))] := [];
t := t+1;
check := 1;
fi;

if check =  0 and
 e[t][1] in Union(compssofar) and e[t][2] in Union(compssofar)
and Comp(compssofar,e[t][1]) = Comp(compssofar,e[t][2])
then t := t+1;
fi;


check := 0;

od;

for t in [1 .. 2*n] do
if not t in Union(compssofar) then
compssofar[ncompssofar+1] := [t];
ncompssofar := ncompssofar +1;
fi;
od;

c := compssofar;
return c;
end;

Ncomps := function(x)
local s,t;
t := 0;
for s in [1 .. 2*n] do
if Length(Components(x)[s]) > 0 then t := t+1;
fi;
od;
return t;
end;

cg := Components(G);



##  Check for inverse pairs in different (nontrivial) components ##
##  call such a pair redvert and redverti, and call their
## corresponding components redcomp and redcompi

redvert := 0;
redverti := 0;
redcomp1 := [];
redcomp2 := [];
for i in [1 .. 2*n] do
if not Comp(cg, i) = Comp(cg, Label(Label(i)^-1))
and Length(G[i]) > 0
then redcomp1 := cg[Comp(cg,i)];
redcomp2 := cg[ Comp(cg, Label(Label(i)^-1))];
redvert := i;
redverti := Label(Label(redvert)^-1);
fi;
od;



## Cut vertex functions ##


IsCutVertex := function(a, b)
local s, acut  ;
acut := [1 .. 2*n];
for s in [1 .. 2*n] do
acut[s] := a[s];
od;

if MyDegree(a,b) = 0 then
return 0;
fi;

if MyDegree(a,b) > 0 then

for s in [1 .. MyDegree(a,b)] do
acut[acut[b][s]]:= Filtered(acut[acut[b][s]],x -> x<>b);
od;


acut[b] := [];


if Ncomps(acut) > Ncomps(a)+1 then
return 1;
fi;
if Ncomps(acut) = Ncomps(a)+1 then
return 0;
fi;

fi;
end;


## This gives the components of graph a with bth vertex removed

CutComponents := function(a,b)

local t, acut, z;
acut := [1 .. 2*n];
for t in [1 .. 2*n] do
acut[t] := a[t];
od;

z := [];

if MyDegree(a,b) = 0 then
return 0;
fi;

if MyDegree(a,b) > 0 then

for t in [1 .. MyDegree(a,b)] do
acut[acut[b][t]]:= Filtered(acut[acut[b][t]],x -> x<>b);
od;

acut[b] := [];
fi;

for t in [1 .. 2*n] do
if not Components(acut)[t] in cg 
 and not Components(acut)[t] = [b] then
Add(z, Components(acut)[t]);
fi;
od;
return(z);
end;


## If no inverse pairs in different comps, then look for cut vertex ##


cutvertex := 0;

if redvert = 0 then

i := 1;

while cutvertex = 0 and i < 2*n do
if IsCutVertex(G,i) = 1 then
cutvertex := i;
redvert := i;
redverti := Label(Label(redvert)^-1);
ccg := CutComponents(G,i);
for j in [1 .. Length(ccg)] do
if Label(Label(i)^-1) in ccg[j] then
redcomp1 := [i];
for k in [1 .. 2*n] do
if k in Union(ccg)
and not k in ccg[j]
then Add(redcomp1, k);
fi;
od;
fi;
od;
fi;
i := i+1;
od;

if redvert = 0 then
reduced := 1;
fi;

fi;


## Change Graph ##
# the disk corresponding to redvert changes into
# the band sum of all disks in redcomp1.  This means that all edges
# involving redvert or redverti change, as do all edges that
# cross into or out of redcomp1.  Remaining edges stay the same.
# There are several cases for how an edge changes, depending on
# which of its endpoints lie in redcomp1, and, if it involves
# redvert or redverti, which of
# its successor's endpoints lie in redcomp1

if reduced = 0 then

newedges := [1 .. nwords];
for i in [1 .. nwords] do
newedges[i] := [];
od;
 
for i in [1 .. nwords] do
for j in [1 .. Length(edges[i])] do

## Case of both endpoints in redcomp1-- edge stays the same.

if edges[i][j][1] in redcomp1 and edges[i][j][2] in redcomp1 then
if not edges[i][j][1] = redvert and not edges[i][j][2] = redvert
 then Add(newedges[i], edges[i][j]);
fi;

## Case of terminal endpoint= redvert.  Then initial endpoint
# is in redcomp1, and edge change depends on whether
# terminal endpoint of successor is in redcomp1 or not.

if not edges[i][j][1] = redvert and edges[i][j][2] = redvert then
if edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [edges[i][j][1], redvert]);
fi;
if not edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [edges[i][j][1], edges[i][Rem(j+1,Length(edges[i]))][2]]);
fi;
fi;
fi;

# Case of init endpoint in redcomp1 and terminal endpoint outside
# This implies one endpoint is a cut vertex


if edges[i][j][1] in redcomp1 and not edges[i][j][2] in redcomp1 then
if not edges[i][j][1] = redvert and not edges[i][j][2] = redverti then
Add(newedges[i], [edges[i][j][1], redverti]);
Add(newedges[i], [redvert, edges[i][j][2]]);
fi;

if not edges[i][j][1] = redvert and edges[i][j][2] = redverti then
Add(newedges[i], [edges[i][j][1], redverti]);
if edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redvert, edges[i][Rem(j+1,Length(edges[i]))][2]]);
fi;
if not edges[i][Rem(j+2)][2] in redcomp1 then
Add(newedges[i], [redvert, redverti]);
fi;
fi;

if edges[i][j][1] = redvert and not edges[i][j][2] = redverti then
Add(newedges[i], [redvert, edges[i][j][2]]);
fi;

if edges[i][j][1] = redvert and edges[i][j][2] = redverti then
if edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redvert,edges[i][Rem(j+1,Length(edges[i]))][2]]);
fi;
if  not edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redvert, redverti]);
fi;
fi;
fi;

if not  edges[i][j][1] in redcomp1 and edges[i][j][2] in redcomp1 then
if not edges[i][j][1] = redverti and not edges[i][j][2] = redvert then
Add(newedges[i], [edges[i][j][1], redvert]);
Add(newedges[i], [redverti, edges[i][j][2]]);
fi;

if not edges[i][j][1] = redverti and edges[i][j][2] = redvert then
Add(newedges[i], [edges[i][j][1], redvert]);
if edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redverti, redvert]);
fi;
if not edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redverti, edges[i][Rem(j+1,Length(edges[i]))][2]]);
fi;
fi;

if edges[i][j][1] = redverti and not edges[i][j][2] = redvert then
Add(newedges[i], [redverti, edges[i][j][2]]);
fi;

if edges[i][j][1] = redverti and edges[i][j][2] = redvert then
if edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redverti, redvert]);
fi;
if not edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [redverti, edges[i][Rem(j+1,Length(edges[i]))][2]]);
fi;
fi;
fi;

if not edges[i][j][1] in redcomp1 and not edges[i][j][2] in redcomp1 then
if not edges[i][j][1] = redverti and not edges[i][j][2] = redverti then
Add(newedges[i], edges[i][j]);
fi;
if not edges[i][j][1] = redverti and edges[i][j][2] = redverti then
if edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [edges[i][j][1], edges[i][Rem(j+1,Length(edges[i]))][2]]);
fi;
if not edges[i][Rem(j+1,Length(edges[i]))][2] in redcomp1 then
Add(newedges[i], [edges[i][j][1], redverti]);
fi;
fi;
fi;

od;

edges[i] := newedges[i];

od;

fi;



#Change vertex record-- keeps track of how the disk basis for the handlebody
#changes, as a vector space

newrow := [1 .. n];
for i in [1 .. n] do
newrow[i] := 0;
od;

if redvert in [1 .. n] then
for i in redcomp1 do

if i in [1 .. n] then
newrow := newrow+V[i];
fi;

if i in [n+1 .. 2*n] then
newrow := newrow -  V[i-n];
fi;

od;
V[redvert] := ShallowCopy(newrow);
fi;

if redvert in [n+1 .. 2*n] then
for i in redcomp1 do

if i in [1 .. n] then
newrow := newrow - V[i];
fi;

if i in [n+1 .. 2*n] then
newrow := newrow + V[i-n];
fi;

od;
V[redvert-n] := ShallowCopy(newrow);
fi;



pass := pass+1;
od;


#Rearrange V so that it only gives unbusted disks


newV := [];
for i in [1 .. n] do
if Length(cg[Comp(cg,i)]) = 1 then Add(newV,ShallowCopy(V[i]));
fi;
od;

V := ShallowCopy(newV);

#Print out info of reduced graph#


Print("Graph reduced after ");
Print(pass-1);
Print(" passes");
Print("\n");
#Print("Graph:  ");
#Print(G);
#Print("\n");
#Print("Components of G: ");
#Print(Components(G));
#Print("\n");

busts := n;
for i in [1 .. Length(cg)] do
if Length(cg[i]) = 1  and cg[i][1] < n+1 then
busts := busts-1;
fi;
od;

isbusting := 0;
if Length(cg[1]) = 2*n then
isbusting := 1;
fi;




return [isbusting, busts, V];
end;