![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to generic_vectors.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Matrices|
Return to generic_vectors.adb CVS log | Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Matrices |
1.1 maekawa 1: with unchecked_deallocation;
2:
3: package body Generic_Vectors is
4:
5: -- COMPARISON AND COPYING :
6:
7: function Equal ( v1,v2 : Vector ) return boolean is
8: begin
9: if v1'first /= v2'first or else v1'last /= v2'last
10: then return false;
11: else for i in v1'range loop
12: if not equal(v1(i),v2(i))
13: then return false;
14: end if;
15: end loop;
16: return true;
17: end if;
18: end Equal;
19:
20: procedure Copy ( v1: in Vector; v2 : in out Vector ) is
21: begin
22: if v1'first /= v2'first or else v1'last /= v2'last
23: then raise CONSTRAINT_ERROR;
24: else Clear(v2);
25: for i in v1'range loop
26: copy(v1(i),v2(i));
27: end loop;
28: end if;
29: end Copy;
30:
31: -- ARITHMETIC AS FUNCTIONS :
32:
33: function "+" ( v1,v2 : Vector ) return Vector is
34: begin
35: if v1'first /= v2'first or else v1'last /= v2'last
36: then raise CONSTRAINT_ERROR;
37: else declare
38: res : Vector(v1'range);
39: begin
40: for i in v1'range loop
41: res(i) := v1(i) + v2(i);
42: end loop;
43: return res;
44: end;
45: end if;
46: end "+";
47:
48: function "+" ( v : Vector ) return Vector is
49:
50: res : Vector(v'range);
51:
52: begin
53: for i in v'range loop
54: res(i) := +v(i);
55: end loop;
56: return res;
57: end "+";
58:
59: function "-" ( v : Vector ) return Vector is
60:
61: res : Vector(v'range);
62:
63: begin
64: for i in v'range loop
65: res(i) := -v(i);
66: end loop;
67: return res;
68: end "-";
69:
70: function "-" ( v1,v2 : Vector ) return Vector is
71: begin
72: if v1'first /= v2'first or else v1'last /= v2'last
73: then raise CONSTRAINT_ERROR;
74: else declare
75: res : Vector(v1'range);
76: begin
77: for i in v1'range loop
78: res(i) := v1(i) - v2(i);
79: end loop;
80: return res;
81: end;
82: end if;
83: end "-";
84:
85: function "*" ( v : Vector; a : number ) return Vector is
86:
87: res : Vector(v'range);
88:
89: begin
90: for i in v'range loop
91: res(i) := v(i) * a;
92: end loop;
93: return res;
94: end "*";
95:
96: function "*" ( a : number; v : Vector ) return Vector is
97: begin
98: return v*a;
99: end "*";
100:
101: function "*" ( v1,v2 : Vector ) return number is
102: begin
103: if v1'first /= v2'first or else v1'last /= v2'last
104: then raise CONSTRAINT_ERROR;
105: else declare
106: temp,sum : number;
107: begin
108: if v1'first <= v1'last
109: then sum := v1(v1'first)*v2(v2'first);
110: for i in v1'first+1..v1'last loop
111: temp := v1(i)*v2(i);
112: Add(sum,temp);
113: Clear(temp);
114: end loop;
115: end if;
116: return sum;
117: end;
118: end if;
119: end "*";
120:
121: function "*" ( v1,v2 : Vector ) return Vector is
122: begin
123: if v1'first /= v2'first or else v1'last /= v2'last
124: then raise CONSTRAINT_ERROR;
125: else declare
126: res : Vector(v1'range);
127: begin
128: for i in v1'range loop
129: res(i) := v1(i)*v2(i);
130: end loop;
131: return res;
132: end;
133: end if;
134: end "*";
135:
136: function Sum ( v : Vector ) return number is
137:
138: res : number := v(v'first);
139:
140: begin
141: for i in v'first+1..v'last loop
142: Add(res,v(i));
143: end loop;
144: return res;
145: end Sum;
146:
147: -- ARITHMETIC AS PROCEDURES :
148:
149: procedure Add ( v1 : in out Vector; v2 : in Vector ) is
150: begin
151: if v1'first /= v2'first or else v1'last /= v2'last
152: then raise CONSTRAINT_ERROR;
153: else for i in v1'range loop
154: Add(v1(i),v2(i));
155: end loop;
156: end if;
157: end Add;
158:
159: procedure Min ( v : in out Vector ) is
160: begin
161: for i in v'range loop
162: Min(v(i));
163: end loop;
164: end Min;
165:
166: procedure Sub ( v1 : in out Vector; v2 : in Vector ) is
167: begin
168: if v1'first /= v2'first or else v1'last /= v2'last
169: then raise CONSTRAINT_ERROR;
170: else for i in v1'range loop
171: Sub(v1(i),v2(i));
172: end loop;
173: end if;
174: end Sub;
175:
176: procedure Mul ( v : in out Vector; a : in number ) is
177: begin
178: for i in v'range loop
179: Mul(v(i),a);
180: end loop;
181: end Mul;
182:
183: procedure Mul ( v1 : in out Vector; v2 : in Vector ) is
184: begin
185: if v1'first /= v2'first or else v1'last /= v2'last
186: then raise CONSTRAINT_ERROR;
187: else for i in v1'range loop
188: Mul(v1(i),v2(i));
189: end loop;
190: end if;
191: end Mul;
192:
193: -- DESTRUCTOR :
194:
195: procedure Clear ( v : in out Vector ) is
196: begin
197: for i in v'range loop
198: Clear(v(i));
199: end loop;
200: end Clear;
201:
202: -- OPERATIONS ON POINTERS TO VECTORS :
203:
204: -- COMPARISON AND COPYING :
205:
206: function Equal ( v1,v2 : Link_to_Vector ) return boolean is
207: begin
208: if (v1 = null) and (v2 = null)
209: then return true;
210: elsif (v1 = null) or (v2 = null)
211: then return false;
212: else return Equal(v1.all,v2.all);
213: end if;
214: end Equal;
215:
216: procedure Copy ( v1: in Link_to_Vector; v2 : in out Link_to_Vector ) is
217: begin
218: Clear(v2);
219: if v1 /= null
220: then v2 := new Vector(v1'range);
221: for i in v1'range loop
222: v2(i) := v1(i);
223: end loop;
224: end if;
225: end Copy;
226:
227: -- ARITHMETIC AS FUNCTIONS :
228:
229: function "+" ( v1,v2 : Link_to_Vector ) return Link_to_Vector is
230: begin
231: if v1 = null
232: then return v2;
233: elsif v2 = null
234: then return v1;
235: else return new Vector'(v1.all + v2.all);
236: end if;
237: end "+";
238:
239: function "+" ( v : Link_to_Vector ) return Link_to_Vector is
240: begin
241: if v = null
242: then return v;
243: else return new Vector'(+v.all);
244: end if;
245: end "+";
246:
247: function "-" ( v : Link_to_Vector ) return Link_to_Vector is
248: begin
249: if v = null
250: then return v;
251: else return new Vector'(-v.all);
252: end if;
253: end "-";
254:
255: function "-" ( v1,v2 : Link_to_Vector ) return Link_to_Vector is
256: begin
257: if v2 = null
258: then return v1;
259: elsif v1 = null
260: then return -v2;
261: else return new Vector'(v1.all - v2.all);
262: end if;
263: end "-";
264:
265: function "*" ( v : Link_to_Vector; a : number ) return Link_to_Vector is
266: begin
267: if v = null
268: then return null;
269: else return new Vector'(v.all*a);
270: end if;
271: end "*";
272:
273: function "*" ( a : number; v : Link_to_Vector ) return Link_to_Vector is
274: begin
275: return v*a;
276: end "*";
277:
278: function "*" ( v1,v2 : Link_to_Vector ) return number is
279: begin
280: return v1.all*v2.all;
281: end "*";
282:
283: function "*" ( v1,v2 : Link_to_Vector ) return Link_to_Vector is
284: begin
285: if (v1 = null) or (v2 = null)
286: then return null;
287: else return new Vector'(v1.all*v2.all);
288: end if;
289: end "*";
290:
291: function Sum ( v : Link_to_Vector ) return number is
292: begin
293: return Sum(v.all);
294: end Sum;
295:
296: -- ARITHMETIC AS PROCEDURES :
297:
298: procedure Add ( v1 : in out Link_to_Vector; v2 : in Link_to_Vector ) is
299: begin
300: if v2 = null
301: then null;
302: elsif v1 = null
303: then Copy(v2,v1);
304: else Add(v1.all,v2.all);
305: end if;
306: end Add;
307:
308: procedure Min ( v : in out Link_to_Vector ) is
309: begin
310: if v = null
311: then null;
312: else Min(v.all);
313: end if;
314: end Min;
315:
316: procedure Sub ( v1 : in out Link_to_Vector; v2 : in Link_to_Vector ) is
317: begin
318: if v2 = null
319: then null;
320: elsif v1 = null
321: then v1 := new Vector'(v2.all);
322: Min(v1.all);
323: else Sub(v1.all,v2.all);
324: end if;
325: end Sub;
326:
327: procedure Mul ( v : in out Link_to_Vector; a : in number ) is
328: begin
329: if v /= null
330: then Mul(v.all,a);
331: end if;
332: end Mul;
333:
334: procedure Mul ( v1 : in out Link_to_Vector; v2 : in Link_to_Vector ) is
335: begin
336: if v2 = null
337: then null;
338: elsif v1 = null
339: then Clear(v1);
340: else Mul(v1.all,v2.all);
341: end if;
342: end Mul;
343:
344: -- DESTRUCTOR :
345:
346: procedure Clear ( v : in out Link_to_Vector ) is
347:
348: procedure free is new unchecked_deallocation(Vector,Link_to_Vector);
349:
350: begin
351: if v /= null
352: then Clear(v.all);
353: free(v);
354: end if;
355: end Clear;
356:
357: end Generic_Vectors;