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