Quelle oprtperm.gi Sprache: Shell

#############################################################################
##
## This file is part of GAP, a system for computational discrete algebra.
## This file's authors include Heiko Theißen.
##
## Copyright of GAP belongs to its developers, whose names are too numerous
## to list here. Please refer to the COPYRIGHT file for details.
##
## SPDX-License-Identifier: GPL-2.0-or-later
##

#############################################################################
##
#M Orbit( <G>, <pnt>, <gens>, <acts>, <OnPoints> ) . . . . . . . on integers
##
InstallOtherMethod( OrbitOp,
 "G, int, gens, perms, act = `OnPoints'", true,
 [ IsPermGroup, IsInt,
 IsList,
 IsList,
 IsFunction ], 0,
 function( G, pnt, gens, acts, act )
 if gens <> acts or act <> OnPoints then
 TryNextMethod();
 fi;
 if HasStabChainMutable( G )
 and IsInBasicOrbit( StabChainMutable( G ), pnt ) then
 return Immutable(StabChainMutable( G ).orbit);
 else
 return Immutable( OrbitPerms( acts, pnt ) );
 fi;
end );

#############################################################################
##
#M OrbitStabilizer( <G>, <pnt>, <gens>, <acts>, <OnPoints> ) . . on integers
##
InstallOtherMethod( OrbitStabilizerOp, "permgroup", true,
 [ IsPermGroup, IsInt,
 IsList,
 IsList,
 IsFunction ], 0,
 function( G, pnt, gens, acts, act )
 local S;

 if gens <> acts or act <> OnPoints then
 TryNextMethod();
 fi;
 S := StabChainOp( G, [ pnt ] );
 if BasePoint( S ) = pnt then
 return Immutable( rec( orbit := S.orbit,
 stabilizer := GroupStabChain
 ( G, S.stabilizer, true ) ) );
 else
 return Immutable( rec( orbit := [ pnt ],
 stabilizer := G ) );
 fi;
end );

#############################################################################
##
#M Orbits( <G>, <D>, <gens>, <acts>, <OnPoints> ) . . . . . . . on integers
##
BindGlobal( "ORBS_PERMGP_PTS", function( G, D, gens, acts, act )
 if act <> OnPoints then
 TryNextMethod();
 fi;
 return Immutable( OrbitsPerms( acts, D ) );
end );

InstallMethod( Orbits, "permgroup on points", true,
 [ IsGroup, IsList and IsCyclotomicCollection, IsList,
 IsList and IsPermCollection, IsFunction ], 0,ORBS_PERMGP_PTS);

InstallMethod( OrbitsDomain, "permgroup on points", true,
 [ IsGroup, IsList and IsCyclotomicCollection, IsList,
 IsList and IsPermCollection, IsFunction ], 0,ORBS_PERMGP_PTS);

#############################################################################
##
#M Cycle( <g>, <pnt>, <OnPoints> ) . . . . . . . . . . . . . . . on integers
##
InstallOtherMethod( CycleOp,"perm, int, act", true,
 [ IsPerm, IsInt, IsFunction ], 0,
 function( g, pnt, act )
 if act <> OnPoints then
 TryNextMethod();
 fi;
 return CycleOp( g, pnt );
end );

InstallOtherMethod( CycleOp,"perm, int", true,
 [ IsPerm and IsInternalRep, IsInt ], 0,
 function( g, pnt )
 return Immutable( CYCLE_PERM_INT( g, pnt ) );
end );

#############################################################################
##
#M CycleLength( <g>, <pnt>, <OnPoints> ) . . . . . . . . . . . . on integers
##
InstallOtherMethod( CycleLengthOp, "perm, int, act", true,
 [ IsPerm, IsInt, IsFunction ], 0,
 function( g, pnt, act )
 if act <> OnPoints then
 TryNextMethod();
 fi;
 return CycleLengthOp( g, pnt );
end );

InstallOtherMethod( CycleLengthOp, "perm, int", true,
 [ IsPerm and IsInternalRep, IsInt ],0, CYCLE_LENGTH_PERM_INT);

