Walther@60760
|
1 |
(* Title: Specify/m-match.sml
|
walther@59960
|
2 |
Author: Walther Neuper 110226
|
walther@59960
|
3 |
(c) due to copyright terms
|
walther@59960
|
4 |
|
walther@59960
|
5 |
Operations on models.
|
walther@59960
|
6 |
*)
|
walther@59960
|
7 |
|
walther@59984
|
8 |
signature MODEL_MATCH =
|
walther@59960
|
9 |
sig
|
Walther@60768
|
10 |
datatype T =
|
walther@59969
|
11 |
Matches of Problem.id * P_Model.T
|
walther@59971
|
12 |
| NoMatch of Problem.id * P_Model.T
|
walther@59984
|
13 |
val matchs2str : T list -> string
|
Walther@60768
|
14 |
|
Walther@60768
|
15 |
val data_by_o: Proof.context -> O_Model.T ->
|
Walther@60770
|
16 |
Model_Pattern.T * Pre_Conds.unchecked * Rule_Def.rule_set ->
|
Walther@60782
|
17 |
bool * (I_Model.T * Pre_Conds.T)
|
Walther@60768
|
18 |
val by_o_model: Proof.context -> O_Model.T ->
|
Walther@60768
|
19 |
Model_Pattern.single list * Pre_Conds.unchecked * Rule_Def.rule_set -> bool
|
Walther@60782
|
20 |
val by_i_model: Proof.context -> I_Model.T ->
|
Walther@60770
|
21 |
Model_Pattern.T * Pre_Conds.unchecked * Rule_Def.rule_set -> bool * Pre_Conds.T
|
Walther@60782
|
22 |
val by_i_models: Proof.context -> O_Model.T -> I_Model.T * I_Model.T ->
|
Walther@60760
|
23 |
Model_Pattern.T * Pre_Conds.unchecked * Rule_Def.rule_set ->
|
Walther@60782
|
24 |
bool * (I_Model.T * Pre_Conds.T)
|
walther@59987
|
25 |
|
walther@59996
|
26 |
val arguments: theory -> Model_Pattern.T -> term list -> O_Model.T
|
walther@59987
|
27 |
val arguments_msg: Problem.id -> term -> term list -> unit
|
walther@59968
|
28 |
|
walther@60251
|
29 |
datatype match' = (* constructors for tests only *)
|
walther@60251
|
30 |
Matches' of P_Model.T | NoMatch' of P_Model.T
|
Walther@60769
|
31 |
val by_formalise : Formalise.model -> Problem.T -> match'
|
Walther@60729
|
32 |
|
Walther@60729
|
33 |
(*from isac_test for Minisubpbl*)
|
Walther@60770
|
34 |
val contains_o: Model_Def.descriptor -> O_Model.T -> bool
|
Walther@60729
|
35 |
|
wenzelm@60223
|
36 |
\<^isac_test>\<open>
|
walther@60010
|
37 |
val matc: theory -> Model_Pattern.T -> term list -> O_Model.T -> O_Model.T
|
wenzelm@60223
|
38 |
\<close>
|
walther@59987
|
39 |
(*\------- rename -------/*)
|
walther@59960
|
40 |
end
|
walther@59960
|
41 |
|
walther@59968
|
42 |
(**)
|
walther@59997
|
43 |
structure M_Match(** ) : MODEL_MATCH( **) =
|
walther@59960
|
44 |
struct
|
walther@59968
|
45 |
(**)
|
walther@59960
|
46 |
|
walther@59984
|
47 |
datatype T =
|
walther@59969
|
48 |
Matches of Problem.id * P_Model.T
|
walther@59969
|
49 |
| NoMatch of Problem.id * P_Model.T;
|
Walther@60585
|
50 |
fun match2str (Matches (pI, model)) = "Matches (" ^ strs2str pI ^ ", " ^ P_Model.to_string model ^ ")"
|
Walther@60585
|
51 |
| match2str (NoMatch (pI, model)) = "NoMatch (" ^ strs2str pI ^ ", " ^ P_Model.to_string model ^ ")";
|
walther@59965
|
52 |
fun matchs2str ms = (strs2str o (map match2str)) ms;
|
walther@59965
|
53 |
|
Walther@60770
|
54 |
fun contains_o descr o_model =
|
Walther@60768
|
55 |
case find_first (fn (_, _, _, descr', _) => descr' = descr) o_model of
|
Walther@60768
|
56 |
SOME _ => true | NONE => false
|
Walther@60768
|
57 |
fun data_by_o ctxt o_model (model_patt, where_, where_rls) =
|
Walther@60768
|
58 |
let
|
Walther@60768
|
59 |
val o_model_vnt = o_model
|
Walther@60768
|
60 |
|> map (fn o_single as (_, variants, _, _, _)
|
Walther@60768
|
61 |
=> if member_swap op = 1 (*variant 1 is mandatory*) variants then [o_single] else [])
|
Walther@60768
|
62 |
|> flat
|
Walther@60768
|
63 |
val is_complete = model_patt
|
Walther@60770
|
64 |
|> map (fn (_, (descr, _)) => contains_o descr o_model_vnt)
|
Walther@60768
|
65 |
|> curry (foldl and_) true
|
Walther@60768
|
66 |
val i_model = (*in order to match sig of Pre_Conds.check*)
|
Walther@60782
|
67 |
map (fn (a, b, c, d, e) => (a, b, true, c, (I_Model.Cor (d, e), Position.none))) o_model_vnt
|
Walther@60768
|
68 |
val (pre_conds_check, pre_conds) = Pre_Conds.check ctxt where_rls where_ (model_patt, i_model)
|
Walther@60768
|
69 |
in
|
Walther@60768
|
70 |
(is_complete andalso pre_conds_check, (i_model, pre_conds))
|
Walther@60768
|
71 |
end
|
walther@59968
|
72 |
|
Walther@60768
|
73 |
fun by_o_model ctxt o_model (model_patt, where_, where_rls) =
|
Walther@60768
|
74 |
(data_by_o ctxt o_model (model_patt, where_, where_rls)) |> #1
|
walther@59968
|
75 |
|
Walther@60769
|
76 |
fun by_i_models ctxt o_model (pbl_imod, met_imod) (met_patt, where_, where_rls) =
|
Walther@60760
|
77 |
let
|
Walther@60760
|
78 |
val met_imod = I_Model.fill_method o_model (pbl_imod, met_imod) met_patt
|
Walther@60760
|
79 |
val (check, preconds) = Pre_Conds.check ctxt where_rls where_ (met_patt, met_imod)
|
Walther@60760
|
80 |
in
|
Walther@60760
|
81 |
(check, (met_imod, preconds))
|
Walther@60760
|
82 |
end
|
walther@59971
|
83 |
|
Walther@60782
|
84 |
(*contains_i: descriptor -> I_Model.T -> bool*)
|
Walther@60770
|
85 |
fun contains_i descr i_model =
|
Walther@60770
|
86 |
case find_first (fn (_, _, _, _, (feedb, _)) => Model_Def.get_descr feedb = descr) i_model of
|
Walther@60770
|
87 |
SOME _ => true | NONE => false
|
Walther@60770
|
88 |
fun by_i_model ctxt i_model (model_patt, where_, where_rls) =
|
Walther@60770
|
89 |
let
|
Walther@60770
|
90 |
val max_vnt = last_elem (Model_Def.max_variants'' i_model)
|
Walther@60770
|
91 |
val i_model_vnt = filter (fn (_, vnts, _, _, _) => member op= vnts max_vnt) i_model
|
Walther@60770
|
92 |
val is_complete = model_patt
|
Walther@60770
|
93 |
|> map (fn (_, (descr, _)) => contains_i descr i_model_vnt)
|
Walther@60770
|
94 |
|> curry (foldl and_) true
|
Walther@60770
|
95 |
|
Walther@60770
|
96 |
val (env_model, (env_subst, env_eval)) = Pre_Conds.make_environments model_patt i_model_vnt;
|
Walther@60770
|
97 |
val (prec_check, precs)
|
Walther@60770
|
98 |
= Pre_Conds.check_envs ctxt where_rls where_ (env_model, (env_subst, env_eval))
|
Walther@60770
|
99 |
in
|
Walther@60770
|
100 |
(is_complete andalso prec_check, precs)
|
Walther@60770
|
101 |
end
|
Walther@60770
|
102 |
|
walther@59971
|
103 |
|
walther@59971
|
104 |
(** for use by math-authors **)
|
walther@59971
|
105 |
|
walther@59971
|
106 |
datatype match' = (* for the user *)
|
walther@59971
|
107 |
Matches' of P_Model.T
|
walther@59971
|
108 |
| NoMatch' of P_Model.T;
|
walther@59971
|
109 |
|
walther@59971
|
110 |
(* match a formalization with a problem type, for tests *)
|
Walther@60769
|
111 |
fun by_formalise fmz ({thy, where_, model, where_rls, ...}: Problem.T) =
|
walther@59971
|
112 |
let
|
Walther@60768
|
113 |
val ctxt = Proof_Context.init_global thy
|
Walther@60768
|
114 |
val (oris, _) = O_Model.init thy fmz model
|
Walther@60768
|
115 |
val (bool, (itms, where_')) = data_by_o ctxt oris (model, where_, where_rls);
|
walther@59971
|
116 |
in
|
walther@59971
|
117 |
if bool
|
Walther@60772
|
118 |
then Matches' (P_Model.from thy itms where_')
|
Walther@60772
|
119 |
else NoMatch' (P_Model.from thy itms where_')
|
walther@59971
|
120 |
end;
|
walther@59971
|
121 |
|
Walther@60586
|
122 |
(* split type-wrapper from program-arg and build part of an ori;
|
walther@59987
|
123 |
an type-error is reported immediately, raises an exn,
|
walther@59987
|
124 |
subsequent handling of exn provides 2nd part of error message *)
|
walther@59987
|
125 |
fun mtc thy (str, (dsc, _)) (ty $ var) =
|
Walther@60650
|
126 |
let val ctxt = Proof_Context.init_global thy
|
Walther@60650
|
127 |
in
|
walther@59987
|
128 |
((Thm.global_cterm_of thy (dsc $ var);(*type check*)
|
walther@59987
|
129 |
SOME (([1], str, dsc, (*[var]*)
|
walther@59987
|
130 |
Input_Descript.split' (dsc, var))) (*:ori without leading #*))
|
walther@59987
|
131 |
handle e as TYPE _ =>
|
walther@59987
|
132 |
(tracing (dashs 70 ^ "\n"
|
walther@59987
|
133 |
^ "*** ERROR while creating the items for the model of the ->problem\n"
|
walther@59987
|
134 |
^ "*** from the ->stac with ->typeconstructor in arglist:\n"
|
Walther@60675
|
135 |
^ "*** item (->description ->value): " ^ UnparseC.term ctxt dsc ^ " " ^ UnparseC.term ctxt var ^ "\n"
|
Walther@60650
|
136 |
^ "*** description: " ^ TermC.string_of_detail ctxt dsc
|
Walther@60650
|
137 |
^ "*** value: " ^ TermC.string_of_detail ctxt var
|
Walther@60650
|
138 |
^ "*** typeconstructor in script: " ^ TermC.string_of_detail ctxt ty
|
walther@59987
|
139 |
^ "*** checked by theory: " ^ Context.theory_name thy ^ "\n"
|
walther@59987
|
140 |
^ "*** " ^ dots 66);
|
walther@59987
|
141 |
writeln (@{make_string} e);
|
walther@59987
|
142 |
Exn.reraise e; (*raise ERROR "actual args do not match formal args";FIXXXME.WN100916*)
|
walther@59987
|
143 |
NONE))
|
Walther@60650
|
144 |
end
|
Walther@60650
|
145 |
| mtc thy _ t =
|
Walther@60650
|
146 |
let val ctxt = Proof_Context.init_global thy
|
Walther@60675
|
147 |
in raise ERROR ("mtc: uncovered case with" ^ UnparseC.term ctxt t) end
|
walther@59987
|
148 |
|
walther@59987
|
149 |
(* match each pat of the model-pattern with an actual argument;
|
walther@59987
|
150 |
precondition: copy-named vars are filtered out *)
|
walther@59987
|
151 |
fun matc _ [] _ oris = oris
|
Walther@60655
|
152 |
| matc thy pbt [] _ =
|
walther@59987
|
153 |
(tracing (dashs 70);
|
Walther@60655
|
154 |
raise ERROR ("actual arg(s) missing for '" ^ Model_Pattern.to_string
|
Walther@60655
|
155 |
(Proof_Context.init_global thy) pbt ^ "' i.e. should be 'copy-named' by '*_._'"))
|
walther@59987
|
156 |
| matc thy ((p as (_, (_, t))) :: pbt) (a :: ags) oris =
|
Walther@60475
|
157 |
(*del?..*)if (O_Model.is_copy_named' o TermC.free2str) t then oris
|
walther@59987
|
158 |
else(*..del?*)
|
walther@59987
|
159 |
let val opt = mtc thy p a
|
walther@59987
|
160 |
in
|
walther@59987
|
161 |
case opt of
|
walther@59987
|
162 |
SOME ori => matc thy pbt ags (oris @ [ori])
|
walther@59987
|
163 |
| NONE => [](*WN050903 skipped by exn handled in arguments*)
|
walther@59987
|
164 |
end
|
walther@59987
|
165 |
|
walther@59987
|
166 |
(* match the actual arguments of a SubProblem with a model-pattern
|
Walther@60473
|
167 |
and create an O_Model (in root-pbl created from Formalise.model).
|
walther@59987
|
168 |
expects ags:pats = 1:1, while copy-named are filtered out of pats;
|
walther@59987
|
169 |
if no 1:1 then exn raised by matc/mtc and handled at call.
|
walther@60152
|
170 |
copy-named pats are appended in order to get them into the Model-items *)
|
walther@59987
|
171 |
fun arguments thy pbt ags =
|
walther@59987
|
172 |
let
|
walther@59987
|
173 |
fun flattup (i, (var, bool, str, itm_)) = (i, var, bool, str, itm_)
|
walther@59987
|
174 |
val pbt' = filter_out O_Model.is_copy_named pbt
|
walther@59987
|
175 |
val cy = filter O_Model.is_copy_named pbt (* cy is NOT a (formal) argument, but the fun's result *)
|
walther@59987
|
176 |
val oris' = matc thy pbt' ags []
|
Walther@60473
|
177 |
val cy' = map (O_Model.copy_name pbt' oris') cy
|
Walther@60472
|
178 |
val ors = O_Model.add_enumerate (oris' @ cy') (*...appended in order to get into the Model-items *)
|
walther@59987
|
179 |
in (map flattup ors) end
|
walther@59987
|
180 |
|
walther@59987
|
181 |
(* report part of the error-msg which is not available in match_args *)
|
Walther@60559
|
182 |
fun arguments_msg ctxt pI stac ags =
|
walther@59987
|
183 |
let
|
Walther@60585
|
184 |
val pats = (#model o Problem.from_store ctxt) pI
|
walther@59987
|
185 |
val msg = (dots 70 ^ "\n"
|
walther@59987
|
186 |
^ "*** problem " ^ strs2str pI ^ " has the ...\n"
|
Walther@60655
|
187 |
^ "*** model-pattern " ^ Model_Pattern.to_string ctxt pats ^ "\n"
|
Walther@60675
|
188 |
^ "*** stac '" ^ UnparseC.term ctxt stac ^ "' has the ...\n"
|
Walther@60675
|
189 |
^ "*** arg-list " ^ UnparseC.terms ctxt ags ^ "\n"
|
walther@59987
|
190 |
^ dashs 70)
|
Walther@60556
|
191 |
in tracing msg end
|
walther@59987
|
192 |
|
walther@59968
|
193 |
(**)end(**)
|