File: [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Implift / arrays_of_lists_utilities.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:28 2000 UTC (23 years, 9 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 Integer_Support_Functions; use Integer_Support_Functions;
with Transformations; use Transformations;
with Transforming_Integer_Vector_Lists; use Transforming_Integer_Vector_Lists;
with Lists_of_Vectors_Utilities; use Lists_of_Vectors_Utilities;
package body Arrays_of_Lists_Utilities is
function All_Equal ( al : Array_of_Lists ) return boolean is
begin
for i in (al'first+1)..al'last loop
if not Is_Equal(al(al'first),al(i))
then return false;
end if;
end loop;
return true;
end All_Equal;
function Interchange2 ( al : Array_of_Lists ) return Array_of_Lists is
res : Array_of_Lists(al'range);
index : integer;
begin
if Length_Of(al(al'first)) <= 2
then res := al;
else index := al'first;
for i in al'first+1..al'last loop
if Length_Of(al(i)) <= 2
then index := i;
else res(i) := al(i);
end if;
exit when index > al'first;
end loop;
if index = al'first
then res(index) := al(index);
else res(index) := al(al'first);
res(res'first) := al(index);
res(index+1..res'last) := al(index+1..al'last);
end if;
end if;
return res;
end Interchange2;
function Index2 ( al : Array_of_Lists ) return integer is
begin
for i in al'range loop
if Length_Of(al(i)) <= 2
then return i;
end if;
end loop;
return al'first;
end Index2;
procedure Mixture ( al : in Array_of_Lists;
perm,mix : out Link_to_Vector ) is
wrkper,wrkmix : vector(al'range); -- intermediate results
nbd : natural := 0; -- # different sets
ind,min : integer;
procedure Sort ( indal,indmix : in natural ) is
-- DESCRIPTION :
-- Puts all lists which are equal to al(perm(index)) together.
-- ON ENTRY :
-- indal the current entry in al;
-- indmix the current entry in wrkmix.
begin
for j in indal+1..al'last loop
if Is_Equal(al(wrkper(indal)),al(wrkper(j)))
then if j /= indal + wrkmix(indmix)
then declare
pos : natural := indal + wrkmix(indmix);
tmppos : natural;
begin
tmppos := wrkper(j);
wrkper(j) := wrkper(pos);
wrkper(pos) := tmppos;
end;
end if;
wrkmix(indmix) := wrkmix(indmix) + 1;
end if;
end loop;
end Sort;
procedure Permute ( ind,nb : in natural ) is
-- DESCRIPTION :
-- Changes the permutation vector such that the entry given by
-- the index stands in front. The number of different supports is
-- given by the parameter nb.
newper : vector(wrkper'range);
cntnew : natural := newper'first + wrkmix(ind);
cntwrk : natural := wrkper'first;
begin
for i in 1..nb loop
if i /= ind
then for j in 0..wrkmix(i)-1 loop
newper(cntnew+j) := wrkper(cntwrk+j);
end loop;
cntnew := cntnew + wrkmix(i);
else for j in 0..wrkmix(ind)-1 loop
newper(newper'first+j) := wrkper(cntwrk+j);
end loop;
end if;
cntwrk := cntwrk + wrkmix(i);
end loop;
wrkper := newper;
end Permute;
begin
-- INITIALIZATIONS :
for i in wrkper'range loop
wrkper(i) := i;
end loop;
wrkmix := (wrkmix'range => 1);
-- SORTING THE SETS :
ind := al'first;
while ind <= al'last loop
nbd := nbd + 1;
Sort(ind,nbd);
ind := ind + wrkmix(nbd);
end loop;
-- MINIMAL OCCURENCE SHOULD APPEAR FIRST :
ind := wrkmix'first;
min := wrkmix(ind);
for i in wrkmix'first+1..nbd loop
if wrkmix(i) < min
then min := wrkmix(i); ind := i;
end if;
end loop;
-- put("The type of mixture : " ); put(wrkmix(wrkmix'first..nbd)); new_line;
-- put("The permutation vector : "); put(wrkper); new_line;
if ind /= wrkmix'first
then Permute(ind,nbd);
wrkmix(ind) := wrkmix(wrkmix'first);
wrkmix(wrkmix'first) := min;
end if;
-- put("The type of mixture : " ); put(wrkmix(wrkmix'first..nbd)); new_line;
-- put("The permutation vector : "); put(wrkper); new_line;
-- RETURNING THE RESULTS :
perm := new Vector'(wrkper);
mix := new Vector'(wrkmix(wrkmix'first..nbd));
end Mixture;
function Permute ( perm : Vector; al : in Array_of_Lists )
return Array_of_Lists is
res : Array_of_Lists(al'range);
begin
for i in al'range loop
res(i) := al(perm(i));
end loop;
return res;
end Permute;
function Different_Points ( al : Array_of_Lists ) return List is
tmp,res,res_last : List;
begin
for i in (al'first+1)..al'last loop
tmp := al(i);
while not Is_Null(tmp) loop
declare
lv : Link_to_Vector := Head_Of(tmp);
begin
if not Is_In(res,lv.all)
then Append(res,res_last,lv.all);
end if;
end;
tmp := Tail_Of(tmp);
end loop;
end loop;
return res;
end Different_Points;
function Different_Points ( al : Array_of_Lists ) return Array_of_Lists is
res : Array_of_Lists(al'range);
begin
res(res'first) := al(al'first);
for i in (al'first+1)..al'last loop
res(i) := Different_Points(al(i));
end loop;
return res;
end Different_Points;
procedure Remove_Duplicates ( al : in out Array_of_Lists ) is
begin
for i in al'range loop
Remove_Duplicates(al(i));
end loop;
end Remove_Duplicates;
procedure Shift ( al : in out Array_of_Lists; shiftvecs : in VecVec ) is
begin
for k in al'range loop
Shift(al(k),shiftvecs(k));
end loop;
end Shift;
function Shift ( al : Array_of_Lists; shiftvecs : VecVec )
return Array_of_Lists is
res : Array_of_Lists(al'range);
begin
for k in res'range loop
res(k) := Shift(al(k),shiftvecs(k));
end loop;
return res;
end Shift;
procedure Projection ( al : in Array_of_Lists; v : in Vector;
ind : integer; res : in out Array_of_Lists;
degenerate : out boolean ) is
pv : integer;
t : Transfo := Build_Transfo(v,ind);
procedure Clean ( i : in integer ) is
begin
for j in res'first..i loop
Deep_Clear(res(j));
end loop;
Clear(t);
end Clean;
begin
degenerate := false;
for i in res'range loop
declare
pvl : List;
l : List renames al(i+1);
begin
pv := Maximal_Support(l,v);
pvl := Face(l,v,pv);
if Length_Of(pvl) <= 1
then degenerate := true;
Deep_Clear(pvl); Clean(i);
return;
else res(i) := Transform_and_Reduce(t,ind,pvl);
Remove_Duplicates(res(i));
if Length_Of(res(i)) <= 1
then degenerate := true;
Deep_Clear(pvl); Clean(i);
return;
end if;
end if;
Deep_Clear(pvl);
end;
end loop;
Clear(t);
end Projection;
end Arrays_of_Lists_Utilities;