#############################################################################
##
#M Blocks( <G>, <D>, <gens>, <acts>, <OnPoints> ) . . . . find block system
##
InstallMethod( BlocksOp, "permgroup on integers",
 [ IsGroup, IsList and IsCyclotomicCollection, IsList and IsEmpty,
 IsList,
 IsList and IsPermCollection,
 IsFunction ],
 function( G, D, noseed, gens, acts, act )
 local one, # identity of `G'
 blocks, # block system of <G>, result
 orbit, # orbit of 1 under <G>
 trans, # factored inverse transversal for <orbit>
 eql, # ' = <eql>[<k>]' means $\beta(i) = \beta(k)$,
 next, # the points that are equivalent are linked
 last, # last point on the list linked through 'next'
 leq, # ' = <leq>[<k>]' means $\beta(i) <= \beta(k)$
 gen, # one generator of <G> or 'Stab(<G>,1)'
 rnd, # random element of <G>
 pnt, # one point in an orbit
 img, # the image of <pnt> under <gen>
 cur, # the current representative of an orbit
 rep, # the representative of a block in the block system
 block, # the block, result
 changed, # number of random Schreier generators
 nrorbs, # number of orbits of subgroup $H$ of $G_1$
 d1g, # D[1]^gen
 tr, # transversal element
 i; # loop variable

 if act <> OnPoints then
 TryNextMethod();
 fi;

 # handle trivial group
 if Length( acts ) = 0 and Length(D)>1 then
 Error("<G> must operate transitively on <D>");
 fi;

 # handle trivial domain
 if Length( D ) = 1 or IsPrimeInt( Length( D ) ) then
 return Immutable( [ D ] );
 fi;

 # compute the orbit of $G$ and a factored transversal
 one:= One( G );
 orbit := [ D[1] ];
 trans := [];
 trans[ D[1] ] := one;
 for pnt in orbit do
 for gen in acts do
 if not IsBound( trans[ pnt / gen ] ) then
 Add( orbit, pnt / gen );
 trans[ pnt / gen ] := gen;
 fi;
 od;
 od;

 # check that the group is transitive
 if Length( orbit ) <> Length( D ) then
 Error("<G> must operate transitively on <D>");
 fi;
 Info( InfoAction, 1, "BlocksNoSeed transversal computed" );
 nrorbs := Length( orbit );

 # since $i \in k^{G_1}$ implies $\beta(i)=\beta(k)$, we initialize <eql>
 # so that the connected components are orbits of some subgroup $H < G_1$
 eql := [];
 leq := [];
 next := [];
 last := [];
 for pnt in orbit do
 eql[pnt] := pnt;
 leq[pnt] := pnt;
 next[pnt] := 0;
 last[pnt] := pnt;
 od;

 # repeat until we have a block system
 changed := 0;
 cur := orbit[2];
 rnd := one;
 repeat

 # compute such an $H$ by taking random Schreier generators of $G_1$
 # and stop if 2 successive generators dont change the orbits any more
 while changed < 2 do

 # compute a random Schreier generator of $G_1$
 i := Length( orbit );
 while 1 <= i do
 rnd := rnd * Random( acts );
 i := QuoInt( i, 2 );
 od;
 gen := rnd;
 d1g:=D[1]^gen;
 while d1g <> D[1] do
 tr:=trans[ d1g ];
 gen := gen * tr;
 d1g:=d1g^tr;
 od;
 changed := changed + 1;
 Info( InfoAction, 3, "Changed: ",changed );

 # compute the image of every point under <gen>
 for pnt in orbit do
 img := pnt ^ gen;

 # find the representative of the orbit of <pnt>
 while eql[pnt] <> pnt do
 pnt := eql[pnt];
 od;

 # find the representative of the orbit of <img>
 while eql[img] <> img do
 img := eql[img];
 od;

 # if the don't agree merge their orbits
 if pnt < img then
 eql[img] := pnt;
 next[ last[pnt] ] := img;
 last[pnt] := last[img];
 nrorbs := nrorbs - 1;
 changed := 0;
 elif img < pnt then
 eql[pnt] := img;
 next[ last[img] ] := pnt;
 last[img] := last[pnt];
 nrorbs := nrorbs - 1;
 changed := 0;
 fi;

 od;

 od;
 Info( InfoAction, 1, "BlocksNoSeed ",
 "number of orbits of <H> < <G>_1 is ",nrorbs );

 # take arbitrary point <cur>, and an element <gen> taking 1 to <cur>
 while eql[cur] <> cur do
 cur := eql[cur];
 od;
 gen := [];
 img := cur;
 while img <> D[1] do
 Add( gen, trans[img] );
 img := img ^ trans[img];
 od;
 gen := Reversed( gen );

 # compute an alleged block as orbit of 1 under $< H, gen >$
 pnt := cur;
 while pnt <> 0 do

 # compute the representative of the block containing the image
 img := pnt;
 for i in gen do
 img := img / i;
 od;
 while eql[img] <> img do
 img := eql[img];
 od;

 # if it is not our current block but a minimal block
 if img <> D[1] and img <> cur and leq[img] = img then

 # then try <img> as a new start
 leq[cur] := img;
 cur := img;
 gen := [];
 img := cur;
 while img <> D[1] do
 Add( gen, trans[img] );
 img := img ^ trans[img];
 od;
 gen := Reversed( gen );
 pnt := cur;

 # otherwise if it is not our current block but contains it
 # by construction a nonminimal block contains the current block
 elif img <> D[1] and img <> cur and leq[img] <> img then

 # then merge all blocks it contains with <cur>
 while img <> cur do
 eql[img] := cur;
 next[ last[cur] ] := img;
 last[ cur ] := last[ img ];
 img := leq[img];
 while img <> eql[img] do
 img := eql[img];
 od;
 od;
 pnt := next[pnt];

 # go on to the next point in the orbit
 else

 pnt := next[pnt];

 fi;

 od;

 # make the alleged block
 block := [ D[1] ];
 pnt := cur;
 while pnt <> 0 do
 Add( block, pnt );
 pnt := next[pnt];
 od;
 block := Set( block );
 blocks := [ block ];
 Info( InfoAction, 1, "BlocksNoSeed ",
 "length of alleged block is ",Length(block) );

 # quick test to see if the group is primitive
 if Length( block ) = Length( orbit ) then
 Info( InfoAction, 1, "BlocksNoSeed <G> is primitive" );
 return Immutable( [ D ] );
 fi;

 # quick test to see if the orbit can be a block
 if Length( orbit ) mod Length( block ) <> 0 then
 Info( InfoAction, 1, "BlocksNoSeed ",
 "alleged block is clearly not a block" );
 changed := -1000;
 fi;

 # '<rep>[]' is the representative of the block containing 
 rep := [];
 for pnt in orbit do
 rep[pnt] := 0;
 od;
 for pnt in block do
 rep[pnt] := 1;
 od;

 # compute the block system with an orbit algorithm
 i := 1;
 while 0 <= changed and i <= Length( blocks ) do

 # loop over the generators
 for gen in acts do

 # compute the image of the block under the generator
 img := OnSets( blocks[i], gen );

 # if this block is new
 if rep[ img[1] ] = 0 then

 # add the new block to the list of blocks
 Add( blocks, img );

 # check that all points in the image are new
 for pnt in img do
 if rep[pnt] <> 0 then
 Info( InfoAction, 1, "BlocksNoSeed ",
 "alleged block is not a block" );
 changed := -1000;
 fi;
 rep[pnt] := img[1];
 od;

 # if this block is old
 else

 # check that all points in the image lie in the block
 for pnt in img do
 if rep[pnt] <> rep[img[1]] then
 Info( InfoAction, 1, "BlocksNoSeed ",
 "alleged block is not a block" );
 changed := -1000;
 fi;
 od;

 fi;

 od;

 # on to the next block in the orbit
 i := i + 1;
 od;

 until 0 <= changed;

 # force sortedness
 if Length(blocks[1])>0 and CanEasilySortElements(blocks[1][1]) then
 blocks:=AsSSortedList(List(blocks,i->Immutable(Set(i))));
 IsSSortedList(blocks);
 fi;
 # return the block system
 return Immutable( blocks );
end );

