Annotation of OpenXM_contrib/PHC/Ada/Math_Lib/Supports/integer_faces_of_polytope.adb, Revision 1.1
1.1 ! maekawa 1: with Integer_Face_Enumerators; use Integer_Face_Enumerators;
! 2:
! 3: package body Integer_Faces_of_Polytope is
! 4:
! 5: -- AUXILIAIRIES :
! 6:
! 7: function Create_Edge ( pts : VecVec; i,j : integer ) return Face is
! 8:
! 9: -- DESCRIPTION :
! 10: -- Creates the edge spanned by pts(i) and pts(j).
! 11:
! 12: res : Face(0..1) := new VecVec(0..1);
! 13:
! 14: begin
! 15: res(0) := new Vector'(pts(i).all);
! 16: res(1) := new Vector'(pts(j).all);
! 17: return res;
! 18: end Create_Edge;
! 19:
! 20: function Create_Face ( pts : VecVec; f : Vector ) return Face is
! 21:
! 22: -- DESCRIPTION :
! 23: -- Returns vector of points pts(f(i)) that span the face.
! 24:
! 25: res : Face(f'range) := new VecVec(f'range);
! 26:
! 27: begin
! 28: for i in f'range loop
! 29: res(i) := new Vector'(pts(f(i)).all);
! 30: end loop;
! 31: return res;
! 32: end Create_Face;
! 33:
! 34: procedure Move_to_Front ( pts : in out VecVec; x : in Vector ) is
! 35:
! 36: -- DESCRIPTION :
! 37: -- The vector x is move to the front of the vector pts.
! 38:
! 39: begin
! 40: if pts(pts'first).all /= x
! 41: then for i in pts'first+1..pts'last loop
! 42: if pts(i).all = x
! 43: then pts(i).all := pts(pts'first).all;
! 44: pts(pts'first).all := x;
! 45: return;
! 46: end if;
! 47: end loop;
! 48: end if;
! 49: end Move_to_Front;
! 50:
! 51: -- CONSTRUCTORS :
! 52:
! 53: function Create ( k,n : positive; p : List ) return Faces is
! 54:
! 55: res : Faces;
! 56:
! 57: begin
! 58: if k > n
! 59: then return res;
! 60: else
! 61: declare
! 62: m : constant natural := Length_Of(p);
! 63: pts : VecVec(1..m) := Shallow_Create(p);
! 64: res_last : Faces := res;
! 65: begin
! 66: if k = 1
! 67: then
! 68: declare
! 69: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
! 70: f : Face := Create_Edge(pts,i,j);
! 71: begin
! 72: Append(res,res_last,f); cont := true;
! 73: end Append_Edge;
! 74: procedure Enum_Edges is new Enumerate_Edges(Append_Edge);
! 75: begin
! 76: Enum_Edges(pts);
! 77: end;
! 78: else
! 79: declare
! 80: procedure Append_Face ( fa : in Vector; cont : out boolean ) is
! 81: f : Face := Create_Face(pts,fa);
! 82: begin
! 83: Append(res,res_last,f); cont := true;
! 84: end Append_Face;
! 85: procedure Enum_Faces is new Enumerate_Faces(Append_Face);
! 86: begin
! 87: Enum_Faces(k,pts);
! 88: end;
! 89: end if;
! 90: return res;
! 91: end;
! 92: end if;
! 93: end Create;
! 94:
! 95: function Create ( k,n : positive; p : List; x : Vector ) return Faces is
! 96:
! 97: res : Faces;
! 98:
! 99: begin
! 100: if k > n
! 101: then return res;
! 102: else
! 103: declare
! 104: m : constant natural := Length_Of(p);
! 105: pts : VecVec(1..m) := Shallow_Create(p);
! 106: res_last : Faces := res;
! 107: begin
! 108: Move_to_Front(pts,x);
! 109: if k = 1
! 110: then
! 111: declare
! 112: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
! 113: f : Face;
! 114: begin
! 115: if i = pts'first
! 116: then f := Create_Edge(pts,i,j);
! 117: Append(res,res_last,f);
! 118: cont := true;
! 119: else cont := false;
! 120: end if;
! 121: end Append_Edge;
! 122: procedure Enum_Edges is new Enumerate_Edges(Append_Edge);
! 123: begin
! 124: Enum_Edges(pts);
! 125: end;
! 126: else
! 127: declare
! 128: procedure Append_Face ( fa : in Vector; cont : out boolean ) is
! 129: f : Face;
! 130: begin
! 131: if fa(fa'first) = pts'first
! 132: then f := Create_Face(pts,fa);
! 133: Append(res,res_last,f);
! 134: cont := true;
! 135: else cont := false;
! 136: end if;
! 137: end Append_Face;
! 138: procedure Enum_Faces is new Enumerate_Faces(Append_Face);
! 139: begin
! 140: Enum_Faces(k,pts);
! 141: end;
! 142: end if;
! 143: return res;
! 144: end;
! 145: end if;
! 146: end Create;
! 147:
! 148: function Create_Lower ( k,n : positive; p : List ) return Faces is
! 149:
! 150: res : Faces;
! 151:
! 152: begin
! 153: if k > n
! 154: then return res;
! 155: else
! 156: declare
! 157: m : constant natural := Length_Of(p);
! 158: pts : VecVec(1..m) := Shallow_Create(p);
! 159: res_last : Faces := res;
! 160: begin
! 161: if k = 1
! 162: then
! 163: declare
! 164: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
! 165: f : Face := Create_Edge(pts,i,j);
! 166: begin
! 167: Append(res,res_last,f); cont := true;
! 168: end Append_Edge;
! 169: procedure Enum_Edges is new Enumerate_Lower_Edges(Append_Edge);
! 170: begin
! 171: Enum_Edges(pts);
! 172: end;
! 173: else
! 174: declare
! 175: procedure Append_Face ( fa : in Vector; cont : out boolean ) is
! 176: f : Face := Create_Face(pts,fa);
! 177: begin
! 178: Append(res,res_last,f); cont := true;
! 179: end Append_Face;
! 180: procedure Enum_Faces is new Enumerate_Lower_Faces(Append_Face);
! 181: begin
! 182: Enum_Faces(k,pts);
! 183: end;
! 184: end if;
! 185: return res;
! 186: end;
! 187: end if;
! 188: end Create_Lower;
! 189:
! 190: function Create_Lower ( k,n : positive; p : List; x : Vector )
! 191: return Faces is
! 192:
! 193: res : Faces;
! 194:
! 195: begin
! 196: if k > n
! 197: then return res;
! 198: else
! 199: declare
! 200: m : constant natural := Length_Of(p);
! 201: pts : VecVec(1..m) := Shallow_Create(p);
! 202: res_last : Faces := res;
! 203: begin
! 204: Move_to_Front(pts,x);
! 205: if k = 1
! 206: then
! 207: declare
! 208: procedure Append_Edge ( i,j : in natural; cont : out boolean ) is
! 209: f : Face := Create_Edge(pts,i,j);
! 210: begin
! 211: if i = pts'first
! 212: then f := Create_Edge(pts,i,j);
! 213: Append(res,res_last,f);
! 214: cont := true;
! 215: else cont := false;
! 216: end if;
! 217: end Append_Edge;
! 218: procedure Enum_Edges is new Enumerate_Lower_Edges(Append_Edge);
! 219: begin
! 220: Enum_Edges(pts);
! 221: end;
! 222: else
! 223: declare
! 224: procedure Append_Face ( fa : in Vector; cont : out boolean ) is
! 225: f : Face;
! 226: begin
! 227: if fa(fa'first) = pts'first
! 228: then f := Create_Face(pts,fa);
! 229: Append(res,res_last,f);
! 230: cont := true;
! 231: else cont := false;
! 232: end if;
! 233: end Append_Face;
! 234: procedure Enum_Faces is new Enumerate_Lower_Faces(Append_Face);
! 235: begin
! 236: Enum_Faces(k,pts);
! 237: end;
! 238: end if;
! 239: return res;
! 240: end;
! 241: end if;
! 242: end Create_Lower;
! 243:
! 244: procedure Construct ( first : in out Faces; fs : in Faces ) is
! 245:
! 246: tmp : Faces := fs;
! 247:
! 248: begin
! 249: while not Is_Null(tmp) loop
! 250: Construct(Head_Of(tmp),first);
! 251: tmp := Tail_Of(tmp);
! 252: end loop;
! 253: end Construct;
! 254:
! 255: procedure Copy ( f1 : in Face; f2 : in out Face ) is
! 256: begin
! 257: Deep_Clear(f2);
! 258: f2 := new VecVec(f2'range);
! 259: for i in f2'range loop
! 260: f2(i) := new Standard_Integer_Vectors.Vector'(f1(i).all);
! 261: end loop;
! 262: end Copy;
! 263:
! 264: procedure Deep_Copy ( f1 : in Faces; f2 : in out Faces ) is
! 265:
! 266: tmp,last : Faces;
! 267:
! 268: begin
! 269: Deep_Clear(f2);
! 270: tmp := f1;
! 271: while not Is_Null(tmp) loop
! 272: declare
! 273: face1 : Face := Head_Of(tmp);
! 274: face2 : Face := new VecVec(face1'range);
! 275: begin
! 276: for i in face2'range loop
! 277: face2(i) := new Standard_Integer_Vectors.Vector'(face1(i).all);
! 278: end loop;
! 279: Append(f2,last,face2);
! 280: end;
! 281: tmp := Tail_Of(tmp);
! 282: end loop;
! 283: end Deep_Copy;
! 284:
! 285: -- SELECTORS :
! 286:
! 287: function Is_Equal ( f1,f2 : Face ) return boolean is
! 288:
! 289: found : boolean;
! 290:
! 291: begin
! 292: for i in f1'range loop
! 293: found := false;
! 294: for j in f2'range loop
! 295: found := Equal(f1(i).all,f2(j).all);
! 296: exit when found;
! 297: end loop;
! 298: if not found
! 299: then return false;
! 300: end if;
! 301: end loop;
! 302: return true;
! 303: end Is_Equal;
! 304:
! 305: function Is_In ( f : Face; x : Vector ) return boolean is
! 306: begin
! 307: for i in f'range loop
! 308: if f(i).all = x
! 309: then return true;
! 310: end if;
! 311: end loop;
! 312: return false;
! 313: end Is_In;
! 314:
! 315: function Is_In ( fs : Faces; f : Face ) return boolean is
! 316:
! 317: tmp : Faces := fs;
! 318:
! 319: begin
! 320: while not Is_Null(tmp) loop
! 321: if Is_Equal(f,Head_Of(tmp))
! 322: then return true;
! 323: else tmp := Tail_Of(tmp);
! 324: end if;
! 325: end loop;
! 326: return false;
! 327: end Is_In;
! 328:
! 329: function Extract_Faces ( fs : Faces; x : Vector ) return Faces is
! 330:
! 331: res,res_last,tmp : Faces;
! 332:
! 333: begin
! 334: tmp := fs;
! 335: while not Is_Null(tmp) loop
! 336: declare
! 337: f : Face := Head_Of(tmp);
! 338: begin
! 339: if Is_In(f,x)
! 340: then Append(res,res_last,f);
! 341: end if;
! 342: end;
! 343: tmp := Tail_Of(tmp);
! 344: end loop;
! 345: return res;
! 346: end Extract_Faces;
! 347:
! 348: -- DESTRUCTORS :
! 349:
! 350: procedure Deep_Clear ( f : in out Face ) is
! 351: begin
! 352: if f /= null
! 353: then for i in f'range loop
! 354: Clear(f(i));
! 355: end loop;
! 356: end if;
! 357: Shallow_Clear(f);
! 358: end Deep_Clear;
! 359:
! 360: procedure Shallow_Clear ( f : in out Face ) is
! 361: begin
! 362: if f /= null
! 363: then Clear(f.all);
! 364: end if;
! 365: end Shallow_Clear;
! 366:
! 367: procedure Deep_Clear ( fa : in out Face_Array ) is
! 368: begin
! 369: for i in fa'range loop
! 370: Deep_Clear(fa(i));
! 371: end loop;
! 372: end Deep_Clear;
! 373:
! 374: procedure Shallow_Clear ( fa : in out Face_Array ) is
! 375: begin
! 376: for i in fa'range loop
! 377: Shallow_Clear(fa(i));
! 378: end loop;
! 379: end Shallow_Clear;
! 380:
! 381: procedure Deep_Clear ( fs : in out Faces ) is
! 382:
! 383: tmp : Faces := fs;
! 384:
! 385: begin
! 386: while not Is_Null(tmp) loop
! 387: declare
! 388: f : Face := Head_Of(tmp);
! 389: begin
! 390: Deep_Clear(f);
! 391: end;
! 392: tmp := Tail_Of(tmp);
! 393: end loop;
! 394: Lists_of_Faces.Clear(Lists_of_Faces.List(fs));
! 395: end Deep_Clear;
! 396:
! 397: procedure Shallow_Clear ( fs : in out Faces ) is
! 398:
! 399: tmp : Faces := fs;
! 400:
! 401: begin
! 402: Lists_of_Faces.Clear(Lists_of_Faces.List(fs));
! 403: end Shallow_Clear;
! 404:
! 405: procedure Deep_Clear ( afs : in out Array_of_Faces ) is
! 406: begin
! 407: for i in afs'range loop
! 408: Deep_Clear(afs(i));
! 409: end loop;
! 410: end Deep_Clear;
! 411:
! 412: procedure Shallow_Clear ( afs : in out Array_of_Faces ) is
! 413: begin
! 414: for i in afs'range loop
! 415: Shallow_Clear(afs(i));
! 416: end loop;
! 417: end Shallow_Clear;
! 418:
! 419: end Integer_Faces_of_Polytope;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to integer_faces_of_polytope.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 / Supports