Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Dynlift/common_faces_of_polytope.adb, Revision 1.1
1.1 ! maekawa 1: with Standard_Integer_Vectors; use Standard_Integer_Vectors;
! 2: with Standard_Integer_VecVecs; use Standard_Integer_VecVecs;
! 3:
! 4: package body Common_Faces_of_Polytope is
! 5:
! 6: function Have_Common_Point ( l : List; v : VecVec ) return boolean is
! 7:
! 8: -- DESCRIPTION :
! 9: -- Returns true if at least one point in v belongs to the list l.
! 10:
! 11: begin
! 12: for i in v'range loop
! 13: if Is_In(l,v(i).all)
! 14: then return true;
! 15: end if;
! 16: end loop;
! 17: return false;
! 18: end Have_Common_Point;
! 19:
! 20: function Is_Neighbor1 ( l : List; fc : Face ) return boolean is
! 21: begin
! 22: return Have_Common_Point(l,fc.all);
! 23: end Is_Neighbor1;
! 24:
! 25: function Is_Neighbor ( l : List; fc : Face ) return boolean is
! 26:
! 27: cntnotin : natural := 0;
! 28: -- counts the points in the face fc that are not in the list l
! 29:
! 30: begin
! 31: for i in fc'range loop
! 32: if not Is_In(l,fc(i).all)
! 33: then cntnotin := cntnotin + 1;
! 34: if cntnotin > 1
! 35: then return false;
! 36: end if;
! 37: end if;
! 38: end loop;
! 39: return true;
! 40: end Is_Neighbor;
! 41:
! 42: function Neighboring_Faces ( mic : Mixed_Cell; fs : Faces; i : natural )
! 43: return Faces is
! 44:
! 45: tmp : Faces := fs;
! 46: res,res_last : Faces;
! 47:
! 48: begin
! 49: while not Is_Null(tmp) loop
! 50: declare
! 51: fc : Face := Head_Of(tmp);
! 52: begin
! 53: if Is_Neighbor(mic.pts(i),fc)
! 54: then Append(res,res_last,fc);
! 55: end if;
! 56: tmp := Tail_Of(tmp);
! 57: end;
! 58: end loop;
! 59: return res;
! 60: end Neighboring_Faces;
! 61:
! 62: function Neighboring_Faces ( mic : Mixed_Cell; afs : Array_of_Faces )
! 63: return Array_of_Faces is
! 64:
! 65: res : Array_of_Faces(afs'range);
! 66:
! 67: begin
! 68: for i in res'range loop
! 69: res(i) := Neighboring_Faces(mic,afs(i),i);
! 70: end loop;
! 71: return res;
! 72: end Neighboring_Faces;
! 73:
! 74: end Common_Faces_of_Polytope;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>