#############################################################################
##
#M Blocks( <G>, <D>, <seed>, <gens>, <acts>, <OnPoints> ) blocks with seed
##
InstallMethod( BlocksOp, "integers, with seed", true,
 [ IsGroup, IsList and IsCyclotomicCollection,
 IsList and IsCyclotomicCollection,
 IsList,
 IsList and IsPermCollection,
 IsFunction ], 0,
 function( G, D, seed, gens, acts, act )
 local blks, # list of blocks, result
 rep, # representative of a point
 siz, # siz[a] of the size of the block with rep <a>
 fst, # first point still to be merged into another block
 nxt, # next point still to be merged into another block
 lst, # last point still to be merged into another block
 gen, # generator of the group <G>
 nrb, # number of blocks so far
 a, b, c, d; # loop variables for points

 if act <> OnPoints then
 TryNextMethod();
 fi;

 nrb := Length(D) - Length(seed) + 1;

 # in the beginning each point <d> is in a block by itself
 rep := [];
 siz := [];
 for d in D do
 rep[d] := d;
 siz[d] := 1;
 od;

 # except the points in <seed>, which form one block with rep <seed>[1]
 fst := 0;
 nxt := siz;
 lst := 0;
 c := seed[1];
 for d in seed do
 if d <> c then
 rep[d] := c;
 siz[c] := siz[c] + siz[d];
 if fst = 0 then
 fst := d;
 else
 nxt[lst] := d;
 fi;
 lst := d;
 nxt[lst] := 0;
 fi;
 od;

 # while there are points still to be merged into another block
 while fst <> 0 do

 # get this point <a> and its repesentative 
 a := fst;
 b := rep[fst];

 # for each generator <gen> merge the blocks of <a>^<gen>, ^<gen>
 for gen in acts do
 c := a^gen;
 while rep[c] <> c do
 c := rep[c];
 od;
 d := b^gen;
 while rep[d] <> d do
 d := rep[d];
 od;
 if c <> d then
 if Length(D) < 2*(siz[c] + siz[d]) then
 return Immutable( [ D ] );
 fi;
 nrb := nrb - 1;
 if siz[d] <= siz[c] then
 rep[d] := c;
 siz[c] := siz[c] + siz[d];
 nxt[lst] := d;
 lst := d;
 nxt[lst] := 0;
 else
 rep[c] := d;
 siz[d] := siz[d] + siz[c];
 nxt[lst] := c;
 lst := c;
 nxt[lst] := 0;
 fi;
 fi;
 od;

 # on to the next point still to be merged into another block
 fst := nxt[fst];
 od;

 # turn the list of representatives <rep> into a list of blocks <blks>
 blks := [];
 for d in D do
 c := d;
 while rep[c] <> c do
 c := rep[c];
 od;
 if IsInt( nxt[c] ) then
 nxt[c] := [ d ];
 Add( blks, nxt[c] );
 else
 AddSet( nxt[c], d );
 fi;
 od;

 # return the set of blocks <blks>
 # force sortedness
 if Length(blks[1])>0 and CanEasilySortElements(blks[1][1]) then
 blks:=AsSSortedList(List(blks,i->Immutable(Set(i))));
 IsSSortedList(blks);
 fi;
 return Immutable( Set( blks ) );
end );

