Quelle oprtperm.gi Sprache: unbekannt

#############################################################################
##
## 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 );

Quelle oprtperm.gi Sprache: unbekannt

[ Dauer der Verarbeitung: 0.49 Sekunden (vorverarbeitet) ]