1 (* Title: Specify/o-model.sml
2 Author: Walther Neuper 110226
3 (c) due to copyright terms
5 An \<open>O_Model\<close> holds \<open>O\<close>riginal data, \<open>descriptor\<close> and \<open>values\<close> parsed from \<open>Formalise.model\<close>
6 selected with respect to a \<open>Model_Pattern\<close> and combined with respective \<open>m_field\<close>s.
7 \<open>complete_for\<close> a \<open>Model_Pattern\<close> is done by \<open>Tactic.Model_Problem\<close>
8 (with defaults from \<open>Formalise\<close>refs), by \<open>Tactic.Specify_Problem\<close> and \<open>Tactic.Specify_Method\<close>
10 \<open>O_Model\<close> serves efficiency of student's interactive modelling via \<open>I_Model\<close>.
12 \<open>O_Model\<close> marks elements with \<open>m_field\<close> \<open>#undef\<close>, which are not required by the \<open>Model_Pattern\<close>
13 of the \<open>Problem\<close> or the \<open>MethodC\<close> .. TODO redes: \<open>m_field\<close> probably different in root..Subproblem
15 TODO: revise with an example with more than 1 variant.
16 + consider: drop m_field ?
19 signature ORIGINAL_MODEL =
30 val to_string: Proof.context -> T -> string
31 val single_to_string: Proof.context -> single -> string
32 val single_empty: single
34 val init: theory -> Formalise.model -> Model_Pattern.T -> T * Proof.context
35 val values : T -> term list
36 val values': Proof.context -> T -> Formalise.model * term list
37 val complete_for: Model_Pattern.T -> T -> T * Proof.context -> T * Proof.context
38 val associate_input: Proof.context -> m_field(*del?*) -> descriptor * values -> T -> message * single * values
39 val associate_input': Proof.context -> m_field -> values -> T -> message * single * values
40 val contains: Proof.context -> m_field -> T -> term -> message * single * values
41 val make_typeless: term -> term
42 val test_types: Proof.context -> descriptor * values -> string
44 val add_enumerate: 'a list -> (int * 'a) list
46 val copy_name: Model_Pattern.T -> preori list -> Model_Pattern.single -> preori
47 val is_copy_named: Model_Pattern.single -> bool
48 val is_copy_named': string -> bool
49 val is_copy_named_generating: Model_Pattern.single -> bool
51 val get_field_term: theory -> single -> m_field * UnparseC.term_as_string
54 val is_copy_named_generating_idstr: string -> bool
55 val string_of_preoris : preori list -> string
56 val add_field: theory -> Model_Pattern.T -> descriptor * values -> m_field * descriptor * values
58 val add_variants: ('a * ''b * 'c) list -> (int * ('a * ''b * 'c)) list
59 val max_variant: variants -> int
60 val partition_variants: ('a * 'a -> bool) -> 'a list -> (int * 'a) list
61 val collect_variants: ('a * ''b) list -> ('a list * ''b) list
63 val replace_0: int -> int list -> int list
64 val flattup: 'a * ('b * ('c * 'd * 'e)) -> 'a * 'b * 'c * 'd * 'e
69 structure O_Model(**) : ORIGINAL_MODEL(**) =
75 type variant = Model_Def.variant;
76 type variants = Model_Def.variants;
77 type m_field = Model_Def.m_field;
78 type descriptor = Model_Def.descriptor;
79 type values = Model_Def.values;
80 type message = string;
82 type T = Model_Def.o_model;
83 val empty = [] : Model_Def.o_model;
84 type single = Model_Def.o_model_single
85 val single_empty = Model_Def.o_model_empty;
87 val single_to_string = Model_Def.o_model_single_to_string;
88 val to_string = Model_Def.o_model_to_string;
90 (* O_Model.single without leading integer *)
91 type preori = (variants * m_field * term * term list);
93 fun preori2str (vs, fi, t, ts) =
94 "(" ^ (strs2str o (map string_of_int)) vs ^ ", " ^ fi ^ ", " ^
95 UnparseC.term t ^ ", " ^ (strs2str o (map UnparseC.term)) ts ^ ")";
96 val string_of_preoris = (strs2str' o (map (linefeed o preori2str)));
99 (* get the first term in ts from ori *)
100 fun get_field_term thy (_, _, fd, d, ts) =
101 (fd, ((UnparseC.term_in_thy thy) o Input_Descript.join) (d,[hd ts]))
104 (** initialise O_Model **)
106 (* compare d and dsc in pbt and transfer field to where_-ori *)
107 fun add_field (_: theory) pbt (d,ts) =
108 let fun eq d pt = (d = (fst o snd) pt);
109 in case filter (eq d) pbt of
110 [(fi, (_, _))] => (fi, d, ts)
111 | [] => ("#undef", d, ts) (*may come with met.model*)
112 | _ => raise ERROR ("add_field: " ^ UnparseC.term d ^ " more than once in pbt")
116 mark an element with the position within a plateau;
117 a plateau with length 1 is marked with 0
119 fun partition_variants _ [] = raise ERROR "partition_variants []"
120 | partition_variants eq xs =
122 fun mar xx _ [x] n = xx @ [(if n = 1 then 0 else n, x)]
123 | mar _ _ [] _ = raise ERROR "partition_variants []"
124 | mar xx eq (x :: x' :: xs) n =
125 if eq (x, x') then mar (xx @ [(n, x)]) eq (x' :: xs) (n + 1)
126 else mar (xx @ [(if n = 1 then 0 else n, x)]) eq (x' :: xs) 1;
127 in mar [] eq xs 1 end;
130 assumes equal descriptions to be in adjacent 'plateaus',
131 items at a certain position within the plateaus form a variant;
132 length = 1 ... marked with 0: covers all variants
134 fun add_variants fdts =
136 fun eq (a, b) = curry op= (snd3 a) (snd3 b);
137 in partition_variants eq fdts end;
139 fun max_variant [] = raise ERROR "max_variant of []"
140 | max_variant (y :: ys) =
142 | mx x (y :: ys) = if x < y then mx y ys else mx x ys;
145 fun collect_variants (((v,x) :: vxs)) =
147 fun col xs (vs, x) [] = xs @ [(vs, x)]
148 | col xs (vs, x) ((v', x') :: vxs') =
149 if x = x' then col xs (vs @ [v'], x') vxs'
150 else col (xs @ [(vs, x)]) ([v'], x') vxs';
151 in col [] ([v], x) vxs end
152 | collect_variants _ = raise ERROR "collect_variants: called with []";
154 fun replace_0 vm [0] = intsto vm
155 | replace_0 _ vs = vs;
157 fun add_enumerate [] = raise ERROR "O_Model.add_enumerate []"
161 | add n (x :: xs) = (n, x) :: add (n + 1) xs;
164 fun flattup (a, (b, (c, d, e))) = (a, b, c, d, e);
166 fun init _ [] _ = ([], ContextC.empty)
169 val (ts, ctxt) = ContextC.init_while_parsing fmz thy
172 |> Input_Descript.split
173 |> add_field thy pbt) ts)
175 val maxv = model |> map fst |> max_variant;
176 val maxv = if maxv = 0 then 1 else maxv;
179 |> map (replace_0 maxv |> apfst)
182 in (model', ctxt) end
184 (** get the values **)
186 fun mkval _(*dsc*) [] = raise ERROR "mkval called with []"
188 | mkval _ ts = TermC.list2isalist ((type_of o hd) ts) ts;
189 fun mkval' x = mkval TermC.empty x;
190 (* from an O_Model create values for ctxt *)
192 ((map (mkval' o (#5))) o (filter ((member_swap op= 1) o (#2)))) oris
194 (* from an O_Model create (Formalise.model, values)
195 e.g. Subproblem ["BOOL (1+x=2)", "REAL x"]
196 --match_ags--> O_Model.T
197 O_Model.T --values'--> (["equality (1+x=2)", "boundVariable x", "solutions L"], values)
199 fun values' ctxt oris =
201 fun ori2fmz_vals (_, _, _, dsc, ts) =
202 case \<^try>\<open>(((UnparseC.term_in_ctxt ctxt) o Input_Descript.join') (dsc, ts), last_elem ts)\<close> of
204 | NONE => raise ERROR ("O_Model.values' called with " ^ UnparseC.terms_in_ctxt ctxt ts)
205 in (split_list o (map ori2fmz_vals)) oris end
208 (** complete wrt. Model_Pattern.T by use of root's O_Model.T **)
210 fun complete_for m_patt root_model (o_model, ctxt) =
212 val missing = m_patt |> filter_out
213 (fn (_, (descriptor, _)) => (member op = (map #4 o_model) descriptor))
214 val add = (root_model
216 (fn (_, _, _, descriptor, _) => (member op = (map (fst o snd) missing)) descriptor))
219 |> map (fn (a, b, _, descr, e) =>
220 case Model_Pattern.get_field descr m_patt of
221 SOME m_field => (a, b, m_field, descr, e)
222 | NONE => (a, b, "#undef", descr, e))
223 |> map (fn (_, b, c, d, e) => (b, c, d, e)) (* for correct enumeration *)
224 |> add_enumerate (* for correct enumeration *)
225 |> map (fn (a, (b, c, d, e)) => (a, b, c, d, e)), (* for correct enumeration *)
226 ctxt |> ContextC.add_constraints (add |> values |> TermC.vars'))
232 (* make oris from args of the stac SubProblem and from pbt.
233 can this formal argument (of a model-pattern) be omitted in the arg-list
234 of a SubProblem ? see calcelems.sml 'type met ' *)
235 fun is_copy_named' str =
236 case (rev o Symbol.explode) str of
237 "'" :: _ :: "'" :: _ => true
239 fun is_copy_named (_, (_, t)) = (is_copy_named' o TermC.free2str) t
241 (* should this formal argument (of a model-pattern) create a new identifier? *)
242 fun is_copy_named_generating_idstr str =
243 if is_copy_named' str
245 case (rev o Symbol.explode) str of
246 "'" :: "'" :: "'" :: _ => false
249 fun is_copy_named_generating (_, (_, t)) = (is_copy_named_generating_idstr o TermC.free2str) t
251 (* generate a new variable "x_i" name from a related given one "x"
252 by use of oris relating "v_v'i'" (is_copy_named!) to "v_v"
253 e.g. (v_v, x) & (v_v'i', ?) --> (v_v'i', x_i),
254 but leave is_copy_named_generating as is, e.t. ss''' *)
255 fun copy_name pbt oris (p as (field, (dsc, t))) =
257 if is_copy_named_generating p
258 then (*WN051014 kept strange old code ...*)
259 let fun sel (_,_,d,ts) = Input_Descript.join'''' (d, ts)
260 val cy' = (implode o (drop_last_n 3) o Symbol.explode o TermC.free2str) t
261 val ext = (last_elem o drop_last o Symbol.explode o TermC.free2str) t
262 val vars' = map (Term.term_name o snd o snd) pbt (*cpy-nam filtered_out*)
263 val vals = map sel oris
264 val cy_ext = (Term.term_name o the) (assoc (vars' ~~ vals, cy')) ^ "_" ^ ext
265 in ([1], field, dsc, [TermC.mk_free (type_of t) cy_ext]) end
266 else ([1], field, dsc, [t])
269 | NONE => raise ERROR ("copy_name: for "^ UnparseC.term t)
272 (** tools for I_Model **)
274 (* to an input (_ $ values) find the according O_Model.single and insert the values *)
275 fun associate_input ctxt m_field (descript, vals) [] =
276 ("associate_input: input ('" ^
277 (UnparseC.term_in_ctxt ctxt (Input_Descript.join (descript, vals))) ^
278 "') not found in oris (typed)", (0, [], m_field, descript, vals), [])
279 | associate_input ctxt sel (d, ts) ((id, vat, sel', d', ts') :: oris) =
280 if sel = sel' andalso d = d' andalso (inter op = ts ts') <> []
281 then ("", (id, vat, sel, d, inter op = ts ts'), ts')
282 else associate_input ctxt sel (d, ts) oris
284 (* to an input (_ $ values) find the according O_Model.single and insert the values *)
285 fun associate_input' ctxt _ vals [] =
286 ("associate_input': input (_, '" ^ strs2str (map (UnparseC.term_in_ctxt ctxt) vals) ^
287 "') not found in oris (typed)", single_empty, [])
288 | associate_input' ctxt m_field vals ((id, vat, m_field', descr, vals') :: oris) =
289 if m_field = m_field' andalso (inter op = vals vals') <> []
291 if m_field = m_field'
292 then ("", (id, vat, m_field, descr, inter op = vals vals'), vals')
293 else ((strs2str' o map (UnparseC.term_in_ctxt ctxt)) vals ^
294 " not for " ^ m_field, single_empty, [])
295 else associate_input' ctxt m_field vals oris
297 fun test_types ctxt (d,ts) =
299 val opt = (try Input_Descript.join) (d, ts)
300 val msg = case opt of
302 | NONE => (UnparseC.term_in_ctxt ctxt d ^ " " ^
303 (strs2str' o map (UnparseC.term_in_ctxt ctxt)) ts ^ " is illtyped")
306 (* make a term 'typeless' for comparing with another 'typeless' term;
307 'type-less' usually is illtyped *)
308 fun make_typeless (Const (s, _)) = (Const (s, TermC.typ_empty))
309 | make_typeless (Free (s, _)) = (Free (s, TermC.typ_empty))
310 | make_typeless (Var (n, _)) = (Var (n, TermC.typ_empty))
311 | make_typeless (Bound i) = (Bound i)
312 | make_typeless (Abs (s, _,t)) = Abs(s, TermC.typ_empty, make_typeless t)
313 | make_typeless (t1 $ t2) = (make_typeless t1) $ (make_typeless t2)
315 (* is the term t input (or taken from fmz) known in O_Model ?
316 give feedback on all(?) strange input;
317 return _all_ terms already input to this item (e.g. valuesFor a,b) *)
318 fun contains ctxt sel ori t =
320 val ots = ((distinct op =) o flat o (map #5)) ori
321 val oids = ((map (fst o dest_Free)) o (distinct op =) o flat o (map TermC.vars)) ots
322 val (d, ts) = Input_Descript.split t
323 val ids = map (fst o dest_Free) (((distinct op =) o (flat o (map TermC.vars))) ts)
325 if (subtract op = oids ids) <> []
326 then ("identifiers " ^ strs2str' (subtract op = oids ids) ^ " not in example", single_empty, [])
330 if not (subset op = (map make_typeless ts, map make_typeless ots))
331 then ("terms '" ^ (strs2str' o (map (UnparseC.term_in_ctxt ctxt))) ts ^
332 "' not in example (make_typeless)", single_empty, [])
334 (case associate_input' ctxt sel ts(*..values*) ori of
335 ("", ori_ as (_, _, _, d, ts), all) =>
336 (case test_types ctxt (d,ts) of
337 "" => ("", ori_, all)
338 | msg => (msg, single_empty, []))
339 | (msg, _, _) => (msg, single_empty, []))
341 if member op = (map #4 ori) d
342 then associate_input ctxt sel (d, ts) ori
343 else (UnparseC.term_in_ctxt ctxt d ^ " not in example", (0, [], sel, d, ts), [])