#############################################################################
##
#M RepresentativesMinimalBlocks( <G>, <D>, <gens>, <acts>, <OnPoints> )
## Adaptation of the code for BlocksNoSeed to return _all_ minimal blocks
## containing D[1].
## By Graham Sharp (Oxford), August 1997
##
InstallOtherMethod( RepresentativesMinimalBlocksOp,
 "permgrp on points", true,
 [ IsGroup, IsList and IsCyclotomicCollection,
 IsList,
 IsList and IsPermCollection,
 IsFunction ], 0,
function( G, D, gens, acts, act )
local blocks, # block system of <G>, result
 orbit, # orbit of 1 under <G>
 trans, # factored inverse transversal for <orbit>
 eql, # ' = <eql>[<k>]' means $\beta(i) = \beta(k)$,
 next, # the points that are equivalent are linked
 last, # last point on the list linked through 'next'
 leq, # ' = <leq>[<k>]' means $\beta(i) <= \beta(k)$
 gen, # one generator of <G> or 'Stab(<G>,1)'
 rnd, # random element of <G>
 pnt, # one point in an orbit
 img, # the image of <pnt> under <gen>
 cur, # the current representative of an orbit
 rep, # the representative of a block in the block system
 block, # the block, result
 changed, # number of random Schreier generators
 nrorbs, # number of orbits of subgroup $H$ of $G_1$
 i, # loop variable
 minblocks, # set of minimal blocks, result
 poss, # flag to indicate whether we might have a block
 iter, # which points we've checked when
 start; # index of first cur for this iteration (non-dec)

 if act<>OnPoints then
 TryNextMethod();
 fi;

 # handle trivial domain
 if Length( D ) = 1 or IsPrime( Length( D ) ) then
 return Immutable([ D ]);
 fi;

 # handle trivial group
 if Length( acts )=0 then
 Error( "<G> must act transitively on <D>" );
 fi;

 # compute the orbit of $G$ and a factored transversal
 orbit := [ D[1] ];
 trans := [];
 trans[ D[1] ] := One( acts[1] ); # note that `acts' is nonempty
 for pnt in orbit do
 for gen in acts do
 if not IsBound( trans[ pnt / gen ] ) then
 Add( orbit, pnt / gen );
 trans[ pnt / gen ] := gen;
 fi;
 od;
 od;

 # check that the group is transitive
 if Length( orbit ) <> Length( D ) then
 Error( "<G> must act transitively on <D>" );
 fi;
 Info(InfoAction,1,"RepresentativesMinimalBlocks transversal computed");
 nrorbs := Length( orbit );

 # since $i \in k^{G_1}$ implies $\beta(i)=\beta(k)$, we initialize <eql>
 # so that the connected components are orbits of some subgroup $H < G_1$
 eql := [];
 leq := [];
 next := [];
 last := [];
 iter := [];
 for pnt in orbit do
 eql[pnt] := pnt;
 leq[pnt] := pnt;
 next[pnt] := 0;
 last[pnt] := pnt;
 iter[pnt] := 0;
 od;

 # repeat until we run out of points
 minblocks := [];
 changed := 0;
 rnd := One( acts[1] );

 for start in orbit{[2..Length(D)]} do

 # repeat until we have a block system
 cur := start;
 # unless this is a new point, ignore and go on to the next
 # -we could do this by a linked list to avoid these checks but the
 # O(n) overheads involved in setting it up are greater than those saved
 if iter[cur] = 0 then

 repeat

 # compute such an $H$ by taking random Schreier generators of $G_1$
 # and stop if 2 successive generators dont change the orbits any
 # more
 while changed < 2 do

 # compute a random Schreier generator of $G_1$
 i := Length( orbit );
 while 1 <= i do
 rnd := rnd * Random( acts );
 i := QuoInt( i, 2 );
 od;
 gen := rnd;
 while D[1] ^ gen <> D[1] do
 gen := gen * trans[ D[1] ^ gen ];
 od;
 changed := changed + 1;

 # compute the image of every point under <gen>
 for pnt in orbit do
 img := pnt ^ gen;

 # find the representative of the orbit of <pnt>
 while eql[pnt] <> pnt do
 pnt := eql[pnt];
 od;

 # find the representative of the orbit of <img>
 while eql[img] <> img do
 img := eql[img];
 od;

 # if the don't agree merge their orbits
 if pnt < img then
 eql[img] := pnt;
 next[ last[pnt] ] := img;
 last[pnt] := last[img];
 nrorbs := nrorbs - 1;
 changed := 0;
 elif img < pnt then
 eql[pnt] := img;
 next[ last[img] ] := pnt;
 last[img] := last[pnt];
 nrorbs := nrorbs - 1;
 changed := 0;
 fi;

 od;

 od;
 Info(InfoAction,1,"RepresentativesMinimalBlocks ",
 "number of orbits of <H> < <G>_1 is ",nrorbs);

 # take arbitrary point <cur>, and an element <gen> taking 1 to <cur>
 while eql[cur] <> cur do
 cur := eql[cur];
 od;
 # Mark the points in this new H-orbit as visited
 if iter[cur] <> start then
 img := cur;
 while img <> 0 do
 iter[img] := start;
 img := next[img];
 od;
 fi;
 gen := [];
 img := cur;
 while img <> D[1] do
 Add( gen, trans[img] );
 img := img ^ trans[img];
 od;
 gen := Reversed( gen );

 # compute an alleged block as orbit of 1 under $< H, gen >$
 pnt := cur;
 poss := true;
 while pnt <> 0 do

 # compute the representative of the block containing the image
 img := pnt;
 for i in gen do
 img := img / i;
 od;
 while eql[img] <> img do
 img := eql[img];
 od;

 # if it is not our current block but a new block
 if img <> D[1] and img <> cur and leq[img] = img
 and (iter[img] = 0 or iter[img] = start) then

 # then try <img> as a new start
 leq[cur] := img;
 cur := img;
 if iter[cur] <> start then
 img := cur;
 while img <> 0 do
 iter[img] := start;
 img := next[img];
 od;
 fi;
 gen := [];
 img := cur;
 while img <> D[1] do
 Add( gen, trans[img] );
 img := img ^ trans[img];
 od;
 gen := Reversed( gen );
 pnt := cur;

 # otherwise if it is not our current block but contains it
 # by construction a nonminimal block contains the current block
 # - not any more it doesn't! Now we also have to check whether
 # the block appeared this time or earlier.
 elif img <> D[1] and img <> cur
 and leq[img] <> img and iter[img] = start then

 # then merge all blocks it contains with <cur>
 while img <> cur do
 eql[img] := cur;
 next[ last[cur] ] := img;
 last[ cur ] := last[ img ];
 img := leq[img];
 while img <> eql[img] do
 img := eql[img];
 od;
 od;
 pnt := next[pnt];

 # else if the block appeared in a previous iteration
 elif iter[img] <> start and iter[img] <> 0 then

 # then end this iteration as this is not a minimal block
 pnt := 0;
 poss := false;

 # otherwise go on to the next point in the orbit
 else

 pnt := next[pnt];

 fi;

 od;

 # Skip this bit if we know we haven't got a block
 if poss = true then
 # make the alleged block
 block := [ D[1] ];
 pnt := cur;
 while pnt <> 0 do
 Add( block, pnt );
 pnt := next[pnt];
 od;
 block := Set( block );
 blocks := [ block ];
 Info(InfoAction,1,"RepresentativesMinimalBlocks ",
 "length of alleged block is ",Length(block));

 # quick test to see if the group is primitive
 if Length( block ) = Length( orbit ) then
 Info(InfoAction,1,"RepresentativesMinimalBlocks <G> is primitive");
 return Immutable([ D ]);
 fi;

 # quick test to see if the orbit can be a block
 if Length( orbit ) mod Length( block ) <> 0 then
 Info(InfoAction,1,"RepresentativesMinimalBlocks ",
 "alleged block is clearly not a block");
 changed := -1000;
 fi;

 # '<rep>[]' is the representative of the block containing 
 rep := [];
 for pnt in orbit do
 rep[pnt] := 0;
 od;
 for pnt in block do
 rep[pnt] := 1;
 od;

 # compute the block system with an orbit algorithm
 i := 1;
 while 0 <= changed and i <= Length( blocks ) do

 # loop over the generators
 for gen in acts do

 # compute the image of the block under the generator
 img := OnSets( blocks[i], gen );

 # if this block is new
 if rep[ img[1] ] = 0 then

 # add the new block to the list of blocks
 Add( blocks, img );

 # check that all points in the image are new
 for pnt in img do
 if rep[pnt] <> 0 then
 Info(InfoAction,1,
 "RepresentativesMinimalBlocks, alleged block is not a block");
 changed := -1000;
 fi;
 rep[pnt] := img[1];
 od;

 # if this block is old
 else

 # check that all points in the image lie in the block
 for pnt in img do
 if rep[pnt] <> rep[img[1]] then
 Info(InfoAction,1,
 "RepresentativesMinimalBlocks , alleged block is not a block");
 changed := -1000;
 fi;
 od;

 fi;

 od;

 # on to the next block in the orbit
 i := i + 1;
 od;
 fi;

 until 0 <= changed;
 if poss = true then AddSet(minblocks, block); fi;

 # loop back to get another minimal block
 fi;
 od;

 # return the block system
 return Immutable(minblocks);
end);

