1 (* Title: src/Tools/isac/BridgeJEdit/Calculation.thy
2 Author: Walther Neuper, JKU Linz
3 (c) due to copyright terms
5 Outer syntax for Isabelle/Isac's Calculation.
10 "~~/src/Tools/isac/MathEngine/MathEngine"
11 (**)"HOL-SPARK.SPARK" (** ) preliminarily for parsing Example files *)
12 (** )"HOL-Word.Word"( ** ) trial on ERROR in definition sdiv below *)
14 "Example" :: thy_load ("str") (* "spark_vc" :: thy_goal *)
15 and "Problem" :: thy_goal (* root-problem + recursively in Solution *)
16 and "Specification" "Model" "References" "Solution" (* structure only *)
17 and"Given" "Find" "Relate" "Where" (* await input of term *)
18 and "RTheory" (* await input of string; "R" distingues "Problem".."RProblem" *)
19 and "RProblem" "RMethod" (* await input of string list *)
20 "Tactic" (* optional for each step 0..end of calculation *)
21 (*//-------------------- investigate Outer_Syntax.local_theory_to_proof -------------------\\*)
22 and"global_interpretationC" :: thy_goal
23 (*\\-------------------- investigate Outer_Syntax.local_theory_to_proof -------------------//*)
26 (**)ML_file parseC.sml(**)
28 section \<open>new code for Outer_Syntax Example, Problem, ...\<close>
30 subsection \<open>code for Example\<close>
33 structure Refs_Data = Theory_Data
36 val empty : T = References.empty
38 fun merge (_, refs) = refs
40 (*/----------------------------- shift to test/../? ----------------------------------------\*)
42 signature THEORY_DATA =
46 val put: T -> theory -> theory
47 val map: (T -> T) -> theory -> theory
50 Refs_Data.empty; (*in Refs_Data defined workers are hidden*)
51 Refs_Data.extend; (*in Refs_Data defined workers are hidden*)
52 Refs_Data.merge; (*in Refs_Data defined workers are hidden*)
54 Value or constructor (empty) has not been declared in structure Refs *)
56 Refs_Data.get: theory -> Refs_Data.T; (*from signature THEORY_DATA*)
57 Refs_Data.put: Refs_Data.T -> theory -> theory; (*from signature THEORY_DATA*)
58 Refs_Data.map: (Refs_Data.T -> Refs_Data.T) -> theory -> theory; (*from signature THEORY_DATA*)
59 (*\----------------------------- shift to test/../? ----------------------------------------/*)
61 structure OMod_Data = Theory_Data
66 fun merge (_, o_model) = o_model
69 structure Ctxt_Data = Theory_Data
71 type T = Proof.context
72 val empty : T = ContextC.empty
74 fun merge (_, ctxt) = ctxt
77 fun store_and_show formalise thy =
79 (**)val file_read_correct = case formalise of xxx as
80 [(["Traegerlaenge L", "Streckenlast q_0", "Biegelinie y", "Randbedingungen [y 0 = (0::real), y L = 0, M_b 0 = 0, M_b L = 0]", "FunktionsVariable x", "GleichungsVariablen [c, c_2, c_3, c_4]", "AbleitungBiegelinie dy"],
81 ("Biegelinie", ["Biegelinien"], ["IntegrierenUndKonstanteBestimmen2"]))] => hd xxx
82 | _ => error "magic failed: handling file exp_Statics_Biegel_Timischl_7-70.str failed"
84 val formalise = hd formalise (*we expect only one Formalise.T in the list*)
85 val (hdlPIDE, _, refs, o_model, var_type_ctxt) = Step_Specify.initialisePIDE formalise
86 (* ^^ TODO remove with cleanup in nxt_specify_init_calc *)
88 TODO: present "Problem hdlPIDE" via PIDE
93 |> OMod_Data.put o_model
94 |> Ctxt_Data.put var_type_ctxt
97 fun load_formalisation parser (files, _) thy =
99 val ([{lines, pos, ...}: Token.file], thy') = files thy;
102 (ParseC.read_out_formalise (fst (parser (fst (ParseC.scan' pos (cat_lines lines))))))
108 subsection \<open>code to write Problem ("Biegelinie", ["Biegelinien"]) to thy\<close>
115 subsection \<open>code for Problem\<close>
117 Again, we copy code from spark_vc into Calculation.thy and
118 add functionality for Problem
119 such that the code keeps running during adaption from spark_vc to Problem.
124 subsubsection \<open>copied from fdl_parser.ML\<close>
130 | Quantifier of string * string list * string * expr
131 | Funct of string * expr list
132 | Element of expr * expr list
133 | Update of expr * expr list * expr
134 | Record of string * (string * expr) list
135 | Array of string * expr option *
136 ((expr * expr option) list list * expr) list;
140 | Enum_Type of string list
141 | Array_Type of string list * string
142 | Record_Type of (string list * string) list
145 (* also store items in a list to preserve order *)
146 type 'a tab = 'a Symtab.table * (string * 'a) list;
148 fun lookup ((tab, _) : 'a tab) = Symtab.lookup tab;
151 subsubsection \<open>copied from spark_vcs.ML\<close>
154 fun err_unfinished () = error "An unfinished SPARK environment is still open."
156 val strip_number = apply2 implode o chop_suffix Fdl_Lexer.is_digit o raw_explode;
158 val name_ord = prod_ord string_ord (option_ord int_ord) o
159 apply2 (strip_number ##> Int.fromString);
161 structure VCtab = Table(type key = string val ord = name_ord);
163 val builtin = Symtab.make (map (rpair ())
164 ["->", "<->", "or", "and", "not", "=", "<>", "<", ">", "<=", ">=",
165 "+", "-", "*", "/", "div", "mod", "**"]);
168 Symtab.defined builtin orf
169 can (unprefix "fld_") orf can (unprefix "upf_") orf
170 can (unsuffix "__pos") orf can (unsuffix "__val") orf
171 equal "succ" orf equal "pred";
173 fun fold_opt f = the_default I o Option.map f;
174 fun fold_pair f g (x, y) = f x #> g y;
176 fun fold_expr f g (Funct (s, es)) = f s #> fold (fold_expr f g) es
177 | fold_expr f g (Ident s) = g s
178 | fold_expr f g (Number _) = I
179 | fold_expr f g (Quantifier (_, _, _, e)) = fold_expr f g e
180 | fold_expr f g (Element (e, es)) =
181 fold_expr f g e #> fold (fold_expr f g) es
182 | fold_expr f g (Update (e, es, e')) =
183 fold_expr f g e #> fold (fold_expr f g) es #> fold_expr f g e'
184 | fold_expr f g (Record (_, flds)) = fold (fold_expr f g o snd) flds
185 | fold_expr f g (Array (_, default, assocs)) =
186 fold_opt (fold_expr f g) default #>
188 (fold (fold (fold_pair
189 (fold_expr f g) (fold_opt (fold_expr f g)))))
190 (fold_expr f g)) assocs;
192 fun add_expr_pfuns funs = fold_expr
193 (fn s => if is_pfun s then I else insert (op =) s)
194 (fn s => if is_none (lookup funs s) then I else insert (op =) s);
197 VCtab.fold (fn (_, (_, _, ps, cs)) => fold f ps #> fold f cs) vcs;
199 fun lookup_prfx "" tab s = Symtab.lookup tab s
200 | lookup_prfx prfx tab s = (case Symtab.lookup tab s of
201 NONE => Symtab.lookup tab (prfx ^ "__" ^ s)
204 fun pfuns_of_vcs prfx funs pfuns vcs =
205 fold_vcs (add_expr_pfuns funs o snd) vcs [] |>
206 filter (is_none o lookup_prfx prfx pfuns);
208 fun pfuns_of_vcs prfx funs pfuns vcs =
209 fold_vcs (add_expr_pfuns funs o snd) vcs [] |>
210 filter (is_none o lookup_prfx prfx pfuns);
212 structure VCs = Theory_Data
215 {pfuns: ((string list * string) option * term) Symtab.table,
216 type_map: (typ * (string * string) list) Symtab.table,
218 {ctxt: Element.context_i list,
219 defs: (binding * thm) list,
221 funs: (string list * string) tab,
222 pfuns: ((string list * string) option * term) Symtab.table,
223 ids: (term * string) Symtab.table * Name.context,
225 vcs: (string * thm list option *
226 (string * expr) list * (string * expr) list) VCtab.table,
228 prefix: string} option}
229 val empty : T = {pfuns = Symtab.empty, type_map = Symtab.empty, env = NONE}
231 fun merge ({pfuns = pfuns1, type_map = type_map1, env = NONE},
232 {pfuns = pfuns2, type_map = type_map2, env = NONE}) =
233 {pfuns = Symtab.merge (eq_pair (op =) (op aconv)) (pfuns1, pfuns2),
234 type_map = Symtab.merge (op =) (type_map1, type_map2),
236 | merge _ = err_unfinished ()
239 fun get_type thy prfx ty =
240 let val {type_map, ...} = VCs.get thy
241 in lookup_prfx prfx type_map ty end;
243 fun mk_type' _ _ "integer" = (HOLogic.intT, [])
244 | mk_type' _ _ "boolean" = (HOLogic.boolT, [])
245 | mk_type' thy prfx ty =
246 (case get_type thy prfx ty of
248 (Syntax.check_typ (Proof_Context.init_global thy)
249 (Type (Sign.full_name thy (Binding.name ty), [])),
253 fun mk_type thy prfx ty = fst (mk_type' thy prfx ty);
255 fun pfun_type thy prfx (argtys, resty) =
256 map (mk_type thy prfx) argtys ---> mk_type thy prfx resty;
258 fun declare_missing_pfuns thy prfx funs pfuns vcs (tab, ctxt) =
260 val (fs, (tys, Ts)) =
261 pfuns_of_vcs prfx funs pfuns vcs |>
262 map_filter (fn s => lookup funs s |>
263 Option.map (fn ty => (s, (SOME ty, pfun_type thy prfx ty)))) |>
264 split_list ||> split_list;
265 val (fs', ctxt') = fold_map Name.variant fs ctxt
267 (fold Symtab.update_new (fs ~~ (tys ~~ map Free (fs' ~~ Ts))) pfuns,
268 Element.Fixes (map2 (fn s => fn T =>
269 (Binding.name s, SOME T, NoSyn)) fs' Ts),
273 fun strip_underscores s =
274 strip_underscores (unsuffix "_" s) handle Fail _ => s;
277 unsuffix "~" s ^ "_init" handle Fail _ => s;
279 val mangle_name = strip_underscores #> strip_tilde;
281 fun mk_variables thy prfx xs ty (tab, ctxt) =
283 val T = mk_type thy prfx ty;
284 val (ys, ctxt') = fold_map Name.variant (map mangle_name xs) ctxt;
285 val zs = map (Free o rpair T) ys;
286 in (zs, (fold (Symtab.update o apsnd (rpair ty)) (xs ~~ zs) tab, ctxt')) end;
289 let val T = fastype_of t
290 in Const (s, T --> T) $ t end;
292 val booleanN = "boolean";
293 val integerN = "integer";
295 val to_lower = raw_explode #> map Symbol.to_ascii_lower #> implode;
296 val lcase_eq = (op =) o apply2 (to_lower o Long_Name.base_name);
298 fun find_field [] fname fields =
299 find_first (curry lcase_eq fname o fst) fields
300 | find_field cmap fname fields =
301 (case AList.lookup (op =) cmap fname of
303 | SOME fname' => SOME (fname', the (AList.lookup (op =) fields fname')));
305 fun get_record_info thy T = (case Record.dest_recTs T of
306 [(tyname, [\<^typ>\<open>unit\<close>])] =>
307 Record.get_info thy (Long_Name.qualifier tyname)
310 fun find_field' fname = get_first (fn (flds, fldty) =>
311 if member (op =) flds fname then SOME fldty else NONE);
313 fun invert_map [] = I
315 map (apfst (the o AList.lookup (op =) (map swap cmap)));
317 fun mk_times (t, u) =
319 val setT = fastype_of t;
320 val T = HOLogic.dest_setT setT;
321 val U = HOLogic.dest_setT (fastype_of u)
323 Const (\<^const_name>\<open>Sigma\<close>, setT --> (T --> HOLogic.mk_setT U) -->
324 HOLogic.mk_setT (HOLogic.mk_prodT (T, U))) $ t $ Abs ("", T, u)
327 fun term_of_expr thy prfx types pfuns =
329 fun tm_of vs (Funct ("->", [e, e'])) =
330 (HOLogic.mk_imp (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
332 | tm_of vs (Funct ("<->", [e, e'])) =
333 (HOLogic.mk_eq (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
335 | tm_of vs (Funct ("or", [e, e'])) =
336 (HOLogic.mk_disj (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
338 | tm_of vs (Funct ("and", [e, e'])) =
339 (HOLogic.mk_conj (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
341 | tm_of vs (Funct ("not", [e])) =
342 (HOLogic.mk_not (fst (tm_of vs e)), booleanN)
344 | tm_of vs (Funct ("=", [e, e'])) =
345 (HOLogic.mk_eq (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
347 | tm_of vs (Funct ("<>", [e, e'])) = (HOLogic.mk_not
348 (HOLogic.mk_eq (fst (tm_of vs e), fst (tm_of vs e'))), booleanN)
350 | tm_of vs (Funct ("<", [e, e'])) = (HOLogic.mk_binrel \<^const_name>\<open>less\<close>
351 (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
353 | tm_of vs (Funct (">", [e, e'])) = (HOLogic.mk_binrel \<^const_name>\<open>less\<close>
354 (fst (tm_of vs e'), fst (tm_of vs e)), booleanN)
356 | tm_of vs (Funct ("<=", [e, e'])) = (HOLogic.mk_binrel \<^const_name>\<open>less_eq\<close>
357 (fst (tm_of vs e), fst (tm_of vs e')), booleanN)
359 | tm_of vs (Funct (">=", [e, e'])) = (HOLogic.mk_binrel \<^const_name>\<open>less_eq\<close>
360 (fst (tm_of vs e'), fst (tm_of vs e)), booleanN)
362 | tm_of vs (Funct ("+", [e, e'])) = (HOLogic.mk_binop \<^const_name>\<open>plus\<close>
363 (fst (tm_of vs e), fst (tm_of vs e')), integerN)
365 | tm_of vs (Funct ("-", [e, e'])) = (HOLogic.mk_binop \<^const_name>\<open>minus\<close>
366 (fst (tm_of vs e), fst (tm_of vs e')), integerN)
368 | tm_of vs (Funct ("*", [e, e'])) = (HOLogic.mk_binop \<^const_name>\<open>times\<close>
369 (fst (tm_of vs e), fst (tm_of vs e')), integerN)
371 | tm_of vs (Funct ("/", [e, e'])) = (HOLogic.mk_binop \<^const_name>\<open>divide\<close>
372 (fst (tm_of vs e), fst (tm_of vs e')), integerN)
374 | tm_of vs (Funct ("div", [e, e'])) = (HOLogic.mk_binop \<^const_name>\<open>sdiv\<close>
375 (fst (tm_of vs e), fst (tm_of vs e')), integerN)
377 | tm_of vs (Funct ("mod", [e, e'])) = (HOLogic.mk_binop \<^const_name>\<open>modulo\<close>
378 (fst (tm_of vs e), fst (tm_of vs e')), integerN)
380 | tm_of vs (Funct ("-", [e])) =
381 (mk_unop \<^const_name>\<open>uminus\<close> (fst (tm_of vs e)), integerN)
383 | tm_of vs (Funct ("**", [e, e'])) =
384 (Const (\<^const_name>\<open>power\<close>, HOLogic.intT --> HOLogic.natT -->
385 HOLogic.intT) $ fst (tm_of vs e) $
386 (\<^const>\<open>nat\<close> $ fst (tm_of vs e')), integerN)
388 | tm_of (tab, _) (Ident s) =
389 (case Symtab.lookup tab s of
391 | NONE => (case lookup_prfx prfx pfuns s of
392 SOME (SOME ([], resty), t) => (t, resty)
393 | _ => error ("Undeclared identifier " ^ s)))
395 | tm_of _ (Number i) = (HOLogic.mk_number HOLogic.intT i, integerN)
397 | tm_of vs (Quantifier (s, xs, ty, e)) =
399 val (ys, vs') = mk_variables thy prfx xs ty vs;
401 "for_all" => HOLogic.mk_all
402 | "for_some" => HOLogic.mk_exists)
404 (fold_rev (fn Free (x, T) => fn t => q (x, T, t))
405 ys (fst (tm_of vs' e)),
409 | tm_of vs (Funct (s, es)) =
411 (* record field selection *)
412 (case try (unprefix "fld_") s of
413 SOME fname => (case es of
416 val (t, rcdty) = tm_of vs e;
417 val (rT, cmap) = mk_type' thy prfx rcdty
418 in case (get_record_info thy rT, lookup types rcdty) of
419 (SOME {fields, ...}, SOME (Record_Type fldtys)) =>
420 (case (find_field cmap fname fields,
421 find_field' fname fldtys) of
422 (SOME (fname', fT), SOME fldty) =>
423 (Const (fname', rT --> fT) $ t, fldty)
424 | _ => error ("Record " ^ rcdty ^
425 " has no field named " ^ fname))
426 | _ => error (rcdty ^ " is not a record type")
428 | _ => error ("Function " ^ s ^ " expects one argument"))
431 (* record field update *)
432 (case try (unprefix "upf_") s of
433 SOME fname => (case es of
436 val (t, rcdty) = tm_of vs e;
437 val (rT, cmap) = mk_type' thy prfx rcdty;
438 val (u, fldty) = tm_of vs e';
439 val fT = mk_type thy prfx fldty
440 in case get_record_info thy rT of
441 SOME {fields, ...} =>
442 (case find_field cmap fname fields of
445 (Const (fname' ^ "_update",
446 (fT --> fT) --> rT --> rT) $
447 Abs ("x", fT, u) $ t,
449 else error ("Type\n" ^
450 Syntax.string_of_typ_global thy fT ^
451 "\ndoes not match type\n" ^
452 Syntax.string_of_typ_global thy fU ^
453 "\nof field " ^ fname)
454 | NONE => error ("Record " ^ rcdty ^
455 " has no field named " ^ fname))
456 | _ => error (rcdty ^ " is not a record type")
458 | _ => error ("Function " ^ s ^ " expects two arguments"))
461 (* enumeration type to integer *)
462 (case try (unsuffix "__pos") s of
463 SOME tyname => (case es of
464 [e] => (Const (\<^const_name>\<open>pos\<close>,
465 mk_type thy prfx tyname --> HOLogic.intT) $ fst (tm_of vs e),
467 | _ => error ("Function " ^ s ^ " expects one argument"))
470 (* integer to enumeration type *)
471 (case try (unsuffix "__val") s of
472 SOME tyname => (case es of
473 [e] => (Const (\<^const_name>\<open>val\<close>,
474 HOLogic.intT --> mk_type thy prfx tyname) $ fst (tm_of vs e),
476 | _ => error ("Function " ^ s ^ " expects one argument"))
479 (* successor / predecessor of enumeration type element *)
480 if s = "succ" orelse s = "pred" then (case es of
483 val (t, tyname) = tm_of vs e;
484 val T = mk_type thy prfx tyname
486 (if s = "succ" then \<^const_name>\<open>succ\<close>
487 else \<^const_name>\<open>pred\<close>, T --> T) $ t, tyname)
489 | _ => error ("Function " ^ s ^ " expects one argument"))
491 (* user-defined proof function *)
493 (case lookup_prfx prfx pfuns s of
494 SOME (SOME (_, resty), t) =>
495 (list_comb (t, map (fst o tm_of vs) es), resty)
496 | _ => error ("Undeclared proof function " ^ s))))))
498 | tm_of vs (Element (e, es)) =
499 let val (t, ty) = tm_of vs e
500 in case lookup types ty of
501 SOME (Array_Type (_, elty)) =>
502 (t $ foldr1 HOLogic.mk_prod (map (fst o tm_of vs) es), elty)
503 | _ => error (ty ^ " is not an array type")
506 | tm_of vs (Update (e, es, e')) =
507 let val (t, ty) = tm_of vs e
508 in case lookup types ty of
509 SOME (Array_Type (idxtys, elty)) =>
511 val T = foldr1 HOLogic.mk_prodT
512 (map (mk_type thy prfx) idxtys);
513 val U = mk_type thy prfx elty;
516 (Const (\<^const_name>\<open>fun_upd\<close>, fT --> T --> U --> fT) $
517 t $ foldr1 HOLogic.mk_prod (map (fst o tm_of vs) es) $
521 | _ => error (ty ^ " is not an array type")
524 | tm_of vs (Record (s, flds)) =
526 val (T, cmap) = mk_type' thy prfx s;
527 val {extension = (ext_name, _), fields, ...} =
528 (case get_record_info thy T of
529 NONE => error (s ^ " is not a record type")
530 | SOME info => info);
531 val flds' = map (apsnd (tm_of vs)) flds;
532 val fnames = fields |> invert_map cmap |>
533 map (Long_Name.base_name o fst);
534 val fnames' = map fst flds;
535 val (fvals, ftys) = split_list (map (fn s' =>
536 case AList.lookup lcase_eq flds' s' of
537 SOME fval_ty => fval_ty
538 | NONE => error ("Field " ^ s' ^ " missing in record " ^ s))
540 val _ = (case subtract lcase_eq fnames fnames' of
542 | xs => error ("Extra field(s) " ^ commas xs ^
544 val _ = (case duplicates (op =) fnames' of
546 | xs => error ("Duplicate field(s) " ^ commas xs ^
551 map (mk_type thy prfx) ftys @ [HOLogic.unitT] ---> T),
552 fvals @ [HOLogic.unit]),
556 | tm_of vs (Array (s, default, assocs)) =
557 (case lookup types s of
558 SOME (Array_Type (idxtys, elty)) =>
560 val Ts = map (mk_type thy prfx) idxtys;
561 val T = foldr1 HOLogic.mk_prodT Ts;
562 val U = mk_type thy prfx elty;
563 fun mk_idx' T (e, NONE) = HOLogic.mk_set T [fst (tm_of vs e)]
564 | mk_idx' T (e, SOME e') = Const (\<^const_name>\<open>atLeastAtMost\<close>,
565 T --> T --> HOLogic.mk_setT T) $
566 fst (tm_of vs e) $ fst (tm_of vs e');
568 if length Ts <> length idx then
569 error ("Arity mismatch in construction of array " ^ s)
570 else foldr1 mk_times (map2 mk_idx' Ts idx);
571 fun mk_upd (idxs, e) t =
572 if length idxs = 1 andalso forall (is_none o snd) (hd idxs)
574 Const (\<^const_name>\<open>fun_upd\<close>, (T --> U) -->
575 T --> U --> T --> U) $ t $
576 foldl1 HOLogic.mk_prod
577 (map (fst o tm_of vs o fst) (hd idxs)) $
580 Const (\<^const_name>\<open>fun_upds\<close>, (T --> U) -->
581 HOLogic.mk_setT T --> U --> T --> U) $ t $
582 foldl1 (HOLogic.mk_binop \<^const_name>\<open>sup\<close>)
588 SOME e => Abs ("x", T, fst (tm_of vs e))
589 | NONE => Const (\<^const_name>\<open>undefined\<close>, T --> U)),
592 | _ => error (s ^ " is not an array type"))
596 fun mk_pat s = (case Int.fromString s of
597 SOME i => [HOLogic.mk_Trueprop (Var (("C", i), HOLogic.boolT))]
598 | NONE => error ("Bad conclusion identifier: C" ^ s));
600 fun mk_vc thy prfx types pfuns ids name_concl (tr, proved, ps, cs) =
602 HOLogic.mk_Trueprop o fst o term_of_expr thy prfx types pfuns ids
605 Element.Assumes (map (fn (s', e) =>
606 ((Binding.name ("H" ^ s'), []), [(prop_of e, [])])) ps),
607 Element.Shows (map (fn (s', e) =>
608 (if name_concl then (Binding.name ("C" ^ s'), [])
609 else Binding.empty_atts,
610 [(prop_of e, mk_pat s')])) cs))
613 (*val lookup_vc: theory -> bool -> string -> (Element.context_i list *
614 (string * thm list option * Element.context_i * Element.statement_i)) option
616 fun lookup_vc thy name_concl name =
618 {env = SOME {vcs, types, funs, pfuns, ids, ctxt, prefix, ...}, ...} =>
619 (case VCtab.lookup vcs name of
621 let val (pfuns', ctxt', ids') =
622 declare_missing_pfuns thy prefix funs pfuns vcs ids
624 SOME (ctxt @ [ctxt'],
625 mk_vc thy prefix types pfuns' ids' name_concl vc)
631 subsubsection \<open>copied from spark_commands.ML\<close>
634 fun get_vc thy vc_name =
635 (case SPARK_VCs.lookup_vc thy false vc_name of
636 SOME (ctxt, (_, proved, ctxt', stmt)) =>
637 if is_some proved then
638 error ("The verification condition " ^
639 quote vc_name ^ " has already been proved.")
640 else (ctxt @ [ctxt'], stmt)
641 | NONE => error ("There is no verification condition " ^
642 quote vc_name ^ "."));
645 val prefer_input: ThyC.id * Problem.id -> References.T -> O_Model.T -> References.T * O_Model.T
647 fun prefer_input (inthy, inpbl : Problem.id) (thy, pbl, met_id) o_model =
648 if inthy = thy andalso inpbl = pbl
649 then ((thy, pbl, met_id) : References.T, o_model)
650 else ((inthy, inpbl, Method.id_empty), [])
653 val prove_vc : string -> Proof.context -> Proof.state
655 val prove_vc : string -> Proof.context -> Proof.state
657 fun prove_vc vc_name lthy =
659 val _ = @{print} {a = "//--- Spark_Commands.prove_vc", vc_name = vc_name}
660 val thy = Proof_Context.theory_of lthy;
661 val (ctxt, stmt) = get_vc thy vc_name
662 (*//--------------------------------- new code --------------------------------\\*)
663 val refs'' = ("Biegelinie", ["Biegelinien"]) (*until Parse.name \<rightarrow> ParseC.problem_headline*)
664 val refs' = Refs_Data.get thy
665 val (refs as (_, pbl_id, _), o_model) = prefer_input refs'' refs' (OMod_Data.get thy)
666 val i_model = I_Model.initPIDE pbl_id
668 TODO: present Specification = i_model () + refs via PIDE
670 (*----------------------------------- new code ----------------------------------*)
671 val _ = @{print} {a = "prove_vc", o_model = o_model, refs = refs, i_model = i_model}
672 (*\\--------------------------------- new code --------------------------------//*)
674 Specification.theorem true Thm.theoremK NONE
675 (fn thmss => (Local_Theory.background_theory
676 (SPARK_VCs.mark_proved vc_name (flat thmss))))
677 (Binding.name vc_name, []) [] ctxt stmt false lthy
682 section \<open>setup command_keyword \<close>
686 Outer_Syntax.command \<^command_keyword>\<open>Example\<close> "start a Calculation from a Formalise-file"
687 (Resources.provide_parse_files "Example" -- Parse.parname
688 >> (Toplevel.theory o (load_formalisation ParseC.formalisation)));
691 Outer_Syntax.local_theory_to_proof \<^command_keyword>\<open>Problem\<close>
692 "start a Specification, either from scratch or from preceding 'Example'"
693 (Parse.name >> prove_vc);
697 subsection \<open>test runs with Example\<close>
699 Starting the Calculation for the Example requires session Isac with Isac.Biegelinie etc.
700 So, do ~~$ ./zcoding-to-test.sh and use Test_Some.thy to evaluate
702 Example \<open>/usr/local/isabisac/src/Tools/isac/Examples/exp_Statics_Biegel_Timischl_7-70\<close>
704 This now gives no error, but also no <Output>. See child of 3ea616c84845.
706 (*required for proof below..*)
707 spark_proof_functions
708 gcd = "gcd :: int \<Rightarrow> int \<Rightarrow> int"
710 spark_open \<open>~~/src/HOL/SPARK/Examples/Gcd/greatest_common_divisor/g_c_d\<close>
712 The following verification conditions remain to be proved:
716 spark_vc procedure_g_c_d_4
718 from \<open>0 < d\<close> have "0 \<le> c mod d" by (rule pos_mod_sign)
719 with \<open>0 \<le> c\<close> \<open>0 < d\<close> \<open>c - c sdiv d * d \<noteq> 0\<close> show ?C1
720 by (simp add: sdiv_pos_pos minus_div_mult_eq_mod [symmetric])
723 from \<open>0 < d\<close> have "0 \<le> c mod d" by (rule pos_mod_sign)
724 with \<open>0 \<le> c\<close> \<open>0 < d\<close> \<open>c - c sdiv d * d \<noteq> 0\<close> show ?C1
725 by (simp add: sdiv_pos_pos minus_div_mult_eq_mod [symmetric])
727 from \<open>0 \<le> c\<close> \<open>0 < d\<close> \<open>gcd c d = gcd m n\<close> show ?C2
728 by (simp add: sdiv_pos_pos minus_div_mult_eq_mod [symmetric] gcd_non_0_int)
733 spark_vc procedure_g_c_d_11
737 ( *Bad path binding: "$ISABELLE_HOME/src/HOL/SPARK/Examples/Gcd/greatest_common_divisor/g_c_d.prv"*)
740 section \<open>adapt spark_vc to Problem\<close>
742 subsection \<open>survey on steps of investigation\<close>
744 1.prove_vc: string -> Proof.context -> Proof.state
745 ? where does ^^^^^^^^^^^^^ come from:
746 fun get_vc: (case SPARK_VCs.lookup_vc .. of SOME (ctxt, (_, proved, ctxt', stmt)) => ...
750 subsection \<open>notes and testbed for spark_vcs\<close>
752 \<close> ML \<open> (* Outer_Syntax.local_theory_to_proof..global_interpretationC *)
753 val interpretation_args_with_defs =
754 Parse.!!! Parse_Spec.locale_expression --
755 (Scan.optional (\<^keyword>\<open>defines\<close> |-- Parse.and_list1 (Parse_Spec.opt_thm_name ":"
756 -- ((Parse.binding -- Parse.opt_mixfix') --| \<^keyword>\<open>=\<close> -- Parse.term))) ([]));
758 Outer_Syntax.local_theory_to_proof \<^command_keyword>\<open>global_interpretationC\<close>
759 "prove interpretation of locale expression into global theory"
760 (interpretation_args_with_defs >> (fn (expr, defs) =>
761 Interpretation.global_interpretation_cmd expr defs));
763 (interpretation_args_with_defs >> (fn (expr, defs) =>
764 Interpretation.global_interpretation_cmd expr defs))
765 : Token.T list -> (local_theory -> Proof.state) * Token.T list;
767 \<close> ML \<open> (* Outer_Syntax.local_theory_to_proof..Problem *)
768 (Parse.name >> prove_vc)
769 : Token.T list -> (Proof.context -> Proof.state) * Token.T list;
774 subsection \<open>testbed for Problem\<close>
788 ERROR: Found the end of the theory, but the last SPARK environment is still open.
789 ..is OK, since "spark_end" does NOT work here for some reason.