Annotation of OpenXM_contrib/PHC/Ada/Homotopy/multprec_complex_solutions.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2: with Multprec_Complex_Number_Tools; use Multprec_Complex_Number_Tools;
! 3: with Multprec_Complex_Vector_Tools; use Multprec_Complex_Vector_Tools;
! 4: with Multprec_Complex_Norms_Equals; use Multprec_Complex_Norms_Equals;
! 5:
! 6: package body Multprec_Complex_Solutions is
! 7:
! 8: use List_of_Solutions;
! 9:
! 10: -- CREATORS :
! 11:
! 12: function Create ( sl : Solution_List ) return Solution_Array is
! 13:
! 14: sa : Solution_Array(1..Length_Of(sl));
! 15:
! 16: begin
! 17: if not Is_Null(sl)
! 18: then declare
! 19: i : positive := 1;
! 20: temp : Solution_List := sl;
! 21: begin
! 22: while not Is_Null(temp) loop
! 23: sa(i) := new Solution'(Head_Of(temp).all);
! 24: i := i + 1;
! 25: temp := Tail_Of(temp);
! 26: end loop;
! 27: end;
! 28: end if;
! 29: return sa;
! 30: end Create;
! 31:
! 32: function Create ( sa : Solution_Array ) return Solution_List is
! 33:
! 34: sl : Solution_List;
! 35:
! 36: begin
! 37: if sa'first <= sa'last
! 38: then declare
! 39: n : natural := sa(sa'first).n;
! 40: sol : Solution(n) := sa(sa'first).all;
! 41: l : Link_to_Solution := new Solution'(sol);
! 42: last,tmp : Solution_List;
! 43: begin
! 44: Construct(l,sl);
! 45: last := sl;
! 46: for i in (sa'first+1)..sa'last loop
! 47: sol := sa(i).all;
! 48: l := new Solution'(sol);
! 49: Construct(l,tmp);
! 50: Swap_Tail(last,tmp);
! 51: last := Tail_Of(last);
! 52: end loop;
! 53: end;
! 54: end if;
! 55: return sl;
! 56: end Create;
! 57:
! 58: function Create ( s : Standard_Complex_Solutions.Solution )
! 59: return Multprec_Complex_Solutions.Solution is
! 60:
! 61: res : Multprec_Complex_Solutions.Solution(s.n);
! 62:
! 63: begin
! 64: res.t := s.t;
! 65: res.m := s.m;
! 66: res.v := Create(s.v);
! 67: res.err := Create(s.err);
! 68: res.rco := Create(s.rco);
! 69: res.res := Create(s.res);
! 70: return res;
! 71: end Create;
! 72:
! 73: function Create ( l : Standard_Complex_Solutions.Solution_List )
! 74: return Multprec_Complex_Solutions.Solution_List is
! 75:
! 76: res,res_last : Multprec_Complex_Solutions.Solution_List;
! 77: tmp : Standard_Complex_Solutions.Solution_List := l;
! 78:
! 79: use Standard_Complex_Solutions;
! 80:
! 81: begin
! 82: while not Is_Null(tmp) loop
! 83: declare
! 84: ls : Standard_Complex_Solutions.Link_to_Solution := Head_Of(tmp);
! 85: ms : Multprec_Complex_Solutions.Solution(ls.n) := Create(ls.all);
! 86: begin
! 87: Append(res,res_last,ms);
! 88: end;
! 89: tmp := Tail_Of(tmp);
! 90: end loop;
! 91: return res;
! 92: end Create;
! 93:
! 94: -- COMPARISON and COPYING :
! 95:
! 96: function Equal ( s1,s2 : Solution; tol : Floating_Number ) return boolean is
! 97:
! 98: use Standard_Complex_Numbers;
! 99:
! 100: begin
! 101: if (s1.t /= s2.t) or else (s1.n /= s2.n)
! 102: then return false;
! 103: else return Equal(s1.v,s2.v,tol);
! 104: end if;
! 105: end Equal;
! 106:
! 107: function Equal ( s1,s2 : Solution_List; tol : Floating_Number )
! 108: return boolean is
! 109: begin
! 110: if Is_Null(s1) and Is_Null(s2)
! 111: then return true;
! 112: elsif Is_Null(s1) or Is_Null(s2)
! 113: then return false;
! 114: else declare
! 115: temp1 : Solution_List := s1;
! 116: temp2 : Solution_List := s2;
! 117: begin
! 118: While not Is_Null(temp1) and not Is_Null(s2) loop
! 119: if not Equal(Head_Of(temp1).all,Head_Of(temp2).all,tol)
! 120: then return false;
! 121: else temp1 := Tail_Of(temp1);
! 122: temp2 := Tail_Of(temp2);
! 123: end if;
! 124: end loop;
! 125: if Is_Null(temp1) and Is_Null(temp2)
! 126: then return true;
! 127: else return false;
! 128: end if;
! 129: end;
! 130: end if;
! 131: end Equal;
! 132:
! 133: function Equal ( s1,s2 : Solution_Array; tol : Floating_Number )
! 134: return boolean is
! 135: begin
! 136: if s1'first /= s2'first
! 137: then return false;
! 138: elsif s1'last /= s2'last
! 139: then return false;
! 140: else for i in s1'range loop
! 141: if not Equal(s1(i).all,s2(i).all,tol)
! 142: then return false;
! 143: end if;
! 144: end loop;
! 145: end if;
! 146: return true;
! 147: end Equal;
! 148:
! 149: procedure Equals ( sols : in out Solution_List; flag : in natural;
! 150: tol : in Floating_Number; same : out boolean ) is
! 151: begin
! 152: same := false;
! 153: if not Is_Null(sols)
! 154: then declare
! 155: n : natural := Head_Of(sols).n;
! 156: i : natural := 1;
! 157: s1,s2 : Solution(n);
! 158: temp : Solution_List := sols;
! 159: begin
! 160: while not Is_Null(temp) loop
! 161: s1 := Head_Of(temp).all;
! 162: for j in (i+1)..Length_Of(sols) loop
! 163: s2 := Get(sols,j);
! 164: if Equal(s1,s2,tol)
! 165: then same := true;
! 166: Change_Multiplicity(sols,i,flag);
! 167: Change_Multiplicity(sols,j,flag);
! 168: end if;
! 169: end loop;
! 170: temp := Tail_Of(temp);
! 171: i := i + 1;
! 172: end loop;
! 173: end;
! 174: end if;
! 175: end Equals;
! 176:
! 177: procedure Equals ( sa : in Solution_Array; x : in Vector; i : in natural;
! 178: tol : in Floating_Number; j : in out natural ) is
! 179:
! 180: eq : boolean;
! 181:
! 182: begin
! 183: while j < i loop
! 184: eq := true;
! 185: for k in x'range loop
! 186: if AbsVal(sa(j).v(k) - x(k)) > tol
! 187: then eq := false;
! 188: end if;
! 189: exit when not eq;
! 190: end loop;
! 191: exit when eq;
! 192: j := j + 1;
! 193: end loop;
! 194: end Equals;
! 195:
! 196: procedure Copy ( s1 : in Solution; s2 : in out Solution ) is
! 197: begin
! 198: s2.t := s1.t;
! 199: s2.m := s1.m;
! 200: Copy(s1.v,s2.v);
! 201: Copy(s1.err,s2.err);
! 202: Copy(s1.rco,s2.rco);
! 203: Copy(s1.res,s2.res);
! 204: end Copy;
! 205:
! 206: procedure Copy ( s1 : in Solution_List; s2 : in out Solution_List ) is
! 207: begin
! 208: Clear(s2);
! 209: if not Is_Null(s1)
! 210: then declare
! 211: temp : Solution_List := s1;
! 212: last : Solution_List;
! 213: n : natural := Head_Of(s1).n;
! 214: sol : Solution(n) := Head_Of(temp).all;
! 215: ns : Solution(n);
! 216: begin
! 217: Copy(sol,ns);
! 218: declare
! 219: l : Link_to_Solution := new Solution'(ns);
! 220: begin
! 221: Construct(l,s2);
! 222: end;
! 223: last := s2;
! 224: temp := Tail_Of(temp);
! 225: while not Is_Null(temp) loop
! 226: sol := Head_Of(temp).all;
! 227: declare
! 228: l : Link_to_Solution := new Solution'(sol);
! 229: tmp : Solution_List;
! 230: begin
! 231: Construct(l,tmp);
! 232: Swap_Tail(last,tmp);
! 233: end;
! 234: last := Tail_Of(last);
! 235: temp := Tail_Of(temp);
! 236: end loop;
! 237: end;
! 238: end if;
! 239: end Copy;
! 240:
! 241: procedure Copy ( s1 : in Solution_Array; s2 : in out Solution_Array ) is
! 242: begin
! 243: Clear(s2);
! 244: for i in s1'range loop
! 245: s2(i) := new Solution'(s1(i).all);
! 246: end loop;
! 247: end Copy;
! 248:
! 249: -- SELECTORS :
! 250:
! 251: function Number ( sols : Solution_List; flag : natural ) return natural is
! 252:
! 253: res : natural := 0;
! 254:
! 255: begin
! 256: if Is_Null(sols)
! 257: then return res;
! 258: else declare
! 259: temp : Solution_List := sols;
! 260: ls : Link_to_Solution;
! 261: begin
! 262: while not Is_Null(temp) loop
! 263: if Head_Of(temp).m = flag
! 264: then res := res + 1;
! 265: end if;
! 266: temp := Tail_Of(temp);
! 267: end loop;
! 268: end;
! 269: return res;
! 270: end if;
! 271: end Number;
! 272:
! 273: function Is_In ( sols : Solution_List; s : Solution; tol : Floating_Number )
! 274: return boolean is
! 275:
! 276: tmp : Solution_List := sols;
! 277:
! 278: begin
! 279: while not Is_Null(tmp) loop
! 280: if Equal(Head_Of(tmp).all,s,tol)
! 281: then return true;
! 282: else tmp := Tail_Of(tmp);
! 283: end if;
! 284: end loop;
! 285: return false;
! 286: end Is_In;
! 287:
! 288: function Is_In ( sa : Solution_Array; s : Solution; tol : Floating_Number )
! 289: return boolean is
! 290: begin
! 291: for i in sa'range loop
! 292: if Equal(sa(i).all,s,tol)
! 293: then return true;
! 294: end if;
! 295: end loop;
! 296: return false;
! 297: end Is_In;
! 298:
! 299: function Get ( sols : Solution_List; pos : positive )
! 300: return Solution is
! 301: begin
! 302: if pos <= Length_Of(sols)
! 303: then declare
! 304: temp : Solution_List := sols;
! 305: count : natural := 1;
! 306: begin
! 307: while not Is_Null(temp) loop
! 308: if count = pos
! 309: then return Head_Of(temp).all;
! 310: else temp := Tail_Of(temp);
! 311: count := count + 1;
! 312: end if;
! 313: end loop;
! 314: end;
! 315: end if;
! 316: declare
! 317: s : Solution(0);
! 318: begin
! 319: return s;
! 320: end;
! 321: end Get;
! 322:
! 323: -- CONSTRUCTORS :
! 324:
! 325: procedure Append ( first,last : in out Solution_List; s : in Solution ) is
! 326:
! 327: ss : Solution(s.n);
! 328: ls : Link_to_Solution;
! 329:
! 330: begin
! 331: Copy(s,ss);
! 332: ls := new Solution'(ss);
! 333: if Is_Null(first)
! 334: then Construct(ls,first);
! 335: last := first;
! 336: else declare
! 337: tmp : Solution_List;
! 338: begin
! 339: Construct(ls,tmp);
! 340: Swap_Tail(last,tmp);
! 341: last := Tail_Of(last);
! 342: end;
! 343: end if;
! 344: end Append;
! 345:
! 346: procedure Add ( sols : in out Solution_List; s : in Solution ) is
! 347:
! 348: last,temp,tmp : Solution_List;
! 349: ls : Link_to_Solution := new Solution'(s);
! 350:
! 351: begin
! 352: if Is_Null(sols)
! 353: then Construct(ls,sols);
! 354: else temp := sols;
! 355: while not Is_Null(temp) loop
! 356: last := temp;
! 357: temp := Tail_Of(temp);
! 358: end loop;
! 359: Construct(ls,tmp);
! 360: Swap_Tail(last,tmp);
! 361: end if;
! 362: end Add;
! 363:
! 364: procedure Add ( sols : in out Solution_List; s : in Solution;
! 365: tol : in Floating_Number; other : out natural ) is
! 366:
! 367: last,temp,tmp : Solution_List;
! 368: ls : Link_to_Solution := new Solution'(s);
! 369: s2 : Solution(s.n);
! 370: count : natural := 1;
! 371:
! 372: begin
! 373: other := 0;
! 374: if Is_Null(sols)
! 375: then Construct(ls,sols);
! 376: else temp := sols;
! 377: while not Is_Null(temp) loop
! 378: s2 := Head_Of(temp).all;
! 379: if Equal(s,s2,tol)
! 380: then other := count;
! 381: Clear(ls);
! 382: return;
! 383: else last := temp;
! 384: temp := Tail_Of(temp);
! 385: count := count + 1;
! 386: end if;
! 387: end loop;
! 388: Construct(ls,tmp);
! 389: Swap_Tail(last,tmp);
! 390: end if;
! 391: end Add;
! 392:
! 393: -- MODIFIERS :
! 394:
! 395: procedure Set_Size ( s : in out Solution; size : in natural ) is
! 396: begin
! 397: Set_Size(s.v,size);
! 398: Set_Size(s.err,size);
! 399: Set_Size(s.rco,size);
! 400: Set_Size(s.res,size);
! 401: end Set_Size;
! 402:
! 403: procedure Set_Size ( ls : in out Link_to_Solution; size : in natural ) is
! 404: begin
! 405: Set_Size(ls.v,size);
! 406: Set_Size(ls.err,size);
! 407: Set_Size(ls.rco,size);
! 408: Set_Size(ls.res,size);
! 409: end Set_Size;
! 410:
! 411: procedure Set_Size ( sols : in out Solution_List; size : in natural ) is
! 412:
! 413: tmp : Solution_List := sols;
! 414:
! 415: begin
! 416: while not Is_Null(tmp) loop
! 417: declare
! 418: ls : Link_to_Solution := Head_Of(tmp);
! 419: begin
! 420: Set_Size(ls,size);
! 421: Set_Head(tmp,ls);
! 422: end;
! 423: tmp := Tail_Of(tmp);
! 424: end loop;
! 425: end Set_Size;
! 426:
! 427: procedure Change ( sols : in out Solution_List; pos : in positive;
! 428: s : in Solution; tol : in Floating_Number;
! 429: other : out natural ) is
! 430: begin
! 431: if pos <= Length_Of(sols)
! 432: then declare
! 433: temp : Solution_List := sols;
! 434: ls : Link_to_Solution;
! 435: begin
! 436: other := 0;
! 437: for i in 1..Length_Of(temp) loop
! 438: ls := Head_Of(temp);
! 439: if i = pos
! 440: then ls.v := s.v;
! 441: ls.m := s.m;
! 442: ls.t := s.t;
! 443: Set_Head(temp,ls);
! 444: return;
! 445: elsif Equal(s,ls.all,tol)
! 446: then other := i;
! 447: return;
! 448: end if;
! 449: temp := Tail_Of(temp);
! 450: end loop;
! 451: end;
! 452: end if;
! 453: end Change;
! 454:
! 455: procedure Set_Continuation_Parameter
! 456: ( sols : in out Solution_List;
! 457: t : in Standard_Complex_Numbers.Complex_Number ) is
! 458:
! 459: tmp : Solution_List := sols;
! 460:
! 461: begin
! 462: while not Is_Null(tmp) loop
! 463: declare
! 464: ls : Link_to_Solution := Head_Of(tmp);
! 465: begin
! 466: ls.t := t;
! 467: Set_Head(tmp,ls);
! 468: end;
! 469: tmp := Tail_Of(tmp);
! 470: end loop;
! 471: end Set_Continuation_Parameter;
! 472:
! 473: procedure Change_Multiplicity
! 474: ( sols : in out Solution_List; pos : in positive;
! 475: m : in natural ) is
! 476: begin
! 477: if pos <= Length_Of(sols)
! 478: then declare
! 479: temp : Solution_List := sols;
! 480: ls : Link_to_Solution;
! 481: begin
! 482: for i in 1..(pos-1) loop
! 483: temp := Tail_Of(temp);
! 484: end loop;
! 485: ls := Head_Of(temp);
! 486: ls.m := m;
! 487: Set_Head(temp,ls);
! 488: end;
! 489: end if;
! 490: end Change_Multiplicity;
! 491:
! 492: procedure Remove ( sols : in out Solution_List; pos : in positive ) is
! 493:
! 494: first,second,temp : Solution_List;
! 495: ls : Link_to_Solution;
! 496:
! 497: begin
! 498: if pos <= Length_Of(sols)
! 499: then if pos = 1
! 500: then if Is_Null(Tail_Of(sols))
! 501: then Clear(sols);
! 502: else ls := Head_Of(sols);
! 503: Clear(ls);
! 504: sols := Tail_Of(sols);
! 505: end if;
! 506: else second := sols;
! 507: for i in 1..(pos-1) loop
! 508: first := second;
! 509: second := Tail_Of(first);
! 510: end loop;
! 511: ls := Head_Of(second);
! 512: Clear(ls);
! 513: temp := Tail_Of(second);
! 514: Swap_Tail(first,temp);
! 515: end if;
! 516: end if;
! 517: end Remove;
! 518:
! 519: procedure Delete ( sols : in out Solution_List ) is
! 520:
! 521: continue : boolean;
! 522:
! 523: begin
! 524: continue := true;
! 525: -- looking for the first element in sols that can stay :
! 526: while not Is_Null(sols) and continue loop
! 527: declare
! 528: ls : Link_to_Solution := Head_Of(sols);
! 529: begin
! 530: if To_Be_Removed(ls.m)
! 531: then Clear(ls);
! 532: sols := Tail_Of(sols);
! 533: else continue := false;
! 534: end if;
! 535: end;
! 536: end loop;
! 537: if not Is_Null(sols)
! 538: then -- first element of sols can stay in the list
! 539: declare
! 540: first,second : Solution_List;
! 541: begin
! 542: first := sols;
! 543: second := Tail_Of(first);
! 544: while not Is_Null(second) loop
! 545: declare
! 546: ls : Link_to_Solution := Head_Of(second);
! 547: temp : Solution_List;
! 548: begin
! 549: if To_Be_Removed(ls.m)
! 550: then Clear(ls);
! 551: temp := Tail_Of(second);
! 552: Swap_Tail(first,temp);
! 553: end if;
! 554: end;
! 555: first := second;
! 556: second := Tail_Of(first);
! 557: end loop;
! 558: end;
! 559: end if;
! 560: end Delete;
! 561:
! 562: procedure Remove_All ( sols : in out Solution_List; flag : in natural ) is
! 563:
! 564: continue : boolean;
! 565:
! 566: begin
! 567: continue := true;
! 568: -- looking for the first element in sols that can stay :
! 569: while not Is_Null(sols) and continue loop
! 570: declare
! 571: ls : Link_to_Solution := Head_Of(sols);
! 572: begin
! 573: if ls.m = flag
! 574: then Clear(ls);
! 575: sols := Tail_Of(sols);
! 576: else continue := false;
! 577: end if;
! 578: end;
! 579: end loop;
! 580: if not Is_Null(sols)
! 581: then -- first element of s can stay in the list
! 582: declare
! 583: first,second : Solution_List;
! 584: begin
! 585: first := sols;
! 586: second := Tail_Of(first);
! 587: while not Is_Null(second) loop
! 588: declare
! 589: ls : Link_to_Solution := Head_Of(second);
! 590: temp : Solution_List;
! 591: begin
! 592: if ls.m = flag
! 593: then Clear(ls);
! 594: temp := Tail_Of(second);
! 595: Swap_Tail(first,temp);
! 596: end if;
! 597: end;
! 598: first := second;
! 599: second := Tail_Of(first);
! 600: end loop;
! 601: end;
! 602: end if;
! 603: end Remove_All;
! 604:
! 605: -- DESTRUCTORS :
! 606:
! 607: procedure Clear( s : in out Solution ) is
! 608: begin
! 609: Clear(s.err);
! 610: Clear(s.res);
! 611: Clear(s.rco);
! 612: Clear(s.v);
! 613: end Clear;
! 614:
! 615: procedure Clear ( ls : in out Link_to_Solution ) is
! 616:
! 617: procedure free is new unchecked_deallocation(Solution,Link_to_Solution);
! 618:
! 619: begin
! 620: if ls /= null
! 621: then Clear(ls.all);
! 622: end if;
! 623: free(ls);
! 624: end Clear;
! 625:
! 626: procedure Shallow_Clear ( sl : in out Solution_List ) is
! 627: begin
! 628: List_of_Solutions.Clear(List_of_Solutions.List(sl));
! 629: end Shallow_Clear;
! 630:
! 631: procedure Deep_Clear ( sl : in out Solution_List ) is
! 632:
! 633: temp : Solution_List := sl;
! 634: ls : Link_to_Solution;
! 635:
! 636: begin
! 637: while not Is_Null(temp) loop
! 638: ls := Head_Of(temp);
! 639: Clear(ls);
! 640: temp := Tail_Of(temp);
! 641: end loop;
! 642: Shallow_Clear(sl);
! 643: end Deep_Clear;
! 644:
! 645: procedure Clear ( sa : in out Solution_Array ) is
! 646: begin
! 647: for i in sa'range loop
! 648: Clear(sa(i));
! 649: end loop;
! 650: end Clear;
! 651:
! 652: end Multprec_Complex_Solutions;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to multprec_complex_solutions.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Homotopy