InstallOtherMethod( RepresentativesMinimalBlocksOp,
 "G, domain, noseed, gens, perms, act", true,
 [ IsGroup, IsList and IsCyclotomicCollection,IsEmpty,
 IsList,
 IsList and IsPermCollection,
 IsFunction ], 0,
function(G,D,noseed,gens,acts,act)
 return RepresentativesMinimalBlocksOp(G,D,gens,acts,act);
end);

InstallOtherMethod( RepresentativesMinimalBlocksOp,
 "general case: translate", true,
 [ IsGroup, IsList,
 IsList,
 IsList,
 IsFunction ],
 # lower ranked than perm method
 -1,
function( G, D, gens, acts, act )
local hom,r;
 hom:=ActionHomomorphism(G,D,gens,acts,act);
 G:=Image(hom,G);
 r:=RepresentativesMinimalBlocksOp(G,[1..Length(D)],
 GeneratorsOfGroup(G),GeneratorsOfGroup(G),OnPoints);
 return List(r,i->D{i});
end);

#############################################################################
##
#M Earns( <G>, <D> ) . . . . . . . . . . . . earns of affine primitive group
##
InstallMethod( Earns, "G, ints, gens, perms, act", true,
 [ IsPermGroup, IsList,
 IsList,
 IsList,
 IsFunction ], 0,
 function( G, D, gens, acts, act )
 local n, fac, p, d, alpha, beta, G1, G2, orb,
 Gamma, M, C, f, P, Q, Q0, R, R0, pre, gen, g,
 ord, pa, a, x, y, z;

 if gens <> acts or act <> OnPoints then
 TryNextMethod();
 fi;

 n := Length( D );
 if not IsPrimePowerInt( n ) then
 return [];
 elif not IsPrimitive( G, D ) then
 TryNextMethod();
 fi;

# # Try a shortcut for solvable groups (or if a solvable normal subgroup is
# # found).
# if DefaultStabChainOptions.tryPcgs then
# pcgs := TryPcgsPermGroup( G, false, false, true );
# if not IsPcgs( pcgs ) then
# pcgs := pcgs[ 1 ];
# fi;
#T why do we know, that this will give us the EARNS and not just a smaller
# one? AH
# if not IsEmpty( pcgs ) then
# return ElementaryAbelianSeries( pcgs )
# [ Length( ElementaryAbelianSeries( pcgs ) ) - 1 ];
# fi;
# fi;

 fac := Factors(Integers, n ); p := fac[ 1 ]; d := Length( fac );
 alpha := BasePoint( StabChainMutable( G ) );
 G1 := Stabilizer( G, alpha );

 # If <G> is regular, it must be cyclic of prime order.
 if IsTrivial( G1 ) then
 return [G];
 fi;

 # If <G> is not a Frobenius group ...
 for orb in OrbitsDomain( G1, D ) do
 beta := orb[ 1 ];
 if beta <> alpha then
 G2 := Stabilizer( G1, beta );
 if not IsTrivial( G2 ) then
 Gamma := Filtered( D, p -> ForAll( GeneratorsOfGroup( G2 ),
 g -> p ^ g = p ) );
 if PrimeDivisors( Length( Gamma ) ) <> [ p ] then
 return [];
 fi;
 C := Centralizer( G, G2 );
 f := ActionHomomorphism( C, Gamma,"surjective" );
 P := PCore( ImagesSource( f ), p );
 if not IsTransitive( P, [ 1 .. Length( Gamma ) ] ) then
 return [];
 fi;
 gens := [ ];
 for gen in GeneratorsOfGroup( Centre( P ) ) do
 pre := PreImagesRepresentative( f, gen );
 ord := Order( pre ); pa := 1;
 while ord mod p = 0 do
 ord := ord / p;
 pa := pa * p;
 od;
 pre := pre ^ ( ord * Gcdex( pa, ord ).coeff2 );
 for g in GeneratorsOfGroup( C ) do
 z := Comm( g, pre );
 if z <> One( C ) then
 M := SolvableNormalClosurePermGroup( G, [ z ] );
 if M <> fail and Size( M ) = n then
 return [M];
 else
 return [];
 fi;
 fi;
 od;
 Add( gens, pre );
 od;
 Q := SylowSubgroup( Centre( G2 ), p );

 # This is unnecessary if you trust the classification of
 # finite simple groups.
 if Size( Q ) > p ^ ( d - 1 ) then
 return [];
 fi;

 R := ClosureGroup( Q, gens );
 R0 := OmegaOp( R, p, 1 );
 y := First( GeneratorsOfGroup( R0 ),
 y -> not # y in Q = Centre(G2)_p
 ( alpha ^ y = alpha
 and beta ^ y = beta
 and ForAll( GeneratorsOfGroup( G2 ),
 gen -> gen ^ y = gen ) ) );
 Q0 := OmegaOp( Q, p, 1 );
 for z in Q0 do
 M := SolvableNormalClosurePermGroup( G, [ y * z ] );
 if M <> fail and Size( M ) = n then
 return [M];
 fi;
 od;
 return [];
 fi;
 fi;
 od;

 # <G> is a Frobenius group.
 a := GeneratorsOfGroup( Centre( G1 ) )[ 1 ];
 x := First( GeneratorsOfGroup( G ), gen -> alpha ^ gen <> alpha );
 z := Comm( a, a ^ x );
 M := SolvableNormalClosurePermGroup( G, [ z ] );
 return [M];

end );

#############################################################################
##
#M Transitivity( <G>, <D>, <gens>, <acts>, <act> ) . . . . . . . on integers
##
InstallMethod( Transitivity, "permgroup on numbers", true,
 [ IsPermGroup, IsList and IsCyclotomicCollection,
 IsList,
 IsList,
 IsFunction ], 0,
 function( G, D, gens, acts, act )
 if gens <> acts or act <> OnPoints then
 TryNextMethod();

 elif not IsTransitive( G, D, gens, acts, act ) then
 return 0;
 else
 G := Stabilizer( G, D[ 1 ], act );
 gens := GeneratorsOfGroup( G );
 return Transitivity( G, D{ [ 2 .. Length( D ) ] },
 gens, gens, act ) + 1;
 fi;
end );

