1 (* Title: Specify/pre-conds.sml
2 Author: Walther Neuper 110226
3 (c) due to copyrigh,t terms
6 signature PRE_CONDITIONS =
10 (*RENA unchecked_pos*)
20 val to_string : Proof.context -> T -> string
22 val max_variant: Model_Def.i_model -> int
23 val environment: Model_Def.i_model -> Env.T
25 val check: Proof.context -> Rule_Set.T -> unchecked -> Model_Def.i_model -> 'a -> checked
26 (*check_TEST is intermediately introduced for step-wise adapting test/* to I_Model.T_TEST
27 in parallel to check, and will finally be replaced by check_from_store:*)
28 val check_from_store: Proof.context -> Rule_Set.T -> unchecked -> env_subst -> env_eval -> checked
29 (*REN check_input: Proof.context -> Rule_Set.T -> unchecked_input -> env_eval -> checked_input*)
30 val check_TEST : Proof.context -> Rule_Set.T -> unchecked_TEST -> env_eval -> checked_TEST
32 (*this makes the OLD tests run AFTER introduction of I_Model.T_TEST..*)
33 val check_OLD: Proof.context -> Rule_Set.T -> unchecked ->
34 Model_Pattern.T * Model_Def.i_model_TEST -> checked
36 val eval: Proof.context -> Rule_Set.T -> bool * term -> bool * term
37 val feedback_TEST_to_string: Model_Def.i_model_feedback_TEST -> string
39 val check_variant_envs: Proof.context -> Rule_Set.T -> unchecked ->
40 env_subst -> env_eval -> checked
42 (*val sep_variants_envs replaced by of_max_variant TODO
43 for that purpose compare with sep_variants_envs_OLD TODO*)
44 val sep_variants_envs: Model_Pattern.T -> Model_Def.i_model_TEST ->
45 ((Model_Def.i_model_TEST * env_subst * env_eval) * Model_Def.variant) list
46 val sep_variants_envs_OLD: Model_Pattern.T -> Model_Def.i_model_TEST ->
50 val of_max_variant: Model_Pattern.T -> Model_Def.i_model_TEST ->
51 Model_Def.i_model_TEST * env_subst * env_eval
53 val of_max_variant:Model_Pattern.T -> Model_Def.i_model_TEST ->
54 Model_Def.i_model_TEST * Env.T * (env_subst * env_eval)
57 (*from isac_test for Minisubpbl*)
58 val discern_feedback_subst: Model_Def.descriptor -> Model_Def.i_model_feedback_TEST -> Env.T;
59 val discern_type_subst: term * term -> term list -> Env.T;
60 val discern_type_eval: Model_Def.descriptor -> term list -> env_eval
61 val discern_atoms: term list -> Env.T;
63 val mk_env: Model_Def.i_model_feedback_TEST -> Env.T
64 val mk_env_subst: (Model_Pattern.single * Model_Def.i_model_single_TEST) list -> env_subst
65 val mk_env_subst_DEL: (Model_Pattern.single * Model_Def.i_model_single_TEST) list -> env_subst
66 val mk_env_eval: (Model_Pattern.single * Model_Def.i_model_single_TEST) list -> env_eval
67 val mk_env_eval_DEL: Model_Def.i_model_single_TEST list -> env_eval
68 val arrange_args2: 'a list -> 'b list -> 'c list -> int * 'd list -> (('a * 'b * 'c) * 'd) list
69 val filter_variants: (Model_Pattern.single * Model_Def.i_model_single_TEST) list ->
70 Model_Def.variant -> (Model_Pattern.single * Model_Def.i_model_single_TEST) list
71 val get_equal_descr: Model_Def.i_model_TEST -> Model_Pattern.single ->
72 (Model_Pattern.single * Model_Def.i_model_single_TEST) list
73 val unchecked_OLD_to_TEST: term list -> (term * Position.T) list
75 val filter_variants': Model_Def.i_model_TEST -> Model_Def.variant -> Model_Def.i_model_TEST
76 val arrange_args1: int list -> int * Model_Def.variant list -> (int * Model_Def.variant) list
77 val cnt_corrects: Model_Def.i_model_TEST -> int
78 val handle_descr_ts: term -> term list -> Env.T
79 val distinguish_atoms: term list -> Env.T
80 (*REN type_repair_env: Env.T -> Env.T*)
81 val repair_env: Env.T -> Env.T
82 val all_atoms: term list -> bool
83 val all_lhs_atoms: term list -> bool
86 val mk_env_model: term -> Model_Def.i_model_feedback_TEST -> Env.T
87 val switch_type: Model_Pattern.descriptor -> typ -> Model_Pattern.descriptor
88 val discern_typ: term -> Model_Pattern.descriptor * term list ->
89 ((term * term) * (term * term)) list
90 val discern_feedback: term -> Model_Def.i_model_feedback_TEST ->
91 ((term * term) * (term * term)) list
92 val make_envs_preconds: (Model_Pattern.single * Model_Def.i_model_single_TEST) list ->
93 ((term * term) * (term * term)) list
99 structure Pre_Conds(**) : PRE_CONDITIONS(**) =
104 type T = Pre_Conds_Def.T; (*= (bool * term) list;*)
105 type unchecked = term list
106 type unchecked_TEST = (term * Position.T) list
107 type checked = bool * (bool * term) list
108 type checked_TEST = bool * (bool * (term * Position.T)) list
111 we have three kinds of Env.T in the specification-phase:
112 (*1*) Env.T produced by I_Model.of_max_variant and required to create O_Model.T, I_Model.T from
114 Env.T / (Constants, fixes) in Model_Pattern.T
115 e.g.[(fixes, [r = 7])] |
116 > (Constants, [<r = 7>]) in O/I_Model.T *)
118 (*2*) type env_subst = Env.T (* / 0 < fixes in Problem.{where_, ...}
121 (*3*) type env_eval = Env.T (* |
123 > 0 < 7 \<longrightarrow> true
125 (*1*) is required to produce (*2*) and (*3*); thus respective code is shifted to Pre_Conds.
126 (*2*) and (*3*) is produced from I_Model.of_max_variant by restricting to "#Given".
128 There is a typing problem, probably to be solved by a language for Specification in the future:
129 term <fixes> in (*1*) has type "bool list"
130 term <fixes> in (*2*) has type "real". So for the transition from (*1*) to (*2..3*)
131 fun switch_type is required.
132 The transition requires better modelling by a novel language for Specification.
135 type input = TermC.as_string list;
137 fun to_str ctxt (b, t) = pair2str (bool2str b, UnparseC.term ctxt t);
138 fun to_string ctxt pres = strs2str' (map (linefeed o (to_str ctxt)) pres);
140 fun eval _ _ (false, where_) = (false, where_) (*NOT ALL Free's have been substituted*)
141 | eval ctxt where_rls (true, where_) =
142 if Rewrite.eval_true ctxt [where_] where_rls
144 else (false, where_);
146 (** old code before I_Model.T_TEST **)
148 (* find most frequent variant v in itms *)
151 * misses variants with equal number of items, etc
153 fun variants itms = ((distinct op =) o flat o (map (fn (_, vrs, _, _, _) => vrs))) itms;
155 (*version without typing problem*)
156 fun cnt itms v = (v, (length o (filter (curry op = v)) o flat o (map (fn (_, vrs, _, _, _) => vrs))) itms);
157 fun count_variants vts itms = map (cnt itms) vts;
159 fun max2 [] = raise ERROR "max2 of []"
162 fun mx (a, x) [] = (a, x)
163 | mx (a, x) ((b, y) :: ys) = if x < y then mx (b, y) ys else mx (a, x) ys;
166 (* get the constant value from a penv *)
167 fun getval (id, values) =
169 [] => raise ERROR ("penv_value: no values in '" ^ UnparseC.term (ContextC.for_ERROR ()) id)
171 | (v1 :: v2 :: _) => (case v1 of
172 Const (\<^const_name>\<open>Program.Arbfix\<close>, _) => (id, v2)
175 (* find the variant with most items already input *)
176 fun max_variant itms =
177 let val vts = (count_variants (variants itms)) itms;
178 in if vts = [] then 0 else (fst o max2) vts end;
180 fun mk_e (Cor (_, iv)) = [getval iv]
183 | mk_e (Inc (_, iv)) = [getval iv]
186 | mk_e _ = raise ERROR "mk_e: uncovered case in fun.def.";
187 fun mk_en vt (_, vts, _, _, itm_) = if member op = vts vt then mk_e itm_ else [];
189 (* extract the environment from an item list; takes the variant with most items *)
190 fun environment itms =
191 let val vt = max_variant itms
192 in (flat o (map (mk_en vt))) itms end;
195 (** new code for I_Model.T_TEST **)
197 fun pen2str ctxt (t, ts) =
198 pair2str (UnparseC.term ctxt t, (strs2str' o map (UnparseC.term ctxt)) ts);
199 fun feedback_to_string_TEST ctxt (Cor_TEST ((d, ts), penv)) =
200 "Cor_TEST " ^ UnparseC.term ctxt (Input_Descript.join (d, ts)) ^ " ," ^ pen2str ctxt penv
201 | feedback_to_string_TEST _ (Syn_TEST c) =
203 | feedback_to_string_TEST ctxt (Inc_TEST ((d, []), _)) =
204 "Inc_TEST " ^ UnparseC.term ctxt (Input_Descript.join (d, [])) ^ " " ^
205 Model_Pattern.empty_for d
206 | feedback_to_string_TEST ctxt (Inc_TEST ((d, ts), penv)) =
207 "Inc_TEST " ^ UnparseC.term ctxt (Input_Descript.join (d, ts)) ^ " ," ^ pen2str ctxt penv
208 | feedback_to_string_TEST ctxt (Sup_TEST (d, ts)) =
209 "Sup_TEST " ^ UnparseC.term ctxt (Input_Descript.join (d, ts))
210 fun feedback_TEST_to_string t = feedback_to_string_TEST (ContextC.for_ERROR ()) t;
213 (*** make environments for substituting model_pattern+program and for evaluating pre-conditions ***)
215 (** OLD make environment for substituting model_pattern+program and pre-conditions **)
217 (*val all_atoms_OLD: term list -> bool*)
218 fun all_atoms_OLD ts =
219 fold (curry and_) (map (fn t => TermC.is_atom (TermC.lhs t)) ts) true
220 fun switch_type (Free (id, _)) T = Free (id, T)
221 | switch_type t _ = raise TERM ("switch_type not for", [t])
224 this repair is spurious and indicates the need for considering a separate language for Model-ing.
225 E.g. "fixes" is used with 2 different types "bool list" and "real" in the problem-definition
226 problem pbl_opti_univ : "univariate_calculus/Optimisation" = ..
227 Given: "Constants fixes"
230 (1) Given: Const ("Input_Descript.Constants", "bool list \<Rightarrow> nam") $ Free ("fixes", "bool list")
231 (2) Where: Const ("Orderings.ord_class.less", "real \<Rightarrow> real \<Rightarrow> bool") $
232 Const ("Groups.zero_class.zero", "real") $ Free ("fixes", "real")
234 The intermediately simplistic solution is to build a pair of environments, type env_pair,
236 The simplistic design works for the instantiation of the demo-example
237 "Constants [r = (7::real)]"
238 but it could be extended to instantiations like
239 "Constants [a = (1::real), b = (2::real)]"
240 with the same Where: "0 < fixes" in the problem-definition
241 if indexing / deletion of found elements from the association list is considered.
243 For the purpose of future pimprovements a pair of environments, type env_pair, is built;
244 where as key of the "outer" environment Free ("fixes", "real" kept to future improvements
245 (by indexing "fixes_1", "fixes_2" in case the are more than one element in
246 "Input_Descript.Constants", "bool list..)
249 map (fn (id_inst, val_) => (switch_type id_inst (type_of val_), val_)) env
251 (* make an Env.T for Prec_Conds.eval *)
252 fun mk_env (Model_Def.Cor_TEST ((descr, [ts]), _)) =
254 (*val ts = TermC.isalist2list ts*)
255 val ts = if TermC.is_list ts then TermC.isalist2list ts else [ts]
257 (*compare Model_Pattern.empty_for*)
258 case type_of descr of
259 (Type ("fun", [Type ("List.list", [Type ("HOL.bool", [])]), _])) (*SideConditions \<longrightarrow> (sideconds, [(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2])*)
260 => if all_atoms_OLD ts then map (fn t => (TermC.lhs t, TermC.rhs t)) ts else []
261 | (Type ("fun", [Type ("List.list", [Type ("Real.real", [])]), _])) (*AdditionalValues [u, v]*)
263 | (Type ("HOL.bool", [])) (*Precision (\<epsilon> = 0.01)*)
264 => if all_atoms_OLD ts then map (fn t => (TermC.lhs t, TermC.rhs t)) ts else []
265 | _ (*Maximum A*) => [(hd ts, TermC.empty (*dummy rhs*))]
267 | mk_env (Model_Def.Inc_TEST ((descr, [ts]), _)) =
269 (*val ts = TermC.isalist2list ts*)
270 val ts = if TermC.is_list ts then TermC.isalist2list ts else [ts]
272 (*compare Model_Pattern.empty_for*)
273 case type_of descr of
274 (Type ("fun", [Type ("List.list", [Type ("HOL.bool", [])]), _])) (*SideConditions \<longrightarrow> (sideconds, [(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2])*)
275 => if all_atoms_OLD ts then map (fn t => (TermC.lhs t, TermC.rhs t)) ts else []
276 | (Type ("fun", [Type ("List.list", [Type ("Real.real", [])]), _])) (*AdditionalValues [u, v]*)
278 | (Type ("HOL.bool", [])) (*Precision (\<epsilon> = 0.01)*)
279 => if all_atoms_OLD ts then map (fn t => (TermC.lhs t, TermC.rhs t)) ts else []
280 | _ (*Maximum A*) => [(hd ts, TermC.empty (*dummy rhs*))]
282 | mk_env (Model_Def.Sup_TEST (descr, [ts])) =
284 (*val ts = TermC.isalist2list ts*)
285 val ts = if TermC.is_list ts then TermC.isalist2list ts else [ts]
287 (*compare Model_Pattern.empty_for*)
288 case type_of descr of
289 (Type ("fun", [Type ("List.list", [Type ("HOL.bool", [])]), _])) (*SideConditions \<longrightarrow> (sideconds, [(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2])*)
290 => if all_atoms_OLD ts then map (fn t => (TermC.lhs t, TermC.rhs t)) ts else []
291 | (Type ("fun", [Type ("List.list", [Type ("Real.real", [])]), _])) (*AdditionalValues [u, v]*)
293 | (Type ("HOL.bool", [])) (*Precision (\<epsilon> = 0.01)*)
294 => if all_atoms_OLD ts then map (fn t => (TermC.lhs t, TermC.rhs t)) ts else []
295 | _ (*Maximum A*) => [(hd ts, TermC.empty (*dummy rhs*))]
298 raise ERROR ("mk_env not reasonable for " ^ quote (feedback_TEST_to_string feedb))
299 fun mk_env_subst equal_descr_pairs =
300 map (fn ((_, (_, id)), (_, _, _, _, (feedb, _)))
301 => (mk_env feedb) |> map fst (*dummy rhs dropped*)|> map (pair id)) equal_descr_pairs
304 (*fun mk_env_eval unused? DEL!*)
305 fun mk_env_eval equal_descr_pairs =
306 map (fn (_, (_, _, _, _, (feedb, _))) => mk_env feedb) equal_descr_pairs
308 |> filter_out (fn (_, b) => b = TermC.empty) (*drop pairs with dummy rhs*)
310 (* all_atoms: term list -> bool*)
312 fold (curry and_) (map (fn t => TermC.is_atom t) ts) true
313 (* all_lhs_atoms: term list -> bool*)
314 fun all_lhs_atoms ts = fold (curry and_) (map (fn t =>
315 if can TermC.lhs t then TermC.is_atom (TermC.lhs t) else false) ts) true
316 (* distinguish_atoms: term list -> Env.T*)
317 fun distinguish_atoms (*[(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2], \<epsilon> = 0.01, [L]*) ts =
319 then map (rpair TermC.empty (*dummy rhs*)) ts
320 else if all_lhs_atoms ts
321 then map (fn t => (TermC.lhs t, TermC.rhs t)) ts
323 (* handle_descr_ts: term -> term list -> (term * term) list*)
324 fun handle_descr_ts descr ts =
325 (*compare Model_Pattern.empty_for*)
326 case type_of descr of
327 (Type ("fun", [Type ("List.list", [Type ("HOL.bool", [])]), _])) (*(SideConds [(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2]), [L]*)
328 => distinguish_atoms ts
329 | (Type ("fun", [Type ("List.list", [Type ("Real.real", [])]), _])) (*AdditionalValues [u, v]*)
330 => if TermC.is_list (hd ts)
331 then [(descr, ts |> map TermC.the_single |> TermC.list2isalist HOLogic.realT)]
333 | (Type ("HOL.bool", [])) (*Precision (\<epsilon> = 0.01)*)
334 => distinguish_atoms ts
335 | _ (*Maximum A*) => [(hd ts, TermC.empty (*dummy rhs*))]
338 (** NEW make environment for substituting program and pre-conditions **)
340 fun switch_type (Free (id, _)) T = Free (id, T)
341 | switch_type t _ = raise TERM ("switch_type not for", [t])
344 map (fn (id_inst, val_) => (switch_type id_inst (type_of val_), val_)) env
346 (* discern_type_subst: term * term -> term list -> Env.T*)
347 fun discern_type_subst (descr, id) ts =
348 (*..compare Model_Pattern.empty_for*)
349 case type_of descr of
350 (Type ("fun", [Type ("List.list", [Type ("HOL.bool", [])]), _])) (*(SideConds [(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2]), [L]*)
351 => if TermC.is_list (hd ts)
352 then [(id, ts |> map TermC.the_single |> TermC.list2isalist HOLogic.boolT)]
353 else if length ts = 1
354 then [(id, Library.the_single ts)]
355 else raise error "discern_type_subst list bool DESIGN ERROR"
356 | (Type ("fun", [Type ("List.list", [Type ("Real.real", [])]), _])) (*AdditionalValues [u, v]*)
357 => if TermC.is_list (hd ts)
358 then [(id, ts |> map TermC.the_single |> TermC.list2isalist HOLogic.realT)]
359 else if length ts = 1
360 then [(id, Library.the_single ts)]
361 else raise error "discern_type_subst list bool DESIGN ERROR"
362 | _ (*Maximum A*) => [(id, Library.the_single ts)] (*if length ts = 1 !*)
364 (* discern_feedback_subst: Model_Def.i_model_feedback_TEST -> Env.T*)
365 fun discern_feedback_subst id (Model_Def.Cor_TEST ((descr, [ts]), _)) =
366 discern_type_subst (descr, id) [ts]
367 | discern_feedback_subst id (Model_Def.Inc_TEST ((descr, [ts]), _)) =
368 discern_type_subst (descr, id) [ts]
369 | discern_feedback_subst id (Model_Def.Sup_TEST (descr, [ts])) =
370 discern_type_subst (descr, id) [ts]
371 | discern_feedback_subst id (Model_Def.Cor_TEST ((descr, (*[*)ts(*]*)), _)) =
372 discern_type_subst (descr, id) ts
373 | discern_feedback_subst _ feedb =
374 raise ERROR ("discern_feedback_subst not reasonable for " ^ quote (feedback_TEST_to_string feedb))
376 fun mk_env_subst_DEL equal_descr_pairs =
377 map (fn ((_, (_, id)), (_, _, _, _, (feedb, _)))
378 => (discern_feedback_subst id feedb)) equal_descr_pairs
383 (** NEW make environment for evaluating pre-conditions **)
385 (* all_atoms: term list -> bool*)
387 fold (curry and_) (map (fn t => TermC.is_atom t) ts) true
388 (* all_lhs_atoms: term list -> bool*)
389 fun all_lhs_atoms ts = fold (curry and_) (map (fn t =>
390 if can TermC.lhs t then TermC.is_atom (TermC.lhs t) else false) ts) true
391 (* discern_atoms: term list -> (term * term) list*)
392 fun discern_atoms (*[(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2], \<epsilon> = 0.01, [L]*) ts =
394 then map (rpair TermC.empty (*dummy rhs*)) ts
395 else if all_lhs_atoms ts
396 then map (fn t => (TermC.lhs t, TermC.rhs t)) ts
399 fun discern_type_eval descr ts =
400 (*..compare Model_Pattern.empty_for*)
401 case type_of descr of
402 (Type ("fun", [Type ("List.list", [Type ("HOL.bool", [])]), _])) (*(SideConds [(u / 2) \<up> 2 + (2 / v) \<up> 2 = r \<up> 2]), [L]*)
404 | (Type ("fun", [Type ("List.list", [Type ("Real.real", [])]), _])) (*AdditionalValues [u, v]*)
406 | _ (*Maximum A*) => discern_atoms ts
408 fun discern_feedback_eval (Model_Def.Cor_TEST ((descr, [ts]), _)) = discern_type_eval descr [ts]
409 | discern_feedback_eval (Model_Def.Inc_TEST ((descr, [ts]), _)) = discern_type_eval descr [ts]
410 | discern_feedback_eval (Model_Def.Sup_TEST (descr, [ts])) = discern_type_eval descr [ts]
411 | discern_feedback_eval (Model_Def.Cor_TEST ((descr, ts), _)) = discern_type_eval descr ts
412 | discern_feedback_eval feedb =
413 raise ERROR ("discern_feedback_eval not defined for " ^ quote (feedback_TEST_to_string feedb))
415 fun mk_env_eval_DEL i_singles =
416 map (fn (_, _, _, _, (feedb, _)) => discern_feedback_eval feedb) i_singles
418 |> filter_out (fn (_, b) => b = TermC.empty) (*drop pairs with dummy rhs*)
421 (*** old check_variant_envs, sep_variants_envs/_OLD, of_max_variant, check/_TEST/_OLD ***)
423 fun check_variant_envs ctxt where_rls pres env_subst env_eval =
425 val pres_subst = map (TermC.subst_atomic_all env_subst) pres;
426 val full_subst = map (fn (bool, t) => (bool, subst_atomic env_eval t)) pres_subst
427 val evals = map (eval ctxt where_rls) full_subst
429 (foldl and_ (true, map fst evals), pres_subst)
433 (* check_variant_envs for PIDE *)
435 fun filter_variants pairs i =
436 filter (fn (_, (_, variants, _, _, _)) => member op= variants i) pairs
438 (*get descriptor of those items which can contribute to Subst.T and Env.T *)
439 (* get_dscr: feedback_TEST -> descriptor option*)
440 fun get_dscr' (Cor_TEST ((descr, _), _)) = SOME descr
441 | get_dscr' (Inc_TEST ((descr, _), _)) = SOME descr
442 | get_dscr' (Sup_TEST (descr, _)) = SOME descr
444 (*other feedback cannot contribute to I_Model.mk_env_TEST and Pre_Conds.mk_env_TEST*) = NONE
445 (* get_descr: I_Model.single_TEST -> descriptor option*)
446 fun get_descr (_, _, _, _, (feedb, _)) =
447 case get_dscr' feedb of NONE => NONE | some_descr => some_descr
448 (* get_equal_descr: I_Model.T_TEST -> Model_Pattern.single ->
449 (Model_Pattern.single * I_Model.single_TEST) list*)
450 fun get_equal_descr i_model (m_patt_single as (_, (descr, _))) =
453 filter (fn i_single => case get_descr i_single of
454 NONE => false (*--------vvvvv*)
455 | SOME descr' => descr' = descr) (*probl_POS*) i_model
457 (map (pair m_patt_single) equal_variants)
459 fun arrange_args2 [] _ _ _(*all have equal length*) = []
460 | arrange_args2 (b :: bs) (c :: cs) (d :: ds) (cnt, all) =
461 ((b, c, d), nth cnt all) :: (arrange_args2 bs cs ds (cnt + 1, all))
462 | arrange_args2 _ _ _ _ = raise ERROR "I_Model.arrange_args2 UnequalLengths"
463 fun sep_variants_envs model_patt i_model =
465 val equal_descr_pairs =
466 map (get_equal_descr i_model) model_patt
469 map (fn (_, (_, variants, _, _, _)) => variants) equal_descr_pairs
472 val variants_separated = map (filter_variants equal_descr_pairs) all_variants
473 val i_models = map (map snd) variants_separated
474 val restricted_to_given = map (filter (fn ((m_field, (_, _)), (_, _, _, _, (_, _))) =>
475 m_field = "#Given")) variants_separated
476 val envs_subst = map mk_env_subst restricted_to_given
477 val envs_eval = map mk_env_eval restricted_to_given
479 arrange_args2 i_models envs_subst envs_eval (1, all_variants)
482 (* smash all environments into one; this works only for old test before Maximum-example *)
483 fun sep_variants_envs_OLD model_patt i_model =
485 val equal_descr_pairs =
486 map (get_equal_descr i_model) model_patt
489 map (fn (_, (_, variants, _, _, _)) => variants) equal_descr_pairs
492 val variants_separated = map (filter_variants equal_descr_pairs) all_variants
493 val restricted_to_given = map (filter (fn ((m_field, (_, _)), (_, _, _, _, (_, _))) =>
494 m_field = "#Given")) variants_separated
495 val envs_subst = map mk_env_subst restricted_to_given
496 val envs_eval = map mk_env_eval restricted_to_given
498 (flat envs_subst, flat envs_eval)
501 (** of_max_variant **)
505 fun mk_env_model _ (Model_Def.Cor_TEST ((_, []), _)) = []
506 | mk_env_model id (Model_Def.Cor_TEST ((descr, ts), _)) =
507 if Model_Pattern.is_list_descr descr
508 then [(id, TermC.list2isalist (Model_Pattern.typ_of_element descr) ts)]
510 | mk_env_model _ (Model_Def.Syn_TEST _) = [] (*TODO handle correct list elements*)
511 | mk_env_model _ (Model_Def.Inc_TEST ((_, []), _)) = []
512 | mk_env_model id (Model_Def.Inc_TEST ((descr, ts), _)) =
513 if Model_Pattern.is_list_descr descr
514 then [(id, TermC.list2isalist (Model_Pattern.typ_of_element descr) ts)]
516 | mk_env_model _ (Model_Def.Sup_TEST _) = []
517 fun make_env_model equal_descr_pairs =
518 map (fn ((_, (_, id)), (_, _, _, _, (feedb, _)))
519 => (mk_env_model id feedb)) equal_descr_pairs
522 fun switch_type_TEST descr [] = descr
523 | switch_type_TEST (Free (id_string, _)) ts =
524 Free (id_string, ts |> hd |> TermC.lhs |> type_of)
525 | switch_type_TEST descr _ = raise ERROR ("switch_type undefined argument " ^
526 quote (UnparseC.term (ContextC.for_ERROR ()) descr))
527 fun discern_typ _ (_, []) = []
528 | discern_typ id (descr, ts) =
529 (*TODO.md "review (descriptor, ts)" REMOVE---------------\*)
531 val ts = if Model_Pattern.is_list_descr descr
532 then TermC.isalist2list (hd ts)
535 (*TODO.md "review (descriptor, ts)" REMOVE---------------/*)
536 if Model_Pattern.typ_of_element descr = HOLogic.boolT
537 andalso ts |> map TermC.lhs |> all_atoms
540 then raise ERROR "model items of type 'bool' in lists with 'lengt ts > 1' NOT YET IMPLEMENTED"
541 else [((switch_type_TEST id ts, TermC.lhs (hd ts)),
542 (TermC.lhs (hd ts), TermC.rhs (hd ts)))]
544 (*TODO.md "review (descriptor, ts)" REMOVE---------------\*)
546 (*TODO.md "review (descriptor, ts)" REMOVE---------------/*)
547 fun discern_feedback id (Model_Def.Cor_TEST ((descr, ts), _)) = discern_typ id (descr, ts)
548 | discern_feedback _ (Model_Def.Syn_TEST _) = [] (*TODO: handle correct elements*)
549 | discern_feedback id (Model_Def.Inc_TEST ((descr, ts), _)) = discern_typ id (descr, ts)
550 | discern_feedback _ (Model_Def.Sup_TEST _) = []
551 fun make_envs_preconds equal_givens =
552 map (fn ((_, (_, id)), (_, _, _, _, (feedb, _))) => discern_feedback id feedb) equal_givens
556 (* filter_variants': Model_Def.i_model_TEST -> Model_Def.variant -> Model_Def.i_model_TEST*)
557 fun filter_variants' i_singles n =
558 filter (fn (_, variants, _, _, _) => member op= variants n) i_singles
559 (*arrange_args1: int list -> int * Model_Def.variant list -> (int * Model_Def.variant) list*)
560 fun arrange_args1 [] _ = []
561 | arrange_args1 (sum :: ss) (cnt, all) = (sum, nth cnt all) :: (arrange_args1 ss (cnt + 1, all))
562 (*cnt_corrects: I_Model.T_TEST -> int*)
563 fun cnt_corrects i_model =
564 fold (curry op +) (map (fn (_, _, _, _, (Cor_TEST _, _)) => 1 | _ => 0) i_model) 0;
567 fun of_max_variant model_patt i_model =
569 fun of_max_variant _ [] = ([], [], ([], []))
570 | of_max_variant model_patt i_model =
574 map (fn (_, variants, _, _, _) => variants) i_model
577 val variants_separated = map (filter_variants' i_model) all_variants
578 val sums_corr = map (cnt_corrects) variants_separated
579 val sum_variant_s = arrange_args1 sums_corr (1, all_variants)
580 val (_, max_variant) = hd (*..crude decision, up to improvement *)
581 (sort (fn ((i, _), (j, _)) => int_ord (i, j)) sum_variant_s)
583 filter (fn (_, variants, _ , _ ,_) => member (op =) variants max_variant) i_model
584 val equal_descr_pairs = map (get_equal_descr i_model) model_patt |> flat
586 val env_subst = mk_env_subst_DEL equal_descr_pairs
587 val env_eval = mk_env_eval_DEL i_model_max
589 (i_model_max, env_subst, env_eval)
592 val env_model = make_env_model equal_descr_pairs
593 val equal_givens = filter (fn ((m_field, _), _) => m_field = "#Given") equal_descr_pairs
594 val subst_eval_list = make_envs_preconds equal_givens
595 val (env_subst, env_eval) = split_list subst_eval_list
597 (i_model_max, env_model, (env_subst, env_eval))
602 (** check pre-conditions **)
604 (* expects the precondition from Problem, ie. needs substitution *)
605 fun check _ _ [] _ _ = (true, [])
606 | check ctxt where_rls pres pbl (_ (*I_Model.variants UNNECESSARY: I_Model.T filtered for*)) =
608 val env = environment pbl;
609 val pres' = map (TermC.subst_atomic_all env) pres;
610 val evals = map (eval ctxt where_rls) pres';
611 in (foldl and_ (true, map fst evals), evals) end;
612 (* expects the precondition from PIDE, ie. already substituted *)
613 fun check_TEST _ _ [] _ = (true, [])
614 | check_TEST ctxt where_rls preconds env_eval =
617 map (fn (t, pos) => (subst_atomic env_eval t, pos)) preconds
619 map (fn (term, pos) => (Rewrite.eval_true ctxt [term] where_rls, (term, pos))) full_subst
621 (foldl and_ (true, map fst evals), (map fst evals) ~~ preconds)
623 fun check_from_store ctxt where_rls pres env_subst env_eval =
625 val pres_subst = map (TermC.subst_atomic_all env_subst) pres;
626 val full_subst = map (fn (bool, t) => (bool, subst_atomic env_eval t)) pres_subst
627 val evals = map (eval ctxt where_rls) full_subst
629 (foldl and_ (true, map fst evals), pres_subst)
633 (* expects the precondition from Problem, ie. needs substitution *)
634 fun check_OLD _ _ [] _ = (true, [])
635 | check_OLD ctxt where_rls pres (model_patt, i_model) =
638 val (env_subst, env_eval) = sep_variants_envs_OLD model_patt i_model
640 val (_, _, (env_subst, env_eval)) = of_max_variant model_patt i_model
642 val pres_subst = map (TermC.subst_atomic_all env_subst) pres;
643 val full_subst = map (fn (bool, t) => (bool, subst_atomic env_eval t)) pres_subst
644 val evals = map (eval ctxt where_rls) full_subst
646 (foldl and_ (true, map fst evals), pres_subst)
649 fun unchecked_OLD_to_TEST pres = map (fn t => (t, Position.none)) pres