File: [local] / OpenXM_contrib / PHC / Ada / Homotopy / multprec_complex_solutions.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:23 2000 UTC (23 years, 11 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 Multprec_Complex_Number_Tools; use Multprec_Complex_Number_Tools;
with Multprec_Complex_Vector_Tools; use Multprec_Complex_Vector_Tools;
with Multprec_Complex_Norms_Equals; use Multprec_Complex_Norms_Equals;
package body Multprec_Complex_Solutions is
use List_of_Solutions;
-- CREATORS :
function Create ( sl : Solution_List ) return Solution_Array is
sa : Solution_Array(1..Length_Of(sl));
begin
if not Is_Null(sl)
then declare
i : positive := 1;
temp : Solution_List := sl;
begin
while not Is_Null(temp) loop
sa(i) := new Solution'(Head_Of(temp).all);
i := i + 1;
temp := Tail_Of(temp);
end loop;
end;
end if;
return sa;
end Create;
function Create ( sa : Solution_Array ) return Solution_List is
sl : Solution_List;
begin
if sa'first <= sa'last
then declare
n : natural := sa(sa'first).n;
sol : Solution(n) := sa(sa'first).all;
l : Link_to_Solution := new Solution'(sol);
last,tmp : Solution_List;
begin
Construct(l,sl);
last := sl;
for i in (sa'first+1)..sa'last loop
sol := sa(i).all;
l := new Solution'(sol);
Construct(l,tmp);
Swap_Tail(last,tmp);
last := Tail_Of(last);
end loop;
end;
end if;
return sl;
end Create;
function Create ( s : Standard_Complex_Solutions.Solution )
return Multprec_Complex_Solutions.Solution is
res : Multprec_Complex_Solutions.Solution(s.n);
begin
res.t := s.t;
res.m := s.m;
res.v := Create(s.v);
res.err := Create(s.err);
res.rco := Create(s.rco);
res.res := Create(s.res);
return res;
end Create;
function Create ( l : Standard_Complex_Solutions.Solution_List )
return Multprec_Complex_Solutions.Solution_List is
res,res_last : Multprec_Complex_Solutions.Solution_List;
tmp : Standard_Complex_Solutions.Solution_List := l;
use Standard_Complex_Solutions;
begin
while not Is_Null(tmp) loop
declare
ls : Standard_Complex_Solutions.Link_to_Solution := Head_Of(tmp);
ms : Multprec_Complex_Solutions.Solution(ls.n) := Create(ls.all);
begin
Append(res,res_last,ms);
end;
tmp := Tail_Of(tmp);
end loop;
return res;
end Create;
-- COMPARISON and COPYING :
function Equal ( s1,s2 : Solution; tol : Floating_Number ) return boolean is
use Standard_Complex_Numbers;
begin
if (s1.t /= s2.t) or else (s1.n /= s2.n)
then return false;
else return Equal(s1.v,s2.v,tol);
end if;
end Equal;
function Equal ( s1,s2 : Solution_List; tol : Floating_Number )
return boolean is
begin
if Is_Null(s1) and Is_Null(s2)
then return true;
elsif Is_Null(s1) or Is_Null(s2)
then return false;
else declare
temp1 : Solution_List := s1;
temp2 : Solution_List := s2;
begin
While not Is_Null(temp1) and not Is_Null(s2) loop
if not Equal(Head_Of(temp1).all,Head_Of(temp2).all,tol)
then return false;
else temp1 := Tail_Of(temp1);
temp2 := Tail_Of(temp2);
end if;
end loop;
if Is_Null(temp1) and Is_Null(temp2)
then return true;
else return false;
end if;
end;
end if;
end Equal;
function Equal ( s1,s2 : Solution_Array; tol : Floating_Number )
return boolean is
begin
if s1'first /= s2'first
then return false;
elsif s1'last /= s2'last
then return false;
else for i in s1'range loop
if not Equal(s1(i).all,s2(i).all,tol)
then return false;
end if;
end loop;
end if;
return true;
end Equal;
procedure Equals ( sols : in out Solution_List; flag : in natural;
tol : in Floating_Number; same : out boolean ) is
begin
same := false;
if not Is_Null(sols)
then declare
n : natural := Head_Of(sols).n;
i : natural := 1;
s1,s2 : Solution(n);
temp : Solution_List := sols;
begin
while not Is_Null(temp) loop
s1 := Head_Of(temp).all;
for j in (i+1)..Length_Of(sols) loop
s2 := Get(sols,j);
if Equal(s1,s2,tol)
then same := true;
Change_Multiplicity(sols,i,flag);
Change_Multiplicity(sols,j,flag);
end if;
end loop;
temp := Tail_Of(temp);
i := i + 1;
end loop;
end;
end if;
end Equals;
procedure Equals ( sa : in Solution_Array; x : in Vector; i : in natural;
tol : in Floating_Number; j : in out natural ) is
eq : boolean;
begin
while j < i loop
eq := true;
for k in x'range loop
if AbsVal(sa(j).v(k) - x(k)) > tol
then eq := false;
end if;
exit when not eq;
end loop;
exit when eq;
j := j + 1;
end loop;
end Equals;
procedure Copy ( s1 : in Solution; s2 : in out Solution ) is
begin
s2.t := s1.t;
s2.m := s1.m;
Copy(s1.v,s2.v);
Copy(s1.err,s2.err);
Copy(s1.rco,s2.rco);
Copy(s1.res,s2.res);
end Copy;
procedure Copy ( s1 : in Solution_List; s2 : in out Solution_List ) is
begin
Clear(s2);
if not Is_Null(s1)
then declare
temp : Solution_List := s1;
last : Solution_List;
n : natural := Head_Of(s1).n;
sol : Solution(n) := Head_Of(temp).all;
ns : Solution(n);
begin
Copy(sol,ns);
declare
l : Link_to_Solution := new Solution'(ns);
begin
Construct(l,s2);
end;
last := s2;
temp := Tail_Of(temp);
while not Is_Null(temp) loop
sol := Head_Of(temp).all;
declare
l : Link_to_Solution := new Solution'(sol);
tmp : Solution_List;
begin
Construct(l,tmp);
Swap_Tail(last,tmp);
end;
last := Tail_Of(last);
temp := Tail_Of(temp);
end loop;
end;
end if;
end Copy;
procedure Copy ( s1 : in Solution_Array; s2 : in out Solution_Array ) is
begin
Clear(s2);
for i in s1'range loop
s2(i) := new Solution'(s1(i).all);
end loop;
end Copy;
-- SELECTORS :
function Number ( sols : Solution_List; flag : natural ) return natural is
res : natural := 0;
begin
if Is_Null(sols)
then return res;
else declare
temp : Solution_List := sols;
ls : Link_to_Solution;
begin
while not Is_Null(temp) loop
if Head_Of(temp).m = flag
then res := res + 1;
end if;
temp := Tail_Of(temp);
end loop;
end;
return res;
end if;
end Number;
function Is_In ( sols : Solution_List; s : Solution; tol : Floating_Number )
return boolean is
tmp : Solution_List := sols;
begin
while not Is_Null(tmp) loop
if Equal(Head_Of(tmp).all,s,tol)
then return true;
else tmp := Tail_Of(tmp);
end if;
end loop;
return false;
end Is_In;
function Is_In ( sa : Solution_Array; s : Solution; tol : Floating_Number )
return boolean is
begin
for i in sa'range loop
if Equal(sa(i).all,s,tol)
then return true;
end if;
end loop;
return false;
end Is_In;
function Get ( sols : Solution_List; pos : positive )
return Solution is
begin
if pos <= Length_Of(sols)
then declare
temp : Solution_List := sols;
count : natural := 1;
begin
while not Is_Null(temp) loop
if count = pos
then return Head_Of(temp).all;
else temp := Tail_Of(temp);
count := count + 1;
end if;
end loop;
end;
end if;
declare
s : Solution(0);
begin
return s;
end;
end Get;
-- CONSTRUCTORS :
procedure Append ( first,last : in out Solution_List; s : in Solution ) is
ss : Solution(s.n);
ls : Link_to_Solution;
begin
Copy(s,ss);
ls := new Solution'(ss);
if Is_Null(first)
then Construct(ls,first);
last := first;
else declare
tmp : Solution_List;
begin
Construct(ls,tmp);
Swap_Tail(last,tmp);
last := Tail_Of(last);
end;
end if;
end Append;
procedure Add ( sols : in out Solution_List; s : in Solution ) is
last,temp,tmp : Solution_List;
ls : Link_to_Solution := new Solution'(s);
begin
if Is_Null(sols)
then Construct(ls,sols);
else temp := sols;
while not Is_Null(temp) loop
last := temp;
temp := Tail_Of(temp);
end loop;
Construct(ls,tmp);
Swap_Tail(last,tmp);
end if;
end Add;
procedure Add ( sols : in out Solution_List; s : in Solution;
tol : in Floating_Number; other : out natural ) is
last,temp,tmp : Solution_List;
ls : Link_to_Solution := new Solution'(s);
s2 : Solution(s.n);
count : natural := 1;
begin
other := 0;
if Is_Null(sols)
then Construct(ls,sols);
else temp := sols;
while not Is_Null(temp) loop
s2 := Head_Of(temp).all;
if Equal(s,s2,tol)
then other := count;
Clear(ls);
return;
else last := temp;
temp := Tail_Of(temp);
count := count + 1;
end if;
end loop;
Construct(ls,tmp);
Swap_Tail(last,tmp);
end if;
end Add;
-- MODIFIERS :
procedure Set_Size ( s : in out Solution; size : in natural ) is
begin
Set_Size(s.v,size);
Set_Size(s.err,size);
Set_Size(s.rco,size);
Set_Size(s.res,size);
end Set_Size;
procedure Set_Size ( ls : in out Link_to_Solution; size : in natural ) is
begin
Set_Size(ls.v,size);
Set_Size(ls.err,size);
Set_Size(ls.rco,size);
Set_Size(ls.res,size);
end Set_Size;
procedure Set_Size ( sols : in out Solution_List; size : in natural ) is
tmp : Solution_List := sols;
begin
while not Is_Null(tmp) loop
declare
ls : Link_to_Solution := Head_Of(tmp);
begin
Set_Size(ls,size);
Set_Head(tmp,ls);
end;
tmp := Tail_Of(tmp);
end loop;
end Set_Size;
procedure Change ( sols : in out Solution_List; pos : in positive;
s : in Solution; tol : in Floating_Number;
other : out natural ) is
begin
if pos <= Length_Of(sols)
then declare
temp : Solution_List := sols;
ls : Link_to_Solution;
begin
other := 0;
for i in 1..Length_Of(temp) loop
ls := Head_Of(temp);
if i = pos
then ls.v := s.v;
ls.m := s.m;
ls.t := s.t;
Set_Head(temp,ls);
return;
elsif Equal(s,ls.all,tol)
then other := i;
return;
end if;
temp := Tail_Of(temp);
end loop;
end;
end if;
end Change;
procedure Set_Continuation_Parameter
( sols : in out Solution_List;
t : in Standard_Complex_Numbers.Complex_Number ) is
tmp : Solution_List := sols;
begin
while not Is_Null(tmp) loop
declare
ls : Link_to_Solution := Head_Of(tmp);
begin
ls.t := t;
Set_Head(tmp,ls);
end;
tmp := Tail_Of(tmp);
end loop;
end Set_Continuation_Parameter;
procedure Change_Multiplicity
( sols : in out Solution_List; pos : in positive;
m : in natural ) is
begin
if pos <= Length_Of(sols)
then declare
temp : Solution_List := sols;
ls : Link_to_Solution;
begin
for i in 1..(pos-1) loop
temp := Tail_Of(temp);
end loop;
ls := Head_Of(temp);
ls.m := m;
Set_Head(temp,ls);
end;
end if;
end Change_Multiplicity;
procedure Remove ( sols : in out Solution_List; pos : in positive ) is
first,second,temp : Solution_List;
ls : Link_to_Solution;
begin
if pos <= Length_Of(sols)
then if pos = 1
then if Is_Null(Tail_Of(sols))
then Clear(sols);
else ls := Head_Of(sols);
Clear(ls);
sols := Tail_Of(sols);
end if;
else second := sols;
for i in 1..(pos-1) loop
first := second;
second := Tail_Of(first);
end loop;
ls := Head_Of(second);
Clear(ls);
temp := Tail_Of(second);
Swap_Tail(first,temp);
end if;
end if;
end Remove;
procedure Delete ( sols : in out Solution_List ) is
continue : boolean;
begin
continue := true;
-- looking for the first element in sols that can stay :
while not Is_Null(sols) and continue loop
declare
ls : Link_to_Solution := Head_Of(sols);
begin
if To_Be_Removed(ls.m)
then Clear(ls);
sols := Tail_Of(sols);
else continue := false;
end if;
end;
end loop;
if not Is_Null(sols)
then -- first element of sols can stay in the list
declare
first,second : Solution_List;
begin
first := sols;
second := Tail_Of(first);
while not Is_Null(second) loop
declare
ls : Link_to_Solution := Head_Of(second);
temp : Solution_List;
begin
if To_Be_Removed(ls.m)
then Clear(ls);
temp := Tail_Of(second);
Swap_Tail(first,temp);
end if;
end;
first := second;
second := Tail_Of(first);
end loop;
end;
end if;
end Delete;
procedure Remove_All ( sols : in out Solution_List; flag : in natural ) is
continue : boolean;
begin
continue := true;
-- looking for the first element in sols that can stay :
while not Is_Null(sols) and continue loop
declare
ls : Link_to_Solution := Head_Of(sols);
begin
if ls.m = flag
then Clear(ls);
sols := Tail_Of(sols);
else continue := false;
end if;
end;
end loop;
if not Is_Null(sols)
then -- first element of s can stay in the list
declare
first,second : Solution_List;
begin
first := sols;
second := Tail_Of(first);
while not Is_Null(second) loop
declare
ls : Link_to_Solution := Head_Of(second);
temp : Solution_List;
begin
if ls.m = flag
then Clear(ls);
temp := Tail_Of(second);
Swap_Tail(first,temp);
end if;
end;
first := second;
second := Tail_Of(first);
end loop;
end;
end if;
end Remove_All;
-- DESTRUCTORS :
procedure Clear( s : in out Solution ) is
begin
Clear(s.err);
Clear(s.res);
Clear(s.rco);
Clear(s.v);
end Clear;
procedure Clear ( ls : in out Link_to_Solution ) is
procedure free is new unchecked_deallocation(Solution,Link_to_Solution);
begin
if ls /= null
then Clear(ls.all);
end if;
free(ls);
end Clear;
procedure Shallow_Clear ( sl : in out Solution_List ) is
begin
List_of_Solutions.Clear(List_of_Solutions.List(sl));
end Shallow_Clear;
procedure Deep_Clear ( sl : in out Solution_List ) is
temp : Solution_List := sl;
ls : Link_to_Solution;
begin
while not Is_Null(temp) loop
ls := Head_Of(temp);
Clear(ls);
temp := Tail_Of(temp);
end loop;
Shallow_Clear(sl);
end Deep_Clear;
procedure Clear ( sa : in out Solution_Array ) is
begin
for i in sa'range loop
Clear(sa(i));
end loop;
end Clear;
end Multprec_Complex_Solutions;