1 (* create new inequalities for lp, cfsqp, formal spec *)
6 let sprintf = Printf.sprintf;;
10 let unsplit d f = function
11 | (x::xs) -> fold_left (fun s t -> s^d^(f t)) (f x) xs
14 let join_lines = unsplit "\n" (fun x-> x);;
19 | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
20 | _ -> failwith "zip";;
23 (* end from lpproc.ml *)
27 type constrain = NONE | SMALLTRI | BIGTRI ;;
29 type node = LOW | MEDIUM | HIGH | EXTRA ;;
31 type edge = SMALL | BIG;;
33 type decimal = Dec of string | Sqrt2 | Sqrt8;;
36 let _ = String.index s '.' in true
37 with failure -> false;;
39 let add_point s = if has_point s then s else s^".0";;
43 else if s="s8" then Sqrt8
46 let d = dec_of_string;;
48 let ds:string -> decimal list = fun s ->
49 let ss = split_sp s in
50 map dec_of_string ss;;
52 let float_of_dec:decimal -> float = function
55 | Dec x -> float_of_string x;;
57 let holtext_of_dec:decimal -> string = function
60 | Dec x -> let y = add_point x in
61 if (y.[0]= '-') then " -- #"^(String.sub y 1 (String.length y - 1))
65 holtext_of_dec (Dec "2.0");;
67 let holtext_of_declist:decimal list -> string = fun xs ->
68 "["^(unsplit ";" holtext_of_dec xs)^"]";;
70 let holtext_of_sgn:sgn -> string = function
74 let holtext_of_constrain:constrain -> string = function
76 | BIGTRI -> "Cstd3_big"
77 | SMALLTRI -> "Cstd3_small";;
79 let split_sp= Str.split (regexp " +");;
84 represents on rectangle xmin[6], xmax[6]:
86 azim[i]*azim i y + rhzim[i]*rhzim i y + tau0 * taumar y + sol0 * sol y
94 mutable constrain: constrain;
96 mutable xmin : decimal list;
97 mutable xmax : decimal list;
99 mutable c : decimal list;
100 mutable p : decimal list;
101 mutable azim : decimal list;
102 mutable rhzim : decimal list;
103 mutable tau0 : decimal;
104 mutable sol0 : decimal;
111 xmin = ds "2 2 2 2 2 2";
112 xmax = ds "2.52 2.52 2.52 2.52 2.52 2.52";
114 c = ds "2.0 2.1 2.2 2.3 2.4 2.5";
115 p = ds "3.0 3.1 3.2 3.3 3.4 3.5";
117 rhzim = ds "-1.0 -2.0 -3.0";
123 let holtext_of_ineq:ineq->string = fun h ->
126 p"let hol_ineq%s = `hol_ineq (\"%s\", " h.id h.id;
127 p" %s," (holtext_of_constrain h.constrain);
128 p" %s," (holtext_of_sgn h.sgn);
129 p" %s," (holtext_of_declist h.xmin);
130 p" %s," (holtext_of_declist h.xmax);
131 p" %s," (holtext_of_dec h.c0);
132 p" %s," (holtext_of_declist h.c);
133 p" %s," (holtext_of_declist h.p);
134 p" %s," (holtext_of_declist h.azim);
135 p" %s," (holtext_of_declist h.rhzim);
136 p" %s," (holtext_of_dec h.tau0);
137 p" %s)` " (holtext_of_dec h.sol0);
140 (* ampl text generation of triangle ineqs
141 ocaml numbering 012345
142 ampl numbering 123456 *)
146 let nz s = (float_of_dec s <> 0.0);;
147 let hasnz s = exists nz s;;
148 let unempty = filter (fun t -> t <> "");;
150 let ampl_of_dec:decimal -> string = function
151 | Sqrt2 -> "+1.4142135623730951"
152 | Sqrt8 -> "+2.8284271247461903"
154 if (x.[0]= '-') then x else "+"^x;;
156 let comp:decimal->decimal->int =
158 if (a=b) then 0 else compare (float_of_dec a) (float_of_dec b);;
160 let less_equal bs cs =
161 []= filter (fun t -> comp (fst t) (snd t) >0 ) (zip bs cs);;
163 let domain_covers (lo,high) h =
164 less_equal h.xmin lo && less_equal high h.xmax;;
166 let domain_covers_itriangle =
167 domain_covers (ds "2 2 2 2 2 2",ds "2.52 2.52 2.52 2.52 2.52 2.52");;
169 let domain_covers_apiece =
170 domain_covers (ds "2 2 2 2 2.52 2.52",ds "2.52 2.52 2.52 2.52 s8 s8");;
172 let domain_covers_flat =
173 domain_covers (ds "2 2 2 2.52 2 2",ds "2.52 2.52 2.52 s8 2.52 2.52");;
175 let domain_covers_apex_sup_flat =
176 domain_covers (ds "2 2 2 s8 2 2",ds "2.52 2.52 2.52 3.0 2.52 2.52");;
178 let domain_covers_std3_big h =
179 domain_covers_itriangle h && (h.constrain = BIGTRI);;
181 let domain_covers_std3_small h =
182 domain_covers_itriangle h && (h.constrain = SMALLTRI);;
184 let node_range = function
186 | MEDIUM -> ds "2.18 2.36"
187 | HIGH -> ds "2.18 2.52"
188 | EXTRA -> ds "2.36 2.52";;
190 let domain_covers_f f node h i =
191 let ymin = nth h.xmin i in
192 let ymax = nth h.xmax i in
193 let [mm;mx] = f node in
194 less_equal [ymin] [mm] && less_equal [mx] [ymax];;
196 let domain_covers_node = domain_covers_f node_range;;
198 let edge_range = function
199 | SMALL -> ds "2 2.25"
200 | BIG -> ds "2.25 2.52";;
202 let domain_covers_edge = domain_covers_f edge_range;;
204 let string_of_domain h = "";;
206 let ampltext_of_ineq:ineq->string = fun h ->
208 let a = ampl_of_dec in
209 let mkone f s = if nz f then p" %s * %s " (a f) s else "" in
210 let mk_madd j = p" %s * (y%d[i2,j] - (%s))"
211 (a (nth h.c j)) (j+1) (a (nth h.p j)) in
214 p"ineq%s 'ID[%s]' {(i1,i2,i3,j) in e_dart : " h.id h.id;
217 mkone h.tau0 "tau[j]";
218 mkone h.sol0 "sol[j]";
219 mkone (nth h.azim 0) "azim[i1,j]";
220 mkone (nth h.azim 1) "azim[i2,j]";
221 mkone (nth h.azim 2) "azim[i3,j]";
222 mkone (nth h.rhzim 0) "rhzim[i1,j]";
223 mkone (nth h.rhzim 1) "rhzim[i2,j]";
224 mkone (nth h.rhzim 2) "rhzim[i3,j]";
227 mk_madd 0;mk_madd 1;mk_madd 2;mk_madd 3;mk_madd 4;mk_madd 5
230 ampltext_of_ineq hh;;