InfoStoreBetterDHVtx := Ignore;
InfoUpdateHistory := Ignore;
InfoUpdateTriple :=Ignore;
InfoReductionDH := Ignore;
InfoReductionHistory := Ignore;
InfoDiffHistoryVtx := Ignore;
InfoDiffReducedWord := Ignore;
InfoDiffReducedWord2 := Ignore;
InfoSubstringClosure := Ignore;
InfoWdAcceptor := Print;
InfoCorrectDiffMachine := Ignore;
InfoCorrectDiffMachine2 := Ignore;
InfoTestAutomatic := Ignore;
WordOrder := function(arg)
local type, generators,invAlphabet, weight, level, maxLevel, getWeight,
history, updateHistory, reductionHistory, betterThanHistory,
F,i,monoidGenerators, IdWord;
# Because GAP freely reduces words as it multiplies them, I have
# made a second set of generators, the monoidGenerators. When
# I need to make words which aren't freely reduced, I use those.
# When GAP stops freely reducing words during multiplication,
# all occurrences of monoidGenerators can be replaced by
# generators - SR
if IsKBMAGRewritingSystemRep(arg[1]) then
generators := arg[1]!.alphabet;
invAlphabet := arg[1]!.invAlphabet;
type := arg[1]!.ordering;
if type="wtlex" or type="wtshortlex" then weight := arg[1]!.weight;
elif type="wreathprod" then level := arg[1]!.level;
fi;
elif IsGroup(arg[1]) then
type := arg[2];
generators := [];
invAlphabet := [];
for i in [1..Length(arg[2].alphabet)] do
generators[2*i-1] := arg[2].alphabet[i];
invAlphabet[2*i] := arg[2].alphabet[i];
generators[2*i] := arg[2].alphabet[i]^-1;
invAlphabet[2*i-1] := arg[2].alphabet[i]^-1;
od;
if type="wtlex" or type="wtshortlex" then weight := arg[3];
elif type="wreathprod" then level := arg[3];
fi;
fi;
F := FreeGroup(Length(generators));
monoidGenerators := ShallowCopy(GeneratorsOfGroup(F));
IdWord := One(F);
if type="wtlex" or type="wtshortlex" then
getWeight := function(w)
local wt,i;
wt:= 0;
for i in [1..Length(w)] do
wt := wt + weight[Position(generators,Subword(w,i,i))];
od;
return wt;
end;
elif type="wreathprod" then
maxLevel := 0;
for i in [1..Length(level)] do
if level[i]>maxLevel then maxLevel := level[i]; fi;
od;
history := function(g,h)
local longer, lev_v, lev_u, seq;
seq := [];
lev_v:= level[g];
if h=0 then
longer:=1;
lev_u := 0;
seq[lev_v] := [0,monoidGenerators[g],IdWord];
else
longer:=0;
lev_u := level[h];
if level[g]=level[h] then
if (g>h) then seq[lev_v] := [1,IdWord,IdWord];
else seq[lev_v] := [-1,IdWord,IdWord]; # g and h cannot be equal
fi;
else
seq[lev_v] := [0,monoidGenerators[g],IdWord];
seq[lev_u] := [0,IdWord,monoidGenerators[h]];
fi;
fi;
return rec(longer:= longer,lev_v:=lev_v,lev_u:=lev_u,seq:=seq);
end;
updateHistory := function(oldHist,g,h,N)
local hist, longer,lev_v,lev_u,seq,
outOfBounds, foundInt, j,
updateTriple;
InfoUpdateHistory("Entering updateHistory with ",
oldHist," ",g," ",h,"\n");
# this function is local to updateHistory
updateTriple := function(oldTriple,g,h)
# Either g or h might be zero, but not both,
# these may not both be the g and h in the argument set of
# updateHistory
# If non-zero, g or h has the right level for the triple.
local oldC, oldV2, oldU2, c,v2,u2,gg,hh;
InfoUpdateTriple("Entering updateTriple with ",
oldTriple," ",g," ",h,"\n");
oldC := oldTriple[1];
oldV2 := oldTriple[2];
oldU2 := oldTriple[3];
if Length(oldV2) = 0 and g=0 then
InfoUpdateTriple("Leaving updateTriple with ",
" ",oldC," ",IdWord," ",oldU2*monoidGenerators[h],"\n");
return [oldC,IdWord,oldU2*monoidGenerators[h]];
elif Length(oldU2) = 0 and h=0 then
InfoUpdateTriple("Leaving updateTriple with ",
" ",oldC," ",oldV2*monoidGenerators[g]," ",IdWord,"\n");
return [oldC,oldV2*monoidGenerators[g],IdWord];
fi;
if Length(oldV2) = 0 then
gg := g;
v2 := IdWord;
elif Length(oldV2) = 1 then
gg := Position(monoidGenerators,Subword(oldV2,1,1));
if g<> 0 then v2 := monoidGenerators[g];
else v2 := IdWord; fi;
else
gg := Position(monoidGenerators,Subword(oldV2,1,1));
if g<> 0 then
v2 := Subword(oldV2,2,Length(oldV2))*monoidGenerators[g];
else
v2 := Subword(oldV2,2,Length(oldV2));
fi;
fi;
if Length(oldU2) = 0 then
hh := h;
u2 := IdWord;
elif Length(oldU2) = 1 then
hh := Position(monoidGenerators,Subword(oldU2,1,1));
if h<> 0 then u2 := monoidGenerators[h];
else u2 := IdWord; fi;
else
hh := Position(monoidGenerators,Subword(oldU2,1,1));
if h<> 0 then
u2 := Subword(oldU2,2,Length(oldU2))*monoidGenerators[h];
else
u2 := Subword(oldU2,2,Length(oldU2));
fi;
fi;
if oldC=0 and gg>hh then c:= 1;
elif oldC=0 and gg<hh then c:= -1;
else c := oldC;
fi;
InfoUpdateTriple("Leaving updateTriple with ",
" ",c," ",v2," ",u2,"\n");
return [c,v2,u2];
end;
if oldHist.longer=1 and h<>0 then return []; fi;
seq := ShallowCopy(oldHist.seq);
if g=0 or level[g]<oldHist.lev_v then lev_v := oldHist.lev_v;
# we allow g=0 only during lookahead for reduction - i.e. such
# histories don't get stored
else lev_v := level[g];
fi;
if h=0 or level[h]<oldHist.lev_u then lev_u := oldHist.lev_u;
else lev_u := level[h];
fi;
if h=0 then
longer:=1;
if lev_v=level[g] then
if not IsBound(oldHist.seq[lev_v]) then
seq[lev_v] := [0,monoidGenerators[g],IdWord];
elif IsList(oldHist.seq[lev_v]) then
seq[lev_v] := updateTriple(oldHist.seq[lev_v],g,h);
fi;
fi; # if g has level less than lev_v nothing gets changed
elif g=0 then
longer:= -1;
if lev_u=level[h] then
if not IsBound(oldHist.seq[lev_u]) then
seq[lev_u] := [0,IdWord,monoidGenerators[h]];
elif IsList(oldHist.seq[lev_u]) then
seq[lev_u] := updateTriple(oldHist.seq[lev_u],g,h);
fi;
fi; # if h has level less than lev_u nothing gets changed
else
longer:=0;
if lev_v=lev_u and lev_v=level[g] and lev_u=level[h] then
if not IsBound(oldHist.seq[lev_v]) then
if g>h then seq[lev_v] := [1,IdWord,IdWord];
elif g<h then seq[lev_v] := [-1,IdWord,IdWord];
fi;
elif IsList(oldHist.seq[lev_v]) then
seq[lev_v] := updateTriple(oldHist.seq[lev_v],g,h);
fi;
else
if lev_v=level[g] then
if not IsBound(oldHist.seq[lev_v]) then
seq[lev_v] := [0,monoidGenerators[g],IdWord];
elif IsList(oldHist.seq[lev_v]) then
seq[lev_v] := updateTriple(oldHist.seq[lev_v],g,0);
fi;
fi;
if lev_u=level[h] then
if not IsBound(oldHist.seq[lev_u]) then
seq[lev_u] := [0,IdWord,monoidGenerators[h]];
elif IsList(oldHist.seq[lev_u]) then
seq[lev_u] := updateTriple(oldHist.seq[lev_u],0,h);
fi;
fi;
fi;
fi;
InfoUpdateHistory("seq is now ",seq,"\n");
if lev_v>lev_u then j := lev_v; else j := lev_u; fi;
foundInt := false;
outOfBounds := false;
while j>= 1 do
if IsBound(seq[j]) then
if foundInt then Unbind(seq[j]);
elif IsList(seq[j]) then
if seq[j][1]=0 and Length(seq[j][2])=0
and Length(seq[j][3])=0 then
# if all entries are trivial delete that triple
Unbind(seq[j]);
elif j<lev_v and j<lev_u then
# only 1 or -1 should be stored, if anything
InfoUpdateHistory("seq at ",j," to ",seq[j],"\n");
InfoUpdateHistory("?1=",seq[j][2]," ",Length(seq[j][2])<> 0,"\n");
InfoUpdateHistory("?2=",Length(seq[j][3])<> 0,"\n");
InfoUpdateHistory("?3=",seq[j][1]<> 0,"\n");
if Length(seq[j][2])<> 0 then seq[j] := 1;
elif Length(seq[j][3])<> 0 then seq[j] := -1;
elif seq[j][1]<>0 then seq[j] := seq[j][1];
else Unbind(seq[j]);
fi;
InfoUpdateHistory("Set seq at ",j," to ",seq[j],"\n");
elif j<lev_v or g=0 then
if Length(seq[j][2])=0 and
(seq[j][1]= -1 or Length(seq[j][3])<>0) then
seq[j] := -1;
InfoUpdateHistory("Setting seq at ",j," to -1\n");
fi;
elif j<lev_u or h=0 then
if Length(seq[j][3])=0 and
(seq[j][1]= 1 or Length(seq[j][2])<>0) then
seq[j] := 1;
InfoUpdateHistory("Setting seq at ",j," to 1\n");
fi;
fi;
if IsList(N)
and IsBound(seq[j]) and IsList(seq[j])
# it WAS a list, but might not be any more
and Length(seq[j][3])>N[j] then
outOfBounds := true;
fi;
fi;
if IsBound(seq[j]) and IsInt(seq[j]) then foundInt := true; fi;
if outOfBounds then j:= 0; fi;
fi;
j := j-1;
od;
InfoUpdateHistory("seq is now ",seq,"\n");
InfoUpdateHistory("Leaving updateHistory\n");
if outOfBounds then return [];
else
hist := rec(longer := longer,lev_v := lev_v, lev_u := lev_u,
seq := seq);
return [hist];
fi;
end;
reductionHistory := function(history,g,h)
local j,hh,newhist, seq;
# This function should probably be rewritten - it is presumably
# rather inefficient to call updateHistory
InfoReductionHistory("Entering reductionHistory for ",
history," ",g," ",h,"\n");
if IsInt(h) then
newhist := updateHistory(history,g,h,0);
else # h is a word
if g<>0 then Error("Arguments of reductionHistory out of range."); fi;
j := 1;
newhist := [StructuralCopy(history)];
repeat
hh := Position(generators,Subword(h,j,j));
newhist := updateHistory(newhist[1],0,hh,0);
j := j+1;
until j>Length(h) or Length(newhist)=0;
fi;
# newhist is a wrapped history or an empty list
InfoReductionHistory("newhist is now ",newhist,"\n");
if Length(newhist)=0 then return false;
else
seq := newhist[1].seq;
InfoReductionHistory("seq is now ",seq,"\n");
j := maxLevel;
while j>=1 do
InfoReductionHistory("j= ",j," ",seq,"\n");
if IsBound(seq[j]) then
if IsInt(seq[j]) then
if seq[j]=1 then return true;
else return false;
fi;
else # we have a list
if Length(seq[j][2])<>0 then return true;
elif Length(seq[j][3])<>0 then return false;
elif seq[j][1]=1 then return true;
else return false;
fi;
fi;
fi;
j := j-1;
od;
fi;
Error("Reached end of reductionHistory function");
end;
betterThanHistory := function(hist1,hist2)
local j;
if hist1.longer=1 and hist2.longer=1 then
if hist2.lev_v> hist2.lev_u then return false;
elif hist2.lev_v = hist2.lev_u then
j := hist2.lev_v;
while not IsBound(hist2.seq[j]) do j := j-1; od;
if IsInt(hist2.seq[j]) and hist2.seq[j]=1
then return false;
fi;
# hist2 ALWAYS leads to a reduction so no history can be
# better than it
fi;
if hist1.lev_v> hist1.lev_u then return true;
elif hist1.lev_v = hist1.lev_u then
j := hist1.lev_v;
while not IsBound(hist1.seq[j]) do j := j-1; od;
if IsInt(hist1.seq[j]) and hist1.seq[j]=1
then return false;
fi;
# hist1 ALWAYS leads to a reduction
fi;
fi;
return "dontknow";
end;
fi;
if type = "shortlex" then
return rec(
type := "shortlex",
alphabet := generators,
monoidGenerators := monoidGenerators,
invAlphabet := invAlphabet,
compareGens := function(g,h)
if g=h then return 0; fi;
# g and h should either both be integers or both be generators
if IsWord(g) then
g := Position(generators,g);
h := Position(generators,h);
fi;
if g>h then return 1; else return -1; fi;
end,
diffHistory := function(d,g,h)
if h=0 then return rec(diff:=d,c0:=0,c1:=1);
elif g>h then return rec(diff:=d,c0:=1,c1:=0);
else return rec(diff:=d,c0:=-1,c1:=0);
fi;
end,
updateDH := function(dh,dd,g,h,wd)
if h>0 and dh.c0<>0 then return rec(diff:=dd,c0:=dh.c0,c1:=0);
elif h=0 then return rec(diff:= dd,c0:= 0,c1:= 1);
else Error("Parameters out of range for updateDH");
fi;
end,
improveDH := function(dh1,dh2)
if (dh2.c0=0 or (dh1.c0<>0 and dh1.c0>=dh2.c0))
and (dh2.c1=0 or dh1.c1 >= dh2.c1)
then return;
else
if dh2.c0<>0 and (dh1.c0=0 or dh2.c0=1) then dh1.c0 := dh2.c0; fi;
if dh2.c1=1 and dh1.c1=0 then dh1.c1 := dh2.c1; fi;
return;
fi;
end,
reductionDH := function(dh,g,h)
if IsInt(h) then
if h>0 and dh.c0=1 then return true;
elif h=0 then return true;
fi;
elif IsWord(h) then
if g<>0 or Length(h)=0 or dh.c0=0 then
Error("Parameters out of range for reductionDH");
fi;
fi;
return false;
end,
emptyDH := function(dh)
return dh.c0=0 and dh.c1=0;
end,
equalLengthsDH := function(dh)
return dh.c0<>0;
end,
diffHistoryVtx := function(d,g,h)
if g>0 then
if h=0 then return rec(diff:= d,gen := 0,back:= 0,len:= 1,lex := 0);
elif g>h then return rec(diff:= d,gen := h,back:= 0,len:= 1,lex := 1);
elif g<h then return rec(diff:= d,gen := h,back:= 0,len:= 1,lex := -1);
else Error("Parameters out of range for diffHistoryVtx");
fi;
else Error("Parameters out of range for diffHistoryVtx");
fi;
end,
updateDHVtx := function(dhv,d,g,h)
return rec(diff:=d,gen:=h,back:=dhv,len:=dhv.len+1,lex:=dhv.lex);
end,
reductionDHVtx := function(dhv,g,h)
if IsInt(h) then
if g>0 and (h=0 or dhv.lex=1) then return true; fi;
elif IsWord(h) then
if g<>0 or Length(h)=0 then
Error("Parameters out of range for reductionDH");
fi;
fi;
return false;
end,
betterThanDHVtx := function(dhv1,dhv2)
# dhv1 and dhv2 are diffHistories for pairs (w,u) and (w,v)
# which lead to the same word difference.
# The function returns "false" if it is clear that
# whenever (wa,ub) leads to the identity word difference and
# wa > ub then also wa > vb and hence there is no value in
# storing dhv1,
# "true" if the above is not clear, BUT it is clear that
# whenever (wa,vb) leads to the identity word difference and
# wa > vb then also wa > ub and hence we can store dhv1 instead
# of dhv2,
# "dontknow" if neither or the above is clear, and so we should
# store both dhv1 and dhv2.
# When dhv1 is better than dhv2,
# we must have dhv1.diff=dhv2.diff and dhv1.gen and dhv2.gen
# both non-zero.
# We can only be certain that u<v if dhv1.lex=1 and dhv2.lex= -1,
# since in that case we know that u<w and w<v
local g1,g2;
if dhv1.diff<> dhv2.diff then return "dontknow"; fi;
g1:= dhv1.gen; g2 := dhv2.gen;
if g1=0 and g2=0 then return false; # u and v are both shorter than w
elif g1=0 or g2=0 then return "dontknow";
fi;
if dhv1.lex=1 and dhv2.lex= -1 then return true;
else return false;
fi;
end
);
elif type="wtlex" then
return rec(
type := "wtlex",
alphabet := generators,
monoidGenerators := monoidGenerators,
invAlphabet := invAlphabet,
weight := weight,
getWeight := getWeight,
compareGens := function(g,h)
if g=h then return 0; fi;
# g and h should either both be integers or both be generators
if IsWord(g) then
g := Position(generators,g);
h := Position(generators,h);
fi;
if weight[g]>weight[h] then return 1;
elif weight[g]<weight[h] then return -1;
elif g>h then return 1;
else return -1; fi;
end,
diffHistory := function(d,g,h)
if h=0 then
return rec(diff:=d,c0:=0,w0:=0,c1 := 1,w1:= 1);
elif g>h then
return rec(diff:=d,c0:=1,w0:=weight[g]-weight[h],c1:=0,w1:=0);
elif g<h then
return rec(diff:=d,c0:= -1,w0:=weight[g]-weight[h],c1:=0,w1:=0);
else Error("Parameters for diffHistory out of range");
fi;
end,
updateDH := function(dh,dd,g,h,wd)
local c0,w0,c1,w1;
if h>0 and dh.c0<>0 then
w0 := dh.w0 + weight[g] - weight[h];
if w0 >= -getWeight(wd) then c0 := dh.c0; else c0 := 0; fi;
return rec(diff:=dd,c0:=c0,w0 := w0,c1:=0,w1:=0);
elif h=0 then
if dh.c0<>0 and dh.c1<>0 then
# Choose the bigger weight difference in dh, add the weight of g
# to it and then set w1 to be the minimum of that and 1.
# c1 is set to be dh.c0 if dh.w0>dh.w1, to be dh.c1 if dh.w1>dh.w0
# and otherwise the larger of dh.c0 and dh.c1.
if dh.w0>dh.w1 then
if dh.w0+weight[g]>0 then w1 := 1; else w1 := dh.w0+weight[g]; fi;
c1 := dh.c0;
elif dh.w1>dh.w0 then
if dh.w1+weight[g]>0 then w1 := 1; else w1 := dh.w1+weight[g]; fi;
c1 := dh.c1;
else
if dh.w1+weight[g]>0 then w1 := 1; else w1 := dh.w1+weight[g]; fi;
if dh.c1 >= dh.c0 then c1 := dh.c1; else c1 := dh.c0; fi;
fi;
elif dh.c0<>0 then
if dh.w0+weight[g]>0 then w1 := 1; else w1 := dh.w0+weight[g]; fi;
c1 := dh.c0;
elif dh.c1<>0 then
if dh.w1+weight[g]>0 then w1 := 1; else w1 := dh.w1+weight[g]; fi;
c1 := dh.c1;
fi;
if w1 < - getWeight(wd) then c1 := 0; fi;
return rec(diff:=dd,c0:=0,w0:=0,c1:=c1,w1:=w1);
else
Error("Parameters out of range for updateDH");
fi;
end,
improveDH := function(dh1,dh2)
if dh2.c0<>0 and
(dh1.c0=0 or dh1.w0<dh2.w0 or (dh1.w0=dh2.w0 and dh2.c0=1)) then
dh1.c0 := dh2.c0; dh1.w0 := dh2.w0;
fi;
if dh2.c1<>0 and
(dh1.c1=0 or dh1.w1 < dh2.w1 or (dh1.w1=dh2.w1 and dh2.c1=1)) then
dh1.c1 := dh2.c1; dh1.w1 := dh2.w1;
fi;
end,
reductionDH := function(dh,g,h)
if IsInt(h) then
if h>0 and dh.c0<>0 then
# Return true if or some v,u with vg=_Gu, where l(vg)=l(u),
# either wt(vg)>wt(u) or wt(vg)=wt(u) but vg>u lexicographically.
if dh.w0 + weight[g]-weight[h]>0 or
(dh.w0+weight[g]-weight[h]=0 and dh.c0=1) then return true; fi;
elif h=0 then
# Return true if gfor some v,u with vg=_Gu, where l(vg)>l(u),
# either wt(vg)>wt(u) or wt(vg)=wt(u) but vg>u lexicographically.
# The cases l(v)=l(u) and l(v)>l(u) are considered separately
if (dh.c0=1 and dh.w0 + weight[g]>=0) or
(dh.c0= -1 and dh.w0 + weight[g]>0) or
(dh.c1=1 and dh.w1 + weight[g]>=0) or
(dh.c1= -1 and dh.w1 + weight[g]>0) then return true; fi;
fi;
return false;
elif IsWord(h) then
if g<>0 or Length(h)=0 or dh.c0=0 then
Error("Parameters out of range for reductionDH");
elif dh.w0 - getWeight(h) >0 or
( dh.c0=1 and dh.w0-getWeight(h)=0) then return true;
fi;
return false;
fi;
end,
emptyDH := function(dh)
return dh.c0=0 and dh.c1=0;
end,
equalLengthsDH := function(dh)
return dh.c0<>0;
end,
diffHistoryVtx := function(d,g,h)
if g>0 then
if h=0 then return rec(diff:= d,gen := 0,back:= 0,
len:= 1,lex := 0,wtdiff:=weight[g]);
elif g>h then return rec(diff:= d,gen := h,back:= 0,
len:= 1,lex := 1,wtdiff:=weight[g]-weight[h]);
elif g<h then return rec(diff:= d,gen := h,back:= 0,
len:= 1,lex := -1,wtdiff:=weight[g]-weight[h]);
else Error("Parameters out of range for diffHistoryVtx");
fi;
else Error("Parameters out of range for diffHistoryVtx");
fi;
end,
updateDHVtx := function(dhv,d,g,h)
if g>0 then
if h=0 then return rec(diff:=d,gen := h,back := dhv,
len := dhv.len+1,lex := dhv.lex,wtdiff:=dhv.wtdiff+weight[g]);
else return rec(diff:= d,gen := h,back:= dhv, len := dhv.len+1,
lex := dhv.lex,wtdiff:=dhv.wtdiff+weight[g]-weight[h]);
fi;
else Error("Parameters out of range for updateDHVtx");
fi;
end,
reductionDHVtx := function(dhv,g,h)
if IsInt(h) then
if g>0 and h>0 then
if dhv.wtdiff + weight[g]-weight[h]>0 or
(dhv.wtdiff+weight[g]-weight[h]=0 and dhv.lex=1) then return true;
fi;
elif g>0 and h=0 then
if dhv.wtdiff+weight[g]> 0 or
(dhv.wtdiff+weight[g]=0 and dhv.lex=1) then return true;
fi;
else Error("Parameters out of range for reductionDHVtx");
fi;
elif IsWord(h) then
if g<>0 or Length(h)=0 then
Error("Parameters out of range for reductionDHVtx");
elif dhv.wtdiff - getWeight(h) >0 or
( dhv.wtdiff-getWeight(h)=0 and dhv.lex=1) then return true;
fi;
fi;
return false;
end,
betterThanDHVtx := function(dhv1,dhv2)
# dhv1 and dhv2 are diffHistories for pairs (w,u) and (w,v)
# which lead to the same word difference.
# The function returns "false" if it is clear that
# whenever (wa,ub) leads to the identity word difference and
# wa > ub then also wa > vb and hence there is no value in
# storing dhv1,
# "true" if the above is not clear, BUT it is clear that
# whenever (wa,vb) leads to the identity word difference and
# wa > vb then also wa > ub and hence we can store dhv1 instead
# of dhv2,
# "dontknow" if neither or the above is clear, and so we should
# store both dhv1 and dhv2.
local g1,g2;
if dhv1.diff<> dhv2.diff then return "dontknow"; fi;
g1:= dhv1.gen; g2 := dhv2.gen;
if g1=0 and g2=0 then
if dhv1.wtdiff>dhv2.wtdiff then return true;
else return false; # u and v are both shorter than w
fi;
elif g1=0 or g2=0 then return "dontknow";
fi;
if dhv1.wtdiff>dhv2.wtdiff or
(dhv1.wtdiff=dhv2.wtdiff and dhv1.lex=1 and dhv2.lex= -1)
then return true;
else return false;
fi;
end
);
elif type = "wreathprod" then
return rec(
type := "wreathprod",
alphabet := generators,
invAlphabet := invAlphabet,
monoidGenerators := monoidGenerators,
level := level,
maxLevel := maxLevel,
compareGens := function(g,h)
if g=h then return 0; fi;
# g and h should either both be integers or both be generators
if IsWord(g) then
g := Position(generators,g);
h := Position(generators,h);
fi;
if level[g]>level[h] then return 1;
elif level[g]<level[h] then return -1;
elif g>h then return 1;
else return -1; fi;
end,
diffHistory := function(d,g,h)
return rec(diff:=d,histories:= [history(g,h)]);
end,
updateDH := function(dh,dd,g,h,wd)
local new,N,i,j,histories;
N := [];
j := maxLevel;
while j>0 do N[j] := 0; j := j-1; od;
for i in [1..Length(wd)] do
j:= level[Position(generators,Subword(wd,i,i))];
N[j] := N[j]+1;
od;
histories := [];
for i in [1..Length(dh.histories)] do
Append(histories,updateHistory(dh.histories[i],g,h,N));
od;
histories := Set(histories);
return rec(diff := dd,histories := histories);
end,
improveDH := function(dh1,dh2)
Append(dh1.histories,dh2.histories);
dh1.histories := Set(dh1.histories);
end,
reductionDH := function(dh,g,h)
local histories,hist,seq,i,j,hh;
histories := dh.histories;
InfoReductionDH("Entering reductionDH with ",dh," ",g," ",h,"\n");
for i in [1..Length(histories)] do
InfoReductionDH("i:=",i," ",histories[i],"\n");
if reductionHistory(histories[i],g,h) then return true; fi;
od;
return false;
end,
emptyDH := function(dh)
return Length(dh.histories)=0;
end,
equalLengthsDH := function(dh)
local i;
for i in [1..Length(dh.histories)] do
if dh.histories[i].longer=0 then return true; fi;
od;
return false;
end,
diffHistoryVtx := function(d,g,h)
InfoDiffHistoryVtx("New diffHistoryVtx ",g," ",h," ",history(g,h),"\n");
if g>0 then
return rec(diff:=d,gen := h,back:=0,len := 1,history:=history(g,h));
elif g=h then Error("g=h, Parameters out of range for diffHistoryVtx");
else Error("Parameters out of range for diffHistoryVtx");
fi;
end,
updateDHVtx := function(dhv,d,g,h)
local newHist;
newHist := updateHistory(dhv.history,g,h,0);
InfoDiffHistoryVtx("Updates diffHistoryVtx ",g," ",h," ",newHist,"\n");
if Length(newHist)=1 then
return rec(diff:=d,gen:=h,back:=dhv,len:=dhv.len+1,
history:=newHist[1]);
else
Error("Parameters out of range for diffHistoryVtx");
fi;
end,
reductionDHVtx := function(dhv,g,h)
return reductionHistory(dhv.history,g,h);
end,
betterThanDHVtx := function(dhv1,dhv2)
# dhv1 and dhv2 are diffHistories for pairs (w,u) and (w,v)
# which lead to the same word difference.
# The function returns "false" if it is clear that
# whenever (wa,ub) leads to the identity word difference and
# wa > ub then also wa > vb and hence there is no value in
# storing dhv1,
# "true" if the above is not clear, BUT it is clear that
# whenever (wa,vb) leads to the identity word difference and
# wa > vb then also wa > ub and hence we can store dhv1 instead
# of dhv2,
# "dontknow" if neither or the above is clear, and so we should
# store both dhv1 and dhv2.
if dhv1.diff <> dhv2.diff then return "dontknow";
elif dhv1.history=dhv2.history then return false;
else return betterThanHistory(dhv1.history,dhv2.history);
fi;
end
);
else
Error("Cannot construct word order of type ",type,"\n");
fi;
end;
DiffInverseList := function(D)
local diffInverse, # list of inverses
count, # integer loop parameter
numSymbols, # number of alphabet symbols
g,h, # indexes for alphabet symbols
d, d_inv, dd, dd_inv; # states of D
if IsBound(D.diffInverse) then return D.diffInverse; fi;
BFSFSA(D);
numSymbols := D.alphabet.base.size;
diffInverse := 0*[1..D.states.size];
diffInverse[1] := 1;
count := 1;
d := 1; d_inv := 1;
repeat
for g in [1..numSymbols+1] do
for h in [1..numSymbols+1] do
if g<>numSymbols+1 or h<>numSymbols+1 then
dd:= TargetDFA(D,[g,h],d);
dd_inv:= TargetDFA(D,[h,g],d_inv);
if (dd<>0 and dd_inv=0) or (dd=0 and dd_inv<>0) then
Error ("DiffInverseList: d=",d," dd=",dd," g=",g," h=",
h,"\nd_inv=",d_inv,"dd_inv=",dd_inv,"\n");
fi;
if dd<> 0 and diffInverse[dd]=0 then
diffInverse[dd] := dd_inv; count := count+1; fi;
if dd_inv<>0 and diffInverse[dd_inv]=0 then
diffInverse[dd_inv] := dd; count := count+1; fi;
fi;
od;
od;
d := d+1;
d_inv := diffInverse[d];
until count = D.states.size;
D.diffInverse := diffInverse;
return diffInverse;
end;
WdAcceptor := function(D,order)
local WA, numSymbols, stateList,
s,sg,t, # states of W
S,Sg, # sets of difference histories corresponding to s and sg
g,h,dollar,
d,dd,d0, # states of D
diffInverse, count,
dh,ddh,stored, # difference histories
fails, brk, i;
WA := FSA(D.alphabet.base);
numSymbols := WA.alphabet.size;
d0 := D.initial[1];
dollar := numSymbols+1;
diffInverse := DiffInverseList(D);
stateList := [[]];
# stateList[i] is the set of difference histories corresponding to state i -
# the start state corresponds to the empty set
# first we define targets for the start state
s:= 1;
for g in [1..numSymbols] do
Sg :=[];
fails := false;
# first check to see if g is equal to the identity
dd := TargetDFA(D,[g,dollar],d0);
if dd=d0 then fails := true;
elif dd>0 then
AddSet(Sg, order.diffHistory(dd,g,0));
fi;
# now check to see if g is equal to another generator
h:=1;
while not fails and h <= numSymbols do
dd := TargetDFA(D,[g,h],d0);
if dd=d0 then if order.compareGens(g,h)=1 then fails := true; fi;
elif dd>0 then
ddh := order.diffHistory(dd,g,h);
if order.reductionDH(ddh,0,D.states.names[diffInverse[dd]]) then
fails := true;
fi;
# Run through Sg to see if there's already a diff history for dd
# in there. If so, remove it and modify ddh to include its info.
if not fails then
brk := false;
for stored in Sg do
if not brk and stored.diff = ddh.diff then
RemoveSet(Sg,stored);
order.improveDH(ddh,stored);
brk:=true;
fi;
od;
AddSet(Sg,ddh);
fi;
fi;
h := h+1;
od; # end of loop for h
if not fails then
# we look to see if there's an existing state corresponding to
# the set Sg of difference histories
sg:= 0;
brk := false;
for i in [2..WA.states.size] do
if not brk and stateList[i]=Sg then
sg:= i;
brk:= true;
fi;
od;
if sg=0 then
# we need to build a new state to be the target of s under g
Add(stateList,Sg);
AddStateFSA(WA);
sg := WA.states.size;
SetAcceptingFSA(WA,sg,true);
fi;
AddEdgeFSA(WA,g,s,sg);
fi;
od;
# Now we define targets for all states after the start state,
# until every state has all its targets defined.
s := 2;
while s <= WA.states.size do
S := stateList[s];
if s mod 100 = 0 then
InfoWdAcceptor("Computing images of ",s,"-th state out of ",WA.states.size,"\n");
fi;
for g in [1..numSymbols] do
t := TargetDFA(WA,g,WA.initial[1]);
if t=0 then fails := true;
else
Sg := StructuralCopy(stateList[t]);
fails := false;
i := 1;
while not fails and i <= Length(S) do
dh := S[i];
d := dh.diff;
dd := TargetDFA(D,[g,dollar],d);
if dd=d0 then
if order.reductionDH(dh,g,0) then fails := true; fi;
elif dd>0 then
ddh := order.updateDH(dh,dd,g,0,D.states.names[dd]);
if not order.emptyDH(ddh) then
brk := false;
for stored in Sg do
if not brk and stored.diff=ddh.diff then
RemoveSet(Sg,stored);
order.improveDH(ddh,stored);
brk := true;
fi;
od;
AddSet(Sg,ddh);
fi;
fi;
if order.equalLengthsDH(dh) then
h := 1;
while not fails and h <= numSymbols do
dd := TargetDFA(D,[g,h],d);
if dd=d0 then
if order.reductionDH(dh,g,h) then fails := true; fi;
elif dd>0 then
ddh := order.updateDH
(dh,dd,g,h,D.states.names[dd]);
if not order.emptyDH(ddh) then
if order.reductionDH
(ddh,0,D.states.names[diffInverse[dd]]) then
fails := true;
else
brk := false;
for stored in Sg do
if not brk and stored.diff=ddh.diff then
RemoveSet(Sg,stored);
order.improveDH(ddh,stored);
brk := true;
fi;
od;
AddSet(Sg,ddh);
fi;
fi;
fi;
h := h+1;
od; # end of loop for h
fi;
i := i+1;
od; # end of loop over S
fi;
if not fails then
sg := 0;
for i in [2..WA.states.size] do
if sg=0 and stateList[i]=Sg then sg:= i; fi;
od;
if sg=0 then
Add(stateList,Sg);
AddStateFSA(WA);
sg := WA.states.size;
SetAcceptingFSA(WA,sg,true);
fi;
AddEdgeFSA(WA,g,s,sg);
fi;
od; # end of loop for g
s := s+1;
od; # end of loop for s
return WA;
end;
DiffReducedWord := function(D,order,w)
## this function is a generalisation of the rewrite function used
## in Derek Holt's KBmag Package for the shortlex order.
## We read through the word v which is to be reduced, one generator at
## a time.
## Let x be the generator in position posn.
## Where a is any prefix of the word v finishing before that position,
## all word differences equal to a^-1b where u is no longer than
## w have been found, and form the vertices of a tree.
## Let dhv be one such vertex. At dhv is stored
## 1) the corresponding state of the word difference machine, d
## 2) the length of the word w, the maximal suffix of a such
## that d = w^-1u (for a suffix w of a)
## 3) an integer labelling the last generator y of u, if u has the
## same length as w, otherwise 0 - the integer is h where column
## h of the difference machine represents transitions on y
## 4) a pointer to the a `previous' vertex corresponding to the
## word difference w'^-1u', where w' is the max. prefix of w
## and u' is the max prefix of u if u has the same length as w,
## but otherwise is equal to u. Additional information
## varies according to the word order and indicates the
## relationship between w and u in the order.
local doneSub, # boolean variables, initially false,
# set true after a reduction, but doneSub is reset to false in each loop
Len, len, redlen,i,j,
posn, # current position in word (range from 1 to Length(w))
vno, # the position on the queue of the vertex currently being processed
d,d0,dd,dD, # states of D
x,y, # generators
xx,yy, # integers indexing the generators x and y
ww, # word,
dhv, ddhv, # vertices of the tree
lastvno, # the position of the last vertex on the queue
firstvno, # the position of the first vertex on the queue in the current
# layer (if there is one)
dhvList, # queue of vertices
LastDhv, # LastDhv[i] is the position of the last vertex on the queue
# at the end of layer i.
diffInverse,
seen, # boolean list of differences seen so far
numSymbols,dollar,
bugw1, bugw2,
StoreBetterDHVtx,
IdWord;
IdWord:=w^0;
StoreBetterDHVtx := function(dhv,d)
## dhv is a vertex with difference d.
## dhvList is known to contain a vertex with difference d
## in the layer from firstvno and lastvno.
## We check through the list, and only add dhv to the list if we cannot
## prove that the reduction info it carries isn't already carried by
## a vertex already on the list. As we add dhv, it may be possible to
## remove other vertices from the list.
local i,j,
bT; # true, false or "dontknow", result of comparing two vertices
# corresponding to the same difference
i := firstvno-1;
j:= 0;
bT := "dontknow";
InfoStoreBetterDHVtx("In StoreBetterDHVtx ",lastvno," ");
while j<>fail and bT<>false do
# We search through all the vertices defined at this layer, and
# compare dh with each vertex associated with the difference d
j:= PositionProperty(dhvList{[i+1..lastvno]},x->x.diff=d);
# j is the index of a vertex within the sublist
# of vertices at this layer, rather than the index within the whole list.
if j<>fail then
i := i+j;
# i is reset to be index of the vertex in the full list
bT := order.betterThanDHVtx(dhv,dhvList[i]);
# If bT is false then dhvList[i] is at least as good as dh,
# so there's no point in adding dh to the list.
# If bT is true then dh is better than dhvList[i],
# so dhvList[i] can be deleted from the list.
# if bT is "dontknow" it's not clear which is better.
if bT=true then
InfoStoreBetterDHVtx("Deleting ",dhvList[i],"\n");
dhvList := dhvList{Concatenation([1..i-1],[i+1..lastvno])};
lastvno := lastvno-1;
fi;
fi;
od;
if bT<>false then
Add(dhvList,dhv); lastvno := lastvno+1;
InfoStoreBetterDHVtx("Adding ",dhvList[lastvno],"\n");
fi;
InfoStoreBetterDHVtx(lastvno,"\n");
end;
diffInverse := DiffInverseList(D);
numSymbols := D.alphabet.base.size;
dollar := numSymbols+1;
dhvList := [];
LastDhv := [];
d0 := 1;
posn := 1;
firstvno := 1;
lastvno := 0;
InfoDiffReducedWord("DiffReducedWord called for ",w,"\n");
while posn <= Length(w) do
Len := Length(w);
InfoDiffReducedWord("Word ",w," posn ",posn,"\n");
doneSub := false;
seen := BlistList([1..D.states.size],[]);
x := Subword(w,posn,posn);
xx := Position(order.alphabet,x);
# First we look for reductions of x itself, and if there are
# none construct a vertex for each x^-1y, y a generator or identity
# which is a non-trivial word difference.
d := d0;
dhv := 0;
len := 0;
dd := TargetDFA(D,[xx,dollar],d);
if dd=d0 then
# x reduces to the identity, so we reduce w
InfoDiffReducedWord2("Word ",w," posn ",posn,"->id\n");
w := SubstitutedWord(w,posn,posn,IdWord);
doneSub := true;
# SubstitutedWord may do free reduction - if it does we have to backtrack.
# We subtract (Len-1-Length(w))/2 from posn to deal with this.
# In fact this might take us back too far, if some of the free reduction
# is with the later rather than the earlier section of the word.
posn := posn - (Len-1-Length(w))/2;
if posn<1 then posn := 1; fi;
elif dd<>0 then
ddhv := order.diffHistoryVtx (dd,xx,0);
if seen[dd]=true then
StoreBetterDHVtx(ddhv,dd);
else Add(dhvList,ddhv); lastvno := lastvno+1; seen[dd] := true;
fi;
fi;
yy := 1;
while not doneSub and yy <= numSymbols do
y := order.alphabet[yy];
dd := TargetDFA(D,[xx,yy],d0);
if dd=d0 then
if order.compareGens(xx,yy)=1 then
# x reduces to y, so we reduce w
InfoDiffReducedWord2("Word ",w," posn ",posn,"->",y,"\n");
w := SubstitutedWord(w,posn,posn,y);
doneSub := true;
# SubstitutedWord may do free reduction - if it does we have to backtrack.
# We subtract (Len-Length(w))/2 from posn to deal with this.
# In fact this might take us back too far, if some of the free reduction
# is with the later rather than the earlier section of the word.
posn := posn - (Len - Length(w))/2;
if posn<1 then posn := 1; fi;
fi;
elif dd<>0 then
ddhv := order.diffHistoryVtx(dd,xx,yy);
if order.reductionDHVtx
(ddhv,0,D.states.names[diffInverse[dd]]) then
# x reduces to y*dd_inv, where dd_inv is the word difference
# inverse to dd
InfoDiffReducedWord2("Word ",w," posn ",posn,"->",
y*D.states.names[diffInverse[dd]],"\n");
w := SubstitutedWord(w,posn,posn,y*D.states.names[diffInverse[dd]]);
doneSub := true;
# SubstitutedWord may do free reduction - if it does we have to backtrack.
# We subtract (Len+Length(D.states.names[diffInverse[dd]]-Length(w))/2
# from posn to deal with this.
# In fact this might take us back too far, if some of the free reduction
# is with the later rather than the earlier section of the word.
posn := posn -(Len + Length(D.states.names[diffInverse[dd]])
-Length(w))/2;
if posn<1 then posn := 1; fi;
InfoDiffReducedWord2("Reduction type 1\n");
else
if seen[dd]=true then
StoreBetterDHVtx(ddhv,dd);
else Add(dhvList,ddhv); lastvno := lastvno+1; seen[dd] := true;
fi;
fi;
fi;
yy := yy+1;
od; # end of loop over yy
# Now we work through the vertices created at the last round (i.e.
# those corresponding to non-trivial suffices of the prefix
# a of v which was read before x) and see if one of these
# points to a reduction of ax. If not we create the next
# layer of vertices.
if not doneSub and posn>1 then
if posn=2 then vno:=1;
else vno := LastDhv[posn-2]+1;
# the position on the list of the first of the vertices
# created in the last round
fi;
while not doneSub and vno <= LastDhv[posn-1] do
InfoDiffReducedWord2("vno ",vno,"\n");
dhv := dhvList[vno];
len := dhv.len;
d := dhv.diff;
dd := TargetDFA(D,[xx,dollar],d);
if dd=d0 then
if order.reductionDHVtx(dhv,xx,0) then
ww := IdWord;
ddhv := dhv;
while ddhv<>0 and ddhv.gen=0 do ddhv := ddhv.back; od;
while ddhv<>0 do
ww := order.alphabet[ddhv.gen] * ww; ddhv := ddhv.back;
od;
InfoDiffReducedWord2("Reduction type 2\n");
InfoDiffReducedWord2("Word ",w," posns",posn-len,"-",posn,
"->",ww,"\n");
w := SubstitutedWord(w,posn-len,posn,ww);
doneSub := true;
# SubstitutedWord may do free reduction - if it does we have to backtrack
# further than we would need to otherwise.
# We subtract (Len+Length(ww)-len-1-Length(w))/2 from posn
# to deal with this.
# In fact this might take us back too far, if some of the free reduction
# is with the later rather than the earlier section of the word.
posn := posn -len -(Len+Length(ww)-len--Length(w))/2;
if posn<1 then posn := 1; fi;
fi;
elif dd<> 0 then
ddhv := order.updateDHVtx (dhv,dd,xx,0);
if seen[dd]=true then
StoreBetterDHVtx(ddhv,dd);
else Add(dhvList,ddhv); lastvno := lastvno+1; seen[dd] := true;
fi;
fi;
if dhv.gen<>0 then
yy := 1;
while not doneSub and yy <= numSymbols do
y := order.alphabet[yy];
dd := TargetDFA(D,[xx,yy],d);
if dd=d0 then
if order.reductionDHVtx(dhv,xx,yy) then
ww := y;
ddhv := dhv;
while ddhv<>0 do
ww := order.alphabet[ddhv.gen] * ww; ddhv := ddhv.back;
od;
InfoDiffReducedWord2("Reduction type 3 posn ",posn," len ",len,"\n");
InfoDiffReducedWord2(w," reduced using ",ww," to give ");
w := SubstitutedWord(w,posn-len,posn,ww);
InfoDiffReducedWord2(w,"\n");
doneSub := true;
# SubstitutedWord may do free reduction - if it does we have to backtrack
# further than we would need to otherwise.
# We subtract (Len+Length(ww)-len-1-Length(w))/2 from posn
# to deal with this.
# In fact this might take us back too far, if some of the free reduction
# is with the later rather than the earlier section of the word.
posn := posn -len -(Len+Length(ww)-len-1-Length(w))/2;
if posn<1 then posn := 1; fi;
fi;
elif dd<>0 then
ddhv := order.updateDHVtx(dhv,dd,xx,yy);
if order.reductionDHVtx
(ddhv,0,D.states.names[diffInverse[dd]]) then
# for some suffix a of the word read so far,
# some b of the same length as a,
# ax reduces to by*dd_inv, where dd_inv is the word difference
# inverse to dd
InfoDiffReducedWord2("Reduction type 4\n");
InfoDiffReducedWord2("xx ",xx," yy ",yy," dhv ",dhv,"\n");
InfoDiffReducedWord2("x ",x," y ",y," inv_diff ",
D.states.names[diffInverse[dd]],"\n");
ww := y*D.states.names[diffInverse[dd]];
InfoDiffReducedWord2("ww ",ww,"\n");
ddhv := dhv;
while ddhv<>0 do
ww := order.alphabet[ddhv.gen] * ww; ddhv := ddhv.back;
od;
InfoDiffReducedWord2("ww ",ww,"\n");
InfoDiffReducedWord2("Word ",w," posns",posn-len,"-",posn,
"->",ww,"\n");
bugw1 := w;
w := SubstitutedWord(w,posn-len,posn,ww);
bugw2 := w;
if bugw1=bugw2 then Error("Word hasn't changed."); fi;
doneSub := true;
# SubstitutedWord may do free reduction - if it does we have to backtrack
# further than we would need to otherwise.
# We subtract (Len+Length(ww)-len-1-Length(w))/2 from posn
# to deal with this.
# In fact this might take us back too far, if some of the free reduction
# is with the later rather than the earlier section of the word.
posn := posn -len -(Len+Length(ww)-len-1-Length(w))/2;
if posn<1 then posn := 1; fi;
else
if seen[dd]=true then
StoreBetterDHVtx(ddhv,dd);
else
Add(dhvList,ddhv); lastvno := lastvno+1; seen[dd] := true;
fi;
fi;
fi;
yy := yy+1;
od; # end of loop over yy
fi;
vno := vno + 1;
od; # end of loop over vno
fi;
if doneSub then
if posn=1 then
dhvList := []; firstvno := 1; lastvno := 0;
else
dhvList := dhvList{[1..LastDhv[posn-1]]};
firstvno := LastDhv[posn-1]+1; lastvno := LastDhv[posn-1];
fi;
else
LastDhv[posn] := Length(dhvList);
firstvno := LastDhv[posn]+1; lastvno := LastDhv[posn];
posn := posn + 1;
fi;
od;
InfoDiffReducedWord("Reduction is ",w,"\n");
return w;
end;
SubstringClosure := function(D,order,inverses)
# inverses could be true or false
local DC,s,s_inv,t,t_inv, # states
a,b,a_inv,a_inv_index,b_inv_index,
numSymbols,
oldNumStates,
dollar,
len,
w,w_inv,ww,
diffInverse;
DC := StructuralCopy(D);
if (inverses) then
diffInverse := DiffInverseList(DC);
fi;
numSymbols := D.alphabet.base.size;
dollar := numSymbols +1;
s:= 1;
while s<=DC.states.size do
InfoSubstringClosure("s:=",s,"Total number of states:=",DC.states.size,"\n");
oldNumStates := DC.states.size;
w := DC.states.names[s];
if inverses then
s_inv := diffInverse[s];
w_inv := DC.states.names[s_inv];
fi;
len := Length(w);
if len>=2 then
a := Subword(w,1,1);
b := Subword(w,len,len);
a_inv_index :=order.invAlphabet[Position(order.alphabet,a)];
b_inv_index :=order.invAlphabet[Position(order.alphabet,b)];
a_inv := order.alphabet[a_inv_index];
if TargetDFA(DC,[dollar,b_inv_index],s)=0 then
ww := Subword(w,1,len-1);
t := Position(DC.states.names,ww);
if t=fail then
AddStateFSA(DC,ww);
t := DC.states.size;
fi;
AddEdgeFSA(DC,[dollar,b_inv_index],s,t);
# the above edge is labelled with (dollar,b^-1)
AddEdgeFSA(DC,[dollar,Position(order.alphabet,b)],t,s);
fi;
if inverses and TargetDFA(DC,[b_inv_index,dollar],s_inv)=0 then
ww := DiffReducedWord(D,order,b*w_inv);
t_inv := Position(DC.states.names,ww);
if t_inv=fail and IsBound(diffInverse[t]) then
Error("t_inv problem 1 ",t," ",diffInverse[t],"\n"); fi;
if t_inv=fail then
AddStateFSA(DC,ww);
t_inv := DC.states.size;
fi;
AddEdgeFSA(DC,[b_inv_index,dollar],s_inv,t_inv);
AddEdgeFSA(DC,[Position(order.alphabet,b),dollar],t_inv,s_inv);
diffInverse[t] := t_inv;
diffInverse[t_inv] := t;
InfoSubstringClosure("Set ",t," and ",t_inv," to be inverse pairs.\n");
fi;
if TargetDFA(DC,[Position(order.alphabet,a),dollar],s)=0 then
ww := Subword(w,2,len);
t := Position(DC.states.names,ww);
if t=fail then
AddStateFSA(DC,ww);
t := DC.states.size;
fi;
AddEdgeFSA(DC,[Position(order.alphabet,a),dollar],s,t);
AddEdgeFSA(DC,
[a_inv_index,dollar],t,s);
fi;
if inverses and
TargetDFA(DC,[dollar,Position(order.alphabet,a)],s_inv)=0 then
ww := DiffReducedWord(D,order,w_inv*a);
t_inv := Position(DC.states.names,ww);
if t_inv=fail and IsBound(diffInverse[t]) then
Error("t_inv problem 2\n"); fi;
if t_inv=fail then
AddStateFSA(DC,ww);
t_inv := DC.states.size;
fi;
AddEdgeFSA(DC,[dollar,Position(order.alphabet,a)],s_inv,t_inv);
AddEdgeFSA(DC,[dollar,a_inv_index],t_inv,s_inv);
diffInverse[t] := t_inv;
diffInverse[t_inv] := t;
InfoSubstringClosure("Set ",t," and ",t_inv," to be inverse pairs.\n");
fi;
fi;
s := s+1;
od;
return DC;
end;
CorrectDiffMachine := function(R,order)
local pair, w1,w2,g,newD, inverses,
change,
dollar, d,d_inv,dd,dd_inv,wd,wd_inv,len1,len2,len,i,
x,x_inv,xx,y,y_inv,yy,
IdWord;
InfoCorrectDiffMachine("R.wg:=",R!.wg,"\n");
newD := StructuralCopy(R!.diff2);
inverses := DiffInverseList(newD);
dollar := R!.diff2.alphabet.base.size+1;
IdWord := R!.wg[1][1]^0;
for pair in R!.wg do
InfoCorrectDiffMachine("pair",pair,"\n");
change := false;
w1 := pair[1];
g := pair[2];
w2 := DiffReducedWord(R!.diff2,order,w1*g);
InfoCorrectDiffMachine2("w1 ",w1," g ",g," w2 ",w2,"\n");
d := 1; d_inv := 1;
len1 := Length(w1);
len2 := Length(w2);
if len2>len1 then len := len2; else len := len1; fi;
i := 1;
while i<= len do
InfoCorrectDiffMachine2("i ",i,"\n");
if i<=len1 then
x := Subword(w1,i,i);
xx := Position(order.alphabet,x);
x_inv := order.alphabet[order.invAlphabet[xx]];
else
x := IdWord;
xx := dollar;
x_inv := IdWord;
fi;
if i<=len2 then
y := Subword(w2,i,i);
yy := Position(order.alphabet,y);
y_inv := order.alphabet[order.invAlphabet[yy]];
else
y := IdWord;
yy := dollar;
y_inv := IdWord;
fi;
dd := TargetDFA(newD,[xx,yy],d);
if i=len then
wd := DiffReducedWord(R!.diff2,order,g);
if dd<>0 and newD.states.names[dd] <> wd then
DeleteEdgeFSA(newD,[xx,yy],d,dd);
InfoCorrectDiffMachine("Replacing edge to ",newD.states.names[dd],
" by edge to ",wd,"\n");
dd:= 0;
fi;
if dd=0 then
change:= true;
dd := Position(newD.states.names,wd);
if dd <> fail then AddEdgeFSA(newD,[xx,yy],d,dd); fi;
fi;
elif dd=0 then
change:= true;
wd := DiffReducedWord(R!.diff2,order,x_inv*newD.states.names[d]*y);
dd := Position(newD.states.names,wd);
if dd <> fail then AddEdgeFSA(newD,[xx,yy],d,dd); fi;
else wd := newD.states.names[dd];
fi;
dd_inv := TargetDFA(newD,[yy,xx],d_inv);
if i=len then
wd_inv := DiffReducedWord(R!.diff2,order,
R!.alphabet[R!.invAlphabet[Position(R!.alphabet,g)]]);
if dd_inv<>0 and newD.states.names[dd_inv] <> wd_inv then
DeleteEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
InfoCorrectDiffMachine("Replacing edge to ",
newD.states.names[dd_inv]," by edge to ",wd_inv,"\n");
dd_inv:= 0;
fi;
if dd_inv=0 then
change:= true;
dd_inv := Position(newD.states.names,wd_inv);
if dd_inv <> fail then AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv); fi;
fi;
elif dd_inv=0 then
change := true;
wd_inv :=
DiffReducedWord(R!.diff2,order,y_inv*newD.states.names[d_inv]*x);
dd_inv := Position(newD.states.names,wd_inv);
if dd_inv <> fail then AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv); fi;
else wd_inv := newD.states.names[dd_inv];
fi;
if dd=fail and dd_inv=fail then
AddStateFSA(newD,wd);
dd := newD.states.size;
InfoCorrectDiffMachine2(
"Creating new state numbered ",dd," for ",wd,"\n");
AddEdgeFSA(newD,[xx,yy],d,dd);
if wd=wd_inv then
dd_inv := dd;
AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
inverses[dd] := dd;
else
AddStateFSA(newD,wd_inv);
dd_inv := newD.states.size;
InfoCorrectDiffMachine2(
"Creating new state numbered ",dd_inv," for ",wd_inv,"\n");
AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
inverses[dd] := dd_inv;
inverses[dd_inv] := dd;
fi;
elif dd_inv=fail then
dd_inv := inverses[dd];
AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
elif dd=fail then
dd := inverses[dd_inv];
AddEdgeFSA(newD,[xx,yy],d,dd);
fi;
InfoCorrectDiffMachine2("dd ",dd," wd ",wd,"\n");
InfoCorrectDiffMachine2("dd_inv ",dd_inv," wd_inv ",wd_inv,"\n");
d := dd;
d_inv := dd_inv;
i := i+1;
od;
if change=false then
InfoCorrectDiffMachine(
"No changes made to difference machine for ",pair,"\n");
fi;
od;
R!.diff2 := newD;
end;
CorrectDiffMachineFromTriples := function(R,order)
local triple, w1,w2,g,newD, inverses,
change,
dollar, d,d_inv,dd,dd_inv,wd,wd_inv,len1,len2,len,i,
x,x_inv,xx,y,y_inv,yy,
IdWord;
InfoCorrectDiffMachine("R.wgw:=",R!.wgw,"\n");
newD := StructuralCopy(R!.diff2);
inverses := DiffInverseList(newD);
dollar := R!.diff2.alphabet.base.size+1;
InfoCorrectDiffMachine2("At top of loop over triples\n");
IdWord := R!.wgw[1]^0;
for triple in R!.wgw do
InfoCorrectDiffMachine("triple",triple,"\n");
change := false;
w1 := triple[1];
g := triple[2];
w2 := triple[3];
d := 1; d_inv := 1;
len1 := Length(w1);
len2 := Length(w2);
if len2>len1 then len := len2; else len := len1; fi;
i := 1;
while i<= len do
InfoCorrectDiffMachine2("i ",i,"\n");
if i<=len1 then
x := Subword(w1,i,i);
xx := Position(order.alphabet,x);
x_inv := order.alphabet[order.invAlphabet[xx]];
else
x := IdWord;
xx := dollar;
x_inv := IdWord;
fi;
if i<=len2 then
y := Subword(w2,i,i);
yy := Position(order.alphabet,y);
y_inv := order.alphabet[order.invAlphabet[yy]];
else
y := IdWord;
yy := dollar;
y_inv := IdWord;
fi;
dd := TargetDFA(newD,[xx,yy],d);
if i=len then
wd := DiffReducedWord(R!.diff2,order,g);
if dd<>0 and newD.states.names[dd] <> wd then
DeleteEdgeFSA(newD,[xx,yy],d,dd);
InfoCorrectDiffMachine("Replacing edge to ",newD.states.names[dd],
" by edge to ",wd,"\n");
dd:= 0;
fi;
if dd=0 then
change:= true;
dd := Position(newD.states.names,wd);
if dd <> fail then AddEdgeFSA(newD,[xx,yy],d,dd); fi;
fi;
elif dd=0 then
change:= true;
wd := DiffReducedWord(R!.diff2,order,x_inv*newD.states.names[d]*y);
dd := Position(newD.states.names,wd);
if dd <> fail then AddEdgeFSA(newD,[xx,yy],d,dd); fi;
else wd := newD.states.names[dd];
fi;
dd_inv := TargetDFA(newD,[yy,xx],d_inv);
if i=len then
wd_inv := DiffReducedWord(R!.diff2,order,g^-1);
if dd_inv<>0 and newD.states.names[dd_inv] <> wd_inv then
DeleteEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
InfoCorrectDiffMachine("Replacing edge to ",newD.states.names[dd_inv],
"by edge to ",wd_inv,"\n");
dd_inv:= 0;
fi;
if dd_inv=0 then
change:= true;
dd_inv := Position(newD.states.names,wd_inv);
if dd_inv <> fail then AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv); fi;
fi;
elif dd_inv=0 then
change := true;
wd_inv := DiffReducedWord(R!.diff2,order,y_inv*newD.states.names[d_inv]*x);
dd_inv := Position(newD.states.names,wd_inv);
if dd_inv <> fail then AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv); fi;
else wd_inv := newD.states.names[dd_inv];
fi;
if dd=fail and dd_inv=fail then
AddStateFSA(newD,wd);
dd := newD.states.size;
InfoCorrectDiffMachine2("Creating new state numbered ",dd," for ",wd,"\n");
AddEdgeFSA(newD,[xx,yy],d,dd);
if wd=wd_inv then
dd_inv := dd;
AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
inverses[dd] := dd;
else
AddStateFSA(newD,wd_inv);
dd_inv := newD.states.size;
InfoCorrectDiffMachine2(
"Creating new state numbered ",dd_inv," for ",wd_inv,"\n");
AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
inverses[dd] := dd_inv;
inverses[dd_inv] := dd;
fi;
elif dd_inv=fail then
dd_inv := inverses[dd];
AddEdgeFSA(newD,[yy,xx],d_inv,dd_inv);
elif dd=fail then
dd := inverses[dd_inv];
AddEdgeFSA(newD,[xx,yy],d,dd);
fi;
InfoCorrectDiffMachine2("dd ",dd," wd ",wd,"\n");
InfoCorrectDiffMachine2("dd_inv ",dd_inv," wd_inv ",wd_inv,"\n");
d := dd;
d_inv := dd_inv;
i := i+1;
od;
if change=false then
InfoCorrectDiffMachine("No changes made to difference machine for ",triple,"\n");
fi;
od;
R!.diff2 := newD;
end;
TestAutomatic := function(R)
local WA, order,
kb, waOK, gmOK, IdWord, i, gpaok;
order := WordOrder(R);
R!.options.tidyint := 20;
R!.options.maxeqns := 200;
R!.options.maxstates := 1000;
R!.options.outputWords := true;
# gpcheckmult should output a list of pairs of words
# it has found which don't fellow travel (but should).
repeat
kb := KBWD(R);
if not kb and R!.options.maxeqns<262144 then
if R!.options.tidyint=20 then R!.options.tidyint := 100;
else R!.options.tidyint := 500; fi;
if R!.options.maxeqns=200 then R!.options.maxeqns := 32768;
else R!.options.maxeqns := 262144; fi;
if IsBound(R!.options.maxstates) then Unbind(R!.options.maxstates); fi;
elif not kb then
Print
("Repeated runs of KB failed to show stabilisation of word differences.\n");
return false;
fi;
until kb=true;
repeat
if R!.ordering<>"shortlex" then
#Need to convert generators in R!.diff2.states
R!.diff2 := SubstringClosure(R!.diff2,order,true);
# and back again!
fi;
Info(InfoRWS,1,"Making word acceptor.\n");
WA := WdAcceptor(R!.diff2,order);
Info(InfoRWS,1,
"Word acceptor has ",WA.states.size," states before minimization.\n");
R!.wa := MinimizeFSA(WA);
Info(InfoRWS,1,
"Word acceptor has ",R!.wa.states.size," states after minimization.\n");
Info(InfoRWS,2,"R!.wa := ",R!.wa,"\n");
repeat
waOK := GpGenMult(R);
Info(InfoRWS,1,"waOK ",waOK,"\n");
if waOK then
InfoTestAutomatic("R!.gm := ",R!.gm,"\n");
gmOK := GpCheckMult(R);
Info(InfoRWS,1,"gmOK ",gmOK,"\n");
if IsBound(R!.wg) then
Info(InfoRWS,2,"R!.wg ",R!.wg,"\n");
CorrectDiffMachine(R,order);
Unbind(R!.wg);
Unbind(R!.gm);
Info(InfoRWS,1,"R!.diff2 now has ",R!.diff2.states.size," states.\n");
Info(InfoRWS,2,"R!.diff2 := ",R!.diff2,"\n");
fi;
fi;
until waOK=false or gmOK=true;
until waOK;
gpaok := GpAxioms(R);
if gpaok then
R!.isAvailableNormalForm := true;
R!.isAvailableReduction := true;
R!.isAvailableSize := true;
R!.warningOn := false;
fi;
return gpaok;
end;
