Quelle selfs.gi
Sprache: unbekannt
|
|
#############################################################################
##
#W selfs.gi automgrp package Yevgen Muntyan
#W Dmytro Savchuk
##
#Y Copyright (C) 2003 - 2018 Yevgen Muntyan, Dmytro Savchuk
##
InstallGlobalFunction(ReduceWord,
function(v)
local i, b;
b := [];
for i in [1..Length(v)] do
if v[i] <> 1 then
Add(b, v[i]);
fi;
od;
return b;
end);
InstallGlobalFunction(ProjectWord, function(w, s, G)
local i, perm, d, proj;
d := Length(G[1])-1;
if s > d or s < 1 then
Error("Incorrect index of a subtree");
fi;
proj := [];
perm := ();
for i in [1..Length(w)] do
Add(proj, G[w[i]][s^perm]);
perm := perm*G[w[i]][d+1];
od;
return proj;
end);
InstallGlobalFunction(WordActionOnFirstLevel, function(w, G)
local i, perm, d;
d := Length(G[1])-1;
perm := ();
for i in [1..Length(w)] do perm := perm*G[w[i]][d+1]; od;
return perm;
end);
InstallGlobalFunction(WordActionOnVertex, function(w, ver, G)
local i, cur_w, new_ver, perm;
new_ver := [];
cur_w := ShallowCopy(w);
for i in [1..Length(ver)] do
perm := WordActionOnFirstLevel(cur_w, G);
new_ver[i] := ver[i]^perm;
cur_w := ProjectWord(cur_w, ver[i], G);
od;
return new_ver;
end);
InstallMethod(OrbitOfVertex, "for [IsList, IsTreeHomomorphism, IsCyclotomic]", true, [IsList, IsTreeHomomorphism, IsCyclotomic],
function(ver, g, n)
local i, ver_tmp, orb;
i := 0; orb := [];
ver_tmp := ver;
while i < n and (ver <> ver_tmp or i = 0) do
Add(orb, ver_tmp);
ver_tmp := ver_tmp^g;
i := i+1;
od;
return orb;
end);
InstallMethod(OrbitOfVertex, "for [IsList, IsTreeHomomorphism]", [IsList, IsTreeHomomorphism],
function(ver, g)
return OrbitOfVertex(ver, g, infinity);
end);
InstallMethod(OrbitOfVertex, "for [IsString, IsTreeHomomorphism, IsCyclotomic]", true, [IsString, IsTreeHomomorphism, IsCyclotomic],
function(ver, g, n)
local i, ver_tmp, orb, ch;
ver_tmp := [];
for i in [1..Length(ver)] do
ch := Int(String([ver[i]]));
if ch < 1 or ch > g!.deg then
Error("received string ", ver, " does not represent a valid vertex");
fi;
Add(ver_tmp, ch);
od;
ver := ver_tmp;
i := 0; orb := [];
ver_tmp := ver;
while i < n and (ver <> ver_tmp or i = 0) do
Add(orb, ver_tmp);
ver_tmp := ver_tmp^g;
i := i+1;
od;
return orb;
end);
InstallMethod(OrbitOfVertex, "for [IsString, IsTreeHomomorphism]",
[IsString, IsTreeHomomorphism],
function(ver, g)
return OrbitOfVertex(ver, g, infinity);
end);
InstallMethod(PrintOrbitOfVertex, "for [IsList, IsTreeHomomorphism, IsCyclotomic]",
[IsList, IsTreeHomomorphism, IsCyclotomic],
function(ver, w, n)
local orb, i, j;
orb := OrbitOfVertex(ver, w, n);
if w!.deg = 2 then
for i in [1..Length(orb)] do
for j in [1..Length(orb[1])] do
# Print(orb[i][j]);
if orb[i][j] = 1 then Print(" "); else Print("x"); fi;
od;
Print("\n");
od;
else
for i in [1..Length(orb)] do
for j in [1..Length(orb[1])] do
Print(orb[i][j]);
od;
Print("\n");
od;
fi;
end);
InstallMethod(PrintOrbitOfVertex, "for [IsString, IsTreeHomomorphism]", [IsList, IsTreeHomomorphism],
function(ver, g)
PrintOrbitOfVertex(ver, g, infinity);
end);
InstallGlobalFunction(IsOneWordSelfSim, function(w, G)
local i, IsOneWordIter, ReachedWords, d;
IsOneWordIter := function(v)
local i, j, perm;
if v in ReachedWords then return true;
else
perm := ();
for i in [1..Length(v)] do perm := perm*G[v[i]][d+1]; od;
if perm <> () then return false; fi;
Add(ReachedWords, v);
for j in [1..d] do
if not IsOneWordIter(ProjectWord(v, j, G)) then return false; fi;
od;
return true;
fi;
end;
d := Length(G[1])-1;
if Length(w) = 0 then return true; fi;
ReachedWords := [];
return IsOneWordIter(w);
end);
InstallGlobalFunction(IsOneWordContr, function(word, G)
local IsOneWordContrLocal;
IsOneWordContrLocal:=function(word)
local i, b, l, v, c, k, res, t, w;
w := ShallowCopy(word);
# Print("w=",w,"\n");
if Length(w) = 0 then return true; fi;
if Length(w) = 1 then
if w = [1] then return true;
else return false;
fi;
fi;
if Length(w) mod 2 = 1 then Add(w, 1); fi;
l := [];
for i in [1..Length(w)/2] do
Add(l, StructuralCopy(G[w[2*i-1]][w[2*i]]));
od;
# Print("l = ", l);
# list c contains permutations c[i+1] = pi[1]*pi[2]*...*pi[i]
c := [(), l[1][Length(l[1])]];
t := Length(l);
for i in [2..t] do
# Print("c[", i, "] = ", c[i], ", l[", i, "] = ", l[i][Length(l[i])], ";");
Add(c, c[i]*l[i][Length(l[i])]);
l[i][Length(l[i])] := c[i];
od;
if c[Length(c)] <> () then
return false;
fi;
l[1][Length(l[1])] := ();
b := [];
for i in [1..Length(l)] do
b[i] := Permuted(l[i],(l[i][Length(l[i])])^(-1));
od;
i := 1;
res := true;
while res and (i <= Length(b[1])-1) do
v := [];
for k in [1..Length(b)] do
Add(v, b[k][i]);
od;
v := ReduceWord(v);
res := IsOneWordContrLocal(v);
i := i+1;
od;
return res;
end;
return IsOneWordContrLocal(word);
end);
InstallGlobalFunction(AG_IsOneList, function(w, G)
if IsList(G[1][1]) then return IsOneWordContr(w, G);
else return IsOneWordSelfSim(w, G);
fi;
end);
InstallMethod(AG_MinimizedAutomatonList, "for [IsAutomGroup]", [IsAutomGroup],
function(H)
return AG_AddInversesListTrack(List(AutomatonList(H), x -> List(x)));
end);
InstallGlobalFunction(CONVERT_ASSOCW_TO_LIST, function(w)
local w_list, w_ext, i, j, numstates, cur_gen;
numstates := FamilyObj(w)!.numstates;
w_list := [];
w_ext := ExtRepOfObj(w!.word);
for i in [1..Length(w_ext)/2] do
if w_ext[2*i] > 0 then
cur_gen := w_ext[2*i-1];
else
cur_gen := w_ext[2*i-1]+numstates;
fi;
for j in [1..AbsInt(w_ext[2*i])] do Add(w_list, cur_gen); od;
od;
return w_list;
end);
InstallGlobalFunction(IsOneContr,
function(a)
local a_list, a_list_orig, track_l, Gi, i;
a_list_orig := CONVERT_ASSOCW_TO_LIST(a);
Gi := AG_MinimizedAutomatonList(GroupOfAutomFamily(FamilyObj(a)));
track_l := Gi[3];
#a_list := [];
#for i in [1..Length(a_list_orig)] do Add(a_list, track_l[a_list_orig[i]]); od;
a_list := List(a_list_orig, i -> track_l[i]);
return IsOneWordContr(a_list, AG_ContractingTable(GroupOfAutomFamily(FamilyObj(a))));
end);
###############################################################################
##
#M AG_IsOneList(w, G) (IsList, IsAutomGroup)
##
#InstallGlobalFunction(AG_IsOneList,
#function(w, G)
# if HasIsContracting(G) and IsContracting(G) and UseContraction(G) then
# return IsOneWordContr(w, AG_ContractingTable(G));
# else
# return IsOneWordSelfSim(w, AG_MinimizedAutomatonList(G)[1]);
# fi;
#end);
InstallGlobalFunction(AG_ChooseAutomatonList,
function(G)
if HasIsContracting(G) and IsContracting(G) and UnderlyingAutomFamily(G)!.use_contraction then
return AG_ContractingTable(G);
else
return AG_MinimizedAutomatonList(G)[1];
fi;
end);
InstallMethod(AG_OrderOfElement, "for [IsList, IsList, IsCyclotomic]", true,
[IsList, IsList, IsCyclotomic],
function(v, G, size)
local w, k;
v := ReduceWord(v);
w := StructuralCopy(v); k := 1;
if Length(G[1]) = 3 then
while (not AG_IsOneList(w, G)) and k < size do
Append(w, w);
# Print(w, ";");
k := 2*k;
od;
else
while (not AG_IsOneList(w, G)) and k < size do
Append(w, v);
# Print(w, ";");
k := k+1;
od;
fi;
if AG_IsOneList(w, G) then return k; else return fail; fi;
end);
InstallMethod(AG_OrderOfElement, "for [IsList, IsList, IsPosInt]",
[IsList, IsList],
function(v, G)
return AG_OrderOfElement(v, G, infinity);
end);
InstallGlobalFunction(GeneratorActionOnVertex, function(G, g, w)
local i, v, gen, d;
d := Length(G[1])-1;
gen := g; v := [];
for i in [1..Length(w)] do
Add(v, (w[i]+1)^G[gen][d+1]-1);
gen := G[gen][w[i]+1];
od;
return v;
end);
InstallGlobalFunction(AG_NumberOfVertex, function(w, d)
local i, s;
s := 0;
for i in [1..Length(w)] do
s := s+w[i]*d^(Length(w)-i);
od;
return s;
end);
InstallGlobalFunction(NumberOfVertex, function(w, d)
local i, s, w_loc;
s := 0;
if IsString(w) then
w_loc := List(w, x -> Int(String([x]))-1);
else
w_loc := List(w, x -> x-1);
fi;
for i in w_loc do
if i < 0 or i >= d then
Error("received string ", w, " does not represent a valid vertex");
fi;
od;
for i in [1..Length(w)] do
s := s+w_loc[i]*d^(Length(w)-i);
od;
return s+1;
end);
InstallGlobalFunction(AG_VertexNumber, function(k, n, d)
local i, l, l1, t;
t := k; l := [];
while t > 0 do
Add(l, t mod d);
t := (t-(t mod d))/d;
od;
for i in [Length(l)+1..n] do Add(l, 0); od;
l1 := [];
for i in [1..n] do l1[i] := l[n-i+1]; od;
return l1;
end);
InstallGlobalFunction(VertexNumber, function(k, n, d)
local i, l, l1, t;
t := k-1; l := [];
while t > 0 do
Add(l, t mod d);
t := (t-(t mod d))/d;
od;
for i in [Length(l)+1..n] do Add(l, 0); od;
l1 := [];
for i in [1..n] do l1[i] := l[n-i+1]; od;
return List(l1, x -> x+1);
end);
InstallGlobalFunction(GeneratorActionOnLevel, function(G, g, n)
local l, d, i, s, v, w, k;
s := (); d := Length(G[1])-1;
l := [];
for i in [1..d^n] do Add(l, 0); od;
i := 0;
while i < d^n do
k := 0;
while l[k+1] > 0 do
k := k+1;
od;
w := AG_VertexNumber(k, n, d);
v := StructuralCopy(w);
i := i+1;
repeat
l[AG_NumberOfVertex(v, d)+1] := 1;
v := GeneratorActionOnVertex(G, g, v);
if v <> w then
s := s*(k+1, AG_NumberOfVertex(v, d)+1);
i := i+1;
fi;
until v = w;
od;
return s;
end);
InstallGlobalFunction(PermActionOnLevel, function(perm, big_lev, sm_lev, deg)
local l, i;
l := [];
for i in [0..deg^sm_lev-1] do
Add(l, Int(((1+i*deg^(big_lev-sm_lev))^perm-1)/(deg^(big_lev-sm_lev)))+1);
od;
return PermList(l);
end);
InstallGlobalFunction(WordActionOnLevel, function(G, w, n)
local gen, perm;
perm := ();
for gen in w do
perm := perm*GeneratorActionOnLevel(G, gen, n);
od;
return perm;
end);
InstallGlobalFunction(AG_IsWordTransitiveOnLevel, function(G, w, lev)
return Length(OrbitPerms([WordActionOnLevel(G, w, lev)], 1)) = (Length(G[1])-1)^lev;
end);
InstallGlobalFunction(AG_GeneratorActionOnLevelAsMatrix, function(G, g, n)
local perm, i, j, m, d;
perm := GeneratorActionOnLevel(G, g, n);
d := Length(G[1])-1;
m := List([1..d^n], x -> List([1..d^n], x -> 0));
for i in [1..d^n] do
m[i][i^perm] := 1;
od;
return m;
end);
InstallGlobalFunction(PermOnLevelAsMatrix, function(g, lev)
local perm, i, j, m, d;
perm := PermOnLevel(g, lev);
d := g!.deg;
m := List([1..d^lev], x -> List([1..d^lev], x -> 0));
for i in [1..d^lev] do
m[i][i^perm] := 1;
od;
return m;
end);
InstallGlobalFunction(TransformationOnLevelAsMatrix, function(g, lev)
local trans, i, j, m, d;
trans := TransformationOnLevel(g, lev);
d := DegreeOfTransformation(trans);
m := List([1..d], x -> List([1..d], x -> 0));
for i in [1..d] do
m[i][i^trans] := 1;
od;
return m;
end);
InstallGlobalFunction(InvestigatePairs, function(G)
local i, j, k, i1, j1, k1, Pairs, Trip, n, IsPairEq, d, res, tmp;
IsPairEq := function(i, j, k) # ij = k?
local t, res;
if (not IsList(Pairs[i][j])) or (IsList(Pairs[i][j])
and (Pairs[i][j][1] <> k)) then
if (not IsList(Pairs[i][j])) and (Pairs[i][j] <> -1) then
if Pairs[i][j] = k then return true;
else return false;
fi;
fi;
if IsList(Pairs[i][j]) then
if Length(Pairs[i][j]) = 1 then
Trip[i][j][Pairs[i][j][1]] := 0;
else
Trip[i1][j1][k1] := 0;
return true;
fi;
fi;
if Trip[i][j][k] = 0 then return false;
else
if G[i][d+1]*G[j][d+1] <> G[k][d+1] then
Trip[i][j][k] := 0;
return false;
fi;
Pairs[i][j] := [k];
t := 1; res := true;
while res and (t <= d) do
# Print("i = ", i, ", j = ", j, ", k = ", k, ", t = ", t, "; ");
res := IsPairEq(G[i][t], G[j][t^G[i][d+1]], G[k][t]);
t := t+1;
od;
if res then
if Trip[i][j][k] <> 0 then
Pairs[i][j] := [k, 1];
return true;
else
Pairs[i][j] := -1;
return false;
fi;
else
Trip[i][j][k] := 0;
Pairs[i][j] := -1;
return false;
fi;
fi;
else
return true;
fi;
end;
Pairs := [[]]; Trip := [];
n := Length(G);
d := Length(G[1])-1;
for j in [1..n] do Add(Pairs[1], j); od;
for i in [2..n] do
Add(Pairs, [i]);
Trip[i] := [];
for j in [2..n] do
Pairs[i][j] := -1;
Trip[i][j] := [];
for k in [1..n] do Trip[i][j][k] := -1; od;
od;
od;
# Print(Pairs);
# Print(Trip);
for i1 in [2..n] do for j1 in [2..n] do
if Pairs[i1][j1] = -1 then
k1 := 1; res := false;
while (not res) and (k1 <= n) do
res := IsPairEq(i1, j1, k1);
# Print(Pairs, "\n");
for i in [2..n] do for j in [2..n] do
if IsList(Pairs[i][j]) then
if res then Pairs[i][j] := Pairs[i][j][1];
else Pairs[i][j] := -1;
fi;
fi;
od; od;
k1 := k1+1;
od;
if Pairs[i1][j1] = -1 then Pairs[i1][j1] := 0; fi;
fi;
od; od;
return Pairs;
end);
InstallMethod(ContractingLevel, "for [IsAutomGroup]", [IsAutomGroup],
function(H)
if not HasIsContracting(H) then
Info(InfoAutomGrp, 1, "If < H > is not contracting, the algorithm will never stop");
fi;
FindNucleus(H,false);
return ContractingLevel(H);
end);
InstallMethod(AG_ContractingTable, "for [IsAutomGroup]", [IsAutomGroup],
function(H)
local AG_ContractingTableLocal;
AG_ContractingTableLocal := function(G)
local lev, n, d, i, j, ContractingPair, Pairs, ContTable;
ContractingPair := function(i, j)
local l, k, t, PairAct, TmpList, g1, g2;
if Pairs[i][j] <> 0 then PairAct := [Pairs[i][j]];
else PairAct := [[i, j]];
fi;
for l in [1..lev] do
TmpList := [];
for t in [1..Length(PairAct)] do
if not IsList(PairAct[t]) then
for k in [1..d] do Add(TmpList, G[PairAct[t]][k]); od;
else
for k in [1..d] do
g1 := G[PairAct[t][1]][k];
g2 := G[PairAct[t][2]][k^G[PairAct[t][1]][d+1]];
if Pairs[g1][g2] <> 0 then Add(TmpList, Pairs[g1][g2]);
else Add(TmpList, [g1, g2]);
fi;
od;
fi;
od;
PairAct := StructuralCopy(TmpList);
od;
Add(PairAct, GeneratorActionOnLevel(G, i, lev)*GeneratorActionOnLevel(G, j, lev));
return PairAct;
end;
lev := ContractingLevel(H);
Pairs := InvestigatePairs(G);
n := Length(G);
d := Length(G[1])-1;
ContTable := [];
for i in [1..n] do
Add(ContTable, []);
for j in [1..n] do Add(ContTable[i], ContractingPair(i, j)); od;
od;
return ContTable;
end;
################ AG_ContractingTable itself #################################
if not HasIsContracting(H) then
Info(InfoAutomGrp, 1, "If < H > is not contracting, the algorithm will never stop");
fi;
return AG_ContractingTableLocal(AG_GeneratingSetWithNucleusAutom(H));
end);
InstallMethod(ContractingTable, "for [IsAutomGroup]", [IsAutomGroup],
function(H)
local T, i, j, k, deg, numstates;
T := StructuralCopy(AG_ContractingTable(H));
deg := Length(T[1][1])-1;
numstates := Length(T);
for i in [1..numstates] do
for j in [1..numstates] do
for k in [1..deg] do
T[i][j][k] := GeneratingSetWithNucleus(H)[T[i][j][k]];
od;
T[i][j] := TreeAutomorphism(T[i][j]{[1..deg]} , T[i][j][deg+1]);
od;
od;
return T;
end);
# The base of the code of the function below below was written by Andriy Russev
InstallGlobalFunction(AG_MinimizationOfAutomatonListTrack, function(A)
local n, perms, m, classes, states, list, i, j, ids, temp, s, d, new_as_old, old_as_new, aut_list, perm, state;
n := Length(A);
d:=Length(A[1])-1;
perms := SSortedList(List(A,x->x[d+1]));
# In the minimization process the set of states is partitioned into classes
m := Length(perms); # number of states of automaton A
# "classes" contains classes of states. To each state of automaton A we assign an number from 1 to m
# (the first element in the list; if the class is not "finished", we add n)
classes := List([1..n], x -> [Position(perms, A[x][d+1])]);
# Canonical representatives of classes of states
states := [];
# The list of states of A that have not been classified yet
list := [1..n];
# At this moment all the states that belong to the same class act identically
# on words of length 1. During each iteration, classes consist of states that
# act identically on the words of length k will be partitioned into smalled
# subclasses of states that act identically on words of length k+1.
# If no class was partitioned during an iteration, then all the states in
# each class are equivalent and act identically on words of arbitrary length.
# This is the end of minimization procedure
while true do
# states from each class act identically on all words of length k.
for i in list do
# Define classes for the states of the first level
classes[i][2] := List(A[i]{[1..d]}, x -> classes[x][1]);
od;
# the extended identifier of a class contains information about the action
# of this state, and of its first level states on words of length k.
# I.e., it describes the action of the state on words of the length k+1.
# If extended identifiers of states coincide, then these states act
# identically on words of length k+1.
# Update the identifiers of classes; save to "temp" the list of classes
# that contain one state
ids := [];
temp := [];
s := Length(states);
for i in list do
j := Position(ids, classes[i]);
if j = fail then
Add(ids, ShallowCopy(classes[i]));
j := Length(ids);
temp[j] := i;
else
Unbind(temp[j]);
fi;
classes[i][1] := s + j + n;
od;
# Check if new classes created during the iteration
if s + Length(ids) = m then break; fi;
m := s + Length(ids);
# Find canonical representatives of classes that contain only a single state of A
temp := Compacted(temp);
for i in temp do
s := s + 1;
classes[i][1] := s;
states[s] := i;
od;
# remove all classes with one state from future iterations.
SubtractSet(list, temp);
od;
# Find canonical representatives of the remaining classes
ids := [];
for i in list do
classes[i][1] := classes[i][1] - n;
j := Position(ids, classes[i]);
if j = fail then
Add(ids, classes[i]);
states[classes[i][1]] := i;
fi;
od;
aut_list:=List(states,
x -> Flat([List(A[x]{[1..d]}, y -> classes[y][1]),
A[x][d+1]]));
old_as_new:=List(classes,c->c[1]);
new_as_old:=List([1..Length(states)],x->Position(old_as_new,x));
#Now sort the new list in the same order as the old states
perm:=Sortex(new_as_old);
aut_list:=Permuted(aut_list,perm);
for state in aut_list do
for i in [1..d] do
state[i]:=state[i]^perm;
od;
od;
Apply(old_as_new, x->x^perm);
return [aut_list,
new_as_old,
old_as_new];
end);
InstallGlobalFunction(AG_MinimizationOfAutomatonList, function(G)
return AG_MinimizationOfAutomatonListTrack(G)[1];
end);
InstallGlobalFunction(AG_AddInversesListTrack, function(H)
local d, n, G, idEl, st, i, perm, inv, minimized_autlist;
## track_s - new generators in terms of old ones
## track_l - old generators in terms of new ones
d := Length(H[1])-1;
n := Length(H);
if n < 1 or d < 1 then return fail; fi;
idEl := Flat([List([1..d],x->1),()]);
G := [idEl];
for i in [1..n] do Add(G, StructuralCopy(H[i])); od;
for st in [2..n+1] do
for i in [1..d] do G[st][i] := G[st][i]+1; od;
od;
for st in [2..n+1] do
inv := [];
perm := G[st][d+1]^(-1);
for i in [1..d] do Add(inv, G[st][i^perm]+n); od;
Add(inv, perm);
Add(G, inv);
od;
# return AG_MinimizationOfAutomatonListTrack(G, [0..Length(G)-1], [2..Length(G)]);
minimized_autlist := AG_MinimizationOfAutomatonListTrack(G);
return [minimized_autlist[1], List(minimized_autlist[2],x->x-1), minimized_autlist[3]{[2..Length(minimized_autlist[3])]}];
end);
InstallGlobalFunction(AG_AddInversesList, function(H)
return AG_AddInversesListTrack(H)[1];
end);
InstallMethod(UseContraction, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
local H;
H := GroupOfAutomFamily(UnderlyingAutomFamily(G));
if not HasIsContracting(H) then
Print("Error in UseContraction(<G>): It is not known whether the group of family is contracting\n");
return fail;
elif not IsContracting(H) then
Print("Error in UseContraction(<G>): The group of family is not contracting");
return fail;
fi;
# IsContracting returns either true or false or an error (it can not return fail)
UnderlyingAutomFamily(G)!.use_contraction := true;
return true;
end);
InstallMethod(DoNotUseContraction, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
UnderlyingAutomFamily(G)!.use_contraction := false;
return true;
end);
InstallMethod(FindNucleus, "for [IsAutomatonGroup, IsCyclotomic, IsBool]", true,
[IsAutomatonGroup, IsCyclotomic, IsBool],
function(H, max_nucl, print_info)
local G, g, Pairs, i, j, PairsToAdd, AssocWPairsToAdd, res, ContPairs, n, d, found, num, DoesPairContract, AddPairs, lev, maxlev, tmp, Nucl, IsElemInNucleus,
nucl_final, cur_nucl, cur_nucl_tmp, Hi, track_s, track_l, G_track, automgens, cur_nucl_length, info;
# DoesPairContract := function(i, j, lev)
# local t, res;
# if lev > maxlev then maxlev := lev; fi;
#
# # ContPairs[i][j] may take the following values:
# # -1 - [i, j] was not met before
# # 1 - [i, j] contracts
# # 2 - [i, j] was met above in the tree
#
# if (ContPairs[i][j] = 1) then return true; fi;
# if Pairs[i][j] <> 0 then
# ContPairs[i][j] := 1;
# return true;
# fi;
# # if we've seen this pair before it needs to be in the nucleus
# if ContPairs[i][j] = 2 then return [i, j]; fi;
# t := 1; res := true;
# ContPairs[i][j] := 2;
# while res = true and (t <= d) do
# res := DoesPairContract(G[i][t], G[j][t^G[i][d+1]], lev+1);
# t := t+1;
# od;
# if res = true then
# ContPairs[i][j] := 1;
# return true;
# else return res;
# fi;
# end;
DoesPairContract := function(i, j, lev)
local t, res, localmaxlev;
if lev > maxlev then maxlev := lev; fi;
# ContPairs[i][j] may take the following values:
# -1 - [i, j] was not met before
# [k] - [i, j] contracts on level k
# 2 - [i, j] was met above in the tree
if IsList(ContPairs[i][j]) then
if lev+ContPairs[i][j][1] > maxlev then maxlev := lev+ContPairs[i][j][1]; fi;
return true;
fi;
if Pairs[i][j] <> 0 then
ContPairs[i][j] := [0];
return true;
fi;
if ContPairs[i][j] = 2 then return [i,j]; fi;
t := 1; res := true;
ContPairs[i][j] := 2;
localmaxlev := 0;
while res = true and (t <= d) do
res := DoesPairContract(G[i][t], G[j][t^G[i][d+1]], lev+1);
if res = true then
if ContPairs[G[i][t]][G[j][t^G[i][d+1]]][1]+1 > localmaxlev then
localmaxlev := ContPairs[G[i][t]][G[j][t^G[i][d+1]]][1]+1;
fi;
fi;
t := t+1;
od;
if res = true then
ContPairs[i][j] := [localmaxlev];
return true;
else return res;
fi;
end;
AddPairs := function(i, j)
local tmp, l, CurNum;
if Pairs[i][j] > 0 then return Pairs[i][j]; fi;
Pairs[i][j] := num;
CurNum := num;
Add(PairsToAdd, []);
num := num+1;
tmp := [];
for l in [1..d] do
Add(tmp, AddPairs(G[i][l], G[j][l^G[i][d+1]]));
od;
Add(tmp, G[i][d+1]*G[j][d+1]);
Append(PairsToAdd[CurNum-n], tmp);
AssocWPairsToAdd[CurNum-n] := cur_nucl[i]*cur_nucl[j];
return CurNum;
end;
IsElemInNucleus := function(g)
local i, res;
if g in tmp then
for i in [Position(tmp, g)..Length(tmp)] do
if not (tmp[i] in Nucl) then Add(Nucl, tmp[i]); fi;
od;
return g = tmp[1];
fi;
Add(tmp, g);
res := false; i := 1;
while (not res) and i <= d do
res := IsElemInNucleus(G[g][i]);
i := i+1;
od;
Remove(tmp);
return res;
end;
# ****************** FindNucleus itself *******************************
if HasIsContracting(H) and not IsContracting(H) then
return fail;
fi;
automgens := UnderlyingAutomFamily(H)!.automgens;
d := UnderlyingAutomFamily(H)!.deg;
cur_nucl := [One(UnderlyingAutomFamily(H))];
Hi := StructuralCopy(AG_MinimizedAutomatonList(H));
# Print("Gi = ", Gi, "\n");
G := Hi[1];
track_s := Hi[2];
track_l := Hi[3];
for i in [2..Length(track_s)] do Add(cur_nucl, automgens[track_s[i]]); od;
found := false;
while (not found) and Length(G) < max_nucl do
res := true; maxlev := 0; ContPairs := [];
Pairs := InvestigatePairs(G);
n := Length(G);
# Print("n = ", n, "\n");
if print_info = true then
Print("Trying generating set with ", n, " elements\n");
else
Info(InfoAutomGrp, 3, "Trying generating set with ", n, " elements");
fi;
# for i in [1..n] do
# Add(ContPairs, [1]);
# for j in [1..n-1] do
# if i = 1 then Add(ContPairs[i], 1);
# else Add(ContPairs[i], -1);
# fi;
# od;
# od;
for i in [1..n] do
Add(ContPairs, [[0]]);
for j in [1..n-1] do
if i = 1 then Add(ContPairs[i], [0]);
else Add(ContPairs[i], -1);
fi;
od;
od;
i := 1;
while res = true and (i <= n) do
j := 1;
while res = true and (j <= n) do
#Print("i = ", i, ", j = ", j, "\n");
if ContPairs[i][j] = -1 then res := DoesPairContract(i, j, 0); fi;
if res <> true then
PairsToAdd := [];
AssocWPairsToAdd := [];
# num represents current number of generators
num := n+1;
AssocWPairsToAdd := [];
AddPairs(res[1], res[2]);
if print_info = true then
Print("Elements added:", List(AssocWPairsToAdd, x -> x!.word), "\n");
else
Info(InfoAutomGrp, 3, "Elements added:", List(AssocWPairsToAdd, x -> x!.word));
fi;
Append(G, PairsToAdd);
# Print("G = ", G, "\n");
Append(cur_nucl, AssocWPairsToAdd);
G_track := AG_AddInversesListTrack(G);
# Print("G_track = ", G_track, "\n");
G := G_track[1];
cur_nucl_tmp := [];
cur_nucl_tmp := [One(UnderlyingAutomFamily(H))];
cur_nucl_length := Length(cur_nucl);
for i in [2..Length(G_track[2])] do
if G_track[2][i] <= cur_nucl_length then
Add(cur_nucl_tmp, cur_nucl[G_track[2][i]]);
else
Add(cur_nucl_tmp, cur_nucl[G_track[2][i]-cur_nucl_length]^-1);
fi;
od;
cur_nucl := StructuralCopy(cur_nucl_tmp);
fi;
j := j+1;
od;
i := i+1;
od;
if res = true then
found := true;
fi;
od;
if not found then return fail; fi;
Nucl := [];
# first add elements of cycles
for i in [1..Length(G)] do
tmp := [];
if not (i in Nucl) then IsElemInNucleus(i); fi;
od;
# now add sections of elements
for g in Nucl do
for i in [1..d] do
if not (G[g][i] in Nucl) then
Add(Nucl, G[g][i]);
fi;
od;
od;
# Print("Nucleus:", Nucl, "\n");
nucl_final := [];
for i in Nucl do Add(nucl_final, cur_nucl[i]); od;
SetIsContracting(H, true);
SetGroupNucleus(H, nucl_final);
SetGeneratingSetWithNucleus(H, cur_nucl);
SetAG_GeneratingSetWithNucleusAutom(H, G);
SetGeneratingSetWithNucleusAutom(H, MealyAutomaton(G));
SetContractingLevel(H, maxlev);
UseContraction(H);
return [nucl_final, cur_nucl, GeneratingSetWithNucleusAutom(H)];
end);
InstallMethod(FindNucleus, "for [IsAutomatonGroup, IsBool]", true,
[IsAutomatonGroup, IsBool],
function(H, print_info)
return FindNucleus(H, infinity, print_info);
end);
InstallMethod(FindNucleus, "for [IsAutomatonGroup, IsCyclotomic]", true,
[IsAutomatonGroup, IsCyclotomic],
function(H, max_nucl)
return FindNucleus(H, max_nucl, true);
end);
InstallMethod(FindNucleus, "for [IsAutomatonGroup]", true,
[IsAutomatonGroup],
function(H)
return FindNucleus(H, infinity, true);
end);
InstallMethod(IsContracting, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
local res;
if IsSelfSimilar(G) = false then
Info(InfoAutomGrp, 3, "The group <G> is not self-similar, so it is not contracting");
return false;
elif not IsAutomatonGroup(G) then
Print("Represent <G> as a group generated by finite automaton\n");
return fail;
fi;
if FindNucleus(G, 50, false) <> fail then return true; fi;
if IsNoncontracting(G, 10, 10) = true then return false; fi;
Info(InfoAutomGrp, 3, "You can try FindNucleus( <G>, <max_nucl> ) or");
Info(InfoAutomGrp, 3, " IsNoncontracting( <G>, <lengh>, <depth> ) with bigger bounds");
TryNextMethod();
end);
InstallMethod(GroupNucleus, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
FindNucleus(G, false);
return GroupNucleus(G);
end);
InstallMethod(GeneratingSetWithNucleus, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
FindNucleus(G, false);
return GeneratingSetWithNucleus(G);
end);
InstallMethod(GeneratingSetWithNucleusAutom, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
FindNucleus(G, false);
return GeneratingSetWithNucleusAutom(G);
end);
InstallMethod(AG_GeneratingSetWithNucleusAutom, "for [IsAutomGroup]", true,
[IsAutomGroup],
function(G)
FindNucleus(G, false);
return AG_GeneratingSetWithNucleusAutom(G);
end);
InstallGlobalFunction(InversePerm, function(G)
local i, j, viewed, inv, found;
viewed := []; inv := ();
for i in [1..Length(G)] do
if not (i in viewed) then
j := 1; found := false;
while j <= Length(G) and not found do
#Print("[", i, ", ", j, "]\n");
if AG_IsOneList([i, j], G) then
found := true;
if i <> j then
inv := inv*(i, j);
Append(viewed, [i, j]);
else
Add(viewed, i);
fi;
fi;
j := j+1;
od;
fi;
od;
return inv;
end);
InstallGlobalFunction(AG_AutomPortraitMain, function(w)
local PortraitIter, bndry, inv, d, Perm_List, max_lev, G, w_list, w_list_orig, Gi, track_l, nucl;
PortraitIter := function(v, lev, plist)
local i, j, tmpv, sigma;
for i in [1..Length(G)] do
tmpv := StructuralCopy(v);
Add(tmpv, i);
if AG_IsOneList(tmpv, G) then
Add(bndry, [lev, nucl[i^inv]]);
Add(plist, nucl[i^inv]);
return;
fi;
od;
for i in [1..d] do
tmpv := []; sigma := ();
for j in v do
Add(tmpv, G[j][i^sigma]);
sigma := sigma*G[j][d+1];
od;
if i = 1 then Add(plist, sigma);fi;
Add(plist, []);
PortraitIter(tmpv, lev+1, plist[i+1]);
od;
end;
d := w!.deg;
G := AG_GeneratingSetWithNucleusAutom(GroupOfAutomFamily(FamilyObj(w)));
nucl := GeneratingSetWithNucleus(GroupOfAutomFamily(FamilyObj(w)));
Gi := AG_MinimizedAutomatonList(GroupOfAutomFamily(FamilyObj(w)));
track_l := Gi[3];
w_list_orig := CONVERT_ASSOCW_TO_LIST(w);
w_list := List(w_list_orig, i -> track_l[i]);
bndry := [];
Perm_List := [];
inv := InversePerm(G);
max_lev := 0;
PortraitIter(w_list, 0, Perm_List);
return [d, bndry, Perm_List];
end);
InstallGlobalFunction(AutomPortrait, function(w)
return AG_AutomPortraitMain(w)[3];
end);
InstallGlobalFunction(AutomPortraitBoundary, function(w)
return AG_AutomPortraitMain(w)[2];
end);
InstallGlobalFunction(AutomPortraitDepth, function(w)
local bndry;
return Maximum(List(AG_AutomPortraitMain(w)[2], x -> x[1]));
end);
################################################################################
##
#F WritePortraitToFile. . . . . . . . . . .Writes portrait in a file in the form
## understandable by Maple
# InstallGlobalFunction(WritePortraitToFile, function(p, file, add)
# local WritePerm, l;
#
# WritePerm := function(perm)
# local j;
# AppendTo(file, "[ ");
# if Length(perm) > 0 then
# AppendTo(file, "`", perm[1], "`");
# for j in [2..Length(perm)] do
# AppendTo(file, ", ");
# WritePerm(perm[j]);
# od;
# fi;
# AppendTo(file, " ]");
# end;
#
#
# l := [p[1], List(p[2], x -> [x[1], x[2]!.word])];
# if add then AppendTo(file, "[ ", l[1], ", ");
# else PrintTo(file, "[ ", l[2], ", ");
# fi;
# WritePerm(p[3]);
# AppendTo(file, " ]");
# end);
################################################################################
##
#F WritePortraitsToFile. . . . . . . . . . . . .Writes portraitso of elements of
## a list in a file in the form understandable by Maple
# InstallGlobalFunction(WritePortraitsToFile, function(lst, G, file, add)
# local WritePerm, i, p;
#
# if add then AppendTo(file, "[ ");
# else PrintTo(file, "[ ");
# fi;
#
# for i in [1..Length(lst)] do
# if i = 1 then
# AppendTo(file, "[ ", lst[i], ", ");
# else
# AppendTo(file, ", [ ", lst[i], ", ");
# fi;
# p := AutomPortrait(lst[i], G);
# WritePortraitToFile(p, file, true);
# AppendTo(file, "]");
#
# od;
# end);
InstallMethod(Growth, "for [IsAutomGroup, IsCyclotomic]", true,
[IsGroup, IsCyclotomic],
function(G, max_len)
local ElList, GrList, i, j, orig_gens, gen, gens, new_gen, g, len, viewed, oldgr, New, k, cur_els;
# produce a symmetric generating set
orig_gens := ShallowCopy(GeneratorsOfGroup(G));
Append(orig_gens, List(orig_gens, x -> x^-1));
gens := [];
# select pairwise different generators
for i in [1..Length(orig_gens)] do
if not IsOne(orig_gens[i]) then
new_gen := true;
for j in [1..i-1] do if orig_gens[i] = orig_gens[j] then new_gen := false; fi; od;
if new_gen then Add(gens, orig_gens[i]); fi;
fi;
od;
ElList := [One(G)]; Append(ElList, ShallowCopy(gens));
GrList := [1, Length(gens)+1];
len := 1;
while len < max_len and GrList[len] <> GrList[len+1] do
for i in [GrList[len]+1..GrList[len+1]] do
oldgr := Length(ElList);
for gen in gens do
g := ElList[i]*gen;
New := true;
if len = 1 then k := 1; else k := GrList[len-1]; fi;
while New and k <= oldgr do
if g = ElList[k] then New := false; fi;
k := k+1;
od;
if New then Add(ElList, g); fi;
od;
od;
Add(GrList, Length(ElList));
Print("There are ", Length(ElList), " elements of length up to ", len+1, "\n");
len := len+1;
od;
if GrList[len] = GrList[len+1] then
SetSize(G, GrList[len]);
fi;
return GrList;
end);
InstallMethod(Growth, "for [IsTreeHomomorphismSemigroup, IsCyclotomic]", true,
[IsTreeHomomorphismSemigroup, IsCyclotomic],
function(G, max_len)
local iter, g, i;
iter := Iterator(G, max_len);
for g in iter do od;
return List(iter!.levels, x -> x[Length(x)]);
end);
InstallMethod(ListOfElements, "for [IsTreeHomomorphismSemigroup, IsCyclotomic]", true,
[IsGroup, IsCyclotomic],
function(G, max_len)
return FindElements(G, ReturnTrue, true, max_len);
end);
InstallMethod(AG_FiniteGroupId, "for [IsAutomatonGroup, IsPosInt]", true,
[IsAutomatonGroup, IsCyclotomic],
function(H, size)
local gr, len, ElList, GrList, inv, i, j, k, oldgr, v, tmpv, New, IsNewRel, inverse, G, FinG, tmpl, push, ProductEls, act, rels, LongCycle;
inverse := function(w)
local i, iw;
iw := [];
for i in [1..Length(w)] do
iw[i] := w[Length(w)-i+1]^inv;
od;
return iw;
end;
ProductEls := function(i, j)
local t, v, tmpv;
v := StructuralCopy(ElList[i]);
Append(v, ElList[j]);
for t in [1..Length(ElList)] do
tmpv := StructuralCopy(v);
Append(tmpv, inverse(ElList[t]));
if AG_IsOneList(tmpv, G) then return t; fi;
od;
end;
LongCycle := function(n)
local l, i;
l := [];
for i in [2..n] do Add(l, i); od;
Add(l, 1);
return PermList(l);
end;
IsNewRel := function(v)
local tmp, i, j, cyc, cycr, v_cyc, r_cyc, r, r_cyc_inv;
cyc := LongCycle(Length(v));
for i in [0..Length(v)-1] do
v_cyc := Permuted(v, cyc^i);
if v_cyc[1] = v_cyc[Length(v)]^inv then return false; fi;
for r in rels do
cycr := LongCycle(Length(r));
for j in [0..Length(r)-1] do
r_cyc := Permuted(r, cycr^j);
r_cyc_inv := inverse(Permuted(r, cycr^j));
if PositionSublist(v_cyc, r_cyc) <> fail or PositionSublist(v_cyc, r_cyc_inv) <> fail then
return false;
fi;
od;
od;
od;
return true;
end;
####################### _FiniteGroupId itself #########################################
gr := 1; len := 1;
G := AG_ChooseAutomatonList(H);
inv := InversePerm(G);
if not HasIsFinite(H) then
Info(InfoAutomGrp, 2, "warning, if < H > is infinite the algorithm will never stop");
fi;
GrList := [1, Length(G)];
ElList := []; rels := [];
for i in [1..Length(G)] do
Add(ElList, [i]);
od;
while GrList[len+1] > GrList[len] and GrList[len+1] < size do
for i in [GrList[len]+1..GrList[len+1]] do
oldgr := Length(ElList);
for j in [2..Length(G)] do
v := StructuralCopy(ElList[i]);
if j <> v[Length(v)]^inv then
Add(v, j);
New := true;
if len = 1 then k := 1; else k := GrList[len-1]+1; fi;
while New and k <= oldgr do
tmpv := StructuralCopy(v);
Append(tmpv, inverse(ElList[k]));
if AG_IsOneList(tmpv, G) then
New := false;
## show relations
if IsNewRel(tmpv) then
Add(rels, tmpv);
# Info(InfoAutomGrp, 3, v, "*", ElList[k], "^(-1) = 1");
# Print(tmpv, "\n");
fi;
fi;
k := k+1;
od;
if New then Add(ElList, v); fi;
fi;
od;
od;
Add(GrList, Length(ElList));
Info(InfoAutomGrp, 3, "There are ", Length(ElList), " elements of length up to ", len+1);
len := len+1;
od;
if GrList[len+1] > GrList[len] then return fail; fi;
SetSize(H, GrList[len]);
# in case of finite group construct Cayley table
FinG := [];
for i in [2..UnderlyingAutomFamily(H)!.numstates+1] do
act := ();
tmpl := [];
while Length(tmpl) < Length(ElList) do
j := 1;
while j in tmpl do j := j+1; od;
Add(tmpl, j);
push := ProductEls(j, i);
while push <> j do
Add(tmpl, push);
act := act*(j, push);
push := ProductEls(push, i);
od;
od;
Add(FinG, act);
od;
return GroupWithGenerators(FinG);
end);
InstallMethod(AG_FiniteGroupId, "for [IsAutomGroup]",
[IsAutomGroup],
function(G)
return AG_FiniteGroupId(G, infinity);
end);
InstallMethod(AG_FiniteGroupId, "for [IsAutomGroup, IsCyclotomic]",
[IsAutomGroup, IsCyclotomic],
function(G, n)
local ElList, GrList, i, j, orig_gens, gen, gens, new_gen, g, len, viewed, oldgr, New, k, ProductEls, FinG, tmpl, push, act, track_l,
num_diff_gens, num_orig_gens, old_gens;
ProductEls := function(i, j)
local t;
for t in [1..Length(ElList)] do
if IsOne(ElList[i]*ElList[j]*ElList[t]^-1) then return t; fi;
od;
return fail;
end;
orig_gens := ShallowCopy(GeneratorsOfGroup(G));
num_orig_gens := Length(orig_gens);
Append(orig_gens, List(orig_gens, x -> x^-1));
gens := [];
# select pairwise different generators and track the original ones.
# examlpe: assume b^2 = 1
# orig_gens = [a, e, a, b, b, c, a^-1, e^-1, a^-1, b^-1, b^-1, c^-1]
# track_l = [1, 0, 1, 2, 2, 3, 4, 0, 4, 2, 2, 5 ]
# gens = [a, b, c, a^-1, c^-1]
# num_orig_gens = 6
# num_diff_gens = 3
track_l := [];
for i in [1..Length(orig_gens)] do
if IsOne(orig_gens[i]) then
track_l[i] := 0;
else
new_gen := true;
j := 1;
while j < i and new_gen do
if orig_gens[i] = orig_gens[j] then
new_gen := false;
track_l[i] := track_l[j];
fi;
j := j+1;
od;
if new_gen then
Add(gens, orig_gens[i]);
track_l[i] := Length(gens);
fi;
if i = num_orig_gens then num_diff_gens := Length(gens); fi;
fi;
od;
ElList := [One(G)]; Append(ElList, ShallowCopy(gens));
GrList := [1, Length(gens)+1];
len := 1;
while len < n and GrList[len] <> GrList[len+1] do
for i in [GrList[len]+1..GrList[len+1]] do
oldgr := Length(ElList);
for gen in gens do
g := ElList[i]*gen;
# Print("g = ", g, "\n\n");
New := true;
if len = 1 then k := 1; else k := GrList[len-1]; fi;
while New and k <= oldgr do
# Print(g*ElList[k]^-1, "\n");
if IsOne(g*ElList[k]^-1) then New := false; fi;
k := k+1;
od;
if New then Add(ElList, g); fi;
od;
od;
Add(GrList, Length(ElList));
Info(InfoAutomGrp, 3, "There are ", Length(ElList), " elements of length up to ", len+1);
len := len+1;
od;
if GrList[len] <> GrList[len+1] then return fail; fi;
SetSize(G, GrList[len]);
# in case of finite group construct Cayley table
FinG := [];
for i in [2..num_diff_gens+1] do
act := ();
tmpl := [];
while Length(tmpl) < Length(ElList) do
j := 1;
while j in tmpl do j := j+1; od;
Add(tmpl, j);
push := ProductEls(j, i);
while push <> j do
Add(tmpl, push);
act := act*(j, push);
push := ProductEls(push, i);
od;
od;
Add(FinG, act);
od;
# switch to the original generating set
old_gens := [];
for i in [1..num_orig_gens] do
if track_l[i] = 0 then
old_gens[i] := ();
else
old_gens[i] := FinG[track_l[i]];
fi;
od;
return GroupWithGenerators(old_gens);
end);
InstallGlobalFunction(AG_IsOneWordSubs, function(w, subs, G)
local i, v;
v := [];
for i in w do Append(v, subs[i]); od;
return AG_IsOneList(v, G);
end);
InstallMethod(FindGroupRelations, "for [IsList and IsAutomCollection, IsList, IsCyclotomic, IsCyclotomic]", true,
[IsList and IsAutomCollection, IsList, IsCyclotomic, IsCyclotomic],
function(subs_words, names, max_len, num_of_rels)
local G, gens, Gi, H, rel, rels, rels0, k, track_s, track_l, AssocW, FindGroupRelationsLocal, gens_autom, i, j, subs, subs1, w_list, FindGroupRelationsSubsLocal, w_ext, w, automgens, numstates, F, cur_gen;
AssocW := function(w)
return Product(List(w, i -> gens[i]));
end;
FindGroupRelationsSubsLocal := function(subs, G)
local gr, len, ElList, GrList, inv, i, j, k, oldgr, v, tmpv, New, IsNewRelS, inverse, inverseS, H, FinG, tmpl, push, ProductEls, act, rels, LongCycle, invslist, invs, origlength, w, invadded, AssocWrels;
inverse := function(w)
local i, iw;
iw := [];
for i in [1..Length(w)] do
iw[i] := w[Length(w)-i+1]^inv;
od;
return iw;
end;
inverseS := function(w)
local i, iw;
iw := [];
for i in [1..Length(w)] do
iw[i] := w[Length(w)-i+1]^invs;
od;
return iw;
end;
ProductEls := function(i, j)
local t, v, tmpv;
v := StructuralCopy(ElList[i]);
Append(v, ElList[j]);
for t in [1..Length(ElList)] do
tmpv := StructuralCopy(v);
Append(tmpv, inverse(ElList[t]));
if AG_IsOneList(tmpv, G) then return t; fi;
od;
end;
LongCycle := function(n)
local l, i;
l := [];
for i in [2..n] do Add(l, i); od;
Add(l, 1);
return PermList(l);
end;
IsNewRelS := function(v)
local tmp, i, j, cyc, cycr, v_cyc, r_cyc, r, r_cyc_inv;
cyc := LongCycle(Length(v));
for i in [0..Length(v)-1] do
v_cyc := Permuted(v, cyc^i);
if v_cyc[1] = v_cyc[Length(v)]^invs then return false; fi;
for r in rels do
cycr := LongCycle(Length(r));
for j in [0..Length(r)-1] do
r_cyc := Permuted(r, cycr^j){[1..Int(Length(r)/2)+1]};
r_cyc_inv := inverseS(Permuted(r, cycr^j)){[1..Int(Length(r)/2)+1]};
if PositionSublist(v_cyc, r_cyc) <> fail or PositionSublist(v_cyc, r_cyc_inv) <> fail then
return false;
fi;
od;
od;
od;
return true;
end;
#************************ FindGroupRelationsSubsLocal itself ****************************************************
rels := [];
# G := GroupOfAutomFamily(FamilyObj(subs_words[1]));
inv := InversePerm(G);
#check if there are any identity elements in subs list
for i in [1..Length(subs)] do
if AG_IsOneList(subs[i], G) then
Error(AssocW([i]), " = id, remove this element from a list and try again");
fi;
od;
AssocWrels := [];
#check if there are any equal elements in subs list
invslist := [];
for i in [1..Length(subs)] do
for j in [i..Length(subs)] do
if i <> j and AG_IsOneList(Concatenation(subs[i], inverse(subs[j])), G) then
Error(AssocW([i]), " = ", AssocW([j]), ", remove one of these elements from a list and try again");
fi;
# Print(AG_IsOneList(Append(StructuralCopy(subs[i]), subs[j]), G), "\n");
# Print(Concatenation(subs[i], subs[j]), "\n");
if AG_IsOneList(Concatenation(subs[i], subs[j]), G) then
invslist[i] := j; invslist[j] := i;
Add(rels, [i, j]);
Add(AssocWrels, AssocW([i, j]));
Print(AssocW([i, j]), "\n");
fi;
od;
od;
# add inverses to subs list
origlength := Length(subs);
invadded := false;
for i in [1..origlength] do
if not IsBound(invslist[i]) then
invadded := true;
Add(subs, inverse(subs[i]));
Add(gens, gens[i]^-1);
invslist[i] := Length(subs);
invslist[Length(subs)] := i;
fi;
od;
invs := PermList(invslist);
GrList := [1, Length(subs)+1];
ElList := [];
gr := 1; len := 1;
for i in [1..Length(subs)] do
Add(ElList, [i]);
od;
while GrList[len+1] > GrList[len] and len < max_len and Length(rels) < num_of_rels do
for i in [GrList[len]..GrList[len+1]-1] do
oldgr := Length(ElList);
for j in [1..Length(subs)] do
v := StructuralCopy(ElList[i]);
if j <> v[Length(v)]^invs then
Add(v, j);
New := true;
# k := 1;
if len = 1 then k := 1; else k := GrList[len-1]; fi;
while New and k <= oldgr do
tmpv := StructuralCopy(v);
Append(tmpv, inverseS(ElList[k]));
if AG_IsOneWordSubs(tmpv, subs, G) then
New := false;
## show relations
if IsNewRelS(tmpv) then
Add(rels, tmpv);
if Length(AssocW(tmpv)) > 0 then
Add(AssocWrels, AssocW(tmpv));
Print(AssocW(tmpv), "\n");
fi;
fi;
fi;
k := k+1;
od;
if New then Add(ElList, v); fi;
fi;
od;
od;
Add(GrList, Length(ElList)+1);
# Print("ElList[", len, "] = ", ElList, "\n");
Info(InfoAutomGrp,3,"There are ", Length(ElList) + 1, " elements of length up to ", len+1);
len := len+1;
od;
return AssocWrels;
end;
#************************ FindGroupRelationsSubs itself ****************************************************
if Length(subs_words) <> Length(names) then
Error("The number of names must coincide with the number of generators");
fi;
F := FreeGroup(names);
G := GroupOfAutomFamily(FamilyObj(subs_words[1]));
# gens is a mutable list of generators
gens := ShallowCopy(GeneratorsOfGroup(F));
automgens := UnderlyingAutomFamily(G)!.automgens;
numstates := UnderlyingAutomFamily(G)!.numstates;
#convert associative words into lists
subs1 := List(subs_words, CONVERT_ASSOCW_TO_LIST);
Gi := StructuralCopy(AG_MinimizedAutomatonList(G));
# Print("Gi = ", Gi, "\n");
H := Gi[1];
track_s := Gi[2];
track_l := Gi[3];
subs := [];
for w in subs1 do
w_list := [];
for i in [1..Length(w)] do Add(w_list, track_l[w[i]]); od;
Add(subs, ShallowCopy(w_list));
od;
rels0 := [];
# for k in [1..Length(AutomatonList(G))] do
# Print("Beam\n");
# if track_l[k] = 1 then Add(rels0, AssocW([k]));
# elif track_s[track_l[k]] <> k then Add(rels0, AssocW([k, track_s[track_l[k]]+Length(AutomatonList(G))]));
# fi;
# od;
rels := FindGroupRelationsSubsLocal(subs, AG_ChooseAutomatonList(G));
if rels = fail then return fail; fi;
Append(rels0, rels);
# Print(rels0);
return rels0;
end);
InstallMethod(FindGroupRelations, "for [IsList and IsAutomCollection, IsList, IsCyclotomic]", true,
[IsList and IsAutomCollection, IsList, IsCyclotomic],
function(subs_words, names, max_len)
return FindGroupRelations(subs_words, names, max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList and IsAutomCollection, IsList]",
[IsList and IsAutomCollection, IsList],
function(subs_words, names)
return FindGroupRelations(subs_words, names, infinity, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsAutomGroup, IsCyclotomic, IsCyclotomic]", true,
[IsAutomatonGroup, IsCyclotomic, IsCyclotomic],
function(G, max_len, num_of_rels)
local gens, Gi, H, rel, rels, rels0, k, track_s, track_l, AssocW, FindGroupRelationsLocal;
AssocW := function(w)
#Print(w);
return Product(List(w, i -> gens[i]));
end;
FindGroupRelationsLocal := function(subs, G)
local gr, len, ElList, GrList, inv, i, j, k, oldgr, v, tmpv, New, IsNewRelS, inverse, inverseS, H, FinG, tmpl, push, ProductEls, act, rels, LongCycle, invslist, invs, origlength, w, invadded, tmpv_orig, AssocWrels;
inverse := function(w)
local i, iw;
iw := [];
for i in [1..Length(w)] do
iw[i] := w[Length(w)-i+1]^inv;
od;
return iw;
end;
inverseS := function(w)
local i, iw;
iw := [];
for i in [1..Length(w)] do
iw[i] := w[Length(w)-i+1]^invs;
od;
return iw;
end;
ProductEls := function(i, j)
local t, v, tmpv;
v := StructuralCopy(ElList[i]);
Append(v, ElList[j]);
for t in [1..Length(ElList)] do
tmpv := StructuralCopy(v);
Append(tmpv, inverse(ElList[t]));
if AG_IsOneList(tmpv, G) then return t; fi;
od;
end;
LongCycle := function(n)
local l, i;
l := [2..n];
Add(l, 1);
return PermList(l);
end;
IsNewRelS := function(v)
local tmp, i, j, cyc, cycr, v_cyc, r_cyc, r, r_cyc_inv;
cyc := LongCycle(Length(v));
for i in [0..Length(v)-1] do
v_cyc := Permuted(v, cyc^i);
if v_cyc[1] = v_cyc[Length(v)]^invs then return false; fi;
for r in rels do
cycr := LongCycle(Length(r));
for j in [0..Length(r)-1] do
r_cyc := Permuted(r, cycr^j){[1..Int(Length(r)/2)+1]};;
r_cyc_inv := inverseS(Permuted(r, cycr^j)){[1..Int(Length(r)/2)+1]};;
if PositionSublist(v_cyc, r_cyc) <> fail or PositionSublist(v_cyc, r_cyc_inv) <> fail then
return false;
fi;
od;
od;
od;
return true;
end;
#************************ FindGroupRelationsLocal itself ****************************************************
rels := [];
AssocWrels := [];
inv := InversePerm(G);
invslist := [];
for i in [1..Length(subs)] do
for j in [i..Length(subs)] do
# Print(AssocW([Gi[2][i+1], Gi[2][j+1]])!.word, "\n");
if AG_IsOneList(Concatenation(subs[i], subs[j]), G) then
invslist[i] := j; invslist[j] := i;
if Length(AssocW([Gi[2][i+1], Gi[2][j+1]])!.word) > 0 then
Add(rels, [i, j]);
Add(AssocWrels, AssocW([Gi[2][i+1], Gi[2][j+1]]));
Print( AssocW([Gi[2][i+1], Gi[2][j+1]])!.word, "\n");
fi;
fi;
od;
od;
invs := PermList(invslist);
GrList := [1, Length(subs)+1];
ElList := [];
gr := 1; len := 1;
for i in [1..Length(subs)] do
Add(ElList, [i]);
od;
while GrList[len+1] > GrList[len] and len < max_len and Length(rels) < num_of_rels do
for i in [GrList[len]..GrList[len+1]-1] do
oldgr := Length(ElList);
for j in [1..Length(subs)] do
v := StructuralCopy(ElList[i]);
if j <> v[Length(v)]^invs then
Add(v, j);
New := true;
# k := 1;
if len = 1 then k := 1; else k := GrList[len-1]; fi;
while New and k <= oldgr do
tmpv := StructuralCopy(v);
Append(tmpv, inverseS(ElList[k]));
if AG_IsOneWordSubs(tmpv, subs, G) then
New := false;
## show relations
if IsNewRelS(tmpv) then
# tmpv in the original generators
tmpv_orig := [];
for k in [1..Length(tmpv)] do
tmpv_orig[k] := Gi[2][tmpv[k]+1];
od;
Add(rels, tmpv);
if Length(AssocW(tmpv_orig)!.word) > 0 then
Add(AssocWrels, AssocW(tmpv_orig));
Print( AssocW(tmpv_orig)!.word, "\n");
fi;
# Print(tmpv, "\n");
fi;
fi;
k := k+1;
od;
if New then Add(ElList, v); fi;
fi;
od;
od;
Add(GrList, Length(ElList)+1);
# Print("ElList[", len, "] = ", ElList, "\n");
Info(InfoAutomGrp, 3, "There are ", Length(ElList) + 1, " elements of length up to ", len + 1);
len := len+1;
od;
return AssocWrels;
end;
#************************ FindGroupRelations itself ****************************************************
gens := ShallowCopy(UnderlyingAutomFamily(G)!.automgens);
Gi := StructuralCopy(AG_MinimizedAutomatonList(G));
# Print("Gi = ", Gi, "\n");
H := Gi[1];
track_s := Gi[2];
track_l := Gi[3];
rels0 := [];
# for k in [1..Length(AutomatonList(G))] do
# Print("Beam\n");
# if track_l[k] = 1 then Add(rels0, AssocW([k]));
# elif track_s[track_l[k]] <> k then Add(rels0, AssocW([k, track_s[track_l[k]]+Length(AutomatonList(G))]));
# fi;
# od;
rels := FindGroupRelationsLocal(List([2..Length(H)], i -> [i]), AG_ChooseAutomatonList(G));
Append(rels0, rels);
# Print(rels0);
return rels0;
end);
InstallMethod(FindGroupRelations, "for [IsAutomGroup, IsCyclotomic]", true,
[IsAutomatonGroup, IsCyclotomic],
function(G, max_len)
return FindGroupRelations(G, max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsAutomGroup]",
[IsAutomatonGroup],
function(G)
return FindGroupRelations(G, infinity, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList and IsAutomCollection, IsCyclotomic, IsCyclotomic]", true,
[IsList and IsAutomCollection, IsCyclotomic, IsCyclotomic],
function(subs_words, max_len, num_of_rels)
return FindGroupRelations(GroupWithGenerators(subs_words), max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList and IsAutomCollection, IsCyclotomic]", true,
[IsList and IsAutomCollection, IsCyclotomic],
function(subs_words, max_len)
return FindGroupRelations(subs_words, max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList and IsAutomCollection]",
[IsList and IsAutomCollection],
function(subs_words)
return FindGroupRelations(subs_words, infinity, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsGroup, IsCyclotomic, IsCyclotomic]", true,
[IsGroup, IsCyclotomic, IsCyclotomic],
function(G, max_len, num_of_rels)
local ElList, GrList, i, j, orig_gens, gen, gens, new_gen, g, len, oldgr, New, k, rels, rel, F, relsF, ElListF, genf, f, fgens, all_relsF, rel1, new_rel, r, orig_fgens, \
IsNewRel, CyclicConjugates, ngens, FFhom_images, FFhom, FGhom_images, FGhom, ElList_inv, inv_gens, cur_rel;
IsNewRel := function(rel)
local rel1, r;
rel1 := rel;
repeat
for r in all_relsF do
if PositionWord(rel1, Subword(r,1,Int(Length(r)/2)+1), 1) <> fail then return false; fi;
od;
rel1 := rel1^Subword(rel1, 1, 1);
until rel1 = rel;
return true;
end;
CyclicConjugates := function(rel)
local rel1, conjs;
rel1 := rel; conjs := [];
repeat
rel1 := rel1^Subword(rel1, 1, 1);
Add(conjs, rel1);
until rel1 = rel;
return conjs;
end;
orig_gens := ShallowCopy(GeneratorsOfGroup(G));
ngens := Length(orig_gens);
F := FreeGroup(ngens);
orig_fgens := ShallowCopy(GeneratorsOfGroup(F));
FFhom_images := ShallowCopy(GeneratorsOfGroup(F));
FGhom_images := ShallowCopy(GeneratorsOfGroup(G));
Append(orig_gens, List(orig_gens, x -> x^-1));
Append(orig_fgens, List(orig_fgens, x -> x^-1));
gens := [];
fgens := [];
rels := [];
relsF := [];
all_relsF := [];
# select pairwise different generators
for i in [1..Length(orig_gens)] do
if not IsOne(orig_gens[i]) then
new_gen := true;
for j in [1..i-1] do
if orig_gens[i] = orig_gens[j] then
new_gen := false;
if IsNewRel(orig_fgens[i]^-1*orig_fgens[j]) then
if not IsIdenticalObj(orig_gens[i], orig_gens[j]) then
Add(rels, orig_gens[i]^-1*orig_gens[j]);
Print( orig_gens[i]^-1*orig_gens[j], "\n");
fi;
Add(relsF, orig_fgens[i]^-1*orig_fgens[j]);
Append(all_relsF, CyclicConjugates(orig_fgens[i]^-1*orig_fgens[j]));
if i > ngens and j <= ngens then
# hom_images[i-ngens] := orig_gens[j+ngens];
# hom_images[j] := orig_gens[i];
FFhom_images[i-ngens] := orig_fgens[j+ngens];
FFhom_images[j] := orig_fgens[i];
fi;
fi;
break;
fi;
od;
if new_gen then
Add(gens, orig_gens[i]);
Add(fgens, orig_fgens[i]);
if i <= ngens then
FGhom_images[i] := orig_gens[i];
fi;
fi;
else
if not IsIdenticalObj(orig_gens[i], One(orig_gens[i])) then
Add(rels, orig_gens[i]);
Print( orig_gens[i], "\n");
fi;
#
# Add(relsF, orig_fgens[i]);
fi;
od;
# inv_gens := [];
# for i in [1..Length(gens)] do
# for j in [1..i] do
# if IsOne(gens[i]*gens[j]) then
# inv_gens[i] := gens[j]; inv_gens[j] := gens[i];
# fi;
# od;
# od;
# Print("gens = ", gens, "\n");
# Print("inv_gens = ", inv_gens, "\n");
FFhom := GroupHomomorphismByImagesNC(F, F, GeneratorsOfGroup(F), FFhom_images);
FGhom := GroupHomomorphismByImagesNC(F, G, GeneratorsOfGroup(F), FGhom_images);
# Print("hom = ", hom, "\n");
ElList := [One(G)];
# ElList_inv := [One(G)];
ElListF := [One(F)];
Append(ElList, ShallowCopy(gens));
# Append(ElList_inv, ShallowCopy(inv_gens));
Append(ElListF, ShallowCopy(fgens));
GrList := [1, Length(gens)+1];
len := 1;
while GrList[len] <> GrList[len+1] and len < max_len and Length(rels) < num_of_rels do
for i in [GrList[len]+1..GrList[len+1]] do
oldgr := Length(ElList);
for j in [1..Length(gens)] do
f := ElListF[i]*fgens[j];
if Length(f) > Length(ElListF[i]) then
g := ElList[i]*gens[j];
New := true;
if len = 1 then k := 1; else k := GrList[len-1]; fi;
while New and k <= oldgr do
if g = ElList[k] then
New := false;
fi;
k := k+1;
od;
if New then
Add(ElList, g);
# Add(ElList_inv, inv_gens[j]*ElList_inv[i]);
Add(ElListF, f);
else
new_rel := true;
rel := CyclicallyReducedWord(Image(FFhom, f^-1)*ElListF[k-1]);
if Length(rel) < Length(f)+Length(ElListF[k-1]) then new_rel := false; fi;
if new_rel and IsNewRel(rel) and IsNewRel(Image(FFhom, rel^-1)) then
# Add(rels, inv_gens[j]*ElList_inv[i]*ElList[k-1]);
cur_rel := Image(FGhom, rel);
Add(rels, cur_rel);
Add(relsF, rel);
Print( cur_rel, "\n");
Append(all_relsF, CyclicConjugates(rel));
fi;
fi;
fi;
od;
od;
Add(GrList, Length(ElList));
Info(InfoAutomGrp, 3, "There are ", Length(ElList), " elements of length up to ", len+1);
len := len+1;
od;
if GrList[len] = GrList[len+1] then
SetSize(G, GrList[len]);
fi;
return rels;
end);
InstallMethod(FindGroupRelations, "for [IsGroup, IsCyclotomic]", true,
[IsGroup, IsCyclotomic],
function(G, max_len)
return FindGroupRelations(G, max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsGroup]",
[IsGroup],
function(G)
return FindGroupRelations(G, infinity, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList, IsCyclotomic, IsCyclotomic]", true,
[IsList, IsCyclotomic, IsCyclotomic],
function(subs_words, max_len, num_of_rels)
return FindGroupRelations(GroupWithGenerators(subs_words), max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList, IsCyclotomic]", true,
[IsList, IsCyclotomic],
function(subs_words, max_len)
return FindGroupRelations(subs_words, max_len, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList]",
[IsList],
function(subs_words)
return FindGroupRelations(subs_words, infinity, infinity);
end);
InstallMethod(FindGroupRelations, "for [IsList, IsList, IsCyclotomic, IsCyclotomic]", true,
[IsList, IsList, IsCyclotomic, IsCyclotomic],
function(subs_words, names, max_len, num_of_rels)
local ElList, GrList, i, j, orig_gens, gen, gens, new_gen, g, len, oldgr, New, k, rel, F, relsF, ElListF, genf, f, fgens, all_relsF, rel1, new_rel, r, orig_fgens, \
IsNewRel, CyclicConjugates, ngens, FFhom_images, FFhom;
IsNewRel := function(rel)
local rel1, r;
rel1 := rel;
repeat
for r in all_relsF do
if PositionWord(rel1, Subword(r,1,Int(Length(r)/2)+1), 1) <> fail then return false; fi;
od;
rel1 := rel1^Subword(rel1, 1, 1);
until rel1 = rel;
return true;
end;
CyclicConjugates := function(rel)
local rel1, conjs;
rel1 := rel; conjs := [];
repeat
rel1 := rel1^Subword(rel1, 1, 1);
Add(conjs, rel1);
until rel1 = rel;
return conjs;
end;
if Length(subs_words) <> Length(names) then
Error("The number of names must coincide with the number of generators");
fi;
orig_gens := ShallowCopy(subs_words);
F := FreeGroup(names);
orig_fgens := ShallowCopy(GeneratorsOfGroup(F));
ngens := Length(orig_gens);
FFhom_images := ShallowCopy(GeneratorsOfGroup(F));
Append(orig_gens, List(orig_gens, x -> x^-1));
Append(orig_fgens, List(orig_fgens, x -> x^-1));
gens := [];
fgens := [];
relsF := [];
all_relsF := [];
# select pairwise different generators
for i in [1..Length(orig_gens)] do
if not IsOne(orig_gens[i]) then
new_gen := true;
for j in [1..i-1] do
if orig_gens[i] = orig_gens[j] then
new_gen := false;
if IsNewRel(orig_fgens[i]^-1*orig_fgens[j]) then
Add(relsF, orig_fgens[i]^-1*orig_fgens[j]);
Print(orig_fgens[i]^-1*orig_fgens[j], "\n");
Append(all_relsF, CyclicConjugates(orig_fgens[i]^-1*orig_fgens[j]));
if i > ngens and j <= ngens then
FFhom_images[i-ngens] := orig_fgens[j+ngens];
FFhom_images[j] := orig_fgens[i];
fi;
fi;
break;
fi;
od;
if new_gen then
Add(gens, orig_gens[i]);
Add(fgens, orig_fgens[i]);
fi;
else
Add(relsF, orig_fgens[i]);
--> --------------------
--> maximum size reached
--> --------------------
[ Dauer der Verarbeitung: 0.54 Sekunden
(vorverarbeitet)
]
|
2026-04-02
|
