1 (* Title: Specify/solve-step.sml
3 (c) due to copyright terms
5 Code for the solve-phase in analogy to structure Specify_Step for the specify-phase.
10 val check: Tactic.input -> Calc.T -> Applicable.T
11 val add: Tactic.T -> Istate_Def.T * Proof.context -> Calc.T -> Test_Out.T
13 val add_general: Tactic.T -> Istate_Def.T * Proof.context -> Calc.T -> Test_Out.T
14 val s_add_general: State_Steps.T ->
15 Ctree.ctree * Pos.pos' list * Pos.pos' -> Ctree.ctree * Pos.pos' list * Pos.pos'
17 theory -> Tactic.T -> Pos.pos' -> Ctree.ctree -> Test_Out.T
19 val get_ruleset: 'a -> Pos.pos' -> Ctree.ctree ->
20 string * ThyC.id * Rewrite_Ord.id * Rule_Def.rule_set * bool
21 val get_eval: string -> Pos.pos' -> Ctree.ctree -> string * ThyC.id * Eval.ml
24 val get_ctxt: Ctree.ctree -> Pos.pos' -> Proof.context
25 val rew_info: Rule_Def.rule_set -> string * Rule_Def.rule_set * Eval.ml_from_prog list
30 structure Solve_Step(**): SOLVE_STEP(**) =
34 (** get data from Calc.T **)
36 (* the source is the parent node, either a problem or a Rule_Set (with inter_steps) *)
37 fun rew_info (Rule_Def.Repeat {erls, rew_ord = (rew_ord', _), calc = ca, ...}) =
39 | rew_info (Rule_Set.Sequence {erls, rew_ord = (rew_ord', _), calc = ca, ...}) =
41 | rew_info (Rule_Set.Rrls {erls, rew_ord = (rew_ord', _), calc = ca, ...}) =
43 | rew_info rls = raise ERROR ("rew_info called with '" ^ Rule_Set.id rls ^ "'");
45 fun get_ruleset _ (pos as (p, _)) pt =
47 val (pbl, p', rls', ctxt) = LItool.parent_node pt pos
52 val thy' = Ctree.get_obj Ctree.g_domID pt p'
53 val {rew_ord', erls, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt p')
54 in ("OK", thy', rew_ord', erls, false) end
57 val thy' = Ctree.get_obj Ctree.g_domID pt (Ctree.par_pblobj pt p)
58 val (rew_ord', erls, _) = rew_info rls'
59 in ("OK", thy', rew_ord', erls, false) end
62 fun get_eval scrop (pos as (p, _)) pt =
64 val (pbl, p', rls', ctxt) = LItool.parent_node pt pos
69 val thy' = Ctree.get_obj Ctree.g_domID pt p'
70 val {calc = scr_isa_fns, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt p')
71 val opt = assoc (scr_isa_fns, scrop)
74 SOME isa_fn => ("OK", thy', isa_fn)
75 | NONE => ("applicable_in Calculate: unknown '" ^ scrop ^ "'", "", ("", Eval.ml_fun_empty))
79 val thy' = Ctree.get_obj Ctree.g_domID pt (Ctree.par_pblobj pt p);
80 val (_, _,(*_,*)scr_isa_fns) = rew_info rls'(*rls*)
82 case assoc (scr_isa_fns, scrop) of
83 SOME isa_fn => ("OK",thy',isa_fn)
84 | NONE => ("applicable_in Calculate: unknown '" ^ scrop ^ "'", "", ("", Eval.ml_fun_empty))
88 (** get context reliably at switch_specify_solve **)
90 fun at_begin_program (is, Pos.Res) = last_elem is = 0
91 | at_begin_program _ = false;
93 (* strange special case at Apply_Method *)
94 fun get_ctxt_from_PblObj pt (p_, Pos.Res) =
96 val pp = Ctree.par_pblobj pt p_ (*drops the "0"*)
97 val {ctxt, ...} = Ctree.get_obj I pt pp |> Ctree.rep_specify_data
99 | get_ctxt_from_PblObj _ _ = raise ERROR "get_ctxt_from_PblObj called by PrfObj or EmptyPtree";
101 fun get_ctxt pt (p_, Pos.Pbl) =
103 val pp = Ctree.par_pblobj pt p_ (*drops the "0"*)
104 val {ctxt, ...} = Ctree.get_obj I pt pp |> Ctree.rep_specify_data
107 if at_begin_program pos
108 then get_ctxt_from_PblObj pt pos
109 else Ctree.get_ctxt pt pos
113 (** Solve_Step.check **)
116 check tactics (input by the user, mostly) for applicability
117 and determine as much of the result of the tactic as possible initially.
119 fun check (Tactic.Apply_Method mI) (pt, (p, _)) =
121 val (dI, pI, probl, ctxt) = case Ctree.get_obj I pt p of
122 Ctree.PblObj {origin = (_, (dI, pI, _), _), probl, ctxt, ...} => (dI, pI, probl, ctxt)
123 | _ => raise ERROR "Solve_Step.check Apply_Method: uncovered case Ctree.get_obj"
124 val {where_, ...} = Problem.from_store ctxt pI
125 val pres = map (I_Model.environment probl |> subst_atomic) where_
126 val ctxt = if ContextC.is_empty ctxt (*vvvvvvvvvvvvvv DO THAT EARLIER?!?*)
127 then ThyC.get_theory dI |> Proof_Context.init_global |> ContextC.insert_assumptions pres
130 Applicable.Yes (Tactic.Apply_Method' (mI, NONE, Istate_Def.empty (*filled later*), ctxt))
132 | check (Tactic.Calculate op_) (cs as (pt, pos as (p, _))) =
134 val (msg, thy', isa_fn) = get_eval op_ pos pt;
135 val f = Calc.current_formula cs;
139 case Rewrite.calculate_ (ThyC.id_to_ctxt thy') isa_fn f of
141 => Applicable.Yes (Tactic.Calculate' (thy', op_, f, (f', (id, thm))))
142 | NONE => Applicable.No ("'calculate " ^ op_ ^ "' not applicable")
143 else Applicable.No msg
145 | check (Tactic.Check_Postcond pI) (_, _) = (*TODO: only applicable, if evaluating to True*)
146 Applicable.Yes (Tactic.Check_Postcond' (pI, TermC.empty))
147 | check (Tactic.Check_elementwise pred) cs =
149 val f = Calc.current_formula cs;
151 Applicable.Yes (Tactic.Check_elementwise' (f, pred, (f, [])))
153 | check Tactic.Empty_Tac _ = Applicable.No "Empty_Tac is not applicable"
154 | check (Tactic.Free_Solve) _ = Applicable.Yes (Tactic.Free_Solve')
155 | check Tactic.Or_to_List cs =
157 val f = Calc.current_formula cs;
158 val ls = Prog_Expr.or2list f;
160 Applicable.Yes (Tactic.Or_to_List' (f, ls))
162 | check (Tactic.Rewrite thm) (cs as (pt, pos as (p, _))) =
164 val (msg, thy', ro, rls', _) = get_ruleset thm pos pt;
165 val thy = ThyC.get_theory thy';
166 val ctxt = Proof_Context.init_global thy;
167 val f = Calc.current_formula cs;
171 case Rewrite.rewrite_ ctxt (get_rew_ord ctxt ro) rls' false (snd thm) f of
172 SOME (f',asm) => Applicable.Yes (Tactic.Rewrite' (thy', ro, rls', false, thm, f, (f', asm)))
173 | NONE => Applicable.No ((thm |> fst |> quote) ^ " not applicable")
174 else Applicable.No msg
176 | check (Tactic.Rewrite_Inst (subs, thm)) (cs as (pt, pos as (p, _))) =
178 val pp = Ctree.par_pblobj pt p;
179 val ctxt = Ctree.get_loc pt pos |> snd
180 val thy = Proof_Context.theory_of ctxt
181 val {rew_ord' = ro', erls = erls, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt pp);
182 val f = Calc.current_formula cs;
183 val subst = Subst.T_from_input ctxt subs; (*TODO: input requires parse _: _ -> _ option*)
185 case Rewrite.rewrite_inst_ ctxt (get_rew_ord ctxt ro') erls false subst (snd thm) f of
187 Applicable.Yes (Tactic.Rewrite_Inst'
188 (Context.theory_name thy, ro', erls, false, subst, thm, f, (f', asm)))
189 | NONE => Applicable.No (fst thm ^ " not applicable")
191 | check (Tactic.Rewrite_Set rls) (cs as (pt, pos)) =
193 val ctxt = Ctree.get_loc pt pos |> snd
194 val thy' = ctxt |> Proof_Context.theory_of |> Context.theory_name
195 val f = Calc.current_formula cs;
197 case Rewrite.rewrite_set_ ctxt false (get_rls ctxt rls) f of
199 => Applicable.Yes (Tactic.Rewrite_Set' (thy', false, get_rls ctxt rls, f, (f', asm)))
200 | NONE => Applicable.No (rls ^ " not applicable")
202 | check (Tactic.Rewrite_Set_Inst (subs, rls)) (cs as (pt, pos)) =
204 val ctxt = Ctree.get_loc pt pos |> snd
205 val thy' = ctxt |> Proof_Context.theory_of |> Context.theory_name
206 val f = Calc.current_formula cs;
207 val subst = Subst.T_from_input ctxt subs; (*TODO: input requires parse _: _ -> _ option*)
209 case Rewrite.rewrite_set_inst_ ctxt false subst (get_rls ctxt rls) f of
212 (Tactic.Rewrite_Set_Inst' (thy', false, subst, get_rls ctxt rls, f, (f', asm)))
213 | NONE => Applicable.No (rls ^ " not applicable")
215 | check (Tactic.Subproblem (domID, pblID)) (_, _) =
216 Applicable.Yes (Tactic.Subproblem' ((domID, pblID, MethodC.id_empty), [],
217 TermC.empty, [], ContextC.empty, Auto_Prog.subpbl domID pblID))
218 | check (Tactic.Substitute sube) (cs as (pt, pos as (p, _))) =
220 val pp = Ctree.par_pblobj pt p
221 val ctxt = Ctree.get_loc pt pos |> snd
222 val thy = Proof_Context.theory_of ctxt
223 val f = Calc.current_formula cs;
224 val {rew_ord', erls, ...} = MethodC.from_store ctxt (Ctree.get_obj Ctree.g_metID pt pp)
225 val subte = Subst.input_to_terms ctxt sube (*?TODO: input requires parse _: _ -> _ option?*)
226 val ro = get_rew_ord ctxt rew_ord'
228 if foldl and_ (true, map TermC.contains_Var subte)
230 let val f' = subst_atomic (Subst.T_from_string_eqs thy sube) f
232 then Applicable.No (Subst.string_eqs_to_string sube ^ " not applicable")
233 else Applicable.Yes (Tactic.Substitute' (ro, erls, subte, f, f'))
236 case Rewrite.rewrite_terms_ ctxt ro erls subte f of
237 SOME (f', _) => Applicable.Yes (Tactic.Substitute' (ro, erls, subte, f, f'))
238 | NONE => Applicable.No (Subst.string_eqs_to_string sube ^ " not applicable")
240 | check (Tactic.Tac id) (cs as (pt, pos)) =
242 val thy = (Ctree.get_loc pt pos |> snd) |> Proof_Context.theory_of
243 val f = Calc.current_formula cs;
245 Applicable.Yes (Tactic.Tac_ (thy, UnparseC.term f, id, UnparseC.term f))
247 (*/----------------- updated----------------------------------* )
248 | check (Tactic.Take str) (pt, pos) =
249 Applicable.Yes (Tactic.Take'
250 (TermC.parse ((*Solve_Step.*)get_ctxt pt pos) str)) (*always applicable*)
251 ( *------------------- updated----------------------------------*)
252 | check (Tactic.Take str) (pt, pos) =
254 val ctxt = (*Solve_Step.*)get_ctxt pt pos
255 val t = Prog_Tac.Take_adapt_to_type ctxt str
256 in Applicable.Yes (Tactic.Take' t) end
257 (*\----------------- updated----------------------------------*)
258 | check (Tactic.Begin_Trans) cs =
259 Applicable.Yes (Tactic.Begin_Trans' (Calc.current_formula cs))
260 | check (Tactic.End_Trans) (pt, (p, p_)) = (*TODO: check parent branches*)
262 then Applicable.Yes (Tactic.End_Trans' (Ctree.get_obj Ctree.g_result pt p))
263 else Applicable.No "'End_Trans' is not applicable at the beginning of a transitive sequence"
264 | check Tactic.End_Proof' _ = Applicable.Yes Tactic.End_Proof''
265 | check m _ = raise ERROR ("Solve_Step.check called for " ^ Tactic.input_to_string m);
268 (** Solve_Step.add **)
270 fun add (Tactic.Apply_Method' (_, topt, is, _)) (_, ctxt) (pt, pos as (p, _)) =
273 let val (pt, c) = Ctree.cappend_form pt p (is, ctxt) t
274 in (pos, c, Test_Out.EmptyMout, pt) end
275 | NONE => (pos, [], Test_Out.EmptyMout, pt))
276 | add (Tactic.Take' t) l (pt, (p, _)) = (* val (Take' t) = m; *)
279 let val (ps, p') = split_last p (* no connex to prev.ppobj *)
280 in if p' = 0 then ps @ [1] else p end
281 val (pt, c) = Ctree.cappend_form pt p l t
283 ((p, Pos.Frm), c, Test_Out.FormKF (UnparseC.term t), pt)
285 | add (Tactic.Begin_Trans' t) l (pt, (p, Pos.Frm)) =
287 val (pt, c) = Ctree.cappend_form pt p l t
288 val pt = Ctree.update_branch pt p Ctree.TransitiveB (*040312*)
289 (* replace the old PrfOjb ~~~~~ *)
290 val p = (Pos.lev_on o Pos.lev_dn (* starts with [...,0] *)) p
291 val (pt, c') = Ctree.cappend_form pt p l t (*FIXME.0402 same istate ???*)
293 ((p, Pos.Frm), c @ c', Test_Out.FormKF (UnparseC.term t), pt)
295 | add (Tactic.Begin_Trans' t) l (pt, (p, Pos.Res)) =
296 (*append after existing PrfObj vvvvvvvvvvvvv*)
297 add (Tactic.Begin_Trans' t) l (pt, (Pos.lev_on p, Pos.Frm))
298 | add (Tactic.End_Trans' tasm) l (pt, (p, _)) =
300 val p' = Pos.lev_up p
301 val (pt, c) = Ctree.append_result pt p' l tasm Ctree.Complete
303 ((p', Pos.Res), c, Test_Out.FormKF "DUMMY" (*term2str t ..ERROR (t) has not been declared*), pt)
305 | add (Tactic.Rewrite_Inst' (_, _, _, _, subs', thm', f, (f', asm))) (is, ctxt) (pt, (p, _)) =
307 val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f
308 (Tactic.Rewrite_Inst (Subst.T_to_input subs', thm')) (f',asm) Ctree.Complete;
309 val pt = Ctree.update_branch pt p Ctree.TransitiveB
311 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term f'), pt)
313 | add (Tactic.Rewrite' (_, _, _, _, thm', f, (f', asm))) (is, ctxt) (pt, (p, _)) =
315 val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f (Tactic.Rewrite thm') (f', asm) Ctree.Complete
316 val pt = Ctree.update_branch pt p Ctree.TransitiveB
318 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term f'), pt)
320 | add (Tactic.Rewrite_Set_Inst' (_, _, subs', rls', f, (f', asm))) (is, ctxt) (pt, (p, _)) =
322 val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f
323 (Tactic.Rewrite_Set_Inst (Subst.T_to_input subs', Rule_Set.id rls')) (f', asm) Ctree.Complete
324 val pt = Ctree.update_branch pt p Ctree.TransitiveB
326 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term f'), pt)
328 | add (Tactic.Rewrite_Set' (_, _, rls', f, (f', asm))) (is, ctxt) (pt, (p, _)) =
330 val (pt, c) = Ctree.cappend_atomic pt p (is, ctxt) f
331 (Tactic.Rewrite_Set (Rule_Set.id rls')) (f', asm) Ctree.Complete
332 val pt = Ctree.update_branch pt p Ctree.TransitiveB
334 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term f'), pt)
336 | add (Tactic.Check_Postcond' (_, scval)) l (pt, (p, _)) =
338 val (pt, c) = Ctree.append_result pt p l (scval, []) Ctree.Complete
340 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term scval), pt)
342 | add (Tactic.Calculate' (_, op_, f, (f', _))) l (pt, (p, _)) =
344 val (pt,c) = Ctree.cappend_atomic pt p l f (Tactic.Calculate op_) (f', []) Ctree.Complete
346 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term f'), pt)
348 | add (Tactic.Check_elementwise' (consts, pred, (f', asm))) l (pt, (p, _)) =
350 val (pt,c) = Ctree.cappend_atomic pt p l consts (Tactic.Check_elementwise pred) (f', asm) Ctree.Complete
352 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term f'), pt)
354 | add (Tactic.Or_to_List' (ors, list)) l (pt, (p, _)) =
356 val (pt,c) = Ctree.cappend_atomic pt p l ors Tactic.Or_to_List (list, []) Ctree.Complete
358 ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term list), pt)
360 | add (Tactic.Substitute' (_, _, subte, t, t')) l (pt, (p, _)) =
363 Ctree.cappend_atomic pt p l t (Tactic.Substitute (Subst.eqs_to_input subte)) (t',[]) Ctree.Complete
364 in ((p, Pos.Res), c, Test_Out.FormKF (UnparseC.term t'), pt)
366 | add (Tactic.Tac_ (_, f, id, f')) l (pt, pos as (p, _)) =
368 val ctxt = Ctree.get_ctxt pt pos
369 val (pt, c) = Ctree.cappend_atomic pt p l
370 (TermC.parse ctxt f) (Tactic.Tac id) (TermC.parse ctxt f', []) Ctree.Complete
372 ((p,Pos.Res), c, Test_Out.FormKF f', pt)
374 | add (Tactic.Subproblem' ((domID, pblID, metID), oris, hdl, fmz_, ctxt_specify, f))
375 (l as (_, ctxt)) (pt, (p, _)) =
377 val (pt, c) = Ctree.cappend_problem pt p l (fmz_, (domID, pblID, metID))
378 (oris, (domID, pblID, metID), hdl, ctxt_specify)
379 val f = Syntax.string_of_term ctxt f
381 ((p, Pos.Pbl), c, Test_Out.FormKF f, pt)
383 | add m' _ (_, pos) =
384 raise ERROR ("Solve_Step.add: not impl.for " ^ Tactic.string_of m' ^ " at " ^ Pos.pos'2str pos)
386 (* LI switches between solve-phase and specify-phase *)
387 fun add_general tac ic cs =
388 if Tactic.for_specify' tac
389 then Specify_Step.add tac ic cs
392 (* the order of State_Steps is reversed: insert last element first *)
393 fun s_add_general [] ptp = ptp
394 | s_add_general tacis (pt, c, _) =
396 val (tacis', (_, tac_, (p, is))) = split_last tacis
397 val (p', c', _, pt') = add_general tac_ is (pt, p)
399 s_add_general tacis' (pt', c@c', p')
402 (* a still undeveloped concept: do a calculation without LI *)
403 fun add_hard _(*thy*) m' (p, p_) pt =
406 Pos.Frm => p | Pos.Res => Pos.lev_on p
407 | _ => raise ERROR ("generate_hard: call by " ^ Pos.pos'2str (p,p_))
409 add_general m' (Istate_Def.empty, ContextC.empty) (pt, (p, p_))