walther@59938
|
1 |
(* Title: Specify/i-model.sml
|
walther@59938
|
2 |
Author: Walther Neuper 110226
|
walther@59938
|
3 |
(c) due to copyright terms
|
walther@59938
|
4 |
*)
|
walther@59938
|
5 |
|
walther@59938
|
6 |
signature MODEL_FOR_INTERACTION =
|
walther@59938
|
7 |
sig
|
walther@59969
|
8 |
|
walther@59961
|
9 |
type T
|
walther@59961
|
10 |
type single
|
walther@59948
|
11 |
val empty: single
|
walther@59960
|
12 |
type variants
|
walther@59961
|
13 |
type m_field
|
walther@59961
|
14 |
type descriptor
|
walther@59948
|
15 |
datatype feedback = datatype Model_Def.i_model_feedback
|
walther@59938
|
16 |
|
walther@59942
|
17 |
val feedback_to_string': feedback -> string
|
walther@59942
|
18 |
val feedback_to_string: Proof.context -> feedback -> string
|
walther@59942
|
19 |
val single_to_string: Proof.context -> single -> string
|
walther@59942
|
20 |
val to_string: Proof.context -> T -> string
|
walther@59942
|
21 |
|
walther@59958
|
22 |
|
walther@59956
|
23 |
datatype additm = Add of single | Err of string
|
walther@59958
|
24 |
val init: Model_Pattern.T -> T
|
walther@59958
|
25 |
val check_single: Proof.context -> m_field -> O_Model.T ->
|
walther@59956
|
26 |
T -> Model_Pattern.T -> TermC.as_string -> additm
|
walther@59958
|
27 |
val add_single: theory -> single -> T -> T
|
walther@59956
|
28 |
|
walther@59992
|
29 |
(*/------- to I_Model from Specify -------\*)
|
walther@59992
|
30 |
(*val make: I_Model.m_field -> TermC.as_string * I_Model.T -> Tactic.T*)
|
walther@59992
|
31 |
val get_tac: m_field -> TermC.as_string * T -> Tactic.T
|
walther@59992
|
32 |
(*\------- to I_Model from Specify -------/*)
|
walther@59988
|
33 |
(*/------- rename -------\*)
|
walther@59956
|
34 |
val d_in: feedback -> term
|
walther@59956
|
35 |
val ts_in: feedback -> term list
|
walther@59956
|
36 |
val vars_of: T -> term list
|
walther@59956
|
37 |
val max_vt: T -> int
|
walther@59958
|
38 |
val is_known: Proof.context -> string -> O_Model.T -> term -> string * O_Model.single * term list
|
walther@59958
|
39 |
val is_notyet_input : Proof.context -> T -> term list -> O_Model.single -> ('a * (term * term)) list
|
walther@59958
|
40 |
-> string * single
|
walther@59958
|
41 |
val dsc_unknown: term
|
walther@59992
|
42 |
val geti_ct: theory -> O_Model.single -> single -> m_field * UnparseC.term_as_string
|
walther@59988
|
43 |
val pbl_ids': term -> term list -> term list
|
walther@59948
|
44 |
|
walther@59956
|
45 |
val mk_env: T -> (term * term) list
|
walther@59956
|
46 |
val penvval_in: feedback -> term list
|
walther@59988
|
47 |
(*\------- rename -------/*)
|
walther@59956
|
48 |
|
walther@59988
|
49 |
val complete: O_Model.T -> T -> T -> Model_Pattern.T -> T
|
walther@59988
|
50 |
val add: single -> T -> T
|
walther@59988
|
51 |
val complete_method: O_Model.T * Model_Pattern.T * Model_Pattern.T * T -> T * T
|
walther@59988
|
52 |
val is_error: feedback -> bool
|
walther@59988
|
53 |
val complete': Model_Pattern.T -> O_Model.single -> single
|
walther@59956
|
54 |
|
walther@59938
|
55 |
(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
|
walther@59988
|
56 |
val is_complete: T -> bool
|
walther@59988
|
57 |
val to_p_model: theory -> feedback -> string
|
walther@59988
|
58 |
(*/------- rename -------\*)
|
walther@59956
|
59 |
val dts2str: term * (term list) -> string
|
walther@59956
|
60 |
val eq1: ''a -> 'b * (''a * 'c) -> bool
|
walther@59988
|
61 |
(*\------- rename -------/*)
|
walther@59938
|
62 |
(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
|
walther@59988
|
63 |
(*/------- rename -------\*)
|
walther@59958
|
64 |
val vts_in: T -> int list
|
walther@59956
|
65 |
val seek_oridts: Proof.context -> ''a -> term * term list -> (int * 'b list * ''a * term * term list) list -> string * (int * 'b list * ''a * term * term list) * term list
|
walther@59988
|
66 |
(*\------- rename -------/*)
|
walther@59938
|
67 |
( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
|
walther@59938
|
68 |
end
|
walther@59938
|
69 |
|
walther@59942
|
70 |
(**)
|
walther@59938
|
71 |
structure I_Model(**) : MODEL_FOR_INTERACTION(**) =
|
walther@59938
|
72 |
struct
|
walther@59942
|
73 |
(**)
|
walther@59955
|
74 |
|
walther@59958
|
75 |
(** data types **)
|
walther@59958
|
76 |
|
walther@59940
|
77 |
type variants = Model_Def.variants;
|
walther@59952
|
78 |
type m_field = Model_Def.m_field;
|
walther@59952
|
79 |
type descriptor = Model_Def.descriptor;
|
walther@59938
|
80 |
|
walther@59940
|
81 |
type T = Model_Def.i_model_single list;
|
walther@59940
|
82 |
datatype feedback = datatype Model_Def.i_model_feedback;
|
walther@59940
|
83 |
type single = Model_Def.i_model_single;
|
walther@59940
|
84 |
val empty = Model_Def.i_model_empty;
|
walther@59938
|
85 |
|
walther@59942
|
86 |
fun pen2str ctxt (t, ts) =
|
walther@59942
|
87 |
pair2str (UnparseC.term_in_ctxt ctxt t, (strs2str' o map (UnparseC.term_in_ctxt ctxt)) ts);
|
walther@59948
|
88 |
|
walther@59942
|
89 |
fun feedback_to_string ctxt (Cor ((d, ts), penv)) =
|
walther@59953
|
90 |
"Cor " ^ UnparseC.term_in_ctxt ctxt (Input_Descript.join (d, ts)) ^ " ," ^ pen2str ctxt penv
|
walther@59942
|
91 |
| feedback_to_string _ (Syn c) = "Syn " ^ c
|
walther@59942
|
92 |
| feedback_to_string _ (Typ c) = "Typ " ^ c
|
walther@59942
|
93 |
| feedback_to_string ctxt (Inc ((d, ts), penv)) =
|
walther@59953
|
94 |
"Inc " ^ UnparseC.term_in_ctxt ctxt (Input_Descript.join (d, ts)) ^ " ," ^ pen2str ctxt penv
|
walther@59942
|
95 |
| feedback_to_string ctxt (Sup (d, ts)) =
|
walther@59953
|
96 |
"Sup " ^ UnparseC.term_in_ctxt ctxt (Input_Descript.join (d, ts))
|
walther@59942
|
97 |
| feedback_to_string ctxt (Mis (d, pid)) =
|
walther@59942
|
98 |
"Mis "^ UnparseC.term_in_ctxt ctxt d ^ " " ^ UnparseC.term_in_ctxt ctxt pid
|
walther@59942
|
99 |
| feedback_to_string _ (Par s) = "Trm "^s;
|
walther@59942
|
100 |
fun feedback_to_string' t = feedback_to_string (ThyC.id_to_ctxt "Isac_Knowledge") t;
|
walther@59942
|
101 |
|
walther@59942
|
102 |
fun single_to_string ctxt (i, is, b, s, itm_) =
|
walther@59942
|
103 |
"(" ^ string_of_int i ^ " ," ^ ints2str' is ^ " ," ^ bool2str b ^ " ," ^
|
walther@59942
|
104 |
s ^ " ," ^ feedback_to_string ctxt itm_ ^ ")";
|
walther@59942
|
105 |
fun to_string ctxt itms = strs2str' (map (linefeed o (single_to_string ctxt)) itms);
|
walther@59942
|
106 |
|
walther@59958
|
107 |
|
walther@59992
|
108 |
(*/------- to I_Model from Specify -------\*)
|
walther@59992
|
109 |
fun get_tac m_field (term_as_string, i_model) =
|
walther@59992
|
110 |
case m_field of
|
walther@59992
|
111 |
"#Given" => Tactic.Add_Given' (term_as_string, i_model)
|
walther@59992
|
112 |
| "#Find" => Tactic.Add_Find' (term_as_string, i_model)
|
walther@59992
|
113 |
| "#Relate" => Tactic.Add_Relation'(term_as_string, i_model)
|
walther@59992
|
114 |
| str => raise ERROR ("specify_additem Frm, Pbl: uncovered case with " ^ str);
|
walther@59992
|
115 |
(*\------- to I_Model from Specify -------/*)
|
walther@59992
|
116 |
|
walther@59992
|
117 |
|
walther@59958
|
118 |
(** initialise a model **)
|
walther@59958
|
119 |
|
walther@59958
|
120 |
fun init pbt =
|
walther@59958
|
121 |
let
|
walther@59958
|
122 |
fun pbt2itm (f, (d, _)) = (0, [], false, f, Inc ((d, []), (TermC.empty, [])))
|
walther@59958
|
123 |
in map pbt2itm pbt end
|
walther@59958
|
124 |
|
walther@59958
|
125 |
|
walther@59958
|
126 |
(** check input on a model **)
|
walther@59942
|
127 |
|
walther@59943
|
128 |
(* find most frequent variant v in itms *)
|
walther@59943
|
129 |
fun vts_in itms = (distinct o flat o (map #2)) (itms: T);
|
walther@59943
|
130 |
|
walther@59943
|
131 |
fun cnt itms v = (v, (length o (filter (curry op = v)) o flat o (map #2)) itms);
|
walther@59943
|
132 |
fun vts_cnt vts itms = map (cnt itms) vts;
|
walther@59962
|
133 |
fun max2 [] = raise ERROR "max2 of []"
|
walther@59943
|
134 |
| max2 (y :: ys) =
|
walther@59943
|
135 |
let
|
walther@59943
|
136 |
fun mx (a,x) [] = (a,x)
|
walther@59943
|
137 |
| mx (a, x) ((b,y) :: ys) = if x < y then mx (b, y) ys else mx (a, x) ys;
|
walther@59943
|
138 |
in mx y ys end;
|
walther@59943
|
139 |
|
walther@59943
|
140 |
(* get the constant value from a penv *)
|
walther@59943
|
141 |
fun getval (id, values) =
|
walther@59943
|
142 |
case values of
|
walther@59962
|
143 |
[] => raise ERROR ("penv_value: no values in '" ^ UnparseC.term id)
|
walther@59943
|
144 |
| [v] => (id, v)
|
walther@59943
|
145 |
| (v1 :: v2 :: _) => (case v1 of
|
walther@59943
|
146 |
Const ("Program.Arbfix",_) => (id, v2)
|
walther@59943
|
147 |
| _ => (id, v1));
|
walther@59943
|
148 |
|
walther@59943
|
149 |
(* find the variant with most items already input *)
|
walther@59943
|
150 |
fun max_vt itms =
|
walther@59943
|
151 |
let val vts = (vts_cnt (vts_in itms)) itms;
|
walther@59943
|
152 |
in if vts = [] then 0 else (fst o max2) vts end;
|
walther@59943
|
153 |
|
walther@59943
|
154 |
(* TODO ev. make more efficient by avoiding flat *)
|
walther@59943
|
155 |
fun mk_e (Cor (_, iv)) = [getval iv]
|
walther@59943
|
156 |
| mk_e (Syn _) = []
|
walther@59943
|
157 |
| mk_e (Typ _) = []
|
walther@59943
|
158 |
| mk_e (Inc (_, iv)) = [getval iv]
|
walther@59943
|
159 |
| mk_e (Sup _) = []
|
walther@59943
|
160 |
| mk_e (Mis _) = []
|
walther@59962
|
161 |
| mk_e _ = raise ERROR "mk_e: uncovered case in fun.def.";
|
walther@59943
|
162 |
fun mk_en vt (_, vts, _, _, itm_) = if member op = vts vt then mk_e itm_ else [];
|
walther@59943
|
163 |
|
walther@59943
|
164 |
(* extract the environment from an item list; takes the variant with most items *)
|
walther@59943
|
165 |
fun mk_env itms =
|
walther@59943
|
166 |
let val vt = max_vt itms
|
walther@59943
|
167 |
in (flat o (map (mk_en vt))) itms end;
|
walther@59943
|
168 |
(**)
|
walther@59943
|
169 |
fun ts_in (Cor ((_, ts), _)) = ts
|
walther@59943
|
170 |
| ts_in (Syn _) = []
|
walther@59943
|
171 |
| ts_in (Typ _) = []
|
walther@59943
|
172 |
| ts_in (Inc ((_, ts), _)) = ts
|
walther@59943
|
173 |
| ts_in (Sup (_, ts)) = ts
|
walther@59943
|
174 |
| ts_in (Mis _) = []
|
walther@59962
|
175 |
| ts_in _ = raise ERROR "ts_in: uncovered case in fun.def.";
|
walther@59943
|
176 |
|
walther@59943
|
177 |
val unique = (Thm.term_of o the o (TermC.parse @{theory "Real"} )) "UnIqE_tErM";
|
walther@59943
|
178 |
fun d_in (Cor ((d ,_), _)) = d
|
walther@59956
|
179 |
| d_in (Syn _) = ((*tracing ("*** d_in: Syn ("^c^")");*) unique)
|
walther@59956
|
180 |
| d_in (Typ _) = ((*tracing ("*** d_in: Typ ("^c^")");*) unique)
|
walther@59943
|
181 |
| d_in (Inc ((d, _), _)) = d
|
walther@59943
|
182 |
| d_in (Sup (d, _)) = d
|
walther@59943
|
183 |
| d_in (Mis (d, _)) = d
|
walther@59943
|
184 |
| d_in _ = raise ERROR "d_in: uncovered case in fun.def.";
|
walther@59943
|
185 |
|
walther@59943
|
186 |
fun dts2str (d, ts) = pair2str (UnparseC.term d, UnparseC.terms ts);
|
walther@59956
|
187 |
fun penvval_in (Cor ((d, _), (_, ts))) = [Input_Descript.join'''' (d, ts)]
|
walther@59956
|
188 |
| penvval_in (Syn (_)) = ((*tracing("*** penvval_in: Syn ("^c^")");*) [])
|
walther@59956
|
189 |
| penvval_in (Typ (_)) = ((*tracing("*** penvval_in: Typ ("^c^")");*) [])
|
walther@59943
|
190 |
| penvval_in (Inc (_, (_, ts))) = ts
|
walther@59956
|
191 |
| penvval_in (Sup _) = ((*tracing ("*** penvval_in: Sup " ^ dts2str dts);*) [])
|
walther@59956
|
192 |
| penvval_in (Mis (_, _)) = ((*tracing ("*** penvval_in: Mis " ^
|
walther@59943
|
193 |
pair2str(UnparseC.term d, UnparseC.term t));*) [])
|
walther@59962
|
194 |
| penvval_in _ = raise ERROR "penvval_in: uncovered case in fun.def.";
|
walther@59943
|
195 |
|
walther@59943
|
196 |
fun vars_of itms = itms |> mk_env |> map snd
|
walther@59943
|
197 |
|
walther@59956
|
198 |
fun seek_oridts ctxt sel (d, ts) [] =
|
walther@59956
|
199 |
("seek_oridts: input ('" ^
|
walther@59956
|
200 |
(UnparseC.term_in_ctxt ctxt (Input_Descript.join (d, ts))) ^ "') not found in oris (typed)",
|
walther@59956
|
201 |
(0, [], sel, d, ts),
|
walther@59956
|
202 |
[])
|
walther@59956
|
203 |
| seek_oridts ctxt sel (d, ts) ((id, vat, sel', d', ts') :: oris) =
|
walther@59956
|
204 |
if sel = sel' andalso d = d' andalso (inter op = ts ts') <> []
|
walther@59956
|
205 |
then ("", (id, vat, sel, d, inter op = ts ts'), ts')
|
walther@59956
|
206 |
else seek_oridts ctxt sel (d, ts) oris
|
walther@59956
|
207 |
|
walther@59956
|
208 |
fun test_types ctxt (d,ts) =
|
walther@59956
|
209 |
let
|
walther@59956
|
210 |
val opt = (try Input_Descript.join) (d, ts)
|
walther@59956
|
211 |
val msg = case opt of
|
walther@59956
|
212 |
SOME _ => ""
|
walther@59956
|
213 |
| NONE => (UnparseC.term_in_ctxt ctxt d ^ " " ^
|
walther@59956
|
214 |
(strs2str' o map (UnparseC.term_in_ctxt ctxt)) ts ^ " is illtyped")
|
walther@59956
|
215 |
in msg end
|
walther@59956
|
216 |
|
walther@59956
|
217 |
(* to an input (_,ts) find the according ori and insert the ts *)
|
walther@59956
|
218 |
fun seek_orits ctxt _ ts [] =
|
walther@59956
|
219 |
("seek_orits: input (_, '" ^ strs2str (map (UnparseC.term_in_ctxt ctxt) ts) ^
|
walther@59956
|
220 |
"') not found in oris (typed)", O_Model.single_empty, [])
|
walther@59956
|
221 |
| seek_orits ctxt sel ts ((id, vat, sel', d, ts') :: oris) =
|
walther@59956
|
222 |
if sel = sel' andalso (inter op = ts ts') <> []
|
walther@59956
|
223 |
then
|
walther@59956
|
224 |
if sel = sel'
|
walther@59956
|
225 |
then ("", (id, vat, sel, d, inter op = ts ts'), ts')
|
walther@59956
|
226 |
else (((strs2str' o map (UnparseC.term_in_ctxt ctxt)) ts) ^ " not for " ^ sel, O_Model.single_empty, [])
|
walther@59956
|
227 |
else seek_orits ctxt sel ts oris
|
walther@59956
|
228 |
|
walther@59956
|
229 |
(* make a term 'typeless' for comparing with another 'typeless' term;
|
walther@59956
|
230 |
'type-less' usually is illtyped *)
|
walther@59956
|
231 |
fun typeless (Const (s, _)) = (Const (s, TermC.typ_empty))
|
walther@59956
|
232 |
| typeless (Free (s, _)) = (Free (s, TermC.typ_empty))
|
walther@59956
|
233 |
| typeless (Var (n, _)) = (Var (n, TermC.typ_empty))
|
walther@59956
|
234 |
| typeless (Bound i) = (Bound i)
|
walther@59956
|
235 |
| typeless (Abs (s, _,t)) = Abs(s, TermC.typ_empty, typeless t)
|
walther@59956
|
236 |
| typeless (t1 $ t2) = (typeless t1) $ (typeless t2)
|
walther@59956
|
237 |
|
walther@59956
|
238 |
(* is the term t input (or taken from fmz) known in oris ?
|
walther@59956
|
239 |
give feedback on all(?) strange input;
|
walther@59956
|
240 |
return _all_ terms already input to this item (e.g. valuesFor a,b) *)
|
walther@59956
|
241 |
fun is_known ctxt sel ori t =
|
walther@59956
|
242 |
let
|
walther@59956
|
243 |
val ots = (distinct o flat o (map #5)) ori
|
walther@59956
|
244 |
val oids = ((map (fst o dest_Free)) o distinct o flat o (map TermC.vars)) ots
|
walther@59956
|
245 |
val (d, ts) = Input_Descript.split t
|
walther@59956
|
246 |
val ids = map (fst o dest_Free) ((distinct o (flat o (map TermC.vars))) ts)
|
walther@59956
|
247 |
in
|
walther@59956
|
248 |
if (subtract op = oids ids) <> []
|
walther@59956
|
249 |
then ("identifiers " ^ strs2str' (subtract op = oids ids) ^ " not in example", O_Model.single_empty, [])
|
walther@59956
|
250 |
else
|
walther@59956
|
251 |
if d = TermC.empty
|
walther@59956
|
252 |
then
|
walther@59956
|
253 |
if not (subset op = (map typeless ts, map typeless ots))
|
walther@59956
|
254 |
then ("terms '" ^ (strs2str' o (map (UnparseC.term_in_ctxt ctxt))) ts ^
|
walther@59956
|
255 |
"' not in example (typeless)", O_Model.single_empty, [])
|
walther@59956
|
256 |
else
|
walther@59956
|
257 |
(case seek_orits ctxt sel ts ori of
|
walther@59956
|
258 |
("", ori_ as (_,_,_,d,ts), all) =>
|
walther@59956
|
259 |
(case test_types ctxt (d,ts) of
|
walther@59956
|
260 |
"" => ("", ori_, all)
|
walther@59956
|
261 |
| msg => (msg, O_Model.single_empty, []))
|
walther@59956
|
262 |
| (msg, _, _) => (msg, O_Model.single_empty, []))
|
walther@59956
|
263 |
else
|
walther@59956
|
264 |
if member op = (map #4 ori) d
|
walther@59956
|
265 |
then seek_oridts ctxt sel (d, ts) ori
|
walther@59956
|
266 |
else (UnparseC.term_in_ctxt ctxt d ^ " not in example", (0, [], sel, d, ts), [])
|
walther@59956
|
267 |
end
|
walther@59956
|
268 |
|
walther@59956
|
269 |
val dsc_unknown = (Thm.term_of o the o (TermC.parseold @{theory})) "unknown::'a => unknow";
|
walther@59956
|
270 |
|
walther@59992
|
271 |
(* get a term from ori, notyet input in itm.
|
walther@59992
|
272 |
the term from ori is thrown back to a string in order to reuse
|
walther@59992
|
273 |
machinery for immediate input by the user. *)
|
walther@59992
|
274 |
fun geti_ct thy (_, _, _, d, ts) (_, _, _, fd, itm_) =
|
walther@59992
|
275 |
(fd, ((UnparseC.term_in_thy thy) o Input_Descript.join) (d, subtract op = (ts_in itm_) ts))
|
walther@59992
|
276 |
|
walther@59956
|
277 |
(* 9.5.03 penv postponed: pbl_ids' *)
|
walther@59956
|
278 |
fun pbl_ids' d vs = [Input_Descript.join'''' (d, vs)];
|
walther@59956
|
279 |
|
walther@59956
|
280 |
(* update the itm_ already input, all..from ori *)
|
walther@59956
|
281 |
fun ori_2itm itm_ pid all (id, vt, fd, d, ts) =
|
walther@59956
|
282 |
let
|
walther@59956
|
283 |
val ts' = union op = (ts_in itm_) ts;
|
walther@59956
|
284 |
val pval =pbl_ids' d ts'
|
walther@59956
|
285 |
(* WN.9.5.03: FIXXXME [#0, epsilon] here would upd_penv be called for [#0, epsilon] etc *)
|
walther@59956
|
286 |
val complete = if eq_set op = (ts', all) then true else false
|
walther@59956
|
287 |
in
|
walther@59956
|
288 |
case itm_ of
|
walther@59956
|
289 |
(Cor _) =>
|
walther@59956
|
290 |
(if fd = "#undef" then (id, vt, complete, fd, Sup (d, ts'))
|
walther@59956
|
291 |
else (id, vt, complete, fd, Cor ((d, ts'), (pid, pval))))
|
walther@59962
|
292 |
| (Syn c) => raise ERROR ("ori_2itm wants to overwrite " ^ c)
|
walther@59962
|
293 |
| (Typ c) => raise ERROR ("ori_2itm wants to overwrite " ^ c)
|
walther@59956
|
294 |
| (Inc _) =>
|
walther@59956
|
295 |
if complete
|
walther@59956
|
296 |
then (id, vt, true, fd, Cor ((d, ts'), (pid, pval)))
|
walther@59956
|
297 |
else (id, vt, false, fd, Inc ((d, ts'), (pid, pval)))
|
walther@59956
|
298 |
| (Sup (d,ts')) => (*4.9.01 lost env*)
|
walther@59956
|
299 |
(*if fd = "#undef" then*) (id,vt,complete,fd,Sup(d,ts'))
|
walther@59956
|
300 |
(*else (id,vt,complete,fd,Cor((d,ts'),e))*)
|
walther@59956
|
301 |
(* 28.1.00: not completely clear ---^^^ etc.*)
|
walther@59956
|
302 |
| (Mis _) => (* 4.9.01: Mis just copied *)
|
walther@59956
|
303 |
if complete
|
walther@59956
|
304 |
then (id, vt, true, fd, Cor ((d,ts'), (pid, pval)))
|
walther@59956
|
305 |
else (id, vt, false, fd, Inc ((d,ts'), (pid, pval)))
|
walther@59962
|
306 |
| i => raise ERROR ("ori_2itm: uncovered case of "^ feedback_to_string' i)
|
walther@59956
|
307 |
end
|
walther@59956
|
308 |
|
walther@59956
|
309 |
fun eq1 d (_, (d', _)) = (d = d')
|
walther@59956
|
310 |
fun eq3 f d (_, _, _, f', itm_) = f = f' andalso d = (d_in itm_)
|
walther@59956
|
311 |
|
walther@59956
|
312 |
fun is_notyet_input ctxt itms all (i, v, f, d, ts) pbt =
|
walther@59956
|
313 |
case find_first (eq1 d) pbt of
|
walther@59956
|
314 |
SOME (_, (_, pid)) =>
|
walther@59956
|
315 |
(case find_first (eq3 f d) itms of
|
walther@59956
|
316 |
SOME (_,_,_,_,itm_) =>
|
walther@59956
|
317 |
let val ts' = inter op = (ts_in itm_) ts
|
walther@59956
|
318 |
in
|
walther@59956
|
319 |
if subset op = (ts, ts')
|
walther@59956
|
320 |
then (((strs2str' o map (UnparseC.term_in_ctxt ctxt)) ts') ^ " already input", empty) (*2*)
|
walther@59956
|
321 |
else ("", ori_2itm itm_ pid all (i,v,f,d, subtract op = ts' ts)) (*3,4*)
|
walther@59956
|
322 |
end
|
walther@59956
|
323 |
| NONE => ("", ori_2itm (Inc ((TermC.empty, []), (pid, []))) pid all (i, v, f, d, ts))) (*1*)
|
walther@59956
|
324 |
| NONE => ("", ori_2itm (Sup (d, ts)) TermC.empty all (i, v, f, d, ts))
|
walther@59956
|
325 |
|
walther@59956
|
326 |
datatype additm =
|
walther@59958
|
327 |
Add of single (* return-value of check_single *)
|
walther@59956
|
328 |
| Err of string (* error-message *)
|
walther@59956
|
329 |
|
walther@59956
|
330 |
(*
|
walther@59956
|
331 |
Create feedback for input of TermC.as_string to m_field;
|
walther@59956
|
332 |
check w.r.t. O_Model.T and Model_Pattern.T.
|
walther@59956
|
333 |
In case of O_Model.T = [] (i.e. no data for user-guidance from Formalise.T)
|
walther@59958
|
334 |
check_single is extremely permissive.
|
walther@59956
|
335 |
*)
|
walther@59958
|
336 |
fun check_single ctxt m_field [] i_model m_patt ct =
|
walther@59956
|
337 |
let
|
walther@59956
|
338 |
val i = 1 + (if i_model = [] then 0 else map #1 i_model |> maxl)
|
walther@59956
|
339 |
in
|
walther@59956
|
340 |
case TermC.parseNEW ctxt ct of
|
walther@59956
|
341 |
NONE => Add (i, [], false, m_field, Syn ct)
|
walther@59956
|
342 |
| SOME t =>
|
walther@59956
|
343 |
let
|
walther@59956
|
344 |
val (d, ts) = Input_Descript.split t
|
walther@59956
|
345 |
in
|
walther@59956
|
346 |
if d = TermC.empty then
|
walther@59956
|
347 |
Add (i, [], false, m_field, Mis (dsc_unknown, hd ts))
|
walther@59956
|
348 |
else
|
walther@59956
|
349 |
(case find_first (eq1 d) m_patt of
|
walther@59956
|
350 |
NONE => Add (i, [], true, m_field, Sup (d,ts))
|
walther@59956
|
351 |
| SOME (f, (_, id)) =>
|
walther@59956
|
352 |
let
|
walther@59956
|
353 |
fun eq2 d (i, _, _, _, itm_) = d = (d_in itm_) andalso i <> 0
|
walther@59956
|
354 |
in
|
walther@59956
|
355 |
case find_first (eq2 d) i_model of
|
walther@59956
|
356 |
NONE => Add (i, [], true, f,Cor ((d, ts), (id, pbl_ids' d ts)))
|
walther@59956
|
357 |
| SOME (i', _, _, _, itm_) =>
|
walther@59956
|
358 |
if Input_Descript.for_list d then
|
walther@59956
|
359 |
let
|
walther@59956
|
360 |
val in_itm = ts_in itm_
|
walther@59956
|
361 |
val ts' = union op = ts in_itm
|
walther@59956
|
362 |
val i'' = if in_itm = [] then i else i'
|
walther@59956
|
363 |
in Add (i'', [], true, f, Cor ((d, ts'), (id, pbl_ids' d ts')))end
|
walther@59956
|
364 |
else Add (i', [], true, f, Cor ((d, ts), (id, pbl_ids' d ts)))
|
walther@59956
|
365 |
end)
|
walther@59956
|
366 |
end
|
walther@59956
|
367 |
end
|
walther@59958
|
368 |
| check_single ctxt m_field o_model i_model m_patt str =
|
walther@59956
|
369 |
case TermC.parseNEW ctxt str of
|
walther@59958
|
370 |
NONE => Err ("check_single: syntax error in '" ^ str ^ "'")
|
walther@59956
|
371 |
| SOME t =>
|
walther@59956
|
372 |
case is_known ctxt m_field o_model t of
|
walther@59956
|
373 |
("", ori', all) =>
|
walther@59956
|
374 |
(case is_notyet_input ctxt i_model all ori' m_patt of
|
walther@59956
|
375 |
("", itm) => Add itm
|
walther@59958
|
376 |
| (msg, _) => Err ("ERROR I_Model.check_single: is_notyet_input: " ^ msg))
|
walther@59958
|
377 |
| (msg, _, _) => Err ("ERROR I_Model.check_single: is_known: " ^ msg);
|
walther@59958
|
378 |
|
walther@59958
|
379 |
|
walther@59958
|
380 |
(** add input **)
|
walther@59958
|
381 |
|
walther@59958
|
382 |
fun overwrite_ppc thy itm ppc =
|
walther@59958
|
383 |
let
|
walther@59958
|
384 |
fun repl _ (_, _, _, _, itm_) [] =
|
walther@59962
|
385 |
raise ERROR ("overwrite_ppc: " ^ (feedback_to_string (ThyC.to_ctxt thy) itm_) ^ " not found")
|
walther@59958
|
386 |
| repl ppc' itm (p :: ppc) =
|
walther@59958
|
387 |
if (#1 itm) = (#1 p)
|
walther@59958
|
388 |
then ppc' @ [itm] @ ppc
|
walther@59958
|
389 |
else repl (ppc' @ [p]) itm ppc
|
walther@59958
|
390 |
in repl [] itm ppc end
|
walther@59958
|
391 |
|
walther@59958
|
392 |
(* find_first item with #1 equal to id *)
|
walther@59958
|
393 |
fun seek_ppc _ [] = NONE
|
walther@59958
|
394 |
| seek_ppc id (p :: ppc) = if id = #1 (p: single) then SOME p else seek_ppc id ppc
|
walther@59958
|
395 |
|
walther@59958
|
396 |
(* 10.3.00: insert the already compiled itm into model;
|
walther@59958
|
397 |
ev. filter_out untouched (in FE: (0,...)) item related to insert-item *)
|
walther@59958
|
398 |
fun add_single thy itm ppc =
|
walther@59958
|
399 |
let
|
walther@59958
|
400 |
fun eq_untouched d (0, _, _, _, itm_) = (d = d_in itm_)
|
walther@59958
|
401 |
| eq_untouched _ _ = false
|
walther@59958
|
402 |
val ppc' = case seek_ppc (#1 itm) ppc of
|
walther@59958
|
403 |
SOME _ => overwrite_ppc thy itm ppc (*itm updated in is_notyet_input WN.11.03*)
|
walther@59958
|
404 |
| NONE => (ppc @ [itm])
|
walther@59958
|
405 |
in filter_out (eq_untouched ((d_in o #5) itm)) ppc' end
|
walther@59956
|
406 |
|
walther@59988
|
407 |
fun complete' pbt (i, v, f, d, ts) =
|
walther@59986
|
408 |
(i, v, true, f, Cor ((d, ts), ((snd o snd o the o (find_first (eq1 d))) pbt, ts)))
|
walther@59986
|
409 |
handle _ => (i, v, true, f, Cor ((d, ts), (d, ts)))
|
walther@59986
|
410 |
(*dsc in oris, but not in pbl pat list: keep this dsc*)
|
walther@59988
|
411 |
|
walther@59988
|
412 |
(* filter out oris which have same description in itms *)
|
walther@59988
|
413 |
fun filter_outs oris [] = oris
|
walther@59988
|
414 |
| filter_outs oris (i::itms) =
|
walther@59988
|
415 |
let
|
walther@59988
|
416 |
val ors = filter_out ((curry op = ((d_in o #5) i)) o (#4)) oris
|
walther@59988
|
417 |
in
|
walther@59988
|
418 |
filter_outs ors itms
|
walther@59988
|
419 |
end
|
walther@59988
|
420 |
|
walther@59988
|
421 |
(* filter oris which are in pbt, too *)
|
walther@59988
|
422 |
fun filter_pbt oris pbt =
|
walther@59988
|
423 |
let
|
walther@59988
|
424 |
val dscs = map (fst o snd) pbt
|
walther@59988
|
425 |
in
|
walther@59988
|
426 |
filter ((member op= dscs) o (#4)) oris
|
walther@59988
|
427 |
end
|
walther@59988
|
428 |
|
walther@59988
|
429 |
fun is_error (Cor _) = false
|
walther@59988
|
430 |
| is_error (Sup _) = false
|
walther@59988
|
431 |
| is_error (Inc _) = false
|
walther@59988
|
432 |
| is_error (Mis _) = false
|
walther@59988
|
433 |
| is_error _ = true
|
walther@59988
|
434 |
|
walther@59988
|
435 |
(*create output-string for itm_*)
|
walther@59988
|
436 |
fun to_p_model _ (Cor ((d, ts), _)) = UnparseC.term (Input_Descript.join (d, ts))
|
walther@59988
|
437 |
| to_p_model _ (Syn c) = c
|
walther@59988
|
438 |
| to_p_model _ (Typ c) = c
|
walther@59988
|
439 |
| to_p_model _ (Inc ((d, ts), _)) = UnparseC.term (Input_Descript.join (d, ts))
|
walther@59988
|
440 |
| to_p_model _ (Sup (d, ts)) = UnparseC.term (Input_Descript.join (d, ts))
|
walther@59988
|
441 |
| to_p_model _ (Mis (d, pid)) = UnparseC.term d ^ " " ^ UnparseC.term pid
|
walther@59988
|
442 |
| to_p_model _ _ = raise ERROR "to_p_model: uncovered definition"
|
walther@59988
|
443 |
|
walther@59988
|
444 |
fun eq_dsc ((_, _, _, _, itm_), (_, _, _, _, iitm_)) = (d_in itm_ = d_in iitm_)
|
walther@59988
|
445 |
|
walther@59988
|
446 |
(* insert_ppc = add for appl_add', input_icalhd 11.03,
|
walther@59988
|
447 |
handles superfluous items carelessly *)
|
walther@59988
|
448 |
fun add itm itms = if member eq_dsc itms itm then itms else itms @ [itm] (* @ new itm *)
|
walther@59988
|
449 |
|
walther@59988
|
450 |
(* combine itms from pbl + met and complete them wrt. pbt *)
|
walther@59988
|
451 |
(* FIXXXME.WN031205 complete doesnt handle incorrect itms !*)
|
walther@59988
|
452 |
fun complete oris pits mits met =
|
walther@59988
|
453 |
let
|
walther@59988
|
454 |
val vat = max_vt pits;
|
walther@59988
|
455 |
val itms = pits @ (filter ((member_swap op = vat) o (#2 )) mits)
|
walther@59988
|
456 |
val ors = filter ((member_swap op= vat) o (#2)) oris
|
walther@59988
|
457 |
val os = filter_outs ors itms (*WN.12.03?: does _NOT_ add itms from met ?!*)
|
walther@59988
|
458 |
in
|
walther@59988
|
459 |
itms @ (map (complete' met) os)
|
walther@59988
|
460 |
end
|
walther@59988
|
461 |
|
walther@59988
|
462 |
(* complete model and guard of a calc-head *)
|
walther@59988
|
463 |
fun complete_method (oris, mpc, ppc, probl) =
|
walther@59988
|
464 |
let
|
walther@59988
|
465 |
val pits = filter_out ((curry op= false) o (#3)) probl
|
walther@59988
|
466 |
val vat = if probl = [] then 1 else max_vt probl
|
walther@59988
|
467 |
val pors = filter ((member_swap op = vat) o (#2)) oris
|
walther@59988
|
468 |
val pors = filter_outs pors pits (*which are in pbl already*)
|
walther@59988
|
469 |
val pors = (filter_pbt pors ppc) (*which are in pbt, too*)
|
walther@59988
|
470 |
val pits = pits @ (map (complete' ppc) pors)
|
walther@59988
|
471 |
val mits = complete oris pits [] mpc
|
walther@59988
|
472 |
in (pits, mits) end
|
walther@59988
|
473 |
|
walther@59988
|
474 |
(* WN0312: use in nxt_spec, too ? what about variants ??? *)
|
walther@59988
|
475 |
fun is_complete [] = false
|
walther@59988
|
476 |
| is_complete itms = foldl and_ (true, (map #3 itms))
|
walther@59986
|
477 |
|
walther@59938
|
478 |
(**)end(**); |