1 (* Title: Specify/model.sml
2 Author: Walther Neuper 110226
3 (c) due to copyright terms
8 signature MODEL_MATCH =
10 datatype T = (* ------------vvvvvvvvv--- adapt to PIDE *)
11 Matches of Problem.id * P_Model.T
12 | NoMatch of Problem.id * P_Model.T
13 val matchs2str : T list -> string
14 (*/------- rename: TODO 220917 review -------\*)
15 (*val o_model: theory -> Rule_Set.T -> O_Model.T -> Model_Pattern.T * term list -> bool*)
16 val match_oris: Proof.context -> Rule_Set.T -> O_Model.T -> Model_Pattern.T * term list -> bool
17 (*unify ^^^^^^^^^^ vvvvvvvvvv
19 (*val match_oris': theory -> O_Model.T -> Model_Pattern.T * term list * Rule_Set.T ->
20 bool * (I_Model.T * Pre_Conds.T)*)
21 val match_oris': theory -> O_Model.T -> Model_Pattern.T * term list(*Pre_Cond.unchecked*) * Rule_Set.T ->
22 bool * (I_Model.T * Pre_Conds.T) (*^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v^v--- type*)
23 (*val o_i_model: O_Model.T * I_Model.T -> Model_Pattern.T * term list * Rule_Set.T -> theory ->
24 bool * (I_Model.T * Pre_Conds.T) (*?values--^^^^^^^^^?*)*)
25 val match_itms_oris: theory -> I_Model.T -> Model_Pattern.T * term list * Rule_Set.T ->
26 O_Model.T -> bool * (I_Model.T * Pre_Conds.T)
28 (*val arguments: theory -> Model_Pattern.T -> term list -> O_Model.T*)
29 val arguments: theory -> Model_Pattern.T -> term list -> O_Model.T
30 (*val arguments_msg: Problem.id -> term -> term list -> unit*)
31 val arguments_msg: Problem.id -> term -> term list -> unit
33 datatype match' = (* constructors for tests only *)
34 Matches' of P_Model.T | NoMatch' of P_Model.T
35 val match_pbl : Formalise.model -> Problem.T -> match'
37 (*val matc: theory -> Model_Pattern.T -> term list -> O_Model.T -> O_Model.T*)
38 val matc: theory -> Model_Pattern.T -> term list -> O_Model.T -> O_Model.T
40 (*\------- rename -------/*)
44 structure M_Match(** ) : MODEL_MATCH( **) =
49 Matches of Problem.id * P_Model.T
50 | NoMatch of Problem.id * P_Model.T;
51 fun match2str (Matches (pI, model)) = "Matches (" ^ strs2str pI ^ ", " ^ P_Model.to_string model ^ ")"
52 | match2str (NoMatch (pI, model)) = "NoMatch (" ^ strs2str pI ^ ", " ^ P_Model.to_string model ^ ")";
53 fun matchs2str ms = (strs2str o (map match2str)) ms;
56 fun field_eq f (_, _, f', _, _) = f = f';
58 fun eq2' (_, (d, _)) (_, _, _, d', _) = d = d';
59 fun eq2 (_, (d, _)) (_, _, _, _, itm_) = d = I_Model.descriptor itm_;
60 fun eq1 d (_, (d', _)) = (d = d');
62 fun ori2itmSup (i, v, _, d, ts) = (i, v, true, "#Given", I_Model.Sup (d, ts));
64 (* check an ori for matching a problemtype by description;
65 returns true only for itms found in pbt *)
66 fun chk1_ pbt (i, vats, f, d, vs) =
67 case find_first (eq1 d) pbt of
68 SOME (_, (_, id)) => [(i, vats, true, f, I_Model.Cor ((d, vs), (id, [Input_Descript.join'''' (d, vs)])))]
71 (* elem 'p' of pbt contained in itms ? *)
72 fun chk1_m itms p = case find_first (eq2 p) itms of SOME _ => true | NONE => false;
73 fun chk1_m' oris (p as (f, (d, t))) =
74 case find_first (eq2' p) oris of
76 | NONE => [(f, I_Model.Mis (d, t))];
77 fun pair0vatsfalse (f, itm_) = (0, [], false, f, itm_);
79 fun chk1_mis _(*mvat*) itms model = foldl and_ (true, map (chk1_m itms) model);
80 fun chk1_mis' oris model = map pair0vatsfalse ((flat o (map (chk1_m' oris))) model);
82 (* check a problem (ie. ori list) for matching a problemtype,
83 takes the I_Model.variables for concluding completeness (FIXME could be another!) *)
84 fun match_oris ctxt where_rls oris (pbt,where_) =
86 val itms = (flat o (map (chk1_ pbt))) oris;
87 val mvat = I_Model.variables itms;
88 val complete = chk1_mis mvat itms pbt;
89 val (pb, _(*where_'*)) = Pre_Conds.check ctxt where_rls where_ itms mvat;
90 in if complete andalso pb then true else false end;
92 (* check a problem (ie. ori list) for matching a problemtype,
93 returns items for output to math-experts *)
94 fun match_oris' thy oris (model, where_, where_rls) =
96 val itms = (flat o (map (chk1_ model))) oris;
97 val sups = ((map ori2itmSup) o (filter (field_eq "#undef"))) oris;
98 val mvat = I_Model.variables itms;
99 val miss = chk1_mis' oris model;
100 val (pb, where_') = Pre_Conds.check (Proof_Context.init_global thy) where_rls where_ itms mvat;
101 in (miss = [] andalso pb, (itms @ miss @ sups, where_')) end;
104 (** check a problem (ie. itm list) for matching a problemtype **)
106 (* check a problem (or method) pbl (ie. itm list) for matching a problemtype pbt,
107 for missing items get data from formalization (ie. ori list);
108 takes the I_Model.variables for concluding completeness (could be another!)
110 (0) determine the most frequent variant mv in pbl
111 ALL pbt. (1) dsc(pbt) notmem dsc(pbls) =>
112 (2) filter (dsc(pbt) = dsc(oris)) oris; -> news;
113 (3) newitms = filter (mv mem vat(news)) news
115 fun match_itms_oris ctxt pbl (pbt, where_, where_rls) oris =
117 (*0*)val mv = I_Model.max_variant pbl;
119 fun eqdsc_pbt_itm ((_,(d,_))) (_, _, _, _, itm_) = d = I_Model.descriptor itm_;
120 fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of
121 SOME _ => false | NONE => true;
122 (*1*)val mis = (filter (notmem pbl)) pbt;
124 fun eqdsc_ori (_,(d,_)) (_, _, _, d', _) = d = d';
125 fun ori2itmMis (f, (d, pid)) (i, v, _, _, _) = (i, v, false, f, I_Model.Mis (d, pid));
126 (*2*)fun oris2itms oris mis1 = ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris;
127 val news = (flat o (map (oris2itms oris))) mis;
128 (*3*)fun mem_vat (_, vats, _, _, _) = member op = vats mv;
129 val newitms = filter mem_vat news;
130 (*4*)val itms' = pbl @ newitms;
131 val (pb, where_') = Pre_Conds.check ctxt where_rls where_ itms' mv;
132 in (length mis = 0 andalso pb, (itms', where_')) end;
135 (** for use by math-authors **)
137 datatype match' = (* for the user *)
138 Matches' of P_Model.T
139 | NoMatch' of P_Model.T;
141 (* match a formalization with a problem type, for tests *)
142 fun match_pbl fmz ({thy = thy, where_ = where_, model, where_rls = er, ...}: Problem.T) =
144 val oris = O_Model.init thy fmz model(* |> #1*);
145 val (bool, (itms, where_')) = match_oris' thy oris (model, where_, er);
148 then Matches' (P_Model.from thy itms where_')
149 else NoMatch' (P_Model.from thy itms where_')
152 (* split type-wrapper from program-arg and build part of an ori;
153 an type-error is reported immediately, raises an exn,
154 subsequent handling of exn provides 2nd part of error message *)
155 fun mtc thy (str, (dsc, _)) (ty $ var) =
156 ((Thm.global_cterm_of thy (dsc $ var);(*type check*)
157 SOME (([1], str, dsc, (*[var]*)
158 Input_Descript.split' (dsc, var))) (*:ori without leading #*))
159 handle e as TYPE _ =>
160 (tracing (dashs 70 ^ "\n"
161 ^ "*** ERROR while creating the items for the model of the ->problem\n"
162 ^ "*** from the ->stac with ->typeconstructor in arglist:\n"
163 ^ "*** item (->description ->value): " ^ UnparseC.term dsc ^ " " ^ UnparseC.term var ^ "\n"
164 ^ "*** description: " ^ TermC.term_detail2str dsc
165 ^ "*** value: " ^ TermC.term_detail2str var
166 ^ "*** typeconstructor in script: " ^ TermC.term_detail2str ty
167 ^ "*** checked by theory: " ^ Context.theory_name thy ^ "\n"
169 writeln (@{make_string} e);
170 Exn.reraise e; (*raise ERROR "actual args do not match formal args";FIXXXME.WN100916*)
172 | mtc _ _ t = raise ERROR ("mtc: uncovered case with" ^ UnparseC.term t)
174 (* match each pat of the model-pattern with an actual argument;
175 precondition: copy-named vars are filtered out *)
176 fun matc _ [] _ oris = oris
179 raise ERROR ("actual arg(s) missing for '" ^ Model_Pattern.to_string pbt ^ "' i.e. should be 'copy-named' by '*_._'"))
180 | matc thy ((p as (_, (_, t))) :: pbt) (a :: ags) oris =
181 (*del?..*)if (O_Model.is_copy_named' o TermC.free2str) t then oris
183 let val opt = mtc thy p a
186 SOME ori => matc thy pbt ags (oris @ [ori])
187 | NONE => [](*WN050903 skipped by exn handled in arguments*)
190 (* match the actual arguments of a SubProblem with a model-pattern
191 and create an O_Model (in root-pbl created from Formalise.model).
192 expects ags:pats = 1:1, while copy-named are filtered out of pats;
193 if no 1:1 then exn raised by matc/mtc and handled at call.
194 copy-named pats are appended in order to get them into the Model-items *)
195 fun arguments thy pbt ags =
197 fun flattup (i, (var, bool, str, itm_)) = (i, var, bool, str, itm_)
198 val pbt' = filter_out O_Model.is_copy_named pbt
199 val cy = filter O_Model.is_copy_named pbt (* cy is NOT a (formal) argument, but the fun's result *)
200 val oris' = matc thy pbt' ags []
201 val cy' = map (O_Model.copy_name pbt' oris') cy
202 val ors = O_Model.add_enumerate (oris' @ cy') (*...appended in order to get into the Model-items *)
203 in (map flattup ors) end
205 (* report part of the error-msg which is not available in match_args *)
206 fun arguments_msg ctxt pI stac ags =
208 val pats = (#model o Problem.from_store ctxt) pI
209 val msg = (dots 70 ^ "\n"
210 ^ "*** problem " ^ strs2str pI ^ " has the ...\n"
211 ^ "*** model-pattern " ^ Model_Pattern.to_string pats ^ "\n"
212 ^ "*** stac '" ^ UnparseC.term stac ^ "' has the ...\n"
213 ^ "*** arg-list " ^ UnparseC.terms ags ^ "\n"