#############################################################################
##
#M IsTransitive( <G> )
#M Transitivity( <G> )
##
## For a group with known order, we use that the number of moved points
## of a transitive permutation group divides the group order.
## If this is not the case then this check avoids computing an orbit or of
## a point stabilizer.
## Note that the GAP library defines transitivity also on partial orbits.
## (If this would be changed then also the five argument method that is
## installed in the call of `OrbitsishOperation' could take advantage of
## the divisibility criterion.)
##
InstallOtherMethod( IsTransitive,
 "for a permutation group (use shortcuts)",
 [ IsPermGroup ], 1,
 function( G )
 local n, gens;

 n:= NrMovedPoints( G );
 if n = 0 then
 return true;
 elif HasSize( G ) and Size( G ) mod n <> 0 then
 # Avoid computing an orbit if the (known) group order
 # is not divisible by the (known) number of points.
 return false;
 else
 # Avoid the `IsSubset' test that occurs in the generic method,
 # checking the orbit length suffices.
 # (And do not call `Orbit'!)
 gens:= GeneratorsOfGroup( G );
 return n = Length( OrbitOp( G, SmallestMovedPoint( G ), gens, gens,
 OnPoints ) );
 fi;
 end );

InstallOtherMethod( Transitivity,
 "for a permutation group with known size",
 [ IsPermGroup and HasSize ],
 function( G )
 local n, t, size;

 n:= NrMovedPoints( G );
 if n = 0 then
 # The trivial group is transitive on the empty set,
 # but has transitivity zero.
 return 0;
 elif IsNaturalSymmetricGroup( G ) then
 return n;
 elif IsNaturalAlternatingGroup( G ) then
 return n - 2;
 fi;
 t:= 0;
 size:= Size( G );
 while IsTransitive( G ) do
 t:= t + 1;
 size:= size / n;
 n:= n-1;
 if size mod n <> 0 then
 break;
 fi;
 G:= Stabilizer( G, SmallestMovedPoint( G ) );
 if NrMovedPoints( G ) <> n then
 if n = 1 then
 # The trivial group is transitive on a singleton set,
 # with transitivity one.
 t:= t + 1;
 fi;
 break;
 fi;
 od;
 return t;
 end );

#############################################################################
##
#M IsSemiRegular( <G>, <D>, <gens>, <acts>, <act> ) . . . . for perm groups
##
InstallMethod( IsSemiRegular, "permgroup on numbers", true,
 [ IsGroup, IsList and IsCyclotomicCollection,
 IsList,
 IsList and IsPermCollection,
 IsFunction ], 0,
 function( G, D, gens, acts, act )
 local used, #
 perm, #
 orbs, # orbits of <G> on <D>
 gen, # one of the generators of <G>
 orb, # orbit of '<D>[1]'
 pnt, # one point in the orbit
 new, # image of <pnt> under <gen>
 img, # image of '<prm>[][<pnt>]' under <gen>
 p, n, # loop variables
 i, l; # loop variables

 if act <> OnPoints then
 TryNextMethod();
 fi;

 # compute the orbits and check that they all have the same length
 orbs := OrbitsDomain( G, D, gens, acts, OnPoints );
 if Length( Set( orbs, Length ) ) <> 1 then
 return false;
 fi;

 # initialize the permutations that act like the generators
 used := [];
 perm := [];
 for i in [ 1 .. Length( acts ) ] do
 used[i] := [];
 perm[i] := [];
 for pnt in orbs[1] do
 used[i][pnt] := false;
 od;
 perm[i][ orbs[1][1] ] := orbs[1][1] ^ acts[i];
 used[i][ orbs[1][1] ^ acts[i] ] := true;
 od;

 # initialize the permutation that permutes the orbits
 l := Length( acts ) + 1;
 used[l] := [];
 perm[l] := [];
 for orb in orbs do
 for pnt in orb do
 used[l][pnt] := false;
 od;
 od;
 for i in [ 1 .. Length(orbs)-1 ] do
 perm[l][orbs[i][1]] := orbs[i+1][1];
 used[l][orbs[i+1][1]] := true;
 od;
 perm[l][Last(orbs)[1]] := orbs[1][1];
 used[l][orbs[1][1]] := true;

 # compute the orbit of the first representative
 orb := [ orbs[1][1] ];
 for pnt in orb do
 for gen in acts do

 # if the image is new
 new := pnt ^ gen;
 if not new in orb then

 # add the new element to the orbit
 Add( orb, new );

 # extend the permutations that act like the generators
 for i in [ 1 .. Length( acts ) ] do
 img := perm[i][pnt] ^ gen;
 if used[i][img] then
 return false;
 else
 perm[i][new] := img;
 used[i][img] := true;
 fi;
 od;

 # extend the permutation that permutates the orbits
 p := pnt;
 n := new;
 for i in [ 1 .. Length( orbs ) ] do
 img := perm[l][p] ^ gen;
 if used[l][img] then
 return false;
 else
 perm[l][n] := img;
 used[l][img] := true;
 fi;
 p := perm[l][p];
 n := img;
 od;

 fi;

 od;
 od;

 # check that the permutations commute with the generators
 for i in [ 1 .. Length( acts ) ] do
 for gen in acts do
 for pnt in orb do
 if perm[i][pnt] ^ gen <> perm[i][pnt ^ gen] then
 return false;
 fi;
 od;
 od;
 od;

 # check that the permutation commutes with the generators
 for gen in acts do
 for orb in orbs do
 for pnt in orb do
 if perm[l][pnt] ^ gen <> perm[l][pnt ^ gen] then
 return false;
 fi;
 od;
 od;
 od;

 # everything is ok, the representation is semiregular
 return true;

end );

#############################################################################
##
#F IsRegular(permgp)
##
InstallOtherMethod( IsRegular,"permgroup",true,[IsPermGroup],0,
function(G)
 if IsTransitive(G) and IsSemiRegular(G) then
 SetSize(G,NrMovedPoints(G));
 return true;
 else
 return false;
 fi;
end);

InstallOtherMethod( IsRegular,"permgroup with known size",true,
 [IsPermGroup and HasSize],0,
 G->Size(G)=NrMovedPoints(G) and IsTransitive(G));

# implications with regularity for permgroups.
InstallTrueMethod(IsSemiRegular,IsPermGroup and IsRegular);
InstallTrueMethod(IsTransitive,IsPermGroup and IsRegular);
InstallTrueMethod(IsRegular,IsPermGroup and IsSemiRegular and IsTransitive);

