1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
# Copyright (c) 1997-2024
# Ewgenij Gawrilow, Michael Joswig, and the polymake team
# Technische Universität Berlin, Germany
# https://polymake.org
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#-------------------------------------------------------------------------------
function induce_permutation_action($$$$$; $=0, $=0) {
my ($this, $from_action, $on_section, $name, $desc, $homogeneous_action, $canon) = @_;
my $a = new PermutationAction($name);
# The variable $on holds the object we find the induced permutation on.
# Normally, this will be the property of $this specified by a string $on_section.
# However, we also allow the variable $on_section to directly specify an object to find the induced permutation on.
# This is necessary, for example, if the object is a matrix with non-homogenized first column, because if we read such a matrix as a property, it will have homogenized first column.
# We distinguish these cases by checking whether $on_section is a ref or not.
my $on = ref($on_section) ? $on_section : $this->$on_section;
if (ref($canon) eq 'CODE') {
# need a copy
$on = $on->type->construct->($on);
$canon->($on);
}
$a->GENERATORS = induced_permutations($this->GROUP->$from_action->GENERATORS, $on, homogeneous_action=>$homogeneous_action);
# This is forbidden: This rule was producing properties just sometimes. Every time this function is called, we have to double up the rule calling it.
#if (defined(my $cc = $this->lookup("GROUP." . $from_action . ".CONJUGACY_CLASS_REPRESENTATIVES"))) {
# $a->CONJUGACY_CLASS_REPRESENTATIVES = induced_permutations($cc, $this->$on_section, homogeneous_action=>$homogeneous_action);
#}
$a->description = $desc;
return $a;
}
function induced_orbits_impl<Scalar>($$$, Scalar, { homog_action=>0, return_matrix=>1 }) {
my ($c, $action_name, $generator_name, $dummy, $options) = @_;
my $n = 0;
my @reps = ();
my @pts_in_orbit_order = ();
my $all_pts = new Set<Vector<Scalar>>;
foreach(@{$c->GROUP->$action_name->$generator_name}) {
my $one_orbit;
if ($action_name eq "MATRIX_ACTION") {
$one_orbit = orbit($c->GROUP->$action_name->GENERATORS, new Vector<Scalar>($_));
} elsif ($options->{homog_action} == 0) {
$one_orbit = nonhomog_container_orbit($c->GROUP->$action_name->GENERATORS, new Vector<Scalar>($_));
} else {
$one_orbit = homog_container_orbit($c->GROUP->$action_name->GENERATORS, new Vector<Scalar>($_));
}
$all_pts += $one_orbit;
if ($n == $all_pts->size()) {
next;
}
push @reps, new Vector<Scalar>($one_orbit->[0]);
foreach(@{$one_orbit}) {
push @pts_in_orbit_order, new Vector<Scalar>($_);
}
$n += $one_orbit->size();
}
my $a = new PermutationAction;
$a->EXPLICIT_ORBIT_REPRESENTATIVE_MATRIX = new Matrix<Scalar>(\@reps);
$a->description = "induced from $action_name";
if ($options->{return_matrix} == 1) {
return (new Matrix<Scalar>(\@pts_in_orbit_order), $a);
} else {
return (\@pts_in_orbit_order, $a);
}
}
function induced_orbits_on_vectors_impl<Scalar>(Array<Matrix<Scalar>>, Matrix<Scalar>) {
my ($gens, $vecs) = @_;
my @orbits;
my $remaining_vecs = new Set<Vector<Scalar>>;
my $index_of = new HashMap<Vector<Scalar>, Int>;
my $index=0;
foreach (0..$vecs->rows()-1) {
my $v = new Vector<Scalar>($vecs->[$_]);
$index_of->{$v} = $index++;
$remaining_vecs += $v;
}
while ($remaining_vecs->size()) {
my $o = orbit($gens, $remaining_vecs->front());
my @orbit_inds;
foreach my $w (@{$o}) {
push @orbit_inds, $index_of->{$w};
}
push @orbits, new Set<Int>(\@orbit_inds);
$remaining_vecs -= $o;
}
return new Array<Set<Int>>(\@orbits);
}
# Local Variables:
# mode: perl
# cperl-indent-level:3
# indent-tabs-mode:nil
# End:
|
