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