#############################################################################
##
#M RepresentativeAction( <G>, <d>, <e>, <act> ) . . . . . for perm groups
##
InstallOtherMethod( RepresentativeActionOp, "permgrp",true, [ IsPermGroup,
 IsObject, IsObject, IsFunction ],
 # the objects might be group elements: rank up
 {} -> 2*RankFilter(IsMultiplicativeElementWithInverse),
 function ( G, d, e, act )
 local rep, # representative, result
 S, # stabilizer of <G>
 rep2, # representative in <S>
 sel,
 dp,ep, # point copies
 i, f; # loop variables

 # standard action on points, make a basechange and trace the rep
 if act = OnPoints and IsInt( d ) and IsInt( e ) then
 d := [ d ]; e := [ e ];
 S := true;
 elif ( act = OnPairs or act = OnTuples )
 and IsPositionsList( d ) and IsPositionsList( e ) then
 S := true;
 fi;
 if IsBound( S ) then
 if d = e then
 rep := One( G );
 elif Length( d ) <> Length( e ) then
 rep:= fail;
 else
 # can we use the current stab chain? (try to avoid rebuilding
 # one if called frequently)
 S:=StabChainMutable(G);
 # move the points already in the base in front
 sel:=List(BaseStabChain(S),i->Position(d,i));
 sel:=Filtered(sel,i->i<>fail);
 if Length(sel)>0 then
 # rearrange
 sel:=Concatenation(sel,Difference([1..Length(d)],sel));
 dp:=d{sel};
 ep:=e{sel};
 rep := S.identity;
 for i in [ 1 .. Length( dp ) ] do
 if BasePoint( S ) = dp[ i ] then
 f := ep[ i ] / rep;
 if not IsInBasicOrbit( S, f ) then
 rep := fail;
 break;
 else
 rep := LeftQuotient( InverseRepresentative( S, f ),
 rep );
 fi;
 S := S.stabilizer;
 elif ep[ i ] <> dp[ i ] ^ rep then
 rep := fail;
 break;
 fi;
 od;
 else
 rep:=fail; # we did not yet get anything
 fi;

 if rep=fail then
 # did not work with the existing stabchain - do again
 S := StabChainOp( G, d );
 rep := S.identity;
 for i in [ 1 .. Length( d ) ] do
 if BasePoint( S ) = d[ i ] then
 f := e[ i ] / rep;
 if not IsInBasicOrbit( S, f ) then
 rep := fail;
 break;
 else
 rep := LeftQuotient( InverseRepresentative( S, f ),
 rep );
 fi;
 S := S.stabilizer;
 elif e[ i ] <> d[ i ] ^ rep then
 rep := fail;
 break;
 fi;
 od;
 fi;

 fi;

 # action on (lists of) permutations, use backtrack
 elif act = OnPoints and IsPerm( d ) and IsPerm( e ) then
 rep := RepOpElmTuplesPermGroup( true, G, [ d ], [ e ],
 TrivialSubgroup( G ), TrivialSubgroup( G ) );
 elif ( act = OnPairs or act = OnTuples )
 and IsList( d ) and IsPermCollection( d )
 and IsList( e ) and IsPermCollection( e ) then
 rep := RepOpElmTuplesPermGroup( true, G, d, e,
 TrivialSubgroup( G ), TrivialSubgroup( G ) );

 # action on permgroups, use backtrack
 elif act = OnPoints and IsPermGroup( d ) and IsPermGroup( e ) then

 if Size(G)<10^5 or NrMovedPoints(G)<500
 # cyclic is handled special by backtrack
 or IsCyclic(d) or IsCyclic(e) or
 # does the group have many short orbits? If so the cluster test
 # would do a lot of checking
 Length(Orbits(d,MovedPoints(G)))^2>NrMovedPoints(G)
 # Do not test for same orbit lengths -- this will be done by next
 # level routine
 then

 rep:=ConjugatorPermGroup(G,d,e);
 else
 S:=ClusterConjugacyPermgroups(G,[e,d]);
 if Length(S.clusters)>1 then return fail;fi;
 if S.gps[1]=S.gps[2] then
 rep:=One(G);
 else
 rep:=ConjugatorPermGroup(S.actors[1],S.gps[2],S.gps[1]);
 fi;
 if rep<>fail then
 rep:=S.conjugators[2]*rep;
 fi;
 fi;

 # action on pairs or tuples of other objects, iterate
 elif act = OnPairs or act = OnTuples then
 rep := One( G );
 S := G;
 i := 1;
 while i <= Length(d) and rep <> fail do
 if e[i] = fail then
 rep := fail;
 else
 rep2 := RepresentativeActionOp( S, d[i], e[i]^(rep^-1),
 OnPoints );
 if rep2 <> fail then
 rep := rep2 * rep;
 S := Stabilizer( S, d[i], OnPoints );
 else
 rep := fail;
 fi;
 fi;
 i := i + 1;
 od;

 # action on sets of points, use backtrack
 elif act = OnSets and IsPositionsList( d ) and IsPositionsList( e ) then
 if Length(d)<>Length(e) then
 return fail;
 fi;
 if Length(d)=1 then
 rep:=RepresentativeActionOp(G,d[1],e[1],OnPoints);
 else
 rep := RepOpSetsPermGroup( G, d, e );
 fi;

 # action on tuples of sets
 elif act = OnTuplesSets
 and IsList(d) and ForAll(d,i->ForAll(i,IsInt))
 and IsList(e) and ForAll(e,i->ForAll(i,IsInt)) then

 if List(d,Length)<>List(e,Length) then return fail;fi;

 # conjugate one by one
 rep:=One(G);
 S:=G;
 for i in [1..Length(d)] do
 rep2:=RepresentativeAction(S,d[i],e[i],OnSets);
 if rep2=fail then return fail;fi;
 d:=List(d,x->OnSets(x,rep2));
 S:=Stabilizer(S,e[i],OnSets);
 rep:=rep*rep2;
 od;
 return rep;

 # other action, fall back on default representative
 else
 TryNextMethod();
 fi;

 # return the representative
 return rep;
end );

