Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Stalift/normal_cone_intersections.adb, Revision 1.1
1.1 ! maekawa 1: with Inner_Normal_Cones; use Inner_Normal_Cones;
! 2:
! 3: package body Normal_Cone_Intersections is
! 4:
! 5: -- AUXILIARY :
! 6:
! 7: function Get ( l : List; i : natural ) return Vector is
! 8:
! 9: -- DESCRIPTION :
! 10: -- Returns the ith point vector in the list.
! 11:
! 12: tmp : List := l;
! 13: cnt : natural := 0;
! 14: nll : Vector(0..0) := (0..0 => 0);
! 15:
! 16: begin
! 17: while not Is_Null(tmp) loop
! 18: cnt := cnt + 1;
! 19: if cnt = i
! 20: then return Head_Of(tmp).all;
! 21: end if;
! 22: tmp := Tail_Of(tmp);
! 23: end loop;
! 24: return nll;
! 25: end Get;
! 26:
! 27: -- CONSTRUCTORS :
! 28:
! 29: function Number_of_Cones ( l : Array_of_Lists; i : natural )
! 30: return natural is
! 31:
! 32: res : natural := 0;
! 33:
! 34: begin
! 35: for j in l'range loop
! 36: if j /= i
! 37: then res := res + Length_Of(l(j));
! 38: end if;
! 39: end loop;
! 40: return res;
! 41: end Number_of_Cones;
! 42:
! 43: function Lengths ( l : Array_of_Lists; i : natural ) return Vector is
! 44:
! 45: res : Vector(l'range);
! 46:
! 47: begin
! 48: res(res'first) := 1;
! 49: for j in l'first..(i-1) loop
! 50: res(j+1) := res(j) + Length_Of(l(j));
! 51: end loop;
! 52: for j in (i+1)..l'last loop
! 53: res(j) := res(j-1) + Length_Of(l(j));
! 54: end loop;
! 55: return res;
! 56: end Lengths;
! 57:
! 58: function Create ( l : Array_of_Lists; g : List; i : natural )
! 59: return Intersection_Matrix is
! 60:
! 61: n : constant natural := l'length - 1;
! 62: m : constant natural := Length_Of(g);
! 63: ll : constant Vector := Lengths(l,i);
! 64: nc : constant natural := ll(ll'last)-1;
! 65: res : Intersection_Matrix(n,m,nc);
! 66:
! 67: begin
! 68: res.sv := ll(ll'first..ll'last-1);
! 69: for j in l'range loop
! 70: if j /= i
! 71: then
! 72: declare
! 73: ind : natural := j;
! 74: tmpl : List := l(j);
! 75: cntl : natural := 0;
! 76: begin
! 77: if ind > i
! 78: then ind := ind - 1;
! 79: end if;
! 80: while not Is_Null(tmpl) loop
! 81: declare
! 82: cone : constant Matrix
! 83: := Inner_Normal_Cone(l(j),Head_Of(tmpl).all);
! 84: tmpg : List := g;
! 85: cntg,sum : natural := 0;
! 86: begin
! 87: -- put_line("The inequalities of the normal cone : "); put(cone);
! 88: while not Is_Null(tmpg) loop
! 89: cntg := cntg + 1;
! 90: -- put(" "); put(Head_Of(tmpg).all);
! 91: if Satisfies(cone,Head_Of(tmpg).all)
! 92: then res.im(cntg,res.sv(ind)+cntl) := 1; sum := sum + 1;
! 93: -- put_line(" satisfies.");
! 94: else res.im(cntg,res.sv(ind)+cntl) := 0;
! 95: -- put_line(" does not satisfy.");
! 96: end if;
! 97: tmpg := Tail_Of(tmpg);
! 98: end loop;
! 99: res.im(0,res.sv(ind)+cntl) := sum;
! 100: end;
! 101: tmpl := Tail_Of(tmpl);
! 102: cntl := cntl + 1;
! 103: end loop;
! 104: end;
! 105: end if;
! 106: end loop;
! 107: return res;
! 108: end Create;
! 109:
! 110: -- ELEMENTARY SELECTORS :
! 111:
! 112: function Is_In ( ima : Intersection_Matrix; i,j,k : natural )
! 113: return boolean is
! 114: begin
! 115: if ima.im(i,ima.sv(j)+k-1) = 1
! 116: then return true;
! 117: else return false;
! 118: end if;
! 119: end Is_In;
! 120:
! 121: function Maximal_Column ( ima : Intersection_Matrix ) return natural is
! 122:
! 123: res : natural := ima.im'first(2);
! 124: max : natural := ima.im(0,ima.im'first(2));
! 125:
! 126: begin
! 127: for j in ima.im'first(2)+1..ima.im'last(2) loop
! 128: if ima.im(0,j) > max
! 129: then max := ima.im(0,j); res := j;
! 130: end if;
! 131: end loop;
! 132: return res;
! 133: end Maximal_Column;
! 134:
! 135: function Component ( ima : Intersection_Matrix; column : natural )
! 136: return natural is
! 137: begin
! 138: for i in ima.sv'range loop
! 139: if ima.sv(i) > column
! 140: then return i-1;
! 141: end if;
! 142: end loop;
! 143: return ima.sv'last;
! 144: end Component;
! 145:
! 146: function Length ( ima : Intersection_Matrix; i : natural ) return natural is
! 147: begin
! 148: if i < ima.sv'last
! 149: then return (ima.sv(i+1) - ima.sv(i));
! 150: else return (ima.im'last(2) - ima.sv(i) + 1);
! 151: end if;
! 152: end Length;
! 153:
! 154: function Row_Sum ( ima : Intersection_Matrix; i,j : natural )
! 155: return natural is
! 156:
! 157: res : natural := 0;
! 158: lst : natural;
! 159:
! 160: begin
! 161: if j < ima.sv'last
! 162: then lst := ima.sv(j+1)-1;
! 163: else lst := ima.im'last(2);
! 164: end if;
! 165: for k in ima.sv(j)..lst loop
! 166: res := res + ima.im(i,k);
! 167: end loop;
! 168: return res;
! 169: end Row_Sum;
! 170:
! 171: -- ENUMERATING COMPLEMENTARY COLUMNS :
! 172:
! 173: procedure Complementary_Columns ( ima : in Intersection_Matrix ) is
! 174:
! 175: acc : Standard_Integer_Vectors.Vector(ima.sv'range) := (ima.sv'range => 0);
! 176: -- acc(j) = 0 if no cone from jth component has been chosen yet,
! 177: -- = k if kth cone from jth component is selected.
! 178:
! 179: continue : boolean := true;
! 180:
! 181: function Is_In ( acc : in Vector; i : in natural ) return boolean is
! 182:
! 183: -- DESCRIPTION :
! 184: -- Returns true if the ith generator already belongs to one of the
! 185: -- chosen cones in acc.
! 186:
! 187: begin
! 188: for j in acc'range loop -- enumerate the components
! 189: if acc(j) /= 0 -- acc(j) = cone selected
! 190: then if Is_In(ima,i,j,acc(j)) -- is in selected cone ?
! 191: then return true;
! 192: end if;
! 193: end if;
! 194: end loop;
! 195: return false;
! 196: end Is_In;
! 197:
! 198: procedure Select_Columns ( i : in natural ) is
! 199:
! 200: -- DESCRIPTION :
! 201: -- Selects all columns such that the ith generator belongs to the
! 202: -- collection of columns.
! 203:
! 204: lst : natural;
! 205:
! 206: begin
! 207: if i > ima.im'last(1)
! 208: then Process(acc,continue);
! 209: else if Is_In(acc,i)
! 210: then Select_Columns(i+1);
! 211: else for j in acc'range loop
! 212: if acc(j) = 0
! 213: then if j < ima.sv'last
! 214: then lst := ima.sv(j+1)-1;
! 215: else lst := ima.im'last(2);
! 216: end if;
! 217: for k in ima.sv(j)..lst loop
! 218: if ima.im(i,k) = 1
! 219: then acc(j) := k-ima.sv(j)+1;
! 220: Select_Columns(i+1);
! 221: acc(j) := 0;
! 222: end if;
! 223: exit when not continue;
! 224: end loop;
! 225: end if;
! 226: exit when not continue;
! 227: end loop;
! 228: end if;
! 229: end if;
! 230: end Select_Columns;
! 231:
! 232: begin
! 233: Select_Columns(1);
! 234: end Complementary_Columns;
! 235:
! 236: function Partition ( ima : Intersection_Matrix; cols : Vector; g : List )
! 237: return Array_of_Lists is
! 238:
! 239: res,res_last : Array_of_Lists(cols'range);
! 240: tmp : List := g;
! 241:
! 242: procedure Search_and_Update ( v : in Vector; i : in natural ) is
! 243:
! 244: -- DESCRIPTION :
! 245: -- Given the ith generator v from the list g, this procedures searches
! 246: -- for the first cone that contains it and updates the partition.
! 247:
! 248: found : boolean := false;
! 249:
! 250: begin
! 251: for j in cols'range loop
! 252: if (cols(j) /= 0) and then Is_In(ima,i,j,cols(j))
! 253: then found := true;
! 254: Append(res(j),res_last(j),v);
! 255: end if;
! 256: exit when found;
! 257: end loop;
! 258: end Search_and_Update;
! 259:
! 260: begin
! 261: for i in ima.im'first(1)+1..ima.im'last(1) loop
! 262: Search_and_Update(Head_Of(tmp).all,i);
! 263: tmp := Tail_Of(tmp);
! 264: end loop;
! 265: return res;
! 266: end Partition;
! 267:
! 268: function Partition_in_Union ( partg,points : Array_of_Lists; i : natural;
! 269: cols : Vector ) return boolean is
! 270:
! 271: -- ALGORITHM : lexicographic enumeration of all couples of lists in partg,
! 272: -- with each time a check whether it belongs to the union of
! 273: -- the normal cones as given by the set of complementary columns.
! 274:
! 275: function Index ( j : natural ) return natural is
! 276: begin
! 277: if j < i
! 278: then return j;
! 279: else return j+1;
! 280: end if;
! 281: end Index;
! 282:
! 283: begin
! 284: for k1 in partg'range loop
! 285: if not Is_Null(partg(k1))
! 286: then
! 287: for k2 in (k1+1)..partg'last loop
! 288: if not Is_Null(partg(k2))
! 289: then
! 290: declare
! 291: ind1 : constant natural := Index(k1);
! 292: ind2 : constant natural := Index(k2);
! 293: x1 : constant Vector := Get(points(ind1),cols(k1));
! 294: x2 : constant Vector := Get(points(ind2),cols(k2));
! 295: ic1 : constant Matrix := Inner_Normal_Cone(points(ind1),x1);
! 296: ic2 : constant Matrix := Inner_Normal_Cone(points(ind2),x2);
! 297: begin
! 298: if not In_Union(partg(k1),partg(k2),ic1,ic2)
! 299: then return false;
! 300: end if;
! 301: end;
! 302: end if;
! 303: end loop;
! 304: end if;
! 305: end loop;
! 306: return true;
! 307: end Partition_in_Union;
! 308:
! 309: function Contained_in_Union
! 310: ( l : Array_of_Lists; i : natural; g : List;
! 311: ima : Intersection_Matrix; cols : Vector ) return boolean is
! 312:
! 313: p : Array_of_Lists(cols'range) := Partition(ima,cols,g);
! 314: res : boolean := Partition_in_Union(p,l,i,cols);
! 315:
! 316: begin
! 317: Deep_Clear(p);
! 318: return res;
! 319: end Contained_in_Union;
! 320:
! 321: -- FINAL TARGET ROUTINE :
! 322:
! 323: function Contained_in_Union
! 324: ( l : Array_of_Lists; i : natural; g : List;
! 325: ima : Intersection_Matrix ) return boolean is
! 326:
! 327: res : boolean := false;
! 328: continue : boolean := true;
! 329:
! 330: procedure Examin_Selection ( cols : in Vector; continue : out boolean ) is
! 331: begin
! 332: res := Contained_in_Union(l,i,g,ima,cols);
! 333: continue := not res;
! 334: end Examin_Selection;
! 335: procedure Enumerate_Complementary_Columns is
! 336: new Complementary_Columns(Examin_Selection);
! 337:
! 338: begin
! 339: Enumerate_Complementary_Columns(ima);
! 340: return res;
! 341: end Contained_in_Union;
! 342:
! 343: end Normal_Cone_Intersections;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to normal_cone_intersections.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