F:=FreeAbelianGroup(4);
rels1:=[F.1+F.2+F.3=0,F.4=0];
H:=sub<Sym(4)|Sym(4)!(1,2),Sym(4)!(1,2,3)>;

function G2BlockSystem()
return Sort([[i]:i in [[1],[2],[3],[-1],[-2],[-3],[4],[-3,2],[-3,1],[-2,3],[-2,1],[-1,2],[-1,3]]]);
end function;

function BlockToRelations(X)
if(#X eq 1) then return []; end if;
w1:=&+[Sign(i)*F.Abs(i):i in X[1]];
return [w1 = &+[Sign(i)*F.Abs(i):i in X[j]]:j in [2..#X]];
end function;


function BlockSystemToRelations(B)
return [F.1+F.2+F.3=0,F.4=0] cat &cat[BlockToRelations(X):X in B];
end function;


function BlockSystemToStabilizer(B)
return quo<F|BlockSystemToRelations(B)>;
end function;


function MergeBlocksOfBlockSystem(B,i,j)
if(i eq j) then return B; end if;
N:=Sort(B[i] cat B[j]);
Remove(~B,Maximum(i,j)); Remove(~B,Minimum(i,j));
return Sort(Append(B,N));
end function;

function MergeSpecificBlocksOfBlockSystem(B,a1,a2)
for i in [1..#B] do if(a1 in B[i]) then i1:=i; end if; if(a2 in B[i]) then i2:=i; end if; end for;
return MergeBlocksOfBlockSystem(B,i1,i2);
end function;

function ClosureOfBlockSystem(B)
rels:=[F.1+F.2+F.3=0,F.4=0] cat &cat[BlockToRelations(X):X in B];
G,rho:=quo<F|rels>;
mer:=[];
for i in [1..#B-1] do
  w1:=&+[rho(Sign(l)*F.Abs(l)):l in B[i,1]];
  for j in [i+1..#B] do
    if(w1 eq &+[rho(Sign(l)*F.Abs(l)):l in B[j,1]]) then Append(~mer,[B[i,1],B[j,1]]); end if;
  end for;
  delete w1;
end for;
for i in mer do B:=MergeSpecificBlocksOfBlockSystem(B,i[1],i[2]); end for;
return B;
end function;


function AllCoarsenings(B)
return [MergeBlocksOfBlockSystem(B,i,j):i,j in [1..#B]|i lt j];
end function;


function ImageUnderPermutation(B,f)
return Sort([Sort([Sort([Sign(i)*(Abs(i)^f):i in j]):j in k]):k in B]);
end function;

function FindSmallestBlockSystem(B,H)
B1:=B;
for h in H do
  B2:=ImageUnderPermutation(B,h);
  if(B2 lt B1) then delete B1; B1:=B2; end if;
  delete B2;
end for;
return B1;
end function;

B0:=G2BlockSystem();
ToRefine:=[B0];
FoundSoFar:=[B0];
DimZero:=[];

while(#ToRefine gt 0) do
  B:=ToRefine[1];
  B1:=AllCoarsenings(B);
  B2:={ClosureOfBlockSystem(i):i in B1};
  B3:=[FindSmallestBlockSystem(i,H):i in B2];
  delete B; delete B1; delete B2;
  for i in B3 do
    if(not(i in FoundSoFar)) then Append(~FoundSoFar,i);
    if(TorsionFreeRank(BlockSystemToStabilizer(i)) eq 0) then Append(~DimZero,i); else Append(~ToRefine,i); end if;
    end if;
  end for;
  delete B3;
  Remove(~ToRefine,1);
  #DimZero,#ToRefine,#FoundSoFar;
end while;

{Exponent(BlockSystemToStabilizer(i)):i in DimZero};