File: [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Symmetry / symmetric_set_structure.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:31 2000 UTC (23 years, 10 months ago) by maekawa
Branch: PHC, MAIN
CVS Tags: v2, maekawa-ipv6, RELEASE_1_2_3, RELEASE_1_2_2_KNOPPIX_b, RELEASE_1_2_2_KNOPPIX, RELEASE_1_2_2, RELEASE_1_2_1, HEAD Changes since 1.1: +0 -0
lines
Import the second public release of PHCpack.
OKed by Jan Verschelde.
|
with unchecked_deallocation;
with text_io,integer_io; use text_io,integer_io;
with Generic_Lists;
with Standard_Natural_Vectors; use Standard_Natural_Vectors;
with Standard_Natural_Vectors_io; use Standard_Natural_Vectors_io;
with Set_Structure; use Set_Structure;
with Permutations,Permute_Operations; use Permutations,Permute_Operations;
with Templates; use Templates;
package body Symmetric_Set_Structure is
-- DATASTRUCTURES :
type set is array (natural range <>) of boolean;
type boolean_array is array (natural range <>) of boolean;
type link_to_boolean_array is access boolean_array;
procedure free is new unchecked_deallocation(boolean_array,
link_to_boolean_array);
type boolean_matrix is array (natural range <>) of link_to_boolean_array;
type link_to_boolean_matrix is access boolean_matrix;
procedure free is new unchecked_deallocation(boolean_matrix,
link_to_boolean_matrix);
type set_coord is record
k,l : natural;
end record;
type Dependency_Structure is array (natural range <>) of set_coord;
type Link_to_Dependency_Structure is access Dependency_Structure;
procedure free is new unchecked_deallocation(Dependency_Structure,
Link_to_Dependency_Structure);
package Lists_of_Dependency_Structures
is new Generic_Lists (Link_to_Dependency_Structure);
type Covering is new Lists_of_Dependency_Structures.List;
-- INTERNAL DATA :
cov : Covering; -- covering of the set structure
lbm : link_to_boolean_matrix;
-- auxiliary data structure for bookeeping during the construction
-- of the covering,
-- to remember which sets have already been treated.
-- AUXILIARY ROUTINES FOR CONSTRUCTING THE COVERING :
function Give_Set ( n,i,j : natural ) return set is
-- DESCRIPTION :
-- Returns the (i,j)-th set out of the set structure.
s : set(1..n);
begin
for k in 1..n loop
s(k) := Is_In(i,j,k);
end loop;
return s;
end Give_Set;
function Equal ( s1,s2 : set ) return boolean is
-- DESCRIPTION :
-- Returns true if both sets are equal.
begin
for i in s1'range loop
if s1(i) /= s2(i)
then return false;
end if;
end loop;
return true;
end Equal;
function Find ( i,n : natural; s : set ) return natural is
-- DESCRIPTION :
-- Returns the first occurence of the set s in the i-th row
-- of the set structure;
-- returns zero if the set does not occur in the i-th row.
begin
for j in 1..Number_Of_Sets(i) loop
if not lbm(i)(j) and then Equal(s,Give_Set(n,i,j))
then return j;
end if;
end loop;
return 0;
end Find;
function Apply ( p : Permutation; s : set ) return set is
-- DESCRIPTION :
-- Returns the result after application of p on the set s.
r : set(s'range);
begin
for i in p'range loop
r(i) := s(p(i));
end loop;
return r;
end Apply;
procedure Init_Covering ( n : in natural ) is
-- DESCRIPTION :
-- Initialization of lbm.
begin
lbm := new boolean_matrix(1..n);
for i in 1..n loop
lbm(i) := new boolean_array'(1..Number_of_Sets(i) => false);
end loop;
end Init_Covering;
procedure Update ( dps : Dependency_Structure ) is
-- DESCRIPTION :
-- All pairs in dps are marked in lbm.
begin
for i in dps'range loop
lbm(dps(i).k)(dps(i).l) := true;
end loop;
end Update;
procedure Search ( n : in natural; i,j : out natural;
empty : out boolean ) is
-- DESCRIPTION :
-- Searches in lbm the first (i,j)-th free set;
-- returns empty if all sets have already been used.
begin
for k in 1..n loop
for l in lbm(k)'range loop
if not lbm(k)(l)
then i := k; j := l; empty := false;
return;
end if;
end loop;
end loop;
empty := true;
end Search;
-- CONSTRUCTOR FOR DEPENDENCY STRUCTURE AND COVERING :
procedure Construct_Dependency_Structure
( n,m : in natural; v,w : in List_Of_Permutations;
i,j : in natural; dps : in out Dependency_Structure;
fail : out boolean ) is
-- DESCRIPTION :
-- A dependency structure will be constructed.
-- ON ENTRY :
-- n the dimension;
-- m number of elements in dps,v and w;
-- v,w matrix representations;
-- i,j coordinates of a set in the dependency structure.
-- ON RETURN :
-- dps the dependency structure;
-- fail is true if the set structure is not symmetric.
s : set(1..n) := Give_Set(n,i,j);
lv,lw : List_Of_Permutations;
pv,pw : Permutation(1..n);
ps : set(1..n);
res : natural;
begin
lv := v; lw := w;
for x in 1..m loop
pw := Permutation(Head_Of(lw).all);
dps(x).k := pw(i);
pv := Permutation(Head_Of(lv).all);
ps := Apply(pv,s);
res := Find(dps(x).k,n,ps);
exit when (res = 0);
dps(x).l := res;
lv := Tail_Of(lv);
lw := Tail_Of(lw);
end loop;
fail := (res = 0);
end Construct_Dependency_Structure;
procedure Construct_Covering
( n,m : in natural; v,w : in List_Of_Permutations;
fail : out boolean ) is
-- DESCRIPTION :
-- A covering of the set structure will be constructed.
-- EFFECT :
-- Initially, all entries in lbm are false;
-- at the end, all entries in lbm are true (if not fail).
dps : Dependency_Structure(1..m);
ldps : Link_to_Dependency_Structure;
empty,fl : boolean;
i,j : natural;
begin
Init_Covering(n);
Search(n,i,j,empty);
while not empty loop
Construct_Dependency_Structure(n,m,v,w,i,j,dps,fl);
exit when fl;
Update(dps);
ldps := new Dependency_Structure(1..m);
ldps.all := dps;
Construct(ldps,cov);
Search(n,i,j,empty);
end loop;
fail := fl;
end Construct_Covering;
-- OUTPUT PROCEDURES FOR COVERING :
procedure Write_Set ( n,i,j : natural ) is
-- DESCRIPTION :
-- Writes the (i,j)-th set on the standard output.
begin
put('{');
for k in 1..n loop
if Is_In(i,j,k)
then put(' '); put('x'); put(k,1);
end if;
end loop;
put(" }");
end Write_Set;
procedure Write_Coord ( k,l : in natural ) is
begin
put('['); put(k,1); put(' '); put(l,1); put(']');
end Write_Coord;
procedure Write_Covering is
tmp : Covering := cov;
ldps : Link_to_Dependency_Structure;
begin
put_line("The covering :");
while not Is_Null(tmp) loop
ldps := Head_Of(tmp);
declare
nb : natural := 0;
begin
for i in ldps'range loop
Write_Coord(ldps(i).k,ldps(i).l);
nb := nb+1;
if nb > 7
then new_line;
nb := 0;
end if;
end loop;
new_line;
end;
tmp := Tail_Of(tmp);
end loop;
end Write_Covering;
procedure Write_Coord ( file : in file_type; k,l : in natural ) is
begin
put(file,'['); put(file,k,1); put(file,' '); put(file,l,1); put(file,']');
end Write_Coord;
procedure Write_Covering ( file : in file_type ) is
tmp : Covering := cov;
ldps : Link_to_Dependency_Structure;
begin
put_line(file,"The covering :");
while not Is_Null(tmp) loop
ldps := Head_Of(tmp);
declare
nb : natural := 0;
begin
for i in ldps'range loop
Write_Coord(file,ldps(i).k,ldps(i).l);
nb := nb+1;
if nb > 7
then new_line(file);
nb := 0;
end if;
end loop;
new_line(file);
end;
tmp := Tail_Of(tmp);
end loop;
end Write_Covering;
-- CONSTRUCTION OF TEMPLATES :
procedure Init_Template ( n : in natural ) is
-- DESCRIPTION :
-- Initialization of the template.
h : Standard_Natural_Vectors.Vector(0..n) := (0..n => 0);
begin
Templates.Create(n);
for i in 1..n loop
for j in 1..Number_Of_Sets(i) loop
Templates.Add_Hyperplane(i,h);
end loop;
end loop;
end Init_Template;
procedure First_Equivariant_Template
( n : in natural; cnt : in out natural ) is
-- DESCRIPTION :
-- Constructs the first equation of the template, for an equivariant
-- linear product system system
-- ON ENTRY :
-- n the dimension;
-- cnt counts the number of free coefficients.
h : Standard_Natural_Vectors.Vector(0..n);
begin
for j in 1..Templates.Number_of_Hyperplanes(1) loop
Templates.Get_Hyperplane(1,j,h);
cnt := cnt + 1; h(0) := cnt;
for k in 1..n loop
if Set_Structure.Is_In(1,j,k)
then if cnt = h(0)
then cnt := cnt + 1;
end if;
h(k) := cnt;
end if;
end loop;
Templates.Change_Hyperplane(1,j,h);
end loop;
end First_Equivariant_Template;
function Action ( i,n : natural ; g : List_of_Permutations )
return Permutation is
-- DESCRIPTION :
-- Returns the group action from the list g that permutes the first
-- array of sets into the ith one.
p : Permutation(1..n);
first,second : Standard_Natural_Vectors.Vector(1..n);
tmp : List_of_Permutations := g;
begin
for k in 1..n loop
if Set_Structure.Is_In(1,1,k)
then first(k) := 1;
else first(k) := 0;
end if;
if Set_Structure.Is_In(i,1,k)
then second(k) := 1;
else second(k) := 0;
end if;
end loop;
while not Is_Null(tmp) loop
p := Permutation(Head_Of(tmp).all);
if second = p*first
then return p;
end if;
tmp := Tail_Of(tmp);
end loop;
p := (p'range => 0);
return p;
end Action;
procedure Propagate_Equivariant_Template
( n : in natural; g : in List_of_Permutations;
fail : out boolean ) is
-- DESCRIPTION :
-- Given a template whose first equation is already constructed,
-- the rest of the template will be constructed, with the aid of the
-- list of generating permutations.
h : Standard_Natural_Vectors.Vector(0..n);
p : Permutation(1..n);
begin
for i in 2..n loop
p := Action(i,n,g);
if p = (p'range => 0)
then fail := true; return;
end if;
for j in 1..Templates.Number_of_Hyperplanes(i) loop
Templates.Get_Hyperplane(1,j,h);
h(1..n) := p*h(1..n);
Templates.Change_Hyperplane(i,j,h);
end loop;
end loop;
fail := false;
end Propagate_Equivariant_Template;
procedure Construct_Part_of_Template
( n,m : in natural; v : in List_Of_Permutations;
dps : in Dependency_Structure; invpv1 : in Permutation;
cnt : in out natural ) is
-- DESCRIPTION :
-- This procedure constructs the coefficients of the hyperplanes
-- associated with the sets in the dependency structure dps.
-- cnt counts the number of free coefficients.
lv : List_Of_Permutations;
pv : Permutation(1..n);
h : Standard_Natural_Vectors.Vector(0..n);
indi : natural;
begin
-- GENERATE CONSTANT COEFFICIENT :
cnt := cnt+1;
for j in 1..m loop
Templates.Get_Hyperplane(dps(j).k,dps(j).l,h);
h(0) := cnt;
Templates.Change_Hyperplane(dps(j).k,dps(j).l,h);
end loop;
-- GENERATE THE OTHER COEFFICIENTS :
for i in 1..n loop
-- GENERATE :
if Is_In(dps(1).k,dps(1).l,i)
then Templates.Get_Hyperplane(dps(1).k,dps(1).l,h);
if h(i) = 0
then cnt := cnt + 1;
-- PROPAGATE :
--put("PROPAGATING "); put(i,1);
--put_line("-th coefficient :");
lv := v;
for j in 1..m loop
pv := Permutation(Head_Of(lv).all);
indi := 0;
for l in 1..n loop
if pv(l) = invpv1(i)
then indi := l;
exit;
end if;
end loop;
--Write_Coord(dps(j).k,dps(j).l); put(" : ");
--Write_Set(n,dps(j).k,dps(j).l);
--put(" indi : "); put(indi,1); new_line;
Templates.Get_Hyperplane(dps(j).k,dps(j).l,h);
h(indi) := cnt;
Templates.Change_Hyperplane(dps(j).k,dps(j).l,h);
lv := Tail_Of(lv);
end loop;
--put_line("RANDOM PRODUCT SYSTEM AFTER PROPAGATION :");
--Write_RPS(n,2,4,3);
--for l in 1..75 loop put("+"); end loop; new_line;
end if;
end if;
end loop;
end Construct_Part_of_Template;
procedure Construct_Template
( n,m : in natural; v : in List_Of_Permutations;
nbfree : out natural ) is
-- DESCRIPTION :
-- Given a covering of the set structure,
-- the data of the package Random_Product_System will be filled.
-- ON ENTRY :
-- n the dimension of the vectors
-- m the number of entries in v
-- v matrix representations of the group
-- ON RETURN :
-- nbfree the number of free coefficients
tmp : Covering := cov;
ldps : Link_to_Dependency_Structure;
invpv1 : Permutation(1..n);
cnt : natural;
begin
Init_Template(n);
cnt := 0;
-- CONSTRUCT THE BASE SET OF dps :
invpv1 := inv(Permutation(Head_Of(v).all));
-- then for each pv in v: permutation of the base set
-- is defined as pv*invpv1.
--put("invpv1 : "); Put(invpv1); new_line;
while not Is_Null(tmp) loop
ldps := Head_Of(tmp);
Construct_Part_of_Template(n,m,v,ldps.all,invpv1,cnt);
tmp := Tail_Of(tmp);
end loop;
nbfree := cnt;
end Construct_Template;
procedure Construct_Equivariant_Template
( n : in natural; g : in List_of_Permutations;
cntfree : in out natural; fail : out boolean ) is
-- DESCRIPTION :
-- Constructs a template for an equivariant system. The list g contains
-- the generating elements of the group. The variable cntfree counts the
-- number of free coefficients.
begin
Init_Template(n);
First_Equivariant_Template(n,cntfree);
Propagate_Equivariant_Template(n,g,fail);
end Construct_Equivariant_Template;
procedure Write_Templates ( n : in natural ) is
begin
Write_Templates(Standard_Output,n);
end Write_Templates;
procedure Write_Templates ( file : in file_type; n : in natural ) is
h : Standard_Natural_Vectors.Vector(0..n);
begin
put_line(file,"The templates :");
for i in 1..n loop
for j in 1..Number_of_Hyperplanes(i) loop
put(file,"("); put(file,i,1); put(file,","); put(file,j,1);
put(file,") : "); Get_Hyperplane(i,j,h); put(file,h); new_line(file);
end loop;
end loop;
end Write_Templates;
-- CONSTRUCTION OF START SYSTEMS :
procedure Equivariant_Start_System
( n : in natural; g : in List_of_Permutations;
fail : out boolean ) is
nbfree : natural := 0;
fl : boolean := false;
begin
Construct_Equivariant_Template(n,g,nbfree,fl);
if not fl
then Templates.Polynomial_System(n,nbfree);
end if;
fail := fl;
end Equivariant_Start_System;
procedure Symmetric_Start_System
( n,bb : in natural; lp : in List;
v,w : in List_Of_Permutations;
notsymmetric,degenerate : out boolean ) is
m : natural := Number(v);
fl : boolean;
nbfree : natural;
begin
Construct_Covering(n,m,v,w,fl);
-- Write_Covering;
for i in lbm'range loop
free(lbm(i));
end loop;
free(lbm);
if fl
then notsymmetric := true;
-- put_line("The set structure is not (G,V,W)-symmetric.");
else notsymmetric := false;
-- put_line("The set structure is (G,V,W)-symmetric.");
-- Templates.Create(n);
Construct_Template(n,m,v,nbfree);
-- Write_Templates(n);
-- vb := Templates.Verify(n,lp);
-- put("The bound of Templates.Verify : "); put(vb,1); new_line;
-- if bb /= vb
-- then degenerate := true;
-- put_line("The set structure is degenerate.");
-- else
degenerate := false;
-- put_line("The set structure is not degenerate.");
Templates.Polynomial_System(n,nbfree);
-- end if;
end if;
end Symmetric_Start_System;
-- DESTRUCTOR :
procedure Clear is
use Lists_of_Dependency_Structures;
tmp : Covering := cov;
elem : Link_to_Dependency_Structure;
begin
while not Is_Null(tmp) loop
elem := Head_Of(tmp);
free(elem);
tmp := Tail_Of(tmp);
end loop;
Clear(cov);
Templates.Clear;
end Clear;
end Symmetric_Set_Structure;