Annotation of OpenXM_contrib/PHC/Ada/Math_Lib/Matrices/generic_vectors.adb, Revision 1.1
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;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[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