Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Stalift/floating_lifting_utilities.adb, Revision 1.1
1.1 ! maekawa 1: package body Floating_Lifting_Utilities is
! 2:
! 3: function Adaptive_Lifting ( l : Array_of_Lists ) return Vector is
! 4:
! 5: res : Vector(l'range);
! 6: fac : constant double_float := 3.0; -- multiplication factor
! 7: max : constant double_float := 23.0; -- upper bound for lifting
! 8:
! 9: begin
! 10: for i in l'range loop
! 11: res(i) := fac*double_float(Length_Of(l(i)));
! 12: if res(i) > max
! 13: then res(i) := max;
! 14: end if;
! 15: end loop;
! 16: return res;
! 17: end Adaptive_Lifting;
! 18:
! 19: procedure Search_Lifting ( l : in List; pt : in Vector;
! 20: found : out boolean; lif : out double_float ) is
! 21:
! 22: tmp : List := l;
! 23: lpt : Link_to_Vector;
! 24:
! 25: begin
! 26: found := false;
! 27: while not Is_Null(tmp) loop
! 28: lpt := Head_Of(tmp);
! 29: if Equal(lpt(pt'range),pt)
! 30: then found := true;
! 31: lif := lpt(lpt'last);
! 32: exit;
! 33: else tmp := Tail_Of(tmp);
! 34: end if;
! 35: end loop;
! 36: end Search_Lifting;
! 37:
! 38: function Search_and_Lift ( l : List; pt : Vector ) return Vector is
! 39:
! 40: tmp : List := l;
! 41: lpt : Link_to_Vector;
! 42:
! 43: begin
! 44: while not Is_Null(tmp) loop
! 45: lpt := Head_Of(tmp);
! 46: if Equal(lpt(pt'range),pt)
! 47: then return lpt.all;
! 48: else tmp := Tail_Of(tmp);
! 49: end if;
! 50: end loop;
! 51: return pt;
! 52: end Search_and_Lift;
! 53:
! 54: function Search_and_Lift ( mic : Mixed_Cell; k : natural; pt : Vector )
! 55: return Vector is
! 56: begin
! 57: return Search_and_Lift(mic.pts(k),pt);
! 58: end Search_and_Lift;
! 59:
! 60: function Occured_Lifting ( mixsub : Mixed_Subdivision; k : natural;
! 61: pt : Vector ) return Vector is
! 62:
! 63: tmp : Mixed_Subdivision := mixsub;
! 64:
! 65: begin
! 66: while not Is_Null(tmp) loop
! 67: declare
! 68: lpt : constant Vector := Search_and_Lift(Head_Of(tmp),k,pt);
! 69: begin
! 70: if lpt'last > pt'last
! 71: then return lpt;
! 72: else tmp := Tail_Of(tmp);
! 73: end if;
! 74: end;
! 75: end loop;
! 76: return pt;
! 77: end Occured_Lifting;
! 78:
! 79: function Occured_Lifting
! 80: ( n : natural; mix : Standard_Integer_Vectors.Vector;
! 81: points : Array_of_Lists; mixsub : Mixed_Subdivision )
! 82: return Array_of_Lists is
! 83:
! 84: res,res_last : Array_of_Lists(mix'range);
! 85: cnt : natural := 1;
! 86: tmp : List;
! 87:
! 88: begin
! 89: for k in mix'range loop
! 90: res_last(k) := res(k);
! 91: tmp := points(cnt);
! 92: while not Is_Null(tmp) loop
! 93: declare
! 94: pt : Link_to_Vector := Head_Of(tmp);
! 95: lpt : constant Vector := Occured_Lifting(mixsub,k,pt.all);
! 96: begin
! 97: if lpt'last > pt'last
! 98: then Append(res(k),res_last(k),lpt);
! 99: end if;
! 100: end;
! 101: tmp := Tail_Of(tmp);
! 102: end loop;
! 103: cnt := cnt + mix(k);
! 104: end loop;
! 105: return res;
! 106: end Occured_Lifting;
! 107:
! 108: function Induced_Lifting ( mixsub : Mixed_Subdivision; k : natural;
! 109: pt : Vector ) return Vector is
! 110:
! 111: tmp : Mixed_Subdivision := mixsub;
! 112: res : Vector(pt'first..pt'last+1);
! 113:
! 114: begin
! 115: while not Is_Null(tmp) loop
! 116: declare
! 117: mic : Mixed_Cell := Head_Of(tmp);
! 118: lpt : constant Vector := Search_and_Lift(mic,k,pt);
! 119: begin
! 120: if lpt'length = pt'length+1
! 121: then return lpt;
! 122: else tmp := Tail_Of(tmp);
! 123: end if;
! 124: end;
! 125: end loop;
! 126: res(pt'range) := pt;
! 127: res(res'last) := 1.0;
! 128: res(res'last) := Conservative_Lifting(mixsub,k,res);
! 129: return res;
! 130: end Induced_Lifting;
! 131:
! 132: function Induced_Lifting
! 133: ( n : natural; mix : Standard_Integer_Vectors.Vector;
! 134: points : Array_of_Lists; mixsub : Mixed_Subdivision )
! 135: return Array_of_Lists is
! 136:
! 137: res,res_last : Array_of_Lists(mix'range);
! 138: cnt : natural := 1;
! 139: tmp : List;
! 140:
! 141: begin
! 142: for k in mix'range loop
! 143: res_last(k) := res(k);
! 144: tmp := points(cnt);
! 145: while not Is_Null(tmp) loop
! 146: declare
! 147: pt : Link_to_Vector := Head_Of(tmp);
! 148: lpt : constant Vector := Induced_Lifting(mixsub,k,pt.all);
! 149: begin
! 150: Append(res(k),res_last(k),lpt);
! 151: end;
! 152: tmp := Tail_Of(tmp);
! 153: end loop;
! 154: cnt := cnt + mix(k);
! 155: end loop;
! 156: return res;
! 157: end Induced_Lifting;
! 158:
! 159: function Conservative_Lifting
! 160: ( mic : Mixed_Cell; k : natural; point : Vector )
! 161: return double_float is
! 162:
! 163: sp : double_float := mic.nor*Head_Of(mic.pts(k));
! 164: spp : double_float:= mic.nor.all*point;
! 165: res : double_float;
! 166:
! 167: begin
! 168: if sp < spp
! 169: then return point(point'last);
! 170: else if mic.nor(mic.nor'last) = 0.0
! 171: then res := point(point'last);
! 172: else spp := spp - point(point'last)*mic.nor(mic.nor'last);
! 173: res := (sp - spp)/mic.nor(mic.nor'last) + 1.0;
! 174: end if;
! 175: return res;
! 176: end if;
! 177: end Conservative_Lifting;
! 178:
! 179: function Conservative_Lifting ( mixsub : Mixed_Subdivision; k : natural;
! 180: point : Vector ) return double_float is
! 181:
! 182: tmp : Mixed_Subdivision := mixsub;
! 183: pt : Vector(point'range) := point;
! 184: res : double_float;
! 185:
! 186: begin
! 187: while not Is_Null(tmp) loop
! 188: pt(pt'last) := Conservative_Lifting(Head_Of(tmp),k,pt);
! 189: tmp := Tail_Of(tmp);
! 190: end loop;
! 191: res := pt(pt'last);
! 192: Clear(pt);
! 193: return res;
! 194: end Conservative_Lifting;
! 195:
! 196: end Floating_Lifting_Utilities;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to floating_lifting_utilities.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