Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Dynlift/cayley_embedding.adb, Revision 1.1
1.1 ! maekawa 1: with Standard_Integer_VecVecs; use Standard_Integer_VecVecs;
! 2:
! 3: package body Cayley_Embedding is
! 4:
! 5: -- AUXILIARIES :
! 6:
! 7: function Is_Good_Point
! 8: ( cnt,n : natural; pt : Link_to_Vector ) return boolean is
! 9:
! 10: -- DESCRIPTION :
! 11: -- Returns true if the point pt is a point of the type indicated
! 12: -- by the parameter cnt, i.e. whether it belongs to the polytope
! 13: -- placed on the vertex with number cnt.
! 14:
! 15: goodpoint : boolean;
! 16:
! 17: begin
! 18: if cnt = 0
! 19: then goodpoint := true;
! 20: for l in pt'first..pt'last-n-1 loop
! 21: if pt(l) /= 0
! 22: then goodpoint := false;
! 23: end if;
! 24: exit when not goodpoint;
! 25: end loop;
! 26: else goodpoint := (pt(cnt) = 1);
! 27: end if;
! 28: return goodpoint;
! 29: end Is_Good_Point;
! 30:
! 31: procedure Project ( n : natural; v : in out Link_to_Vector ) is
! 32:
! 33: -- DESCRIPTION :
! 34: -- After application, v points to a vector of length n+1.
! 35:
! 36: newv : Link_to_Vector;
! 37:
! 38: begin
! 39: newv := new Vector(1..n+1);
! 40: newv(1..n+1) := v(v'last-n..v'last);
! 41: Clear(v);
! 42: v := newv;
! 43: end Project;
! 44:
! 45: -- TARGET ROUTINES :
! 46:
! 47: function Embedding_Before_Lifting
! 48: ( supports : Array_of_Lists ) return List is
! 49:
! 50: tmp,res,res_last : List;
! 51: r1 : constant natural := supports'length-1;
! 52: pt : Link_to_Vector;
! 53: cnt : natural := 0;
! 54:
! 55: begin
! 56: for k in supports'range loop
! 57: tmp := supports(k);
! 58: while not Is_Null(tmp) loop
! 59: pt := Head_Of(tmp);
! 60: declare
! 61: npt : Vector(pt'first..pt'last+r1);
! 62: begin
! 63: npt(npt'last-pt'length+1..npt'last) := pt.all;
! 64: npt(npt'first..npt'first+r1-1) := (npt'first..npt'first+r1-1 => 0);
! 65: if cnt > 0
! 66: then npt(cnt) := 1;
! 67: end if;
! 68: Append(res,res_last,npt);
! 69: end;
! 70: tmp := Tail_Of(tmp);
! 71: end loop;
! 72: cnt := cnt + 1;
! 73: end loop;
! 74: return res;
! 75: end Embedding_Before_Lifting;
! 76:
! 77: function Extract ( vtp,n : natural; pts : VecVec ) return List is
! 78:
! 79: res,res_last : List;
! 80:
! 81: begin
! 82: for k in pts'range loop
! 83: if Is_Good_Point(vtp,n,pts(k))
! 84: then Append(res,res_last,pts(k).all);
! 85: end if;
! 86: end loop;
! 87: return res;
! 88: end Extract;
! 89:
! 90: function Extract ( vtp,n : natural; pts : List ) return List is
! 91:
! 92: -- DESCRIPTION :
! 93: -- Extracts the points out of the list that are of the type
! 94: -- indicated by vtp.
! 95:
! 96: tmp,res,res_last : List;
! 97: pt : Link_to_Vector;
! 98:
! 99: begin
! 100: tmp := pts;
! 101: while not Is_Null(tmp) loop
! 102: pt := Head_Of(tmp);
! 103: if Is_Good_Point(vtp,n,pt)
! 104: then Append(res,res_last,pt.all);
! 105: end if;
! 106: tmp := Tail_Of(tmp);
! 107: end loop;
! 108: return res;
! 109: end Extract;
! 110:
! 111: function Extract_Mixed_Cell
! 112: ( n : natural; mix : Vector; s : Simplex ) return Mixed_Cell is
! 113:
! 114: res : Mixed_Cell;
! 115: work : Array_of_Lists(mix'range);
! 116: cnt : natural := 0;
! 117: iscell : boolean;
! 118: pts : constant VecVec := Vertices(s);
! 119:
! 120: begin
! 121: for k in mix'range loop
! 122: work(k) := Extract(cnt,n,pts);
! 123: iscell := (Length_Of(work(k)) = mix(k)+1);
! 124: exit when not iscell;
! 125: cnt := cnt + 1;
! 126: end loop;
! 127: if iscell
! 128: then res.pts := new Array_of_Lists'(work);
! 129: res.nor := new vector'(Normal(s));
! 130: else Deep_Clear(work);
! 131: end if;
! 132: return res;
! 133: end Extract_Mixed_Cell;
! 134:
! 135: function Extract_Mixed_Cells
! 136: ( n : natural; mix : Vector; t : Triangulation )
! 137: return Mixed_Subdivision is
! 138:
! 139: res,res_last : Mixed_Subdivision;
! 140: s : Simplex;
! 141: tmp : Triangulation;
! 142:
! 143: begin
! 144: tmp := t;
! 145: while not Is_Null(tmp) loop
! 146: s := Head_Of(tmp);
! 147: declare
! 148: mic : Mixed_Cell := Extract_Mixed_Cell(n,mix,s);
! 149: begin
! 150: if mic.nor /= null
! 151: then Append(res,res_last,mic);
! 152: end if;
! 153: end;
! 154: tmp := Tail_Of(tmp);
! 155: end loop;
! 156: return res;
! 157: end Extract_Mixed_Cells;
! 158:
! 159: function Extract_non_Flat_Mixed_Cells
! 160: ( n : natural; mix : Vector; t : Triangulation )
! 161: return Mixed_Subdivision is
! 162:
! 163: res,res_last : Mixed_Subdivision;
! 164: s : Simplex;
! 165: tmp : Triangulation;
! 166:
! 167: begin
! 168: tmp := t;
! 169: while not Is_Null(tmp) loop
! 170: s := Head_Of(tmp);
! 171: exit when Is_Flat(s);
! 172: declare
! 173: mic : Mixed_Cell := Extract_Mixed_Cell(n,mix,s);
! 174: begin
! 175: if mic.nor /= null
! 176: then Append(res,res_last,mic);
! 177: end if;
! 178: end;
! 179: tmp := Tail_Of(tmp);
! 180: end loop;
! 181: return res;
! 182: end Extract_non_Flat_Mixed_Cells;
! 183:
! 184: procedure Deflate ( n : natural; l : in out List ) is
! 185:
! 186: tmp : List := l;
! 187:
! 188: begin
! 189: while not Is_Null(tmp) loop
! 190: declare
! 191: pt : Link_to_Vector := Head_Of(tmp);
! 192: begin
! 193: Project(n,pt);
! 194: Set_Head(tmp,pt);
! 195: end;
! 196: tmp := Tail_Of(tmp);
! 197: end loop;
! 198: end Deflate;
! 199:
! 200: procedure Deflate ( n : natural; mic : in out Mixed_Cell ) is
! 201: begin
! 202: Project(n,mic.nor);
! 203: for k in mic.pts'range loop
! 204: Deflate(n,mic.pts(k));
! 205: end loop;
! 206: end Deflate;
! 207:
! 208: procedure Deflate ( n : natural; mixsub : in out Mixed_Subdivision ) is
! 209:
! 210: tmp : Mixed_Subdivision := mixsub;
! 211:
! 212: begin
! 213: while not Is_Null(tmp) loop
! 214: declare
! 215: mic : Mixed_Cell := Head_Of(tmp);
! 216: begin
! 217: Deflate(n,mic);
! 218: Set_Head(tmp,mic);
! 219: end;
! 220: tmp := Tail_Of(tmp);
! 221: end loop;
! 222: end Deflate;
! 223:
! 224: end Cayley_Embedding;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to cayley_embedding.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 / Dynlift