![[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|
Return to multprec_complex_solutions.adb CVS log | Up to [local] / OpenXM_contrib / PHC / Ada / Homotopy |
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;