Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Stalift/floating_mixed_subdivisions.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2: with Standard_Floating_Matrices; use Standard_Floating_Matrices;
! 3: with Floating_Support_Functions; use Floating_Support_Functions;
! 4:
! 5: package body Floating_Mixed_Subdivisions is
! 6:
! 7: -- CREATORS :
! 8:
! 9: function Create ( pts : Array_of_Lists; nor : Vector; tol : double_float )
! 10: return Mixed_Cell is
! 11:
! 12: res : Mixed_Cell;
! 13: sup : double_float;
! 14:
! 15: begin
! 16: res.nor := new Vector'(nor);
! 17: res.pts := new Array_of_Lists(pts'range);
! 18: for k in pts'range loop
! 19: sup := Minimal_Support(pts(k),nor);
! 20: res.pts(k) := Face(pts(k),nor,sup,tol);
! 21: end loop;
! 22: return res;
! 23: end Create;
! 24:
! 25: function Create ( pts : Array_of_Lists; nors : List; tol : double_float )
! 26: return Mixed_Subdivision is
! 27:
! 28: res,res_last : Mixed_Subdivision;
! 29: tmp : List := nors;
! 30:
! 31: begin
! 32: while not Is_Null(tmp) loop
! 33: Append(res,res_last,Create(pts,Head_Of(tmp).all,tol));
! 34: tmp := Tail_Of(tmp);
! 35: end loop;
! 36: return res;
! 37: end Create;
! 38:
! 39: function Create ( pts : Array_of_Lists; mixsub : Mixed_Subdivision;
! 40: tol : double_float ) return Mixed_Subdivision is
! 41:
! 42: tmp,res,res_last : Mixed_Subdivision;
! 43:
! 44: begin
! 45: tmp := mixsub;
! 46: while not Is_Null(tmp) loop
! 47: Append(res,res_last,Create(pts,Head_Of(tmp).nor.all,tol));
! 48: tmp := Tail_Of(tmp);
! 49: end loop;
! 50: return res;
! 51: end Create;
! 52:
! 53: procedure Update ( pts : in Array_of_Lists; nor : in Vector;
! 54: mixsub,mixsub_last : in out Mixed_Subdivision ) is
! 55:
! 56: -- DESCRIPTION :
! 57: -- Given a tuple of point sets and a normal,
! 58: -- the mixed subdivision will be updated.
! 59:
! 60: tmp : Mixed_Subdivision := mixsub;
! 61: done : boolean := false;
! 62:
! 63: begin
! 64: while not Is_Null(tmp) and not done loop
! 65: declare
! 66: mic : Mixed_Cell := Head_Of(tmp);
! 67: last : List;
! 68: begin
! 69: if Equal(mic.nor.all,nor)
! 70: then for k in mic.pts'range loop
! 71: last := mic.pts(k);
! 72: while not Is_Null(Tail_Of(last)) loop
! 73: last := Tail_Of(last);
! 74: end loop;
! 75: Deep_Concat_Diff(mic.pts(k),last,pts(k));
! 76: end loop;
! 77: Set_Head(tmp,mic);
! 78: done := true;
! 79: else tmp := Tail_Of(tmp);
! 80: end if;
! 81: end;
! 82: end loop;
! 83: if not done
! 84: then declare
! 85: mic : Mixed_Cell;
! 86: begin
! 87: mic.pts := new Array_of_Lists(pts'range);
! 88: Copy(pts,mic.pts.all);
! 89: mic.nor := new Standard_Floating_Vectors.Vector'(nor);
! 90: mic.sub := null;
! 91: Append(mixsub,mixsub_last,mic);
! 92: end;
! 93: end if;
! 94: end Update;
! 95:
! 96: -- CONSTRUCTORS :
! 97:
! 98: procedure Copy ( mic1 : in Mixed_Cell; mic2 : in out Mixed_Cell ) is
! 99: begin
! 100: Deep_Clear(mic2);
! 101: if mic1.nor /= null
! 102: then mic2.nor := new Standard_Floating_Vectors.Vector'(mic1.nor.all);
! 103: end if;
! 104: if mic1.pts /= null
! 105: then mic2.pts := new Array_of_Lists(mic1.pts'range);
! 106: Copy(mic1.pts.all,mic2.pts.all);
! 107: end if;
! 108: if mic1.sub /= null
! 109: then mic2.sub := new Mixed_Subdivision;
! 110: Copy(mic1.sub.all,mic2.sub.all);
! 111: end if;
! 112: end Copy;
! 113:
! 114: procedure Copy ( mixsub1 : in Mixed_Subdivision;
! 115: mixsub2 : in out Mixed_Subdivision ) is
! 116:
! 117: tmp : Mixed_Subdivision := mixsub1;
! 118: mixsub2_last : Mixed_Subdivision;
! 119:
! 120: begin
! 121: Deep_Clear(mixsub2);
! 122: while not Is_Null(tmp) loop
! 123: declare
! 124: mic1,mic2 : Mixed_Cell;
! 125: begin
! 126: mic1 := Head_Of(tmp);
! 127: Copy(mic1,mic2);
! 128: Append(mixsub2,mixsub2_last,mic2);
! 129: end;
! 130: tmp := Tail_Of(tmp);
! 131: end loop;
! 132: end Copy;
! 133:
! 134: procedure Append_Diff ( first,last : in out Mixed_Subdivision;
! 135: mic : in Mixed_Cell ) is
! 136: begin
! 137: if not Is_In(first,mic)
! 138: then Append(first,last,mic);
! 139: end if;
! 140: end Append_Diff;
! 141:
! 142: procedure Concat_Diff ( first,last : in out Mixed_Subdivision;
! 143: mixsub : in Mixed_Subdivision ) is
! 144:
! 145: tmp : Mixed_Subdivision := mixsub;
! 146:
! 147: begin
! 148: while not Is_Null(tmp) loop
! 149: declare
! 150: mic : Mixed_Cell := Head_Of(tmp);
! 151: begin
! 152: if not Is_In(first,mic)
! 153: then Append_Diff(first,last,mic);
! 154: end if;
! 155: end;
! 156: tmp := Tail_Of(tmp);
! 157: end loop;
! 158: end Concat_Diff;
! 159:
! 160: procedure Construct ( mixsub : in Mixed_Subdivision;
! 161: first : in out Mixed_Subdivision ) is
! 162:
! 163: tmp : Mixed_Subdivision := mixsub;
! 164:
! 165: begin
! 166: while not Is_Null(tmp) loop
! 167: declare
! 168: mic : Mixed_Cell := Head_Of(tmp);
! 169: begin
! 170: Construct(mic,first);
! 171: end;
! 172: tmp := Tail_Of(tmp);
! 173: end loop;
! 174: end Construct;
! 175:
! 176: procedure Construct_Diff ( mixsub : in Mixed_Subdivision;
! 177: first : in out Mixed_Subdivision ) is
! 178:
! 179: tmp : Mixed_Subdivision := mixsub;
! 180:
! 181: begin
! 182: while not Is_Null(tmp) loop
! 183: declare
! 184: mic : Mixed_Cell := Head_Of(tmp);
! 185: begin
! 186: if not Is_In(first,mic)
! 187: then Construct(mic,first);
! 188: end if;
! 189: end;
! 190: tmp := Tail_Of(tmp);
! 191: end loop;
! 192: end Construct_Diff;
! 193:
! 194: -- SELECTORS :
! 195:
! 196: function Equal ( mic1,mic2 : Mixed_Cell ) return boolean is
! 197: begin
! 198: if not Equal(mic1.nor,mic2.nor)
! 199: then return false;
! 200: elsif Equal(mic1.pts,mic2.pts)
! 201: then return Equal(mic1.sub,mic2.sub);
! 202: else return false;
! 203: end if;
! 204: end Equal;
! 205:
! 206: function Is_Sub ( mixsub1,mixsub2 : Mixed_Subdivision ) return boolean is
! 207:
! 208: -- DESCRIPTION :
! 209: -- Returns true when every cell in mixsub1 also belongs to mixsub2.
! 210:
! 211: tmp : Mixed_Subdivision := mixsub1;
! 212:
! 213: begin
! 214: while not Is_Null(tmp) loop
! 215: if not Is_In(mixsub2,Head_Of(tmp))
! 216: then return false;
! 217: else tmp := Tail_Of(tmp);
! 218: end if;
! 219: end loop;
! 220: return true;
! 221: end Is_Sub;
! 222:
! 223: function Equal ( mixsub1,mixsub2 : Mixed_Subdivision ) return boolean is
! 224: begin
! 225: if Is_Sub(mixsub1,mixsub2)
! 226: then return Is_Sub(mixsub2,mixsub1);
! 227: else return false;
! 228: end if;
! 229: end Equal;
! 230:
! 231: function Equal ( mixsub1,mixsub2 : Link_to_Mixed_Subdivision )
! 232: return boolean is
! 233: begin
! 234: if mixsub1 = null and then mixsub2 /= null
! 235: then return false;
! 236: elsif mixsub2 = null
! 237: then return true;
! 238: else return Equal(mixsub1.all,mixsub2.all);
! 239: end if;
! 240: end Equal;
! 241:
! 242: function Is_In ( mixsub : Mixed_Subdivision; normal : Vector )
! 243: return boolean is
! 244:
! 245: tmp : Mixed_Subdivision := mixsub;
! 246: c : Mixed_Cell;
! 247:
! 248: begin
! 249: while not Is_Null(tmp) loop
! 250: c := Head_Of(tmp);
! 251: if Equal(c.nor.all,normal)
! 252: then return true;
! 253: end if;
! 254: tmp := Tail_Of(tmp);
! 255: end loop;
! 256: return false;
! 257: end Is_In;
! 258:
! 259: function Is_In ( mixsub : Mixed_Subdivision; mic : Mixed_Cell )
! 260: return boolean is
! 261:
! 262: tmp : Mixed_Subdivision := mixsub;
! 263: mic1 : Mixed_Cell;
! 264:
! 265: begin
! 266: while not Is_Null(tmp) loop
! 267: mic1 := Head_Of(tmp);
! 268: if Equal(mic1,mic)
! 269: then return true;
! 270: else tmp := Tail_Of(tmp);
! 271: end if;
! 272: end loop;
! 273: return false;
! 274: end Is_In;
! 275:
! 276: -- DESTRUCTORS :
! 277:
! 278: procedure free is new unchecked_deallocation
! 279: (Mixed_Subdivision,Link_to_Mixed_Subdivision);
! 280:
! 281: procedure Deep_Clear ( mic : in out Mixed_Cell ) is
! 282: begin
! 283: Clear(mic.nor); Deep_Clear(mic.pts); Deep_Clear(mic.sub);
! 284: end Deep_Clear;
! 285:
! 286: procedure Shallow_Clear ( mic : in out Mixed_Cell ) is
! 287: begin
! 288: Clear(mic.nor); Shallow_Clear(mic.pts); Shallow_Clear(mic.sub);
! 289: end Shallow_Clear;
! 290:
! 291: procedure Deep_Clear ( mixsub : in out Mixed_Subdivision ) is
! 292:
! 293: tmp : Mixed_Subdivision;
! 294:
! 295: begin
! 296: tmp := mixsub;
! 297: while not Is_Null(tmp) loop
! 298: declare
! 299: mic : Mixed_Cell := Head_Of(tmp);
! 300: begin
! 301: Deep_Clear(mic);
! 302: end;
! 303: tmp := Tail_Of(tmp);
! 304: end loop;
! 305: Shallow_Clear(mixsub);
! 306: end Deep_Clear;
! 307:
! 308: procedure Deep_Clear ( mixsub : in out Link_to_Mixed_Subdivision ) is
! 309: begin
! 310: if mixsub /= null
! 311: then Deep_Clear(mixsub.all);
! 312: free(mixsub);
! 313: end if;
! 314: end Deep_Clear;
! 315:
! 316: procedure Shallow_Clear ( mixsub : in out Mixed_Subdivision ) is
! 317: begin
! 318: Lists_of_Mixed_Cells.Clear(Lists_of_Mixed_Cells.List(mixsub));
! 319: end Shallow_Clear;
! 320:
! 321: procedure Shallow_Clear ( mixsub : in out Link_to_Mixed_Subdivision ) is
! 322: begin
! 323: if mixsub /= null
! 324: then Shallow_Clear(mixsub.all);
! 325: free(mixsub);
! 326: end if;
! 327: end Shallow_Clear;
! 328:
! 329: end Floating_Mixed_Subdivisions;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to floating_mixed_subdivisions.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