Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Stalift/contributions_to_mixed_volume.adb, Revision 1.1
1.1 ! maekawa 1: with Standard_Integer_VecVecs; use Standard_Integer_VecVecs;
! 2: with Standard_Integer_Matrices; use Standard_Integer_Matrices;
! 3: with Standard_Integer_Linear_Solvers; use Standard_Integer_Linear_Solvers;
! 4: with Lists_of_Integer_Vectors; use Lists_of_Integer_Vectors;
! 5: with Vertices; use Vertices;
! 6: with Inner_Normal_Cones; use Inner_Normal_Cones;
! 7: with Normal_Cone_Intersections; use Normal_Cone_Intersections;
! 8:
! 9: package body Contributions_to_Mixed_Volume is
! 10:
! 11: -- AUXILIAIRIES TO CONSTRUCT THE FACETS :
! 12:
! 13: procedure Copy_Remove ( l : in out List; x : in Vector ) is
! 14:
! 15: -- DESCRIPTION :
! 16: -- Replaces the list by a copy of it, without the point x.
! 17:
! 18: tmp,res,res_last : List;
! 19:
! 20: begin
! 21: tmp := l;
! 22: while not Is_Null(tmp) loop
! 23: declare
! 24: pt : Link_to_Vector := Head_Of(tmp);
! 25: begin
! 26: if not Equal(pt.all,x)
! 27: then Append(res,res_last,pt.all);
! 28: end if;
! 29: end;
! 30: tmp := Tail_Of(tmp);
! 31: end loop;
! 32: Copy(res,l); Deep_Clear(l);
! 33: end Copy_Remove;
! 34:
! 35: function Vertex_Points ( l : Array_of_Lists ) return Array_of_Lists is
! 36:
! 37: -- DESCRIPTION :
! 38: -- returns for each list the list of the vertex points.
! 39:
! 40: res : Array_of_Lists(l'range);
! 41:
! 42: begin
! 43: for i in l'range loop
! 44: res(i) := Vertex_Points(l(i));
! 45: end loop;
! 46: return res;
! 47: end Vertex_Points;
! 48:
! 49: procedure Copy ( f1 : in Array_of_Faces; f2 : in out Array_of_Faces ) is
! 50:
! 51: -- DESCRIPTION :
! 52: -- Copies the array f1 into the array f2.
! 53:
! 54: begin
! 55: for i in f1'range loop
! 56: Deep_Copy(f1(i),f2(i));
! 57: end loop;
! 58: end Copy;
! 59:
! 60: function Create_Facets ( n : natural; l : List; x : Vector ) return Faces is
! 61:
! 62: -- DESCRIPTION :
! 63: -- Returns a list of all facets of conv(l), that all contain x.
! 64: -- First it will be checked whether x belongs to l or not.
! 65:
! 66: res : Faces;
! 67: wrk : List;
! 68: lx : Link_to_Vector;
! 69:
! 70: begin
! 71: if Is_In(l,x)
! 72: then res := Create(n-1,n,l,x);
! 73: else wrk := l;
! 74: lx := new Vector'(x);
! 75: Construct(lx,wrk);
! 76: res := Create(n-1,n,wrk,x);
! 77: end if;
! 78: return res;
! 79: end Create_Facets;
! 80:
! 81: function All_Facets ( n : natural; l : Array_of_Lists )
! 82: return Array_of_Faces is
! 83:
! 84: -- DESCRIPTION :
! 85: -- Returns all facets of all sets in l.
! 86:
! 87: res : Array_of_Faces(l'range);
! 88:
! 89: begin
! 90: for i in l'range loop
! 91: res(i) := Create(n-1,n,l(i));
! 92: end loop;
! 93: return res;
! 94: end All_Facets;
! 95:
! 96: -- DETERMINE ZERO CONTRIBUTION BASED ON INTERSECTION MATRIX :
! 97:
! 98: function Exhaustive_Zero_Contribution
! 99: ( pts : Array_of_Lists; g : List; i : natural ) return boolean is
! 100:
! 101: -- DESCRIPTION :
! 102: -- Creates an intersection matrix, based on the list of generators of
! 103: -- the normal cone of a points in the ith component of pts.
! 104:
! 105: res : boolean;
! 106: n1 : constant natural := pts'length - 1;
! 107: mg : constant natural := Length_Of(g);
! 108: nc : constant natural := Number_of_Cones(pts,i);
! 109: ima : Intersection_Matrix(n1,mg,nc);
! 110:
! 111: begin
! 112: ima := Create(pts,g,i);
! 113: return Contained_in_Union(pts,i,g,ima);
! 114: end Exhaustive_Zero_Contribution;
! 115:
! 116: -- THE CRITERION :
! 117:
! 118: function Simple_Zero_Contribution
! 119: ( pts : Array_of_Lists; x : Vector; i : natural )
! 120: return boolean is
! 121:
! 122: res : boolean := false;
! 123: g : List := Generators(pts(i),x);
! 124:
! 125: begin
! 126: for j in pts'range loop
! 127: if j /= i
! 128: then res := Contained_in_Cone(pts(j),g);
! 129: end if;
! 130: exit when res;
! 131: end loop;
! 132: Deep_Clear(g);
! 133: return res;
! 134: end Simple_Zero_Contribution;
! 135:
! 136: function Simple_Zero_Contribution
! 137: ( pts : Array_of_Lists; ifacets : Faces;
! 138: x : Vector; i : natural ) return boolean is
! 139:
! 140: g : List := Generators(pts(i),ifacets,x);
! 141: res : boolean := false;
! 142:
! 143: begin
! 144: for j in pts'range loop
! 145: if j /= i
! 146: then res := Contained_in_Cone(pts(j),g);
! 147: end if;
! 148: exit when res;
! 149: end loop;
! 150: Deep_Clear(g);
! 151: return res;
! 152: end Simple_Zero_Contribution;
! 153:
! 154: function Exhaustive_Zero_Contribution
! 155: ( pts : Array_of_Lists;
! 156: x : Vector; i : natural ) return boolean is
! 157:
! 158: n : constant natural := x'length;
! 159: res : boolean := false;
! 160:
! 161: begin
! 162: if Length_Of(pts(i)) > n
! 163: then declare
! 164: f : Faces := Create_Facets(n,pts(i),x);
! 165: begin
! 166: res := Exhaustive_Zero_Contribution(pts,f,x,i);
! 167: Clear(f);
! 168: end;
! 169: else declare
! 170: g : List := Generators(pts(i),x);
! 171: begin
! 172: res := Exhaustive_Zero_Contribution(pts,g,i);
! 173: end;
! 174: end if;
! 175: return res;
! 176: end Exhaustive_Zero_Contribution;
! 177:
! 178: function Exhaustive_Zero_Contribution
! 179: ( pts : Array_of_Lists; ifacets : Faces;
! 180: x : Vector; i : natural ) return boolean is
! 181:
! 182: g : List;
! 183:
! 184: begin
! 185: if not Is_Null(ifacets)
! 186: then g := Generators(pts(i),ifacets,x);
! 187: else g := Generators(pts(i),x);
! 188: end if;
! 189: return Exhaustive_Zero_Contribution(pts,g,i);
! 190: end Exhaustive_Zero_Contribution;
! 191:
! 192: -- SWEEPING THROUGH THE POINT LISTS :
! 193:
! 194: function Simple_Sweep ( pts : Array_of_Lists ) return Array_of_Lists is
! 195:
! 196: n : constant natural := Head_Of(pts(pts'first))'length;
! 197: afa : Array_of_Faces(pts'range) := All_Facets(n,pts);
! 198:
! 199: begin
! 200: return Simple_Sweep(pts,afa);
! 201: end Simple_Sweep;
! 202:
! 203: function Simple_Sweep ( pts : Array_of_Lists; facets : Array_of_Faces )
! 204: return Array_of_Lists is
! 205:
! 206: res,res_last,points : Array_of_Lists(pts'range);
! 207: -- wrkfacets : Array_of_Faces(facets'range);
! 208:
! 209: -- SAFETY MODE : checks whether mixed volume does not decrease
! 210: -- n : constant natural := pts'last;
! 211: -- mix : constant Vector := (1..n => 1);
! 212: -- mv : constant natural := Mixed_Volume(n,mix,pts);
! 213:
! 214: begin
! 215: -- Copy(facets,wrkfacets);
! 216: points := Vertex_Points(pts); -- instead of: Copy(pts,points);
! 217: for i in points'range loop
! 218: declare
! 219: tmp : constant VecVec := Shallow_Create(points(i));
! 220: begin
! 221: for j in tmp'range loop
! 222: declare
! 223: x : constant Vector := tmp(j).all;
! 224: -- f : Faces := Extract_Faces(wrkfacets(i),x);
! 225: begin
! 226: -- if not Simple_Zero_Contribution(points,f,x,i)
! 227: if not Simple_Zero_Contribution(points,x,i)
! 228: then Append(res(i),res_last(i),x);
! 229: else Remove(points(i),x);
! 230: -- SAFETY MODE :
! 231: -- if mv > Mixed_Volume(n,mix,points)
! 232: -- then put_line("BUG at points : "); put(points);
! 233: -- put("for the vector : "); put(x); new_line;
! 234: -- put(" at component "); put(i,1); new_line;
! 235: -- raise PROGRAM_ERROR;
! 236: -- end if;
! 237: -- Clear(wrkfacets(i));
! 238: -- wrkfacets(i) := Create(x'length-1,x'length,points(i));
! 239: end if;
! 240: end;
! 241: end loop;
! 242: end;
! 243: Copy(res(i),points(i));
! 244: end loop;
! 245: Deep_Clear(points);
! 246: return res;
! 247: end Simple_Sweep;
! 248:
! 249: function Exhaustive_Sweep ( pts : Array_of_Lists ) return Array_of_Lists is
! 250:
! 251: n : constant natural := Head_Of(pts(pts'first))'length;
! 252: afa : Array_of_Faces(pts'range) := All_Facets(n,pts);
! 253:
! 254: begin
! 255: return Exhaustive_Sweep(pts,afa);
! 256: end Exhaustive_Sweep;
! 257:
! 258: function Exhaustive_Sweep ( pts : Array_of_Lists; facets : Array_of_Faces )
! 259: return Array_of_Lists is
! 260:
! 261: res,res_last,points : Array_of_Lists(pts'range);
! 262: -- wrkfacets : Array_of_Faces(facets'range);
! 263:
! 264: -- SAFETY MODE : checks whether mixed volume does not decrease
! 265: -- n : constant natural := pts'last;
! 266: -- mix : constant Vector := (1..n => 1);
! 267: -- mv : constant natural := Mixed_Volume(n,mix,pts);
! 268:
! 269: begin
! 270: -- Copy(facets,wrkfacets);
! 271: points := Vertex_Points(pts); -- instead of: Copy(pts,points);
! 272: for i in points'range loop
! 273: declare
! 274: tmp : constant VecVec := Shallow_Create(points(i));
! 275: begin
! 276: for j in tmp'range loop
! 277: declare
! 278: x : constant Vector := tmp(j).all;
! 279: -- f : Faces := Extract_Faces(wrkfacets(i),x);
! 280: begin
! 281: -- if not Exhaustive_Zero_Contribution(points,f,x,i)
! 282: if not Exhaustive_Zero_Contribution(points,x,i)
! 283: then Append(res(i),res_last(i),x);
! 284: else Remove(points(i),x);
! 285: -- SAFETY MODE :
! 286: -- if mv > Mixed_Volume(n,mix,points)
! 287: -- then put_line("BUG at points : "); put(points);
! 288: -- put("for the vector : "); put(x); new_line;
! 289: -- put(" at component "); put(i,1); new_line;
! 290: -- raise PROGRAM_ERROR;
! 291: -- end if;
! 292: -- Clear(wrkfacets(i));
! 293: -- wrkfacets(i) := Create(x'length-1,x'length,points(i));
! 294: end if;
! 295: end;
! 296: end loop;
! 297: end;
! 298: Copy(res(i),points(i));
! 299: end loop;
! 300: Deep_Clear(points);
! 301: return res;
! 302: end Exhaustive_Sweep;
! 303:
! 304: end Contributions_to_Mixed_Volume;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to contributions_to_mixed_volume.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Stalift