#############################################################################
##
#M Stabilizer( <G>, <d>, <gens>, <gens>, <act> ) . . . . . . for perm groups
##

BindGlobal( "PermGroupStabilizerOp", function(arg)
 local K, # stabilizer <K>, result
 S, base,
 G,d,gens,acts,act;

# get arguments, ignoring a given domain
G:=arg[1];
K:=Length(arg);
act:=arg[K];
acts:=arg[K-1];
gens:=arg[K-2];
d:=arg[K-3];

 if gens <> acts then
 #TODO: Check whether acts is permutations and one could work in the
 #permutation image (even if G is not permgroups)
 TryNextMethod();
 fi;

 # standard action on points, make a stabchain beginning with <d>
 if act = OnPoints and IsInt( d ) then
 base := [ d ];
 elif ( act = OnPairs or act = OnTuples )
 and IsPositionsList( d ) then
 base := d;
 fi;
 if IsBound( base ) then
 K := StabChainOp( G, base );
 S := K;
 while IsBound( S.orbit ) and S.orbit[ 1 ] in base do
 S := S.stabilizer;
 od;
 if IsIdenticalObj( S, K ) then K := G;
 else K := GroupStabChain( G, S, true ); fi;

 # standard action on (lists of) permutations, take the centralizer
 elif act = OnPoints and IsPerm( d ) then
 K := Centralizer( G, d );
 elif ( act = OnPairs or act = OnTuples )
 and IsList( d ) and IsPermCollection( d ) then
 K := RepOpElmTuplesPermGroup( false, G, d, d,
 TrivialSubgroup( G ), TrivialSubgroup( G ) );

 # standard action on a permutation group, take the normalizer
 elif act = OnPoints and IsPermGroup(d) then
 K := Normalizer( G, d );

 # action on sets of points, use a backtrack
 elif act = OnSets and ForAll( d, IsInt ) then
 if Length(d)=1 then
 K:=Stabilizer(G,d[1]);
 else
 K := RepOpSetsPermGroup( G, d );
 fi;

 # action on sets of pairwise disjoint sets
 elif act = OnSetsDisjointSets
 and IsList(d) and ForAll(d,i->ForAll(i,IsInt)) then
 K := PartitionStabilizerPermGroup( G, d );

 #T OnSetTuples? is hard

 # action on tuples of sets
 elif act = OnTuplesSets
 and IsList(d) and ForAll(d,i->ForAll(i,IsInt)) then
 K:=G;
 for S in d do
 K:=Stabilizer(K,S,OnSets);
 od;

 # action on tuples of tuples
 elif act = OnTuplesTuples
 and IsList(d) and ForAll(d,i->ForAll(i,IsInt)) then
 K:=G;
 for S in d do
 K:=Stabilizer(K,S,OnTuples);
 od;

 # other action
 else
 TryNextMethod();
 fi;

 # enforce size computation (unless the stabilizer did not cause a
 # StabChain to be computed.
 if HasStabChainMutable(K) then
 Size(K);
 fi;

 # return the stabilizer
 return K;
end );

InstallOtherMethod( StabilizerOp, "permutation group with generators list",
 true,
 [ IsPermGroup, IsObject,
 IsList,
 IsList,
 IsFunction ],
 # the objects might be a group element: rank up
 {} -> RankFilter(IsMultiplicativeElementWithInverse)
 # and we are better even if the group is solvable
 +RankFilter(IsSolvableGroup),
 PermGroupStabilizerOp);

InstallOtherMethod( StabilizerOp, "permutation group with domain",true,
 [ IsPermGroup, IsObject,
 IsObject,
 IsList,
 IsList,
 IsFunction ],
 # the objects might be a group element: rank up
 {} -> RankFilter(IsMultiplicativeElementWithInverse)
 # and we are better even if the group is solvable
 +RankFilter(IsSolvableGroup),
 PermGroupStabilizerOp);

#############################################################################
##
#F StabilizerOfBlockNC( <G>, ) . . . . block stabilizer for perm groups
##
InstallGlobalFunction( StabilizerOfBlockNC, function(G,B)
local S,j;
 S:=StabChainOp(G,rec(base:=[B[1]],reduced:=false));
 S:=StructuralCopy(S);

 # Make <S> the stabilizer of the block .
 InsertTrivialStabilizer(S.stabilizer,B[1]);
 j := 1;
 while j < Length( B )
 and Length( S.stabilizer.orbit ) < Length( B ) do
 j := j + 1;
 if IsBound( S.translabels[ B[ j ] ] ) then
 AddGeneratorsExtendSchreierTree( S.stabilizer,
 [ InverseRepresentative( S, B[ j ] ) ] );
 fi;
 od;
 return GroupStabChain(G,S.stabilizer,true);
end );

#############################################################################
##
#F OnSetsSets( <set>, <g> )
##
InstallGlobalFunction( OnSetsSets, function( e, g )
 return Set( e, i -> OnSets( i, g ) );
end );

#############################################################################
##
#F OnSetsDisjointSets( <set>, <g> )
##
## `OnSetsDisjointSets' does the same as `OnSetsSets',
## but since this special case is treated in a special way for example by
## `StabilizerOp',
## the function must be an object different from `OnSetsSets'.
##
InstallGlobalFunction( OnSetsDisjointSets, function( e, g )
 return Set( e, i -> OnSets( i, g ) );
end );

#############################################################################
##
#F OnSetsTuples( <set>, <g> )
##
InstallGlobalFunction( OnSetsTuples, function(e,g)
 return Set(e,i->OnTuples(i,g));
end );

#############################################################################
##
#F OnTuplesSets( <set>, <g> )
##
InstallGlobalFunction( OnTuplesSets, function(e,g)
 return List(e,i->OnSets(i,g));
end );

#############################################################################
##
#F OnTuplesTuples( <set>, <g> )
##
InstallGlobalFunction( OnTuplesTuples, function(e,g)
 return List(e,i->OnTuples(i,g));
end );

Messung V0.5 in Prozent

¤ Dauer der Verarbeitung: 0.54 Sekunden (vorverarbeitet am 2026-10-11) ¤

Wurzel

Suchen

PVS Prover

Isabelle Prover

NIST Cobol Testsuite

Cephes Mathematical Library

Vienna Development Method

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung und die Messung sind noch experimentell.