![[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;