diff --git a/thys/Applicative_Lifting/applicative.ML b/thys/Applicative_Lifting/applicative.ML --- a/thys/Applicative_Lifting/applicative.ML +++ b/thys/Applicative_Lifting/applicative.ML @@ -1,1376 +1,1376 @@ (* Author: Joshua Schneider, ETH Zurich *) signature APPLICATIVE = sig type afun val intern: Context.generic -> xstring -> string val extern: Context.generic -> string -> xstring val afun_of_generic: Context.generic -> string -> afun val afun_of: Proof.context -> string -> afun val afuns_of_term_generic: Context.generic -> term -> afun list val afuns_of_term: Proof.context -> term -> afun list val afuns_of_typ_generic: Context.generic -> typ -> afun list val afuns_of_typ: Proof.context -> typ -> afun list val name_of_afun: afun -> binding val unfolds_of_afun: afun -> thm list type afun_inst val match_afun_inst: Proof.context -> afun -> term * int -> afun_inst val import_afun_inst: afun -> Proof.context -> afun_inst * Proof.context val inner_sort_of: afun_inst -> sort val mk_type: afun_inst -> typ -> typ val mk_pure: afun_inst -> typ -> term val lift_term: afun_inst -> term -> term val mk_ap: afun_inst -> typ * typ -> term val mk_comb: afun_inst -> typ -> term * term -> term val mk_set: afun_inst -> typ -> term val dest_type: Proof.context -> afun_inst -> typ -> typ option val dest_type': Proof.context -> afun_inst -> typ -> typ val dest_pure: Proof.context -> afun_inst -> term -> term val dest_comb: Proof.context -> afun_inst -> term -> term * term val infer_comb: Proof.context -> afun_inst -> term * term -> term val subst_lift_term: afun_inst -> (term * term) list -> term -> term val generalize_lift_terms: afun_inst -> term list -> Proof.context -> term list * Proof.context val afun_unfold_tac: Proof.context -> afun -> int -> tactic val afun_fold_tac: Proof.context -> afun -> int -> tactic val unfold_all_tac: Proof.context -> int -> tactic val normalform_conv: Proof.context -> afun -> conv val normalize_rel_tac: Proof.context -> afun -> int -> tactic val general_normalform_conv: Proof.context -> afun -> cterm * cterm -> thm * thm val general_normalize_rel_tac: Proof.context -> afun -> int -> tactic val forward_lift_rule: Proof.context -> afun -> thm -> thm val unfold_wrapper_tac: Proof.context -> afun option -> int -> tactic val fold_wrapper_tac: Proof.context -> afun option -> int -> tactic val normalize_wrapper_tac: Proof.context -> afun option -> int -> tactic val lifting_wrapper_tac: Proof.context -> afun option -> int -> tactic val setup_combinators: (string * thm) list -> local_theory -> local_theory val combinator_rule_attrib: string list option -> attribute val parse_opt_afun: afun option context_parser val applicative_cmd: (((((binding * string list) * string) * string) * string option) * string option) -> local_theory -> Proof.state val print_afuns: Proof.context -> unit val add_unfold_attrib: xstring option -> attribute val forward_lift_attrib: xstring -> attribute end; structure Applicative : APPLICATIVE = struct open Ctr_Sugar_Util (** General utilities **) fun fold_options xs = fold (fn x => (case x of SOME x' => cons x' | NONE => I)) xs []; fun the_pair [x, y] = (x, y) | the_pair _ = raise General.Size; fun strip_comb2 (f $ x $ y) = (f, (x, y)) | strip_comb2 t = raise TERM ("strip_comb2", [t]); fun mk_comb_pattern (t, n) = let val Ts = take n (binder_types (fastype_of t)); val maxidx = maxidx_of_term t; val vars = map (fn (T, i) => ((Name.uu, maxidx + i), T)) (Ts ~~ (1 upto n)); in (vars, Term.betapplys (t, map Var vars)) end; fun match_comb_pattern ctxt tn u = let val thy = Proof_Context.theory_of ctxt; val (vars, pat) = mk_comb_pattern tn; val envs = Pattern.match thy (pat, u) (Vartab.empty, Vartab.empty) handle Pattern.MATCH => raise TERM ("match_comb_pattern", [u, pat]); in (vars, envs) end; fun dest_comb_pattern ctxt tn u = let val (vars, (_, env)) = match_comb_pattern ctxt tn u; in map (the o Envir.lookup1 env) vars end; fun norm_term_types tyenv t = Term_Subst.map_types_same (Envir.norm_type_same tyenv) t handle Same.SAME => t; val mk_TFrees_of = mk_TFrees' oo replicate; fun mk_Free name typ ctxt = yield_singleton Variable.variant_fixes name ctxt |>> (fn name' => Free (name', typ)); (*tuples with explicit sentinel*) fun mk_tuple' ts = fold_rev (curry HOLogic.mk_prod) ts HOLogic.unit; fun strip_tuple' (Const (@{const_name Unity}, _)) = [] | strip_tuple' (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: strip_tuple' t2 | strip_tuple' t = raise TERM ("strip_tuple'", [t]); fun mk_eq_on S = let val (SA, ST) = `HOLogic.dest_setT (fastype_of S); in Const (@{const_name eq_on}, ST --> BNF_Util.mk_pred2T SA SA) $ S end; (* Polymorphic terms and term groups *) type poly_type = typ list * typ; type poly_term = typ list * term; fun instantiate_poly_type (tvars, T) insts = typ_subst_atomic (tvars ~~ insts) T; fun instantiate_poly_term (tvars, t) insts = subst_atomic_types (tvars ~~ insts) t; fun dest_poly_type ctxt (tvars, T) U = let val thy = Proof_Context.theory_of ctxt; val tyenv = Sign.typ_match thy (T, U) Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("dest_poly_type", [U, T], []); in map (Type.lookup tyenv o dest_TVar) tvars end; fun poly_type_to_term (tvars, T) = (tvars, Logic.mk_type T); fun poly_type_of_term (tvars, t) = (tvars, Logic.dest_type t); (* Schematic variables are treated uniformly in packed terms, thus forming an ad hoc context of type variables. Otherwise, morphisms are allowed to rename schematic variables non-consistently in separate terms, and occasionally will do so. *) fun pack_poly_term (tvars, t) = HOLogic.mk_prod (mk_tuple' (map Logic.mk_type tvars), t); fun unpack_poly_term t = let val (tvars, t') = HOLogic.dest_prod t; in (map Logic.dest_type (strip_tuple' tvars), t') end; val pack_poly_terms = mk_tuple' o map pack_poly_term; val unpack_poly_terms = map unpack_poly_term o strip_tuple'; (*match and instantiate schematic type variables which are not "quantified" in the packed term*) fun match_poly_terms_type ctxt (pt, i) (U, maxidx) = let val thy = Proof_Context.theory_of ctxt; val pt' = Logic.incr_indexes ([], [], maxidx + 1) pt; val (tvars, T) = poly_type_of_term (nth (unpack_poly_terms pt') i); val tyenv = Sign.typ_match thy (T, U) Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("match_poly_terms", [U, T], []); val tyenv' = fold Vartab.delete_safe (map (#1 o dest_TVar) tvars) tyenv; val pt'' = Envir.subst_term_types tyenv' pt'; in unpack_poly_terms pt'' end; fun match_poly_terms ctxt (pt, i) (t, maxidx) = match_poly_terms_type ctxt (pt, i) (fastype_of t, maxidx); (*fix schematic type variables which are not "quantified", as well as schematic term variables*) fun import_poly_terms pt ctxt = let fun insert_paramTs (tvars, t) = fold_types (fold_atyps (fn TVar v => if member (op =) tvars (TVar v) then I else insert (op =) v | _ => I)) t; val paramTs = rev (fold insert_paramTs (unpack_poly_terms pt) []); val (tfrees, ctxt') = Variable.invent_types (map #2 paramTs) ctxt; val instT = TVars.make (paramTs ~~ map TFree tfrees); val params = map (apsnd (Term_Subst.instantiateT instT)) (rev (Term.add_vars pt [])); val (frees, ctxt'') = Variable.variant_fixes (map (Name.clean o #1 o #1) params) ctxt'; val inst = Vars.make (params ~~ map Free (frees ~~ map #2 params)); val pt' = Term_Subst.instantiate (instT, inst) pt; in (unpack_poly_terms pt', ctxt'') end; (** Internal representation **) (* Applicative functors *) type rel_thms = { pure_transfer: thm, ap_rel_fun: thm }; fun map_rel_thms f {pure_transfer, ap_rel_fun} = {pure_transfer = f pure_transfer, ap_rel_fun = f ap_rel_fun}; type afun_thms = { hom: thm, ichng: thm, reds: thm Symtab.table, rel_thms: rel_thms option, rel_intros: thm list, pure_comp_conv: thm }; fun map_afun_thms f {hom, ichng, reds, rel_thms, rel_intros, pure_comp_conv} = {hom = f hom, ichng = f ichng, reds = Symtab.map (K f) reds, rel_thms = Option.map (map_rel_thms f) rel_thms, rel_intros = map f rel_intros, pure_comp_conv = f pure_comp_conv}; datatype afun = AFun of { name: binding, terms: term, rel: term option, thms: afun_thms, unfolds: thm Item_Net.T }; fun rep_afun (AFun af) = af; val name_of_afun = #name o rep_afun; val terms_of_afun = #terms o rep_afun; val rel_of_afun = #rel o rep_afun; val thms_of_afun = #thms o rep_afun; val unfolds_of_afun = Item_Net.content o #unfolds o rep_afun; val red_of_afun = Symtab.lookup o #reds o thms_of_afun; val has_red_afun = is_some oo red_of_afun; fun mk_afun name terms rel thms = AFun {name = name, terms = terms, rel = rel, thms = thms, unfolds = Thm.item_net}; fun map_afun f1 f2 f3 f4 f5 (AFun {name, terms, rel, thms, unfolds}) = AFun {name = f1 name, terms = f2 terms, rel = f3 rel, thms = f4 thms, unfolds = f5 unfolds}; fun map_unfolds f thms = fold Item_Net.update (map f (Item_Net.content thms)) Thm.item_net; fun morph_afun phi = let val binding = Morphism.binding phi; val term = Morphism.term phi; val thm = Morphism.thm phi; in map_afun binding term (Option.map term) (map_afun_thms thm) (map_unfolds thm) end; val transfer_afun = morph_afun o Morphism.transfer_morphism; fun add_unfolds_afun thms = map_afun I I I I (fold Item_Net.update thms); fun patterns_of_afun af = let val [Tt, (_, pure), (_, ap), _] = unpack_poly_terms (terms_of_afun af); val (_, T) = poly_type_of_term Tt; in [#2 (mk_comb_pattern (pure, 1)), #2 (mk_comb_pattern (ap, 2)), Net.encode_type T] end; (* Combinator rules *) datatype combinator_rule = Combinator_Rule of { strong_premises: string Ord_List.T, weak_premises: bool, conclusion: string, eq_thm: thm }; fun rep_combinator_rule (Combinator_Rule rule) = rule; val conclusion_of_rule = #conclusion o rep_combinator_rule; val thm_of_rule = #eq_thm o rep_combinator_rule; fun eq_combinator_rule (rule1, rule2) = pointer_eq (rule1, rule2) orelse Thm.eq_thm (thm_of_rule rule1, thm_of_rule rule2); fun is_applicable_rule rule have_weak have_premises = let val {strong_premises, weak_premises, ...} = rep_combinator_rule rule; in (have_weak orelse not weak_premises) andalso have_premises strong_premises end; fun map_combinator_rule f1 f2 f3 f4 (Combinator_Rule {strong_premises, weak_premises, conclusion, eq_thm}) = Combinator_Rule {strong_premises = f1 strong_premises, weak_premises = f2 weak_premises, conclusion = f3 conclusion, eq_thm = f4 eq_thm}; fun transfer_combinator_rule thy = map_combinator_rule I I I (Thm.transfer thy); fun mk_combinator_rule comb_names weak_premises thm = let val (lhs, rhs) = Logic.dest_equals (Thm.prop_of thm); val conclusion = the (Symtab.lookup comb_names (#1 (dest_Const lhs))); val premises = Ord_List.make fast_string_ord (fold_options (map (Symtab.lookup comb_names o #1) (Term.add_consts rhs []))); val weak_premises' = Ord_List.make fast_string_ord (these weak_premises); val strong_premises = Ord_List.subtract fast_string_ord weak_premises' premises; in Combinator_Rule {strong_premises = strong_premises, weak_premises = is_some weak_premises, conclusion = conclusion, eq_thm = thm} end; (* Generic data *) (*FIXME: needs tests, especially around theory merging*) fun merge_afuns _ (af1, af2) = if pointer_eq (af1, af2) then raise Change_Table.SAME else map_afun I I I I (fn thms1 => Item_Net.merge (thms1, #unfolds (rep_afun af2))) af1; structure Data = Generic_Data ( type T = { combinators: thm Symtab.table * combinator_rule list, afuns: afun Name_Space.table, patterns: (string * term list) Item_Net.T }; val empty = { combinators = (Symtab.empty, []), afuns = Name_Space.empty_table "applicative functor", patterns = Item_Net.init (op = o apply2 #1) #2 }; fun merge ({combinators = (cd1, cr1), afuns = a1, patterns = p1}, {combinators = (cd2, cr2), afuns = a2, patterns = p2}) = {combinators = (Symtab.merge (K true) (cd1, cd2), Library.merge eq_combinator_rule (cr1, cr2)), afuns = Name_Space.join_tables merge_afuns (a1, a2), patterns = Item_Net.merge (p1, p2)}; ); fun get_combinators context = let val thy = Context.theory_of context; val {combinators = (defs, rules), ...} = Data.get context; in (Symtab.map (K (Thm.transfer thy)) defs, map (transfer_combinator_rule thy) rules) end; val get_afun_table = #afuns o Data.get; val get_afun_space = Name_Space.space_of_table o get_afun_table; val get_patterns = #patterns o Data.get; fun map_data f1 f2 f3 {combinators, afuns, patterns} = {combinators = f1 combinators, afuns = f2 afuns, patterns = f3 patterns}; val intern = Name_Space.intern o get_afun_space; fun extern context = Name_Space.extern (Context.proof_of context) (get_afun_space context); local fun undeclared name = error ("Undeclared applicative functor " ^ quote name); in fun afun_of_generic context name = case Name_Space.lookup (get_afun_table context) name of SOME af => transfer_afun (Context.theory_of context) af | NONE => undeclared name; val afun_of = afun_of_generic o Context.Proof; fun update_afun name f context = if Name_Space.defined (get_afun_table context) name then Data.map (map_data I (Name_Space.map_table_entry name f) I) context else undeclared name; end; fun match_term context = map #1 o Item_Net.retrieve_matching (get_patterns context); fun match_typ context = match_term context o Net.encode_type; (*works only with terms which are combinations of pure and ap*) fun afuns_of_term_generic context = map (afun_of_generic context) o match_term context; val afuns_of_term = afuns_of_term_generic o Context.Proof; fun afuns_of_typ_generic context = map (afun_of_generic context) o match_typ context; val afuns_of_typ = afuns_of_typ_generic o Context.Proof; fun all_unfolds_of_generic context = let val unfolds_of = map (Thm.transfer'' context) o unfolds_of_afun; in Name_Space.fold_table (fn (_, af) => append (unfolds_of af)) (get_afun_table context) [] end; val all_unfolds_of = all_unfolds_of_generic o Context.Proof; (** Term construction and destruction **) type afun_inst = { T: poly_type, pure: poly_term, ap: poly_term, set: poly_term }; fun mk_afun_inst [T, pure, ap, set] = {T = poly_type_of_term T, pure = pure, ap = ap, set = set}; fun pack_afun_inst {T, pure, ap, set} = pack_poly_terms [poly_type_to_term T, pure, ap, set]; fun match_afun_inst ctxt af = match_poly_terms ctxt (terms_of_afun af, 0) #> mk_afun_inst; fun import_afun_inst_raw terms = import_poly_terms terms #>> mk_afun_inst; val import_afun_inst = import_afun_inst_raw o terms_of_afun; fun inner_sort_of {T = (tvars, _), ...} = Type.sort_of_atyp (the_single tvars); fun mk_type {T, ...} = instantiate_poly_type T o single; fun mk_pure {pure, ...} = instantiate_poly_term pure o single; fun mk_ap {ap, ...} (T1, T2) = instantiate_poly_term ap [T1, T2]; fun mk_set {set, ...} = instantiate_poly_term set o single; fun lift_term af_inst t = Term.betapply (mk_pure af_inst (Term.fastype_of t), t); fun mk_comb af_inst funT (t1, t2) = Term.betapplys (mk_ap af_inst (dest_funT funT), [t1, t2]); fun dest_type ctxt {T, ...} = the_single o dest_poly_type ctxt T; val dest_type' = the_default HOLogic.unitT ooo dest_type; fun dest_pure ctxt {pure = (_, pure), ...} = the_single o dest_comb_pattern ctxt (pure, 1); fun dest_comb ctxt {ap = (_, ap), ...} = the_pair o dest_comb_pattern ctxt (ap, 2); fun infer_comb ctxt af_inst (t1, t2) = let val funT = the_default (dummyT --> dummyT) (dest_type ctxt af_inst (fastype_of t1)); in mk_comb af_inst funT (t1, t2) end; (*lift a term, except for non-combination subterms mapped by subst*) fun subst_lift_term af_inst subst tm = let fun subst_lift (s $ t) = (case (subst_lift s, subst_lift t) of (NONE, NONE) => NONE | (SOME s', NONE) => SOME (mk_comb af_inst (fastype_of s) (s', lift_term af_inst t)) | (NONE, SOME t') => SOME (mk_comb af_inst (fastype_of s) (lift_term af_inst s, t')) | (SOME s', SOME t') => SOME (mk_comb af_inst (fastype_of s) (s', t'))) | subst_lift t = AList.lookup (op aconv) subst t; in (case subst_lift tm of NONE => lift_term af_inst tm | SOME tm' => tm') end; fun add_lifted_vars (s $ t) = add_lifted_vars s #> add_lifted_vars t | add_lifted_vars (Abs (_, _, t)) = Term.add_vars t | add_lifted_vars _ = I; (*lift terms, where schematic variables are generalized to the functor and then fixed*) fun generalize_lift_terms af_inst ts ctxt = let val vars = subtract (op =) (fold add_lifted_vars ts []) (fold Term.add_vars ts []); val (var_names, Ts) = split_list vars; val (free_names, ctxt') = Variable.variant_fixes (map #1 var_names) ctxt; val Ts' = map (mk_type af_inst) Ts; val subst = map Var vars ~~ map Free (free_names ~~ Ts'); in (map (subst_lift_term af_inst subst) ts, ctxt') end; (** Reasoning with applicative functors **) (* Utilities *) val clean_name = perhaps (perhaps_apply [try Name.dest_skolem, try Name.dest_internal]); (*based on term_name from Pure/term.ML*) fun term_to_vname (Const (x, _)) = Long_Name.base_name x | term_to_vname (Free (x, _)) = clean_name x | term_to_vname (Var ((x, _), _)) = clean_name x | term_to_vname _ = "x"; fun afuns_of_rel precise ctxt t = let val (_, (lhs, rhs)) = Variable.focus NONE t ctxt |> #1 |> #2 |> Logic.strip_imp_concl |> Envir.beta_eta_contract |> HOLogic.dest_Trueprop |> strip_comb2; in if precise then (case afuns_of_term ctxt lhs of [] => afuns_of_term ctxt rhs | afs => afs) else afuns_of_typ ctxt (fastype_of lhs) end; fun AUTO_AFUNS precise tac ctxt opt_af = case opt_af of SOME af => tac [af] | NONE => SUBGOAL (fn (goal, i) => (case afuns_of_rel precise ctxt goal of [] => no_tac | afs => tac afs i) handle TERM _ => no_tac); fun AUTO_AFUN precise tac = AUTO_AFUNS precise (tac o hd); fun binop_par_conv cv ct = let val ((binop, arg1), arg2) = Thm.dest_comb ct |>> Thm.dest_comb; val (th1, th2) = cv (arg1, arg2); in Drule.binop_cong_rule binop th1 th2 end; fun binop_par_conv_tac cv = CONVERSION (HOLogic.Trueprop_conv (binop_par_conv cv)); val fold_goal_tac = SELECT_GOAL oo Raw_Simplifier.fold_goals_tac; (* Unfolding of lifted constants *) fun afun_unfold_tac ctxt af = Raw_Simplifier.rewrite_goal_tac ctxt (unfolds_of_afun af); fun afun_fold_tac ctxt af = fold_goal_tac ctxt (unfolds_of_afun af); fun unfold_all_tac ctxt = Raw_Simplifier.rewrite_goal_tac ctxt (all_unfolds_of ctxt); (* Basic conversions *) fun pure_conv ctxt {pure = (_, pure), ...} cv ct = let val ([var], (tyenv, env)) = match_comb_pattern ctxt (pure, 1) (Thm.term_of ct); val arg = the (Envir.lookup1 env var); val thm = cv (Thm.cterm_of ctxt arg); in if Thm.is_reflexive thm then Conv.all_conv ct else let val pure_inst = Envir.subst_term_types tyenv pure; in Drule.arg_cong_rule (Thm.cterm_of ctxt pure_inst) thm end end; fun ap_conv ctxt {ap = (_, ap), ...} cv1 cv2 ct = let val ([var1, var2], (tyenv, env)) = match_comb_pattern ctxt (ap, 2) (Thm.term_of ct); val (arg1, arg2) = apply2 (the o Envir.lookup1 env) (var1, var2); val thm1 = cv1 (Thm.cterm_of ctxt arg1); val thm2 = cv2 (Thm.cterm_of ctxt arg2); in if Thm.is_reflexive thm1 andalso Thm.is_reflexive thm2 then Conv.all_conv ct else let val ap_inst = Envir.subst_term_types tyenv ap; in Drule.binop_cong_rule (Thm.cterm_of ctxt ap_inst) thm1 thm2 end end; (* Normal form conversion *) (*convert a term into applicative normal form*) fun normalform_conv ctxt af ct = let val {hom, ichng, pure_comp_conv, ...} = thms_of_afun af; val the_red = the o red_of_afun af; val leaf_conv = Conv.rewr_conv (mk_meta_eq (the_red "I") |> Thm.symmetric); val merge_conv = Conv.rewr_conv (mk_meta_eq hom); val swap_conv = Conv.rewr_conv (mk_meta_eq ichng); val rotate_conv = Conv.rewr_conv (mk_meta_eq (the_red "B") |> Thm.symmetric); val pure_rotate_conv = Conv.rewr_conv (mk_meta_eq pure_comp_conv); val af_inst = match_afun_inst ctxt af (Thm.term_of ct, Thm.maxidx_of_cterm ct); fun left_conv cv = ap_conv ctxt af_inst cv Conv.all_conv; fun norm_pure_nf ct = ((pure_rotate_conv then_conv left_conv norm_pure_nf) else_conv merge_conv) ct; val norm_nf_pure = swap_conv then_conv norm_pure_nf; fun norm_nf_nf ct = ((rotate_conv then_conv left_conv (left_conv norm_pure_nf then_conv norm_nf_nf)) else_conv norm_nf_pure) ct; fun normalize ct = ((ap_conv ctxt af_inst normalize normalize then_conv norm_nf_nf) else_conv pure_conv ctxt af_inst Conv.all_conv else_conv leaf_conv) ct; in normalize ct end; val normalize_rel_tac = binop_par_conv_tac o apply2 oo normalform_conv; (* Bracket abstraction and generalized unlifting *) (*TODO: use proper conversions*) datatype apterm = Pure of term (*includes pure application*) | ApVar of int * term (*unique index, instantiated term*) | Ap of apterm * apterm; fun apterm_vars (Pure _) = I | apterm_vars (ApVar v) = cons v | apterm_vars (Ap (t1, t2)) = apterm_vars t1 #> apterm_vars t2; fun occurs_any _ (Pure _) = false | occurs_any vs (ApVar (i, _)) = exists (fn j => i = j) vs | occurs_any vs (Ap (t1, t2)) = occurs_any vs t1 orelse occurs_any vs t2; fun term_of_apterm ctxt af_inst t = let fun tm_of (Pure t) = t | tm_of (ApVar (_, t)) = t | tm_of (Ap (t1, t2)) = infer_comb ctxt af_inst (tm_of t1, tm_of t2); in tm_of t end; fun apterm_of_term ctxt af_inst t = let fun aptm_of t i = case try (dest_comb ctxt af_inst) t of SOME (t1, t2) => i |> aptm_of t1 ||>> aptm_of t2 |>> Ap | NONE => if can (dest_pure ctxt af_inst) t then (Pure t, i) else (ApVar (i, t), i + 1); in aptm_of t end; (*find a common variable sequence for two applicative terms, depending on available combinators*) fun consolidate ctxt af (t1, t2) = let fun common_inst (i, t) (j, insts) = case Termtab.lookup insts t of SOME k => (((i, t), k), (j, insts)) | NONE => (((i, t), j), (j + 1, Termtab.update (t, j) insts)); val (vars, _) = (0, Termtab.empty) |> fold_map common_inst (apterm_vars t1 []) ||>> fold_map common_inst (apterm_vars t2 []); fun merge_adjacent (([], _), _) [] = [] | merge_adjacent ((is, t), d) [] = [((is, t), d)] | merge_adjacent (([], _), _) (((i, t), d)::xs) = merge_adjacent (([i], t), d) xs | merge_adjacent ((is, t), d) (((i', t'), d')::xs) = if d = d' then merge_adjacent ((i'::is, t), d) xs else ((is, t), d) :: merge_adjacent (([i'], t'), d') xs; fun align _ [] = NONE | align ((i, t), d) (((i', t'), d')::xs) = if d = d' then SOME ([((i @ i', t), d)], xs) else Option.map (apfst (cons ((i', t'), d'))) (align ((i, t), d) xs); fun merge ([], ys) = ys | merge (xs, []) = xs | merge ((xs as ((is1, t1), d1)::xs'), ys as (((is2, t2), d2)::ys')) = if d1 = d2 then ((is1 @ is2, t1), d1) :: merge (xs', ys') else case (align ((is2, t2), d2) xs, align ((is1, t1), d1) ys) of (SOME (zs, xs''), NONE) => zs @ merge (xs'', ys') | (NONE, SOME (zs, ys'')) => zs @ merge (xs', ys'') | _ => ((is1, t1), d1) :: ((is2, t2), d2) :: merge (xs', ys'); fun unbalanced vs = error ("Unbalanced opaque terms " ^ commas_quote (map (Syntax.string_of_term ctxt o #2 o #1) vs)); fun mismatch (t1, t2) = error ("Mismatched opaque terms " ^ quote (Syntax.string_of_term ctxt t1) ^ " and " ^ quote (Syntax.string_of_term ctxt t2)); fun same ([], []) = [] | same ([], ys) = unbalanced ys | same (xs, []) = unbalanced xs | same ((((i1, t1), d1)::xs), (((i2, t2), d2)::ys)) = if d1 = d2 then ((i1 @ i2, t1), d1) :: same (xs, ys) else mismatch (t1, t2); in vars |> has_red_afun af "C" ? apply2 (sort (int_ord o apply2 #2)) |> apply2 (if has_red_afun af "W" then merge_adjacent (([], Term.dummy), 0) else map (apfst (apfst single))) |> (if has_red_afun af "K" then merge else same) |> map #1 end; fun ap_cong ctxt af_inst thm1 thm2 = let val funT = the_default (dummyT --> dummyT) (dest_type ctxt af_inst (Thm.typ_of_cterm (Thm.lhs_of thm1))); val ap_inst = Thm.cterm_of ctxt (mk_ap af_inst (dest_funT funT)); in Drule.binop_cong_rule ap_inst thm1 thm2 end; fun rewr_subst_ap ctxt af_inst rewr thm1 thm2 = let val rule1 = ap_cong ctxt af_inst thm1 thm2; val rule2 = Conv.rewr_conv rewr (Thm.rhs_of rule1); in Thm.transitive rule1 rule2 end; fun merge_pures ctxt af_inst merge_thm tt = let fun merge (Pure t) = SOME (Thm.reflexive (Thm.cterm_of ctxt t)) | merge (ApVar _) = NONE | merge (Ap (tt1, tt2)) = case merge tt1 of NONE => NONE | SOME thm1 => case merge tt2 of NONE => NONE | SOME thm2 => SOME (rewr_subst_ap ctxt af_inst merge_thm thm1 thm2); in merge tt end; exception ASSERT of string; (*abstract over a variable (opaque subterm)*) fun eliminate ctxt (af, af_inst) tt (v, v_tm) = let val {hom, ichng, ...} = thms_of_afun af; val the_red = the o red_of_afun af; val hom_conv = mk_meta_eq hom; val ichng_conv = mk_meta_eq ichng; val mk_combI = Thm.symmetric o mk_meta_eq; val id_conv = mk_combI (the_red "I"); val comp_conv = mk_combI (the_red "B"); val flip_conv = Option.map mk_combI (red_of_afun af "C"); val const_conv = Option.map mk_combI (red_of_afun af "K"); val dup_conv = Option.map mk_combI (red_of_afun af "W"); val rewr_subst_ap = rewr_subst_ap ctxt af_inst; fun extract_comb n thm = Pure (thm |> Thm.rhs_of |> funpow n Thm.dest_arg1 |> Thm.term_of); fun refl_step tt = (tt, Thm.reflexive (Thm.cterm_of ctxt (term_of_apterm ctxt af_inst tt))); fun comb2_step def (tt1, thm1) (tt2, thm2) = let val thm = rewr_subst_ap def thm1 thm2; in (Ap (Ap (extract_comb 3 thm, tt1), tt2), thm) end; val B_step = comb2_step comp_conv; fun swap_B_step (tt1, thm1) thm2 = let val thm3 = rewr_subst_ap ichng_conv thm1 thm2; val thm4 = Thm.transitive thm3 (Conv.rewr_conv comp_conv (Thm.rhs_of thm3)); in (Ap (Ap (extract_comb 3 thm4, extract_comb 1 thm3), tt1), thm4) end; fun I_step tm = let val thm = Conv.rewr_conv id_conv (Thm.cterm_of ctxt tm) in (extract_comb 1 thm, thm) end; fun W_step s1 s2 = let val (Ap (Ap (tt1, tt2), tt3), thm1) = B_step s1 s2; val thm2 = Conv.rewr_conv comp_conv (Thm.rhs_of thm1 |> funpow 2 Thm.dest_arg1); val thm3 = merge_pures ctxt af_inst hom_conv tt3 |> the; val (tt4, thm4) = swap_B_step (Ap (Ap (extract_comb 3 thm2, tt1), tt2), thm2) thm3; val var = Thm.rhs_of thm1 |> Thm.dest_arg; val thm5 = rewr_subst_ap (the dup_conv) thm4 (Thm.reflexive var); val thm6 = Thm.transitive thm1 thm5; in (Ap (extract_comb 2 thm6, tt4), thm6) end; fun S_step s1 s2 = let val (Ap (Ap (tt1, tt2), tt3), thm1) = comb2_step (the flip_conv) s1 s2; val thm2 = Conv.rewr_conv comp_conv (Thm.rhs_of thm1 |> Thm.dest_arg1); val var = Thm.rhs_of thm1 |> Thm.dest_arg; val thm3 = rewr_subst_ap (the dup_conv) thm2 (Thm.reflexive var); val thm4 = Thm.transitive thm1 thm3; val tt = Ap (extract_comb 2 thm4, Ap (Ap (extract_comb 3 thm2, Ap (tt1, tt2)), tt3)); in (tt, thm4) end; fun K_step tt tm = let val ct = Thm.cterm_of ctxt tm; val T_opt = Term.fastype_of tm |> dest_type ctxt af_inst |> Option.map (Thm.ctyp_of ctxt); val thm = Thm.instantiate' [T_opt] [SOME ct] (Conv.rewr_conv (the const_conv) (term_of_apterm ctxt af_inst tt |> Thm.cterm_of ctxt)) in (Ap (extract_comb 2 thm, tt), thm) end; fun unreachable _ = raise ASSERT "eliminate: assertion failed"; fun elim (Pure _) = unreachable () | elim (ApVar (i, t)) = if exists (fn x => x = i) v then I_step t else unreachable () | elim (Ap (t1, t2)) = (case (occurs_any v t1, occurs_any v t2) of (false, false) => unreachable () | (false, true) => B_step (refl_step t1) (elim t2) | (true, false) => (case merge_pures ctxt af_inst hom_conv t2 of SOME thm => swap_B_step (elim t1) thm | NONE => comb2_step (the flip_conv) (elim t1) (refl_step t2)) | (true, true) => if is_some flip_conv then S_step (elim t1) (elim t2) else W_step (elim t1) (elim t2)); in if occurs_any v tt then elim tt else K_step tt v_tm end; (*convert a pair of terms into equal canonical forms, modulo pure terms*) fun general_normalform_conv ctxt af cts = let val (t1, t2) = apply2 (Thm.term_of) cts; val maxidx = Int.max (apply2 Thm.maxidx_of_cterm cts); (* TODO: is there a better strategy for finding the instantiated functor? *) val af_inst = match_afun_inst ctxt af (t1, maxidx); val ((apt1, apt2), _) = 0 |> apterm_of_term ctxt af_inst t1 ||>> apterm_of_term ctxt af_inst t2; val vs = consolidate ctxt af (apt1, apt2); val merge_thm = mk_meta_eq (#hom (thms_of_afun af)); fun elim_all tt [] = the (merge_pures ctxt af_inst merge_thm tt) | elim_all tt (v::vs) = let val (tt', rule1) = eliminate ctxt (af, af_inst) tt v; val rule2 = elim_all tt' vs; val (_, vartm) = dest_comb ctxt af_inst (Thm.term_of (Thm.rhs_of rule1)); val rule3 = ap_cong ctxt af_inst rule2 (Thm.reflexive (Thm.cterm_of ctxt vartm)); in Thm.transitive rule1 rule3 end; in (elim_all apt1 vs, elim_all apt2 vs) end; val general_normalize_rel_tac = binop_par_conv_tac oo general_normalform_conv; (* Reduce canonical forms to base relation *) fun rename_params names i st = let val (_, Bs, Bi, C) = Thm.dest_state (st, i); val Bi' = Logic.list_rename_params names Bi; in Thm.renamed_prop (Logic.list_implies (Bs @ [Bi'], C)) st end; (* R' (pure f <> x1 <> ... <> xn) (pure g <> x1 <> ... <> xn) ===> !!y1 ... yn. [| yi : setF xi ... |] ==> R (f y1 ... yn) (g y1 ... yn), where either both R and R' are equality, or R' = relF R for relator relF of the functor. The premises yi : setF xi are added only in the latter case and if the set operator is available. Succeeds if partial progress can be made. The names of the new parameters yi are derived from the arguments xi. *) fun head_cong_tac ctxt af renames = let val {rel_intros, ...} = thms_of_afun af; fun term_name tm = case AList.lookup (op aconv) renames tm of SOME n => n | NONE => term_to_vname tm; fun gather_vars' af_inst tm = case try (dest_comb ctxt af_inst) tm of SOME (t1, t2) => term_name t2 :: gather_vars' af_inst t1 | NONE => []; fun gather_vars prop = case prop of Const (@{const_name Trueprop}, _) $ (_ $ rhs) => rev (gather_vars' (match_afun_inst ctxt af (rhs, maxidx_of_term prop)) rhs) | _ => []; in SUBGOAL (fn (subgoal, i) => (REPEAT_DETERM (resolve_tac ctxt rel_intros i) THEN REPEAT_DETERM (resolve_tac ctxt [ext, @{thm rel_fun_eq_onI}] i ORELSE eresolve_tac ctxt [@{thm UNIV_E}] i) THEN PRIMITIVE (rename_params (gather_vars subgoal) i))) end; (* Forward lifting *) (* TODO: add limited support for premises, where used variables are not generalized in the conclusion *) fun forward_lift_rule ctxt af thm = let val thm = Object_Logic.rulify ctxt thm; val (af_inst, ctxt_inst) = import_afun_inst af ctxt; val (prop, ctxt_Ts) = yield_singleton Variable.importT_terms (Thm.prop_of thm) ctxt_inst; val (lhs, rhs) = prop |> HOLogic.dest_Trueprop |> HOLogic.dest_eq; val ([lhs', rhs'], ctxt_lifted) = generalize_lift_terms af_inst [lhs, rhs] ctxt_Ts; val lifted = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs', rhs')); val (lifted', ctxt') = yield_singleton (Variable.import_terms true) lifted ctxt_lifted; fun tac {prems, context} = HEADGOAL (general_normalize_rel_tac context af THEN' head_cong_tac context af [] THEN' resolve_tac context [prems MRS thm]); val thm' = singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] lifted' tac); val thm'' = Raw_Simplifier.fold_rule ctxt (unfolds_of_afun af) thm'; in thm'' end; fun forward_lift_attrib name = Thm.rule_attribute [] (fn context => fn thm => let val af = afun_of_generic context (intern context name) (* FIXME !?!? *) in forward_lift_rule (Context.proof_of context) af thm end); (* High-level tactics *) fun unfold_wrapper_tac ctxt = AUTO_AFUNS false (fn afs => Simplifier.safe_asm_full_simp_tac (ctxt addsimps flat (map unfolds_of_afun afs))) ctxt; fun fold_wrapper_tac ctxt = AUTO_AFUN true (fold_goal_tac ctxt o unfolds_of_afun) ctxt; fun WRAPPER tac ctxt opt_af = REPEAT_DETERM o resolve_tac ctxt [@{thm allI}] THEN' Subgoal.FOCUS (fn {context = ctxt, params, ...} => let val renames = map (swap o apsnd Thm.term_of) params in AUTO_AFUNS false (EVERY' o map (afun_unfold_tac ctxt)) ctxt opt_af 1 THEN AUTO_AFUN true (fn af => afun_unfold_tac ctxt af THEN' CONVERSION Drule.beta_eta_conversion THEN' tac ctxt af THEN' head_cong_tac ctxt af renames) ctxt opt_af 1 end) ctxt THEN' Raw_Simplifier.rewrite_goal_tac ctxt [Drule.triv_forall_equality]; val normalize_wrapper_tac = WRAPPER normalize_rel_tac; val lifting_wrapper_tac = WRAPPER general_normalize_rel_tac; val parse_opt_afun = Scan.peek (fn context => Scan.option Parse.name >> Option.map (intern context #> afun_of_generic context)); (** Declaration **) (* Combinator setup *) fun declare_combinators combs phi = let val (names, thms) = split_list combs; val thms' = map (Morphism.thm phi) thms; fun add_combs (defs, rules) = (fold (Symtab.insert (K false)) (names ~~ thms') defs, rules); in Data.map (map_data add_combs I I) end; val setup_combinators = - Local_Theory.declaration {syntax = false, pervasive = false} o declare_combinators; + Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} o declare_combinators; fun combinator_of_red thm = let val (lhs, _) = Logic.dest_equals (Thm.prop_of thm); val (head, _) = strip_comb lhs; in #1 (dest_Const head) end; fun register_combinator_rule weak_premises thm context = let val (lhs, rhs) = Logic.dest_equals (Thm.prop_of thm); val ltvars = Term.add_tvars lhs []; val rtvars = Term.add_tvars rhs []; val _ = if exists (not o member op = ltvars) rtvars then Pretty.breaks [Pretty.str "Combinator equation", Pretty.quote (Syntax.pretty_term (Context.proof_of context) (Thm.prop_of thm)), Pretty.str "has additional type variables on right-hand side."] |> Pretty.block |> Pretty.string_of |> error else (); val (defs, _) = #combinators (Data.get context); val comb_names = Symtab.make (map (fn (name, thm) => (combinator_of_red thm, name)) (Symtab.dest defs)); val rule = mk_combinator_rule comb_names weak_premises thm; fun add_rule (defs, rules) = (defs, insert eq_combinator_rule rule rules); in Data.map (map_data add_rule I I) context end; val combinator_rule_attrib = Thm.declaration_attribute o register_combinator_rule; (* Derivation of combinator reductions *) fun combinator_closure rules have_weak combs = let fun apply rule (cs, changed) = if not (Ord_List.member fast_string_ord cs (conclusion_of_rule rule)) andalso is_applicable_rule rule have_weak (fn prems => Ord_List.subset fast_string_ord (prems, cs)) then (Ord_List.insert fast_string_ord (conclusion_of_rule rule) cs, true) else (cs, changed); fun loop cs = (case fold apply rules (cs, false) of (cs', true) => loop cs' | (_, false) => cs); in loop combs end; fun derive_combinator_red ctxt af_inst red_thms (base_thm, eq_thm) = let val base_prop = Thm.prop_of base_thm; val tvars = Term.add_tvars base_prop []; val (Ts, ctxt_Ts) = mk_TFrees_of (length tvars) (inner_sort_of af_inst) ctxt; val base_prop' = base_prop |> Term_Subst.instantiate (TVars.make (tvars ~~ Ts), Vars.empty); val (lhs, rhs) = Logic.dest_equals base_prop'; val ([lhs', rhs'], ctxt') = generalize_lift_terms af_inst [lhs, rhs] ctxt_Ts; val lifted_prop = (lhs', rhs') |> HOLogic.mk_eq |> HOLogic.mk_Trueprop; val unfold_comb_conv = HOLogic.Trueprop_conv (HOLogic.eq_conv (Conv.top_sweep_rewrs_conv [eq_thm] ctxt') Conv.all_conv); fun tac goal_ctxt = HEADGOAL (CONVERSION unfold_comb_conv THEN' Raw_Simplifier.rewrite_goal_tac goal_ctxt red_thms THEN' resolve_tac goal_ctxt [@{thm refl}]); in singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] lifted_prop (tac o #context)) end; (*derive all instantiations with pure terms which can be simplified by homomorphism*) (*FIXME: more of a workaround than a sensible solution*) fun weak_red_closure ctxt (af_inst, merge_thm) strong_red = let val (lhs, _) = Thm.prop_of strong_red |> Logic.dest_equals; val vars = rev (Term.add_vars lhs []); fun closure [] prev thms = (prev::thms) | closure ((v, af_T)::vs) prev thms = (case try (dest_type ctxt af_inst) af_T of NONE => closure vs prev thms | SOME T_opt => let val (T, ctxt') = (case T_opt of NONE => yield_singleton Variable.invent_types (inner_sort_of af_inst) ctxt |>> TFree | SOME T => (T, ctxt)); val (v', ctxt'') = mk_Free (#1 v) T ctxt'; val pure_v = Thm.cterm_of ctxt'' (lift_term af_inst v'); val next = Drule.instantiate_normalize (TVars.empty, Vars.make [((v, af_T), pure_v)]) prev; val next' = Raw_Simplifier.rewrite_rule ctxt'' [merge_thm] next; val next'' = singleton (Variable.export ctxt'' ctxt) next'; in closure vs next'' (prev::thms) end); in closure vars strong_red [] end; fun combinator_red_closure ctxt (comb_defs, rules) (af_inst, merge_thm) weak_reds combs = let val have_weak = not (null weak_reds); val red_thms0 = Symtab.fold (fn (_, thm) => cons (mk_meta_eq thm)) combs weak_reds; val red_thms = flat (map (weak_red_closure ctxt (af_inst, merge_thm)) red_thms0); fun apply rule ((cs, rs), changed) = if not (Symtab.defined cs (conclusion_of_rule rule)) andalso is_applicable_rule rule have_weak (forall (Symtab.defined cs)) then let val conclusion = conclusion_of_rule rule; val def = the (Symtab.lookup comb_defs conclusion); val new_red_thm = derive_combinator_red ctxt af_inst rs (def, thm_of_rule rule); val new_red_thms = weak_red_closure ctxt (af_inst, merge_thm) (mk_meta_eq new_red_thm); in ((Symtab.update (conclusion, new_red_thm) cs, new_red_thms @ rs), true) end else ((cs, rs), changed); fun loop xs = (case fold apply rules (xs, false) of (xs', true) => loop xs' | (_, false) => xs); in #1 (loop (combs, red_thms)) end; (* Preparation of AFun data *) fun mk_terms ctxt (raw_pure, raw_ap, raw_rel, raw_set) = let val thy = Proof_Context.theory_of ctxt; val show_typ = quote o Syntax.string_of_typ ctxt; val show_term = quote o Syntax.string_of_term ctxt; fun closed_poly_term t = let val poly_t = singleton (Variable.polymorphic ctxt) t; in case Term.add_vars (singleton (Variable.export_terms (Proof_Context.augment t ctxt) ctxt) t) [] of [] => (case (Term.hidden_polymorphism poly_t) of [] => poly_t | _ => error ("Hidden type variables in term " ^ show_term t)) | _ => error ("Locally free variables in term " ^ show_term t) end; val pure = closed_poly_term raw_pure; val (tvar, T1) = fastype_of pure |> dest_funT |>> dest_TVar handle TYPE _ => error ("Bad type for pure: " ^ show_typ (fastype_of pure)); val maxidx_pure = maxidx_of_term pure; val ap = Logic.incr_indexes ([], [], maxidx_pure + 1) (closed_poly_term raw_ap); fun bad_ap _ = error ("Bad type for ap: " ^ show_typ (fastype_of ap)); val (T23, (T2, T3)) = fastype_of ap |> dest_funT ||> dest_funT handle TYPE _ => bad_ap (); val maxidx_common = Term.maxidx_term ap maxidx_pure; (*unify type variables, while keeping the live variables separate*) fun no_unifier (T, U) = error ("Unable to infer common functor type from " ^ commas (map show_typ [T, U])); fun unify_ap_type T (tyenv, maxidx) = let val argT = TVar ((Name.aT, maxidx + 1), []); val T1' = Term_Subst.instantiateT (TVars.make [(tvar, argT)]) T1; val (tyenv', maxidx') = Sign.typ_unify thy (T1', T) (tyenv, maxidx + 1) handle Type.TUNIFY => no_unifier (T1', T); in (argT, (tyenv', maxidx')) end; val (ap_args, (ap_env, maxidx_env)) = fold_map unify_ap_type [T2, T3, T23] (Vartab.empty, maxidx_common); val [T2_arg, T3_arg, T23_arg] = map (Envir.norm_type ap_env) ap_args; val (tvar2, tvar3) = (dest_TVar T2_arg, dest_TVar T3_arg) handle TYPE _ => bad_ap (); val _ = if T23_arg = T2_arg --> T3_arg then () else bad_ap (); val sort = foldl1 (Sign.inter_sort thy) (map #2 [tvar, tvar2, tvar3]); val _ = Sign.of_sort thy (Term.aT sort --> Term.aT sort, sort) orelse error ("Sort constraint " ^ quote (Syntax.string_of_sort ctxt sort) ^ " not closed under function types"); fun update_sort (v, S) (tyenv, maxidx) = (Vartab.update_new (v, (S, TVar ((Name.aT, maxidx + 1), sort))) tyenv, maxidx + 1); val (common_env, _) = fold update_sort [tvar, tvar2, tvar3] (ap_env, maxidx_env); val tvar' = Envir.norm_type common_env (TVar tvar); val pure' = norm_term_types common_env pure; val (tvar2', tvar3') = apply2 (Envir.norm_type common_env) (T2_arg, T3_arg); val ap' = norm_term_types common_env ap; fun bad_set set = error ("Bad type for set: " ^ show_typ (fastype_of set)); fun mk_set set = let val tyenv = Sign.typ_match thy (domain_type (fastype_of set), range_type (fastype_of pure')) Vartab.empty handle Type.TYPE_MATCH => bad_set set; val set' = Envir.subst_term_types tyenv set; val set_tvar = fastype_of set' |> range_type |> HOLogic.dest_setT |> dest_TVar handle TYPE _ => bad_set set; val _ = if Term.eq_tvar (dest_TVar tvar', set_tvar) then () else bad_set set; in ([tvar'], set') end val set = (case raw_set of NONE => ([tvar'], Abs ("x", tvar', HOLogic.mk_UNIV tvar')) | SOME t => mk_set (closed_poly_term t)); val terms = Term_Subst.zero_var_indexes (pack_poly_terms [poly_type_to_term ([tvar'], range_type (fastype_of pure')), ([tvar'], pure'), ([tvar2', tvar3'], ap'), set]); (*TODO: also infer the relator type?*) fun bad_rel rel = error ("Bad type for rel: " ^ show_typ (fastype_of rel)); fun mk_rel rel = let val ((T1, T2), (T1_af, T2_af)) = fastype_of rel |> dest_funT |>> BNF_Util.dest_pred2T ||> BNF_Util.dest_pred2T; val _ = (dest_TVar T1; dest_TVar T2); val _ = if T1 = T2 then bad_rel rel else (); val af_inst = mk_afun_inst (match_poly_terms_type ctxt (terms, 0) (T1_af, maxidx_of_term rel)); val (T1', T2') = apply2 (dest_type ctxt af_inst) (T1_af, T2_af); val _ = if (is_none T1' andalso is_none T2') orelse (T1' = SOME T1 andalso T2' = SOME T2) then () else bad_rel rel; in Term_Subst.zero_var_indexes (pack_poly_terms [([T1, T2], rel)]) end handle TYPE _ => bad_rel rel; val rel = Option.map (mk_rel o closed_poly_term) raw_rel; in (terms, rel) end; fun mk_rel_intros {pure_transfer, ap_rel_fun} = let val pure_rel_intro = pure_transfer RS @{thm rel_funD}; in [pure_rel_intro, ap_rel_fun] end; fun mk_afun_thms ctxt af_inst (hom_thm, ichng_thm, reds, rel_axioms) = let val pure_comp_conv = let val ([T1, T2, T3], ctxt_Ts) = mk_TFrees_of 3 (inner_sort_of af_inst) ctxt; val (((g, f), x), ctxt') = ctxt_Ts |> mk_Free "g" (T2 --> T3) ||>> mk_Free "f" (mk_type af_inst (T1 --> T2)) ||>> mk_Free "x" (mk_type af_inst T1); val comb = mk_comb af_inst; val lhs = comb (T2 --> T3) (lift_term af_inst g, comb (T1 --> T2) (f, x)); val B_g = Abs ("f", T1 --> T2, Abs ("x", T1, Term.betapply (g, Bound 1 $ Bound 0))); val rhs = comb (T1 --> T3) (comb ((T1 --> T2) --> T1 --> T3) (lift_term af_inst B_g, f), x); val prop = HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop; val merge_rule = mk_meta_eq hom_thm; val B_intro = the (Symtab.lookup reds "B") |> mk_meta_eq |> Thm.symmetric; fun tac goal_ctxt = HEADGOAL (Raw_Simplifier.rewrite_goal_tac goal_ctxt [B_intro, merge_rule] THEN' resolve_tac goal_ctxt [@{thm refl}]); in singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] prop (tac o #context)) end; val eq_intros = let val ([T1, T2], ctxt_Ts) = mk_TFrees_of 2 (inner_sort_of af_inst) ctxt; val T12 = mk_type af_inst (T1 --> T2); val (((((x, y), x'), f), g), ctxt') = ctxt_Ts |> mk_Free "x" T1 ||>> mk_Free "y" T1 ||>> mk_Free "x" (mk_type af_inst T1) ||>> mk_Free "f" T12 ||>> mk_Free "g" T12; val pure_fun = mk_pure af_inst T1; val pure_cong = Drule.infer_instantiate' ctxt' (map (SOME o Thm.cterm_of ctxt') [x, y, pure_fun]) @{thm arg_cong}; val ap_fun = mk_ap af_inst (T1, T2); val ap_cong1 = Drule.infer_instantiate' ctxt' (map (SOME o Thm.cterm_of ctxt') [f, g, ap_fun, x']) @{thm arg1_cong}; in Variable.export ctxt' ctxt [pure_cong, ap_cong1] end; val rel_intros = case rel_axioms of NONE => [] | SOME axioms => mk_rel_intros axioms; in {hom = hom_thm, ichng = ichng_thm, reds = reds, rel_thms = rel_axioms, rel_intros = eq_intros @ rel_intros, pure_comp_conv = pure_comp_conv} end; fun reuse_TFrees n S (ctxt, Ts) = let val have_n = Int.min (n, length Ts); val (more_Ts, ctxt') = mk_TFrees_of (n - have_n) S ctxt; in (take have_n Ts @ more_Ts, (ctxt', Ts @ more_Ts)) end; fun mk_comb_prop lift_pos thm af_inst ctxt_Ts = let val base = Thm.prop_of thm; val tvars = Term.add_tvars base []; val (Ts, (ctxt', Ts')) = reuse_TFrees (length tvars) (inner_sort_of af_inst) ctxt_Ts; val base' = base |> Term_Subst.instantiate (TVars.make (tvars ~~ Ts), Vars.empty); val (lhs, rhs) = Logic.dest_equals base'; val (_, lhs_args) = strip_comb lhs; val lift_var = Var o apsnd (mk_type af_inst) o dest_Var; val (lhs_args', subst) = fold_index (fn (i, v) => if member (op =) lift_pos i then apfst (cons v) else map_prod (cons (lift_var v)) (cons (v, lift_var v))) lhs_args ([], []); val (lhs', rhs') = apply2 (subst_lift_term af_inst subst) (lhs, rhs); val lifted = (lhs', rhs') |> HOLogic.mk_eq |> HOLogic.mk_Trueprop; in (fold Logic.all lhs_args' lifted, (ctxt', Ts')) end; fun mk_homomorphism_prop af_inst ctxt_Ts = let val ([T1, T2], (ctxt', Ts')) = reuse_TFrees 2 (inner_sort_of af_inst) ctxt_Ts; val ((f, x), _) = ctxt' |> mk_Free "f" (T1 --> T2) ||>> mk_Free "x" T1; val lhs = mk_comb af_inst (T1 --> T2) (lift_term af_inst f, lift_term af_inst x); val rhs = lift_term af_inst (f $ x); val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)); in (Logic.all f (Logic.all x prop), (ctxt', Ts')) end; fun mk_interchange_prop af_inst ctxt_Ts = let val ([T1, T2], (ctxt', Ts')) = reuse_TFrees 2 (inner_sort_of af_inst) ctxt_Ts; val ((f, x), _) = ctxt' |> mk_Free "f" (mk_type af_inst (T1 --> T2)) ||>> mk_Free "x" T1; val lhs = mk_comb af_inst (T1 --> T2) (f, lift_term af_inst x); val T_x = Abs ("f", T1 --> T2, Bound 0 $ x); val rhs = mk_comb af_inst ((T1 --> T2) --> T2) (lift_term af_inst T_x, f); val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)); in (Logic.all f (Logic.all x prop), (ctxt', Ts')) end; fun mk_rel_props (af_inst, rel_inst) ctxt_Ts = let fun mk_af_rel tm = let val (T1, T2) = BNF_Util.dest_pred2T (fastype_of tm); in betapply (instantiate_poly_term rel_inst [T1, T2], tm) end; val ([T1, T2, T3], (ctxt', Ts')) = reuse_TFrees 3 (inner_sort_of af_inst) ctxt_Ts; val (pure_R, _) = mk_Free "R" (T1 --> T2 --> @{typ bool}) ctxt'; val rel_pure = BNF_Util.mk_rel_fun pure_R (mk_af_rel pure_R) $ mk_pure af_inst T1 $ mk_pure af_inst T2; val pure_prop = Logic.all pure_R (HOLogic.mk_Trueprop rel_pure); val ((((f, g), x), ap_R), _) = ctxt' |> mk_Free "f" (mk_type af_inst (T1 --> T2)) ||>> mk_Free "g" (mk_type af_inst (T1 --> T3)) ||>> mk_Free "x" (mk_type af_inst T1) ||>> mk_Free "R" (T2 --> T3 --> @{typ bool}); val fun_rel = BNF_Util.mk_rel_fun (mk_eq_on (mk_set af_inst T1 $ x)) ap_R; val rel_ap = Logic.mk_implies (HOLogic.mk_Trueprop (mk_af_rel fun_rel $ f $ g), HOLogic.mk_Trueprop (mk_af_rel ap_R $ mk_comb af_inst (T1 --> T2) (f, x) $ mk_comb af_inst (T1 --> T3) (g, x))); val ap_prop = fold_rev Logic.all [ap_R, f, g, x] rel_ap; in ([pure_prop, ap_prop], (ctxt', Ts')) end; fun mk_interchange ctxt ((comb_defs, _), comb_unfolds) (af_inst, merge_thm) reds = let val T_def = the (Symtab.lookup comb_defs "T"); val T_red = the (Symtab.lookup reds "T"); val (weak_prop, (ctxt', _)) = mk_comb_prop [0] T_def af_inst (ctxt, []); fun tac goal_ctxt = HEADGOAL (Raw_Simplifier.rewrite_goal_tac goal_ctxt [Thm.symmetric merge_thm] THEN' resolve_tac goal_ctxt [T_red]); val weak_red = singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] weak_prop (tac o #context)); in Raw_Simplifier.rewrite_rule ctxt (comb_unfolds) weak_red RS sym end; fun mk_weak_reds ctxt ((comb_defs, _), comb_unfolds) af_inst (hom_thm, ichng_thm, reds) = let val unfolded_reds = Symtab.map (K (Raw_Simplifier.rewrite_rule ctxt comb_unfolds)) reds; val af_thms = mk_afun_thms ctxt af_inst (hom_thm, ichng_thm, unfolded_reds, NONE); val af = mk_afun Binding.empty (pack_afun_inst af_inst) NONE af_thms; fun tac goal_ctxt = HEADGOAL (normalize_wrapper_tac goal_ctxt (SOME af) THEN' Raw_Simplifier.rewrite_goal_tac goal_ctxt comb_unfolds THEN' resolve_tac goal_ctxt [refl]); fun mk comb lift_pos = let val def = the (Symtab.lookup comb_defs comb); val (prop, (ctxt', _)) = mk_comb_prop lift_pos def af_inst (ctxt, []); val hol_thm = singleton (Variable.export ctxt' ctxt) (Goal.prove ctxt' [] [] prop (tac o #context)); in mk_meta_eq hol_thm end; val uncurry_thm = mk_meta_eq (forward_lift_rule ctxt af @{thm uncurry_pair}); in [mk "C" [1], mk "C" [2], uncurry_thm] end; fun mk_comb_reds ctxt combss af_inst user_combs (hom_thm, user_thms, ichng_thms) = let val ((comb_defs, comb_rules), comb_unfolds) = combss; val merge_thm = mk_meta_eq hom_thm; val user_reds = Symtab.make (user_combs ~~ user_thms); val reds0 = combinator_red_closure ctxt (comb_defs, comb_rules) (af_inst, merge_thm) [] user_reds; val ichng_thm = case ichng_thms of [] => singleton (Variable.export ctxt ctxt) (mk_interchange ctxt combss (af_inst, merge_thm) reds0) | [thm] => thm; val weak_reds = mk_weak_reds ctxt combss af_inst (hom_thm, ichng_thm, reds0); val reds1 = combinator_red_closure ctxt (comb_defs, comb_rules) (af_inst, merge_thm) weak_reds reds0; val unfold = Raw_Simplifier.rewrite_rule ctxt comb_unfolds; in (Symtab.map (K unfold) reds1, ichng_thm) end; fun note_afun_thms af = let val thms = thms_of_afun af; val named_thms = [("homomorphism", [#hom thms]), ("interchange", [#ichng thms]), ("afun_rel_intros", #rel_intros thms)] @ map (fn (name, thm) => ("pure_" ^ name ^ "_conv", [thm])) (Symtab.dest (#reds thms)) @ (case #rel_thms thms of NONE => [] | SOME rel_thms' => [("pure_transfer", [#pure_transfer rel_thms']), ("ap_rel_fun_cong", [#ap_rel_fun rel_thms'])]); val base_name = Binding.name_of (name_of_afun af); fun mk_note (name, thms) = ((Binding.qualify true base_name (Binding.name name), []), [(thms, [])]); in Local_Theory.notes (map mk_note named_thms) #> #2 end; fun register_afun af = let fun decl phi context = Data.map (fn {combinators, afuns, patterns} => let val af' = morph_afun phi af; val (name, afuns') = Name_Space.define context true (name_of_afun af', af') afuns; val patterns' = Item_Net.update (name, patterns_of_afun af') patterns; in {combinators = combinators, afuns = afuns', patterns = patterns'} end) context; - in Local_Theory.declaration {syntax = false, pervasive = false} decl end; + in Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} decl end; fun applicative_cmd (((((name, flags), raw_pure), raw_ap), raw_rel), raw_set) lthy = let val comb_unfolds = Named_Theorems.get lthy @{named_theorems combinator_unfold}; val comb_reprs = Named_Theorems.get lthy @{named_theorems combinator_repr}; val (comb_defs, comb_rules) = get_combinators (Context.Proof lthy); val _ = fold (fn name => if Symtab.defined comb_defs name then I else error ("Unknown combinator " ^ quote name)) flags (); val _ = if has_duplicates op = flags then warning "Ignoring duplicate combinators" else (); val user_combs0 = Ord_List.make fast_string_ord flags; val raw_pure' = Syntax.read_term lthy raw_pure; val raw_ap' = Syntax.read_term lthy raw_ap; val raw_rel' = Option.map (Syntax.read_term lthy) raw_rel; val raw_set' = Option.map (Syntax.read_term lthy) raw_set; val (terms, rel) = mk_terms lthy (raw_pure', raw_ap', raw_rel', raw_set'); val derived_combs0 = combinator_closure comb_rules false user_combs0; val required_combs = Ord_List.make fast_string_ord ["B", "I"]; val user_combs = Ord_List.union fast_string_ord user_combs0 (Ord_List.subtract fast_string_ord derived_combs0 required_combs); val derived_combs1 = combinator_closure comb_rules false user_combs; val derived_combs2 = combinator_closure comb_rules true derived_combs1; fun is_redundant comb = eq_list (op =) (derived_combs2, (combinator_closure comb_rules true (Ord_List.remove fast_string_ord comb user_combs))); val redundant_combs = filter is_redundant user_combs; val _ = if null redundant_combs then () else warning ("Redundant combinators: " ^ commas redundant_combs); val prove_interchange = not (Ord_List.member fast_string_ord derived_combs1 "T"); val (af_inst, ctxt_af) = import_afun_inst_raw terms lthy; (* TODO: reuse TFrees from above *) val (rel_insts, ctxt_inst) = (case rel of NONE => (NONE, ctxt_af) | SOME r => let val (rel_inst, ctxt') = import_poly_terms r ctxt_af |>> the_single; val T = fastype_of (#2 rel_inst) |> range_type |> domain_type; val af_inst = match_poly_terms_type ctxt' (terms, 0) (T, ~1) |> mk_afun_inst; in (SOME (af_inst, rel_inst), ctxt') end); val mk_propss = [apfst single o mk_homomorphism_prop af_inst, fold_map (fn comb => mk_comb_prop [] (the (Symtab.lookup comb_defs comb)) af_inst) user_combs, if prove_interchange then apfst single o mk_interchange_prop af_inst else pair [], if is_some rel then mk_rel_props (the rel_insts) else pair []]; val (propss, (ctxt_Ts, _)) = fold_map I mk_propss (ctxt_inst, []); fun repr_tac ctxt = Raw_Simplifier.rewrite_goals_tac ctxt comb_reprs; fun after_qed thmss lthy' = let val [[hom_thm], user_thms, ichng_thms, rel_thms] = map (Variable.export lthy' ctxt_inst) thmss; val (reds, ichng_thm) = mk_comb_reds ctxt_inst ((comb_defs, comb_rules), comb_unfolds) af_inst user_combs (hom_thm, user_thms, ichng_thms); val rel_axioms = case rel_thms of [] => NONE | [thm1, thm2] => SOME {pure_transfer = thm1, ap_rel_fun = thm2}; val af_thms = mk_afun_thms ctxt_inst af_inst (hom_thm, ichng_thm, reds, rel_axioms); val af_thms = map_afun_thms (singleton (Variable.export ctxt_inst lthy)) af_thms; val af = mk_afun name terms rel af_thms; in lthy |> register_afun af |> note_afun_thms af end; in Proof.theorem NONE after_qed ((map o map) (rpair []) propss) ctxt_Ts |> Proof.refine (Method.Basic (SIMPLE_METHOD o repr_tac)) |> Seq.the_result "" end; fun print_afuns ctxt = let fun pretty_afun (name, af) = let val [pT, (_, pure), (_, ap), (_, set)] = unpack_poly_terms (terms_of_afun af); val ([tvar], T) = poly_type_of_term pT; val rel = Option.map (#2 o the_single o unpack_poly_terms) (rel_of_afun af); val combinators = Symtab.keys (#reds (thms_of_afun af)); in Pretty.block (Pretty.fbreaks ([Pretty.block [Pretty.str name, Pretty.str ":", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt T), Pretty.brk 1, Pretty.str "of", Pretty.brk 1, Syntax.pretty_typ ctxt tvar], Pretty.block [Pretty.str "pure:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt pure)], Pretty.block [Pretty.str "ap:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt ap)], Pretty.block [Pretty.str "set:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt set)]] @ (case rel of NONE => [] | SOME rel' => [Pretty.block [Pretty.str "rel:", Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt rel')]]) @ [Pretty.block ([Pretty.str "combinators:", Pretty.brk 1] @ Pretty.commas (map Pretty.str combinators))])) end; val afuns = sort_by #1 (Name_Space.fold_table cons (get_afun_table (Context.Proof ctxt)) []); in Pretty.writeln (Pretty.big_list "Registered applicative functors:" (map pretty_afun afuns)) end; (* Unfolding *) fun add_unfold_thm name thm context = let val (lhs, _) = Thm.prop_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq handle TERM _ => error "Not an equation"; val names = case name of SOME n => [intern context n] | NONE => case match_typ context (Term.fastype_of lhs) of ns as (_::_) => ns | [] => error "Unable to determine applicative functor instance"; val _ = map (afun_of_generic context) names; (*TODO: check equation*) val thm' = mk_meta_eq thm; in fold (fn n => update_afun n (add_unfolds_afun [thm'])) names context end; fun add_unfold_attrib name = Thm.declaration_attribute (add_unfold_thm name); (*TODO: attribute to delete unfolds*) end; diff --git a/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy b/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy --- a/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy +++ b/thys/Automatic_Refinement/Tool/Autoref_Fix_Rel.thy @@ -1,983 +1,983 @@ section \Relator Fixing\ theory Autoref_Fix_Rel imports Autoref_Id_Ops begin ML_val "2 upto 5" subsubsection \Priority tags\ text \ Priority tags are used to influence the ordering of refinement theorems. A priority tag defines two numeric priorities, a major and a minor priority. The major priority is considered first, the minor priority last, i.e., after the homogenity and relator-priority criteria. The default value for both priorities is 0. \ definition PRIO_TAG :: "int \ int \ bool" where [simp]: "PRIO_TAG ma mi \ True" lemma PRIO_TAGI: "PRIO_TAG ma mi" by simp abbreviation "MAJOR_PRIO_TAG i \ PRIO_TAG i 0" abbreviation "MINOR_PRIO_TAG i \ PRIO_TAG 0 i" abbreviation "DFLT_PRIO_TAG \ PRIO_TAG 0 0" text \Some standard tags\ abbreviation "PRIO_TAG_OPTIMIZATION \ MINOR_PRIO_TAG 10" \ \Optimized version of an algorithm, with additional side-conditions\ abbreviation "PRIO_TAG_GEN_ALGO \ MINOR_PRIO_TAG (- 10)" \ \Generic algorithm, considered to be less efficient than default algorithm\ subsection \Solving Relator Constraints\ text \ In this phase, we try to instantiate the annotated relators, using the available refinement rules. \ definition CONSTRAINT :: "'a \ ('c\'a) set \ bool" where [simp]: "CONSTRAINT f R \ True" lemma CONSTRAINTI: "CONSTRAINT f R" by auto ML \ structure Autoref_Rules = Named_Thms ( val name = @{binding autoref_rules_raw} val description = "Refinement Framework: " ^ "Automatic refinement rules" ); \ setup Autoref_Rules.setup text \Generic algorithm tags have to be defined here, as we need them for relator fixing !\ definition PREFER_tag :: "bool \ bool" where [simp, autoref_tag_defs]: "PREFER_tag x \ x" definition DEFER_tag :: "bool \ bool" where [simp, autoref_tag_defs]: "DEFER_tag x \ x" lemma PREFER_tagI: "P \ PREFER_tag P" by simp lemma DEFER_tagI: "P \ DEFER_tag P" by simp lemmas SIDEI = PREFER_tagI DEFER_tagI definition [simp, autoref_tag_defs]: "GEN_OP_tag P == P" lemma GEN_OP_tagI: "P ==> GEN_OP_tag P" by simp abbreviation "SIDE_GEN_OP P == PREFER_tag (GEN_OP_tag P)" text \Shortcut for assuming an operation in a generic algorithm lemma\ abbreviation "GEN_OP c a R \ SIDE_GEN_OP ((c,OP a ::: R) \ R)" definition TYREL :: "('a\'b) set \ bool" where [simp]: "TYREL R \ True" definition TYREL_DOMAIN :: "'a itself \ bool" where [simp]: "TYREL_DOMAIN i \ True" lemma TYREL_RES: "\ TYREL_DOMAIN TYPE('a); TYREL (R::(_\'a) set) \ \ TYREL R" . lemma DOMAIN_OF_TYREL: "TYREL (R::(_\'a) set) \ TYREL_DOMAIN TYPE('a)" by simp lemma TYRELI: "TYREL (R::(_\'a) set)" by simp lemma ty_REL: "TYREL (R::(_\'a) set)" by simp ML \ signature AUTOREF_FIX_REL = sig type constraint = (term * term) list * (term * term) type thm_pairs = (constraint option * thm) list type hom_net = (int * thm) Net.net val thm_pairsD_init: Proof.context -> Proof.context val thm_pairsD_get: Proof.context -> thm_pairs val constraints_of_term: term -> (term * term) list val constraints_of_goal: int -> thm -> (term * term) list val mk_CONSTRAINT: term * term -> term val mk_CONSTRAINT_rl: Proof.context -> constraint -> thm val insert_CONSTRAINTS_tac: Proof.context -> tactic' val constraint_of_thm: Proof.context -> thm -> constraint datatype prio_relpos = PR_FIRST | PR_LAST | PR_BEFORE of string | PR_AFTER of string val declare_prio: string -> term -> prio_relpos -> local_theory -> local_theory val delete_prio: string -> local_theory -> local_theory val print_prios: Proof.context -> unit val compute_hom_net: thm_pairs -> Proof.context -> hom_net val add_hom_rule: thm -> Context.generic -> Context.generic val del_hom_rule: thm -> Context.generic -> Context.generic val get_hom_rules: Proof.context -> thm list val add_tyrel_rule: thm -> Context.generic -> Context.generic val del_tyrel_rule: thm -> Context.generic -> Context.generic val get_tyrel_rules: Proof.context -> thm list val insert_tyrel_tac : Proof.context -> int -> int -> tactic' val solve_tyrel_tac : Proof.context -> tactic' val tyrel_tac : Proof.context -> itactic val internal_hom_tac: Proof.context -> itactic val internal_spec_tac: Proof.context -> itactic val internal_solve_tac: Proof.context -> itactic val guess_relators_tac: Proof.context -> itactic val pretty_constraint: Proof.context -> constraint -> Pretty.T val pretty_constraints: Proof.context -> constraint list -> Pretty.T val pretty_thm_pair: Proof.context -> (constraint option * thm) -> Pretty.T val pretty_thm_pairs: Proof.context -> thm_pairs -> Pretty.T val analyze: Proof.context -> int -> int -> thm -> bool val pretty_failure: Proof.context -> int -> int -> thm -> Pretty.T val try_solve_tac: Proof.context -> tactic' val solve_step_tac: Proof.context -> tactic' val phase: Autoref_Phases.phase val setup: theory -> theory end structure Autoref_Fix_Rel :AUTOREF_FIX_REL = struct type constraint = (term * term) list * (term * term) type thm_pairs = (constraint option * thm) list type hom_net = (int * thm) Net.net (*********************) (* Constraints *) (*********************) local fun fix_loose_bvars env t = if Term.is_open t then let val frees = tag_list 0 env |> map (fn (i,(n,T)) => Free (":"^string_of_int i ^ "_" ^ n,T)) in subst_bounds (frees, t) end else t fun constraints env @{mpat "OP ?f ::: ?R"} = ( Term.is_open R andalso raise TERM ("Loose bvar in relator",[R]); [(fix_loose_bvars env f,R)] ) | constraints _ (Free _) = [] | constraints _ (Bound _) = [] | constraints env @{mpat "?f ::: _"} = constraints env f | constraints env @{mpat "?f$?x"} = constraints env x @ constraints env f | constraints env @{mpat "PROTECT (\x. PROTECT ?t)"} = constraints ((x,x_T)::env) t | constraints _ @{mpat "PROTECT PROTECT"} = [] | constraints _ t = raise TERM ("constraints_of_term",[t]) in val constraints_of_term = constraints [] end fun constraints_of_goal i st = case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop ((_,?a)\_)"} => constraints_of_term a | _ => raise THM ("constraints_of_goal",i,[st]) fun mk_CONSTRAINT (f,R) = let val fT = fastype_of f val RT = fastype_of R val res = Const (@{const_name CONSTRAINT},fT --> RT --> HOLogic.boolT) $f$R in res end; (* Types of f and R must match! *) fun mk_CONSTRAINT_rl ctxt (ps,c) = let val ps = map (mk_CONSTRAINT #> HOLogic.mk_Trueprop) ps val c = mk_CONSTRAINT c |> HOLogic.mk_Trueprop val g = Logic.list_implies (ps,c) in Goal.prove ctxt [] [] g (fn {context = goal_ctxt, ...} => resolve_tac goal_ctxt @{thms CONSTRAINTI} 1) end; (* Internal use for hom-patterns, f and R are unified *) fun mk_CONSTRAINT_rl_atom ctxt (f,R) = let val ts = map (SOME o Thm.cterm_of ctxt) [f,R] val idx = Term.maxidx_term f (Term.maxidx_of_term R) + 1 in infer_instantiate' ctxt ts (Thm.incr_indexes idx @{thm CONSTRAINTI}) end; fun insert_CONSTRAINTS_tac ctxt i st = let val cs = constraints_of_goal i st |> map (mk_CONSTRAINT #> HOLogic.mk_Trueprop #> Thm.cterm_of ctxt) in Refine_Util.insert_subgoals_tac cs i st end fun constraint_of_thm ctxt thm = let exception NO_REL of term open Autoref_Tagging fun extract_entry t = case Logic.strip_imp_concl (strip_all_body t) of @{mpat "Trueprop ((_,?f)\_)"} => SOME (fst (strip_app f),t) | _ => NONE fun relator_of t = let (*val _ = tracing (Syntax.string_of_term @{context} t)*) val t = strip_all_body t val prems = Logic.strip_imp_prems t val concl = Logic.strip_imp_concl t in case concl of @{mpat "Trueprop ((_,?t)\?R)"} => let val (f,args) = strip_app t in case f of @{mpat "OP ?f:::?rel"} => (f,rel) | _ => let val rels = map_filter extract_entry prems fun find_rel t = case filter (fn (t',_) => t=t') rels of [(_,t)] => snd (relator_of t) | _ => raise NO_REL t val argrels = map find_rel args val rel = fold Relators.mk_fun_rel (rev argrels) R in (f,rel) end end | _ => raise THM ("constraint_of_thm: Invalid concl",~1,[thm]) end val (f,rel) = relator_of (Thm.prop_of thm) handle exc as (NO_REL t) => ( warning ( "Could not infer unique higher-order relator for " ^ "refinement rule: \n" ^ Thm.string_of_thm ctxt thm ^ "\n for argument: " ^ Syntax.string_of_term ctxt t ); Exn.reraise exc) (* Extract GEN_OP-tags *) fun genop_cs @{mpat "Trueprop (SIDE_GEN_OP ((_,OP ?f ::: _) \ ?R))"} = if has_Var f then NONE else SOME (f,R) | genop_cs _ = NONE val gen_ops = Thm.prems_of thm |> map_filter genop_cs in (gen_ops,(f,rel)) end (*********************) (* Priorities *) (*********************) structure Rel_Prio_List = Prio_List ( type item = string * term val eq = (op =) o apply2 fst ) structure Rel_Prio = Generic_Data ( type T = Rel_Prio_List.T val empty = Rel_Prio_List.empty val merge = Rel_Prio_List.merge ) fun pretty_rel_prio ctxt (s,t) = Pretty.block [ Pretty.str s, Pretty.str ":", Pretty.brk 1, Syntax.pretty_term ctxt t ] fun print_prios ctxt = let val rpl = Rel_Prio.get (Context.Proof ctxt) in (map (pretty_rel_prio ctxt) rpl) |> Pretty.big_list "Relator Priorities" |> Pretty.string_of |> warning end datatype prio_relpos = PR_FIRST | PR_LAST | PR_BEFORE of string | PR_AFTER of string fun declare_prio name pat0 relpos lthy = let val pat1 = Proof_Context.cert_term lthy pat0 val pat2 = singleton (Variable.export_terms (Proof_Context.augment pat1 lthy) lthy) pat1 in - lthy |> Local_Theory.declaration {syntax = false, pervasive = false} + lthy |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn phi => let val item = (name, Morphism.term phi pat2) in Rel_Prio.map (fn rpl => case relpos of PR_FIRST => Rel_Prio_List.add_first rpl item | PR_LAST => Rel_Prio_List.add_last rpl item | PR_BEFORE n => Rel_Prio_List.add_before rpl item (n,Term.dummy) | PR_AFTER n => Rel_Prio_List.add_after rpl item (n,Term.dummy) ) end) end - fun delete_prio name = Local_Theory.declaration {syntax = false, pervasive = false} + fun delete_prio name = Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn phi => Rel_Prio.map (Rel_Prio_List.delete (name, Term.dummy))) local fun relators_of R = let fun f @{mpat "?R1.0\?R2.0"} = f R1 @ f R2 | f R = [R] in f R |> map Refine_Util.anorm_term |> distinct (op =) end fun dest_prio_tag @{mpat "Trueprop (PRIO_TAG ?ma ?mi)"} = apply2 (#2 o HOLogic.dest_number) (ma,mi) | dest_prio_tag t = raise TERM ("dest_prio_tag",[t]) fun get_tagged_prios thm = let val prems = Thm.prems_of thm fun r [] = (0,0) | r (prem::prems) = ( case try dest_prio_tag prem of NONE => r prems | SOME p => p ) in r prems end fun prio_order_of ctxt (SOME (_,(_,R)),thm) = let val rels = relators_of R val hom = length rels val (major_prio,minor_prio) = get_tagged_prios thm val rpl = Rel_Prio.get (Context.Proof ctxt) val matches = Pattern.matches (Proof_Context.theory_of ctxt) fun prefer ((_,p1),(_,p2)) = matches (p2,p1) fun prio_of R = Rel_Prio_List.prio_of (fn (_,pat) => matches (pat,R)) prefer rpl + 1 val prio = fold (fn R => fn s => prio_of R + s) rels 0 in (major_prio, (hom,(prio,minor_prio))) end | prio_order_of _ _ = raise Match val prio_order = prod_ord (rev_order o int_ord) (prod_ord int_ord (prod_ord (rev_order o int_ord) (rev_order o int_ord))) fun annotate_thm_pair ctxt (SOME (ps,(f,R)),thm) = let open Autoref_Tagging Conv fun warn () = warning ("Error annotating refinement theorem: " ^ Thm.string_of_thm ctxt thm ) val R_cert = Thm.cterm_of ctxt R fun cnv ctxt ct = (case Thm.term_of ct of @{mpat "OP _ ::: _"} => all_conv | @{mpat "OP _"} => mk_rel_ANNOT_conv ctxt R_cert | @{mpat "_ $ _"} => arg1_conv (cnv ctxt) | _ => mk_OP_conv then_conv mk_rel_ANNOT_conv ctxt R_cert ) ct (*val _ = tracing ("ANNOT: " ^ @{make_string} thm)*) val thm = (fconv_rule (rhs_conv cnv ctxt)) thm val thm = case try (fconv_rule (rhs_conv cnv ctxt)) thm of NONE => (warn (); thm) | SOME thm => thm (*val _ = tracing ("RES: " ^ @{make_string} thm)*) in (SOME (ps,(f,R)),thm) end | annotate_thm_pair _ p = p in fun compute_thm_pairs ctxt = let val rules = Autoref_Rules.get ctxt fun add_o p = (prio_order_of ctxt p,p) val pairs = rules |> map (fn thm => (try (constraint_of_thm ctxt) thm,thm)) val spairs = filter (is_some o #1) pairs |> map add_o |> sort (prio_order o apply2 #1) |> map #2 val npairs = filter (is_none o #1) pairs in spairs@npairs |> map (annotate_thm_pair ctxt) end end structure thm_pairsD = Autoref_Data ( type T = thm_pairs val compute = compute_thm_pairs val prereq = [] ) val thm_pairsD_init = thm_pairsD.init val thm_pairsD_get = thm_pairsD.get structure hom_rules = Named_Sorted_Thms ( val name = @{binding autoref_hom} val description = "Autoref: Homogenity rules" val sort = K I val transform = K ( fn thm => case Thm.concl_of thm of @{mpat "Trueprop (CONSTRAINT _ _)"} => [thm] | _ => raise THM ("Invalid homogenity rule",~1,[thm]) ) ) val add_hom_rule = hom_rules.add_thm val del_hom_rule = hom_rules.del_thm val get_hom_rules = hom_rules.get local open Relators fun repl @{mpat "?R\?S"} ctab = let val (R,ctab) = repl R ctab val (S,ctab) = repl S ctab in (mk_fun_rel R S,ctab) end | repl R ctab = let val (args,R) = strip_relAPP R val (args,ctab) = fold_map repl args ctab val (ctxt,tab) = ctab val (R,(ctxt,tab)) = case Termtab.lookup tab R of SOME R => (R,(ctxt,tab)) | NONE => let val aT = fastype_of R |> strip_type |> #2 |> HOLogic.dest_setT |> HOLogic.dest_prodT |> #2 val (cT,ctxt) = yield_singleton Variable.invent_types @{sort type} ctxt val cT = TFree cT val T = map fastype_of args ---> HOLogic.mk_setT (HOLogic.mk_prodT (cT,aT)) val (R',ctxt) = yield_singleton Variable.variant_fixes "R" ctxt val R' = list_relAPP args (Free (R',T)) val tab = Termtab.update (R,R') tab in (R',(ctxt,tab)) end in (R,(ctxt,tab)) end fun hom_pat_of_rel ctxt R = let val (R,(ctxt',_)) = repl R (ctxt,Termtab.empty) val R = singleton (Variable.export_terms ctxt' ctxt) R in Refine_Util.anorm_term R end in fun compute_hom_net pairs ctxt = let val cs = map_filter #1 pairs val cs' = map (fn (_,(f,R)) => (f,hom_pat_of_rel ctxt R)) cs val thms = get_hom_rules ctxt @ map (mk_CONSTRAINT_rl_atom ctxt) cs' val thms = map (Thm.cprop_of #> Thm.trivial) thms val net = Tactic.build_net thms in net end end structure hom_netD = Autoref_Data ( type T = hom_net fun compute ctxt = compute_hom_net (thm_pairsD.get ctxt) ctxt val prereq = [ thm_pairsD.init ] ) structure tyrel_rules = Named_Sorted_Thms ( val name = @{binding autoref_tyrel} val description = "Autoref: Type-based relator fixing rules" val sort = K I val transform = K ( fn thm => case Thm.prop_of thm of @{mpat "Trueprop (TYREL _)"} => [thm] | _ => raise THM ("Invalid tyrel-rule",~1,[thm]) ) ) val add_tyrel_rule = tyrel_rules.add_thm val del_tyrel_rule = tyrel_rules.del_thm val get_tyrel_rules = tyrel_rules.get local (*fun rel_annots @{mpat "_ ::: ?R"} = [R] | rel_annots @{mpat "?f$?x"} = rel_annots f @ rel_annots x | rel_annots @{mpat "PROTECT (\_. PROTECT ?t)"} = rel_annots t | rel_annots @{mpat "PROTECT PROTECT"} = [] | rel_annots (Free _) = [] | rel_annots (Bound _) = [] | rel_annots t = raise TERM ("rel_annots",[t]) *) fun add_relators t acc = let open Relators val (args,_) = strip_relAPP t val res = fold add_relators args acc val res = insert (op =) t res in res end fun add_relators_of_subgoal st i acc = case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT _ ?R)"} => add_relators R acc | _ => acc in fun insert_tyrel_tac ctxt i j k st = let fun get_constraint t = let val T = fastype_of t val res = Const (@{const_name TYREL}, T --> HOLogic.boolT) $ t in res |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt end val relators = fold (add_relators_of_subgoal st) (i upto j) [] val tyrels = map get_constraint relators in Refine_Util.insert_subgoals_tac tyrels k st end end fun solve_tyrel_tac ctxt = let fun mk_tac rl = resolve_tac ctxt @{thms TYREL_RES} THEN' match_tac ctxt [rl RS @{thm DOMAIN_OF_TYREL}] THEN' resolve_tac ctxt [rl] val tac = FIRST' (map mk_tac (tyrel_rules.get ctxt)) in DETERM o tac ORELSE' (TRY o resolve_tac ctxt @{thms TYRELI}) end fun tyrel_tac ctxt i j = (insert_tyrel_tac ctxt i j THEN_ALL_NEW_FWD solve_tyrel_tac ctxt) i fun internal_hom_tac ctxt = let val hom_net = hom_netD.get ctxt in Seq.INTERVAL (TRY o DETERM o resolve_from_net_tac ctxt hom_net) end fun internal_spec_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (snd #> mk_CONSTRAINT_rl_atom ctxt)) |> Tactic.build_net in fn i => fn j => REPEAT (CHANGED (Seq.INTERVAL (DETERM o Anti_Unification.specialize_net_tac ctxt net) i j) ) end fun apply_to_constraints tac = let fun no_CONSTRAINT_tac i st = case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT _ _)"} => Seq.empty | _ => Seq.single st in Seq.INTERVAL (no_CONSTRAINT_tac ORELSE' tac) end fun internal_solve_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net val s_tac = SOLVED' (REPEAT_ALL_NEW (resolve_from_net_tac ctxt net)) in apply_to_constraints s_tac ORELSE_INTERVAL apply_to_constraints (TRY o DETERM o s_tac) end fun guess_relators_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net val hom_net = hom_netD.get ctxt fun hom_tac i j = Seq.INTERVAL (TRY o DETERM o resolve_from_net_tac ctxt hom_net) i j fun spec_tac i j = REPEAT (CHANGED (Seq.INTERVAL (DETERM o Anti_Unification.specialize_net_tac ctxt net) i j) ) val solve_tac = let val s_tac = SOLVED' (REPEAT_ALL_NEW (resolve_from_net_tac ctxt net)) in apply_to_constraints s_tac ORELSE_INTERVAL apply_to_constraints (TRY o DETERM o s_tac) end in Seq.INTERVAL (insert_CONSTRAINTS_tac ctxt) THEN_INTERVAL hom_tac THEN_INTERVAL spec_tac THEN_INTERVAL (tyrel_tac ctxt) THEN_INTERVAL solve_tac end (*********************) (* Pretty Printing *) (*********************) fun pretty_constraint_atom ctxt (f,R) = Pretty.block [ Syntax.pretty_term ctxt f, Pretty.str " :: ", Syntax.pretty_typ ctxt (fastype_of f), Pretty.str " ::: ", Syntax.pretty_term ctxt R] fun pretty_constraint ctxt (ps,(f,R)) = case ps of [] => pretty_constraint_atom ctxt (f,R) | _ => Pretty.block [ map (pretty_constraint_atom ctxt) ps |> Pretty.separate "; " |> Pretty.enclose "\" "\", Pretty.brk 1, Pretty.str "\", Pretty.brk 1, pretty_constraint_atom ctxt (f,R) ] fun pretty_constraints ctxt l = Pretty.big_list "Constraints" (map (pretty_constraint ctxt) l) fun pretty_thm_pair ctxt (c,thm) = Pretty.block [ case c of NONE => Pretty.str "NONE" | SOME c => pretty_constraint ctxt c, Pretty.brk 2, Pretty.str "---", Pretty.brk 2, Thm.pretty_thm ctxt thm ] fun pretty_thm_pairs ctxt pairs = Pretty.big_list "Thm-Pairs" (map (pretty_thm_pair ctxt) pairs) local fun unifies ctxt (t1, t2) = Term.could_unify (t1, t2) andalso let val idx1 = Term.maxidx_of_term t1 val t2 = Logic.incr_indexes ([], [], idx1 + 1) t2 val idx2 = Term.maxidx_of_term t2 in can (Pattern.unify (Context.Proof ctxt) (t1,t2)) (Envir.empty idx2) end fun analyze_possible_problems ctxt (f,R) = let fun strange_aux sf R = ( if sf then let val T = fastype_of R in case try (HOLogic.dest_prodT o HOLogic.dest_setT) T of SOME _ => [] | NONE => [Pretty.block [ Pretty.str "Strange relator type, expected plain relation: ", Syntax.pretty_term (Config.put show_types true ctxt) R ]] end else [] ) @ ( case R of @{mpat "\?R\?S"} => strange_aux true R @ strange_aux false S | Var (_,T) => ( case try (HOLogic.dest_prodT o HOLogic.dest_setT) (#2 (strip_type T)) of SOME (TFree _,_) => [Pretty.block [ Pretty.str "Fixed concrete type on schematic relator: ", Syntax.pretty_term (Config.put show_types true ctxt) R ]] | _ => [] ) | _ => [] ) val strange = case strange_aux true R of [] => NONE | l => SOME (Pretty.block l) val folded_relator = let fun match (Type (name,args)) R = let val (Rargs,Rhd) = Relators.strip_relAPP R in if is_Var Rhd then [] else if length args <> length Rargs then [Pretty.block [ Pretty.str "Type/relator arity mismatch:", Pretty.brk 1, Pretty.block [ Pretty.str name, Pretty.str "/", Pretty.str (string_of_int (length args)) ], Pretty.brk 1,Pretty.str "vs.",Pretty.brk 1, Pretty.block [ Syntax.pretty_term ctxt Rhd, Pretty.str "/", Pretty.str (string_of_int (length Rargs)) ] ]] else args ~~ Rargs |> map (uncurry match) |> flat end | match _ _ = [] in case match (fastype_of f) R of [] => NONE | l => SOME (Pretty.block (Pretty.fbreaks l @ [Pretty.fbrk, Pretty.str ("Explanation: This may be due to using polymorphic " ^ "relators like Id on non-terminal types." ^ "A problem usually occurs when " ^ "this relator has to be matched against a fully unfolded one." ^ "This warning is also issued on partially parametric relators " ^ "like br. However, the refinement rules are usually set up to " ^ "compensate for this, so this is probably not the cause for an " ^ "unsolved constraint") ])) end val issues = [strange, folded_relator] |> map_filter I in case issues of [] => NONE | l => SOME (Pretty.big_list "Possible problems" l) end fun pretty_try_candidates ctxt i st = if i > Thm.nprems_of st then Pretty.str "Goal number out of range" else case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT ?f ?R)"} => let val pairs = thm_pairsD.get ctxt val st = Drule.zero_var_indexes st val pt_hd = Pretty.block [ Pretty.str "Head: ", Pretty.fbrk, pretty_constraint_atom ctxt (f,R) ] fun isc (SOME (ps,(fp,R)),_) = if unifies ctxt (f,fp) then SOME (ps,(fp,R)) else NONE | isc _ = NONE val candidates = pairs |> map_filter isc fun try_c c = let val pt1 = Pretty.block [ Pretty.str "Trying ", pretty_constraint ctxt c ] val rl = mk_CONSTRAINT_rl ctxt c |> Drule.zero_var_indexes val res = (SOLVED' (resolve_tac ctxt [rl])) i st |> Seq.pull |> is_some val pt2 = (if res then Pretty.str "OK" else Pretty.str "ERR") in Pretty.block [pt1,Pretty.fbrk,pt2] end val res = Pretty.block ( Pretty.fbreaks [pt_hd, Pretty.big_list "Solving Attempts" (map try_c candidates)] ) in res end | _ => Pretty.str "Unexpected goal format" exception ERR of Pretty.T fun analyze' ctxt i j st = let val As = Logic.strip_horn (Thm.prop_of st) |> #1 |> drop (i-1) |> take (j-i+1) |> map (strip_all_body #> Logic.strip_imp_concl) val Cs = map_filter ( fn @{mpat "Trueprop (CONSTRAINT ?f ?R)"} => SOME (f,R) | @{mpat "Trueprop ((_,_)\_)"} => NONE | t => raise ERR (Pretty.block [ Pretty.str "Internal: Unexpected goal format: ", Syntax.pretty_term ctxt t ]) ) As val Cs_problems = map (fn c => case analyze_possible_problems ctxt c of NONE => pretty_constraint_atom ctxt c | SOME p => Pretty.block [pretty_constraint_atom ctxt c,Pretty.fbrk,p] ) Cs val Cs_pretty = Pretty.big_list "Constraints" Cs_problems in case Cs of [] => () | _ => raise ERR (Pretty.block [ Pretty.str "Could not infer all relators, some constraints remaining", Pretty.fbrk, Cs_pretty, Pretty.fbrk, Pretty.block [ Pretty.str "Trying to solve first constraint", Pretty.fbrk, pretty_try_candidates ctxt i st ] ]) end in fun analyze ctxt i j st = can (analyze' ctxt i j) st fun pretty_failure ctxt i j st = (analyze' ctxt i j st; Pretty.str "No failure") handle ERR p => p fun try_solve_tac ctxt i st = if i > Thm.nprems_of st then (tracing "Goal number out of range"; Seq.empty) else case Logic.concl_of_goal (Thm.prop_of st) i of @{mpat "Trueprop (CONSTRAINT ?f ?R)"} => let val pairs = thm_pairsD.get ctxt val st = Drule.zero_var_indexes st val pt = Pretty.block [ Pretty.str "Head: ", Pretty.fbrk, pretty_constraint_atom ctxt (f,R) ] val _ = tracing (Pretty.string_of pt) val _ = case analyze_possible_problems ctxt (f,R) of NONE => () | SOME p => tracing (Pretty.string_of p) fun isc (SOME (ps,(fp,R)),_) = if unifies ctxt (f,fp) then SOME (ps,(fp,R)) else NONE | isc _ = NONE val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net val candidates = pairs |> map_filter isc fun try_c c = let val _ = Pretty.block [ Pretty.str "Trying ", pretty_constraint ctxt c ] |> Pretty.string_of |> tracing val rl = mk_CONSTRAINT_rl ctxt c |> Drule.zero_var_indexes val res = (SOLVED' (resolve_tac ctxt [rl] THEN_ALL_NEW (REPEAT_ALL_NEW (resolve_from_net_tac ctxt net))) ) i st |> Seq.pull |> is_some val _ = (if res then Pretty.str "OK" else Pretty.str "ERR") |> Pretty.string_of |> tracing in () end val _ = map try_c candidates in Seq.single st end | _ => Seq.empty end fun solve_step_tac ctxt = let val pairs = thm_pairsD.get ctxt val net = pairs |> map_filter (fst #> map_option (mk_CONSTRAINT_rl ctxt)) |> Tactic.build_net in resolve_from_net_tac ctxt net end val phase = { init = thm_pairsD.init #> hom_netD.init, tac = guess_relators_tac, analyze = analyze, pretty_failure = pretty_failure } val setup = hom_rules.setup #> tyrel_rules.setup end \ setup Autoref_Fix_Rel.setup end diff --git a/thys/Clean/document/root.bib b/thys/Clean/document/root.bib --- a/thys/Clean/document/root.bib +++ b/thys/Clean/document/root.bib @@ -1,644 +1,599 @@ @misc{bockenek:hal-02069705, TITLE = {{Using Isabelle/UTP for the Verification of Sorting Algorithms A Case Study}}, AUTHOR = {Bockenek, Joshua A and Lammich, Peter and Nemouchi, Yakoub and Wolff, Burkhart}, URL = {https://easychair.org/publications/preprint/CxRV}, NOTE = {Isabelle Workshop 2018, Colocated with Interactive Theorem Proving. As part of FLOC 2018, Oxford, GB.}, YEAR = {2018}, MONTH = Jul } @book{DBLP:books/sp/NipkowPW02, author = {Tobias Nipkow and Lawrence C. Paulson and Markus Wenzel}, title = {Isabelle/HOL - {A} Proof Assistant for Higher-Order Logic}, series = {Lecture Notes in Computer Science}, volume = {2283}, publisher = {Springer}, year = {2002}, url = {https://doi.org/10.1007/3-540-45949-9}, doi = {10.1007/3-540-45949-9}, isbn = {3-540-43376-7}, timestamp = {Tue, 14 May 2019 10:00:35 +0200}, biburl = {https://dblp.org/rec/bib/books/sp/NipkowPW02}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/sosp/KleinEHACDEEKNSTW09, author = {Gerwin Klein and Kevin Elphinstone and Gernot Heiser and June Andronick and David Cock and Philip Derrin and Dhammika Elkaduwe and Kai Engelhardt and Rafal Kolanski and Michael Norrish and Thomas Sewell and Harvey Tuch and Simon Winwood}, title = {seL4: formal verification of an {OS} kernel}, booktitle = {Proceedings of the 22nd {ACM} Symposium on Operating Systems Principles 2009, {SOSP} 2009, Big Sky, Montana, USA, October 11-14, 2009}, pages = {207--220}, year = {2009}, crossref = {DBLP:conf/sosp/2009}, url = {https://doi.org/10.1145/1629575.1629596}, doi = {10.1145/1629575.1629596}, timestamp = {Tue, 06 Nov 2018 16:59:32 +0100}, biburl = {https://dblp.org/rec/bib/conf/sosp/KleinEHACDEEKNSTW09}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/sosp/2009, editor = {Jeanna Neefe Matthews and Thomas E. Anderson}, title = {Proceedings of the 22nd {ACM} Symposium on Operating Systems Principles 2009, {SOSP} 2009, Big Sky, Montana, USA, October 11-14, 2009}, publisher = {{ACM}}, year = {2009}, url = {https://doi.org/10.1145/1629575}, doi = {10.1145/1629575}, isbn = {978-1-60558-752-3}, timestamp = {Tue, 06 Nov 2018 16:59:32 +0100}, biburl = {https://dblp.org/rec/bib/conf/sosp/2009}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/tphol/CohenDHLMSST09, author = {Ernie Cohen and Markus Dahlweid and Mark A. Hillebrand and Dirk Leinenbach and Michal Moskal and Thomas Santen and Wolfram Schulte and Stephan Tobies}, title = {{VCC:} {A} Practical System for Verifying Concurrent {C}}, booktitle = {Theorem Proving in Higher Order Logics, 22nd International Conference, TPHOLs 2009, Munich, Germany, August 17-20, 2009. Proceedings}, pages = {23--42}, year = {2009}, url = {https://doi.org/10.1007/978-3-642-03359-9_2}, doi = {10.1007/978-3-642-03359-9_2}, timestamp = {Tue, 23 May 2017 01:12:08 +0200}, biburl = {https://dblp.org/rec/bib/conf/tphol/CohenDHLMSST09}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/cacm/Leroy09, author = {Xavier Leroy}, title = {Formal verification of a realistic compiler}, journal = {Commun. {ACM}}, volume = {52}, number = {7}, pages = {107--115}, year = {2009}, url = {http://doi.acm.org/10.1145/1538788.1538814}, doi = {10.1145/1538788.1538814}, timestamp = {Thu, 02 Jul 2009 13:36:32 +0200}, biburl = {https://dblp.org/rec/bib/journals/cacm/Leroy09}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/itp/Wenzel14, author = {Makarius Wenzel}, title = {Asynchronous User Interaction and Tool Integration in Isabelle/PIDE}, booktitle = {Interactive Theorem Proving - 5th International Conference, {ITP} 2014, Held as Part of the Vienna Summer of Logic, {VSL} 2014, Vienna, Austria, July 14-17, 2014. Proceedings}, pages = {515--530}, year = {2014}, crossref = {DBLP:conf/itp/2014}, url = {https://doi.org/10.1007/978-3-319-08970-6\_33}, doi = {10.1007/978-3-319-08970-6\_33}, timestamp = {Tue, 14 May 2019 10:00:37 +0200}, biburl = {https://dblp.org/rec/bib/conf/itp/Wenzel14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/itp/2014, editor = {Gerwin Klein and Ruben Gamboa}, title = {Interactive Theorem Proving - 5th International Conference, {ITP} 2014, Held as Part of the Vienna Summer of Logic, {VSL} 2014, Vienna, Austria, July 14-17, 2014. Proceedings}, series = {Lecture Notes in Computer Science}, volume = {8558}, publisher = {Springer}, year = {2014}, url = {https://doi.org/10.1007/978-3-319-08970-6}, doi = {10.1007/978-3-319-08970-6}, isbn = {978-3-319-08969-0}, timestamp = {Tue, 14 May 2019 10:00:37 +0200}, biburl = {https://dblp.org/rec/bib/conf/itp/2014}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:journals/corr/Wenzel14, author = {Makarius Wenzel}, title = {System description: Isabelle/jEdit in 2014}, booktitle = {Proceedings Eleventh Workshop on User Interfaces for Theorem Provers, {UITP} 2014, Vienna, Austria, 17th July 2014.}, pages = {84--94}, year = {2014}, crossref = {DBLP:journals/corr/BenzmullerP14}, url = {https://doi.org/10.4204/EPTCS.167.10}, doi = {10.4204/EPTCS.167.10}, timestamp = {Wed, 12 Sep 2018 01:05:15 +0200}, biburl = {https://dblp.org/rec/bib/journals/corr/Wenzel14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:journals/corr/BenzmullerP14, editor = {Christoph Benzm{\"{u}}ller and Bruno {Woltzenlogel Paleo}}, title = {Proceedings Eleventh Workshop on User Interfaces for Theorem Provers, {UITP} 2014, Vienna, Austria, 17th July 2014}, series = {{EPTCS}}, volume = {167}, year = {2014}, url = {https://doi.org/10.4204/EPTCS.167}, doi = {10.4204/EPTCS.167}, timestamp = {Wed, 12 Sep 2018 01:05:15 +0200}, biburl = {https://dblp.org/rec/bib/journals/corr/BenzmullerP14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/mkm/BarrasGHRTWW13, author = {Bruno Barras and Lourdes Del Carmen Gonz{\'{a}}lez{-}Huesca and Hugo Herbelin and Yann R{\'{e}}gis{-}Gianas and Enrico Tassi and Makarius Wenzel and Burkhart Wolff}, title = {Pervasive Parallelism in Highly-Trustable Interactive Theorem Proving Systems}, booktitle = {Intelligent Computer Mathematics - MKM, Calculemus, DML, and Systems and Projects 2013, Held as Part of {CICM} 2013, Bath, UK, July 8-12, 2013. Proceedings}, pages = {359--363}, year = {2013}, crossref = {DBLP:conf/mkm/2013}, url = {https://doi.org/10.1007/978-3-642-39320-4\_29}, doi = {10.1007/978-3-642-39320-4\_29}, timestamp = {Sun, 02 Jun 2019 21:17:34 +0200}, biburl = {https://dblp.org/rec/bib/conf/mkm/BarrasGHRTWW13}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/mkm/2013, editor = {Jacques Carette and David Aspinall and Christoph Lange and Petr Sojka and Wolfgang Windsteiger}, title = {Intelligent Computer Mathematics - MKM, Calculemus, DML, and Systems and Projects 2013, Held as Part of {CICM} 2013, Bath, UK, July 8-12, 2013. Proceedings}, series = {Lecture Notes in Computer Science}, volume = {7961}, publisher = {Springer}, year = {2013}, url = {https://doi.org/10.1007/978-3-642-39320-4}, doi = {10.1007/978-3-642-39320-4}, isbn = {978-3-642-39319-8}, timestamp = {Sun, 02 Jun 2019 21:17:34 +0200}, biburl = {https://dblp.org/rec/bib/conf/mkm/2013}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/afp/LammichW19, author = {Peter Lammich and Simon Wimmer}, title = {{IMP2} - Simple Program Verification in Isabelle/HOL}, journal = {Archive of Formal Proofs}, volume = {2019}, year = {2019}, url = {https://www.isa-afp.org/entries/IMP2.html}, timestamp = {Mon, 20 May 2019 11:45:07 +0200}, biburl = {https://dblp.org/rec/bib/journals/afp/LammichW19}, bibsource = {dblp computer science bibliography, https://dblp.org} } @misc{frama-c-home-page, title = {The Frama-C Home Page}, author = {CEA LIST}, year = 2019, month = jan, day = 10, url = {https://frama-c.com}, note = {Accessed \DTMdate{2019-03-24}} } @inproceedings{DBLP:conf/fm/LeinenbachS09, author = {Dirk Leinenbach and Thomas Santen}, title = {Verifying the Microsoft Hyper-V Hypervisor with {VCC}}, booktitle = {{FM} 2009: Formal Methods, Second World Congress, Eindhoven, The Netherlands, November 2-6, 2009. Proceedings}, pages = {806--809}, year = {2009}, url = {https://doi.org/10.1007/978-3-642-05089-3_51}, doi = {10.1007/978-3-642-05089-3_51}, timestamp = {Mon, 22 May 2017 17:11:19 +0200}, biburl = {https://dblp.org/rec/bib/conf/fm/LeinenbachS09}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/tap/Keller18, author = {Chantal Keller}, title = {Tactic Program-Based Testing and Bounded Verification in Isabelle/HOL}, booktitle = {Tests and Proofs - 12th International Conference, {TAP} 2018, Held as Part of {STAF} 2018, Toulouse, France, June 27-29, 2018, Proceedings}, pages = {103--119}, year = {2018}, url = {https://doi.org/10.1007/978-3-319-92994-1\_6}, doi = {10.1007/978-3-319-92994-1\_6}, timestamp = {Mon, 18 Jun 2018 13:57:50 +0200}, biburl = {https://dblp.org/rec/bib/conf/tap/Keller18}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/itp/AissatVW16, author = {Romain A{\"{\i}}ssat and Fr{\'{e}}d{\'{e}}ric Voisin and Burkhart Wolff}, title = {Infeasible Paths Elimination by Symbolic Execution Techniques - Proof of Correctness and Preservation of Paths}, booktitle = {Interactive Theorem Proving - 7th International Conference, {ITP} 2016, Nancy, France, August 22-25, 2016, Proceedings}, pages = {36--51}, year = {2016}, url = {https://doi.org/10.1007/978-3-319-43144-4\_3}, doi = {10.1007/978-3-319-43144-4\_3}, timestamp = {Thu, 17 Aug 2017 16:22:01 +0200}, biburl = {https://dblp.org/rec/bib/conf/itp/AissatVW16}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/tocs/KleinAEMSKH14, author = {Gerwin Klein and June Andronick and Kevin Elphinstone and Toby C. Murray and Thomas Sewell and Rafal Kolanski and Gernot Heiser}, title = {Comprehensive formal verification of an {OS} microkernel}, journal = {{ACM} Trans. Comput. Syst.}, volume = {32}, number = {1}, pages = {2:1--2:70}, year = {2014}, url = {http://doi.acm.org/10.1145/2560537}, doi = {10.1145/2560537}, timestamp = {Tue, 03 Jan 2017 11:51:57 +0100}, biburl = {https://dblp.org/rec/bib/journals/tocs/KleinAEMSKH14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/pldi/GreenawayLAK14, author = {David Greenaway and Japheth Lim and June Andronick and Gerwin Klein}, title = {Don't sweat the small stuff: formal verification of {C} code without the pain}, booktitle = {{ACM} {SIGPLAN} Conference on Programming Language Design and Implementation, {PLDI} '14, Edinburgh, United Kingdom - June 09 - 11, 2014}, pages = {429--439}, year = {2014}, url = {http://doi.acm.org/10.1145/2594291.2594296}, doi = {10.1145/2594291.2594296}, timestamp = {Tue, 20 Dec 2016 10:12:01 +0100}, biburl = {https://dblp.org/rec/bib/conf/pldi/GreenawayLAK14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/mkm/BruckerACW18, author = {Achim D. Brucker and Idir A{\"{\i}}t{-}Sadoune and Paolo Crisafulli and Burkhart Wolff}, title = {Using the Isabelle Ontology Framework - Linking the Formal with the Informal}, booktitle = {Intelligent Computer Mathematics - 11th International Conference, {CICM} 2018, Hagenberg, Austria, August 13-17, 2018, Proceedings}, pages = {23--38}, year = {2018}, url = {https://doi.org/10.1007/978-3-319-96812-4\_3}, doi = {10.1007/978-3-319-96812-4\_3}, timestamp = {Sat, 11 Aug 2018 00:57:41 +0200}, biburl = {https://dblp.org/rec/bib/conf/mkm/BruckerACW18}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/afp/TuongW15, author = {Fr{\'{e}}d{\'{e}}ric Tuong and Burkhart Wolff}, title = {A Meta-Model for the Isabelle {API}}, journal = {Archive of Formal Proofs}, volume = {2015}, year = {2015}, url = {https://www.isa-afp.org/entries/Isabelle\_Meta\_Model.shtml}, timestamp = {Mon, 07 Jan 2019 11:16:33 +0100}, biburl = {https://dblp.org/rec/bib/journals/afp/TuongW15}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/tphol/WinwoodKSACN09, author = {Simon Winwood and Gerwin Klein and Thomas Sewell and June Andronick and David Cock and Michael Norrish}, title = {Mind the Gap}, booktitle = {Theorem Proving in Higher Order Logics, 22nd International Conference, TPHOLs 2009, Munich, Germany, August 17-20, 2009. Proceedings}, pages = {500--515}, year = {2009}, crossref = {DBLP:conf/tphol/2009}, url = {https://doi.org/10.1007/978-3-642-03359-9\_34}, doi = {10.1007/978-3-642-03359-9\_34}, timestamp = {Fri, 02 Nov 2018 09:49:05 +0100}, biburl = {https://dblp.org/rec/bib/conf/tphol/WinwoodKSACN09}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/tphol/2009, editor = {Stefan Berghofer and Tobias Nipkow and Christian Urban and Makarius Wenzel}, title = {Theorem Proving in Higher Order Logics, 22nd International Conference, TPHOLs 2009, Munich, Germany, August 17-20, 2009. Proceedings}, series = {Lecture Notes in Computer Science}, volume = {5674}, publisher = {Springer}, year = {2009}, url = {https://doi.org/10.1007/978-3-642-03359-9}, doi = {10.1007/978-3-642-03359-9}, isbn = {978-3-642-03358-2}, timestamp = {Tue, 23 May 2017 01:12:08 +0200}, biburl = {https://dblp.org/rec/bib/conf/tphol/2009}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/afp/BruckerTW14, author = {Achim D. Brucker and Fr{\'{e}}d{\'{e}}ric Tuong and Burkhart Wolff}, title = {Featherweight {OCL:} {A} Proposal for a Machine-Checked Formal Semantics for {OCL} 2.5}, journal = {Archive of Formal Proofs}, volume = {2014}, year = {2014}, url = {https://www.isa-afp.org/entries/Featherweight\_OCL.shtml}, timestamp = {Mon, 07 Jan 2019 11:16:33 +0100}, biburl = {https://dblp.org/rec/bib/journals/afp/BruckerTW14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/tacas/SananZHZTL17, author = {David San{\'{a}}n and Yongwang Zhao and Zhe Hou and Fuyuan Zhang and Alwen Tiu and Yang Liu}, title = {CSimpl: {A} Rely-Guarantee-Based Framework for Verifying Concurrent Programs}, booktitle = {Tools and Algorithms for the Construction and Analysis of Systems - 23rd International Conference, {TACAS} 2017, Held as Part of the European Joint Conferences on Theory and Practice of Software, {ETAPS} 2017, Uppsala, Sweden, April 22-29, 2017, Proceedings, Part {I}}, pages = {481--498}, year = {2017}, crossref = {DBLP:conf/tacas/2017-1}, url = {https://doi.org/10.1007/978-3-662-54577-5\_28}, doi = {10.1007/978-3-662-54577-5\_28}, timestamp = {Mon, 18 Sep 2017 08:38:37 +0200}, biburl = {https://dblp.org/rec/bib/conf/tacas/SananZHZTL17}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/tacas/2017-1, editor = {Axel Legay and Tiziana Margaria}, title = {Tools and Algorithms for the Construction and Analysis of Systems - 23rd International Conference, {TACAS} 2017, Held as Part of the European Joint Conferences on Theory and Practice of Software, {ETAPS} 2017, Uppsala, Sweden, April 22-29, 2017, Proceedings, Part {I}}, series = {Lecture Notes in Computer Science}, volume = {10205}, year = {2017}, url = {https://doi.org/10.1007/978-3-662-54577-5}, doi = {10.1007/978-3-662-54577-5}, isbn = {978-3-662-54576-8}, timestamp = {Wed, 24 May 2017 08:28:32 +0200}, biburl = {https://dblp.org/rec/bib/conf/tacas/2017-1}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{DBLP:conf/itp/HouSTL17, author = {Zhe Hou and David San{\'{a}}n and Alwen Tiu and Yang Liu}, title = {Proof Tactics for Assertions in Separation Logic}, booktitle = {Interactive Theorem Proving - 8th International Conference, {ITP} 2017, Bras{\'{\i}}lia, Brazil, September 26-29, 2017, Proceedings}, pages = {285--303}, year = {2017}, crossref = {DBLP:conf/itp/2017}, url = {https://doi.org/10.1007/978-3-319-66107-0\_19}, doi = {10.1007/978-3-319-66107-0\_19}, timestamp = {Mon, 18 Sep 2017 08:38:37 +0200}, biburl = {https://dblp.org/rec/bib/conf/itp/HouSTL17}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/itp/2017, editor = {Mauricio Ayala{-}Rinc{\'{o}}n and C{\'{e}}sar A. Mu{\~{n}}oz}, title = {Interactive Theorem Proving - 8th International Conference, {ITP} 2017, Bras{\'{\i}}lia, Brazil, September 26-29, 2017, Proceedings}, series = {Lecture Notes in Computer Science}, volume = {10499}, publisher = {Springer}, year = {2017}, url = {https://doi.org/10.1007/978-3-319-66107-0}, doi = {10.1007/978-3-319-66107-0}, isbn = {978-3-319-66106-3}, timestamp = {Wed, 06 Sep 2017 14:53:52 +0200}, biburl = {https://dblp.org/rec/bib/conf/itp/2017}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/sigbed/CarrascosaCMBC14, author = {E. Carrascosa and Javier Coronel and Miguel Masmano and Patricia Balbastre and Alfons Crespo}, title = {XtratuM hypervisor redesign for {LEON4} multicore processor}, journal = {{SIGBED} Review}, volume = {11}, number = {2}, pages = {27--31}, year = {2014}, url = {https://doi.org/10.1145/2668138.2668142}, doi = {10.1145/2668138.2668142}, timestamp = {Tue, 06 Nov 2018 12:51:31 +0100}, biburl = {https://dblp.org/rec/bib/journals/sigbed/CarrascosaCMBC14}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/cacm/Earley70, author = {Jay Earley}, title = {An Efficient Context-Free Parsing Algorithm}, journal = {Commun. {ACM}}, volume = {13}, number = {2}, pages = {94--102}, year = {1970}, url = {https://doi.org/10.1145/362007.362035}, doi = {10.1145/362007.362035}, timestamp = {Wed, 14 Nov 2018 10:22:30 +0100}, biburl = {https://dblp.org/rec/bib/journals/cacm/Earley70}, bibsource = {dblp computer science bibliography, https://dblp.org} } @article{DBLP:journals/jfp/Hutton92, author = {Graham Hutton}, title = {Higher-Order Functions for Parsing}, journal = {J. Funct. Program.}, volume = {2}, number = {3}, pages = {323--343}, year = {1992}, url = {https://doi.org/10.1017/S0956796800000411}, doi = {10.1017/S0956796800000411}, timestamp = {Sat, 27 May 2017 14:24:34 +0200}, biburl = {https://dblp.org/rec/bib/journals/jfp/Hutton92}, bibsource = {dblp computer science bibliography, https://dblp.org} } @inproceedings{TuongWolff19, author = {Fr{\'{e}}d{\'{e}}ric Tuong and Burkhart Wolff}, title = {Deeply Integrating {C11} Code Support into Isabelle/PIDE}, booktitle = {Formal IDE - 5th International Workshop, {F-IDE} 2019, Porto, Portugal, October 7, 2019. Proceedings}, year = {2019}, url = {https://gitlri.lri.fr/ftuong/isabelle_c}, } @inproceedings{DBLP:conf/ictac/FosterZW16, author = {Simon Foster and Frank Zeyda and Jim Woodcock}, title = {Unifying Heterogeneous State-Spaces with Lenses}, booktitle = {Theoretical Aspects of Computing - {ICTAC} 2016 - 13th International Colloquium, Taipei, Taiwan, ROC, October 24-31, 2016, Proceedings}, pages = {295--314}, year = {2016}, crossref = {DBLP:conf/ictac/2016}, url = {https://doi.org/10.1007/978-3-319-46750-4\_17}, doi = {10.1007/978-3-319-46750-4\_17}, timestamp = {Tue, 14 May 2019 10:00:38 +0200}, biburl = {https://dblp.org/rec/bib/conf/ictac/FosterZW16}, bibsource = {dblp computer science bibliography, https://dblp.org} } @proceedings{DBLP:conf/ictac/2016, editor = {Augusto Sampaio and Farn Wang}, title = {Theoretical Aspects of Computing - {ICTAC} 2016 - 13th International Colloquium, Taipei, Taiwan, ROC, October 24-31, 2016, Proceedings}, series = {Lecture Notes in Computer Science}, volume = {9965}, year = {2016}, url = {https://doi.org/10.1007/978-3-319-46750-4}, doi = {10.1007/978-3-319-46750-4}, isbn = {978-3-319-46749-8}, timestamp = {Tue, 14 May 2019 10:00:38 +0200}, biburl = {https://dblp.org/rec/bib/conf/ictac/2016}, bibsource = {dblp computer science bibliography, https://dblp.org} } @phdthesis{Foster2009BidirectionalPL, author = {John Nathan Foster}, title = {Bidirectional programming languages}, school = {University of Pennsylvania}, year = {2009}, url = {https://repository.upenn.edu/edissertations/56/} } @article{DBLP:journals/toplas/FosterGMPS07, author = {J. Nathan Foster and Michael B. Greenwald and Jonathan T. Moore and Benjamin C. Pierce and Alan Schmitt}, title = {Combinators for bidirectional tree transformations: {A} linguistic approach to the view-update problem}, journal = {{ACM} Trans. Program. Lang. Syst.}, volume = {29}, number = {3}, pages = {17}, year = {2007}, url = {https://doi.org/10.1145/1232420.1232424}, doi = {10.1145/1232420.1232424}, timestamp = {Tue, 06 Nov 2018 12:51:29 +0100}, biburl = {https://dblp.org/rec/bib/journals/toplas/FosterGMPS07}, bibsource = {dblp computer science bibliography, https://dblp.org} } - -@PhdThesis{Foster09, - author = {Foster, J.}, - title = {Bidirectional programming languages}, - school = {University of Pennsylvania}, - year = 2009} - -@article{Foster07, - author = {Foster, J. and Greenwald, M. and Moore, J. and Pierce, B. and Schmitt, A.}, - title = {Combinators for Bidirectional Tree Transformations: A Linguistic Approach to the View-update Problem}, - journal = {ACM Trans. Program. Lang. Syst.}, - issue_date = {May 2007}, - volume = {29}, - number = {3}, - month = may, - year = {2007}, - issn = {0164-0925}, - articleno = {17}, - url = {http://doi.acm.org/10.1145/1232420.1232424}, - doi = {10.1145/1232420.1232424}, - acmid = {1232424}, - publisher = {ACM}, - address = {New York, NY, USA}, - keywords = {Bidirectional programming, Harmony, XML, lenses, view update problem}, -} - -@InProceedings{Fischer2015, -author="Fischer, S. and Hu, Z. and Pacheco, H.", -title="A Clear Picture of Lens Laws", -booktitle="MPC 2015", -year="2015", -publisher="Springer", -pages="215--223", -} - -@article{Gibbons17, - title = "Profunctor Optics: Modular Data Accessors", - author = "Matthew Pickering and Jeremy Gibbons and Nicolas Wu", - year = "2017", - journal = "The Art, Science, and Engineering of Programming", - number = "2", - publisher = "AOSA", - url = "http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf", - volume = "1", -} diff --git a/thys/Clean/examples/IsPrime.thy b/thys/Clean/examples/IsPrime.thy --- a/thys/Clean/examples/IsPrime.thy +++ b/thys/Clean/examples/IsPrime.thy @@ -1,109 +1,110 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* * IsPrime-Test * * Authors : Burkhart Wolff, Frédéric Tuong *) chapter \ Clean Semantics : Another Clean Example\ theory IsPrime imports Clean.Clean Clean.Hoare_Clean Clean.Clean_Symbex "HOL-Computational_Algebra.Primes" begin section\The Primality-Test Example at a Glance\ definition "SQRT_UINT_MAX = (65536::nat)" definition "UINT_MAX = (2^32::nat) - 1" function_spec isPrime(n :: nat) returns bool pre "\n \ SQRT_UINT_MAX\" post "\\res. res \ prime n \" local_vars i :: nat defines " if\<^sub>C \n < 2\ then return\<^bsub>local_isPrime_state.result_value_update\<^esub> \False\ else skip\<^sub>S\<^sub>E fi ;- \i := 2\ ;- while\<^sub>C \i < SQRT_UINT_MAX \ i*i \ n \ do if\<^sub>C \n mod i = 0\ then return\<^bsub>local_isPrime_state.result_value_update\<^esub> \False\ else skip\<^sub>S\<^sub>E fi ;- \i := i + 1 \ od ;- return\<^bsub>local_isPrime_state.result_value_update\<^esub> \True\" find_theorems name:isPrime name:core - +term\isPrime_core\ + lemma XXX : "isPrime_core n \ if\<^sub>C (\\. n < 2) then (return\<^bsub>result_value_update\<^esub> (\\. False)) else skip\<^sub>S\<^sub>E fi;- i_update :==\<^sub>L (\\. 2) ;- while\<^sub>C (\\. (hd\i)\ < SQRT_UINT_MAX \ (hd\i)\ * (hd\i)\ \ n) do (if\<^sub>C (\\. n mod (hd \ i) \ = 0) then (return\<^bsub>result_value_update\<^esub> (\\. False)) else skip\<^sub>S\<^sub>E fi ;- i_update :==\<^sub>L (\\. (hd \ i) \ + 1)) od ;- return\<^bsub>result_value_update\<^esub> (\\. True)" by(simp add: isPrime_core_def) lemma YYY: "isPrime n \ block\<^sub>C push_local_isPrime_state (isPrime_core n) pop_local_isPrime_state" by(simp add: isPrime_def) lemma isPrime_correct : "\\\. \ \ \ isPrime_pre (n)(\) \ \ = \\<^sub>p\<^sub>r\<^sub>e \ isPrime n \\r \. \ \ \ isPrime_post(n) (\\<^sub>p\<^sub>r\<^sub>e)(\)(r) \" oops end diff --git a/thys/Clean/examples/LinearSearch.thy b/thys/Clean/examples/LinearSearch.thy --- a/thys/Clean/examples/LinearSearch.thy +++ b/thys/Clean/examples/LinearSearch.thy @@ -1,105 +1,110 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* * Authors : Burkhart Wolff, Frédéric Tuong *) chapter \ A Clean Semantics Example : Linear Search\ text\The following show-case introduces subsequently a non-trivial example involving local and global variable declarations, declarations of operations with pre-post conditions as well as direct-recursive operations (i.e. C-like functions with side-effects on global and local variables. \ theory LinearSearch imports Clean.Clean Clean.Hoare_MonadSE begin section\The LinearSearch Example\ definition bool2int where "bool2int x = (if x then 1::int else 0)" -global_vars state +global_vars (state) t :: "int list" +global_vars ("2") + tt :: "int list" + +find_theorems (160) name:"2" name:"Linear" + function_spec linearsearch (x::int, n::int) returns int pre "\ 0 \ n \ n < int(length t) \ sorted t\" post "\\res::int. res = bool2int (\ i \ {0 ..< length t}. t!i = x) \" local_vars i :: int -defines " \i := 0 \ ;- +defines " \i := 0 \ ;- \tt := [] \;- while\<^sub>C \i < n \ do if\<^sub>C \t ! (nat i) < x\ then \i := i + 1 \ else return\<^sub>C result_value_update \bool2int(t!(nat i) = x)\ fi od " (* C\ /*@ requires "n >= 0" requires "valid(t+(0..n-1))" requires "(forall integer i,j; 0<=i<=j t[i] <= t[j])" ensures "exists integer i; (0<=i result == 1" ensures "(forall integer i; 0<=i t[i] != x) <==> result == 0" assigns nothing */ int linearsearch(int x, int t[], int n) { int i = 0; /*@ loop invariant "0<=i<=n" loop invariant "forall integer j; 0<=j (t[j] != x)" loop assigns i loop variant "n-i" */ while (i < n) { if (t[i] < x) { i++; } else { return (t[i] == x); } } return 0; } \ *) end \ No newline at end of file diff --git a/thys/Clean/examples/Quicksort.thy b/thys/Clean/examples/Quicksort.thy --- a/thys/Clean/examples/Quicksort.thy +++ b/thys/Clean/examples/Quicksort.thy @@ -1,150 +1,150 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* * Quicksort : all at a glance. * * Authors : Burkhart Wolff, Frédéric Tuong *) chapter \ Clean Semantics : A Coding-Concept Example\ text\The following show-case introduces subsequently a non-trivial example involving local and global variable declarations, declarations of operations with pre-post conditions as well as direct-recursive operations (i.e. C-like functions with side-effects on global and local variables. \ theory Quicksort imports Clean.Clean Clean.Hoare_Clean Clean.Clean_Symbex begin section\The Quicksort Example - At a Glance\ text\ We present the following quicksort algorithm in some conceptual, high-level notation: \begin{isar} algorithm (A,i,j) = tmp := A[i]; A[i]:=A[j]; A[j]:=tmp algorithm partition(A, lo, hi) is pivot := A[hi] i := lo for j := lo to hi - 1 do if A[j] < pivot then swap A[i] with A[j] i := i + 1 swap A[i] with A[hi] return i algorithm quicksort(A, lo, hi) is if lo < hi then p := partition(A, lo, hi) quicksort(A, lo, p - 1) quicksort(A, p + 1, hi) \end{isar} \ section\Clean Encoding of the Global State of Quicksort\ -global_vars state +global_vars (state) A :: "int list" function_spec swap (i::nat,j::nat) \ \TODO: the hovering on parameters produces a number of report equal to the number of \<^ML>\Proof_Context.add_fixes\ called in \<^ML>\Function_Specification_Parser.checkNsem_function_spec\\ pre "\i < length A \ j < length A\" post "\\res. length A = length(old A) \ res = ()\" local_vars tmp :: int defines " \ tmp := A ! i\ ;- \ A := list_update A i (A ! j)\ ;- \ A := list_update A j tmp\ " function_spec partition (lo::nat, hi::nat) returns nat pre "\lo < length A \ hi < length A\" post "\\res::nat. length A = length(old A) \ res = 3\" local_vars pivot :: int i :: nat j :: nat defines " \pivot := A ! hi \ ;- \i := lo \ ;- \j := lo \ ;- while\<^sub>C \j \ hi - 1 \ do if\<^sub>C \A ! j < pivot\ then call\<^sub>C swap \(i , j) \ ;- \i := i + 1 \ else skip\<^sub>S\<^sub>E fi ;- \j := j + 1 \ od;- call\<^sub>C swap \(i, j)\ ;- return\<^bsub>local_partition_state.result_value_update\<^esub> \i\" thm partition_core_def rec_function_spec quicksort (lo::nat, hi::nat) returns unit pre "\lo \ hi \ hi < length A\" post "\\res::unit. \i\{lo .. hi}. \j\{lo .. hi}. i \ j \ A!i \ A!j\" variant "hi - lo" local_vars p :: "nat" defines " if\<^sub>C \lo < hi\ then (p\<^sub>t\<^sub>m\<^sub>p \ call\<^sub>C partition \(lo, hi)\ ; assign_local p_update (\\. p\<^sub>t\<^sub>m\<^sub>p)) ;- call\<^sub>C quicksort \(lo, p - 1)\ ;- call\<^sub>C quicksort \(lo, p + 1)\ else skip\<^sub>S\<^sub>E fi" thm quicksort_core_def thm quicksort_def thm quicksort_pre_def thm quicksort_post_def section\Possible Application Sketch\ lemma quicksort_correct : "\\\. \ \ \ quicksort_pre (lo, hi)(\) \ \ = \\<^sub>p\<^sub>r\<^sub>e \ quicksort (lo, hi) \\r \. \ \ \ quicksort_post(lo, hi)(\\<^sub>p\<^sub>r\<^sub>e)(\)(r) \" oops end diff --git a/thys/Clean/examples/Quicksort_concept.thy b/thys/Clean/examples/Quicksort_concept.thy --- a/thys/Clean/examples/Quicksort_concept.thy +++ b/thys/Clean/examples/Quicksort_concept.thy @@ -1,531 +1,548 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* * Quicksort Concept * * Authors : Burkhart Wolff, Frédéric Tuong *) chapter \ Clean Semantics : A Coding-Concept Example\ text\The following show-case introduces subsequently a non-trivial example involving local and global variable declarations, declarations of operations with pre-post conditions as well as direct-recursive operations (i.e. C-like functions with side-effects on global and local variables. \ theory Quicksort_concept imports Clean.Clean Clean.Hoare_Clean Clean.Clean_Symbex begin section\The Quicksort Example\ text\ We present the following quicksort algorithm in some conceptual, high-level notation: \begin{isar} algorithm (A,i,j) = tmp := A[i]; A[i]:=A[j]; A[j]:=tmp algorithm partition(A, lo, hi) is pivot := A[hi] i := lo for j := lo to hi - 1 do if A[j] < pivot then swap A[i] with A[j] i := i + 1 swap A[i] with A[hi] return i algorithm quicksort(A, lo, hi) is if lo < hi then p := partition(A, lo, hi) quicksort(A, lo, p - 1) quicksort(A, p + 1, hi) \end{isar} \ text\In the following, we will present the Quicksort program alternatingly in Clean high-level notation and simulate its effect by an alternative formalisation representing the semantic effects of the high-level notation on a step-buy-step basis. Note that Clean does not posses the concept of call-by-reference parameters; consequently, the algorithm must be specialized to a variant where @{term A} is just a global variable.\ section\Clean Encoding of the Global State of Quicksort\ text\We demonstrate the accumulating effect of some key Clean commands by highlighting the changes of Clean's state-management module state. At the beginning, the state-type of the Clean state management is just the type of the @{typ "'a Clean.control_state.control_state_ext"}, while the table of global and local variables is empty.\ ML\ val Type(s,t) = StateMgt_core.get_state_type_global @{theory}; StateMgt_core.get_state_field_tab_global @{theory}; \ text\The \global_vars\ command, described and defined in \<^verbatim>\Clean.thy\, declares the global variable \<^verbatim>\A\. This has the following effect:\ -global_vars state + +global_vars (S) A :: "int list" +ML\ +(fst o StateMgt_core.get_data_global) @{theory} +\ +global_vars (S2) + B :: "int list" + + +ML\ +(Int.toString o length o Symtab.dest o fst o StateMgt_core.get_data_global) @{theory} +\ + +find_theorems (60) name:global_state2_state find_theorems create\<^sub>L name:"Quick" text\... which is reflected in Clean's state-management table:\ -ML\ val Type("Quicksort_concept.global_state_state_scheme",t) +ML\ val Type("Quicksort_concept.global_S2_state_scheme",t) = StateMgt_core.get_state_type_global @{theory}; - StateMgt_core.get_state_field_tab_global @{theory}\ + (Int.toString o length o Symtab.dest)(StateMgt_core.get_state_field_tab_global @{theory})\ text\Note that the state-management uses long-names for complete disambiguation.\ subsubsection\A Simulation of Synthesis of Typed Assignment-Rules\ -definition A\<^sub>L' where "A\<^sub>L' \ create\<^sub>L global_state_state.A global_state_state.A_update" +definition A\<^sub>L' where "A\<^sub>L' \ create\<^sub>L global_S_state.A global_S_state.A_update" lemma A\<^sub>L'_control_indep : "(break_status\<^sub>L \ A\<^sub>L' \ return_status\<^sub>L \ A\<^sub>L')" unfolding A\<^sub>L'_def break_status\<^sub>L_def return_status\<^sub>L_def create\<^sub>L_def upd2put_def by (simp add: lens_indep_def) lemma A\<^sub>L'_strong_indep : "\! A\<^sub>L'" unfolding strong_control_independence_def using A\<^sub>L'_control_indep by blast text\Specialized Assignment Rule for Global Variable \A\. Note that this specialized rule of @{thm assign_global} does not need any further side-conditions referring to independence from the control. Consequently, backward inference in an \wp\-calculus will just maintain the invariant @{term \\ exec_stop \\}.\ lemma assign_global_A: "\\\. \ \ \ P (\\A := rhs \\)\ A_update :==\<^sub>G rhs \\r \. \ \ \ P \ \" apply(rule assign_global) - apply(rule strong_vs_weak_upd [of global_state_state.A global_state_state.A_update]) + apply(rule strong_vs_weak_upd [of global_S_state.A global_S_state.A_update]) apply (metis A\<^sub>L'_def A\<^sub>L'_strong_indep) by(rule ext, rule ext, auto) section \Encoding swap in Clean\ subsection \\<^verbatim>\swap\ in High-level Notation\ text\Unfortunately, the name \result\ is already used in the logical context; we use local binders instead.\ definition "i = ()" \ \check that \<^term>\i\ can exist as a constant with an arbitrary type before treating \<^theory_text>\function_spec\\ definition "j = ()" \ \check that \<^term>\j\ can exist as a constant with an arbitrary type before treating \<^theory_text>\function_spec\\ function_spec swap (i::nat,j::nat) \ \TODO: the hovering on parameters produces a number of report equal to the number of \<^ML>\Proof_Context.add_fixes\ called in \<^ML>\Function_Specification_Parser.checkNsem_function_spec\\ pre "\i < length A \ j < length A\" post "\\res. length A = length(old A) \ res = ()\" local_vars tmp :: int defines " \ tmp := A ! i\ ;- \ A := list_update A i (A ! j)\ ;- \ A := list_update A j tmp\ " value "\break_status = False, return_status = False, A = [1,2,3], tmp = [], result_value = [], \ = X\" -value "swap (0,1) \break_status = False, return_status = False, A = [1,2,3], +term swap + +find_theorems (70) name:"local_swap_state" + +value "swap (0,1) \break_status = False, return_status = False, A = [1,2,3], B=[], tmp = [], result_value = [],\ = X\" text\The body --- heavily using the \\\-lifting cartouche --- corresponds to the low level term: \ text\ @{cartouche [display=true] \\defines " ((assign_local tmp_update (\\. (A \) ! i )) ;- (assign_global A_update (\\. list_update (A \) (i) (A \ ! j))) ;- (assign_global A_update (\\. list_update (A \) (j) ((hd o tmp) \))))"\\}\ text\The effect of this statement is generation of the following definitions in the logical context:\ term "(i, j)" \ \check that \<^term>\i\ and \<^term>\j\ are pointing to the constants defined before treating \<^theory_text>\function_spec\\ thm push_local_swap_state_def thm pop_local_swap_state_def thm swap_pre_def thm swap_post_def thm swap_core_def thm swap_def text\The state-management is in the following configuration:\ ML\ val Type(s,t) = StateMgt_core.get_state_type_global @{theory}; StateMgt_core.get_state_field_tab_global @{theory}\ subsection \A Similation of \<^verbatim>\swap\ in elementary specification constructs:\ text\Note that we prime identifiers in order to avoid confusion with the definitions of the previous section. The pre- and postconditions are just definitions of the following form:\ -definition swap'_pre :: " nat \ nat \ 'a global_state_state_scheme \ bool" +definition swap'_pre :: " nat \ nat \ 'a global_S_state_scheme \ bool" where "swap'_pre \ \(i, j) \. i < length (A \) \ j < length (A \)" -definition swap'_post :: "'a \ 'b \ 'c global_state_state_scheme \ 'd global_state_state_scheme \ unit \ bool" +definition swap'_post :: "'a \ 'b \ 'c global_S_state_scheme \ 'd global_S_state_scheme \ unit \ bool" where "swap'_post \ \(i, j) \\<^sub>p\<^sub>r\<^sub>e \ res. length (A \) = length (A \\<^sub>p\<^sub>r\<^sub>e) \ res = ()" text\The somewhat vacuous parameter \res\ for the result of the swap-computation is the conseqeuence of the implicit definition of the return-type as @{typ "unit"}\ text\We simulate the effect of the local variable space declaration by the following command factoring out the functionality into the command \local_vars_test\ \ -local_vars_test swap' "unit" +local_vars_test (swap' "unit") tmp :: "int" text\The immediate effect of this command on the internal Clean State Management can be made explicit as follows: \ ML\ val Type(s,t) = StateMgt_core.get_state_type_global @{theory}; val tab = StateMgt_core.get_state_field_tab_global @{theory}; @{term "A::('a local_swap_state_scheme\ int list)"}\ text\This has already the effect of the definition:\ thm push_local_swap_state_def thm pop_local_swap_state_def text\Again, we simulate the effect of this command by more elementary \HOL specification constructs:\ (* Thus, the internal functionality in \local_vars\ is the construction of the two definitions *) definition push_local_swap_state' :: "(unit,'a local_swap'_state_scheme) MON\<^sub>S\<^sub>E" where "push_local_swap_state' \ = Some((),\\local_swap'_state.tmp := undefined # local_swap'_state.tmp \ \)" definition pop_local_swap_state' :: "(unit,'a local_swap'_state_scheme) MON\<^sub>S\<^sub>E" where "pop_local_swap_state' \ = Some(hd(local_swap_state.result_value \), \ \ recall : returns op value \ \ \ which happens to be unit \ \\local_swap_state.tmp:= tl( local_swap_state.tmp \) \)" definition swap'_core :: "nat \ nat \ (unit,'a local_swap'_state_scheme) MON\<^sub>S\<^sub>E" where "swap'_core \ (\(i,j). ((assign_local tmp_update (\\. A \ ! i )) ;- (assign_global A_update (\\. list_update (A \) (i) (A \ ! j))) ;- (assign_global A_update (\\. list_update (A \) (j) ((hd o tmp) \)))))" text\ a block manages the "dynamically" created fresh instances for the local variables of swap \ definition swap' :: "nat \ nat \ (unit,'a local_swap'_state_scheme) MON\<^sub>S\<^sub>E" where "swap' \ \(i,j). block\<^sub>C push_local_swap_state' (swap_core (i,j)) pop_local_swap_state'" text\NOTE: If local variables were only used in single-assignment style, it is possible to drastically simplify the encoding. These variables were not stored in the state, just kept as part of the monadic calculation. The simplifications refer both to calculation as well as well as symbolic execution and deduction.\ text\The could be represented by the following alternative, optimized version :\ -definition swap_opt :: "nat \ nat \ (unit,'a global_state_state_scheme) MON\<^sub>S\<^sub>E" +definition swap_opt :: "nat \ nat \ (unit,'a global_S_state_scheme) MON\<^sub>S\<^sub>E" where "swap_opt \ \(i,j). (tmp \ yield\<^sub>C (\\. A \ ! i) ; ((assign_global A_update (\\. list_update (A \) (i) (A \ ! j))) ;- (assign_global A_update (\\. list_update (A \) (j) (tmp)))))" text\In case that all local variables are single-assigned in swap, the entire local var definition could be ommitted.\ text\A more pretty-printed term representation is:\ term\ swap_opt = (\(i, j). tmp \ (yield\<^sub>C (\\. A \ ! i)); (A_update :==\<^sub>G (\\. (A \)[i := A \ ! j]) ;- A_update :==\<^sub>G (\\. (A \)[j := tmp])))\ subsubsection\A Simulation of Synthesis of Typed Assignment-Rules\ definition tmp\<^sub>L where "tmp\<^sub>L \ create\<^sub>L local_swap'_state.tmp local_swap'_state.tmp_update" lemma tmp\<^sub>L_control_indep : "(break_status\<^sub>L \ tmp\<^sub>L \ return_status\<^sub>L \ tmp\<^sub>L)" unfolding tmp\<^sub>L_def break_status\<^sub>L_def return_status\<^sub>L_def create\<^sub>L_def upd2put_def by (simp add: lens_indep_def) lemma tmp\<^sub>L_strong_indep : "\! tmp\<^sub>L" unfolding strong_control_independence_def using tmp\<^sub>L_control_indep by blast text\Specialized Assignment Rule for Local Variable \tmp\. Note that this specialized rule of @{thm assign_local} does not need any further side-conditions referring to independence from the control. Consequently, backward inference in an \wp\-calculus will just maintain the invariant @{term \\ \\}.\ lemma assign_local_tmp: "\\\. \ \ \ P ((tmp_update \ upd_hd) (\_. rhs \) \)\ local_swap'_state.tmp_update :==\<^sub>L rhs \\r \. \ \ \ P \ \" apply(rule assign_local) apply(rule strong_vs_weak_upd_list) apply(rule tmp\<^sub>L_strong_indep[simplified tmp\<^sub>L_def]) by(rule ext, rule ext, auto) section \Encoding \<^verbatim>\partition\ in Clean\ subsection \\<^verbatim>\partition\ in High-level Notation\ function_spec partition (lo::nat, hi::nat) returns nat pre "\lo < length A \ hi < length A\" post "\\res::nat. length A = length(old A) \ res = 3\" local_vars pivot :: int i :: nat j :: nat defines " \pivot := A ! hi \ ;- \i := lo \ ;- \j := lo \ ;- (while\<^sub>C \j \ hi - 1 \ do (if\<^sub>C \A ! j < pivot\ then call\<^sub>C swap \(i , j) \ ;- \i := i + 1 \ else skip\<^sub>S\<^sub>E fi) ;- \j := j + 1 \ od) ;- call\<^sub>C swap \(i, j)\ ;- return\<^sub>C result_value_update \i\" text\ The body is a fancy syntax for : @{cartouche [display=true] \\defines " ((assign_local pivot_update (\\. A \ ! hi )) ;- (assign_local i_update (\\. lo )) ;- (assign_local j_update (\\. lo )) ;- (while\<^sub>C (\\. (hd o j) \ \ hi - 1 ) do (if\<^sub>C (\\. A \ ! (hd o j) \ < (hd o pivot)\ ) then call\<^sub>C (swap) (\\. ((hd o i) \, (hd o j) \)) ;- assign_local i_update (\\. ((hd o i) \) + 1) else skip\<^sub>S\<^sub>E fi) ;- (assign_local j_update (\\. ((hd o j) \) + 1)) od) ;- call\<^sub>C (swap) (\\. ((hd o i) \, (hd o j) \)) ;- assign_local result_value_update (\\. (hd o i) \) \ \ the meaning of the return stmt \ ) "\\}\ text\The effect of this statement is generation of the following definitions in the logical context:\ thm partition_pre_def thm partition_post_def thm push_local_partition_state_def thm pop_local_partition_state_def thm partition_core_def thm partition_def text\The state-management is in the following configuration:\ ML\ val Type(s,t) = StateMgt_core.get_state_type_global @{theory}; StateMgt_core.get_state_field_tab_global @{theory}\ subsection \A Similation of \<^verbatim>\partition\ in elementary specification constructs:\ subsubsection \Contract-Elements\ definition "partition'_pre \ \(lo, hi) \. lo < length (A \) \ hi < length (A \)" definition "partition'_post \ \(lo, hi) \\<^sub>p\<^sub>r\<^sub>e \ res. length (A \) = length (A \\<^sub>p\<^sub>r\<^sub>e) \ res = 3" subsubsection\Memory-Model\ text\Recall: list-lifting is automatic in \local_vars_test\:\ -local_vars_test partition' "nat" +local_vars_test (partition' "nat") pivot :: "int" i :: "nat" j :: "nat" text\ ... which results in the internal definition of the respective push and pop operations for the @{term "partition'"} local variable space: \ thm push_local_partition'_state_def thm pop_local_partition'_state_def (* equivalent to *) definition push_local_partition_state' :: "(unit, 'a local_partition'_state_scheme) MON\<^sub>S\<^sub>E" where "push_local_partition_state' \ = Some((), \\local_partition_state.pivot := undefined # local_partition_state.pivot \, local_partition_state.i := undefined # local_partition_state.i \, local_partition_state.j := undefined # local_partition_state.j \, local_partition_state.result_value := undefined # local_partition_state.result_value \ \)" definition pop_local_partition_state' :: "(nat,'a local_partition_state_scheme) MON\<^sub>S\<^sub>E" where "pop_local_partition_state' \ = Some(hd(local_partition_state.result_value \), \\local_partition_state.pivot := tl(local_partition_state.pivot \), local_partition_state.i := tl(local_partition_state.i \), local_partition_state.j := tl(local_partition_state.j \), local_partition_state.result_value := tl(local_partition_state.result_value \) \)" subsubsection\Memory-Model\ text\Independence of Control-Block:\ subsubsection\Monadic Representation of the Body\ definition partition'_core :: "nat \ nat \ (unit,'a local_partition'_state_scheme) MON\<^sub>S\<^sub>E" where "partition'_core \ \(lo,hi). ((assign_local pivot_update (\\. A \ ! hi )) ;- (assign_local i_update (\\. lo )) ;- (assign_local j_update (\\. lo )) ;- (while\<^sub>C (\\. (hd o j) \ \ hi - 1 ) do (if\<^sub>C (\\. A \ ! (hd o j) \ < (hd o pivot)\ ) then call\<^sub>C (swap) (\\. ((hd o i) \, (hd o j) \)) ;- assign_local i_update (\\. ((hd o i) \) + 1) else skip\<^sub>S\<^sub>E fi) od) ;- (assign_local j_update (\\. ((hd o j) \) + 1)) ;- call\<^sub>C (swap) (\\. ((hd o i) \, (hd o j) \)) ;- assign_local result_value_update (\\. (hd o i) \) \ \ the meaning of the return stmt \ )" thm partition_core_def (* a block manages the "dynamically" created fresh instances for the local variables of swap *) definition partition' :: "nat \ nat \ (nat,'a local_partition'_state_scheme) MON\<^sub>S\<^sub>E" where "partition' \ \(lo,hi). block\<^sub>C push_local_partition_state (partition_core (lo,hi)) pop_local_partition_state" section \Encoding the toplevel : \<^verbatim>\quicksort\ in Clean\ subsection \\<^verbatim>\quicksort\ in High-level Notation\ rec_function_spec quicksort (lo::nat, hi::nat) returns unit pre "\lo \ hi \ hi < length A\" post "\\res::unit. \i\{lo .. hi}. \j\{lo .. hi}. i \ j \ A!i \ A!j\" variant "hi - lo" local_vars p :: "nat" defines " if\<^sub>C \lo < hi\ then (p\<^sub>t\<^sub>m\<^sub>p \ call\<^sub>C partition \(lo, hi)\ ; assign_local p_update (\\. p\<^sub>t\<^sub>m\<^sub>p)) ;- call\<^sub>C quicksort \(lo, p - 1)\ ;- call\<^sub>C quicksort \(lo, p + 1)\ else skip\<^sub>S\<^sub>E fi" thm quicksort_core_def thm quicksort_def thm quicksort_pre_def thm quicksort_post_def subsection \A Similation of \<^verbatim>\quicksort\ in elementary specification constructs:\ text\This is the most complex form a Clean function may have: it may be directly recursive. Two subcases are to be distinguished: either a measure is provided or not.\ text\We start again with our simulation: First, we define the local variable \p\.\ -local_vars_test quicksort' "unit" +local_vars_test (quicksort' "unit") p :: "nat" ML\ val (x,y) = StateMgt_core.get_data_global @{theory}; \ thm pop_local_quicksort'_state_def thm push_local_quicksort'_state_def (* this implies the definitions : *) definition push_local_quicksort_state' :: "(unit, 'a local_quicksort'_state_scheme) MON\<^sub>S\<^sub>E" where "push_local_quicksort_state' \ = Some((), \\local_quicksort'_state.p := undefined # local_quicksort'_state.p \, local_quicksort'_state.result_value := undefined # local_quicksort'_state.result_value \ \)" definition pop_local_quicksort_state' :: "(unit,'a local_quicksort'_state_scheme) MON\<^sub>S\<^sub>E" where "pop_local_quicksort_state' \ = Some(hd(local_quicksort'_state.result_value \), \\local_quicksort'_state.p := tl(local_quicksort'_state.p \), local_quicksort'_state.result_value := tl(local_quicksort'_state.result_value \) \)" text\We recall the structure of the direct-recursive call in Clean syntax: @{cartouche [display=true] \ funct quicksort(lo::int, hi::int) returns unit pre "True" post "True" local_vars p :: int \if\<^sub>C\<^sub>L\<^sub>E\<^sub>A\<^sub>N \lo < hi\ then p := partition(lo, hi) ;- quicksort(lo, p - 1) ;- quicksort(p + 1, hi) else Skip\ \} \ definition quicksort'_pre :: "nat \ nat \ 'a local_quicksort'_state_scheme \ bool" where "quicksort'_pre \ \(i,j). \\. True " definition quicksort'_post :: "nat \ nat \ unit \ 'a local_quicksort'_state_scheme \ bool" where "quicksort'_post \ \(i,j). \ res. \\. True" definition quicksort'_core :: " (nat \ nat \ (unit,'a local_quicksort'_state_scheme) MON\<^sub>S\<^sub>E) \ (nat \ nat \ (unit,'a local_quicksort'_state_scheme) MON\<^sub>S\<^sub>E)" where "quicksort'_core quicksort_rec \ \(lo, hi). ((if\<^sub>C (\\. lo < hi ) then (p\<^sub>t\<^sub>m\<^sub>p \ call\<^sub>C partition (\\. (lo, hi)) ; assign_local p_update (\\. p\<^sub>t\<^sub>m\<^sub>p)) ;- call\<^sub>C quicksort_rec (\\. (lo, (hd o p) \ - 1)) ;- call\<^sub>C quicksort_rec (\\. ((hd o p) \ + 1, hi)) else skip\<^sub>S\<^sub>E fi))" term " ((quicksort'_core X) (lo,hi))" definition quicksort' :: " ((nat \ nat) \ (nat \ nat)) set \ (nat \ nat \ (unit,'a local_quicksort'_state_scheme) MON\<^sub>S\<^sub>E)" where "quicksort' order \ wfrec order (\X. \(lo, hi). block\<^sub>C push_local_quicksort'_state (quicksort'_core X (lo,hi)) pop_local_quicksort'_state)" subsection\Setup for Deductive Verification\ text\The coupling between the pre- and the post-condition state is done by the free variable (serving as a kind of ghost-variable) @{term "\\<^sub>p\<^sub>r\<^sub>e"}. This coupling can also be used to express framing conditions; i.e. parts of the state which are independent and/or not affected by the computations to be verified. \ lemma quicksort_correct : "\\\. \ \ \ quicksort_pre (lo, hi)(\) \ \ = \\<^sub>p\<^sub>r\<^sub>e \ quicksort (lo, hi) \\r \. \ \ \ quicksort_post(lo, hi)(\\<^sub>p\<^sub>r\<^sub>e)(\)(r) \" oops end diff --git a/thys/Clean/examples/SquareRoot_concept.thy b/thys/Clean/examples/SquareRoot_concept.thy --- a/thys/Clean/examples/SquareRoot_concept.thy +++ b/thys/Clean/examples/SquareRoot_concept.thy @@ -1,235 +1,235 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* * SquareRoot_concept --- Example of monadic symbolic execution for a WHILE program. * Burkhart Wolff and Chantal Keller, LRI, Univ. Paris-Sud, France *) section \ The Squareroot Example for Symbolic Execution \ theory SquareRoot_concept imports Clean.Test_Clean begin subsection\ The Conceptual Algorithm in Clean Notation\ text\ In high-level notation, the algorithm we are investigating looks like this: @{cartouche [display=true] \\ function_spec sqrt (a::int) returns int pre "\0 \ a\" post "\\res::int. (res + 1)\<^sup>2 > a \ a \ (res)\<^sup>2\" defines " (\tm := 1\ ;- \sqsum := 1\ ;- \i := 0\ ;- (while\<^sub>S\<^sub>E \sqsum <= a\ do \i := i+1\ ;- \tm := tm + 2\ ;- \sqsum := tm + sqsum\ od) ;- return\<^sub>C result_value_update \i\ )" \\} \ subsection\ Definition of the Global State \ text\The state is just a record; and the global variables correspond to fields in this record. This corresponds to typed, structured, non-aliasing states. Note that the types in the state can be arbitrary HOL-types - want to have sets of functions in a ghost-field ? No problem ! \ text\ The state of the square-root program looks like this : \ typ "Clean.control_state" ML\ val Type(s,t) = StateMgt_core.get_state_type_global @{theory} val Type(u,v) = @{typ unit} \ (* could also be local variable, we flipped a coin and it became this way *) -global_vars state +global_vars (state) tm :: int i :: int sqsum :: int ML\ val Type(s,t) = StateMgt_core.get_state_type_global @{theory} val Type(u,v) = @{typ unit} \ (* should be automatic *) lemma tm_independent [simp]: "\ tm_update" unfolding control_independence_def by auto lemma i_independent [simp]: "\ i_update" unfolding control_independence_def by auto lemma sqsum_independent [simp]: "\ sqsum_update" unfolding control_independence_def by auto subsection\ Setting for Symbolic Execution \ text\ Some lemmas to reason about memory\ lemma tm_simp : "tm (\\tm := t\) = t" using [[simp_trace]] by simp (* from trace: [1]Procedure "record" produced rewrite rule: tm (?r\tm := ?k\) \ ?k Unfortunately, this lemma is not exported ... It looks as if it is computed on the fly ... This could explain why this is slow for our purposes ... *) lemma tm_simp1 : "tm (\\sqsum := s\) = tm \" by simp lemma tm_simp2 : "tm (\\i := s\) = tm \" by simp lemma sqsum_simp : "sqsum (\\sqsum := s\) = s" by simp lemma sqsum_simp1 : "sqsum (\\tm := t\) = sqsum \" by simp lemma sqsum_simp2 : "sqsum (\\i := t\) = sqsum \" by simp lemma i_simp : "i (\\i := i'\) = i'" by simp lemma i_simp1 : "i (\\tm := i'\) = i \" by simp lemma i_simp2 : "i (\\sqsum := i'\) = i \" by simp lemmas memory_theory = tm_simp tm_simp1 tm_simp2 sqsum_simp sqsum_simp1 sqsum_simp2 i_simp i_simp1 i_simp2 declare memory_theory [memory_theory] lemma non_exec_assign_globalD': assumes "\ upd" shows "\ \ upd :==\<^sub>G rhs ;- M \ \ \ \ upd (\_. rhs \) \ \ M" apply(drule non_exec_assign_global'[THEN iffD1]) using assms exec_stop_vs_control_independence apply blast by auto lemmas non_exec_assign_globalD'_tm = non_exec_assign_globalD'[OF tm_independent] lemmas non_exec_assign_globalD'_i = non_exec_assign_globalD'[OF i_independent] lemmas non_exec_assign_globalD'_sqsum = non_exec_assign_globalD'[OF sqsum_independent] text\ Now we run a symbolic execution. We run match-tactics (rather than the Isabelle simplifier which would do the trick as well) in order to demonstrate a symbolic execution in Isabelle. \ subsection\ A Symbolic Execution Simulation \ lemma assumes non_exec_stop[simp]: "\ exec_stop \\<^sub>0" and pos : "0 \ (a::int)" and annotated_program: "\\<^sub>0 \ \tm := 1\ ;- \sqsum := 1\ ;- \i := 0\ ;- (while\<^sub>S\<^sub>E \sqsum <= a\ do \i := i+1\ ;- \tm := tm + 2\ ;- \sqsum := tm + sqsum\ od) ;- assert\<^sub>S\<^sub>E(\\. \=\\<^sub>R)" shows "\\<^sub>R \assert\<^sub>S\<^sub>E \i\<^sup>2 \ a \ a < (i + 1)\<^sup>2\ " apply(insert annotated_program) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_tm\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_sqsum\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_i\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"exec_whileD\"}] 1") apply(tactic "ematch_tac @{context} [@{thm \"if_SE_execE''\"}] 1") apply(simp_all only: memory_theory MonadSE.bind_assoc') apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_i\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_tm\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_sqsum\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"exec_whileD\"}] 1") apply(tactic "ematch_tac @{context} [@{thm \"if_SE_execE''\"}] 1") apply(simp_all only: memory_theory MonadSE.bind_assoc') apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_i\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_tm\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_sqsum\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"exec_whileD\"}] 1") apply(tactic "ematch_tac @{context} [@{thm \"if_SE_execE''\"}] 1") apply(simp_all only: memory_theory MonadSE.bind_assoc') apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_i\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_tm\"}] 1",simp) apply(tactic "dmatch_tac @{context} [@{thm \"non_exec_assign_globalD'_sqsum\"}] 1",simp) apply(simp_all) text\Here are all abstract test-cases explicit. Each subgoal correstponds to a path taken through the loop.\ txt\push away the test-hyp: postcond is true for programs with more than three loop traversals (criterion: all-paths(k). This reveals explicitly the three test-cases for @{term "k<3"}. \ defer 1 (* txt\Instead of testing, we @{emph \prove\} that the test cases satisfy the post-condition for all @{term "k<3"} loop traversals and @{emph \all\} positive inputs @{term "a "}.\ apply(auto simp: assert_simp) *) oops text\TODO: re-establish automatic test-coverage tactics of \<^cite>\"DBLP:conf/tap/Keller18"\.\ end diff --git a/thys/Clean/src/Clean.thy b/thys/Clean/src/Clean.thy --- a/thys/Clean/src/Clean.thy +++ b/thys/Clean/src/Clean.thy @@ -1,1425 +1,1518 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* * Clean --- a basic abstract ("shallow") programming language for test and proof. * Burkhart Wolff and Frédéric Tuong, LRI, Univ. Paris-Saclay, France *) chapter \The Clean Language\ theory Clean imports Optics Symbex_MonadSE keywords "global_vars" "local_vars_test" :: thy_decl and "returns" "pre" "post" "local_vars" "variant" and "function_spec" :: thy_decl and "rec_function_spec" :: thy_decl begin text\Clean (pronounced as: ``C lean'' or ``Céline'' [selin]) is a minimalistic imperative language with C-like control-flow operators based on a shallow embedding into the ``State Exception Monads'' theory formalized in \<^file>\MonadSE.thy\. It strives for a type-safe notation of program-variables, an incremental construction of the typed state-space in order to facilitate incremental verification and open-world extensibility to new type definitions intertwined with the program definition. It comprises: \begin{itemize} \item C-like control flow with \<^term>\break\ and \<^term>\return\, \item global variables, \item function calls (seen as monadic executions) with side-effects, recursion and local variables, \item parameters are modeled via functional abstractions (functions are monads); a passing of parameters to local variables might be added later, \item direct recursive function calls, \item cartouche syntax for \\\-lifted update operations supporting global and local variables. \end{itemize} Note that Clean in its current version is restricted to \<^emph>\monomorphic\ global and local variables as well as function parameters. This limitation will be overcome at a later stage. The construction in itself, however, is deeply based on parametric polymorphism (enabling structured proofs over extensible records as used in languages of the ML family \<^url>\http://www.cs.ioc.ee/tfp-icfp-gpce05/tfp-proc/21num.pdf\ and Haskell \<^url>\https://www.schoolofhaskell.com/user/fumieval/extensible-records\). \ (*<*) text\ @{footnote \sdf\}, @{file "$ISABELLE_HOME/src/Pure/ROOT.ML"}\ (*>*) section\A High-level Description of the Clean Memory Model\ subsection\A Simple Typed Memory Model of Clean: An Introduction \ text\ Clean is based on a ``no-frills'' state-exception monad \<^theory_text>\type_synonym ('o, '\) MON\<^sub>S\<^sub>E = \'\ \ ('o \ '\)\\ with the usual definitions of \<^term>\bind\ and \<^term>\unit\. In this language, sequence operators, conditionals and loops can be integrated. \ text\From a concrete program, the underlying state \<^theory_text>\'\\ is \<^emph>\incrementally\ constructed by a sequence of extensible record definitions: \<^enum> Initially, an internal control state is defined to give semantics to \<^term>\break\ and \<^term>\return\ statements: \begin{isar} record control_state = break_val :: bool return_val :: bool \end{isar} \<^theory_text>\control_state\ represents the $\sigma_0$ state. \<^enum> Any global variable definition block with definitions $a_1 : \tau_1$ $\dots$ $a_n : \tau_n$ is translated into a record extension: \begin{isar} record \$_{n+1}$ = \$_n$ + a$_1$ :: $\tau_1$; ...; $a_n$ :: $\tau_n$ \end{isar} \<^enum> Any local variable definition block (as part of a procedure declaration) with definitions $a_1 : \tau_1$ $\dots$ $a_n : \tau_n$ is translated into the record extension: \begin{isar} record \$_{n+1}$ = \$_n$ + a$_1$ :: $\tau_1$ list; ...; $a_n$ :: $\tau_n$ list; result :: $\tau_{result-type}$ list; \end{isar} where the \<^typ>\_ list\-lifting is used to model a \<^emph>\stack\ of local variable instances in case of direct recursions and the \<^term>\result_value\ used for the value of the \<^term>\return\ statement.\ text \ The \<^theory_text>\record\ package creates an \<^theory_text>\'\\ extensible record type \<^theory_text>\'\ control_state_ext\ where the \<^theory_text>\'\\ stands for extensions that are subsequently ``stuffed'' in them. Furthermore, it generates definitions for the constructor, accessor and update functions and automatically derives a number of theorems over them (e.g., ``updates on different fields commute'', ``accessors on a record are surjective'', ``accessors yield the value of the last update''). The collection of these theorems constitutes the \<^emph>\memory model\ of Clean, providing an incrementally extensible state-space for global and local program variables. In contrast to axiomatizations of memory models, our generated state-spaces might be ``wrong'' in the sense that they do not reflect the operational behaviour of a particular compiler or a sufficiently large portion of the C language; however, it is by construction \<^emph>\logically consistent\ since it is impossible to derive falsity from the entire set of conservative extension schemes used in their construction. A particular advantage of the incremental state-space construction is that it supports incremental verification and interleaving of program definitions with theory development.\ subsection\ Formally Modeling Control-States \ text\The control state is the ``root'' of all extensions for local and global variable spaces in Clean. It contains just the information of the current control-flow: a \<^term>\break\ occurred (meaning all commands till the end of the control block will be skipped) or a \<^term>\return\ occurred (meaning all commands till the end of the current function body will be skipped).\ record control_state = break_status :: bool return_status :: bool (* ML level representation: *) ML\ val t = @{term "\ \ break_status := False \"}\ (* break quits innermost while or for, return quits an entire execution sequence. *) definition break :: "(unit, ('\_ext) control_state_ext) MON\<^sub>S\<^sub>E" where "break \ (\ \. Some((), \ \ break_status := True \))" definition unset_break_status :: "(unit, ('\_ext) control_state_ext) MON\<^sub>S\<^sub>E" where "unset_break_status \ (\ \. Some((), \ \ break_status := False \))" definition set_return_status :: " (unit, ('\_ext) control_state_ext) MON\<^sub>S\<^sub>E" where "set_return_status = (\ \. Some((), \ \ return_status := True \))" definition unset_return_status :: "(unit, ('\_ext) control_state_ext) MON\<^sub>S\<^sub>E" where "unset_return_status = (\ \. Some((), \ \ return_status := False \))" definition exec_stop :: "('\_ext) control_state_ext \ bool" where "exec_stop = (\ \. break_status \ \ return_status \ )" abbreviation normal_execution :: "('\_ext) control_state_ext \ bool" where "(normal_execution s) \ (\ exec_stop s)" notation normal_execution ("\") lemma exec_stop1[simp] : "break_status \ \ exec_stop \" unfolding exec_stop_def by simp lemma exec_stop2[simp] : "return_status \ \ exec_stop \" unfolding exec_stop_def by simp text\ On the basis of the control-state, assignments, conditionals and loops are reformulated into \<^term>\break\-aware and \<^term>\return\-aware versions as shown in the definitions of \<^term>\assign\ and \<^term>\if_C\ (in this theory file, see below). \ text\For Reasoning over Clean programs, we need the notion of independance of an update from the control-block: \ definition break_status\<^sub>L where "break_status\<^sub>L = create\<^sub>L control_state.break_status control_state.break_status_update" lemma "vwb_lens break_status\<^sub>L" unfolding break_status\<^sub>L_def by (simp add: vwb_lens_def create\<^sub>L_def wb_lens_def mwb_lens_def mwb_lens_axioms_def upd2put_def wb_lens_axioms_def weak_lens_def) definition return_status\<^sub>L where "return_status\<^sub>L = create\<^sub>L control_state.return_status control_state.return_status_update" lemma "vwb_lens return_status\<^sub>L" unfolding return_status\<^sub>L_def by (simp add: vwb_lens_def create\<^sub>L_def wb_lens_def mwb_lens_def mwb_lens_axioms_def upd2put_def wb_lens_axioms_def weak_lens_def) lemma break_return_indep : "break_status\<^sub>L \ return_status\<^sub>L " by (simp add: break_status\<^sub>L_def lens_indepI return_status\<^sub>L_def upd2put_def create\<^sub>L_def) definition strong_control_independence ("\!") where "\! L = (break_status\<^sub>L \ L \ return_status\<^sub>L \ L)" lemma "vwb_lens break_status\<^sub>L" unfolding vwb_lens_def break_status\<^sub>L_def create\<^sub>L_def wb_lens_def mwb_lens_def by (simp add: mwb_lens_axioms_def upd2put_def wb_lens_axioms_def weak_lens_def) definition control_independence :: "(('b\'b)\'a control_state_scheme \ 'a control_state_scheme) \ bool" ("\") where "\ upd \ (\\ T b. break_status (upd T \) = break_status \ \ return_status (upd T \) = return_status \ \ upd T (\\ return_status := b \) = (upd T \)\ return_status := b \ \ upd T (\\ break_status := b \) = (upd T \)\ break_status := b \) " lemma strong_vs_weak_ci : "\! L \ \ (\f. \\. lens_put L \ (f (lens_get L \)))" unfolding strong_control_independence_def control_independence_def by (simp add: break_status\<^sub>L_def lens_indep_def return_status\<^sub>L_def upd2put_def create\<^sub>L_def) lemma expimnt :"\! (create\<^sub>L getv updv) \ (\f \. updv (\_. f (getv \)) \) = updv" unfolding create\<^sub>L_def strong_control_independence_def break_status\<^sub>L_def return_status\<^sub>L_def lens_indep_def apply(rule ext, rule ext) apply auto unfolding upd2put_def (* seems to be independent *) oops lemma expimnt : "vwb_lens (create\<^sub>L getv updv) \ (\f \. updv (\_. f (getv \)) \) = updv" unfolding create\<^sub>L_def strong_control_independence_def lens_indep_def break_status\<^sub>L_def return_status\<^sub>L_def vwb_lens_def apply(rule ext, rule ext) apply auto unfolding upd2put_def wb_lens_def weak_lens_def wb_lens_axioms_def mwb_lens_def mwb_lens_axioms_def apply auto (* seems to be independent *) oops lemma strong_vs_weak_upd : assumes * : "\! (create\<^sub>L getv updv)" (* getv and upd are constructed as lense *) and ** : "(\f \. updv (\_. f (getv \)) \) = updv" (* getv and upd are involutive *) shows "\ (updv)" apply(insert * **) unfolding create\<^sub>L_def upd2put_def by(drule strong_vs_weak_ci, auto) text\This quite tricky proof establishes the fact that the special case \hd(getv \) = []\ for \getv \ = []\ is finally irrelevant in our setting. This implies that we don't need the list-lense-construction (so far).\ lemma strong_vs_weak_upd_list : assumes * : "\! (create\<^sub>L (getv:: 'b control_state_scheme \ 'c list) (updv:: ('c list \ 'c list) \ 'b control_state_scheme \ 'b control_state_scheme))" (* getv and upd are constructed as lense *) and ** : "(\f \. updv (\_. f (getv \)) \) = updv" (* getv and upd are involutive *) shows "\ (updv \ upd_hd)" proof - have *** : "\! (create\<^sub>L (hd \ getv ) (updv \ upd_hd))" using * ** by (simp add: indep_list_lift strong_control_independence_def) show "\ (updv \ upd_hd)" apply(rule strong_vs_weak_upd) apply(rule ***) apply(rule ext, rule ext, simp) apply(subst (2) **[symmetric]) proof - fix f:: "'c \ 'c" fix \ :: "'b control_state_scheme" show "updv (upd_hd (\_. f (hd (getv \)))) \ = updv (\_. upd_hd f (getv \)) \" proof (cases "getv \") case Nil then show ?thesis by (simp,metis (no_types) "**" upd_hd.simps(1)) next case (Cons a list) then show ?thesis proof - have "(\c. f (hd (getv \))) = ((\c. f a)::'c \ 'c)" using local.Cons by auto then show ?thesis by (metis (no_types) "**" local.Cons upd_hd.simps(2)) qed qed qed qed lemma exec_stop_vs_control_independence [simp]: "\ upd \ exec_stop (upd f \) = exec_stop \" unfolding control_independence_def exec_stop_def by simp lemma exec_stop_vs_control_independence' [simp]: "\ upd \ (upd f (\ \ return_status := b \)) = (upd f \)\ return_status := b \" unfolding control_independence_def exec_stop_def by simp lemma exec_stop_vs_control_independence'' [simp]: "\ upd \ (upd f (\ \ break_status := b \)) = (upd f \) \ break_status := b \" unfolding control_independence_def exec_stop_def by simp subsection\An Example for Global Variable Declarations.\ text\We present the above definition of the incremental construction of the state-space in more detail via an example construction. Consider a global variable \A\ representing an array of integer. This \<^emph>\global variable declaration\ corresponds to the effect of the following record declaration: \<^theory_text>\record state0 = control_state + A :: "int list"\ which is later extended by another global variable, say, \B\ representing a real described in the Cauchy Sequence form @{typ "nat \ (int \ int)"} as follows: \<^theory_text>\record state1 = state0 + B :: "nat \ (int \ int)"\. A further extension would be needed if a (potentially recursive) function \f\ with some local variable \tmp\ is defined: \<^theory_text>\record state2 = state1 + tmp :: "nat stack" result_value :: "nat stack" \, where the \stack\ needed for modeling recursive instances is just a synonym for \list\. \ subsection\ The Assignment Operations (embedded in State-Exception Monad) \ text\Based on the global variable states, we define \<^term>\break\-aware and \<^term>\return\-aware version of the assignment. The trick to do this in a generic \<^emph>\and\ type-safe way is to provide the generated accessor and update functions (the ``lens'' representing this global variable, cf. \<^cite>\"Foster2009BidirectionalPL" and "DBLP:journals/toplas/FosterGMPS07" and "DBLP:conf/ictac/FosterZW16"\) to the generic assign operators. This pair of accessor and update carries all relevant semantic and type information of this particular variable and \<^emph>\characterizes\ this variable semantically. Specific syntactic support~\<^footnote>\via the Isabelle concept of -cartouche: \<^url>\https://isabelle.in.tum.de/doc/isar-ref.pdf\\ will hide away the syntactic overhead and permit a human-readable -form of assignments or expressions accessing the underlying state. \ +cartouche: \<^url>\https://isabelle.in.tum.de/doc/isar-ref.pdf\\ will hide away the syntactic overhead +and permit a human-readable form of assignments or expressions accessing the underlying state. \ consts syntax_assign :: "('\ \ int) \ int \ term" (infix ":=" 60) definition assign :: "(('\_ext) control_state_scheme \ ('\_ext) control_state_scheme) \ (unit,('\_ext) control_state_scheme)MON\<^sub>S\<^sub>E" where "assign f = (\\. if exec_stop \ then Some((), \) else Some((), f \))" definition assign_global :: "(('a \ 'a ) \ '\_ext control_state_scheme \ '\_ext control_state_scheme) \ ('\_ext control_state_scheme \ 'a) \ (unit,'\_ext control_state_scheme) MON\<^sub>S\<^sub>E" (infix ":==\<^sub>G" 100) where "assign_global upd rhs = assign(\\. ((upd) (\_. rhs \)) \)" text\An update of the variable \A\ based on the state of the previous example is done by @{term [source = true] \assign_global A_upd (\\. list_update (A \) (i) (A \ ! j))\} representing \A[i] = A[j]\; arbitrary nested updates can be constructed accordingly.\ text\Local variable spaces work analogously; except that they are represented by a stack in order to support individual instances in case of function recursion. This requires automated generation of specific push- and pop operations used to model the effect of entering or leaving a function block (to be discussed later).\ definition assign_local :: "(('a list \ 'a list) \ '\_ext control_state_scheme \ '\_ext control_state_scheme) \ ('\_ext control_state_scheme \ 'a) \ (unit,'\_ext control_state_scheme) MON\<^sub>S\<^sub>E" (infix ":==\<^sub>L" 100) where "assign_local upd rhs = assign(\\. ((upd o upd_hd) (%_. rhs \)) \)" text\Semantically, the difference between \<^emph>\global\ and \<^emph>\local\ is rather unimpressive as the following lemma shows. However, the distinction matters for the pretty-printing setup of Clean.\ lemma "(upd :==\<^sub>L rhs) = ((upd \ upd_hd) :==\<^sub>G rhs)" unfolding assign_local_def assign_global_def by simp text\The \return\ command in C-like languages is represented basically by an assignment to a local variable \result_value\ (see below in the Clean-package generation), plus some setup of \<^term>\return_status\. Note that a \<^term>\return\ may appear after a \<^term>\break\ and should have no effect in this case.\ definition return\<^sub>C0 where "return\<^sub>C0 A = (\\. if exec_stop \ then Some((), \) else (A ;- set_return_status) \)" definition return\<^sub>C :: "(('a list \ 'a list) \ '\_ext control_state_scheme \ '\_ext control_state_scheme) \ ('\_ext control_state_scheme \ 'a) \ (unit,'\_ext control_state_scheme) MON\<^sub>S\<^sub>E" ("return\") where "return\<^sub>C upd rhs = return\<^sub>C0 (assign_local upd rhs)" subsection\Example for a Local Variable Space\ text\Consider the usual operation \swap\ defined in some free-style syntax as follows: @{cartouche [display] \ function_spec swap (i::nat,j::nat) local_vars tmp :: int defines " \ tmp := A ! i\ ;- \ A[i] := A ! j\ ;- \ A[j] := tmp\ "\} \ text\ For the fantasy syntax \tmp := A ! i\, we can construct the following semantic code: @{term [source = true] \assign_local tmp_update (\\. (A \) ! i )\} where \tmp_update\ is the update operation generated by the \<^theory_text>\record\-package, which is generated while treating local variables of \swap\. By the way, a stack for \return\-values is also generated in order to give semantics to a \return\ operation: it is syntactically equivalent to the assignment of the result variable in the local state (stack). It sets the \<^term>\return_val\ flag. The management of the local state space requires function-specific \push\ and \pop\ operations, for which suitable definitions are generated as well: @{cartouche [display] \definition push_local_swap_state :: "(unit,'a local_swap_state_scheme) MON\<^sub>S\<^sub>E" where "push_local_swap_state \ = Some((),\\local_swap_state.tmp := undefined # local_swap_state.tmp \, local_swap_state.result_value := undefined # local_swap_state.result_value \ \)" definition pop_local_swap_state :: "(unit,'a local_swap_state_scheme) MON\<^sub>S\<^sub>E" where "pop_local_swap_state \ = Some(hd(local_swap_state.result_value \), \\local_swap_state.tmp:= tl( local_swap_state.tmp \) \)"\} where \result_value\ is the stack for potential result values (not needed in the concrete example \swap\). \ section\ Global and Local State Management via Extensible Records \ text\In the sequel, we present the automation of the state-management as schematically discussed in the previous section; the declarations of global and local variable blocks are constructed by subsequent extensions of @{typ "'a control_state_scheme"}, defined above.\ ML\ structure StateMgt_core = struct val control_stateT = Syntax.parse_typ @{context} "control_state" val control_stateS = @{typ "('a)control_state_scheme"}; fun optionT t = Type(@{type_name "Option.option"},[t]); fun MON_SE_T res state = state --> optionT(HOLogic.mk_prodT(res,state)); fun merge_control_stateS (@{typ "('a)control_state_scheme"},t) = t |merge_control_stateS (t, @{typ "('a)control_state_scheme"}) = t |merge_control_stateS (t, t') = if (t = t') then t else error"can not merge Clean state" datatype var_kind = global_var of typ | local_var of typ fun type_of(global_var t) = t | type_of(local_var t) = t type state_field_tab = var_kind Symtab.table structure Data = Generic_Data ( type T = (state_field_tab * typ (* current extensible record *)) val empty = (Symtab.empty,control_stateS) val extend = I fun merge((s1,t1),(s2,t2)) = (Symtab.merge (op =)(s1,s2),merge_control_stateS(t1,t2)) ); val get_data = Data.get o Context.Proof; val map_data = Data.map; val get_data_global = Data.get o Context.Theory; val map_data_global = Context.theory_map o map_data; val get_state_type = snd o get_data val get_state_type_global = snd o get_data_global val get_state_field_tab = fst o get_data val get_state_field_tab_global = fst o get_data_global fun upd_state_type f = map_data (fn (tab,t) => (tab, f t)) fun upd_state_type_global f = map_data_global (fn (tab,t) => (tab, f t)) fun fetch_state_field (ln,X) = let val a::b:: _ = rev (Long_Name.explode ln) in ((b,a),X) end; fun filter_name name ln = let val ((a,b),X) = fetch_state_field ln in if a = name then SOME((a,b),X) else NONE end; fun filter_attr_of name thy = let val tabs = get_state_field_tab_global thy in map_filter (filter_name name) (Symtab.dest tabs) end; fun is_program_variable name thy = Symtab.defined((fst o get_data_global) thy) name fun is_global_program_variable name thy = case Symtab.lookup((fst o get_data_global) thy) name of SOME(global_var _) => true | _ => false fun is_local_program_variable name thy = case Symtab.lookup((fst o get_data_global) thy) name of SOME(local_var _) => true | _ => false fun declare_state_variable_global f field thy = let val Const(name,ty) = Syntax.read_term_global thy field in (map_data_global (apfst (Symtab.update_new(name,f ty))) (thy) handle Symtab.DUP _ => error("multiple declaration of global var")) end; fun declare_state_variable_local f field ctxt = let val Const(name,ty) = Syntax.read_term_global (Context.theory_of ctxt) field in (map_data (apfst (Symtab.update_new(name,f ty)))(ctxt) handle Symtab.DUP _ => error("multiple declaration of global var")) end; end\ subsection\Block-Structures\ text\ On the managed local state-spaces, it is now straight-forward to define the semantics for a \block\ representing the necessary management of local variable instances: \ definition block\<^sub>C :: " (unit, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E \ (unit, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "block\<^sub>C push core pop \ ( \ \assumes break and return unset \ push ;- \ \create new instances of local variables \ core ;- \ \execute the body \ unset_break_status ;- \ \unset a potential break \ unset_return_status;- \ \unset a potential return break \ (x \ pop; \ \restore previous local var instances \ unit\<^sub>S\<^sub>E(x)))" \ \yield the return value \ text\ Based on this definition, the running \swap\ example is represented as follows: @{cartouche [display] \definition swap_core :: "nat \ nat \ (unit,'a local_swap_state_scheme) MON\<^sub>S\<^sub>E" where "swap_core \ (\(i,j). ((assign_local tmp_update (\\. A \ ! i )) ;- (assign_global A_update (\\. list_update (A \) (i) (A \ ! j))) ;- (assign_global A_update (\\. list_update (A \) (j) ((hd o tmp) \)))))" definition swap :: "nat \ nat \ (unit,'a local_swap_state_scheme) MON\<^sub>S\<^sub>E" where "swap \ \(i,j). block\<^sub>C push_local_swap_state (swap_core (i,j)) pop_local_swap_state" \} \ subsection\Call Semantics\ text\It is now straight-forward to define the semantics of a generic call --- which is simply a monad execution that is \<^term>\break\-aware and \<^term>\return\<^bsub>upd\<^esub>\-aware.\ definition call\<^sub>C :: "( '\ \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E) \ ((('\_ext) control_state_ext) \ '\) \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "call\<^sub>C M A\<^sub>1 = (\\. if exec_stop \ then Some(undefined, \) else M (A\<^sub>1 \) \)" text\Note that this presentation assumes a uncurried format of the arguments. The question arises if this is the right approach to handle calls of operation with multiple arguments. Is it better to go for an some appropriate currying principle? Here are some more experimental variants for curried operations... \ definition call_0\<^sub>C :: "('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "call_0\<^sub>C M = (\\. if exec_stop \ then Some(undefined, \) else M \)" text\The generic version using tuples is identical with @{term \call_1\<^sub>C\}.\ definition call_1\<^sub>C :: "( '\ \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E) \ ((('\_ext) control_state_ext) \ '\) \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "call_1\<^sub>C = call\<^sub>C" definition call_2\<^sub>C :: "( '\ \ '\ \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E) \ ((('\_ext) control_state_ext) \ '\) \ ((('\_ext) control_state_ext) \ '\) \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "call_2\<^sub>C M A\<^sub>1 A\<^sub>2 = (\\. if exec_stop \ then Some(undefined, \) else M (A\<^sub>1 \) (A\<^sub>2 \) \)" definition call_3\<^sub>C :: "( '\ \ '\ \ '\ \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E) \ ((('\_ext) control_state_ext) \ '\) \ ((('\_ext) control_state_ext) \ '\) \ ((('\_ext) control_state_ext) \ '\) \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "call_3\<^sub>C M A\<^sub>1 A\<^sub>2 A\<^sub>3 = (\\. if exec_stop \ then Some(undefined, \) else M (A\<^sub>1 \) (A\<^sub>2 \) (A\<^sub>3 \) \)" (* and 4 and 5 and ... *) section\ Some Term-Coding Functions \ text\In the following, we add a number of advanced HOL-term constructors in the style of @{ML_structure "HOLogic"} from the Isabelle/HOL libraries. They incorporate the construction of types during term construction in a bottom-up manner. Consequently, the leafs of such terms should always be typed, and anonymous loose-@{ML "Bound"} variables avoided.\ ML\ (* HOLogic extended *) fun mk_None ty = let val none = \<^const_name>\Option.option.None\ val none_ty = ty --> Type(\<^type_name>\option\,[ty]) in Const(none, none_ty) end; fun mk_Some t = let val some = \<^const_name>\Option.option.Some\ val ty = fastype_of t val some_ty = ty --> Type(\<^type_name>\option\,[ty]) in Const(some, some_ty) $ t end; fun dest_listTy (Type(\<^type_name>\List.list\, [T])) = T; fun mk_hdT t = let val ty = fastype_of t in Const(\<^const_name>\List.hd\, ty --> (dest_listTy ty)) $ t end fun mk_tlT t = let val ty = fastype_of t in Const(\<^const_name>\List.tl\, ty --> ty) $ t end fun mk_undefined (@{typ "unit"}) = Const (\<^const_name>\Product_Type.Unity\, \<^typ>\unit\) |mk_undefined t = Const (\<^const_name>\HOL.undefined\, t) fun meta_eq_const T = Const (\<^const_name>\Pure.eq\, T --> T --> propT); fun mk_meta_eq (t, u) = meta_eq_const (fastype_of t) $ t $ u; fun mk_pat_tupleabs [] t = t | mk_pat_tupleabs [(s,ty)] t = absfree(s,ty)(t) | mk_pat_tupleabs ((s,ty)::R) t = HOLogic.mk_case_prod(absfree(s,ty)(mk_pat_tupleabs R t)); fun read_constname ctxt n = fst(dest_Const(Syntax.read_term ctxt n)) fun wfrecT order recs = let val funT = domain_type (fastype_of recs) val aTy = domain_type funT val ordTy = HOLogic.mk_setT(HOLogic.mk_prodT (aTy,aTy)) in Const(\<^const_name>\Wfrec.wfrec\, ordTy --> (funT --> funT) --> funT) $ order $ recs end fun mk_lens_type from_ty to_ty = Type(@{type_name "lens.lens_ext"}, [from_ty, to_ty, HOLogic.unitT]); \ text\And here comes the core of the \<^theory_text>\Clean\-State-Management: the module that provides the functionality for the commands keywords \<^theory_text>\global_vars\, \<^theory_text>\local_vars\ and \<^theory_text>\local_vars_test\. Note that the difference between \<^theory_text>\local_vars\ and \<^theory_text>\local_vars_test\ is just a technical one: \<^theory_text>\local_vars\ can only be used inside a Clean function specification, made with the \<^theory_text>\function_spec\ command. On the other hand, \<^theory_text>\local_vars_test\ is defined as a global Isar command for test purposes. A particular feature of the local-variable management is the provision of definitions for \<^term>\push\ and \<^term>\pop\ operations --- encoded as \<^typ>\('o, '\) MON\<^sub>S\<^sub>E\ operations --- which are vital for the function specifications defined below. \ ML\ -structure StateMgt = + +signature STATEMGT = sig + structure Data: GENERIC_DATA + datatype var_kind = global_var of typ | local_var of typ + type state_field_tab = var_kind Symtab.table + val MON_SE_T: typ -> typ -> typ + val add_record_cmd: + {overloaded: bool} -> + bool -> + (string * string option) list -> + binding -> string option -> (binding * string * mixfix) list -> theory -> theory + val add_record_cmd': + {overloaded: bool} -> + bool -> + (string * string option) list -> + binding -> string option -> (binding * typ * mixfix) list -> theory -> theory + val add_record_cmd0: + ('a -> Proof.context -> (binding * typ * mixfix) list * Proof.context) -> + {overloaded: bool} -> + bool -> (string * string option) list -> binding -> string option -> 'a -> theory -> theory + val cmd: + (binding * typ option * mixfix) option * (Attrib.binding * term) * term list * + (binding * typ option * mixfix) list + -> local_theory -> local_theory + val construct_update: bool -> binding -> typ -> theory -> term + val control_stateS: typ + val control_stateT: typ + val declare_state_variable_global: (typ -> var_kind) -> string -> theory -> theory + val declare_state_variable_local: (typ -> var_kind) -> string -> Context.generic -> Context.generic + val define_lense: binding -> typ -> binding * typ * 'a -> Proof.context -> local_theory + val fetch_state_field: string * 'a -> (string * string) * 'a + val filter_attr_of: string -> theory -> ((string * string) * var_kind) list + val filter_name: string -> string * 'a -> ((string * string) * 'a) option + val get_data: Proof.context -> Data.T + val get_data_global: theory -> Data.T + val get_result_value_conf: string -> theory -> (string * string) * var_kind + val get_state_field_tab: Proof.context -> state_field_tab + val get_state_field_tab_global: theory -> state_field_tab + val get_state_type: Proof.context -> typ + val get_state_type_global: theory -> typ + val is_global_program_variable: Symtab.key -> theory -> bool + val is_local_program_variable: Symtab.key -> theory -> bool + val is_program_variable: Symtab.key -> theory -> bool + val map_data: (Data.T -> Data.T) -> Context.generic -> Context.generic + val map_data_global: (Data.T -> Data.T) -> theory -> theory + val map_to_update: typ -> bool -> theory -> (string * string) * var_kind -> term -> term + val merge_control_stateS: typ * typ -> typ + val mk_global_state_name: binding -> binding + val mk_lense_name: binding -> binding + val mk_local_state_name: binding -> binding + val mk_lookup_result_value_term: string -> typ -> theory -> term + val mk_pop_def: binding -> typ -> typ -> Proof.context -> local_theory + val mk_pop_name: binding -> binding + val mk_push_def: binding -> typ -> Proof.context -> local_theory + val mk_push_name: binding -> binding + val new_state_record: + bool -> + (((string * string option) list * binding) * string option) option * + (binding * string * mixfix) list + -> theory -> theory + val new_state_record': + bool -> + (((string * string option) list * binding) * typ option) option * (binding * typ * mixfix) list -> + theory -> theory + val new_state_record0: + ({overloaded: bool} -> + bool -> 'a list -> binding -> string option -> (binding * 'b * mixfix) list -> theory -> theory) + -> bool -> (('a list * binding) * 'b option) option * (binding * 'b * mixfix) list -> theory -> theory + val optionT: typ -> typ + val parse_typ_'a: Proof.context -> binding -> typ + val pop_eq: binding -> string -> typ -> typ -> Proof.context -> term + val push_eq: binding -> string -> typ -> typ -> Proof.context -> term + val read_fields: ('a * string * 'b) list -> Proof.context -> ('a * typ * 'b) list * Proof.context + val read_parent: string option -> Proof.context -> (typ list * string) option * Proof.context + val result_name: string + val typ_2_string_raw: typ -> string + val type_of: var_kind -> typ + val upd_state_type: (typ -> typ) -> Context.generic -> Context.generic + val upd_state_type_global: (typ -> typ) -> theory -> theory + + end + +structure StateMgt : STATEMGT = struct open StateMgt_core val result_name = "result_value" fun get_result_value_conf name thy = let val S = filter_attr_of name thy in hd(filter (fn ((_,b),_) => b = result_name) S) handle Empty => error "internal error: get_result_value_conf " end; fun mk_lookup_result_value_term name sty thy = let val ((prefix,name),local_var(Type("fun", [_,ty]))) = get_result_value_conf name thy; val long_name = Sign.intern_const thy (prefix^"."^name) val term = Const(long_name, sty --> ty) in mk_hdT (term $ Free("\",sty)) end fun map_to_update sty is_pop thy ((struct_name, attr_name), local_var (Type("fun",[_,ty]))) term = let val tlT = if is_pop then Const(\<^const_name>\List.tl\, ty --> ty) else Const(\<^const_name>\List.Cons\, dest_listTy ty --> ty --> ty) $ mk_undefined (dest_listTy ty) val update_name = Sign.intern_const thy (struct_name^"."^attr_name^"_update") in (Const(update_name, (ty --> ty) --> sty --> sty) $ tlT) $ term end | map_to_update _ _ _ ((_, _),_) _ = error("internal error map_to_update") fun mk_local_state_name binding = Binding.prefix_name "local_" (Binding.suffix_name "_state" binding) fun mk_global_state_name binding = Binding.prefix_name "global_" (Binding.suffix_name "_state" binding) fun construct_update is_pop binding sty thy = let val long_name = Binding.name_of( binding) val attrS = StateMgt_core.filter_attr_of long_name thy in fold (map_to_update sty is_pop thy) (attrS) (Free("\",sty)) end fun cmd (decl, spec, prems, params) = #2 o Specification.definition decl params prems spec fun mk_push_name binding = Binding.prefix_name "push_" binding fun mk_lense_name binding = Binding.suffix_name "\<^sub>L" binding fun push_eq binding name_op rty sty lthy = let val mty = MON_SE_T rty sty val thy = Proof_Context.theory_of lthy val term = construct_update false binding sty thy in mk_meta_eq((Free(name_op, mty) $ Free("\",sty)), mk_Some ( HOLogic.mk_prod (mk_undefined rty,term))) end; fun mk_push_def binding sty lthy = let val name_pushop = mk_push_name binding val rty = \<^typ>\unit\ val eq = push_eq binding (Binding.name_of name_pushop) rty sty lthy val mty = StateMgt_core.MON_SE_T rty sty val args = (SOME(name_pushop, SOME mty, NoSyn), (Binding.empty_atts,eq),[],[]) in cmd args lthy end; fun mk_pop_name binding = Binding.prefix_name "pop_" binding fun pop_eq binding name_op rty sty lthy = let val mty = MON_SE_T rty sty val thy = Proof_Context.theory_of lthy val res_access = mk_lookup_result_value_term (Binding.name_of binding) sty thy val term = construct_update true binding sty thy in mk_meta_eq((Free(name_op, mty) $ Free("\",sty)), mk_Some ( HOLogic.mk_prod (res_access,term))) end; fun mk_pop_def binding rty sty lthy = let val mty = StateMgt_core.MON_SE_T rty sty val name_op = mk_pop_name binding val eq = pop_eq binding (Binding.name_of name_op) rty sty lthy val args = (SOME(name_op, SOME mty, NoSyn),(Binding.empty_atts,eq),[],[]) in cmd args lthy end; fun read_parent NONE ctxt = (NONE, ctxt) | read_parent (SOME raw_T) ctxt = (case Proof_Context.read_typ_abbrev ctxt raw_T of Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt) | T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T)); fun read_fields raw_fields ctxt = let val Ts = Syntax.read_typs ctxt (map (fn (_, raw_T, _) => raw_T) raw_fields); val fields = map2 (fn (x, _, mx) => fn T => (x, T, mx)) raw_fields Ts; val ctxt' = fold Variable.declare_typ Ts ctxt; in (fields, ctxt') end; fun parse_typ_'a ctxt binding = let val ty_bind = Binding.prefix_name "'a " (Binding.suffix_name "_scheme" binding) in case Syntax.parse_typ ctxt (Binding.name_of ty_bind) of Type (s, _) => Type (s, [@{typ "'a::type"}]) | _ => error ("Unexpected type" ^ Position.here \<^here>) end fun define_lense binding sty (attr_name,rty,_) lthy = let val prefix = Binding.name_of binding^"_" val name_L = attr_name |> Binding.prefix_name prefix |> mk_lense_name val name_upd = Binding.suffix_name "_update" attr_name val acc_ty = sty --> rty val upd_ty = (rty --> rty) --> sty --> sty val cr = Const(@{const_name "Optics.create\<^sub>L"}, acc_ty --> upd_ty --> mk_lens_type rty sty) val thy = Proof_Context.theory_of lthy val acc_name = Sign.intern_const thy (Binding.name_of attr_name) val upd_name = Sign.intern_const thy (Binding.name_of name_upd) val acc = Const(acc_name, acc_ty) val upd = Const(upd_name, upd_ty) val lens_ty = mk_lens_type rty sty val eq = mk_meta_eq (Free(Binding.name_of name_L, lens_ty), cr $ acc $ upd) val args = (SOME(name_L, SOME lens_ty, NoSyn), (Binding.empty_atts,eq),[],[]) in cmd args lthy end fun add_record_cmd0 read_fields overloaded is_global_kind raw_params binding raw_parent raw_fields thy = let val ctxt = Proof_Context.init_global thy; val params = map (apsnd (Typedecl.read_constraint ctxt)) raw_params; val ctxt1 = fold (Variable.declare_typ o TFree) params ctxt; val (parent, ctxt2) = read_parent raw_parent ctxt1; val (fields, ctxt3) = read_fields raw_fields ctxt2; fun lift (a,b,c) = (a, HOLogic.listT b, c) val fields' = if is_global_kind then fields else map lift fields val params' = map (Proof_Context.check_tfree ctxt3) params; val declare = StateMgt_core.declare_state_variable_global fun upd_state_typ thy = let val ctxt = Proof_Context.init_global thy val ty = Syntax.parse_typ ctxt (Binding.name_of binding) in StateMgt_core.upd_state_type_global(K ty)(thy) end fun insert_var ((f,_,_), thy) = if is_global_kind then declare StateMgt_core.global_var (Binding.name_of f) thy else declare StateMgt_core.local_var (Binding.name_of f) thy fun define_push_pop thy = if not is_global_kind then let val sty = parse_typ_'a (Proof_Context.init_global thy) binding; val rty = dest_listTy (#2(hd(rev fields'))) in thy |> Named_Target.theory_map (mk_push_def binding sty) |> Named_Target.theory_map (mk_pop_def binding rty sty) end else thy fun define_lenses thy = let val sty = parse_typ_'a (Proof_Context.init_global thy) binding; in thy |> Named_Target.theory_map (fold (define_lense binding sty) fields') end in thy |> Record.add_record overloaded (params', binding) parent fields' |> (fn thy => List.foldr insert_var (thy) (fields')) |> upd_state_typ |> define_push_pop |> define_lenses end; fun typ_2_string_raw (Type(s,[TFree _])) = if String.isSuffix "_scheme" s then Long_Name.base_name(unsuffix "_scheme" s) else Long_Name.base_name(unsuffix "_ext" s) |typ_2_string_raw (Type(s,_)) = error ("Illegal parameterized state type - not allowed in Clean:" ^ s) |typ_2_string_raw _ = error "Illegal state type - not allowed in Clean." -fun new_state_record0 add_record_cmd is_global_kind (((raw_params, binding), res_ty), raw_fields) thy = - let val binding = if is_global_kind +fun new_state_record0 add_record_cmd is_global_kind (aS, raw_fields) thy = + let val state_index = (Int.toString o length o Symtab.dest) + (StateMgt_core.get_state_field_tab_global thy) + val state_pos = (Binding.pos_of o #1 o hd) raw_fields + val ((raw_params, binding), res_ty) = case aS of + SOME d => d + | NONE => (([], Binding.make(state_index,state_pos)), NONE) + val binding = if is_global_kind then mk_global_state_name binding else mk_local_state_name binding val raw_parent = SOME(typ_2_string_raw (StateMgt_core.get_state_type_global thy)) + val _ = writeln("XXXXX " ^ @{make_string} raw_params ^ "CCC " ^ @{make_string} binding + ^ @{make_string} raw_fields) val pos = Binding.pos_of binding fun upd_state_typ thy = StateMgt_core.upd_state_type_global (K (parse_typ_'a (Proof_Context.init_global thy) binding)) thy val result_binding = Binding.make(result_name,pos) val raw_fields' = case res_ty of NONE => raw_fields | SOME res_ty => raw_fields @ [(result_binding,res_ty, NoSyn)] in thy |> add_record_cmd {overloaded = false} is_global_kind raw_params binding raw_parent raw_fields' |> upd_state_typ end val add_record_cmd = add_record_cmd0 read_fields; val add_record_cmd' = add_record_cmd0 pair; val new_state_record = new_state_record0 add_record_cmd -val new_state_record' = new_state_record0 add_record_cmd' +val new_state_record' = new_state_record0 add_record_cmd'; + + +fun clean_ctxt_parser b = Parse.$$$ "(" + |-- (Parse.type_args_constrained -- Parse.binding) + -- (if b then Scan.succeed NONE else Parse.typ >> SOME) + --| Parse.$$$ ")" + : (((string * string option) list * binding) * string option) parser val _ = Outer_Syntax.command \<^command_keyword>\global_vars\ "define global state record" - ((Parse.type_args_constrained -- Parse.binding) - -- Scan.succeed NONE - -- Scan.repeat1 Parse.const_binding - >> (Toplevel.theory o new_state_record true)); -; + (Scan.option (clean_ctxt_parser true) -- Scan.repeat1 Parse.const_binding + >> (Toplevel.theory o new_state_record true)); + + val _ = Outer_Syntax.command \<^command_keyword>\local_vars_test\ "define local state record" - ((Parse.type_args_constrained -- Parse.binding) - -- (Parse.typ >> SOME) - -- Scan.repeat1 Parse.const_binding - >> (Toplevel.theory o new_state_record false)) -; + (Scan.option (clean_ctxt_parser false) -- Scan.repeat1 Parse.const_binding + >> (Toplevel.theory o new_state_record false)); + + end \ section\Syntactic Sugar supporting \\\-lifting for Global and Local Variables \ ML \ structure Clean_Syntax_Lift = struct type T = { is_local : string -> bool , is_global : string -> bool } val init = Proof_Context.theory_of #> (fn thy => { is_local = fn name => StateMgt_core.is_local_program_variable name thy , is_global = fn name => StateMgt_core.is_global_program_variable name thy }) local fun mk_local_access X = Const (@{const_name "Fun.comp"}, dummyT) $ Const (@{const_name "List.list.hd"}, dummyT) $ X in fun app_sigma0 (st : T) db tm = case tm of Const(name, _) => if #is_global st name then tm $ (Bound db) (* lambda lifting *) else if #is_local st name then (mk_local_access tm) $ (Bound db) (* lambda lifting local *) else tm (* no lifting *) | Free _ => tm | Var _ => tm | Bound n => if n > db then Bound(n + 1) else Bound n | Abs (x, ty, tm') => Abs(x, ty, app_sigma0 st (db+1) tm') | t1 $ t2 => (app_sigma0 st db t1) $ (app_sigma0 st db t2) fun app_sigma db tm = init #> (fn st => app_sigma0 st db tm) fun scope_var st name = if #is_global st name then SOME true else if #is_local st name then SOME false else NONE fun assign_update var = var ^ Record.updateN fun transform_term0 abs scope_var tm = case tm of Const (@{const_name "Clean.syntax_assign"}, _) $ (t1 as Const ("_type_constraint_", _) $ Const (name, ty)) $ t2 => Const ( case scope_var name of SOME true => @{const_name "assign_global"} | SOME false => @{const_name "assign_local"} | NONE => raise TERM ("mk_assign", [t1]) , dummyT) $ Const(assign_update name, ty) $ abs t2 | _ => abs tm fun transform_term st sty = transform_term0 (fn tm => Abs ("\", sty, app_sigma0 st 0 tm)) (scope_var st) fun transform_term' st = transform_term st dummyT fun string_tr ctxt content args = let fun err () = raise TERM ("string_tr", args) in (case args of [(Const (@{syntax_const "_constrain"}, _)) $ (Free (s, _)) $ p] => (case Term_Position.decode_position p of SOME (pos, _) => Symbol_Pos.implode (content (s, pos)) |> Syntax.parse_term ctxt |> transform_term (init ctxt) (StateMgt_core.get_state_type ctxt) |> Syntax.check_term ctxt | NONE => err ()) | _ => err ()) end end end \ syntax "_cartouche_string" :: "cartouche_position \ string" ("_") parse_translation \ [(@{syntax_const "_cartouche_string"}, (fn ctxt => Clean_Syntax_Lift.string_tr ctxt (Symbol_Pos.cartouche_content o Symbol_Pos.explode)))] \ section\Support for (direct recursive) Clean Function Specifications \ text\Based on the machinery for the State-Management and implicitly cooperating with the cartouches for assignment syntax, the function-specification \<^theory_text>\function_spec\-package coordinates: \<^enum> the parsing and type-checking of parameters, \<^enum> the parsing and type-checking of pre and post conditions in MOAL notation (using \\\-lifting cartouches and implicit reference to parameters, pre and post states), \<^enum> the parsing local variable section with the local-variable space generation, \<^enum> the parsing of the body in this extended variable space, \<^enum> and optionally the support of measures for recursion proofs. The reader interested in details is referred to the \<^file>\../examples/Quicksort_concept.thy\-example, accompanying this distribution. \ text\In order to support the \<^verbatim>\old\-notation known from JML and similar annotation languages, we introduce the following definition:\ definition old :: "'a \ 'a" where "old x = x" text\The core module of the parser and operation specification construct is implemented in the following module:\ ML \ structure Function_Specification_Parser = struct type funct_spec_src = { binding: binding, (* name *) params: (binding*string) list, (* parameters and their type*) ret_type: string, (* return type; default unit *) locals: (binding*string*mixfix)list, (* local variables *) pre_src: string, (* precondition src *) post_src: string, (* postcondition src *) variant_src: string option, (* variant src *) body_src: string * Position.T (* body src *) } type funct_spec_sem_old = { params: (binding*typ) list, (* parameters and their type*) ret_ty: typ, (* return type *) pre: term, (* precondition *) post: term, (* postcondition *) variant: term option (* variant *) } type funct_spec_sem = { binding: binding, (* name *) params: (binding*string) list, (* parameters and their type*) ret_type: string, (* return type; default unit *) locals: (binding*string*mixfix)list, (* local variables *) read_pre: Proof.context -> term, (* precondition src *) read_post: Proof.context -> term, (* postcondition src *) read_variant_opt: (Proof.context->term) option, (* variant src *) read_body: Proof.context -> typ -> term (* body src *) } val parse_arg_decl = Parse.binding -- (Parse.$$$ "::" |-- Parse.typ) val parse_param_decls = Args.parens (Parse.enum "," parse_arg_decl) val parse_returns_clause = Scan.optional (\<^keyword>\returns\ |-- Parse.typ) "unit" val locals_clause = (Scan.optional ( \<^keyword>\local_vars\ -- (Scan.repeat1 Parse.const_binding)) ("", [])) val parse_proc_spec = ( Parse.binding -- parse_param_decls -- parse_returns_clause --| \<^keyword>\pre\ -- Parse.term --| \<^keyword>\post\ -- Parse.term -- (Scan.option ( \<^keyword>\variant\ |-- Parse.term)) -- (Scan.optional( \<^keyword>\local_vars\ |-- (Scan.repeat1 Parse.const_binding))([])) --| \<^keyword>\defines\ -- (Parse.position (Parse.term)) ) >> (fn ((((((((binding,params),ret_ty),pre_src),post_src),variant_src),locals)),body_src) => { binding = binding, params=params, ret_type=ret_ty, pre_src=pre_src, post_src=post_src, variant_src=variant_src, locals=locals, body_src=body_src} : funct_spec_src ) fun read_params params ctxt = let val Ts = Syntax.read_typs ctxt (map snd params); in (Ts, fold Variable.declare_typ Ts ctxt) end; fun read_result ret_ty ctxt = let val [ty] = Syntax.read_typs ctxt [ret_ty] val ctxt' = Variable.declare_typ ty ctxt in (ty, ctxt') end fun read_function_spec ( params, ret_type, read_variant_opt) ctxt = let val (params_Ts, ctxt') = read_params params ctxt val (rty, ctxt'') = read_result ret_type ctxt' val variant = case read_variant_opt of NONE => NONE |SOME f => SOME(f ctxt'') val paramT_l = (map2 (fn (b, _) => fn T => (b, T)) params params_Ts) in ((paramT_l, rty, variant),ctxt'') end fun check_absence_old term = let fun test (s,ty) = if s = @{const_name "old"} andalso fst (dest_Type ty) = "fun" then error("the old notation is not allowed here!") else false in exists_Const test term end fun transform_old sty term = let fun transform_old0 (Const(@{const_name "old"}, Type ("fun", [_,_])) $ term ) = (case term of (Const(s,ty) $ Bound x) => (Const(s,ty) $ Bound (x+1)) | _ => error("illegal application of the old notation.")) |transform_old0 (t1 $ t2) = transform_old0 t1 $ transform_old0 t2 |transform_old0 (Abs(s,ty,term)) = Abs(s,ty,transform_old0 term) |transform_old0 term = term in Abs("\\<^sub>p\<^sub>r\<^sub>e", sty, transform_old0 term) end fun define_cond binding f_sty transform_old check_absence_old cond_suffix params read_cond (ctxt:local_theory) = let val params' = map (fn(b, ty) => (Binding.name_of b,ty)) params val src' = case transform_old (read_cond ctxt) of Abs(nn, sty_pre, term) => mk_pat_tupleabs params' (Abs(nn,sty_pre,term)) | _ => error ("define abstraction for result" ^ Position.here \<^here>) val bdg = Binding.suffix_name cond_suffix binding val _ = check_absence_old src' val bdg_ty = HOLogic.mk_tupleT(map (#2) params) --> f_sty HOLogic.boolT val eq = mk_meta_eq(Free(Binding.name_of bdg, bdg_ty),src') val args = (SOME(bdg,NONE,NoSyn), (Binding.empty_atts,eq),[],[]) in StateMgt.cmd args ctxt end fun define_precond binding sty = define_cond binding (fn boolT => sty --> boolT) I check_absence_old "_pre" fun define_postcond binding rty sty = define_cond binding (fn boolT => sty --> sty --> rty --> boolT) (transform_old sty) I "_post" fun define_body_core binding args_ty sty params body = let val params' = map (fn(b,ty) => (Binding.name_of b, ty)) params val bdg_core = Binding.suffix_name "_core" binding val bdg_core_name = Binding.name_of bdg_core val umty = args_ty --> StateMgt.MON_SE_T @{typ "unit"} sty val eq = mk_meta_eq(Free (bdg_core_name, umty),mk_pat_tupleabs params' body) val args_core =(SOME (bdg_core, SOME umty, NoSyn), (Binding.empty_atts, eq), [], []) in StateMgt.cmd args_core end fun define_body_main {recursive = x:bool} binding rty sty params read_variant_opt _ ctxt = let val push_name = StateMgt.mk_push_name (StateMgt.mk_local_state_name binding) val pop_name = StateMgt.mk_pop_name (StateMgt.mk_local_state_name binding) val bdg_core = Binding.suffix_name "_core" binding val bdg_core_name = Binding.name_of bdg_core val bdg_rec_name = Binding.name_of(Binding.suffix_name "_rec" binding) val bdg_ord_name = Binding.name_of(Binding.suffix_name "_order" binding) val args_ty = HOLogic.mk_tupleT (map snd params) val rmty = StateMgt_core.MON_SE_T rty sty val umty = StateMgt.MON_SE_T @{typ "unit"} sty val argsProdT = HOLogic.mk_prodT(args_ty,args_ty) val argsRelSet = HOLogic.mk_setT argsProdT val params' = map (fn(b, ty) => (Binding.name_of b,ty)) params val measure_term = case read_variant_opt of NONE => Free(bdg_ord_name,args_ty --> HOLogic.natT) | SOME f => ((f ctxt) |> mk_pat_tupleabs params') val measure = Const(@{const_name "Wellfounded.measure"}, (args_ty --> HOLogic.natT) --> argsRelSet ) $ measure_term val lhs_main = if x andalso is_none (read_variant_opt ) then Free(Binding.name_of binding, (args_ty --> HOLogic.natT) --> args_ty --> rmty) $ Free(bdg_ord_name, args_ty --> HOLogic.natT) else Free(Binding.name_of binding, args_ty --> rmty) val rhs_main = mk_pat_tupleabs params' (Const(@{const_name "Clean.block\<^sub>C"}, umty --> umty --> rmty --> rmty) $ Const(read_constname ctxt (Binding.name_of push_name),umty) $ (Const(read_constname ctxt bdg_core_name, args_ty --> umty) $ HOLogic.mk_tuple (map Free params')) $ Const(read_constname ctxt (Binding.name_of pop_name),rmty)) val rhs_main_rec = wfrecT measure (Abs(bdg_rec_name, (args_ty --> umty) , mk_pat_tupleabs params' (Const(@{const_name "Clean.block\<^sub>C"}, umty-->umty-->rmty-->rmty) $ Const(read_constname ctxt (Binding.name_of push_name),umty) $ (Const(read_constname ctxt bdg_core_name, (args_ty --> umty) --> args_ty --> umty) $ (Bound (length params)) $ HOLogic.mk_tuple (map Free params')) $ Const(read_constname ctxt (Binding.name_of pop_name),rmty)))) val eq_main = mk_meta_eq(lhs_main, if x then rhs_main_rec else rhs_main ) val args_main = (SOME(binding,NONE,NoSyn), (Binding.empty_atts,eq_main),[],[]) in ctxt |> StateMgt.cmd args_main end val _ = Local_Theory.exit_result_global; val _ = Named_Target.theory_map_result; val _ = Named_Target.theory_map; (* This code is in large parts so messy because the extensible record package (used inside StateMgt.new_state_record) is only available as transformation on global contexts, which cuts the local context calculations into two halves. The second halves is cut again into two halves because the definition of the core apparently does not take effect before defining the block - structure when not separated (this problem can perhaps be overcome somehow)) Precondition: the terms of the read-functions are full typed in the respective local contexts. *) fun checkNsem_function_spec_gen {recursive = false} ({read_variant_opt=SOME _, ...}) _ = error "No measure required in non-recursive call" |checkNsem_function_spec_gen (isrec as {recursive = _:bool}) ({binding, ret_type, read_variant_opt, locals, read_body, read_pre, read_post, params} : funct_spec_sem) thy = let fun addfixes ((params_Ts,ret_ty,t_opt), ctxt) = (fn fg => fn ctxt => ctxt |> Proof_Context.add_fixes (map (fn (s,ty)=>(s,SOME ty,NoSyn)) params_Ts) (* this declares the parameters of a function specification as Free variables (overrides a possible constant declaration) and assigns the declared type to them *) |> (fn (X, ctxt) => fg params_Ts ret_ty ctxt) , ctxt) val (theory_map, thy') = Named_Target.theory_map_result (K (fn f => Named_Target.theory_map o f)) ( read_function_spec (params, ret_type, read_variant_opt) #> addfixes ) (thy) in thy' |> theory_map let val sty_old = StateMgt_core.get_state_type_global thy' fun parse_contract params ret_ty = ( define_precond binding sty_old params read_pre #> define_postcond binding ret_ty sty_old params read_post) in parse_contract end - |> StateMgt.new_state_record false ((([],binding), SOME ret_type),locals) + |> StateMgt.new_state_record false (SOME (([],binding), SOME ret_type),locals) |> theory_map (fn params => fn ret_ty => fn ctxt => let val sty = StateMgt_core.get_state_type ctxt val args_ty = HOLogic.mk_tupleT (map snd params) val mon_se_ty = StateMgt_core.MON_SE_T ret_ty sty val body = read_body ctxt mon_se_ty val ctxt' = if #recursive isrec then Proof_Context.add_fixes [(binding, SOME (args_ty --> mon_se_ty), NoSyn)] ctxt |> #2 else ctxt val body = read_body ctxt' mon_se_ty in ctxt' |> define_body_core binding args_ty sty params body end) (* separation nasty, but nec. in order to make the body definition take effect. No other reason. *) |> theory_map (fn params => fn ret_ty => fn ctxt => let val sty = StateMgt_core.get_state_type ctxt val mon_se_ty = StateMgt_core.MON_SE_T ret_ty sty val body = read_body ctxt mon_se_ty in ctxt |> define_body_main isrec binding ret_ty sty params read_variant_opt body end) end fun checkNsem_function_spec (isrec as {recursive = _:bool}) ( {binding, ret_type, variant_src, locals, body_src, pre_src, post_src, params} : funct_spec_src) thy = checkNsem_function_spec_gen (isrec) ( {binding = binding, params = params, ret_type = ret_type, read_variant_opt = (case variant_src of NONE => NONE | SOME t=> SOME(fn ctxt => Syntax.read_term ctxt t)), locals = locals, read_body = fn ctxt => fn expected_type => Syntax.read_term ctxt (fst body_src), read_pre = fn ctxt => Syntax.read_term ctxt pre_src, read_post = fn ctxt => Syntax.read_term ctxt post_src} : funct_spec_sem) thy val _ = Outer_Syntax.command \<^command_keyword>\function_spec\ "define Clean function specification" (parse_proc_spec >> (Toplevel.theory o checkNsem_function_spec {recursive = false})); val _ = Outer_Syntax.command \<^command_keyword>\rec_function_spec\ "define recursive Clean function specification" (parse_proc_spec >> (Toplevel.theory o checkNsem_function_spec {recursive = true})); end \ section\The Rest of Clean: Break/Return aware Version of If, While, etc.\ definition if_C :: "[('\_ext) control_state_ext \ bool, ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E, ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E] \ ('\, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "if_C c E F = (\\. if exec_stop \ then Some(undefined, \) \ \state unchanged, return arbitrary\ else if c \ then E \ else F \)" syntax (xsymbols) "_if_SECLEAN" :: "['\ \ bool,('o,'\)MON\<^sub>S\<^sub>E,('o','\)MON\<^sub>S\<^sub>E] \ ('o','\)MON\<^sub>S\<^sub>E" ("(if\<^sub>C _ then _ else _fi)" [5,8,8]20) translations "(if\<^sub>C cond then T1 else T2 fi)" == "CONST Clean.if_C cond T1 T2" definition while_C :: "(('\_ext) control_state_ext \ bool) \ (unit, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E \ (unit, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "while_C c B \ (\\. if exec_stop \ then Some((), \) else ((MonadSE.while_SE (\ \. \exec_stop \ \ c \) B) ;- unset_break_status) \)" syntax (xsymbols) "_while_C" :: "['\ \ bool, (unit, '\)MON\<^sub>S\<^sub>E] \ (unit, '\)MON\<^sub>S\<^sub>E" ("(while\<^sub>C _ do _ od)" [8,8]20) translations "while\<^sub>C c do b od" == "CONST Clean.while_C c b" section\Miscellaneous\ text\Since \<^verbatim>\int\ were mapped to Isabelle/HOL @{typ "int"} and \<^verbatim>\unsigned int\ to @{typ "nat"}, there is the need for a common interface for accesses in arrays, which were represented by Isabelle/HOL lists: \ consts nth\<^sub>C :: "'a list \ 'b \ 'a" overloading nth\<^sub>C \ "nth\<^sub>C :: 'a list \ nat \ 'a" begin definition nth\<^sub>C_nat : "nth\<^sub>C (S::'a list) (a) \ nth S a" end overloading nth\<^sub>C \ "nth\<^sub>C :: 'a list \ int \ 'a" begin definition nth\<^sub>C_int : "nth\<^sub>C (S::'a list) (a) \ nth S (nat a)" end definition while_C_A :: " (('\_ext) control_state_scheme \ bool) \ (('\_ext) control_state_scheme \ nat) \ (('\_ext) control_state_ext \ bool) \ (unit, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E \ (unit, ('\_ext) control_state_ext)MON\<^sub>S\<^sub>E" where "while_C_A Inv f c B \ while_C c B" ML\ structure Clean_Term_interface = struct fun mk_seq_C C C' = let val t = fastype_of C val t' = fastype_of C' - in Const(\<^const_name>\bind_SE'\, t --> t' --> t') end; + in Const(\<^const_name>\bind_SE'\, t --> t' --> t') $ C $ C' end; fun mk_skip_C sty = Const(\<^const_name>\skip\<^sub>S\<^sub>E\, StateMgt_core.MON_SE_T HOLogic.unitT sty) fun mk_break sty = - Const(\<^const_name>\if_C\, StateMgt_core.MON_SE_T HOLogic.unitT sty ) + Const(\<^const_name>\break\, StateMgt_core.MON_SE_T HOLogic.unitT sty ) fun mk_return_C upd rhs = let val ty = fastype_of rhs val (sty,rty) = case ty of Type("fun", [sty,rty]) => (sty,rty) | _ => error "mk_return_C: illegal type for body" val upd_ty = (HOLogic.listT rty --> HOLogic.listT rty) --> sty --> sty val rhs_ty = sty --> rty val mty = StateMgt_core.MON_SE_T HOLogic.unitT sty in Const(\<^const_name>\return\<^sub>C\, upd_ty --> rhs_ty --> mty) $ upd $ rhs end fun mk_assign_global_C upd rhs = let val ty = fastype_of rhs val (sty,rty) = case ty of Type("fun", [sty,rty]) => (sty,rty) | _ => error "mk_assign_global_C: illegal type for body" val upd_ty = (rty --> rty) --> sty --> sty val rhs_ty = sty --> rty val mty = StateMgt_core.MON_SE_T HOLogic.unitT sty in Const(\<^const_name>\assign_global\, upd_ty --> rhs_ty --> mty) $ upd $ rhs end fun mk_assign_local_C upd rhs = let val ty = fastype_of rhs val (sty,rty) = case ty of Type("fun", [sty,rty]) => (sty,rty) | _ => error "mk_assign_local_C: illegal type for body" val upd_ty = (HOLogic.listT rty --> HOLogic.listT rty) --> sty --> sty val rhs_ty = sty --> rty val mty = StateMgt_core.MON_SE_T HOLogic.unitT sty in Const(\<^const_name>\assign_local\, upd_ty --> rhs_ty --> mty) $ upd $ rhs end fun mk_call_C opn args = let val ty = fastype_of opn val (argty,mty) = case ty of Type("fun", [argty,mty]) => (argty,mty) | _ => error "mk_call_C: illegal type for body" val sty = case mty of Type("fun", [sty,_]) => sty | _ => error "mk_call_C: illegal type for body 2" val args_ty = sty --> argty in Const(\<^const_name>\call\<^sub>C\, ty --> args_ty --> mty) $ opn $ args end (* missing : a call_assign_local and a call_assign_global. Or define at HOL level ? *) fun mk_if_C c B B' = let val ty = fastype_of B val ty_cond = case ty of Type("fun", [argty,_]) => argty --> HOLogic.boolT |_ => error "mk_if_C: illegal type for body" in Const(\<^const_name>\if_C\, ty_cond --> ty --> ty --> ty) $ c $ B $ B' end; fun mk_while_C c B = let val ty = fastype_of B val ty_cond = case ty of Type("fun", [argty,_]) => argty --> HOLogic.boolT |_ => error "mk_while_C: illegal type for body" in Const(\<^const_name>\while_C\, ty_cond --> ty --> ty) $ c $ B end; fun mk_while_anno_C inv f c B = (* no type-check on inv and measure f *) let val ty = fastype_of B val (ty_cond,ty_m) = case ty of Type("fun", [argty,_]) =>( argty --> HOLogic.boolT, argty --> HOLogic.natT) |_ => error "mk_while_anno_C: illegal type for body" in Const(\<^const_name>\while_C_A\, ty_cond --> ty_m --> ty_cond --> ty --> ty) $ inv $ f $ c $ B end; fun mk_block_C push body pop = let val body_ty = fastype_of body val pop_ty = fastype_of pop val bty = body_ty --> body_ty --> pop_ty --> pop_ty in Const(\<^const_name>\block\<^sub>C\, bty) $ push $ body $ pop end end;\ section\Function-calls in Expressions\ text\The precise semantics of function-calls appearing inside expressions is underspecified in C, which is a notorious problem for compilers and analysis tools. In Clean, it is impossible by construction --- and the type displine --- to have function-calls inside expressions. However, there is a somewhat \<^emph>\recommended coding-scheme\ for this feature, which leaves this issue to decisions in the front-end: \begin{verbatim} a = f() + g(); \end{verbatim} can be represented in Clean by: \x \ f(); y \ g(); \a := x + y\ \ or \x \ g(); y \ f(); \a := y + x\ \ which makes the evaluation order explicit without introducing local variables or any form of explicit trace on the state-space of the Clean program. We assume, however, even in this coding scheme, that \<^verbatim>\f()\ and \<^verbatim>\g()\ are atomic actions; note that this assumption is not necessarily justified in modern compilers, where actually neither of these two (atomic) serializations of \<^verbatim>\f()\ and \<^verbatim>\g()\ may exists. Note, furthermore, that expressions may not only be right-hand-sides of (local or global) assignments or conceptually similar return-statements, but also passed as argument of other function calls, where the same problem arises. \ - - end diff --git a/thys/Clean/src/Lens_Laws.thy b/thys/Clean/src/Lens_Laws.thy --- a/thys/Clean/src/Lens_Laws.thy +++ b/thys/Clean/src/Lens_Laws.thy @@ -1,332 +1,332 @@ (******************************************************************************) (* Project: The Isabelle/UTP Proof System *) (* File: Lens_Laws *) (* Authors: Simon Foster and Frank Zeyda *) (* Authors: Burkhart Wolff (slight modifications) *) (* Emails: simon.foster@york.ac.uk frank.zeyda@york.ac.uk *) (******************************************************************************) (* LAST REVIEWED: 7/12/2016 *) text\ This file is an except from the "Optics" module of the AFP \<^url>\https://www.isa-afp.org/entries/Optics.html\. \ section \Core Lens Laws\ theory Lens_Laws imports Main begin subsection \Lens Signature\ text \This theory introduces the signature of lenses and indentifies the core algebraic hierarchy of lens - classes, including laws for well-behaved, very well-behaved, and bijective lenses~\<^cite>\"Foster07" and "Fischer2015" and "Gibbons17"\.\ + classes, including laws for well-behaved, very well-behaved, and bijective lenses~\cite{Foster07,Fischer2015,Gibbons17}.\ record ('a, 'b) lens = lens_get :: "'b \ 'a" ("get\") lens_put :: "'b \ 'a \ 'b" ("put\") type_notation lens (infixr "\" 0) text \ \begin{figure} \begin{center} \includegraphics[width=6cm]{figures/Lens} \end{center} \vspace{-5ex} \caption{Visualisation of a simple lens} \label{fig:Lens} \end{figure} A lens $X : \view \lto \src$, for source type $\src$ and view type $\view$, identifies - $\view$ with a subregion of $\src$~\<^cite>\"Foster07" and "Foster09"\, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes + $\view$ with a subregion of $\src$~\cite{Foster07,Foster09}, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes $X$ and the hatched area denotes the subregion $\view$ it characterises. Transformations on $\view$ can be performed without affecting the parts of $\src$ outside the hatched area. The lens signature consists of a pair of functions $\lget_X : \src \Rightarrow \view$ that extracts a view from a source, and $\lput_X : \src \Rightarrow \view \Rightarrow \src$ that updates a view within a given source. \ named_theorems lens_defs text \ \lens_source\ gives the set of constructible sources; that is those that can be built by putting a value into an arbitrary source. \ definition lens_source :: "('a \ 'b) \ 'b set" ("\\") where "lens_source X = {s. \ v s'. s = put\<^bsub>X\<^esub> s' v}" abbreviation some_source :: "('a \ 'b) \ 'b" ("src\") where "some_source X \ (SOME s. s \ \\<^bsub>X\<^esub>)" definition lens_create :: "('a \ 'b) \ 'a \ 'b" ("create\") where [lens_defs]: "create\<^bsub>X\<^esub> v = put\<^bsub>X\<^esub> (src\<^bsub>X\<^esub>) v" text \ Function $\lcreate_X~v$ creates an instance of the source type of $X$ by injecting $v$ as the view, and leaving the remaining context arbitrary. \ subsection \Weak Lenses\ text \ Weak lenses are the least constrained class of lenses in our algebraic hierarchy. They - simply require that the PutGet law~\<^cite>\"Foster09" and "Fischer2015"\ is satisfied, meaning that + simply require that the PutGet law~\cite{Foster09,Fischer2015} is satisfied, meaning that $\lget$ is the inverse of $\lput$. \ locale weak_lens = fixes x :: "'a \ 'b" (structure) assumes put_get: "get (put \ v) = v" begin lemma source_nonempty: "\ s. s \ \" by (auto simp add: lens_source_def) lemma put_closure: "put \ v \ \" by (auto simp add: lens_source_def) lemma create_closure: "create v \ \" by (simp add: lens_create_def put_closure) lemma src_source [simp]: "src \ \" using some_in_eq source_nonempty by auto lemma create_get: "get (create v) = v" by (simp add: lens_create_def put_get) lemma create_inj: "inj create" by (metis create_get injI) text \ The update function is analogous to the record update function which lifts a function on a view type to one on the source type. \ definition update :: "('a \ 'a) \ ('b \ 'b)" where [lens_defs]: "update f \ = put \ (f (get \))" lemma get_update: "get (update f \) = f (get \)" by (simp add: put_get update_def) lemma view_determination: assumes "put \ u = put \ v" shows "u = v" by (metis assms put_get) lemma put_inj: "inj (put \)" by (simp add: injI view_determination) end declare weak_lens.put_get [simp] declare weak_lens.create_get [simp] subsection \Well-behaved Lenses\ -text \ Well-behaved lenses add to weak lenses that requirement that the GetPut law~\<^cite>\"Foster09" and "Fischer2015"\ +text \ Well-behaved lenses add to weak lenses that requirement that the GetPut law~\cite{Foster09,Fischer2015} is satisfied, meaning that $\lput$ is the inverse of $\lget$. \ locale wb_lens = weak_lens + assumes get_put: "put \ (get \) = \" begin lemma put_twice: "put (put \ v) v = put \ v" by (metis get_put put_get) lemma put_surjectivity: "\ \ v. put \ v = \" using get_put by blast lemma source_stability: "\ v. put \ v = \" using get_put by auto lemma source_UNIV [simp]: "\ = UNIV" by (metis UNIV_eq_I put_closure wb_lens.source_stability wb_lens_axioms) end declare wb_lens.get_put [simp] lemma wb_lens_weak [simp]: "wb_lens x \ weak_lens x" by (simp add: wb_lens_def) subsection \ Mainly Well-behaved Lenses \ text \ Mainly well-behaved lenses extend weak lenses with the PutPut law that shows how one put override a previous one. \ locale mwb_lens = weak_lens + assumes put_put: "put (put \ v) u = put \ u" begin lemma update_comp: "update f (update g \) = update (f \ g) \" by (simp add: put_get put_put update_def) text \ Mainly well-behaved lenses give rise to a weakened version of the $get-put$ law, where the source must be within the set of constructible sources. \ lemma weak_get_put: "\ \ \ \ put \ (get \) = \" by (auto simp add: lens_source_def put_get put_put) lemma weak_source_determination: assumes "\ \ \" "\ \ \" "get \ = get \" "put \ v = put \ v" shows "\ = \" by (metis assms put_put weak_get_put) lemma weak_put_eq: assumes "\ \ \" "get \ = k" "put \ u = put \ v" shows "put \ k = \" by (metis assms put_put weak_get_put) text \ Provides $s$ is constructible, then @{term get} can be uniquely determined from @{term put} \ lemma weak_get_via_put: "s \ \ \ get s = (THE v. put s v = s)" by (rule sym, auto intro!: the_equality weak_get_put, metis put_get) end declare mwb_lens.put_put [simp] declare mwb_lens.weak_get_put [simp] lemma mwb_lens_weak [simp]: "mwb_lens x \ weak_lens x" by (simp add: mwb_lens.axioms(1)) subsection \Very Well-behaved Lenses\ -text \Very well-behaved lenses combine all three laws, as in the literature~\<^cite>\"Foster09" and "Fischer2015"\.\ +text \Very well-behaved lenses combine all three laws, as in the literature~\cite{Foster09,Fischer2015}.\ locale vwb_lens = wb_lens + mwb_lens begin lemma source_determination: assumes "get \ = get \" "put \ v = put \ v" shows "\ = \" by (metis assms get_put put_put) lemma put_eq: assumes "get \ = k" "put \ u = put \ v" shows "put \ k = \" using assms weak_put_eq[of \ k u \ v] by (simp) text \ @{term get} can be uniquely determined from @{term put} \ lemma get_via_put: "get s = (THE v. put s v = s)" by (simp add: weak_get_via_put) end lemma vwb_lens_wb [simp]: "vwb_lens x \ wb_lens x" by (simp add: vwb_lens_def) lemma vwb_lens_mwb [simp]: "vwb_lens x \ mwb_lens x" using vwb_lens_def by auto subsection \ Ineffectual Lenses \ text \Ineffectual lenses can have no effect on the view type -- application of the $\lput$ function always yields the same source. They are thus, trivially, very well-behaved lenses.\ locale ief_lens = weak_lens + assumes put_inef: "put \ v = \" begin sublocale vwb_lens proof fix \ v u show "put \ (get \) = \" by (simp add: put_inef) show "put (put \ v) u = put \ u" by (simp add: put_inef) qed lemma ineffectual_const_get: "\ v. \ \\\. get \ = v" using put_get put_inef by auto end abbreviation "eff_lens X \ (weak_lens X \ (\ ief_lens X))" subsection \ Bijective Lenses \ text \Bijective lenses characterise the situation where the source and view type are equivalent: in other words the view type full characterises the whole source type. It is often useful when the view type and source type are syntactically different, but nevertheless correspond precisely in terms of what they observe. Bijective lenses are formulates using - the strong GetPut law~\<^cite>\"Foster09" and "Fischer2015"\.\ + the strong GetPut law~\cite{Foster09,Fischer2015}.\ locale bij_lens = weak_lens + assumes strong_get_put: "put \ (get \) = \" begin sublocale vwb_lens proof fix \ v u show "put \ (get \) = \" by (simp add: strong_get_put) show "put (put \ v) u = put \ u" by (metis bij_lens.strong_get_put bij_lens_axioms put_get) qed lemma put_bij: "bij_betw (put \) UNIV UNIV" by (metis bijI put_inj strong_get_put surj_def) lemma put_is_create: "\ \ \ \ put \ v = create v" by (metis create_get strong_get_put) lemma get_create: "\ \ \ \ create (get \) = \" by (simp add: lens_create_def strong_get_put) end declare bij_lens.strong_get_put [simp] declare bij_lens.get_create [simp] lemma bij_lens_weak [simp]: "bij_lens x \ weak_lens x" by (simp_all add: bij_lens_def) lemma bij_lens_vwb [simp]: "bij_lens x \ vwb_lens x" by (metis bij_lens.strong_get_put bij_lens_weak mwb_lens.intro mwb_lens_axioms.intro vwb_lens_def wb_lens.intro wb_lens_axioms.intro weak_lens.put_get) subsection \Lens Independence\ text \ \begin{figure} \begin{center} \includegraphics[width=6cm]{figures/Independence} \end{center} \vspace{-5ex} \caption{Lens Independence} \label{fig:Indep} \end{figure} Lens independence shows when two lenses $X$ and $Y$ characterise disjoint regions of the source type, as illustrated in Figure~\ref{fig:Indep}. We specify this by requiring that the $\lput$ functions of the two lenses commute, and that the $\lget$ function of each lens is unaffected by application of $\lput$ from the corresponding lens. \ locale lens_indep = fixes X :: "'a \ 'c" and Y :: "'b \ 'c" assumes lens_put_comm: "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \ v) u = put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \ u) v" and lens_put_irr1: "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \ v) = get\<^bsub>X\<^esub> \" and lens_put_irr2: "get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \ u) = get\<^bsub>Y\<^esub> \" notation lens_indep (infix "\" 50) lemma lens_indepI: "\ \ u v \. lens_put x (lens_put y \ v) u = lens_put y (lens_put x \ u) v; \ v \. lens_get x (lens_put y \ v) = lens_get x \; \ u \. lens_get y (lens_put x \ u) = lens_get y \ \ \ x \ y" by (simp add: lens_indep_def) text \Lens independence is symmetric.\ lemma lens_indep_sym: "x \ y \ y \ x" by (simp add: lens_indep_def) lemma lens_indep_sym': "(x \ y) = (y \ x)" by (auto simp: lens_indep_def) lemma lens_indep_comm: "x \ y \ lens_put x (lens_put y \ v) u = lens_put y (lens_put x \ u) v" by (simp add: lens_indep_def) lemma lens_indep_get [simp]: assumes "x \ y" shows "lens_get x (lens_put y \ v) = lens_get x \" using assms lens_indep_def by fastforce end \ No newline at end of file diff --git a/thys/Clean/src/Symbex_MonadSE.thy b/thys/Clean/src/Symbex_MonadSE.thy --- a/thys/Clean/src/Symbex_MonadSE.thy +++ b/thys/Clean/src/Symbex_MonadSE.thy @@ -1,567 +1,555 @@ (****************************************************************************** * Clean * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) theory Symbex_MonadSE imports Seq_MonadSE begin subsection\Definition and Properties of Valid Execution Sequences\ text\A key-notion in our framework is the \emph{valid} execution sequence, \ie{} a sequence that: \begin{enumerate} \item terminates (not obvious since while), \item results in a final @{term True}, \item does not fail globally (but recall the FailSave and FailPurge variants of @{term mbind}-operators, that handle local exceptions in one or another way). \end{enumerate} Seen from an automata perspective (where the monad - operations correspond to the step function), valid execution sequences can be used to model ``feasible paths'' across an automaton.\ definition valid_SE :: "'\ \ (bool,'\) MON\<^sub>S\<^sub>E \ bool" (infix "\" 9) where "(\ \ m) = (m \ \ None \ fst(the (m \)))" text\This notation consideres failures as valid -- a definition inspired by I/O conformance.\ subsubsection\Valid Execution Sequences and their Symbolic Execution\ lemma exec_unit_SE [simp]: "(\ \ (result P)) = (P)" by(auto simp: valid_SE_def unit_SE_def) lemma exec_unit_SE' [simp]: "(\\<^sub>0 \ (\\. Some (f \, \))) = (f \\<^sub>0)" by(simp add: valid_SE_def ) lemma exec_fail_SE [simp]: "(\ \ fail\<^sub>S\<^sub>E) = False" by(auto simp: valid_SE_def fail_SE_def) lemma exec_fail_SE'[simp]: "\(\\<^sub>0 \ (\\. None))" by(simp add: valid_SE_def ) text\The following the rules are in a sense the heart of the entire symbolic execution approach\ lemma exec_bind_SE_failure: "A \ = None \ \(\ \ ((s \ A ; M s)))" by(simp add: valid_SE_def unit_SE_def bind_SE_def) lemma exec_bind_SE_failure2: "A \ = None \ \(\ \ ((A ;- M)))" by(simp add: valid_SE_def unit_SE_def bind_SE_def bind_SE'_def) lemma exec_bind_SE_success: "A \ = Some(b,\') \ (\ \ ((s \ A ; M s))) = (\' \ (M b))" by(simp add: valid_SE_def unit_SE_def bind_SE_def ) lemma exec_bind_SE_success2: "A \ = Some(b,\') \ (\ \ ((A ;- M))) = (\' \ M)" by(simp add: valid_SE_def unit_SE_def bind_SE_def bind_SE'_def ) lemma exec_bind_SE_success': (* atomic boolean Monad "Query Functions" *) "M \ = Some(f \,\) \ (\ \ M) = f \" by(simp add: valid_SE_def unit_SE_def bind_SE_def ) lemma exec_bind_SE_success'': "\ \ ((s \ A ; M s)) \ \ v \'. the(A \) = (v,\') \ (\' \ M v)" apply(auto simp: valid_SE_def unit_SE_def bind_SE_def) apply(cases "A \", simp_all) apply(drule_tac x="A \" and f=the in arg_cong, simp) apply(rule_tac x="fst aa" in exI) apply(rule_tac x="snd aa" in exI, auto) done lemma exec_bind_SE_success''': "\ \ ((s \ A ; M s)) \ \ a. (A \) = Some a \ (snd a \ M (fst a))" apply(auto simp: valid_SE_def unit_SE_def bind_SE_def) apply(cases "A \", simp_all) apply(drule_tac x="A \" and f=the in arg_cong, simp) apply(rule_tac x="fst aa" in exI) apply(rule_tac x="snd aa" in exI, auto) done lemma exec_bind_SE_success'''' : "\ \ ((s \ A ; M s)) \ \ v \'. A \ = Some(v,\') \ (\' \ M v)" apply(auto simp: valid_SE_def unit_SE_def bind_SE_def) apply(cases "A \", simp_all) apply(drule_tac x="A \" and f=the in arg_cong, simp) apply(rule_tac x="fst aa" in exI) apply(rule_tac x="snd aa" in exI, auto) done lemma valid_bind_cong : " f \ = g \ \ (\ \ (x \ f ; M x)) = (\ \ (x \ g ; M x))" unfolding bind_SE'_def bind_SE_def valid_SE_def by simp lemma valid_bind'_cong : " f \ = g \ \ (\ \ f ;- M) = (\ \ g ;- M)" unfolding bind_SE'_def bind_SE_def valid_SE_def by simp text\Recall \verb+mbind_unit+ for the base case.\ lemma valid_mbind_mt : "(\ \ ( s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e [] f; unit\<^sub>S\<^sub>E (P s))) = P [] " by simp lemma valid_mbind_mtE: "\ \ ( s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e [] f; unit\<^sub>S\<^sub>E (P s)) \ (P [] \ Q) \ Q" by(auto simp: valid_mbind_mt) lemma valid_mbind'_mt : "(\ \ ( s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p [] f; unit\<^sub>S\<^sub>E (P s))) = P [] " by simp lemma valid_mbind'_mtE: "\ \ ( s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p [] f; unit\<^sub>S\<^sub>E (P s)) \ (P [] \ Q) \ Q" by(auto simp: valid_mbind'_mt) lemma valid_mbind''_mt : "(\ \ ( s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e [] f; unit\<^sub>S\<^sub>E (P s))) = P [] " by(simp add: mbind''.simps valid_SE_def bind_SE_def unit_SE_def) lemma valid_mbind''_mtE: "\ \ ( s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e [] f; unit\<^sub>S\<^sub>E (P s)) \ (P [] \ Q) \ Q" by(auto simp: valid_mbind''_mt) lemma exec_mbindFSave_failure: "ioprog a \ = None \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e (a#S) ioprog ; M s)) = (\ \ (M []))" by(simp add: valid_SE_def unit_SE_def bind_SE_def) lemma exec_mbindFStop_failure: "ioprog a \ = None \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p (a#S) ioprog ; M s)) = (False)" by(simp add: exec_bind_SE_failure) lemma exec_mbindFPurge_failure: "ioprog a \ = None \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e (a#S) ioprog ; M s)) = (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e (S) ioprog ; M s))" by(simp add: valid_SE_def unit_SE_def bind_SE_def mbind''.simps) lemma exec_mbindFSave_success : "ioprog a \ = Some(b,\') \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e (a#S) ioprog ; M s)) = (\' \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e S ioprog ; M (b#s)))" unfolding valid_SE_def unit_SE_def bind_SE_def by(cases "mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e S ioprog \'", auto) lemma exec_mbindFStop_success : "ioprog a \ = Some(b,\') \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p (a#S) ioprog ; M s)) = (\' \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S ioprog ; M (b#s)))" unfolding valid_SE_def unit_SE_def bind_SE_def by(cases "mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S ioprog \'", auto simp: mbind'.simps) lemma exec_mbindFPurge_success : "ioprog a \ = Some(b,\') \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e (a#S) ioprog ; M s)) = (\' \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e S ioprog ; M (b#s)))" unfolding valid_SE_def unit_SE_def bind_SE_def by(cases "mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e S ioprog \'", auto simp: mbind''.simps) lemma exec_mbindFSave: "(\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e (a#S) ioprog ; return (P s))) = (case ioprog a \ of None \ (\ \ (return (P []))) | Some(b,\') \ (\' \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e S ioprog ; return (P (b#s)))))" apply(case_tac "ioprog a \") apply(auto simp: exec_mbindFSave_failure exec_mbindFSave_success split: prod.splits) done lemma mbind_eq_sexec: assumes * : "\b \'. f a \ = Some(b,\') \ (os \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S f; P (b#os)) = (os \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S f; P' (b#os))" shows "( a \ f a; x \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S f; P (a # x)) \ = ( a \ f a; x \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S f; P'(a # x)) \" apply(cases "f a \ = None") apply(subst bind_SE_def, simp) apply(subst bind_SE_def, simp) apply auto apply(subst bind_SE_def, simp) apply(subst bind_SE_def, simp) apply(simp add: *) done lemma mbind_eq_sexec': assumes * : "\b \'. f a \ = Some(b,\') \ (P (b))\' = (P' (b))\'" shows "( a \ f a; P (a)) \ = ( a \ f a; P'(a)) \" apply(cases "f a \ = None") apply(subst bind_SE_def, simp) apply(subst bind_SE_def, simp) apply auto apply(subst bind_SE_def, simp) apply(subst bind_SE_def, simp) apply(simp add: *) done lemma mbind'_concat: "(os \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p (S@T) f; P os) = (os \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S f; os' \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p T f; P (os @ os'))" proof (rule ext, rename_tac "\", induct S arbitrary: \ P) case Nil show ?case by simp next case (Cons a S) show ?case apply(insert Cons.hyps, simp) by(rule mbind_eq_sexec',simp) qed lemma assert_suffix_inv : "\ \ ( _ \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p xs istep; assert\<^sub>S\<^sub>E (P)) \ \\. P \ \ (\ \ (_ \ istep x; assert\<^sub>S\<^sub>E (P))) \ \ \ ( _ \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p (xs @ [x]) istep; assert\<^sub>S\<^sub>E (P))" apply(subst mbind'_concat, simp) unfolding bind_SE_def assert_SE_def valid_SE_def apply(auto split: option.split option.split_asm) apply(case_tac "aa",simp_all) apply(case_tac "P bb",simp_all) apply (metis option.distinct(1)) apply(case_tac "aa",simp_all) apply(case_tac "P bb",simp_all) by (metis option.distinct(1)) text\Universal splitting and symbolic execution rule\ lemma exec_mbindFSave_E: assumes seq : "(\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e (a#S) ioprog ; (P s)))" and none: "ioprog a \ = None \ (\ \ (P [])) \ Q" and some: "\ b \'. ioprog a \ = Some(b,\') \ (\' \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e S ioprog;(P (b#s)))) \ Q " shows "Q" using seq proof(cases "ioprog a \") case None assume ass:"ioprog a \ = None" show "Q" apply(rule none[OF ass]) apply(insert ass, erule_tac ioprog1=ioprog in exec_mbindFSave_failure[THEN iffD1],rule seq) done next case (Some aa) assume ass:"ioprog a \ = Some aa" show "Q" apply(insert ass,cases "aa",simp, rename_tac "out" "\'") apply(erule some) apply(insert ass,simp) apply(erule_tac ioprog1=ioprog in exec_mbindFSave_success[THEN iffD1],rule seq) done qed text\The next rule reveals the particular interest in deduction; as an elimination rule, it allows for a linear conversion of a validity judgement @{term "mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p"} over an input list @{term "S"} into a constraint system; without any branching ... Symbolic execution can even be stopped tactically whenever @{term "ioprog a \ = Some(b,\')"} comes to a contradiction.\ lemma exec_mbindFStop_E: assumes seq : "(\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p (a#S) ioprog ; (P s)))" and some: "\b \'. ioprog a \ = Some(b,\') \ (\'\ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p S ioprog;(P(b#s)))) \ Q" shows "Q" using seq proof(cases "ioprog a \") case None assume ass:"ioprog a \ = None" show "Q" apply(insert ass seq) apply(drule_tac \=\ and S=S and M=P in exec_mbindFStop_failure, simp) done next case (Some aa) assume ass:"ioprog a \ = Some aa" show "Q" apply(insert ass,cases "aa",simp, rename_tac "out" "\'") apply(erule some) apply(insert ass,simp) apply(erule_tac ioprog1=ioprog in exec_mbindFStop_success[THEN iffD1],rule seq) done qed lemma exec_mbindFPurge_E: assumes seq : "(\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e (a#S) ioprog ; (P s)))" and none: "ioprog a \ = None \ (\ \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e S ioprog;(P (s)))) \ Q" and some: "\ b \'. ioprog a \ = Some(b,\') \ (\' \ (s \ mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>P\<^sub>u\<^sub>r\<^sub>g\<^sub>e S ioprog;(P (b#s)))) \ Q " shows "Q" using seq proof(cases "ioprog a \") case None assume ass:"ioprog a \ = None" show "Q" apply(rule none[OF ass]) apply(insert ass, erule_tac ioprog1=ioprog in exec_mbindFPurge_failure[THEN iffD1],rule seq) done next case (Some aa) assume ass:"ioprog a \ = Some aa" show "Q" apply(insert ass,cases "aa",simp, rename_tac "out" "\'") apply(erule some) apply(insert ass,simp) apply(erule_tac ioprog1=ioprog in exec_mbindFPurge_success[THEN iffD1],rule seq) done qed lemma assert_disch1 :" P \ \ (\ \ (x \ assert\<^sub>S\<^sub>E P; M x)) = (\ \ (M True))" by(auto simp: bind_SE_def assert_SE_def valid_SE_def) lemma assert_disch2 :" \ P \ \ \ (\ \ (x \ assert\<^sub>S\<^sub>E P ; M s))" by(auto simp: bind_SE_def assert_SE_def valid_SE_def) lemma assert_disch3 :" \ P \ \ \ (\ \ (assert\<^sub>S\<^sub>E P))" by(auto simp: bind_SE_def assert_SE_def valid_SE_def) lemma assert_disch4 :" P \ \ (\ \ (assert\<^sub>S\<^sub>E P))" by(auto simp: bind_SE_def assert_SE_def valid_SE_def) lemma assert_simp : "(\ \ assert\<^sub>S\<^sub>E P) = P \" by (meson assert_disch3 assert_disch4) lemmas assert_D = assert_simp[THEN iffD1] (* legacy *) lemma assert_bind_simp : "(\ \ (x \ assert\<^sub>S\<^sub>E P; M x)) = (P \ \ (\ \ (M True)))" by(auto simp: bind_SE_def assert_SE_def valid_SE_def split: HOL.if_split_asm) lemmas assert_bindD = assert_bind_simp[THEN iffD1] (* legacy *) lemma assume_D : "(\ \ (_ \ assume\<^sub>S\<^sub>E P; M)) \ \ \. (P \ \ (\ \ M) )" apply(auto simp: bind_SE_def assume_SE_def valid_SE_def split: HOL.if_split_asm) apply(rule_tac x="Eps P" in exI, auto) apply(subst Hilbert_Choice.someI,assumption,simp) done lemma assume_E : assumes * : "\ \ ( _ \ assume\<^sub>S\<^sub>E P; M) " and ** : "\ \. P \ \ \ \ M \ Q" shows "Q" apply(insert *) by(insert *[THEN assume_D], auto intro: **) lemma assume_E' : assumes * : "\ \ assume\<^sub>S\<^sub>E P ;- M" and ** : "\ \. P \ \ \ \ M \ Q" shows "Q" by(insert *[simplified "bind_SE'_def", THEN assume_D], auto intro: **) text\These two rule prove that the SE Monad in connection with the notion of valid sequence is actually sufficient for a representation of a Boogie-like language. The SBE monad with explicit sets of states --- to be shown below --- is strictly speaking not necessary (and will therefore be discontinued in the development).\ term "if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi" lemma if_SE_D1 : "P \ \ (\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi)) = (\ \ B\<^sub>1)" by(auto simp: if_SE_def valid_SE_def) lemma if_SE_D1' : "P \ \ (\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi);-M) = (\ \ (B\<^sub>1;-M))" by(auto simp: if_SE_def valid_SE_def bind_SE'_def bind_SE_def) lemma if_SE_D2 : "\ P \ \ (\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi)) = (\ \ B\<^sub>2)" by(auto simp: if_SE_def valid_SE_def) lemma if_SE_D2' : "\ P \ \ (\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi);-M) = (\ \ B\<^sub>2;-M)" by(auto simp: if_SE_def valid_SE_def bind_SE'_def bind_SE_def) lemma if_SE_split_asm : "(\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi)) = ((P \ \ (\ \ B\<^sub>1)) \ (\ P \ \ (\ \ B\<^sub>2)))" by(cases "P \",auto simp: if_SE_D1 if_SE_D2) lemma if_SE_split_asm': "(\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi);-M) = ((P \ \ (\ \ B\<^sub>1;-M)) \ (\ P \ \ (\ \ B\<^sub>2;-M)))" by(cases "P \",auto simp: if_SE_D1' if_SE_D2') lemma if_SE_split: "(\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi)) = ((P \ \ (\ \ B\<^sub>1)) \ (\ P \ \ (\ \ B\<^sub>2)))" by(cases "P \", auto simp: if_SE_D1 if_SE_D2) lemma if_SE_split': "(\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi);-M) = ((P \ \ (\ \ B\<^sub>1;-M)) \ (\ P \ \ (\ \ B\<^sub>2;-M)))" by(cases "P \", auto simp: if_SE_D1' if_SE_D2') lemma if_SE_execE: assumes A: "\ \ ((if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi))" and B: "P \ \ \ \ (B\<^sub>1) \ Q" and C: "\ P \\ \ \ (B\<^sub>2) \ Q" shows "Q" by(insert A [simplified if_SE_split],cases "P \", simp_all, auto elim: B C) lemma if_SE_execE': assumes A: "\ \ ((if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi);-M)" and B: "P \ \ \ \ (B\<^sub>1;-M) \ Q" and C: "\ P \\ \ \ (B\<^sub>2;-M) \ Q" shows "Q" by(insert A [simplified if_SE_split'],cases "P \", simp_all, auto elim: B C) lemma exec_while : "(\ \ ((while\<^sub>S\<^sub>E b do c od) ;- M)) = (\ \ ((if\<^sub>S\<^sub>E b then c ;- (while\<^sub>S\<^sub>E b do c od) else unit\<^sub>S\<^sub>E ()fi) ;- M))" apply(subst while_SE_unfold) by(simp add: bind_SE'_def ) lemmas exec_whileD = exec_while[THEN iffD1] lemma if_SE_execE'': "\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi) ;- M \ (P \ \ \ \ B\<^sub>1 ;- M \ Q) \ (\ P \ \ \ \ B\<^sub>2 ;- M \ Q) \ Q" by(auto elim: if_SE_execE') definition "opaque (x::bool) = x" lemma if_SE_execE''_pos: "\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi) ;- M \ (P \ \ \ \ B\<^sub>1 ;- M \ Q) \ (opaque (\ \ (if\<^sub>S\<^sub>E P then B\<^sub>1 else B\<^sub>2 fi) ;- M) \ Q) \ Q" using opaque_def by auto lemma [code]: "(\ \ m) = (case (m \) of None \ False | (Some (x,y)) \ x)" apply(simp add: valid_SE_def) apply(cases "m \ = None", simp_all) apply(insert not_None_eq, auto) done (* for the moment no good idea to state the case where the body eventually crashes. *) lemma "P \ \ (_ \ assume\<^sub>S\<^sub>E P ; x \ M; assert\<^sub>S\<^sub>E (\\. (x=X) \ Q x \))" oops lemma "\\. \ X. \ \ (_ \ assume\<^sub>S\<^sub>E P ; x \ M; assert\<^sub>S\<^sub>E (\\. x=X \ Q x \))" oops lemma monadic_sequence_rule: "\ X \\<^sub>1. (\ \ (_ \ assume\<^sub>S\<^sub>E (\\'. (\=\') \ P \) ; x \ M; assert\<^sub>S\<^sub>E (\\. (x=X) \ (\=\\<^sub>1) \ Q x \))) \ (\\<^sub>1 \ (_ \ assume\<^sub>S\<^sub>E (\\. (\=\\<^sub>1) \ Q x \) ; y \ M'; assert\<^sub>S\<^sub>E (\\. R x y \))) \ \ \ (_ \ assume\<^sub>S\<^sub>E (\\'. (\=\') \ P \) ; x \ M; y \ M'; assert\<^sub>S\<^sub>E (R x y))" apply(elim exE impE conjE) apply(drule assume_D) apply(elim exE impE conjE) unfolding valid_SE_def assume_SE_def assert_SE_def bind_SE_def apply(auto split: if_split HOL.if_split_asm Option.option.split Option.option.split_asm) apply (metis (mono_tags, lifting) option.simps(3) someI_ex) oops lemma "\ X. \ \ (_ \ assume\<^sub>S\<^sub>E P ; x \ M; assert\<^sub>S\<^sub>E (\\. x=X \ Q x \)) \ \ \ (_ \ assume\<^sub>S\<^sub>E P ; x \ M; assert\<^sub>S\<^sub>E (\\. Q x \))" unfolding valid_SE_def assume_SE_def assert_SE_def bind_SE_def by(auto split: if_split HOL.if_split_asm Option.option.split Option.option.split_asm) lemma exec_skip: "(\ \ skip\<^sub>S\<^sub>E ;- M) = (\ \ M)" by (simp add: skip\<^sub>S\<^sub>E_def) lemmas exec_skipD = exec_skip[THEN iffD1] text\Test-Refinements will be stated in terms of the failsave @{term mbind}, opting more generality. The following lemma allows for an optimization both in test execution as well as in symbolic execution for an important special case of the post-codition: Whenever the latter has the constraint that the length of input and output sequence equal each other (that is to say: no failure occured), failsave mbind can be reduced to failstop mbind ...\ lemma mbindFSave_vs_mbindFStop : "(\ \ (os \ (mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e \s ioprog); result(length \s = length os \ P \s os))) = (\ \ (os \ (mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p \s ioprog); result(P \s os)))" apply(rule_tac x=P in spec) apply(rule_tac x=\ in spec) proof(induct "\s") case Nil show ?case by(simp_all add: mbind_try try_SE_def del: Seq_MonadSE.mbind.simps) case (Cons a \s) show ?case apply(rule allI, rename_tac "\",rule allI, rename_tac "P") apply(insert Cons.hyps) apply(case_tac "ioprog a \") apply(simp only: exec_mbindFSave_failure exec_mbindFStop_failure, simp) apply(simp add: split_paired_all del: Seq_MonadSE.mbind.simps ) apply(rename_tac "\'") apply(subst exec_mbindFSave_success, assumption) apply(subst (2) exec_bind_SE_success, assumption) apply(erule_tac x="\'" in allE) apply(erule_tac x="\\s s. P (a # \s) (aa # s)" in allE) (* heureka ! *) apply(simp) done qed lemma mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e_vs_mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p: -assumes A: "\ \ \. ioprog \ \ \ None" +assumes A: "\ \\set \s. \ \. ioprog \ \ \ None" shows "(\ \ (os \ (mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e \s ioprog); P os)) = (\ \ (os \ (mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p \s ioprog); P os))" -proof(induct "\s") +proof(insert A, erule rev_mp, induct "\s") case Nil show ?case by simp next case (Cons a \s) from Cons.hyps have B:"\ S f \. mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e S f \ \ None " by simp - have C:"\\. mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p \s ioprog \ = mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e \s ioprog \" + + have C:"(\ \\set \s. \ \. ioprog \ \ \ None) + \ (\\. mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>t\<^sub>o\<^sub>p \s ioprog \ = mbind\<^sub>F\<^sub>a\<^sub>i\<^sub>l\<^sub>S\<^sub>a\<^sub>v\<^sub>e \s ioprog \)" apply(induct \s, simp) - apply(rule allI,rename_tac "\") + apply(intro impI allI,rename_tac "\") apply(simp add: Seq_MonadSE.mbind'.simps(2)) - apply(insert A, erule_tac x="a" in allE) + apply(insert A, erule_tac x="a" in ballE) apply(erule_tac x="\" and P="\\ . ioprog a \ \ None" in allE) apply(auto split:option.split) done - show ?case - apply(insert A,erule_tac x="a" in allE,erule_tac x="\" in allE) - apply(simp, elim exE) - apply(rename_tac "out" "\'") - apply(insert B, erule_tac x=\s in allE, erule_tac x=ioprog in allE, erule_tac x=\' in allE) - apply(subst(asm) not_None_eq, elim exE) - apply(subst exec_bind_SE_success) - apply(simp split: option.split, auto) - apply(rule_tac s="(\ a b c. a # (fst c)) out \' (aa, b)" in trans, simp,rule refl) - apply(rule_tac s="(\ a b c. (snd c)) out \' (aa, b)" in trans, simp,rule refl) - apply(simp_all) - apply(subst exec_bind_SE_success, assumption) - apply(subst exec_bind_SE_success) - apply(rule_tac s="Some (aa, b)" in trans,simp_all add:C) - apply(subst(asm) exec_bind_SE_success, assumption) - apply(subst(asm) exec_bind_SE_success) - apply(rule_tac s="Some (aa, b)" in trans,simp_all add:C) - done + show ?case + apply(intro impI) + by (smt (verit, best) C exec_mbindFSave_E exec_mbindFSave_success exec_mbindFStop_E + exec_mbindFStop_success list.set_intros(1) list.set_intros(2) valid_bind_cong) qed subsection\Miscellaneous\ no_notation unit_SE ("(result _)" 8) end \ No newline at end of file diff --git a/thys/Collections/ICF/tools/Locale_Code.thy b/thys/Collections/ICF/tools/Locale_Code.thy --- a/thys/Collections/ICF/tools/Locale_Code.thy +++ b/thys/Collections/ICF/tools/Locale_Code.thy @@ -1,385 +1,385 @@ section \Code Generation from Locales\ theory Locale_Code imports ICF_Tools Ord_Code_Preproc begin text \ Provides a simple mechanism to prepare code equations for constants stemming from locale interpretations. The usage pattern is as follows: \setup Locale_Code.checkpoint\ is called before a series of interpretations, and afterwards, \setup Locale_Code.prepare\ is called. Afterwards, the code generator will correctly recognize expressions involving terms from the locale interpretation. \ text \Tag to indicate pattern deletion\ definition LC_DEL :: "'a \ unit" where "LC_DEL a \ ()" ML \ signature LOCALE_CODE = sig type pat_eq = cterm * thm list val open_block: theory -> theory val close_block: theory -> theory val del_pat: cterm -> theory -> theory val add_pat_eq: cterm -> thm list -> theory -> theory val lc_decl_eq: thm list -> local_theory -> local_theory val lc_decl_del: term -> local_theory -> local_theory val setup: theory -> theory val get_unf_ss: theory -> simpset val tracing_enabled: bool Unsynchronized.ref end structure Locale_Code :LOCALE_CODE = struct open ICF_Tools val tracing_enabled = Unsynchronized.ref false; type pat_eq = cterm * thm list type block_data = {idx:int, del_pats: cterm list, add_pateqs: pat_eq list} val closed_block = {idx = ~1, del_pats=[], add_pateqs=[]}; fun init_block idx = {idx = idx, del_pats=[], add_pateqs=[]}; fun is_open ({idx,...}:block_data) = idx <> ~1; fun assert_open bd = if is_open bd then () else error "Locale_Code: No open block"; fun assert_closed bd = if is_open bd then error "Locale_Code: Block already open" else (); fun merge_bd (bd1,bd2) = ( if is_open bd1 orelse is_open bd2 then error "Locale_Code: Merge with open block" else (); closed_block ); fun bd_add_del_pats ps {idx,del_pats,add_pateqs} = {idx = idx, del_pats = ps@del_pats, add_pateqs = add_pateqs}; fun bd_add_add_pateqs pes {idx,del_pats,add_pateqs} = {idx = idx, del_pats = del_pats, add_pateqs = pes@add_pateqs}; structure BlockData = Theory_Data ( type T = block_data val empty = (closed_block) val merge = merge_bd ); structure FoldSSData = Oc_Simpset ( val prio = 5; val name = "Locale_Code"; ); fun add_unf_thms thms thy = let val ctxt = Proof_Context.init_global thy val thms = map Thm.symmetric thms in FoldSSData.map (fn ss => put_simpset ss ctxt |> sss_add thms |> simpset_of ) thy end val get_unf_ss = FoldSSData.get; (* First order match with fixed head *) fun match_fixed_head (pat,obj) = let (* Match heads *) val inst = Thm.first_order_match (chead_of pat, chead_of obj); val pat = Thm.instantiate_cterm inst pat; (* Now match whole pattern *) val inst = Thm.first_order_match (pat, obj); in inst end; val matches_fixed_head = can match_fixed_head; (* First order match of heads only *) fun match_heads (pat,obj) = Thm.first_order_match (chead_of pat, chead_of obj); val matches_heads = can match_heads; val pat_nargs = Thm.term_of #> strip_comb #> #2 #> length; (* Adjust a theorem to exactly match pattern *) fun norm_thm_pat (thm,pat) = let val thm = norm_def_thm thm; val na_pat = pat_nargs pat; val lhs = Thm.lhs_of thm; val na_lhs = pat_nargs lhs; val lhs' = if na_lhs > na_pat then funpow (na_lhs - na_pat) Thm.dest_fun lhs else lhs; val inst = Thm.first_order_match (lhs',pat); in Thm.instantiate inst thm end; fun del_pat_matches cpat (epat,_) = if pat_nargs cpat = 0 then matches_heads (cpat,epat) else matches_fixed_head (cpat,epat); (* Pattern-Eqs from specification *) local datatype action = ADD of (cterm * thm list) | DEL of cterm fun filter_pat_eq thy thms pat = let val cpat = Thm.global_cterm_of thy pat; in if (pat_nargs cpat = 0) then NONE else let val thms' = fold (fn thm => fn acc => case try norm_thm_pat (thm, cpat) of NONE => acc | SOME thm => thm::acc ) thms []; in case thms' of [] => NONE | _ => SOME (ADD (cpat,thms')) end end; fun process_actions acc [] = acc | process_actions acc (ADD peq::acts) = process_actions (peq::acc) acts | process_actions acc (DEL cpat::acts) = let val acc' = filter (not o curry renames_cterm cpat o fst) acc; val _ = if length acc = length acc' then warning ("Locale_Code: LC_DEL without effect: " ^ @{make_string} cpat) else (); in process_actions acc' acts end; fun pat_eqs_of_spec thy {rough_classification = Spec_Rules.Equational _, terms = pats, rules = thms, ...} = map_filter (filter_pat_eq thy thms) pats | pat_eqs_of_spec thy {rough_classification = Spec_Rules.Unknown, terms = [Const (@{const_name LC_DEL},_)$pat], ...} = [(DEL (Thm.global_cterm_of thy pat))] | pat_eqs_of_spec _ _ = []; in fun pat_eqs_of_specs thy specs = map (pat_eqs_of_spec thy) specs |> flat |> rev |> process_actions []; end; fun is_proper_pat cpat = let val pat = Thm.term_of cpat; val (f,args) = strip_comb pat; in is_Const f andalso args <> [] andalso not (is_Var (hd (rev args))) end; (* Instantiating pattern-eq *) local (* Get constant name for instantiation pattern *) fun inst_name lthy pat = let val (fname,params) = case strip_comb pat of ((Const (fname,_)),params) => (fname,params) | _ => raise TERM ("inst_name: Expected pattern",[pat]); fun pname (Const (n,_)) = Long_Name.base_name n | pname (s$t) = pname s ^ "_" ^ pname t | pname _ = Name.uu; in space_implode "_" (Long_Name.base_name fname::map pname params) |> gen_variant (can (Proof_Context.read_const {proper = true, strict = false} lthy)) end; in fun inst_pat_eq (cpat,thms) = wrap_lthy_result_global (fn lthy => let val (((instT,inst),thms),lthy) = Variable.import true thms lthy; val cpat = Thm.instantiate_cterm (instT, inst) cpat; val pat = Thm.term_of cpat; val name = inst_name lthy pat; val ((_,(_,def_thm)),lthy) = Local_Theory.define ((Binding.name name,NoSyn), ((Binding.name (Thm.def_name name),[]),pat)) lthy; val thms' = map (Local_Defs.fold lthy [def_thm]) thms; in ((def_thm,thms'),lthy) end) (fn m => fn (def_thm,thms') => (Morphism.thm m def_thm, map (Morphism.thm m) thms')) #> (fn ((def_thm,thms'),thy) => let val thy = thy |> add_unf_thms [def_thm] |> Code.declare_default_eqns_global (map (rpair true) thms'); in thy end) end (* Bookkeeping *) fun new_specs thy = let val bd = BlockData.get thy; val _ = assert_open bd; val ctxt = Proof_Context.init_global thy; val srules = Spec_Rules.get ctxt; val res = take (length srules - #idx bd) srules; in res end fun open_block thy = let val bd = BlockData.get thy; val _ = assert_closed bd; val ctxt = Proof_Context.init_global thy; val idx = length (Spec_Rules.get ctxt); val thy = BlockData.map (K (init_block idx)) thy; in thy end; fun process_block bd thy = let fun filter_del_pats cpat peqs = let val peqs' = filter (not o del_pat_matches cpat) peqs val _ = if length peqs = length peqs' then warning ("Locale_Code: No pattern-eqs matching filter: " ^ @{make_string} cpat) else (); in peqs' end; fun filter_add_pats (orig_pat,_) = forall (fn (add_pat,_) => not (renames_cterm (orig_pat,add_pat))) (#add_pateqs bd); val specs = new_specs thy; val peqs = pat_eqs_of_specs thy specs |> fold filter_del_pats (#del_pats bd) |> filter filter_add_pats; val peqs = peqs @ #add_pateqs bd; val peqs = rev peqs; (* Important: Process equations in the order in that they have been added! *) val _ = if !tracing_enabled then map (fn peq => (tracing (@{make_string} peq); ())) peqs else []; val thy = thy |> fold inst_pat_eq peqs; in thy end; fun close_block thy = let val bd = BlockData.get thy; val _ = assert_open bd; val thy = process_block bd thy |> BlockData.map (K closed_block); in thy end; fun del_pat cpat thy = let val bd = BlockData.get thy; val _ = assert_open bd; val bd = bd_add_del_pats [cpat] bd; val thy = BlockData.map (K bd) thy; in thy end; fun add_pat_eq cpat thms thy = let val _ = is_proper_pat cpat orelse raise CTERM ("add_pat_eq: Not a proper pattern",[cpat]); fun ntp thm = case try norm_thm_pat (thm,cpat) of NONE => raise THM ("add_pat_eq: Theorem does not match pattern",~1,[thm]) | SOME thm => thm; val thms = map ntp thms; val thy = BlockData.map (bd_add_add_pateqs [(cpat,thms)]) thy; in thy end; local fun cpat_of_thm thm = let fun strip ct = case Thm.term_of ct of (_$Var _) => strip (Thm.dest_fun ct) | _ => ct; in strip (Thm.lhs_of thm) end; fun adjust_length (cpat1,cpat2) = let val n1 = cpat1 |> Thm.term_of |> strip_comb |> #2 |> length; val n2 = cpat2 |> Thm.term_of |> strip_comb |> #2 |> length; in if n1>n2 then (funpow (n1-n2) Thm.dest_fun cpat1, cpat2) else (cpat1, funpow (n2-n1) Thm.dest_fun cpat2) end fun find_match cpat cpat' = SOME (cpat,rename_cterm (cpat',cpat)) handle Pattern.MATCH => (case Thm.term_of cpat' of _$_ => find_match (Thm.dest_fun cpat) (Thm.dest_fun cpat') | _ => NONE ); (* Common head of definitional theorems *) fun comp_head thms = case map norm_def_thm thms of [] => NONE | thm::thms => let fun ch [] r = SOME r | ch (thm::thms) (cpat,acc) = let val cpat' = cpat_of_thm thm; val (cpat,cpat') = adjust_length (cpat,cpat') in case find_match cpat cpat' of NONE => NONE | SOME (cpat,inst) => ch thms (cpat, Drule.instantiate_normalize inst thm :: acc) end; in ch thms (cpat_of_thm thm,[thm]) end; in fun lc_decl_eq thms lthy = case comp_head thms of SOME (cpat,thms) => let val _ = if !tracing_enabled then tracing ("decl_eq: " ^ @{make_string} cpat ^ ": " ^ @{make_string} thms) else (); fun decl m = let val cpat'::thms' = Morphism.fact m (Drule.mk_term cpat :: thms); val cpat' = Drule.dest_term cpat'; in Context.mapping (BlockData.map (bd_add_add_pateqs [(cpat',thms')])) I end in - lthy |> Local_Theory.declaration {syntax = false, pervasive = false} decl + lthy |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} decl end | NONE => raise THM ("Locale_Code.lc_decl_eq: No common pattern",~1,thms); end; fun lc_decl_del pat = let val ty = fastype_of pat; val dpat = Const (@{const_name LC_DEL},ty --> @{typ unit})$pat; in Spec_Rules.add Binding.empty Spec_Rules.Unknown [dpat] [] end (* Package setup *) val setup = FoldSSData.setup; end \ setup Locale_Code.setup attribute_setup lc_delete = \ Parse.and_list1' ICF_Tools.parse_cpat >> (fn cpats => Thm.declaration_attribute (K (Context.mapping (fold Locale_Code.del_pat cpats) I))) \ "Locale_Code: Delete patterns for current block" attribute_setup lc_add = \ Parse.and_list1' (ICF_Tools.parse_cpat -- Attrib.thms) >> (fn peqs => Thm.declaration_attribute (K (Context.mapping (fold (uncurry Locale_Code.add_pat_eq) peqs) I))) \ "Locale_Code: Add pattern-eqs for current block" end diff --git a/thys/ConcurrentIMP/cimp.ML b/thys/ConcurrentIMP/cimp.ML --- a/thys/ConcurrentIMP/cimp.ML +++ b/thys/ConcurrentIMP/cimp.ML @@ -1,140 +1,139 @@ (* Pollutes the global namespace, but we use them everywhere *) fun ss_only thms ctxt = clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps thms; fun HOL_ss_only thms ctxt = clear_simpset (put_simpset HOL_ss ctxt) addsimps thms; signature CIMP = sig val com_locs_fold : (term * 'b -> 'b) -> 'b -> term -> 'b val com_locs_map : (term -> 'b) -> term -> 'b list val com_locs_fold_no_response : (term * 'b -> 'b) -> 'b -> term -> 'b val com_locs_map_no_response : (term -> 'b) -> term -> 'b list val intern_com : Facts.ref -> local_theory -> local_theory val def_locset : thm -> local_theory -> local_theory end; structure Cimp : CIMP = struct fun com_locs_fold f x (Const (@{const_name Request}, _) $ l $ _ $ _ ) = f (l, x) | com_locs_fold f x (Const (@{const_name Response}, _) $ l $ _) = f (l, x) | com_locs_fold f x (Const (@{const_name LocalOp}, _) $ l $ _) = f (l, x) | com_locs_fold f x (Const (@{const_name Cond1}, _) $ l $ _ $ c) = com_locs_fold f (f (l, x)) c | com_locs_fold f x (Const (@{const_name Cond2}, _) $ l $ _ $ c1 $ c2) = com_locs_fold f (com_locs_fold f (f (l, x)) c1) c2 | com_locs_fold f x (Const (@{const_name Loop}, _) $ c) = com_locs_fold f x c | com_locs_fold f x (Const (@{const_name While}, _) $ l $ _ $ c) = com_locs_fold f (f (l, x)) c | com_locs_fold f x (Const (@{const_name Seq}, _) $ c1 $ c2) = com_locs_fold f (com_locs_fold f x c1) c2 | com_locs_fold f x (Const (@{const_name Choose}, _) $ c1 $ c2) = com_locs_fold f (com_locs_fold f x c1) c2 | com_locs_fold _ x _ = x; fun com_locs_map f com = com_locs_fold (fn (l, acc) => f l :: acc) [] com fun com_locs_fold_no_response f x (Const (@{const_name Request}, _) $ l $ _ $ _ ) = f (l, x) | com_locs_fold_no_response _ x (Const (@{const_name Response}, _) $ _ $ _) = x (* can often ignore \Response\ *) | com_locs_fold_no_response f x (Const (@{const_name LocalOp}, _) $ l $ _) = f (l, x) | com_locs_fold_no_response f x (Const (@{const_name Cond1}, _) $ l $ _ $ c) = com_locs_fold_no_response f (f (l, x)) c | com_locs_fold_no_response f x (Const (@{const_name Cond2}, _) $ l $ _ $ c1 $ c2) = com_locs_fold_no_response f (com_locs_fold_no_response f (f (l, x)) c1) c2 | com_locs_fold_no_response f x (Const (@{const_name Loop}, _) $ c) = com_locs_fold_no_response f x c | com_locs_fold_no_response f x (Const (@{const_name While}, _) $ l $ _ $ c) = com_locs_fold_no_response f (f (l, x)) c | com_locs_fold_no_response f x (Const (@{const_name Seq}, _) $ c1 $ c2) = com_locs_fold_no_response f (com_locs_fold_no_response f x c1) c2 | com_locs_fold_no_response f x (Const (@{const_name Choose}, _) $ c1 $ c2) = com_locs_fold_no_response f (com_locs_fold_no_response f x c1) c2 | com_locs_fold_no_response _ x _ = x; fun com_locs_map_no_response f com = com_locs_fold_no_response (fn (l, acc) => f l :: acc) [] com fun cprop_of_equality ctxt : thm -> cterm = Local_Defs.meta_rewrite_rule ctxt (* handle `=` or `\` *) #> Thm.cprop_of fun equality_lhs ctxt : thm -> term = cprop_of_equality ctxt #> Thm.dest_equals_lhs #> Thm.term_of fun equality_rhs ctxt : thm -> term = cprop_of_equality ctxt #> Thm.dest_equals_rhs #> Thm.term_of (* Intern all labels mentioned in CIMP programs \facts\ FIXME can only use \com_intern\ once per locale FIXME forces all labels to be unique and distinct from other constants in the locale. FIXME assumes the labels are character strings *) fun intern_com facts ctxt : local_theory = let val thms = Proof_Context.get_fact ctxt facts (* Define constants with defs of the form loc.XXX_def: "XXX \ ''XXX''. *) val attrs = [] fun add_literal_def (literal, (loc_defs, ctxt)) : thm list * local_theory = let val literal_name = HOLogic.dest_string literal (* FIXME might not be a nice name, but the error is readable so shrug. FIXME generalise to other label types *) val literal_def_binding = Binding.empty (* Binding.qualify true "loc" (Binding.name (Thm.def_name literal_name)) No need to name individual defs *) val ((_, (_, loc_def)), ctxt) = Local_Theory.define ((Binding.name literal_name, Mixfix.NoSyn), ((literal_def_binding, attrs), literal)) ctxt in (loc_def :: loc_defs, ctxt) end; val (loc_defs, ctxt) = List.foldl (fn (com, acc) => com_locs_fold add_literal_def acc (equality_rhs ctxt com)) ([], ctxt) thms val coms_interned = List.map (Local_Defs.fold ctxt loc_defs) thms val attrs = [] val (_, ctxt) = Local_Theory.note ((@{binding "loc_defs"}, attrs), loc_defs) ctxt val (_, ctxt) = Local_Theory.note ((@{binding "com_interned"}, attrs), coms_interned) ctxt in ctxt end; (* Cache location set membership facts. Decide membership in the given set for each label in the CIMP programs in the Named_Theorems "com". If the label set and com types differ, we probably get a nasty error. *) fun def_locset thm ctxt = let val set_name = equality_lhs ctxt thm val set_name_str = case set_name of Const (c, _) => c | Free (c, _) => c | _ => error ("Not an equation of the form x = set: " ^ Thm.string_of_thm ctxt thm) val memb_thm_name = Binding.qualify true set_name_str (Binding.name "memb") fun mk_memb l = Thm.cterm_of ctxt (HOLogic.mk_mem (l, set_name)) (* 1. solve atomic membership yielding \''label'' \ set\ or \''label'' \ set\. 2. fold \loc_defs\ 3. cleanup with the existing \locset_cache\. FIXME trim simpsets: 1: sets 2: not much 3: not much *) val loc_defs = Proof_Context.get_fact ctxt (Facts.named "loc_defs") val membership_ctxt = ctxt addsimps ([thm] @ loc_defs) val cleanup_ctxt = HOL_ss_only (@{thms cleanup_simps} @ Named_Theorems.get ctxt \<^named_theorems>\locset_cache\) ctxt val rewrite_tac = Simplifier.rewrite membership_ctxt #> Local_Defs.fold ctxt loc_defs #> Simplifier.simplify cleanup_ctxt val coms = Proof_Context.get_fact ctxt (Facts.named "com_interned") (* Parallel *) fun mk_thms coms : thm list = Par_List.map rewrite_tac (maps (equality_rhs ctxt #> com_locs_map_no_response mk_memb) coms) (* Sequential *) (* fun mk_thms coms = List.foldl (fn (c, thms) => com_locs_fold (fn l => fn thms => rewrite_tac (mk_memb l) :: thms) thms c) [] coms *) val attrs = [] val (_, ctxt) = ctxt |> Local_Theory.note ((memb_thm_name, attrs), mk_thms coms) (* Add \memb_thms\ to the global (and inherited by locales) \locset_cache\ *) val memb_thm_full_name = Local_Theory.full_name ctxt memb_thm_name val (finish, ctxt) = Target_Context.switch_named_cmd (SOME ("-", Position.none)) (Context.Proof ctxt) (* switch to the "root" local theory *) val memb_thms = Proof_Context.get_fact ctxt (Facts.named memb_thm_full_name) - val attrs = [Attrib.internal (K (Named_Theorems.add \<^named_theorems>\locset_cache\))] - val (_, ctxt) = ctxt |> Local_Theory.note ((Binding.empty, attrs), memb_thms) + val (_, ctxt) = ctxt |> Local_Theory.note ((Binding.empty, @{attributes [locset_cache]}), memb_thms) val ctxt = case finish ctxt of Context.Proof ctxt => ctxt | _ => error "Context.generic failure" (* Return to the locale we were in *) in ctxt end; end; val _ = Outer_Syntax.local_theory \<^command_keyword>\intern_com\ "intern labels in CIMP commands" (Parse.thms1 >> (fn facts => fn ctxt => List.foldl (fn ((f, _), ctxt) => Cimp.intern_com f ctxt) ctxt facts)); val _ = Outer_Syntax.local_theory' \<^command_keyword>\locset_definition\ "constant definition for sets of locations" (Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) -- Parse_Spec.if_assumes -- Parse.for_fixes >> (fn (((decl, spec), prems), params) => fn b => fn lthy => Specification.definition_cmd decl params prems spec b lthy |> (fn ((_, (_, thm)), lthy) => (thm, lthy)) |> uncurry Cimp.def_locset)); diff --git a/thys/Conditional_Transfer_Rule/CTR/CTR_Postprocessing.ML b/thys/Conditional_Transfer_Rule/CTR/CTR_Postprocessing.ML --- a/thys/Conditional_Transfer_Rule/CTR/CTR_Postprocessing.ML +++ b/thys/Conditional_Transfer_Rule/CTR/CTR_Postprocessing.ML @@ -1,108 +1,108 @@ (* Title: CTR/CTR_Postprocessing.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins Postprocessing of the output of the algorithms associated with the CTR. *) signature CTR_POSTPROCESSING = sig val postprocess_parametricity : binding -> thm -> local_theory -> ctr_pp_out val postprocess_relativization : binding -> mixfix -> thm -> Proof.context -> ctr_pp_out val postprocess_failure : Proof.context -> ctr_pp_out end; structure CTR_Postprocessing : CTR_POSTPROCESSING = struct open CTR_Utilities; (*post-processing of an arbitrary transfer rule*) fun postprocess_transfer_rule b thm ctxt = let val b = ((b |> Binding.path_of |> map fst) @ [Binding.name_of b, "transfer"]) |> Long_Name.implode |> Binding.qualified_name_mandatory val lthy = ctxt |> Local_Theory.note ( - (b, Transfer.transfer_add |> K |> Attrib.internal |> single), + (b, Transfer.transfer_add |> K |> Attrib.internal \<^here> |> single), single thm ) |>> #2 |>> the_single |> #2 val _ = let val lthy_print = ("Transfer.lifting_syntax" |> single |> Bundle.includes) lthy in thm |> single |> (Local_Theory.full_name lthy_print b |> thm_printer lthy_print true) end in lthy end; (*post-processing of a parametricity property*) fun postprocess_parametricity b thm ctxt = PPParametricity (thm, postprocess_transfer_rule b thm ctxt); (*post-processing of a relativization*) fun postprocess_relativization b mf thm ctxt = let val (_, rhst, _) = thm |> Thm.concl_of |> HOLogic.dest_Trueprop |> CTR_Conversions.dest_trt val (rhst, ctxt') = rhst |> Logic.unvarify_local_term (Local_Theory.begin_nested ctxt |> snd) val (absts, rhst) = rhst |> Term.strip_abs_eta (rhst |> strip_abs_vars |> length) val argts = rhst |> (fn t => Term.add_frees t []) |> rev |> subtract op= absts |> curry (swap #> op@) absts |> map Free val (lhst, lthy) = let fun declare_const_with thy = let val T = map type_of argts ---> type_of rhst in Sign.declare_const_global ((b, T), mf) thy end in Local_Theory.raw_theory_result declare_const_with ctxt' end val lhst = Term.list_comb (lhst, argts) fun make_with_def thy = let val b = ((b |> Binding.path_of |> map fst) @ [Binding.name_of b ^ "_def"]) |> Long_Name.implode |> Binding.qualified_name_mandatory in Global_Theory.add_defs false (single ((b, Logic.mk_equals (lhst, rhst)), [])) thy |>> the_single end val (ow_def_thm, lthy') = Local_Theory.raw_theory_result make_with_def lthy val _ = ow_def_thm |> single |> (ow_def_thm |> Thm.derivation_name |> thm_printer lthy' true) val thm' = thm |> singleton (Proof_Context.export ctxt lthy') |> Thm.pure_unfold lthy' (ow_def_thm |> Thm.symmetric |> single) val lthy'' = Local_Theory.end_nested lthy' val thm'' = singleton (Proof_Context.export lthy' lthy'') thm' val ow_def_thm'' = singleton (Proof_Context.export lthy' lthy'') ow_def_thm in ((ow_def_thm'', thm''), postprocess_transfer_rule b thm'' lthy'') |> PPRelativization end; (*post-processing of a failed attempt to perform relativization*) fun postprocess_failure lthy = PPFailure lthy; end; \ No newline at end of file diff --git a/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML b/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML --- a/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML +++ b/thys/Conditional_Transfer_Rule/CTR/CTR_Relators.ML @@ -1,225 +1,225 @@ (* Title: CTR/CTR_Relators.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins Implementation of the functionality associated with the ctr relators, including the command ctr_relator for registering the ctr relators. *) signature CTR_RELATORS = sig structure RelatorData: GENERIC_DATA val get_relator_data_generic : Context.generic -> RelatorData.T val get_relator_data_proof : Proof.context -> RelatorData.T val get_relator_data_global : theory -> RelatorData.T val relator_of_generic : Context.generic -> Symtab.key -> term option val relator_of_proof : Proof.context -> Symtab.key -> term option val relator_of_global : theory -> Symtab.key -> term option val update_relator : Symtab.key -> term -> local_theory -> local_theory val process_ctr_relator : string -> Proof.context -> local_theory val pr_of_typ : Proof.context -> ((string * sort) * term) list -> typ -> term val bnf_relator_of_type_name : Proof.context -> string -> term option end; structure CTR_Relators : CTR_RELATORS = struct (**** Data ****) (*** Data container ***) structure RelatorData = Generic_Data ( type T = term Symtab.table val empty = Symtab.empty val merge = Symtab.merge (K true) ); (*** Generic operations on the relator data ***) val get_relator_data_generic = RelatorData.get; val get_relator_data_proof = Context.Proof #> get_relator_data_generic; val get_relator_data_global = Context.Theory #> get_relator_data_generic; fun relator_of_generic context = context |> get_relator_data_generic |> Symtab.lookup #> ( context |> Context.theory_of |> (Morphism.transfer_morphism #> Morphism.term) |> Option.map ); val relator_of_proof = Context.Proof #> relator_of_generic; val relator_of_global = Context.Theory #> relator_of_generic; fun update_relator k rel = Local_Theory.declaration - {pervasive=true, syntax=false} + {pervasive=true, syntax=false, pos = \<^here>} (fn phi => (k, Morphism.term phi rel) |> Symtab.update |> RelatorData.map); (**** User input analysis ****) fun mk_msg_ctr_relator msg = "ctr_relator: " ^ msg; val mk_msg_not_const = "the input must be a constant term"; val mk_msg_not_body_bool = "the body of the type of the input must be bool"; val mk_msg_not_binders_2 = "the type of the input must have more than two binders"; val mk_msg_not_binders_binrelT = "all of the binders associated with the type of the input" ^ "except the last two must be the binary relation types"; val mk_msg_no_dup_binrelT = "the types of the binders of the binary relations associated " ^ "with the type of the input must have no duplicates"; val mk_msg_not_binders_binrelT_ftv_stv = "the types of the binders of the binary relation types associated " ^ "with the input type must be either free type variables or " ^ "schematic type variables"; val mk_msg_not_type_constructor = "the last two binders of the input type must be " ^ "the results of an application of a type constructor"; val mk_msg_not_identical_type_constructors = "the type constructors that are associated with the last two binders " ^ "of the input type must be identical"; val mk_msg_not_identical_input_types = "the sequences of the input types to the type constructors that are " ^ "associated with the last two binders of the input type must be " ^ "identical to the sequences of the types formed by concatenating the " ^ "type variables associated with the left hand side and the right " ^ "hand side of the binary relation types, respectively"; (**** Command for the registration of ctr relators ****) fun relator_type_name_of_type T = let val _ = T |> body_type |> curry op= HOLogic.boolT orelse error (mk_msg_ctr_relator mk_msg_not_body_bool) val binders = binder_types T val n = length binders val _ = n |> (fn n => n > 2) orelse error (mk_msg_ctr_relator mk_msg_not_binders_2) val (relTs, (mainT_lhs, mainT_rhs)) = binders |> chop (n - 2) ||> chop 1 ||> apfst the_single ||> apsnd the_single val _ = relTs |> map HOLogic.is_binrelT |> List.all I orelse error (mk_msg_ctr_relator mk_msg_not_binders_binrelT) val (lhs_tvars, rhs_tvars) = relTs |> map HOLogic.dest_binrelT |> split_list val tvars = lhs_tvars @ rhs_tvars val _ = tvars |> has_duplicates op= |> not orelse error (mk_msg_ctr_relator mk_msg_no_dup_binrelT) val _ = tvars |> map (fn T => is_TVar T orelse is_TFree T) |> List.all I orelse error (mk_msg_ctr_relator mk_msg_not_binders_binrelT_ftv_stv) val _ = is_Type mainT_lhs orelse error (mk_msg_ctr_relator mk_msg_not_type_constructor) val _ = is_Type mainT_rhs orelse error (mk_msg_ctr_relator mk_msg_not_type_constructor) val mainT_lhs = dest_Type mainT_lhs val mainT_rhs = dest_Type mainT_rhs val _ = op= (apply2 #1 (mainT_lhs, mainT_rhs)) orelse error (mk_msg_ctr_relator mk_msg_not_identical_type_constructors) val _ = lhs_tvars = #2 mainT_lhs orelse error (mk_msg_ctr_relator mk_msg_not_identical_input_types) val _ = rhs_tvars = #2 mainT_rhs orelse error (mk_msg_ctr_relator mk_msg_not_identical_input_types) in #1 mainT_lhs end; fun process_ctr_relator args ctxt = let val t = Syntax.read_term ctxt args val _ = is_Const t orelse error (mk_msg_ctr_relator mk_msg_not_const) val c = relator_type_name_of_type (type_of t) in update_relator c t ctxt end; val _ = Outer_Syntax.local_theory \<^command_keyword>\ctr_relator\ "registration of the ctr relators" (Parse.const >> process_ctr_relator); (**** ctr relators combined with the bnf relators ****) fun bnf_relator_of_type_name ctxt c = let fun bnf_relator_of_type_name ctxt c = let val relator_of_bnf = BNF_Def.rel_of_bnf #> strip_comb #> #1 #> dest_Const #> #1 #> Syntax.read_term ctxt #> Logic.varify_global in c |> BNF_Def.bnf_of ctxt |> Option.map relator_of_bnf end in case relator_of_proof ctxt c of SOME t => SOME t | NONE => bnf_relator_of_type_name ctxt c end; (**** Conversion of a type to a parametricity relation ****) (* The algorithm follows an outline of an algorithm for a similar purpose suggested in section 4.1 of the Ph.D. thesis of Ondřej Kunčar titled "Types, Abstraction and Parametric Polymorphism in Higher-Order Logic". *) fun pr_of_typ ctxt ftv_spec_relt T = let fun pr_of_typ _ trel (TFree ftv_spec) = trel ftv_spec | pr_of_typ _ _ (Type (c, [])) = Const ( \<^const_name>\HOL.eq\, HOLogic.mk_binrelT (Type (c, []), Type (c, [])) ) | pr_of_typ relator_of_type_name trel (Type (c, Ts)) = let val constt = relator_of_type_name c handle Option => raise TYPE ("pr_of_typ: no relator", [Type (c, Ts)], []) val constT = type_of constt val binders = constT |> binder_types |> take (length Ts) val argts = map (pr_of_typ relator_of_type_name trel) Ts val argTs = map type_of argts val tyenv_match = Type.typ_matches (Proof_Context.tsig_of ctxt) (binders, argTs) Vartab.empty handle Type.TYPE_MATCH => raise TYPE ("pr_of_typ: invalid relator", [Type (c, Ts)], []) val constt = constt |> dest_Const ||> K (Envir.subst_type tyenv_match constT) |> Const in list_comb (constt, argts) end | pr_of_typ _ _ T = raise TYPE ("pr_of_typ: type", single T, []) val trel = AList.lookup op= ftv_spec_relt #> the in pr_of_typ (bnf_relator_of_type_name ctxt #> the) trel T end; end; \ No newline at end of file diff --git a/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy b/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy --- a/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy +++ b/thys/Conditional_Transfer_Rule/CTR/Tests/CTR_Tests.thy @@ -1,252 +1,252 @@ (* Title: CTR/Tests/CTR_Tests.thy Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins A test suite for the sub-framework CTR. *) section\A test suite for CTR\ theory CTR_Tests imports "../CTR" "../../IML_UT/IML_UT" Complex_Main keywords "ctr_test" :: thy_defn begin subsection\Background\ ML\ type ctr_test_data = { ctr_type : string, synthesis : (string * thm list option) option, elems: (string, string, Facts.ref) Element.ctxt list, type_specs : (string * string) list, thm_specs : ((binding option * thm) * mixfix) list }; structure CTRTestData = Generic_Data ( type T = ctr_test_data Symtab.table val empty = Symtab.empty val merge = Symtab.merge (K true) ); val get_ctr_test_data_generic = CTRTestData.get; val get_ctr_test_data_proof = Context.Proof #> get_ctr_test_data_generic; val get_ctr_test_data_global = Context.Theory #> get_ctr_test_data_generic; fun test_data_of_generic context = context |> get_ctr_test_data_generic |> Symtab.lookup; val ctr_test_data_of_proof = Context.Proof #> test_data_of_generic; (*oversimplified: to be used with care*) fun update_ctr_test_data k ctr_test_data = Local_Theory.declaration - {pervasive=true, syntax=false} + {pervasive=true, syntax=false, pos = \<^here>} (fn _ => (k, ctr_test_data) |> Symtab.update |> CTRTestData.map); fun process_ctr_test_data (k, args) (lthy : local_theory) = let fun preprocess_thm_specs lthy = map (apfst (apsnd (singleton (Attrib.eval_thms lthy)))) fun process_ctrs_impl (CTR.ALG_PP _) (lthy : local_theory) = lthy | process_ctrs_impl (CTR.ALG_RP (((synthesis, elems), type_specs), thm_specs)) (lthy : local_theory) = let val thm_specs' = preprocess_thm_specs lthy thm_specs val synthesis' = Option.map (apsnd (Option.map ((single #> Attrib.eval_thms lthy)))) synthesis val data : ctr_test_data = { ctr_type = "relativization", synthesis = synthesis', elems = elems, type_specs = type_specs, thm_specs = thm_specs' } in update_ctr_test_data k data lthy end in process_ctrs_impl args lthy end; val ctr_test_parser = Parse.string -- CTR.ctr_parser; val _ = Outer_Syntax.local_theory \<^command_keyword>\ctr_test\ "test setup for the command ctr" (ctr_test_parser >> process_ctr_test_data); \ definition mono where "mono f \ (\x y. x \ y \ f x \ f y)" ud \mono\ definition mono_ow :: "'a set \ ('b \ 'b \ bool) \ ('a \ 'a \ bool) \ ('a \ 'b) \ bool" where "mono_ow UB leb lea f \ \x\UB. \y\UB. lea x y \ leb (f x) (f y)" typedef 'a K = \{xs::'a list. length xs = 2}\ by (simp add: Ex_list_of_length) definition KK :: "'a K \ 'a K \ bool" where "KK k1 k2 \ k1 = k2" typedef 'a L = \{xs::'a list. length xs = 2}\ by (simp add: Ex_list_of_length) definition LL :: "'a L \ 'a L \ bool" where "LL k1 k2 \ k1 = k2" definition rel_L :: "('a::group_add \ 'b::group_add \ bool) \ 'a::group_add L \ 'b::group_add L \ bool" where "rel_L A b c = True" ctr_relator rel_L definition not_binders_binrelT :: "('a \ 'b \ bool) \ ('c \ bool) \ 'a \ 'b \ bool" where "not_binders_binrelT R1 R2 a b = True" definition no_dup_binrelT :: "('a \ 'b \ bool) \ ('c \ 'a \ bool) \ 'a \ 'b \ bool" where "no_dup_binrelT R1 R2 a b = True" definition not_binders_binrelT_ftv_stv :: "('a \ 'b \ bool) \ (nat \ 'c \ bool) \ 'a \ 'b \ bool" where "not_binders_binrelT_ftv_stv R1 R2 a b = True" definition not_type_constructor_lhs :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a \ 'a K \ bool" where "not_type_constructor_lhs R1 R2 a b = True" definition not_type_constructor_rhs :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a K \ 'e \ bool" where "not_type_constructor_rhs R1 R2 a b = True" definition not_identical_type_constructors :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a K \ 'e L \ bool" where "not_identical_type_constructors R1 R2 a b = True" definition not_identical_type_constructors_lhs :: "('a \ 'b \ bool) \ ('c \ 'd \ bool) \ 'a K \ 'b K \ bool" where "not_identical_type_constructors_lhs R1 R2 a b = True" definition not_identical_type_constructors_rhs :: "('a \ 'b \ bool) \ 'a K \ 'c K \ bool" where "not_identical_type_constructors_rhs R1 a b = True" subsection\Test data\ lemma mono_ow_transfer': includes lifting_syntax assumes [transfer_domain_rule, transfer_rule]: "Domainp B = (\x. x \ UB)" and [transfer_rule]: "right_total B" shows "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (B ===> A) ===> (=)) (mono_ow UB) mono.with" unfolding mono_ow_def mono.with_def by (transfer_prover_start, transfer_step+) simp ctr_test "mono_with" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'a B) in mono_ow': mono.with_def ctr_test "exI" relativization in mono_ow'': exI ctr_test "binrel" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b A) and (?'a B) in mono_ow': mono.with_def ctr_test "binrel_ftv" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::nat\'b\bool\) and (?'a B) in mono_ow': mono.with_def ctr_test "dup_stvs" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'b B) in mono_ow': mono.with_def ctr_test "dup_binrel_ftvs" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'d\bool\) and (?'a B) in mono_ow': mono.with_def ctr_test "no_relator" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'a B) in KK_def ctr_test "invalid_relator" relativization synthesis ctr_simps_Collect_mem_eq assumes [transfer_domain_rule, transfer_rule]: "Domainp (B::'c\'d\bool) = (\x. x \ UB)" and [transfer_rule]: "right_total B" trp (?'b \A::'a\'b\bool\) and (?'a B) in LL_def subsection\Tests\ subsubsection\\process_relativization\\ ML_file\CTR_TEST_PROCESS_RELATIVIZATION.ML\ context includes lifting_syntax begin ML\ Lecker.test_group @{context} () [ctr_test_process_relativization.test_suite] \ end subsubsection\\process_ctr_relator\\ ML_file\CTR_TEST_PROCESS_CTR_RELATOR.ML\ context includes lifting_syntax begin ML\ Lecker.test_group @{context} () [ctr_test_process_ctr_relator.test_suite] \ end end \ No newline at end of file diff --git a/thys/Constructor_Funs/constructor_funs.ML b/thys/Constructor_Funs/constructor_funs.ML --- a/thys/Constructor_Funs/constructor_funs.ML +++ b/thys/Constructor_Funs/constructor_funs.ML @@ -1,183 +1,183 @@ signature CONSTRUCTOR_FUNS = sig val mk_funs: Ctr_Sugar.ctr_sugar -> local_theory -> local_theory val mk_funs_typ: typ -> local_theory -> local_theory val mk_funs_cmd: string -> local_theory -> local_theory val enabled: bool Config.T val conv: Proof.context -> conv val constructor_funs_plugin: string val setup: theory -> theory end structure Constructor_Funs : CONSTRUCTOR_FUNS = struct val enabled = Attrib.setup_config_bool @{binding "constructor_funs"} (K false) structure Data = Generic_Data ( type T = term list * (int * thm) list * Symtab.set val empty = ([], [], Symtab.empty) fun merge ((ts1, unfolds1, s1), (ts2, unfolds2, s2)) = (ts1 @ ts2, unfolds1 @ unfolds2, Symtab.merge op = (s1, s2)) ) fun lenient_unvarify t = (* type variables in records are not schematic *) Logic.unvarify_global t handle TERM _ => t fun mk_funs {T, ctrs, ...} lthy = let val typ_name = fst (dest_Type T) fun mk_fun ctr lthy = let val (name, typ) = dest_Const (lenient_unvarify ctr) val (typs, _) = strip_type typ val len = length typs in if len > 0 then let val base_name = Long_Name.base_name name val binding = Binding.name base_name val args = Name.invent_names (Name.make_context [base_name]) Name.uu typs |> map Free val lhs = list_comb (Free (base_name, typ), args) val rhs = list_comb (Const (name, typ), args) val def = Logic.mk_equals (lhs, rhs) val ((term, (_, def_thm)), lthy') = Specification.definition NONE [] [] ((binding, []), def) lthy val unfold_thm = @{thm Pure.symmetric} OF [Local_Defs.abs_def_rule lthy' def_thm] in (SOME (term, (len, unfold_thm)), lthy') end else (NONE, lthy) end fun morph_unfold phi (len, thm) = (len, Morphism.thm phi thm) fun upd (ts', unfolds') = - Local_Theory.declaration {syntax = false, pervasive = true} + Local_Theory.declaration {syntax = false, pervasive = true, pos = \<^here>} (fn phi => Data.map (fn (ts, unfolds, s) => (map (Morphism.term phi) ts' @ ts, map (morph_unfold phi) unfolds' @ unfolds, Symtab.update_new (typ_name, ()) s))) val exists = Symtab.defined (#3 (Data.get (Context.Proof lthy))) typ_name val warn = Pretty.separate "" [Syntax.pretty_typ lthy T, Pretty.str "already processed"] |> Pretty.block val _ = if exists then warning (Pretty.string_of warn) else () in if exists then lthy else (snd o Local_Theory.begin_nested) lthy |> Proof_Context.concealed |> Local_Theory.map_background_naming (Name_Space.mandatory_path typ_name #> Name_Space.mandatory_path "constructor_fun") |> fold_map mk_fun ctrs |>> map_filter I |>> split_list |-> upd |> Local_Theory.end_nested end fun mk_funs_typ typ lthy = mk_funs (the (Ctr_Sugar.ctr_sugar_of lthy (fst (dest_Type typ)))) lthy fun mk_funs_cmd s lthy = mk_funs_typ (Proof_Context.read_type_name {proper = true, strict = false} lthy s) lthy fun comb_conv ctxt cv1 cv2 ct = let val (f, xs) = strip_comb (Thm.term_of ct) val f = Thm.cterm_of ctxt f val xs = map (Thm.cterm_of ctxt) xs val f' = cv1 f val xs' = map cv2 xs in fold (fn x => fn f => Thm.combination f x) xs' f' end fun conv ctxt = let val (_, unfolds, _) = Data.get (Context.Proof ctxt) val unfolds = map (apsnd (Thm.transfer' ctxt)) unfolds fun full_conv ct = let val (_, xs) = strip_comb (Thm.term_of ct) val actual_len = length xs fun head_conv ct = let fun can_rewrite (len, thm) = Option.map (pair len) (try (Conv.rewr_conv thm) ct) val _ = get_first can_rewrite unfolds in case get_first can_rewrite unfolds of NONE => Conv.all_conv ct | SOME (target_len, thm) => if target_len = actual_len then Conv.all_conv ct else thm end in comb_conv ctxt head_conv full_conv ct end in full_conv end fun functrans ctxt thms = let val (consts, _, _) = Data.get (Context.Proof ctxt) val conv = Conv.arg_conv (conv ctxt) fun apply_conv thm = let val thm' = Conv.fconv_rule conv thm val prop = Thm.prop_of thm val head = Logic.dest_equals prop |> fst |> strip_comb |> fst val protected = exists (fn const => Pattern.matches (Proof_Context.theory_of ctxt) (const, head)) consts in if protected orelse Thm.prop_of thm aconv Thm.prop_of thm' then (false, thm) else (true, thm') end val (changeds, thms') = split_list (map apply_conv thms) in if exists I changeds then SOME thms' else NONE end val code_functrans = Code_Preproc.simple_functrans (fn ctxt => if Config.get ctxt enabled then functrans ctxt else K NONE) val constructor_funs_plugin = Plugin_Name.declare_setup @{binding constructor_funs} (** setup **) val _ = Outer_Syntax.local_theory @{command_keyword "constructor_funs"} "defines constructor functions for a datatype and sets up the code generator" (Scan.repeat1 Parse.embedded_inner_syntax >> fold mk_funs_cmd) val setup = Code_Preproc.add_functrans ("constructor_funs", code_functrans) #> Ctr_Sugar.ctr_sugar_interpretation constructor_funs_plugin (mk_funs_typ o #T) end \ No newline at end of file diff --git a/thys/Dependent_SIFUM_Type_Systems/Examples/TypeSystemTactics.thy b/thys/Dependent_SIFUM_Type_Systems/Examples/TypeSystemTactics.thy --- a/thys/Dependent_SIFUM_Type_Systems/Examples/TypeSystemTactics.thy +++ b/thys/Dependent_SIFUM_Type_Systems/Examples/TypeSystemTactics.thy @@ -1,171 +1,171 @@ theory TypeSystemTactics imports "../Compositionality" "../TypeSystem" "HOL-Eisbach.Eisbach_Tools" begin (* Some Eisbach magic to get around Eisbach and locales not getting along *) ML \ structure Data = Proof_Data ( type T = morphism fun init _ = Morphism.identity; ); \ method_setup wrap = \Method.text_closure >> (fn text => fn ctxt => let val morph = Data.get ctxt; - fun safe_fact thm = - perhaps (try (Morphism.thm morph)) thm; + fun safe_fact thms = + perhaps (try (Morphism.fact morph)) thms; val morph' = Morphism.morphism "safe" - {binding = [Morphism.binding morph], - fact = [map safe_fact], - term = [Morphism.term morph], - typ = [Morphism.typ morph]} + {binding = [K (Morphism.binding morph)], + fact = [K safe_fact], + term = [K (Morphism.term morph)], + typ = [K (Morphism.typ morph)]} val text' = Method.map_source (map (Token.transform morph')) text; in Method.evaluate_runtime text' ctxt end)\ method_setup print_headgoal = \Scan.succeed (fn ctxt => SIMPLE_METHOD (SUBGOAL (fn (t,_) => (Output.writeln (Pretty.string_of (Syntax.pretty_term ctxt t)); all_tac)) 1))\ named_theorems aexpr and bexpr and prog and custom_if context sifum_types_assign begin (* More Eisbach magic to get around Eisbach and mutual recursion not getting along *) method_setup call_by_name = \Scan.lift Parse.string >> (fn str => fn ctxt => case (try (Method.check_src ctxt) (Token.make_src (str, Position.none) [])) of SOME src => Method.evaluate (Method.Source src) ctxt | _ => Method.fail)\ (* Eisbach tactics for partially automating has_type proofs *) method seq_tac methods tac = (wrap \rule seq_type\, tac, tac) method anno_tac methods tac = (wrap \rule anno_type[OF HOL.refl HOL.refl HOL.refl], clarsimp, tac, simp, fastforce simp: add_anno_def subtype_def pred_entailment_def pred_def bot_Sec_def[symmetric], simp add: add_anno_def, simp\) method assign\<^sub>2_tac = wrap \rule assign\<^sub>2\, simp, solves \rule aexpr; simp\, (fastforce), simp, simp method assign\<^sub>1_tac = wrap \rule assign\<^sub>1, simp, simp, solves \rule aexpr; simp\, simp, clarsimp simp: subtype_def pred_def, simp\ method assign\<^sub>\_tac = wrap \rule assign\<^sub>\\, simp, solves \rule aexpr; simp\, (solves \simp\), (solves \simp\ | (clarsimp, fast)), (solves \simp\)?, simp method if_tac methods tac = wrap \rule if_type'\, solves \rule bexpr, simp\, solves \simp\, solves \tac\, solves \tac\, solves \clarsimp, fastforce\ method has_type_no_if_tac' declares aexpr bexpr= (seq_tac \call_by_name "has_type_no_if_tac'"\ | anno_tac \call_by_name "has_type_no_if_tac'"\ | wrap \rule skip_type\ | wrap \rule stop_type\ | assign\<^sub>1_tac| assign\<^sub>2_tac | assign\<^sub>\_tac)? method has_type_no_if_tac uses prog declares aexpr bexpr = (intro exI, unfold prog, has_type_no_if_tac') method has_type_tac' declares aexpr bexpr= (seq_tac \call_by_name "has_type_tac'"\ | anno_tac \call_by_name "has_type_tac'"\ | wrap \rule skip_type\ | wrap \rule stop_type\ | assign\<^sub>2_tac | if_tac \call_by_name "has_type_tac'"\ | assign\<^sub>1_tac | assign\<^sub>\_tac)? method has_type_tac uses prog declares aexpr bexpr = (intro exI, unfold prog, has_type_tac') method if_type_tac declares bexpr custom_if = (wrap \rule custom_if, rule bexpr, simp?, simp?, has_type_tac', has_type_tac', (* Check if this work for other cases? If so just give the rest of this method a time out. Otherwise, remove from tac and add as explicit lemma proof *) (clarsimp simp: context_equiv_def type_equiv_def subtype_def)?, (clarsimp simp: context_equiv_def type_equiv_def subtype_def)?, (simp add: subset_entailment)?, (simp add: subset_entailment)?, (clarsimp, (subst tyenv_wellformed_def) , (clarsimp simp: mds_consistent_def types_wellformed_def type_wellformed_def types_stable_def), (fastforce simp: tyenv_wellformed_def mds_consistent_def))?, (clarsimp, (subst tyenv_wellformed_def) , (clarsimp simp: mds_consistent_def types_wellformed_def type_wellformed_def types_stable_def), (fastforce simp: tyenv_wellformed_def mds_consistent_def))?\) declaration \fn phi => Context.mapping I (Data.put phi)\ end end diff --git a/thys/Deriving/Comparator_Generator/comparator_generator.ML b/thys/Deriving/Comparator_Generator/comparator_generator.ML --- a/thys/Deriving/Comparator_Generator/comparator_generator.ML +++ b/thys/Deriving/Comparator_Generator/comparator_generator.ML @@ -1,642 +1,642 @@ (* Title: Deriving class instances for datatypes Author: Christian Sternagel and René Thiemann Maintainer: Christian Sternagel and René Thiemann License: LGPL *) signature COMPARATOR_GENERATOR = sig type info = {map : term, (* take % x. x, if there is no map *) pcomp : term, (* partial comparator *) comp : term, (* full comparator *) comp_def : thm option, (* definition of comparator, important for nesting *) map_comp : thm option, (* compositionality of map, important for nesting *) partial_comp_thms : thm list, (* first eq, then sym, finally trans *) comp_thm : thm, (* comparator acomp \ \ \ comparator (full_comp acomp \) *) used_positions : bool list} (* registers @{term comparator_of :: "some_type :: linorder comparator"} where some_type must just be a type without type-arguments *) val register_comparator_of : string -> local_theory -> local_theory val register_foreign_comparator : typ -> (* type-constant without type-variables *) term -> (* comparator for type *) thm -> (* comparator thm for provided comparator *) local_theory -> local_theory val register_foreign_partial_and_full_comparator : string -> (* long type name *) term -> (* map function, should be \x. x, if there is no map *) term -> (* partial comparator of type ('a => order, 'b)ty => ('a,'b)ty => order, where 'a is used, 'b is unused *) term -> (* (full) comparator of type ('a \ 'a \ order) \ ('a,'b)ty \ ('a,'b)ty \ order, where 'a is used, 'b is unused *) thm option -> (* comp_def, should be full_comp = pcomp o map acomp ..., important for nesting *) thm option -> (* map compositionality, important for nesting *) thm -> (* partial eq thm for full comparator *) thm -> (* partial sym thm for full comparator *) thm -> (* partial trans thm for full comparator *) thm -> (* full thm: comparator a-comp => comparator (full_comp a-comp) *) bool list -> (*used positions*) local_theory -> local_theory datatype comparator_type = Linorder | BNF val generate_comparators_from_bnf_fp : string -> (* name of type *) local_theory -> ((term * thm list) list * (* partial comparators + simp-rules *) (term * thm) list) * (* non-partial comparator + def_rule *) local_theory val generate_comparator : comparator_type -> string -> (* name of type *) local_theory -> local_theory val get_info : Proof.context -> string -> info option (* ensures that the info will be available on later requests *) val ensure_info : comparator_type -> string -> local_theory -> local_theory end structure Comparator_Generator : COMPARATOR_GENERATOR = struct open Generator_Aux datatype comparator_type = BNF | Linorder val debug = false fun debug_out s = if debug then writeln s else () val orderT = @{typ order} fun compT T = T --> T --> orderT val orderify = map_atyps (fn T => T --> orderT) fun pcompT T = orderify T --> T --> orderT type info = {map : term, pcomp : term, comp : term, comp_def : thm option, map_comp : thm option, partial_comp_thms : thm list, comp_thm : thm, used_positions : bool list}; structure Data = Generic_Data ( type T = info Symtab.table; val empty = Symtab.empty; val merge = Symtab.merge (fn (info1 : info, info2 : info) => #comp info1 = #comp info2); ); fun add_info T info = Data.map (Symtab.update_new (T, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no comparator information available for type " ^ quote tyco)) fun declare_info tyco m p c c_def m_comp p_thms c_thm used_pos = - Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => + Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn phi => add_info tyco {map = Morphism.term phi m, pcomp = Morphism.term phi p, comp = Morphism.term phi c, comp_def = Option.map (Morphism.thm phi) c_def, map_comp = Option.map (Morphism.thm phi) m_comp, partial_comp_thms = Morphism.fact phi p_thms, comp_thm = Morphism.thm phi c_thm, used_positions = used_pos}) val EQ = 0 val SYM = 1 val TRANS = 2 fun register_foreign_partial_and_full_comparator tyco m p c c_def m_comp eq_thm sym_thm trans_thm c_thm = declare_info tyco m p c c_def m_comp [eq_thm, sym_thm, trans_thm] c_thm fun mk_infer_const name ctxt c = infer_type ctxt (Const (name, dummyT) $ c) val mk_eq_comp = mk_infer_const @{const_name eq_comp} val mk_peq_comp = mk_infer_const @{const_name peq_comp} val mk_sym_comp = mk_infer_const @{const_name sym_comp} val mk_psym_comp = mk_infer_const @{const_name psym_comp} val mk_trans_comp = mk_infer_const @{const_name trans_comp} val mk_ptrans_comp = mk_infer_const @{const_name ptrans_comp} val mk_comp = mk_infer_const @{const_name comparator} fun default_comp T = absdummy T (absdummy T @{term Eq}) (*%_ _. Eq*) fun register_foreign_comparator T comp comp_thm lthy = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant") val eq = @{thm comp_to_peq_comp} OF [comp_thm] val sym = @{thm comp_to_psym_comp} OF [comp_thm] val trans = @{thm comp_to_ptrans_comp} OF [comp_thm] in register_foreign_partial_and_full_comparator tyco (HOLogic.id_const T) comp comp NONE NONE eq sym trans comp_thm [] lthy end fun register_comparator_of tyco lthy = let val T = Type (tyco, []) val comp = Const (@{const_name comparator_of}, compT T) val comp_thm = Thm.instantiate' [SOME (Thm.ctyp_of lthy T)] [] @{thm comparator_of} in register_foreign_comparator T comp comp_thm lthy end fun generate_comparators_from_bnf_fp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating comparator for type " ^ quote tyco) tycos |> cat_lines |> writeln val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val cs = map (subT "comp") used_tfrees val comp_Ts = map compT used_tfrees val arg_comps = map Free (cs ~~ comp_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] val XTys = Bnf_Access.bnf_types lthy tycos val inst_types = typ_subst_atomic (XTys ~~ Ts) val cTys = map (map (map inst_types)) (Bnf_Access.constr_argument_types lthy tycos) val map_simps = Bnf_Access.map_simps lthy tycos val case_simps = Bnf_Access.case_simps lthy tycos val maps = Bnf_Access.map_terms lthy tycos val map_comp_thms = Bnf_Access.map_comps lthy tycos val t_ixs = 0 upto (length Ts - 1) val compNs = (*TODO: clashes in presence of same type names in different theories*) map (Long_Name.base_name) tycos |> map (fn s => "comparator_" ^ s) fun gen_vars prefix = map (fn (i, pty) => Free (prefix ^ ints_to_subscript [i], pty)) (t_ixs ~~ Ts) (* primrec definitions of partial comparators *) fun mk_pcomp (tyco, T) = ("partial_comparator_" ^ Long_Name.base_name tyco, pcompT T) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (map freeify_tvars o fst o strip_type) o dest_Const) fun generate_pcomp_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let val m = Generator_Aux.create_map default_comp (K o Free o mk_pcomp) () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pcomp oo the_info) tycos ((K o K) ()) T lthy val p = Generator_Aux.create_partial () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pcomp oo the_info) tycos ((K o K) ()) T lthy in p $ (m $ x) $ y |> infer_type lthy end fun generate_eq lthy (c_T as (cN, Ts)) = let val arg_Ts' = map orderify Ts val c = Const (cN, arg_Ts' ---> orderify T) val (y, (xs, ys)) = Name.variant "y" (Variable.names_of lthy) |>> Free o rpair T ||> (fn ctxt => Name.invent_names ctxt "x" (arg_Ts' @ Ts) |> map Free) ||> chop (length Ts) val k = find_index (curry (op =) c_T) constrs val cases = constrs |> map_index (fn (i, (_, Ts')) => if i < k then fold_rev absdummy Ts' @{term Gt} else if k < i then fold_rev absdummy Ts' @{term Lt} else @{term comp_lex} $ HOLogic.mk_list orderT (@{map 3} comp_arg Ts xs ys) |> lambdas ys) val lhs = Free (mk_pcomp (tyco, T)) $ list_comb (c, xs) $ y val rhs = list_comb (singleton (Bnf_Access.case_consts lthy) tyco, cases) $ y in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy end in map (generate_eq lthy) constrs end val eqs = map (generate_pcomp_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_pcomp |> map (fn (name, T) => (Binding.name name, SOME T, NoSyn)) val ((pcomps, pcomp_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> (BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs)) |> Local_Theory.end_nested_result (fn phi => fn (pcomps, _, pcomp_simps) => (map (Morphism.term phi) pcomps, map (Morphism.fact phi) pcomp_simps)) (* definitions of comparators via partial comparators and maps *) fun generate_comp_def tyco lthy = let val cs = map (subT "comp") used_tfrees val arg_Ts = map compT used_tfrees val args = map Free (cs ~~ arg_Ts) val (pcomp, m) = AList.lookup (op =) (tycos ~~ (pcomps ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ args) T |> the_default (default_comp T)) val rhs = HOLogic.mk_comp (pcomp, list_comb (m, ts)) |> infer_type lthy val abs_def = lambdas args rhs val name = "comparator_" ^ Long_Name.base_name tyco val ((comp, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (comp, args), rhs) val thm = Goal.prove lthy (map (fst o dest_Free) args) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt [prethm]) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K comp) end val ((comps, comp_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_def tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (comps, comp_defs) => (map (Morphism.term phi) comps, map (Morphism.thm phi) comp_defs)) (* alternative simp-rules for comparators *) val full_comps = map (list_comb o rpair arg_comps) comps fun generate_comp_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let fun create_comp (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_comps) T |> the_default (HOLogic.id_const dummyT) | create_comp (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ comps) tyco of SOME c => list_comb (c, arg_comps) | NONE => let val {comp = c, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_comp T) else NONE) in list_comb (c, ts) end) | create_comp T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val comp = create_comp T in comp $ x $ y |> infer_type lthy end fun generate_eq_thm lthy (c_T as (_, Ts)) = let val (xs, ctxt) = Variable.names_of lthy |> fold_map (fn T => Name.variant "x" #>> Free o rpair T) Ts fun mk_const (c, Ts) = Const (c, Ts ---> T) val comp_const = AList.lookup (op =) (tycos ~~ comps) tyco |> the val lhs = list_comb (comp_const, arg_comps) $ list_comb (mk_const c_T, xs) val k = find_index (curry (op =) c_T) constrs fun mk_eq c ys rhs = let val y = list_comb (mk_const c, ys) val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs $ y, rhs)) in (ys, eq |> infer_type lthy) end val ((ys, eqs), _) = fold_map (fn (i, c as (_, Ts')) => fn ctxt => let val (ys, ctxt) = fold_map (fn T => Name.variant "y" #>> Free o rpair T) Ts' ctxt in (if i < k then mk_eq c ys @{term Gt} else if k < i then mk_eq c ys @{term Lt} else @{term comp_lex} $ HOLogic.mk_list orderT (@{map 3} comp_arg Ts xs ys) |> mk_eq c ys, ctxt) end) (tag_list 0 constrs) ctxt |> apfst (apfst flat o split_list) val dep_comp_defs = map_filter (#comp_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thms = prove_multi_future lthy (map (fst o dest_Free) (xs @ ys) @ cs) [] eqs (fn {context = ctxt, ...} => Goal.conjunction_tac 1 THEN unfold_tac ctxt (@{thms id_apply o_def} @ flat case_simps @ flat pcomp_simps @ dep_map_comps @ comp_defs @ dep_comp_defs @ flat map_simps)) in thms end val thms = map (generate_eq_thm lthy) constrs |> flat val simp_thms = map (Local_Defs.unfold lthy @{thms comp_lex_unfolds}) thms val name = "comparator_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), simp_thms) |> snd |> (fn lthy => (thms, lthy)) end val (comp_simps, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_simps (tycos ~~ Ts) |> Local_Theory.end_nested_result (fn phi => map (Morphism.fact phi)) (* partial theorems *) val set_funs = Bnf_Access.set_terms lthy tycos val x_vars = gen_vars "x" val free_names = map (fst o dest_Free) (x_vars @ arg_comps) val xi_vars = map_index (fn (i, _) => map_index (fn (j, pty) => Free ("x" ^ ints_to_subscript [i, j], pty)) used_tfrees) Ts fun mk_eq_sym_trans_thm' mk_eq_sym_trans' = map_index (fn (i, ((set_funs, x), xis)) => let fun create_cond ((set_t, xi), c) = let val rhs = mk_eq_sym_trans' lthy c $ xi |> HOLogic.mk_Trueprop val lhs = HOLogic.mk_mem (xi, set_t $ x) |> HOLogic.mk_Trueprop in Logic.all xi (Logic.mk_implies (lhs, rhs)) end val used_sets = map (the o AList.lookup (op =) (map TFree tfrees ~~ set_funs)) used_tfrees val conds = map create_cond (used_sets ~~ xis ~~ arg_comps) val concl = mk_eq_sym_trans' lthy (nth full_comps i) $ x |> HOLogic.mk_Trueprop in Logic.list_implies (conds, concl) |> infer_type lthy end) (set_funs ~~ x_vars ~~ xi_vars) val induct_thms = Bnf_Access.induct_thms lthy tycos val set_simps = Bnf_Access.set_simps lthy tycos val case_thms = Bnf_Access.case_thms lthy tycos val distinct_thms = Bnf_Access.distinct_thms lthy tycos val inject_thms = Bnf_Access.inject_thms lthy tycos val rec_info = (the_info lthy, #used_positions, tycos) val split_IHs = split_IHs rec_info val unknown_value = false (* effect of choosing false / true not yet visible *) fun induct_tac ctxt f = ((DETERM o Induction.induction_tac ctxt false (map (fn x => [SOME (NONE, (x, unknown_value))]) x_vars) [] [] (SOME induct_thms) []) THEN_ALL_NEW (fn i => Subgoal.SUBPROOF (fn {context = ctxt, prems = prems, params = iparams, ...} => f (i - 1) ctxt prems iparams) ctxt i)) 1 fun recursor_tac kind = std_recursor_tac rec_info used_tfrees (fn info => nth (#partial_comp_thms info) kind) fun instantiate_IHs IHs pre_conds = map (fn IH => OF_option IH (replicate (Thm.nprems_of IH - length pre_conds) NONE @ map SOME pre_conds)) IHs fun get_v_i vs k = nth vs k |> snd |> SOME (* partial eq-theorem *) val _ = debug_out "Partial equality" val eq_thms' = mk_eq_sym_trans_thm' mk_peq_comp fun eq_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val distinct_thms = nth distinct_thms i val inject_thms = nth inject_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms peq_compI} 1 THEN Subgoal.FOCUS (fn focus => let val y = #params focus |> hd val yt = y |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, _) = if j = j' then unfold_tac ctxt (y_simp @ comp_simps) THEN unfold_tac ctxt @{thms comp_lex_eq} THEN unfold_tac ctxt (@{thms in_set_simps} @ inject_thms @ @{thms refl_True}) THEN conjI_tac @{thms conj_weak_cong} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt @{thms peq_compD} 1 THEN recursor_tac EQ pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ distinct_thms @ comp_simps @ @{thms order.simps}) in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val eq_thms' = prove_multi_future lthy free_names [] eq_thms' (fn {context = ctxt, ...} => induct_tac ctxt eq_solve_tac) val _ = debug_out (@{make_string} eq_thms') (* partial symmetry-theorem *) val _ = debug_out "Partial symmetry" val sym_thms' = mk_eq_sym_trans_thm' mk_psym_comp fun sym_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms psym_compI} 1 THEN Subgoal.FOCUS (fn focus => let val y = #params focus |> hd val yt = y |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, ys) = if j = j' then unfold_tac ctxt (y_simp @ comp_simps) THEN resolve_tac ctxt @{thms comp_lex_sym} 1 THEN unfold_tac ctxt (@{thms length_nth_simps forall_finite}) THEN conjI_tac @{thms conjI} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt' [infer_instantiate' ctxt' [NONE, get_v_i xs k, get_v_i ys k] @{thm psym_compD}] 1 THEN recursor_tac SYM pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ comp_simps @ @{thms invert_order.simps}) in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val sym_thms' = prove_multi_future lthy free_names [] sym_thms' (fn {context = ctxt, ...} => induct_tac ctxt sym_solve_tac) val _ = debug_out (@{make_string} sym_thms') (* partial transitivity-theorem *) val _ = debug_out "Partial transitivity" val trans_thms' = mk_eq_sym_trans_thm' mk_ptrans_comp fun trans_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms ptrans_compI} 1 THEN Subgoal.FOCUS (fn focus => let val y = nth (#params focus) 0 val z = nth (#params focus) 1 val yt = y |> snd |> Thm.term_of val zt = z |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, ys) = let fun sub_case_tac' j'' (ctxt, z_simp, zs) = if j = j' andalso j = j'' then unfold_tac ctxt (y_simp @ z_simp @ comp_simps) THEN resolve_tac ctxt @{thms comp_lex_trans} 1 THEN unfold_tac ctxt (@{thms length_nth_simps forall_finite}) THEN conjI_tac @{thms conjI} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt' [infer_instantiate' ctxt' [NONE, get_v_i xs k, get_v_i ys k, get_v_i zs k] @{thm ptrans_compD}] 1 THEN recursor_tac TRANS pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ z_simp @ comp_simps @ @{thms trans_order_different}) in mk_case_tac ctxt [[SOME zt]] case_thm sub_case_tac' end in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val trans_thms' = prove_multi_future lthy free_names [] trans_thms' (fn {context = ctxt, ...} => induct_tac ctxt trans_solve_tac) val _ = debug_out (@{make_string} trans_thms') (* total theorems *) fun mk_eq_sym_trans_thm mk_eq_sym_trans compI2 compE2 thms' = let val conds = map (fn c => mk_eq_sym_trans lthy c |> HOLogic.mk_Trueprop) arg_comps val thms = map (fn i => mk_eq_sym_trans lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds,concl))) t_ixs val thms = prove_multi_future lthy free_names [] thms (fn {context = ctxt, ...} => ALLGOALS Goal.conjunction_tac THEN Method.intros_tac ctxt (@{thm conjI} :: compI2 :: thms') [] THEN ALLGOALS (eresolve_tac ctxt [compE2])) in thms end val eq_thms = mk_eq_sym_trans_thm mk_eq_comp @{thm eq_compI2} @{thm eq_compD2} eq_thms' val sym_thms = mk_eq_sym_trans_thm mk_sym_comp @{thm sym_compI2} @{thm sym_compD2} sym_thms' val trans_thms = mk_eq_sym_trans_thm mk_trans_comp @{thm trans_compI2} @{thm trans_compD2} trans_thms' val _ = debug_out "full comparator thms" fun mk_comp_thm (i, ((e, s), t)) = let val conds = map (fn c => mk_comp lthy c |> HOLogic.mk_Trueprop) arg_comps fun from_comp thm i = thm OF replicate (Thm.prems_of thm |> length) (nth @{thms comparator_imp_eq_sym_trans} i) val nearly_thm = @{thm eq_sym_trans_imp_comparator} OF [from_comp e EQ, from_comp s SYM, from_comp t TRANS] val thm = mk_comp lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds, concl)) in Goal.prove_future lthy free_names [] thm (K (resolve_tac lthy [nearly_thm] 1 THEN ALLGOALS (assume_tac lthy))) end val comp_thms = map_index mk_comp_thm (eq_thms ~~ sym_thms ~~ trans_thms) val (_, lthy) = fold_map (fn (thm, cname) => Local_Theory.note ((Binding.name cname, []), [thm])) (comp_thms ~~ compNs) lthy val _ = debug_out (@{make_string} comp_thms) val pcomp_thms = map (fn ((e, s), t) => [e, s, t]) (eq_thms' ~~ sym_thms' ~~ trans_thms') val (_, lthy) = fold_map (fn (thms, cname) => Local_Theory.note ((Binding.name (cname ^ "_pointwise"), []), thms)) (pcomp_thms ~~ compNs) lthy in ((pcomps ~~ pcomp_simps, comps ~~ comp_defs), lthy) ||> fold (fn (((((((tyco, map), pcomp), comp), comp_def), map_comp), pcomp_thms), comp_thm) => declare_info tyco map pcomp comp (SOME comp_def) (SOME map_comp) pcomp_thms comp_thm used_positions) (tycos ~~ maps ~~ pcomps ~~ comps ~~ comp_defs ~~ map_comp_thms ~~ pcomp_thms ~~ comp_thms) end fun generate_comparator gen_type tyco lthy = let val _ = is_some (get_info lthy tyco) andalso error ("type " ^ quote tyco ^ " does already have a comparator") in case gen_type of BNF => generate_comparators_from_bnf_fp tyco lthy |> snd | Linorder => register_comparator_of tyco lthy end fun ensure_info gen_type tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_comparator gen_type tyco lthy) fun generate_comparator_cmd tyco param = Named_Target.theory_map ( if param = "linorder" then generate_comparator Linorder tyco else if param = "" then generate_comparator BNF tyco else error ("unknown parameter, expecting no parameter for BNF-datatypes, " ^ "or \"linorder\" for types which are already in linorder")) val _ = Theory.setup (Derive_Manager.register_derive "comparator" "generate comparators for given types, options: (linorder) or ()" generate_comparator_cmd) end diff --git a/thys/Deriving/Equality_Generator/equality_generator.ML b/thys/Deriving/Equality_Generator/equality_generator.ML --- a/thys/Deriving/Equality_Generator/equality_generator.ML +++ b/thys/Deriving/Equality_Generator/equality_generator.ML @@ -1,518 +1,518 @@ (* Title: Deriving class instances for datatypes Author: Christian Sternagel and René Thiemann Maintainer: Christian Sternagel and René Thiemann License: LGPL *) signature EQUALITY_GENERATOR = sig type info = {map : term, (* take % x. x, if there is no map *) pequality : term, (* partial equality *) equality : term, (* full equality *) equality_def : thm option, (* definition of equality, important for nesting *) map_comp : thm option, (* compositionality of map, important for nesting *) partial_equality_thm : thm, (* partial version of equality thm *) equality_thm : thm, (* equality acomp \ \ \ equality (full_comp acomp \) *) used_positions : bool list} (* registers @{term equality_of :: "some_type :: linorder equality"} where some_type must just be a type without type-arguments *) val register_equality_of : string -> local_theory -> local_theory val register_foreign_equality : typ -> (* type-constant without type-variables *) term -> (* equality for type *) thm -> (* equality thm for provided equality *) local_theory -> local_theory val register_foreign_partial_and_full_equality : string -> (* long type name *) term -> (* map function, should be \x. x, if there is no map *) term -> (* partial equality of type ('a => order, 'b)ty => ('a,'b)ty => order, where 'a is used, 'b is unused *) term -> (* (full) equality of type ('a \ 'a \ order) \ ('a,'b)ty \ ('a,'b)ty \ order, where 'a is used, 'b is unused *) thm option -> (* comp_def, should be full_comp = pcomp o map acomp ..., important for nesting *) thm option -> (* map compositionality, important for nesting *) thm -> (* partial eq thm for full equality *) thm -> (* full thm: equality a-comp => equality (full_comp a-comp) *) bool list -> (*used positions*) local_theory -> local_theory datatype equality_type = EQ | BNF val generate_equalitys_from_bnf_fp : string -> (* name of type *) local_theory -> ((term * thm list) list * (* partial equalitys + simp-rules *) (term * thm) list) * (* non-partial equality + def_rule *) local_theory val generate_equality : equality_type -> string -> (* name of type *) local_theory -> local_theory val get_info : Proof.context -> string -> info option (* ensures that the info will be available on later requests *) val ensure_info : equality_type -> string -> local_theory -> local_theory end structure Equality_Generator : EQUALITY_GENERATOR = struct open Generator_Aux datatype equality_type = BNF | EQ val debug = false fun debug_out s = if debug then writeln s else () val boolT = @{typ bool} fun compT T = T --> T --> boolT val orderify = map_atyps (fn T => T --> boolT) fun pcompT T = orderify T --> T --> boolT type info = {map : term, pequality : term, equality : term, equality_def : thm option, map_comp : thm option, partial_equality_thm : thm, equality_thm : thm, used_positions : bool list}; structure Data = Generic_Data ( type T = info Symtab.table; val empty = Symtab.empty; val merge = Symtab.merge (fn (info1 : info, info2 : info) => #equality info1 = #equality info2); ); fun add_info T info = Data.map (Symtab.update_new (T, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no equality information available for type " ^ quote tyco)) fun declare_info tyco m p c c_def m_comp p_thm c_thm used_pos = - Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => + Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn phi => add_info tyco {map = Morphism.term phi m, pequality = Morphism.term phi p, equality = Morphism.term phi c, equality_def = Option.map (Morphism.thm phi) c_def, map_comp = Option.map (Morphism.thm phi) m_comp, partial_equality_thm = Morphism.thm phi p_thm, equality_thm = Morphism.thm phi c_thm, used_positions = used_pos}) fun register_foreign_partial_and_full_equality tyco m p c c_def m_comp eq_thm c_thm = declare_info tyco m p c c_def m_comp eq_thm c_thm val mk_equality = mk_infer_const @{const_name equality} val mk_pequality = mk_infer_const @{const_name pequality} fun default_comp T = absdummy T (absdummy T @{term True}) (*%_ _. True*) fun register_foreign_equality T comp comp_thm lthy = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant with no arguments") val eq = @{thm equalityD2} OF [comp_thm] in register_foreign_partial_and_full_equality tyco (HOLogic.id_const T) comp comp NONE NONE eq comp_thm [] lthy end fun register_equality_of tyco lthy = let val (T,_) = typ_and_vs_of_typname (Proof_Context.theory_of lthy) tyco @{sort type} val comp = HOLogic.eq_const T val comp_thm = Thm.instantiate' [SOME (Thm.ctyp_of lthy T)] [] @{thm eq_equality} in register_foreign_equality T comp comp_thm lthy end fun generate_equalitys_from_bnf_fp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating equality for type " ^ quote tyco) tycos |> cat_lines |> writeln val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val cs = map (subT "eq") used_tfrees val comp_Ts = map compT used_tfrees val arg_comps = map Free (cs ~~ comp_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] val XTys = Bnf_Access.bnf_types lthy tycos val inst_types = typ_subst_atomic (XTys ~~ Ts) val cTys = map (map (map inst_types)) (Bnf_Access.constr_argument_types lthy tycos) val map_simps = Bnf_Access.map_simps lthy tycos val case_simps = Bnf_Access.case_simps lthy tycos val maps = Bnf_Access.map_terms lthy tycos val map_comp_thms = Bnf_Access.map_comps lthy tycos val t_ixs = 0 upto (length Ts - 1) val compNs = (*TODO: clashes in presence of same type names in different theories*) map (Long_Name.base_name) tycos |> map (fn s => "equality_" ^ s) fun gen_vars prefix = map (fn (i, pty) => Free (prefix ^ ints_to_subscript [i], pty)) (t_ixs ~~ Ts) (* primrec definitions of partial equalitys *) fun mk_pcomp (tyco, T) = ("partial_equality_" ^ Long_Name.base_name tyco, pcompT T) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (map freeify_tvars o fst o strip_type) o dest_Const) fun generate_pcomp_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let val m = Generator_Aux.create_map default_comp (K o Free o mk_pcomp) () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pequality oo the_info) tycos ((K o K) ()) T lthy val p = Generator_Aux.create_partial () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #pequality oo the_info) tycos ((K o K) ()) T lthy in p $ (m $ x) $ y |> infer_type lthy end fun generate_eq lthy (c_T as (cN, Ts)) = let val arg_Ts' = map orderify Ts val c = Const (cN, arg_Ts' ---> orderify T) val (y, (xs, ys)) = Name.variant "y" (Variable.names_of lthy) |>> Free o rpair T ||> (fn ctxt => Name.invent_names ctxt "x" (arg_Ts' @ Ts) |> map Free) ||> chop (length Ts) val k = find_index (curry (op =) c_T) constrs val cases = constrs |> map_index (fn (i, (_, Ts')) => if i < k then fold_rev absdummy Ts' @{term False} else if k < i then fold_rev absdummy Ts' @{term False} else @{term list_all_eq} $ HOLogic.mk_list boolT (@{map 3} comp_arg Ts xs ys) |> lambdas ys) val lhs = Free (mk_pcomp (tyco, T)) $ list_comb (c, xs) $ y val rhs = list_comb (singleton (Bnf_Access.case_consts lthy) tyco, cases) $ y in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy end in map (generate_eq lthy) constrs end val eqs = map (generate_pcomp_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_pcomp |> map (fn (name, T) => (Binding.name name, SOME T, NoSyn)) val ((pcomps, pcomp_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> (BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs)) |> Local_Theory.end_nested_result (fn phi => fn (pcomps, _, pcomp_simps) => (map (Morphism.term phi) pcomps, map (Morphism.fact phi) pcomp_simps)) (* definitions of equalitys via partial equalitys and maps *) fun generate_comp_def tyco lthy = let val cs = map (subT "eq") used_tfrees val arg_Ts = map compT used_tfrees val args = map Free (cs ~~ arg_Ts) val (pcomp, m) = AList.lookup (op =) (tycos ~~ (pcomps ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ args) T |> the_default (default_comp T)) val rhs = HOLogic.mk_comp (pcomp, list_comb (m, ts)) |> infer_type lthy val abs_def = lambdas args rhs val name = "equality_" ^ Long_Name.base_name tyco val ((comp, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (comp, args), rhs) val thm = Goal.prove lthy (map (fst o dest_Free) args) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt [prethm]) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K comp) end val ((comps, comp_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_def tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (comps, comp_defs) => (map (Morphism.term phi) comps, map (Morphism.thm phi) comp_defs)) (* alternative simp-rules for equalitys *) val full_comps = map (list_comb o rpair arg_comps) comps fun generate_comp_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco fun comp_arg T x y = let fun create_comp (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_comps) T |> the_default (HOLogic.id_const dummyT) | create_comp (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ comps) tyco of SOME c => list_comb (c, arg_comps) | NONE => let val {equality = c, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_comp T) else NONE) in list_comb (c, ts) end) | create_comp T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val comp = create_comp T in comp $ x $ y |> infer_type lthy end fun generate_eq_thm lthy (c_T as (_, Ts)) = let val (xs, ctxt) = Variable.names_of lthy |> fold_map (fn T => Name.variant "x" #>> Free o rpair T) Ts fun mk_const (c, Ts) = Const (c, Ts ---> T) val comp_const = AList.lookup (op =) (tycos ~~ comps) tyco |> the val lhs = list_comb (comp_const, arg_comps) $ list_comb (mk_const c_T, xs) val k = find_index (curry (op =) c_T) constrs fun mk_eq c ys rhs = let val y = list_comb (mk_const c, ys) val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs $ y, rhs)) in (ys, eq |> infer_type lthy) end val ((ys, eqs), _) = fold_map (fn (i, c as (_, Ts')) => fn ctxt => let val (ys, ctxt) = fold_map (fn T => Name.variant "y" #>> Free o rpair T) Ts' ctxt in (if i < k then mk_eq c ys @{term False} else if k < i then mk_eq c ys @{term False} else @{term list_all_eq} $ HOLogic.mk_list boolT (@{map 3} comp_arg Ts xs ys) |> mk_eq c ys, ctxt) end) (tag_list 0 constrs) ctxt |> apfst (apfst flat o split_list) val dep_comp_defs = map_filter (#equality_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thms = prove_multi_future lthy (map (fst o dest_Free) (xs @ ys) @ cs) [] eqs (fn {context = ctxt, ...} => Goal.conjunction_tac 1 THEN unfold_tac ctxt (@{thms id_apply o_def} @ flat case_simps @ flat pcomp_simps @ dep_map_comps @ comp_defs @ dep_comp_defs @ flat map_simps)) in thms end val thms = map (generate_eq_thm lthy) constrs |> flat val simp_thms = map (Local_Defs.unfold lthy @{thms list_all_eq_unfold}) thms val name = "equality_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), simp_thms) |> snd |> (fn lthy => (thms, lthy)) end val (comp_simps, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_comp_simps (tycos ~~ Ts) |> Local_Theory.end_nested_result (fn phi => map (Morphism.fact phi)) (* partial theorems *) val set_funs = Bnf_Access.set_terms lthy tycos val x_vars = gen_vars "x" val free_names = map (fst o dest_Free) (x_vars @ arg_comps) val xi_vars = map_index (fn (i, _) => map_index (fn (j, pty) => Free ("x" ^ ints_to_subscript [i, j], pty)) used_tfrees) Ts fun mk_eq_thm' mk_eq' = map_index (fn (i, ((set_funs, x), xis)) => let fun create_cond ((set_t, xi), c) = let val rhs = mk_eq' lthy c $ xi |> HOLogic.mk_Trueprop val lhs = HOLogic.mk_mem (xi, set_t $ x) |> HOLogic.mk_Trueprop in Logic.all xi (Logic.mk_implies (lhs, rhs)) end val used_sets = map (the o AList.lookup (op =) (map TFree tfrees ~~ set_funs)) used_tfrees val conds = map create_cond (used_sets ~~ xis ~~ arg_comps) val concl = mk_eq' lthy (nth full_comps i) $ x |> HOLogic.mk_Trueprop in Logic.list_implies (conds, concl) |> infer_type lthy end) (set_funs ~~ x_vars ~~ xi_vars) val induct_thms = Bnf_Access.induct_thms lthy tycos val set_simps = Bnf_Access.set_simps lthy tycos val case_thms = Bnf_Access.case_thms lthy tycos val distinct_thms = Bnf_Access.distinct_thms lthy tycos val inject_thms = Bnf_Access.inject_thms lthy tycos val rec_info = (the_info lthy, #used_positions, tycos) val split_IHs = split_IHs rec_info val unknown_value = false (* effect of choosing false / true not yet visible *) fun induct_tac ctxt f = ((DETERM o Induction.induction_tac ctxt false (map (fn x => [SOME (NONE, (x, unknown_value))]) x_vars) [] [] (SOME induct_thms) []) THEN_ALL_NEW (fn i => Subgoal.SUBPROOF (fn {context = ctxt, prems = prems, params = iparams, ...} => f (i - 1) ctxt prems iparams) ctxt i)) 1 val recursor_tac = std_recursor_tac rec_info used_tfrees (fn info => #partial_equality_thm info) fun instantiate_IHs IHs pre_conds = map (fn IH => OF_option IH (replicate (Thm.nprems_of IH - length pre_conds) NONE @ map SOME pre_conds)) IHs (* partial eq-theorem *) val _ = debug_out "Partial equality" val eq_thms' = mk_eq_thm' mk_pequality fun eq_solve_tac i ctxt IH_prems xs = let val (i, j) = ind_case_to_idxs cTys i val k = length IH_prems - length arg_comps val pre_conds = drop k IH_prems val IH = take k IH_prems val comp_simps = nth comp_simps i val case_thm = nth case_thms i val distinct_thms = nth distinct_thms i val inject_thms = nth inject_thms i val set_thms = nth set_simps i in (* after induction *) resolve_tac ctxt @{thms pequalityI} 1 THEN Subgoal.FOCUS (fn focus => let val y = #params focus |> hd val yt = y |> snd |> Thm.term_of val ctxt = #context focus val pre_cond = map (fn pre_cond => Local_Defs.unfold ctxt set_thms pre_cond) pre_conds val IH = instantiate_IHs IH pre_cond val xs_tys = map (fastype_of o Thm.term_of o snd) xs val IHs = split_IHs xs_tys IH fun sub_case_tac j' (ctxt, y_simp, _) = if j = j' then unfold_tac ctxt (y_simp @ comp_simps) THEN unfold_tac ctxt @{thms list_all_eq} THEN unfold_tac ctxt (@{thms in_set_simps} @ inject_thms @ @{thms refl_True}) THEN conjI_tac @{thms conj_weak_cong} ctxt xs (fn ctxt' => fn k => resolve_tac ctxt @{thms pequalityD} 1 THEN recursor_tac pre_cond (nth xs_tys k) (nth IHs k) ctxt') else (* different constructors *) unfold_tac ctxt (y_simp @ distinct_thms @ comp_simps @ @{thms bool.simps}) in mk_case_tac ctxt [[SOME yt]] case_thm sub_case_tac end ) ctxt 1 end val eq_thms' = prove_multi_future lthy free_names [] eq_thms' (fn {context = ctxt, ...} => induct_tac ctxt eq_solve_tac) val _ = debug_out (@{make_string} eq_thms') (* total theorems *) fun mk_eq_sym_trans_thm mk_eq_sym_trans compI2 compE2 thms' = let val conds = map (fn c => mk_eq_sym_trans lthy c |> HOLogic.mk_Trueprop) arg_comps val thms = map (fn i => mk_eq_sym_trans lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds,concl))) t_ixs val thms = prove_multi_future lthy free_names [] thms (fn {context = ctxt, ...} => ALLGOALS Goal.conjunction_tac THEN Method.intros_tac ctxt (@{thm conjI} :: compI2 :: thms') [] THEN ALLGOALS (eresolve_tac ctxt [compE2])) in thms end val eq_thms = mk_eq_sym_trans_thm mk_equality @{thm equalityI2} @{thm equalityD2} eq_thms' val _ = debug_out "full equality thms" fun mk_comp_thm (i, e) = let val conds = map (fn c => mk_equality lthy c |> HOLogic.mk_Trueprop) arg_comps val nearly_thm = e val thm = mk_equality lthy (nth full_comps i) |> HOLogic.mk_Trueprop |> (fn concl => Logic.list_implies (conds, concl)) in Goal.prove_future lthy free_names [] thm (K (resolve_tac lthy [nearly_thm] 1 THEN ALLGOALS (assume_tac lthy))) end val comp_thms = map_index mk_comp_thm eq_thms val (_, lthy) = fold_map (fn (thm, cname) => Local_Theory.note ((Binding.name cname, []), [thm])) (comp_thms ~~ compNs) lthy val _ = debug_out (@{make_string} comp_thms) val (_, lthy) = fold_map (fn (thm, cname) => Local_Theory.note ((Binding.name (cname ^ "_pointwise"), []), [thm])) (eq_thms' ~~ compNs) lthy in ((pcomps ~~ pcomp_simps, comps ~~ comp_defs), lthy) ||> fold (fn (((((((tyco, map), pcomp), comp), comp_def), map_comp) , peq_thm), comp_thm) => declare_info tyco map pcomp comp (SOME comp_def) (SOME map_comp) peq_thm comp_thm used_positions) (tycos ~~ maps ~~ pcomps ~~ comps ~~ comp_defs ~~ map_comp_thms ~~ eq_thms' ~~ comp_thms) end fun generate_equality gen_type tyco lthy = let val _ = is_some (get_info lthy tyco) andalso error ("type " ^ quote tyco ^ " does already have a equality") in case gen_type of BNF => generate_equalitys_from_bnf_fp tyco lthy |> snd | EQ => register_equality_of tyco lthy end fun ensure_info gen_type tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_equality gen_type tyco lthy) fun generate_equality_cmd tyco param = Named_Target.theory_map ( if param = "eq" then generate_equality EQ tyco else if param = "" then generate_equality BNF tyco else error ("unknown parameter, expecting no parameter for BNF-datatypes, " ^ "or \"eq\" for types where the built-in equality \"=\" should be used.")) val _ = Theory.setup (Derive_Manager.register_derive "equality" "generate an equality function, options are () and (eq)" generate_equality_cmd) end diff --git a/thys/Deriving/Hash_Generator/hash_generator.ML b/thys/Deriving/Hash_Generator/hash_generator.ML --- a/thys/Deriving/Hash_Generator/hash_generator.ML +++ b/thys/Deriving/Hash_Generator/hash_generator.ML @@ -1,412 +1,412 @@ (* Title: Deriving class instances for datatypes Author: Christian Sternagel and René Thiemann Maintainer: Christian Sternagel and René Thiemann License: LGPL *) signature HASHCODE_GENERATOR = sig type info = {map : term, (* take % x. x, if there is no map *) phash : term, (* partial hash *) hash : term, (* full hash *) hash_def : thm option, (* definition of hash, important for nesting *) map_comp : thm option, (* hashositionality of map, important for nesting *) used_positions : bool list} (* registers some type which is already instance of hashcode class in hash generator where some type must just be a type without type-arguments *) val register_hash_of : string -> local_theory -> local_theory val register_foreign_hash : typ -> (* type-constant without type-variables *) term -> (* hash-function for type *) local_theory -> local_theory val register_foreign_partial_and_full_hash : string -> (* long type name *) term -> (* map function, should be \x. x, if there is no map *) term -> (* partial hash-function of type (hashcode, 'b)ty => hashcode, where 'a is used, 'b is unused *) term -> (* (full) hash-function of type ('a \ hashcode) \ ('a,'b)ty \ hashcode, where 'a is used, 'b is unused *) thm option -> (* hash_def, should be full_hash = phash o map ahash ..., important for nesting *) thm option -> (* map compositionality, important for nesting *) bool list -> (*used positions*) local_theory -> local_theory datatype hash_type = HASHCODE | BNF val generate_hashs_from_bnf_fp : string -> (* name of type *) local_theory -> ((term * thm list) list * (* partial hashs + simp-rules *) (term * thm) list) * (* non-partial hash + def_rule *) local_theory val generate_hash : hash_type -> string -> (* name of type *) local_theory -> local_theory (* construct hashcode instance for datatype *) val hashable_instance : string -> theory -> theory val get_info : Proof.context -> string -> info option (* ensures that the info will be available on later requests *) val ensure_info : hash_type -> string -> local_theory -> local_theory end structure Hashcode_Generator : HASHCODE_GENERATOR = struct open Generator_Aux datatype hash_type = BNF | HASHCODE val hash_name = @{const_name "hashcode"} val hashS = @{sort hashable} val hashT = @{typ hashcode} fun hashfunT T = T --> hashT val hashify = map_atyps (fn _ => hashT) fun phashfunT T = hashify T --> hashT val max_int = 2147483648 (* 2 ^^ 31 *) fun int_of_string s = fold (fn c => fn i => (1792318057 * i + Char.ord c) mod max_int) (String.explode s) 0 (* all numbers in int_of_string and create_factors are primes (31-bit) *) fun create_factor ty_name con_name i = (1444315237 * int_of_string ty_name + 1336760419 * int_of_string con_name + 2044890737 * (i + 1) ) mod max_int fun create_hashes ty_name con_name Ts = map (fn i => HOLogic.mk_number hashT (create_factor ty_name con_name i)) (0 upto length Ts) |> HOLogic.mk_list hashT fun create_def_size _ = 10 type info = {map : term, phash : term, hash : term, hash_def : thm option, map_comp : thm option, used_positions : bool list}; structure Data = Generic_Data ( type T = info Symtab.table; val empty = Symtab.empty; val merge = Symtab.merge (fn (info1 : info, info2 : info) => #hash info1 = #hash info2); ); fun add_info T info = Data.map (Symtab.update_new (T, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no hash_code information available for type " ^ quote tyco)) fun declare_info tyco m p c c_def m_hash used_pos = - Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => + Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn phi => add_info tyco {map = Morphism.term phi m, phash = Morphism.term phi p, hash = Morphism.term phi c, hash_def = Option.map (Morphism.thm phi) c_def, map_comp = Option.map (Morphism.thm phi) m_hash, used_positions = used_pos}) fun register_foreign_partial_and_full_hash tyco m p c c_def m_hash eq_thm c_thm = declare_info tyco m p c c_def m_hash eq_thm c_thm fun default_hash T = absdummy T @{term "0 :: hashcode"} (*%_. 0*) fun register_foreign_hash T hash lthy = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant with no arguments") in register_foreign_partial_and_full_hash tyco (HOLogic.id_const T) hash hash NONE NONE [] lthy end fun register_hash_of tyco lthy = let val _ = is_class_instance (Proof_Context.theory_of lthy) tyco hashS orelse error ("type " ^ quote tyco ^ " is not an instance of class \"hashable\"") val (T,_) = typ_and_vs_of_typname (Proof_Context.theory_of lthy) tyco @{sort type} val hash = Const (hash_name, hashfunT T) in register_foreign_hash T hash lthy end fun generate_hashs_from_bnf_fp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating hash-function for type " ^ quote tyco) tycos |> cat_lines |> writeln val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val cs = map (subT "h") used_tfrees val hash_Ts = map hashfunT used_tfrees val arg_hashs = map Free (cs ~~ hash_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] val map_simps = Bnf_Access.map_simps lthy tycos val case_simps = Bnf_Access.case_simps lthy tycos val maps = Bnf_Access.map_terms lthy tycos val map_comp_thms = Bnf_Access.map_comps lthy tycos (* primrec definitions of partial hashs *) fun mk_phash (tyco, T) = ("partial_hash_code_" ^ Long_Name.base_name tyco, phashfunT T) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (map freeify_tvars o fst o strip_type) o dest_Const) fun generate_phash_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco fun hash_arg T x = let val m = Generator_Aux.create_map default_hash (K o Free o mk_phash) () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #phash oo the_info) tycos ((K o K) ()) T lthy val p = Generator_Aux.create_partial () (K false) (#used_positions oo the_info) (#map oo the_info) (K o #phash oo the_info) tycos ((K o K) ()) T lthy in p $ (m $ x) |> infer_type lthy end fun generate_eq lthy (cN, Ts) = let val arg_Ts' = map hashify Ts val c = Const (cN, arg_Ts' ---> hashify T) val xs = Name.invent_names (Variable.names_of lthy) "x" (arg_Ts') |> map Free val lhs = Free (mk_phash (tyco, T)) $ list_comb (c, xs) val rhs = @{term hash_combine} $ HOLogic.mk_list hashT (@{map 2} hash_arg Ts xs) $ create_hashes tyco cN Ts in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy end in map (generate_eq lthy) constrs end val eqs = map (generate_phash_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_phash |> map (fn (name, T) => (Binding.name name, SOME T, NoSyn)) val ((phashs, phash_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs) |> Local_Theory.end_nested_result (fn phi => fn (phashs, _, phash_simps) => (map (Morphism.term phi) phashs, map (Morphism.fact phi) phash_simps)) (* definitions of hashs via partial hashs and maps *) fun generate_hash_def tyco lthy = let val cs = map (subT "h") used_tfrees val arg_Ts = map hashfunT used_tfrees val args = map Free (cs ~~ arg_Ts) val (phash, m) = AList.lookup (op =) (tycos ~~ (phashs ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ args) T |> the_default (default_hash T)) val rhs = HOLogic.mk_comp (phash, list_comb (m, ts)) |> infer_type lthy val abs_def = lambdas args rhs val name = "hash_code_" ^ Long_Name.base_name tyco val ((hash, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (hash, args), rhs) val thm = Goal.prove lthy (map (fst o dest_Free) args) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt [prethm]) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K hash) end val ((hashs, hash_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_hash_def tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (hashs, hash_defs) => (map (Morphism.term phi) hashs, map (Morphism.thm phi) hash_defs)) (* alternative simp-rules for hashs *) fun generate_hash_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco fun hash_arg T x = let fun create_hash (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_hashs) T |> the_default (HOLogic.id_const dummyT) | create_hash (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ hashs) tyco of SOME c => list_comb (c, arg_hashs) | NONE => let val {hash = c, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_hash T) else NONE) in list_comb (c, ts) end) | create_hash T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val hash = create_hash T in hash $ x |> infer_type lthy end fun generate_eq_thm lthy (c_T as (cN, Ts)) = let val xs = Variable.names_of lthy |> fold_map (fn T => Name.variant "x" #>> Free o rpair T) Ts |> fst fun mk_const (c, Ts) = Const (c, Ts ---> T) val hash_const = AList.lookup (op =) (tycos ~~ hashs) tyco |> the val lhs = list_comb (hash_const, arg_hashs) $ list_comb (mk_const c_T, xs) val rhs = @{term hash_combine} $ HOLogic.mk_list hashT (@{map 2} hash_arg Ts xs) $ create_hashes tyco cN Ts val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy val dep_hash_defs = map_filter (#hash_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thms = prove_multi_future lthy (map (fst o dest_Free) xs @ cs) [] [eq] (fn {context = ctxt, ...} => Goal.conjunction_tac 1 THEN unfold_tac ctxt (@{thms id_apply o_def} @ flat case_simps @ flat phash_simps @ dep_map_comps @ hash_defs @ dep_hash_defs @ flat map_simps)) in thms end val thms = map (generate_eq_thm lthy) constrs |> flat val simp_thms = map (Local_Defs.unfold lthy @{thms hash_combine_unfold}) thms val name = "hash_code_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), simp_thms) |> snd |> (fn lthy => (thms, lthy)) end val lthy = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_hash_simps (tycos ~~ Ts) |> snd |> Local_Theory.end_nested in ((phashs ~~ phash_simps, hashs ~~ hash_defs), lthy) ||> fold (fn (((((tyco, map), phash), hash), hash_def), map_comp) => declare_info tyco map phash hash (SOME hash_def) (SOME map_comp) used_positions) (tycos ~~ maps ~~ phashs ~~ hashs ~~ hash_defs ~~ map_comp_thms) end fun generate_hash gen_type tyco lthy = let val _ = is_some (get_info lthy tyco) andalso error ("type " ^ quote tyco ^ " does already have a hash") in case gen_type of BNF => generate_hashs_from_bnf_fp tyco lthy |> snd | HASHCODE => register_hash_of tyco lthy end fun ensure_info gen_type tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_hash gen_type tyco lthy) fun dest_hash ctxt tname = (case get_info ctxt tname of SOME {hash = c, ...} => let val Ts = fastype_of c |> strip_type |> fst |> `((fn x => x - 1) o length) |> uncurry take in (c, Ts) end | NONE => error ("no hash info for type " ^ quote tname)) fun all_tys hash free_types = let val Ts = fastype_of hash |> strip_type |> fst |> List.last |> dest_Type |> snd in rename_types (Ts ~~ free_types) end fun mk_hash_rhs c Ts = list_comb (c, map (fn T => Const (hash_name, T)) Ts) fun mk_hash_def T rhs = Logic.mk_equals (Const (hash_name, hashfunT T), rhs) fun hashable_instance tname thy = let val _ = is_class_instance thy tname hashS andalso error ("type " ^ quote tname ^ " is already an instance of class \"hashcode\"") val _ = writeln ("deriving \"hashable\" instance for type " ^ quote tname) val thy = Named_Target.theory_map (ensure_info BNF tname) thy val {used_positions = us, ...} = the (get_info (Named_Target.theory_init thy) tname) val (_, xs) = typ_and_vs_of_used_typname tname us hashS val (_, (hashs_thm,lthy)) = Class.instantiation ([tname], xs, hashS) thy |> (fn ctxt => let val (c, Ts) = dest_hash ctxt tname val typ_mapping = all_tys c (map TFree xs) val hash_rhs = mk_hash_rhs c Ts val hash_def = mk_hash_def dummyT hash_rhs |> typ_mapping |> infer_type ctxt val ty = Term.fastype_of (snd (Logic.dest_equals hash_def)) |> Term.dest_Type |> snd |> hd val ty_it = Type (@{type_name itself}, [ty]) val hashs_rhs = lambda (Free ("x",ty_it)) (HOLogic.mk_number @{typ nat} (create_def_size tname)) val hashs_def = mk_def (ty_it --> @{typ nat}) @{const_name def_hashmap_size} hashs_rhs val basename = Long_Name.base_name tname in Generator_Aux.define_overloaded_generic ((Binding.name ("hashcode_" ^ basename ^ "_def"), @{attributes [code]}), hash_def) ctxt ||> define_overloaded ("def_hashmap_size_" ^ basename ^ "_def", hashs_def) end) in Class.prove_instantiation_exit (fn ctxt => Class.intro_classes_tac ctxt [] THEN unfold_tac ctxt [hashs_thm] THEN simp_tac ctxt 1 ) lthy end fun generate_hash_cmd tyco param = Named_Target.theory_map ( if param = "hashcode" then generate_hash HASHCODE tyco else if param = "" then generate_hash BNF tyco else error ("unknown parameter, expecting no parameter for BNF-datatypes, " ^ "or \"hashcode\" for types where the class-instance hashcode should be used.")) val _ = Theory.setup (Derive_Manager.register_derive "hash_code" "generate a hash function, options are () and (hashcode)" generate_hash_cmd #> Derive_Manager.register_derive "hashable" "register types in class hashable" (fn tyname => K (hashable_instance tyname))) end diff --git a/thys/Dict_Construction/class_graph.ML b/thys/Dict_Construction/class_graph.ML --- a/thys/Dict_Construction/class_graph.ML +++ b/thys/Dict_Construction/class_graph.ML @@ -1,339 +1,339 @@ signature CLASS_GRAPH = sig type selector = typ -> term type node = {class: string, qname: string, selectors: selector Symtab.table, make: typ -> term, data_thms: thm list, cert: typ -> term, cert_thms: thm * thm * thm list} val dict_typ: node -> typ -> typ type edge = {super_selector: selector, subclass: thm} type path = edge list type ev val class_of: ev -> class val node_of: ev -> node val parents_of: ev -> (edge * ev) Symtab.table val find_path': ev -> (ev -> 'a option) -> (path * 'a) option val find_path: ev -> class -> path option val fold_path: path -> typ -> term -> term val ensure_class: class -> local_theory -> (ev * local_theory) val edges: local_theory -> class -> edge Symtab.table option val node: local_theory -> class -> node option val all_edges: local_theory -> edge Symreltab.table val all_nodes: local_theory -> node Symtab.table val pretty_ev: Proof.context -> ev -> Pretty.T (* utilities *) val mangle: string -> string val param_sorts: string -> class -> theory -> class list list val super_classes: class -> theory -> string list end structure Class_Graph: CLASS_GRAPH = struct open Dict_Construction_Util val mangle = translate_string (fn x => if x = "." then "_" else if x = "_" then "__" else x) fun param_sorts tyco class thy = let val algebra = Sign.classes_of thy in Sorts.mg_domain algebra tyco [class] |> map (filter (Class.is_class thy)) end fun super_classes class thy = let val algebra = Sign.classes_of thy in Sorts.super_classes algebra class |> Sorts.minimize_sort algebra |> filter (Class.is_class thy) |> sort fast_string_ord end type selector = typ -> term type node = {class: string, qname: string, selectors: selector Symtab.table, make: typ -> term, data_thms: thm list, cert: typ -> term, cert_thms: thm * thm * thm list} type edge = {super_selector: selector, subclass: thm} type path = edge list abstype ev = Evidence of class * node * (edge * ev) Symtab.table with fun class_of (Evidence (class, _, _)) = class fun node_of (Evidence (_, node, _)) = node fun parents_of (Evidence (_, _, tab)) = tab fun mk_evidence class node tab = Evidence (class, node, tab) fun find_path' ev is_goal = case is_goal ev of SOME a => SOME ([], a) | NONE => let fun f (_, (edge, ev)) = Option.map (apfst (cons edge)) (find_path' ev is_goal) in Symtab.get_first f (parents_of ev) end fun find_path ev goal = find_path' ev (fn ev => if class_of ev = goal then SOME () else NONE) |> Option.map fst fun pretty_ev ctxt (Evidence (class, {qname, ...}, tab)) = let val typ = @{typ 'a} fun mk_super ({super_selector, ...}, super_ev) = Pretty.block [Pretty.str "selector:", Pretty.brk 1, Syntax.pretty_term ctxt (super_selector typ), Pretty.fbrk, pretty_ev ctxt super_ev] val supers = Symtab.dest tab |> map (fn (_, super) => mk_super super) |> Pretty.big_list "super classes" in Pretty.block [Pretty.str "Evidence for ", Syntax.pretty_sort ctxt [class], Pretty.str ": ", Syntax.pretty_typ ctxt (Type (qname, [typ])), Pretty.str (" (qname = " ^ qname ^ ")"), Pretty.fbrk, supers] end end structure Classes = Generic_Data ( type T = (edge Symtab.table * node) Symtab.table val empty = Symtab.empty fun merge (t1, t2) = if Symtab.is_empty t1 andalso Symtab.is_empty t2 then Symtab.empty else error "merging not supported" ) fun node lthy class = Symtab.lookup (Classes.get (Context.Proof lthy)) class |> Option.map snd fun edges lthy class = Symtab.lookup (Classes.get (Context.Proof lthy)) class |> Option.map fst val all_nodes = Context.Proof #> Classes.get #> Symtab.map (K snd) val all_edges = Context.Proof #> Classes.get #> Symtab.map (K fst) #> symreltab_of_symtab fun dict_typ {qname, ...} typ = Type (qname, [typ]) fun fold_path path typ = fold (fn {super_selector = s, ...} => fn acc => s typ $ acc) path fun mk_super_selector' qualified qname super_ev typ = let val {class = super_class, qname = super_qname, ...} = node_of super_ev val raw_name = mangle super_class ^ "__super" val name = if qualified then Long_Name.append qname raw_name else raw_name in (name, Type (qname, [typ]) --> Type (super_qname, [typ])) end fun mk_node class info super_evs lthy = let fun print_info ctxt = Pretty.block [Pretty.str "Defining record for class ", Syntax.pretty_sort ctxt [class]] |> Pretty.writeln val name = mangle class ^ "__dict" val qname = Local_Theory.full_name lthy (Binding.name name) val tvar = @{typ 'a} val typ = Type (qname, [tvar]) fun mk_field name ftyp = (Binding.name name, ftyp) val params = #params info |> map (fn (name', ftyp) => let val ftyp' = typ_subst_atomic [(TFree ("'a", [class]), @{typ 'a})] ftyp val field_name = mangle name' ^ "__field" val field = mk_field field_name ftyp' fun sel tvar' = Const (Long_Name.append qname field_name, typ_subst_atomic [(tvar, tvar')] (typ --> ftyp')) in (field, (name', sel)) end) val (fields, selectors) = split_list params val super_params = Symtab.dest super_evs |> map (fn (_, super_ev) => let val {cert = raw_super_cert, qname = super_qname, ...} = node_of super_ev val (field_name, _) = mk_super_selector' false qname super_ev tvar val field = mk_field field_name (Type (super_qname, [tvar])) fun sel typ = Const (mk_super_selector' true qname super_ev typ) fun super_cert dict = raw_super_cert tvar $ (sel tvar $ dict) val raw_edge = (class_of super_ev, sel) in (field, raw_edge, super_cert) end) val (super_fields, raw_edges, super_certs) = split_list3 super_params val all_fields = super_fields @ fields fun make typ' = Const (Long_Name.append qname "Dict", typ_subst_atomic [(tvar, typ')] (map #2 all_fields ---> typ)) val cert_name = name ^ "__cert" val cert_binding = Binding.name cert_name val cert_body = let fun local_param_eq ((_, typ), (name, sel)) dict = HOLogic.mk_eq (sel tvar $ dict, Const (name, typ)) in map local_param_eq params @ super_certs end val cert_var_name = "dict" val cert_term = Abs (cert_var_name, typ, List.foldr HOLogic.mk_conj @{term True} (map (fn x => x (Bound 0)) cert_body)) fun prove_thms (cert, cert_def) lthy = let val var = Free (cert_var_name, typ) fun tac ctxt = Local_Defs.unfold_tac ctxt [cert_def] THEN blast_tac ctxt 1 fun prove prop = Goal.prove_future lthy [cert_var_name] [] prop (fn {context, ...} => tac context) fun mk_dest_props raw_prop = HOLogic.mk_Trueprop (cert $ var) ==> HOLogic.mk_Trueprop (raw_prop var) fun mk_intro_cond raw_prop = HOLogic.mk_Trueprop (raw_prop var) val dests = map (fn raw_prop => prove (mk_dest_props raw_prop)) cert_body val intro = prove (map mk_intro_cond cert_body ===> HOLogic.mk_Trueprop (cert $ var)) val (dests', (intro', lthy')) = note_thms Binding.empty dests lthy ||> note_thm Binding.empty intro val (param_dests, super_dests) = chop (length params) dests' fun pre_edges phi = let fun mk_edge thm (sc, sel) = (sc, {super_selector = sel, subclass = Morphism.thm phi thm}) in Symtab.make (map2 mk_edge super_dests raw_edges) end in ((param_dests, pre_edges, intro'), lthy') end val constructor = (((Binding.empty, Binding.name "Dict"), all_fields), NoSyn) val datatyp = (([(NONE, (@{typ 'a}, @{sort type}))], Binding.name name), NoSyn) val dtspec = (Ctr_Sugar.default_ctr_options, [(((datatyp, [constructor]), (Binding.empty, Binding.empty, Binding.empty)), [])]) val (((raw_cert, raw_cert_def), (param_dests, pre_edges, intro)), (lthy', lthy)) = lthy |> tap print_info |> BNF_FP_Def_Sugar.co_datatypes BNF_Util.Least_FP BNF_LFP.construct_lfp dtspec (* FIXME ideally BNF would return a fp_sugar value right here so that I can avoid constructing long names by hand above *) |> (snd o Local_Theory.begin_nested) |> Local_Theory.define ((cert_binding, NoSyn), ((Thm.def_binding cert_binding, []), cert_term)) |>> apsnd snd |> (fn (raw_cert, lthy) => prove_thms raw_cert lthy |>> pair raw_cert) ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' fun cert typ = subst_TVars [(("'a", 0), typ)] (Morphism.term phi raw_cert) val cert_def = Morphism.thm phi raw_cert_def val edges = pre_edges phi val param_dests' = map (Morphism.thm phi) param_dests val intro' = Morphism.thm phi intro val data_thms = BNF_FP_Def_Sugar.fp_sugar_of lthy' qname |> the |> #fp_ctr_sugar |> #ctr_sugar |> #sel_thmss |> flat |> map safe_mk_meta_eq val node = {class = class, qname = qname, selectors = Symtab.make selectors, make = make, data_thms = data_thms, cert = cert, cert_thms = (cert_def, intro', param_dests')} in (node, edges, lthy') end fun ensure_class class lthy = if not (Class.is_class (Proof_Context.theory_of lthy) class) then error ("not a proper class: " ^ class) else let val thy = Proof_Context.theory_of lthy val super_classes = super_classes class thy fun collect_super mk_node = let val (super_evs, lthy') = fold_map ensure_class super_classes lthy val raw_tab = Symtab.make (super_classes ~~ super_evs) val (node, edges, lthy'') = mk_node raw_tab lthy' val tab = zip_symtabs pair edges raw_tab val ev = mk_evidence class node tab in (ev, edges, lthy'') end in case Symtab.lookup (Classes.get (Context.Proof lthy)) class of SOME (edge_tab, node) => if super_classes = Symtab.keys edge_tab then let val (ev, _, lthy') = collect_super (fn _ => fn lthy => (node, edge_tab, lthy)) in (ev, lthy') end else (* This happens when a new subclass relationship is established which subsumes or augments previous superclasses. *) error "class with different super classes" | NONE => let val ax_info = Axclass.get_info thy class val (ev, edges, lthy') = collect_super (mk_node class ax_info) val upd = Symtab.update_new (class, (edges, node_of ev)) in - (ev, Local_Theory.declaration {pervasive = false, syntax = false} (K (Classes.map upd)) lthy') + (ev, Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} (K (Classes.map upd)) lthy') end end end diff --git a/thys/Dict_Construction/dict_construction.ML b/thys/Dict_Construction/dict_construction.ML --- a/thys/Dict_Construction/dict_construction.ML +++ b/thys/Dict_Construction/dict_construction.ML @@ -1,934 +1,934 @@ signature DICT_CONSTRUCTION = sig datatype cert_proof = Cert | Skip type const type 'a sccs = (string * 'a) list list val annotate_code_eqs: local_theory -> string list -> (const sccs * local_theory) val new_names: local_theory -> const sccs -> (string * const) sccs val symtab_of_sccs: 'a sccs -> 'a Symtab.table val axclass: class -> local_theory -> Class_Graph.node * local_theory val instance: (string * const) Symtab.table -> string -> class -> local_theory -> term * local_theory val term: term Symreltab.table -> (string * const) Symtab.table -> term -> local_theory -> (term * local_theory) val consts: (string * const) Symtab.table -> cert_proof -> (string * const) list -> local_theory -> local_theory (* certification *) type const_info = {fun_info: Function.info option, inducts: thm list option, base_thms: thm list, base_certs: thm list, simps: thm list, code_thms: thm list, (* old defining theorems *) congs: thm list option} type fun_target = (string * class) list * (term * term) type dict_thms = {base_thms: thm list, def_thm: thm} type dict_target = (string * class) list * (term * string * class) val prove_fun_cert: fun_target list -> const_info -> cert_proof -> local_theory -> thm list val prove_dict_cert: dict_target -> dict_thms -> local_theory -> thm val the_info: Proof.context -> string -> const_info (* utilities *) val normalizer_conv: Proof.context -> conv val cong_of_const: Proof.context -> string -> thm option val get_code_eqs: Proof.context -> string -> thm list val group_code_eqs: Proof.context -> string list -> (string * (((string * sort) list * typ) * ((term list * term) * thm option) list)) list list end structure Dict_Construction: DICT_CONSTRUCTION = struct open Class_Graph open Dict_Construction_Util (* FIXME copied from skip_proof.ML *) val (_, make_thm_cterm) = Context.>>> (Context.map_theory_result (Thm.add_oracle (@{binding cert_oracle}, I))) fun make_thm ctxt prop = make_thm_cterm (Thm.cterm_of ctxt prop) fun cheat_tac ctxt i st = resolve_tac ctxt [make_thm ctxt (Var (("A", 0), propT))] i st (** utilities **) val normalizer_conv = Axclass.overload_conv fun cong_of_const ctxt name = let val head = Thm.concl_of #> Logic.dest_equals #> fst #> strip_comb #> fst #> dest_Const #> fst fun applicable thm = try head thm = SOME name in Function_Context_Tree.get_function_congs ctxt |> filter applicable |> try hd end fun group_code_eqs ctxt consts = let val thy = Proof_Context.theory_of ctxt val graph = #eqngr (Code_Preproc.obtain true { ctxt = ctxt, consts = consts, terms = [] }) fun mk_eqs name = name |> Code_Preproc.cert graph |> Code.equations_of_cert thy ||> these ||> map (apsnd fst o apfst (apsnd snd o apfst (map snd))) |> pair name in map (map mk_eqs) (rev (Graph.strong_conn graph)) end fun get_code_eqs ctxt const = AList.lookup op = (flat (group_code_eqs ctxt [const])) const |> the |> snd |> map snd |> cat_options |> map (Conv.fconv_rule (normalizer_conv ctxt)) (** certification **) datatype cert_proof = Cert | Skip type const_info = {fun_info: Function.info option, inducts: thm list option, base_thms: thm list, base_certs: thm list, simps: thm list, code_thms: thm list, congs: thm list option} fun map_const_info f1 f2 f3 f4 f5 f6 f7 {fun_info, inducts, base_thms, base_certs, simps, code_thms, congs} = {fun_info = f1 fun_info, inducts = f2 inducts, base_thms = f3 base_thms, base_certs = f4 base_certs, simps = f5 simps, code_thms = f6 code_thms, congs = f7 congs} fun morph_const_info phi = map_const_info (Option.map (Function_Common.transform_function_data phi)) (Option.map (map (Morphism.thm phi))) (map (Morphism.thm phi)) (map (Morphism.thm phi)) (map (Morphism.thm phi)) I (* sic *) (Option.map (map (Morphism.thm phi))) type fun_target = (string * class) list * (term * term) type dict_thms = {base_thms: thm list, def_thm: thm} type dict_target = (string * class) list * (term * string * class) fun fun_cert_tac base_thms base_certs simps code_thms = SOLVED' o Subgoal.FOCUS (fn {prems, context = ctxt, concl, ...} => let val _ = if_debug ctxt (fn () => tracing ("Proving " ^ Syntax.string_of_term ctxt (Thm.term_of concl))) fun is_ih prem = Thm.prop_of prem |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop |> can HOLogic.dest_eq val (ihs, certs) = partition is_ih prems val super_certs = all_edges ctxt |> Symreltab.dest |> map (#subclass o snd) val param_dests = all_nodes ctxt |> Symtab.dest |> maps (#3 o #cert_thms o snd) val congs = Function_Context_Tree.get_function_congs ctxt @ map safe_mk_meta_eq @{thms cong} val simp_context = (clear_simpset ctxt) addsimps (certs @ super_certs @ base_certs @ base_thms @ param_dests) addloop ("overload", CONVERSION o changed_conv o Axclass.overload_conv) val ihs = map (Simplifier.asm_full_simplify simp_context) ihs val ih_tac = resolve_tac ctxt ihs THEN_ALL_NEW (TRY' (SOLVED' (Simplifier.asm_full_simp_tac simp_context))) val unfold_new = ANY' (map (CONVERSION o rewr_lhs_head_conv) simps) val normalize = CONVERSION (normalizer_conv ctxt) val unfold_old = ANY' (map (CONVERSION o rewr_rhs_head_conv) code_thms) val simp = CONVERSION (lhs_conv (Simplifier.asm_full_rewrite simp_context)) fun walk_congs i = i |> ((resolve_tac ctxt @{thms refl} ORELSE' SOLVED' (Simplifier.asm_full_simp_tac simp_context) ORELSE' ih_tac ORELSE' Method.assm_tac ctxt ORELSE' (resolve_tac ctxt @{thms meta_eq_to_obj_eq} THEN' fo_resolve_tac congs ctxt)) THEN_ALL_NEW walk_congs) val tacs = [unfold_new, normalize, unfold_old, simp, walk_congs] in EVERY' tacs 1 end) fun dict_cert_tac class def_thm base_thms = SOLVED' o Subgoal.FOCUS (fn {prems, context = ctxt, ...} => let val (intro, sels) = case node ctxt class of SOME {cert_thms = (_, intro, _), data_thms = sels, ...} => (intro, sels) | NONE => error ("class " ^ class ^ " is not defined") val apply_intro = resolve_tac ctxt [intro] val unfold_dict = CONVERSION (Conv.rewr_conv def_thm |> Conv.arg_conv |> lhs_conv) val normalize = CONVERSION (normalizer_conv ctxt) val smash_sels = CONVERSION (lhs_conv (Conv.rewrs_conv sels)) val solve = resolve_tac ctxt (@{thm HOL.refl} :: base_thms) val finally = resolve_tac ctxt prems val tacs = [apply_intro, unfold_dict, normalize, smash_sels, solve, finally] in EVERY (map (ALLGOALS' ctxt) tacs) end) fun prepare_dicts classes names lthy = let val sorts = Symtab.make_list classes fun mk_dicts (param_name, (tvar, class)) = case node lthy class of NONE => error ("unknown class " ^ class) | SOME {cert, qname, ...} => let val sort = the (Symtab.lookup sorts tvar) val param = Free (param_name, Type (qname, [TFree (tvar, sort)])) in (param, HOLogic.mk_Trueprop (cert dummyT $ param)) end val dict_names = Name.invent_names names "a" classes val names = fold Name.declare (map fst dict_names) names val (dict_params, prems) = split_list (map mk_dicts dict_names) in (dict_params, prems, names) end fun prepare_fun_goal targets lthy = let fun mk_eq (classes, (lhs, rhs)) names = let val (lhs_name, _) = dest_Const lhs val (rhs_name, rhs_typ) = dest_Const rhs val (dict_params, prems, names) = prepare_dicts classes names lthy val param_names = fst (strip_type rhs_typ) |> map (K dummyT) |> Name.invent_names names "a" val names = fold Name.declare (map fst param_names) names val params = map Free param_names val lhs = list_comb (Const (lhs_name, dummyT), dict_params @ params) val rhs = list_comb (Const (rhs_name, dummyT), params) val eq = Const (@{const_name HOL.eq}, dummyT) $ lhs $ rhs val all_params = dict_params @ params val eq :: rest = Syntax.check_terms lthy (eq :: prems @ all_params) val (prems, all_params) = unappend (prems, all_params) rest val eq = if is_some (Axclass.inst_of_param (Proof_Context.theory_of lthy) rhs_name) then Thm.cterm_of lthy eq |> conv_result (Conv.arg_conv (normalizer_conv lthy)) else eq val prop = prems ===> HOLogic.mk_Trueprop eq in ((all_params, prop), names) end in fold_map mk_eq targets Name.context |> fst |> split_list end fun prepare_dict_goal (classes, (term, _, class)) lthy = let val cert = case node lthy class of NONE => error ("unknown class " ^ class) | SOME {cert, ...} => cert dummyT val names = Name.context val (dict_params, prems, _) = prepare_dicts classes names lthy val (term_name, _) = dest_Const term val dict = list_comb (Const (term_name, dummyT), dict_params) val prop = prems ===> HOLogic.mk_Trueprop (cert $ dict) val prop :: dict_params = Syntax.check_terms lthy (prop :: dict_params) in (dict_params, prop) end fun prove_fun_cert targets {inducts, base_thms, base_certs, simps, code_thms, ...} proof lthy = let (* the props contain dictionary certs as prems we can't exclude them from the induction because the dicts are part of the function definition excluding them would mean that applying the induction rules becomes tricky or impossible proper fix would be if fun, akin to inductive, supported a "for" clause that marks parameters as "not changing" *) val (argss, props) = prepare_fun_goal targets lthy val frees = flat argss |> map (fst o dest_Free) (* we first prove the extensional variant (easier to prove), and then derive the contracted variant abs_def can't deal with premises, so we use our own version here *) val tac = case proof of Cert => fun_cert_tac base_thms base_certs simps code_thms | Skip => cheat_tac val long_thms = prove_common' lthy frees [] props (fn {context, ...} => maybe_induct_tac inducts argss [] context THEN ALLGOALS' context (tac context)) in map (contract lthy) long_thms end fun prove_dict_cert target {base_thms, def_thm} lthy = let val (args, prop) = prepare_dict_goal target lthy val frees = map (fst o dest_Free) args val (_, (_, _, class)) = target in prove' lthy frees [] prop (fn {context, ...} => dict_cert_tac class def_thm base_thms context 1) end (** background data **) type definitions = {instantiations: (term * thm) Symreltab.table, (* key: (class, tyco) *) constants: (string * (thm option * const_info)) Symtab.table (* key: constant name *) } structure Definitions = Generic_Data ( type T = definitions val empty = {instantiations = Symreltab.empty, constants = Symtab.empty} fun merge ({instantiations = i1, constants = c1}, {instantiations = i2, constants = c2}) = if Symreltab.is_empty i1 andalso Symtab.is_empty c1 andalso Symreltab.is_empty i2 andalso Symtab.is_empty c2 then empty else error "merging not supported" ) fun map_definitions map_insts map_consts = Definitions.map (fn {instantiations, constants} => {instantiations = map_insts instantiations, constants = map_consts constants}) fun the_info ctxt name = Symtab.lookup (#constants (Definitions.get (Context.Proof ctxt))) name |> the |> snd |> snd fun add_instantiation (class, tyco) term cert = let fun upd phi = map_definitions (fn tab => if Symreltab.defined tab (class, tyco) then error ("Duplicate instantiation " ^ quote tyco ^ " :: " ^ quote class) else tab |> Symreltab.update ((class, tyco), (Morphism.term phi term, Morphism.thm phi cert))) I in - Local_Theory.declaration {pervasive = false, syntax = false} upd + Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} upd end fun add_constant name name' (cert, info) lthy = let val qname = Local_Theory.full_name lthy (Binding.name name') fun upd phi = map_definitions I (fn tab => if Symtab.defined tab name then error ("Duplicate constant " ^ quote name) else tab |> Symtab.update (name, (qname, (Option.map (Morphism.thm phi) cert, morph_const_info phi info)))) in - Local_Theory.declaration {pervasive = false, syntax = false} upd lthy + Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} upd lthy |> Local_Theory.note ((Binding.empty, @{attributes [dict_construction_specs]}), #simps info) |> snd end (** classes **) fun axclass class = ensure_class class #>> node_of (** grouping and annotating constants **) datatype const = Fun of {dicts: ((string * class) * typ) list, certs: term list, param_typs: typ list, typ: typ, (* typified *) new_typ: typ, eqs: {params: term list, rhs: term, thm: thm} list, info: Function_Common.info option, cong: thm option} | Constructor | Classparam of {class: class, typ: typ, (* varified *) selector: term (* varified *)} type 'a sccs = (string * 'a) list list fun symtab_of_sccs x = Symtab.make (flat x) fun raw_dict_params tparams lthy = let fun mk_dict tparam class lthy = let val (node, lthy') = axclass class lthy val targ = TFree (tparam, @{sort type}) val typ = dict_typ node targ val cert = #cert node targ in ((((tparam, class), typ), cert), lthy') end fun mk_dicts (tparam, sort) = fold_map (mk_dict tparam) (filter (Class.is_class (Proof_Context.theory_of lthy)) sort) in fold_map mk_dicts tparams lthy |>> flat end fun dict_params context dicts = let fun dict_param ((_, class), typ) = Name.variant (mangle class) #>> rpair typ #>> Free in fold_map dict_param dicts context end fun get_sel class param typ lthy = let val ({selectors, ...}, lthy') = axclass class lthy in case Symtab.lookup selectors param of NONE => error ("unknown class parameter " ^ param) | SOME sel => (sel typ, lthy') end fun annotate_const name ((tparams, typ), raw_eqs) lthy = if Code.is_constr (Proof_Context.theory_of lthy) name then ((name, Constructor), lthy) else if null raw_eqs then (* this detection is reliable, because code equations with overloaded heads are not allowed *) let val (_, class) = the_single tparams ||> the_single val (selector, thy') = get_sel class name (TVar (("'a", 0), @{sort type})) lthy val typ = range_type (fastype_of selector) in ((name, Classparam {class = class, typ = typ, selector = selector}), thy') end else let val info = try (Function.get_info lthy) (Const (name, typ)) val cong = cong_of_const lthy name val ((raw_dicts, certs), lthy') = raw_dict_params tparams lthy |>> split_list val dict_typs = map snd raw_dicts val typ' = typify_typ typ fun mk_eq ((raw_params, rhs), SOME thm) = let val norm = normalizer_conv lthy' val transform = Thm.cterm_of lthy' #> conv_result norm #> typify val params = map transform raw_params in if has_duplicates (op =) (flat (map all_frees' params)) then (warning "ignoring code equation with non-linear pattern"; NONE) else SOME {params = params, rhs = rhs, thm = Conv.fconv_rule norm thm} end | mk_eq _ = error "no theorem" val const = Fun {dicts = raw_dicts, certs = certs, typ = typ', param_typs = binder_types typ', new_typ = dict_typs ---> typ', eqs = map_filter mk_eq raw_eqs, info = info, cong = cong} in ((name, const), lthy') end fun annotate_code_eqs lthy consts = fold_map (fold_map (uncurry annotate_const)) (group_code_eqs lthy consts) lthy (** instances and terms **) fun mk_path [] _ _ lthy = (NONE, lthy) | mk_path ((class, term) :: rest) typ goal lthy = let val (ev, lthy') = ensure_class class lthy in case find_path ev goal of SOME path => (SOME (fold_path path typ term), lthy') | NONE => mk_path rest typ goal lthy' end fun instance consts tyco class lthy = case Symreltab.lookup (#instantiations (Definitions.get (Context.Proof lthy))) (class, tyco) of SOME (inst, _) => (inst, lthy) | NONE => let val thy = Proof_Context.theory_of lthy val tparam_sorts = param_sorts tyco class thy fun print_info ctxt = let val tvars = Name.invent_list [] Name.aT (length tparam_sorts) ~~ tparam_sorts |> map TFree in [Pretty.str "Defining instance ", Syntax.pretty_typ ctxt (Type (tyco, tvars)), Pretty.str " :: ", Syntax.pretty_sort ctxt [class]] |> Pretty.block |> Pretty.writeln end val ({make, ...}, lthy) = axclass class lthy val name = mangle class ^ "__instance__" ^ mangle tyco val tparams = Name.invent_names Name.context Name.aT tparam_sorts val ((dict_params, _), lthy) = raw_dict_params tparams lthy |>> map fst |>> dict_params (Name.make_context [name]) val dict_context = Symreltab.make (flat_right tparams ~~ dict_params) val {params, ...} = Axclass.get_info thy class val (super_fields, lthy) = fold_map (obtain_dict dict_context consts (Type (tyco, map TFree tparams))) (super_classes class thy) lthy val tparams' = map (TFree o rpair @{sort type} o fst) tparams val typ_inst = (TFree ("'a", [class]), Type (tyco, tparams')) fun mk_field (field, typ) = let val param = Axclass.param_of_inst thy (field, tyco) (* check: did we already define all required fields? *) (* if not: abort (else we would run into an infinite loop) *) val _ = case Symtab.lookup (#constants (Definitions.get (Context.Proof lthy))) param of NONE => (* necessary for zero_nat *) if Code.is_constr thy param then () else error ("cyclic dependency: " ^ param ^ " not yet defined in the definition of " ^ tyco ^ " :: " ^ class) | SOME _ => () in term dict_context consts (Const (param, typ_subst_atomic [typ_inst] typ)) end val (fields, lthy) = fold_map mk_field params lthy val rhs = list_comb (make (Type (tyco, tparams')), super_fields @ fields) val typ = map fastype_of dict_params ---> fastype_of rhs val head = Free (name, typ) val lhs = list_comb (head, dict_params) val term = Logic.mk_equals (lhs, rhs) val (def, (lthy', lthy)) = lthy |> tap print_info |> (snd o Local_Theory.begin_nested) |> define_params_nosyn term ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' val def = Morphism.thm phi def val base_thms = Definitions.get (Context.Proof lthy') |> #constants |> Symtab.dest |> map (apsnd fst o snd) |> map_filter snd val target = (flat_right tparams, (Morphism.term phi head, tyco, class)) val args = {base_thms = base_thms, def_thm = def} val thm = prove_dict_cert target args lthy' val const = Const (Local_Theory.full_name lthy' (Binding.name name), typ) in (const, add_instantiation (class, tyco) const thm lthy') end and obtain_dict dict_context consts = let val dict_context' = Symreltab.dest dict_context fun for_class (Type (tyco, args)) class lthy = let val inst_param_sorts = param_sorts tyco class (Proof_Context.theory_of lthy) val (raw_inst, lthy') = instance consts tyco class lthy val (const_name, _) = dest_Const raw_inst val (inst_args, lthy'') = fold_map for_sort (inst_param_sorts ~~ args) lthy' val head = Sign.mk_const (Proof_Context.theory_of lthy'') (const_name, args) in (list_comb (head, flat inst_args), lthy'') end | for_class (TFree (name, _)) class lthy = let val available = map_filter (fn ((tp, class), term) => if tp = name then SOME (class, term) else NONE) dict_context' val (path, lthy') = mk_path available (TFree (name, @{sort type})) class lthy in case path of SOME term => (term, lthy') | NONE => error "no path found" end | for_class (TVar _) _ _ = error "unexpected type variable" and for_sort (sort, typ) = fold_map (for_class typ) sort in for_class end and term dict_context consts term lthy = let fun traverse (t as Const (name, typ)) lthy = (case Symtab.lookup consts name of NONE => error ("unknown constant " ^ name) | SOME (_, Constructor) => (typify t, lthy) | SOME (_, Classparam {class, typ = typ', selector}) => let val subst = Sign.typ_match (Proof_Context.theory_of lthy) (typ', typ) Vartab.empty val (_, targ) = the (Vartab.lookup subst ("'a", 0)) val (dict, lthy') = obtain_dict dict_context consts targ class lthy in (subst_TVars [(("'a", 0), targ)] selector $ dict, lthy') end | SOME (name', Fun {dicts = dicts, typ = typ', new_typ, ...}) => let val subst = Type.raw_match (Logic.varifyT_global typ', typ) Vartab.empty |> Vartab.dest |> map (apsnd snd) fun lookup tparam = the (AList.lookup (op =) subst (tparam, 0)) val (dicts, lthy') = fold_map (uncurry (obtain_dict dict_context consts o lookup)) (map fst dicts) lthy val typ = typ_subst_TVars subst (Logic.varifyT_global new_typ) val head = case Symtab.lookup (#constants (Definitions.get (Context.Proof lthy))) name of NONE => Free (name', typ) | SOME (n, _) => Const (n, typ) val res = list_comb (head, dicts) in (res, lthy') end) | traverse (f $ x) lthy = let val (f', lthy') = traverse f lthy val (x', lthy'') = traverse x lthy' in (f' $ x', lthy'') end | traverse (Abs (name, typ, term)) lthy = let val (term', lthy') = traverse term lthy in (Abs (name, typify_typ typ, term'), lthy') end | traverse (Free (name, typ)) lthy = (Free (name, typify_typ typ), lthy) | traverse (Var (name, typ)) lthy = (Var (name, typify_typ typ), lthy) | traverse (Bound n) lthy = (Bound n, lthy) in traverse term lthy end (** group of constants **) fun new_names lthy consts = let val (all_names, all_consts) = split_list (flat consts) val all_frees = map (fn Fun {eqs, ...} => eqs | _ => []) all_consts |> flat |> map #params |> flat |> map all_frees' |> flat val context = fold Name.declare (all_names @ all_frees) (Variable.names_of lthy) fun new_name (name, const) context = let val (name', context') = Name.variant (mangle name) context in ((name, (name', const)), context') end in fst (fold_map (fold_map new_name) consts context) end fun consts consts proof group lthy = let val fun_config = Function_Common.FunctionConfig {sequential=true, default=NONE, domintros=false, partials=false} fun pat_completeness_auto ctxt = Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt val all_names = map fst group val pretty_consts = map (pretty_const lthy) all_names |> Pretty.commas fun print_info msg = Pretty.str (msg ^ " ") :: pretty_consts |> Pretty.block |> Pretty.writeln val _ = print_info "Redefining constant(s)" fun process_eqs (name, Fun {dicts, param_typs, new_typ, eqs, info, cong, ...}) lthy = let val new_name = case Symtab.lookup consts name of NONE => error ("no new name for " ^ name) | SOME (n, _) => n val all_frees = map #params eqs |> flat |> map all_frees' |> flat val context = Name.make_context (all_names @ all_frees) val (dict_params, context') = dict_params context dicts fun adapt_params param_typs params = let val real_params = dict_params @ params val ext_params = drop (length params) param_typs |> map typify_typ |> Name.invent_names context' "e0" |> map Free in (real_params, ext_params) end fun mk_eq {params, rhs, thm} lthy = let val (real_params, ext_params) = adapt_params param_typs params val lhs' = list_comb (Free (new_name, new_typ), real_params @ ext_params) val (rhs', lthy') = term (Symreltab.make (map fst dicts ~~ dict_params)) consts rhs lthy val rhs'' = list_comb (rhs', ext_params) in ((HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs', rhs'')), thm), lthy') end val is_fun = length param_typs + length dicts > 0 in fold_map mk_eq eqs lthy |>> rpair (new_typ, is_fun) |>> SOME |>> pair ((name, new_name, map fst dicts), {info = info, cong = cong}) end | process_eqs (name, _) lthy = ((((name, name, []), {info = NONE, cong = NONE}), NONE), lthy) val (items, lthy') = fold_map process_eqs group lthy val ((metas, infos), ((eqs, code_thms), (new_typs, is_funs))) = items |> map_filter (fn (meta, eqs) => Option.map (pair meta) eqs) |> split_list ||> split_list ||> apfst (flat #> split_list #>> map typify) ||> apsnd split_list |>> split_list val _ = if_debug lthy (fn () => if null code_thms then () else map (Syntax.pretty_term lthy o Thm.prop_of) code_thms |> Pretty.big_list "Equations:" |> Pretty.string_of |> tracing) val is_fun = case distinct (op =) is_funs of [b] => b | [] => false | _ => error "unsupported feature: mixed non-function and function definitions" fun mk_binding (_, new_name, _) typ = (Binding.name new_name, SOME typ, NoSyn) val bindings = map2 mk_binding metas new_typs val {constants, instantiations} = Definitions.get (Context.Proof lthy') val base_thms = Symtab.dest constants |> map (apsnd fst o snd) |> map_filter snd val base_certs = Symreltab.dest instantiations |> map (snd o snd) val consts = Sign.consts_of (Proof_Context.theory_of lthy') fun prove_eq_fun (info as {simps = SOME simps, fs, inducts = SOME inducts, ...}) lthy = let fun mk_target (name, _, classes) new = (classes, (new, Const (Consts.the_const consts name))) val targets = map2 mk_target metas fs val args = {fun_info = SOME info, inducts = SOME inducts, simps = simps, base_thms = base_thms, base_certs = base_certs, code_thms = code_thms, congs = NONE} in (prove_fun_cert targets args proof lthy, args) end fun prove_eq_def defs lthy = let fun mk_target (name, _, classes) new = (classes, (new, Const (Consts.the_const consts name))) val targets = map2 mk_target metas (map (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) defs) val args = {fun_info = NONE, inducts = NONE, simps = defs, base_thms = base_thms, base_certs = base_certs, code_thms = code_thms, congs = NONE} in (prove_fun_cert targets args proof lthy, args) end fun add_constants ((((name, name', _), _), SOME _) :: xs) ((thm :: thms), info) = add_constant name name' (SOME thm, info) #> add_constants xs (thms, info) | add_constants ((((name, name', _), _), NONE) :: xs) (thms, info) = add_constant name name' (NONE, info) #> add_constants xs (thms, info) | add_constants [] _ = I fun prove_termination new_info ctxt = let val termination_ctxt = ctxt addsimps (@{thms equal} @ base_thms) addloop ("overload", CONVERSION o changed_conv o Axclass.overload_conv) val fallback_tac = Function_Common.termination_prover_tac true termination_ctxt val tac = case try hd (cat_options (map #info infos)) of SOME old_info => HEADGOAL (Transfer_Termination.termination_tac new_info old_info ctxt) | NONE => no_tac in Function.prove_termination NONE (tac ORELSE fallback_tac) ctxt end fun prove_cong data lthy = let fun rewr_cong thm cong = if Thm.nprems_of thm > 0 then (warning "No fundef_cong rule can be derived; this will likely not work later"; NONE) else (print_info "Porting fundef_cong rule for "; SOME (Local_Defs.fold lthy [thm] cong)) val congs' = map2 (Option.mapPartial o rewr_cong) (fst data) (map #cong infos) |> cat_options fun add_congs phi = fold Function_Context_Tree.add_function_cong (map (Morphism.thm phi) congs') val data' = apsnd (map_const_info I I I I I I (K (SOME congs'))) data in - (data', Local_Theory.declaration {pervasive = false, syntax = false} add_congs lthy) + (data', Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} add_congs lthy) end fun mk_fun lthy = let val specs = map (fn eq => (((Binding.empty, []), eq), [], [])) eqs val (info, lthy') = Function.add_function bindings specs fun_config pat_completeness_auto lthy |-> prove_termination val simps = the (#simps info) val (_, lthy'') = (* [simp del] is required because otherwise non-matching function definitions (e.g. divmod_nat) make the simplifier loop separate step because otherwise we'll get tons of warnings because the psimp rules are not added to the simpset *) Local_Theory.note ((Binding.empty, @{attributes [simp del]}), simps) lthy' fun prove_eq phi = prove_eq_fun (Function_Common.transform_function_data phi info) in (((simps, #inducts info), prove_eq), lthy'') end fun mk_def lthy = let val (defs, lthy') = fold_map define_params_nosyn eqs lthy fun prove_eq phi = prove_eq_def (map (Morphism.thm phi) defs) in (((defs, NONE), prove_eq), lthy') end in if null eqs then lthy' else let (* the redefinition itself doesn't have a sort constraint, but the equality prop may have one; hence the proof needs to happen after exiting the local theory target conceptually, everything happening locally would be great, but the type checker won't allow us to add sort constraints to TFrees after they have been declared *) val ((side, prove_eq), (lthy', lthy)) = lthy' |> (snd o Local_Theory.begin_nested) |> (if is_fun then mk_fun else mk_def) |-> (fn ((simps, inducts), prove_eq) => apfst (rpair prove_eq) o Side_Conditions.mk_side simps inducts) ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' in lthy' |> `(prove_eq phi) |>> apfst (on_thms_complete (fn () => print_info "Proved equivalence for")) |-> prove_cong |-> add_constants items end end fun const_raw (binding, raw_consts) proof lthy = let val _ = if proof = Skip then warning "Skipping certificate proofs" else () val (name, _) = Syntax.read_terms lthy raw_consts |> map dest_Const |> split_list val (eqs, lthy) = annotate_code_eqs lthy name val tab = symtab_of_sccs (new_names lthy eqs) val lthy = fold (consts tab proof) eqs lthy val {instantiations, constants} = Definitions.get (Context.Proof lthy) val thms = map (snd o snd) (Symreltab.dest instantiations) @ map_filter (fst o snd o snd) (Symtab.dest constants) in snd (Local_Theory.note (binding, thms) lthy) end (** setup **) val parse_flags = Scan.optional (Args.parens (Parse.reserved "skip" >> K Skip)) Cert val _ = Outer_Syntax.local_theory @{command_keyword "declassify"} "redefines a constant after applying the dictionary construction" (parse_flags -- Parse_Spec.opt_thm_name ":" -- Scan.repeat1 Parse.const >> (fn ((flags, def_binding), consts) => const_raw (def_binding, consts) flags)) end \ No newline at end of file diff --git a/thys/Dict_Construction/side_conditions.ML b/thys/Dict_Construction/side_conditions.ML --- a/thys/Dict_Construction/side_conditions.ML +++ b/thys/Dict_Construction/side_conditions.ML @@ -1,239 +1,239 @@ signature SIDE_CONDITIONS = sig type predicate = {f: term, index: int, inductive: Inductive.result, alt: thm option} val transform_predicate: morphism -> predicate -> predicate val get_predicate: Proof.context -> term -> predicate option val set_alt: term -> thm -> Context.generic -> Context.generic val is_total: Proof.context -> term -> bool val mk_side: thm list -> thm list option -> local_theory -> predicate list * local_theory val time_limit: real Config.T end structure Side_Conditions : SIDE_CONDITIONS = struct open Dict_Construction_Util val time_limit = Attrib.setup_config_real @{binding side_conditions_time_limit} (K 5.0) val inductive_config = {quiet_mode = true, verbose = true, alt_name = Binding.empty, coind = false, no_elim = false, no_ind = false, skip_mono = false} type predicate = {f: term, index: int, inductive: Inductive.result, alt: thm option} fun transform_predicate phi {f, index, inductive, alt} = {f = Morphism.term phi f, index = index, inductive = Inductive.transform_result phi inductive, alt = Option.map (Morphism.thm phi) alt} structure Predicates = Generic_Data ( type T = predicate Item_Net.T val empty = Item_Net.init (op aconv o apply2 #f) (single o #f) val merge = Item_Net.merge ) fun get_predicate ctxt t = Item_Net.retrieve (Predicates.get (Context.Proof ctxt)) t |> try hd |> Option.map (transform_predicate (Morphism.transfer_morphism (Proof_Context.theory_of ctxt))) fun is_total ctxt t = let val SOME {alt = SOME alt, ...} = get_predicate ctxt t val (_, rhs) = Logic.dest_equals (Thm.prop_of alt) in rhs = @{term True} end (* must be of the form [f_side ?x ?y = True] *) fun set_alt t thm context = let val thm = safe_mk_meta_eq thm val (lhs, _) = Logic.dest_equals (Thm.prop_of thm) val {f, index, inductive, ...} = hd (Item_Net.retrieve (Predicates.get context) t) val pred = nth (#preds inductive) index val (arg_typs, _) = strip_type (fastype_of pred) val args = Name.invent_names (Variable.names_of (Context.proof_of context)) "x" arg_typs |> map Free val new_pred = {f = f, index = index, inductive = inductive, alt = SOME thm} in if Pattern.matches (Context.theory_of context) (lhs, list_comb (pred, args)) then Predicates.map (Item_Net.update new_pred) context else error "Alternative is not fully general" end fun apply_simps ctxt clear thms t = let val ctxt' = Context_Position.not_really ctxt |> clear ? put_simpset HOL_ss in conv_result (Simplifier.asm_full_rewrite (ctxt' addsimps thms)) t end fun apply_alts ctxt = Item_Net.content (Predicates.get (Context.Proof ctxt)) |> map #alt |> cat_options |> apply_simps ctxt true fun apply_intros ctxt = Item_Net.content (Predicates.get (Context.Proof ctxt)) |> map #inductive |> maps #intrs |> apply_simps ctxt false fun dest_head (Free (name, typ)) = (name, typ) | dest_head (Const (name, typ)) = (Long_Name.base_name name, typ) val sideN = "_side" fun mk_side simps inducts lthy = let val thy = Proof_Context.theory_of lthy val ((_, simps), names) = Variable.import true simps lthy ||> Variable.names_of val (lhss, rhss) = map (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) simps |> split_list val heads = map (`dest_head o (fst o strip_comb)) lhss fun mk_typ t = binder_types t ---> @{typ bool} val sides = map (apfst (suffix sideN) o apsnd mk_typ o fst) heads fun mk_pred_app pred (f, xs) = let val pred_typs = binder_types (fastype_of pred) val exp_param_count = length pred_typs val f_typs = take exp_param_count (binder_types (fastype_of f)) val pred' = Envir.subst_term_types (fold (Sign.typ_match thy) (pred_typs ~~ f_typs) Vartab.empty) pred val diff = exp_param_count - length xs in if diff > 0 then let val bounds = map Bound (0 upto diff - 1) val alls = map (K ("x", dummyT)) (0 upto diff - 1) val prop = Logic.list_all (alls, HOLogic.mk_Trueprop (list_comb (pred', xs @ bounds))) in prop (* fishy *) end else HOLogic.mk_Trueprop (list_comb (pred', take exp_param_count xs)) end fun mk_cond f xs = if is_Abs f then (* do not look this up in the Item_Net, it'll only end in tears *) NONE else case get_predicate lthy f of NONE => (case find_index (equal f o snd) heads of ~1 => NONE (* in this case we don't know anything about f; it may be a constructor *) | index => SOME (mk_pred_app (Free (nth sides index)) (f, xs))) | SOME {index, inductive = {preds, ...}, ...} => SOME (mk_pred_app (nth preds index) (f, xs)) fun mk_atom f = (* in this branch, if f has a non-const-true predicate, it is most likely that there is a missing congruence rule *) the_list (mk_cond f []) fun mk_cong t _ cs = let val cs' = maps (fn (ctx, ts) => map (Congruences.export_term_ctx ctx) ts) (tl cs) val (f, xs) = strip_comb t val cs = mk_cond f xs in the_list cs @ cs' end val rules = map (Congruences.import_rule lthy) (Function.get_congs lthy) val premss = map (Congruences.import_term lthy rules) rhss |> map (Congruences.fold_tree mk_atom mk_cong) val concls = map Free sides ~~ map (snd o strip_comb) lhss |> map (HOLogic.mk_Trueprop o list_comb) val time = Time.fromReal (Config.get lthy time_limit) val intros = map Logic.list_implies (premss ~~ concls) |> Syntax.check_terms lthy |> map (apply_alts lthy o Thm.cterm_of lthy) |> Par_List.map (with_timeout time (apply_intros lthy o Thm.cterm_of lthy)) val inds = map (rpair NoSyn o apfst Binding.name) (distinct op = sides) val (result, lthy') = Inductive.add_inductive inductive_config inds [] (map (pair (Binding.empty, [])) intros) [] lthy fun mk_impartial_goal pred names = let val param_typs = binder_types (fastype_of pred) val (args, names) = fold_map (fn typ => apfst (Free o rpair typ) o Name.variant "x") param_typs names val goal = HOLogic.mk_Trueprop (list_comb (pred, args)) in ((goal, args), names) end val ((props, instss), _) = fold_map mk_impartial_goal (#preds result) names |>> split_list val frees = flat instss |> map (fst o dest_Free) fun tactic {context = ctxt, ...} = let val simp_context = put_simpset HOL_ss (Context_Position.not_really ctxt) addsimps (#intrs result) in maybe_induct_tac inducts instss [] ctxt THEN PARALLEL_ALLGOALS (Nitpick_Util.DETERM_TIMEOUT time o asm_full_simp_tac simp_context) end val alts = try (Goal.prove_common lthy' NONE frees [] props) tactic |> Option.map (map (mk_eq o Thm.close_derivation \<^here>)) val _ = if is_none alts then Pretty.str "Potentially underspecified function(s): " :: Pretty.commas (map (Syntax.pretty_term lthy o snd) (distinct op = heads)) |> Pretty.block |> Pretty.string_of |> warning else () fun mk_pred n t = {f = t, index = n, inductive = result, alt = Option.map (fn alts => nth alts n) alts} val preds = map_index (fn (n, (_, t)) => mk_pred n t) (distinct op = heads) val lthy'' = - Local_Theory.declaration {pervasive = false, syntax = false} + Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} (fn phi => fold (Predicates.map o Item_Net.update o transform_predicate phi) preds) lthy' in (preds, lthy'') end end \ No newline at end of file diff --git a/thys/First_Order_Terms/Term.thy b/thys/First_Order_Terms/Term.thy --- a/thys/First_Order_Terms/Term.thy +++ b/thys/First_Order_Terms/Term.thy @@ -1,659 +1,659 @@ (* Author: Christian Sternagel Author: René Thiemann License: LGPL *) section \First-Order Terms\ theory Term imports Main begin datatype (funs_term : 'f, vars_term : 'v) "term" = is_Var: Var (the_Var: 'v) | Fun 'f (args : "('f, 'v) term list") where "args (Var _) = []" abbreviation "is_Fun t \ \ is_Var t" lemma is_VarE [elim]: "is_Var t \ (\x. t = Var x \ P) \ P" by (cases t) auto lemma is_FunE [elim]: "is_Fun t \ (\f ts. t = Fun f ts \ P) \ P" by (cases t) auto lemma inj_on_Var[simp]: \<^marker>\contributor \Martin Desharnais\\ "inj_on Var A" by (rule inj_onI) simp lemma member_image_the_Var_image_subst: \<^marker>\contributor \Martin Desharnais\\ assumes is_var_\: "\x. is_Var (\ x)" shows "x \ the_Var ` \ ` V \ Var x \ \ ` V" using is_var_\ image_iff by (metis (no_types, opaque_lifting) term.collapse(1) term.sel(1)) lemma image_the_Var_image_subst_renaming_eq: \<^marker>\contributor \Martin Desharnais\\ assumes is_var_\: "\x. is_Var (\ x)" shows "the_Var ` \ ` V = (\x \ V. vars_term (\ x))" proof (rule Set.equalityI; rule Set.subsetI) from is_var_\ show "\x. x \ the_Var ` \ ` V \ x \ (\x\V. vars_term (\ x))" using term.set_sel(3) by force next from is_var_\ show "\x. x \ (\x\V. vars_term (\ x)) \ x \ the_Var ` \ ` V" by (smt (verit, best) Term.term.simps(17) UN_iff image_eqI singletonD term.collapse(1)) qed text \Reorient equations of the form @{term "Var x = t"} and @{term "Fun f ss = t"} to facilitate simplification.\ setup \ Reorient_Proc.add (fn Const (@{const_name Var}, _) $ _ => true | _ => false) #> Reorient_Proc.add (fn Const (@{const_name Fun}, _) $ _ $ _ => true | _ => false) \ -simproc_setup reorient_Var ("Var x = t") = Reorient_Proc.proc -simproc_setup reorient_Fun ("Fun f ss = t") = Reorient_Proc.proc +simproc_setup reorient_Var ("Var x = t") = \K Reorient_Proc.proc\ +simproc_setup reorient_Fun ("Fun f ss = t") = \K Reorient_Proc.proc\ text \The \emph{root symbol} of a term is defined by:\ fun root :: "('f, 'v) term \ ('f \ nat) option" where "root (Var x) = None" | "root (Fun f ts) = Some (f, length ts)" lemma finite_vars_term [simp]: "finite (vars_term t)" by (induct t) simp_all lemma finite_Union_vars_term: "finite (\t \ set ts. vars_term t)" by auto text \A substitution is a mapping \\\ from variables to terms. We call a substitution that alters the type of variables a generalized substitution, since it does not have all properties that are expected of (standard) substitutions (e.g., there is no empty substitution).\ type_synonym ('f, 'v, 'w) gsubst = "'v \ ('f, 'w) term" type_synonym ('f, 'v) subst = "('f, 'v, 'v) gsubst" fun subst_apply_term :: "('f, 'v) term \ ('f, 'v, 'w) gsubst \ ('f, 'w) term" (infixl "\" 67) where "Var x \ \ = \ x" | "Fun f ss \ \ = Fun f (map (\t. t \ \) ss)" definition subst_compose :: "('f, 'u, 'v) gsubst \ ('f, 'v, 'w) gsubst \ ('f, 'u, 'w) gsubst" (infixl "\\<^sub>s" 75) where "\ \\<^sub>s \ = (\x. (\ x) \ \)" lemma subst_subst_compose [simp]: "t \ (\ \\<^sub>s \) = t \ \ \ \" by (induct t \ rule: subst_apply_term.induct) (simp_all add: subst_compose_def) lemma subst_compose_assoc: "\ \\<^sub>s \ \\<^sub>s \ = \ \\<^sub>s (\ \\<^sub>s \)" proof (rule ext) fix x show "(\ \\<^sub>s \ \\<^sub>s \) x = (\ \\<^sub>s (\ \\<^sub>s \)) x" proof - have "(\ \\<^sub>s \ \\<^sub>s \) x = \(x) \ \ \ \" by (simp add: subst_compose_def) also have "\ = \(x) \ (\ \\<^sub>s \)" by simp finally show ?thesis by (simp add: subst_compose_def) qed qed lemma subst_apply_term_empty [simp]: "t \ Var = t" proof (induct t) case (Fun f ts) from map_ext [rule_format, of ts _ id, OF Fun] show ?case by simp qed simp interpretation subst_monoid_mult: monoid_mult "Var" "(\\<^sub>s)" by (unfold_locales) (simp add: subst_compose_assoc, simp_all add: subst_compose_def) lemma term_subst_eq: assumes "\x. x \ vars_term t \ \ x = \ x" shows "t \ \ = t \ \" using assms by (induct t) (auto) lemma term_subst_eq_rev: "t \ \ = t \ \ \ \x \ vars_term t. \ x = \ x" by (induct t) simp_all lemma term_subst_eq_conv: "t \ \ = t \ \ \ (\x \ vars_term t. \ x = \ x)" using term_subst_eq [of t \ \] and term_subst_eq_rev [of t \ \] by auto lemma subst_term_eqI: assumes "(\t. t \ \ = t \ \)" shows "\ = \" using assms [of "Var x" for x] by (intro ext) simp definition subst_domain :: "('f, 'v) subst \ 'v set" where "subst_domain \ = {x. \ x \ Var x}" fun subst_range :: "('f, 'v) subst \ ('f, 'v) term set" where "subst_range \ = \ ` subst_domain \" text \The variables introduced by a substitution.\ definition range_vars :: "('f, 'v) subst \ 'v set" where "range_vars \ = \(vars_term ` subst_range \)" lemma mem_range_varsI: \<^marker>\contributor \Martin Desharnais\\ assumes "\ x = Var y" and "x \ y" shows "y \ range_vars \" unfolding range_vars_def UN_iff proof (rule bexI[of _ "Var y"]) show "y \ vars_term (Var y)" by simp next from assms show "Var y \ subst_range \" by (simp_all add: subst_domain_def) qed lemma subst_domain_Var [simp]: "subst_domain Var = {}" by (simp add: subst_domain_def) lemma subst_range_Var[simp]: \<^marker>\contributor \Martin Desharnais\\ "subst_range Var = {}" by simp lemma range_vars_Var[simp]: \<^marker>\contributor \Martin Desharnais\\ "range_vars Var = {}" by (simp add: range_vars_def) lemma subst_apply_term_ident: \<^marker>\contributor \Martin Desharnais\\ "vars_term t \ subst_domain \ = {} \ t \ \ = t" proof (induction t) case (Var x) thus ?case by (simp add: subst_domain_def) next case (Fun f ts) thus ?case by (auto intro: list.map_ident_strong) qed lemma vars_term_subst_apply_term: \<^marker>\contributor \Martin Desharnais\\ "vars_term (t \ \) = (\x \ vars_term t. vars_term (\ x))" by (induction t) (auto simp add: insert_Diff_if subst_domain_def) corollary vars_term_subst_apply_term_subset: \<^marker>\contributor \Martin Desharnais\\ "vars_term (t \ \) \ vars_term t - subst_domain \ \ range_vars \" unfolding vars_term_subst_apply_term proof (induction t) case (Var x) show ?case by (cases "\ x = Var x") (auto simp add: range_vars_def subst_domain_def) next case (Fun f xs) thus ?case by auto qed definition is_renaming :: "('f, 'v) subst \ bool" where "is_renaming \ \ (\x. is_Var (\ x)) \ inj_on \ (subst_domain \)" lemma inv_renaming_sound: \<^marker>\contributor \Martin Desharnais\\ assumes is_var_\: "\x. is_Var (\ x)" and "inj \" shows "\ \\<^sub>s (Var \ (inv (the_Var \ \))) = Var" proof - define \' where "\' = the_Var \ \" have \_def: "\ = Var \ \'" unfolding \'_def using is_var_\ by auto from is_var_\ \inj \\ have "inj \'" unfolding inj_def \_def comp_def by fast hence "inv \' \ \' = id" using inv_o_cancel[of \'] by simp hence "Var \ (inv \' \ \') = Var" by simp hence "\x. (Var \ (inv \' \ \')) x = Var x" by metis hence "\x. ((Var \ \') \\<^sub>s (Var \ (inv \'))) x = Var x" unfolding subst_compose_def by auto thus "\ \\<^sub>s (Var \ (inv \')) = Var" using \_def by auto qed lemma ex_inverse_of_renaming: \<^marker>\contributor \Martin Desharnais\\ assumes "\x. is_Var (\ x)" and "inj \" shows "\\. \ \\<^sub>s \ = Var" using inv_renaming_sound[OF assms] by blast lemma vars_term_subst: "vars_term (t \ \) = \(vars_term ` \ ` vars_term t)" by (induct t) simp_all lemma range_varsE [elim]: assumes "x \ range_vars \" and "\t. x \ vars_term t \ t \ subst_range \ \ P" shows "P" using assms by (auto simp: range_vars_def) lemma range_vars_subst_compose_subset: "range_vars (\ \\<^sub>s \) \ (range_vars \ - subst_domain \) \ range_vars \" (is "?L \ ?R") proof fix x assume "x \ ?L" then obtain y where "y \ subst_domain (\ \\<^sub>s \)" and "x \ vars_term ((\ \\<^sub>s \) y)" by (auto simp: range_vars_def) then show "x \ ?R" proof (cases) assume "y \ subst_domain \" and "x \ vars_term ((\ \\<^sub>s \) y)" moreover then obtain v where "v \ vars_term (\ y)" and "x \ vars_term (\ v)" by (auto simp: subst_compose_def vars_term_subst) ultimately show ?thesis by (cases "v \ subst_domain \") (auto simp: range_vars_def subst_domain_def) qed (auto simp: range_vars_def subst_compose_def subst_domain_def) qed definition "subst x t = Var (x := t)" lemma subst_simps [simp]: "subst x t x = t" "subst x (Var x) = Var" by (auto simp: subst_def) lemma subst_subst_domain [simp]: "subst_domain (subst x t) = (if t = Var x then {} else {x})" proof - { fix y have "y \ {y. subst x t y \ Var y} \ y \ (if t = Var x then {} else {x})" by (cases "x = y", auto simp: subst_def) } then show ?thesis by (simp add: subst_domain_def) qed lemma subst_subst_range [simp]: "subst_range (subst x t) = (if t = Var x then {} else {t})" by (cases "t = Var x") (auto simp: subst_domain_def subst_def) lemma subst_apply_left_idemp [simp]: assumes "\ x = t \ \" shows "s \ subst x t \ \ = s \ \" using assms by (induct s) (auto simp: subst_def) lemma subst_compose_left_idemp [simp]: assumes "\ x = t \ \" shows "subst x t \\<^sub>s \ = \" by (rule subst_term_eqI) (simp add: assms) lemma subst_ident [simp]: assumes "x \ vars_term t" shows "t \ subst x u = t" proof - have "t \ subst x u = t \ Var" by (rule term_subst_eq) (auto simp: assms subst_def) then show ?thesis by simp qed lemma subst_self_idemp [simp]: "x \ vars_term t \ subst x t \\<^sub>s subst x t = subst x t" by (metis subst_simps(1) subst_compose_left_idemp subst_ident) type_synonym ('f, 'v) terms = "('f, 'v) term set" text \Applying a substitution to every term of a given set.\ abbreviation subst_apply_set :: "('f, 'v) terms \ ('f, 'v, 'w) gsubst \ ('f, 'w) terms" (infixl "\\<^sub>s\<^sub>e\<^sub>t" 60) where "T \\<^sub>s\<^sub>e\<^sub>t \ \ (\t. t \ \) ` T" text \Composition of substitutions\ lemma subst_compose: "(\ \\<^sub>s \) x = \ x \ \" by (auto simp: subst_compose_def) lemmas subst_subst = subst_subst_compose [symmetric] lemma subst_apply_eq_Var: assumes "s \ \ = Var x" obtains y where "s = Var y" and "\ y = Var x" using assms by (induct s) auto lemma subst_domain_subst_compose: "subst_domain (\ \\<^sub>s \) = (subst_domain \ - {x. \y. \ x = Var y \ \ y = Var x}) \ (subst_domain \ - subst_domain \)" by (auto simp: subst_domain_def subst_compose_def elim: subst_apply_eq_Var) text \A substitution is idempotent iff the variables in its range are disjoint from its domain. (See also "Term Rewriting and All That" \<^cite>\\Lemma 4.5.7\ in "AllThat"\.)\ lemma subst_idemp_iff: "\ \\<^sub>s \ = \ \ subst_domain \ \ range_vars \ = {}" proof assume "\ \\<^sub>s \ = \" then have "\x. \ x \ \ = \ x \ Var" by simp (metis subst_compose_def) then have *: "\x. \y\vars_term (\ x). \ y = Var y" unfolding term_subst_eq_conv by simp { fix x y assume "\ x \ Var x" and "x \ vars_term (\ y)" with * [of y] have False by simp } then show "subst_domain \ \ range_vars \ = {}" by (auto simp: subst_domain_def range_vars_def) next assume "subst_domain \ \ range_vars \ = {}" then have *: "\x y. \ x = Var x \ \ y = Var y \ x \ vars_term (\ y)" by (auto simp: subst_domain_def range_vars_def) have "\x. \y\vars_term (\ x). \ y = Var y" proof fix x y assume "y \ vars_term (\ x)" with * [of y x] show "\ y = Var y" by auto qed then show "\ \\<^sub>s \ = \" by (simp add: subst_compose_def term_subst_eq_conv [symmetric]) qed lemma subst_compose_apply_eq_apply_lhs: \<^marker>\contributor \Martin Desharnais\\ assumes "range_vars \ \ subst_domain \ = {}" "x \ subst_domain \" shows "(\ \\<^sub>s \) x = \ x" proof (cases "\ x") case (Var y) show ?thesis proof (cases "x = y") case True with Var have \\ x = Var x\ by simp moreover from \x \ subst_domain \\ have "\ x = Var x" by (simp add: disjoint_iff subst_domain_def) ultimately show ?thesis by (simp add: subst_compose_def) next case False have "y \ range_vars \" unfolding range_vars_def UN_iff proof (rule bexI) show "y \ vars_term (Var y)" by simp next from Var False show "Var y \ subst_range \" by (simp_all add: subst_domain_def) qed hence "y \ subst_domain \" using \range_vars \ \ subst_domain \ = {}\ by (simp add: disjoint_iff) with Var show ?thesis unfolding subst_compose_def by (simp add: subst_domain_def) qed next case (Fun f ys) hence "Fun f ys \ subst_range \ \ (\y\set ys. y \ subst_range \)" using subst_domain_def by fastforce hence "\x \ vars_term (Fun f ys). x \ range_vars \" by (metis UN_I range_vars_def term.distinct(1) term.sel(4) term.set_cases(2)) hence "Fun f ys \ \ = Fun f ys \ Var" unfolding term_subst_eq_conv using \range_vars \ \ subst_domain \ = {}\ by (simp add: disjoint_iff subst_domain_def) hence "Fun f ys \ \ = Fun f ys" by simp with Fun show ?thesis by (simp add: subst_compose_def) qed lemma subst_apply_term_subst_apply_term_eq_subst_apply_term_lhs: \<^marker>\contributor \Martin Desharnais\\ assumes "range_vars \ \ subst_domain \ = {}" and "vars_term t \ subst_domain \ = {}" shows "t \ \ \ \ = t \ \" proof - from assms have "\x. x \ vars_term t \ (\ \\<^sub>s \) x = \ x" using subst_compose_apply_eq_apply_lhs by fastforce hence "t \ \ \\<^sub>s \ = t \ \" using term_subst_eq_conv[of t "\ \\<^sub>s \" \] by metis thus ?thesis by simp qed fun num_funs :: "('f, 'v) term \ nat" where "num_funs (Var x) = 0" | "num_funs (Fun f ts) = Suc (sum_list (map num_funs ts))" lemma num_funs_0: assumes "num_funs t = 0" obtains x where "t = Var x" using assms by (induct t) auto lemma num_funs_subst: "num_funs (t \ \) \ num_funs t" by (induct t) (simp_all, metis comp_apply sum_list_mono) lemma sum_list_map_num_funs_subst: assumes "sum_list (map (num_funs \ (\t. t \ \)) ts) = sum_list (map num_funs ts)" shows "\i < length ts. num_funs (ts ! i \ \) = num_funs (ts ! i)" using assms proof (induct ts) case (Cons t ts) then have "num_funs (t \ \) + sum_list (map (num_funs \ (\t. t \ \)) ts) = num_funs t + sum_list (map num_funs ts)" by (simp add: o_def) moreover have "num_funs (t \ \) \ num_funs t" by (metis num_funs_subst) moreover have "sum_list (map (num_funs \ (\t. t \ \)) ts) \ sum_list (map num_funs ts)" using num_funs_subst [of _ \] by (induct ts) (auto intro: add_mono) ultimately show ?case using Cons by (auto) (case_tac i, auto) qed simp lemma is_Fun_num_funs_less: assumes "x \ vars_term t" and "is_Fun t" shows "num_funs (\ x) < num_funs (t \ \)" using assms proof (induct t) case (Fun f ts) then obtain u where u: "u \ set ts" "x \ vars_term u" by auto then have "num_funs (u \ \) \ sum_list (map (num_funs \ (\t. t \ \)) ts)" by (intro member_le_sum_list) simp moreover have "num_funs (\ x) \ num_funs (u \ \)" using Fun.hyps [OF u] and u by (cases u; simp) ultimately show ?case by simp qed simp lemma finite_subst_domain_subst: "finite (subst_domain (subst x y))" by simp lemma subst_domain_compose: "subst_domain (\ \\<^sub>s \) \ subst_domain \ \ subst_domain \" by (auto simp: subst_domain_def subst_compose_def) lemma vars_term_disjoint_imp_unifier: fixes \ :: "('f, 'v, 'w) gsubst" assumes "vars_term s \ vars_term t = {}" and "s \ \ = t \ \" shows "\\ :: ('f, 'v, 'w) gsubst. s \ \ = t \ \" proof - let ?\ = "\x. if x \ vars_term s then \ x else \ x" have "s \ \ = s \ ?\" unfolding term_subst_eq_conv by (induct s) (simp_all) moreover have "t \ \ = t \ ?\" using assms(1) unfolding term_subst_eq_conv by (induct s arbitrary: t) (auto) ultimately have "s \ ?\ = t \ ?\" using assms(2) by simp then show ?thesis by blast qed lemma vars_term_subset_subst_eq: assumes "vars_term t \ vars_term s" and "s \ \ = s \ \" shows "t \ \ = t \ \" using assms by (induct t) (induct s, auto) subsection \Restrict the Domain of a Substitution\ definition restrict_subst_domain where \<^marker>\contributor \Martin Desharnais\\ "restrict_subst_domain V \ x \ (if x \ V then \ x else Var x)" lemma restrict_subst_domain_empty[simp]: \<^marker>\contributor \Martin Desharnais\\ "restrict_subst_domain {} \ = Var" unfolding restrict_subst_domain_def by auto lemma restrict_subst_domain_Var[simp]: \<^marker>\contributor \Martin Desharnais\\ "restrict_subst_domain V Var = Var" unfolding restrict_subst_domain_def by auto lemma subst_domain_restrict_subst_domain[simp]: \<^marker>\contributor \Martin Desharnais\\ "subst_domain (restrict_subst_domain V \) = V \ subst_domain \" unfolding restrict_subst_domain_def subst_domain_def by auto lemma subst_apply_term_restrict_subst_domain: \<^marker>\contributor \Martin Desharnais\\ "vars_term t \ V \ t \ restrict_subst_domain V \ = t \ \" by (rule term_subst_eq) (simp add: restrict_subst_domain_def subsetD) subsection \Rename the Domain of a Substitution\ definition rename_subst_domain where \<^marker>\contributor \Martin Desharnais\\ "rename_subst_domain \ \ x = (if Var x \ \ ` subst_domain \ then \ (the_inv \ (Var x)) else Var x)" lemma rename_subst_domain_Var_lhs[simp]: \<^marker>\contributor \Martin Desharnais\\ "rename_subst_domain Var \ = \" by (rule ext) (simp add: rename_subst_domain_def inj_image_mem_iff the_inv_f_f subst_domain_def) lemma rename_subst_domain_Var_rhs[simp]: \<^marker>\contributor \Martin Desharnais\\ "rename_subst_domain \ Var = Var" by (rule ext) (simp add: rename_subst_domain_def) lemma subst_domain_rename_subst_domain_subset: \<^marker>\contributor \Martin Desharnais\\ assumes is_var_\: "\x. is_Var (\ x)" shows "subst_domain (rename_subst_domain \ \) \ the_Var ` \ ` subst_domain \" by (auto simp add: subst_domain_def rename_subst_domain_def member_image_the_Var_image_subst[OF is_var_\]) lemma subst_range_rename_subst_domain_subset: \<^marker>\contributor \Martin Desharnais\\ assumes "inj \" shows "subst_range (rename_subst_domain \ \) \ subst_range \" proof (intro Set.equalityI Set.subsetI) fix t assume "t \ subst_range (rename_subst_domain \ \)" then obtain x where t_def: "t = rename_subst_domain \ \ x" and "rename_subst_domain \ \ x \ Var x" by (auto simp: image_iff subst_domain_def) show "t \ subst_range \" proof (cases \Var x \ \ ` subst_domain \\) case True then obtain x' where "\ x' = Var x" and "x' \ subst_domain \" by auto then show ?thesis using the_inv_f_f[OF \inj \\, of x'] by (simp add: t_def rename_subst_domain_def) next case False hence False using \rename_subst_domain \ \ x \ Var x\ by (simp add: t_def rename_subst_domain_def) thus ?thesis .. qed qed lemma range_vars_rename_subst_domain_subset: \<^marker>\contributor \Martin Desharnais\\ assumes "inj \" shows "range_vars (rename_subst_domain \ \) \ range_vars \" unfolding range_vars_def using subst_range_rename_subst_domain_subset[OF \inj \\] by (metis Union_mono image_mono) lemma renaming_cancels_rename_subst_domain: \<^marker>\contributor \Martin Desharnais\\ assumes is_var_\: "\x. is_Var (\ x)" and "inj \" and vars_t: "vars_term t \ subst_domain \" shows "t \ \ \ rename_subst_domain \ \ = t \ \" unfolding subst_subst proof (intro term_subst_eq ballI) fix x assume "x \ vars_term t" with vars_t have x_in: "x \ subst_domain \" by blast obtain x' where \_x: "\ x = Var x'" using is_var_\ by (meson is_Var_def) with x_in have x'_in: "Var x' \ \ ` subst_domain \" by (metis image_eqI) have "(\ \\<^sub>s rename_subst_domain \ \) x = \ x \ rename_subst_domain \ \" by (simp add: subst_compose_def) also have "\ = rename_subst_domain \ \ x'" using \_x by simp also have "\ = \ (the_inv \ (Var x'))" by (simp add: rename_subst_domain_def if_P[OF x'_in]) also have "\ = \ (the_inv \ (\ x))" by (simp add: \_x) also have "\ = \ x" using \inj \\ by (simp add: the_inv_f_f) finally show "(\ \\<^sub>s rename_subst_domain \ \) x = \ x" by simp qed subsection \Rename the Domain and Range of a Substitution\ definition rename_subst_domain_range where \<^marker>\contributor \Martin Desharnais\\ "rename_subst_domain_range \ \ x = (if Var x \ \ ` subst_domain \ then ((Var o the_inv \) \\<^sub>s \ \\<^sub>s \) (Var x) else Var x)" lemma rename_subst_domain_range_Var_lhs[simp]: \<^marker>\contributor \Martin Desharnais\\ "rename_subst_domain_range Var \ = \" by (rule ext) (simp add: rename_subst_domain_range_def inj_image_mem_iff the_inv_f_f subst_domain_def subst_compose_def) lemma rename_subst_domain_range_Var_rhs[simp]: \<^marker>\contributor \Martin Desharnais\\ "rename_subst_domain_range \ Var = Var" by (rule ext) (simp add: rename_subst_domain_range_def) lemma subst_compose_renaming_rename_subst_domain_range: \<^marker>\contributor \Martin Desharnais\\ fixes \ \ :: "('f, 'v) subst" assumes is_var_\: "\x. is_Var (\ x)" and "inj \" shows "\ \\<^sub>s rename_subst_domain_range \ \ = \ \\<^sub>s \" proof (rule ext) fix x from is_var_\ obtain x' where "\ x = Var x'" by (meson is_Var_def is_renaming_def) with \inj \\ have inv_\_x': "the_inv \ (Var x') = x" by (metis the_inv_f_f) show "(\ \\<^sub>s rename_subst_domain_range \ \) x = (\ \\<^sub>s \) x" proof (cases "x \ subst_domain \") case True hence "Var x' \ \ ` subst_domain \" using \\ x = Var x'\ by (metis imageI) thus ?thesis by (simp add: \\ x = Var x'\ rename_subst_domain_range_def subst_compose_def inv_\_x') next case False hence "Var x' \ \ ` subst_domain \" proof (rule contrapos_nn) assume "Var x' \ \ ` subst_domain \" hence "\ x \ \ ` subst_domain \" unfolding \\ x = Var x'\ . thus "x \ subst_domain \" unfolding inj_image_mem_iff[OF \inj \\] . qed with False \\ x = Var x'\ show ?thesis by (simp add: subst_compose_def subst_domain_def rename_subst_domain_range_def) qed qed corollary subst_apply_term_renaming_rename_subst_domain_range: \<^marker>\contributor \Martin Desharnais\\ \ \This might be easier to find with @{command find_theorems}.\ fixes t :: "('f, 'v) term" and \ \ :: "('f, 'v) subst" assumes is_var_\: "\x. is_Var (\ x)" and "inj \" shows "t \ \ \ rename_subst_domain_range \ \ = t \ \ \ \" unfolding subst_subst unfolding subst_compose_renaming_rename_subst_domain_range[OF assms] by (rule refl) end diff --git a/thys/HOLCF-Prelude/Data_Integer.thy b/thys/HOLCF-Prelude/Data_Integer.thy --- a/thys/HOLCF-Prelude/Data_Integer.thy +++ b/thys/HOLCF-Prelude/Data_Integer.thy @@ -1,341 +1,343 @@ section \Data: Integers\ theory Data_Integer imports Numeral_Cpo Data_Bool begin domain Integer = MkI (lazy int) instance Integer :: flat proof fix x y :: Integer assume "x \ y" then show "x = \ \ x = y" by (cases x; cases y) simp_all qed instantiation Integer :: "{plus,times,minus,uminus,zero,one}" begin definition "0 = MkI\0" definition "1 = MkI\1" definition "a + b = (\ (MkI\x) (MkI\y). MkI\(x + y))\a\b" definition "a - b = (\ (MkI\x) (MkI\y). MkI\(x - y))\a\b" definition "a * b = (\ (MkI\x) (MkI\y). MkI\(x * y))\a\b" definition "- a = (\ (MkI\x). MkI\(uminus x))\a" instance .. end lemma Integer_arith_strict [simp]: fixes x :: Integer shows "\ + x = \" and "x + \ = \" and "\ * x = \" and "x * \ = \" and "\ - x = \" and "x - \ = \" and "- \ = (\::Integer)" unfolding plus_Integer_def times_Integer_def unfolding minus_Integer_def uminus_Integer_def by (cases x, simp, simp)+ lemma Integer_arith_simps [simp]: "MkI\a + MkI\b = MkI\(a + b)" "MkI\a * MkI\b = MkI\(a * b)" "MkI\a - MkI\b = MkI\(a - b)" "- MkI\a = MkI\(uminus a)" unfolding plus_Integer_def times_Integer_def unfolding minus_Integer_def uminus_Integer_def by simp_all lemma plus_MkI_MkI: "MkI\x + MkI\y = MkI\(x + y)" unfolding plus_Integer_def by simp instance Integer :: "{plus_cpo,minus_cpo,times_cpo}" by standard (simp_all add: flatdom_strict2cont) instance Integer :: comm_monoid_add proof fix a b c :: Integer show "(a + b) + c = a + (b + c)" by (cases a; cases b; cases c) simp_all show "a + b = b + a" by (cases a; cases b) simp_all show "0 + a = a" unfolding zero_Integer_def by (cases a) simp_all qed instance Integer :: comm_monoid_mult proof fix a b c :: Integer show "(a * b) * c = a * (b * c)" by (cases a; cases b; cases c) simp_all show "a * b = b * a" by (cases a; cases b) simp_all show "1 * a = a" unfolding one_Integer_def by (cases a) simp_all qed instance Integer :: comm_semiring proof fix a b c :: Integer show "(a + b) * c = a * c + b * c" by (cases a; cases b; cases c) (simp_all add: distrib_right) qed instance Integer :: semiring_numeral .. lemma Integer_add_diff_cancel [simp]: "b \ \ \ (a::Integer) + b - b = a" by (cases a; cases b) simp_all lemma zero_Integer_neq_bottom [simp]: "(0::Integer) \ \" by (simp add: zero_Integer_def) lemma one_Integer_neq_bottom [simp]: "(1::Integer) \ \" by (simp add: one_Integer_def) lemma plus_Integer_eq_bottom_iff [simp]: fixes x y :: Integer shows "x + y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma diff_Integer_eq_bottom_iff [simp]: fixes x y :: Integer shows "x - y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma mult_Integer_eq_bottom_iff [simp]: fixes x y :: Integer shows "x * y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma minus_Integer_eq_bottom_iff [simp]: fixes x :: Integer shows "- x = \ \ x = \" by (cases x, simp, simp) lemma numeral_Integer_eq: "numeral k = MkI\(numeral k)" by (induct k, simp_all only: numeral.simps one_Integer_def plus_MkI_MkI) lemma numeral_Integer_neq_bottom [simp]: "(numeral k::Integer) \ \" unfolding numeral_Integer_eq by simp text \Symmetric versions are also needed, because the reorient simproc does not apply to these comparisons.\ lemma bottom_neq_zero_Integer [simp]: "(\::Integer) \ 0" by (simp add: zero_Integer_def) lemma bottom_neq_one_Integer [simp]: "(\::Integer) \ 1" by (simp add: one_Integer_def) lemma bottom_neq_numeral_Integer [simp]: "(\::Integer) \ numeral k" unfolding numeral_Integer_eq by simp instantiation Integer :: Ord_linear begin definition "eq = (\ (MkI\x) (MkI\y). if x = y then TT else FF)" definition "compare = (\ (MkI\x) (MkI\y). if x < y then LT else if x > y then GT else EQ)" instance proof fix x y z :: Integer show "compare\\\y = \" unfolding compare_Integer_def by simp show "compare\x\\ = \" unfolding compare_Integer_def by (cases x, simp_all) show "oppOrdering\(compare\x\y) = compare\y\x" unfolding compare_Integer_def by (cases x, cases y, simp, simp, cases y, simp, simp add: not_less less_imp_le) - { assume "compare\x\y = EQ" then show "x = y" - unfolding compare_Integer_def - by (cases x, cases y, simp, simp, - cases y, simp, simp split: if_splits) } - { assume "compare\x\y = LT" and "compare\y\z = LT" then show "compare\x\z = LT" - unfolding compare_Integer_def - by (cases x, simp, cases y, simp, cases z, simp, - auto split: if_splits) } + show "x = y" if "compare\x\y = EQ" + using that + unfolding compare_Integer_def + by (cases x, cases y, simp, simp, + cases y, simp, simp split: if_splits) + show "compare\x\z = LT" if "compare\x\y = LT" and "compare\y\z = LT" + using that + unfolding compare_Integer_def + by (cases x, simp, cases y, simp, cases z, simp, + auto split: if_splits) show "eq\x\y = is_EQ\(compare\x\y)" unfolding eq_Integer_def compare_Integer_def by (cases x, simp, cases y, simp, auto) show "compare\x\x \ EQ" unfolding compare_Integer_def by (cases x, simp_all) qed end lemma eq_MkI_MkI [simp]: "eq\(MkI\m)\(MkI\n) = (if m = n then TT else FF)" by (simp add: eq_Integer_def) lemma compare_MkI_MkI [simp]: "compare\(MkI\x)\(MkI\y) = (if x < y then LT else if x > y then GT else EQ)" unfolding compare_Integer_def by simp lemma lt_MkI_MkI [simp]: "lt\(MkI\x)\(MkI\y) = (if x < y then TT else FF)" unfolding lt_def by simp lemma le_MkI_MkI [simp]: "le\(MkI\x)\(MkI\y) = (if x \ y then TT else FF)" unfolding le_def by simp lemma eq_Integer_bottom_iff [simp]: fixes x y :: Integer shows "eq\x\y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma compare_Integer_bottom_iff [simp]: fixes x y :: Integer shows "compare\x\y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma lt_Integer_bottom_iff [simp]: fixes x y :: Integer shows "lt\x\y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma le_Integer_bottom_iff [simp]: fixes x y :: Integer shows "le\x\y = \ \ x = \ \ y = \" by (cases x, simp, cases y, simp, simp) lemma compare_refl_Integer [simp]: "(x::Integer) \ \ \ compare\x\x = EQ" by (cases x) simp_all lemma eq_refl_Integer [simp]: "(x::Integer) \ \ \ eq\x\x = TT" by (cases x) simp_all lemma lt_refl_Integer [simp]: "(x::Integer) \ \ \ lt\x\x = FF" by (cases x) simp_all lemma le_refl_Integer [simp]: "(x::Integer) \ \ \ le\x\x = TT" by (cases x) simp_all lemma eq_Integer_numeral_simps [simp]: "eq\(0::Integer)\0 = TT" "eq\(0::Integer)\1 = FF" "eq\(1::Integer)\0 = FF" "eq\(1::Integer)\1 = TT" "eq\(0::Integer)\(numeral k) = FF" "eq\(numeral k)\(0::Integer) = FF" "k \ Num.One \ eq\(1::Integer)\(numeral k) = FF" "k \ Num.One \ eq\(numeral k)\(1::Integer) = FF" "eq\(numeral k::Integer)\(numeral l) = (if k = l then TT else FF)" unfolding zero_Integer_def one_Integer_def numeral_Integer_eq by simp_all lemma compare_Integer_numeral_simps [simp]: "compare\(0::Integer)\0 = EQ" "compare\(0::Integer)\1 = LT" "compare\(1::Integer)\0 = GT" "compare\(1::Integer)\1 = EQ" "compare\(0::Integer)\(numeral k) = LT" "compare\(numeral k)\(0::Integer) = GT" "Num.One < k \ compare\(1::Integer)\(numeral k) = LT" "Num.One < k \ compare\(numeral k)\(1::Integer) = GT" "compare\(numeral k::Integer)\(numeral l) = (if k < l then LT else if k > l then GT else EQ)" unfolding zero_Integer_def one_Integer_def numeral_Integer_eq by simp_all lemma lt_Integer_numeral_simps [simp]: "lt\(0::Integer)\0 = FF" "lt\(0::Integer)\1 = TT" "lt\(1::Integer)\0 = FF" "lt\(1::Integer)\1 = FF" "lt\(0::Integer)\(numeral k) = TT" "lt\(numeral k)\(0::Integer) = FF" "Num.One < k \ lt\(1::Integer)\(numeral k) = TT" "lt\(numeral k)\(1::Integer) = FF" "lt\(numeral k::Integer)\(numeral l) = (if k < l then TT else FF)" unfolding zero_Integer_def one_Integer_def numeral_Integer_eq by simp_all lemma le_Integer_numeral_simps [simp]: "le\(0::Integer)\0 = TT" "le\(0::Integer)\1 = TT" "le\(1::Integer)\0 = FF" "le\(1::Integer)\1 = TT" "le\(0::Integer)\(numeral k) = TT" "le\(numeral k)\(0::Integer) = FF" "le\(1::Integer)\(numeral k) = TT" "Num.One < k \ le\(numeral k)\(1::Integer) = FF" "le\(numeral k::Integer)\(numeral l) = (if k \ l then TT else FF)" unfolding zero_Integer_def one_Integer_def numeral_Integer_eq by simp_all lemma MkI_eq_0_iff [simp]: "MkI\n = 0 \ n = 0" unfolding zero_Integer_def by simp lemma MkI_eq_1_iff [simp]: "MkI\n = 1 \ n = 1" unfolding one_Integer_def by simp lemma MkI_eq_numeral_iff [simp]: "MkI\n = numeral k \ n = numeral k" unfolding numeral_Integer_eq by simp lemma MkI_0: "MkI\0 = 0" by simp lemma MkI_1: "MkI\1 = 1" by simp lemma le_plus_1: fixes m :: "Integer" assumes "le\m\n = TT" shows "le\m\(n + 1) = TT" proof - from assms have "n \ \" by auto then have "le\n\(n + 1) = TT" by (cases n) (auto, metis le_MkI_MkI less_add_one less_le_not_le one_Integer_def plus_MkI_MkI) with assms show ?thesis by (auto dest: le_trans) qed subsection \Induction rules that do not break the abstraction\ lemma nonneg_Integer_induct [consumes 1, case_names 0 step]: fixes i :: Integer assumes i_nonneg: "le\0\i = TT" and zero: "P 0" and step: "\i. le\1\i = TT \ P (i - 1) \ P i" shows "P i" proof (cases i) case bottom then have False using i_nonneg by simp then show ?thesis .. next case (MkI integer) show ?thesis proof (cases integer) case neg then have False using i_nonneg MkI by (auto simp add: zero_Integer_def one_Integer_def) then show ?thesis .. next case (nonneg nat) have "P (MkI\(int nat))" proof(induct nat) case 0 show ?case using zero by (simp add: zero_Integer_def) next case (Suc nat) have "le\1\(MkI\(int (Suc nat))) = TT" by (simp add: one_Integer_def) moreover have "P (MkI\(int (Suc nat)) - 1)" using Suc by (simp add: one_Integer_def) ultimately show ?case by (rule step) qed then show ?thesis using nonneg MkI by simp qed qed end diff --git a/thys/HOLCF-Prelude/Data_List.thy b/thys/HOLCF-Prelude/Data_List.thy --- a/thys/HOLCF-Prelude/Data_List.thy +++ b/thys/HOLCF-Prelude/Data_List.thy @@ -1,1625 +1,1621 @@ section \Data: List\ theory Data_List imports Type_Classes Data_Function Data_Bool Data_Tuple Data_Integer Numeral_Cpo begin no_notation (ASCII) Set.member ("'(:')") and Set.member ("(_/ : _)" [51, 51] 50) subsection \Datatype definition\ domain 'a list ("[_]") = Nil ("[]") | Cons (lazy head :: 'a) (lazy tail :: "['a]") (infixr ":" 65) (*FIXME: We need to standardize a mapping from Haskell fixities (0 to 9) to Isabelle ones (between 50 and 100).*) subsubsection \Section syntax for @{const Cons}\ syntax "_Cons_section" :: "'a \ ['a] \ ['a]" ("'(:')") "_Cons_section_left" :: "'a \ ['a] \ ['a]" ("'(_:')") translations "(x:)" == "(CONST Rep_cfun) (CONST Cons) x" abbreviation Cons_section_right :: "['a] \ 'a \ ['a]" ("'(:_')") where "(:xs) \ \ x. x:xs" syntax "_lazy_list" :: "args \ ['a]" ("[(_)]") translations "[x, xs]" == "x : [xs]" "[x]" == "x : []" abbreviation null :: "['a] \ tr" where "null \ is_Nil" subsection \Haskell function definitions\ instantiation list :: (Eq) Eq_strict begin fixrec eq_list :: "['a] \ ['a] \ tr" where "eq_list\[]\[] = TT" | "eq_list\(x : xs)\[] = FF" | "eq_list\[]\(y : ys) = FF" | "eq_list\(x : xs)\(y : ys) = (eq\x\y andalso eq_list\xs\ys)" instance proof fix xs :: "['a]" show "eq\xs\\ = \" by (cases xs, fixrec_simp+) show "eq\\\xs = \" by fixrec_simp qed end instance list :: (Eq_sym) Eq_sym proof fix xs ys :: "['a]" show "eq\xs\ys = eq\ys\xs" proof (induct xs arbitrary: ys) case Nil show ?case by (cases ys; simp) next case Cons then show ?case by (cases ys; simp add: eq_sym) qed simp_all qed instance list :: (Eq_equiv) Eq_equiv proof fix xs ys zs :: "['a]" show "eq\xs\xs \ FF" by (induct xs, simp_all) assume "eq\xs\ys = TT" and "eq\ys\zs = TT" then show "eq\xs\zs = TT" proof (induct xs arbitrary: ys zs) case (Nil ys zs) then show ?case by (cases ys, simp_all) next case (Cons x xs ys zs) from Cons.prems show ?case by (cases ys; cases zs) (auto intro: eq_trans Cons.hyps) qed simp_all qed instance list :: (Eq_eq) Eq_eq proof fix xs ys :: "['a]" show "eq\xs\xs \ FF" by (induct xs) simp_all assume "eq\xs\ys = TT" then show "xs = ys" proof (induct xs arbitrary: ys) case Nil then show ?case by (cases ys) auto next case Cons then show ?case by (cases ys) auto qed auto qed instantiation list :: (Ord) Ord_strict begin fixrec compare_list :: "['a] \ ['a] \ Ordering" where "compare_list\[]\[] = EQ" | "compare_list\(x : xs)\[] = GT" | "compare_list\[]\(y : ys) = LT" | "compare_list\(x : xs)\(y : ys) = thenOrdering\(compare\x\y)\(compare_list\xs\ys)" instance by standard (fixrec_simp, rename_tac x, case_tac x, fixrec_simp+) end instance list :: (Ord_linear) Ord_linear proof fix xs ys zs :: "['a]" show "oppOrdering\(compare\xs\ys) = compare\ys\xs" proof (induct xs arbitrary: ys) case Nil show ?case by (cases ys; simp) next case Cons then show ?case by (cases ys; simp add: oppOrdering_thenOrdering) qed simp_all show "xs = ys" if "compare\xs\ys = EQ" using that proof (induct xs arbitrary: ys) case Nil then show ?case by (cases ys; simp) next case Cons then show ?case by (cases ys; auto elim: compare_EQ_dest) qed simp_all show "compare\xs\zs = LT" if "compare\xs\ys = LT" and "compare\ys\zs = LT" using that proof (induct xs arbitrary: ys zs) case Nil then show ?case by (cases ys; cases zs; simp) next case (Cons a xs) then show ?case by (cases ys; cases zs) (auto dest: compare_EQ_dest compare_LT_trans) qed simp_all show "eq\xs\ys = is_EQ\(compare\xs\ys)" proof (induct xs arbitrary: ys) case Nil show ?case by (cases ys; simp) next case Cons then show ?case by (cases ys; simp add: eq_conv_compare) qed simp_all show "compare\xs\xs \ EQ" by (induct xs) simp_all qed fixrec zipWith :: "('a \ 'b \ 'c) \ ['a] \ ['b] \ ['c]" where "zipWith\f\(x : xs)\(y : ys) = f\x\y : zipWith\f\xs\ys" | "zipWith\f\(x : xs)\[] = []" | "zipWith\f\[]\ys = []" definition zip :: "['a] \ ['b] \ [\'a, 'b\]" where "zip = zipWith\\,\" fixrec zipWith3 :: "('a \ 'b \ 'c \ 'd) \ ['a] \ ['b] \ ['c] \ ['d]" where "zipWith3\f\(x : xs)\(y : ys)\(z : zs) = f\x\y\z : zipWith3\f\xs\ys\zs" | (unchecked) "zipWith3\f\xs\ys\zs = []" definition zip3 :: "['a] \ ['b] \ ['c] \ [\'a, 'b, 'c\]" where "zip3 = zipWith3\\,,\" fixrec map :: "('a \ 'b) \ ['a] \ ['b]" where "map\f\[] = []" | "map\f\(x : xs) = f\x : map\f\xs" fixrec filter :: "('a \ tr) \ ['a] \ ['a]" where "filter\P\[] = []" | "filter\P\(x : xs) = If (P\x) then x : filter\P\xs else filter\P\xs" fixrec repeat :: "'a \ ['a]" where [simp del]: "repeat\x = x : repeat\x" fixrec takeWhile :: "('a \ tr) \ ['a] \ ['a]" where "takeWhile\p\[] = []" | "takeWhile\p\(x:xs) = If p\x then x : takeWhile\p\xs else []" fixrec dropWhile :: "('a \ tr) \ ['a] \ ['a]" where "dropWhile\p\[] = []" | "dropWhile\p\(x:xs) = If p\x then dropWhile\p\xs else (x:xs)" fixrec span :: "('a -> tr) -> ['a] -> \['a],['a]\" where "span\p\[] = \[],[]\" | "span\p\(x:xs) = If p\x then (case span\p\xs of \ys, zs\ \ \x:ys,zs\) else \[], x:xs\" fixrec break :: "('a -> tr) -> ['a] -> \['a],['a]\" where "break\p = span\(neg oo p)" fixrec nth :: "['a] \ Integer \ 'a" where "nth\[]\n = \" | nth_Cons [simp del]: "nth\(x : xs)\n = If eq\n\0 then x else nth\xs\(n - 1)" (* bh: Perhaps we should rename this to 'index', to match the standard Haskell function named 'genericIndex'. *) abbreviation nth_syn :: "['a] \ Integer \ 'a" (infixl "!!" 100) where "xs !! n \ nth\xs\n" definition partition :: "('a \ tr) \ ['a] \ \['a], ['a]\" where "partition = (\ P xs. \filter\P\xs, filter\(neg oo P)\xs\)" fixrec iterate :: "('a \ 'a) \ 'a \ ['a]" where "iterate\f\x = x : iterate\f\(f\x)" fixrec foldl :: "('a -> 'b -> 'a) -> 'a -> ['b] -> 'a" where "foldl\f\z\[] = z" | "foldl\f\z\(x:xs) = foldl\f\(f\z\x)\xs" fixrec foldl1 :: "('a -> 'a -> 'a) -> ['a] -> 'a" where "foldl1\f\[] = \" | "foldl1\f\(x:xs) = foldl\f\x\xs" fixrec foldr :: "('a \ 'b \ 'b) \ 'b \ ['a] \ 'b" where "foldr\f\d\[] = d" | "foldr\f\d\(x : xs) = f\x\(foldr\f\d\xs)" fixrec foldr1 :: "('a \ 'a \ 'a) \ ['a] \ 'a" where "foldr1\f\[] = \" | "foldr1\f\[x] = x" | "foldr1\f\(x : (x':xs)) = f\x\(foldr1\f\(x':xs))" fixrec elem :: "'a::Eq \ ['a] \ tr" where "elem\x\[] = FF" | "elem\x\(y : ys) = (eq\y\x orelse elem\x\ys)" fixrec notElem :: "'a::Eq \ ['a] \ tr" where "notElem\x\[] = TT" | "notElem\x\(y : ys) = (neq\y\x andalso notElem\x\ys)" fixrec append :: "['a] \ ['a] \ ['a]" where "append\[]\ys = ys" | "append\(x : xs)\ys = x : append\xs\ys" abbreviation append_syn :: "['a] \ ['a] \ ['a]" (infixr "++" 65) where "xs ++ ys \ append\xs\ys" definition concat :: "[['a]] \ ['a]" where "concat = foldr\append\[]" definition concatMap :: "('a \ ['b]) \ ['a] \ ['b]" where "concatMap = (\ f. concat oo map\f)" fixrec last :: "['a] -> 'a" where "last\[x] = x" | "last\(_:(x:xs)) = last\(x:xs)" fixrec init :: "['a] -> ['a]" where "init\[x] = []" | "init\(x:(y:xs)) = x:(init\(y:xs))" fixrec reverse :: "['a] -> ['a]" where [simp del]:"reverse = foldl\(flip\(:))\[]" fixrec the_and :: "[tr] \ tr" where "the_and = foldr\trand\TT" fixrec the_or :: "[tr] \ tr" where "the_or = foldr\tror\FF" fixrec all :: "('a \ tr) \ ['a] \ tr" where "all\P = the_and oo (map\P)" fixrec any :: "('a \ tr) \ ['a] \ tr" where "any\P = the_or oo (map\P)" fixrec tails :: "['a] \ [['a]]" where "tails\[] = [[]]" | "tails\(x : xs) = (x : xs) : tails\xs" fixrec inits :: "['a] \ [['a]]" where "inits\[] = [[]]" | "inits\(x : xs) = [[]] ++ map\(x:)\(inits\xs)" fixrec scanr :: "('a \ 'b \ 'b) \ 'b \ ['a] \ ['b]" where "scanr\f\q0\[] = [q0]" | "scanr\f\q0\(x : xs) = ( let qs = scanr\f\q0\xs in (case qs of [] \ \ | q : qs' \ f\x\q : qs))" fixrec scanr1 :: "('a \ 'a \ 'a) \ ['a] \ ['a]" where "scanr1\f\[] = []" | "scanr1\f\(x : xs) = (case xs of [] \ [x] | x' : xs' \ ( let qs = scanr1\f\xs in (case qs of [] \ \ | q : qs' \ f\x\q : qs)))" fixrec scanl :: "('a \ 'b \ 'a) \ 'a \ ['b] \ ['a]" where "scanl\f\q\ls = q : (case ls of [] \ [] | x : xs \ scanl\f\(f\q\x)\xs)" definition scanl1 :: "('a \ 'a \ 'a) \ ['a] \ ['a]" where "scanl1 = (\ f ls. (case ls of [] \ [] | x : xs \ scanl\f\x\xs))" subsubsection \Arithmetic Sequences\ fixrec upto :: "Integer \ Integer \ [Integer]" where [simp del]: "upto\x\y = If le\x\y then x : upto\(x+1)\y else []" fixrec intsFrom :: "Integer \ [Integer]" where [simp del]: "intsFrom\x = seq\x\(x : intsFrom\(x+1))" class Enum = fixes toEnum :: "Integer \ 'a" and fromEnum :: "'a \ Integer" begin definition succ :: "'a \ 'a" where "succ = toEnum oo (+1) oo fromEnum" definition pred :: "'a \ 'a" where "pred = toEnum oo (-1) oo fromEnum" definition enumFrom :: "'a \ ['a]" where "enumFrom = (\ x. map\toEnum\(intsFrom\(fromEnum\x)))" definition enumFromTo :: "'a \ 'a \ ['a]" where "enumFromTo = (\ x y. map\toEnum\(upto\(fromEnum\x)\(fromEnum\y)))" end abbreviation enumFrom_To_syn :: "'a::Enum \ 'a \ ['a]" ("(1[_../_])") where "[m..n] \ enumFromTo\m\n" abbreviation enumFrom_syn :: "'a::Enum \ ['a]" ("(1[_..])") where "[n..] \ enumFrom\n" instantiation Integer :: Enum begin definition [simp]: "toEnum = ID" definition [simp]: "fromEnum = ID" instance .. end fixrec take :: "Integer \ ['a] \ ['a]" where [simp del]: "take\n\xs = If le\n\0 then [] else (case xs of [] \ [] | y : ys \ y : take\(n - 1)\ys)" fixrec drop :: "Integer \ ['a] \ ['a]" where [simp del]: "drop\n\xs = If le\n\0 then xs else (case xs of [] \ [] | y : ys \ drop\(n - 1)\ys)" fixrec isPrefixOf :: "['a::Eq] \ ['a] \ tr" where "isPrefixOf\[]\_ = TT" | "isPrefixOf\(x:xs)\[] = FF" | "isPrefixOf\(x:xs)\(y:ys) = (eq\x\y andalso isPrefixOf\xs\ys)" fixrec isSuffixOf :: "['a::Eq] \ ['a] \ tr" where "isSuffixOf\x\y = isPrefixOf\(reverse\x)\(reverse\y)" fixrec intersperse :: "'a \ ['a] \ ['a]" where "intersperse\sep\[] = []" | "intersperse\sep\[x] = [x]" | "intersperse\sep\(x:y:xs) = x:sep:intersperse\sep\(y:xs)" fixrec intercalate :: "['a] \ [['a]] \ ['a]" where "intercalate\xs\xss = concat\(intersperse\xs\xss)" definition replicate :: "Integer \ 'a \ ['a]" where "replicate = (\ n x. take\n\(repeat\x))" definition findIndices :: "('a \ tr) \ ['a] \ [Integer]" where "findIndices = (\ P xs. map\snd\(filter\(\ \x, i\. P\x)\(zip\xs\[0..])))" fixrec length :: "['a] \ Integer" where "length\[] = 0" | "length\(x : xs) = length\xs + 1" fixrec delete :: "'a::Eq \ ['a] \ ['a]" where "delete\x\[] = []" | "delete\x\(y : ys) = If eq\x\y then ys else y : delete\x\ys" fixrec diff :: "['a::Eq] \ ['a] \ ['a]" where "diff\xs\[] = xs" | "diff\xs\(y : ys) = diff\(delete\y\xs)\ys" abbreviation diff_syn :: "['a::Eq] \ ['a] \ ['a]" (infixl "\\\\" 70) where "xs \\\\ ys \ diff\xs\ys" subsection \Logical predicates on lists\ inductive finite_list :: "['a] \ bool" where Nil [intro!, simp]: "finite_list []" | Cons [intro!, simp]: "\x xs. finite_list xs \ finite_list (x : xs)" inductive_cases finite_listE [elim!]: "finite_list (x : xs)" lemma finite_list_upwards: assumes "finite_list xs" and "xs \ ys" shows "finite_list ys" using assms proof (induct xs arbitrary: ys) case Nil then have "ys = []" by (cases ys) simp+ then show ?case by auto next case (Cons x xs) from \x : xs \ ys\ obtain y ys' where "ys = y : ys'" by (cases ys) auto with \x : xs \ ys\ have "xs \ ys'" by auto then have "finite_list ys'" by (rule Cons.hyps) with \ys = _\ show ?case by auto qed lemma adm_finite_list [simp]: "adm finite_list" by (metis finite_list_upwards adm_upward) lemma bot_not_finite_list [simp]: "finite_list \ = False" by (rule, cases rule: finite_list.cases) auto inductive listmem :: "'a \ ['a] \ bool" where "listmem x (x : xs)" | "listmem x xs \ listmem x (y : xs)" lemma listmem_simps [simp]: shows "\ listmem x \" and "\ listmem x []" and "listmem x (y : ys) \ x = y \ listmem x ys" by (auto elim: listmem.cases intro: listmem.intros) definition set :: "['a] \ 'a set" where "set xs = {x. listmem x xs}" lemma set_simps [simp]: shows "set \ = {}" and "set [] = {}" and "set (x : xs) = insert x (set xs)" unfolding set_def by auto inductive distinct :: "['a] \ bool" where Nil [intro!, simp]: "distinct []" | Cons [intro!, simp]: "\x xs. distinct xs \ x \ set xs \ distinct (x : xs)" subsection \Properties\ lemma map_strict [simp]: "map\P\\ = \" by (fixrec_simp) lemma map_ID [simp]: "map\ID\xs = xs" by (induct xs) simp_all lemma enumFrom_intsFrom_conv [simp]: "enumFrom = intsFrom" by (intro cfun_eqI) (simp add: enumFrom_def) lemma enumFromTo_upto_conv [simp]: "enumFromTo = upto" by (intro cfun_eqI) (simp add: enumFromTo_def) lemma zipWith_strict [simp]: "zipWith\f\\\ys = \" "zipWith\f\(x : xs)\\ = \" by fixrec_simp+ lemma zip_simps [simp]: "zip\(x : xs)\(y : ys) = \x, y\ : zip\xs\ys" "zip\(x : xs)\[] = []" "zip\(x : xs)\\ = \" "zip\[]\ys = []" "zip\\\ys = \" unfolding zip_def by simp_all lemma zip_Nil2 [simp]: "xs \ \ \ zip\xs\[] = []" by (cases xs) simp_all lemma nth_strict [simp]: "nth\\\n = \" "nth\xs\\ = \" by (fixrec_simp) (cases xs, fixrec_simp+) lemma upto_strict [simp]: "upto\\\y = \" "upto\x\\ = \" by fixrec_simp+ lemma upto_simps [simp]: "n < m \ upto\(MkI\m)\(MkI\n) = []" "m \ n \ upto\(MkI\m)\(MkI\n) = MkI\m : [MkI\m+1..MkI\n]" by (subst upto.simps, simp)+ lemma filter_strict [simp]: "filter\P\\ = \" by (fixrec_simp) lemma nth_Cons_simp [simp]: "eq\n\0 = TT \ nth\(x : xs)\n = x" "eq\n\0 = FF \ nth\(x : xs)\n = nth\xs\(n - 1)" by (subst nth.simps, simp)+ lemma nth_Cons_split: "P (nth\(x : xs)\n) = ((eq\n\0 = FF \ P (nth\(x : xs)\n)) \ (eq\n\0 = TT \ P (nth\(x : xs)\n)) \ (n = \ \ P (nth\(x : xs)\n)))" (* "!!x. P (test x) = (~ (\a b. x = (a, b) & ~ P (test (a, b))))" *) apply (cases n, simp) apply (cases "n = 0", simp_all add: zero_Integer_def) done lemma nth_Cons_numeral [simp]: "(x : xs) !! 0 = x" "(x : xs) !! 1 = xs !! 0" "(x : xs) !! numeral (Num.Bit0 k) = xs !! numeral (Num.BitM k)" "(x : xs) !! numeral (Num.Bit1 k) = xs !! numeral (Num.Bit0 k)" by (simp_all add: nth_Cons numeral_Integer_eq zero_Integer_def one_Integer_def) lemma take_strict [simp]: "take\\\xs = \" by (fixrec_simp) lemma take_strict_2 [simp]: "le\1\i = TT \ take\i\\ = \" by (subst take.simps, cases "le\i\0") (auto dest: le_trans) lemma drop_strict [simp]: "drop\\\xs = \" by (fixrec_simp) lemma isPrefixOf_strict [simp]: "isPrefixOf\\\xs = \" "isPrefixOf\(x:xs)\\ = \" by (fixrec_simp)+ lemma last_strict[simp]: "last\\= \" "last\(x:\) = \" by (fixrec_simp+) lemma last_nil [simp]: "last\[] = \" by (fixrec_simp) lemma last_spine_strict: "\ finite_list xs \ last\xs = \" proof (induct xs) case (Cons a xs) then show ?case by (cases xs) auto qed auto lemma init_strict [simp]: "init\\= \" "init\(x:\) = \" by (fixrec_simp+) lemma init_nil [simp]: "init\[] = \" by (fixrec_simp) lemma strict_foldr_strict2 [simp]: "(\x. f\x\\ = \) \ foldr\f\\\xs = \" by (induct xs, auto) fixrec_simp lemma foldr_strict [simp]: "foldr\f\d\\ = \" "foldr\f\\\[] = \" "foldr\\\d\(x : xs) = \" by fixrec_simp+ lemma foldr_Cons_Nil [simp]: "foldr\(:)\[]\xs = xs" by (induct xs) simp+ lemma append_strict1 [simp]: "\ ++ ys = \" by fixrec_simp lemma foldr_append [simp]: "foldr\f\a\(xs ++ ys) = foldr\f\(foldr\f\a\ys)\xs" by (induct xs) simp+ lemma foldl_strict [simp]: "foldl\f\d\\ = \" "foldl\f\\\[] = \" by fixrec_simp+ lemma foldr1_strict [simp]: "foldr1\f\\= \" "foldr1\f\(x:\)= \" by fixrec_simp+ lemma foldl1_strict [simp]: "foldl1\f\\= \" by fixrec_simp lemma foldl_spine_strict: "\ finite_list xs \ foldl\f\x\xs = \" by (induct xs arbitrary: x) auto lemma foldl_assoc_foldr: assumes "finite_list xs" and assoc: "\x y z. f\(f\x\y)\z = f\x\(f\y\z)" and neutr1: "\x. f\z\x = x" and neutr2: "\x. f\x\z = x" shows "foldl\f\z\xs = foldr\f\z\xs" using \finite_list xs\ proof (induct xs) case (Cons x xs) from \finite_list xs\ have step: "\y. f\y\(foldl\f\z\xs) = foldl\f\(f\z\y)\xs" proof (induct xs) case (Cons x xs y) have "f\y\(foldl\f\z\(x : xs)) = f\y\(foldl\f\(f\z\x)\xs)" by auto also have "... = f\y\(f\x\(foldl\f\z\xs))" by (simp only: Cons.hyps) also have "... = f\(f\y\x)\(foldl\f\z\xs)" by (simp only: assoc) also have "... = foldl\f\(f\z\(f\y\x))\xs" by (simp only: Cons.hyps) also have "... = foldl\f\(f\(f\z\y)\x)\xs" by (simp only: assoc) also have "... = foldl\f\(f\z\y)\(x : xs)" by auto finally show ?case. qed (simp add: neutr1 neutr2) have "foldl\f\z\(x : xs) = foldl\f\(f\z\x)\xs" by auto also have "... = f\x\(foldl\f\z\xs)" by (simp only: step) also have "... = f\x\(foldr\f\z\xs)" by (simp only: Cons.hyps) also have "... = (foldr\f\z\(x:xs))" by auto finally show ?case . qed auto lemma elem_strict [simp]: "elem\x\\ = \" by fixrec_simp lemma notElem_strict [simp]: "notElem\x\\ = \" by fixrec_simp lemma list_eq_nil[simp]: "eq\l\[] = TT \ l = []" "eq\[]\l = TT \ l = []" by (cases l, auto)+ lemma take_Nil [simp]: "n \ \ \ take\n\[] = []" by (subst take.simps) (cases "le\n\0"; simp) lemma take_0 [simp]: "take\0\xs = []" "take\(MkI\0)\xs = []" by (subst take.simps, simp add: zero_Integer_def)+ lemma take_Cons [simp]: "le\1\i = TT \ take\i\(x:xs) = x : take\(i - 1)\xs" by (subst take.simps, cases "le\i\0") (auto dest: le_trans) lemma take_MkI_Cons [simp]: "0 < n \ take\(MkI\n)\(x : xs) = x : take\(MkI\(n - 1))\xs" by (subst take.simps) (simp add: zero_Integer_def one_Integer_def) lemma take_numeral_Cons [simp]: "take\1\(x : xs) = [x]" "take\(numeral (Num.Bit0 k))\(x : xs) = x : take\(numeral (Num.BitM k))\xs" "take\(numeral (Num.Bit1 k))\(x : xs) = x : take\(numeral (Num.Bit0 k))\xs" by (subst take.simps, simp add: zero_Integer_def one_Integer_def numeral_Integer_eq)+ lemma drop_0 [simp]: "drop\0\xs = xs" "drop\(MkI\0)\xs = xs" by (subst drop.simps, simp add: zero_Integer_def)+ lemma drop_pos [simp]: "le\n\0 = FF \ drop\n\xs = (case xs of [] \ [] | y : ys \ drop\(n - 1)\ys)" by (subst drop.simps, simp) lemma drop_numeral_Cons [simp]: "drop\1\(x : xs) = xs" "drop\(numeral (Num.Bit0 k))\(x : xs) = drop\(numeral (Num.BitM k))\xs" "drop\(numeral (Num.Bit1 k))\(x : xs) = drop\(numeral (Num.Bit0 k))\xs" by (subst drop.simps, simp add: zero_Integer_def one_Integer_def numeral_Integer_eq)+ lemma take_drop_append: "take\(MkI\i)\xs ++ drop\(MkI\i)\xs = xs" proof (cases i) case (nonneg n) then show ?thesis proof (induct n arbitrary : i xs) case (Suc n) thus ?case apply (subst drop.simps) apply (subst take.simps) apply (cases xs) apply (auto simp add: zero_Integer_def one_Integer_def ) done qed simp next case (neg nat) then show ?thesis apply (subst drop.simps) apply (subst take.simps) apply (auto simp add: zero_Integer_def one_Integer_def ) done qed lemma take_intsFrom_enumFrom [simp]: "take\(MkI\n)\[MkI\i..] = [MkI\i..MkI\(n+i) - 1]" proof (cases n) fix m assume "n = int m" then show ?thesis proof (induct m arbitrary: n i) case 0 then show ?case by (simp add: one_Integer_def) next case (Suc m) then have "n - 1 = int m" by simp from Suc(1) [OF this] have "take\(MkI\(n - 1))\[MkI\(i+1)..] = [MkI\(i+1)..MkI\(n - 1 + (i+1)) - 1]" . moreover have "(n - 1) + (i+1) - 1 = n + i - 1" by arith ultimately have IH: "take\(MkI\(n - 1))\[MkI\(i+1)..] = [MkI\(i+1)..MkI\(n+i) - 1]" by simp from Suc(2) have gt: "n > 0" by simp moreover have "[MkI\i..] = MkI\i : [MkI\i + 1..]" by (simp, subst intsFrom.simps) simp ultimately have *: "take\(MkI\n)\[MkI\i..] = MkI\i : take\(MkI\(n - 1))\[MkI\(i+1)..]" by (simp add: one_Integer_def) show ?case unfolding IH * using gt by (simp add: one_Integer_def) qed next fix m assume "n = - int m" then have "n \ 0" by simp then show ?thesis by (subst take.simps) (simp add: zero_Integer_def one_Integer_def) qed lemma drop_intsFrom_enumFrom [simp]: assumes "n \ 0" shows "drop\(MkI\n)\[MkI\i..] = [MkI\(n+i)..]" proof- from assms obtain n' where "n = int n'" by (cases n, auto) then show ?thesis apply(induct n' arbitrary: n i ) apply simp apply (subst intsFrom.simps[unfolded enumFrom_intsFrom_conv[symmetric]]) apply (subst drop.simps) apply (auto simp add: zero_Integer_def one_Integer_def) apply (rule cfun_arg_cong) apply (rule cfun_arg_cong) apply arith done qed lemma last_append_singleton: "finite_list xs \ last\(xs ++ [x]) = x" proof (induct xs rule:finite_list.induct) case (Cons x xs) then show ?case by (cases xs) auto qed auto lemma init_append_singleton: "finite_list xs \ init\(xs ++ [x]) = xs" proof (induct xs rule:finite_list.induct) case (Cons x xs) then show ?case by (cases xs) auto qed auto lemma append_Nil2 [simp]: "xs ++ [] = xs" by (induct xs) simp_all lemma append_assoc [simp]: "(xs ++ ys) ++ zs = xs ++ ys ++ zs" by (induct xs) simp_all lemma concat_simps [simp]: "concat\[] = []" "concat\(xs : xss) = xs ++ concat\xss" "concat\\ = \" unfolding concat_def by simp_all lemma concatMap_simps [simp]: "concatMap\f\[] = []" "concatMap\f\(x : xs) = f\x ++ concatMap\f\xs" "concatMap\f\\ = \" unfolding concatMap_def by simp_all lemma filter_append [simp]: "filter\P\(xs ++ ys) = filter\P\xs ++ filter\P\ys" proof (induct xs) case (Cons x xs) then show ?case by (cases "P\x") (auto simp: If_and_if) qed simp_all lemma elem_append [simp]: "elem\x\(xs ++ ys) = (elem\x\xs orelse elem\x\ys)" by (induct xs) auto lemma filter_filter [simp]: "filter\P\(filter\Q\xs) = filter\(\ x. Q\x andalso P\x)\xs" by (induct xs) (auto simp: If2_def [symmetric] split: split_If2) lemma filter_const_TT [simp]: "filter\(\ _. TT)\xs = xs" by (induct xs) simp_all lemma tails_strict [simp]: "tails\\ = \" by fixrec_simp lemma inits_strict [simp]: "inits\\ = \" by fixrec_simp lemma the_and_strict [simp]: "the_and\\ = \" by fixrec_simp lemma the_or_strict [simp]: "the_or\\ = \" by fixrec_simp lemma all_strict [simp]: "all\P\\ = \" by fixrec_simp lemma any_strict [simp]: "any\P\\ = \" by fixrec_simp lemma tails_neq_Nil [simp]: "tails\xs \ []" by (cases xs) simp_all lemma inits_neq_Nil [simp]: "inits\xs \ []" by (cases xs) simp_all lemma Nil_neq_tails [simp]: "[] \ tails\xs" by (cases xs) simp_all lemma Nil_neq_inits [simp]: "[] \ inits\xs" by (cases xs) simp_all lemma finite_list_not_bottom [simp]: assumes "finite_list xs" shows "xs \ \" using assms by (cases) simp_all lemma head_append [simp]: "head\(xs ++ ys) = If null\xs then head\ys else head\xs" by (cases xs) simp_all lemma filter_cong: "\x\set xs. p\x = q\x \ filter\p\xs = filter\q\xs" proof (induct arbitrary: xs rule: filter.induct) case (3 x) then show ?case by (cases xs) auto qed simp_all lemma filter_TT [simp]: assumes "\x\set xs. P\x = TT" shows "filter\P\xs = xs" by (rule filter_cong [of xs P "\ _. TT", simplified, OF assms]) lemma filter_FF [simp]: assumes "finite_list xs" and "\x\set xs. P\x = FF" shows "filter\P\xs = []" using assms by (induct xs) simp_all lemma map_cong: "\x\set xs. p\x = q\x \ map\p\xs = map\q\xs" proof (induct arbitrary: xs rule: map.induct) case (3 x) then show ?case by (cases xs) auto qed simp_all lemma finite_list_upto: "finite_list (upto\(MkI\m)\(MkI\n))" (is "?P m n") proof (cases "n - m") fix d assume "n - m = int d" then show "?P m n" proof (induct d arbitrary: m n) case (Suc d) then have "n - (m + 1) = int d" and le: "m \ n" by simp_all from Suc(1) [OF this(1)] have IH: "?P (m+1) n" . then show ?case using le by (simp add: one_Integer_def) qed (simp add: one_Integer_def) next fix d assume "n - m = - int d" then have "n \ m" by auto moreover - { assume "n = m" then have "?P m n" by (simp add: one_Integer_def) } + have "?P m n" if "n = m" using that by (simp add: one_Integer_def) moreover - { assume "n < m" then have "?P m n" by (simp add: one_Integer_def) } + have "?P m n" if "n < m" using that by (simp add: one_Integer_def) ultimately show ?thesis by arith qed lemma filter_commute: assumes "\x\set xs. (Q\x andalso P\x) = (P\x andalso Q\x)" shows "filter\P\(filter\Q\xs) = filter\Q\(filter\P\xs)" using filter_cong [of xs "\ x. Q\x andalso P\x" "\ x. P\x andalso Q\x"] and assms by simp lemma upto_append_intsFrom [simp]: assumes "m \ n" shows "upto\(MkI\m)\(MkI\n) ++ intsFrom\(MkI\n+1) = intsFrom\(MkI\m)" (is "?u m n ++ _ = ?i m") proof (cases "n - m") case (nonneg i) with assms show ?thesis proof (induct i arbitrary: m n) case (Suc i) then have "m + 1 \ n" and "n - (m + 1) = int i" by simp_all from Suc(1) [OF this] have IH: "?u (m+1) n ++ ?i (n+1) = ?i (m+1)" by (simp add: one_Integer_def) from \m + 1 \ n\ have "m \ n" by simp then have "?u m n ++ ?i (n+1) = (MkI\m : ?u (m+1) n) ++ ?i (n+1)" by (simp add: one_Integer_def) also have "\ = MkI\m : ?i (m+1)" by (simp add: IH) finally show ?case by (subst (2) intsFrom.simps) (simp add: one_Integer_def) qed (subst (2) intsFrom.simps, simp add: one_Integer_def) next case (neg i) then have "n < m" by simp with assms show ?thesis by simp qed lemma set_upto [simp]: "set (upto\(MkI\m)\(MkI\n)) = {MkI\i | i. m \ i \ i \ n}" (is "set (?u m n) = ?R m n") proof (cases "n - m") case (nonneg i) then show ?thesis proof (induct i arbitrary: m n) case (Suc i) then have *: "n - (m + 1) = int i" by simp from Suc(1) [OF *] have IH: "set (?u (m+1) n) = ?R (m+1) n" . from * have "m \ n" by simp then have "set (?u m n) = set (MkI\m : ?u (m+1) n)" by (simp add: one_Integer_def) also have "\ = insert (MkI\m) (?R (m+1) n)" by (simp add: IH) also have "\ = ?R m n" using \m \ n\ by auto finally show ?case . qed (force simp: one_Integer_def) qed simp lemma Nil_append_iff [iff]: "xs ++ ys = [] \ xs = [] \ ys = []" by (induct xs) simp_all text \This version of definedness rule for Nil is made necessary by the reorient simproc.\ lemma bottom_neq_Nil [simp]: "\ \ []" by simp text \Simproc to rewrite @{term "Nil = x"} to @{term "x = Nil"}.\ setup \ Reorient_Proc.add (fn Const(@{const_name Nil}, _) => true | _ => false) \ -simproc_setup reorient_Nil ("Nil = x") = Reorient_Proc.proc +simproc_setup reorient_Nil ("Nil = x") = \K Reorient_Proc.proc\ lemma set_append [simp]: assumes "finite_list xs" shows "set (xs ++ ys) = set xs \ set ys" using assms by (induct) simp_all lemma distinct_Cons [simp]: "distinct (x : xs) \ distinct xs \ x \ set xs" (is "?l = ?r") proof assume ?l then show ?r by (cases) simp_all next assume ?r then show ?l by auto qed lemma finite_list_append [iff]: "finite_list (xs ++ ys) \ finite_list xs \ finite_list ys" (is "?l = ?r") proof presume "finite_list xs" and "finite_list ys" then show ?l by (induct) simp_all next assume "?l" then show "?r" proof (induct "xs ++ ys" arbitrary: xs ys) case (Cons x xs) then show ?case by (cases xs) auto qed simp qed simp_all lemma distinct_append [simp]: assumes "finite_list (xs ++ ys)" shows "distinct (xs ++ ys) \ distinct xs \ distinct ys \ set xs \ set ys = {}" (is "?P xs ys") using assms proof (induct "xs ++ ys" arbitrary: xs ys) - case (Cons z zs) + case Cons': (Cons z zs) show ?case proof (cases xs) - note Cons' = Cons case (Cons u us) with Cons' have "finite_list us" and [simp]: "zs = us ++ ys" "?P us ys" by simp_all then show ?thesis by (auto simp: Cons) - qed (insert Cons, simp_all) + qed (use Cons' in simp_all) qed simp lemma finite_set [simp]: assumes "distinct xs" shows "finite (set xs)" using assms by induct auto lemma distinct_card: assumes "distinct xs" shows "MkI\(int (card (set xs))) = length\xs" using assms by (induct) (simp_all add: zero_Integer_def plus_MkI_MkI [symmetric] one_Integer_def ac_simps) lemma set_delete [simp]: fixes xs :: "['a::Eq_eq]" assumes "distinct xs" and "\x\set xs. eq\a\x \ \" shows "set (delete\a\xs) = set xs - {a}" using assms proof induct case (Cons x xs) then show ?case by (cases "eq\a\x", force+) qed simp lemma distinct_delete [simp]: fixes xs :: "['a::Eq_eq]" assumes "distinct xs" and "\x\set xs. eq\a\x \ \" shows "distinct (delete\a\xs)" using assms proof induct case (Cons x xs) then show ?case by (cases "eq\a\x", force+) qed simp lemma set_diff [simp]: fixes xs ys :: "['a::Eq_eq]" assumes "distinct ys" and "distinct xs" and "\a\set ys. \x\set xs. eq\a\x \ \" shows "set (xs \\\\ ys) = set xs - set ys" using assms proof (induct arbitrary: xs) case Nil then show ?case by (induct xs rule: distinct.induct) simp_all next case (Cons y ys) let ?xs = "delete\y\xs" from Cons have *: "\x\set xs. eq\y\x \ \" by simp from set_delete [OF \distinct xs\ this] have **: "set ?xs = set xs - {y}" . with Cons have "\a\set ys. \x\set ?xs. eq\a\x \ \" by simp moreover from * and \distinct xs\ have "distinct ?xs" by simp ultimately have "set (?xs \\\\ ys) = set ?xs - set ys" using Cons by blast then show ?case by (force simp: **) qed lemma distinct_delete_filter: fixes xs :: "['a::Eq_eq]" assumes "distinct xs" and "\x\set xs. eq\a\x \ \" shows "delete\a\xs = filter\(\ x. neq\a\x)\xs" using assms proof (induct) case (Cons x xs) then have IH: "delete\a\xs = filter\(\ x. neq\a\x)\xs" by simp show ?case proof (cases "eq\a\x") case TT have "\x\set xs. (\ x. neq\a\x)\x = (\ _. TT)\x" proof fix y assume "y \ set xs" with Cons(3, 4) have "x \ y" and "eq\a\y \ \" by auto with TT have "eq\a\y = FF" by (metis (no_types) eqD(1) trE) then show "(\ x. neq\a\x)\y = (\ _. TT)\y" by simp qed from filter_cong [OF this] and TT show ?thesis by simp qed (simp_all add: IH) qed simp lemma distinct_diff_filter: fixes xs ys :: "['a::Eq_eq]" assumes "finite_list ys" and "distinct xs" and "\a\set ys. \x\set xs. eq\a\x \ \" shows "xs \\\\ ys = filter\(\ x. neg\(elem\x\ys))\xs" using assms proof (induct arbitrary: xs) case Nil then show ?case by simp next case (Cons y ys) let ?xs = "delete\y\xs" from Cons have *: "\x\set xs. eq\y\x \ \" by simp from set_delete [OF \distinct xs\ this] have "set ?xs = set xs - {y}" . with Cons have "\a\set ys. \x\set ?xs. eq\a\x \ \" by simp moreover from * and \distinct xs\ have "distinct ?xs" by simp ultimately have "?xs \\\\ ys = filter\(\ x. neg\(elem\x\ys))\?xs" using Cons by blast then show ?case using \distinct xs\ and * by (simp add: distinct_delete_filter) qed lemma distinct_upto [intro, simp]: "distinct [MkI\m..MkI\n]" proof (cases "n - m") case (nonneg i) then show ?thesis proof (induct i arbitrary: m) case (Suc i) then have "n - (m + 1) = int i" and "m \ n" by simp_all with Suc have "distinct [MkI\(m+1)..MkI\n]" by force with \m \ n\ show ?case by (simp add: one_Integer_def) qed (simp add: one_Integer_def) qed simp lemma set_intsFrom [simp]: "set (intsFrom\(MkI\m)) = {MkI\n | n. m \ n}" (is "set (?i m) = ?I") proof show "set (?i m) \ ?I" proof fix n assume "n \ set (?i m)" then have "listmem n (?i m)" by (simp add: set_def) then show "n \ ?I" proof (induct n "(?i m)" arbitrary: m) fix x xs m assume "x : xs = ?i m" then have "x : xs = MkI\m : ?i (m+1)" by (subst (asm) intsFrom.simps) (simp add: one_Integer_def) then have [simp]: "x = MkI\m" "xs = ?i (m+1)" by simp_all show "x \ {MkI\n | n. m \ n}" by simp next fix x xs y m assume IH: "listmem x xs" "\m. xs = ?i m \ x \ {MkI\n | n. m \ n}" "y : xs = ?i m" then have "y : xs = MkI\m : ?i (m+1)" by (subst (asm) (2) intsFrom.simps) (simp add: one_Integer_def) then have [simp]: "y = MkI\m" "xs = ?i (m+1)" by simp_all from IH (2) [of "m+1"] have "x \ {MkI\n | n. m+1 \ n}" by (simp add: one_Integer_def) then show "x \ {MkI\n | n. m \ n}" by force qed qed next show "?I \ set (?i m)" proof fix x assume "x \ ?I" then obtain n where [simp]: "x = MkI\n" and "m \ n" by blast from upto_append_intsFrom [OF this(2), symmetric] have *: "set (?i m) = set (upto\(MkI\m)\(MkI\n)) \ set (?i (n+1))" using finite_list_upto [of m n] by (simp add: one_Integer_def) show "x \ set (?i m)" using \m \ n\ by (auto simp: * one_Integer_def) qed qed lemma If_eq_bottom_iff [simp]: (* FIXME: move *) "(If b then x else y = \) \ b = \ \ b = TT \ x = \ \ b = FF \ y = \" by (induct b) simp_all lemma upto_eq_bottom_iff [simp]: "upto\m\n = \ \ m = \ \ n = \" by (subst upto.simps, simp) lemma seq_eq_bottom_iff [simp]: (* FIXME: move *) "seq\x\y = \ \ x = \ \ y = \" by (simp add: seq_conv_if) lemma intsFrom_eq_bottom_iff [simp]: "intsFrom\m = \ \ m = \" by (subst intsFrom.simps, simp) lemma intsFrom_split: assumes "m \ n" shows "[MkI\n..] = [MkI\n .. MkI\(m - 1)] ++ [MkI\m..]" proof- from assms have ge: "m - n \ 0" by arith have "[MkI\n..] = (take\(MkI\(m - n)) \ [MkI\n..]) ++ (drop\(MkI\(m - n)) \ [MkI\n..])" by (subst take_drop_append, rule) also have "... = [MkI\n.. MkI\(m - 1)] ++ [MkI\m..]" by (subst drop_intsFrom_enumFrom[OF ge], auto simp add:take_intsFrom_enumFrom[simplified] one_Integer_def) finally show ?thesis . qed lemma filter_fast_forward: assumes "n+1 \ n'" and "\k . n < k \ k < n' \ \ P k" shows "filter\(\ (MkI\i) . Def (P i))\[MkI\(n+1)..] = filter\(\ (MkI\i) . Def (P i))\[MkI\n'..]" proof- from assms(1) have"[MkI\(n+1)..] = [MkI\(n+1).. MkI\(n'- 1)] ++ [MkI\n'..]" (is "_ = ?l1 ++ ?l2") by (subst intsFrom_split[of "n+1" n'], auto) moreover have "filter\(\ (MkI\i) . Def (P i))\[MkI\(n+1).. MkI\(n'- 1)] = []" apply (rule filter_FF) apply (simp, rule finite_list_upto) using assms(2) apply auto done ultimately show ?thesis by simp qed lemma null_eq_TT_iff [simp]: "null\xs = TT \ xs = []" by (cases xs) simp_all lemma null_set_empty_conv: "xs \ \ \ null\xs = TT \ set xs = {}" by (cases xs) simp_all lemma elem_TT [simp]: fixes x :: "'a::Eq_eq" shows "elem\x\xs = TT \ x \ set xs" apply (induct arbitrary: xs rule: elem.induct, simp_all) apply (rename_tac xs, case_tac xs, simp_all) apply (rename_tac a list, case_tac "eq\a\x", force+) done lemma elem_FF [simp]: fixes x :: "'a::Eq_equiv" shows "elem\x\xs = FF \ x \ set xs" by (induct arbitrary: xs rule: elem.induct, simp_all) (rename_tac xs, case_tac xs, simp_all, force) lemma length_strict [simp]: "length\\ = \" by (fixrec_simp) lemma repeat_neq_bottom [simp]: "repeat\x \ \" by (subst repeat.simps) simp lemma list_case_repeat [simp]: "list_case\a\f\(repeat\x) = f\x\(repeat\x)" by (subst repeat.simps) simp lemma length_append [simp]: "length\(xs ++ ys) = length\xs + length\ys" by (induct xs) (simp_all add: ac_simps) lemma replicate_strict [simp]: "replicate\\\x = \" by (simp add: replicate_def) lemma replicate_0 [simp]: "replicate\0\x = []" "replicate\(MkI\0)\xs = []" by (simp add: replicate_def)+ lemma Integer_add_0 [simp]: "MkI\0 + n = n" by (cases n) simp_all lemma replicate_MkI_plus_1 [simp]: "0 \ n \ replicate\(MkI\(n+1))\x = x : replicate\(MkI\n)\x" "0 \ n \ replicate\(MkI\(1+n))\x = x : replicate\(MkI\n)\x" by (simp add: replicate_def, subst take.simps, simp add: one_Integer_def zero_Integer_def)+ lemma replicate_append_plus_conv: assumes "0 \ m" and "0 \ n" shows "replicate\(MkI\m)\x ++ replicate\(MkI\n)\x = replicate\(MkI\m + MkI\n)\x" proof (cases m) case (nonneg i) with assms show ?thesis proof (induct i arbitrary: m) case (Suc i) then have ge: "int i + n \ 0" by force have "replicate\(MkI\m)\x ++ replicate\(MkI\n)\x = x : (replicate\(MkI\(int i))\x ++ replicate\(MkI\n)\x)" by (simp add: Suc) also have "\ = x : replicate\(MkI\(int i) + MkI\n)\x" using Suc by simp finally show ?case using ge by (simp add: Suc ac_simps) qed simp next case (neg i) with assms show ?thesis by simp qed lemma replicate_MkI_1 [simp]: "replicate\(MkI\1)\x = x : []" by (simp add: replicate_def, subst take.simps, simp add: zero_Integer_def one_Integer_def) lemma length_replicate [simp]: assumes "0 \ n" shows "length\(replicate\(MkI\n)\x) = MkI\n" proof (cases n) case (nonneg i) with assms show ?thesis by (induct i arbitrary: n) (simp_all add: replicate_append_plus_conv zero_Integer_def one_Integer_def) next case (neg i) with assms show ?thesis by (simp add: replicate_def) qed lemma map_oo [simp]: "map\f\(map\g\xs) = map\(f oo g)\xs" by (induct xs) simp_all lemma nth_Cons_MkI [simp]: "0 < i \ (a : xs) !! (MkI\i) = xs !! (MkI\(i - 1))" unfolding nth_Cons by (cases i, simp add: zero_Integer_def one_Integer_def) (case_tac n, simp_all) lemma map_plus_intsFrom: "map\(+ MkI\n)\(intsFrom\(MkI\m)) = intsFrom\(MkI\(m+n))" (is "?l = ?r") proof (rule list.take_lemma) fix i show "list_take i\?l = list_take i\?r" proof (induct i arbitrary: m) case (Suc i) then show ?case by (subst (1 2) intsFrom.simps) (simp add: ac_simps one_Integer_def) qed simp qed lemma plus_eq_MkI_conv: "l + n = MkI\m \ (\l' n'. l = MkI\l' \ n = MkI\n' \ m = l' + n')" by (cases l, simp) (cases n, auto) lemma length_ge_0: "length\xs = MkI\n \ n \ 0" by (induct xs arbitrary: n) (auto simp: one_Integer_def plus_eq_MkI_conv) lemma length_0_conv [simp]: "length\xs = MkI\0 \ xs = []" apply (cases xs) apply (simp_all add: one_Integer_def) apply (case_tac "length\list") apply (auto dest: length_ge_0) done lemma length_ge_1 [simp]: "length\xs = MkI\(1 + int n) \ (\u us. xs = u : us \ length\us = MkI\(int n))" (is "?l = ?r") proof assume ?r then show ?l by (auto simp: one_Integer_def) next assume 1: ?l then obtain u us where [simp]: "xs = u : us" by (cases xs) auto from 1 have 2: "1 + length\us = MkI\(1 + int n)" by (simp add: ac_simps) then have "length\us \ \" by (cases "length\us") simp_all moreover from 2 have "length\us + 1 = MkI\(int n) + 1" by (simp add: one_Integer_def ac_simps) ultimately have "length\us = MkI\(int n)" by (cases "length\us") (simp_all add: one_Integer_def) then show ?r by simp qed lemma finite_list_length_conv: "finite_list xs \ (\n. length\xs = MkI\(int n))" (is "?l = ?r") proof assume "?l" then show "?r" by (induct, auto simp: one_Integer_def) presburger next assume "?r" then obtain n where "length\xs = MkI\(int n)" by blast then show "?l" by (induct n arbitrary: xs) auto qed lemma nth_append: assumes "length\xs = MkI\n" and "n \ m" shows "(xs ++ ys) !! MkI\m = ys !! MkI\(m - n)" using assms proof (induct xs arbitrary: n m) case (Cons x xs) then have ge: "n \ 0" by (blast intro: length_ge_0) from Cons(2) have len: "length\xs = MkI\(n - 1)" by (auto simp: plus_eq_MkI_conv one_Integer_def) from Cons(3) have le: "n - 1 \ m - 1" by simp - { assume "m < 0" - with ge have ?case using Cons(3) by simp } - moreover - { assume "m = 0" + consider "m < 0" | "m = 0" | "m > 0" by arith + then show ?case + proof cases + case 1 + with ge show ?thesis using Cons(3) by simp + next + case 2 with Cons(3) and ge have "n = 0" by simp - with Cons(2) have ?case - by (auto dest: length_ge_0 simp: one_Integer_def plus_eq_MkI_conv) } - moreover - { assume "m > 0" - then have ?case - by (auto simp: Cons(1) [OF len le] zero_Integer_def one_Integer_def) } - ultimately show ?case by arith + with Cons(2) show ?thesis + by (auto dest: length_ge_0 simp: one_Integer_def plus_eq_MkI_conv) + next + case 3 + then show ?thesis + by (auto simp: Cons(1) [OF len le] zero_Integer_def one_Integer_def) + qed qed (simp_all add: zero_Integer_def) lemma replicate_nth [simp]: assumes "0 \ n" shows "(replicate\(MkI\n)\x ++ xs) !! MkI\n = xs !! MkI\0" using nth_append [OF length_replicate [OF assms], of n] by simp lemma map2_zip: "map\(\\x, y\. \x, f\y\)\(zip\xs\ys) = zip\xs\(map\f\ys)" by (induct xs arbitrary: ys) (simp_all, case_tac ys, simp_all) lemma map2_filter: "map\(\\x, y\. \x, f\y\)\(filter\(\\x, y\. P\x)\xs) = filter\(\\x, y\. P\x)\(map\(\\x, y\. \x, f\y\)\xs)" apply (induct xs, simp_all) apply (rename_tac x xs, case_tac x, simp, simp) apply (rename_tac a b, case_tac "P\a", auto) done lemma map_map_snd: "f\\ = \ \ map\f\(map\snd\xs) = map\snd\(map\(\\x, y\. \x, f\y\)\xs)" by (induct xs, simp_all, rename_tac a b, case_tac a, simp_all) lemma findIndices_Cons [simp]: "findIndices\P\(a : xs) = If P\a then 0 : map\(+1)\(findIndices\P\xs) else map\(+1)\(findIndices\P\xs)" by (auto simp: findIndices_def, subst intsFrom.simps, cases "P\a") (simp_all del: map_oo add: map_oo [symmetric] map_map_snd one_Integer_def zero_Integer_def map_plus_intsFrom [of 1 0, simplified, symmetric] map2_zip [of "(+ MkI\1)", simplified] map2_filter [of "(+ MkI\1)", simplified]) lemma filter_alt_def: fixes xs :: "['a]" shows "filter\P\xs = map\(nth\xs)\(findIndices\P\xs)" proof - - { - fix f g :: "Integer \ 'a" + have 1: "map\f\(map\snd\(filter\(\\x, i\. P\x)\(zip\xs\[MkI\i..]))) + = map\g\(map\snd\(filter\(\\x, i\. P\x)\(zip\xs\[MkI\i..])))" + if "\j\i. f\(MkI\j) = g\(MkI\j)" + for f g :: "Integer \ 'a" and P :: "'a \ tr" and i xs - assume "\j\i. f\(MkI\j) = g\(MkI\j)" - then have "map\f\(map\snd\(filter\(\\x, i\. P\x)\(zip\xs\[MkI\i..]))) - = map\g\(map\snd\(filter\(\\x, i\. P\x)\(zip\xs\[MkI\i..])))" - by (induct xs arbitrary: i, simp_all, subst (1 2) intsFrom.simps) - (rename_tac a b c, case_tac "P\a", simp_all add: one_Integer_def) - } note 1 = this - { - fix a and ys :: "['a]" - have "\i\0. nth\ys\(MkI\i) = (nth\(a : ys) oo (+1))\(MkI\i)" - by (auto simp: one_Integer_def zero_Integer_def) - } note 2 = this - { - fix a P and ys xs :: "['a]" - have "map\(nth\(a : ys) oo (+1))\(findIndices\P\xs) - = map\(nth\ys)\(findIndices\P\xs)" - by (simp add: findIndices_def 1 [OF 2, simplified, of ys P xs a] zero_Integer_def) - } note 3 = this + using that + by (induct xs arbitrary: i, simp_all, subst (1 2) intsFrom.simps) + (rename_tac a b c, case_tac "P\a", simp_all add: one_Integer_def) + have 2: "\i\0. nth\ys\(MkI\i) = (nth\(a : ys) oo (+1))\(MkI\i)" + for a and ys :: "['a]" + by (auto simp: one_Integer_def zero_Integer_def) + have 3: "map\(nth\(a : ys) oo (+1))\(findIndices\P\xs) + = map\(nth\ys)\(findIndices\P\xs)" + for a P and ys xs :: "['a]" + by (simp add: findIndices_def 1 [OF 2, simplified, of ys P xs a] zero_Integer_def) show ?thesis by (induct xs, simp_all, simp add: findIndices_def, simp add: findIndices_def) (rename_tac a b, case_tac "P\a", simp add: findIndices_def, simp_all add: 3) qed abbreviation cfun_image :: "('a \ 'b) \ 'a set \ 'b set" (infixr "`\" 90) where "f `\ A \ Rep_cfun f ` A" lemma set_map: "set (map\f\xs) = f `\ set xs" (is "?l = ?r") proof - { fix a assume "listmem a xs" then have "listmem (f\a) (map\f\xs)" - by (induct) simp_all } + have "listmem (f\a) (map\f\xs)" if "listmem a xs" for a + using that by (induct) simp_all then show "?r \ ?l" by (auto simp: set_def) next - { fix a assume "listmem a (map\f\xs)" - then have "\b. a = f\b \ listmem b xs" + have "\b. a = f\b \ listmem b xs" if "listmem a (map\f\xs)" for a + using that by (induct a "map\f\xs" arbitrary: xs) - (rename_tac xsa, case_tac xsa, auto)+ } + (rename_tac xsa, case_tac xsa, auto)+ then show "?l \ ?r" unfolding set_def by auto qed subsection \@{const reverse} and @{const reverse} induction\ text \Alternative simplification rules for @{const reverse} (easier to use for equational reasoning):\ lemma reverse_Nil [simp]: "reverse\[] = []" by (simp add: reverse.simps) lemma reverse_singleton [simp]: "reverse\[x] = [x]" by (simp add: reverse.simps) lemma reverse_strict [simp]: "reverse\\ = \" by (simp add: reverse.simps) lemma foldl_flip_Cons_append: "foldl\(flip\(:))\ys\xs = foldl\(flip\(:))\[]\xs ++ ys" proof (induct xs arbitrary: ys) case (Cons x xs) show ?case by simp (metis (no_types) Cons append.simps append_assoc) qed simp+ lemma reverse_Cons [simp]: "reverse\(x:xs) = reverse\xs ++ [x]" by (simp add: reverse.simps) (subst foldl_flip_Cons_append, rule refl) lemma reverse_append_below: "reverse\(xs ++ ys) \ reverse\ys ++ reverse\xs" apply (induction xs) apply (simp del: append_assoc add: append_assoc [symmetric])+ apply (blast intro: monofun_cfun append_assoc) done lemma reverse_reverse_below: "reverse\(reverse\xs) \ xs" proof (induction xs) case (Cons x xs) have "reverse\(reverse\(x:xs)) = reverse\(reverse\xs ++ [x])" by simp also have "\ \ reverse\[x] ++ reverse\(reverse\xs)" by (rule reverse_append_below) also have "\ = x : reverse\(reverse\xs)" by simp also have "\ \ x : xs" by (simp add: Cons) finally show ?case . qed simp+ lemma reverse_append [simp]: assumes "finite_list xs" shows "reverse\(xs ++ ys) = reverse\ys ++ reverse\xs" using assms by (induct xs) simp+ lemma reverse_spine_strict: "\ finite_list xs \ reverse\xs = \" by (auto simp add: reverse.simps foldl_spine_strict) lemma reverse_finite [simp]: assumes "finite_list xs" shows "finite_list (reverse\xs)" using assms by (induct xs) simp+ lemma reverse_reverse [simp]: assumes "finite_list xs" shows "reverse\(reverse\xs) = xs" using assms by (induct xs) simp+ lemma reverse_induct [consumes 1, case_names Nil snoc]: "\finite_list xs; P []; \x xs . finite_list xs \ P xs \ P (xs ++ [x])\ \ P xs" apply (subst reverse_reverse [symmetric]) apply assumption apply (rule finite_list.induct[where x = "reverse\xs"]) apply simp+ done lemma length_plus_not_0: "le\1\n = TT \ le\(length\xs + n)\0 = TT \ False" proof (induct xs arbitrary: n) case Nil then show ?case by auto (metis Ord_linear_class.le_trans dist_eq_tr(3) le_Integer_numeral_simps(3)) next case (Cons x xs) from Cons(1) [of "n + 1"] show ?case using Cons(2-) by (auto simp: ac_simps dest: le_plus_1) qed simp+ lemma take_length_plus_1: "length\xs \ \ \ take\(length\xs + 1)\(y:ys) = y : take\(length\xs)\ys" by (subst take.simps, cases "le\(length\xs + 1)\0") (auto, metis (no_types) length_plus_not_0 le_Integer_numeral_simps(4)) lemma le_length_plus: "length\xs \ \ \ n \ \ \ le\n\(length\xs + n) = TT" proof (induct xs arbitrary: n) case (Cons x xs) then have "le\(n + 1)\(length\xs + (n + 1)) = TT" by simp moreover have "le\n\(n + 1) = TT" using \n \ \\ by (metis le_plus_1 le_refl_Integer) ultimately have "le\n\(length\xs + (n + 1)) = TT" by (blast dest: le_trans) then show ?case by (simp add: ac_simps) qed simp+ lemma eq_take_length_isPrefixOf: "eq\xs\(take\(length\xs)\ys) \ isPrefixOf\xs\ys" proof (induct xs arbitrary: ys) - case (Cons x xs) - note IH = this + case IH: (Cons x xs) show ?case proof (cases "length\xs = \") case True then show ?thesis by simp next case False show ?thesis proof (cases ys) case bottom then show ?thesis using False using le_length_plus [of xs 1] by simp next case Nil then show ?thesis using False by simp next case (Cons z zs) then show ?thesis using False and IH [of zs] by (simp add: take_length_plus_1 monofun_cfun_arg) qed qed qed simp+ end diff --git a/thys/HOLCF-Prelude/Data_Maybe.thy b/thys/HOLCF-Prelude/Data_Maybe.thy --- a/thys/HOLCF-Prelude/Data_Maybe.thy +++ b/thys/HOLCF-Prelude/Data_Maybe.thy @@ -1,147 +1,149 @@ section \Data: Maybe\ theory Data_Maybe imports Type_Classes Data_Function Data_List Data_Bool begin domain 'a Maybe = Nothing | Just (lazy "'a") abbreviation maybe :: "'b \ ('a \ 'b) \ 'a Maybe \ 'b" where "maybe \ Maybe_case" fixrec isJust :: "'a Maybe \ tr" where "isJust\(Just\a) = TT" | "isJust\Nothing = FF" fixrec isNothing :: "'a Maybe \ tr" where "isNothing = neg oo isJust" fixrec fromJust :: "'a Maybe \ 'a" where "fromJust\(Just\a) = a" | "fromJust\Nothing = \" fixrec fromMaybe :: "'a \ 'a Maybe \ 'a" where "fromMaybe\d\Nothing = d" | "fromMaybe\d\(Just\a) = a" fixrec maybeToList :: "'a Maybe \ ['a]" where "maybeToList\Nothing = []" | "maybeToList\(Just\a) = [a]" fixrec listToMaybe :: "['a] \ 'a Maybe" where "listToMaybe\[] = Nothing" | "listToMaybe\(a:_) = Just\a" (* FIXME: The Prelude definition uses list comps, which are too advanced for our syntax *) fixrec catMaybes :: "['a Maybe] \ ['a]" where "catMaybes = concatMap\maybeToList" fixrec mapMaybe :: "('a \ 'b Maybe) \ ['a] \ ['b]" where "mapMaybe\f = catMaybes oo map\f" instantiation Maybe :: (Eq) Eq_strict begin definition "eq = maybe\(maybe\TT\(\ y. FF))\(\ x. maybe\FF\(\ y. eq\x\y))" instance proof fix x :: "'a Maybe" show "eq\x\\ = \" unfolding eq_Maybe_def by (cases x) simp_all show "eq\\\x = \" unfolding eq_Maybe_def by simp qed end lemma eq_Maybe_simps [simp]: "eq\Nothing\Nothing = TT" "eq\Nothing\(Just\y) = FF" "eq\(Just\x)\Nothing = FF" "eq\(Just\x)\(Just\y) = eq\x\y" unfolding eq_Maybe_def by simp_all instance Maybe :: (Eq_sym) Eq_sym proof fix x y :: "'a Maybe" show "eq\x\y = eq\y\x" by (cases x, simp, cases y, simp, simp, simp, cases y, simp, simp, simp add: eq_sym) qed instance Maybe :: (Eq_equiv) Eq_equiv proof fix x y z :: "'a Maybe" show "eq\x\x \ FF" by (cases x, simp_all) assume "eq\x\y = TT" and "eq\y\z = TT" then show "eq\x\z = TT" by (cases x, simp, cases y, simp, cases z, simp, simp, simp, simp, cases y, simp, simp, cases z, simp, simp, simp, fast elim: eq_trans) qed instance Maybe :: (Eq_eq) Eq_eq proof fix x y :: "'a Maybe" show "eq\x\x \ FF" by (cases x, simp_all) assume "eq\x\y = TT" then show "x = y" by (cases x, simp, cases y, simp, simp, simp, cases y, simp, simp, simp, fast) qed instantiation Maybe :: (Ord) Ord_strict begin definition "compare = maybe\(maybe\EQ\(\ y. LT))\(\ x. maybe\GT\(\ y. compare\x\y))" instance proof fix x :: "'a Maybe" show "compare\x\\ = \" unfolding compare_Maybe_def by (cases x) simp_all show "compare\\\x = \" unfolding compare_Maybe_def by simp qed end lemma compare_Maybe_simps [simp]: "compare\Nothing\Nothing = EQ" "compare\Nothing\(Just\y) = LT" "compare\(Just\x)\Nothing = GT" "compare\(Just\x)\(Just\y) = compare\x\y" unfolding compare_Maybe_def by simp_all instance Maybe :: (Ord_linear) Ord_linear proof fix x y z :: "'a Maybe" show "eq\x\y = is_EQ\(compare\x\y)" by (cases x, simp, cases y, simp, simp, simp, cases y, simp, simp, simp add: eq_conv_compare) show "oppOrdering\(compare\x\y) = compare\y\x" by (cases x, simp, (cases y, simp, simp, simp)+) show "compare\x\x \ EQ" by (cases x) simp_all - { assume "compare\x\y = EQ" then show "x = y" - by (cases x, simp, cases y, simp, simp, simp, - cases y, simp, simp, simp) (erule compare_EQ_dest) } - { assume "compare\x\y = LT" and "compare\y\z = LT" then show "compare\x\z = LT" - apply (cases x, simp) - apply (cases y, simp, simp) - apply (cases z, simp, simp, simp) - apply (cases y, simp, simp) - apply (cases z, simp, simp) - apply (auto elim: compare_LT_trans) - done } + show "x = y" if "compare\x\y = EQ" + using that + by (cases x, simp, cases y, simp, simp, simp, + cases y, simp, simp, simp) (erule compare_EQ_dest) + show "compare\x\z = LT" if "compare\x\y = LT" and "compare\y\z = LT" + using that + apply (cases x, simp) + apply (cases y, simp, simp) + apply (cases z, simp, simp, simp) + apply (cases y, simp, simp) + apply (cases z, simp, simp) + apply (auto elim: compare_LT_trans) + done qed lemma isJust_strict [simp]: "isJust\\ = \" by (fixrec_simp) lemma fromMaybe_strict [simp]: "fromMaybe\x\\ = \" by (fixrec_simp) lemma maybeToList_strict [simp]: "maybeToList\\ = \" by (fixrec_simp) end diff --git a/thys/HOLCF-Prelude/Data_Tuple.thy b/thys/HOLCF-Prelude/Data_Tuple.thy --- a/thys/HOLCF-Prelude/Data_Tuple.thy +++ b/thys/HOLCF-Prelude/Data_Tuple.thy @@ -1,234 +1,238 @@ section \Data: Tuple\ theory Data_Tuple imports Type_Classes Data_Bool begin subsection \Datatype definitions\ domain Unit ("\\") = Unit ("\\") domain ('a, 'b) Tuple2 ("\_, _\") = Tuple2 (lazy fst :: "'a") (lazy snd :: "'b") ("\_, _\") notation Tuple2 ("\,\") fixrec uncurry :: "('a \ 'b \ 'c) \ \'a, 'b\ \ 'c" where "uncurry\f\p = f\(fst\p)\(snd\p)" fixrec curry :: "(\'a, 'b\ \ 'c) \ 'a \ 'b \ 'c" where "curry\f\a\b = f\\a, b\" domain ('a, 'b, 'c) Tuple3 ("\_, _, _\") = Tuple3 (lazy "'a") (lazy "'b") (lazy "'c") ("\_, _, _\") notation Tuple3 ("\,,\") subsection \Type class instances\ instantiation Unit :: Ord_linear begin definition "eq = (\ \\ \\. TT)" definition "compare = (\ \\ \\. EQ)" instance apply standard apply (unfold eq_Unit_def compare_Unit_def) apply simp apply (rename_tac x, case_tac x, simp, simp) apply (rename_tac x y, case_tac x, simp, case_tac y, simp, simp) apply (rename_tac x y, case_tac x, case_tac y, simp, simp, case_tac y, simp, simp) apply (rename_tac x y, case_tac x, simp, case_tac y, simp, simp) apply (rename_tac x, case_tac x, simp, simp) apply (rename_tac x y z, case_tac x, simp, case_tac y, simp, case_tac z, simp, simp) done end instantiation Tuple2 :: (Eq, Eq) Eq_strict begin definition "eq = (\ \x1, y1\ \x2, y2\. eq\x1\x2 andalso eq\y1\y2)" instance proof fix x :: "\'a, 'b\" show "eq\x\\ = \" unfolding eq_Tuple2_def by (cases x, simp_all) show "eq\\\x = \" unfolding eq_Tuple2_def by simp qed end lemma eq_Tuple2_simps [simp]: "eq\\x1, y1\\\x2, y2\ = (eq\x1\x2 andalso eq\y1\y2)" unfolding eq_Tuple2_def by simp instance Tuple2 :: (Eq_sym, Eq_sym) Eq_sym proof fix x y :: "\'a, 'b\" show "eq\x\y = eq\y\x" unfolding eq_Tuple2_def by (cases x, simp, (cases y, simp, simp add: eq_sym)+) qed instance Tuple2 :: (Eq_equiv, Eq_equiv) Eq_equiv proof fix x y z :: "\'a, 'b\" show "eq\x\x \ FF" by (cases x, simp_all) - { assume "eq\x\y = TT" and "eq\y\z = TT" then show "eq\x\z = TT" - by (cases x, simp, cases y, simp, cases z, simp, simp, - fast intro: eq_trans) } + show "eq\x\z = TT" if "eq\x\y = TT" and "eq\y\z = TT" + using that + by (cases x, simp, cases y, simp, cases z, simp, simp, + fast intro: eq_trans) qed instance Tuple2 :: (Eq_eq, Eq_eq) Eq_eq proof fix x y :: "\'a, 'b\" show "eq\x\x \ FF" by (cases x, simp_all) - { assume "eq\x\y = TT" then show "x = y" - by (cases x, simp, cases y, simp, simp, fast) } + show "x = y" if "eq\x\y = TT" + using that by (cases x, simp, cases y, simp, simp, fast) qed instantiation Tuple2 :: (Ord, Ord) Ord_strict begin definition "compare = (\ \x1, y1\ \x2, y2\. thenOrdering\(compare\x1\x2)\(compare\y1\y2))" instance by standard (simp add: compare_Tuple2_def, rename_tac x, case_tac x, simp_all add: compare_Tuple2_def) end lemma compare_Tuple2_simps [simp]: "compare\\x1, y1\\\x2, y2\ = thenOrdering\(compare\x1\x2)\(compare\y1\y2)" unfolding compare_Tuple2_def by simp instance Tuple2 :: (Ord_linear, Ord_linear) Ord_linear proof fix x y z :: "\'a, 'b\" show "eq\x\y = is_EQ\(compare\x\y)" by (cases x, simp, cases y, simp, simp add: eq_conv_compare) show "oppOrdering\(compare\x\y) = compare\y\x" by (cases x, simp, cases y, simp, simp add: oppOrdering_thenOrdering) - { assume "compare\x\y = EQ" then show "x = y" - by (cases x, simp, cases y, simp, auto elim: compare_EQ_dest) } - { assume "compare\x\y = LT" and "compare\y\z = LT" then show "compare\x\z = LT" - apply (cases x, simp, cases y, simp, cases z, simp, simp) - apply (elim disjE conjE) - apply (fast elim!: compare_LT_trans) - apply (fast dest: compare_EQ_dest) - apply (fast dest: compare_EQ_dest) - apply (drule compare_EQ_dest) - apply (fast elim!: compare_LT_trans) - done } + show "x = y" if "compare\x\y = EQ" + using that by (cases x, simp, cases y, simp, auto elim: compare_EQ_dest) + show "compare\x\z = LT" if "compare\x\y = LT" and "compare\y\z = LT" + using that + apply (cases x, simp, cases y, simp, cases z, simp, simp) + apply (elim disjE conjE) + apply (fast elim!: compare_LT_trans) + apply (fast dest: compare_EQ_dest) + apply (fast dest: compare_EQ_dest) + apply (drule compare_EQ_dest) + apply (fast elim!: compare_LT_trans) + done show "compare\x\x \ EQ" by (cases x, simp_all) qed instantiation Tuple3 :: (Eq, Eq, Eq) Eq_strict begin definition "eq = (\ \x1, y1, z1\ \x2, y2, z2\. eq\x1\x2 andalso eq\y1\y2 andalso eq\z1\z2)" instance proof fix x :: "\'a, 'b, 'c\" show "eq\x\\ = \" unfolding eq_Tuple3_def by (cases x, simp_all) show "eq\\\x = \" unfolding eq_Tuple3_def by simp qed end lemma eq_Tuple3_simps [simp]: "eq\\x1, y1, z1\\\x2, y2, z2\ = (eq\x1\x2 andalso eq\y1\y2 andalso eq\z1\z2)" unfolding eq_Tuple3_def by simp instance Tuple3 :: (Eq_sym, Eq_sym, Eq_sym) Eq_sym proof fix x y :: "\'a, 'b, 'c\" show "eq\x\y = eq\y\x" unfolding eq_Tuple3_def by (cases x, simp, (cases y, simp, simp add: eq_sym)+) qed instance Tuple3 :: (Eq_equiv, Eq_equiv, Eq_equiv) Eq_equiv proof fix x y z :: "\'a, 'b, 'c\" show "eq\x\x \ FF" by (cases x, simp_all) - { assume "eq\x\y = TT" and "eq\y\z = TT" then show "eq\x\z = TT" - by (cases x, simp, cases y, simp, cases z, simp, simp, - fast intro: eq_trans) } + show "eq\x\z = TT" if "eq\x\y = TT" and "eq\y\z = TT" + using that + by (cases x, simp, cases y, simp, cases z, simp, simp, + fast intro: eq_trans) qed instance Tuple3 :: (Eq_eq, Eq_eq, Eq_eq) Eq_eq proof fix x y :: "\'a, 'b, 'c\" show "eq\x\x \ FF" by (cases x, simp_all) - { assume "eq\x\y = TT" then show "x = y" - by (cases x, simp, cases y, simp, simp, fast) } + show "x = y" if "eq\x\y = TT" + using that by (cases x, simp, cases y, simp, simp, fast) qed instantiation Tuple3 :: (Ord, Ord, Ord) Ord_strict begin definition "compare = (\ \x1, y1, z1\ \x2, y2, z2\. thenOrdering\(compare\x1\x2)\(thenOrdering\(compare\y1\y2)\(compare\z1\z2)))" instance by standard (simp add: compare_Tuple3_def, rename_tac x, case_tac x, simp_all add: compare_Tuple3_def) end lemma compare_Tuple3_simps [simp]: "compare\\x1, y1, z1\\\x2, y2, z2\ = thenOrdering\(compare\x1\x2)\ (thenOrdering\(compare\y1\y2)\(compare\z1\z2))" unfolding compare_Tuple3_def by simp instance Tuple3 :: (Ord_linear, Ord_linear, Ord_linear) Ord_linear proof fix x y z :: "\'a, 'b, 'c\" show "eq\x\y = is_EQ\(compare\x\y)" by (cases x, simp, cases y, simp, simp add: eq_conv_compare) show "oppOrdering\(compare\x\y) = compare\y\x" by (cases x, simp, cases y, simp, simp add: oppOrdering_thenOrdering) - { assume "compare\x\y = EQ" then show "x = y" - by (cases x, simp, cases y, simp, auto elim: compare_EQ_dest) } - { assume "compare\x\y = LT" and "compare\y\z = LT" then show "compare\x\z = LT" - apply (cases x, simp, cases y, simp, cases z, simp, simp) - apply (elim disjE conjE) - apply (fast elim!: compare_LT_trans) - apply (fast dest: compare_EQ_dest) - apply (fast dest: compare_EQ_dest) + show "x = y" if "compare\x\y = EQ" + using that by (cases x, simp, cases y, simp, auto elim: compare_EQ_dest) + show "compare\x\z = LT" if "compare\x\y = LT" and "compare\y\z = LT" + using that + apply (cases x, simp, cases y, simp, cases z, simp, simp) + apply (elim disjE conjE) + apply (fast elim!: compare_LT_trans) apply (fast dest: compare_EQ_dest) apply (fast dest: compare_EQ_dest) - apply (drule compare_EQ_dest) - apply (fast elim!: compare_LT_trans) + apply (fast dest: compare_EQ_dest) apply (fast dest: compare_EQ_dest) - apply (fast dest: compare_EQ_dest) - apply (fast dest: compare_EQ_dest elim!: compare_LT_trans) - done } + apply (drule compare_EQ_dest) + apply (fast elim!: compare_LT_trans) + apply (fast dest: compare_EQ_dest) + apply (fast dest: compare_EQ_dest) + apply (fast dest: compare_EQ_dest elim!: compare_LT_trans) + done show "compare\x\x \ EQ" by (cases x, simp_all) qed end diff --git a/thys/HOLCF-Prelude/Definedness.thy b/thys/HOLCF-Prelude/Definedness.thy --- a/thys/HOLCF-Prelude/Definedness.thy +++ b/thys/HOLCF-Prelude/Definedness.thy @@ -1,224 +1,221 @@ section \Definedness\ theory Definedness imports Data_List begin text \ This is an attempt for a setup for better handling bottom, by a better simp setup, and less breaking the abstractions. \ definition defined :: "'a :: pcpo \ bool" where "defined x = (x \ \)" lemma defined_bottom [simp]: "\ defined \" by (simp add: defined_def) lemma defined_seq [simp]: "defined x \ seq\x\y = y" by (simp add: defined_def) consts val :: "'a::type \ 'b::type" ("\_\") text \val for booleans\ definition val_Bool :: "tr \ bool" where "val_Bool i = (THE j. i = Def j)" adhoc_overloading val val_Bool lemma defined_Bool_simps [simp]: "defined (Def i)" "defined TT" "defined FF" by (simp_all add: defined_def) lemma val_Bool_simp1 [simp]: "\Def i\ = i" by (simp_all add: val_Bool_def TT_def FF_def) lemma val_Bool_simp2 [simp]: "\TT\ = True" "\FF\ = False" by (simp_all add: TT_def FF_def) lemma IF_simps [simp]: "defined b \ \ b \ \ (If b then x else y) = x" "defined b \ \ b \ = False \ (If b then x else y) = y" by (cases b, simp_all)+ lemma defined_neg [simp]: "defined (neg\b) \ defined b" by (cases b, auto) lemma val_Bool_neg [simp]: "defined b \ \ neg \ b \ = (\ \ b \)" by (cases b, auto) text \val for integers\ definition val_Integer :: "Integer \ int" where "val_Integer i = (THE j. i = MkI\j)" adhoc_overloading val val_Integer lemma defined_Integer_simps [simp]: "defined (MkI\i)" "defined (0::Integer)" "defined (1::Integer)" by (simp_all add: defined_def) lemma defined_numeral [simp]: "defined (numeral x :: Integer)" by (simp add: defined_def) lemma val_Integer_simps [simp]: "\MkI\i\ = i" "\0\ = 0" "\1\ = 1" by (simp_all add: val_Integer_def) lemma val_Integer_numeral [simp]: "\ numeral x :: Integer \ = numeral x" by (simp_all add: val_Integer_def) lemma val_Integer_to_MkI: "defined i \ i = (MkI \ \ i \)" apply (cases i) apply (auto simp add: val_Integer_def defined_def) done lemma defined_Integer_minus [simp]: "defined i \ defined j \ defined (i - (j::Integer))" apply (cases i, auto) apply (cases j, auto) done lemma val_Integer_minus [simp]: "defined i \ defined j \ \ i - j \ = \ i \ - \ j \" apply (cases i, auto) apply (cases j, auto) done lemma defined_Integer_plus [simp]: "defined i \ defined j \ defined (i + (j::Integer))" apply (cases i, auto) apply (cases j, auto) done lemma val_Integer_plus [simp]: "defined i \ defined j \ \ i + j \ = \ i \ + \ j \" apply (cases i, auto) apply (cases j, auto) done lemma defined_Integer_eq [simp]: "defined (eq\a\b) \ defined a \ defined (b::Integer)" apply (cases a, simp) apply (cases b, simp) apply simp done lemma val_Integer_eq [simp]: "defined a \ defined b \ \ eq\a\b \ = (\ a \ = (\ b \ :: int))" apply (cases a, simp) apply (cases b, simp) apply simp done text \Full induction for non-negative integers\ lemma nonneg_full_Int_induct [consumes 1, case_names neg Suc]: assumes defined: "defined i" assumes neg: "\ i. defined i \ \i\ < 0 \ P i" assumes step: "\ i. defined i \ 0 \ \i\ \ (\ j. defined j \ \ j \ < \ i \ \ P j) \ P i" shows "P (i::Integer)" proof (cases i) case bottom then have False using defined by simp then show ?thesis .. next case (MkI integer) show ?thesis proof (cases integer) case neg then show ?thesis using assms(2) MkI by simp next case (nonneg nat) have "P (MkI\(int nat))" proof(induction nat rule:full_nat_induct) case (1 nat) have "defined (MkI\(int nat))" by simp moreover have "0 \ \ MkI\(int nat) \" by simp moreover - { fix j::Integer - assume "defined j" and le: "\ j \ < \ MkI\(int nat) \" - have "P j" - proof(cases j) - case bottom with \defined j\ show ?thesis by simp + have "P j" if "defined j" and le: "\ j \ < \ MkI\(int nat) \" for j::Integer + proof(cases j) + case bottom with \defined j\ show ?thesis by simp + next + case (MkI integer) + show ?thesis + proof(cases integer) + case (neg nat) + have "\j\ < 0" using neg MkI by simp + with \defined j\ + show ?thesis by (rule assms(2)) next - case (MkI integer) - show ?thesis - proof(cases integer) - case (neg nat) - have "\j\ < 0" using neg MkI by simp - with \defined j\ - show ?thesis by (rule assms(2)) - next - case (nonneg m) - have "Suc m \ nat" using le nonneg MkI by simp - then have "P (MkI\(int m))" by (metis "1.IH") - then show ?thesis using nonneg MkI by simp - qed + case (nonneg m) + have "Suc m \ nat" using le nonneg MkI by simp + then have "P (MkI\(int m))" by (metis "1.IH") + then show ?thesis using nonneg MkI by simp qed - } + qed ultimately show ?case by (rule step) qed then show ?thesis using nonneg MkI by simp qed qed text \Some list lemmas re-done with the new setup.\ lemma nth_tail: (* TODO: move *) "defined n \ \ n \ \ 0 \ tail\xs !! n = xs !! (1 + n)" apply (cases xs, simp_all) apply (cases n, simp) apply (simp add: one_Integer_def zero_Integer_def) done lemma nth_zipWith: (* TODO: move *) assumes f1 [simp]: "\y. f\\\y = \" assumes f2 [simp]: "\x. f\x\\ = \" shows "zipWith\f\xs\ys !! n = f\(xs !! n)\(ys !! n)" proof (induct xs arbitrary: ys n) case (Cons x xs ys n) then show ?case by (cases ys, simp_all split:nth_Cons_split) qed simp_all lemma nth_neg [simp]: "defined n \ \ n \ < 0 \ nth\xs\n = \" proof (induction xs arbitrary: n) have [simp]: "eq\n\0 = TT \ (n::Integer) = 0" for n by (cases n, auto simp add: zero_Integer_def) case (Cons a xs n) have "eq\n\0 = FF" using Cons.prems by (cases "eq\n\0") auto then show ?case using Cons.prems by (auto intro: Cons.IH) qed simp_all lemma nth_Cons_simp [simp]: "defined n \ \ n \ = 0 \ nth\(x : xs)\n = x" "defined n \ \ n \ > 0 \ nth\(x : xs)\n = nth\xs\(n - 1)" proof - assume "defined n" and "\ n \ = 0" then have "n = 0" by (cases n) auto then show "nth\(x : xs)\n = x" by simp next assume "defined n" and "\ n \ > 0" then have "eq\n\0 = FF" by (cases "eq\n\0") auto then show "nth\(x : xs)\n = nth\xs\(n - 1)" by simp qed end diff --git a/thys/HOLCF-Prelude/Type_Classes.thy b/thys/HOLCF-Prelude/Type_Classes.thy --- a/thys/HOLCF-Prelude/Type_Classes.thy +++ b/thys/HOLCF-Prelude/Type_Classes.thy @@ -1,276 +1,279 @@ section \Type Classes\ theory Type_Classes imports HOLCF_Main begin subsection \Eq class\ class Eq = fixes eq :: "'a \ 'a \ tr" text \ The Haskell type class does allow /= to be specified separately. For now, we assume that all modeled type classes use the default implementation, or an equivalent. \ fixrec neq :: "'a::Eq \ 'a \ tr" where "neq\x\y = neg\(eq\x\y)" class Eq_strict = Eq + assumes eq_strict [simp]: "eq\x\\ = \" "eq\\\y = \" class Eq_sym = Eq_strict + assumes eq_sym: "eq\x\y = eq\y\x" class Eq_equiv = Eq_sym + assumes eq_self_neq_FF [simp]: "eq\x\x \ FF" and eq_trans: "eq\x\y = TT \ eq\y\z = TT \ eq\x\z = TT" begin lemma eq_refl: "eq\x\x \ \ \ eq\x\x = TT" by (cases "eq\x\x") simp+ end class Eq_eq = Eq_sym + assumes eq_self_neq_FF': "eq\x\x \ FF" and eq_TT_dest: "eq\x\y = TT \ x = y" begin subclass Eq_equiv by standard (auto simp: eq_self_neq_FF' dest: eq_TT_dest) lemma eqD [dest]: "eq\x\y = TT \ x = y" "eq\x\y = FF \ x \ y" by (auto elim: eq_TT_dest) end subsubsection \Class instances\ instantiation lift :: (countable) Eq_eq begin definition "eq \ (\(Def x) (Def y). Def (x = y))" instance by standard (auto simp: eq_lift_def flift1_def split: lift.splits) end lemma eq_ONE_ONE [simp]: "eq\ONE\ONE = TT" unfolding ONE_def eq_lift_def by simp subsection \Ord class\ domain Ordering = LT | EQ | GT definition oppOrdering :: "Ordering \ Ordering" where "oppOrdering = (\ x. case x of LT \ GT | EQ \ EQ | GT \ LT)" lemma oppOrdering_simps [simp]: "oppOrdering\LT = GT" "oppOrdering\EQ = EQ" "oppOrdering\GT = LT" "oppOrdering\\ = \" unfolding oppOrdering_def by simp_all class Ord = Eq + fixes compare :: "'a \ 'a \ Ordering" begin definition lt :: "'a \ 'a \ tr" where "lt = (\ x y. case compare\x\y of LT \ TT | EQ \ FF | GT \ FF)" definition le :: "'a \ 'a \ tr" where "le = (\ x y. case compare\x\y of LT \ TT | EQ \ TT | GT \ FF)" lemma lt_eq_TT_iff: "lt\x\y = TT \ compare\x\y = LT" by (cases "compare\x\y") (simp add: lt_def)+ end class Ord_strict = Ord + assumes compare_strict [simp]: "compare\\\y = \" "compare\x\\ = \" begin lemma lt_strict [simp]: shows "lt\\\x = \" and "lt\x\\ = \" by (simp add: lt_def)+ lemma le_strict [simp]: shows "le\\\x = \" and "le\x\\ = \" by (simp add: le_def)+ end text \TODO: It might make sense to have a class for preorders too, analogous to class \eq_equiv\.\ class Ord_linear = Ord_strict + assumes eq_conv_compare: "eq\x\y = is_EQ\(compare\x\y)" and oppOrdering_compare [simp]: "oppOrdering\(compare\x\y) = compare\y\x" and compare_EQ_dest: "compare\x\y = EQ \ x = y" and compare_self_below_EQ: "compare\x\x \ EQ" and compare_LT_trans: "compare\x\y = LT \ compare\y\z = LT \ compare\x\z = LT" (*BH: Is this set of axioms complete?*) (*CS: How about totality of the order?*) begin lemma eq_TT_dest: "eq\x\y = TT \ x = y" by (cases "compare\x\y") (auto dest: compare_EQ_dest simp: eq_conv_compare)+ lemma le_iff_lt_or_eq: "le\x\y = TT \ lt\x\y = TT \ eq\x\y = TT" by (cases "compare\x\y") (simp add: le_def lt_def eq_conv_compare)+ lemma compare_sym: "compare\x\y = (case compare\y\x of LT \ GT | EQ \ EQ | GT \ LT)" by (subst oppOrdering_compare [symmetric]) (simp add: oppOrdering_def) lemma compare_self_neq_LT [simp]: "compare\x\x \ LT" using compare_self_below_EQ [of x] by clarsimp lemma compare_self_neq_GT [simp]: "compare\x\x \ GT" using compare_self_below_EQ [of x] by clarsimp declare compare_self_below_EQ [simp] lemma lt_trans: "lt\x\y = TT \ lt\y\z = TT \ lt\x\z = TT" unfolding lt_eq_TT_iff by (rule compare_LT_trans) lemma compare_GT_iff_LT: "compare\x\y = GT \ compare\y\x = LT" by (cases "compare\x\y", simp_all add: compare_sym [of y x]) lemma compare_GT_trans: "compare\x\y = GT \ compare\y\z = GT \ compare\x\z = GT" unfolding compare_GT_iff_LT by (rule compare_LT_trans) lemma compare_EQ_iff_eq_TT: "compare\x\y = EQ \ eq\x\y = TT" by (cases "compare\x\y") (simp add: is_EQ_def eq_conv_compare)+ lemma compare_EQ_trans: "compare\x\y = EQ \ compare\y\z = EQ \ compare\x\z = EQ" by (blast dest: compare_EQ_dest) lemma le_trans: "le\x\y = TT \ le\y\z = TT \ le\x\z = TT" by (auto dest: eq_TT_dest lt_trans simp: le_iff_lt_or_eq) lemma neg_lt: "neg\(lt\x\y) = le\y\x" by (cases "compare\x\y", simp_all add: le_def lt_def compare_sym [of y x]) lemma neg_le: "neg\(le\x\y) = lt\y\x" by (cases "compare\x\y", simp_all add: le_def lt_def compare_sym [of y x]) subclass Eq_eq proof fix x y show "eq\x\y = eq\y\x" unfolding eq_conv_compare by (cases "compare\x\y", simp_all add: compare_sym [of y x]) show "eq\x\\ = \" unfolding eq_conv_compare by simp show "eq\\\y = \" unfolding eq_conv_compare by simp show "eq\x\x \ FF" unfolding eq_conv_compare by (cases "compare\x\x", simp_all) - { assume "eq\x\y = TT" then show "x = y" - unfolding eq_conv_compare - by (cases "compare\x\y", auto dest: compare_EQ_dest) } + show "x = y" if "eq\x\y = TT" + using that + unfolding eq_conv_compare + by (cases "compare\x\y", auto dest: compare_EQ_dest) qed end text \A combinator for defining Ord instances for datatypes.\ definition thenOrdering :: "Ordering \ Ordering \ Ordering" where "thenOrdering = (\ x y. case x of LT \ LT | EQ \ y | GT \ GT)" lemma thenOrdering_simps [simp]: "thenOrdering\LT\y = LT" "thenOrdering\EQ\y = y" "thenOrdering\GT\y = GT" "thenOrdering\\\y = \" unfolding thenOrdering_def by simp_all lemma thenOrdering_LT_iff [simp]: "thenOrdering\x\y = LT \ x = LT \ x = EQ \ y = LT" by (cases x, simp_all) lemma thenOrdering_EQ_iff [simp]: "thenOrdering\x\y = EQ \ x = EQ \ y = EQ" by (cases x, simp_all) lemma thenOrdering_GT_iff [simp]: "thenOrdering\x\y = GT \ x = GT \ x = EQ \ y = GT" by (cases x, simp_all) lemma thenOrdering_below_EQ_iff [simp]: "thenOrdering\x\y \ EQ \ x \ EQ \ (x = \ \ y \ EQ)" by (cases x) simp_all lemma is_EQ_thenOrdering [simp]: "is_EQ\(thenOrdering\x\y) = (is_EQ\x andalso is_EQ\y)" by (cases x) simp_all lemma oppOrdering_thenOrdering: "oppOrdering\(thenOrdering\x\y) = thenOrdering\(oppOrdering\x)\(oppOrdering\y)" by (cases x) simp_all instantiation lift :: ("{linorder,countable}") Ord_linear begin definition "compare \ (\ (Def x) (Def y). if x < y then LT else if x > y then GT else EQ)" instance proof fix x y z :: "'a lift" show "compare\\\y = \" unfolding compare_lift_def by simp show "compare\x\\ = \" unfolding compare_lift_def by (cases x, simp_all) show "oppOrdering\(compare\x\y) = compare\y\x" unfolding compare_lift_def by (cases x, cases y, simp, simp, cases y, simp, simp add: not_less less_imp_le) - { assume "compare\x\y = EQ" then show "x = y" - unfolding compare_lift_def - by (cases x, cases y, simp, simp, - cases y, simp, simp split: if_splits) } - { assume "compare\x\y = LT" and "compare\y\z = LT" then show "compare\x\z = LT" - unfolding compare_lift_def - by (cases x, simp, cases y, simp, cases z, simp, - auto split: if_splits) } + show "x = y" if "compare\x\y = EQ" + using that + unfolding compare_lift_def + by (cases x, cases y, simp, simp, + cases y, simp, simp split: if_splits) + show "compare\x\z = LT" if "compare\x\y = LT" and "compare\y\z = LT" + using that + unfolding compare_lift_def + by (cases x, simp, cases y, simp, cases z, simp, + auto split: if_splits) show "eq\x\y = is_EQ\(compare\x\y)" unfolding eq_lift_def compare_lift_def by (cases x, simp, cases y, simp, auto) show "compare\x\x \ EQ" unfolding compare_lift_def by (cases x, simp_all) qed end lemma lt_le: "lt\(x::'a::Ord_linear)\y = (le\x\y andalso neq\x\y)" by (cases "compare\x\y") (auto simp: lt_def le_def eq_conv_compare) end diff --git a/thys/HOLCF-Prelude/examples/HLint.thy b/thys/HOLCF-Prelude/examples/HLint.thy --- a/thys/HOLCF-Prelude/examples/HLint.thy +++ b/thys/HOLCF-Prelude/examples/HLint.thy @@ -1,990 +1,989 @@ theory HLint imports "../HOLCF_Prelude" "../List_Comprehension" begin section \HLint\ text \ The tool \texttt{hlint} analyses Haskell code and, based on a data base of rewrite rules, suggests stylistic improvements to it. We verify a number of these rules using our implementation of the Haskell standard library. \ (* -- I/O *) (* putStrLn (show x) ==> print x *) (* mapM_ putChar ==> putStr *) (* hGetChar stdin ==> getChar *) (* hGetLine stdin ==> getLine *) (* hGetContents stdin ==> getContents *) (* hPutChar stdout ==> putChar *) (* hPutStr stdout ==> putStr *) (* hPutStrLn stdout ==> putStrLn *) (* hPrint stdout ==> print *) (* hWaitForInput a 0 ==> hReady a *) (* hPutStrLn a (show b) ==> hPrint a b *) (* hIsEOF stdin ==> isEOF *) (* -- EXIT *) (* exitWith ExitSuccess ==> exitSuccess *) subsection \Ord\ (* not (a == b) ==> a /= b where note = "incorrect if either value is NaN" *) (* not (a /= b) ==> a == b where note = "incorrect if either value is NaN" *) (* not (a > b) ==> a <= b where note = "incorrect if either value is NaN" *) (* not (a >= b) ==> a < b where note = "incorrect if either value is NaN" *) (* not (a < b) ==> a >= b where note = "incorrect if either value is NaN" *) (* not (a <= b) ==> a > b where note = "incorrect if either value is NaN" *) (* compare x y /= GT ==> x <= y *) (* compare x y == LT ==> x < y *) (* compare x y /= LT ==> x >= y *) (* compare x y == GT ==> x > y *) text \@{verbatim \x == a || x == b || x == c ==> x `elem` [a,b,c]\ } \ lemma "(eq\(x::'a::Eq_sym)\a orelse eq\x\b orelse eq\x\c) = elem\x\[a, b, c]" by (auto simp add: eq_sym) text \@{verbatim \ x /= a && x /= b && x /= c ==> x `notElem` [a,b,c]\ } \ lemma "(neq\(x::'a::Eq_sym)\a andalso neq\x\b andalso neq\x\c) = notElem\x\[a, b, c]" by (auto simp add: eq_sym) (* compare (f x) (f y) ==> Data.Ord.comparing f x y -- not that great *) (* on compare f ==> Data.Ord.comparing f -- not that great *) (* -- READ/SHOW *) (* showsPrec 0 x "" ==> show x *) (* readsPrec 0 ==> reads *) (* showsPrec 0 ==> shows *) (* showIntAtBase 16 intToDigit ==> showHex *) (* showIntAtBase 8 intToDigit ==> showOct *) subsection \List\ text \@{verbatim \ concat (map f x) ==> concatMap f x\ } \ lemma "concat\(map\f\x) = concatMap\f\x" by (auto simp add: concatMap_def) text \@{verbatim \ concat [a, b] ==> a ++ b\ } \ lemma "concat\[a, b] = a ++ b" by auto text \@{verbatim \ map f (map g x) ==> map (f . g) x\ } \ lemma "map\f\(map\g\x) = map\(f oo g)\x" by auto text \@{verbatim \ x !! 0 ==> head x\ } \ lemma "x !! 0 = head\x" by (cases x) auto text \@{verbatim \ take n (repeat x) ==> replicate n x\ } \ lemma "take\n\(repeat\x) = replicate\n\x" by (simp add: replicate_def) text \@{verbatim \lemma "head\(reverse\x) = last\x" \ } \ lemma "head\(reverse\x) = last\x" proof (cases "finite_list x") case True then show ?thesis by (induct x rule: reverse_induct) (auto simp add: last_append_singleton) next case False then show ?thesis by (simp add: last_spine_strict reverse_spine_strict) qed text \@{verbatim \ head (drop n x) ==> x !! n where note = "if the index is non-negative"\ } \ lemma assumes "le\0\n \ FF" shows "head\(drop\n\x) = x !! n" proof (cases "le\0\n") assume "le\0\n = FF" with assms show ?thesis.. next assume "le\0\n = TT" then show ?thesis proof (induction arbitrary: x rule: nonneg_Integer_induct) case 0 show ?case by (cases x) auto next case (step i x) from step.hyps have [simp]:"le\i\0 = FF" by (cases i, auto simp add: one_Integer_def zero_Integer_def) from step.hyps have [simp]:"eq\i\0 = FF" by (cases i, auto simp add: one_Integer_def zero_Integer_def) show ?case using step.IH by (cases x)auto qed qed simp text \@{verbatim \ reverse (tail (reverse x)) ==> init x\ } \ lemma "reverse\(tail\(reverse\x)) \ init\x" proof (cases "finite_list x") case True then show ?thesis by (induct x rule: reverse_induct) (auto simp add: init_append_singleton) next case False then show ?thesis by (auto simp add: reverse_spine_strict) qed text \@{verbatim \ take (length x - 1) x ==> init x\ } \ lemma assumes "x \ []" shows "take\(length\x - 1)\x \ init\x" using assms proof (induct x) - case (Cons y ys) + case IH: (Cons y ys) show ?case proof (cases ys) - note IH = Cons case (Cons z zs) show ?thesis using IH by (cases "length\zs") (auto simp: Cons one_Integer_def dest: length_ge_0) qed (auto simp: one_Integer_def) qed auto text \@{verbatim \ foldr (++) [] ==> concat\ } \ lemma foldr_append_concat:"foldr\append\[] = concat" proof (rule cfun_eqI) fix xs :: "[['a]]" show "foldr\append\[]\xs = concat\xs" by (induct xs) auto qed text \@{verbatim \ foldl (++) [] ==> concat\ } \ lemma "foldl\append\[] \ concat" proof (rule cfun_belowI) fix xs :: "[['a]]" show "foldl\append\[]\xs \ concat\xs" by (cases "finite_list xs") (auto simp add: foldr_append_concat foldl_assoc_foldr foldl_spine_strict) qed text \@{verbatim \ span (not . p) ==> break p\ } \ lemma "span\(neg oo p) = break\p" by simp text \@{verbatim \ break (not . p) ==> span p\ } \ lemma "break\(neg oo p) = span\p" by (unfold break.simps) (subst assoc_oo, simp) (* concatMap (++ "\n") ==> unlines *) text \@{verbatim \ or (map p x) ==> any p x\ } \ lemma "the_or\(map\p\x) = any\p\x" by simp text \@{verbatim \ and (map p x) ==> all p x\ } \ lemma "the_and\(map\p\x) = all\p\x" by simp text \@{verbatim \ zipWith (,) ==> zip\ } \ lemma "zipWith\\,\ = zip" by (simp add: zip_def) text \@{verbatim \ zipWith3 (,,) ==> zip3\ } \ lemma "zipWith3\\,,\ = zip3" by (simp add: zip3_def) text \@{verbatim \ length x == 0 ==> null x where note = "increases laziness"\ } \ lemma "eq\(length\x)\0 \ null\x" proof (cases x) case (Cons y ys) then show ?thesis by (cases "length\ys") (auto dest: length_ge_0 simp: zero_Integer_def one_Integer_def) qed simp+ text \@{verbatim \ length x /= 0 ==> not (null x)\ } \ lemma "neq\(length\x)\0 \ neg\(null\x)" proof (cases x) case (Cons y ys) then show ?thesis by (cases "length\ys") (auto dest: length_ge_0 simp: zero_Integer_def one_Integer_def) qed simp+ (* (\x -> [x]) ==> (:[]) *) text \@{verbatim \ map (uncurry f) (zip x y) ==> zipWith f x y\ } \ lemma "map\(uncurry\f)\(zip\x\y) = zipWith\f\x\y" proof (induct x arbitrary: y) case (Cons x xs y) then show ?case by (cases y) auto qed auto text \@{verbatim \ map f (zip x y) ==> zipWith (curry f) x y where _ = isVar f\ } \ lemma "map\f\(zip\x\y) = zipWith\(curry\f)\x\y" proof(induct x arbitrary: y) case (Cons x xs y) then show ?case by (cases y) auto qed auto text \@{verbatim \ not (elem x y) ==> notElem x y\ } \ lemma "neg\(elem\x\y) = notElem\x\y" by (induct y) auto text \@{verbatim \ foldr f z (map g x) ==> foldr (f . g) z x\ } \ lemma "foldr\f\z\(map\g\x) = foldr\(f oo g)\z\x" by (induct x) auto (* x ++ concatMap (' ':) y ==> unwords (x:y) *) (* intercalate " " ==> unwords *) (* concat (intersperse x y) ==> intercalate x y where _ = notEq x " " *) (* concat (intersperse " " x) ==> unwords x *) text \@{verbatim \ null (filter f x) ==> not (any f x)\ } \ lemma "null\(filter\f\x) = neg\(any\f\x)" proof (induct x) case (Cons x xs) then show ?case by (cases "f\x") auto qed auto text \@{verbatim \ filter f x == [] ==> not (any f x)\ } \ lemma "eq\(filter\f\x)\[] = neg\(any\f\x)" proof (induct x) case (Cons x xs) then show ?case by (cases "f\x") auto qed auto text \@{verbatim \ filter f x /= [] ==> any f x\ } \ lemma "neq\(filter\f\x)\[] = any\f\x" proof (induct x) case (Cons x xs) then show ?case by (cases "f\x") auto qed auto text \@{verbatim \ any (== a) ==> elem a\ } \ lemma "any\(\ z. eq\z\a) = elem\a" proof (rule cfun_eqI) fix xs show "any\(\ z. eq\z\a)\xs = elem\a\xs" by (induct xs) auto qed text \@{verbatim \ any ((==) a) ==> elem a\ } \ lemma "any\(eq\(a::'a::Eq_sym)) = elem\a" proof (rule cfun_eqI) fix xs show "any\(eq\a)\xs = elem\a\xs" by (induct xs) (auto simp: eq_sym) qed text \@{verbatim \any (a ==) ==> elem a\ } \ lemma "any\(\ z. eq\(a::'a::Eq_sym)\z) = elem\a" proof (rule cfun_eqI) fix xs show "any\(\ z. eq\a\z)\xs = elem\a\xs" by (induct xs) (auto simp: eq_sym) qed text \@{verbatim \ all (/= a) ==> notElem a\ } \ lemma "all\(\ z. neq\z\(a::'a::Eq_sym)) = notElem\a" proof (rule cfun_eqI) fix xs show "all\(\ z. neq\z\a)\xs = notElem\a\xs" by (induct xs) auto qed text \@{verbatim \ all (a /=) ==> notElem a\ } \ lemma "all\(\ z. neq\(a::'a::Eq_sym)\z) = notElem\a" proof (rule cfun_eqI) fix xs show "all\(\ z. neq\a\z)\xs = notElem\a\xs" by (induct xs) (auto simp: eq_sym) qed (* findIndex ((==) a) ==> elemIndex a *) (* findIndex (a ==) ==> elemIndex a *) (* findIndex (== a) ==> elemIndex a *) (* findIndices ((==) a) ==> elemIndices a *) (* findIndices (a ==) ==> elemIndices a *) (* findIndices (== a) ==> elemIndices a *) (* lookup b (zip l [0..]) ==> elemIndex b l *) subsection \Folds\ (* foldr (>>) (return ()) ==> sequence_ *) text \@{verbatim \ foldr (&&) True ==> and\ } \ lemma "foldr\trand\TT = the_and" by (subst the_and.simps, rule) text \@{verbatim \ foldl (&&) True ==> and\ } \ lemma foldl_to_and:"foldl\trand\TT \ the_and" proof (rule cfun_belowI) fix xs show "foldl\trand\TT\xs \ the_and\xs" by (cases "finite_list xs") (auto simp: foldl_assoc_foldr foldl_spine_strict) qed text \@{verbatim \ foldr1 (&&) ==> and\ } \ lemma "foldr1\trand \ the_and" proof (rule cfun_belowI) fix xs show "foldr1\trand\xs \ the_and\xs" proof (induct xs) case (Cons y ys) then show ?case by (cases ys) (auto elim: monofun_cfun_arg) qed simp+ qed text \@{verbatim \ foldl1 (&&) ==> and\ } \ lemma "foldl1\trand \ the_and" proof (rule cfun_belowI) fix x have "foldl1\trand\x \ foldl\trand\TT\x" by (cases x, auto) also have "... \ the_and\x" by (rule monofun_cfun_fun[OF foldl_to_and]) finally show "foldl1\trand\x \ the_and\x" . qed text \@{verbatim \ foldr (||) False ==> or\ } \ lemma "foldr\tror\FF = the_or" by (subst the_or.simps, rule) text \@{verbatim \ foldl (||) False ==> or\ } \ lemma foldl_to_or: "foldl\tror\FF \ the_or" proof (rule cfun_belowI) fix xs show "foldl\tror\FF\xs \ the_or\xs" by (cases "finite_list xs") (auto simp: foldl_assoc_foldr foldl_spine_strict) qed text \@{verbatim \ foldr1 (||) ==> or\ } \ lemma "foldr1\tror \ the_or" proof (rule cfun_belowI) fix xs show "foldr1\tror\xs \ the_or\xs" proof (induct xs) case (Cons y ys) then show ?case by (cases ys) (auto elim: monofun_cfun_arg) qed simp+ qed text \@{verbatim \ foldl1 (||) ==> or\ } \ lemma "foldl1\tror \ the_or" proof(rule cfun_belowI) fix x have "foldl1\tror\x \ foldl\tror\FF\x" by (cases x, auto) also have "... \ the_or\x" by (rule monofun_cfun_fun[OF foldl_to_or]) finally show "foldl1\tror\x \ the_or\x" . qed (* foldl (+) 0 ==> sum *) (* foldr (+) 0 ==> sum *) (* foldl1 (+) ==> sum *) (* foldr1 (+) ==> sum *) (* foldl ( * ) 1 ==> product *) (* foldr ( * ) 1 ==> product *) (* foldl1 ( * ) ==> product *) (* foldr1 ( * ) ==> product *) (* foldl1 max ==> maximum *) (* foldr1 max ==> maximum *) (* foldl1 min ==> minimum *) (* foldr1 min ==> minimum *) (* foldr mplus mzero ==> msum *) subsection \Function\ text \@{verbatim \ (\x -> x) ==> id\ } \ lemma "(\ x. x) = ID" by (metis ID_def) text \@{verbatim \ (\x y -> x) ==> const\ } \ lemma "(\ x y. x) = const" by (intro cfun_eqI) simp text \@{verbatim \(\(x,y) -> y) ==> fst where _ = notIn x y\ } \ lemma "(\ \x, y\. x) = fst" proof (rule cfun_eqI) fix p show "(case p of \x, y\ \ x) = fst \ p" proof (cases p) case bottom then show ?thesis by simp next case Tuple2 then show ?thesis by simp qed qed text \@{verbatim \(\(x,y) -> y) ==> snd where _ = notIn x y\ } \ lemma "(\ \x, y\. y) = snd" proof (rule cfun_eqI) fix p show "(case p of \x, y\ \ y) = snd \ p" proof (cases p) case bottom then show ?thesis by simp next case Tuple2 then show ?thesis by simp qed qed text \@{verbatim \ (\x y-> f (x,y)) ==> curry f where _ = notIn [x,y] f\ } \ lemma "(\ x y. f\\x, y\) = curry\f" by (auto intro!: cfun_eqI) text \@{verbatim \ (\(x,y) -> f x y) ==> uncurry f where _ = notIn [x,y] f\ } \ lemma "(\ \x, y\. f\x\y) \ uncurry\f" by (rule cfun_belowI, rename_tac x, case_tac x, auto) (* (($) . f) ==> f *) (* (f $) ==> f *) text \@{verbatim \ (\x -> y) ==> const y where _ = isAtom y && notIn x y\ } \ lemma "(\ x. y) = const\y" by (intro cfun_eqI) simp (* flip f x y ==> f y x where _ = isApp original *) lemma "flip\f\x\y = f\y\x" by simp (* (\a b -> o (f a) (f b)) ==> o `Data.Function.on` f *) (* -- CHAR *) (* a >= 'a' && a <= 'z' ==> isAsciiLower a *) (* a >= 'A' && a <= 'Z' ==> isAsciiUpper a *) (* a >= '0' && a <= '9' ==> isDigit a *) (* a >= '0' && a <= '7' ==> isOctDigit a *) (* not (isControl a) ==> isPrint a *) (* isLower a || isUpper a ==> isAlpha a *) (* isAlpha a || isDigit a ==> isAlphaNum a *) subsection \Bool\ text \@{verbatim \ a == True ==> a\ } \ lemma eq_true:"eq\x\TT = x" by (cases x, auto) text \@{verbatim \ a == False ==> not a\ } \ lemma eq_false:"eq\x\FF = neg\x" by (cases x, auto) text \@{verbatim \ (if a then x else x) ==> x where note = "reduces strictness"\ } \ lemma if_equal:"(If a then x else x) \ x" by (cases a, auto) text \@{verbatim \ (if a then True else False) ==> a\ } \ lemma "(If a then TT else FF) = a" by (cases a, auto) text \@{verbatim \ (if a then False else True) ==> not a\ } \ lemma "(If a then FF else TT) = neg\a" by (cases a, auto) text \@{verbatim \ (if a then t else (if b then t else f)) ==> if a || b then t else f\ } \ lemma "(If a then t else (If b then t else f)) = (If a orelse b then t else f)" by (cases a, auto) text \@{verbatim \ (if a then (if b then t else f) else f) ==> if a && b then t else f\ } \ lemma "(If a then (If b then t else f) else f) = (If a andalso b then t else f)" by (cases a, auto) text \@{verbatim \ (if x then True else y) ==> x || y where _ = notEq y False\ } \ lemma "(If x then TT else y) = (x orelse y)" by (cases x, auto) text \@{verbatim \ (if x then y else False) ==> x && y where _ = notEq y True\ } \ lemma "(If x then y else FF) = (x andalso y)" by (cases x, auto) (* case a of {True -> t; False -> f} ==> if a then t else f *) (* case a of {False -> f; True -> t} ==> if a then t else f *) (* case a of {True -> t; _ -> f} ==> if a then t else f *) (* case a of {False -> f; _ -> t} ==> if a then t else f *) text \@{verbatim \ (if c then (True, x) else (False, x)) ==> (c, x) where note = "reduces strictness"\ } \ lemma "(If c then \TT, x\ else \FF, x\) \ \c, x\" by (cases c, auto) text \@{verbatim \ (if c then (False, x) else (True, x)) ==> (not c, x) where note = "reduces strictness"\ } \ lemma "(If c then \FF, x\ else \TT, x\) \ \neg\c, x\" by (cases c, auto) text \@{verbatim \ or [x,y] ==> x || y\ } \ lemma "the_or\[x, y] = (x orelse y)" by (fixrec_simp) text \@{verbatim \ or [x,y,z] ==> x || y || z\ } \ lemma "the_or\[x, y, z] = (x orelse y orelse z)" by (fixrec_simp) text \@{verbatim \ and [x,y] ==> x && y\ } \ lemma "the_and\[x, y] = (x andalso y)" by (fixrec_simp) text \@{verbatim \ and [x,y,z] ==> x && y && z\ } \ lemma "the_and\[x, y, z] = (x andalso y andalso z)" by (fixrec_simp) subsection \Arrow\ (* id *** g ==> second g *) (* f *** id ==> first f *) (* zip (map f x) (map g x) ==> map (f Control.Arrow.&&& g) x *) (* (\(x,y) -> (f x, g y)) ==> f Control.Arrow.*** g where _ = notIn [x,y] [f,g] *) (* (\x -> (f x, g x)) ==> f Control.Arrow.&&& g where _ = notIn x [f,g] *) (* (\(x,y) -> (f x,y)) ==> Control.Arrow.first f where _ = notIn [x,y] f *) (* (\(x,y) -> (x,f y)) ==> Control.Arrow.second f where _ = notIn [x,y] f *) (* (f (fst x), g (snd x)) ==> (f Control.Arrow.*** g) x *) text \@{verbatim \ (fst x, snd x) ==> x\ } \ lemma "x \ \fst\x, snd\x\" by (cases x, auto) (* -- FUNCTOR *) (* fmap f (fmap g x) ==> fmap (f . g) x *) (* fmap id ==> id *) (* -- MONAD *) (* return a >>= f ==> f a *) (* m >>= return ==> m *) (* m >>= return . f ==> Control.Monad.liftM f m -- cannot be fmap, because is in Functor not Monad *) (* (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) *) (* (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y *) (* (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) *) (* (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y *) (* sequence (map f x) ==> mapM f x *) (* sequence_ (map f x) ==> mapM_ f x *) (* flip mapM ==> Control.Monad.forM *) (* flip mapM_ ==> Control.Monad.forM_ *) (* flip forM ==> mapM *) (* flip forM_ ==> mapM_ *) (* when (not x) ==> unless x *) (* x >>= id ==> Control.Monad.join x *) (* liftM f (liftM g x) ==> liftM (f . g) x *) (* a >> return () ==> void a *) (* fmap (const ()) ==> void *) (* flip (>=>) ==> (<=<) *) (* flip (<=<) ==> (>=>) *) (* (\x -> f x >>= g) ==> f Control.Monad.>=> g where _ = notIn x [f,g] *) (* (\x -> f =<< g x) ==> f Control.Monad.<=< g where _ = notIn x [f,g] *) (* a >> forever a ==> forever a *) (* liftM2 id ==> ap *) (* -- MONAD LIST *) (* liftM unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x *) (* sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y *) (* sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y *) (* sequence (replicate n x) ==> Control.Monad.replicateM n x *) (* sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x *) (* mapM f (map g x) ==> mapM (f . g) x *) (* mapM_ f (map g x) ==> mapM_ (f . g) x *) (* -- APPLICATIVE / TRAVERSABLE *) (* flip traverse ==> for *) (* flip for ==> traverse *) (* flip traverse_ ==> for_ *) (* flip for_ ==> traverse_ *) (* foldr ( *>) (pure ()) ==> sequenceA_ *) (* foldr (<|>) empty ==> asum *) (* liftA2 (flip ($)) ==> (<**>) *) (* Just <$> a <|> pure Nothing ==> optional a *) (* -- LIST COMP *) (* (if b then [x] else []) ==> [x | b] *) (* [x | x <- y] ==> y where _ = isVar x *) (* -- SEQ *) subsection \Seq\ text \@{verbatim \ x `seq` x ==> x\ } \ lemma "seq\x\x = x" by (simp add: seq_def) (* id $! x ==> x *) (* x `seq` y ==> y where _ = isWHNF x *) (* f $! x ==> f x where _ = isWHNF x *) (* evaluate x ==> return x where _ = isWHNF x *) (* -- MAYBE *) (* maybe x id ==> Data.Maybe.fromMaybe x *) (* maybe False (const True) ==> Data.Maybe.isJust *) (* maybe True (const False) ==> Data.Maybe.isNothing *) (* not (isNothing x) ==> isJust x *) (* not (isJust x) ==> isNothing x *) (* maybe [] (:[]) ==> maybeToList *) (* catMaybes (map f x) ==> mapMaybe f x *) (* (case x of Nothing -> y; Just a -> a) ==> fromMaybe y x *) (* (if isNothing x then y else f (fromJust x)) ==> maybe y f x *) (* (if isJust x then f (fromJust x) else y) ==> maybe y f x *) (* maybe Nothing (Just . f) ==> fmap f *) (* map fromJust . filter isJust ==> Data.Maybe.catMaybes *) (* x == Nothing ==> isNothing x *) (* Nothing == x ==> isNothing x *) (* x /= Nothing ==> Data.Maybe.isJust x *) (* Nothing /= x ==> Data.Maybe.isJust x *) (* concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f *) (* concatMap maybeToList ==> catMaybes *) (* maybe n Just x ==> Control.Monad.mplus x n *) (* (case x of Just a -> a; Nothing -> y) ==> fromMaybe y x *) (* (if isNothing x then y else fromJust x) ==> fromMaybe y x *) (* (if isJust x then fromJust x else y) ==> fromMaybe y x *) (* isJust x && (fromJust x == y) ==> x == Just y *) (* mapMaybe f (map g x) ==> mapMaybe (f . g) x *) (* fromMaybe a (fmap f x) ==> maybe a f x *) (* [x | Just x <- a] ==> Data.Maybe.catMaybes a *) (* -- EITHER *) (* [a | Left a <- a] ==> lefts a *) (* [a | Right a <- a] ==> rights a *) (* -- INFIX *) (* X.elem x y ==> x `X.elem` y where _ = not (isInfixApp original) && not (isParen result) *) (* X.notElem x y ==> x `X.notElem` y where _ = not (isInfixApp original) && not (isParen result) *) (* X.isInfixOf x y ==> x `X.isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) *) (* X.isSuffixOf x y ==> x `X.isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) *) (* X.isPrefixOf x y ==> x `X.isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) *) (* X.union x y ==> x `X.union` y where _ = not (isInfixApp original) && not (isParen result) *) (* X.intersect x y ==> x `X.intersect` y where _ = not (isInfixApp original) && not (isParen result) *) (* -- MATHS *) (* fromIntegral x ==> x where _ = isLitInt x *) (* fromInteger x ==> x where _ = isLitInt x *) (* x + negate y ==> x - y *) (* 0 - x ==> negate x *) (* log y / log x ==> logBase x y *) (* x ** 0.5 ==> sqrt x *) (* sin x / cos x ==> tan x *) (* sinh x / cosh x ==> tanh x *) (* n `rem` 2 == 0 ==> even n *) (* n `rem` 2 /= 0 ==> odd n *) (* not (even x) ==> odd x *) (* not (odd x) ==> even x *) (* x ** 0.5 ==> sqrt x *) (* x ^^ y ==> x ** y where _ = isLitInt y *) (* x ^ 0 ==> 1 *) (* round (x - 0.5) ==> floor x *) (* -- CONCURRENT *) (* mapM_ (writeChan a) ==> writeList2Chan a *) (* -- EXCEPTION *) (* Prelude.catch ==> Control.Exception.catch where note = "Prelude.catch does not catch most exceptions" *) (* flip Control.Exception.catch ==> handle *) (* flip handle ==> Control.Exception.catch *) (* flip (catchJust p) ==> handleJust p *) (* flip (handleJust p) ==> catchJust p *) (* Control.Exception.bracket b (const a) (const t) ==> Control.Exception.bracket_ b a t *) (* Control.Exception.bracket (openFile x y) hClose ==> withFile x y *) (* Control.Exception.bracket (openBinaryFile x y) hClose ==> withBinaryFile x y *) (* throw (ErrorCall a) ==> error a *) (* a `seq` return a ==> Control.Exception.evaluate a *) (* toException NonTermination ==> nonTermination *) (* toException NestedAtomically ==> nestedAtomically *) (* -- WEAK POINTERS *) (* mkWeak a a b ==> mkWeakPtr a b *) (* mkWeak a (a, b) c ==> mkWeakPair a b c *) subsection \Evaluate\ text \@{verbatim \ True && x ==> x\ } \ lemma "(TT andalso x) = x" by auto text \@{verbatim \ False && x ==> False\ } \ lemma "(FF andalso x) = FF" by auto text \@{verbatim \ True || x ==> True\ } \ lemma "(TT orelse x) = TT" by auto text \@{verbatim \ False || x ==> x\ } \ lemma "(FF orelse x) = x" by auto text \@{verbatim \ not True ==> False\ } \ lemma "neg\TT = FF" by auto text \@{verbatim \ not False ==> True\ } \ lemma "neg\FF = TT" by auto (* Nothing >>= k ==> Nothing *) (* either f g (Left x) ==> f x *) (* either f g (Right y) ==> g y *) text \@{verbatim \ fst (x,y) ==> x\ } \ lemma "fst\\x, y\ = x" by auto text \@{verbatim \ snd (x,y) ==> y\ } \ lemma "snd\\x, y\ = y" by auto text \@{verbatim \ f (fst p) (snd p) ==> uncurry f p\ } \ lemma "f\(fst\p)\(snd\p) = uncurry\f\p" by (cases p, auto) text \@{verbatim \ init [x] ==> []\ } \ lemma "init\[x] = []" by auto text \@{verbatim \ null [] ==> True\ } \ lemma "null\[] = TT" by auto text \@{verbatim \ length [] ==> 0\ } \ lemma "length\[] = 0" by auto text \@{verbatim \ foldl f z [] ==> z\ } \ lemma "foldl\f\z\[] = z" by simp text \@{verbatim \ foldr f z [] ==> z\ } \ lemma "foldr\f\z\[] = z" by auto text \@{verbatim \ foldr1 f [x] ==> x\ } \ lemma "foldr1\f\[x] = x" by simp text \@{verbatim \ scanr f z [] ==> [z]\ } \ lemma "scanr\f\z\[] = [z]" by simp text \@{verbatim \ scanr1 f [] ==> []\ } \ lemma "scanr1\f\[] = []" by simp text \@{verbatim \ scanr1 f [x] ==> [x]\ } \ lemma "scanr1\f\[x] = [x]" by simp text \@{verbatim \ take n [] ==> []\ } \ lemma "take\n\[] \ []" by (cases n, auto) text \@{verbatim \ drop n [] ==> []\ } \ lemma "drop\n\[] \ []" by (subst drop.simps) (auto simp: if_equal) text \@{verbatim \ takeWhile p [] ==> []\ } \ lemma "takeWhile\p\[] = []" by (fixrec_simp) text \@{verbatim \ dropWhile p [] ==> []\ } \ lemma "dropWhile\p\[] = []" by (fixrec_simp) text \@{verbatim \ span p [] ==> ([],[])\ } \ lemma "span\p\[] = \[], []\" by (fixrec_simp) (* lines "" ==> [] *) (* unwords [] ==> "" *) (* x - 0 ==> x *) (* x * 1 ==> x *) (* x / 1 ==> x *) text \@{verbatim \ concat [a] ==> a\ } \ lemma "concat\[a] = a" by auto text \@{verbatim \ concat [] ==> []\ } \ lemma "concat\[] = []" by auto text \@{verbatim \ zip [] [] ==> []\ } \ lemma "zip\[]\[] = []" by auto text \@{verbatim \ id x ==> x\ } \ lemma "ID\x = x" by auto text \@{verbatim \ const x y ==> x\ } \ lemma "const\x\y = x" by simp subsection \Complex hints\ text \@{verbatim \ take (length t) s == t ==> t `Data.List.isPrefixOf` s\ } \ lemma fixes t :: "['a::Eq_sym]" shows "eq\(take\(length\t)\s)\t \ isPrefixOf\t\s" by (subst eq_sym) (rule eq_take_length_isPrefixOf) text \@{verbatim \ (take i s == t) ==> _eval_ ((i >= length t) && (t `Data.List.isPrefixOf` s))\ } \ text \The hint is not true in general, as the following two lemmas show:\ lemma assumes "t = []" and "s = x : xs" and "i = 1" shows "\ (eq\(take\i\s)\t \ (le\(length\t)\i andalso isPrefixOf\t\s))" using assms by simp lemma assumes "le\0\i = TT" and "le\i\0 = FF" and "s = \" and "t = []" shows "\ ((le\(length\t)\i andalso isPrefixOf\t\s) \ eq\(take\i\s)\t)" using assms by (subst take.simps) simp (* -- clever hint, but not actually a good idea *) (* (do a <- f; g a) ==> f >>= g *) (* a $$$$ b $$$$ c ==> a . b $$$$$ c *) (* not (a == b) ==> a /= b *) lemma "neg\(eq\a\b) = neq\a\b" by auto text \@{verbatim \not (a /= b) ==> a == b\ } \ lemma "neg\(neq\a\b) = eq\a\b" by auto text \@{verbatim \map id ==> id\ } \ lemma map_id:"map\ID = ID" by (auto simp add: cfun_eq_iff) text \@{verbatim \x == [] ==> null x\ } \ lemma "eq\x\[] = null\x" by (cases x, auto) text \@{verbatim \any id ==> or\ } \ lemma "any\ID = the_or" by (auto simp add:map_id) text \@{verbatim \all id ==> and\ } \ lemma "all\ID = the_and" by (auto simp add:map_id) text \@{verbatim \(if x then False else y) ==> (not x && y)\ } \ lemma "(If x then FF else y) = (neg\x andalso y)" by (cases x, auto) text \@{verbatim \(if x then y else True) ==> (not x || y)\ } \ lemma "(If x then y else TT) = (neg\x orelse y)" by (cases x, auto) text \@{verbatim \not (not x) ==> x\ } \ lemma "neg\(neg\x) = x" by auto text \@{verbatim \(if c then f x else f y) ==> f (if c then x else y)\ } \ lemma "(If c then f\x else f\y) \ f\(If c then x else y)" by (cases c, auto) text \@{verbatim \(\ x -> [x]) ==> (: [])\ } \ lemma "(\ x. [x]) = (\ z. z : [])" by auto text \@{verbatim \True == a ==> a\ } \ lemma "eq\TT\a = a" by (cases a, auto) text \@{verbatim \False == a ==> not a\ } \ lemma "eq\FF\a = neg\a" by (cases a, auto) text \@{verbatim \a /= True ==> not a\ } \ lemma "neq\a\TT = neg\a" by (cases a, auto) text \@{verbatim \a /= False ==> a\ } \ lemma "neq\a\FF = a" by (cases a, auto) text \@{verbatim \True /= a ==> not a\ } \ lemma "neq\TT\a = neg\a" by (cases a, auto) text \@{verbatim \False /= a ==> a\ } \ lemma "neq\FF\a = a" by (cases a, auto) text \@{verbatim \not (isNothing x) ==> isJust x\ } \ lemma "neg\(isNothing\x) = isJust\x" by auto text \@{verbatim \not (isJust x) ==> isNothing x\ } \ lemma "neg\(isJust\x) = isNothing\x" by auto text \@{verbatim \x == Nothing ==> isNothing x\ } \ lemma "eq\x\Nothing = isNothing\x" by (cases x, auto) text \@{verbatim \Nothing == x ==> isNothing x\ } \ lemma "eq\Nothing\x = isNothing\x" by (cases x, auto) text \@{verbatim \x /= Nothing ==> Data.Maybe.isJust x\ } \ lemma "neq\x\Nothing = isJust\x" by (cases x, auto) text \@{verbatim \Nothing /= x ==> Data.Maybe.isJust x\ } \ lemma "neq\Nothing\x = isJust\x" by (cases x, auto) text \@{verbatim \(if isNothing x then y else fromJust x) ==> fromMaybe y x\ } \ lemma "(If isNothing\x then y else fromJust\x) = fromMaybe\y\x" by (cases x, auto) text \@{verbatim \(if isJust x then fromJust x else y) ==> fromMaybe y x\ } \ lemma "(If isJust\x then fromJust\x else y) = fromMaybe\y\x" by (cases x, auto) text \@{verbatim \(isJust x && (fromJust x == y)) ==> x == Just y\ } \ lemma "(isJust\x andalso (eq\(fromJust\x)\y)) = eq\x\(Just\y)" by (cases x, auto) text \@{verbatim \elem True ==> or\ } \ lemma "elem\TT = the_or" proof (rule cfun_eqI) fix xs show "elem\TT\xs = the_or\xs" by (induct xs) (auto simp: eq_true) qed text \@{verbatim \notElem False ==> and\ } \ lemma "notElem\FF = the_and" proof (rule cfun_eqI) fix xs show "notElem\FF\xs = the_and\xs" by (induct xs) (auto simp: eq_false) qed text \@{verbatim \all ((/=) a) ==> notElem a\ } \ lemma "all\(neq\(a::'a::Eq_sym)) = notElem\a" proof (rule cfun_eqI) fix xs show "all\(neq\a)\xs = notElem\a\xs" by (induct xs) (auto simp: eq_sym) qed text \@{verbatim \maybe x id ==> Data.Maybe.fromMaybe x\ } \ lemma "maybe\x\ID = fromMaybe\x" proof (rule cfun_eqI) fix xs show "maybe\x\ID\xs = fromMaybe\x\xs" by (cases xs) auto qed text \@{verbatim \maybe False (const True) ==> Data.Maybe.isJust\ } \ lemma "maybe\FF\(const\TT) = isJust" proof (rule cfun_eqI) fix x :: "'a Maybe" show "maybe\FF\(const\TT)\x = isJust\x" by (cases x) simp+ qed text \@{verbatim \maybe True (const False) ==> Data.Maybe.isNothing\ } \ lemma "maybe\TT\(const\FF) = isNothing" proof (rule cfun_eqI) fix x :: "'a Maybe" show "maybe\TT\(const\FF)\x = isNothing\x" by (cases x) simp+ qed text \@{verbatim \maybe [] (: []) ==> maybeToList\ } \ lemma "maybe\[]\(\ z. z : []) = maybeToList" proof (rule cfun_eqI) fix x :: "'a Maybe" show "maybe\[]\(\ z. z : [])\x = maybeToList\x" by (cases x) simp+ qed text \@{verbatim \catMaybes (map f x) ==> mapMaybe f x\ } \ lemma "catMaybes\(map\f\x) = mapMaybe\f\x" by auto text \@{verbatim \(if isNothing x then y else f (fromJust x)) ==> maybe y f x\ } \ lemma "(If isNothing\x then y else f\(fromJust\x)) = maybe\y\f\x" by (cases x, auto) text \@{verbatim \(if isJust x then f (fromJust x) else y) ==> maybe y f x\ } \ lemma "(If isJust\x then f\(fromJust\x) else y) = maybe\y\f\x" by (cases x, auto) text \@{verbatim \(map fromJust . filter isJust) ==> Data.Maybe.catMaybes\ } \ lemma "(map\fromJust oo filter\isJust) = catMaybes" proof (rule cfun_eqI) fix xs :: "['a Maybe]" show "(map\fromJust oo filter\isJust)\xs = catMaybes\xs" proof (induct xs) case (Cons y ys) then show ?case by (cases y) simp+ qed simp+ qed text \@{verbatim \concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f\ } \ lemma "concatMap\(maybeToList oo f) = mapMaybe\f" proof (rule cfun_eqI) fix xs show "concatMap\(maybeToList oo f)\xs = mapMaybe\f\xs" by (induct xs) auto qed text \@{verbatim \concatMap maybeToList ==> catMaybes\ } \ lemma "concatMap\maybeToList = catMaybes" by auto text \@{verbatim \mapMaybe f (map g x) ==> mapMaybe (f . g) x\ } \ lemma "mapMaybe\f\(map\g\x) = mapMaybe\(f oo g)\x" by auto text \@{verbatim \(($) . f) ==> f\ } \ lemma "(dollar oo f) = f" by (auto simp add:cfun_eq_iff) text \@{verbatim \(f $) ==> f\ } \ lemma "(\ z. dollar\f\z) = f" by (auto simp add:cfun_eq_iff) text \@{verbatim \(\ a b -> g (f a) (f b)) ==> g `Data.Function.on` f\ } \ lemma "(\ a b. g\(f\a)\(f\b)) = on\g\f" by (auto simp add:cfun_eq_iff) text \@{verbatim \id $! x ==> x\ } \ lemma "dollarBang\ID\x = x" by (auto simp add:seq_def) text \@{verbatim \[x | x <- y] ==> y\ } \ lemma "[x | x <- y] = y" by (induct y, auto) text \@{verbatim \isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y\ } \ lemma "isPrefixOf\(reverse\x)\(reverse\y) = isSuffixOf\x\y" by auto text \@{verbatim \concat (intersperse x y) ==> intercalate x y\ } \ lemma "concat\(intersperse\x\y) = intercalate\x\y" by auto text \@{verbatim \x `seq` y ==> y\ } \ lemma assumes "x \ \" shows "seq\x\y = y" using assms by (simp add: seq_def) text \@{verbatim \f $! x ==> f x\ } \ lemma assumes "x \ \" shows "dollarBang\f\x = f\x" using assms by (simp add: seq_def) text \@{verbatim \maybe (f x) (f . g) ==> (f . maybe x g)\ } \ lemma "maybe\(f\x)\(f oo g) \ (f oo maybe\x\g)" proof (rule cfun_belowI) fix y show "maybe\(f\x)\(f oo g)\y \ (f oo maybe\x\g)\y" by (cases y) auto qed end diff --git a/thys/IEEE_Floating_Point/IEEE.thy b/thys/IEEE_Floating_Point/IEEE.thy --- a/thys/IEEE_Floating_Point/IEEE.thy +++ b/thys/IEEE_Floating_Point/IEEE.thy @@ -1,475 +1,475 @@ (* Formalization of IEEE-754 Standard for binary floating-point arithmetic *) (* Author: Lei Yu, University of Cambridge Contrib: Peter Lammich: fixed wrong sign handling in fmadd *) section \Specification of the IEEE standard\ theory IEEE imports "HOL-Library.Float" Word_Lib.Word_Lemmas begin typedef (overloaded) ('e::len, 'f::len) float = "UNIV::(1 word \ 'e word \ 'f word) set" by auto setup_lifting type_definition_float syntax "_float" :: "type \ type \ type" ("'(_, _') float") text \parse \('a, 'b) float\ as ('a::len, 'b::len) float.\ parse_translation \ let fun float t u = Syntax.const @{type_syntax float} $ t $ u; fun len_tr u = (case Term_Position.strip_positions u of v as Free (x, _) => if Lexicon.is_tid x then (Syntax.const @{syntax_const "_ofsort"} $ v $ Syntax.const @{class_syntax len}) else u | _ => u) fun len_float_tr [t, u] = float (len_tr t) (len_tr u) in [(@{syntax_const "_float"}, K len_float_tr)] end \ subsection \Derived parameters for floating point formats\ definition wordlength :: "('e, 'f) float itself \ nat" where "wordlength x = LENGTH('e) + LENGTH('f) + 1" definition bias :: "('e, 'f) float itself \ nat" where "bias x = 2^(LENGTH('e) - 1) - 1" definition emax :: "('e, 'f) float itself \ nat" where "emax x = unat (- 1::'e word)" abbreviation fracwidth::"('e, 'f) float itself \ nat" where "fracwidth _ \ LENGTH('f)" subsection \Predicates for the four IEEE formats\ definition is_single :: "('e, 'f) float itself \ bool" where "is_single x \ LENGTH('e) = 8 \ wordlength x = 32" definition is_double :: "('e, 'f) float itself \ bool" where "is_double x \ LENGTH('e) = 11 \ wordlength x = 64" definition is_single_extended :: "('e, 'f) float itself \ bool" where "is_single_extended x \ LENGTH('e) \ 11 \ wordlength x \ 43" definition is_double_extended :: "('e, 'f) float itself \ bool" where "is_double_extended x \ LENGTH('e) \ 15 \ wordlength x \ 79" subsection \Extractors for fields\ lift_definition sign::"('e, 'f) float \ nat" is "\(s::1 word, _::'e word, _::'f word). unat s" . lift_definition exponent::"('e, 'f) float \ nat" is "\(_, e::'e word, _). unat e" . lift_definition fraction::"('e, 'f) float \ nat" is "\(_, _, f::'f word). unat f" . abbreviation "real_of_word x \ real (unat x)" lift_definition valof :: "('e, 'f) float \ real" is "\(s, e, f). let x = (TYPE(('e, 'f) float)) in (if e = 0 then (-1::real)^(unat s) * (2 / (2^bias x)) * (real_of_word f/2^(LENGTH('f))) else (-1::real)^(unat s) * ((2^(unat e)) / (2^bias x)) * (1 + real_of_word f/2^LENGTH('f)))" . subsection \Partition of numbers into disjoint classes\ definition is_nan :: "('e, 'f) float \ bool" where "is_nan a \ exponent a = emax TYPE(('e, 'f)float) \ fraction a \ 0" definition is_infinity :: "('e, 'f) float \ bool" where "is_infinity a \ exponent a = emax TYPE(('e, 'f)float) \ fraction a = 0" definition is_normal :: "('e, 'f) float \ bool" where "is_normal a \ 0 < exponent a \ exponent a < emax TYPE(('e, 'f)float)" definition is_denormal :: "('e, 'f) float \ bool" where "is_denormal a \ exponent a = 0 \ fraction a \ 0" definition is_zero :: "('e, 'f) float \ bool" where "is_zero a \ exponent a = 0 \ fraction a = 0" definition is_finite :: "('e, 'f) float \ bool" where "is_finite a \ (is_normal a \ is_denormal a \ is_zero a)" subsection \Special values\ lift_definition plus_infinity :: "('e, 'f) float" ("\") is "(0, - 1, 0)" . lift_definition topfloat :: "('e, 'f) float" is "(0, - 2, 2^LENGTH('f) - 1)" . instantiation float::(len, len) zero begin lift_definition zero_float :: "('e, 'f) float" is "(0, 0, 0)" . instance proof qed end subsection \Negation operation on floating point values\ instantiation float::(len, len) uminus begin lift_definition uminus_float :: "('e, 'f) float \ ('e, 'f) float" is "\(s, e, f). (1 - s, e, f)" . instance proof qed end abbreviation (input) "minus_zero \ - (0::('e, 'f)float)" abbreviation (input) "minus_infinity \ - \" abbreviation (input) "bottomfloat \ - topfloat" subsection \Real number valuations\ text \The largest value that can be represented in floating point format.\ definition largest :: "('e, 'f) float itself \ real" where "largest x = (2^(emax x - 1) / 2^bias x) * (2 - 1/(2^fracwidth x))" text \Threshold, used for checking overflow.\ definition threshold :: "('e, 'f) float itself \ real" where "threshold x = (2^(emax x - 1) / 2^bias x) * (2 - 1/(2^(Suc(fracwidth x))))" text \Unit of least precision.\ lift_definition one_lp::"('e ,'f) float \ ('e ,'f) float" is "\(s, e, f). (0, e::'e word, 1)" . lift_definition zero_lp::"('e ,'f) float \ ('e ,'f) float" is "\(s, e, f). (0, e::'e word, 0)" . definition ulp :: "('e, 'f) float \ real" where "ulp a = valof (one_lp a) - valof (zero_lp a)" text \Enumerated type for rounding modes.\ datatype roundmode = roundNearestTiesToEven | roundNearestTiesToAway | roundTowardPositive | roundTowardNegative | roundTowardZero abbreviation (input) "RNE \ roundNearestTiesToEven" abbreviation (input) "RNA \ roundNearestTiesToAway" abbreviation (input) "RTP \ roundTowardPositive" abbreviation (input) "RTN \ roundTowardNegative" -abbreviation (input) "RNZ \ roundTowardZero" +abbreviation (input) "RTZ \ roundTowardZero" subsection \Rounding\ text \Characterization of best approximation from a set of abstract values.\ definition "is_closest v s x a \ a \ s \ (\b. b \ s \ \v a - x\ \ \v b - x\)" text \Best approximation with a deciding preference for multiple possibilities.\ definition "closest v p s x = (SOME a. is_closest v s x a \ ((\b. is_closest v s x b \ p b) \ p a))" fun round :: "roundmode \ real \ ('e ,'f) float" where "round roundNearestTiesToEven y = (if y \ - threshold TYPE(('e ,'f) float) then minus_infinity else if y \ threshold TYPE(('e ,'f) float) then plus_infinity else closest (valof) (\a. even (fraction a)) {a. is_finite a} y)" (*FIXME: broken, especially if both nearest are odd*) | "round roundNearestTiesToAway y = (if y \ - threshold TYPE(('e ,'f) float) then minus_infinity else if y \ threshold TYPE(('e ,'f) float) then plus_infinity else closest (valof) (\a. True) {a. is_finite a \ \valof a\ \ \y\} y)" | "round roundTowardPositive y = (if y < - largest TYPE(('e ,'f) float) then bottomfloat else if y > largest TYPE(('e ,'f) float) then plus_infinity else closest (valof) (\a. True) {a. is_finite a \ valof a \ y} y)" | "round roundTowardNegative y = (if y < - largest TYPE(('e ,'f) float) then minus_infinity else if y > largest TYPE(('e ,'f) float) then topfloat else closest (valof) (\a. True) {a. is_finite a \ valof a \ y} y)" | "round roundTowardZero y = (if y < - largest TYPE(('e ,'f) float) then bottomfloat else if y > largest TYPE(('e ,'f) float) then topfloat else closest (valof) (\a. True) {a. is_finite a \ \valof a\ \ \y\} y)" text \Rounding to integer values in floating point format.\ definition is_integral :: "('e ,'f) float \ bool" where "is_integral a \ is_finite a \ (\n::nat. \valof a\ = real n)" fun intround :: "roundmode \ real \ ('e ,'f) float" where "intround roundNearestTiesToEven y = (if y \ - threshold TYPE(('e ,'f) float) then minus_infinity else if y \ threshold TYPE(('e ,'f) float) then plus_infinity else closest (valof) (\a. (\n::nat. even n \ \valof a\ = real n)) {a. is_integral a} y)" | "intround roundNearestTiesToAway y = (if y \ - threshold TYPE(('e ,'f) float) then minus_infinity else if y \ threshold TYPE(('e ,'f) float) then plus_infinity else closest (valof) (\x. True) {a. is_integral a \ \valof a\ \ \y\} y)" | "intround roundTowardPositive y = (if y < - largest TYPE(('e ,'f) float) then bottomfloat else if y > largest TYPE(('e ,'f) float) then plus_infinity else closest (valof) (\x. True) {a. is_integral a \ valof a \ y} y)" | "intround roundTowardNegative y = (if y < - largest TYPE(('e ,'f) float) then minus_infinity else if y > largest TYPE(('e ,'f) float) then topfloat else closest (valof) (\x. True) {a. is_integral a \ valof a \ y} y)" | "intround roundTowardZero y = (if y < - largest TYPE(('e ,'f) float) then bottomfloat else if y > largest TYPE(('e ,'f) float) then topfloat else closest (valof) (\x. True) {a. is_integral a \ \valof a\ \ \y\} y)" text \Round, choosing between -0.0 or +0.0\ definition float_round::"roundmode \ bool \ real \ ('e, 'f) float" where "float_round mode toneg r = (let x = round mode r in if is_zero x then if toneg then minus_zero else 0 else x)" text \Non-standard of NaN.\ definition some_nan :: "('e ,'f) float" where "some_nan = (SOME a. is_nan a)" text \Coercion for signs of zero results.\ definition zerosign :: "nat \ ('e ,'f) float \ ('e ,'f) float" where "zerosign s a = (if is_zero a then (if s = 0 then 0 else - 0) else a)" text \Remainder operation.\ definition rem :: "real \ real \ real" where "rem x y = (let n = closest id (\x. \n::nat. even n \ \x\ = real n) {x. \n :: nat. \x\ = real n} (x / y) in x - n * y)" definition frem :: "roundmode \ ('e ,'f) float \ ('e ,'f) float \ ('e ,'f) float" where "frem m a b = (if is_nan a \ is_nan b \ is_infinity a \ is_zero b then some_nan else zerosign (sign a) (round m (rem (valof a) (valof b))))" subsection \Definitions of the arithmetic operations\ definition fintrnd :: "roundmode \ ('e ,'f) float \ ('e ,'f) float" where "fintrnd m a = (if is_nan a then (some_nan) else if is_infinity a then a else zerosign (sign a) (intround m (valof a)))" definition fadd :: "roundmode \ ('e ,'f) float \ ('e ,'f) float \ ('e ,'f) float" where "fadd m a b = (if is_nan a \ is_nan b \ (is_infinity a \ is_infinity b \ sign a \ sign b) then some_nan else if (is_infinity a) then a else if (is_infinity b) then b else zerosign (if is_zero a \ is_zero b \ sign a = sign b then sign a else if m = roundTowardNegative then 1 else 0) (round m (valof a + valof b)))" definition fsub :: "roundmode \ ('e ,'f) float \ ('e ,'f) float \ ('e ,'f) float" where "fsub m a b = (if is_nan a \ is_nan b \ (is_infinity a \ is_infinity b \ sign a = sign b) then some_nan else if is_infinity a then a else if is_infinity b then - b else zerosign (if is_zero a \ is_zero b \ sign a \ sign b then sign a else if m = roundTowardNegative then 1 else 0) (round m (valof a - valof b)))" definition fmul :: "roundmode \ ('e ,'f) float \ ('e ,'f) float \ ('e ,'f) float" where "fmul m a b = (if is_nan a \ is_nan b \ (is_zero a \ is_infinity b) \ (is_infinity a \ is_zero b) then some_nan else if is_infinity a \ is_infinity b then (if sign a = sign b then plus_infinity else minus_infinity) else zerosign (if sign a = sign b then 0 else 1 ) (round m (valof a * valof b)))" definition fdiv :: "roundmode \ ('e ,'f) float \ ('e ,'f) float \ ('e ,'f) float" where "fdiv m a b = (if is_nan a \ is_nan b \ (is_zero a \ is_zero b) \ (is_infinity a \ is_infinity b) then some_nan else if is_infinity a \ is_zero b then (if sign a = sign b then plus_infinity else minus_infinity) else if is_infinity b then (if sign a = sign b then 0 else - 0) else zerosign (if sign a = sign b then 0 else 1) (round m (valof a / valof b)))" definition fsqrt :: "roundmode \ ('e ,'f) float \ ('e ,'f) float" where "fsqrt m a = (if is_nan a then some_nan else if is_zero a \ is_infinity a \ sign a = 0 then a else if sign a = 1 then some_nan else zerosign (sign a) (round m (sqrt (valof a))))" definition fmul_add :: "roundmode \ ('t ,'w) float \ ('t ,'w) float \ ('t ,'w) float \ ('t ,'w) float" where "fmul_add mode x y z = (let signP = if sign x = sign y then 0 else 1; infP = is_infinity x \ is_infinity y in if is_nan x \ is_nan y \ is_nan z then some_nan else if is_infinity x \ is_zero y \ is_zero x \ is_infinity y \ is_infinity z \ infP \ signP \ sign z then some_nan else if is_infinity z \ (sign z = 0) \ infP \ (signP = 0) then plus_infinity else if is_infinity z \ (sign z = 1) \ infP \ (signP = 1) then minus_infinity else let r1 = valof x * valof y; r2 = valof z; r = r1+r2 in if r=0 then ( \ \Exact Zero Case. Same sign rules as for add apply. \ if r1=0 \ r2=0 \ signP=sign z then zerosign signP 0 else if mode = roundTowardNegative then -0 else 0 ) else ( \ \Not exactly zero: Rounding has sign of exact value, even if rounded val is zero\ zerosign (if r<0 then 1 else 0) (round mode r) ) )" subsection \Comparison operations\ datatype ccode = Gt | Lt | Eq | Und definition fcompare :: "('e ,'f) float \ ('e ,'f) float \ ccode" where "fcompare a b = (if is_nan a \ is_nan b then Und else if is_infinity a \ sign a = 1 then (if is_infinity b \ sign b = 1 then Eq else Lt) else if is_infinity a \ sign a = 0 then (if is_infinity b \ sign b = 0 then Eq else Gt) else if is_infinity b \ sign b = 1 then Gt else if is_infinity b \ sign b = 0 then Lt else if valof a < valof b then Lt else if valof a = valof b then Eq else Gt)" definition flt :: "('e ,'f) float \ ('e ,'f) float \ bool" where "flt a b \ fcompare a b = Lt" definition fle :: "('e ,'f) float \ ('e ,'f) float \ bool" where "fle a b \ fcompare a b = Lt \ fcompare a b = Eq" definition fgt :: "('e ,'f) float \ ('e ,'f) float \ bool" where "fgt a b \ fcompare a b = Gt" definition fge :: "('e ,'f) float \ ('e ,'f) float \ bool" where "fge a b \ fcompare a b = Gt \ fcompare a b = Eq" definition feq :: "('e ,'f) float \ ('e ,'f) float \ bool" where "feq a b \ fcompare a b = Eq" section \Specify float to be double precision and round to even\ instantiation float :: (len, len) plus begin definition plus_float :: "('a, 'b) float \ ('a, 'b) float \ ('a, 'b) float" where "a + b = fadd RNE a b" instance .. end instantiation float :: (len, len) minus begin definition minus_float :: "('a, 'b) float \ ('a, 'b) float \ ('a, 'b) float" where "a - b = fsub RNE a b" instance .. end instantiation float :: (len, len) times begin definition times_float :: "('a, 'b) float \ ('a, 'b) float \ ('a, 'b) float" where "a * b = fmul RNE a b" instance .. end instantiation float :: (len, len) one begin lift_definition one_float :: "('a, 'b) float" is "(0, 2^(LENGTH('a) - 1) - 1, 0)" . instance .. end instantiation float :: (len, len) inverse begin definition divide_float :: "('a, 'b) float \ ('a, 'b) float \ ('a, 'b) float" where "a div b = fdiv RNE a b" definition inverse_float :: "('a, 'b) float \ ('a, 'b) float" where "inverse_float a = fdiv RNE 1 a" instance .. end definition float_rem :: "('a, 'b) float \ ('a, 'b) float \ ('a, 'b) float" where "float_rem a b = frem RNE a b" definition float_sqrt :: "('a, 'b) float \ ('a, 'b) float" where "float_sqrt a = fsqrt RNE a" definition ROUNDFLOAT ::"('a, 'b) float \ ('a, 'b) float" where "ROUNDFLOAT a = fintrnd RNE a" instantiation float :: (len, len) ord begin definition less_float :: "('a, 'b) float \ ('a, 'b) float \ bool" where "a < b \ flt a b" definition less_eq_float :: "('a, 'b) float \ ('a, 'b) float \ bool" where "a \ b \ fle a b" instance .. end definition float_eq :: "('a, 'b) float \ ('a, 'b) float \ bool" (infixl "\" 70) where "float_eq a b = feq a b" instantiation float :: (len, len) abs begin definition abs_float :: "('a, 'b) float \ ('a, 'b) float" where "abs_float a = (if sign a = 0 then a else - a)" instance .. end text \The \1 + \\ property.\ definition normalizes :: "_ itself \ real \ bool" where "normalizes float_format x = (1/ (2::real)^(bias float_format - 1) \ \x\ \ \x\ < threshold float_format)" end diff --git a/thys/IEEE_Floating_Point/IEEE_Properties.thy b/thys/IEEE_Floating_Point/IEEE_Properties.thy --- a/thys/IEEE_Floating_Point/IEEE_Properties.thy +++ b/thys/IEEE_Floating_Point/IEEE_Properties.thy @@ -1,1026 +1,1025 @@ (* Author: Lei Yu, University of Cambridge Author: Fabian Hellauer Fabian Immler *) section \Proofs of Properties about Floating Point Arithmetic\ theory IEEE_Properties imports IEEE begin subsection \Theorems derived from definitions\ - lemma valof_eq: "valof x = (if exponent x = 0 then (- 1) ^ sign x * (2 / 2 ^ bias TYPE(('a, 'b) float)) * (real (fraction x) / 2 ^ LENGTH('b)) else (- 1) ^ sign x * (2 ^ exponent x / 2 ^ bias TYPE(('a, 'b) float)) * (1 + real (fraction x) / 2 ^ LENGTH('b)))" for x::"('a, 'b) float" unfolding Let_def by transfer (auto simp: bias_def divide_simps unat_eq_0) lemma exponent_le [simp]: \exponent a \ mask LENGTH('a)\ for a :: \('a, _) float\ by transfer (auto simp add: of_nat_mask_eq intro: word_unat_less_le split: prod.split) lemma exponent_not_less [simp]: \\ mask LENGTH('a) < IEEE.exponent a\ for a :: \('a, _) float\ by (simp add: not_less) lemma infinity_simps: "sign (plus_infinity::('e, 'f)float) = 0" "sign (minus_infinity::('e, 'f)float) = 1" "exponent (plus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)" "exponent (minus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)" "fraction (plus_infinity::('e, 'f)float) = 0" "fraction (minus_infinity::('e, 'f)float) = 0" subgoal by transfer auto subgoal by transfer auto subgoal by transfer (simp add: emax_def mask_eq_exp_minus_1) subgoal by transfer (simp add: emax_def mask_eq_exp_minus_1) subgoal by transfer auto subgoal by transfer auto done lemma zero_simps: "sign (0::('e, 'f)float) = 0" "sign (- 0::('e, 'f)float) = 1" "exponent (0::('e, 'f)float) = 0" "exponent (- 0::('e, 'f)float) = 0" "fraction (0::('e, 'f)float) = 0" "fraction (- 0::('e, 'f)float) = 0" subgoal by transfer auto subgoal by transfer auto subgoal by transfer auto subgoal by transfer auto subgoal by transfer auto subgoal by transfer auto done lemma emax_eq: "emax x = 2 ^ LENGTH('e) - 1" for x::"('e, 'f)float itself" by (simp add: emax_def unsigned_minus_1_eq_mask mask_eq_exp_minus_1) lemma topfloat_simps: "sign (topfloat::('e, 'f)float) = 0" "exponent (topfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1" "fraction (topfloat::('e, 'f)float) = 2 ^ (fracwidth TYPE(('e, 'f)float)) - 1" and bottomfloat_simps: "sign (bottomfloat::('e, 'f)float) = 1" "exponent (bottomfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1" "fraction (bottomfloat::('e, 'f)float) = 2 ^ (fracwidth TYPE(('e, 'f)float)) - 1" subgoal by transfer simp subgoal by transfer (simp add: emax_eq take_bit_minus_small_eq nat_diff_distrib nat_power_eq) subgoal by transfer (simp add: unsigned_minus_1_eq_mask mask_eq_exp_minus_1) subgoal by transfer simp subgoal by transfer (simp add: emax_eq take_bit_minus_small_eq nat_diff_distrib nat_power_eq) subgoal by transfer (simp add: unsigned_minus_1_eq_mask mask_eq_exp_minus_1) done lemmas float_defs = is_finite_def is_infinity_def is_zero_def is_nan_def is_normal_def is_denormal_def valof_eq less_eq_float_def less_float_def flt_def fgt_def fle_def fge_def feq_def fcompare_def infinity_simps zero_simps topfloat_simps bottomfloat_simps float_eq_def lemma float_cases: "is_nan a \ is_infinity a \ is_normal a \ is_denormal a \ is_zero a" by (auto simp add: float_defs not_less le_less emax_def unsigned_minus_1_eq_mask) lemma float_cases_finite: "is_nan a \ is_infinity a \ is_finite a" by (simp add: float_cases is_finite_def) -lemma float_zero1[simp]: "is_zero 0" +lemma float_zero1 [simp]: "is_zero 0" unfolding float_defs by transfer auto -lemma float_zero2[simp]: "is_zero (- x) \ is_zero x" +lemma float_zero2 [simp]: "is_zero (- x) \ is_zero x" unfolding float_defs by transfer auto -lemma emax_pos[simp]: "0 < emax x" "emax x \ 0" +lemma emax_pos [simp]: "0 < emax x" "emax x \ 0" by (auto simp: emax_def) text \The types of floating-point numbers are mutually distinct.\ lemma float_distinct: "\ (is_nan a \ is_infinity a)" "\ (is_nan a \ is_normal a)" "\ (is_nan a \ is_denormal a)" "\ (is_nan a \ is_zero a)" "\ (is_infinity a \ is_normal a)" "\ (is_infinity a \ is_denormal a)" "\ (is_infinity a \ is_zero a)" "\ (is_normal a \ is_denormal a)" "\ (is_denormal a \ is_zero a)" by (auto simp: float_defs) lemma denormal_imp_not_zero: "is_denormal f \ \is_zero f" by (simp add: is_denormal_def is_zero_def) lemma normal_imp_not_zero: "is_normal f \ \is_zero f" by (simp add: is_normal_def is_zero_def) lemma normal_imp_not_denormal: "is_normal f \ \is_denormal f" by (simp add: is_normal_def is_denormal_def) -lemma denormal_zero[simp]: "\is_denormal 0" "\is_denormal minus_zero" +lemma denormal_zero [simp]: "\is_denormal 0" "\is_denormal minus_zero" using denormal_imp_not_zero float_zero1 float_zero2 by blast+ -lemma normal_zero[simp]: "\is_normal 0" "\is_normal minus_zero" +lemma normal_zero [simp]: "\is_normal 0" "\is_normal minus_zero" using normal_imp_not_zero float_zero1 float_zero2 by blast+ lemma float_distinct_finite: "\ (is_nan a \ is_finite a)" "\(is_infinity a \ is_finite a)" by (auto simp: float_defs) lemma finite_infinity: "is_finite a \ \ is_infinity a" by (auto simp: float_defs) lemma finite_nan: "is_finite a \ \ is_nan a" by (auto simp: float_defs) -text \For every real number, the floating-point numbers closest to it always exist.\ +text \For every real number, the floating-point numbers closest to it always exists.\ lemma is_closest_exists: fixes v :: "('e, 'f)float \ real" and s :: "('e, 'f)float set" assumes finite: "finite s" and non_empty: "s \ {}" shows "\a. is_closest v s x a" using finite non_empty proof (induct s rule: finite_induct) case empty then show ?case by simp next case (insert z s) show ?case proof (cases "s = {}") case True then have "is_closest v (insert z s) x z" by (auto simp: is_closest_def) then show ?thesis by metis next case False then obtain a where a: "is_closest v s x a" using insert by metis then show ?thesis proof (cases "\v a - x\" "\v z - x\" rule: le_cases) case le then show ?thesis by (metis insert_iff a is_closest_def) next case ge have "\b. b \ s \ \v a - x\ \ \v b - x\" by (metis a is_closest_def) then have "\b. b \ insert z s \ \v z - x\ \ \v b - x\" by (metis eq_iff ge insert_iff order.trans) then show ?thesis using is_closest_def a by (metis insertI1) qed qed qed lemma closest_is_everything: fixes v :: "('e, 'f)float \ real" and s :: "('e, 'f)float set" assumes finite: "finite s" and non_empty: "s \ {}" shows "is_closest v s x (closest v p s x) \ ((\b. is_closest v s x b \ p b) \ p (closest v p s x))" unfolding closest_def by (rule someI_ex) (metis assms is_closest_exists [of s v x]) lemma closest_in_set: fixes v :: "('e, 'f)float \ real" assumes "finite s" and "s \ {}" shows "closest v p s x \ s" by (metis assms closest_is_everything is_closest_def) lemma closest_is_closest_finite: fixes v :: "('e, 'f)float \ real" assumes "finite s" and "s \ {}" shows "is_closest v s x (closest v p s x)" by (metis closest_is_everything assms) instance float::(len, len) finite proof qed (transfer, simp) lemma is_finite_nonempty: "{a. is_finite a} \ {}" proof - have "0 \ {a. is_finite a}" unfolding float_defs by transfer auto then show ?thesis by (metis empty_iff) qed lemma closest_is_closest: fixes v :: "('e, 'f)float \ real" assumes "s \ {}" shows "is_closest v s x (closest v p s x)" by (rule closest_is_closest_finite) (auto simp: assms) subsection \Properties about ordering and bounding\ text \Lifting of non-exceptional comparisons.\ lemma float_lt [simp]: assumes "is_finite a" "is_finite b" shows "a < b \ valof a < valof b" proof assume "valof a < valof b" moreover have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms by (auto simp: finite_nan finite_infinity) ultimately have "fcompare a b = Lt" by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def) then show "a < b" by (auto simp: float_defs) next assume "a < b" then have lt: "fcompare a b = Lt" by (simp add: float_defs) have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms by (auto simp: finite_nan finite_infinity) then show "valof a < valof b" using lt assms by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm) qed lemma float_eq [simp]: assumes "is_finite a" "is_finite b" shows "a \ b \ valof a = valof b" proof assume *: "valof a = valof b" have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms float_distinct_finite by auto with * have "fcompare a b = Eq" by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def) then show "a \ b" by (auto simp: float_defs) next assume "a \ b" then have eq: "fcompare a b = Eq" by (simp add: float_defs) have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms float_distinct_finite by auto then show "valof a = valof b" using eq assms by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm) qed lemma float_le [simp]: assumes "is_finite a" "is_finite b" shows "a \ b \ valof a \ valof b" proof - have "a \ b \ a < b \ a \ b" by (auto simp add: float_defs) then show ?thesis by (auto simp add: assms) qed text \Reflexivity of equality for non-NaNs.\ lemma float_eq_refl [simp]: "a \ a \ \ is_nan a" by (auto simp: float_defs) -text \Properties about Ordering.\ + +text \Properties about ordering.\ lemma float_lt_trans: "is_finite a \ is_finite b \ is_finite c \ a < b \ b < c \ a < c" by (auto simp: le_trans) lemma float_le_less_trans: "is_finite a \ is_finite b \ is_finite c \ a \ b \ b < c \ a < c" by (auto simp: le_trans) lemma float_le_trans: "is_finite a \ is_finite b \ is_finite c \ a \ b \ b \ c \ a \ c" by (auto simp: le_trans) lemma float_le_neg: "is_finite a \ is_finite b \ \ a < b \ b \ a" by auto text \Properties about bounding.\ -lemma float_le_infinity [simp]: "\ is_nan a \ a \ plus_infinity" +lemma float_le_plus_infinity [simp]: "\ is_nan a \ a \ plus_infinity" unfolding float_defs by auto -lemma zero_le_topfloat[simp]: "0 \ topfloat" "- 0 \ topfloat" +lemma minus_infinity_le_float [simp]: "\ is_nan a \ minus_infinity \ a" + unfolding float_defs + by auto + +lemma zero_le_topfloat [simp]: "0 \ topfloat" "- 0 \ topfloat" by (auto simp: float_defs field_simps power_gt1_lemma of_nat_diff mask_eq_exp_minus_1) lemma LENGTH_contr: "Suc 0 < LENGTH('e) \ 2 ^ LENGTH('e::len) \ Suc (Suc 0) \ False" by (metis le_antisym len_gt_0 n_less_equal_power_2 not_less_eq numeral_2_eq_2 one_le_numeral self_le_power) lemma valof_topfloat: "valof (topfloat::('e, 'f)float) = largest TYPE(('e, 'f)float)" if "LENGTH('e) > 1" using that LENGTH_contr by (auto simp add: emax_eq largest_def divide_simps float_defs of_nat_diff mask_eq_exp_minus_1) lemma float_frac_le: "fraction a \ 2^LENGTH('f) - 1" for a::"('e, 'f)float" unfolding float_defs using less_Suc_eq_le by transfer fastforce lemma float_exp_le: "is_finite a \ exponent a \ emax TYPE(('e, 'f)float) - 1" for a::"('e, 'f)float" unfolding float_defs by auto lemma float_sign_le: "(-1::real)^(sign a) = 1 \ (-1::real)^(sign a) = -1" by (metis neg_one_even_power neg_one_odd_power) lemma exp_less: "a \ b \ (2::real)^a \ 2^b" for a b :: nat by auto lemma div_less: "a \ b \ c > 0 \ a/c \ b/c" for a b c :: "'a::linordered_field" by (metis divide_le_cancel less_asym) lemma finite_topfloat: "is_finite topfloat" unfolding float_defs by auto lemmas float_leI = float_le[THEN iffD2] lemma factor_minus: "x * a - x = x * (a - 1)" for x a::"'a::comm_semiring_1_cancel" by (simp add: algebra_simps) lemma real_le_power_numeral_diff: "real a \ numeral b ^ n - 1 \ a \ numeral b ^ n - 1" by (metis (mono_tags, lifting) of_nat_1 of_nat_diff of_nat_le_iff of_nat_numeral one_le_numeral one_le_power semiring_1_class.of_nat_power) definition denormal_exponent::"('e, 'f)float itself \ int" where "denormal_exponent x = 1 - (int (LENGTH('f)) + int (bias TYPE(('e, 'f)float)))" definition normal_exponent::"('e, 'f)float \ int" where "normal_exponent x = int (exponent x) - int (bias TYPE(('e, 'f)float)) - int (LENGTH('f))" definition denormal_mantissa::"('e, 'f)float \ int" where "denormal_mantissa x = (-1::int)^sign x * int (fraction x)" definition normal_mantissa::"('e, 'f)float \ int" where "normal_mantissa x = (-1::int)^sign x * (2^LENGTH('f) + int (fraction x))" lemma unat_one_word_le: "unat a \ Suc 0" for a::"1 word" using unat_lt2p[of a] by auto lemma one_word_le: "a \ 1" for a::"1 word" by (auto simp: word_le_nat_alt unat_one_word_le) lemma sign_cases[case_names pos neg]: obtains "sign x = 0" | "sign x = 1" proof cases assume "sign x = 0" then show ?thesis .. next assume "sign x \ 0" have "sign x \ 1" by transfer (auto simp: unat_one_word_le) then have "sign x = 1" using \sign x \ 0\ by auto then show ?thesis .. qed lemma is_infinity_cases: assumes "is_infinity x" obtains "x = plus_infinity" | "x = minus_infinity" proof (cases rule: sign_cases[of x]) assume "sign x = 0" then have "x = plus_infinity" using assms apply (unfold float_defs) apply transfer apply (auto simp add: unat_eq_of_nat emax_def of_nat_mask_eq) done then show ?thesis .. next assume "sign x = 1" then have "x = minus_infinity" using assms apply (unfold float_defs) apply transfer apply (auto simp add: unat_eq_of_nat emax_def of_nat_mask_eq) done then show ?thesis .. qed lemma is_zero_cases: assumes "is_zero x" obtains "x = 0" | "x = - 0" proof (cases rule: sign_cases[of x]) assume "sign x = 0" then have "x = 0" using assms unfolding float_defs by transfer (auto simp: emax_def unat_eq_0) then show ?thesis .. next assume "sign x = 1" then have "x = minus_zero" using assms unfolding float_defs by transfer (auto simp: emax_def unat_eq_of_nat) then show ?thesis .. qed -lemma minus_minus_float[simp]: "- (-f) = f" for f::"('e, 'f)float" +lemma minus_minus_float [simp]: "- (-f) = f" for f::"('e, 'f)float" by transfer auto lemma sign_minus_float: "sign (-f) = (1 - sign f)" for f::"('e, 'f)float" by transfer (auto simp: unat_eq_1 one_word_le unat_sub) -lemma exponent_uminus[simp]: "exponent (- f) = exponent f" by transfer auto -lemma fraction_uminus[simp]: "fraction (- f) = fraction f" by transfer auto +lemma exponent_uminus [simp]: "exponent (- f) = exponent f" by transfer auto +lemma fraction_uminus [simp]: "fraction (- f) = fraction f" by transfer auto -lemma is_normal_minus_float[simp]: "is_normal (-f) = is_normal f" for f::"('e, 'f)float" +lemma is_normal_minus_float [simp]: "is_normal (-f) = is_normal f" for f::"('e, 'f)float" by (auto simp: is_normal_def) -lemma is_denormal_minus_float[simp]: "is_denormal (-f) = is_denormal f" for f::"('e, 'f)float" +lemma is_denormal_minus_float [simp]: "is_denormal (-f) = is_denormal f" for f::"('e, 'f)float" by (auto simp: is_denormal_def) lemma bitlen_normal_mantissa: "bitlen (abs (normal_mantissa x)) = Suc LENGTH('f)" for x::"('e, 'f)float" proof - have "fraction x < 2 ^ LENGTH('f)" using float_frac_le[of x] by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power) moreover have "- int (fraction x) \ 2 ^ LENGTH('f)" using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast ultimately show ?thesis by (cases x rule: sign_cases) (auto simp: bitlen_le_iff_power bitlen_ge_iff_power nat_add_distrib normal_mantissa_def intro!: antisym) qed lemma less_int_natI: "x < y" if "0 \ x" "nat x < nat y" using that by arith lemma normal_exponent_bounds_int: "2 - 2 ^ (LENGTH('e) - 1) - int LENGTH('f) \ normal_exponent x" "normal_exponent x \ 2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1" if "is_normal x" for x::"('e, 'f)float" using that apply (auto simp add: normal_exponent_def is_normal_def emax_eq bias_def diff_le_eq diff_less_eq mask_eq_exp_minus_1 of_nat_diff simp flip: zless_nat_eq_int_zless power_Suc) apply (simp flip: power_Suc mask_eq_exp_minus_1 add: nat_mask_eq) apply (simp add: mask_eq_exp_minus_1) done lemmas of_int_leI = of_int_le_iff[THEN iffD2] lemma normal_exponent_bounds_real: "2 - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) \ normal_exponent x" "normal_exponent x \ 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1" if "is_normal x" for x::"('e, 'f)float" subgoal by (rule order_trans[OF _ of_int_leI[OF normal_exponent_bounds_int(1)[OF that]]]) auto subgoal by (rule order_trans[OF of_int_leI[OF normal_exponent_bounds_int(2)[OF that]]]) auto done lemma float_eqI: "x = y" if "sign x = sign y" "fraction x = fraction y" "exponent x = exponent y" using that by transfer (auto simp add: word_unat_eq_iff) lemma float_induct[induct type:float, case_names normal denormal neg zero infinity nan]: fixes a::"('e, 'f)float" assumes normal: "\x. is_normal x \ valof x = normal_mantissa x * 2 powr normal_exponent x \ P x" assumes denormal: "\x. is_denormal x \ valof x = denormal_mantissa x * 2 powr denormal_exponent TYPE(('e, 'f)float) \ P x" assumes zero: "P 0" "P minus_zero" assumes infty: "P plus_infinity" "P minus_infinity" assumes nan: "\x. is_nan x \ P x" shows "P a" proof - from float_cases[of a] consider "is_nan a" | "is_infinity a" | "is_normal a" | "is_denormal a" | "is_zero a" by blast then show ?thesis proof cases case 1 then show ?thesis by (rule nan) next case 2 then consider "a = plus_infinity" | "a = minus_infinity" by (rule is_infinity_cases) then show ?thesis by cases (auto intro: infty) next case hyps: 3 from hyps have "valof a = normal_mantissa a * 2 powr normal_exponent a" by (cases a rule: sign_cases) (auto simp: valof_eq normal_mantissa_def normal_exponent_def is_normal_def powr_realpow[symmetric] powr_diff powr_add field_simps) from hyps this show ?thesis by (rule normal) next case hyps: 4 from hyps have "valof a = denormal_mantissa a * 2 powr denormal_exponent TYPE(('e, 'f)float)" by (cases a rule: sign_cases) (auto simp: valof_eq denormal_mantissa_def denormal_exponent_def is_denormal_def powr_realpow[symmetric] powr_diff powr_add field_simps) from hyps this show ?thesis by (rule denormal) next case 5 then consider "a = 0" | "a = minus_zero" by (rule is_zero_cases) then show ?thesis by cases (auto intro: zero) qed qed -lemma infinite_infinity[simp]: "\ is_finite plus_infinity" "\ is_finite minus_infinity" +lemma infinite_infinity [simp]: "\ is_finite plus_infinity" "\ is_finite minus_infinity" by (auto simp: is_finite_def is_normal_def infinity_simps is_denormal_def is_zero_def) -lemma nan_not_finite[simp]: "is_nan x \ \ is_finite x" +lemma nan_not_finite [simp]: "is_nan x \ \ is_finite x" using float_distinct_finite(1) by blast lemma valof_nonneg: "valof x \ 0" if "sign x = 0" for x::"('e, 'f)float" by (auto simp: valof_eq that) lemma valof_nonpos: "valof x \ 0" if "sign x = 1" for x::"('e, 'f)float" using that by (auto simp: valof_eq is_finite_def) lemma real_le_intI: "x \ y" if "floor x \ floor y" "x \ \" for x y::real using that(2,1) by (induction rule: Ints_induct) (auto elim!: Ints_induct simp: le_floor_iff) lemma real_of_int_le_2_powr_bitlenI: "real_of_int x \ 2 powr n - 1" if "bitlen (abs x) \ m" "m \ n" proof - have "real_of_int x \ abs (real_of_int x)" by simp also have "\ < 2 powr (bitlen (abs x))" by (rule abs_real_le_2_powr_bitlen) finally have "real_of_int x \ 2 powr (bitlen (abs x)) - 1" by (auto simp: powr_real_of_int bitlen_nonneg intro!: real_le_intI) also have "\ \ 2 powr m - 1" by (simp add: that) also have "\ \ 2 powr n - 1" by (simp add: that) finally show ?thesis . qed lemma largest_eq: "largest TYPE(('e, 'f)float) = (2 ^ (LENGTH('f) + 1) - 1) * 2 powr real_of_int (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)" proof - have "2 ^ LENGTH('e) - 1 - 1 = (2::nat) ^ LENGTH('e) - 2" by arith then have "largest TYPE(('e, 'f)float) = (2 ^ (LENGTH('f) + 1) - 1) * 2 powr (real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f))" by (auto simp add: largest_def emax_eq bias_def powr_minus field_simps powr_diff powr_add of_nat_diff mask_eq_exp_minus_1 simp flip: powr_realpow) also have "2 ^ LENGTH('e) \ (2::nat)" by (simp add: self_le_power) then have "(real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f)) = (real (2 ^ LENGTH('e)) - 2 ^ (LENGTH('e) - 1) - LENGTH('f)) - 1" by (auto simp add: of_nat_diff) also have "real (2 ^ LENGTH('e)) = 2 ^ LENGTH('e)" by auto also have "(2 ^ LENGTH('e) - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1) = real_of_int ((2 ^ (LENGTH('e) - 1) - int (LENGTH('f)) - 1))" by (simp, subst power_Suc[symmetric], simp) finally show ?thesis by simp qed lemma bitlen_denormal_mantissa: "bitlen (abs (denormal_mantissa x)) \ LENGTH('f)" for x::"('e, 'f)float" proof - have "fraction x < 2 ^ LENGTH('f)" using float_frac_le[of x] by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power) moreover have "- int (fraction x) \ 2 ^ LENGTH('f)" using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast ultimately show ?thesis by (cases x rule: sign_cases) (auto simp: bitlen_le_iff_power denormal_mantissa_def intro!: antisym) qed lemma float_le_topfloat: fixes a::"('e, 'f)float" assumes "is_finite a" "LENGTH('e) > 1" shows "a \ topfloat" using assms(1) proof (induction a rule: float_induct) case (normal x) note normal(2) also have "real_of_int (normal_mantissa x) * 2 powr real_of_int (normal_exponent x) \ (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)" using normal_exponent_bounds_real(2)[OF \is_normal x\] by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero) also have "\ = largest TYPE(('e, 'f) IEEE.float)" unfolding largest_eq by (auto simp: powr_realpow powr_add) also have "\ = valof (topfloat::('e, 'f) float)" using assms by (simp add: valof_topfloat) finally show ?case by (intro float_leI normal finite_topfloat) next case (denormal x) note denormal(2) also have "3 \ 2 powr (1 + real (LENGTH('e) - Suc 0))" proof - have "3 \ 2 powr (2::real)" by simp also have "\ \ 2 powr (1 + real (LENGTH('e) - Suc 0))" using assms by (subst powr_le_cancel_iff) auto finally show ?thesis . qed then have "real_of_int (denormal_mantissa x) * 2 powr real_of_int (denormal_exponent TYPE(('e, 'f)float)) \ (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)" using bitlen_denormal_mantissa[of x] by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero mask_eq_exp_minus_1 denormal_exponent_def bias_def powr_mult_base of_nat_diff) also have "\ \ largest TYPE(('e, 'f) IEEE.float)" unfolding largest_eq by (rule mult_mono) (auto simp: powr_realpow powr_add power_Suc[symmetric] simp del: power_Suc) also have "\ = valof (topfloat::('e, 'f) float)" using assms by (simp add: valof_topfloat) finally show ?case by (intro float_leI denormal finite_topfloat) qed auto lemma float_val_le_largest: "valof a \ largest TYPE(('e, 'f)float)" if "is_finite a" "LENGTH('e) > 1" for a::"('e, 'f)float" by (metis that finite_topfloat float_le float_le_topfloat valof_topfloat) lemma float_val_lt_threshold: "valof a < threshold TYPE(('e, 'f)float)" if "is_finite a" "LENGTH('e) > 1" for a::"('e, 'f)float" proof - have "valof a \ largest TYPE(('e, 'f)float)" by (rule float_val_le_largest [OF that]) also have "\ < threshold TYPE(('e, 'f)float)" by (auto simp: largest_def threshold_def divide_simps) finally show ?thesis . qed subsection \Algebraic properties about basic arithmetic\ text \Commutativity of addition.\ lemma assumes "is_finite a" "is_finite b" shows float_plus_comm_eq: "a + b = b + a" - and float_plus_comm: "is_finite (a + b) \ (a + b) \ (b + a)" + and float_plus_comm: "is_finite (a + b) \ (a + b) \ (b + a)" (*FIXME: this should hold unconditionally?*) proof - have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms by (auto simp: finite_nan finite_infinity) then show "a + b = b + a" by (simp add: float_defs fadd_def plus_float_def add.commute) then show "is_finite (a + b) \ (a + b) \ (b + a)" by (metis float_eq) qed -text \The floating-point number a falls into the same category as the negation of \a\.\ -lemma is_zero_uminus[simp]: "is_zero (- a) \ is_zero a" +text \The floating-point number \a\ falls into the same category as the negation of \a\.\ +lemma is_zero_uminus [simp]: "is_zero (- a) \ is_zero a" by (simp add: is_zero_def) lemma is_infinity_uminus [simp]: "is_infinity (- a) = is_infinity a" by (simp add: is_infinity_def) -lemma is_finite_uminus[simp]: "is_finite (- a) \ is_finite a" +lemma is_finite_uminus [simp]: "is_finite (- a) \ is_finite a" by (simp add: is_finite_def) -lemma is_nan_uminus[simp]: "is_nan (- a) \ is_nan a" +lemma is_nan_uminus [simp]: "is_nan (- a) \ is_nan a" by (simp add: is_nan_def) -text \The sign of a and the sign of a's negation is different.\ -lemma float_neg_sign: "(sign a) \ (sign (- a))" +text \The sign of \a\ and the sign of \a\'s negation are different.\ +lemma float_neg_sign: "sign a \ sign (- a)" by (cases a rule: sign_cases) (auto simp: sign_minus_float) lemma float_neg_sign1: "sign a = sign (- b) \ sign a \ sign b" by (metis float_neg_sign sign_cases) lemma valof_uminus: assumes "is_finite a" - shows "valof (- a) = - valof a" (is "?L = ?R") + shows "valof (- a) = - valof a" by (cases a rule: sign_cases) (auto simp: valof_eq sign_minus_float) - -text \Showing \a + (- b) = a - b\.\ -lemma float_neg_add: - "is_finite a \ is_finite b \ is_finite (a - b) \ valof a + valof (- b) = valof a - valof b" - by (simp add: valof_uminus) - +text \Showing \a + (- b) \ a - b\.\ lemma float_plus_minus: assumes "is_finite a" "is_finite b" "is_finite (a - b)" shows "(a + - b) \ (a - b)" proof - have nab: "\ is_nan a" "\ is_nan (- b)" "\ is_infinity a" "\ is_infinity (- b)" using assms by (auto simp: finite_nan finite_infinity) have "a - b = (zerosign (if is_zero a \ is_zero b \ sign a \ sign b then (sign a) else 0) (round RNE (valof a - valof b)))" using nab by (auto simp: minus_float_def fsub_def) also have "\ = (zerosign (if is_zero a \ is_zero (- b) \ sign a = sign (- b) then sign a else 0) (round RNE (valof a + valof (- b))))" using assms - by (simp add: float_neg_sign1 float_neg_add) + by (simp add: float_neg_sign1 valof_uminus) also have "\ = a + - b" using nab by (auto simp: float_defs fadd_def plus_float_def) finally show ?thesis using assms by (metis float_eq) qed lemma finite_bottomfloat: "is_finite bottomfloat" by (simp add: finite_topfloat) lemma bottomfloat_eq_m_largest: "valof (bottomfloat::('e, 'f)float) = - largest TYPE(('e, 'f)float)" if "LENGTH('e) > 1" using that by (auto simp: valof_topfloat valof_uminus finite_topfloat) lemma float_val_ge_bottomfloat: "valof a \ valof (bottomfloat::('e, 'f)float)" if "LENGTH('e) > 1" "is_finite a" for a::"('e,'f)float" proof - have "- a \ topfloat" using that by (auto intro: float_le_topfloat) then show ?thesis using that by (auto simp: valof_uminus finite_topfloat) qed lemma float_ge_bottomfloat: "is_finite a \ a \ bottomfloat" if "LENGTH('e) > 1" "is_finite a" for a::"('e,'f)float" by (metis finite_bottomfloat float_le float_val_ge_bottomfloat that) lemma float_val_ge_largest: fixes a::"('e,'f)float" assumes "LENGTH('e) > 1" "is_finite a" shows "valof a \ - largest TYPE(('e,'f)float)" proof - have "- largest TYPE(('e,'f)float) = valof (bottomfloat::('e,'f)float)" using assms by (simp add: bottomfloat_eq_m_largest) also have "\ \ valof a" using assms by (simp add: float_val_ge_bottomfloat) finally show ?thesis . qed lemma float_val_gt_threshold: fixes a::"('e,'f)float" assumes "LENGTH('e) > 1" "is_finite a" shows "valof a > - threshold TYPE(('e,'f)float)" proof - have largest: "valof a \ -largest TYPE(('e,'f)float)" using assms by (metis float_val_ge_largest) then have "-largest TYPE(('e,'f)float) > - threshold TYPE(('e,'f)float)" by (auto simp: bias_def threshold_def largest_def divide_simps) then show ?thesis by (metis largest less_le_trans) qed text \Showing \abs (- a) = abs a\.\ lemma float_abs [simp]: "\ is_nan a \ abs (- a) = abs a" by (metis IEEE.abs_float_def float_neg_sign1 minus_minus_float zero_simps(1)) lemma neg_zerosign: "- (zerosign s a) = zerosign (1 - s) (- a)" by (auto simp: zerosign_def) subsection \Properties about Rounding Errors\ definition error :: "('e, 'f)float itself \ real \ real" where "error _ x = valof (round RNE x::('e, 'f)float) - x" lemma bound_at_worst_lemma: fixes a::"('e, 'f)float" assumes threshold: "\x\ < threshold TYPE(('e, 'f)float)" assumes finite: "is_finite a" shows "\valof (round RNE x::('e, 'f)float) - x\ \ \valof a - x\" proof - have *: "(round RNE x::('e,'f)float) = closest valof (\a. even (fraction a)) {a. is_finite a} x" using threshold finite by auto have "is_closest (valof) {a. is_finite a} x (round RNE x::('e,'f)float)" using is_finite_nonempty unfolding * by (intro closest_is_closest) auto then show ?thesis using finite is_closest_def by (metis mem_Collect_eq) qed lemma error_at_worst_lemma: fixes a::"('e, 'f)float" assumes threshold: "\x\ < threshold TYPE(('e, 'f)float)" and "is_finite a" shows "\error TYPE(('e, 'f)float) x\ \ \valof a - x\ " unfolding error_def by (rule bound_at_worst_lemma; fact) lemma error_is_zero [simp]: fixes a::"('e, 'f)float" assumes "is_finite a" "1 < LENGTH('e)" shows "error TYPE(('e, 'f)float) (valof a) = 0" proof - have "\valof a\ < threshold TYPE(('e, 'f)float)" by (metis abs_less_iff minus_less_iff float_val_gt_threshold float_val_lt_threshold assms) then show ?thesis by (metis abs_le_zero_iff abs_zero diff_self error_at_worst_lemma assms(1)) qed -lemma is_finite_zerosign[simp]: "is_finite (zerosign s a) \ is_finite a" +lemma is_finite_zerosign [simp]: "is_finite (zerosign s a) \ is_finite a" by (auto simp: zerosign_def is_finite_def) lemma is_finite_closest: "is_finite (closest (v::_\real) p {a. is_finite a} x)" using closest_is_closest[OF is_finite_nonempty, of v x p] by (auto simp: is_closest_def) lemma defloat_float_zerosign_round_finite: assumes threshold: "\x\ < threshold TYPE(('e, 'f)float)" shows "is_finite (zerosign s (round RNE x::('e, 'f)float))" proof - have "(round RNE x::('e, 'f)float) = (closest valof (\a. even (fraction a)) {a. is_finite a} x)" using threshold by (metis (full_types) abs_less_iff leD le_minus_iff round.simps(1)) then have "is_finite (round RNE x::('e, 'f)float)" by (metis is_finite_closest) then show ?thesis using is_finite_zerosign by auto qed -lemma valof_zero[simp]: "valof 0 = 0" "valof minus_zero = 0" +lemma valof_zero [simp]: "valof 0 = 0" "valof minus_zero = 0" by (auto simp add: zerosign_def valof_eq zero_simps) lemma signzero_zero: "is_zero a \ valof (zerosign s a) = 0" by (auto simp add: zerosign_def) lemma val_zero: "is_zero a \ valof a = 0" by (cases a rule: is_zero_cases) auto lemma float_add: fixes a b::"('e, 'f)float" assumes "is_finite a" and "is_finite b" and threshold: "\valof a + valof b\ < threshold TYPE(('e, 'f)float)" shows finite_float_add: "is_finite (a + b)" and error_float_add: "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)" proof - have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms float_distinct_finite by auto then have ab: "(a + b) = (zerosign (if is_zero a \ is_zero b \ sign a = sign b then (sign a) else 0) (round RNE (valof a + valof b)))" using assms by (auto simp add: float_defs fadd_def plus_float_def) then show "is_finite ((a + b))" by (metis threshold defloat_float_zerosign_round_finite) have val_ab: "valof (a + b) = valof (zerosign (if is_zero a \ is_zero b \ sign a = sign b then (sign a) else 0) (round RNE (valof a + valof b)::('e, 'f)float))" by (auto simp: ab is_infinity_def is_nan_def valof_def) show "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)" proof (cases "is_zero (round RNE (valof a + valof b)::('e, 'f)float)") case True have "valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b) = valof (round RNE (valof a + valof b)::('e, 'f)float)" unfolding error_def by simp then show ?thesis by (metis True signzero_zero val_zero val_ab) next case False then show ?thesis by (metis ab add.commute eq_diff_eq' error_def zerosign_def) qed qed lemma float_sub: fixes a b::"('e, 'f)float" assumes "is_finite a" and "is_finite b" and threshold: "\valof a - valof b\ < threshold TYPE(('e, 'f)float)" shows finite_float_sub: "is_finite (a - b)" and error_float_sub: "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)" proof - have "\ is_nan a" and "\ is_nan b" and "\ is_infinity a" and "\ is_infinity b" using assms by (auto simp: finite_nan finite_infinity) then have ab: "a - b = (zerosign (if is_zero a \ is_zero b \ sign a \ sign b then sign a else 0) (round RNE (valof a - valof b)))" using assms by (auto simp add: float_defs fsub_def minus_float_def) then show "is_finite (a - b)" by (metis threshold defloat_float_zerosign_round_finite) have val_ab: "valof (a - b) = valof (zerosign (if is_zero a \ is_zero b \ sign a \ sign b then sign a else 0) (round RNE (valof a - valof b)::('e, 'f)float))" by (auto simp: ab is_infinity_def is_nan_def valof_def) show "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)" proof (cases "is_zero (round RNE (valof a - valof b)::('e, 'f)float)") case True have "valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b) = valof (round RNE (valof a - valof b)::('e, 'f)float)" unfolding error_def by simp then show ?thesis by (metis True signzero_zero val_zero val_ab) next case False then show ?thesis by (metis ab add.commute eq_diff_eq' error_def zerosign_def) qed qed lemma float_mul: fixes a b::"('e, 'f)float" assumes "is_finite a" and "is_finite b" and threshold: "\valof a * valof b\ < threshold TYPE(('e, 'f)float)" shows finite_float_mul: "is_finite (a * b)" and error_float_mul: "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)" proof - have non: "\ is_nan a" "\ is_nan b" "\ is_infinity a" "\ is_infinity b" using assms float_distinct_finite by auto then have ab: "a * b = (zerosign (of_bool (sign a \ sign b)) (round RNE (valof a * valof b)::('e, 'f)float))" using assms by (auto simp: float_defs fmul_def times_float_def) then show "is_finite (a * b)" by (metis threshold defloat_float_zerosign_round_finite) have val_ab: "valof (a * b) = valof (zerosign (of_bool (sign a \ sign b)) (round RNE (valof a * valof b)::('e, 'f)float))" by (auto simp: ab float_defs of_bool_def) show "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)" proof (cases "is_zero (round RNE (valof a * valof b)::('e, 'f)float)") case True have "valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b) = valof (round RNE (valof a * valof b)::('e, 'f)float)" unfolding error_def by simp then show ?thesis by (metis True signzero_zero val_zero val_ab) next case False then show ?thesis by (metis ab add.commute eq_diff_eq' error_def zerosign_def) qed qed lemma float_div: fixes a b::"('e, 'f)float" assumes "is_finite a" and "is_finite b" and not_zero: "\ is_zero b" and threshold: "\valof a / valof b\ < threshold TYPE(('e, 'f)float)" shows finite_float_div: "is_finite (a / b)" and error_float_div: "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b)" proof - have ab: "a / b = (zerosign (of_bool (sign a \ sign b)) (round RNE (valof a / valof b)))" using assms by (simp add: divide_float_def fdiv_def finite_infinity finite_nan not_zero float_defs [symmetric]) then show "is_finite (a / b)" by (metis threshold defloat_float_zerosign_round_finite) have val_ab: "valof (a / b) = valof (zerosign (of_bool (sign a \ sign b)) (round RNE (valof a / valof b))::('e, 'f)float)" by (auto simp: ab float_defs of_bool_def) show "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b)" proof (cases "is_zero (round RNE (valof a / valof b)::('e, 'f)float)") case True have "valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b) = valof (round RNE (valof a / valof b)::('e, 'f)float)" unfolding error_def by simp then show ?thesis by (metis True signzero_zero val_zero val_ab) next case False then show ?thesis by (metis ab add.commute eq_diff_eq' error_def zerosign_def) qed qed -lemma valof_one[simp]: "valof (1 :: ('e, 'f) float) = of_bool (LENGTH('e) > 1)" +lemma valof_one [simp]: "valof (1 :: ('e, 'f) float) = of_bool (LENGTH('e) > 1)" apply transfer apply (auto simp add: bias_def unat_mask_eq simp flip: mask_eq_exp_minus_1) apply (simp add: mask_eq_exp_minus_1) done end diff --git a/thys/IEEE_Floating_Point/IEEE_Single_NaN.thy b/thys/IEEE_Floating_Point/IEEE_Single_NaN.thy new file mode 100644 --- /dev/null +++ b/thys/IEEE_Floating_Point/IEEE_Single_NaN.thy @@ -0,0 +1,284 @@ +(* Author: Tjark Weber, Uppsala University +*) + +section \Specification of the IEEE standard with a single NaN value\ + +theory IEEE_Single_NaN + imports + IEEE_Properties +begin + +text \This theory defines a type of floating-point numbers that contains a single NaN value, much + like specification level~2 of IEEE-754 (which does not distinguish between a quiet and a + signaling NaN, nor between different bit representations of NaN). + + In contrast, the type @{typ \('e, 'f) float\} defined in {\tt IEEE.thy} may contain several + distinct (bit) representations of NaN, much like specification level~4 of IEEE-754. + + One aim of this theory is to define a floating-point type (along with arithmetic operations) whose + semantics agrees with the semantics of the SMT-LIB floating-point theory at + \url{https://smtlib.cs.uiowa.edu/theories-FloatingPoint.shtml}. The following development + therefore deviates from {\tt IEEE.thy} in some places to ensure alignment with the SMT-LIB + theory.\ + +text \Note that we are using HOL equality (rather than IEEE-754 floating-point equality) in the + following definition. This is because we do not want to identify~$+0$ and~$-0$.\ +definition is_nan_equivalent :: "('e, 'f) float \ ('e, 'f) float \ bool" + where "is_nan_equivalent a b \ a = b \ (is_nan a \ is_nan b)" + +quotient_type (overloaded) ('e, 'f) floatSingleNaN = "('e, 'f) float" / is_nan_equivalent + by (metis equivpI is_nan_equivalent_def reflpI sympI transpI) + +text \Note that @{typ "('e, 'f) floatSingleNaN"} does not count the hidden bit in the significand. + For instance, IEEE-754's double-precision binary floating point format {\tt binary64} corresponds + to @{typ "(11,52) floatSingleNaN"}. The corresponding SMT-LIB sort is {\tt (\_ FloatingPoint 11 53)}, + where the hidden bit is counted. Since the bit size is encoded as a type argument, and Isabelle/HOL + does not permit arithmetic on type expressions, it would be difficult to resolve this difference + without completely separating the definition of @{typ "('e, 'f) floatSingleNaN"} in this theory + from the definition of @{typ "('e, 'f) float"} in IEEE.thy.\ + +syntax "_floatSingleNaN" :: "type \ type \ type" ("'(_, _') floatSingleNaN") +text \Parse \('a, 'b) floatSingleNaN\ as \('a::len, 'b::len) floatSingleNaN\.\ + +parse_translation \ + let + fun float t u = Syntax.const @{type_syntax floatSingleNaN} $ t $ u; + fun len_tr u = + (case Term_Position.strip_positions u of + v as Free (x, _) => + if Lexicon.is_tid x then + (Syntax.const @{syntax_const "_ofsort"} $ v $ + Syntax.const @{class_syntax len}) + else u + | _ => u) + fun len_float_tr [t, u] = + float (len_tr t) (len_tr u) + in + [(@{syntax_const "_floatSingleNaN"}, K len_float_tr)] + end +\ + + +subsection \Value constructors\ + +subsubsection \FP literals as bit string triples, with the leading bit for the significand not + represented (hidden bit)\ + +lift_definition fp :: "1 word \ 'e word \ 'f word \ ('e, 'f) floatSingleNaN" + is "\s e f. IEEE.Abs_float (s, e, f)" . + +subsubsection \Plus and minus infinity\ + +lift_definition plus_infinity :: "('e, 'f) floatSingleNaN" ("\") is IEEE.plus_infinity . + +lift_definition minus_infinity :: "('e, 'f) floatSingleNaN" is IEEE.minus_infinity . + +subsubsection \Plus and minus zero\ + +instantiation floatSingleNaN :: (len, len) zero begin + + lift_definition zero_floatSingleNaN :: "('a, 'b) floatSingleNaN" is 0 . + + instance .. + +end + +lift_definition minus_zero :: "('e, 'f) floatSingleNaN" is IEEE.minus_zero . + +subsubsection \Non-numbers (NaN)\ + +lift_definition NaN :: "('e, 'f) floatSingleNaN" is some_nan . + + +subsection \Operators\ + +subsubsection \Absolute value\ + +setup \Sign.mandatory_path "abs_floatSingleNaN_inst"\ \ \workaround to avoid a duplicate fact declaration {\tt abs\_floatSingleNaN\_def} in lift\_definition below\ + +instantiation floatSingleNaN :: (len, len) abs +begin + + lift_definition abs_floatSingleNaN :: "('a, 'b) floatSingleNaN \ ('a, 'b) floatSingleNaN" is abs + unfolding is_nan_equivalent_def by (metis IEEE.abs_float_def is_nan_uminus) + + instance .. + +end + +setup \Sign.parent_path\ + +subsubsection \Negation (no rounding needed)\ + +instantiation floatSingleNaN :: (len, len) uminus +begin + + lift_definition uminus_floatSingleNaN :: "('a, 'b) floatSingleNaN \ ('a, 'b) floatSingleNaN" is uminus + unfolding is_nan_equivalent_def by (metis is_nan_uminus) + + instance .. + +end + +subsubsection \Addition\ + +lift_definition fadd :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fadd + unfolding is_nan_equivalent_def by (metis IEEE.fadd_def) + +subsubsection \Subtraction\ + +lift_definition fsub :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fsub + unfolding is_nan_equivalent_def by (metis IEEE.fsub_def) + +subsubsection \Multiplication\ + +lift_definition fmul :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fmul + unfolding is_nan_equivalent_def by (metis IEEE.fmul_def) + +subsubsection \Division\ + +lift_definition fdiv :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fdiv + unfolding is_nan_equivalent_def by (metis IEEE.fdiv_def) + +subsubsection \Fused multiplication and addition; $(x \cdot y) + z$\ + +lift_definition fmul_add :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fmul_add + unfolding is_nan_equivalent_def by (smt (verit) IEEE.fmul_add_def) + +subsubsection \Square root\ + +lift_definition fsqrt :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fsqrt + unfolding is_nan_equivalent_def by (metis IEEE.fsqrt_def) + +subsubsection \Remainder: $x - y \cdot n$, where $n \in \mathrm{Z}$ is nearest to $x/y$\ + +lift_definition frem :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.frem + unfolding is_nan_equivalent_def by (metis IEEE.frem_def) + +lift_definition float_rem :: "('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.float_rem + unfolding is_nan_equivalent_def by (metis IEEE.frem_def IEEE.float_rem_def) + +subsubsection \Rounding to integral\ + +lift_definition fintrnd :: "roundmode \ ('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN" is IEEE.fintrnd + unfolding is_nan_equivalent_def by (metis IEEE.fintrnd_def) + +subsubsection \Minimum and maximum\ + +text \In IEEE 754-2019, the minNum and maxNum operations of the 2008 version of the standard have +been replaced by minimum, minimumNumber, maximum, maximumNumber (see Section~9.6 of the 2019 +standard). These are not (yet) available in SMT-LIB. We currently do not implement any of these +operations.\ + +subsubsection \Comparison operators\ + +lift_definition fle :: "('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ bool" is IEEE.fle + unfolding is_nan_equivalent_def by (smt (verit) IEEE.fcompare_def IEEE.fle_def) + +lift_definition flt :: "('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ bool" is IEEE.flt + unfolding is_nan_equivalent_def by (smt (verit) IEEE.fcompare_def IEEE.flt_def) + +lift_definition fge :: "('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ bool" is IEEE.fge + unfolding is_nan_equivalent_def by (smt (verit) IEEE.fcompare_def IEEE.fge_def) + +lift_definition fgt :: "('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ bool" is IEEE.fgt + unfolding is_nan_equivalent_def by (smt (verit) IEEE.fcompare_def IEEE.fgt_def) + +subsubsection \IEEE 754 equality\ + +lift_definition feq :: "('e ,'f) floatSingleNaN \ ('e ,'f) floatSingleNaN \ bool" is IEEE.feq + unfolding is_nan_equivalent_def by (smt (verit) IEEE.fcompare_def IEEE.feq_def) + +subsubsection \Classification of numbers\ + +lift_definition is_normal :: "('e, 'f) floatSingleNaN \ bool" is IEEE.is_normal + unfolding is_nan_equivalent_def using float_distinct by blast + +lift_definition is_subnormal :: "('e, 'f) floatSingleNaN \ bool" is IEEE.is_denormal + unfolding is_nan_equivalent_def using float_distinct by blast + +lift_definition is_zero :: "('e, 'f) floatSingleNaN \ bool" is IEEE.is_zero + unfolding is_nan_equivalent_def using float_distinct by blast + +lift_definition is_infinity :: "('e, 'f) floatSingleNaN \ bool" is IEEE.is_infinity + unfolding is_nan_equivalent_def using float_distinct by blast + +lift_definition is_nan :: "('e, 'f) floatSingleNaN \ bool" is IEEE.is_nan + unfolding is_nan_equivalent_def by blast + +lift_definition is_finite :: "('e, 'f) floatSingleNaN \ bool" is IEEE.is_finite + unfolding is_nan_equivalent_def using nan_not_finite by blast + +definition is_negative :: "('e, 'f) floatSingleNaN \ bool" + where "is_negative x \ x = minus_zero \ flt x minus_zero" + +definition is_positive :: "('e, 'f) floatSingleNaN \ bool" + where "is_positive x \ x = 0 \ flt 0 x" + + +subsection \Conversions to other sorts\ + +subsubsection \to real\ + +text \SMT-LIB leaves {\tt fp.to\_real} unspecified for $+\infty$, $-\infty$, NaN. In contrast, +@{const valof} is (partially) specified also for those arguments. This means that the SMT-LIB +semantics can prove fewer theorems about {\tt fp.to\_real} than Isabelle can prove about +@{const valof}.\ + +lift_definition valof :: "('e,'f) floatSingleNaN \ real" + is "\a. if IEEE.is_infinity a then undefined a + else if IEEE.is_nan a then undefined \ \returning the same value for all floats that satisfy @{const IEEE.is_nan} is necessary to obtain a function that can be lifted to the quotient type\ + else IEEE.valof a" + unfolding is_nan_equivalent_def using float_distinct(1) by fastforce + +subsubsection \to unsigned machine integer, represented as a bit vector\ + +definition unsigned_word_of_floatSingleNaN :: "roundmode \ ('e,'f) floatSingleNaN \ 'a::len word" + where "unsigned_word_of_floatSingleNaN mode a \ + if is_infinity a \ is_nan a then undefined mode a + else (SOME w. valof (fintrnd mode a) = real_of_word w)" + +subsubsection \to signed machine integer, represented as a 2's complement bit vector\ + +definition signed_word_of_floatSingleNaN :: "roundmode \ ('e,'f) floatSingleNaN \ 'a::len word" + where "signed_word_of_floatSingleNaN mode a \ + if is_infinity a \ is_nan a then undefined mode a + else (SOME w. valof (fintrnd mode a) = real_of_int (sint w))" + + +subsection \Conversions from other sorts\ + +subsubsection \from single bitstring representation in IEEE 754 interchange format\ + +text \The intention is that @{prop \LENGTH('a::len) = 1 + LENGTH('e::len) + LENGTH('f::len)\} + (recall that @{term \LENGTH('f::len)\} does not include the significand's hidden bit). Of course, + the type system of Isabelle/HOL is not strong enough to enforce this.\ + +definition floatSingleNaN_of_IEEE754_word :: "'a::len word \ ('e,'f) floatSingleNaN" + where "floatSingleNaN_of_IEEE754_word w \ + let (se, f) = word_split w :: 'a word \ _; (s, e) = word_split se in fp s e f" \ \using @{typ \'a word\} ensures that no bits are lost in @{term \se\}\ + +subsubsection \from real\ + +lift_definition round :: "roundmode \ real \ ('e,'f) floatSingleNaN" is IEEE.round . + +subsubsection \from another floating point sort\ + +definition floatSingleNaN_of_floatSingleNaN :: "roundmode \ ('a,'b) floatSingleNaN \ ('e,'f) floatSingleNaN" + where "floatSingleNaN_of_floatSingleNaN mode a \ + if a = plus_infinity then plus_infinity + else if a = minus_infinity then minus_infinity + else if a = NaN then NaN + else round mode (valof a)" + +subsubsection \from signed machine integer, represented as a 2's complement bit vector\ + +definition floatSingleNaN_of_signed_word :: "roundmode \ 'a::len word \ ('e,'f) floatSingleNaN" + where "floatSingleNaN_of_signed_word mode w \ round mode (real_of_int (sint w))" + +subsubsection \from unsigned machine integer, represented as bit vector\ + +definition floatSingleNaN_of_unsigned_word :: "roundmode \ 'a::len word \ ('e,'f) floatSingleNaN" + where "floatSingleNaN_of_unsigned_word mode w \ round mode (real_of_word w)" + +end diff --git a/thys/IEEE_Floating_Point/IEEE_Single_NaN_SMTLIB.thy b/thys/IEEE_Floating_Point/IEEE_Single_NaN_SMTLIB.thy new file mode 100644 --- /dev/null +++ b/thys/IEEE_Floating_Point/IEEE_Single_NaN_SMTLIB.thy @@ -0,0 +1,19 @@ +(* Author: Tjark Weber, Uppsala University +*) + +section \Translation of the IEEE model (with a single NaN value) into SMT-LIB's floating point theory\ + +theory IEEE_Single_NaN_SMTLIB + imports + IEEE_Single_NaN +begin + +text \SMT setup. Note that an interpretation of floating-point arithmetic in SMT-LIB allows external + SMT solvers that support the SMT-LIB floating-point theory to find more proofs, but---in the + absence of built-in floating-point automation in Isabelle/HOL---significantly \emph{reduces} + Sledgehammer's proof reconstruction rate. Until such automation becomes available, you probably + want to use the interpreted translation only if you intend to use the external SMT solvers as + trusted oracles.\ +ML_file \smt_float.ML\ + +end diff --git a/thys/IEEE_Floating_Point/ROOT b/thys/IEEE_Floating_Point/ROOT --- a/thys/IEEE_Floating_Point/ROOT +++ b/thys/IEEE_Floating_Point/ROOT @@ -1,13 +1,15 @@ chapter AFP session IEEE_Floating_Point (AFP) = "Word_Lib" + options [timeout = 3600] sessions "HOL-Library" theories IEEE_Properties FP64 Double + IEEE_Single_NaN + IEEE_Single_NaN_SMTLIB document_files "root.bib" "root.tex" diff --git a/thys/IEEE_Floating_Point/smt_float.ML b/thys/IEEE_Floating_Point/smt_float.ML new file mode 100644 --- /dev/null +++ b/thys/IEEE_Floating_Point/smt_float.ML @@ -0,0 +1,232 @@ +(* Title: IEEE_Floating_Point/smt_float.ML + Author: Olle Torstensson, Uppsala University + Author: Tjark Weber, Uppsala University + +SMT setup for floating-points. + +This file provides an interpretation of floating-point related types and constants found in +IEEE_Floating_Point/IEEE_Single_NaN.thy into SMT-LIB. The interpretation encompasses + - fixed format floating-point types, + - the rounding mode type, + - floating-point value construction from bit vector triples, + - special floating-point values (+/- 0, +/- infinity, and NaN), + - rounding modes, + - classification operations, + - arithmetic operations, + - comparison operations, + - type conversions to and from the reals, and + - type conversions to and from bit-vector representations. + +The interpretation does NOT cover polymorphic floating-point types. Variables and constants with a +floating-point type will in general need to be attached with explicit type constraints in order to +trigger the interpretation. +*) + +structure SMT_Float: sig end = +struct + +(*Determine whether a type is a word type of a fixed format supported by SMT-LIB.*) +fun is_word (Type (\<^type_name>\Word.word\, [a])) = + can Word_Lib.dest_binT a andalso Word_Lib.dest_binT a > 0 + | is_word _ = false + +(*Determine whether a type is a floating-point type of a fixed format supported by SMT-LIB.*) +fun is_float (Type (\<^type_name>\IEEE_Single_NaN.floatSingleNaN\, [e,f])) = + can (apply2 Word_Lib.dest_binT) (e,f) andalso + Word_Lib.dest_binT e > 1 andalso + Word_Lib.dest_binT f > 0 \ \SMT-LIB requires e>1 and f>1 but counts the significand's hidden bit in f\ + | is_float _ = false + +(*Extract type argument from word types of fixed formats.*) +fun word_Targ (T as (Type (\<^type_name>\Word.word\, [a]))) = + if is_word T then + SOME (Word_Lib.dest_binT a) + else + NONE + | word_Targ _ = NONE + +(*Extract type arguments from floating-point types of fixed formats.*) +fun float_Targs (T as (Type (\<^type_name>\IEEE_Single_NaN.floatSingleNaN\, [e,f]))) = + if is_float T then + SOME (Word_Lib.dest_binT e, Word_Lib.dest_binT f) + else + NONE + | float_Targs _ = NONE + +(*True except for floating-point and word types of unsupported formats.*) +fun is_valid_type (T as (Type (\<^type_name>\IEEE_Single_NaN.floatSingleNaN\, _))) = is_float T + | is_valid_type (T as (Type (\<^type_name>\Word.word\, _))) = is_word T + | is_valid_type _ = true + + +(* SMT-LIB logic *) + +(* + SMT-LIB logics are generally too restrictive for Isabelle's problems. "ALL" denotes the most + general logic supported by the SMT solver, and is chosen if a rounding mode or supported + floating-point type is encountered among the terms. Isabelle's SMTLIB_Interface unfortunately + does not provide a modular way to indicate that a problem requires the floating-point (FP) theory. +*) +fun smtlib_logic _ ts = + let + fun is_float_or_rm (Type (\<^type_name>\IEEE.roundmode\, _)) = true + | is_float_or_rm T = is_float T + in + if exists (Term.exists_type (Term.exists_subtype is_float_or_rm)) ts then + SOME "ALL" (*FIXME: There are currently three SMT solvers available in Isabelle: cvc4, verit, + and z3. verit currently does not support the FP theory at all. z3 + currently does not support the "ALL" logic but ignores it gracefully.*) + else + NONE + end + + +(* SMT-LIB built-ins *) + +(*Interpret floating-point related types and constants supported by the SMT-LIB floating-point theory.*) +local + + (*SMT-LIB syntax template for parameterized sorts and functions.*) + fun param_template1 s a = + "(_ " ^ s ^ " " ^ string_of_int a ^ ")" + + fun param_template2 s (e,f) = + "(_ " ^ s ^ " " ^ string_of_int e ^ " " ^ string_of_int (f + 1) ^ ")" + + fun word_typ T = Option.map (rpair [] o param_template1 "BitVec") (word_Targ T) + + fun float_typ T = Option.map (rpair [] o param_template2 "FloatingPoint") (float_Targs T) + + (* + Generic function for interpreting floating-point constants. + f can be used to customize the interpretation. + *) + fun add_float_fun f (t, s) = + let + val (n, _) = Term.dest_Const t + in + (*FIXME: It would be preferable to add the floating-point types and functions only for those + SMT solvers that support them (currently, cvc4 and z3). However, doing this in a + modular way would require a change to the solver interface specifications (in + isabelle/src/HOL/Tools/SMT/). *) + SMT_Builtin.add_builtin_fun SMTLIB_Interface.smtlibC (Term.dest_Const t, f n s) + end + + (*Customized interpretation. Check whether the type is supported and add two type arguments + extracted from the result type.*) + fun add_with_Targs n s _ T ts = + let + val (Us, U) = Term.strip_type T + val all_valid = forall is_valid_type (U::Us) + in + case (all_valid, float_Targs U) of + (true, SOME args) => + SOME (param_template2 s args, length Us, ts, Term.list_comb o pair (Const (n, T))) + | _ => NONE + end + + (*Customized interpretation. Check whether the type is supported and add one type argument + extracted from the result type.*) + fun add_with_Targ n s _ T ts = + let + val (Us, U) = Term.strip_type T + val all_valid = forall is_valid_type (U::Us) + in + case (all_valid, word_Targ U) of + (true, SOME arg) => + SOME (param_template1 s arg, length Us, ts, Term.list_comb o pair (Const (n, T))) + | _ => NONE + end + + (*Customized interpretation. Check whether the type is supported.*) + fun add_if_fixed n s _ T ts = + let + val (Us, U) = Term.strip_type T + val all_valid = forall is_valid_type (U::Us) + in + if all_valid then + SOME (s, length Us, ts, Term.list_comb o pair (Const (n, T))) + else + NONE + end + +in + +val setup_builtins = + + (*Types*) + fold (SMT_Builtin.add_builtin_typ SMTLIB_Interface.smtlibC) [ + (\<^typ>\('a::len) Word.word\, word_typ, K (K NONE)), + (\<^typ>\('e::len,'f::len) IEEE_Single_NaN.floatSingleNaN\, float_typ, K (K NONE)), + (\<^typ>\IEEE.roundmode\, K (SOME ("RoundingMode", [])), K (K NONE))] #> + + (*Rounding modes*) + fold (SMT_Builtin.add_builtin_fun' SMTLIB_Interface.smtlibC) [ + (@{const IEEE.roundNearestTiesToEven}, "RNE"), + (@{const IEEE.roundTowardPositive}, "RTP"), + (@{const IEEE.roundTowardNegative}, "RTN"), + (@{const IEEE.roundTowardZero}, "RTZ"), + (@{const IEEE.roundNearestTiesToAway}, "RNA")] #> + + (*Value constructors*) + add_float_fun add_if_fixed + (@{const IEEE_Single_NaN.fp (\'e::len\,\'f::len\)}, "fp") #> + fold (add_float_fun add_with_Targs) [ + (@{const IEEE_Single_NaN.plus_infinity (\'e::len\,\'f::len\)}, "+oo"), + (@{const IEEE_Single_NaN.minus_infinity (\'e::len\,\'f::len\)}, "-oo"), + (@{const zero_class.zero (\('e::len,'f::len) IEEE_Single_NaN.floatSingleNaN\)}, "+zero"), + (@{const IEEE_Single_NaN.minus_zero (\'e::len\,\'f::len\)}, "-zero"), + (@{const IEEE_Single_NaN.NaN (\'e::len\,\'f::len\)}, "NaN")] #> + + (*Operators*) + fold (add_float_fun add_if_fixed) [ + (*arithmetic operators*) + (@{const abs_class.abs (\('e::len,'f::len) IEEE_Single_NaN.floatSingleNaN\)}, "fp.abs"), + (@{const uminus_class.uminus (\('e::len,'f::len) IEEE_Single_NaN.floatSingleNaN\)}, "fp.neg"), + (@{const IEEE_Single_NaN.fadd (\'e::len\,\'f::len\)}, "fp.add"), + (@{const IEEE_Single_NaN.fsub (\'e::len\,\'f::len\)}, "fp.sub"), + (@{const IEEE_Single_NaN.fmul (\'e::len\,\'f::len\)}, "fp.mul"), + (@{const IEEE_Single_NaN.fdiv (\'e::len\,\'f::len\)}, "fp.div"), + (@{const IEEE_Single_NaN.fmul_add (\'e::len\,\'f::len\)}, "fp.fma"), + (@{const IEEE_Single_NaN.fsqrt (\'e::len\,\'f::len\)}, "fp.sqrt"), + (@{const IEEE_Single_NaN.float_rem (\'e::len\,\'f::len\)}, "fp.rem"), + (@{const IEEE_Single_NaN.fintrnd (\'e::len\,\'f::len\)}, "fp.roundToIntegral"), + (*comparison operators, IEEE 754 equality*) + (@{const IEEE_Single_NaN.fle (\'e::len\,\'f::len\)}, "fp.leq"), + (@{const IEEE_Single_NaN.flt (\'e::len\,\'f::len\)}, "fp.lt"), + (@{const IEEE_Single_NaN.fge (\'e::len\,\'f::len\)}, "fp.geq"), + (@{const IEEE_Single_NaN.fgt (\'e::len\,\'f::len\)}, "fp.gt"), + (@{const IEEE_Single_NaN.feq (\'e::len\,\'f::len\)}, "fp.eq"), + (*classification of numbers*) + (@{const IEEE_Single_NaN.is_normal (\'e::len\,\'f::len\)}, "fp.isNormal"), + (@{const IEEE_Single_NaN.is_subnormal (\'e::len\,\'f::len\)}, "fp.isSubnormal"), + (@{const IEEE_Single_NaN.is_zero (\'e::len\,\'f::len\)}, "fp.isZero"), + (@{const IEEE_Single_NaN.is_infinity (\'e::len\,\'f::len\)}, "fp.isInfinite"), + (@{const IEEE_Single_NaN.is_nan (\'e::len\,\'f::len\)}, "fp.isNaN"), + (@{const IEEE_Single_NaN.is_negative (\'e::len\,\'f::len\)}, "fp.isNegative"), + (@{const IEEE_Single_NaN.is_positive (\'e::len\,\'f::len\)}, "fp.isPositive"), + (*conversions to other types*) + (@{const IEEE_Single_NaN.valof (\'e::len\,\'f::len\)}, "fp.to_real")] #> + fold (add_float_fun add_with_Targ) [ + (@{const IEEE_Single_NaN.unsigned_word_of_floatSingleNaN (\'e::len\,\'f::len\,\'a::len\)}, "fp.to_ubv"), + (@{const IEEE_Single_NaN.signed_word_of_floatSingleNaN (\'e::len\,\'f::len\,\'a::len\)}, "fp.to_sbv")] #> + (*conversions from other types*) + fold (add_float_fun add_with_Targs) [ + (@{const IEEE_Single_NaN.floatSingleNaN_of_IEEE754_word (\'a::len\,\'e::len\,\'f::len\)}, "to_fp"), (*FIXME: interpret only if a=e+f+1*) + (@{const IEEE_Single_NaN.round (\'e::len\,\'f::len\)}, "to_fp"), + (@{const IEEE_Single_NaN.floatSingleNaN_of_floatSingleNaN (\'a::len\,\'b::len\,\'a::len\,\'b::len\)}, "to_fp"), + (@{const IEEE_Single_NaN.floatSingleNaN_of_signed_word (\'a::len\,\'e::len\,\'f::len\)}, "to_fp"), + (@{const IEEE_Single_NaN.floatSingleNaN_of_unsigned_word (\'a::len\,\'e::len\,\'f::len\)}, "to_fp_unsigned")] + +end + + +(* Setup *) + +(*Override any other logic.*) +val _ = Theory.setup (Context.theory_map ( + SMTLIB_Interface.add_logic (0, smtlib_logic) #> + setup_builtins + )) + +end; diff --git a/thys/IMP2/lib/named_simpsets.ML b/thys/IMP2/lib/named_simpsets.ML --- a/thys/IMP2/lib/named_simpsets.ML +++ b/thys/IMP2/lib/named_simpsets.ML @@ -1,160 +1,160 @@ (* Named simpsets. Derived from named_theorems.ML *) signature NAMED_SIMPSETS = sig val get: Proof.context -> string -> simpset val clear: string -> Context.generic -> Context.generic val map: string -> (simpset -> simpset) -> Context.generic -> Context.generic val map_ctxt: string -> (Proof.context -> Proof.context) -> Context.generic -> Context.generic val put: string -> Proof.context -> Proof.context val get_all: Proof.context -> simpset Name_Space.table val add_simp: string -> thm -> Context.generic -> Context.generic val del_simp: string -> thm -> Context.generic -> Context.generic val add_cong: string -> thm -> Context.generic -> Context.generic val del_cong: string -> thm -> Context.generic -> Context.generic val add_split: string -> thm -> Context.generic -> Context.generic val del_split: string -> thm -> Context.generic -> Context.generic val add_attr: string -> attribute val del_attr: string -> attribute val add_cong_attr: string -> attribute val del_cong_attr: string -> attribute val add_split_attr: string -> attribute val del_split_attr: string -> attribute val check: Proof.context -> xstring * Position.T -> string val declare: binding -> simpset option -> local_theory -> local_theory val declare_cmd: binding -> (xstring * Position.T) option -> local_theory -> local_theory end; structure Named_Simpsets: NAMED_SIMPSETS = struct (* context data *) structure Data = Generic_Data ( type T = simpset Name_Space.table; val empty: T = Name_Space.empty_table "named-simpset"; val merge : T * T -> T = Name_Space.join_tables (K merge_ss); ); val content = Name_Space.get o Data.get val get = content o Context.Proof; val get_all = Data.get o Context.Proof fun put name ctxt = put_simpset (get ctxt name) ctxt fun map name f context = (content context name; Data.map (Name_Space.map_table_entry name f) context); fun map_ctxt name f context = map name (simpset_map (Context.proof_of context) f) context (* maintain content *) fun clear name = map_ctxt name clear_simpset; fun add_simp name thm = map_ctxt name (Simplifier.add_simp thm) fun del_simp name thm = map_ctxt name (Simplifier.del_simp thm) fun add_cong name thm = map_ctxt name (Simplifier.add_cong thm) fun del_cong name thm = map_ctxt name (Simplifier.del_cong thm) fun add_split name thm = map_ctxt name (Splitter.add_split thm) fun del_split name thm = map_ctxt name (Splitter.del_split thm) val add_attr = Thm.declaration_attribute o add_simp; val del_attr = Thm.declaration_attribute o del_simp; val add_cong_attr = Thm.declaration_attribute o add_cong; val del_cong_attr = Thm.declaration_attribute o del_cong; val add_split_attr = Thm.declaration_attribute o add_split; val del_split_attr = Thm.declaration_attribute o del_split; (* check *) fun check ctxt = let val context = Context.Proof ctxt in Name_Space.check context (Data.get context) #> #1 end (* declaration *) fun new_entry binding init = let fun decl _ context = let val sstab = Data.get context val ss = the_default (Raw_Simplifier.clear_simpset (Context.proof_of context) |> simpset_of) init val (_,sstab) = Name_Space.define context true (binding,ss) sstab in Data.put sstab context end in - Local_Theory.declaration {syntax=false, pervasive=true} decl + Local_Theory.declaration {syntax=false, pervasive=true, pos = \<^here>} decl end fun declare binding init lthy = let val lthy' = lthy |> new_entry binding init in (lthy') end; fun declare_cmd binding init_src lthy = let val init = Option.map (get lthy o check lthy) init_src in declare binding init lthy end val named_simpset_attr = (Args.context -- Scan.lift (Parse.position Parse.embedded)) :|-- (fn (ctxt,raw_binding) => let val name = check ctxt raw_binding in (Scan.lift (Args.$$$ "simp") |-- Attrib.add_del (add_attr name) (del_attr name)) || (Scan.lift (Args.$$$ "cong") |-- Attrib.add_del (add_cong_attr name) (del_cong_attr name)) || (Scan.lift (Args.$$$ "split") |-- Attrib.add_del (add_split_attr name) (del_split_attr name)) || Attrib.add_del (add_attr name) (del_attr name) end ) val _ = Theory.setup (Attrib.setup \<^binding>\named_ss\ named_simpset_attr "Modify named simpsets") val put_named_simpset_attr = (Args.context -- Scan.lift (Parse.position Parse.embedded)) >> (fn (ctxt,raw_binding) => let val name = check ctxt raw_binding val attr = Thm.declaration_attribute (fn _ => Context.map_proof (put name)) in attr end) val _ = Theory.setup (Attrib.setup \<^binding>\put_named_ss\ put_named_simpset_attr "Activate named simpset") (* ML antiquotation *) val _ = Theory.setup (ML_Antiquotation.inline \<^binding>\named_simpset\ (Args.context -- Scan.lift (Parse.position Parse.embedded) >> (fn (ctxt, name) => ML_Syntax.print_string (check ctxt name)))); end; diff --git a/thys/Irrationality_J_Hancl/document/root.bib b/thys/Irrationality_J_Hancl/document/root.bib --- a/thys/Irrationality_J_Hancl/document/root.bib +++ b/thys/Irrationality_J_Hancl/document/root.bib @@ -1,8 +1,20 @@ +%% This BibTeX bibliography file was created using BibDesk. +%% http://bibdesk.sourceforge.net/ + + +%% Created for Larry Paulson at 2023-05-16 11:53:41 +0100 + + +%% Saved with string encoding Unicode (UTF-8) + + + @article{hancl, - title={Irrational rapidly convergent series}, - author={Hancl, JAROSLAV}, - journal={Rend. Sem. Mat. Univ. Padova}, - volume={107}, - pages={225--231}, - year={2002} -} \ No newline at end of file + author = {Han{\v c}l, Jaroslav}, + date-modified = {2023-05-16 11:53:41 +0100}, + journal = {Rendiconti del Seminario Matematico della Universit{\`a} di Padova}, + pages = {225-231}, + title = {Irrational Rapidly Convergent Series}, + url = {http://eudml.org/doc/108582}, + volume = {107}, + year = {2002}} diff --git a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy --- a/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy +++ b/thys/Isabelle_C/C11-FrontEnd/src/C_Lexer_Annotation.thy @@ -1,1413 +1,1413 @@ (****************************************************************************** * Isabelle/C * * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) section \Annotation Language: Parsing Combinator\ theory C_Lexer_Annotation imports C_Lexer_Language begin ML \ \\<^file>\~~/src/Pure/Isar/keyword.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay Analogous to: (* Title: Pure/Isar/keyword.ML Author: Makarius Isar keyword classification. *)*) \ structure C_Keyword = struct (** keyword classification **) (* kinds *) val command_kinds = [Keyword.diag, Keyword.document_heading, Keyword.document_body, Keyword.document_raw, Keyword.thy_begin, Keyword.thy_end, Keyword.thy_load, Keyword.thy_decl, Keyword.thy_decl_block, Keyword.thy_defn, Keyword.thy_stmt, Keyword.thy_goal, Keyword.thy_goal_defn, Keyword.thy_goal_stmt, Keyword.qed, Keyword.qed_script, Keyword.qed_block, Keyword.qed_global, Keyword.prf_goal, Keyword.prf_block, Keyword.next_block, Keyword.prf_open, Keyword.prf_close, Keyword.prf_chain, Keyword.prf_decl, Keyword.prf_asm, Keyword.prf_asm_goal, Keyword.prf_script, Keyword.prf_script_goal, Keyword.prf_script_asm_goal]; (* specifications *) type spec = Keyword.spec; type entry = {pos: Position.T, id: serial, kind: string, tags: string list}; fun check_spec pos ({kind, tags, ...}: spec) : entry = if not (member (op =) command_kinds kind) then error ("Unknown annotation syntax keyword kind " ^ quote kind) else {pos = pos, id = serial (), kind = kind, tags = tags}; (** keyword tables **) (* type keywords *) datatype keywords = Keywords of {minor: Scan.lexicon, major: Scan.lexicon, commands: entry Symtab.table}; fun minor_keywords (Keywords {minor, ...}) = minor; fun major_keywords (Keywords {major, ...}) = major; fun make_keywords (minor, major, commands) = Keywords {minor = minor, major = major, commands = commands}; fun map_keywords f (Keywords {minor, major, commands}) = make_keywords (f (minor, major, commands)); (* build keywords *) val empty_keywords = make_keywords (Scan.empty_lexicon, Scan.empty_lexicon, Symtab.empty); fun empty_keywords' minor = make_keywords (minor, Scan.empty_lexicon, Symtab.empty); fun merge_keywords (Keywords {minor = minor1, major = major1, commands = commands1}, Keywords {minor = minor2, major = major2, commands = commands2}) = make_keywords (Scan.merge_lexicons (minor1, minor2), Scan.merge_lexicons (major1, major2), Symtab.merge (K true) (commands1, commands2)); val add_keywords0 = fold (fn ((name, pos), force_minor, spec as {kind, ...}: spec) => map_keywords (fn (minor, major, commands) => let val extend = Scan.extend_lexicon (Symbol.explode name) fun update spec = Symtab.update (name, spec) in if force_minor then (extend minor, major, update (check_spec pos spec) commands) else if kind = "" orelse kind = Keyword.before_command orelse kind = Keyword.quasi_command then (extend minor, major, commands) else (minor, extend major, update (check_spec pos spec) commands) end)); val add_keywords = add_keywords0 o map (fn (cmd, spec) => (cmd, false, spec)) val add_keywords_minor = add_keywords0 o map (fn (cmd, spec) => (cmd, true, spec)) (* keyword status *) fun is_command (Keywords {commands, ...}) = Symtab.defined commands; fun dest_commands (Keywords {commands, ...}) = Symtab.keys commands; (* command keywords *) fun lookup_command (Keywords {commands, ...}) = Symtab.lookup commands; fun command_markup keywords name = lookup_command keywords name |> Option.map (fn {pos, id, ...} => Position.make_entity_markup {def = false} id Markup.command_keywordN (name, pos)); (* command categories *) fun command_category ks = let val tab = Symtab.make_set ks; fun pred keywords name = (case lookup_command keywords name of NONE => false | SOME {kind, ...} => Symtab.defined tab kind); in pred end; val is_theory_end = command_category [Keyword.thy_end]; val is_proof_asm = command_category [Keyword.prf_asm, Keyword.prf_asm_goal]; val is_improper = command_category [ Keyword.qed_script , Keyword.prf_script , Keyword.prf_script_goal , Keyword.prf_script_asm_goal]; end; \ text \ Notes: \<^item> The next structure contains a duplicated copy of the type \<^ML_type>\Token.T\, since it is not possible to set an arbitrary \<^emph>\slot\ value in \<^ML_structure>\Token\. \<^item> Parsing priorities in C and HOL slightly differ, see for instance \<^ML>\Token.explode\. \ ML \ \\<^file>\~~/src/Pure/Isar/token.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay Analogous to: (* Title: Pure/Isar/token.ML Author: Markus Wenzel, TU Muenchen Outer token syntax for Isabelle/Isar. *)*) \ structure C_Token = struct (** tokens **) (* token kind *) fun equiv_kind kind kind' = (case (kind, kind') of (Token.Control _, Token.Control _) => true | (Token.Error _, Token.Error _) => true | _ => kind = kind'); val immediate_kinds' = fn Token.Command => 0 | Token.Keyword => 1 | Token.Ident => 2 | Token.Long_Ident => 3 | Token.Sym_Ident => 4 | Token.Var => 5 | Token.Type_Ident => 6 | Token.Type_Var => 7 | Token.Nat => 8 | Token.Float => 9 | Token.Space => 10 | _ => ~1 val delimited_kind = (fn Token.String => true | Token.Alt_String => true | Token.Cartouche => true | Token.Control _ => true | Token.Comment _ => true | _ => false); (* datatype token *) (*The value slot assigns an (optional) internal value to a token, usually as a side-effect of special scanner setup (see also args.ML). Note that an assignable ref designates an intermediate state of internalization -- it is NOT meant to persist.*) datatype T = Token of (Symbol_Pos.text * Position.range) * (Token.kind * string) * slot and slot = Slot | Value of value option | Assignable of value option Unsynchronized.ref and value = Source of T list | Literal of bool * Markup.T | Name of Token.name_value * morphism | Typ of typ | Term of term | Fact of string option * thm list | (*optional name for dynamic fact, i.e. fact "variable"*) Attribute of morphism -> attribute | - Declaration of declaration | + Declaration of Morphism.declaration | Files of Token.file Exn.result list | Output of XML.body option; type src = T list; (* position *) fun pos_of (Token ((_, (pos, _)), _, _)) = pos; fun end_pos_of (Token ((_, (_, pos)), _, _)) = pos; fun adjust_offsets adjust (Token ((x, range), y, z)) = Token ((x, apply2 (Position.adjust_offsets adjust) range), y, z); (* stopper *) fun mk_eof pos = Token (("", (pos, Position.none)), (Token.EOF, ""), Slot); val eof = mk_eof Position.none; fun is_eof (Token (_, (Token.EOF, _), _)) = true | is_eof _ = false; val not_eof = not o is_eof; val stopper = Scan.stopper (fn [] => eof | toks => mk_eof (end_pos_of (List.last toks))) is_eof; (* kind of token *) fun kind_of (Token (_, (k, _), _)) = k; fun is_kind k (Token (_, (k', _), _)) = equiv_kind k k'; fun get_control tok = (case kind_of tok of Token.Control control => SOME control | _ => NONE); val is_command = is_kind Token.Command; fun keyword_with pred (Token (_, (Token.Keyword, x), _)) = pred x | keyword_with _ _ = false; val is_command_modifier = keyword_with (fn x => x = "private" orelse x = "qualified"); fun ident_with pred (Token (_, (Token.Ident, x), _)) = pred x | ident_with _ _ = false; fun is_ignored (Token (_, (Token.Space, _), _)) = true | is_ignored (Token (_, (Token.Comment NONE, _), _)) = true | is_ignored _ = false; fun is_proper (Token (_, (Token.Space, _), _)) = false | is_proper (Token (_, (Token.Comment _, _), _)) = false | is_proper _ = true; fun is_comment (Token (_, (Token.Comment _, _), _)) = true | is_comment _ = false; fun is_informal_comment (Token (_, (Token.Comment NONE, _), _)) = true | is_informal_comment _ = false; fun is_formal_comment (Token (_, (Token.Comment (SOME _), _), _)) = true | is_formal_comment _ = false; fun is_document_marker (Token (_, (Token.Comment (SOME Comment.Marker), _), _)) = true | is_document_marker _ = false; fun is_begin_ignore (Token (_, (Token.Comment NONE, "<"), _)) = true | is_begin_ignore _ = false; fun is_end_ignore (Token (_, (Token.Comment NONE, ">"), _)) = true | is_end_ignore _ = false; fun is_error (Token (_, (Token.Error _, _), _)) = true | is_error _ = false; fun is_error' (Token (_, (Token.Error msg, _), _)) = SOME msg | is_error' _ = NONE; fun content_of (Token (_, (_, x), _)) = x; fun content_of' (Token (_, (_, _), Value (SOME (Source l)))) = map (fn Token ((_, (pos, _)), (_, x), _) => (x, pos)) l | content_of' _ = []; val is_stack1 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) => forall (fn tok => content_of tok = "+") l | _ => false; val is_stack2 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) => forall (fn tok => content_of tok = "@") l | _ => false; val is_stack3 = fn Token (_, (Token.Sym_Ident, _), Value (SOME (Source l))) => forall (fn tok => content_of tok = "&") l | _ => false; (* blanks and newlines -- space tokens obey lines *) fun is_space (Token (_, (Token.Space, _), _)) = true | is_space _ = false; fun is_blank (Token (_, (Token.Space, x), _)) = not (String.isSuffix "\n" x) | is_blank _ = false; fun is_newline (Token (_, (Token.Space, x), _)) = String.isSuffix "\n" x | is_newline _ = false; (* range of tokens *) fun range_of (toks as tok :: _) = let val pos' = end_pos_of (List.last toks) in Position.range (pos_of tok, pos') end | range_of [] = Position.no_range; val core_range_of = drop_prefix is_ignored #> drop_suffix is_ignored #> range_of; (* token content *) fun content_of (Token (_, (_, x), _)) = x; fun source_of (Token ((source, _), _, _)) = source; fun input_of (Token ((source, range), (kind, _), _)) = Input.source (delimited_kind kind) source range; fun inner_syntax_of tok = let val x = content_of tok in if YXML.detect x then x else Syntax.implode_input (input_of tok) end; (* markup reports *) local val token_kind_markup = fn Token.Var => (Markup.var, "") | Token.Type_Ident => (Markup.tfree, "") | Token.Type_Var => (Markup.tvar, "") | Token.String => (Markup.string, "") | Token.Alt_String => (Markup.alt_string, "") | Token.Cartouche => (Markup.cartouche, "") | Token.Control _ => (Markup.cartouche, "") | Token.Comment _ => (Markup.ML_comment, "") | Token.Error msg => (Markup.bad (), msg) | _ => (Markup.empty, ""); fun keyword_reports tok = map (fn markup => ((pos_of tok, markup), "")); fun command_markups keywords x = if C_Keyword.is_theory_end keywords x then [Markup.keyword2 |> Markup.keyword_properties] else (if C_Keyword.is_proof_asm keywords x then [Markup.keyword3] else if C_Keyword.is_improper keywords x then [Markup.keyword1, Markup.improper] else [Markup.keyword1]) |> map Markup.command_properties; fun keyword_markup (important, keyword) x = if important orelse Symbol.is_ascii_identifier x then keyword else Markup.delimiter; fun command_minor_markups keywords x = if C_Keyword.is_theory_end keywords x then [Markup.keyword2 |> Markup.keyword_properties] else (if C_Keyword.is_proof_asm keywords x then [Markup.keyword3] else if C_Keyword.is_improper keywords x then [Markup.keyword1, Markup.improper] else if C_Keyword.is_command keywords x then [Markup.keyword1] else [keyword_markup (false, Markup.keyword2 |> Markup.keyword_properties) x]); in fun completion_report tok = if is_kind Token.Keyword tok then map (fn m => ((pos_of tok, m), "")) (Completion.suppress_abbrevs (content_of tok)) else []; fun reports keywords tok = if is_command tok then keyword_reports tok (command_markups keywords (content_of tok)) else if is_stack1 tok orelse is_stack2 tok orelse is_stack3 tok then keyword_reports tok [Markup.keyword2 |> Markup.keyword_properties] else if is_kind Token.Keyword tok then keyword_reports tok (command_minor_markups keywords (content_of tok)) else let val pos = pos_of tok; val (m, text) = token_kind_markup (kind_of tok); val deleted = Symbol_Pos.explode_deleted (source_of tok, pos); in ((pos, m), text) :: map (fn p => ((p, Markup.delete), "")) deleted end; fun markups keywords = map (#2 o #1) o reports keywords; end; (* unparse *) fun unparse' (Token ((source0, _), (kind, x), _)) = let val source = \ \ We are computing a reverse function of \<^ML>\Symbol_Pos.implode_range\ taking into account consecutive \<^ML>\Symbol.DEL\ symbols potentially appearing at the beginning, or at the end of the string.\ case Symbol.explode source0 of x :: xs => if x = Symbol.DEL then case rev xs of x' :: xs => if x' = Symbol.DEL then implode (rev xs) else source0 | _ => source0 else source0 | _ => source0 in case kind of Token.String => Symbol_Pos.quote_string_qq source | Token.Alt_String => Symbol_Pos.quote_string_bq source | Token.Cartouche => cartouche source | Token.Control control => Symbol_Pos.content (Antiquote.control_symbols control) | Token.Comment NONE => enclose "(*" "*)" source | Token.EOF => "" | _ => x end; fun text_of tok = let val k = Token.str_of_kind (kind_of tok); val ms = markups C_Keyword.empty_keywords tok; val s = unparse' tok; in if s = "" then (k, "") else if size s < 40 andalso not (exists_string (fn c => c = "\n") s) then (k ^ " " ^ Markup.markups ms s, "") else (k, Markup.markups ms s) end; (** associated values **) (* inlined file content *) fun file_source (file: Token.file) = let val text = cat_lines (#lines file); val end_pos = Position.symbol_explode text (#pos file); in Input.source true text (Position.range (#pos file, end_pos)) end; fun get_files (Token (_, _, Value (SOME (Files files)))) = files | get_files _ = []; fun put_files [] tok = tok | put_files files (Token (x, y, Slot)) = Token (x, y, Value (SOME (Files files))) | put_files _ tok = raise Fail ("Cannot put inlined files here" ^ Position.here (pos_of tok)); (* access values *) (* reports of value *) (* name value *) (* maxidx *) (* fact values *) (* transform *) (* static binding *) (*1st stage: initialize assignable slots*) fun init_assignable tok = (case tok of Token (x, y, Slot) => Token (x, y, Assignable (Unsynchronized.ref NONE)) | Token (_, _, Value _) => tok | Token (_, _, Assignable r) => (r := NONE; tok)); (*2nd stage: assign values as side-effect of scanning*) fun assign v tok = (case tok of Token (x, y, Slot) => Token (x, y, Value v) | Token (_, _, Value _) => tok | Token (_, _, Assignable r) => (r := v; tok)); fun evaluate mk eval arg = let val x = eval arg in (assign (SOME (mk x)) arg; x) end; (*3rd stage: static closure of final values*) fun closure (Token (x, y, Assignable (Unsynchronized.ref v))) = Token (x, y, Value v) | closure tok = tok; (* pretty *) (* src *) (** scanners **) open Basic_Symbol_Pos; val err_prefix = "Annotation lexical error: "; fun !!! msg = Symbol_Pos.!!! (fn () => err_prefix ^ msg); (* scan stack *) fun scan_stack is_stack = Scan.optional (Scan.one is_stack >> content_of') [] (* scan symbolic idents *) val scan_symid = Scan.many1 (Symbol.is_symbolic_char o Symbol_Pos.symbol) || Scan.one (Symbol.is_symbolic o Symbol_Pos.symbol) >> single; fun is_symid str = (case try Symbol.explode str of SOME [s] => Symbol.is_symbolic s orelse Symbol.is_symbolic_char s | SOME ss => forall Symbol.is_symbolic_char ss | _ => false); fun ident_or_symbolic "begin" = false | ident_or_symbolic ":" = true | ident_or_symbolic "::" = true | ident_or_symbolic s = Symbol_Pos.is_identifier s orelse is_symid s; (* scan cartouche *) val scan_cartouche = Symbol_Pos.scan_pos -- ((Symbol_Pos.scan_cartouche err_prefix >> Symbol_Pos.cartouche_content) -- Symbol_Pos.scan_pos); (* scan space *) fun space_symbol (s, _) = Symbol.is_blank s andalso s <> "\n"; val scan_space = Scan.many1 space_symbol @@@ Scan.optional ($$$ "\n") [] || Scan.many space_symbol @@@ $$$ "\n"; (* scan comment *) val scan_comment = Symbol_Pos.scan_pos -- (Symbol_Pos.scan_comment_body err_prefix -- Symbol_Pos.scan_pos); (** token sources **) local fun token_leq ((_, syms1), (_, syms2)) = length syms1 <= length syms2; fun token k ss = Token ((Symbol_Pos.implode ss, Symbol_Pos.range ss), (k, Symbol_Pos.content ss), Slot); fun token' (mk_value, k) ss = if mk_value then Token ( (Symbol_Pos.implode ss, Symbol_Pos.range ss) , (k, Symbol_Pos.content ss) , Value (SOME (Source (map (fn (s, pos) => Token (("", (pos, Position.none)), (k, s), Slot)) ss)))) else token k ss; fun token_t k = token' (true, k) fun token_range k (pos1, (ss, pos2)) = Token (Symbol_Pos.implode_range (pos1, pos2) ss, (k, Symbol_Pos.content ss), Slot); fun scan_token keywords = !!! "bad input" (Symbol_Pos.scan_string_qq err_prefix >> token_range Token.String || Symbol_Pos.scan_string_bq err_prefix >> token_range Token.Alt_String || scan_comment >> token_range (Token.Comment NONE) || Comment.scan_outer >> (fn (k, ss) => token (Token.Comment (SOME k)) ss) || scan_cartouche >> token_range Token.Cartouche || Antiquote.scan_control err_prefix >> (fn control => token (Token.Control control) (Antiquote.control_symbols control)) || scan_space >> token Token.Space || Scan.repeats1 ($$$ "+") >> token_t Token.Sym_Ident || Scan.repeats1 ($$$ "@") >> token_t Token.Sym_Ident || Scan.repeats1 ($$$ "&") >> token_t Token.Sym_Ident || (Scan.max token_leq (Scan.max token_leq (Scan.literal (C_Keyword.major_keywords keywords) >> pair Token.Command) (Scan.literal (C_Keyword.minor_keywords keywords) >> pair Token.Keyword)) (Lexicon.scan_longid >> pair Token.Long_Ident || Scan.max token_leq (C_Lex.scan_ident' >> pair Token.Ident) (Lexicon.scan_id >> pair Token.Ident) || Lexicon.scan_var >> pair Token.Var || Lexicon.scan_tid >> pair Token.Type_Ident || Lexicon.scan_tvar >> pair Token.Type_Var || Symbol_Pos.scan_float >> pair Token.Float || Symbol_Pos.scan_nat >> pair Token.Nat || scan_symid >> pair Token.Sym_Ident)) >> uncurry (token' o pair false)); fun recover msg = (Symbol_Pos.recover_string_qq || Symbol_Pos.recover_string_bq || Symbol_Pos.recover_cartouche || Symbol_Pos.recover_comment || Scan.one (Symbol.not_eof o Symbol_Pos.symbol) >> single) >> (single o token (Token.Error msg)); in fun make_source keywords {strict} = let val scan_strict = Scan.bulk (scan_token keywords); val scan = if strict then scan_strict else Scan.recover scan_strict recover; in Source.source Symbol_Pos.stopper scan end; end; (* explode *) fun tokenize keywords strict syms = Source.of_list syms |> make_source keywords strict |> Source.exhaust; fun explode keywords pos text = Symbol_Pos.explode (text, pos) |> tokenize keywords {strict = false}; fun explode0 keywords = explode keywords Position.none; (* print names in parsable form *) (* make *) (** parsers **) type 'a parser = T list -> 'a * T list; type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list); (* wrapped syntax *) local fun make src pos = Token.make src pos |> #1 fun make_default text pos = make ((~1, 0), text) pos fun explode keywords pos text = case Token.explode keywords pos text of [tok] => tok | _ => make_default text pos in fun syntax' f = I #> map (fn tok0 as Token ((source, (pos1, pos2)), (kind, x), _) => if is_stack1 tok0 orelse is_stack2 tok0 orelse is_stack3 tok0 then make_default source pos1 else if is_eof tok0 then Token.eof else if delimited_kind kind then explode Keyword.empty_keywords pos1 (unparse' tok0) else let val tok1 = explode ((case kind of Token.Keyword => Keyword.add_keywords [((x, Position.none), Keyword.no_spec)] | Token.Command => Keyword.add_keywords [( (x, Position.none) , Keyword.command_spec (Keyword.thy_decl, []))] | _ => I) Keyword.empty_keywords) pos1 source in if Token.kind_of tok1 = kind then tok1 else make ( ( immediate_kinds' kind , case Position.distance_of (pos1, pos2) of NONE => 0 | SOME i => i) , source) pos1 end) #> f #> apsnd (map (fn tok => Token ( (Token.source_of tok, Token.range_of [tok]) , (Token.kind_of tok, Token.content_of tok) , Slot))) end end; type 'a c_parser = 'a C_Token.parser; type 'a c_context_parser = 'a C_Token.context_parser; \ (* parsers for C syntax. A partial copy is unfortunately necessary due to signature restrictions. *) ML \ \\<^file>\~~/src/Pure/Isar/parse.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay Analogous to: (* Title: Pure/Isar/parse.ML Author: Markus Wenzel, TU Muenchen Generic parsers for Isabelle/Isar outer syntax. *)*) \ signature C_PARSE = sig type T type src = T list type 'a parser = T list -> 'a * T list type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list) (**) val C_source: Input.source parser val star: string parser (**) val group: (unit -> string) -> (T list -> 'a) -> T list -> 'a val !!! : (T list -> 'a) -> T list -> 'a val !!!! : (T list -> 'a) -> T list -> 'a val not_eof: T parser val token: 'a parser -> T parser val range: 'a parser -> ('a * Position.range) parser val position: 'a parser -> ('a * Position.T) parser val input: 'a parser -> Input.source parser val inner_syntax: 'a parser -> string parser val command: string parser val keyword: string parser val short_ident: string parser val long_ident: string parser val sym_ident: string parser val dots: string parser val minus: string parser val term_var: string parser val type_ident: string parser val type_var: string parser val number: string parser val float_number: string parser val string: string parser val string_position: (string * Position.T) parser val alt_string: string parser val cartouche: string parser val control: Antiquote.control parser val eof: string parser val command_name: string -> string parser val keyword_with: (string -> bool) -> string parser val keyword_markup: bool * Markup.T -> string -> string parser val keyword_improper: string -> string parser val $$$ : string -> string parser val reserved: string -> string parser val underscore: string parser val maybe: 'a parser -> 'a option parser val maybe_position: ('a * Position.T) parser -> ('a option * Position.T) parser val opt_keyword: string -> bool parser val opt_bang: bool parser val begin: string parser val opt_begin: bool parser val nat: int parser val int: int parser val real: real parser val enum_positions: string -> 'a parser -> ('a list * Position.T list) parser val enum1_positions: string -> 'a parser -> ('a list * Position.T list) parser val enum: string -> 'a parser -> 'a list parser val enum1: string -> 'a parser -> 'a list parser val and_list: 'a parser -> 'a list parser val and_list1: 'a parser -> 'a list parser val enum': string -> 'a context_parser -> 'a list context_parser val enum1': string -> 'a context_parser -> 'a list context_parser val and_list': 'a context_parser -> 'a list context_parser val and_list1': 'a context_parser -> 'a list context_parser val list: 'a parser -> 'a list parser val list1: 'a parser -> 'a list parser val name: string parser val name_range: (string * Position.range) parser val name_position: (string * Position.T) parser val binding: binding parser val embedded: string parser val embedded_inner_syntax: string parser val embedded_input: Input.source parser val embedded_position: (string * Position.T) parser val path_input: Input.source parser val path: string parser val path_binding: (string * Position.T) parser val session_name: (string * Position.T) parser val theory_name: (string * Position.T) parser val liberal_name: string parser val parname: string parser val parbinding: binding parser val class: string parser val sort: string parser val type_const: string parser val arity: (string * string list * string) parser val multi_arity: (string list * string list * string) parser val type_args: string list parser val type_args_constrained: (string * string option) list parser val typ: string parser val mixfix: mixfix parser val mixfix': mixfix parser val opt_mixfix: mixfix parser val opt_mixfix': mixfix parser val syntax_mode: Syntax.mode parser val where_: string parser val const_decl: (string * string * mixfix) parser val const_binding: (binding * string * mixfix) parser val params: (binding * string option * mixfix) list parser val vars: (binding * string option * mixfix) list parser val for_fixes: (binding * string option * mixfix) list parser val ML_source: Input.source parser val document_source: Input.source parser val document_marker: Input.source parser val const: string parser val term: string parser val prop: string parser val literal_fact: string parser val propp: (string * string list) parser val termp: (string * string list) parser val private: Position.T parser val qualified: Position.T parser val target: (string * Position.T) parser val opt_target: (string * Position.T) option parser val args: T list parser val args1: (string -> bool) -> T list parser val attribs: src list parser val opt_attribs: src list parser val thm_sel: Facts.interval list parser val thm: (Facts.ref * src list) parser val thms1: (Facts.ref * src list) list parser val options: ((string * Position.T) * (string * Position.T)) list parser val embedded_ml: ML_Lex.token Antiquote.antiquote list parser end; structure C_Parse: C_PARSE = struct type T = C_Token.T type src = T list type 'a parser = T list -> 'a * T list type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list) structure Token = struct open Token open C_Token end (** error handling **) (* group atomic parsers (no cuts!) *) fun group s scan = scan || Scan.fail_with (fn [] => (fn () => s () ^ " expected,\nbut end-of-input was found") | tok :: _ => (fn () => (case Token.text_of tok of (txt, "") => s () ^ " expected,\nbut " ^ txt ^ Position.here (Token.pos_of tok) ^ " was found" | (txt1, txt2) => s () ^ " expected,\nbut " ^ txt1 ^ Position.here (Token.pos_of tok) ^ " was found:\n" ^ txt2))); (* cut *) fun cut kind scan = let fun get_pos [] = " (end-of-input)" | get_pos (tok :: _) = Position.here (Token.pos_of tok); fun err (toks, NONE) = (fn () => kind ^ get_pos toks) | err (toks, SOME msg) = (fn () => let val s = msg () in if String.isPrefix kind s then s else kind ^ get_pos toks ^ ": " ^ s end); in Scan.!! err scan end; fun !!! scan = cut "Annotation syntax error" scan; fun !!!! scan = cut "Corrupted annotation syntax in presentation" scan; (** basic parsers **) (* tokens *) fun RESET_VALUE atom = (*required for all primitive parsers*) Scan.ahead (Scan.one (K true)) -- atom >> (fn (arg, x) => (Token.assign NONE arg; x)); val not_eof = RESET_VALUE (Scan.one Token.not_eof); fun token atom = Scan.ahead not_eof --| atom; fun range scan = (Scan.ahead not_eof >> (Token.range_of o single)) -- scan >> Library.swap; fun position scan = (Scan.ahead not_eof >> Token.pos_of) -- scan >> Library.swap; fun input atom = Scan.ahead atom |-- not_eof >> Token.input_of; fun inner_syntax atom = Scan.ahead atom |-- not_eof >> Token.inner_syntax_of; fun kind k = group (fn () => Token.str_of_kind k) (RESET_VALUE (Scan.one (Token.is_kind k) >> Token.content_of)); val command = kind Token.Command; val keyword = kind Token.Keyword; val short_ident = kind Token.Ident; val long_ident = kind Token.Long_Ident; val sym_ident = kind Token.Sym_Ident; val term_var = kind Token.Var; val type_ident = kind Token.Type_Ident; val type_var = kind Token.Type_Var; val number = kind Token.Nat; val float_number = kind Token.Float; val string = kind Token.String; val alt_string = kind Token.Alt_String; val cartouche = kind Token.Cartouche; val control = token (kind Token.control_kind) >> (the o Token.get_control); val eof = kind Token.EOF; fun command_name x = group (fn () => Token.str_of_kind Token.Command ^ " " ^ quote x) (RESET_VALUE (Scan.one (fn tok => Token.is_command tok andalso Token.content_of tok = x))) >> Token.content_of; fun keyword_with pred = RESET_VALUE (Scan.one (Token.keyword_with pred) >> Token.content_of); fun keyword_markup markup x = group (fn () => Token.str_of_kind Token.Keyword ^ " " ^ quote x) (Scan.ahead not_eof -- keyword_with (fn y => x = y)) >> (fn (tok, x) => (Token.assign (SOME (Token.Literal markup)) tok; x)); val keyword_improper = keyword_markup (true, Markup.improper); val $$$ = keyword_markup (false, Markup.quasi_keyword); fun reserved x = group (fn () => "reserved identifier " ^ quote x) (RESET_VALUE (Scan.one (Token.ident_with (fn y => x = y)) >> Token.content_of)); val dots = sym_ident :-- (fn "\" => Scan.succeed () | _ => Scan.fail) >> #1; val minus = sym_ident :-- (fn "-" => Scan.succeed () | _ => Scan.fail) >> #1; val underscore = sym_ident :-- (fn "_" => Scan.succeed () | _ => Scan.fail) >> #1; fun maybe scan = underscore >> K NONE || scan >> SOME; fun maybe_position scan = position (underscore >> K NONE) || scan >> apfst SOME; val nat = number >> (#1 o Library.read_int o Symbol.explode); val int = Scan.optional (minus >> K ~1) 1 -- nat >> op *; val real = float_number >> Value.parse_real || int >> Real.fromInt; fun opt_keyword s = Scan.optional ($$$ "(" |-- !!! (($$$ s >> K true) --| $$$ ")")) false; val opt_bang = Scan.optional ($$$ "!" >> K true) false; val begin = $$$ "begin"; val opt_begin = Scan.optional (begin >> K true) false; (* enumerations *) fun enum1_positions sep scan = scan -- Scan.repeat (position ($$$ sep) -- !!! scan) >> (fn (x, ys) => (x :: map #2 ys, map (#2 o #1) ys)); fun enum_positions sep scan = enum1_positions sep scan || Scan.succeed ([], []); fun enum1 sep scan = scan ::: Scan.repeat ($$$ sep |-- !!! scan); fun enum sep scan = enum1 sep scan || Scan.succeed []; fun enum1' sep scan = scan ::: Scan.repeat (Scan.lift ($$$ sep) |-- scan); fun enum' sep scan = enum1' sep scan || Scan.succeed []; fun and_list1 scan = enum1 "and" scan; fun and_list scan = enum "and" scan; fun and_list1' scan = enum1' "and" scan; fun and_list' scan = enum' "and" scan; fun list1 scan = enum1 "," scan; fun list scan = enum "," scan; (* names and embedded content *) val name = group (fn () => "name") (short_ident || long_ident || sym_ident || number || string); val name_range = input name >> Input.source_content_range; val name_position = input name >> Input.source_content; val string_position = input string >> Input.source_content; val binding = name_position >> Binding.make; val embedded = group (fn () => "embedded content") (cartouche || string || short_ident || long_ident || sym_ident || term_var || type_ident || type_var || number); val embedded_inner_syntax = inner_syntax embedded; val embedded_input = input embedded; val embedded_position = embedded_input >> Input.source_content; val path_input = group (fn () => "file name/path specification") embedded_input; val path = path_input >> Input.string_of; val path_binding = group (fn () => "path binding (strict file name)") (position embedded); val session_name = group (fn () => "session name") name_position; val theory_name = group (fn () => "theory name") name_position; val liberal_name = keyword_with Token.ident_or_symbolic || name; val parname = Scan.optional ($$$ "(" |-- name --| $$$ ")") ""; val parbinding = Scan.optional ($$$ "(" |-- binding --| $$$ ")") Binding.empty; (* type classes *) val class = group (fn () => "type class") (inner_syntax embedded); val sort = group (fn () => "sort") (inner_syntax embedded); val type_const = group (fn () => "type constructor") (inner_syntax embedded); val arity = type_const -- ($$$ "::" |-- !!! (Scan.optional ($$$ "(" |-- !!! (list1 sort --| $$$ ")")) [] -- sort)) >> Scan.triple2; val multi_arity = and_list1 type_const -- ($$$ "::" |-- !!! (Scan.optional ($$$ "(" |-- !!! (list1 sort --| $$$ ")")) [] -- sort)) >> Scan.triple2; (* types *) val typ = group (fn () => "type") (inner_syntax embedded); fun type_arguments arg = arg >> single || $$$ "(" |-- !!! (list1 arg --| $$$ ")") || Scan.succeed []; val type_args = type_arguments type_ident; val type_args_constrained = type_arguments (type_ident -- Scan.option ($$$ "::" |-- !!! sort)); (* mixfix annotations *) local val mfix = input (string || cartouche); val mixfix_ = mfix -- !!! (Scan.optional ($$$ "[" |-- !!! (list nat --| $$$ "]")) [] -- Scan.optional nat 1000) >> (fn (sy, (ps, p)) => fn range => Mixfix (sy, ps, p, range)); val structure_ = $$$ "structure" >> K Structure; val binder_ = $$$ "binder" |-- !!! (mfix -- ($$$ "[" |-- nat --| $$$ "]" -- nat || nat >> (fn n => (n, n)))) >> (fn (sy, (p, q)) => fn range => Binder (sy, p, q, range)); val infixl_ = $$$ "infixl" |-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infixl (sy, p, range))); val infixr_ = $$$ "infixr" |-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infixr (sy, p, range))); val infix_ = $$$ "infix" |-- !!! (mfix -- nat >> (fn (sy, p) => fn range => Infix (sy, p, range))); val mixfix_body = mixfix_ || structure_ || binder_ || infixl_ || infixr_ || infix_; fun annotation guard body = Scan.trace ($$$ "(" |-- guard (body --| $$$ ")")) >> (fn (mx, toks) => mx (Token.range_of toks)); fun opt_annotation guard body = Scan.optional (annotation guard body) NoSyn; in val mixfix = annotation !!! mixfix_body; val mixfix' = annotation I mixfix_body; val opt_mixfix = opt_annotation !!! mixfix_body; val opt_mixfix' = opt_annotation I mixfix_body; end; (* syntax mode *) val syntax_mode_spec = ($$$ "output" >> K ("", false)) || name -- Scan.optional ($$$ "output" >> K false) true; val syntax_mode = Scan.optional ($$$ "(" |-- !!! (syntax_mode_spec --| $$$ ")")) Syntax.mode_default; (* fixes *) val where_ = $$$ "where"; val const_decl = name -- ($$$ "::" |-- !!! typ) -- opt_mixfix >> Scan.triple1; val const_binding = binding -- ($$$ "::" |-- !!! typ) -- opt_mixfix >> Scan.triple1; val param_mixfix = binding -- Scan.option ($$$ "::" |-- typ) -- mixfix' >> (single o Scan.triple1); val params = (binding -- Scan.repeat binding) -- Scan.option ($$$ "::" |-- !!! (Scan.ahead typ -- embedded)) >> (fn ((x, ys), T) => (x, Option.map #1 T, NoSyn) :: map (fn y => (y, Option.map #2 T, NoSyn)) ys); val vars = and_list1 (param_mixfix || params) >> flat; val for_fixes = Scan.optional ($$$ "for" |-- !!! vars) []; (* embedded source text *) val ML_source = input (group (fn () => "ML source") embedded); val document_source = input (group (fn () => "document source") embedded); val document_marker = group (fn () => "document marker") (RESET_VALUE (Scan.one Token.is_document_marker >> Token.input_of)); (* terms *) val const = group (fn () => "constant") (inner_syntax embedded); val term = group (fn () => "term") (inner_syntax embedded); val prop = group (fn () => "proposition") (inner_syntax embedded); val literal_fact = inner_syntax (group (fn () => "literal fact") (alt_string || cartouche)); (* patterns *) val is_terms = Scan.repeat1 ($$$ "is" |-- term); val is_props = Scan.repeat1 ($$$ "is" |-- prop); val propp = prop -- Scan.optional ($$$ "(" |-- !!! (is_props --| $$$ ")")) []; val termp = term -- Scan.optional ($$$ "(" |-- !!! (is_terms --| $$$ ")")) []; (* target information *) val private = position ($$$ "private") >> #2; val qualified = position ($$$ "qualified") >> #2; val target = ($$$ "(" -- $$$ "in") |-- !!! (name_position --| $$$ ")"); val opt_target = Scan.option target; (* arguments within outer syntax *) local val argument_kinds = [Token.Ident, Token.Long_Ident, Token.Sym_Ident, Token.Var, Token.Type_Ident, Token.Type_Var, Token.Nat, Token.Float, Token.String, Token.Alt_String, Token.Cartouche]; fun arguments is_symid = let fun argument blk = group (fn () => "argument") (Scan.one (fn tok => let val kind = Token.kind_of tok in member (op =) argument_kinds kind orelse Token.keyword_with is_symid tok orelse (blk andalso Token.keyword_with (fn s => s = ",") tok) end)); fun args blk x = Scan.optional (args1 blk) [] x and args1 blk x = (Scan.repeats1 (Scan.repeat1 (argument blk) || argsp "(" ")" || argsp "[" "]")) x and argsp l r x = (token ($$$ l) ::: !!! (args true @@@ (token ($$$ r) >> single))) x; in (args, args1) end; in val args = #1 (arguments Token.ident_or_symbolic) false; fun args1 is_symid = #2 (arguments is_symid) false; end; (* attributes *) val attrib = token liberal_name ::: !!! args; val attribs = $$$ "[" |-- list attrib --| $$$ "]"; val opt_attribs = Scan.optional attribs []; (* theorem references *) val thm_sel = $$$ "(" |-- list1 (nat --| minus -- nat >> Facts.FromTo || nat --| minus >> Facts.From || nat >> Facts.Single) --| $$$ ")"; val thm = $$$ "[" |-- attribs --| $$$ "]" >> pair (Facts.named "") || (literal_fact >> Facts.Fact || name_position -- Scan.option thm_sel >> Facts.Named) -- opt_attribs; val thms1 = Scan.repeat1 thm; (* options *) val option_name = group (fn () => "option name") name_position; val option_value = group (fn () => "option value") ((token real || token name) >> Token.content_of); val option = option_name :-- (fn (_, pos) => Scan.optional ($$$ "=" |-- !!! (position option_value)) ("true", pos)); val options = $$$ "[" |-- list1 option --| $$$ "]"; (* embedded ML *) val embedded_ml = input underscore >> ML_Lex.read_source || embedded_input >> ML_Lex.read_source || control >> (ML_Lex.read_symbols o Antiquote.control_symbols); (* read embedded source, e.g. for antiquotations *) (** C basic parsers **) (* embedded source text *) val C_source = input (group (fn () => "C source") embedded); (* AutoCorres (MODIFIES) *) val star = sym_ident :-- (fn "*" => Scan.succeed () | _ => Scan.fail) >> #1; end; structure C_Parse_Native: C_PARSE = struct open Token open Parse (** C basic parsers **) (* embedded source text *) val C_source = input (group (fn () => "C source") embedded); (* AutoCorres (MODIFIES) *) val star = sym_ident :-- (fn "*" => Scan.succeed () | _ => Scan.fail) >> #1; end; structure C_Parse_Read = struct (* read embedded source, e.g. for antiquotations *) fun read_with_commands'0 keywords syms = Source.of_list syms |> C_Token.make_source keywords {strict = false} |> Source.filter (not o C_Token.is_proper) |> Source.exhaust fun read_with_commands' keywords scan syms = Source.of_list syms |> C_Token.make_source keywords {strict = false} |> Source.filter C_Token.is_proper |> Source.source C_Token.stopper (Scan.recover (Scan.bulk scan) (fn msg => Scan.one (not o C_Token.is_eof) >> (fn tok => [C_Scan.Right let val msg = case C_Token.is_error' tok of SOME msg0 => msg0 ^ " (" ^ msg ^ ")" | NONE => msg in ( msg , [((C_Token.pos_of tok, Markup.bad ()), msg)] , tok) end]))) |> Source.exhaust; fun read_antiq' keywords scan = read_with_commands' keywords (scan >> C_Scan.Left); end \ ML \ \\<^file>\~~/src/Pure/Thy/thy_header.ML\\ (* Author: Frédéric Tuong, Université Paris-Saclay Analogous to: (* Title: Pure/Thy/thy_header.ML Author: Makarius Static theory header information. *)*) \ structure C_Thy_Header = struct val bootstrap_keywords = C_Keyword.empty_keywords' (Keyword.minor_keywords (Thy_Header.get_keywords @{theory})) (* theory data *) structure Data = Theory_Data ( type T = C_Keyword.keywords; val empty = bootstrap_keywords; val merge = C_Keyword.merge_keywords; ); val add_keywords = Data.map o C_Keyword.add_keywords; val add_keywords_minor = Data.map o C_Keyword.add_keywords_minor; val get_keywords = Data.get; val get_keywords' = get_keywords o Proof_Context.theory_of; end \ end diff --git a/thys/Lazy_Case/lazy_case.ML b/thys/Lazy_Case/lazy_case.ML --- a/thys/Lazy_Case/lazy_case.ML +++ b/thys/Lazy_Case/lazy_case.ML @@ -1,192 +1,192 @@ signature LAZY_CASE = sig val lazify: Ctr_Sugar.ctr_sugar -> local_theory -> local_theory val lazify_typ: typ -> local_theory -> local_theory val lazify_cmd: string -> local_theory -> local_theory val lazy_case_plugin: string val setup: theory -> theory end structure Lazy_Case : LAZY_CASE = struct structure Data = Generic_Data ( type T = Symtab.set val empty = Symtab.empty val merge = Symtab.merge op = ) fun init [] = error "empty list" | init [_] = [] | init (x :: xs) = x :: init xs fun lazify {T, casex, ctrs, case_thms, case_cong, ...} lthy = let val is_fun = can dest_funT val typ_name = fst (dest_Type T) val len = length ctrs val idxs = 0 upto len - 1 val (name, typ) = dest_Const casex ||> Logic.unvarifyT_global val (typs, _) = strip_type typ val exists = Symtab.defined (Data.get (Context.Proof lthy)) typ_name val warn = Pretty.separate "" [Syntax.pretty_typ lthy T, Pretty.str "already lazified"] |> Pretty.block val _ = if exists then warning (Pretty.string_of warn) else () in (* for records, casex is the dummy pattern *) if Term.is_dummy_pattern casex orelse forall is_fun (init typs) orelse exists then lthy else let val arg_typs = init typs fun apply_to_unit typ idx = if is_fun typ then (typ, Bound idx) else (@{typ unit} --> typ, Bound idx $ @{term "()"}) val (arg_typs', args) = split_list (map2 apply_to_unit arg_typs (rev idxs)) val def = list_comb (Const (name, typ), args) |> fold_rev Term.abs (map (pair "c") arg_typs') val binding = Binding.name "case_lazy" val ((term, thm), (lthy', lthy)) = (snd o Local_Theory.begin_nested) lthy |> Proof_Context.concealed |> Local_Theory.map_background_naming (Name_Space.mandatory_path typ_name) |> Local_Theory.define ((binding, NoSyn), ((Thm.def_binding binding, []), def)) |>> apsnd snd ||> `Local_Theory.end_nested val phi = Proof_Context.export_morphism lthy lthy' val thm' = Morphism.thm phi thm val term' = Logic.unvarify_global (Morphism.term phi term) fun defs_tac ctxt idx = Local_Defs.unfold_tac ctxt [thm', nth case_thms idx] THEN HEADGOAL (resolve_tac ctxt @{thms refl}) val frees = fastype_of term' |> strip_type |> fst |> init val frees_f = Name.invent_names Name.context "f0" frees val frees_g = Name.invent_names Name.context "g0" frees val fs = map Free frees_f val gs = map Free frees_g fun mk_def_goal ctr idx = let val (name, len) = dest_Const ctr ||> strip_type ||> fst ||> length val frees = Name.invent Name.context "p0" len val args = map (Free o rpair dummyT) frees val ctr_val = list_comb (Const (name, dummyT), args) val lhs = list_comb (term', fs) $ ctr_val val rhs = if len = 0 then nth fs idx $ @{term "()"} else list_comb (nth fs idx, args) in (frees, HOLogic.mk_Trueprop (Syntax.check_term lthy' (HOLogic.mk_eq (lhs, rhs)))) end fun prove_defs (frees', goal) idx = Goal.prove_future lthy' (map fst frees_f @ frees') [] goal (fn {context, ...} => defs_tac context idx) val def_thms = map2 prove_defs (map2 mk_def_goal ctrs idxs) idxs val frees = Name.invent_names Name.context "q0" arg_typs val unfold_goal = let val lhs = list_comb (Const (name, typ), map Free frees) fun mk_abs (name, typ) = if is_fun typ then Free (name, typ) else Abs ("u", @{typ unit}, Free (name, typ)) val rhs = list_comb (Const (fst (dest_Const term'), dummyT), map mk_abs frees) in HOLogic.mk_Trueprop (Syntax.check_term lthy' (HOLogic.mk_eq (lhs, rhs))) end fun unfold_tac ctxt = Local_Defs.unfold_tac ctxt [thm'] THEN HEADGOAL (resolve_tac ctxt @{thms refl}) val unfold_thm = Goal.prove_future lthy' (map fst frees) [] unfold_goal (fn {context, ...} => unfold_tac context) fun mk_cong_prem t ctr (f, g) = let (* FIXME get rid of dummyT here *) fun mk_all t = Logic.all_const dummyT $ Abs ("", dummyT, t) val len = dest_Const ctr |> snd |> strip_type |> fst |> length val args = map Bound (len - 1 downto 0) val ctr_val = list_comb (Logic.unvarify_global ctr, args) val args' = if len = 0 then [Bound 0] else args val lhs = list_comb (f, args') val rhs = list_comb (g, args') val concl = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) val prem = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, ctr_val)) in fold (K mk_all) args' (Logic.mk_implies (prem, concl)) end val cong_goal = let val t1 = Free ("t1", Logic.unvarifyT_global T) val t2 = Free ("t2", Logic.unvarifyT_global T) val prems = HOLogic.mk_Trueprop (HOLogic.mk_eq (t1, t2)) :: map2 (mk_cong_prem t2) ctrs (fs ~~ gs) val lhs = list_comb (term', fs) $ t1 val rhs = list_comb (term', gs) $ t2 val concl = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) in Logic.list_implies (prems, concl) |> Syntax.check_term lthy' end fun cong_tac ctxt = Local_Defs.unfold_tac ctxt [thm'] THEN HEADGOAL (eresolve_tac ctxt [case_cong]) THEN ALLGOALS (ctxt |> Subgoal.FOCUS (fn {context = ctxt, prems, ...} => HEADGOAL (resolve_tac ctxt prems THEN' resolve_tac ctxt prems))) val cong_thm = Goal.prove_future lthy' ("t1" :: "t2" :: map fst frees_f @ map fst frees_g) [] cong_goal (fn {context, ...} => cong_tac context) val upd = Data.map (Symtab.update_new (typ_name, ())) in lthy' |> Local_Theory.note ((Binding.empty, @{attributes [code]}), def_thms) |> snd |> Local_Theory.note ((Binding.empty, @{attributes [code_unfold]}), [unfold_thm]) |> snd |> Local_Theory.note ((Binding.empty, @{attributes [fundef_cong]}), [cong_thm]) |> snd - |> Local_Theory.declaration {syntax = false, pervasive = true} (K upd) + |> Local_Theory.declaration {syntax = false, pervasive = true, pos = \<^here>} (K upd) end end fun lazify_typ typ lthy = lazify (the (Ctr_Sugar.ctr_sugar_of lthy (fst (dest_Type typ)))) lthy fun lazify_cmd s lthy = lazify_typ (Proof_Context.read_type_name {proper = true, strict = false} lthy s) lthy val lazy_case_plugin = Plugin_Name.declare_setup @{binding lazy_case} (** setup **) val _ = Outer_Syntax.local_theory @{command_keyword "lazify"} "defines a lazy case constant and sets up the code generator" (Scan.repeat1 Parse.embedded_inner_syntax >> fold lazify_cmd) val setup = Ctr_Sugar.ctr_sugar_interpretation lazy_case_plugin (lazify_typ o #T) end \ No newline at end of file diff --git a/thys/Monad_Memo_DP/transform/Transform_Data.ML b/thys/Monad_Memo_DP/transform/Transform_Data.ML --- a/thys/Monad_Memo_DP/transform/Transform_Data.ML +++ b/thys/Monad_Memo_DP/transform/Transform_Data.ML @@ -1,165 +1,165 @@ signature TRANSFORM_DATA = sig type dp_info = { old_head: term, new_head': term, new_headT: term, old_defs: thm list, new_defT: thm, new_def': thm list } type cmd_info = { scope: binding, head: term, locale: string option, dp_info: dp_info option } val get_dp_info: string -> Proof.context -> term -> dp_info option val get_last_cmd_info: Proof.context -> cmd_info val commit_dp_info: string -> dp_info -> local_theory -> local_theory val add_tmp_cmd_info: binding * term * string option -> local_theory -> local_theory val get_or_last_cmd_info: Proof.context -> (string * term) option -> cmd_info end structure Transform_Data : TRANSFORM_DATA = struct type dp_info = { old_head: term, new_head': term, new_headT: term, old_defs: thm list, new_defT: thm, new_def': thm list } type cmd_info = { scope: binding, head: term, locale: string option, dp_info: dp_info option } fun map_cmd_info f0 f1 f2 f3 {scope, head, locale, dp_info} = {scope = f0 scope, head = f1 head, locale = f2 locale, dp_info = f3 dp_info} fun map_cmd_dp_info f = map_cmd_info I I I f structure Data = Generic_Data ( type T = { monadified_terms: (string * cmd_info Item_Net.T) list, last_cmd_info: cmd_info option } val empty = { monadified_terms = ["state", "heap"] ~~ replicate 2 (Item_Net.init (op aconv o apply2 #head) (single o #head)), last_cmd_info = NONE } fun merge ( {monadified_terms = m0, ...}, {monadified_terms = m1, ...} ) = let val keys0 = map fst m0 val keys1 = map fst m1 val _ = @{assert} (keys0 = keys1) val vals = map Item_Net.merge (map snd m0 ~~ map snd m1) val ms = keys0 ~~ vals in {monadified_terms = ms, last_cmd_info = NONE} end ) fun transform_dp_info phi {old_head, new_head', new_headT, old_defs, new_defT, new_def'} = { old_head = Morphism.term phi old_head, new_head' = Morphism.term phi new_head', new_headT = Morphism.term phi new_headT, old_defs = Morphism.fact phi old_defs, new_def' = Morphism.fact phi new_def', new_defT = Morphism.thm phi new_defT } fun get_monadified_terms_generic monad_name context = Data.get context |> #monadified_terms |> (fn l => AList.lookup op= l monad_name) |> the fun get_monadified_terms monad_name ctxt = get_monadified_terms_generic monad_name (Context.Proof ctxt) fun map_data f0 f1 = Data.map (fn {monadified_terms, last_cmd_info} => {monadified_terms = f0 monadified_terms, last_cmd_info = f1 last_cmd_info}) fun map_monadified_terms f = map_data f I fun map_last_cmd_info f = map_data I f fun put_monadified_terms_generic monad_name new_terms context = context |> map_monadified_terms (AList.update op= (monad_name, new_terms)) fun map_monadified_terms_generic monad_name f context = context |> map_monadified_terms (AList.map_entry op= monad_name f) fun put_last_cmd_info cmd_info_opt context = map_last_cmd_info (K cmd_info_opt) context fun get_cmd_info monad_name ctxt tm = get_monadified_terms monad_name ctxt |> (fn net => Item_Net.retrieve net tm) fun get_dp_info monad_name ctxt tm = get_cmd_info monad_name ctxt tm |> (fn result => case result of {dp_info = SOME dp_info', ...} :: _ => SOME dp_info' | _ => NONE) fun get_last_cmd_info_generic context = Data.get context |> #last_cmd_info |> the fun get_last_cmd_info ctxt = get_last_cmd_info_generic (Context.Proof ctxt) fun commit_dp_info monad_name dp_info = Local_Theory.declaration - {pervasive = false, syntax = false} + {pervasive = false, syntax = false, pos = \<^here>} (fn phi => fn context => let val old_cmd_info = get_last_cmd_info_generic context val new_dp_info = transform_dp_info phi dp_info val new_cmd_info = old_cmd_info |> map_cmd_dp_info (K (SOME new_dp_info)) in context |> map_monadified_terms_generic monad_name (Item_Net.update new_cmd_info) |> put_last_cmd_info (SOME new_cmd_info) end) fun add_tmp_cmd_info (scope, head, locale_opt) = Local_Theory.declaration - {pervasive = false, syntax = false} + {pervasive = false, syntax = false, pos = \<^here>} (fn phi => fn context => let val new_cmd_info = { scope = Morphism.binding phi scope, head = Morphism.term phi head, locale = locale_opt, dp_info = NONE } in context |> put_last_cmd_info (SOME new_cmd_info) end ) fun get_or_last_cmd_info ctxt monad_name_tm_opt = case monad_name_tm_opt of NONE => get_last_cmd_info ctxt | SOME (monad_name, tm) => get_cmd_info monad_name ctxt tm |> the_single end diff --git a/thys/Nominal2/Nominal2.thy b/thys/Nominal2/Nominal2.thy --- a/thys/Nominal2/Nominal2.thy +++ b/thys/Nominal2/Nominal2.thy @@ -1,757 +1,752 @@ theory Nominal2 imports Nominal2_Base Nominal2_Abs Nominal2_FCB keywords "nominal_datatype" :: thy_defn and "nominal_function" "nominal_inductive" "nominal_termination" :: thy_goal_defn and "avoids" "binds" begin ML_file \nominal_dt_data.ML\ ML \open Nominal_Dt_Data\ ML_file \nominal_dt_rawfuns.ML\ ML \open Nominal_Dt_RawFuns\ ML_file \nominal_dt_alpha.ML\ ML \open Nominal_Dt_Alpha\ ML_file \nominal_dt_quot.ML\ ML \open Nominal_Dt_Quot\ (*****************************************) (* setup for induction principles method *) ML_file \nominal_induct.ML\ method_setup nominal_induct = \NominalInduct.nominal_induct_method\ \nominal induction\ (****************************************************) (* inductive definition involving nominal datatypes *) ML_file \nominal_inductive.ML\ (***************************************) (* forked code of the function package *) (* for defining nominal functions *) ML_file \nominal_function_common.ML\ ML_file \nominal_function_core.ML\ ML_file \nominal_mutual.ML\ ML_file \nominal_function.ML\ ML_file \nominal_termination.ML\ -ML \ -val eqvt_attr = Attrib.internal (K Nominal_ThmDecls.eqvt_add) -val simp_attr = Attrib.internal (K Simplifier.simp_add) -val induct_attr = Attrib.internal (K Induct.induct_simp_add) -\ section\Interface for \nominal_datatype\\ ML \ fun get_cnstrs dts = map snd dts fun get_typed_cnstrs dts = flat (map (fn ((bn, _, _), constrs) => (map (fn (bn', _, _) => (Binding.name_of bn, Binding.name_of bn')) constrs)) dts) fun get_cnstr_strs dts = map (fn (bn, _, _) => Binding.name_of bn) (flat (get_cnstrs dts)) fun get_bn_fun_strs bn_funs = map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs \ text \Infrastructure for adding \_raw\ to types and terms\ ML \ fun add_raw s = s ^ "_raw" fun add_raws ss = map add_raw ss fun raw_bind bn = Binding.suffix_name "_raw" bn fun replace_str ss s = case (AList.lookup (op =) ss s) of SOME s' => s' | NONE => s fun replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts) | replace_typ ty_ss T = T fun raw_dts ty_ss dts = let fun raw_dts_aux1 (bind, tys, _) = (raw_bind bind, map (replace_typ ty_ss) tys, NoSyn) fun raw_dts_aux2 ((bind, ty_args, _), constrs) = ((raw_bind bind, ty_args, NoSyn), map raw_dts_aux1 constrs) in map raw_dts_aux2 dts end fun replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T) | replace_aterm trm_ss (Free (a, T)) = Free (replace_str trm_ss a, T) | replace_aterm trm_ss trm = trm fun replace_term trm_ss ty_ss trm = trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty_ss) \ ML \ fun rawify_dts dts dts_env = raw_dts dts_env dts \ ML \ fun rawify_bn_funs dts_env cnstrs_env bn_fun_env bn_funs bn_eqs = let val bn_funs' = map (fn (bn, ty, _) => (raw_bind bn, SOME (replace_typ dts_env ty), NoSyn)) bn_funs val bn_eqs' = map (fn (attr, trm) => ((attr, replace_term (cnstrs_env @ bn_fun_env) dts_env trm), [], [])) bn_eqs in (bn_funs', bn_eqs') end \ ML \ fun rawify_bclauses dts_env cnstrs_env bn_fun_env bclauses = let fun rawify_bnds bnds = map (apfst (Option.map (replace_term (cnstrs_env @ bn_fun_env) dts_env))) bnds fun rawify_bclause (BC (mode, bnds, bdys)) = BC (mode, rawify_bnds bnds, bdys) in (map o map o map) rawify_bclause bclauses end \ ML \ (* definition of the raw datatype *) fun define_raw_dts dts cnstr_names cnstr_tys bn_funs bn_eqs bclauses lthy = let val thy = Local_Theory.exit_global lthy val thy_name = Context.theory_base_name thy val dt_names = map (fn ((s, _, _), _) => Binding.name_of s) dts val dt_full_names = map (Long_Name.qualify thy_name) dt_names val dt_full_names' = add_raws dt_full_names val dts_env = dt_full_names ~~ dt_full_names' val cnstr_full_names = map (Long_Name.qualify thy_name) cnstr_names val cnstr_full_names' = map (fn (x, y) => Long_Name.qualify thy_name (Long_Name.qualify (add_raw x) (add_raw y))) cnstr_tys val cnstrs_env = cnstr_full_names ~~ cnstr_full_names' val bn_fun_strs = get_bn_fun_strs bn_funs val bn_fun_strs' = add_raws bn_fun_strs val bn_fun_env = bn_fun_strs ~~ bn_fun_strs' val bn_fun_full_env = map (apply2 (Long_Name.qualify thy_name)) (bn_fun_strs ~~ bn_fun_strs') val raw_dts = rawify_dts dts dts_env val (raw_bn_funs, raw_bn_eqs) = rawify_bn_funs dts_env cnstrs_env bn_fun_env bn_funs bn_eqs val raw_bclauses = rawify_bclauses dts_env cnstrs_env bn_fun_full_env bclauses val (raw_full_dt_names', thy1) = BNF_LFP_Compat.add_datatype [BNF_LFP_Compat.Kill_Type_Args] raw_dts thy val lthy1 = Named_Target.theory_init thy1 val dtinfos = map (Old_Datatype_Data.the_info (Proof_Context.theory_of lthy1)) raw_full_dt_names' val raw_fp_sugars = map (the o BNF_FP_Def_Sugar.fp_sugar_of lthy1) raw_full_dt_names' val {descr, ...} = hd dtinfos val raw_ty_args = hd (Old_Datatype_Aux.get_rec_types descr) |> snd o dest_Type |> map dest_TFree val raw_schematic_ty_args = (snd o dest_Type o #T o hd) raw_fp_sugars val typ_subst = raw_schematic_ty_args ~~ map TFree raw_ty_args val freezeT = Term.typ_subst_atomic typ_subst val freeze = Term.subst_atomic_types typ_subst val raw_tys = map (freezeT o #T) raw_fp_sugars val raw_cns_info = all_dtyp_constrs_types descr val raw_all_cns = map (map freeze o #ctrs o #ctr_sugar o #fp_ctr_sugar) raw_fp_sugars val raw_inject_thms = flat (map #inject dtinfos) val raw_distinct_thms = flat (map #distinct dtinfos) val raw_induct_thm = (hd o #common_co_inducts o the o #fp_co_induct_sugar o hd) raw_fp_sugars val raw_induct_thms = map (the_single o #co_inducts o the o #fp_co_induct_sugar) raw_fp_sugars val raw_exhaust_thms = map #exhaust dtinfos val raw_size_trms = map HOLogic.size_const raw_tys val raw_size_thms = these (Option.map (#2 o #2) (BNF_LFP_Size.size_of lthy1 (hd raw_full_dt_names'))) val raw_result = RawDtInfo {raw_dt_names = raw_full_dt_names', raw_fp_sugars = raw_fp_sugars, raw_dts = raw_dts, raw_tys = raw_tys, raw_ty_args = raw_ty_args, raw_cns_info = raw_cns_info, raw_all_cns = raw_all_cns, raw_inject_thms = raw_inject_thms, raw_distinct_thms = raw_distinct_thms, raw_induct_thm = raw_induct_thm, raw_induct_thms = raw_induct_thms, raw_exhaust_thms = raw_exhaust_thms, raw_size_trms = raw_size_trms, raw_size_thms = raw_size_thms} in (raw_bclauses, raw_bn_funs, raw_bn_eqs, raw_result, lthy1) end \ ML \ fun nominal_datatype2 opt_thms_name dts bn_funs bn_eqs bclauses lthy = let val cnstr_names = get_cnstr_strs dts val cnstr_tys = get_typed_cnstrs dts val _ = trace_msg (K "Defining raw datatypes...") val (raw_bclauses, raw_bn_funs, raw_bn_eqs, raw_dt_info, lthy0) = define_raw_dts dts cnstr_names cnstr_tys bn_funs bn_eqs bclauses lthy val RawDtInfo {raw_dt_names, raw_tys, raw_ty_args, raw_fp_sugars, raw_all_cns, raw_inject_thms, raw_distinct_thms, raw_induct_thm, raw_induct_thms, raw_exhaust_thms, raw_size_trms, raw_size_thms, ...} = raw_dt_info val _ = trace_msg (K "Defining raw permutations...") val ((raw_perm_funs, raw_perm_simps, raw_perm_laws), lthy2a) = define_raw_perms raw_dt_info lthy0 (* noting the raw permutations as eqvt theorems *) - val lthy3 = snd (Local_Theory.note ((Binding.empty, [eqvt_attr]), raw_perm_simps) lthy2a) + val lthy3 = snd (Local_Theory.note ((Binding.empty, @{attributes [eqvt]}), raw_perm_simps) lthy2a) val _ = trace_msg (K "Defining raw fv- and bn-functions...") val (raw_bns, raw_bn_defs, raw_bn_info, raw_bn_inducts, lthy3a) = define_raw_bns raw_dt_info raw_bn_funs raw_bn_eqs lthy3 (* defining the permute_bn functions *) val (raw_perm_bns, raw_perm_bn_simps, lthy3b) = define_raw_bn_perms raw_dt_info raw_bn_info lthy3a val (raw_fvs, raw_fv_bns, raw_fv_defs, raw_fv_bns_induct, lthy3c) = define_raw_fvs raw_dt_info raw_bn_info raw_bclauses lthy3b val _ = trace_msg (K "Defining alpha relations...") val (alpha_result, lthy4) = define_raw_alpha raw_dt_info raw_bn_info raw_bclauses raw_fvs lthy3c val _ = trace_msg (K "Proving distinct theorems...") val alpha_distincts = raw_prove_alpha_distincts lthy4 alpha_result raw_dt_info val _ = trace_msg (K "Proving eq-iff theorems...") val alpha_eq_iff = raw_prove_alpha_eq_iff lthy4 alpha_result raw_dt_info val _ = trace_msg (K "Proving equivariance of bns, fvs, size and alpha...") val raw_bn_eqvt = raw_prove_eqvt raw_bns raw_bn_inducts (raw_bn_defs @ raw_perm_simps) lthy4 (* noting the raw_bn_eqvt lemmas in a temporary theory *) val lthy_tmp = lthy4 |> Local_Theory.begin_nested |> snd - |> Local_Theory.note ((Binding.empty, [eqvt_attr]), raw_bn_eqvt) + |> Local_Theory.note ((Binding.empty, @{attributes [eqvt]}), raw_bn_eqvt) |> snd |> Local_Theory.end_nested val raw_fv_eqvt = raw_prove_eqvt (raw_fvs @ raw_fv_bns) raw_fv_bns_induct (raw_fv_defs @ raw_perm_simps) lthy_tmp val raw_size_eqvt = let val RawDtInfo {raw_size_trms, raw_size_thms, raw_induct_thms, ...} = raw_dt_info in raw_prove_eqvt raw_size_trms raw_induct_thms (raw_size_thms @ raw_perm_simps) lthy_tmp |> map (rewrite_rule lthy_tmp @{thms permute_nat_def[THEN eq_reflection]}) |> map (fn thm => thm RS @{thm sym}) end - val lthy5 = snd (Local_Theory.note ((Binding.empty, [eqvt_attr]), raw_fv_eqvt) lthy_tmp) + val lthy5 = snd (Local_Theory.note ((Binding.empty, @{attributes [eqvt]}), raw_fv_eqvt) lthy_tmp) val alpha_eqvt = let val AlphaResult {alpha_trms, alpha_bn_trms, alpha_raw_induct, alpha_intros, ...} = alpha_result in Nominal_Eqvt.raw_equivariance lthy5 (alpha_trms @ alpha_bn_trms) alpha_raw_induct alpha_intros end val alpha_eqvt_norm = map (Nominal_ThmDecls.eqvt_transform lthy5) alpha_eqvt val _ = trace_msg (K "Proving equivalence of alpha...") val alpha_refl_thms = raw_prove_refl lthy5 alpha_result raw_induct_thm val alpha_sym_thms = raw_prove_sym lthy5 alpha_result alpha_eqvt_norm val alpha_trans_thms = raw_prove_trans lthy5 alpha_result (raw_distinct_thms @ raw_inject_thms) alpha_eqvt_norm val (alpha_equivp_thms, alpha_bn_equivp_thms) = raw_prove_equivp lthy5 alpha_result alpha_refl_thms alpha_sym_thms alpha_trans_thms val _ = trace_msg (K "Proving alpha implies bn...") val alpha_bn_imp_thms = raw_prove_bn_imp lthy5 alpha_result val _ = trace_msg (K "Proving respectfulness...") val raw_funs_rsp_aux = raw_fv_bn_rsp_aux lthy5 alpha_result raw_fvs raw_bns raw_fv_bns (raw_bn_defs @ raw_fv_defs) val raw_funs_rsp = map (Drule.eta_contraction_rule o mk_funs_rsp lthy5) raw_funs_rsp_aux fun match_const cnst th = (fst o dest_Const o snd o dest_comb o HOLogic.dest_Trueprop o Thm.prop_of) th = fst (dest_Const cnst); fun find_matching_rsp cnst = hd (filter (fn th => match_const cnst th) raw_funs_rsp); val raw_fv_rsp = map find_matching_rsp raw_fvs; val raw_bn_rsp = map find_matching_rsp raw_bns; val raw_fv_bn_rsp = map find_matching_rsp raw_fv_bns; val raw_size_rsp = raw_size_rsp_aux lthy5 alpha_result (raw_size_thms @ raw_size_eqvt) |> map (mk_funs_rsp lthy5) val raw_constrs_rsp = raw_constrs_rsp lthy5 alpha_result raw_all_cns (alpha_bn_imp_thms @ raw_funs_rsp_aux) val alpha_permute_rsp = map (mk_alpha_permute_rsp lthy5) alpha_eqvt val alpha_bn_rsp = raw_alpha_bn_rsp alpha_result alpha_bn_equivp_thms alpha_bn_imp_thms val raw_perm_bn_rsp = raw_perm_bn_rsp lthy5 alpha_result raw_perm_bns raw_perm_bn_simps val _ = trace_msg (K "Defining the quotient types...") val qty_descr = map (fn ((bind, vs, mx), _) => (map fst vs, bind, mx)) dts val (qty_infos, lthy7) = let val AlphaResult {alpha_trms, alpha_tys, ...} = alpha_result in define_qtypes qty_descr alpha_tys alpha_trms alpha_equivp_thms lthy5 end val qtys = map #qtyp qty_infos val qty_full_names = map (fst o dest_Type) qtys val qty_names = map Long_Name.base_name qty_full_names val _ = trace_msg (K "Defining the quotient constants...") val qconstrs_descrs = (map2 o map2) (fn (b, _, mx) => fn (t, th) => (Variable.check_name b, t, mx, th)) (get_cnstrs dts) (map (op ~~) (raw_all_cns ~~ raw_constrs_rsp)) val qbns_descr = map2 (fn (b, _, mx) => fn (t, th) => (Variable.check_name b, t, mx, th)) bn_funs (raw_bns ~~ raw_bn_rsp) val qfvs_descr = map2 (fn n => fn (t, th) => ("fv_" ^ n, t, NoSyn, th)) qty_names (raw_fvs ~~ raw_fv_rsp) val qfv_bns_descr = map2 (fn (b, _, _) => fn (t, th) => ("fv_" ^ Variable.check_name b, t, NoSyn, th)) bn_funs (raw_fv_bns ~~ raw_fv_bn_rsp) val qalpha_bns_descr = let val AlphaResult {alpha_bn_trms, ...} = alpha_result in map2 (fn (b, _, _) => fn (t, th) => ("alpha_" ^ Variable.check_name b, t, NoSyn, th)) bn_funs (alpha_bn_trms ~~ alpha_bn_rsp) end val qperm_descr = map2 (fn n => fn (t, th) => ("permute_" ^ n, Type.legacy_freeze t, NoSyn, th)) qty_names (raw_perm_funs ~~ (take (length raw_perm_funs) alpha_permute_rsp)) val qsize_descr = map2 (fn n => fn (t, th) => ("size_" ^ n, t, NoSyn, th)) qty_names (raw_size_trms ~~ (take (length raw_size_trms) raw_size_rsp)) val qperm_bn_descr = map2 (fn (b, _, _) => fn (t, th) => ("permute_" ^ Variable.check_name b, t, NoSyn, th)) bn_funs (raw_perm_bns ~~ raw_perm_bn_rsp) val ((((((qconstrs_infos, qbns_info), qfvs_info), qfv_bns_info), qalpha_bns_info), qperm_bns_info), lthy8) = lthy7 |> fold_map (define_qconsts qtys) qconstrs_descrs ||>> define_qconsts qtys qbns_descr ||>> define_qconsts qtys qfvs_descr ||>> define_qconsts qtys qfv_bns_descr ||>> define_qconsts qtys qalpha_bns_descr ||>> define_qconsts qtys qperm_bn_descr val lthy9 = define_qperms qtys qty_full_names raw_ty_args qperm_descr raw_perm_laws lthy8 val lthy9a = define_qsizes qtys qty_full_names raw_ty_args qsize_descr lthy9 val qtrms = (map o map) #qconst qconstrs_infos val qbns = map #qconst qbns_info val qfvs = map #qconst qfvs_info val qfv_bns = map #qconst qfv_bns_info val qalpha_bns = map #qconst qalpha_bns_info val qperm_bns = map #qconst qperm_bns_info val _ = trace_msg (K "Lifting of theorems...") val eq_iff_simps = @{thms alphas permute_prod.simps prod_fv.simps prod_alpha_def rel_prod_sel prod.case} val ([ qdistincts, qeq_iffs, qfv_defs, qbn_defs, qperm_simps, qfv_qbn_eqvts, qbn_inducts, qsize_eqvt, [qinduct], qexhausts, qsize_simps, qperm_bn_simps, qalpha_refl_thms, qalpha_sym_thms, qalpha_trans_thms ], lthyB) = lthy9a |>>> lift_thms qtys [] alpha_distincts ||>>> lift_thms qtys eq_iff_simps alpha_eq_iff ||>>> lift_thms qtys [] raw_fv_defs ||>>> lift_thms qtys [] raw_bn_defs ||>>> lift_thms qtys [] raw_perm_simps ||>>> lift_thms qtys [] (raw_fv_eqvt @ raw_bn_eqvt) ||>>> lift_thms qtys [] raw_bn_inducts ||>>> lift_thms qtys [] raw_size_eqvt ||>>> lift_thms qtys [] [raw_induct_thm] ||>>> lift_thms qtys [] raw_exhaust_thms ||>>> lift_thms qtys [] raw_size_thms ||>>> lift_thms qtys [] raw_perm_bn_simps ||>>> lift_thms qtys [] alpha_refl_thms ||>>> lift_thms qtys [] alpha_sym_thms ||>>> lift_thms qtys [] alpha_trans_thms val qinducts = Project_Rule.projections lthyB qinduct val _ = trace_msg (K "Proving supp lemmas and fs-instances...") val qsupports_thms = prove_supports lthyB qperm_simps (flat qtrms) (* finite supp lemmas *) val qfsupp_thms = prove_fsupp lthyB qtys qinduct qsupports_thms (* fs instances *) val lthyC = fs_instance qtys qty_full_names raw_ty_args qfsupp_thms lthyB val _ = trace_msg (K "Proving equality between fv and supp...") val qfv_supp_thms = prove_fv_supp qtys (flat qtrms) qfvs qfv_bns qalpha_bns qfv_defs qeq_iffs qperm_simps qfv_qbn_eqvts qinduct (flat raw_bclauses) lthyC |> map Drule.eta_contraction_rule (* postprocessing of eq and fv theorems *) val qeq_iffs' = qeq_iffs |> map (simplify (put_simpset HOL_basic_ss lthyC addsimps qfv_supp_thms)) |> map (simplify (put_simpset HOL_basic_ss lthyC addsimps @{thms prod_fv_supp prod_alpha_eq Abs_eq_iff[symmetric]})) (* filters the theorems that are of the form "qfv = supp" *) val qfv_names = map (fst o dest_Const) qfvs fun is_qfv_thm \<^Const_>\Trueprop for \<^Const_>\HOL.eq _ for \Const (lhs, _)\ _\\ = member (op =) qfv_names lhs | is_qfv_thm _ = false val qsupp_constrs = qfv_defs |> map (simplify (put_simpset HOL_basic_ss lthyC addsimps (filter (is_qfv_thm o Thm.prop_of) qfv_supp_thms))) val transform_thm = @{lemma "x = y \ a \ x \ a \ y" by simp} val transform_thms = [ @{lemma "a \ (S \ T) \ a \ S \ a \ T" by simp}, @{lemma "a \ (S - T) \ a \ S \ a \ T" by simp}, @{lemma "(lhs = (a \ {})) \ lhs" by simp}, @{thm fresh_def[symmetric]}] val qfresh_constrs = qsupp_constrs |> map (fn thm => thm RS transform_thm) |> map (simplify (put_simpset HOL_basic_ss lthyC addsimps transform_thms)) (* proving that the qbn result is finite *) val qbn_finite_thms = prove_bns_finite qtys qbns qinduct qbn_defs lthyC (* proving that perm_bns preserve alpha *) val qperm_bn_alpha_thms = prove_perm_bn_alpha_thms qtys qperm_bns qalpha_bns qinduct qperm_bn_simps qeq_iffs' qalpha_refl_thms lthyC (* proving the relationship of bn and permute_bn *) val qpermute_bn_thms = prove_permute_bn_thms qtys qbns qperm_bns qinduct qperm_bn_simps qbn_defs qfv_qbn_eqvts lthyC val _ = trace_msg (K "Proving strong exhaust lemmas...") val qstrong_exhaust_thms = prove_strong_exhausts lthyC qexhausts bclauses qbn_finite_thms qeq_iffs' qfv_qbn_eqvts qpermute_bn_thms qperm_bn_alpha_thms val _ = trace_msg (K "Proving strong induct lemmas...") val qstrong_induct_thms = prove_strong_induct lthyC qinduct qstrong_exhaust_thms qsize_simps bclauses (* noting the theorems *) (* generating the prefix for the theorem names *) val thms_name = the_default (Binding.name (space_implode "_" qty_names)) opt_thms_name fun thms_suffix s = Binding.qualify_name true thms_name s - val case_names_attr = Attrib.internal (K (Rule_Cases.case_names cnstr_names)) + val case_names_attr = Attrib.internal \<^here> (K (Rule_Cases.case_names cnstr_names)) val infos = mk_infos qty_full_names qeq_iffs' qdistincts qstrong_exhaust_thms qstrong_induct_thms val (_, lthy9') = lthyC - |> Local_Theory.declaration {syntax = false, pervasive = false} (K (fold register_info infos)) - |> Local_Theory.note ((thms_suffix "distinct", [induct_attr, simp_attr]), qdistincts) - ||>> Local_Theory.note ((thms_suffix "eq_iff", [induct_attr, simp_attr]), qeq_iffs') + |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (K (fold register_info infos)) + |> Local_Theory.note ((thms_suffix "distinct", @{attributes [induct_simp, simp]}), qdistincts) + ||>> Local_Theory.note ((thms_suffix "eq_iff", @{attributes [induct_simp, simp]}), qeq_iffs') ||>> Local_Theory.note ((thms_suffix "fv_defs", []), qfv_defs) ||>> Local_Theory.note ((thms_suffix "bn_defs", []), qbn_defs) ||>> Local_Theory.note ((thms_suffix "bn_inducts", []), qbn_inducts) - ||>> Local_Theory.note ((thms_suffix "perm_simps", [eqvt_attr, simp_attr]), qperm_simps) - ||>> Local_Theory.note ((thms_suffix "fv_bn_eqvt", [eqvt_attr]), qfv_qbn_eqvts) - ||>> Local_Theory.note ((thms_suffix "size", [simp_attr]), qsize_simps) + ||>> Local_Theory.note ((thms_suffix "perm_simps", @{attributes [eqvt, simp]}), qperm_simps) + ||>> Local_Theory.note ((thms_suffix "fv_bn_eqvt", @{attributes [eqvt]}), qfv_qbn_eqvts) + ||>> Local_Theory.note ((thms_suffix "size", @{attributes [simp]}), qsize_simps) ||>> Local_Theory.note ((thms_suffix "size_eqvt", []), qsize_eqvt) ||>> Local_Theory.note ((thms_suffix "induct", [case_names_attr]), [qinduct]) ||>> Local_Theory.note ((thms_suffix "inducts", [case_names_attr]), qinducts) ||>> Local_Theory.note ((thms_suffix "exhaust", [case_names_attr]), qexhausts) ||>> Local_Theory.note ((thms_suffix "strong_exhaust", [case_names_attr]), qstrong_exhaust_thms) ||>> Local_Theory.note ((thms_suffix "strong_induct", [case_names_attr]), qstrong_induct_thms) ||>> Local_Theory.note ((thms_suffix "supports", []), qsupports_thms) ||>> Local_Theory.note ((thms_suffix "fsupp", []), qfsupp_thms) ||>> Local_Theory.note ((thms_suffix "supp", []), qsupp_constrs) - ||>> Local_Theory.note ((thms_suffix "fresh", [simp_attr]), qfresh_constrs) + ||>> Local_Theory.note ((thms_suffix "fresh", @{attributes [simp]}), qfresh_constrs) ||>> Local_Theory.note ((thms_suffix "perm_bn_simps", []), qperm_bn_simps) ||>> Local_Theory.note ((thms_suffix "bn_finite", []), qbn_finite_thms) ||>> Local_Theory.note ((thms_suffix "perm_bn_alpha", []), qperm_bn_alpha_thms) ||>> Local_Theory.note ((thms_suffix "permute_bn", []), qpermute_bn_thms) ||>> Local_Theory.note ((thms_suffix "alpha_refl", []), qalpha_refl_thms) ||>> Local_Theory.note ((thms_suffix "alpha_sym", []), qalpha_sym_thms) ||>> Local_Theory.note ((thms_suffix "alpha_trans", []), qalpha_trans_thms) in lthy9' end \ section \Preparing and parsing of the specification\ ML \ (* adds the default sort @{sort fs} to nominal specifications *) fun augment_sort thy S = Sign.inter_sort thy (@{sort fs}, S) fun augment_sort_typ thy = map_type_tfree (fn (s, S) => TFree (s, augment_sort thy S)) \ ML \ (* generates the parsed datatypes and declares the constructors *) fun prepare_dts dt_strs thy = let fun prep_spec ((tname, tvs, mx), constrs) = ((tname, tvs, mx), constrs |> map (fn (c, atys, mx', _) => (c, map snd atys, mx'))) val (dts, spec_ctxt) = Old_Datatype.read_specs (map prep_spec dt_strs) thy fun augment ((tname, tvs, mx), constrs) = ((tname, map (apsnd (augment_sort thy)) tvs, mx), constrs |> map (fn (c, tys, mx') => (c, map (augment_sort_typ thy) tys, mx'))) val dts' = map augment dts fun mk_constr_trms ((tname, tvs, _), constrs) = let val ty = Type (Sign.full_name thy tname, map TFree tvs) in map (fn (c, tys, mx) => (c, (tys ---> ty), mx)) constrs end val constr_trms = flat (map mk_constr_trms dts') (* FIXME: local version *) (* val (_, spec_ctxt') = Proof_Context.add_fixes constr_trms spec_ctxt *) val thy' = Sign.add_consts constr_trms (Proof_Context.theory_of spec_ctxt) in (dts', thy') end \ ML \ (* parsing the binding function specifications and *) (* declaring the function constants *) fun prepare_bn_funs bn_fun_strs bn_eq_strs thy = let val lthy = Named_Target.theory_init thy val ((bn_funs, bn_eqs), lthy') = Specification.read_multi_specs bn_fun_strs bn_eq_strs lthy fun prep_bn_fun ((bn, T), mx) = (bn, T, mx) val bn_funs' = map prep_bn_fun bn_funs in (Local_Theory.exit_global lthy') |> Sign.add_consts bn_funs' |> pair (bn_funs', bn_eqs) end \ text \associates every SOME with the index in the list; drops NONEs\ ML \ fun indexify xs = let fun mapp _ [] = [] | mapp i (NONE :: xs) = mapp (i + 1) xs | mapp i (SOME x :: xs) = (x, i) :: mapp (i + 1) xs in mapp 0 xs end fun index_lookup xs x = case AList.lookup (op =) xs x of SOME x => x | NONE => error ("Cannot find " ^ x ^ " as argument annotation."); \ ML \ fun prepare_bclauses dt_strs thy = let val annos_bclauses = get_cnstrs dt_strs |> (map o map) (fn (_, antys, _, bns) => (map fst antys, bns)) fun prep_binder env bn_str = case (Syntax.read_term_global thy bn_str) of Free (x, _) => (NONE, index_lookup env x) | Const (a, T) $ Free (x, _) => (SOME (Const (a, T)), index_lookup env x) | _ => error ("The term " ^ bn_str ^ " is not allowed as binding function.") fun prep_body env bn_str = index_lookup env bn_str fun prep_bclause env (mode, binders, bodies) = let val binders' = map (prep_binder env) binders val bodies' = map (prep_body env) bodies in BC (mode, binders', bodies') end fun prep_bclauses (annos, bclause_strs) = let val env = indexify annos (* for every label, associate the index *) in map (prep_bclause env) bclause_strs end in ((map o map) prep_bclauses annos_bclauses, thy) end \ text \ adds an empty binding clause for every argument that is not already part of a binding clause \ ML \ fun included i bcs = let fun incl (BC (_, bns, bds)) = member (op =) (map snd bns) i orelse member (op =) bds i in exists incl bcs end \ ML \ fun complete dt_strs bclauses = let val args = get_cnstrs dt_strs |> (map o map) (fn (_, antys, _, _) => length antys) fun complt n bcs = let fun add bcs i = (if included i bcs then [] else [BC (Lst, [], [i])]) in bcs @ (flat (map_range (add bcs) n)) end in (map2 o map2) complt args bclauses end \ ML \ fun nominal_datatype2_cmd (opt_thms_name, dt_strs, bn_fun_strs, bn_eq_strs) lthy = let (* this theory is used just for parsing *) val thy = Proof_Context.theory_of lthy val (((dts, (bn_funs, bn_eqs)), bclauses), _) = thy |> prepare_dts dt_strs ||>> prepare_bn_funs bn_fun_strs bn_eq_strs ||>> prepare_bclauses dt_strs val bclauses' = complete dt_strs bclauses in nominal_datatype2 opt_thms_name dts bn_funs bn_eqs bclauses' lthy end \ ML \ (* nominal datatype parser *) local fun triple1 ((x, y), z) = (x, y, z) fun triple2 ((x, y), z) = (y, x, z) fun tuple2 (((x, y), z), u) = (x, y, u, z) fun tuple3 ((x, y), (z, u)) = (x, y, z, u) in val opt_name = Scan.option (Parse.binding --| Args.colon) val anno_typ = Scan.option (Parse.name --| @{keyword "::"}) -- Parse.typ val bind_mode = @{keyword "binds"} |-- Scan.optional (Args.parens (Args.$$$ "list" >> K Lst || (Args.$$$ "set" -- Args.$$$ "+") >> K Res || Args.$$$ "set" >> K Set)) Lst val bind_clauses = Parse.enum "," (bind_mode -- Scan.repeat1 Parse.term -- (@{keyword "in"} |-- Scan.repeat1 Parse.name) >> triple1) val cnstr_parser = Parse.binding -- Scan.repeat anno_typ -- bind_clauses -- Parse.opt_mixfix >> tuple2 (* datatype parser *) val dt_parser = (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix >> triple2) -- (@{keyword "="} |-- Parse.enum1 "|" cnstr_parser) (* binding function parser *) val bnfun_parser = Scan.optional (@{keyword "binder"} |-- Parse_Spec.specification) ([], []) (* main parser *) val main_parser = opt_name -- Parse.and_list1 dt_parser -- bnfun_parser >> tuple3 end (* Command Keyword *) val _ = Outer_Syntax.local_theory @{command_keyword nominal_datatype} "declaration of nominal datatypes" (main_parser >> nominal_datatype2_cmd) \ end diff --git a/thys/Nominal2/nominal_atoms.ML b/thys/Nominal2/nominal_atoms.ML --- a/thys/Nominal2/nominal_atoms.ML +++ b/thys/Nominal2/nominal_atoms.ML @@ -1,85 +1,83 @@ (* Title: nominal_atoms/ML Authors: Brian Huffman, Christian Urban Command for defining concrete atom types. At the moment, only single-sorted atom types are supported. *) signature ATOM_DECL = sig val add_atom_decl: (binding * (binding option)) -> theory -> theory end; structure Atom_Decl : ATOM_DECL = struct -val simp_attr = Attrib.internal (K Simplifier.simp_add) - fun atom_decl_set (str : string) : term = let val a = Free ("a", \<^Type>\atom\); val s = \<^Const>\Sort for \HOLogic.mk_string str\ \<^Const>\Nil \<^Type>\atom_sort\\\; in HOLogic.mk_Collect ("a", \<^Type>\atom\, HOLogic.mk_eq (mk_sort_of a, s)) end fun add_atom_decl (name : binding, arg : binding option) (thy : theory) = let val str = Sign.full_name thy name; (* typedef *) val set = atom_decl_set str; fun tac ctxt = resolve_tac ctxt @{thms exists_eq_simple_sort} 1; val ((full_tname, info as ({Rep_name, Abs_name, ...}, {type_definition, ...})), thy) = thy |> Named_Target.theory_map_result (apsnd o Typedef.transform_info) (Typedef.add_typedef {overloaded = false} (name, [], NoSyn) set NONE tac); (* definition of atom and permute *) val newT = #abs_type (fst info); val RepC = Const (Rep_name, newT --> \<^Type>\atom\); val AbsC = Const (Abs_name, \<^Type>\atom\ --> newT); val a = Free ("a", newT); val p = Free ("p", \<^Type>\perm\); val atom_eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq (mk_atom a, RepC $ a)); val permute_eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq (mk_perm p a, AbsC $ (mk_perm p (RepC $ a)))); val atom_def_name = Binding.prefix_name "atom_" (Binding.suffix_name "_def" name); val sort_thm_name = Binding.prefix_name "atom_" (Binding.suffix_name "_sort" name); val permute_def_name = Binding.prefix_name "permute_" (Binding.suffix_name "_def" name); (* at class instance *) val lthy = Class.instantiation ([full_tname], [], @{sort at}) thy; val ((_, (_, permute_ldef)), lthy) = Specification.definition NONE [] [] ((permute_def_name, []), permute_eqn) lthy; val ((_, (_, atom_ldef)), lthy) = Specification.definition NONE [] [] ((atom_def_name, []), atom_eqn) lthy; val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy); val permute_def = singleton (Proof_Context.export lthy ctxt_thy) permute_ldef; val atom_def = singleton (Proof_Context.export lthy ctxt_thy) atom_ldef; val class_thm = @{thm at_class} OF [type_definition, atom_def, permute_def]; val sort_thm = @{thm at_class_sort} OF [type_definition, atom_def] val thy = lthy - |> snd o (Local_Theory.note ((sort_thm_name, [simp_attr]), [sort_thm])) + |> snd o (Local_Theory.note ((sort_thm_name, @{attributes [simp]}), [sort_thm])) |> Class.prove_instantiation_instance (fn ctxt => resolve_tac ctxt [class_thm] 1) |> Local_Theory.exit_global; in thy end; (** outer syntax **) val _ = Outer_Syntax.command @{command_keyword atom_decl} "declaration of a concrete atom type" ((Parse.binding -- Scan.option (Args.parens (Parse.binding))) >> (Toplevel.theory o add_atom_decl)) end; diff --git a/thys/Nominal2/nominal_eqvt.ML b/thys/Nominal2/nominal_eqvt.ML --- a/thys/Nominal2/nominal_eqvt.ML +++ b/thys/Nominal2/nominal_eqvt.ML @@ -1,147 +1,146 @@ (* Title: nominal_eqvt.ML Author: Stefan Berghofer (original code) Author: Christian Urban Author: Tjark Weber Automatic proofs for equivariance of inductive predicates. *) signature NOMINAL_EQVT = sig val raw_equivariance: Proof.context -> term list -> thm -> thm list -> thm list val equivariance_cmd: string -> Proof.context -> local_theory end structure Nominal_Eqvt : NOMINAL_EQVT = struct open Nominal_Permeq; open Nominal_ThmDecls; fun atomize_conv ctxt = Raw_Simplifier.rewrite_cterm (true, false, false) (K (K NONE)) (put_simpset HOL_basic_ss ctxt addsimps @{thms induct_atomize}) fun atomize_intr ctxt = Conv.fconv_rule (Conv.prems_conv ~1 (atomize_conv ctxt)) fun atomize_induct ctxt = Conv.fconv_rule (Conv.prems_conv ~1 (Conv.params_conv ~1 (Conv.prems_conv ~1 o atomize_conv) ctxt)) (** equivariance tactics **) fun eqvt_rel_single_case_tac ctxt pred_names pi intro = let val cpi = Thm.cterm_of ctxt pi val pi_intro_rule = Thm.instantiate' [] [NONE, SOME cpi] @{thm permute_boolI} val eqvt_sconfig = eqvt_strict_config addexcls pred_names in eqvt_tac ctxt eqvt_sconfig THEN' SUBPROOF (fn {prems, context = goal_ctxt, ...} => let val simps1 = put_simpset HOL_basic_ss goal_ctxt addsimps @{thms permute_fun_def permute_self split_paired_all} val simps2 = put_simpset HOL_basic_ss goal_ctxt addsimps @{thms permute_bool_def permute_minus_cancel(2)} val prems' = map (transform_prem2 goal_ctxt pred_names) prems val prems'' = map (fn thm => eqvt_rule goal_ctxt eqvt_sconfig (thm RS pi_intro_rule)) prems' val prems''' = map (simplify simps2 o simplify simps1) prems'' in HEADGOAL (resolve_tac goal_ctxt [intro] THEN_ALL_NEW resolve_tac goal_ctxt (prems' @ prems'' @ prems''')) end) ctxt end fun eqvt_rel_tac ctxt pred_names pi induct intros = let val cases = map (eqvt_rel_single_case_tac ctxt pred_names pi) intros in EVERY' ((DETERM o resolve_tac ctxt [induct]) :: cases) end (** equivariance procedure **) fun prepare_goal ctxt pi pred_with_args = let val (c, xs) = strip_comb pred_with_args fun is_nonfixed_Free (Free (s, _)) = not (Variable.is_fixed ctxt s) | is_nonfixed_Free _ = false fun mk_perm_nonfixed_Free t = if is_nonfixed_Free t then mk_perm pi t else t in HOLogic.mk_imp (pred_with_args, list_comb (c, map mk_perm_nonfixed_Free xs)) end fun name_of (Const (s, _)) = s fun raw_equivariance ctxt preds raw_induct intrs = let (* FIXME: polymorphic predicates should either be rejected or specialized to arguments of sort pt *) val is_already_eqvt = filter (is_eqvt ctxt) preds val _ = if null is_already_eqvt then () else error ("Already equivariant: " ^ commas (map (Syntax.string_of_term ctxt) is_already_eqvt)) val pred_names = map (name_of o head_of) preds val raw_induct' = atomize_induct ctxt raw_induct val intrs' = map (atomize_intr ctxt) intrs val (([raw_concl], [raw_pi]), ctxt') = ctxt |> Variable.import_terms false [Thm.concl_of raw_induct'] ||>> Variable.variant_fixes ["p"] val pi = Free (raw_pi, \<^Type>\perm\) val preds_with_args = raw_concl |> HOLogic.dest_Trueprop |> HOLogic.dest_conj |> map (fst o HOLogic.dest_imp) val goal = preds_with_args |> map (prepare_goal ctxt pi) |> foldr1 HOLogic.mk_conj |> HOLogic.mk_Trueprop in Goal.prove ctxt' [] [] goal (fn {context = goal_ctxt, ...} => eqvt_rel_tac goal_ctxt pred_names pi raw_induct' intrs' 1) |> Old_Datatype_Aux.split_conj_thm |> Proof_Context.export ctxt' ctxt |> map (fn th => th RS mp) |> map zero_var_indexes end (** stores thm under name.eqvt and adds [eqvt]-attribute **) fun note_named_thm (name, thm) ctxt = let val thm_name = Binding.qualified_name (Long_Name.qualify (Long_Name.base_name name) "eqvt") - val attr = Attrib.internal (K eqvt_add) - val ((_, [thm']), ctxt') = Local_Theory.note ((thm_name, [attr]), [thm]) ctxt + val ((_, [thm']), ctxt') = Local_Theory.note ((thm_name, @{attributes [eqvt]}), [thm]) ctxt in (thm', ctxt') end (** equivariance command **) fun equivariance_cmd pred_name ctxt = let val ({names, ...}, {preds, raw_induct, intrs, ...}) = Inductive.the_inductive_global ctxt (long_name ctxt pred_name) val thms = raw_equivariance ctxt preds raw_induct intrs in fold_map note_named_thm (names ~~ thms) ctxt |> snd end val _ = Outer_Syntax.local_theory @{command_keyword equivariance} "Proves equivariance for inductive predicate involving nominal datatypes." (Parse.const >> equivariance_cmd) end (* structure *) diff --git a/thys/Nominal2/nominal_function.ML b/thys/Nominal2/nominal_function.ML --- a/thys/Nominal2/nominal_function.ML +++ b/thys/Nominal2/nominal_function.ML @@ -1,248 +1,245 @@ (* Nominal Mutual Functions Author: Christian Urban heavily based on the code of Alexander Krauss (code forked on 14 January 2011) Main entry points to the nominal function package. *) signature NOMINAL_FUNCTION = sig include NOMINAL_FUNCTION_DATA val add_nominal_function: (binding * typ option * mixfix) list -> Specification.multi_specs -> Nominal_Function_Common.nominal_function_config -> (Proof.context -> tactic) -> local_theory -> nominal_info * local_theory val add_nominal_function_cmd: (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> Nominal_Function_Common.nominal_function_config -> (Proof.context -> tactic) -> bool -> local_theory -> nominal_info * local_theory val nominal_function: (binding * typ option * mixfix) list -> Specification.multi_specs -> Nominal_Function_Common.nominal_function_config -> local_theory -> Proof.state val nominal_function_cmd: (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> Nominal_Function_Common.nominal_function_config -> bool -> local_theory -> Proof.state val get_info : Proof.context -> term -> nominal_info end structure Nominal_Function : NOMINAL_FUNCTION = struct open Function_Lib open Function_Common open Nominal_Function_Common (* Check for all sorts of errors in the input - nominal needs a different checking function *) fun nominal_check_defs ctxt fixes eqs = let val fnames = map (fst o fst) fixes fun check geq = let fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq]) fun check_head fname = member (op =) fnames fname orelse input_error ("Illegal equation head. Expected " ^ commas_quote fnames) val (fname, qs, gs, args, rhs) = split_def ctxt check_head geq val _ = length args > 0 orelse input_error "Function has no arguments:" fun add_bvs t is = add_loose_bnos (t, 0, is) val rvs = (subtract (op =) (fold add_bvs args []) (add_bvs rhs [])) |> map (fst o nth (rev qs)) val _ = forall (not o Term.exists_subterm (fn Free (n, _) => member (op =) fnames n | _ => false)) (gs @ args) orelse input_error "Defined function may not occur in premises or arguments" val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs val _ = null funvars orelse (warning (cat_lines ["Bound variable" ^ plural " " "s " funvars ^ commas_quote (map fst funvars) ^ " occur" ^ plural "s" "" funvars ^ " in function position.", "Misspelled constructor???"]); true) in (fname, length args) end val grouped_args = AList.group (op =) (map check eqs) val _ = grouped_args |> map (fn (fname, ars) => length (distinct (op =) ars) = 1 orelse error ("Function " ^ quote fname ^ " has different numbers of arguments in different equations")) val not_defined = subtract (op =) (map fst grouped_args) fnames val _ = null not_defined orelse error ("No defining equations for function" ^ plural " " "s " not_defined ^ commas_quote not_defined) fun check_sorts ((fname, fT), _) = Sorts.of_sort (Sign.classes_of (Proof_Context.theory_of ctxt)) (fT, @{sort "pt"}) orelse error (cat_lines ["Type of " ^ quote fname ^ " is not of sort " ^ quote "pt" ^ ":", Syntax.string_of_typ (Config.put show_sorts true ctxt) fT]) val _ = map check_sorts fixes in () end -val psimp_attribs = map (Attrib.internal o K) - [Named_Theorems.add @{named_theorems nitpick_psimp}] - fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_" fun add_simps fnames post sort extra_qualify label mod_binding moreatts simps lthy = let val spec = post simps |> map (apfst (apsnd (fn ats => moreatts @ ats))) |> map (apfst (apfst extra_qualify)) val (saved_spec_simps, lthy) = fold_map Local_Theory.note spec lthy val saved_simps = maps snd saved_spec_simps val simps_by_f = sort saved_simps fun add_for_f fname simps = Local_Theory.note ((mod_binding (Binding.qualify true fname (Binding.name label)), []), simps) #> snd in (saved_simps, fold2 add_for_f fnames simps_by_f lthy) end (* nominal *) fun prepare_nominal_function do_print prep default_constraint fixspec eqns config lthy = let val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx)) val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy val fixes = map (apfst (apfst Binding.name_of)) fixes0; val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0; val (eqs, post, sort_cont, cnames) = empty_preproc nominal_check_defs (Function_Common.default_config) ctxt' fixes spec (* nominal *) val defname = mk_defname fixes val NominalFunctionConfig {partials, ...} = config val ((goal_state, cont), lthy') = Nominal_Function_Mutual.prepare_nominal_function_mutual config defname fixes eqs lthy fun afterqed [[proof]] lthy = let val NominalFunctionResult {fs, R, psimps, simple_pinducts, termination, domintros, cases, eqvts, ...} = cont lthy (Thm.close_derivation \<^here> proof) val fnames = map (fst o fst) fixes fun qualify n = Binding.name n |> Binding.qualify true defname val concealed_partial = if partials then I else Binding.concealed val addsmps = add_simps fnames post sort_cont val (((psimps', pinducts'), (_, [termination'])), lthy) = lthy |> addsmps (concealed_partial o Binding.qualify false "partial") - "psimps" concealed_partial psimp_attribs psimps + "psimps" concealed_partial @{attributes [nitpick_psimp]} psimps ||>> Local_Theory.note ((concealed_partial (qualify "pinduct"), - [Attrib.internal (K (Rule_Cases.case_names cnames)), - Attrib.internal (K (Rule_Cases.consumes 1)), - Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts) + [Attrib.internal \<^here> (K (Rule_Cases.case_names cnames)), + Attrib.internal \<^here> (K (Rule_Cases.consumes 1)), + Attrib.internal \<^here> (K (Induct.induct_pred ""))]), simple_pinducts) ||>> Local_Theory.note ((Binding.concealed (qualify "termination"), []), [termination]) ||> (snd o Local_Theory.note ((qualify "cases", - [Attrib.internal (K (Rule_Cases.case_names cnames))]), [cases])) + [Attrib.internal \<^here> (K (Rule_Cases.case_names cnames))]), [cases])) ||> (case domintros of NONE => I | SOME thms => Local_Theory.note ((qualify "domintros", []), thms) #> snd) val info = { add_simps=addsmps, case_names=cnames, psimps=psimps', pinducts=snd pinducts', simps=NONE, inducts=NONE, termination=termination', fs=fs, R=R, defname=defname, is_partial=true, eqvts=eqvts} val _ = Proof_Display.print_consts do_print (Position.thread_data ()) lthy (K false) (map fst fixes) in (info, - lthy |> Local_Theory.declaration {syntax = false, pervasive = false} + lthy |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (add_function_data o morph_function_data info)) end in ((goal_state, afterqed), lthy') end fun gen_add_nominal_function do_print prep default_constraint fixspec eqns config tac lthy = let val ((goal_state, afterqed), lthy') = prepare_nominal_function do_print prep default_constraint fixspec eqns config lthy val pattern_thm = case SINGLE (tac lthy') goal_state of NONE => error "pattern completeness and compatibility proof failed" | SOME st => Goal.finish lthy' st in lthy' |> afterqed [[pattern_thm]] end val add_nominal_function = gen_add_nominal_function false Specification.check_multi_specs (Type_Infer.anyT @{sort type}) fun add_nominal_function_cmd a b c d int = gen_add_nominal_function int Specification.read_multi_specs "_::type" a b c d fun gen_nominal_function do_print prep default_constraint fixspec eqns config lthy = let val ((goal_state, afterqed), lthy') = prepare_nominal_function do_print prep default_constraint fixspec eqns config lthy in lthy' |> Proof.theorem NONE (snd oo afterqed) [[(Logic.unprotect (Thm.concl_of goal_state), [])]] |> Proof.refine_singleton (Method.primitive_text (K (K goal_state))) end val nominal_function = gen_nominal_function false Specification.check_multi_specs (Type_Infer.anyT @{sort type}) fun nominal_function_cmd a b c int = gen_nominal_function int Specification.read_multi_specs "_::type" a b c fun get_info ctxt t = Item_Net.retrieve (get_function ctxt) t |> the_single |> snd (* outer syntax *) local val option_parser = Parse.group (fn () => "option") ((Parse.reserved "sequential" >> K Sequential) || ((Parse.reserved "default" |-- Parse.term) >> Default) || (Parse.reserved "domintros" >> K DomIntros) || (Parse.reserved "no_partials" >> K No_Partials) || ((Parse.reserved "invariant" |-- Parse.term) >> Invariant)) fun config_parser default = (Scan.optional (@{keyword "("} |-- Parse.!!! (Parse.list1 option_parser) --| @{keyword ")"}) []) >> (fn opts => fold apply_opt opts default) in fun nominal_function_parser default_cfg = config_parser default_cfg -- Parse_Spec.specification end val _ = Outer_Syntax.local_theory_to_proof' @{command_keyword nominal_function} "define general recursive nominal functions" (nominal_function_parser nominal_default_config >> (fn (config, (fixes, specs)) => nominal_function_cmd fixes specs config)) end diff --git a/thys/Nominal2/nominal_function_common.ML b/thys/Nominal2/nominal_function_common.ML --- a/thys/Nominal2/nominal_function_common.ML +++ b/thys/Nominal2/nominal_function_common.ML @@ -1,162 +1,163 @@ (* Nominal Function Common Author: Christian Urban heavily based on the code of Alexander Krauss (code forked on 5 June 2011) Redefinition of config datatype *) signature NOMINAL_FUNCTION_DATA = sig type nominal_info = {is_partial : bool, defname : string, (* contains no logical entities: invariant under morphisms: *) add_simps : (binding -> binding) -> string -> (binding -> binding) -> Token.src list -> thm list -> local_theory -> thm list * local_theory, case_names : string list, fs : term list, R : term, psimps: thm list, pinducts: thm list, simps : thm list option, inducts : thm list option, termination: thm, eqvts: thm list} end structure Nominal_Function_Common = struct type nominal_info = {is_partial : bool, defname : string, (* contains no logical entities: invariant under morphisms: *) add_simps : (binding -> binding) -> string -> (binding -> binding) -> Token.src list -> thm list -> local_theory -> thm list * local_theory, case_names : string list, fs : term list, R : term, psimps: thm list, pinducts: thm list, simps : thm list option, inducts : thm list option, termination: thm, eqvts: thm list} fun morph_function_data ({add_simps, case_names, fs, R, psimps, pinducts, simps, inducts, termination, defname, is_partial, eqvts} : nominal_info) phi = let val term = Morphism.term phi val thm = Morphism.thm phi val fact = Morphism.fact phi val name = Binding.name_of o Morphism.binding phi o Binding.name in { add_simps = add_simps, case_names = case_names, fs = map term fs, R = term R, psimps = fact psimps, pinducts = fact pinducts, simps = Option.map fact simps, inducts = Option.map fact inducts, termination = thm termination, defname = name defname, is_partial=is_partial, eqvts = fact eqvts } end structure NominalFunctionData = Generic_Data ( type T = (term * nominal_info) Item_Net.T; val empty : T = Item_Net.init (op aconv o apply2 fst) (single o fst); fun merge tabs : T = Item_Net.merge tabs; ) val get_function = NominalFunctionData.get o Context.Proof; -fun lift_morphism ctxt f = +fun lift_morphism f = let - fun term t = Thm.term_of (Drule.cterm_rule f (Thm.cterm_of ctxt t)) + fun term thy t = Thm.term_of (Drule.cterm_rule f (Thm.global_cterm_of thy t)) + fun typ thy t = Logic.type_map (term thy) t in Morphism.morphism "lift_morphism" {binding = [], - typ = [Logic.type_map term], - term = [term], - fact = [map f]} + typ = [typ o Morphism.the_theory], + term = [term o Morphism.the_theory], + fact = [fn _ => map f]} end fun import_function_data t ctxt = let val ct = Thm.cterm_of ctxt t - val inst_morph = lift_morphism ctxt o Thm.instantiate + val inst_morph = Morphism.set_context' ctxt o lift_morphism o Thm.instantiate fun match (trm, data) = SOME (morph_function_data data (inst_morph (Thm.match (Thm.cterm_of ctxt trm, ct)))) handle Pattern.MATCH => NONE in get_first match (Item_Net.retrieve (get_function ctxt) t) end fun import_last_function ctxt = case Item_Net.content (get_function ctxt) of [] => NONE | (t, data) :: _ => let val ([t'], ctxt') = Variable.import_terms true [t] ctxt in import_function_data t' ctxt' end val all_function_data = Item_Net.content o get_function fun add_function_data (data : nominal_info as {fs, termination, ...}) = NominalFunctionData.map (fold (fn f => Item_Net.update (f, data)) fs) #> Function_Common.store_termination_rule termination (* Configuration management *) datatype nominal_function_opt = Sequential | Default of string | DomIntros | No_Partials | Invariant of string datatype nominal_function_config = NominalFunctionConfig of {sequential: bool, default: string option, domintros: bool, partials: bool, inv: string option} fun apply_opt Sequential (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=true, default=default, domintros=domintros, partials=partials, inv=inv} | apply_opt (Default d) (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=SOME d, domintros=domintros, partials=partials, inv=inv} | apply_opt DomIntros (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=default, domintros=true, partials=partials, inv=inv} | apply_opt No_Partials (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=default, domintros=domintros, partials=false, inv=inv} | apply_opt (Invariant s) (NominalFunctionConfig {sequential, default, domintros, partials, inv}) = NominalFunctionConfig {sequential=sequential, default=default, domintros=domintros, partials=partials, inv = SOME s} val nominal_default_config = NominalFunctionConfig { sequential=false, default=NONE, domintros=false, partials=true, inv=NONE} datatype nominal_function_result = NominalFunctionResult of {fs: term list, G: term, R: term, psimps : thm list, simple_pinducts : thm list, cases : thm, termination : thm, domintros : thm list option, eqvts : thm list} end diff --git a/thys/Nominal2/nominal_inductive.ML b/thys/Nominal2/nominal_inductive.ML --- a/thys/Nominal2/nominal_inductive.ML +++ b/thys/Nominal2/nominal_inductive.ML @@ -1,441 +1,441 @@ (* Title: nominal_inductive.ML Author: Christian Urban Author: Tjark Weber Infrastructure for proving strong induction theorems for inductive predicates involving nominal datatypes. Code based on an earlier version by Stefan Berghofer. *) signature NOMINAL_INDUCTIVE = sig val prove_strong_inductive: string list -> string list -> term list list -> thm -> thm list -> Proof.context -> Proof.state val prove_strong_inductive_cmd: xstring * (string * string list) list -> Proof.context -> Proof.state end structure Nominal_Inductive : NOMINAL_INDUCTIVE = struct fun mk_cplus p q = Thm.apply (Thm.apply @{cterm "plus :: perm => perm => perm"} p) q fun mk_cminus p = Thm.apply @{cterm "uminus :: perm => perm"} p fun minus_permute_intro_tac ctxt p = resolve_tac ctxt [Thm.instantiate' [] [SOME (mk_cminus p)] @{thm permute_boolE}] fun minus_permute_elim p thm = thm RS (Thm.instantiate' [] [NONE, SOME (mk_cminus p)] @{thm permute_boolI}) (* fixme: move to nominal_library *) fun real_head_of \<^Const_>\Trueprop for t\ = real_head_of t | real_head_of \<^Const_>\Pure.imp for _ t\ = real_head_of t | real_head_of \<^Const_>\Pure.all _ for \Abs (_, _, t)\\ = real_head_of t | real_head_of \<^Const_>\All _ for \Abs (_, _, t)\\ = real_head_of t | real_head_of \<^Const_>\HOL.induct_forall _ for \Abs (_, _, t)\\ = real_head_of t | real_head_of t = head_of t fun mk_vc_compat (avoid, avoid_trm) prems concl_args params = if null avoid then [] else let val vc_goal = concl_args |> HOLogic.mk_tuple |> mk_fresh_star avoid_trm |> HOLogic.mk_Trueprop |> (curry Logic.list_implies) prems |> fold_rev (Logic.all o Free) params val finite_goal = avoid_trm |> mk_finite |> HOLogic.mk_Trueprop |> (curry Logic.list_implies) prems |> fold_rev (Logic.all o Free) params in [vc_goal, finite_goal] end (* fixme: move to nominal_library *) fun map_term prop f trm = if prop trm then f trm else case trm of (t1 $ t2) => map_term prop f t1 $ map_term prop f t2 | Abs (x, T, t) => Abs (x, T, map_term prop f t) | _ => trm fun add_p_c p (c, c_ty) trm = let val (P, args) = strip_comb trm val (P_name, P_ty) = dest_Free P val (ty_args, bool) = strip_type P_ty val args' = map (mk_perm p) args in list_comb (Free (P_name, (c_ty :: ty_args) ---> bool), c :: args') |> (fn t => HOLogic.all_const c_ty $ lambda c t ) |> (fn t => HOLogic.all_const \<^Type>\perm\ $ lambda p t) end fun induct_forall_const T = \<^Const>\HOL.induct_forall T\ fun mk_induct_forall (a, T) t = induct_forall_const T $ Abs (a, T, t) fun add_c_prop qnt Ps (c, c_name, c_ty) trm = let fun add t = let val (P, args) = strip_comb t val (P_name, P_ty) = dest_Free P val (ty_args, bool) = strip_type P_ty val args' = args |> qnt ? map (incr_boundvars 1) in list_comb (Free (P_name, (c_ty :: ty_args) ---> bool), c :: args') |> qnt ? mk_induct_forall (c_name, c_ty) end in map_term (member (op =) Ps o head_of) add trm end fun prep_prem Ps c_name c_ty (avoid, avoid_trm) (params, prems, concl) = let val prems' = prems |> map (incr_boundvars 1) |> map (add_c_prop true Ps (Bound 0, c_name, c_ty)) val avoid_trm' = avoid_trm |> fold_rev absfree (params @ [(c_name, c_ty)]) |> strip_abs_body |> (fn t => mk_fresh_star_ty c_ty t (Bound 0)) |> HOLogic.mk_Trueprop val prems'' = if null avoid then prems' else avoid_trm' :: prems' val concl' = concl |> incr_boundvars 1 |> add_c_prop false Ps (Bound 0, c_name, c_ty) in mk_full_horn (params @ [(c_name, c_ty)]) prems'' concl' end (* fixme: move to nominal_library *) fun same_name (Free (a1, _), Free (a2, _)) = (a1 = a2) | same_name (Var (a1, _), Var (a2, _)) = (a1 = a2) | same_name (Const (a1, _), Const (a2, _)) = (a1 = a2) | same_name _ = false (* local abbreviations *) local open Nominal_Permeq in (* by default eqvt_strict_config contains unwanted @{thm permute_pure} *) val eqvt_sconfig = eqvt_strict_config addpres @{thms permute_minus_cancel} fun eqvt_stac ctxt = eqvt_tac ctxt eqvt_sconfig fun eqvt_srule ctxt = eqvt_rule ctxt eqvt_sconfig end val all_elims = let fun spec' ct = Thm.instantiate' [SOME (Thm.ctyp_of_cterm ct)] [NONE, SOME ct] @{thm spec} in fold (fn ct => fn th => th RS spec' ct) end fun helper_tac flag prm p ctxt = Subgoal.SUBPROOF (fn {context = ctxt', prems, ...} => let val prems' = prems |> map (minus_permute_elim p) |> map (eqvt_srule ctxt') val prm' = (prems' MRS prm) |> flag ? (all_elims [p]) |> flag ? (eqvt_srule ctxt') in asm_full_simp_tac (put_simpset HOL_ss ctxt' addsimps (prm' :: @{thms HOL.induct_forall_def})) 1 end) ctxt fun non_binder_tac prem intr_cvars Ps ctxt = Subgoal.SUBPROOF (fn {context = ctxt', params, prems, ...} => let val (prms, p, _) = split_last2 (map snd params) val prm_tys = map (fastype_of o Thm.term_of) prms val cperms = map (Thm.cterm_of ctxt' o perm_const) prm_tys val p_prms = map2 (fn ct1 => fn ct2 => Thm.mk_binop ct1 p ct2) cperms prms val prem' = prem |> infer_instantiate ctxt' (map (#1 o dest_Var o Thm.term_of) intr_cvars ~~ p_prms) |> eqvt_srule ctxt' (* for inductive-premises*) fun tac1 prm = helper_tac true prm p ctxt' (* for non-inductive premises *) fun tac2 prm = EVERY' [ minus_permute_intro_tac ctxt' p, eqvt_stac ctxt', helper_tac false prm p ctxt' ] fun select prm (t, i) = (if member same_name Ps (real_head_of t) then tac1 prm else tac2 prm) i in EVERY1 [ eqvt_stac ctxt', resolve_tac ctxt' [prem'], RANGE (map (SUBGOAL o select) prems) ] end) ctxt fun fresh_thm ctxt user_thm p c concl_args avoid_trm = let val conj1 = mk_fresh_star (mk_perm (Bound 0) (mk_perm p avoid_trm)) c val conj2 = mk_fresh_star_ty \<^Type>\perm\ (mk_supp (HOLogic.mk_tuple (map (mk_perm p) concl_args))) (Bound 0) val fresh_goal = mk_exists ("q", \<^Type>\perm\) (HOLogic.mk_conj (conj1, conj2)) |> HOLogic.mk_Trueprop val ss = @{thms finite_supp supp_Pair finite_Un permute_finite} @ @{thms fresh_star_Pair fresh_star_permute_iff} val simp = asm_full_simp_tac (put_simpset HOL_ss ctxt addsimps ss) in Goal.prove ctxt [] [] fresh_goal (fn {context = goal_ctxt, ...} => HEADGOAL (resolve_tac goal_ctxt @{thms at_set_avoiding2} THEN_ALL_NEW EVERY' [cut_facts_tac user_thm, REPEAT o eresolve_tac goal_ctxt @{thms conjE}, simp])) end val supp_perm_eq' = @{lemma "fresh_star (supp (permute p x)) q ==> permute p x == permute (q + p) x" by (simp add: supp_perm_eq)} val fresh_star_plus = @{lemma "fresh_star (permute q (permute p x)) c ==> fresh_star (permute (q + p) x) c" by (simp add: permute_plus)} fun binder_tac prem intr_cvars param_trms Ps user_thm avoid_trm concl_args ctxt = Subgoal.FOCUS (fn {context = ctxt, params, prems, concl, ...} => let val (prms, p, c) = split_last2 (map snd params) val prm_trms = map Thm.term_of prms val prm_tys = map fastype_of prm_trms val avoid_trm' = subst_free (param_trms ~~ prm_trms) avoid_trm val concl_args' = map (subst_free (param_trms ~~ prm_trms)) concl_args val user_thm' = map (infer_instantiate ctxt (map (#1 o dest_Var o Thm.term_of) intr_cvars ~~ prms)) user_thm |> map (full_simplify (put_simpset HOL_ss ctxt addsimps (@{thm fresh_star_Pair}::prems))) val fthm = fresh_thm ctxt user_thm' (Thm.term_of p) (Thm.term_of c) concl_args' avoid_trm' val (([(_, q)], fprop :: fresh_eqs), ctxt') = Obtain.result (K (EVERY1 [eresolve_tac ctxt @{thms exE}, full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms supp_Pair fresh_star_Un}), REPEAT o eresolve_tac ctxt @{thms conjE}, dresolve_tac ctxt [fresh_star_plus], REPEAT o dresolve_tac ctxt [supp_perm_eq']])) [fthm] ctxt val expand_conv = Conv.try_conv (Conv.rewrs_conv fresh_eqs) fun expand_conv_bot ctxt = Conv.bottom_conv (K expand_conv) ctxt val cperms = map (Thm.cterm_of ctxt' o perm_const) prm_tys val qp_prms = map2 (fn ct1 => fn ct2 => Thm.mk_binop ct1 (mk_cplus q p) ct2) cperms prms val prem' = prem |> infer_instantiate ctxt' (map (#1 o dest_Var o Thm.term_of) intr_cvars ~~ qp_prms) |> eqvt_srule ctxt' val fprop' = eqvt_srule ctxt' fprop val tac_fresh = simp_tac (put_simpset HOL_basic_ss ctxt' addsimps [fprop']) (* for inductive-premises*) fun tac1 goal_ctxt prm = helper_tac true prm (mk_cplus q p) goal_ctxt (* for non-inductive premises *) fun tac2 goal_ctxt prm = EVERY' [ minus_permute_intro_tac goal_ctxt (mk_cplus q p), eqvt_stac goal_ctxt, helper_tac false prm (mk_cplus q p) goal_ctxt ] fun select goal_ctxt prm (t, i) = (if member same_name Ps (real_head_of t) then tac1 goal_ctxt prm else tac2 goal_ctxt prm) i val side_thm = Goal.prove ctxt' [] [] (Thm.term_of concl) (fn {context = goal_ctxt, ...} => EVERY1 [ CONVERSION (expand_conv_bot goal_ctxt), eqvt_stac goal_ctxt, resolve_tac goal_ctxt [prem'], RANGE (tac_fresh :: map (SUBGOAL o select goal_ctxt) prems) ]) |> singleton (Proof_Context.export ctxt' ctxt) in resolve_tac ctxt [side_thm] 1 end) ctxt fun case_tac ctxt Ps avoid avoid_trm intr_cvars param_trms prem user_thm concl_args = let val tac1 = non_binder_tac prem intr_cvars Ps ctxt val tac2 = binder_tac prem intr_cvars param_trms Ps user_thm avoid_trm concl_args ctxt in EVERY' [ resolve_tac ctxt @{thms allI}, resolve_tac ctxt @{thms allI}, if null avoid then tac1 else tac2 ] end fun prove_sinduct_tac raw_induct user_thms Ps avoids avoid_trms intr_cvars param_trms concl_args {prems, context = ctxt} = let val cases_tac = @{map 7} (case_tac ctxt Ps) avoids avoid_trms intr_cvars param_trms prems user_thms concl_args in EVERY1 [ DETERM o resolve_tac ctxt [raw_induct], RANGE cases_tac ] end val normalise = @{lemma "(Q \ (\p c. P p c)) \ (\c. Q \ P (0::perm) c)" by simp} fun prove_strong_inductive pred_names rule_names avoids raw_induct intrs ctxt = let val ((_, [raw_induct']), ctxt') = Variable.import true [raw_induct] ctxt val (ind_prems, ind_concl) = raw_induct' |> Thm.prop_of |> Logic.strip_horn |>> map strip_full_horn val params = map (fn (x, _, _) => x) ind_prems val param_trms = (map o map) Free params val intr_vars_tys = map (fn t => rev (Term.add_vars (Thm.prop_of t) [])) intrs val intr_vars = (map o map) fst intr_vars_tys val intr_vars_substs = map2 (curry (op ~~)) intr_vars param_trms val intr_cvars = (map o map) (Thm.cterm_of ctxt o Var) intr_vars_tys val (intr_prems, intr_concls) = intrs |> map Thm.prop_of |> map2 subst_Vars intr_vars_substs |> map Logic.strip_horn |> split_list val intr_concls_args = map (snd o fixed_nonfixed_args ctxt' o HOLogic.dest_Trueprop) intr_concls val avoid_trms = avoids |> (map o map) (setify ctxt') |> map fold_union val vc_compat_goals = map4 mk_vc_compat (avoids ~~ avoid_trms) intr_prems intr_concls_args params val ([c_name, a, p], ctxt'') = Variable.variant_fixes ["c", "'a", "p"] ctxt' val c_ty = TFree (a, @{sort fs}) val c = Free (c_name, c_ty) val p = Free (p, \<^Type>\perm\) val (preconds, ind_concls) = ind_concl |> HOLogic.dest_Trueprop |> HOLogic.dest_conj |> map HOLogic.dest_imp |> split_list val Ps = map (fst o strip_comb) ind_concls val ind_concl' = ind_concls |> map (add_p_c p (c, c_ty)) |> (curry (op ~~)) preconds |> map HOLogic.mk_imp |> fold_conj |> HOLogic.mk_Trueprop val ind_prems' = ind_prems |> map2 (prep_prem Ps c_name c_ty) (avoids ~~ avoid_trms) fun after_qed ctxt_outside user_thms ctxt = let val strong_ind_thms = Goal.prove ctxt [] ind_prems' ind_concl' (prove_sinduct_tac raw_induct user_thms Ps avoids avoid_trms intr_cvars param_trms intr_concls_args) |> singleton (Proof_Context.export ctxt ctxt_outside) |> Old_Datatype_Aux.split_conj_thm |> map (fn thm => thm RS normalise) |> map (asm_full_simplify (put_simpset HOL_basic_ss ctxt addsimps @{thms permute_zero induct_rulify})) |> map (Drule.rotate_prems (length ind_prems')) |> map zero_var_indexes val qualified_thm_name = pred_names |> map Long_Name.base_name |> space_implode "_" |> (fn s => Binding.qualify false s (Binding.name "strong_induct")) val attrs = - [ Attrib.internal (K (Rule_Cases.consumes 1)), - Attrib.internal (K (Rule_Cases.case_names rule_names)) ] + [ Attrib.internal \<^here> (K (Rule_Cases.consumes 1)), + Attrib.internal \<^here> (K (Rule_Cases.case_names rule_names)) ] in ctxt |> Local_Theory.note ((qualified_thm_name, attrs), strong_ind_thms) |> snd end in Proof.theorem NONE (after_qed ctxt) ((map o map) (rpair []) vc_compat_goals) ctxt'' end fun prove_strong_inductive_cmd (pred_name, avoids) ctxt = let val ({names, ...}, {raw_induct, intrs, ...}) = Inductive.the_inductive_global ctxt (long_name ctxt pred_name) val rule_names = hd names |> the o Induct.lookup_inductP ctxt |> fst o Rule_Cases.get |> map (fst o fst) val case_names = map fst avoids val _ = case duplicates (op =) case_names of [] => () | xs => error ("Duplicate case names: " ^ commas_quote xs) val _ = case subtract (op =) rule_names case_names of [] => () | xs => error ("No such case(s) in inductive definition: " ^ commas_quote xs) val avoids_ordered = order_default (op =) [] rule_names avoids fun read_avoids avoid_trms intr = let (* fixme hack *) val (((_, inst), _), ctxt') = Variable.import true [intr] ctxt val trms = build (inst |> Vars.fold (cons o Thm.term_of o snd)) val ctxt'' = fold Variable.declare_term trms ctxt' in map (Syntax.read_term ctxt'') avoid_trms end val avoid_trms = map2 read_avoids avoids_ordered intrs in prove_strong_inductive names rule_names avoid_trms raw_induct intrs ctxt end (* outer syntax *) local val single_avoid_parser = Parse.name -- (@{keyword ":"} |-- Parse.and_list1 Parse.term) val avoids_parser = Scan.optional (@{keyword "avoids"} |-- Parse.enum1 "|" single_avoid_parser) [] val main_parser = Parse.name -- avoids_parser in val _ = Outer_Syntax.local_theory_to_proof @{command_keyword nominal_inductive} "prove strong induction theorem for inductive predicate involving nominal datatypes" (main_parser >> prove_strong_inductive_cmd) end end diff --git a/thys/Nominal2/nominal_termination.ML b/thys/Nominal2/nominal_termination.ML --- a/thys/Nominal2/nominal_termination.ML +++ b/thys/Nominal2/nominal_termination.ML @@ -1,115 +1,109 @@ (* Nominal Termination Author: Christian Urban heavily based on the code of Alexander Krauss (code forked on 18 July 2011) Redefinition of the termination command *) signature NOMINAL_FUNCTION_TERMINATION = sig include NOMINAL_FUNCTION_DATA val termination : bool -> term option -> local_theory -> Proof.state val termination_cmd : bool -> string option -> local_theory -> Proof.state end structure Nominal_Function_Termination : NOMINAL_FUNCTION_TERMINATION = struct open Function_Lib open Function_Common open Nominal_Function_Common -val simp_attribs = map (Attrib.internal o K) - [Simplifier.simp_add, - Named_Theorems.add @{named_theorems nitpick_simp}] - -val eqvt_attrib = Attrib.internal (K Nominal_ThmDecls.eqvt_add) - fun prepare_termination_proof prep_term is_eqvt raw_term_opt lthy = let val term_opt = Option.map (prep_term lthy) raw_term_opt val info = the (case term_opt of SOME t => (import_function_data t lthy handle Option.Option => error ("Not a function: " ^ quote (Syntax.string_of_term lthy t))) | NONE => (import_last_function lthy handle Option.Option => error "Not a function")) val { termination, fs, R, add_simps, case_names, psimps, pinducts, defname, eqvts, ...} = info val domT = domain_type (fastype_of R) val goal = HOLogic.mk_Trueprop (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT))) fun afterqed [[totality]] lthy = let val totality = Thm.close_derivation \<^here> totality val remove_domain_condition = full_simplify (put_simpset HOL_basic_ss lthy addsimps [totality, @{thm True_implies_equals}]) val tsimps = map remove_domain_condition psimps val tinducts = map remove_domain_condition pinducts val teqvts = map remove_domain_condition eqvts fun qualify n = Binding.name n |> Binding.qualify true defname in lthy - |> add_simps I "simps" I simp_attribs tsimps - ||>> Local_Theory.note ((qualify "eqvt", if is_eqvt then [eqvt_attrib] else []), teqvts) + |> add_simps I "simps" I @{attributes [simp, nitpick_simp]} tsimps + ||>> Local_Theory.note ((qualify "eqvt", if is_eqvt then @{attributes [eqvt]} else []), teqvts) ||>> Local_Theory.note ((qualify "induct", - [Attrib.internal (K (Rule_Cases.case_names case_names))]), + [Attrib.internal \<^here> (K (Rule_Cases.case_names case_names))]), tinducts) |-> (fn ((simps, (_, eqvts)), (_, inducts)) => fn lthy => let val info' = { is_partial=false, defname=defname, add_simps=add_simps, case_names=case_names, fs=fs, R=R, psimps=psimps, pinducts=pinducts, simps=SOME simps, inducts=SOME inducts, termination=termination, eqvts=teqvts } in lthy - |> Local_Theory.declaration {syntax = false, pervasive = false} + |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (add_function_data o morph_function_data info') |> Spec_Rules.add Binding.empty Spec_Rules.equational_recdef fs tsimps |> Code.declare_default_eqns (map (rpair true) tsimps) |> pair info' end) end in (goal, afterqed, termination) end fun gen_termination prep_term is_eqvt raw_term_opt lthy = let val (goal, afterqed, termination) = prepare_termination_proof prep_term is_eqvt raw_term_opt lthy in lthy |> Proof_Context.note_thmss "" [((Binding.empty, [Context_Rules.rule_del]), [([allI], [])])] |> snd |> Proof_Context.note_thmss "" [((Binding.empty, [Context_Rules.intro_bang (SOME 1)]), [([allI], [])])] |> snd |> Proof_Context.note_thmss "" [((Binding.name "termination", [Context_Rules.intro_bang (SOME 0)]), [([Goal.norm_result lthy termination], [])])] |> snd |> Proof.theorem NONE (snd oo afterqed) [[(goal, [])]] end val termination = gen_termination Syntax.check_term val termination_cmd = gen_termination Syntax.read_term (* outer syntax *) val option_parser = (Scan.optional (@{keyword "("} |-- Parse.!!! ((Parse.reserved "eqvt" >> K true) || (Parse.reserved "no_eqvt" >> K false)) --| @{keyword ")"}) (false)) val _ = Outer_Syntax.local_theory_to_proof @{command_keyword nominal_termination} "prove termination of a recursive nominal function" (option_parser -- Scan.option Parse.term >> (fn (is_eqvt, opt_trm) => termination_cmd is_eqvt opt_trm)) end diff --git a/thys/Ordinary_Differential_Equations/IVP/Flow.thy b/thys/Ordinary_Differential_Equations/IVP/Flow.thy --- a/thys/Ordinary_Differential_Equations/IVP/Flow.thy +++ b/thys/Ordinary_Differential_Equations/IVP/Flow.thy @@ -1,3199 +1,3199 @@ section \Flow\ theory Flow imports Picard_Lindeloef_Qualitative "HOL-Library.Diagonal_Subsequence" "../Library/Bounded_Linear_Operator" "../Library/Multivariate_Taylor" "../Library/Interval_Integral_HK" begin text \TODO: extend theorems for dependence on initial time\ subsection \simp rules for integrability (TODO: move)\ lemma blinfun_ext: "x = y \ (\i. blinfun_apply x i = blinfun_apply y i)" by transfer auto notation id_blinfun ("1\<^sub>L") lemma blinfun_inverse_left: fixes f::"'a::euclidean_space \\<^sub>L 'a" and f' shows "f o\<^sub>L f' = 1\<^sub>L \ f' o\<^sub>L f = 1\<^sub>L" by transfer (auto dest!: bounded_linear.linear simp: id_def[symmetric] linear_inverse_left) lemma onorm_zero_blinfun[simp]: "onorm (blinfun_apply 0) = 0" by transfer (simp add: onorm_zero) lemma blinfun_compose_1_left[simp]: "x o\<^sub>L 1\<^sub>L = x" and blinfun_compose_1_right[simp]: "1\<^sub>L o\<^sub>L y = y" by (auto intro!: blinfun_eqI) named_theorems integrable_on_simps lemma integrable_on_refl_ivl[intro, simp]: "g integrable_on {b .. (b::'b::ordered_euclidean_space)}" and integrable_on_refl_closed_segment[intro, simp]: "h integrable_on closed_segment a a" using integrable_on_refl by auto lemma integrable_const_ivl_closed_segment[intro, simp]: "(\x. c) integrable_on closed_segment a (b::real)" by (auto simp: closed_segment_eq_real_ivl) lemma integrable_ident_ivl[intro, simp]: "(\x. x) integrable_on closed_segment a (b::real)" and integrable_ident_cbox[intro, simp]: "(\x. x) integrable_on cbox a (b::real)" by (auto simp: closed_segment_eq_real_ivl ident_integrable_on) lemma content_closed_segment_real: fixes a b::real shows "content (closed_segment a b) = abs (b - a)" by (auto simp: closed_segment_eq_real_ivl) lemma integral_const_closed_segment: fixes a b::real shows "integral (closed_segment a b) (\x. c) = abs (b - a) *\<^sub>R c" by (auto simp: closed_segment_eq_real_ivl content_closed_segment_real) lemmas [integrable_on_simps] = integrable_on_empty \ \empty\ integrable_on_refl integrable_on_refl_ivl integrable_on_refl_closed_segment \ \singleton\ integrable_const integrable_const_ivl integrable_const_ivl_closed_segment \ \constant\ ident_integrable_on integrable_ident_ivl integrable_ident_cbox \ \identity\ lemma integrable_cmul_real: fixes K::real shows "f integrable_on X \ (\x. K * f x) integrable_on X " unfolding real_scaleR_def[symmetric] by (rule integrable_cmul) lemmas [integrable_on_simps] = integrable_0 integrable_neg integrable_cmul integrable_cmul_real integrable_on_cmult_iff integrable_on_cmult_left integrable_on_cmult_right integrable_on_cdivide integrable_on_cmult_iff integrable_on_cmult_left_iff integrable_on_cmult_right_iff integrable_on_cdivide_iff integrable_diff integrable_add integrable_sum lemma dist_cancel_add1: "dist (t0 + et) t0 = norm et" by (simp add: dist_norm) lemma double_nonneg_le: fixes a::real shows "a * 2 \ b \ a \ 0 \ a \ b" by arith subsection \Nonautonomous IVP on maximal existence interval\ context ll_on_open_it begin context fixes x0 assumes iv_defined: "t0 \ T" "x0 \ X" begin lemmas closed_segment_iv_subset_domain = closed_segment_subset_domainI[OF iv_defined(1)] lemma local_unique_solutions: obtains t u L where "0 < t" "0 < u" "cball t0 t \ existence_ivl t0 x0" "cball x0 (2 * u) \ X" "\t'. t' \ cball t0 t \ L-lipschitz_on (cball x0 (2 * u)) (f t')" "\x. x \ cball x0 u \ (flow t0 x usolves_ode f from t0) (cball t0 t) (cball x u)" "\x. x \ cball x0 u \ cball x u \ X" proof - from local_unique_solution[OF iv_defined] obtain et ex B L where "0 < et" "0 < ex" "cball t0 et \ T" "cball x0 ex \ X" "unique_on_cylinder t0 (cball t0 et) x0 ex f B L" by metis then interpret cyl: unique_on_cylinder t0 "cball t0 et" x0 ex "cball x0 ex" f B L by auto from cyl.solution_solves_ode order_refl \cball x0 ex \ X\ have "(cyl.solution solves_ode f) (cball t0 et) X" by (rule solves_ode_on_subset) then have "cball t0 et \ existence_ivl t0 x0" by (rule existence_ivl_maximal_interval) (insert \cball t0 et \ T\ \0 < et\, auto) have "cball t0 et = {t0 - et .. t0 + et}" using \et > 0\ by (auto simp: dist_real_def) then have cylbounds[simp]: "cyl.tmin = t0 - et" "cyl.tmax = t0 + et" unfolding cyl.tmin_def cyl.tmax_def using \0 < et\ by auto define et' where "et' \ et / 2" define ex' where "ex' \ ex / 2" have "et' > 0" "ex' > 0" using \0 < et\ \0 < ex\ by (auto simp: et'_def ex'_def) moreover from \cball t0 et \ existence_ivl t0 x0\ have "cball t0 et' \ existence_ivl t0 x0" by (force simp: et'_def dest!: double_nonneg_le) moreover from this have "cball t0 et' \ T" using existence_ivl_subset[of x0] by simp have "cball x0 (2 * ex') \ X" "\t'. t' \ cball t0 et' \ L-lipschitz_on (cball x0 (2 * ex')) (f t')" using cyl.lipschitz \0 < et\ \cball x0 ex \ X\ by (auto simp: ex'_def et'_def intro!:) moreover { fix x0'::'a assume x0': "x0' \ cball x0 ex'" { fix b assume d: "dist x0' b \ ex'" have "dist x0 b \ dist x0 x0' + dist x0' b" by (rule dist_triangle) also have "\ \ ex' + ex'" using x0' d by simp also have "\ \ ex" by (simp add: ex'_def) finally have "dist x0 b \ ex" . } note triangle = this have subs1: "cball t0 et' \ cball t0 et" and subs2: "cball x0' ex' \ cball x0 ex" and subs: "cball t0 et' \ cball x0' ex' \ cball t0 et \ cball x0 ex" using \0 < ex\ \0 < et\ x0' by (auto simp: ex'_def et'_def triangle dest!: double_nonneg_le) have subset_X: "cball x0' ex' \ X" using \cball x0 ex \ X\ subs2 \0 < ex'\ by force then have "x0' \ X" using \0 < ex'\ by force have x0': "t0 \ T" "x0' \ X" by fact+ have half_intros: "a \ ex' \ a \ ex" "a \ et' \ a \ et" and halfdiv_intro: "a * 2 \ ex / B \ a \ ex' / B" for a using \0 < ex\ \0 < et\ by (auto simp: ex'_def et'_def) interpret cyl': solution_in_cylinder t0 "cball t0 et'" x0' ex' f "cball x0' ex'" B using \0 < et'\ \0 < ex'\ \0 < et\ cyl.norm_f cyl.continuous subs1 \cball t0 et \ T\ apply unfold_locales apply (auto simp: split_beta' dist_cancel_add1 intro!: triangle continuous_intros cyl.norm_f order_trans[OF _ cyl.e_bounded] halfdiv_intro) by (simp add: ex'_def et'_def dist_commute) interpret cyl': unique_on_cylinder t0 "cball t0 et'" x0' ex' "cball x0' ex'" f B L using cyl.lipschitz[simplified] subs subs1 by (unfold_locales) (auto simp: triangle intro!: half_intros lipschitz_on_subset[OF _ subs2]) from cyl'.solution_usolves_ode have "(flow t0 x0' usolves_ode f from t0) (cball t0 et') (cball x0' ex')" apply (rule usolves_ode_solves_odeI) subgoal apply (rule cyl'.solves_ode_on_subset_domain[where Y=X]) subgoal apply (rule solves_ode_on_subset[where S="existence_ivl t0 x0'" and Y=X]) subgoal by (rule flow_solves_ode[OF x0']) subgoal using subs2 \cball x0 ex \ X\ \0 < et'\ \cball t0 et' \ T\ by (intro existence_ivl_maximal_interval[OF solves_ode_on_subset[OF cyl'.solution_solves_ode]]) auto subgoal by force done subgoal by (force simp: \x0' \ X\ iv_defined) subgoal using \0 < et'\ by force subgoal by force subgoal by force done subgoal by (force simp: \x0' \ X\ iv_defined cyl'.solution_iv) done note this subset_X } ultimately show thesis .. qed lemma Picard_iterate_mem_existence_ivlI: assumes "t \ T" assumes "compact C" "x0 \ C" "C \ X" assumes "\y s. s \ {t0 -- t} \ y t0 = x0 \ y \ {t0--s} \ C \ continuous_on {t0--s} y \ x0 + ivl_integral t0 s (\t. f t (y t)) \ C" shows "t \ existence_ivl t0 x0" "\s. s \ {t0 -- t} \ flow t0 x0 s \ C" proof - have "{t0 -- t} \ T" by (intro closed_segment_subset_domain iv_defined assms) from lipschitz_on_compact[OF compact_segment \{t0 -- t} \ T\ \compact C\ \C \ X\] obtain L where L: "\s. s \ {t0 -- t} \ L-lipschitz_on C (f s)" by metis interpret uc: unique_on_closed t0 "{t0 -- t}" x0 f C L using assms closed_segment_iv_subset_domain by unfold_locales (auto intro!: L compact_imp_closed \compact C\ continuous_on_f continuous_intros simp: split_beta) have "{t0 -- t} \ existence_ivl t0 x0" using assms closed_segment_iv_subset_domain by (intro maximal_existence_flow[OF solves_ode_on_subset[OF uc.solution_solves_ode]]) auto thus "t \ existence_ivl t0 x0" using assms by auto show "flow t0 x0 s \ C" if "s \ {t0 -- t}" for s proof - have "flow t0 x0 s = uc.solution s" "uc.solution s \ C" using solves_odeD[OF uc.solution_solves_ode] that assms by (auto simp: closed_segment_iv_subset_domain intro!: maximal_existence_flowI(2)[where K="{t0 -- t}"]) thus ?thesis by simp qed qed lemma flow_has_vderiv_on: "(flow t0 x0 has_vderiv_on (\t. f t (flow t0 x0 t))) (existence_ivl t0 x0)" by (rule solves_ode_vderivD[OF flow_solves_ode[OF iv_defined]]) lemmas flow_has_vderiv_on_compose[derivative_intros] = has_vderiv_on_compose2[OF flow_has_vderiv_on, THEN has_vderiv_on_eq_rhs] end lemma unique_on_intersection: assumes sols: "(x solves_ode f) U X" "(y solves_ode f) V X" assumes iv_mem: "t0 \ U" "t0 \ V" and subs: "U \ T" "V \ T" assumes ivls: "is_interval U" "is_interval V" assumes iv: "x t0 = y t0" assumes mem: "t \ U" "t \ V" shows "x t = y t" proof - from maximal_existence_flow(2)[OF sols(1) refl ivls(1) iv_mem(1) subs(1) mem(1)] maximal_existence_flow(2)[OF sols(2) iv[symmetric] ivls(2) iv_mem(2) subs(2) mem(2)] show ?thesis by simp qed lemma unique_solution: assumes sols: "(x solves_ode f) U X" "(y solves_ode f) U X" assumes iv_mem: "t0 \ U" and subs: "U \ T" assumes ivls: "is_interval U" assumes iv: "x t0 = y t0" assumes mem: "t \ U" shows "x t = y t" by (metis unique_on_intersection assms) lemma assumes s: "s \ existence_ivl t0 x0" assumes t: "t + s \ existence_ivl s (flow t0 x0 s)" shows flow_trans: "flow t0 x0 (s + t) = flow s (flow t0 x0 s) (s + t)" and existence_ivl_trans: "s + t \ existence_ivl t0 x0" proof - note ll_on_open_it_axioms moreover from ll_on_open_it_axioms have iv_defined: "t0 \ T" "x0 \ X" and iv_defined': "s \ T" "flow t0 x0 s \ X" using ll_on_open_it.mem_existence_ivl_iv_defined s t by blast+ have "{t0--s} \ existence_ivl t0 x0" by (simp add: s segment_subset_existence_ivl iv_defined) have "s \ existence_ivl s (flow t0 x0 s)" by (rule ll_on_open_it.existence_ivl_initial_time; fact) have "{s--t + s} \ existence_ivl s (flow t0 x0 s)" by (rule ll_on_open_it.segment_subset_existence_ivl; fact) have unique: "flow t0 x0 u = flow s (flow t0 x0 s) u" if "u \ {s--t + s}" "u \ {t0--s}" for u using ll_on_open_it_axioms ll_on_open_it.flow_solves_ode[OF ll_on_open_it_axioms iv_defined] ll_on_open_it.flow_solves_ode[OF ll_on_open_it_axioms iv_defined'] s apply (rule ll_on_open_it.unique_on_intersection) using \s \ existence_ivl s (flow t0 x0 s)\ existence_ivl_subset \flow t0 x0 s \ X\ \s \ T\ iv_defined s t ll_on_open_it.in_existence_between_zeroI that ll_on_open_it_axioms ll_on_open_it.mem_existence_ivl_subset by (auto simp: is_interval_existence_ivl) let ?un = "{t0 -- s} \ {s -- t + s}" let ?if = "\t. if t \ {t0 -- s} then flow t0 x0 t else flow s (flow t0 x0 s) t" have "(?if solves_ode (\t. if t \ {t0 -- s} then f t else f t)) ?un (X \ X)" apply (rule connection_solves_ode) subgoal by (rule solves_ode_on_subset[OF flow_solves_ode[OF iv_defined] \{t0--s} \ _\ order_refl]) subgoal by (rule solves_ode_on_subset[OF ll_on_open_it.flow_solves_ode[OF ll_on_open_it_axioms iv_defined'] \{s--t + s} \ _\ order_refl]) subgoal by simp subgoal by simp subgoal by (rule unique) auto subgoal by simp done then have ifsol: "(?if solves_ode f) ?un X" by simp moreover have "?un \ existence_ivl t0 x0" using existence_ivl_subset[of x0] ll_on_open_it.existence_ivl_subset[OF ll_on_open_it_axioms, of s "flow t0 x0 s"] \{t0 -- s} \ _\ \{s--t + s} \ _\ by (intro existence_ivl_maximal_interval[OF ifsol]) (auto intro!: is_real_interval_union) then show "s + t \ existence_ivl t0 x0" by (auto simp: ac_simps) have "(flow t0 x0 solves_ode f) ?un X" using \{t0--s} \ _\ \{s -- t + s} \ _\ by (intro solves_ode_on_subset[OF flow_solves_ode \?un \ _\ order_refl] iv_defined) moreover have "s \ ?un" by simp ultimately have "?if (s + t) = flow t0 x0 (s + t)" apply (rule ll_on_open_it.unique_solution) using existence_ivl_subset[of x0] ll_on_open_it.existence_ivl_subset[OF ll_on_open_it_axioms, of s "flow t0 x0 s"] \{t0 -- s} \ _\ \{s--t + s} \ _\ by (auto intro!: is_real_interval_union simp: ac_simps) with unique[of "s + t"] show "flow t0 x0 (s + t) = flow s (flow t0 x0 s) (s + t)" by (auto split: if_splits simp: ac_simps) qed lemma assumes t: "t \ existence_ivl t0 x0" shows flows_reverse: "flow t (flow t0 x0 t) t0 = x0" and existence_ivl_reverse: "t0 \ existence_ivl t (flow t0 x0 t)" proof - have iv_defined: "t0 \ T" "x0 \ X" using mem_existence_ivl_iv_defined t by blast+ show "t0 \ existence_ivl t (flow t0 x0 t)" using assms by (metis (no_types, opaque_lifting) closed_segment_commute closed_segment_subset_interval ends_in_segment(2) general.csol(2-4) general.existence_ivl_maximal_segment general.is_interval_existence_ivl is_interval_closed_segment_1 iv_defined ll_on_open_it.equals_flowI local.existence_ivl_initial_time local.flow_initial_time local.ll_on_open_it_axioms) then have "flow t (flow t0 x0 t) (t + (t0 - t)) = flow t0 x0 (t + (t0 - t))" by (intro flow_trans[symmetric]) (auto simp: t iv_defined) then show "flow t (flow t0 x0 t) t0 = x0" by (simp add: iv_defined) qed lemma flow_has_derivative: assumes "t \ existence_ivl t0 x0" shows "(flow t0 x0 has_derivative (\i. i *\<^sub>R f t (flow t0 x0 t))) (at t)" proof - have "(flow t0 x0 has_derivative (\i. i *\<^sub>R f t (flow t0 x0 t))) (at t within existence_ivl t0 x0)" using flow_has_vderiv_on by (auto simp: has_vderiv_on_def has_vector_derivative_def assms mem_existence_ivl_iv_defined[OF assms]) then show ?thesis by (simp add: at_within_open[OF assms open_existence_ivl]) qed lemma flow_has_vector_derivative: assumes "t \ existence_ivl t0 x0" shows "(flow t0 x0 has_vector_derivative f t (flow t0 x0 t)) (at t)" using flow_has_derivative[OF assms] by (simp add: has_vector_derivative_def) lemma flow_has_vector_derivative_at_0: assumes"t \ existence_ivl t0 x0" shows "((\h. flow t0 x0 (t + h)) has_vector_derivative f t (flow t0 x0 t)) (at 0)" proof - from flow_has_vector_derivative[OF assms] have "((+) t has_vector_derivative 1) (at 0)" "(flow t0 x0 has_vector_derivative f t (flow t0 x0 t)) (at (t + 0))" by (auto intro!: derivative_eq_intros) from vector_diff_chain_at[OF this] show ?thesis by (simp add: o_def) qed lemma assumes "t \ existence_ivl t0 x0" shows closed_segment_subset_existence_ivl: "closed_segment t0 t \ existence_ivl t0 x0" and ivl_subset_existence_ivl: "{t0 .. t} \ existence_ivl t0 x0" and ivl_subset_existence_ivl': "{t .. t0} \ existence_ivl t0 x0" using assms in_existence_between_zeroI by (auto simp: closed_segment_eq_real_ivl) lemma flow_fixed_point: assumes t: "t \ existence_ivl t0 x0" shows "flow t0 x0 t = x0 + ivl_integral t0 t (\t. f t (flow t0 x0 t))" proof - have "(flow t0 x0 has_vderiv_on (\s. f s (flow t0 x0 s))) {t0 -- t}" using closed_segment_subset_existence_ivl[OF t] by (auto intro!: has_vector_derivative_at_within flow_has_vector_derivative simp: has_vderiv_on_def) from fundamental_theorem_of_calculus_ivl_integral[OF this] have "((\t. f t (flow t0 x0 t)) has_ivl_integral flow t0 x0 t - x0) t0 t" by (simp add: mem_existence_ivl_iv_defined[OF assms]) from this[THEN ivl_integral_unique] show ?thesis by simp qed lemma flow_continuous: "t \ existence_ivl t0 x0 \ continuous (at t) (flow t0 x0)" by (metis has_derivative_continuous flow_has_derivative) lemma flow_tendsto: "t \ existence_ivl t0 x0 \ (ts \ t) F \ ((\s. flow t0 x0 (ts s)) \ flow t0 x0 t) F" by (rule isCont_tendsto_compose[OF flow_continuous]) lemma flow_continuous_on: "continuous_on (existence_ivl t0 x0) (flow t0 x0)" by (auto intro!: flow_continuous continuous_at_imp_continuous_on) lemma flow_continuous_on_intro: "continuous_on s g \ (\xa. xa \ s \ g xa \ existence_ivl t0 x0) \ continuous_on s (\xa. flow t0 x0 (g xa))" by (auto intro!: continuous_on_compose2[OF flow_continuous_on]) lemma f_flow_continuous: assumes "t \ existence_ivl t0 x0" shows "isCont (\t. f t (flow t0 x0 t)) t" by (rule continuous_on_interior) (insert existence_ivl_subset assms, auto intro!: flow_in_domain flow_continuous_on continuous_intros simp: interior_open open_existence_ivl) lemma exponential_initial_condition: assumes y0: "t \ existence_ivl t0 y0" assumes z0: "t \ existence_ivl t0 z0" assumes "Y \ X" assumes remain: "\s. s \ closed_segment t0 t \ flow t0 y0 s \ Y" "\s. s \ closed_segment t0 t \ flow t0 z0 s \ Y" assumes lipschitz: "\s. s \ closed_segment t0 t \ K-lipschitz_on Y (f s)" shows "norm (flow t0 y0 t - flow t0 z0 t) \ norm (y0 - z0) * exp ((K + 1) * abs (t - t0))" proof cases assume "y0 = z0" thus ?thesis by simp next assume ne: "y0 \ z0" define K' where "K' \ K + 1" from lipschitz have "K'-lipschitz_on Y (f s)" if "s \ {t0 -- t}" for s using that by (auto simp: lipschitz_on_def K'_def intro!: order_trans[OF _ mult_right_mono[of K "K + 1"]]) from mem_existence_ivl_iv_defined[OF y0] mem_existence_ivl_iv_defined[OF z0] have "t0 \ T" and inX: "y0 \ X" "z0 \ X" by auto from remain[of t0] inX \t0 \ T \ have "y0 \ Y" "z0 \ Y" by auto define v where "v \ \t. norm (flow t0 y0 t - flow t0 z0 t)" { fix s assume s: "s \ {t0 -- t}" with s closed_segment_subset_existence_ivl[OF y0] closed_segment_subset_existence_ivl[OF z0] have y0': "s \ existence_ivl t0 y0" and z0': "s \ existence_ivl t0 z0" by (auto simp: closed_segment_eq_real_ivl) have integrable: "(\t. f t (flow t0 y0 t)) integrable_on {t0--s}" "(\t. f t (flow t0 z0 t)) integrable_on {t0--s}" using closed_segment_subset_existence_ivl[OF y0'] closed_segment_subset_existence_ivl[OF z0'] \y0 \ X\ \z0 \ X\ \t0 \ T\ by (auto intro!: continuous_at_imp_continuous_on f_flow_continuous integrable_continuous_closed_segment) hence int: "flow t0 y0 s - flow t0 z0 s = y0 - z0 + ivl_integral t0 s (\t. f t (flow t0 y0 t) - f t (flow t0 z0 t))" unfolding v_def using flow_fixed_point[OF y0'] flow_fixed_point[OF z0'] s by (auto simp: algebra_simps ivl_integral_diff) have "v s \ v t0 + K' * integral {t0 -- s} (\t. v t)" using closed_segment_subset_existence_ivl[OF y0'] closed_segment_subset_existence_ivl[OF z0'] s using closed_segment_closed_segment_subset[OF _ _ s, of _ t0, simplified] by (subst integral_mult) (auto simp: integral_mult v_def int inX \t0 \ T\ simp del: Henstock_Kurzweil_Integration.integral_mult_right intro!: norm_triangle_le ivl_integral_norm_bound_integral integrable_continuous_closed_segment continuous_intros continuous_at_imp_continuous_on flow_continuous f_flow_continuous lipschitz_on_normD[OF \_ \ K'-lipschitz_on _ _\] remain) } note le = this have cont: "continuous_on {t0 -- t} v" using closed_segment_subset_existence_ivl[OF y0] closed_segment_subset_existence_ivl[OF z0] inX by (auto simp: v_def \t0 \ T\ intro!: continuous_at_imp_continuous_on continuous_intros flow_continuous) have nonneg: "\t. v t \ 0" by (auto simp: v_def) from ne have pos: "v t0 > 0" by (auto simp: v_def \t0 \ T\ inX) have lippos: "K' > 0" proof - have "0 \ dist (f t0 y0) (f t0 z0)" by simp also from lipschitz_onD[OF lipschitz \y0 \ Y\ \z0 \ Y\, of t0]ne have "\ \ K * dist y0 z0" by simp finally have "0 \ K" by (metis dist_le_zero_iff ne zero_le_mult_iff) thus ?thesis by (simp add: K'_def) qed from le cont nonneg pos \0 < K'\ have "v t \ v t0 * exp (K' * abs (t - t0))" by (rule gronwall_general_segment) simp_all thus ?thesis by (simp add: v_def K'_def \t0 \ T\ inX) qed lemma existence_ivl_cballs: assumes iv_defined: "t0 \ T" "x0 \ X" obtains t u L where "\y. y \ cball x0 u \ cball t0 t \ existence_ivl t0 y" "\s y. y \ cball x0 u \ s \ cball t0 t \ flow t0 y s \ cball y u" "L-lipschitz_on (cball t0 t\cball x0 u) (\(t, x). flow t0 x t)" "\y. y \ cball x0 u \ cball y u \ X" "0 < t" "0 < u" proof - note iv_defined from local_unique_solutions[OF this] obtain t u L where tu: "0 < t" "0 < u" and subsT: "cball t0 t \ existence_ivl t0 x0" and subs': "cball x0 (2 * u) \ X" and lipschitz: "\s. s \ cball t0 t \ L-lipschitz_on (cball x0 (2*u)) (f s)" and usol: "\y. y \ cball x0 u \ (flow t0 y usolves_ode f from t0) (cball t0 t) (cball y u)" and subs: "\y. y \ cball x0 u \ cball y u \ X" by metis { fix y assume y: "y \ cball x0 u" from subs[OF y] \0 < u\ have "y \ X" by auto note iv' = \t0 \ T\ \y \ X\ from usol[OF y, THEN usolves_odeD(1)] have sol1: "(flow t0 y solves_ode f) (cball t0 t) (cball y u)" . from sol1 order_refl subs[OF y] have sol: "(flow t0 y solves_ode f) (cball t0 t) X" by (rule solves_ode_on_subset) note * = maximal_existence_flow[OF sol flow_initial_time is_interval_cball_1 _ order_trans[OF subsT existence_ivl_subset], unfolded centre_in_cball, OF iv' less_imp_le[OF \0 < t\]] have eivl: "cball t0 t \ existence_ivl t0 y" by (rule *) have "flow t0 y s \ cball y u" if "s \ cball t0 t" for s by (rule solves_odeD(2)[OF sol1 that]) note eivl this } note * = this note * moreover have cont_on_f_flow: "\x1 S. S \ cball t0 t \ x1 \ cball x0 u \ continuous_on S (\t. f t (flow t0 x1 t))" using subs[of x0] \u > 0\ *(1) iv_defined by (auto intro!: continuous_at_imp_continuous_on f_flow_continuous) have "bounded ((\(t, x). f t x) ` (cball t0 t \ cball x0 (2 * u)))" using subs' subsT existence_ivl_subset[of x0] by (auto intro!: compact_imp_bounded compact_continuous_image compact_Times continuous_intros simp: split_beta') then obtain B where B: "\s y. s \ cball t0 t \ y \ cball x0 (2 * u) \ norm (f s y) \ B" "B > 0" by (auto simp: bounded_pos cball_def) have flow_in_cball: "flow t0 x1 s \ cball x0 (2 * u)" if s: "s \ cball t0 t" and x1: "x1 \ cball x0 u" for s::real and x1 proof - from *(2)[OF x1 s] have "flow t0 x1 s \ cball x1 u" . also have "\ \ cball x0 (2 * u)" using x1 by (auto intro!: dist_triangle_le[OF add_mono, of _ x1 u _ u, simplified] simp: dist_commute) finally show ?thesis . qed have "(B + exp ((L + 1) * \t\))-lipschitz_on (cball t0 t\cball x0 u) (\(t, x). flow t0 x t)" proof (rule lipschitz_onI, safe) fix t1 t2 :: real and x1 x2 assume t1: "t1 \ cball t0 t" and t2: "t2 \ cball t0 t" and x1: "x1 \ cball x0 u" and x2: "x2 \ cball x0 u" have t1_ex: "t1 \ existence_ivl t0 x1" and t2_ex: "t2 \ existence_ivl t0 x1" "t2 \ existence_ivl t0 x2" and "x1 \ cball x0 (2*u)" "x2 \ cball x0 (2*u)" using *(1)[OF x1] *(1)[OF x2] t1 t2 x1 x2 tu by auto have "dist (flow t0 x1 t1) (flow t0 x2 t2) \ dist (flow t0 x1 t1) (flow t0 x1 t2) + dist (flow t0 x1 t2) (flow t0 x2 t2)" by (rule dist_triangle) also have "dist (flow t0 x1 t2) (flow t0 x2 t2) \ dist x1 x2 * exp ((L + 1) * \t2 - t0\)" unfolding dist_norm proof (rule exponential_initial_condition[where Y = "cball x0 (2 * u)"]) fix s assume "s \ closed_segment t0 t2" hence s: "s \ cball t0 t" using t2 by (auto simp: dist_real_def closed_segment_eq_real_ivl split: if_split_asm) show "flow t0 x1 s \ cball x0 (2 * u)" by (rule flow_in_cball[OF s x1]) show "flow t0 x2 s \ cball x0 (2 * u)" by (rule flow_in_cball[OF s x2]) show "L-lipschitz_on (cball x0 (2 * u)) (f s)" if "s \ closed_segment t0 t2" for s using that centre_in_cball convex_contains_segment less_imp_le t2 tu(1) by (blast intro!: lipschitz) qed (fact)+ also have "\ \ dist x1 x2 * exp ((L + 1) * \t\)" using \u > 0\ t2 by (auto intro!: mult_left_mono add_nonneg_nonneg lipschitz[THEN lipschitz_on_nonneg] simp: cball_eq_empty cball_eq_sing' dist_real_def) also have "x1 \ X" using x1 subs[of x0] \u > 0\ by auto have *: "\t0 - t1\ \ t \ x \ {t0--t1} \ \t0 - x\ \ t" "\t0 - t2\ \ t \ x \ {t0--t2} \ \t0 - x\ \ t" "\t0 - t1\ \ t \ \t0 - t2\ \ t \ x \ {t1--t2} \ \t0 - x\ \ t" for x using t1 t2 t1_ex x1 flow_in_cball[OF _ x1] by (auto simp: closed_segment_eq_real_ivl split: if_splits) have integrable: "(\t. f t (flow t0 x1 t)) integrable_on {t0--t1}" "(\t. f t (flow t0 x1 t)) integrable_on {t0--t2}" "(\t. f t (flow t0 x1 t)) integrable_on {t1--t2}" using t1 t2 t1_ex x1 flow_in_cball[OF _ x1] by (auto intro!: order_trans[OF integral_bound[where B=B]] cont_on_f_flow B integrable_continuous_closed_segment intro: * simp: dist_real_def integral_minus_sets') have *: "\t0 - t1\ \ t \ \t0 - t2\ \ t \ s \ {t1--t2} \ \t0 - s\ \ t" for s by (auto simp: closed_segment_eq_real_ivl split: if_splits) note [simp] = t1_ex t2_ex \x1 \ X\ integrable have "dist (flow t0 x1 t1) (flow t0 x1 t2) \ dist t1 t2 * B" using t1 t2 x1 flow_in_cball[OF _ x1] \t0 \ T\ ivl_integral_combine[of "\t. f t (flow t0 x1 t)" t2 t0 t1] ivl_integral_combine[of "\t. f t (flow t0 x1 t)" t1 t0 t2] by (auto simp: flow_fixed_point dist_norm add.commute closed_segment_commute norm_minus_commute ivl_integral_minus_sets' ivl_integral_minus_sets intro!: order_trans[OF ivl_integral_bound[where B=B]] cont_on_f_flow B dest: *) finally have "dist (flow t0 x1 t1) (flow t0 x2 t2) \ dist t1 t2 * B + dist x1 x2 * exp ((L + 1) * \t\)" by arith also have "\ \ dist (t1, x1) (t2, x2) * B + dist (t1, x1) (t2, x2) * exp ((L + 1) * \t\)" using \B > 0\ by (auto intro!: add_mono mult_right_mono simp: dist_prod_def) finally show "dist (flow t0 x1 t1) (flow t0 x2 t2) \ (B + exp ((L + 1) * \t\)) * dist (t1, x1) (t2, x2)" by (simp add: algebra_simps) qed (simp add: \0 < B\ less_imp_le) ultimately show thesis using subs tu .. qed context fixes x0 assumes iv_defined: "t0 \ T" "x0 \ X" begin lemma existence_ivl_notempty: "existence_ivl t0 x0 \ {}" using existence_ivl_initial_time iv_defined by auto lemma initial_time_bounds: shows "bdd_above (existence_ivl t0 x0) \ t0 < Sup (existence_ivl t0 x0)" (is "?a \ _") and "bdd_below (existence_ivl t0 x0) \ Inf (existence_ivl t0 x0) < t0" (is "?b \ _") proof - from local_unique_solutions[OF iv_defined] obtain te where te: "te > 0" "cball t0 te \ existence_ivl t0 x0" by metis then show "t0 < Sup (existence_ivl t0 x0)" if bdd: "bdd_above (existence_ivl t0 x0)" using less_cSup_iff[OF existence_ivl_notempty bdd, of t0] iv_defined by (auto simp: dist_real_def intro!: bexI[where x="t0 + te"]) from te show "Inf (existence_ivl t0 x0) < t0" if bdd: "bdd_below (existence_ivl t0 x0)" unfolding cInf_less_iff[OF existence_ivl_notempty bdd, of t0] by (auto simp: dist_real_def iv_defined intro!: bexI[where x="t0 - te"]) qed lemma flow_leaves_compact_ivl_right: assumes bdd: "bdd_above (existence_ivl t0 x0)" defines "b \ Sup (existence_ivl t0 x0)" assumes "b \ T" assumes "compact K" assumes "K \ X" obtains t where "t \ t0" "t \ existence_ivl t0 x0" "flow t0 x0 t \ K" proof (atomize_elim, rule ccontr, auto) note iv_defined note ne = existence_ivl_notempty assume K[rule_format]: "\t. t \ existence_ivl t0 x0 \ t0 \ t \ flow t0 x0 t \ K" have b_upper: "t \ b" if "t \ existence_ivl t0 x0" for t unfolding b_def by (rule cSup_upper[OF that bdd]) have less_b_iff: "y < b \ (\x\existence_ivl t0 x0. y < x)" for y unfolding b_def less_cSup_iff[OF ne bdd] .. have "t0 \ b" by (simp add: iv_defined b_upper) then have geI: "t \ {t0-- t0 \ t" for t by (auto simp: half_open_segment_real) have subset: "{t0 --< b} \ existence_ivl t0 x0" using \t0 \ b\ in_existence_between_zeroI by (auto simp: half_open_segment_real iv_defined less_b_iff) have sol: "(flow t0 x0 solves_ode f) {t0 --< b} K" apply (rule solves_odeI) apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF flow_solves_ode] subset]) using subset iv_defined by (auto intro!: K geI) have cont: "continuous_on ({t0--b} \ K) (\(t, x). f t x)" using \K \ X\ closed_segment_subset_domainI[OF iv_defined(1) \b \ T\] by (auto simp: split_beta intro!: continuous_intros) from initial_time_bounds(1)[OF bdd] have "t0 \ b" by (simp add: b_def) from solves_ode_half_open_segment_continuation[OF sol cont \compact K\ \t0 \ b\] obtain l where lim: "(flow t0 x0 \ l) (at b within {t0--t. if t = b then l else flow t0 x0 t) solves_ode f) {t0--b} K" . have "b \ existence_ivl t0 x0" using \t0 \ b\ closed_segment_subset_domainI[OF \t0 \ T\ \b \ T\] by (intro existence_ivl_maximal_segment[OF solves_ode_on_subset[OF limsol order_refl \K \ X\]]) (auto simp: iv_defined) have "flow t0 x0 b \ X" by (simp add: \b \ existence_ivl t0 x0\ flow_in_domain iv_defined) from ll_on_open_it.local_unique_solutions[OF ll_on_open_it_axioms \b \ T\ \flow t0 x0 b \ X\] obtain e where "e > 0" "cball b e \ existence_ivl b (flow t0 x0 b)" by metis then have "e + b \ existence_ivl b (flow t0 x0 b)" by (auto simp: dist_real_def) from existence_ivl_trans[OF \b \ existence_ivl t0 x0\ \e + b \ existence_ivl _ _\] have "b + e \ existence_ivl t0 x0" . from b_upper[OF this] \e > 0\ show False by simp qed lemma flow_leaves_compact_ivl_left: assumes bdd: "bdd_below (existence_ivl t0 x0)" defines "b \ Inf (existence_ivl t0 x0)" assumes "b \ T" assumes "compact K" assumes "K \ X" obtains t where "t \ t0" "t \ existence_ivl t0 x0" "flow t0 x0 t \ K" proof - interpret rev: ll_on_open "(preflect t0 ` T)" "(\t. - f (preflect t0 t))" X .. from antimono_preflect bdd have bdd_rev: "bdd_above (rev.existence_ivl t0 x0)" unfolding rev_existence_ivl_eq by (rule bdd_above_image_antimono) note ne = existence_ivl_notempty have "Sup (rev.existence_ivl t0 x0) = preflect t0 b" using continuous_at_Inf_antimono[OF antimono_preflect _ ne bdd] by (simp add: continuous_preflect b_def rev_existence_ivl_eq) then have Sup_mem: "Sup (rev.existence_ivl t0 x0) \ preflect t0 ` T" using \b \ T\ by auto have rev_iv: "t0 \ preflect t0 ` T" "x0 \ X" using iv_defined by auto from rev.flow_leaves_compact_ivl_right[OF rev_iv bdd_rev Sup_mem \compact K\ \K \ X\] obtain t where "t0 \ t" "t \ rev.existence_ivl t0 x0" "rev.flow t0 x0 t \ K" . then have "preflect t0 t \ t0" "preflect t0 t \ existence_ivl t0 x0" "flow t0 x0 (preflect t0 t) \ K" by (auto simp: rev_existence_ivl_eq rev_flow_eq) thus ?thesis .. qed lemma sup_existence_maximal: assumes "\t. t0 \ t \ t \ existence_ivl t0 x0 \ flow t0 x0 t \ K" assumes "compact K" "K \ X" assumes "bdd_above (existence_ivl t0 x0)" shows "Sup (existence_ivl t0 x0) \ T" using flow_leaves_compact_ivl_right[of K] assms by force lemma inf_existence_minimal: assumes "\t. t \ t0 \ t \ existence_ivl t0 x0 \ flow t0 x0 t \ K" assumes "compact K" "K \ X" assumes "bdd_below (existence_ivl t0 x0)" shows "Inf (existence_ivl t0 x0) \ T" using flow_leaves_compact_ivl_left[of K] assms by force end lemma subset_mem_compact_implies_subset_existence_interval: assumes ivl: "t0 \ T'" "is_interval T'" "T' \ T" assumes iv_defined: "x0 \ X" assumes mem_compact: "\t. t \ T' \ t \ existence_ivl t0 x0 \ flow t0 x0 t \ K" assumes K: "compact K" "K \ X" shows "T' \ existence_ivl t0 x0" proof (rule ccontr) assume "\ T' \ existence_ivl t0 x0" then obtain t' where t': "t' \ existence_ivl t0 x0" "t' \ T'" by auto from assms have iv_defined: "t0 \ T" "x0 \ X" by auto show False proof (cases rule: not_in_connected_cases[OF connected_existence_ivl t'(1) existence_ivl_notempty[OF iv_defined]]) assume bdd: "bdd_below (existence_ivl t0 x0)" assume t'_lower: "t' \ y" if "y \ existence_ivl t0 x0" for y have i: "Inf (existence_ivl t0 x0) \ T'" using initial_time_bounds[OF iv_defined] iv_defined apply - by (rule mem_is_intervalI[of _ t' t0]) (auto simp: ivl t' bdd intro!: t'_lower cInf_greatest[OF existence_ivl_notempty[OF iv_defined]]) have *: "t \ T'" if "t \ t0" "t \ existence_ivl t0 x0" for t by (rule mem_is_intervalI[OF \is_interval T'\ i \t0 \ T'\]) (auto intro!: cInf_lower that bdd) from inf_existence_minimal[OF iv_defined mem_compact K bdd, OF *] show False using i ivl by auto next assume bdd: "bdd_above (existence_ivl t0 x0)" assume t'_upper: "y \ t'" if "y \ existence_ivl t0 x0" for y have s: "Sup (existence_ivl t0 x0) \ T'" using initial_time_bounds[OF iv_defined] apply - apply (rule mem_is_intervalI[of _ t0 t']) by (auto simp: ivl t' bdd intro!: t'_upper cSup_least[OF existence_ivl_notempty[OF iv_defined]]) have *: "t \ T'" if "t0 \ t" "t \ existence_ivl t0 x0" for t by (rule mem_is_intervalI[OF \is_interval T'\ \t0 \ T'\ s]) (auto intro!: cSup_upper that bdd) from sup_existence_maximal[OF iv_defined mem_compact K bdd, OF *] show False using s ivl by auto qed qed lemma mem_compact_implies_subset_existence_interval: assumes iv_defined: "t0 \ T" "x0 \ X" assumes mem_compact: "\t. t \ T \ t \ existence_ivl t0 x0 \ flow t0 x0 t \ K" assumes K: "compact K" "K \ X" shows "T \ existence_ivl t0 x0" by (rule subset_mem_compact_implies_subset_existence_interval; (fact | rule order_refl interval iv_defined)) lemma global_right_existence_ivl_explicit: assumes "b \ t0" assumes b: "b \ existence_ivl t0 x0" obtains d K where "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ b \ existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {t0 .. b} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" proof - note iv_defined = mem_existence_ivl_iv_defined[OF b] define seg where "seg \ (\t. flow t0 x0 t) ` (closed_segment t0 b)" have [simp]: "x0 \ seg" by (auto simp: seg_def intro!: image_eqI[where x=t0] simp: closed_segment_eq_real_ivl iv_defined) have "seg \ {}" by (auto simp: seg_def closed_segment_eq_real_ivl) moreover have "compact seg" using iv_defined b by (auto simp: seg_def closed_segment_eq_real_ivl intro!: compact_continuous_image continuous_at_imp_continuous_on flow_continuous; metis (erased, opaque_lifting) atLeastAtMost_iff closed_segment_eq_real_ivl closed_segment_subset_existence_ivl contra_subsetD order.trans) moreover note open_domain(2) moreover have "seg \ X" using closed_segment_subset_existence_ivl b by (auto simp: seg_def intro!: flow_in_domain iv_defined) ultimately obtain e where e: "0 < e" "{x. infdist x seg \ e} \ X" thm compact_in_open_separated by (rule compact_in_open_separated) define A where "A \ {x. infdist x seg \ e}" have "A \ X" using e by (simp add: A_def) have mem_existence_ivlI: "\s. t0 \ s \ s \ b \ s \ existence_ivl t0 x0" by (rule in_existence_between_zeroI[OF b]) (auto simp: closed_segment_eq_real_ivl) have "compact A" unfolding A_def by (rule compact_infdist_le) fact+ have "compact {t0 .. b}" "{t0 .. b} \ T" subgoal by simp subgoal using mem_existence_ivlI mem_existence_ivl_subset[of _ x0] iv_defined b ivl_subset_existence_ivl by blast done from lipschitz_on_compact[OF this \compact A\ \A \ X\] obtain K' where K': "\t. t \ {t0 .. b} \ K'-lipschitz_on A (f t)" by metis define K where "K \ K' + 1" have "0 < K" "0 \ K" using assms lipschitz_on_nonneg[OF K', of t0] by (auto simp: K_def) have K: "\t. t \ {t0 .. b} \ K-lipschitz_on A (f t)" unfolding K_def using \_ \ lipschitz_on K' A _\ by (rule lipschitz_on_mono) auto have [simp]: "x0 \ A" using \0 < e\ by (auto simp: A_def) define d where "d \ min e (e * exp (-K * (b - t0)))" hence d: "0 < d" "d \ e" "d \ e * exp (-K * (b - t0))" using e by auto have d_times_exp_le: "d * exp (K * (t - t0)) \ e" if "t0 \ t" "t \ b" for t proof - from that have "d * exp (K * (t - t0)) \ d * exp (K * (b - t0))" using \0 \ K\ \0 < d\ by (auto intro!: mult_left_mono) also have "d * exp (K * (b - t0)) \ e" using d by (auto simp: exp_minus divide_simps) finally show ?thesis . qed have "ball x0 d \ X" using d \A \ X\ by (auto simp: A_def dist_commute intro!: infdist_le2[where a=x0]) note iv_defined { fix y assume y: "y \ ball x0 d" hence "y \ A" using d by (auto simp: A_def dist_commute intro!: infdist_le2[where a=x0]) hence "y \ X" using \A \ X\ by auto note y_iv = \t0 \ T\ \y \ X\ have in_A: "flow t0 y t \ A" if t: "t0 \ t" "t \ existence_ivl t0 y" "t \ b" for t proof (rule ccontr) assume flow_out: "flow t0 y t \ A" obtain t' where t': "t0 \ t'" "t' \ t" "\t. t \ {t0 .. t'} \ flow t0 x0 t \ A" "infdist (flow t0 y t') seg \ e" "\t. t \ {t0 .. t'} \ flow t0 y t \ A" proof - let ?out = "((\t. infdist (flow t0 y t) seg) -` {e..}) \ {t0..t}" have "compact ?out" unfolding compact_eq_bounded_closed proof safe show "bounded ?out" by (auto intro!: bounded_closed_interval) have "continuous_on {t0 .. t} ((\t. infdist (flow t0 y t) seg))" using closed_segment_subset_existence_ivl t iv_defined by (force intro!: continuous_at_imp_continuous_on continuous_intros flow_continuous simp: closed_segment_eq_real_ivl) thus "closed ?out" by (simp add: continuous_on_closed_vimage) qed moreover have "t \ (\t. infdist (flow t0 y t) seg) -` {e..} \ {t0..t}" using flow_out \t0 \ t\ by (auto simp: A_def) hence "?out \ {}" by blast ultimately have "\s\?out. \t\?out. s \ t" by (rule compact_attains_inf) then obtain t' where t': "\s. e \ infdist (flow t0 y s) seg \ t0 \ s \ s \ t \ t' \ s" "e \ infdist (flow t0 y t') seg" "t0 \ t'" "t' \ t" by (auto simp: vimage_def Ball_def) metis have flow_in: "flow t0 x0 s \ A" if s: "s \ {t0 .. t'}" for s proof - from s have "s \ closed_segment t0 b" using \t \ b\ t' by (auto simp: closed_segment_eq_real_ivl) then show ?thesis using s \e > 0\ by (auto simp: seg_def A_def) qed have "flow t0 y t' \ A" if "t' = t0" using y d iv_defined that by (auto simp: A_def \y \ X\ infdist_le2[where a=x0] dist_commute) moreover have "flow t0 y s \ A" if s: "s \ {t0 ..< t'}" for s proof - from s have "s \ closed_segment t0 b" using \t \ b\ t' by (auto simp: closed_segment_eq_real_ivl) from t'(1)[of s] have "t' > s \ t0 \ s \ s \ t \ e > infdist (flow t0 y s) seg" by force then show ?thesis using s t' \e > 0\ by (auto simp: seg_def A_def) qed moreover note left_of_in = this have "closed A" using \compact A\ by (auto simp: compact_eq_bounded_closed) have "((\s. flow t0 y s) \ flow t0 y t') (at_left t')" using closed_segment_subset_existence_ivl[OF t(2)] t' \y \ X\ iv_defined by (intro flow_tendsto) (auto intro!: tendsto_intros simp: closed_segment_eq_real_ivl) with \closed A\ _ _ have "t' \ t0 \ flow t0 y t' \ A" proof (rule Lim_in_closed_set) assume "t' \ t0" hence "t' > t0" using t' by auto hence "eventually (\x. x \ t0) (at_left t')" by (metis eventually_at_left less_imp_le) thus "eventually (\x. flow t0 y x \ A) (at_left t')" unfolding eventually_at_filter by eventually_elim (auto intro!: left_of_in) qed simp ultimately have flow_y_in: "s \ {t0 .. t'} \ flow t0 y s \ A" for s by (cases "s = t'"; fastforce) have "t0 \ t'" "t' \ t" "\t. t \ {t0 .. t'} \ flow t0 x0 t \ A" "infdist (flow t0 y t') seg \ e" "\t. t \ {t0 .. t'} \ flow t0 y t \ A" by (auto intro!: flow_in flow_y_in) fact+ thus ?thesis .. qed { fix s assume s: "s \ {t0 .. t'}" hence "t0 \ s" by simp have "s \ b" using t t' s b by auto hence sx0: "s \ existence_ivl t0 x0" by (simp add: \t0 \ s\ mem_existence_ivlI) have sy: "s \ existence_ivl t0 y" by (meson atLeastAtMost_iff contra_subsetD s t'(1) t'(2) that(2) ivl_subset_existence_ivl) have int: "flow t0 y s - flow t0 x0 s = y - x0 + (integral {t0 .. s} (\t. f t (flow t0 y t)) - integral {t0 .. s} (\t. f t (flow t0 x0 t)))" using iv_defined s unfolding flow_fixed_point[OF sx0] flow_fixed_point[OF sy] by (simp add: algebra_simps ivl_integral_def) have "norm (flow t0 y s - flow t0 x0 s) \ norm (y - x0) + norm (integral {t0 .. s} (\t. f t (flow t0 y t)) - integral {t0 .. s} (\t. f t (flow t0 x0 t)))" unfolding int by (rule norm_triangle_ineq) also have "norm (integral {t0 .. s} (\t. f t (flow t0 y t)) - integral {t0 .. s} (\t. f t (flow t0 x0 t))) = norm (integral {t0 .. s} (\t. f t (flow t0 y t) - f t (flow t0 x0 t)))" using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy by (subst Henstock_Kurzweil_Integration.integral_diff) (auto intro!: integrable_continuous_real continuous_at_imp_continuous_on f_flow_continuous simp: closed_segment_eq_real_ivl) also have "\ \ (integral {t0 .. s} (\t. norm (f t (flow t0 y t) - f t (flow t0 x0 t))))" using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy by (intro integral_norm_bound_integral) (auto intro!: integrable_continuous_real continuous_at_imp_continuous_on f_flow_continuous continuous_intros simp: closed_segment_eq_real_ivl) also have "\ \ (integral {t0 .. s} (\t. K * norm ((flow t0 y t) - (flow t0 x0 t))))" using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy iv_defined s t'(3,5) \s \ b\ by (auto simp del: Henstock_Kurzweil_Integration.integral_mult_right intro!: integral_le integrable_continuous_real continuous_at_imp_continuous_on lipschitz_on_normD[OF K] flow_continuous f_flow_continuous continuous_intros simp: closed_segment_eq_real_ivl) also have "\ = K * integral {t0 .. s} (\t. norm (flow t0 y t - flow t0 x0 t))" using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy by (subst integral_mult) (auto intro!: integrable_continuous_real continuous_at_imp_continuous_on lipschitz_on_normD[OF K] flow_continuous f_flow_continuous continuous_intros simp: closed_segment_eq_real_ivl) finally have norm: "norm (flow t0 y s - flow t0 x0 s) \ norm (y - x0) + K * integral {t0 .. s} (\t. norm (flow t0 y t - flow t0 x0 t))" by arith note norm \s \ b\ sx0 sy } note norm_le = this from norm_le(2) t' have "t' \ closed_segment t0 b" by (auto simp: closed_segment_eq_real_ivl) hence "infdist (flow t0 y t') seg \ dist (flow t0 y t') (flow t0 x0 t')" by (auto simp: seg_def infdist_le) also have "\ \ norm (flow t0 y t' - flow t0 x0 t')" by (simp add: dist_norm) also have "\ \ norm (y - x0) * exp (K * \t' - t0\)" unfolding K_def apply (rule exponential_initial_condition[OF _ _ _ _ _ K']) subgoal by (metis atLeastAtMost_iff local.norm_le(4) order_refl t'(1)) subgoal by (metis atLeastAtMost_iff local.norm_le(3) order_refl t'(1)) subgoal using e by (simp add: A_def) subgoal by (metis closed_segment_eq_real_ivl t'(1,5)) subgoal by (metis closed_segment_eq_real_ivl t'(1,3)) subgoal by (simp add: closed_segment_eq_real_ivl local.norm_le(2) t'(1)) done also have "\ < d * exp (K * (t - t0))" using y d t' t by (intro mult_less_le_imp_less) (auto simp: dist_norm[symmetric] dist_commute intro!: mult_mono \0 \ K\) also have "\ \ e" by (rule d_times_exp_le; fact) finally have "infdist (flow t0 y t') seg < e" . with \infdist (flow t0 y t') seg \ e\ show False by (auto simp: frontier_def) qed have "{t0..b} \ existence_ivl t0 y" by (rule subset_mem_compact_implies_subset_existence_interval[OF _ is_interval_cc \{t0..b} \ T\ \y \ X\ in_A \compact A\ \A \ X\]) (auto simp: \t0 \ b\) with \t0 \ b\ have b_in: "b \ existence_ivl t0 y" by force { fix t assume t: "t \ {t0 .. b}" also have "{t0 .. b} = {t0 -- b}" by (auto simp: closed_segment_eq_real_ivl assms) also note closed_segment_subset_existence_ivl[OF b_in] finally have t_in: "t \ existence_ivl t0 y" . note t also note \{t0 .. b} = {t0 -- b}\ also note closed_segment_subset_existence_ivl[OF assms(2)] finally have t_in': "t \ existence_ivl t0 x0" . have "norm (flow t0 y t - flow t0 x0 t) \ norm (y - x0) * exp (K * \t - t0\)" unfolding K_def using t closed_segment_subset_existence_ivl[OF b_in] \0 < e\ by (intro in_A exponential_initial_condition[OF t_in t_in' \A \ X\ _ _ K']) (auto simp: closed_segment_eq_real_ivl A_def seg_def) hence "dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * \t - t0\)" by (auto simp: dist_norm[symmetric] dist_commute) } note b_in this } from \d > 0\ \K > 0\ \ball x0 d \ X\ this show ?thesis .. qed lemma global_left_existence_ivl_explicit: assumes "b \ t0" assumes b: "b \ existence_ivl t0 x0" assumes iv_defined: "t0 \ T" "x0 \ X" obtains d K where "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ b \ existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {b .. t0} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" proof - interpret rev: ll_on_open "(preflect t0 ` T)" "(\t. - f (preflect t0 t))" X .. have t0': "t0 \ preflect t0 ` T" "x0 \ X" by (auto intro!: iv_defined) from assms have "preflect t0 b \ t0" "preflect t0 b \ rev.existence_ivl t0 x0" by (auto simp: rev_existence_ivl_eq) from rev.global_right_existence_ivl_explicit[OF this] obtain d K where dK: "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ preflect t0 b \ rev.existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {t0 .. preflect t0 b} \ dist (rev.flow t0 x0 t) (rev.flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" by (auto simp: rev_flow_eq \x0 \ X\) have ex_ivlI: "dist x0 y < d \ t \ existence_ivl t0 y" if "b \ t" "t \ t0" for t y using that dK(4)[of y] dK(3) iv_defined by (auto simp: subset_iff rev_existence_ivl_eq[of ] closed_segment_eq_real_ivl iv_defined in_existence_between_zeroI) have "b \ existence_ivl t0 y" if "dist x0 y < d" for y using that dK by (subst existence_ivl_eq_rev) (auto simp: iv_defined intro!: image_eqI[where x="preflect t0 b"]) with dK have "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ b \ existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {b .. t0} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" by (auto simp: flow_eq_rev iv_defined ex_ivlI \x0 \ X\ subset_iff intro!: order_trans[OF dK(5)] image_eqI[where x="preflect t0 b"]) then show ?thesis .. qed lemma global_existence_ivl_explicit: assumes a: "a \ existence_ivl t0 x0" assumes b: "b \ existence_ivl t0 x0" assumes le: "a \ b" obtains d K where "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ a \ existence_ivl t0 y" "\y. y \ ball x0 d \ b \ existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {a .. b} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" proof - note iv_defined = mem_existence_ivl_iv_defined[OF a] define r where "r \ Max {t0, a, b}" define l where "l \ Min {t0, a, b}" have r: "r \ t0" "r \ existence_ivl t0 x0" using a b by (auto simp: max_def r_def iv_defined) obtain dr Kr where right: "0 < dr" "0 < Kr" "ball x0 dr \ X" "\y. y \ ball x0 dr \ r \ existence_ivl t0 y" "\y t. y \ ball x0 dr \ t \ {t0..r} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (Kr * \t - t0\)" by (rule global_right_existence_ivl_explicit[OF r]) blast have l: "l \ t0" "l \ existence_ivl t0 x0" using a b by (auto simp: min_def l_def iv_defined) obtain dl Kl where left: "0 < dl" "0 < Kl" "ball x0 dl \ X" "\y. y \ ball x0 dl \ l \ existence_ivl t0 y" "\y t. y \ ball x0 dl \ t \ {l .. t0} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (Kl * \t - t0\)" by (rule global_left_existence_ivl_explicit[OF l iv_defined]) blast define d where "d \ min dr dl" define K where "K \ max Kr Kl" note iv_defined have "0 < d" "0 < K" "ball x0 d \ X" using left right by (auto simp: d_def K_def) moreover { fix y assume y: "y \ ball x0 d" hence "y \ X" using \ball x0 d \ X\ by auto from y closed_segment_subset_existence_ivl[OF left(4), of y] closed_segment_subset_existence_ivl[OF right(4), of y] have "a \ existence_ivl t0 y" "b \ existence_ivl t0 y" by (auto simp: d_def l_def r_def min_def max_def closed_segment_eq_real_ivl split: if_split_asm) } moreover { fix t y assume y: "y \ ball x0 d" and t: "t \ {a .. b}" from y have "y \ X" using \ball x0 d \ X\ by auto have "dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" proof cases assume "t \ t0" hence "dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (Kr * abs (t - t0))" using y t by (intro right) (auto simp: d_def r_def) also have "exp (Kr * abs (t - t0)) \ exp (K * abs (t - t0))" by (auto simp: mult_left_mono K_def max_def mult_right_mono) finally show ?thesis by (simp add: mult_left_mono) next assume "\t \ t0" hence "dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (Kl * abs (t - t0))" using y t by (intro left) (auto simp: d_def l_def) also have "exp (Kl * abs (t - t0)) \ exp (K * abs (t - t0))" by (auto simp: mult_left_mono K_def max_def mult_right_mono) finally show ?thesis by (simp add: mult_left_mono) qed } ultimately show ?thesis .. qed lemma eventually_exponential_separation: assumes a: "a \ existence_ivl t0 x0" assumes b: "b \ existence_ivl t0 x0" assumes le: "a \ b" obtains K where "K > 0" "\\<^sub>F y in at x0. \t\{a..b}. dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * \t - t0\)" proof - from global_existence_ivl_explicit[OF assms] obtain d K where *: "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ a \ existence_ivl t0 y" "\y. y \ ball x0 d \ b \ existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {a .. b} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" by auto note \K > 0\ moreover have "eventually (\y. y \ ball x0 d) (at x0)" using \d > 0\[THEN eventually_at_ball] by eventually_elim simp hence "eventually (\y. \t\{a..b}. dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * \t - t0\)) (at x0)" by eventually_elim (safe intro!: *) ultimately show ?thesis .. qed lemma eventually_mem_existence_ivl: assumes b: "b \ existence_ivl t0 x0" shows "\\<^sub>F x in at x0. b \ existence_ivl t0 x" proof - from mem_existence_ivl_iv_defined[OF b] have iv_defined: "t0 \ T" "x0 \ X" by simp_all note eiit = existence_ivl_initial_time[OF iv_defined] { fix a b assume assms: "a \ existence_ivl t0 x0" "b \ existence_ivl t0 x0" "a \ b" from global_existence_ivl_explicit[OF assms] obtain d K where *: "d > 0" "K > 0" "ball x0 d \ X" "\y. y \ ball x0 d \ a \ existence_ivl t0 y" "\y. y \ ball x0 d \ b \ existence_ivl t0 y" "\t y. y \ ball x0 d \ t \ {a .. b} \ dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * abs (t - t0))" by auto have "eventually (\y. y \ ball x0 d) (at x0)" using \d > 0\[THEN eventually_at_ball] by eventually_elim simp then have "\\<^sub>F x in at x0. a \ existence_ivl t0 x \ b \ existence_ivl t0 x" by (eventually_elim) (auto intro!: *) } from this[OF b eiit] this[OF eiit b] show ?thesis by (cases "t0 \ b") (auto simp: eventually_mono) qed lemma uniform_limit_flow: assumes a: "a \ existence_ivl t0 x0" assumes b: "b \ existence_ivl t0 x0" assumes le: "a \ b" shows "uniform_limit {a .. b} (flow t0) (flow t0 x0) (at x0)" proof (rule uniform_limitI) fix e::real assume "0 < e" from eventually_exponential_separation[OF assms] obtain K where "0 < K" "\\<^sub>F y in at x0. \t\{a..b}. dist (flow t0 x0 t) (flow t0 y t) \ dist x0 y * exp (K * \t - t0\)" by auto note this(2) moreover let ?m = "max (abs (b - t0)) (abs (a - t0))" have "eventually (\y. \t\{a..b}. dist x0 y * exp (K * \t - t0\) \ dist x0 y * exp (K * ?m)) (at x0)" using \a \ b\ \0 < K\ by (auto intro!: mult_left_mono always_eventually) moreover have "eventually (\y. dist x0 y * exp (K * ?m) < e) (at x0)" using \0 < e\ by (auto intro!: order_tendstoD tendsto_eq_intros) ultimately show "eventually (\y. \t\{a..b}. dist (flow t0 y t) (flow t0 x0 t) < e) (at x0)" by eventually_elim (force simp: dist_commute) qed lemma eventually_at_fst: assumes "eventually P (at (fst x))" assumes "P (fst x)" shows "eventually (\h. P (fst h)) (at x)" using assms unfolding eventually_at_topological by (metis open_vimage_fst rangeI range_fst vimageE vimageI) lemma eventually_at_snd: assumes "eventually P (at (snd x))" assumes "P (snd x)" shows "eventually (\h. P (snd h)) (at x)" using assms unfolding eventually_at_topological by (metis open_vimage_snd rangeI range_snd vimageE vimageI) lemma shows open_state_space: "open (Sigma X (existence_ivl t0))" and flow_continuous_on_state_space: "continuous_on (Sigma X (existence_ivl t0)) (\(x, t). flow t0 x t)" proof (safe intro!: topological_space_class.openI continuous_at_imp_continuous_on) fix t x assume "x \ X" and t: "t \ existence_ivl t0 x" have iv_defined: "t0 \ T" "x \ X" using mem_existence_ivl_iv_defined[OF t] by auto from \x \ X\ t open_existence_ivl obtain e where e: "e > 0" "cball t e \ existence_ivl t0 x" by (metis open_contains_cball) hence ivl: "t - e \ existence_ivl t0 x" "t + e \ existence_ivl t0 x" "t - e \ t + e" by (auto simp: cball_def dist_real_def) obtain d K where dK: "0 < d" "0 < K" "ball x d \ X" "\y. y \ ball x d \ t - e \ existence_ivl t0 y" "\y. y \ ball x d \ t + e \ existence_ivl t0 y" "\y s. y \ ball x d \ s \ {t - e..t + e} \ dist (flow t0 x s) (flow t0 y s) \ dist x y * exp (K * \s - t0\)" by (rule global_existence_ivl_explicit[OF ivl]) blast let ?T = "ball x d \ ball t e" have "open ?T" by (auto intro!: open_Times) moreover have "(x, t) \ ?T" by (auto simp: dK \0 < e\) moreover have "?T \ Sigma X (existence_ivl t0)" proof safe fix s y assume y: "y \ ball x d" and s: "s \ ball t e" with \ball x d \ X\ show "y \ X" by auto have "ball t e \ closed_segment t0 (t - e) \ closed_segment t0 (t + e)" by (auto simp: closed_segment_eq_real_ivl dist_real_def) with \y \ X\ s closed_segment_subset_existence_ivl[OF dK(4)[OF y]] closed_segment_subset_existence_ivl[OF dK(5)[OF y]] show "s \ existence_ivl t0 y" by auto qed ultimately show "\T. open T \ (x, t) \ T \ T \ Sigma X (existence_ivl t0)" by blast have **: "\\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x t) < 2 * eps" if "eps > 0" for eps :: real proof - have "\\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x t) = norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s) + (flow t0 x (t + snd s) - flow t0 x t))" by auto moreover have "\\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s) + (flow t0 x (t + snd s) - flow t0 x t)) \ norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s)) + norm (flow t0 x (t + snd s) - flow t0 x t)" by eventually_elim (rule norm_triangle_ineq) moreover have "\\<^sub>F s in at 0. t + snd s \ ball t e" by (auto simp: dist_real_def intro!: order_tendstoD[OF _ \0 < e\] intro!: tendsto_eq_intros) moreover from uniform_limit_flow[OF ivl, THEN uniform_limitD, OF \eps > 0\] have "\\<^sub>F (h::(_ )) in at (fst (0::'a*real)). \t\{t - e..t + e}. dist (flow t0 x t) (flow t0 (x + h) t) < eps" by (subst (asm) at_to_0) (auto simp: eventually_filtermap dist_commute ac_simps) hence "\\<^sub>F (h::(_ * real)) in at 0. \t\{t - e..t + e}. dist (flow t0 x t) (flow t0 (x + fst h) t) < eps" by (rule eventually_at_fst) (simp add: \eps > 0\) moreover have "\\<^sub>F h in at (snd (0::'a * _)). norm (flow t0 x (t + h) - flow t0 x t) < eps" using flow_continuous[OF t, unfolded isCont_def, THEN tendstoD, OF \eps > 0\] by (subst (asm) at_to_0) (auto simp: eventually_filtermap dist_norm ac_simps) hence "\\<^sub>F h::('a * _) in at 0. norm (flow t0 x (t + snd h) - flow t0 x t) < eps" by (rule eventually_at_snd) (simp add: \eps > 0\) ultimately show ?thesis proof eventually_elim case (elim s) note elim(1) also note elim(2) also note elim(5) also from elim(3) have "t + snd s \ {t - e..t + e}" by (auto simp: dist_real_def algebra_simps) from elim(4)[rule_format, OF this] have "norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s)) < eps" by (auto simp: dist_commute dist_norm[symmetric]) finally show ?case by simp qed qed have *: "\\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x t) < eps" if "eps > 0" for eps::real proof - from that have "eps / 2 > 0" by simp from **[OF this] show ?thesis by auto qed show "isCont (\(x, y). flow t0 x y) (x, t)" unfolding isCont_iff by (rule LIM_zero_cancel) (auto simp: split_beta' norm_conv_dist[symmetric] intro!: tendstoI *) qed lemmas flow_continuous_on_compose[continuous_intros] = continuous_on_compose_Pair[OF flow_continuous_on_state_space] lemma flow_isCont_state_space: "t \ existence_ivl t0 x0 \ isCont (\(x, t). flow t0 x t) (x0, t)" using flow_continuous_on_state_space[of] mem_existence_ivl_iv_defined[of t x0] using continuous_on_eq_continuous_at open_state_space by fastforce lemma flow_absolutely_integrable_on[integrable_on_simps]: assumes "s \ existence_ivl t0 x0" shows "(\x. norm (flow t0 x0 x)) integrable_on closed_segment t0 s" using assms by (auto simp: closed_segment_eq_real_ivl intro!: integrable_continuous_real continuous_intros flow_continuous_on_intro intro: in_existence_between_zeroI) lemma existence_ivl_eq_domain: assumes iv_defined: "t0 \ T" "x0 \ X" assumes bnd: "\tm tM t x. tm \ T \ tM \ T \ \M. \L. \t \ {tm .. tM}. \x \ X. norm (f t x) \ M + L * norm x" assumes "is_interval T" "X = UNIV" shows "existence_ivl t0 x0 = T" proof - from assms have XI: "x \ X" for x by auto { fix tm tM assume tm: "tm \ T" and tM: "tM \ T" and tmtM: "tm \ t0" "t0 \ tM" from bnd[OF tm tM] obtain M' L' where bnd': "\x t. x \ X \ tm \ t \ t \ tM \ norm (f t x) \ M' + L' * norm x" by force define M where "M \ norm M' + 1" define L where "L \ norm L' + 1" have bnd: "\x t. x \ X \ tm \ t \ t \ tM \ norm (f t x) \ M + L * norm x" by (auto simp: M_def L_def intro!: bnd'[THEN order_trans] add_mono mult_mono) have "M > 0" "L > 0" by (auto simp: L_def M_def) let ?r = "(norm x0 + \tm - tM\ * M + 1) * exp (L * \tm - tM\)" define K where "K \ cball (0::'a) ?r" have K: "compact K" "K \ X" by (auto simp: K_def \X = UNIV\) { fix t assume t: "t \ existence_ivl t0 x0" and le: "tm \ t" "t \ tM" { fix s assume sc: "s \ closed_segment t0 t" then have s: "s \ existence_ivl t0 x0" and le: "tm \ s" "s \ tM" using t le sc using closed_segment_subset_existence_ivl apply - subgoal by force subgoal by (metis (full_types) atLeastAtMost_iff closed_segment_eq_real_ivl order_trans tmtM(1)) subgoal by (metis (full_types) atLeastAtMost_iff closed_segment_eq_real_ivl order_trans tmtM(2)) done from sc have nle: "norm (t0 - s) \ norm (t0 - t)" by (auto simp: closed_segment_eq_real_ivl split: if_split_asm) from flow_fixed_point[OF s] have "norm (flow t0 x0 s) \ norm x0 + integral (closed_segment t0 s) (\t. M + L * norm (flow t0 x0 t))" using tmtM using closed_segment_subset_existence_ivl[OF s] le by (auto simp: intro!: norm_triangle_le norm_triangle_ineq4[THEN order.trans] ivl_integral_norm_bound_integral bnd integrable_continuous_closed_segment integrable_continuous_real continuous_intros continuous_on_subset[OF flow_continuous_on] flow_in_domain mem_existence_ivl_subset) (auto simp: closed_segment_eq_real_ivl split: if_splits) also have "\ = norm x0 + norm (t0 - s) * M + L * integral (closed_segment t0 s) (\t. norm (flow t0 x0 t))" by (simp add: integral_add integrable_on_simps \s \ existence_ivl _ _\ integral_const_closed_segment abs_minus_commute) also have "norm (t0 - s) * M \ norm (t0 - t) * M " using nle \M > 0\ by auto also have "\ \ \ + 1" by simp finally have "norm (flow t0 x0 s) \ norm x0 + norm (t0 - t) * M + 1 + L * integral (closed_segment t0 s) (\t. norm (flow t0 x0 t))" by simp } then have "norm (flow t0 x0 t) \ (norm x0 + norm (t0 - t) * M + 1) * exp (L * \t - t0\)" using closed_segment_subset_existence_ivl[OF t] by (intro gronwall_more_general_segment[where a=t0 and b = t and t = t]) (auto simp: \0 < L\ \0 < M\ less_imp_le intro!: add_nonneg_pos mult_nonneg_nonneg add_nonneg_nonneg continuous_intros flow_continuous_on_intro) also have "\ \ ?r" using le tmtM by (auto simp: less_imp_le \0 < M\ \0 < L\ abs_minus_commute intro!: mult_mono) finally have "flow t0 x0 t \ K" by (simp add: dist_norm K_def) } note flow_compact = this have "{tm..tM} \ existence_ivl t0 x0" using tmtM tm \x0 \ X\ \compact K\ \K \ X\ mem_is_intervalI[OF \is_interval T\ \tm \ T\ \tM \ T\] by (intro subset_mem_compact_implies_subset_existence_interval[OF _ _ _ _flow_compact]) (auto simp: tmtM is_interval_cc) } note bnds = this show "existence_ivl t0 x0 = T" proof safe fix x assume x: "x \ T" from bnds[OF x iv_defined(1)] bnds[OF iv_defined(1) x] show "x \ existence_ivl t0 x0" by (cases "x \ t0") auto qed (insert existence_ivl_subset, fastforce) qed lemma flow_unique: assumes "t \ existence_ivl t0 x0" assumes "phi t0 = x0" assumes "\t. t \ existence_ivl t0 x0 \ (phi has_vector_derivative f t (phi t)) (at t)" assumes "\t. t \ existence_ivl t0 x0 \ phi t \ X" shows "flow t0 x0 t = phi t" apply (rule maximal_existence_flow[where K="existence_ivl t0 x0"]) subgoal by (auto intro!: solves_odeI simp: has_vderiv_on_def assms at_within_open[OF _ open_existence_ivl]) subgoal by fact subgoal by simp subgoal using mem_existence_ivl_iv_defined[OF \t \ existence_ivl t0 x0\] by simp subgoal by (simp add: existence_ivl_subset) subgoal by fact done lemma flow_unique_on: assumes "t \ existence_ivl t0 x0" assumes "phi t0 = x0" assumes "(phi has_vderiv_on (\t. f t (phi t))) (existence_ivl t0 x0)" assumes "\t. t \ existence_ivl t0 x0 \ phi t \ X" shows "flow t0 x0 t = phi t" using flow_unique[where phi=phi, OF assms(1,2) _ assms(4)] assms(3) by (auto simp: has_vderiv_on_open) end \ \@{thm local_lipschitz}\ locale two_ll_on_open = F: ll_on_open T1 F X + G: ll_on_open T2 G X for F T1 G T2 X J x0 + fixes e::real and K assumes t0_in_J: "0 \ J" assumes J_subset: "J \ F.existence_ivl 0 x0" assumes J_ivl: "is_interval J" assumes F_lipschitz: "\t. t \ J \ K-lipschitz_on X (F t)" assumes K_pos: "0 < K" assumes F_G_norm_ineq: "\t x. t \ J \ x \ X \ norm (F t x - G t x) < e" begin context begin lemma F_iv_defined: "0 \ T1" "x0 \ X" subgoal using F.existence_ivl_initial_time_iff J_subset t0_in_J by blast subgoal using F.mem_existence_ivl_iv_defined(2) J_subset t0_in_J by blast done lemma e_pos: "0 < e" using le_less_trans[OF norm_ge_zero F_G_norm_ineq[OF t0_in_J F_iv_defined(2)]] by assumption qualified definition "flow0 t = F.flow 0 x0 t" qualified definition "Y t = G.flow 0 x0 t" lemma norm_X_Y_bound: shows "\t \ J \ G.existence_ivl 0 x0. norm (flow0 t - Y t) \ e / K * (exp(K * \t\) - 1)" proof(safe) fix t assume "t \ J" assume tG: "t \ G.existence_ivl 0 x0" have "0 \ J" by (simp add: t0_in_J) let ?u="\t. norm (flow0 t - Y t)" show "norm (flow0 t - Y t) \ e / K * (exp (K * \t\) - 1)" proof(cases "0 \ t") assume "0 \ t" hence [simp]: "\t\ = t" by simp have t0_t_in_J: "{0..t} \ J" using \t \ J\ \0 \ J\ J_ivl using mem_is_interval_1_I atLeastAtMost_iff subsetI by blast note F_G_flow_cont[continuous_intros] = continuous_on_subset[OF F.flow_continuous_on] continuous_on_subset[OF G.flow_continuous_on] have "?u t + e/K \ e/K * exp(K * t)" proof(rule gronwall[where g="\t. ?u t + e/K", OF _ _ _ _ K_pos \0 \ t\ order.refl]) fix s assume "0 \ s" "s \ t" hence "{0..s} \ J" using t0_t_in_J by auto hence t0_s_in_existence: "{0..s} \ F.existence_ivl 0 x0" "{0..s} \ G.existence_ivl 0 x0" using J_subset tG \0 \ s\ \s \ t\ G.ivl_subset_existence_ivl[OF tG] by auto hence s_in_existence: "s \ F.existence_ivl 0 x0" "s \ G.existence_ivl 0 x0" using \0 \ s\ by auto note cont_statements[continuous_intros] = F_iv_defined (* G.iv_defined *) F.flow_in_domain G.flow_in_domain F.mem_existence_ivl_subset G.mem_existence_ivl_subset have [integrable_on_simps]: "continuous_on {0..s} (\s. F s (F.flow 0 x0 s))" "continuous_on {0..s} (\s. G s (G.flow 0 x0 s))" "continuous_on {0..s} (\s. F s (G.flow 0 x0 s))" "continuous_on {0..s} (\s. G s (F.flow 0 x0 s))" using t0_s_in_existence by (auto intro!: continuous_intros integrable_continuous_real) have "flow0 s - Y s = integral {0..s} (\s. F s (flow0 s) - G s (Y s))" using \0 \ s\ by (simp add: flow0_def Y_def Henstock_Kurzweil_Integration.integral_diff integrable_on_simps ivl_integral_def F.flow_fixed_point[OF s_in_existence(1)] G.flow_fixed_point[OF s_in_existence(2)]) also have "... = integral {0..s} (\s. (F s (flow0 s) - F s (Y s)) + (F s (Y s) - G s (Y s)))" by simp also have "... = integral {0..s} (\s. F s (flow0 s) - F s (Y s)) + integral {0..s} (\s. F s (Y s) - G s (Y s))" by (simp add: Henstock_Kurzweil_Integration.integral_diff Henstock_Kurzweil_Integration.integral_add flow0_def Y_def integrable_on_simps) finally have "?u s \ norm (integral {0..s} (\s. F s (flow0 s) - F s (Y s))) + norm (integral {0..s} (\s. F s (Y s) - G s (Y s)))" by (simp add: norm_triangle_ineq) also have "... \ integral {0..s} (\s. norm (F s (flow0 s) - F s (Y s))) + integral {0..s} (\s. norm (F s (Y s) - G s (Y s)))" using t0_s_in_existence by (auto simp add: flow0_def Y_def intro!: add_mono continuous_intros continuous_on_imp_absolutely_integrable_on) also have "... \ integral {0..s} (\s. K * ?u s) + integral {0..s} (\s. e)" proof (rule add_mono[OF integral_le integral_le]) show "norm (F x (flow0 x) - F x (Y x)) \ K * norm (flow0 x - Y x)" if "x \ {0..s}" for x using F_lipschitz[unfolded lipschitz_on_def, THEN conjunct2] that cont_statements(1,2,4) t0_s_in_existence F_iv_defined (* G.iv_defined *) by (metis F_lipschitz flow0_def Y_def \{0..s} \ J\ lipschitz_on_normD F.flow_in_domain G.flow_in_domain subsetCE) show "\x. x \ {0..s} \ norm (F x (Y x) - G x (Y x)) \ e" using F_G_norm_ineq cont_statements(2,3) t0_s_in_existence using Y_def \{0..s} \ J\ cont_statements(5) subset_iff G.flow_in_domain by (metis eucl_less_le_not_le) qed (simp_all add: t0_s_in_existence continuous_intros integrable_on_simps flow0_def Y_def) also have "... = K * integral {0..s} (\s. ?u s + e / K)" using K_pos t0_s_in_existence by (simp_all add: algebra_simps Henstock_Kurzweil_Integration.integral_add flow0_def Y_def continuous_intros continuous_on_imp_absolutely_integrable_on) finally show "?u s + e / K \ e / K + K * integral {0..s} (\s. ?u s + e / K)" by simp next show "continuous_on {0..t} (\t. norm (flow0 t - Y t) + e / K)" using t0_t_in_J J_subset G.ivl_subset_existence_ivl[OF tG] by (auto simp add: flow0_def Y_def intro!: continuous_intros) next fix s assume "0 \ s" "s \ t" show "0 \ norm (flow0 s - Y s) + e / K" using e_pos K_pos by simp next show "0 < e / K" using e_pos K_pos by simp qed thus ?thesis by (simp add: algebra_simps) next assume "\0 \ t" hence "t \ 0" by simp hence [simp]: "\t\ = -t" by simp have t0_t_in_J: "{t..0} \ J" using \t \ J\ \0 \ J\ J_ivl \\ 0 \ t\ atMostAtLeast_subset_convex is_interval_convex_1 by auto note F_G_flow_cont[continuous_intros] = continuous_on_subset[OF F.flow_continuous_on] continuous_on_subset[OF G.flow_continuous_on] have "?u t + e/K \ e/K * exp(- K * t)" proof(rule gronwall_left[where g="\t. ?u t + e/K", OF _ _ _ _ K_pos order.refl \t \ 0\]) fix s assume "t \ s" "s \ 0" hence "{s..0} \ J" using t0_t_in_J by auto hence t0_s_in_existence: "{s..0} \ F.existence_ivl 0 x0" "{s..0} \ G.existence_ivl 0 x0" using J_subset G.ivl_subset_existence_ivl'[OF tG] \s \ 0\ \t \ s\ by auto hence s_in_existence: "s \ F.existence_ivl 0 x0" "s \ G.existence_ivl 0 x0" using \s \ 0\ by auto note cont_statements[continuous_intros] = F_iv_defined F.flow_in_domain G.flow_in_domain F.mem_existence_ivl_subset G.mem_existence_ivl_subset then have [continuous_intros]: "{s..0} \ T1" "{s..0} \ T2" "F.flow 0 x0 ` {s..0} \ X" "G.flow 0 x0 ` {s..0} \ X" "s \ x \ x \ 0 \ x \ F.existence_ivl 0 x0" "s \ x \ x \ 0 \ x \ G.existence_ivl 0 x0" for x using t0_s_in_existence by auto have "flow0 s - Y s = - integral {s..0} (\s. F s (flow0 s) - G s (Y s))" using t0_s_in_existence \s \ 0\ by (simp add: flow0_def Y_def ivl_integral_def F.flow_fixed_point[OF s_in_existence(1)] G.flow_fixed_point[OF s_in_existence(2)] continuous_intros integrable_on_simps Henstock_Kurzweil_Integration.integral_diff) also have "... = - integral {s..0} (\s. (F s (flow0 s) - F s (Y s)) + (F s (Y s) - G s (Y s)))" by simp also have "... = - (integral {s..0} (\s. F s (flow0 s) - F s (Y s)) + integral {s..0} (\s. F s (Y s) - G s (Y s)))" using t0_s_in_existence by (subst Henstock_Kurzweil_Integration.integral_add) (simp_all add: integral_add flow0_def Y_def continuous_intros integrable_on_simps) finally have "?u s \ norm (integral {s..0} (\s. F s (flow0 s) - F s (Y s))) + norm (integral {s..0} (\s. F s (Y s) - G s (Y s)))" by (metis (no_types, lifting) norm_minus_cancel norm_triangle_ineq) also have "... \ integral {s..0} (\s. norm (F s (flow0 s) - F s (Y s))) + integral {s..0} (\s. norm (F s (Y s) - G s (Y s)))" using t0_s_in_existence by (auto simp add: flow0_def Y_def intro!: continuous_intros continuous_on_imp_absolutely_integrable_on add_mono) also have "... \ integral {s..0} (\s. K * ?u s) + integral {s..0} (\s. e)" proof (rule add_mono[OF integral_le integral_le]) show "norm (F x (flow0 x) - F x (Y x)) \ K * norm (flow0 x - Y x)" if "x\{s..0}" for x using F_lipschitz[unfolded lipschitz_on_def, THEN conjunct2] cont_statements(1,2,4) that t0_s_in_existence F_iv_defined (* G.iv_defined *) by (metis F_lipschitz flow0_def Y_def \{s..0} \ J\ lipschitz_on_normD F.flow_in_domain G.flow_in_domain subsetCE) show "\x. x \ {s..0} \ norm (F x (Y x) - G x (Y x)) \ e" using F_G_norm_ineq Y_def \{s..0} \ J\ cont_statements(5) subset_iff t0_s_in_existence(2) using Y_def \{s..0} \ J\ cont_statements(5) subset_iff G.flow_in_domain by (metis eucl_less_le_not_le) qed (simp_all add: t0_s_in_existence continuous_intros integrable_on_simps flow0_def Y_def) also have "... = K * integral {s..0} (\s. ?u s + e / K)" using K_pos t0_s_in_existence by (simp_all add: algebra_simps Henstock_Kurzweil_Integration.integral_add t0_s_in_existence continuous_intros integrable_on_simps flow0_def Y_def) finally show "?u s + e / K \ e / K + K * integral {s..0} (\s. ?u s + e / K)" by simp next show "continuous_on {t..0} (\t. norm (flow0 t - Y t) + e / K)" using t0_t_in_J J_subset G.ivl_subset_existence_ivl'[OF tG] F_iv_defined by (auto simp add: flow0_def Y_def intro!: continuous_intros) next fix s assume "t \ s" "s \ 0" show "0 \ norm (flow0 s - Y s) + e / K" using e_pos K_pos by simp next show "0 < e / K" using e_pos K_pos by simp qed thus ?thesis by (simp add: algebra_simps) qed qed end end locale auto_ll_on_open = fixes f::"'a::{banach, heine_borel} \ 'a" and X assumes auto_local_lipschitz: "local_lipschitz UNIV X (\_::real. f)" assumes auto_open_domain[intro!, simp]: "open X" begin text \autonomous flow and existence interval \ definition "flow0 x0 t = ll_on_open.flow UNIV (\_. f) X 0 x0 t" definition "existence_ivl0 x0 = ll_on_open.existence_ivl UNIV (\_. f) X 0 x0" sublocale ll_on_open_it UNIV "\_. f" X 0 rewrites "flow = (\t0 x0 t. flow0 x0 (t - t0))" and "existence_ivl = (\t0 x0. (+) t0 ` existence_ivl0 x0)" and "(+) 0 = (\x::real. x)" and "s - 0 = s" and "(\x. x) ` S = S" and "s \ (+) t ` S \ s - t \ (S::real set)" and "P (s + t - s) = P (t::real)"\ \TODO: why does just the equation not work?\ and "P (t + s - s) = P t"\ \TODO: why does just the equation not work?\ proof - interpret ll_on_open UNIV "\_. f" X by unfold_locales (auto intro!: continuous_on_const auto_local_lipschitz) show "ll_on_open_it UNIV (\_. f) X" .. show "(+) 0 = (\x::real. x)" "(\x. x) ` S = S" "s - 0 = s" "P (t + s - s) = P t" "P (s + t - s) = P (t::real)" by auto show "flow = (\t0 x0 t. flow0 x0 (t - t0))" unfolding flow0_def apply (rule ext) apply (rule ext) apply (rule flow_eq_in_existence_ivlI) apply (auto intro: flow_shift_autonomous1 mem_existence_ivl_shift_autonomous1 mem_existence_ivl_shift_autonomous2) done show "existence_ivl = (\t0 x0. (+) t0 ` existence_ivl0 x0)" unfolding existence_ivl0_def apply (safe intro!: ext) subgoal using image_iff mem_existence_ivl_shift_autonomous1 by fastforce subgoal premises prems for t0 x0 x s proof - have f2: "\x1 x2. (x2::real) - x1 = - 1 * x1 + x2" by auto have "- 1 * t0 + (t0 + s) = s" by auto then show ?thesis using f2 prems mem_existence_ivl_iv_defined(2) mem_existence_ivl_shift_autonomous2 by presburger qed done show "(s \ (+) t ` S) = (s - t \ S)" by force qed \ \at this point, there should be no theorems about \existence_ivl\, only \existence_ivl0\. Moreover, \(+) _ ` _\ and \_ + _ - _\ etc should have been removed\ lemma existence_ivl_zero: "x0 \ X \ 0 \ existence_ivl0 x0" by simp lemmas [continuous_intros del] = continuous_on_f lemmas continuous_on_f_comp[continuous_intros] = continuous_on_f[OF continuous_on_const _ subset_UNIV] lemma flow_in_compact_right_existence: assumes "\t. 0 \ t \ t \ existence_ivl0 x \ flow0 x t \ K" assumes "compact K" "K \ X" assumes "x \ X" "t \ 0" shows "t \ existence_ivl0 x" proof (rule ccontr) assume "t \ existence_ivl0 x" have "bdd_above (existence_ivl0 x)" by (rule bdd_above_is_intervalI[OF is_interval_existence_ivl \0 \ t\ existence_ivl_zero]) fact+ from sup_existence_maximal[OF UNIV_I \x \ X\ assms(1-3) this] show False by auto qed lemma flow_in_compact_left_existence: assumes "\t. t \ 0 \ t \ existence_ivl0 x \ flow0 x t \ K" assumes "compact K" "K \ X" assumes "x \ X" "t \ 0" shows "t \ existence_ivl0 x" proof (rule ccontr) assume "t \ existence_ivl0 x" have "bdd_below (existence_ivl0 x)" by (rule bdd_below_is_intervalI[OF is_interval_existence_ivl \t \ 0\ _ existence_ivl_zero]) fact+ from inf_existence_minimal[OF UNIV_I \x \ X\ assms(1-3) this] show False by auto qed end locale compact_continuously_diff = derivative_on_prod T X f "\(t, x). f' x o\<^sub>L snd_blinfun" for T X and f::"real \ 'a::{banach,perfect_space,heine_borel} \ 'a" and f'::"'a \ ('a, 'a) blinfun" + assumes compact_domain: "compact X" assumes convex: "convex X" assumes nonempty_domains: "T \ {}" "X \ {}" assumes continuous_derivative: "continuous_on X f'" begin lemma ex_onorm_bound: "\B. \x \ X. norm (f' x) \ B" proof - from _ compact_domain have "compact (f' ` X)" by (intro compact_continuous_image continuous_derivative) hence "bounded (f' ` X)" by (rule compact_imp_bounded) thus ?thesis by (auto simp add: bounded_iff cball_def norm_blinfun.rep_eq) qed definition "onorm_bound = (SOME B. \x \ X. norm (f' x) \ B)" lemma onorm_bound: assumes "x \ X" shows "norm (f' x) \ onorm_bound" unfolding onorm_bound_def using someI_ex[OF ex_onorm_bound] assms by blast sublocale closed_domain X using compact_domain by unfold_locales (rule compact_imp_closed) sublocale global_lipschitz T X f onorm_bound proof (unfold_locales, rule lipschitz_onI) fix t z y assume "t \ T" "y \ X" "z \ X" then have "norm (f t y - f t z) \ onorm_bound * norm (y - z)" using onorm_bound by (intro differentiable_bound[where f'=f', OF convex]) (auto intro!: derivative_eq_intros simp: norm_blinfun.rep_eq) thus "dist (f t y) (f t z) \ onorm_bound * dist y z" by (auto simp: dist_norm norm_Pair) next from nonempty_domains obtain x where x: "x \ X" by auto show "0 \ onorm_bound" using dual_order.trans local.onorm_bound norm_ge_zero x by blast qed end \ \@{thm compact_domain}\ locale unique_on_compact_continuously_diff = self_mapping + compact_interval T + compact_continuously_diff T X f begin sublocale unique_on_closed t0 T x0 f X onorm_bound by unfold_locales (auto intro!: f' has_derivative_continuous_on) end locale c1_on_open = fixes f::"'a::{banach, perfect_space, heine_borel} \ 'a" and f' X assumes open_dom[simp]: "open X" assumes derivative_rhs: "\x. x \ X \ (f has_derivative blinfun_apply (f' x)) (at x)" assumes continuous_derivative: "continuous_on X f'" begin lemmas continuous_derivative_comp[continuous_intros] = continuous_on_compose2[OF continuous_derivative] lemma derivative_tendsto[tendsto_intros]: assumes [tendsto_intros]: "(g \ l) F" and "l \ X" shows "((\x. f' (g x)) \ f' l) F" using continuous_derivative[simplified continuous_on] assms by (auto simp: at_within_open[OF _ open_dom] intro!: tendsto_eq_intros intro: tendsto_compose) lemma c1_on_open_rev[intro, simp]: "c1_on_open (-f) (-f') X" using derivative_rhs continuous_derivative by unfold_locales (auto intro!: continuous_intros derivative_eq_intros simp: fun_Compl_def blinfun.bilinear_simps) lemma derivative_rhs_compose[derivative_intros]: "((g has_derivative g') (at x within s)) \ g x \ X \ ((\x. f (g x)) has_derivative (\xa. blinfun_apply (f' (g x)) (g' xa))) (at x within s)" by (metis has_derivative_compose[of g g' x s f "f' (g x)"] derivative_rhs) sublocale auto_ll_on_open proof (standard, rule local_lipschitzI) fix x and t::real assume "x \ X" with open_contains_cball[of "UNIV::real set"] open_UNIV open_contains_cball[of X] open_dom obtain u v where uv: "cball t u \ UNIV" "cball x v \ X" "u > 0" "v > 0" by blast let ?T = "cball t u" and ?X = "cball x v" have "bounded ?X" by simp have "compact (cball x v)" by simp interpret compact_continuously_diff ?T ?X "\_. f" f' using uv by unfold_locales (auto simp: convex_cball cball_eq_empty split_beta' intro!: derivative_eq_intros continuous_on_compose2[OF continuous_derivative] continuous_intros) have "onorm_bound-lipschitz_on ?X f" using lipschitz[of t] uv by auto thus "\u>0. \L. \t \ cball t u \ UNIV. L-lipschitz_on (cball x u \ X) f" by (intro exI[where x=v]) (auto intro!: exI[where x=onorm_bound] \0 < v\ simp: Int_absorb2 uv) qed (auto intro!: continuous_intros) end \ \@{thm derivative_rhs}\ locale c1_on_open_euclidean = c1_on_open f f' X for f::"'a::euclidean_space \ _" and f' X begin lemma c1_on_open_euclidean_anchor: True .. definition "vareq x0 t = f' (flow0 x0 t)" interpretation var: ll_on_open "existence_ivl0 x0" "vareq x0" UNIV apply standard apply (auto intro!: c1_implies_local_lipschitz[where f' = "\(t, x). vareq x0 t"] continuous_intros derivative_eq_intros simp: split_beta' blinfun.bilinear_simps vareq_def) using local.mem_existence_ivl_iv_defined(2) apply blast using local.existence_ivl_reverse local.mem_existence_ivl_iv_defined(2) apply blast using local.mem_existence_ivl_iv_defined(2) apply blast using local.existence_ivl_reverse local.mem_existence_ivl_iv_defined(2) apply blast done context begin lemma continuous_on_A[continuous_intros]: assumes "continuous_on S a" assumes "continuous_on S b" assumes "\s. s \ S \ a s \ X" assumes "\s. s \ S \ b s \ existence_ivl0 (a s)" shows "continuous_on S (\s. vareq (a s) (b s))" proof - have "continuous_on S (\x. f' (flow0 (a x) (b x)))" by (auto intro!: continuous_intros assms flow_in_domain) then show ?thesis by (rule continuous_on_eq) (auto simp: assms vareq_def) qed lemmas [intro] = mem_existence_ivl_iv_defined context fixes x0::'a begin lemma flow0_defined: "xa \ existence_ivl0 x0 \ flow0 x0 xa \ X" by (auto simp: flow_in_domain) lemma continuous_on_flow0: "continuous_on (existence_ivl0 x0) (flow0 x0)" by (auto simp: intro!: continuous_intros) lemmas continuous_on_flow0_comp[continuous_intros] = continuous_on_compose2[OF continuous_on_flow0] lemma varexivl_eq_exivl: assumes "t \ existence_ivl0 x0" shows "var.existence_ivl x0 t a = existence_ivl0 x0" proof (rule var.existence_ivl_eq_domain) fix s t x assume s: "s \ existence_ivl0 x0" and t: "t \ existence_ivl0 x0" then have "{s .. t} \ existence_ivl0 x0" by (metis atLeastatMost_empty_iff2 empty_subsetI real_Icc_closed_segment var.closed_segment_subset_domain) then have "continuous_on {s .. t} (vareq x0)" by (auto simp: closed_segment_eq_real_ivl intro!: continuous_intros flow0_defined) then have "compact ((vareq x0) ` {s .. t})" using compact_Icc by (rule compact_continuous_image) then obtain B where B: "\u. u \ {s .. t} \ norm (vareq x0 u) \ B" by (force dest!: compact_imp_bounded simp: bounded_iff) show "\M L. \t\{s..t}. \x\UNIV. norm (blinfun_apply (vareq x0 t) x) \ M + L * norm x" by (rule exI[where x=0], rule exI[where x=B]) (auto intro!: order_trans[OF norm_blinfun] mult_right_mono B simp:) qed (auto intro: assms) definition "vector_Dflow u0 t \ var.flow x0 0 u0 t" qualified abbreviation "Y z t \ flow0 (x0 + z) t" text \Linearity of the solution to the variational equation. TODO: generalize this and some other things for arbitrary linear ODEs\ lemma vector_Dflow_linear: assumes "t \ existence_ivl0 x0" shows "vector_Dflow (\ *\<^sub>R a + \ *\<^sub>R b) t = \ *\<^sub>R vector_Dflow a t + \ *\<^sub>R vector_Dflow b t" proof - note mem_existence_ivl_iv_defined[OF assms, intro, simp] have "((\c. \ *\<^sub>R var.flow x0 0 a c + \ *\<^sub>R var.flow x0 0 b c) solves_ode (\x. vareq x0 x)) (existence_ivl0 x0) UNIV" by (auto intro!: derivative_intros var.flow_has_vector_derivative solves_odeI simp: blinfun.bilinear_simps varexivl_eq_exivl vareq_def[symmetric]) moreover have "\ *\<^sub>R var.flow x0 0 a 0 + \ *\<^sub>R var.flow x0 0 b 0 = \ *\<^sub>R a + \ *\<^sub>R b" by simp moreover note is_interval_existence_ivl[of x0] ultimately show ?thesis unfolding vareq_def[symmetric] vector_Dflow_def by (rule var.maximal_existence_flow) (auto simp: assms) qed lemma linear_vector_Dflow: assumes "t \ existence_ivl0 x0" shows "linear (\z. vector_Dflow z t)" using vector_Dflow_linear[OF assms, of 1 _ 1] vector_Dflow_linear[OF assms, of _ _ 0] by (auto intro!: linearI) lemma bounded_linear_vector_Dflow: assumes "t \ existence_ivl0 x0" shows "bounded_linear (\z. vector_Dflow z t)" by (simp add: linear_linear linear_vector_Dflow assms) lemma vector_Dflow_continuous_on_time: "x0 \ X \ continuous_on (existence_ivl0 x0) (\t. vector_Dflow z t)" using var.flow_continuous_on[of x0 0 z] varexivl_eq_exivl unfolding vector_Dflow_def by (auto simp: ) proposition proposition_17_6_weak: \ \from "Differential Equations, Dynamical Systems, and an Introduction to Chaos", Hirsch/Smale/Devaney\ assumes "t \ existence_ivl0 x0" shows "(\y. (Y (y - x0) t - flow0 x0 t - vector_Dflow (y - x0) t) /\<^sub>R norm (y - x0)) \ x0 \ 0" proof- note x0_def = mem_existence_ivl_iv_defined[OF assms] have "0 \ existence_ivl0 x0" by (simp add: x0_def) text \Find some \J \ existence_ivl0 x0\ with \0 \ J\ and \t \ J\.\ define t0 where "t0 \ min 0 t" define t1 where "t1 \ max 0 t" define J where "J \ {t0..t1}" have "t0 \ 0" "0 \ t1" "0 \ J" "J \ {}" "t \ J" "compact J" and J_in_existence: "J \ existence_ivl0 x0" using ivl_subset_existence_ivl ivl_subset_existence_ivl' x0_def assms by (auto simp add: J_def t0_def t1_def min_def max_def) { fix z S assume assms: "x0 + z \ X" "S \ existence_ivl0 (x0 + z)" have "continuous_on S (Y z)" using flow_continuous_on assms(1) by (intro continuous_on_subset[OF _ assms(2)]) (simp add:) } note [continuous_intros] = this integrable_continuous_real blinfun.continuous_on have U_continuous[continuous_intros]: "\z. continuous_on J (vector_Dflow z)" by(rule continuous_on_subset[OF vector_Dflow_continuous_on_time[OF \x0 \ X\] J_in_existence]) from \t \ J\ have "t0 \ t" and "t \ t1" and "t0 \ t1" and "t0 \ existence_ivl0 x0" and "t \ existence_ivl0 x0" and "t1 \ existence_ivl0 x0" using J_def J_in_existence by auto from global_existence_ivl_explicit[OF \t0 \ existence_ivl0 x0\ \t1 \ existence_ivl0 x0\ \t0 \ t1\] obtain u K where uK_def: "0 < u" "0 < K" "ball x0 u \ X" "\y. y \ ball x0 u \ t0 \ existence_ivl0 y" "\y. y \ ball x0 u \ t1 \ existence_ivl0 y" "\t y. y \ ball x0 u \ t \ J \ dist (flow0 x0 t) (Y (y - x0) t) \ dist x0 y * exp (K * \t\)" by (auto simp add: J_def) have J_in_existence_ivl: "\y. y \ ball x0 u \ J \ existence_ivl0 y" unfolding J_def using uK_def by (simp add: real_Icc_closed_segment segment_subset_existence_ivl t0_def t1_def) have ball_in_X: "\z. z \ ball 0 u \ x0 + z \ X" using uK_def(3) by (auto simp: dist_norm) have flow0_J_props: "flow0 x0 ` J \ {}" "compact (flow0 x0 ` J)" "flow0 x0` J \ X" using \t0 \ t1\ using J_def(1) J_in_existence by (auto simp add: J_def intro!: compact_continuous_image continuous_intros flow_in_domain) have [continuous_intros]: "continuous_on J (\s. f' (flow0 x0 s))" using J_in_existence by (auto intro!: continuous_intros flow_in_domain simp:) text \ Show the thesis via cases \t = 0\, \0 < t\ and \t < 0\. \ show ?thesis proof(cases "t = 0") assume "t = 0" show ?thesis unfolding \t = 0\ Lim_at proof(simp add: dist_norm[of _ 0] del: zero_less_dist_iff, safe, rule exI, rule conjI[OF \0 < u\], safe) - fix e::real and x assume "0 < e" "0 < dist x x0" "dist x x0 < u" + fix e::real and x assume "0 < e" "dist x x0 < u" hence "x \ X" using uK_def(3) by (auto simp: dist_commute) hence "inverse (norm (x - x0)) * norm (Y (x - x0) 0 - flow0 x0 0 - vector_Dflow (x - x0) 0) = 0" using x0_def by (simp add: vector_Dflow_def) thus "inverse (norm (x - x0)) * norm (flow0 x 0 - flow0 x0 0 - vector_Dflow (x - x0) 0) < e" using \0 < e\ by auto qed next assume "t \ 0" show ?thesis proof(unfold Lim_at, safe) fix e::real assume "0 < e" then obtain e' where "0 < e'" "e' < e" using dense by auto obtain N where N_ge_SupS: "Sup { norm (f' (flow0 x0 s)) |s. s \ J } \ N" (is "Sup ?S \ N") and N_gr_0: "0 < N" \ \We need N to be an upper bound of @{term ?S}, but also larger than zero.\ by (meson le_cases less_le_trans linordered_field_no_ub) have N_ineq: "\s. s \ J \ norm (f' (flow0 x0 s)) \ N" proof- fix s assume "s \ J" have "?S = (norm o f' o flow0 x0) ` J" by auto moreover have "continuous_on J (norm o f' o flow0 x0)" using J_in_existence by (auto intro!: continuous_intros) ultimately have "\a b. ?S = {a..b} \ a \ b" using continuous_image_closed_interval[OF \t0 \ t1\] by (simp add: J_def) then obtain a b where "?S = {a..b}" and "a \ b" by auto hence "bdd_above ?S" by simp from \s \ J\ cSup_upper[OF _ this] have "norm (f' (flow0 x0 s)) \ Sup ?S" by auto thus "norm (f' (flow0 x0 s)) \ N" using N_ge_SupS by simp qed text \ Define a small region around \flow0 ` J\, that is a subset of the domain \X\. \ from compact_in_open_separated[OF flow0_J_props(1,2) auto_open_domain flow0_J_props(3)] obtain e_domain where e_domain_def: "0 < e_domain" "{x. infdist x (flow0 x0 ` J) \ e_domain} \ X" by auto define G where "G \ {x\X. infdist x (flow0 x0 ` J) < e_domain}" have G_vimage: "G = ((\x. infdist x (flow0 x0 ` J)) -` {.. X" by (auto simp: G_def) have "open G" "G \ X" unfolding G_vimage by (auto intro!: open_Int open_vimage continuous_intros continuous_at_imp_continuous_on) text \Define a compact subset H of G. Inside H, we can guarantee an upper bound on the Taylor remainder.\ define e_domain2 where "e_domain2 \ e_domain / 2" have "e_domain2 > 0" "e_domain2 < e_domain" using \e_domain > 0\ by (simp_all add: e_domain2_def) define H where "H \ {x. infdist x (flow0 x0 ` J) \ e_domain2}" have H_props: "H \ {}" "compact H" "H \ G" proof- have "x0 \ flow0 x0 ` J" unfolding image_iff using \0 \ J\ x0_def by force hence "x0 \ H" using \0 < e_domain2\ by (simp add: H_def x0_def) thus "H \ {}" by auto next show "compact H" unfolding H_def using \0 < e_domain2\ flow0_J_props by (intro compact_infdist_le) simp_all next show "H \ G" proof fix x assume "x \ H" then have *: "infdist x (flow0 x0 ` J) < e_domain" using \0 < e_domain\ by (simp add: H_def e_domain2_def) then have "x \ X" using e_domain_def(2) by auto with * show "x \ G" unfolding G_def by auto qed qed have f'_cont_on_G: "(\x. x \ G \ isCont f' x)" using continuous_on_interior[OF continuous_on_subset[OF continuous_derivative \G \ X\]] by (simp add: interior_open[OF \open G\]) define e1 where "e1 \ e' / (\t\ * exp (K * \t\) * exp (N * \t\))" \ \@{term e1} is the bounding term for the Taylor remainder.\ have "0 < \t\" using \t \ 0\ by simp hence "0 < e1" using \0 < e'\ by (simp add: e1_def) text \ Taylor expansion of f on set G. \ from uniform_explicit_remainder_Taylor_1[where f=f and f'=f', OF derivative_rhs[OF subsetD[OF \G \ X\]] f'_cont_on_G \open G\ H_props \0 < e1\] obtain d_Taylor R where Taylor_expansion: "0 < d_Taylor" "\x z. f z = f x + (f' x) (z - x) + R x z" "\x y. x \ H \ y \ H \ dist x y < d_Taylor \ norm (R x y) \ e1 * dist x y" "continuous_on (G \ G) (\(a, b). R a b)" by auto text \ Find d, such that solutions are always at least \min (e_domain/2) d_Taylor\ apart, i.e. always in H. This later gives us the bound on the remainder. \ have "0 < min (e_domain/2) d_Taylor" using \0 < d_Taylor\ \0 < e_domain\ by auto from uniform_limit_flow[OF \t0 \ existence_ivl0 x0\ \t1 \ existence_ivl0 x0\ \t0 \ t1\, THEN uniform_limitD, OF this, unfolded eventually_at] obtain d_ivl where d_ivl_def: "0 < d_ivl" "\x. 0 < dist x x0 \ dist x x0 < d_ivl \ (\t\J. dist (flow0 x0 t) (Y (x - x0) t) < min (e_domain / 2) d_Taylor)" by (auto simp: dist_commute J_def) define d where "d \ min u d_ivl" have "0 < d" using \0 < u\ \0 < d_ivl\ by (simp add: d_def) hence "d \ u" "d \ d_ivl" by (auto simp: d_def) text \ Therefore, any flow0 starting in \ball x0 d\ will be in G. \ have Y_in_G: "\y. y \ ball x0 d \ (\s. Y (y - x0) s) ` J \ G" proof fix x y assume assms: "y \ ball x0 d" "x \ (\s. Y (y - x0) s) ` J" show "x \ G" proof(cases) assume "y = x0" from assms(2) have "x \ flow0 x0 ` J" by (simp add: \y = x0\) thus "x \ G" using \0 < e_domain\ \flow0 x0 ` J \ X\ by (auto simp: G_def) next assume "y \ x0" hence "0 < dist y x0" by (simp add: dist_norm) from d_ivl_def(2)[OF this] \d \ d_ivl\ \0 < e_domain\ assms(1) have dist_flow0_Y: "\t. t \ J \ dist (flow0 x0 t) (Y (y - x0) t) < e_domain" by (auto simp: dist_commute) from assms(2) obtain t where t_def: "t \ J" "x = Y (y - x0) t" by auto have "x \ X" unfolding t_def(2) using uK_def(3) assms(1) \d \ u\ subsetD[OF J_in_existence_ivl t_def(1)] by (auto simp: intro!: flow_in_domain) have "flow0 x0 t \ flow0 x0 ` J" using t_def by auto from dist_flow0_Y[OF t_def(1)] have "dist x (flow0 x0 t) < e_domain" by (simp add: t_def(2) dist_commute) from le_less_trans[OF infdist_le[OF \flow0 x0 t \ flow0 x0 ` J\] this] \x \ X\ show "x \ G" by (auto simp: G_def) qed qed from this[of x0] \0 < d\ have X_in_G: "flow0 x0 ` J \ G" by simp show "\d>0. \x. 0 < dist x x0 \ dist x x0 < d \ dist ((Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) /\<^sub>R norm (x - x0)) 0 < e" proof(rule exI, rule conjI[OF \0 < d\], safe, unfold norm_conv_dist[symmetric]) fix x assume x_x0_dist: "0 < dist x x0" "dist x x0 < d" hence x_in_ball': "x \ ball x0 d" by (simp add: dist_commute) hence x_in_ball: "x \ ball x0 u" using \d \ u\ by simp text \ First, some prerequisites. \ from x_in_ball have z_in_ball: "x - x0 \ ball 0 u" using \0 < u\ by (simp add: dist_norm) hence [continuous_intros]: "dist x0 x < u" by (auto simp: dist_norm) from J_in_existence_ivl[OF x_in_ball] have J_in_existence_ivl_x: "J \ existence_ivl0 x" . from ball_in_X[OF z_in_ball] have x_in_X[continuous_intros]: "x \ X" by simp text \ On all of \J\, we can find upper bounds for the distance of \flow0\ and \Y\. \ have dist_flow0_Y: "\s. s \ J \ dist (flow0 x0 s) (Y (x - x0) s) \ dist x0 x * exp (K * \t\)" using t0_def t1_def uK_def(2) by (intro order_trans[OF uK_def(6)[OF x_in_ball] mult_left_mono]) (auto simp add: J_def intro!: mult_mono) from d_ivl_def x_x0_dist \d \ d_ivl\ have dist_flow0_Y2: "\t. t \ J \ dist (flow0 x0 t) (Y (x - x0) t) < min (e_domain2) d_Taylor" by (auto simp: e_domain2_def) let ?g = "\t. norm (Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t)" let ?C = "\t\ * dist x0 x * exp (K * \t\) * e1" text \ Find an upper bound to \?g\, i.e. show that \?g s \ ?C + N * integral {a..b} ?g\ for \{a..b} = {0..s}\ or \{a..b} = {s..0}\ for some \s \ J\. We can then apply Grönwall's inequality to obtain a true bound for \?g\. \ have g_bound: "?g s \ ?C + N * integral {a..b} ?g" if s_def: "s \ {a..b}" and J'_def: "{a..b} \ J" and ab_cases: "(a = 0 \ b = s) \ (a = s \ b = 0)" for s a b proof - from that have "s \ J" by auto have s_in_existence_ivl_x0: "s \ existence_ivl0 x0" using J_in_existence \s \ J\ by auto have s_in_existence_ivl: "\y. y \ ball x0 u \ s \ existence_ivl0 y" using J_in_existence_ivl \s \ J\ by auto have s_in_existence_ivl2: "\z. z \ ball 0 u \ s \ existence_ivl0 (x0 + z)" using s_in_existence_ivl by (simp add: dist_norm) text \Prove continuities beforehand.\ note continuous_on_0_s[continuous_intros] = continuous_on_subset[OF _ \{a..b} \ J\] have[continuous_intros]: "continuous_on J (flow0 x0)" using J_in_existence by (auto intro!: continuous_intros simp:) { fix z S assume assms: "x0 + z \ X" "S \ existence_ivl0 (x0 + z)" have "continuous_on S (\s. f (Y z s))" proof(rule continuous_on_subset[OF _ assms(2)]) show "continuous_on (existence_ivl0 (x0 + z)) (\s. f (Y z s))" using assms by (auto intro!: continuous_intros flow_in_domain flow_continuous_on simp:) qed } note [continuous_intros] = this have [continuous_intros]: "continuous_on J (\s. f (flow0 x0 s))" by(rule continuous_on_subset[OF _ J_in_existence]) (auto intro!: continuous_intros flow_continuous_on flow_in_domain simp: x0_def) have [continuous_intros]: "\z. continuous_on J (\s. f' (flow0 x0 s) (vector_Dflow z s))" proof- fix z have a1: "continuous_on J (flow0 x0)" by (auto intro!: continuous_intros) have a2: "(\s. (flow0 x0 s, vector_Dflow z s)) ` J \ (flow0 x0 ` J) \ ((\s. vector_Dflow z s) ` J)" by auto have a3: "continuous_on ((\s. (flow0 x0 s, vector_Dflow z s)) ` J) (\(x, u). f' x u)" using assms flow0_J_props by (auto intro!: continuous_intros simp: split_beta') from continuous_on_compose[OF continuous_on_Pair[OF a1 U_continuous] a3] show "continuous_on J (\s. f' (flow0 x0 s) (vector_Dflow z s))" by simp qed have [continuous_intros]: "continuous_on J (\s. R (flow0 x0 s) (Y (x - x0) s))" using J_in_existence J_in_existence_ivl[OF x_in_ball] X_in_G \{a..b} \ J\ Y_in_G x_x0_dist by (auto intro!: continuous_intros continuous_on_compose_Pair[OF Taylor_expansion(4)] simp: dist_commute subset_iff) hence [continuous_intros]: "(\s. R (flow0 x0 s) (Y (x - x0) s)) integrable_on J" unfolding J_def by (rule integrable_continuous_real) have i1: "integral {a..b} (\s. f (flow0 x s)) - integral {a..b} (\s. f (flow0 x0 s)) = integral {a..b} (\s. f (flow0 x s) - f (flow0 x0 s))" using J_in_existence_ivl[OF x_in_ball] apply (intro Henstock_Kurzweil_Integration.integral_diff[symmetric]) by (auto intro!: continuous_intros existence_ivl_reverse) have i2: "integral {a..b} (\s. f (flow0 x s) - f (flow0 x0 s) - (f' (flow0 x0 s)) (vector_Dflow (x - x0) s)) = integral {a..b} (\s. f (flow0 x s) - f (flow0 x0 s)) - integral {a..b} (\s. f' (flow0 x0 s) (vector_Dflow (x - x0) s))" using J_in_existence_ivl[OF x_in_ball] by (intro Henstock_Kurzweil_Integration.integral_diff[OF Henstock_Kurzweil_Integration.integrable_diff]) (auto intro!: continuous_intros existence_ivl_reverse) from ab_cases have "?g s = norm (integral {a..b} (\s'. f (Y (x - x0) s')) - integral {a..b} (\s'. f (flow0 x0 s')) - integral {a..b} (\s'. (f' (flow0 x0 s')) (vector_Dflow (x - x0) s')))" proof(safe) assume "a = 0" "b = s" hence "0 \ s" using \s \ {a..b}\ by simp text\ Integral equations for flow0, Y and U. \ have flow0_integral_eq: "flow0 x0 s = x0 + ivl_integral 0 s (\s. f (flow0 x0 s))" by (rule flow_fixed_point[OF s_in_existence_ivl_x0]) have Y_integral_eq: "flow0 x s = x0 + (x - x0) + ivl_integral 0 s (\s. f (Y (x - x0) s))" using flow_fixed_point \0 \ s\ s_in_existence_ivl2[OF z_in_ball] ball_in_X[OF z_in_ball] by (simp add:) have U_integral_eq: "vector_Dflow (x - x0) s = (x - x0) + ivl_integral 0 s (\s. vareq x0 s (vector_Dflow (x - x0) s))" unfolding vector_Dflow_def by (rule var.flow_fixed_point) (auto simp: \0 \ s\ x0_def varexivl_eq_exivl s_in_existence_ivl_x0) show "?g s = norm (integral {0..s} (\s'. f (Y (x - x0) s')) - integral {0..s} (\s'. f (flow0 x0 s')) - integral {0..s} (\s'. blinfun_apply (f' (flow0 x0 s')) (vector_Dflow (x - x0) s')))" using \0 \ s\ unfolding vareq_def[symmetric] by (simp add: flow0_integral_eq Y_integral_eq U_integral_eq ivl_integral_def) next assume "a = s" "b = 0" hence "s \ 0" using \s \ {a..b}\ by simp have flow0_integral_eq_left: "flow0 x0 s = x0 + ivl_integral 0 s (\s. f (flow0 x0 s))" by (rule flow_fixed_point[OF s_in_existence_ivl_x0]) have Y_integral_eq_left: "Y (x - x0) s = x0 + (x - x0) + ivl_integral 0 s (\s. f (Y (x - x0) s))" using flow_fixed_point \s \ 0\ s_in_existence_ivl2[OF z_in_ball] ball_in_X[OF z_in_ball] by simp have U_integral_eq_left: "vector_Dflow (x - x0) s = (x - x0) + ivl_integral 0 s (\s. vareq x0 s (vector_Dflow (x - x0) s))" unfolding vector_Dflow_def by (rule var.flow_fixed_point) (auto simp: \s \ 0\ x0_def varexivl_eq_exivl s_in_existence_ivl_x0) have "?g s = norm (- integral {s..0} (\s'. f (Y (x - x0) s')) + integral {s..0} (\s'. f (flow0 x0 s')) + integral {s..0} (\s'. vareq x0 s' (vector_Dflow (x - x0) s')))" unfolding flow0_integral_eq_left Y_integral_eq_left U_integral_eq_left using \s \ 0\ by (simp add: ivl_integral_def) also have "... = norm (integral {s..0} (\s'. f (Y (x - x0) s')) - integral {s..0} (\s'. f (flow0 x0 s')) - integral {s..0} (\s'. vareq x0 s' (vector_Dflow (x - x0) s')))" by (subst norm_minus_cancel[symmetric], simp) finally show "?g s = norm (integral {s..0} (\s'. f (Y (x - x0) s')) - integral {s..0} (\s'. f (flow0 x0 s')) - integral {s..0} (\s'. blinfun_apply (f' (flow0 x0 s')) (vector_Dflow (x - x0) s')))" unfolding vareq_def . qed also have "... = norm (integral {a..b} (\s. f (Y (x - x0) s) - f (flow0 x0 s) - (f' (flow0 x0 s)) (vector_Dflow (x - x0) s)))" by (simp add: i1 i2) also have "... \ integral {a..b} (\s. norm (f (Y (x - x0) s) - f (flow0 x0 s) - f' (flow0 x0 s) (vector_Dflow (x - x0) s)))" using x_in_X J_in_existence_ivl_x J_in_existence \{a..b} \ J\ by (auto intro!: continuous_intros continuous_on_imp_absolutely_integrable_on existence_ivl_reverse) also have "... = integral {a..b} (\s. norm (f' (flow0 x0 s) (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s) + R (flow0 x0 s) (Y (x - x0) s)))" proof (safe intro!: integral_spike[OF negligible_empty, simplified] arg_cong[where f=norm]) fix s' assume "s' \ {a..b}" show "f' (flow0 x0 s') (Y (x - x0) s' - flow0 x0 s' - vector_Dflow (x - x0) s') + R (flow0 x0 s') (Y (x - x0) s') = f (Y (x - x0) s') - f (flow0 x0 s') - f' (flow0 x0 s') (vector_Dflow (x - x0) s')" by (simp add: blinfun.diff_right Taylor_expansion(2)[of "flow0 x s'" "flow0 x0 s'"]) qed also have "... \ integral {a..b} (\s. norm (f' (flow0 x0 s) (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s)) + norm (R (flow0 x0 s) (Y (x - x0) s)))" using J_in_existence_ivl[OF x_in_ball] norm_triangle_ineq using \continuous_on J (\s. R (flow0 x0 s) (Y (x - x0) s))\ by (auto intro!: continuous_intros integral_le) also have "... = integral {a..b} (\s. norm (f' (flow0 x0 s) (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s))) + integral {a..b} (\s. norm (R (flow0 x0 s) (Y (x - x0) s)))" using J_in_existence_ivl[OF x_in_ball] using \continuous_on J (\s. R (flow0 x0 s) (Y (x - x0) s))\ by (auto intro!: continuous_intros Henstock_Kurzweil_Integration.integral_add) also have "... \ N * integral {a..b} ?g + ?C" (is "?l1 + ?r1 \ _") proof(rule add_mono) have "?l1 \ integral {a..b} (\s. norm (f' (flow0 x0 s)) * norm (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s))" using norm_blinfun J_in_existence_ivl[OF x_in_ball] by (auto intro!: continuous_intros integral_le) also have "... \ integral {a..b} (\s. N * norm (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s))" using J_in_existence_ivl[OF x_in_ball] N_ineq[OF \{a..b} \ J\[THEN subsetD]] by (intro integral_le) (auto intro!: continuous_intros mult_right_mono) also have "... = N * integral {a..b} (\s. norm ((Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s)))" unfolding real_scaleR_def[symmetric] by(rule integral_cmul) finally show "?l1 \ N * integral {a..b} ?g" . next have "?r1 \ integral {a..b} (\s. e1 * dist (flow0 x0 s) (Y (x - x0) s))" using J_in_existence_ivl[OF x_in_ball] \0 < e_domain\ dist_flow0_Y2 \0 < e_domain2\ by (intro integral_le) (force intro!: continuous_intros Taylor_expansion(3) order_trans[OF infdist_le] dest!: \{a..b} \ J\[THEN subsetD] intro: less_imp_le simp: dist_commute H_def)+ also have "... \ integral {a..b} (\s. e1 * (dist x0 x * exp (K * \t\)))" apply(rule integral_le) subgoal using J_in_existence_ivl[OF x_in_ball] by (force intro!: continuous_intros) subgoal by force subgoal by (force dest!: \{a..b} \ J\[THEN subsetD] intro!: less_imp_le[OF \0 < e1\] mult_left_mono[OF dist_flow0_Y]) done also have "... \ ?C" using \s \ J\ x_x0_dist \0 < e1\ \{a..b} \ J\ \0 < \t\\ t0_def t1_def by (auto simp: integral_const_real J_def(1)) finally show "?r1 \ ?C" . qed finally show ?thesis by simp qed have g_continuous: "continuous_on J ?g" using J_in_existence_ivl[OF x_in_ball] J_in_existence using J_def(1) U_continuous by (auto simp: J_def intro!: continuous_intros) note [continuous_intros] = continuous_on_subset[OF g_continuous] have C_gr_zero: "0 < ?C" using \0 < \t\\ \0 < e1\ x_x0_dist(1) by (simp add: dist_commute) have "0 \ t \ t \ 0" by auto then have "?g t \ ?C * exp (N * \t\)" proof assume "0 \ t" moreover have "continuous_on {0..t} (vector_Dflow (x - x0))" using U_continuous by (rule continuous_on_subset) (auto simp: J_def t0_def t1_def) then have "norm (Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) \ \t\ * dist x0 x * exp (K * \t\) * e1 * exp (N * t)" using \t \ J\ J_def \t0 \ 0\ J_in_existence J_in_existence_ivl_x by (intro gronwall[OF g_bound _ _ C_gr_zero \0 < N\ \0 \ t\ order.refl]) (auto intro!: continuous_intros simp: ) ultimately show ?thesis by simp next assume "t \ 0" moreover have "continuous_on {t .. 0} (vector_Dflow (x - x0))" using U_continuous by (rule continuous_on_subset) (auto simp: J_def t0_def t1_def) then have "norm (Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) \ \t\ * dist x0 x * exp (K * \t\) * e1 * exp (- N * t)" using \t \ J\ J_def \0 \ t1\ J_in_existence J_in_existence_ivl_x by (intro gronwall_left[OF g_bound _ _ C_gr_zero \0 < N\ order.refl \t \ 0\]) (auto intro!: continuous_intros) ultimately show ?thesis by simp qed also have "... = dist x x0 * (\t\ * exp (K * \t\) * e1 * exp (N * \t\))" by (auto simp: dist_commute) also have "... < norm (x - x0) * e" unfolding e1_def using \e' < e\ \0 < \t\\ \0 < e1\ x_x0_dist(1) by (simp add: dist_norm) finally show "norm ((Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) /\<^sub>R norm (x - x0)) < e" by (simp, metis x_x0_dist(1) dist_norm divide_inverse mult.commute pos_divide_less_eq) qed qed qed qed lemma local_lipschitz_A: "OT \ existence_ivl0 x0 \ local_lipschitz OT (OS::('a \\<^sub>L 'a) set) (\t. (o\<^sub>L) (vareq x0 t))" by (rule local_lipschitz_subset[OF _ _ subset_UNIV, where T="existence_ivl0 x0"]) (auto simp: split_beta' vareq_def intro!: c1_implies_local_lipschitz[where f'="\(t, x). comp3 (f' (flow0 x0 t))"] derivative_eq_intros blinfun_eqI ext continuous_intros flow_in_domain) lemma total_derivative_ll_on_open: "ll_on_open (existence_ivl0 x0) (\t. blinfun_compose (vareq x0 t)) (UNIV::('a \\<^sub>L 'a) set)" by standard (auto intro!: continuous_intros local_lipschitz_A[OF order_refl]) end end sublocale mvar: ll_on_open "existence_ivl0 x0" "\t. blinfun_compose (vareq x0 t)" "UNIV::('a \\<^sub>L 'a) set" for x0 by (rule total_derivative_ll_on_open) lemma mvar_existence_ivl_eq_existence_ivl[simp]:\ \TODO: unify with @{thm varexivl_eq_exivl}\ assumes "t \ existence_ivl0 x0" shows "mvar.existence_ivl x0 t = (\_. existence_ivl0 x0)" proof (rule ext, rule mvar.existence_ivl_eq_domain) fix s t x assume s: "s \ existence_ivl0 x0" and t: "t \ existence_ivl0 x0" then have "{s .. t} \ existence_ivl0 x0" by (meson atLeastAtMost_iff is_interval_1 is_interval_existence_ivl subsetI) then have "continuous_on {s .. t} (vareq x0)" by (auto intro!: continuous_intros) then have "compact (vareq x0 ` {s .. t})" using compact_Icc by (rule compact_continuous_image) then obtain B where B: "\u. u \ {s .. t} \ norm (vareq x0 u) \ B" by (force dest!: compact_imp_bounded simp: bounded_iff) show "\M L. \t\{s .. t}. \x\UNIV. norm (vareq x0 t o\<^sub>L x) \ M + L * norm x" unfolding o_def by (rule exI[where x=0], rule exI[where x=B]) (auto intro!: order_trans[OF norm_blinfun_compose] mult_right_mono B) qed (auto intro: assms) lemma assumes "t \ existence_ivl0 x0" shows "continuous_on (UNIV \ existence_ivl0 x0) (\(x, ta). mvar.flow x0 t x ta)" proof - from mvar.flow_continuous_on_state_space[of x0 t, unfolded mvar_existence_ivl_eq_existence_ivl[OF assms]] show "continuous_on (UNIV \ existence_ivl0 x0) (\(x, ta). mvar.flow x0 t x ta)" . qed definition "Dflow x0 = mvar.flow x0 0 id_blinfun" lemma var_eq_mvar: assumes "t0 \ existence_ivl0 x0" assumes "t \ existence_ivl0 x0" shows "var.flow x0 t0 i t = mvar.flow x0 t0 id_blinfun t i" by (rule var.flow_unique) (auto intro!: assms derivative_eq_intros mvar.flow_has_derivative simp: varexivl_eq_exivl assms has_vector_derivative_def blinfun.bilinear_simps) lemma Dflow_zero[simp]: "x \ X \ Dflow x 0 = 1\<^sub>L" unfolding Dflow_def by (subst mvar.flow_initial_time) auto subsection \Differentiability of the flow0\ text \ \U t\, i.e. the solution of the variational equation, is the space derivative at the initial value \x0\. \ lemma flow_dx_derivative: assumes "t \ existence_ivl0 x0" shows "((\x0. flow0 x0 t) has_derivative (\z. vector_Dflow x0 z t)) (at x0)" unfolding has_derivative_at2 using assms by (intro iffD1[OF LIM_equal proposition_17_6_weak[OF assms]] conjI[OF bounded_linear_vector_Dflow[OF assms]]) (simp add: diff_diff_add inverse_eq_divide) lemma flow_dx_derivative_blinfun: assumes "t \ existence_ivl0 x0" shows "((\x. flow0 x t) has_derivative Blinfun (\z. vector_Dflow x0 z t)) (at x0)" by (rule has_derivative_Blinfun[OF flow_dx_derivative[OF assms]]) definition "flowderiv x0 t = comp12 (Dflow x0 t) (blinfun_scaleR_left (f (flow0 x0 t)))" lemma flowderiv_eq: "flowderiv x0 t (\\<^sub>1, \\<^sub>2) = (Dflow x0 t) \\<^sub>1 + \\<^sub>2 *\<^sub>R f (flow0 x0 t)" by (auto simp: flowderiv_def) lemma W_continuous_on: "continuous_on (Sigma X existence_ivl0) (\(x0, t). Dflow x0 t)" \ \TODO: somewhere here is hidden continuity wrt rhs of ODE, extract it!\ unfolding continuous_on split_beta' proof (safe intro!: tendstoI) fix e'::real and t x assume x: "x \ X" and tx: "t \ existence_ivl0 x" and e': "e' > 0" let ?S = "Sigma X existence_ivl0" have "(x, t) \ ?S" using x tx by auto from open_prod_elim[OF open_state_space this] obtain OX OT where OXOT: "open OX" "open OT" "(x, t) \ OX \ OT" "OX \ OT \ ?S" by blast then obtain dx dt where dx: "dx > 0" "cball x dx \ OX" and dt: "dt > 0" "cball t dt \ OT" by (force simp: open_contains_cball) from OXOT dt dx have "cball t dt \ existence_ivl0 x" "cball x dx \ X" apply (auto simp: subset_iff) subgoal for ta apply (drule spec[where x=ta]) apply (drule spec[where x=t])+ apply auto done done have one_exivl: "mvar.existence_ivl x 0 = (\_. existence_ivl0 x)" by (rule mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \x \ X\]]) have *: "closed ({t .. 0} \ {0 .. t})" "{t .. 0} \ {0 .. t} \ {}" by auto let ?T = "{t .. 0} \ {0 .. t} \ cball t dt" have "compact ?T" by (auto intro!: compact_Un) have "?T \ existence_ivl0 x" by (intro Un_least ivl_subset_existence_ivl' ivl_subset_existence_ivl \x \ X\ \t \ existence_ivl0 x\ \cball t dt \ existence_ivl0 x\) have "compact (mvar.flow x 0 id_blinfun ` ?T)" using \?T \ _\ \x \ X\ mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \x \ X\]] by (auto intro!: \0 < dx\ compact_continuous_image \compact ?T\ continuous_on_subset[OF mvar.flow_continuous_on]) let ?line = "mvar.flow x 0 id_blinfun ` ?T" let ?X = "{x. infdist x ?line \ dx}" have "compact ?X" using \?T \ _\ \x \ X\ mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \x \ X\]] by (auto intro!: compact_infdist_le \0 < dx\ compact_continuous_image compact_Un continuous_on_subset[OF mvar.flow_continuous_on ]) from mvar.local_lipschitz \?T \ _\ have llc: "local_lipschitz ?T ?X (\t. (o\<^sub>L) (vareq x t))" by (rule local_lipschitz_subset) auto have cont: "\xa. xa \ ?X \ continuous_on ?T (\t. vareq x t o\<^sub>L xa)" using \?T \ _\ by (auto intro!: continuous_intros \x \ X\) from local_lipschitz_compact_implies_lipschitz[OF llc \compact ?X\ \compact ?T\ cont] obtain K' where K': "\ta. ta \ ?T \ K'-lipschitz_on ?X ((o\<^sub>L) (vareq x ta))" by blast define K where "K \ abs K' + 1" have "K > 0" by (simp add: K_def) have K: "\ta. ta \ ?T \ K-lipschitz_on ?X ((o\<^sub>L) (vareq x ta))" by (auto intro!: lipschitz_onI mult_right_mono order_trans[OF lipschitz_onD[OF K']] simp: K_def) have ex_ivlI: "\y. y \ cball x dx \ ?T \ existence_ivl0 y" using dx dt OXOT by (intro Un_least ivl_subset_existence_ivl' ivl_subset_existence_ivl; force) have cont: "continuous_on ((?T \ ?X) \ cball x dx) (\((ta, xa), y). (vareq y ta o\<^sub>L xa))" using \cball x dx \ X\ ex_ivlI by (force intro!: continuous_intros simp: split_beta' ) have "mvar.flow x 0 id_blinfun t \ mvar.flow x 0 id_blinfun ` ({t..0} \ {0..t} \ cball t dt)" by auto then have mem: "(t, mvar.flow x 0 id_blinfun t, x) \ ?T \ ?X \ cball x dx" by (auto simp: \0 < dx\ less_imp_le) define e where "e \ min e' (dx / 2) / 2" have "e > 0" using \e' > 0\ by (auto simp: e_def \0 < dx\) define d where "d \ e * K / (exp (K * (abs t + abs dt + 1)) - 1)" have "d > 0" by (auto simp: d_def intro!: mult_pos_pos divide_pos_pos \0 < e\ \K > 0\) have cmpct: "compact ((?T \ ?X) \ cball x dx)" "compact (?T \ ?X)" using \compact ?T\ \compact ?X\ by (auto intro!: compact_cball compact_Times) have compact_line: "compact ?line" using \{t..0} \ {0..t} \ cball t dt \ existence_ivl0 x\ one_exivl by (force intro!: compact_continuous_image \compact ?T\ continuous_on_subset[OF mvar.flow_continuous_on] simp: \x \ X\) from compact_uniformly_continuous[OF cont cmpct(1), unfolded uniformly_continuous_on_def, rule_format, OF \0 < d\] obtain d' where d': "d' > 0" "\ta xa xa' y. ta \ ?T \ xa \ ?X \ xa'\cball x dx \ y\cball x dx \ dist xa' y < d' \ dist (vareq xa' ta o\<^sub>L xa) (vareq y ta o\<^sub>L xa) < d" by (auto simp: dist_prod_def) { fix y assume dxy: "dist x y < d'" assume "y \ cball x dx" then have "y \ X" using dx dt OXOT by force+ have two_exivl: "mvar.existence_ivl y 0 = (\_. existence_ivl0 y)" by (rule mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \y \ X\]]) let ?X' = "\x \ ?line. ball x dx" have "open ?X'" by auto have "?X' \ ?X" by (auto intro!: infdist_le2 simp: dist_commute) interpret oneR: ll_on_open "existence_ivl0 x" "(\t. (o\<^sub>L) (vareq x t))" ?X' by standard (auto intro!: \x \ X\ continuous_intros local_lipschitz_A[OF order_refl]) interpret twoR: ll_on_open "existence_ivl0 y" "(\t. (o\<^sub>L) (vareq y t))" ?X' by standard (auto intro!: \y \ X\ continuous_intros local_lipschitz_A[OF order_refl]) interpret both: two_ll_on_open "(\t. (o\<^sub>L) (vareq x t))" "existence_ivl0 x" "(\t. (o\<^sub>L) (vareq y t))" "existence_ivl0 y" ?X' ?T "id_blinfun" d K proof unfold_locales show "0 < K" by (simp add: \0 < K\) show iv_defined: "0 \ {t..0} \ {0..t} \ cball t dt" by auto show "is_interval ({t..0} \ {0..t} \ cball t dt)" by (auto simp: is_interval_def dist_real_def) show "{t..0} \ {0..t} \ cball t dt \ oneR.existence_ivl 0 id_blinfun" apply (rule oneR.maximal_existence_flow[where x="mvar.flow x 0 id_blinfun"]) subgoal apply (rule solves_odeI) apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF mvar.flow_solves_ode[of 0 x id_blinfun]]]) subgoal using \x \ X\ \?T \ _\ \0 < dx\ by simp subgoal by simp subgoal by (simp add: \cball t dt \ existence_ivl0 x\ ivl_subset_existence_ivl ivl_subset_existence_ivl' one_exivl tx) subgoal using dx by (auto; force) done subgoal by (simp add: \x \ X\) subgoal by fact subgoal using iv_defined by blast subgoal using \{t..0} \ {0..t} \ cball t dt \ existence_ivl0 x\ by blast done fix s assume s: "s \ ?T" then show "K-lipschitz_on ?X' ((o\<^sub>L) (vareq x s))" by (intro lipschitz_on_subset[OF K \?X' \ ?X\]) auto fix j assume j: "j \ ?X'" show "norm ((vareq x s o\<^sub>L j) - (vareq y s o\<^sub>L j)) < d" unfolding dist_norm[symmetric] apply (rule d') subgoal by (rule s) subgoal using \?X' \ ?X\ j .. subgoal using \dx > 0\ by simp subgoal using \y \ cball x dx\ by simp subgoal using dxy by simp done qed have less_e: "norm (Dflow x s - both.Y s) < e" if s: "s \ ?T \ twoR.existence_ivl 0 id_blinfun" for s proof - from s have s_less: "\s\ < \t\ + \dt\ + 1" by (auto simp: dist_real_def) note both.norm_X_Y_bound[rule_format, OF s] also have "d / K * (exp (K * \s\) - 1) = e * ((exp (K * \s\) - 1) / (exp (K * (\t\ + \dt\ + 1)) - 1))" by (simp add: d_def) also have "\ < e * 1" by (rule mult_strict_left_mono[OF _ \0 < e\]) (simp add: add_nonneg_pos \0 < K\ \0 < e\ s_less) also have "\ = e" by simp also from s have s: "s \ ?T" by simp have "both.flow0 s = Dflow x s" unfolding both.flow0_def Dflow_def apply (rule oneR.maximal_existence_flow[where K="?T"]) subgoal apply (rule solves_odeI) apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF mvar.flow_solves_ode[of 0 x id_blinfun]]]) subgoal using \x \ X\ \0 < dx\ by simp subgoal by simp subgoal by (simp add: \cball t dt \ existence_ivl0 x\ ivl_subset_existence_ivl ivl_subset_existence_ivl' one_exivl tx) subgoal using dx by (auto; force) done subgoal by (simp add: \x \ X\) subgoal by (rule both.J_ivl) subgoal using both.t0_in_J by blast subgoal using \{t..0} \ {0..t} \ cball t dt \ existence_ivl0 x\ by blast subgoal using s by blast done finally show ?thesis . qed have "e < dx" using \dx > 0\ by (auto simp: e_def) let ?i = "{y. infdist y (mvar.flow x 0 id_blinfun ` ?T) \ e}" have 1: "?i \ (\x\mvar.flow x 0 id_blinfun ` ?T. ball x dx)" proof - have cl: "closed ?line" "?line \ {}" using compact_line by (auto simp: compact_imp_closed) have "?i \ (\y\mvar.flow x 0 id_blinfun ` ?T. cball y e)" proof safe fix x assume H: "infdist x ?line \ e" from infdist_attains_inf[OF cl, of x] obtain y where "y \ ?line" "infdist x ?line = dist x y" by auto then show "x \ (\x\?line. cball x e)" using H by (auto simp: dist_commute) qed also have "\ \ (\x\?line. ball x dx)" using \e < dx\ by auto finally show ?thesis . qed have 2: "twoR.flow 0 id_blinfun s \ ?i" if "s \ ?T" "s \ twoR.existence_ivl 0 id_blinfun" for s proof - from that have sT: "s \ ?T \ twoR.existence_ivl 0 id_blinfun" by force from less_e[OF this] have "dist (twoR.flow 0 id_blinfun s) (mvar.flow x 0 id_blinfun s) \ e" unfolding Dflow_def both.Y_def dist_commute dist_norm by simp then show ?thesis using sT by (force intro: infdist_le2) qed have T_subset: "?T \ twoR.existence_ivl 0 id_blinfun" apply (rule twoR.subset_mem_compact_implies_subset_existence_interval[ where K="{x. infdist x ?line \ e}"]) subgoal using \0 < dt\ by force subgoal by (rule both.J_ivl) subgoal using \y \ cball x dx\ ex_ivlI by blast subgoal using both.F_iv_defined(2) by blast subgoal by (rule 2) subgoal using \dt > 0\ by (intro compact_infdist_le) (auto intro!: compact_line \0 < e\) subgoal by (rule 1) done also have "twoR.existence_ivl 0 id_blinfun \ existence_ivl0 y" by (rule twoR.existence_ivl_subset) finally have "?T \ existence_ivl0 y" . have "norm (Dflow x s - Dflow y s) < e" if s: "s \ ?T" for s proof - from s have "s \ ?T \ twoR.existence_ivl 0 id_blinfun" using T_subset by force from less_e[OF this] have "norm (Dflow x s - both.Y s) < e" . also have "mvar.flow y 0 id_blinfun s = twoR.flow 0 id_blinfun s" apply (rule mvar.maximal_existence_flow[where K="?T"]) subgoal apply (rule solves_odeI) apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF twoR.flow_solves_ode[of 0 id_blinfun]]]) subgoal using \y \ X\ by simp subgoal using both.F_iv_defined(2) by blast subgoal using T_subset by blast subgoal by simp done subgoal using \y \ X\ auto_ll_on_open.existence_ivl_zero auto_ll_on_open_axioms both.F_iv_defined(2) twoR.flow_initial_time by blast subgoal by (rule both.J_ivl) subgoal using both.t0_in_J by blast subgoal using \{t..0} \ {0..t} \ cball t dt \ existence_ivl0 y\ by blast subgoal using s by blast done then have "both.Y s = Dflow y s" unfolding both.Y_def Dflow_def by simp finally show ?thesis . qed } note cont_data = this have "\\<^sub>F (y, s) in at (x, t) within ?S. dist x y < d'" unfolding at_within_open[OF \(x, t) \ ?S\ open_state_space] UNIV_Times_UNIV[symmetric] using \d' > 0\ by (intro eventually_at_Pair_within_TimesI1) (auto simp: eventually_at less_imp_le dist_commute) moreover have "\\<^sub>F (y, s) in at (x, t) within ?S. y \ cball x dx" unfolding at_within_open[OF \(x, t) \ ?S\ open_state_space] UNIV_Times_UNIV[symmetric] using \dx > 0\ by (intro eventually_at_Pair_within_TimesI1) (auto simp: eventually_at less_imp_le dist_commute) moreover have "\\<^sub>F (y, s) in at (x, t) within ?S. s \ ?T" unfolding at_within_open[OF \(x, t) \ ?S\ open_state_space] UNIV_Times_UNIV[symmetric] using \dt > 0\ by (intro eventually_at_Pair_within_TimesI2) (auto simp: eventually_at less_imp_le dist_commute) moreover have "0 \ existence_ivl0 x" by (simp add: \x \ X\) have "\\<^sub>F y in at t within existence_ivl0 x. dist (mvar.flow x 0 id_blinfun y) (mvar.flow x 0 id_blinfun t) < e" using mvar.flow_continuous_on[of x 0 id_blinfun] using \0 < e\ tx by (auto simp add: continuous_on one_exivl dest!: tendstoD) then have "\\<^sub>F (y, s) in at (x, t) within ?S. dist (Dflow x s) (Dflow x t) < e" using \0 < e\ unfolding at_within_open[OF \(x, t) \ ?S\ open_state_space] UNIV_Times_UNIV[symmetric] Dflow_def by (intro eventually_at_Pair_within_TimesI2) (auto simp: at_within_open[OF tx open_existence_ivl]) ultimately have "\\<^sub>F (y, s) in at (x, t) within ?S. dist (Dflow y s) (Dflow x t) < e'" apply eventually_elim proof (safe del: UnE, goal_cases) case (1 y s) have "dist (Dflow y s) (Dflow x t) \ dist (Dflow y s) (Dflow x s) + dist (Dflow x s) (Dflow x t)" by (rule dist_triangle) also have "dist (Dflow x s) (Dflow x t) < e" by (rule 1) also have "dist (Dflow y s) (Dflow x s) < e" unfolding dist_norm norm_minus_commute using 1 by (intro cont_data) also have "e + e \ e'" by (simp add: e_def) finally show "dist (Dflow y s) (Dflow x t) < e'" by arith qed then show "\\<^sub>F ys in at (x, t) within ?S. dist (Dflow (fst ys) (snd ys)) (Dflow (fst (x, t)) (snd (x, t))) < e'" by (simp add: split_beta') qed lemma W_continuous_on_comp[continuous_intros]: assumes h: "continuous_on S h" and g: "continuous_on S g" shows "(\s. s \ S \ h s \ X) \ (\s. s \ S \ g s \ existence_ivl0 (h s)) \ continuous_on S (\s. Dflow (h s) (g s))" using continuous_on_compose[OF continuous_on_Pair[OF h g] continuous_on_subset[OF W_continuous_on]] by auto lemma f_flow_continuous_on: "continuous_on (Sigma X existence_ivl0) (\(x0, t). f (flow0 x0 t))" using flow_continuous_on_state_space by (auto intro!: continuous_on_f flow_in_domain simp: split_beta') lemma flow_has_space_derivative: assumes "t \ existence_ivl0 x0" shows "((\x0. flow0 x0 t) has_derivative Dflow x0 t) (at x0)" by (rule flow_dx_derivative_blinfun[THEN has_derivative_eq_rhs]) (simp_all add: var_eq_mvar assms blinfun.blinfun_apply_inverse Dflow_def vector_Dflow_def mem_existence_ivl_iv_defined[OF assms]) lemma flow_has_flowderiv: assumes "t \ existence_ivl0 x0" shows "((\(x0, t). flow0 x0 t) has_derivative flowderiv x0 t) (at (x0, t) within S)" proof - have Sigma: "(x0, t) \ Sigma X existence_ivl0" using assms by auto from open_state_space assms obtain e' where e': "e' > 0" "ball (x0, t) e' \ Sigma X existence_ivl0" by (force simp: open_contains_ball) define e where "e = e' / sqrt 2" have "0 < e" using e' by (auto simp: e_def) have "ball x0 e \ ball t e \ ball (x0, t) e'" by (auto simp: dist_prod_def real_sqrt_sum_squares_less e_def) also note e'(2) finally have subs: "ball x0 e \ ball t e \ Sigma X existence_ivl0" . have d1: "((\x0. flow0 x0 s) has_derivative blinfun_apply (Dflow y s)) (at y within ball x0 e)" if "y \ ball x0 e" "s \ ball t e" for y s using subs that by (subst at_within_open; force intro!: flow_has_space_derivative) have d2: "(flow0 y has_derivative blinfun_apply (blinfun_scaleR_left (f (flow0 y s)))) (at s within ball t e)" if "y \ ball x0 e" "s \ ball t e" for y s using subs that unfolding has_vector_derivative_eq_has_derivative_blinfun[symmetric] by (subst at_within_open; force intro!: flow_has_vector_derivative) have "((\(x0, t). flow0 x0 t) has_derivative flowderiv x0 t) (at (x0, t) within ball x0 e \ ball t e)" using subs unfolding UNIV_Times_UNIV[symmetric] by (intro has_derivative_partialsI[OF d1 d2, THEN has_derivative_eq_rhs]) (auto intro!: \0 < e\ continuous_intros flow_in_domain continuous_on_imp_continuous_within[where s="Sigma X existence_ivl0"] assms simp: flowderiv_def split_beta' flow0_defined assms mem_ball) then have "((\(x0, t). flow0 x0 t) has_derivative flowderiv x0 t) (at (x0, t) within Sigma X existence_ivl0)" by (auto simp: at_within_open[OF _ open_state_space] at_within_open[OF _ open_Times] assms \0 < e\ mem_existence_ivl_iv_defined[OF assms]) then show ?thesis unfolding at_within_open[OF Sigma open_state_space] by (rule has_derivative_at_withinI) qed lemma flow0_comp_has_derivative: assumes h: "h s \ existence_ivl0 (g s)" assumes [derivative_intros]: "(g has_derivative g') (at s within S)" assumes [derivative_intros]: "(h has_derivative h') (at s within S)" shows "((\x. flow0 (g x) (h x)) has_derivative (\x. blinfun_apply (flowderiv (g s) (h s)) (g' x, h' x))) (at s within S)" by (rule has_derivative_compose[where f="\x. (g x, h x)" and s=S, OF _ flow_has_flowderiv[OF h], simplified]) (auto intro!: derivative_eq_intros) lemma flowderiv_continuous_on: "continuous_on (Sigma X existence_ivl0) (\(x0, t). flowderiv x0 t)" unfolding flowderiv_def split_beta' by (subst blinfun_of_matrix_works[where f="comp12 (Dflow (fst x) (snd x)) (blinfun_scaleR_left (f (flow0 (fst x) (snd x))))" for x, symmetric]) (auto intro!: continuous_intros flow_in_domain) lemma flowderiv_continuous_on_comp[continuous_intros]: assumes "continuous_on S x" assumes "continuous_on S t" assumes "\s. s \ S \ x s \ X" "\s. s \ S \ t s \ existence_ivl0 (x s)" shows "continuous_on S (\xa. flowderiv (x xa) (t xa))" by (rule continuous_on_compose2[OF flowderiv_continuous_on, where f="\s. (x s, t s)", unfolded split_beta' fst_conv snd_conv]) (auto intro!: continuous_intros assms) lemmas [intro] = flow_in_domain lemma vareq_trans: "t0 \ existence_ivl0 x0 \ t \ existence_ivl0 (flow0 x0 t0) \ vareq (flow0 x0 t0) t = vareq x0 (t0 + t)" by (auto simp: vareq_def flow_trans) lemma diff_existence_ivl_trans: "t0 \ existence_ivl0 x0 \ t \ existence_ivl0 x0 \ t - t0 \ existence_ivl0 (flow0 x0 t0)" for t by (metis (no_types, opaque_lifting) add.left_neutral diff_add_eq local.existence_ivl_reverse local.existence_ivl_trans local.flows_reverse) lemma has_vderiv_on_blinfun_compose_right[derivative_intros]: assumes "(g has_vderiv_on g') T" assumes "\x. x \ T \ gd' x = g' x o\<^sub>L d" shows "((\x. g x o\<^sub>L d) has_vderiv_on gd') T" using assms by (auto simp: has_vderiv_on_def has_vector_derivative_def blinfun_ext blinfun.bilinear_simps intro!: derivative_eq_intros ext) lemma has_vderiv_on_blinfun_compose_left[derivative_intros]: assumes "(g has_vderiv_on g') T" assumes "\x. x \ T \ gd' x = d o\<^sub>L g' x" shows "((\x. d o\<^sub>L g x) has_vderiv_on gd') T" using assms by (auto simp: has_vderiv_on_def has_vector_derivative_def blinfun_ext blinfun.bilinear_simps intro!: derivative_eq_intros ext) lemma mvar_flow_shift: assumes "t0 \ existence_ivl0 x0" "t1 \ existence_ivl0 x0" shows "mvar.flow x0 t0 d t1 = Dflow (flow0 x0 t0) (t1 - t0) o\<^sub>L d" proof - have "mvar.flow x0 t0 d t1 = mvar.flow x0 t0 d (t0 + (t1 - t0))" by simp also have "\ = mvar.flow x0 t0 (mvar.flow x0 t0 d t0) t1" by (subst mvar.flow_trans) (auto simp add: assms) also have "\ = Dflow (flow0 x0 t0) (t1 - t0) o\<^sub>L d" apply (rule mvar.flow_unique_on) apply (auto simp add: assms mvar.flow_initial_time_if blinfun_ext Dflow_def intro!: derivative_intros derivative_eq_intros) apply (auto simp: assms has_vderiv_on_open has_vector_derivative_def intro!: derivative_eq_intros blinfun_eqI) apply (subst mvar_existence_ivl_eq_existence_ivl) by (auto simp add: vareq_trans assms diff_existence_ivl_trans) finally show ?thesis . qed lemma Dflow_trans: assumes "h \ existence_ivl0 x0" assumes "i \ existence_ivl0 (flow0 x0 h)" shows "Dflow x0 (h + i) = Dflow (flow0 x0 h) i o\<^sub>L (Dflow x0 h)" proof - have [intro, simp]: "h + i \ existence_ivl0 x0" "i + h \ existence_ivl0 x0" "x0 \ X" using assms by (auto simp add: add.commute existence_ivl_trans) show ?thesis unfolding Dflow_def apply (subst mvar.flow_trans[where s=h and t=i]) subgoal by (auto simp: assms) subgoal by (auto simp: assms) by (subst mvar_flow_shift) (auto simp: assms Dflow_def ) qed lemma Dflow_trans_apply: assumes "h \ existence_ivl0 x0" assumes "i \ existence_ivl0 (flow0 x0 h)" shows "Dflow x0 (h + i) d0 = Dflow (flow0 x0 h) i (Dflow x0 h d0)" proof - have [intro, simp]: "h + i \ existence_ivl0 x0" "i + h \ existence_ivl0 x0" "x0 \ X" using assms by (auto simp add: add.commute existence_ivl_trans) show ?thesis unfolding Dflow_def apply (subst mvar.flow_trans[where s=h and t=i]) subgoal by (auto simp: assms) subgoal by (auto simp: assms) by (subst mvar_flow_shift) (auto simp: assms Dflow_def ) qed end \ \@{thm c1_on_open_euclidean_anchor}\ end diff --git a/thys/Partial_Function_MR/partial_function_mr.ML b/thys/Partial_Function_MR/partial_function_mr.ML --- a/thys/Partial_Function_MR/partial_function_mr.ML +++ b/thys/Partial_Function_MR/partial_function_mr.ML @@ -1,338 +1,338 @@ (* Author: Rene Thiemann, License: LGPL *) signature PARTIAL_FUNCTION_MR = sig val init: string -> (* make monad_map: monad term * funs * monad as typ * monad bs typ * a->b typs -> map_monad funs monad term *) (term * term list * typ * typ * typ list -> term) -> (* make monad type: fixed and flexible types *) (typ list * typ list -> typ) -> (* destruct monad type: fixed and flexible types *) (typ -> typ list * typ list) -> (* monad_map_compose thm: mapM f (mapM g x) = mapM (f o g) x *) thm list -> (* monad_map_ident thm: mapM (% y. y) x = x *) - thm list -> declaration + thm list -> Morphism.declaration val add_partial_function_mr: string -> (binding * typ option * mixfix) list -> Specification.multi_specs -> local_theory -> thm list * local_theory val add_partial_function_mr_cmd: string -> (binding * string option * mixfix) list -> Specification.multi_specs_cmd -> local_theory -> thm list * local_theory end; structure Partial_Function_MR: PARTIAL_FUNCTION_MR = struct val partial_function_mr_trace = Attrib.setup_config_bool @{binding partial_function_mr_trace} (K false); fun trace ctxt msg = if Config.get ctxt partial_function_mr_trace then tracing msg else () datatype setup_data = Setup_Data of {mk_monad_map: term * term list * typ * typ * typ list -> term, mk_monadT: typ list * typ list -> typ, dest_monadT: typ -> typ list * typ list, monad_map_comp: thm list, monad_map_id: thm list}; (* the following code has been copied from partial_function.ML *) structure Modes = Generic_Data ( type T = setup_data Symtab.table; val empty = Symtab.empty; fun merge data = Symtab.merge (K true) data; ) val known_modes = Symtab.keys o Modes.get o Context.Proof; val lookup_mode = Symtab.lookup o Modes.get o Context.Proof; fun curry_const (A, B, C) = Const (@{const_name Product_Type.curry}, [HOLogic.mk_prodT (A, B) --> C, A, B] ---> C); fun mk_curry f = case fastype_of f of Type ("fun", [Type (_, [S, T]), U]) => curry_const (S, T, U) $ f | T => raise TYPE ("mk_curry", [T], [f]); fun curry_n arity = funpow (arity - 1) mk_curry; fun uncurry_n arity = funpow (arity - 1) HOLogic.mk_case_prod; (* end copy of partial_function.ML *) fun init mode mk_monad_map mk_monadT dest_monadT monad_map_comp monad_map_id phi = let val thm = Morphism.thm phi; (* TODO: are there morphisms required on mk_monad_map???, ... *) val data' = Setup_Data {mk_monad_map=mk_monad_map, mk_monadT=mk_monadT, dest_monadT=dest_monadT, monad_map_comp=map thm monad_map_comp,monad_map_id=map thm monad_map_id}; in Modes.map (Symtab.update (mode, data')) end fun mk_sumT (T1,T2) = Type (@{type_name sum}, [T1,T2]) fun mk_choiceT [ty] = ty | mk_choiceT (ty :: more) = mk_sumT (ty,mk_choiceT more) | mk_choiceT _ = error "mk_choiceT []" fun mk_choice_resT mk_monadT dest_monadT mTs = let val (commonTs,argTs) = map dest_monadT mTs |> split_list |> apfst hd; val n = length (hd argTs); val new = map (fn i => mk_choiceT (map (fn xs => nth xs i) argTs)) (0 upto (n - 1)) in mk_monadT (commonTs,new) end; fun mk_inj [_] t _ = t | mk_inj (ty :: more) t n = let val moreT = mk_choiceT more; val allT = mk_sumT (ty,moreT) in if n = 0 then Const (@{const_name Inl}, ty --> allT) $ t else Const (@{const_name Inr}, moreT --> allT) $ mk_inj more t (n-1) end | mk_inj _ _ _ = error "mk_inj [] _ _" fun mk_proj [_] t _ = t | mk_proj (ty :: more) t n = let val moreT = mk_choiceT more; val allT = mk_sumT (ty,moreT) in if n = 0 then Const (@{const_name Sum_Type.projl}, allT --> ty) $ t else mk_proj more (Const (@{const_name Sum_Type.projr}, allT --> moreT) $ t) (n-1) end | mk_proj _ _ _ = error "mk_proj [] _ _" fun get_head ctxt (_,(_,eqn)) = let val ((_, plain_eqn), _) = Variable.focus NONE eqn ctxt; val lhs = HOLogic.dest_eq (HOLogic.dest_Trueprop plain_eqn) |> #1; val head = strip_comb lhs |> #1; in head end; fun get_infos lthy heads (fix,(_,eqn)) = let val ((_, plain_eqn), _) = Variable.focus NONE eqn lthy; val ((f_binding, fT), mixfix) = fix; val fname = Binding.name_of f_binding; val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop plain_eqn); val (_, args) = strip_comb lhs; val F = fold_rev lambda (heads @ args) rhs; val arity = length args; val (aTs, bTs) = chop arity (binder_types fT); val tupleT = foldl1 HOLogic.mk_prodT aTs; val fT_uc = tupleT :: bTs ---> body_type fT; val (inT,resT) = dest_funT fT_uc; val f_uc = Free (fname, fT_uc); val f_cuc = curry_n arity f_uc in (fname, f_cuc, f_uc, inT, resT, ((f_binding,mixfix),fT), F, arity, args) end; fun fresh_var ctxt name = Name.variant name (Variable.names_of ctxt) |> #1 (* partial_function_mr definition *) fun gen_add_partial_function_mr prep mode fixes_raw eqns_raw lthy = let val setup_data = the (lookup_mode lthy mode) handle Option.Option => error (cat_lines ["Unknown mode " ^ quote mode ^ ".", "Known modes are " ^ commas_quote (known_modes lthy) ^ "."]); val Setup_Data {mk_monad_map, mk_monadT, dest_monadT, monad_map_comp, monad_map_id} = setup_data; val _ = if length eqns_raw < 2 then error "require at least two function definitions" else (); val ((fixes, eq_abinding_eqns), _) = prep fixes_raw eqns_raw lthy; val _ = if length eqns_raw = length fixes then () else error "# of eqns does not match # of constants"; val fix_eq_abinding_eqns = fixes ~~ eq_abinding_eqns; val heads = map (get_head lthy) fix_eq_abinding_eqns; val fnames = map (Binding.name_of o #1 o #1) fixes val fnames' = map (#1 o Term.dest_Free) heads val f_f = fnames ~~ fnames' val _ = case find_first (fn (f,g) => not (f = g)) f_f of NONE => () | SOME _ => error ("list of function symbols does not match list of equations:\n" ^ @{make_string} fnames ^ "\nvs\n" ^ @{make_string} fnames') val all = map (get_infos lthy heads) fix_eq_abinding_eqns val f_cucs = map #2 all val f_ucs = map #3 all val inTs = map #4 all val resTs = map #5 all val bindings_types = map #6 all val Fs = map #7 all val arities = map #8 all val all_args = map #9 all val glob_inT = mk_choiceT inTs val glob_resT = mk_choice_resT mk_monadT dest_monadT resTs val inj = mk_inj inTs val glob_fname = fresh_var lthy (foldl1 (fn (a,b) => a ^ "_" ^ b) (fnames @ [serial_string ()])) val glob_constT = glob_inT --> glob_resT; val glob_const = Free (glob_fname, glob_constT) val nums = 0 upto (length all - 1) fun mk_res_inj_proj n = let val resT = nth resTs n val glob_Targs = dest_monadT glob_resT |> #2 val res_Targs = dest_monadT resT |> #2 val m = length res_Targs fun inj_proj m = let val resTs_m = map (fn resT => nth (dest_monadT resT |> #2) m) resTs val resT_arg = nth resTs_m n val globT_arg = nth glob_Targs m val x = Free ("x",resT_arg) val y = Free ("x",globT_arg) val inj = lambda x (mk_inj resTs_m x n) val proj = lambda y (mk_proj resTs_m y n) in ((inj, resT_arg --> globT_arg), (proj, globT_arg --> resT_arg)) end; val (inj,proj) = map inj_proj (0 upto (m - 1)) |> split_list val (t_to_ss_inj,t_to_sTs_inj) = split_list inj; val (t_to_ss_proj,t_to_sTs_proj) = split_list proj; in (fn mt => mk_monad_map (mt, t_to_ss_inj, resT, glob_resT, t_to_sTs_inj), fn mt => mk_monad_map (mt, t_to_ss_proj, glob_resT, resT, t_to_sTs_proj)) end; val (res_inj, res_proj) = map mk_res_inj_proj nums |> split_list fun mk_global_fun n = let val fname = nth fnames n val inT = nth inTs n val xs = Free (fresh_var lthy ("x_" ^ fname), inT) val inj_xs = inj xs n val glob_inj_xs = glob_const $ inj_xs val glob_inj_xs_map = nth res_proj n glob_inj_xs val res = lambda xs glob_inj_xs_map in (xs,res) end val (xss,global_funs) = map mk_global_fun nums |> split_list fun mk_cases n = let val xs = nth xss n val F = nth Fs n; val arity = nth arities n; val F_uc = fold_rev lambda f_ucs (uncurry_n arity (list_comb (F, f_cucs))); val F_uc_inst = Term.betapplys (F_uc,global_funs) val res = lambda xs (nth res_inj n (F_uc_inst $ xs)) in res end; val all_cases = map mk_cases nums; fun combine_cases [cs] [_] = cs | combine_cases (cs :: more) (inT :: moreTy) = let val moreT = mk_choiceT moreTy val sumT = mk_sumT (inT, moreT) val case_const = Const (@{const_name case_sum}, (inT --> glob_resT) --> (moreT --> glob_resT) --> sumT --> glob_resT) in case_const $ cs $ combine_cases more moreTy end | combine_cases _ _ = error "combine_cases with incompatible argument lists"; val glob_x_name = fresh_var lthy ("x_" ^ glob_fname) val glob_x = Free (glob_x_name,glob_inT) val rhs = combine_cases all_cases inTs $ glob_x; val lhs = glob_const $ glob_x val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs)) val glob_binding = Binding.name (glob_fname) |> Binding.concealed val glob_attrib_binding = Binding.empty_atts val _ = trace lthy "invoking partial_function on global function" val priv_lthy = lthy |> Proof_Context.private_scope (Binding.new_scope()) val ((glob_const, glob_simp_thm),priv_lthy') = priv_lthy |> Partial_Function.add_partial_function mode [(glob_binding,SOME glob_constT,NoSyn)] (glob_attrib_binding,eq) val glob_lthy = priv_lthy' |> Proof_Context.restore_naming lthy val _ = trace lthy "deriving simp rules for separate functions from global function" fun define_f n (fs, fdefs,rhss,lthy) = let val ((fbinding,mixfix),_) = nth bindings_types n val fname = nth fnames n val inT = nth inTs n; val arity = nth arities n; val x = Free (fresh_var lthy ("x_" ^ fname), inT) val inj_argsProd = inj x n val call = glob_const $ inj_argsProd val post = nth res_proj n call val rhs = curry_n arity (lambda x post) val ((f, (_, f_def)),lthy') = Local_Theory.define_internal ((fbinding,mixfix), (Binding.empty_atts, rhs)) lthy in (f :: fs, f_def :: fdefs,rhs :: rhss,lthy') end val (fs,fdefs,f_rhss,local_lthy) = fold_rev define_f nums ([],[],[],glob_lthy) val glob_simp_thm' = let fun mk_case_new n = let val F = nth Fs n val arity = nth arities n val Finst = uncurry_n arity (Term.betapplys (F,fs)) val xs = nth xss n val res = lambda xs (nth res_inj n (Finst $ xs)) in res end; val new_cases = map mk_case_new nums; val rhs = combine_cases new_cases inTs $ glob_x; val lhs = glob_const $ glob_x val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,rhs)) in Goal.prove local_lthy [glob_x_name] [] eq (fn {prems = _, context = ctxt} => Thm.instantiate' [] [SOME (Thm.cterm_of ctxt glob_x)] glob_simp_thm |> (fn simp_thm => unfold_tac ctxt [simp_thm] THEN unfold_tac ctxt fdefs)) end fun mk_simp_thm n = let val args = nth all_args n val arg_names = map (dest_Free #> fst) args val f = nth fs n val F = nth Fs n val fdef = nth fdefs n val lhs = list_comb (f,args); val mhs = Term.betapplys (nth f_rhss n, args) val rhs = list_comb (list_comb (F,fs), args); val eq1 = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,mhs)) val eq2 = HOLogic.mk_Trueprop (HOLogic.mk_eq (mhs,rhs)) val simp_thm1 = Goal.prove local_lthy arg_names [] eq1 (fn {prems = _, context = ctxt} => unfold_tac ctxt [fdef]) val simp_thm2 = Goal.prove local_lthy arg_names [] eq2 (fn {prems = _, context = ctxt} => unfold_tac ctxt [glob_simp_thm'] THEN unfold_tac ctxt @{thms sum.simps curry_def split} THEN unfold_tac ctxt (@{thm o_def} :: monad_map_comp) THEN unfold_tac ctxt (monad_map_id @ @{thms sum.sel})) in @{thm trans} OF [simp_thm1,simp_thm2] end val simp_thms = map mk_simp_thm nums fun register n lthy = let val simp_thm = nth simp_thms n val eq_abinding = nth eq_abinding_eqns n |> fst val fname = nth fnames n val f = nth fs n in lthy |> Local_Theory.note (eq_abinding, [simp_thm]) |-> (fn (_, simps) => Spec_Rules.add Binding.empty Spec_Rules.equational_recdef [f] simps #> Local_Theory.note ((Binding.qualify true fname (Binding.name "simps"), @{attributes [code]}), simps) #>> snd #>> hd) end in fold (fn i => fn (simps, lthy) => case register i lthy of (simp, lthy') => (simps @ [simp], lthy')) nums ([], local_lthy) end; val add_partial_function_mr = gen_add_partial_function_mr Specification.check_multi_specs; val add_partial_function_mr_cmd = gen_add_partial_function_mr Specification.read_multi_specs; val mode = @{keyword "("} |-- Parse.name --| @{keyword ")"}; val _ = Outer_Syntax.local_theory @{command_keyword partial_function_mr} "define mutually recursive partial functions" (mode -- Parse_Spec.specification >> (fn (mode, (fixes, specs)) => add_partial_function_mr_cmd mode fixes specs #> #2)); end diff --git a/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy b/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy --- a/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy +++ b/thys/Randomised_Social_Choice/Automation/Preference_Profile_Cmd.thy @@ -1,385 +1,385 @@ (* Title: Preference_Profiles_Cmd.thy Author: Manuel Eberl, TU München Provides the preference_profile command that defines preference profiles, proves well-formedness, and provides some useful lemmas for them. *) section \Automatic definition of Preference Profiles\ theory Preference_Profile_Cmd imports Complex_Main "../Elections" keywords "preference_profile" :: thy_goal begin ML_file \preference_profiles.ML\ context election begin lemma preferred_alts_prefs_from_table: assumes "prefs_from_table_wf agents alts xs" "i \ set (map fst xs)" shows "preferred_alts (prefs_from_table xs i) x = of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x" proof - interpret pref_profile_wf agents alts "prefs_from_table xs" by (intro pref_profile_from_tableI assms) from assms have [simp]: "i \ agents" by (auto simp: prefs_from_table_wf_def) have "of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x = Collect (of_weak_ranking (the (map_of xs i)) x)" by (rule eval_Collect_of_weak_ranking [symmetric]) also from assms(2) have "the (map_of xs i) \ set (map snd xs)" by (cases "map_of xs i") (force simp: map_of_eq_None_iff dest: map_of_SomeD)+ from prefs_from_table_wfD(5)[OF assms(1) this] have "Collect (of_weak_ranking (the (map_of xs i)) x) = {y\alts. of_weak_ranking (the (map_of xs i)) x y}" by safe (force elim!: of_weak_ranking.cases) also from assms have "of_weak_ranking (the (map_of xs i)) = prefs_from_table xs i" by (subst prefs_from_table_map_of[OF assms(1)]) (auto simp: prefs_from_table_wf_def) finally show ?thesis by (simp add: of_weak_ranking_Collect_ge_def preferred_alts_altdef) qed lemma favorites_prefs_from_table: assumes wf: "prefs_from_table_wf agents alts xs" and i: "i \ agents" shows "favorites (prefs_from_table xs) i = hd (the (map_of xs i))" proof (cases "map_of xs i") case None with assms show ?thesis by (auto simp: map_of_eq_None_iff prefs_from_table_wf_def) next case (Some y) with assms have "is_finite_weak_ranking y" "y \ []" by (auto simp: prefs_from_table_wf_def) with Some show ?thesis unfolding favorites_def using assms by (simp add: prefs_from_table_def is_finite_weak_ranking_def Max_wrt_of_weak_ranking prefs_from_table_wfD) qed lemma has_unique_favorites_prefs_from_table: assumes wf: "prefs_from_table_wf agents alts xs" shows "has_unique_favorites (prefs_from_table xs) = list_all (\z. is_singleton (hd (snd z))) xs" proof - interpret pref_profile_wf agents alts "prefs_from_table xs" by (intro pref_profile_from_tableI assms) from wf have "agents = set (map fst xs)" "distinct (map fst xs)" by (auto simp: prefs_from_table_wf_def) thus ?thesis unfolding has_unique_favorites_altdef using assms by (auto simp: favorites_prefs_from_table list_all_iff) qed end subsection \Automatic definition of preference profiles from tables\ function favorites_prefs_from_table where "i = j \ favorites_prefs_from_table ((j,x)#xs) i = hd x" | "i \ j \ favorites_prefs_from_table ((j,x)#xs) i = favorites_prefs_from_table xs i" | "favorites_prefs_from_table [] i = {}" by (metis list.exhaust old.prod.exhaust) auto termination by lexicographic_order lemma (in election) eval_favorites_prefs_from_table: assumes "prefs_from_table_wf agents alts xs" shows "favorites_prefs_from_table xs i = favorites (prefs_from_table xs) i" proof (cases "i \ agents") assume i: "i \ agents" with assms have "favorites (prefs_from_table xs) i = hd (the (map_of xs i))" by (simp add: favorites_prefs_from_table) also from assms i have "i \ set (map fst xs)" by (auto simp: prefs_from_table_wf_def) hence "hd (the (map_of xs i)) = favorites_prefs_from_table xs i" by (induction xs i rule: favorites_prefs_from_table.induct) simp_all finally show ?thesis .. next assume i: "i \ agents" with assms have i': "i \ set (map fst xs)" by (simp add: prefs_from_table_wf_def) hence "map_of xs i = None" by (simp add: map_of_eq_None_iff) hence "prefs_from_table xs i = (\_ _. False)" by (intro ext) (auto simp: prefs_from_table_def) hence "favorites (prefs_from_table xs) i = {}" by (simp add: favorites_def Max_wrt_altdef) also from i' have "\ = favorites_prefs_from_table xs i" by (induction xs i rule: favorites_prefs_from_table.induct) simp_all finally show ?thesis .. qed function weak_ranking_prefs_from_table where "i \ j \ weak_ranking_prefs_from_table ((i,x)#xs) j = weak_ranking_prefs_from_table xs j" | "i = j \ weak_ranking_prefs_from_table ((i,x)#xs) j = x" | "weak_ranking_prefs_from_table [] j = []" by (metis list.exhaust old.prod.exhaust) auto termination by lexicographic_order lemma eval_weak_ranking_prefs_from_table: assumes "prefs_from_table_wf agents alts xs" shows "weak_ranking_prefs_from_table xs i = weak_ranking (prefs_from_table xs i)" proof (cases "i \ agents") assume i: "i \ agents" with assms have "weak_ranking (prefs_from_table xs i) = the (map_of xs i)" by (auto simp: prefs_from_table_def prefs_from_table_wf_def weak_ranking_of_weak_ranking split: option.splits) also from assms i have "i \ set (map fst xs)" by (auto simp: prefs_from_table_wf_def) hence "the (map_of xs i) = weak_ranking_prefs_from_table xs i" by (induction xs i rule: weak_ranking_prefs_from_table.induct) simp_all finally show ?thesis .. next assume i: "i \ agents" with assms have i': "i \ set (map fst xs)" by (simp add: prefs_from_table_wf_def) hence "map_of xs i = None" by (simp add: map_of_eq_None_iff) hence "prefs_from_table xs i = (\_ _. False)" by (intro ext) (auto simp: prefs_from_table_def) hence "weak_ranking (prefs_from_table xs i) = []" by simp also from i' have "\ = weak_ranking_prefs_from_table xs i" by (induction xs i rule: weak_ranking_prefs_from_table.induct) simp_all finally show ?thesis .. qed lemma eval_prefs_from_table_aux: assumes "R \ prefs_from_table xs" "prefs_from_table_wf agents alts xs" shows "R i a b \ prefs_from_table xs i a b" "a \[R i] b \ prefs_from_table xs i a b \ \prefs_from_table xs i b a" "anonymous_profile R = mset (map snd xs)" "election agents alts \ i \ set (map fst xs) \ preferred_alts (R i) x = of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x" "election agents alts \ i \ set (map fst xs) \ favorites R i = favorites_prefs_from_table xs i" "election agents alts \ i \ set (map fst xs) \ weak_ranking (R i) = weak_ranking_prefs_from_table xs i" "election agents alts \ i \ set (map fst xs) \ favorite R i = the_elem (favorites_prefs_from_table xs i)" "election agents alts \ has_unique_favorites R \ list_all (\z. is_singleton (hd (snd z))) xs" using assms prefs_from_table_wfD[OF assms(2)] by (simp_all add: strongly_preferred_def favorite_def anonymise_prefs_from_table election.preferred_alts_prefs_from_table election.eval_favorites_prefs_from_table election.has_unique_favorites_prefs_from_table eval_weak_ranking_prefs_from_table) lemma pref_profile_from_tableI': assumes "R1 \ prefs_from_table xss" "prefs_from_table_wf agents alts xss" shows "pref_profile_wf agents alts R1" using assms by (simp add: pref_profile_from_tableI) ML \ signature PREFERENCE_PROFILES_CMD = sig type info val preference_profile : (term * term) * ((binding * (term * term list list) list) list) -> Proof.context -> Proof.state val preference_profile_cmd : (string * string) * ((binding * (string * string list list) list) list) -> Proof.context -> Proof.state val get_info : term -> Proof.context -> info val add_info : term -> info -> Context.generic -> Context.generic val transform_info : info -> morphism -> info end structure Preference_Profiles_Cmd : PREFERENCE_PROFILES_CMD = struct open Preference_Profiles type info = { term : term, def_thm : thm, wf_thm : thm, wf_raw_thm : thm, binding : binding, raw : (term * term list list) list, eval_thms : thm list } fun transform_info ({term = t, binding, def_thm, wf_thm, wf_raw_thm, raw, eval_thms} : info) phi = let val thm = Morphism.thm phi val fact = Morphism.fact phi val term = Morphism.term phi val bdg = Morphism.binding phi in { term = term t, binding = bdg binding, def_thm = thm def_thm, wf_thm = thm wf_thm, wf_raw_thm = thm wf_raw_thm, raw = map (fn (a, bss) => (term a, map (map term) bss)) raw, eval_thms = fact eval_thms } end structure Data = Generic_Data ( type T = (term * info) Item_Net.T val empty = Item_Net.init (op aconv o apply2 fst) (single o fst) val merge = Item_Net.merge ); fun get_info term lthy = Item_Net.retrieve (Data.get (Context.Proof lthy)) term |> the_single |> snd fun add_info term info lthy = Data.map (Item_Net.update (term, info)) lthy fun add_infos infos lthy = Data.map (fold Item_Net.update infos) lthy fun preference_profile_aux agents alts (binding, args) lthy = let val dest_Type' = Term.dest_Type #> snd #> hd val (agentT, altT) = apply2 (dest_Type' o fastype_of) (agents, alts) val alt_setT = HOLogic.mk_setT altT fun define t = Local_Theory.define ((binding, NoSyn), ((Binding.suffix_name "_def" binding, @{attributes [code]}), t)) lthy val ty = HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT)) val args' = args |> map (fn x => x ||> map (HOLogic.mk_set altT) ||> HOLogic.mk_list alt_setT) val t_raw = args' |> map HOLogic.mk_prod |> HOLogic.mk_list ty val t = Const (@{const_name prefs_from_table}, HOLogic.listT ty --> pref_profileT agentT altT) $ t_raw val ((prefs, prefs_def), lthy) = define t val prefs_from_table_wf_const = Const (@{const_name prefs_from_table_wf}, HOLogic.mk_setT agentT --> HOLogic.mk_setT altT --> HOLogic.listT (HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT))) --> HOLogic.boolT) val wf_prop = (prefs_from_table_wf_const $ agents $ alts $ t_raw) |> HOLogic.mk_Trueprop in ((prefs, wf_prop, prefs_def), lthy) end fun fold_accum f xs s = let fun fold_accum_aux _ [] s acc = (rev acc, s) | fold_accum_aux f (x::xs) s acc = case f x s of (y, s') => fold_accum_aux f xs s' (y::acc) in fold_accum_aux f xs s [] end fun preference_profile ((agents, alts), args) lthy = let fun qualify pref suff = Binding.qualify true (Binding.name_of pref) (Binding.name suff) val (results, lthy) = fold_accum (preference_profile_aux agents alts) args lthy val prefs_terms = map #1 results val wf_props = map #2 results val defs = map (snd o #3) results val raws = map snd args val bindings = map fst args fun tac lthy = let val lthy' = put_simpset HOL_ss lthy addsimps @{thms list.set Union_insert Un_insert_left insert_not_empty Int_empty_left Int_empty_right insert_commute Un_empty_left Un_empty_right insert_absorb2 Union_empty is_weak_ranking_Cons is_weak_ranking_Nil finite_insert finite.emptyI Set.singleton_iff Set.empty_iff Set.ball_simps} in Local_Defs.unfold_tac lthy defs THEN ALLGOALS (resolve_tac lthy [@{thm prefs_from_table_wfI}]) THEN Local_Defs.unfold_tac lthy @{thms is_finite_weak_ranking_def list.set insert_iff empty_iff simp_thms list.map snd_conv fst_conv} THEN ALLGOALS (TRY o REPEAT_ALL_NEW (eresolve_tac lthy @{thms disjE})) THEN ALLGOALS (TRY o Hypsubst.hyp_subst_tac lthy) THEN ALLGOALS (Simplifier.asm_full_simp_tac lthy') THEN ALLGOALS (TRY o REPEAT_ALL_NEW (resolve_tac lthy @{thms conjI})) THEN distinct_subgoals_tac end fun after_qed [wf_thms_raw] lthy = let fun prep_thms attrs suffix (thms : thm list) binding = (((qualify binding suffix, attrs), [(thms,[])])) fun prep_thmss simp suffix thmss = map2 (prep_thms simp suffix) thmss bindings fun notes thmss suffix attrs lthy = Local_Theory.notes (prep_thmss attrs suffix thmss) lthy |> snd fun note thms suffix attrs lthy = notes (map single thms) suffix attrs lthy val eval_thmss = map2 (fn def => fn wf => map (fn thm => thm OF [def, wf]) @{thms eval_prefs_from_table_aux}) defs wf_thms_raw val wf_thms = map2 (fn def => fn wf => @{thm pref_profile_from_tableI'} OF [def, wf]) defs wf_thms_raw val mk_infos = let fun aux acc (bdg::bdgs) (t::ts) (r::raws) (def::def_thms) (wf::wf_thms) (wf_raw::wf_raw_thms) (evals::eval_thmss) = aux ((t, {binding = bdg, term = t, raw = r, def_thm = def, wf_thm = wf, wf_raw_thm = wf_raw, eval_thms = evals}) :: acc) bdgs ts raws def_thms wf_thms wf_raw_thms eval_thmss | aux acc [] _ _ _ _ _ _ = (acc : (term * info) list) | aux _ _ _ _ _ _ _ _ = raise Match in aux [] end val infos = mk_infos bindings prefs_terms raws defs wf_thms wf_thms_raw eval_thmss in lthy |> note wf_thms_raw "wf_raw" [] |> note wf_thms "wf" @{attributes [simp]} |> notes eval_thmss "eval" [] - |> Local_Theory.declaration {syntax = false, pervasive = false} + |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn m => add_infos (map (fn (t,i) => (Morphism.term m t, transform_info i m)) infos)) end | after_qed _ _ = raise Match in Proof.theorem NONE after_qed [map (fn prop => (prop, [])) wf_props] lthy |> Proof.refine_singleton (Method.Basic (SIMPLE_METHOD o tac)) end fun preference_profile_cmd ((agents, alts), argss) lthy = let val read = Syntax.read_term lthy fun read' ty t = Syntax.parse_term lthy t |> Type.constraint ty |> Syntax.check_term lthy val agents' = read agents val alts' = read alts val agentT = agents' |> fastype_of |> dest_Type |> snd |> hd val altT = alts' |> fastype_of |> dest_Type |> snd |> hd fun read_pref_elem ts = map (read' altT) ts fun read_prefs prefs = map read_pref_elem prefs fun prep (binding, args) = (binding, map (fn (agent, prefs) => (read' agentT agent, read_prefs prefs)) args) in preference_profile ((agents', alts'), map prep argss) lthy end val parse_prefs = let val parse_pref_elem = (Args.bracks (Parse.list1 Parse.term)) || Parse.term >> single in Parse.list1 parse_pref_elem end val parse_pref_profile = Parse.binding --| Args.$$$ "=" -- Scan.repeat1 (Parse.term --| Args.colon -- parse_prefs) val _ = Outer_Syntax.local_theory_to_proof @{command_keyword preference_profile} "construct preference profiles from a table" (Args.$$$ "agents" |-- Args.colon |-- Parse.term --| Args.$$$ "alts" --| Args.colon -- Parse.term --| Args.$$$ "where" -- Parse.and_list1 parse_pref_profile >> preference_profile_cmd); end \ end diff --git a/thys/Show/show_generator.ML b/thys/Show/show_generator.ML --- a/thys/Show/show_generator.ML +++ b/thys/Show/show_generator.ML @@ -1,446 +1,446 @@ (* Title: Show Author: Christian Sternagel Author: René Thiemann Maintainer: Christian Sternagel Maintainer: René Thiemann Generate/register show functions for arbitrary types. Precedence is used to determine parenthesization of subexpressions. In the automatically generated functions 0 means "no parentheses" and 1 means "parenthesize". *) signature SHOW_GENERATOR = sig (*generate show functions for the given datatype*) val generate_showsp : string -> local_theory -> local_theory val register_foreign_partial_and_full_showsp : string -> (*type name*) int -> (*default precedence for type parameters*) term -> (*partial show function*) term -> (*show function*) thm option -> (*definition of show function via partial show function*) term -> (*map function*) thm option -> (*compositionality theorem of map function*) bool list -> (*indicate which positions of type parameters are used*) thm -> (*show law intro rule*) local_theory -> local_theory (*for type constants (i.e., nullary type constructors) partial and full show functions coincide and no other information is necessary.*) val register_foreign_showsp : typ -> term -> thm -> local_theory -> local_theory (*automatically derive a "show" class instance for the given datatype*) val show_instance : string -> theory -> theory end structure Show_Generator : SHOW_GENERATOR = struct open Generator_Aux val mk_prec = HOLogic.mk_number @{typ nat} val prec0 = mk_prec 0 val prec1 = mk_prec 1 val showS = @{sort "show"} val showsT = @{typ "shows"} fun showspT T = @{typ nat} --> T --> showsT val showsify_typ = map_atyps (K showsT) val showsify = map_types showsify_typ fun show_law_const T = \<^Const>\show_law T\ fun shows_prec_const T = \<^Const>\shows_prec T\ fun shows_list_const T = \<^Const>\shows_list T\ fun showsp_list_const T = \<^Const>\showsp_list T\ val dest_showspT = binder_types #> tl #> hd type info = {prec : int, pshowsp : term, showsp : term, show_def : thm option, map : term, map_comp : thm option, used_positions : bool list, show_law_intro : thm} structure Data = Generic_Data ( type T = info Symtab.table val empty = Symtab.empty val merge = Symtab.merge (fn (info1, info2) => #pshowsp info1 = #pshowsp info2) ) fun add_info tyco info = Data.map (Symtab.update_new (tyco, info)) val get_info = Context.Proof #> Data.get #> Symtab.lookup fun the_info ctxt tyco = (case get_info ctxt tyco of SOME info => info | NONE => error ("no show function available for type " ^ quote tyco)) fun declare_info tyco p pshow show show_def m m_comp used_pos law_thm = - Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => + Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} (fn phi => add_info tyco {prec = p, pshowsp = Morphism.term phi pshow, showsp = Morphism.term phi show, show_def = Option.map (Morphism.thm phi) show_def, map = Morphism.term phi m, map_comp = Option.map (Morphism.thm phi) m_comp, used_positions = used_pos, show_law_intro = Morphism.thm phi law_thm}) val register_foreign_partial_and_full_showsp = declare_info fun register_foreign_showsp T show = let val tyco = (case T of Type (tyco, []) => tyco | _ => error "expected type constant") in register_foreign_partial_and_full_showsp tyco 0 show show NONE (HOLogic.id_const T) NONE [] end fun shows_string c = \<^Const>\shows_string for \HOLogic.mk_string (Long_Name.base_name c)\\ fun mk_shows_parens _ [t] = t | mk_shows_parens p ts = Library.foldl1 HOLogic.mk_comp (\<^Const>\shows_pl for p\ :: separate \<^Const>\shows_space\ ts @ [\<^Const>\shows_pr for p\]) fun simp_only_tac ctxt ths = CHANGED o full_simp_tac (clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps ths) fun generate_showsp tyco lthy = let val (tycos, Ts) = mutual_recursive_types tyco lthy val _ = map (fn tyco => "generating show function for type " ^ quote tyco) tycos |> cat_lines |> writeln val maps = Bnf_Access.map_terms lthy tycos val map_simps = Bnf_Access.map_simps lthy tycos val map_comps = Bnf_Access.map_comps lthy tycos val (tfrees, used_tfrees) = type_parameters (hd Ts) lthy val used_positions = map (member (op =) used_tfrees o TFree) tfrees val ss = map (subT "show") used_tfrees val show_Ts = map showspT used_tfrees val arg_shows = map Free (ss ~~ show_Ts) val dep_tycos = fold (add_used_tycos lthy) tycos [] fun mk_pshowsp (tyco, T) = ("pshowsp_" ^ Long_Name.base_name tyco, showspT T |> showsify_typ) fun default_show T = absdummy T (mk_id @{typ string}) fun constr_terms lthy = Bnf_Access.constr_terms lthy #> map (apsnd (fst o strip_type) o dest_Const) (* primrec definitions of partial show functions *) fun generate_pshow_eqs lthy (tyco, T) = let val constrs = constr_terms lthy tyco |> map (fn (c, Ts) => let val Ts' = map showsify_typ Ts in (Const (c, Ts' ---> T) |> showsify, Ts') end) fun shows_arg (x, T) = let val m = Generator_Aux.create_map default_show (fn (tyco, T) => fn p => Free (mk_pshowsp (tyco, T)) $ p) prec1 (equal @{typ "shows"}) (#used_positions oo the_info) (#map oo the_info) (curry (op $) o #pshowsp oo the_info) tycos (mk_prec o #prec oo the_info) T lthy val pshow = Generator_Aux.create_partial prec1 (equal @{typ "shows"}) (#used_positions oo the_info) (#map oo the_info) (curry (op $) o #pshowsp oo the_info) tycos (mk_prec o #prec oo the_info) T lthy in pshow $ (m $ Free (x, T)) |> infer_type lthy end fun generate_eq lthy (c, arg_Ts) = let val (p, xs) = Name.variant "p" (Variable.names_of lthy) |>> Free o rpair @{typ nat} ||> (fn ctxt => Name.invent_names ctxt "x" arg_Ts) val lhs = Free (mk_pshowsp (tyco, T)) $ p $ list_comb (c, map Free xs) val rhs = shows_string (dest_Const c |> fst) :: map shows_arg xs |> mk_shows_parens p in HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) end in map (generate_eq lthy) constrs end val eqs = map (generate_pshow_eqs lthy) (tycos ~~ Ts) |> flat val bindings = tycos ~~ Ts |> map mk_pshowsp |> map (fn (name, T) => (Binding.name name, T |> showsify_typ |> SOME, NoSyn)) val ((pshows, pshow_simps), lthy) = lthy |> Local_Theory.begin_nested |> snd |> BNF_LFP_Rec_Sugar.primrec false [] bindings (map (fn t => ((Binding.empty_atts, t), [], [])) eqs) |> Local_Theory.end_nested_result (fn phi => fn (pshows, _, pshow_simps) => (map (Morphism.term phi) pshows, map (Morphism.fact phi) pshow_simps)) (* definitions of show functions via partial show functions and map *) fun generate_show_defs tyco lthy = let val ss = map (subT "show") used_tfrees val arg_Ts = map showspT used_tfrees val arg_shows = map Free (ss ~~ arg_Ts) val p = Name.invent (Variable.names_of lthy) "p" 1 |> the_single |> Free o rpair @{typ nat} val (pshow, m) = AList.lookup (op =) (tycos ~~ (pshows ~~ maps)) tyco |> the val ts = tfrees |> map TFree |> map (fn T => AList.lookup (op =) (used_tfrees ~~ map (fn x => x $ prec1) arg_shows) T |> the_default (default_show T)) val args = arg_shows @ [p] val rhs = HOLogic.mk_comp (pshow $ p, list_comb (m, ts)) |> infer_type lthy val abs_def = fold_rev lambda args rhs val name = "showsp_" ^ Long_Name.base_name tyco val ((showsp, (_, prethm)), lthy) = Local_Theory.define ((Binding.name name, NoSyn), (Binding.empty_atts, abs_def)) lthy val eq = Logic.mk_equals (list_comb (showsp, args), rhs) val thm = Goal.prove_future lthy (map (fst o dest_Free) args) [] eq (K (unfold_tac lthy [prethm])) in Local_Theory.note ((Binding.name (name ^ "_def"), []), [thm]) lthy |>> the_single o snd |>> `(K showsp) end val ((shows, show_defs), lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_show_defs tycos |>> split_list |> Local_Theory.end_nested_result (fn phi => fn (shows, show_defs) => (map (Morphism.term phi) shows, map (Morphism.thm phi) show_defs)) (* alternative simp-rules for show functions *) fun generate_show_simps (tyco, T) lthy = let val constrs = constr_terms lthy tyco |> map (apsnd (map freeify_tvars)) |> map (fn (c, Ts) => (Const (c, Ts ---> T), Ts)) fun shows_arg (x, T) = let fun create_show (T as TFree _) = AList.lookup (op =) (used_tfrees ~~ arg_shows) T |> the | create_show (Type (tyco, Ts)) = (case AList.lookup (op =) (tycos ~~ shows) tyco of SOME show_const => list_comb (show_const, arg_shows) | NONE => let val {showsp = s, used_positions = up, ...} = the_info lthy tyco val ts = (up ~~ Ts) |> map_filter (fn (b, T) => if b then SOME (create_show T) else NONE) in list_comb (s, ts) end) | create_show T = error ("unexpected schematic variable " ^ quote (Syntax.string_of_typ lthy T)) val show = create_show T |> infer_type lthy in show $ prec1 $ Free (x, T) end fun generate_eq_thm lthy (c, arg_Ts) = let val (p, xs) = Name.variant "p" (Variable.names_of lthy) |>> Free o rpair @{typ nat} ||> (fn ctxt => Name.invent_names ctxt "x" arg_Ts) val show_const = AList.lookup (op =) (tycos ~~ shows) tyco |> the val lhs = list_comb (show_const, arg_shows) $ p $ list_comb (c, map Free xs) val rhs = shows_string (dest_Const c |> fst) :: map shows_arg xs |> mk_shows_parens p val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)) |> infer_type lthy val dep_show_defs = map_filter (#show_def o the_info lthy) dep_tycos val dep_map_comps = map_filter (#map_comp o the_info lthy) dep_tycos val thm = Goal.prove_future lthy (fst (dest_Free p) :: map fst xs @ ss) [] eq (fn {context = ctxt, ...} => unfold_tac ctxt (@{thms id_def o_def} @ flat pshow_simps @ dep_map_comps @ show_defs @ dep_show_defs @ flat map_simps)) in thm end val thms = map (generate_eq_thm lthy) constrs val name = "showsp_" ^ Long_Name.base_name tyco in lthy |> Local_Theory.note ((Binding.name (name ^ "_simps"), @{attributes [simp, code]}), thms) |> apfst snd end val (show_simps, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map generate_show_simps (tycos ~~ Ts) |> Local_Theory.end_nested_result (fn phi => map (Morphism.fact phi)) (* show law theorems *) val induct_thms = Bnf_Access.induct_thms lthy tycos val set_simps = Bnf_Access.set_simps lthy tycos val sets = Bnf_Access.set_terms lthy tycos fun generate_show_law_thms (tyco, x) = let val sets = AList.lookup (op =) (tycos ~~ sets) tyco |> the val used_sets = map (the o AList.lookup (op =) (map TFree tfrees ~~ sets)) used_tfrees fun mk_prem ((show, set), T) = let (*val y = singleton (Name.variant_list [fst x]) "y" |> Free o rpair T*) val y = Free (subT "x" T, T) val lhs = HOLogic.mk_mem (y, set $ Free x) |> HOLogic.mk_Trueprop val rhs = show_law_const T $ show $ y |> HOLogic.mk_Trueprop in Logic.all y (Logic.mk_implies (lhs, rhs)) end val prems = map mk_prem (arg_shows ~~ used_sets ~~ used_tfrees) val (show_const, T) = AList.lookup (op =) (tycos ~~ (shows ~~ Ts)) tyco |> the val concl = show_law_const T $ list_comb (show_const, arg_shows) $ Free x |> HOLogic.mk_Trueprop in Logic.list_implies (prems, concl) |> infer_type lthy end val xs = Name.invent_names (Variable.names_of lthy) "x" Ts val show_law_prethms = map generate_show_law_thms (tycos ~~ xs) val rec_info = (the_info lthy, #used_positions, tycos) val split_IHs = split_IHs rec_info val recursor_tac = std_recursor_tac rec_info used_tfrees #show_law_intro fun show_law_tac ctxt xs = let val constr_Ts = tycos |> map (#ctrXs_Tss o #fp_ctr_sugar o the o BNF_FP_Def_Sugar.fp_sugar_of ctxt) val ind_case_to_idxs = let fun number n (i, j) ((_ :: xs) :: ys) = (n, (i, j)) :: number (n + 1) (i, j + 1) (xs :: ys) | number n (i, _) ([] :: ys) = number n (i + 1, 0) ys | number _ _ [] = [] in AList.lookup (op =) (number 0 (0, 0) constr_Ts) #> the end fun instantiate_IHs IHs assms = map (fn IH => OF_option IH (replicate (Thm.nprems_of IH - length assms) NONE @ map SOME assms)) IHs fun induct_tac ctxt f = (DETERM o Induction.induction_tac ctxt false (map (fn x => [SOME (NONE, (x, false))]) xs) [] [] (SOME induct_thms) []) THEN_ALL_NEW (fn st => Subgoal.SUBPROOF (fn {context = ctxt, prems, params, ...} => f ctxt (st - 1) prems params) ctxt st) (*do not use full "show_law_simps" here, since otherwise too many subgoals might be solved (so that the number of subgoals does no longer match the number of IHs)*) val show_law_simps_less = @{thms shows_string_append shows_pl_append shows_pr_append shows_space_append} fun o_append_intro_tac ctxt f = HEADGOAL ( K (Method.try_intros_tac ctxt @{thms o_append} []) THEN_ALL_NEW K (unfold_tac ctxt show_law_simps_less) THEN_ALL_NEW (fn i => Subgoal.SUBPROOF (fn {context = ctxt', ...} => f (i - 1) ctxt') ctxt i)) fun solve_tac ctxt case_num prems params = let val (i, _) = ind_case_to_idxs case_num (*(constructor number, argument number)*) val k = length prems - length used_tfrees val (IHs, assms) = chop k prems in resolve_tac ctxt @{thms show_lawI} 1 THEN Subgoal.FOCUS (fn {context = ctxt, ...} => let val assms = map (Local_Defs.unfold ctxt (nth set_simps i)) assms val Ts = map (fastype_of o Thm.term_of o snd) params val IHs = instantiate_IHs IHs assms |> split_IHs Ts in unfold_tac ctxt (nth show_simps i) THEN o_append_intro_tac ctxt (fn i => fn ctxt' => resolve_tac ctxt' @{thms show_lawD} 1 THEN recursor_tac assms (nth Ts i) (nth IHs i) ctxt') end) ctxt 1 end in induct_tac ctxt solve_tac end val show_law_thms = prove_multi_future lthy (map fst xs @ ss) [] show_law_prethms (fn {context = ctxt, ...} => HEADGOAL (show_law_tac ctxt (map Free xs))) val (show_law_thms, lthy) = lthy |> Local_Theory.begin_nested |> snd |> fold_map (fn (tyco, thm) => Local_Theory.note ((Binding.name ("show_law_" ^ Long_Name.base_name tyco), @{attributes [show_law_intros]}), [thm]) #> apfst (the_single o snd)) (tycos ~~ show_law_thms) |> Local_Theory.end_nested_result Morphism.fact in lthy |> fold (fn ((((((tyco, pshow), show), show_def), m), m_comp), law_thm) => declare_info tyco 1 pshow show (SOME show_def) m (SOME m_comp) used_positions law_thm) (tycos ~~ pshows ~~ shows ~~ show_defs ~~ maps ~~ map_comps ~~ show_law_thms) end fun ensure_info tyco lthy = (case get_info lthy tyco of SOME _ => lthy | NONE => generate_showsp tyco lthy) (* proving show instances *) fun dest_showsp showsp = dest_Const showsp ||> ( binder_types #> chop_prefix (fn T => T <> @{typ nat}) #>> map (freeify_tvars o dest_showspT) ##> map (dest_TFree o freeify_tvars) o snd o dest_Type o hd o tl) fun show_instance tyco thy = let val _ = Sorts.has_instance (Sign.classes_of thy) tyco showS andalso error ("type " ^ quote tyco ^ " is already an instance of class \"show\"") val _ = writeln ("deriving \"show\" instance for type " ^ quote tyco) val thy = Named_Target.theory_map (ensure_info tyco) thy val lthy = Named_Target.theory_init thy val {showsp, ...} = the_info lthy tyco val (showspN, (used_tfrees, tfrees)) = dest_showsp showsp val tfrees' = tfrees |> map (fn (x, S) => if member (op =) used_tfrees (TFree (x, S)) then (x, showS) else (x, S)) val used_tfrees' = map (dest_TFree #> fst #> rpair showS #> TFree) used_tfrees val T = Type (tyco, map TFree tfrees') val arg_Ts = map showspT used_tfrees' val showsp' = Const (showspN, arg_Ts ---> showspT T) val shows_prec_def = Logic.mk_equals (shows_prec_const T, list_comb (showsp', map shows_prec_const used_tfrees')) val shows_list_def = Logic.mk_equals (shows_list_const T, showsp_list_const T $ shows_prec_const T $ prec0) val name = Long_Name.base_name tyco val ((shows_prec_thm, shows_list_thm), lthy) = Class.instantiation ([tyco], tfrees', showS) thy |> Generator_Aux.define_overloaded_generic ((Binding.name ("shows_prec_" ^ name ^ "_def"), @{attributes [code]}), shows_prec_def) ||>> Generator_Aux.define_overloaded_generic ((Binding.name ("shows_list_" ^ name ^ "_def"), @{attributes [code]}), shows_list_def) in Class.prove_instantiation_exit (fn ctxt => let val show_law_intros = Named_Theorems.get ctxt @{named_theorems "show_law_intros"} val show_law_simps = Named_Theorems.get ctxt @{named_theorems "show_law_simps"} val show_append_tac = resolve_tac ctxt @{thms show_lawD} THEN' REPEAT_ALL_NEW (resolve_tac ctxt show_law_intros) THEN_ALL_NEW ( resolve_tac ctxt @{thms show_lawI} THEN' simp_only_tac ctxt show_law_simps) in Class.intro_classes_tac ctxt [] THEN unfold_tac ctxt [shows_prec_thm, shows_list_thm] THEN REPEAT1 (HEADGOAL show_append_tac) end) lthy end val _ = Theory.setup (Derive_Manager.register_derive "show" "generate show instance" (K o show_instance)) end diff --git a/thys/Simpl/hoare.ML b/thys/Simpl/hoare.ML --- a/thys/Simpl/hoare.ML +++ b/thys/Simpl/hoare.ML @@ -1,3403 +1,3403 @@ (* Title: hoare.ML Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2007 Norbert Schirmer This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) signature HOARE = sig datatype hoareMode = Partial | Total val gen_proc_rec: Proof.context -> hoareMode -> int -> thm datatype state_kind = Record | Function datatype par_kind = In | Out val deco: string val proc_deco: string val par_deco: string -> string val chopsfx: string -> string -> string val is_state_var: string -> bool val extern: Proof.context -> string -> string val remdeco: Proof.context -> string -> string val remdeco': string -> string val undeco: Proof.context -> term -> term val varname: string -> string val resuffix: string -> string -> string -> string type proc_info = {params: ((par_kind * string) list), recursive: bool, state_kind: state_kind} type hoare_tac = (bool -> int -> tactic) -> Proof.context -> hoareMode -> int -> tactic type hoare_data = {proc_info: proc_info Symtab.table, active_procs: string list list, default_state_kind: state_kind, generate_guard: (stamp * (Proof.context -> term -> term option)), wp_tacs: (string * hoare_tac) list, hoare_tacs: (string * hoare_tac) list, vcg_simps: thm list} val get_data: Proof.context -> hoare_data val get_params: string -> Proof.context -> (par_kind * string) list option val get_default_state_kind: Proof.context -> state_kind val get_state_kind: string -> Proof.context -> state_kind option val clique_name: string list -> string val install_generate_guard: (Proof.context -> term -> term option) -> Context.generic -> Context.generic val generate_guard: Proof.context -> term -> term option val BasicSimpTac: Proof.context -> state_kind -> bool -> thm list -> (int -> tactic) -> int -> tactic val hoare: (Proof.context -> Proof.method) context_parser val hoare_raw: (Proof.context -> Proof.method) context_parser val vcg: (Proof.context -> Proof.method) context_parser val vcg_step: (Proof.context -> Proof.method) context_parser val hoare_rule: (Proof.context -> Proof.method) context_parser val add_foldcongsimps: thm list -> theory -> theory val get_foldcong_ss : theory -> simpset val add_foldcongs : thm list -> theory -> theory val modeqN : string val modexN : string val implementationN : string val specL : string val vcg_tac : string -> string -> string list -> Proof.context -> int -> tactic val hoare_rule_tac : Proof.context -> thm list -> int -> tactic datatype 'a bodykind = BodyTyp of 'a | BodyTerm of 'a val proc_specs : (bstring * string) list parser val add_params : morphism -> string -> (par_kind * string) list -> Context.generic -> Context.generic val set_default_state_kind : state_kind -> Context.generic -> Context.generic val add_state_kind : morphism -> string -> state_kind -> Context.generic -> Context.generic val add_recursive : morphism -> string -> Context.generic -> Context.generic end; structure Hoare: HOARE = struct (* Misc *) val record_vanish = Attrib.setup_config_bool @{binding hoare_record_vanish} (K true); val use_generalise = Attrib.setup_config_bool @{binding hoare_use_generalise} (K false); val sort_variables = Attrib.setup_config_bool @{binding hoare_sort_variables} (K true); val use_cond_inv_modifies = Attrib.setup_config_bool @{binding hoare_use_cond_inv_modifies} (K true); val hoare_trace = Attrib.setup_config_bool @{binding hoare_trace} (K false); val body_def_sfx = "_body"; val programN = "\"; val hoare_ctxtL = "hoare"; val specL = "_spec"; val procL = "_proc"; val bodyP = "_impl"; val modifysfx = "_modifies"; val modexN = "Hoare.mex"; val modeqN = "Hoare.meq"; val KNF = @{const_name StateFun.K_statefun}; (* Some abstract syntax operations *) val Trueprop = HOLogic.mk_Trueprop; infix 0 ===; val (op ===) = Trueprop o HOLogic.mk_eq; fun is_empty_set (Const (@{const_name Orderings.bot}, _)) = true | is_empty_set _ = false; fun mk_Int Ts A B = let val T = fastype_of1 (Ts, A) in Const (@{const_name Lattices.inf}, T --> T --> T) $ A $ B end; fun mk_Un T (A, B) = Const (@{const_name Lattices.sup}, T --> T --> T) $ A $ B; fun dest_Un (Const (@{const_name Lattices.sup}, _) $ t1 $ t2) = dest_Un t1 @ dest_Un t2 | dest_Un t = [t] fun mk_UN' dT rT t = let val dTs = HOLogic.mk_setT dT; val rTs = HOLogic.mk_setT rT; in Const (@{const_name Complete_Lattices.Sup}, rTs --> rT) $ (Const (@{const_name image}, (dT --> rT) --> dTs --> rTs) $ t $ Const (@{const_name Orderings.top}, dTs)) end; fun mk_UN ((x, T), P) = mk_UN' T (fastype_of P) (absfree (x, T) P); fun dest_UN (Const (@{const_name Complete_Lattices.Sup}, _) $ (Const (@{const_name Set.image}, _) $ Abs (x, T, t) $ Const (@{const_name Orderings.top}, _))) = let val (vars, body) = dest_UN t in ((x, T) :: vars, body) end | dest_UN t = ([], t); fun tap_UN (Const (@{const_name Complete_Lattices.Sup}, _) $ (Const (@{const_name Set.image}, _) $ t $ Const (@{const_name Orderings.top}, _))) = SOME t | tap_UN _ = NONE; (* Fetching the rules *) datatype hoareMode = Partial | Total fun get_rule p t Partial = p | get_rule p t Total = t val Guard = get_rule @{thm HoarePartial.Guard} @{thm HoareTotal.Guard}; val GuardStrip = get_rule @{thm HoarePartial.GuardStrip} @{thm HoareTotal.GuardStrip}; val GuaranteeAsGuard = get_rule @{thm HoarePartial.GuaranteeAsGuard} @{thm HoareTotal.GuaranteeAsGuard}; val Guarantee = get_rule @{thm HoarePartial.Guarantee} @{thm HoareTotal.Guarantee}; val GuaranteeStrip = get_rule @{thm HoarePartial.GuaranteeStrip} @{thm HoareTotal.GuaranteeStrip}; val GuardsNil = get_rule @{thm HoarePartial.GuardsNil} @{thm HoareTotal.GuardsNil}; val GuardsCons = get_rule @{thm HoarePartial.GuardsCons} @{thm HoareTotal.GuardsCons}; val GuardsConsGuaranteeStrip = get_rule @{thm HoarePartial.GuardsConsGuaranteeStrip} @{thm HoareTotal.GuardsConsGuaranteeStrip}; val Skip = get_rule @{thm HoarePartial.Skip} @{thm HoareTotal.Skip}; val Basic = get_rule @{thm HoarePartial.Basic} @{thm HoareTotal.Basic}; val BasicCond = get_rule @{thm HoarePartial.BasicCond} @{thm HoareTotal.BasicCond}; val Spec = get_rule @{thm HoarePartial.Spec} @{thm HoareTotal.Spec}; val SpecIf = get_rule @{thm HoarePartial.SpecIf} @{thm HoareTotal.SpecIf}; val Throw = get_rule @{thm HoarePartial.Throw} @{thm HoareTotal.Throw}; val Raise = get_rule @{thm HoarePartial.raise} @{thm HoareTotal.raise}; val Catch = get_rule @{thm HoarePartial.Catch} @{thm HoareTotal.Catch}; val CondCatch = get_rule @{thm HoarePartial.condCatch} @{thm HoareTotal.condCatch}; val CatchSwap = get_rule @{thm HoarePartial.CatchSwap} @{thm HoareTotal.CatchSwap}; val CondCatchSwap = get_rule @{thm HoarePartial.condCatchSwap} @{thm HoareTotal.condCatchSwap}; val Seq = get_rule @{thm HoarePartial.Seq} @{thm HoareTotal.Seq}; val SeqSwap = get_rule @{thm HoarePartial.SeqSwap} @{thm HoareTotal.SeqSwap}; val BSeq = get_rule @{thm HoarePartial.BSeq} @{thm HoareTotal.BSeq}; val Cond = get_rule @{thm HoarePartial.Cond} @{thm HoareTotal.Cond}; val CondInv'Partial = @{thm HoarePartial.CondInv'}; val CondInv'Total = @{thm HoareTotal.CondInv'}; val CondInv' = get_rule CondInv'Partial CondInv'Total; val SwitchNil = get_rule @{thm HoarePartial.switchNil} @{thm HoareTotal.switchNil}; val SwitchCons = get_rule @{thm HoarePartial.switchCons} @{thm HoareTotal.switchCons}; val CondSwap = get_rule @{thm HoarePartial.CondSwap} @{thm HoareTotal.CondSwap}; val While = get_rule @{thm HoarePartial.While} @{thm HoareTotal.While}; val WhileAnnoG = get_rule @{thm HoarePartial.WhileAnnoG} @{thm HoareTotal.WhileAnnoG}; val WhileAnnoFix = get_rule @{thm HoarePartial.WhileAnnoFix'} @{thm HoareTotal.WhileAnnoFix'}; val WhileAnnoGFix = get_rule @{thm HoarePartial.WhileAnnoGFix} @{thm HoareTotal.WhileAnnoGFix}; val BindR = get_rule @{thm HoarePartial.Bind} @{thm HoareTotal.Bind}; val Block = get_rule @{thm HoarePartial.Block} @{thm HoareTotal.Block}; val BlockSwap = get_rule @{thm HoarePartial.BlockSwap} @{thm HoareTotal.BlockSwap}; val Proc = get_rule @{thm HoarePartial.ProcSpec} @{thm HoareTotal.ProcSpec}; val ProcNoAbr = get_rule @{thm HoarePartial.ProcSpecNoAbrupt} @{thm HoareTotal.ProcSpecNoAbrupt}; val ProcBody = get_rule @{thm HoarePartial.ProcBody} @{thm HoareTotal.ProcBody}; val CallBody = get_rule @{thm HoarePartial.CallBody} @{thm HoareTotal.CallBody}; val FCall = get_rule @{thm HoarePartial.FCall} @{thm HoareTotal.FCall}; val ProcRecSpecs = get_rule @{thm HoarePartial.ProcRecSpecs} @{thm HoareTotal.ProcRecSpecs}; val ProcModifyReturnSameFaults = get_rule @{thm HoarePartial.ProcModifyReturnSameFaults} @{thm HoareTotal.ProcModifyReturnSameFaults}; val ProcModifyReturn = get_rule @{thm HoarePartial.ProcModifyReturn} @{thm HoareTotal.ProcModifyReturn}; val ProcModifyReturnNoAbr = get_rule @{thm HoarePartial.ProcModifyReturnNoAbr} @{thm HoareTotal.ProcModifyReturnNoAbr}; val ProcModifyReturnNoAbrSameFaultsPartial = @{thm HoarePartial.ProcModifyReturnNoAbrSameFaults}; val ProcModifyReturnNoAbrSameFaultsTotal = @{thm HoareTotal.ProcModifyReturnNoAbrSameFaults}; val ProcModifyReturnNoAbrSameFaults = get_rule ProcModifyReturnNoAbrSameFaultsPartial ProcModifyReturnNoAbrSameFaultsTotal; val TrivPost = get_rule @{thm HoarePartial.TrivPost} @{thm HoareTotal.TrivPost}; val TrivPostNoAbr = get_rule @{thm HoarePartial.TrivPostNoAbr} @{thm HoareTotal.TrivPostNoAbr}; val DynProcProcPar = get_rule @{thm HoarePartial.DynProcProcPar} @{thm HoareTotal.DynProcProcPar}; val DynProcProcParNoAbr = get_rule @{thm HoarePartial.DynProcProcParNoAbrupt} @{thm HoareTotal.DynProcProcParNoAbrupt}; val ProcProcParModifyReturn = get_rule @{thm HoarePartial.ProcProcParModifyReturn} @{thm HoareTotal.ProcProcParModifyReturn}; val ProcProcParModifyReturnSameFaultsPartial = @{thm HoarePartial.ProcProcParModifyReturnSameFaults}; val ProcProcParModifyReturnSameFaultsTotal = @{thm HoareTotal.ProcProcParModifyReturnSameFaults}; val ProcProcParModifyReturnSameFaults = get_rule ProcProcParModifyReturnSameFaultsPartial ProcProcParModifyReturnSameFaultsTotal; val ProcProcParModifyReturnNoAbr = get_rule @{thm HoarePartial.ProcProcParModifyReturnNoAbr} @{thm HoareTotal.ProcProcParModifyReturnNoAbr}; val ProcProcParModifyReturnNoAbrSameFaultsPartial = @{thm HoarePartial.ProcProcParModifyReturnNoAbrSameFaults}; val ProcProcParModifyReturnNoAbrSameFaultsTotal = @{thm HoareTotal.ProcProcParModifyReturnNoAbrSameFaults}; val ProcProcParModifyReturnNoAbrSameFaults = get_rule ProcProcParModifyReturnNoAbrSameFaultsPartial ProcProcParModifyReturnNoAbrSameFaultsTotal; val DynCom = get_rule @{thm HoarePartial.DynComConseq} @{thm HoareTotal.DynComConseq}; val AugmentContext = get_rule @{thm HoarePartial.augment_context'} @{thm HoareTotal.augment_context'}; val AugmentEmptyFaults = get_rule @{thm HoarePartial.augment_emptyFaults} @{thm HoareTotal.augment_emptyFaults}; val AsmUN = get_rule @{thm HoarePartial.AsmUN} @{thm HoareTotal.AsmUN}; val SpecAnno = get_rule @{thm HoarePartial.SpecAnno'} @{thm HoareTotal.SpecAnno'}; val SpecAnnoNoAbrupt = get_rule @{thm HoarePartial.SpecAnnoNoAbrupt} @{thm HoareTotal.SpecAnnoNoAbrupt}; val LemAnno = get_rule @{thm HoarePartial.LemAnno} @{thm HoareTotal.LemAnno}; val LemAnnoNoAbrupt = get_rule @{thm HoarePartial.LemAnnoNoAbrupt} @{thm HoareTotal.LemAnnoNoAbrupt}; val singleton_conv_sym = @{thm Set.singleton_conv2} RS sym; val anno_defs = [@{thm Language.whileAnno_def},@{thm Language.whileAnnoG_def},@{thm Language.specAnno_def}, @{thm Language.whileAnnoGFix_def},@{thm Language.whileAnnoFix_def},@{thm Language.lem_def}]; val strip_simps = @{thm Language.strip_simp} :: @{thm Option.option.map(2)} :: @{thms Language.strip_guards_simps}; val normalize_simps = [@{thm Language.while_def}, @{thm Language.bseq_def}, @{thm List.append_Nil}, @{thm List.append_Cons}] @ @{thms List.list.cases} @ @{thms Language.flatten_simps} @ @{thms Language.sequence.simps} @ @{thms Language.normalize_simps} @ @{thms Language.guards.simps} @ [@{thm fst_conv}, @{thm snd_conv}]; val K_rec_convs = []; val K_fun_convs = [@{thm StateFun.K_statefun_apply}, @{thm StateFun.K_statefun_comp}]; val K_convs = K_rec_convs @ K_fun_convs; val K_rec_congs = []; val K_fun_congs = [@{thm StateFun.K_statefun_cong}]; val K_congs = K_rec_congs @ K_fun_congs; (* misc. aux. functions *) (* first_subterm * yields result x of P for first subterm for which P is (SOME x), and all bound variables on the path * to that term *) fun first_subterm_dest P = let fun first abs_vars t = (case P t of SOME x => SOME (abs_vars,x) |_=> (case t of u $ v => (case first abs_vars u of NONE => first abs_vars v | SOME x => SOME x) | Abs (c,T,u) => first (abs_vars @ [(c,T)]) u | _ => NONE)) in first [] end; (* first_subterm * yields first subterm for which P holds, and all bound variables on the path * to that term *) fun first_subterm P = let fun P' t = if P t then SOME t else NONE; in first_subterm_dest P' end; (* max_subterm_dest * yields results of P for all maximal subterms for which P is (SOME x), * and all bound variables on the path to that subterm *) fun max_subterms_dest P = let fun collect abs_vars t = (case P t of SOME x => [(abs_vars,x)] |_=> (case t of u $ v => collect abs_vars u @ collect abs_vars v | Abs (c,T,u) => collect (abs_vars @ [(c,T)]) u | _ => [])) in collect [] end; fun last [] = raise Empty | last [x] = x | last (_::xs) = last xs; fun dest_splits (Const (@{const_name case_prod},_)$Abs (n,T,t)) = (n,T)::dest_splits t | dest_splits (Const (@{const_name case_prod},_)$Abs (n,T,t)$_) = (n,T)::dest_splits t | dest_splits (Abs (n,T,_)) = [(n,T)] | dest_splits _ = []; fun idx eq [] x = ~1 | idx eq (x::rs) y = if eq x y then 0 else let val i = idx eq rs y in if i < 0 then i else i+1 end; fun resuffix sfx1 sfx2 s = suffix sfx2 (unsuffix sfx1 s) handle Fail _ => s; (* state space representation dependent functions *) datatype state_kind = Record | Function fun state_simprocs Record = [Record.simproc] | state_simprocs Function = [Record.simproc, StateFun.lookup_simproc]; fun state_upd_simproc Record = Record.upd_simproc | state_upd_simproc Function = StateFun.update_simproc; fun state_ex_sel_eq_simproc Record = Record.ex_sel_eq_simproc | state_ex_sel_eq_simproc Function = StateFun.ex_lookup_eq_simproc; val state_split_simp_tac = Record.split_simp_tac val state_hierarchy = Record.dest_recTs fun stateT_id T = case (state_hierarchy T) of [] => NONE | Ts => SOME (last Ts); fun globalsT (Type (_, T :: _)) = SOME T | globalsT _ = NONE; fun stateT_ids T = (case stateT_id T of NONE => NONE | SOME sT => (case globalsT T of NONE => SOME [sT] | SOME gT => (case stateT_id gT of NONE => SOME [sT] | SOME gT' => SOME [sT,gT']))); datatype par_kind = In | Out (*** utilities ***) (* utils for variable name decorations *) val deco = "_'"; val proc_deco = "_'proc"; fun par_deco name = deco ^ name ^ deco; fun chopsfx sfx str = (case try (unsuffix sfx) str of SOME s => s | NONE => str) val is_state_var = can (unsuffix deco); (* removes the suffix of the string beginning with deco. * "xys_'a" --> "xys"; * The a is also chopped, since sometimes the bound variables * are renamed, I think SELECT_GOAL in rename_goal is to blame *) fun remdeco' str = let fun chop (p::ps) (x::xs) = chop ps xs | chop [] xs = [] | chop (p::ps) [] = error "remdeco: code should never be reached"; fun remove prf (s as (x::xs)) = if is_prefix (op =) prf s then chop prf s else (x::remove prf xs) | remove prf [] = []; in String.implode (remove (String.explode deco) (String.explode str)) end; fun extern ctxt s = (case try (Proof_Context.extern_const ctxt o Lexicon.unmark_const) s of NONE => s | SOME s' => s'); fun remdeco ctxt s = remdeco' (extern ctxt s); fun undeco ctxt (Const (c, T)) = Const (remdeco ctxt c, T) | undeco ctxt ((f as Const (@{syntax_const "_free"},_)) $ Free (x, T)) = (*f$*)Const (remdeco' x, T) | undeco ctxt (Const _ $ _ $ ((Const (@{syntax_const "_free"},_)) $ Free (x, T))) = (*f$*)Const (remdeco' x, T) | undeco ctxt (Free (c, T)) = Const (remdeco' c, T) | undeco ctxt x = x fun varname x = x ^ deco val dest_string = map (chr o HOLogic.dest_char) o HOLogic.dest_list; fun dest_string' t = (case try dest_string t of SOME s => implode s | NONE => (case t of Free (s,_) => s | Const (s,_) => Long_Name.base_name s | _ => raise TERM ("dest_string'",[t]))) fun is_state_space_var Tids t = let fun is_stateT T = (case stateT_id T of NONE => 0 | SOME id => if member (op =) Tids id then ~1 else 0); in (case t of Const _ $ Abs (_,T,_) => is_stateT T | Free (_,T) => is_stateT T | _ => 0) end; datatype callMode = Static | Parameter fun proc_name Static (Const (p,_)$_) = resuffix deco proc_deco (Long_Name.base_name p) | proc_name Static (Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_) = suffix proc_deco (remdeco' (Long_Name.base_name p)) | proc_name Static p = dest_string' p | proc_name Parameter (Const (p,_)) = resuffix deco proc_deco (Long_Name.base_name p) | proc_name Parameter (Abs (_,_,Const (p,_)$Bound 0)) = resuffix deco proc_deco (Long_Name.base_name p) | proc_name Parameter (Abs (_,_,Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_)) = suffix proc_deco (remdeco' (Long_Name.base_name p)) | proc_name _ t = raise TERM ("proc_name",[t]); fun dest_call (Const (@{const_name Language.call},_)$init$pname$return$c) = (init,pname,return,c,Static,true) | dest_call (Const (@{const_name Language.fcall},_)$init$pname$return$_$c) = (init,pname,return,c,Static,true) | dest_call (Const (@{const_name Language.com.Call},_)$pname) = (Bound 0,pname,Bound 0,Bound 0,Static,false) | dest_call (Const (@{const_name Language.dynCall},_)$init$pname$return$c) = (init,pname,return,c,Parameter,true) | dest_call t = raise TERM ("Hoare.dest_call: unexpected term",[t]); fun dest_whileAnno (Const (@{const_name Language.whileAnnoG},_) $gs$b$I$V$c) = (SOME gs,b,I,V,c,false) | dest_whileAnno (Const (@{const_name Language.whileAnno},_) $b$I$V$c) = (NONE,b,I,V,c,false) | dest_whileAnno (Const (@{const_name Language.whileAnnoGFix},_)$gs$b$I$V$c) = (SOME gs,b,I,V,c,true) | dest_whileAnno (Const (@{const_name Language.whileAnnoFix},_) $b$I$V$c) = (NONE,b,I,V,c,true) | dest_whileAnno t = raise TERM ("Hoare.dest_while: unexpected term",[t]); fun dest_Guard (Const (@{const_name Language.com.Guard},_)$f$g$c) = (f,g,c,false) | dest_Guard (Const (@{const_name Language.guaranteeStrip},_)$f$g$c) = (f,g,c,true) | dest_Guard t = raise TERM ("Hoare.dest_guard: unexpected term",[t]); (*** extend theory by procedure definition ***) fun add_declaration name decl thy = thy |> Named_Target.init [] name - |> Local_Theory.declaration {syntax = false, pervasive = false} decl + |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} decl |> Local_Theory.exit |> Proof_Context.theory_of; (* data kind 'HOL/hoare' *) type proc_info = {params: ((par_kind * string) list), recursive: bool, state_kind: state_kind} type hoare_tac = (bool -> int -> tactic) -> Proof.context -> hoareMode -> int -> tactic; type hoare_data = {proc_info: proc_info Symtab.table, active_procs: string list list, default_state_kind: state_kind, generate_guard: (stamp * (Proof.context -> term -> term option)), wp_tacs: (string * hoare_tac) list, hoare_tacs: (string * hoare_tac) list, vcg_simps: thm list}; fun make_hoare_data proc_info active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps = {proc_info = proc_info, active_procs = active_procs, default_state_kind = default_state_kind, generate_guard = generate_guard, wp_tacs = wp_tacs, hoare_tacs = hoare_tacs, vcg_simps = vcg_simps}; structure Hoare_Data = Generic_Data ( type T = hoare_data; val empty = make_hoare_data (Symtab.empty: proc_info Symtab.table) ([]:string list list) (Function) (stamp (),(K (K NONE)): Proof.context -> term -> term option) ([]:(string * hoare_tac) list) ([]:(string * hoare_tac) list) ([]:thm list); (* FIXME exponential blowup due to append !? *) fun merge ({proc_info = proc_info1, active_procs = active_procs1, default_state_kind = _, generate_guard = (stmp1,generate_gaurd1), wp_tacs = wp_tacs1, hoare_tacs = hoare_tacs1, vcg_simps = vcg_simps1}, {proc_info = proc_info2, active_procs = active_procs2, default_state_kind = default_state_kind2, generate_guard = (stmp2, _), wp_tacs = wp_tacs2, hoare_tacs = hoare_tacs2, vcg_simps=vcg_simps2}) : T = if stmp1=stmp2 then make_hoare_data (Symtab.merge (K true) (proc_info1,proc_info2)) (active_procs1 @ active_procs2) (default_state_kind2) (stmp1,generate_gaurd1) (wp_tacs1 @ wp_tacs2) (hoare_tacs1 @ hoare_tacs2) (Thm.merge_thms (vcg_simps1,vcg_simps2)) else error ("Theories have different aux. functions to generate guards") ); val get_data = Hoare_Data.get o Context.Proof; (* access 'params' *) fun mk_free context name = let val ctxt = Context.proof_of context; val n' = Variable.intern_fixed ctxt name |> perhaps Long_Name.dest_hidden; val T' = Proof_Context.infer_type ctxt (n', dummyT) handle ERROR _ => dummyT in (Free (n',T')) end; fun morph_name context phi name = (case Morphism.term phi (mk_free context name) of Free (x,_) => x | _ => name); datatype 'a bodykind = BodyTyp of 'a | BodyTerm of 'a fun set_default_state_kind sk context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs sk generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; val get_default_state_kind = #default_state_kind o get_data; fun add_active_procs phi ps context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info ((map (morph_name context phi) ps)::active_procs) default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun add_hoare_tacs tacs context = let val {proc_info,active_procs, default_state_kind, generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind generate_guard wp_tacs (hoare_tacs@tacs) vcg_simps; in Hoare_Data.put data context end; fun map_vcg_simps f context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind generate_guard wp_tacs hoare_tacs (f vcg_simps); in Hoare_Data.put data context end; fun thy_attrib f = Thm.declaration_attribute (fn thm => map_vcg_simps (f thm)); val vcg_simpadd = Thm.add_thm val vcg_simpdel = Thm.del_thm val vcg_simp_add = thy_attrib vcg_simpadd; val vcg_simp_del = thy_attrib vcg_simpdel; (* add 'procedure' *) fun mk_proc_info params recursive state_kind = {params=params,recursive=recursive,state_kind=state_kind}; val empty_proc_info = {params=[],recursive=false,state_kind=Record}; fun map_proc_info_params f {params,recursive,state_kind} = mk_proc_info (f params) recursive state_kind; fun map_proc_info_recursive f {params,recursive,state_kind} = mk_proc_info params (f recursive) state_kind; fun map_proc_info_state_kind f {params,recursive,state_kind} = mk_proc_info params recursive (f state_kind); fun add_params phi name frmls context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val params = map (apsnd (morph_name context phi)) frmls; val f = map_proc_info_params (K params); val default = f empty_proc_info; val proc_info' = Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun get_params name ctxt = Option.map #params (Symtab.lookup (#proc_info (get_data ctxt)) name); fun add_recursive phi name context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val f = map_proc_info_recursive (K true); val default = f empty_proc_info; val proc_info'= Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun get_recursive name ctxt = Option.map #recursive (Symtab.lookup (#proc_info (get_data ctxt)) name); fun add_state_kind phi name sk context = let val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val f = map_proc_info_state_kind (K sk); val default = f empty_proc_info; val proc_info'= Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind generate_guard wp_tacs hoare_tacs vcg_simps; in Hoare_Data.put data context end; fun get_state_kind name ctxt = Option.map #state_kind (Symtab.lookup (#proc_info (get_data ctxt)) name); fun install_generate_guard f context = let val {proc_info,active_procs, default_state_kind, generate_guard,wp_tacs,hoare_tacs, vcg_simps,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind (stamp (), f) wp_tacs hoare_tacs vcg_simps in Hoare_Data.put data context end; fun generate_guard ctxt = snd (#generate_guard (get_data ctxt)) ctxt; fun check_procedures_definition procs thy = let val ctxt = Proof_Context.init_global thy; fun already_defined name = if is_some (get_params name ctxt) then ["procedure " ^ quote name ^ " already defined"] else [] val err_already_defined = maps (already_defined o #1) procs; fun duplicate_procs names = (case duplicates (op =) names of [] => [] | dups => ["Duplicate procedures " ^ commas_quote dups]); val err_duplicate_procs = duplicate_procs (map #1 procs); fun duplicate_pars name pars = (case duplicates (op =) (map fst pars) of [] => [] | dups => ["Duplicate parameters in procedure " ^ quote name ^ ": " ^ commas_quote dups]); val err_duplicate_pars = maps (fn (name,inpars,outpars,locals,_,_,_) => duplicate_pars name (inpars @ locals) @ duplicate_pars name (outpars @ locals)) procs; (* FIXME: Check that no global variables are used as result parameters *) val errs = err_already_defined @ err_duplicate_procs @ err_duplicate_pars; in if null errs then () else error (cat_lines errs) end; fun add_parameter_info phi cname (name,(inpars,outpars,state_kind)) context = let fun par_deco' T = if T = "" then deco else par_deco (cname name); val pars = map (fn (par,T) => (In,suffix (par_deco' T) par)) inpars@ map (fn (par,T) => (Out,suffix (par_deco' T) par)) outpars; in context |> add_params phi name pars |> add_state_kind phi name state_kind end; fun mk_loc_exp xs = let fun mk_expr s = (s,(("",false),(Expression.Named [],[]))) in (map mk_expr xs,[]) end; val parametersN = "_parameters"; val variablesN = "_variables"; val signatureN = "_signature"; val bodyN = "_body"; val implementationN = "_impl"; val cliqueN = "_clique"; val clique_namesN = "_clique_names"; val NoBodyN = @{const_name Vcg.NoBody}; val statetypeN = "StateType"; val proc_nameT = HOLogic.stringT; fun expression_no_pos (expr, fixes) : Expression.expression = (map (fn (name, inst) => ((name, Position.none), inst)) expr, fixes); fun add_locale name expr elems thy = thy |> Expression.add_locale (Binding.name name) (Binding.name name) [] expr elems |> snd |> Local_Theory.exit; fun add_locale' name expr elems thy = thy |> Expression.add_locale (Binding.name name) (Binding.name name) [] expr elems ||> Local_Theory.exit; fun add_locale_cmd name expr elems thy = thy |> Expression.add_locale_cmd (Binding.name name) (Binding.name name) [] (expression_no_pos expr) elems |> snd |> Local_Theory.exit; fun read_typ thy raw_T env = let val ctxt' = Proof_Context.init_global thy |> fold (Variable.declare_typ o TFree) env; val T = Syntax.read_typ ctxt' raw_T; val env' = Term.add_tfreesT T env; in (T, env') end; fun add_variable_statespaces (cname, (inpars, outpars, locvars)) thy = let val inpars' = if forall (fn (_,T) => T = "") inpars then [] else inpars; val outpars' = if forall (fn (_,T) => T = "") outpars then [] else outpars; fun prep_comp (n, T) env = let val (T', env') = read_typ thy T env handle ERROR msg => cat_error msg ("The error(s) above occurred in component " ^ quote n) in ((n, T'), env') end; val (in_outs,in_out_env) = fold_map prep_comp (distinct (op =) (inpars'@outpars')) []; val (locs,var_env) = fold_map prep_comp locvars in_out_env; val parSP = cname ^ parametersN; val in_outs' = map (apfst (suffix (par_deco cname))) in_outs; val in_out_args = map fst in_out_env; val varSP = cname ^ variablesN; val locs' = map (apfst (suffix (par_deco cname))) locs; val var_args = map fst var_env; in if null inpars' andalso null outpars' andalso null locvars then thy |> add_locale_cmd parSP ([],[]) [] |> Proof_Context.theory_of |> add_locale_cmd varSP ([],[]) [] |> Proof_Context.theory_of else thy |> StateSpace.define_statespace_i (SOME statetypeN) in_out_args parSP [] in_outs' |> StateSpace.define_statespace_i (SOME statetypeN) var_args varSP [((cname, false), ((map TFree in_out_env),parSP,[]))] locs' end; fun intern_locale thy = Locale.intern thy #> perhaps Long_Name.dest_hidden; fun apply_in_context thy lexp f t = let fun name_variant lname = if intern_locale thy lname = lname then lname else name_variant (lname ^ "'"); in thy (* Create a dummy locale in dummy theory just to read the term *) |> add_locale_cmd (name_variant "foo") lexp [] |> (fn ctxt => f ctxt t) end; fun add_abbrev loc mode name spec thy = thy |> Named_Target.init [] loc |> (fn lthy => let val t = Syntax.read_term (Local_Theory.target_of lthy) spec; in Local_Theory.abbrev mode ((Binding.name name, NoSyn), t) lthy end) |> #2 |> Local_Theory.exit |> Proof_Context.theory_of; exception TOPSORT of string fun topsort less [] = [] | topsort less xs = let fun list_all P xs = fold (fn x => fn b => b andalso P x) xs true; fun split_min n (x::xs) = if n=0 then raise TOPSORT "no minimum in list" else if list_all (less x) xs then (x,xs) else split_min (n-1) (xs@[x]); fun tsort [] = [] | tsort xs = let val (x,xs') = split_min (length xs) xs; in x::tsort xs' end; in tsort xs end; fun clique_name clique = (foldr1 (fn (a,b) => a ^ "_" ^ b) (map (unsuffix proc_deco) clique)); fun error_to_warning msg f thy = f thy handle ERROR msg' => (warning (msg' ^ "\n" ^ msg); thy); fun procedures_definition locname procs thy = let val procs' = map (fn (name,a,b,c,d,e,f) => (suffix proc_deco name,a,b,c,d,e,f)) procs; val _ = check_procedures_definition procs' thy; val name_pars = map (fn (name,inpars,outpars,_,_,_,sk) => (name,(inpars,outpars,sk))) procs'; val name_vars = map (fn (name,inpars,outpars,locals,_,_,_) => (name,(inpars,outpars,locals))) procs'; val name_body = map (fn (name,_,_,_,body,_,_) => (name,body)) procs'; val name_pars_specs = map (fn (name,inpars,outpars,_,_,specs,sk) => (name,(inpars,outpars,sk),specs)) procs'; val names = map #1 procs'; val sk = #7 (hd procs'); val thy = thy |> Context.theory_map (set_default_state_kind sk); val (all_callss,cliques,is_recursive,has_body) = let val context = Context.Theory thy |> fold (add_parameter_info Morphism.identity (unsuffix proc_deco)) name_pars |> Config.put_generic StateSpace.silent true fun read_body (_, body) = Syntax.read_term (Context.proof_of context) body; val bodies = map read_body name_body; fun dcall t = (case try dest_call t of SOME (_,p,_,_,m,_) => SOME (proc_name m p) | _ => NONE); fun in_names x = if member (op =) names x then SOME x else NONE; fun add_edges n = fold (fn x => Graph.add_edge (n, x)); val all_callss = map (map snd o max_subterms_dest dcall) bodies; val callss = map (map_filter in_names) all_callss; val graph = fold (fn n => Graph.new_node (n, ())) names Graph.empty; val graph' = fold2 add_edges names callss graph; fun idx x = find_index (fn y => x=y) names; fun name_ord (a,b) = int_ord (idx a, idx b); val cliques = Graph.strong_conn graph'; val cliques' = map (sort name_ord) cliques; val my_calls = these o AList.lookup (op =) (names ~~ map (distinct (op =)) callss); val my_body = AList.lookup (op =) (names ~~ bodies); fun is_recursive n = exists (fn [_] => false | ns => member (op =) ns n) (Graph.strong_conn graph'); fun has_body n = (case my_body n of SOME (Const (c,_)) => c <> NoBodyN | _ => true) fun clique_less c1 c2 = null (inter (op =) (distinct (op =) (maps my_calls c1)) c2); val cliques'' = topsort clique_less cliques'; in (all_callss,cliques'',is_recursive,has_body) end; (* cliques may only depend on ones to the left, so it is safe to * add the locales from the left to the right. *) fun my_clique n = Library.find_first (fn c => member (op =) c n) cliques; fun lname sfx clique = suffix sfx (clique_name clique); fun cname n = clique_name (the (my_clique n)); fun parameter_info_decl phi = fold (add_parameter_info phi cname) name_pars; fun get_loc sfx clique n = if member (op =) clique n then NONE else SOME (resuffix proc_deco sfx n); fun parent_locales thy sfx clique = let val calls = distinct (op =) (flat (map_filter (AList.lookup (op =) (names ~~ all_callss)) clique)); in map (intern_locale thy) (distinct (op =) (map_filter (get_loc sfx clique) calls)) end; val names_all_callss = names ~~ map (distinct (op =)) all_callss; val get_calls = the o AList.lookup (op =) names_all_callss; fun clique_vars clique = let fun add name (ins,outs,locs) = let val (nins,nouts,nlocs) = the (AList.lookup (op =) name_vars name) in (ins@nins,outs@nouts,locs@nlocs) end; val (is,os,ls) = fold add clique ([],[],[]); in (lname "" clique, (distinct (op =) is, distinct (op =) os, distinct (op =) ls)) end; fun add_signature_locale (cname, name) thy = let val name' = unsuffix proc_deco name; val fixes = [Element.Fixes [(Binding.name name, SOME proc_nameT, NoSyn)]]; (* FIXME: may use HOLogic.typeT as soon as locale type-inference works properly *) val pE = mk_loc_exp [intern_locale thy (suffix parametersN cname)]; val sN = suffix signatureN name'; in thy |> add_locale sN pE fixes |> Proof_Context.theory_of |> (fn thy => add_declaration (intern_locale thy sN) parameter_info_decl thy) end; fun mk_bdy_def read_term name = let val name' = unsuffix proc_deco name; val bdy = read_term (the (AList.lookup (op =) name_body name)); val bdy_defN = suffix body_def_sfx name'; val b = Binding.name bdy_defN; in ((b, NoSyn), ((Thm.def_binding b, []), bdy)) end; fun add_body_locale (name, _) thy = let val name' = unsuffix proc_deco name; val callees = filter_out (fn n => n = name) (get_calls name) val fixes = [Element.Fixes [(Binding.name name, SOME proc_nameT, NoSyn)]]; (* FIXME: may use HOLogic.typeT as soon as locale type-inference works properly *) val pE = mk_loc_exp (map (intern_locale thy) ([lname variablesN (the (my_clique name))]@ the_list locname@ map (resuffix proc_deco signatureN) callees)); fun def lthy = let val read = Syntax.read_term (Context.proof_map (add_active_procs Morphism.identity (the (my_clique name))) (Local_Theory.target_of lthy)) in mk_bdy_def read name end; fun add_decl_and_def lname ctxt = ctxt |> Proof_Context.theory_of |> Named_Target.init [] lname - |> Local_Theory.declaration {syntax = false, pervasive = false} parameter_info_decl + |> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} parameter_info_decl |> (fn lthy => if has_body name then snd (Local_Theory.define (def lthy) lthy) else lthy) |> Local_Theory.exit |> Proof_Context.theory_of; in thy |> add_locale' (suffix bodyN name') pE fixes |-> add_decl_and_def end; fun mk_def_eq thy read_term name = if has_body name then let (* FIXME: All the read_term stuff is just because type-inference/abbrevs for * new locale elements does not work right now; * We read the term to expand the abbreviations, then we print it again * (without folding the abbreviation) and reread as string *) val name' = unsuffix proc_deco name; val bdy_defN = suffix body_def_sfx name'; val rhs = read_term ("Some " ^ bdy_defN); val nt = read_term name; val Free (gamma,_) = read_term programN; val eq = HOLogic.Trueprop$ HOLogic.mk_eq (Free (gamma,fastype_of nt --> fastype_of rhs)$nt,rhs) val consts = Sign.consts_of thy; val eqs = YXML.string_of_body (Term_XML.Encode.term consts (Consts.dummy_types consts eq)); val assms = Element.Assumes [((Binding.name (suffix bodyP name'), []),[(eqs,[])])] in [assms] end else []; fun add_impl_locales clique thy = let val cliqN = lname cliqueN clique; val cnamesN = lname clique_namesN clique; val multiple_procs = length clique > 1; val add_distinct_procs_namespace = if multiple_procs then StateSpace.namespace_definition cnamesN proc_nameT ([],[]) [] clique else I; val bodyLs = map (suffix bodyN o unsuffix proc_deco) clique; fun pE thy = mk_loc_exp (map (intern_locale thy) (hoare_ctxtL::bodyLs) @ (parent_locales thy implementationN clique) @ (if multiple_procs then [intern_locale thy cnamesN] else [])); fun read_term thy = apply_in_context thy (pE thy) Syntax.read_term; fun elems thy = maps (mk_def_eq thy (read_term thy)) clique; fun add_recursive_info phi name = if is_recursive name then (add_recursive phi name) else I; fun proc_declaration phi = add_active_procs phi clique; fun recursive_declaration phi context = context |> fold (add_recursive_info phi) clique; fun add_impl_locale name thy = let val implN = suffix implementationN (unsuffix proc_deco name); val parentN = intern_locale thy cliqN val parent = mk_loc_exp [parentN]; in thy |> add_locale_cmd implN parent [] |> Proof_Context.theory_of |> (fn thy => Interpretation.global_sublocale parentN (mk_loc_exp [intern_locale thy implN]) [] thy) |> Proof.global_terminal_proof ((Method.Basic (fn ctxt => Method.SIMPLE_METHOD (Locale.intro_locales_tac {strict = true, eager = false} ctxt [])), Position.no_range), NONE) |> Proof_Context.theory_of end; in thy |> add_distinct_procs_namespace |> (fn thy => add_locale_cmd cliqN (pE thy) (elems thy) thy) |> Proof_Context.theory_of |> fold add_impl_locale clique |> (fn thy => add_declaration (intern_locale thy cliqN) proc_declaration thy) |> (fn thy => add_declaration (intern_locale thy cliqN) recursive_declaration thy) end; fun add_spec_locales (name, _, specs) thy = let val name' = unsuffix proc_deco name; val ps = (suffix signatureN name' :: the_list locname); val ps' = hoare_ctxtL :: ps ; val pE = mk_loc_exp (map (intern_locale thy) ps) val pE' = mk_loc_exp (map (intern_locale thy) ps') fun read thy = apply_in_context thy (mk_loc_exp [intern_locale thy (suffix cliqueN (cname name))]) (Syntax.read_prop); fun proc_declaration phi = (*parameter_info_decl phi o already in signature *) add_active_procs phi (the (my_clique name)); fun add_locale'' (thm_name,spec) thy = let val spec' = read thy spec; val elem = Element.Assumes [((Binding.name thm_name, []), [(spec', [])])]; in thy |> add_locale thm_name pE' [elem] |> Proof_Context.theory_of |> (fn thy => add_declaration (intern_locale thy thm_name) proc_declaration thy) |> error_to_warning ("abbreviation: '" ^ thm_name ^ "' not added") (add_abbrev (intern_locale thy (suffix cliqueN (cname name))) Syntax.mode_input thm_name spec) end; in thy |> fold add_locale'' specs end; in thy |> fold (add_variable_statespaces o clique_vars) cliques |> fold (fn c => fold (fn n => add_signature_locale (lname "" c, n)) c) cliques |> fold add_body_locale name_pars |> fold add_impl_locales cliques |> fold add_spec_locales name_pars_specs end; (********************* theory extender interface ********************************) (** package setup **) (* outer syntax *) val var_declP = Parse.name -- (@{keyword "::"} |-- Parse.!!! Parse.embedded); val var_declP' = Parse.name >> (fn n => (n,"")); val localsP = Scan.repeat var_declP; val argP = var_declP; val argP' = var_declP'; val not_eqP = Scan.ahead (Scan.unless @{keyword "="} (Scan.one (K true))) val proc_decl_statespace = (Parse.short_ident --| @{keyword "("}) -- ((Parse.list argP) -- (Scan.optional (@{keyword "|"} |-- Parse.list argP) []) --| @{keyword ")"}) --| not_eqP val proc_decl_record = (Parse.short_ident --| @{keyword "("}) -- ((Parse.list argP') -- (Scan.optional (@{keyword "|"} |-- Parse.list argP') []) --| @{keyword ")"}) --| Scan.option @{keyword "="} val proc_decl = proc_decl_statespace >> pair Function || proc_decl_record >> pair Record; val loc_decl = Scan.optional (@{keyword "where"} |-- localsP --| @{keyword "in"}) [] val proc_body = Parse.embedded (*>> BodyTerm*) fun proc_specs x = (Parse.!!! (Scan.repeat (Parse_Spec.thm_name ":" -- Parse.embedded)) >> map (fn ((thm_name, _), prop) => (Binding.name_of thm_name, prop))) x val par_loc = Scan.option (@{keyword "("} |-- @{keyword "imports"} |-- Parse.name --| @{keyword ")"}); val _ = Outer_Syntax.command @{command_keyword procedures} "define procedures" (par_loc -- (Parse.and_list1 (proc_decl -- loc_decl -- proc_body -- proc_specs)) >> (fn (loc,decls) => let val decls' = map (fn ((((state_kind,(name,(ins,outs))),ls),bdy),specs) => (name,ins,outs,ls,bdy,specs,state_kind)) decls in Toplevel.theory (procedures_definition loc decls') end)); val _ = Outer_Syntax.command @{command_keyword hoarestate} "define state space for hoare logic" (StateSpace.statespace_decl >> (fn ((args,name),(parents,comps)) => Toplevel.theory (StateSpace.define_statespace args name parents (map (apfst (suffix deco)) comps)))); (*************************** Auxiliary Functions for integration of ********************) (*************************** automatic program analysers ********************) fun dest_conjs t = (case HOLogic.dest_conj t of [t1,t2] => dest_conjs t1 @ dest_conjs t2 | ts => ts); fun split_guard (Const (@{const_name Collect},CT)$(Abs (s,T,t))) = let fun mkCollect t = Const (@{const_name Collect},CT)$(Abs (s,T,t)); in map mkCollect (dest_conjs t) end | split_guard t = [t]; fun split_guards gs = let fun norm c f g = map (fn g => c$f$g) (split_guard g); fun norm_guard ((c as Const (@{const_name Pair},_))$f$g) = norm c f g | norm_guard ((c as Const (@{const_name Language.guaranteeStripPair},_))$f$g) = norm c f g | norm_guard t = [t]; in maps norm_guard (HOLogic.dest_list gs) end fun fold_com f t = let (* traverse does not descend into abstractions, like in DynCom, call, etc. *) fun traverse cnt (c as Const (@{const_name Language.com.Skip},_)) = (cnt,f cnt c [] []) | traverse cnt ((c as Const (@{const_name Language.com.Basic},_))$g) = (cnt, f cnt c [g] []) | traverse cnt ((c as Const (@{const_name Language.com.Spec},_))$r) = (cnt, f cnt c [r] []) | traverse cnt ((c as Const (@{const_name Language.com.Seq},_))$c1$c2) = let val (cnt1,v1) = traverse cnt c1; val (cnt2,v2) = traverse cnt1 c2; in (cnt2, f cnt c [] [v1,v2]) end | traverse cnt ((c as Const (@{const_name Language.com.Cond},_))$b$c1$c2) = let val (cnt1,v1) = traverse cnt c1; val (cnt2,v2) = traverse cnt1 c2; in (cnt2, f cnt c [b] [v1,v2]) end | traverse cnt ((c as Const (@{const_name Language.com.While},_))$b$c1) = let val (cnt1,v1) = traverse cnt c1 in (cnt1, f cnt c [b] [v1]) end | traverse cnt ((c as Const (@{const_name Language.com.Call},_))$p) = (cnt, f cnt c [p] []) | traverse cnt ((c as Const (@{const_name Language.com.DynCom},_))$c1) = (cnt, f cnt c [c1] []) | traverse cnt ((c as Const (@{const_name Language.com.Guard},_))$flt$g$c1) = let val (cnt1,v1) = traverse (cnt + length (split_guard g)) c1 in (cnt1, f cnt c [flt,g] [v1]) end | traverse cnt (c as Const (@{const_name Language.com.Throw},_)) = (cnt,f cnt c [] []) | traverse cnt ((c as Const (@{const_name Language.com.Catch},_))$c1$c2) = let val (cnt1,v1) = traverse cnt c1; val (cnt2,v2) = traverse cnt1 c2; in (cnt2, f cnt c [] [v1,v2]) end | traverse cnt ((c as Const (@{const_name Language.guards},_))$gs$c1) = let val (cnt1,v1) = traverse (cnt + length (split_guards gs)) c1; in (cnt1, f cnt c [gs] [v1]) end | traverse cnt ((c as Const (@{const_name Language.block},_))$init$c1$return$c2) = let val (cnt1,v1) = traverse cnt c1 in (cnt1, f cnt c [init,return,c2] [v1]) end | traverse cnt ((c as Const (@{const_name Language.call},_))$init$p$return$c1) = (cnt, f cnt c [init,p,return,c1] []) | traverse cnt ((c as Const (@{const_name Language.whileAnno},_))$b$I$V$c1) = let val (cnt1,v1) = traverse cnt c1 in (cnt1, f cnt c [b,I,V] [v1]) end | traverse cnt ((c as Const (@{const_name Language.whileAnnoG},_))$gs$b$I$V$c1) = let val (cnt1,v1) = traverse (cnt + length (split_guards gs)) c1 in (cnt1, f cnt c [gs,b,I,V] [v1]) end | traverse _ t = raise TERM ("fold_com: unknown command",[t]); in snd (traverse 0 t) end; (*************************** Tactics ****************************************************) (*** Aux. tactics ***) fun cond_rename_bvars cond name thm = let fun rename (tm as (Abs (x, T, t))) = if cond tm then Abs (name x, T, rename t) else Abs (x, T, rename t) | rename (t $ u) = rename t $ rename u | rename a = a; in Thm.renamed_prop (rename (Thm.prop_of thm)) thm end; val rename_bvars = cond_rename_bvars (K true); fun trace_tac ctxt str st = (if Config.get ctxt hoare_trace then tracing str else (); all_tac st); fun error_tac str st = (error str;no_tac st); fun rename_goal ctxt name = EVERY' [K (trace_tac ctxt "rename_goal -- START"), SELECT_GOAL (PRIMITIVE (rename_bvars name)), K (trace_tac ctxt "rename_goal -- STOP")]; (* splits applications of tupled arguments to a schematic Variables, e.g. * ALL a b. ?P (a,b) --> ?Q (a,b) gets * ALL a b. ?P a b --> ?Q a b * only tuples nested to the right are splitted. *) fun split_pair_apps ctxt thm = let val t = Thm.prop_of thm; fun mk_subst subst (Abs (x,T,t)) = mk_subst subst t | mk_subst subst (t as (t1$t2)) = (case strip_comb t of (var as Var (v,vT),args) => (if not (AList.defined (op =) subst var) then let val len = length args; val (argTs,bdyT) = strip_type vT; val (z, _) = Name.variant "z" (fold Term.declare_term_frees args Name.context); val frees = map (apfst (fn i => z^string_of_int i)) (0 upto (len - 1) ~~ argTs); fun splitT (Type (@{type_name Product_Type.prod}, [T1, T2])) = T1::splitT T2 | splitT T = [T]; fun pair_depth (Const (@{const_name Pair},aT)$t1$t2) = 1 + (pair_depth t2) | pair_depth _ = 0; fun mk_sel max free i = let val snds = funpow i HOLogic.mk_snd (Free free) in if i=max then snds else HOLogic.mk_fst snds end; fun split (free,arg) = let val depth = (pair_depth arg); in if depth = 0 then [Free free] else map (mk_sel depth free) (0 upto depth) end; val args' = maps split (frees ~~ args); val argTs' = maps splitT argTs; val inst = fold_rev absfree frees (list_comb (Var (v,argTs' ---> bdyT), args')) in subst@[(var,inst)] end else subst) | _ => mk_subst (mk_subst subst t1) t2) | mk_subst subst t = subst; val subst = map (fn (v,t) => (dest_Var v, Thm.cterm_of ctxt t)) (mk_subst [] t); in full_simplify (put_simpset HOL_basic_ss ctxt addsimps [@{thm fst_conv}, @{thm snd_conv}]) (Drule.instantiate_normalize (TVars.empty, Vars.make subst) thm) end; (* Generates split theorems, for !!,!,? quantifiers and for UN, e.g. * ALL x. P x = ALL a b. P a b *) fun mk_split_thms ctxt (vars as _::_) = let val thy = Proof_Context.theory_of ctxt; val names = map fst vars; val types = map snd vars; val free_vars = map Free vars; val pT = foldr1 HOLogic.mk_prodT types; val x = (singleton (Name.variant_list names) "x", pT); val xp = foldr1 HOLogic.mk_prod free_vars; val tfree_names = fold Term.add_tfree_names free_vars []; val zeta = TFree (singleton (Name.variant_list tfree_names) "z", Sign.defaultS thy); val split_meta_prop = let val P = Free (singleton (Name.variant_list names) "P", pT --> Term.propT) in Logic.mk_equals (Logic.all (Free x) (P $ Free x), fold_rev Logic.all free_vars (P $ xp)) end; val P = Free (singleton (Name.variant_list names) "P", pT --> HOLogic.boolT); val split_object_prop = let fun ALL vs t = Library.foldr (fn ((v,T),t) => HOLogic.mk_all (v,T,t)) (vs,t) in (ALL [x] (P $ Free x)) === (ALL vars (P $ xp)) end; val split_ex_prop = let fun EX vs t = Library.foldr (fn ((v,T),t) => HOLogic.mk_exists (v,T,t)) (vs,t) in (EX [x] (P $ Free x)) === (EX vars (P $ xp)) end; val split_UN_prop = let val P = Free (singleton (Name.variant_list names) "P", pT --> HOLogic.mk_setT zeta); fun UN vs t = Library.foldr mk_UN (vs, t) in (UN [x] (P $ Free x)) === (UN vars (P $ xp)) end; fun prove_simp simps prop = let val ([prop'], _) = Variable.importT_terms [prop] ctxt (* FIXME continue context!? *) in Goal.prove_global thy [] [] prop' (fn {context = goal_ctxt, ...} => ALLGOALS (simp_tac (put_simpset HOL_basic_ss goal_ctxt addsimps simps))) end; val split_meta = prove_simp [@{thm split_paired_all}] split_meta_prop; val split_object = prove_simp [@{thm split_paired_All}] split_object_prop; val split_ex = prove_simp [@{thm split_paired_Ex}] split_ex_prop; val split_UN = prove_simp [@{thm Hoare.split_paired_UN}] split_UN_prop; in [split_meta,split_object,split_ex,split_UN] end | mk_split_thms _ _ = raise Match; fun rename_aux_var name rule = let fun is_aux_var (Abs ("Z",TVar(_,_),_)) = true | is_aux_var _ = false; in cond_rename_bvars is_aux_var (K name) rule end; (* adapts single auxiliary variable in a rule to potentialy multiple auxiliary * variables in actual specification, e.g. if vars are a b, * split_app=false: ALL Z. ?P Z gets to ALL a b. ?P (a,b) * split_app=true: ALL Z. ?P Z gets to ALL a b. ?P a b * If only one auxiliary variable is given, the variables are just renamed, * If no auxiliary is given, unit is inserted for Z: * ALL Z. ?P Z gets P () *) fun adapt_aux_var ctxt split_app (vars as (_::_::_)) tvar_rules = let val thy = Proof_Context.theory_of ctxt; val max_idx = fold Integer.max (map (Thm.maxidx_of o snd) tvar_rules) 0; val types = map (fn i => TVar (("z",i),Sign.defaultS thy)) (max_idx + 1 upto (max_idx + length vars)); fun tvar n = (n, Sign.defaultS thy); val pT = Thm.ctyp_of ctxt (foldr1 HOLogic.mk_prodT types); val rules' = map (fn (z,r) => (Drule.instantiate_normalize (TVars.make [(tvar z,pT)], Vars.empty) r)) tvar_rules; val splits = mk_split_thms ctxt (vars ~~ types); val rules'' = map (full_simplify (put_simpset HOL_basic_ss ctxt addsimps splits)) rules'; in if split_app then (map (split_pair_apps ctxt) rules'') else rules'' end | adapt_aux_var _ _ ([name]) tvar_rules = map (rename_aux_var name o snd) tvar_rules | adapt_aux_var ctxt _ ([]) tvar_rules = let val thy = Proof_Context.theory_of ctxt; fun tvar n = (n, Sign.defaultS thy); val uT = Thm.ctyp_of ctxt HOLogic.unitT; val rules' = map (fn (z,r) => (Drule.instantiate_normalize (TVars.make [(tvar z,uT)], Vars.empty) r)) tvar_rules; val splits = [@{thm Hoare.unit_meta},@{thm Hoare.unit_object},@{thm Hoare.unit_ex},@{thm Hoare.unit_UN}]; val rules'' = map (full_simplify (put_simpset HOL_basic_ss ctxt addsimps splits)) rules'; in rules'' end (* Generates a rule for recursion for n procedures out of general recursion rule *) fun gen_call_rec_rule ctxt specs_name n rule = let val thy = Proof_Context.theory_of ctxt; val maxidx = Thm.maxidx_of rule; val vars = Term.add_vars (Thm.prop_of rule) []; fun get_type n = the (AList.lookup (op =) vars (n, 0)); val (Type (_, [Type (_, [assT, Type (_, [pT,_])])])) = get_type specs_name; val zT = TVar (("z",maxidx+1),Sign.defaultS thy) fun mk_var i n T = Var ((n ^ string_of_int i,0),T); val quadT = HOLogic.mk_prodT (assT, HOLogic.mk_prodT (pT, HOLogic.mk_prodT (assT,assT))); val quadT_set = HOLogic.mk_setT quadT; fun mk_spec i = let val quadruple = HOLogic.mk_ptuple (HOLogic.flat_tupleT_paths quadT) quadT [mk_var i "P" (zT --> assT)$Bound 0, mk_var i "p" pT, mk_var i "Q" (zT --> assT)$Bound 0, mk_var i "A" (zT --> assT)$Bound 0]; val single = HOLogic.mk_set quadT [quadruple]; in mk_UN' zT quadT_set (Abs ("Z", zT, single)) end; val Specs = foldr1 (mk_Un quadT_set) (map mk_spec (1 upto n)); val rule' = Thm.instantiate' [] [SOME (Thm.cterm_of ctxt Specs)] rule |> full_simplify (put_simpset (simpset_of @{theory_context Main}) ctxt addsimps [@{thm Hoare.conjE_simp},@{thm Hoare.in_Specs_simp},@{thm Hoare.in_set_Un_simp},@{thm split_all_conj}, @{thm image_Un},@{thm image_Un_single_simp}] ) |> rename_bvars (fn s => if member (op =) ["s","\"] s then s else "Z") in rule' end; fun gen_proc_rec ctxt mode n = gen_call_rec_rule ctxt "Specs" n (ProcRecSpecs mode); (*** verification condition generator ***) (* simplifications on "Collect" sets, like {s. P s} Int {s. Q s} = {s. P s & Q s} *) fun merge_assertion_simp_tac ctxt thms = simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([@{thm Hoare.CollectInt_iff},@{thm HOL.conj_assoc},@{thm Hoare.Compl_Collect},singleton_conv_sym, @{thm Set.Int_empty_right},@{thm Set.Int_empty_left},@{thm Un_empty_right},@{thm Un_empty_left}]@thms)) ; (* The following probably shouldn't live here, but refactoring so that Hoare could depend on recursive_records does not look feasible. The upshot is that there's a duplicate foldcong_ss set here. *) structure FoldCongData = Theory_Data ( type T = simpset; val empty = HOL_basic_ss; val merge = merge_ss; ) val get_foldcong_ss = FoldCongData.get fun add_foldcongs congs thy = FoldCongData.map (fn ss => Proof_Context.init_global thy |> put_simpset ss |> fold Simplifier.add_cong congs |> simpset_of) thy fun add_foldcongsimps simps thy = FoldCongData.map (fn ss => Proof_Context.init_global thy |> put_simpset ss |> (fn ctxt => ctxt addsimps simps) |> simpset_of) thy (* propagates state into "Collect" sets and simplifies selections updates like: * s:{s. P s} = P s *) fun in_assertion_simp_tac ctxt state_kind thms i = let val vcg_simps = #vcg_simps (get_data ctxt); val fold_simps = get_foldcong_ss (Proof_Context.theory_of ctxt) in EVERY [simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([mem_Collect_eq,@{thm Set.Un_iff},@{thm Set.Int_iff}, @{thm Set.empty_subsetI}, @{thm Set.empty_iff}, UNIV_I, @{thm Hoare.Collect_False}]@thms@K_convs@vcg_simps) addsimprocs (state_simprocs state_kind) |> fold Simplifier.add_cong K_congs) i THEN_MAYBE (simp_tac (put_simpset fold_simps ctxt addsimprocs [state_upd_simproc state_kind]) i) ] end; fun assertion_simp_tac ctxt state_kind thms i = merge_assertion_simp_tac ctxt [] i THEN_MAYBE in_assertion_simp_tac ctxt state_kind thms i (* simplify equality test on strings (and datatype-constructors) and propagate result*) fun string_eq_simp_tac ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms}); fun assertion_string_eq_simp_tac ctxt state_kind thms i = assertion_simp_tac ctxt state_kind thms i THEN_MAYBE string_eq_simp_tac ctxt i; fun before_set2pred_simp_tac ctxt = (simp_tac (put_simpset HOL_basic_ss ctxt addsimps [singleton_conv_sym, @{thm Hoare.CollectInt_iff}, @{thm Hoare.Compl_Collect}])); (*****************************************************************************) (** set2pred transforms sets inclusion into predicates implication, **) (** maintaining the original variable names. **) (** Ex. "{x. x=0} <= {x. x <= 1}" -set2pred-> "x=0 --> x <= 1" **) (** Subgoals containing intersections (A Int B) or complement sets (-A) **) (** are first simplified by "before_set2pred_simp_tac", that returns only **) (** subgoals of the form "{x. P x} <= {x. Q x}", which are easily **) (** transformed. **) (** This transformation may solve very easy subgoals due to a ligth **) (** simplification done by full_simp_tac **) (*****************************************************************************) fun set2pred_tac ctxt i thm = ((before_set2pred_simp_tac ctxt i) THEN_MAYBE (EVERY [trace_tac ctxt "set2pred", resolve_tac ctxt [subsetI] i, resolve_tac ctxt [CollectI] i, dresolve_tac ctxt [CollectD] i, full_simp_tac (put_simpset HOL_basic_ss ctxt) i ])) thm (*****************************************************************************) (** BasicSimpTac is called to simplify all verification conditions. It does **) (** a light simplification by applying "mem_Collect_eq" **) (** then it tries to solve subgoals of the form "A <= A" and then if **) (** set2pred is true it **) (** transforms any other into predicates, applying then **) (** the tactic chosen by the user, which may solve the subgoal completely **) (** (MaxSimpTac). **) (*****************************************************************************) fun MaxSimpTac ctxt tac i = TRY (FIRST[resolve_tac ctxt [subset_refl] i, set2pred_tac ctxt i THEN_MAYBE tac i, trace_tac ctxt "final_tac failed" ]); fun BasicSimpTac ctxt state_kind set2pred thms tac i = EVERY [(trace_tac ctxt "BasicSimpTac -- START --"), assertion_simp_tac ctxt state_kind thms i THEN_MAYBE (if set2pred then MaxSimpTac ctxt tac i else TRY (resolve_tac ctxt [subset_refl] i)), (trace_tac ctxt "BasicSimpTac -- STOP --")]; (* EVERY [(trace_tac ctxt "BasicSimpTac -- START --"), simp_tac (HOL_basic_ss addsimps [mem_Collect_eq,@{thm Hoare.CollectInt_iff}, @{thm Set.empty_subsetI}, @{thm Set.empty_iff}, UNIV_I] addsimprocs [state_simproc sk]) i THEN_MAYBE simp_tac (HOL_basic_ss addsimprocs [state_upd_simproc sk]) i THEN_MAYBE (if set2pred then MaxSimpTac ctxt tac i else TRY (rtac subset_refl i)), (trace_tac ctxt "BasicSimpTac -- STOP --")]; *) (* fun simp_state_eq_tac Record state_space = full_simp_tac (HOL_basic_ss addsimprocs (state_simprocs Record)) THEN_MAYBE' full_simp_tac (HOL_basic_ss addsimprocs [state_upd_simproc Record]) THEN_MAYBE' (state_split_simp_tac [] state_space) | simp_state_eq_tac StateFun state_space = *) fun post_conforms_tac ctxt state_kind i = EVERY [REPEAT1 (resolve_tac ctxt [allI,impI] i), ((fn i => TRY (resolve_tac ctxt [conjI] i)) THEN_ALL_NEW (fn i => (REPEAT (resolve_tac ctxt [allI,impI] i)) THEN (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq,@{thm Set.singleton_iff},@{thm Set.empty_iff},UNIV_I] addsimprocs (state_simprocs state_kind)) i))) i]; fun dest_hoare_raw (Const(@{const_name HoarePartialDef.hoarep},_)$G$T$F$P$C$Q$A) = (P,C,Q,A,Partial,G,T,F) | dest_hoare_raw (Const(@{const_name HoareTotalDef.hoaret},_)$G$T$F$P$C$Q$A) = (P,C,Q,A,Total,G,T,F) | dest_hoare_raw t = raise TERM ("Hoare.dest_hoare_raw: unexpected term",[t]) fun mk_hoare_abs Ts (P,C,Q,A,mode,G,T,F) = let val hoareT = map (curry fastype_of1 Ts) [G,T,F,P,C,Q,A] ---> HOLogic.boolT; val hoareC = (case mode of Partial => Const (@{const_name HoarePartialDef.hoarep},hoareT) | Total => Const (@{const_name HoareTotalDef.hoaret},hoareT)); in hoareC$G$T$F$P$C$Q$A end; val is_hoare = can dest_hoare_raw fun dest_hoare t = let val triple = (strip_qnt_body @{const_name "All"} o HOLogic.dest_Trueprop o strip_qnt_body @{const_name Pure.all}) t; in dest_hoare_raw triple end; fun get_aux_tvar rule = let fun aux_hoare (Abs ("Z",TVar (z,_),t)) = if is_hoare (strip_qnt_body @{const_name All} t) then SOME z else NONE | aux_hoare _ = NONE; in (case first_subterm_dest (aux_hoare) (Thm.prop_of rule) of SOME (_,z) => (z,rule) | NONE => raise TERM ("get_aux_tvar: No auxiliary variable of hoare-rule found", [Thm.prop_of rule])) end; fun strip_vars t = let val bdy = (HOLogic.dest_Trueprop o Logic.strip_assums_concl) t; in strip_qnt_vars @{const_name Pure.all} t @ strip_qnt_vars @{const_name All} bdy end; local (* ex_simps are necessary in case of multiple logical variables. The state will usually be the first variable. EX s a b. s=s' ... . We have to transport EX s to s=s' to perform the substitution *) val conseq1_ss_base = simpset_of (put_simpset HOL_basic_ss @{context} addsimps ([mem_Collect_eq,@{thm Set.singleton_iff},@{thm Set.Int_iff}, @{thm Set.empty_iff},UNIV_I, @{thm HOL.conj_assoc}, @{thm disj_assoc}] @ @{thms Hoare.all_imp_eq_triv} @K_convs @ @{thms simp_thms} @ @{thms ex_simps} @ @{thms all_simps}) delsimps [@{thm Hoare.all_imp_to_ex}] |> fold Simplifier.add_cong K_congs) val conseq1_ss_record = simpset_of (put_simpset conseq1_ss_base @{context} addsimprocs (state_simprocs Record)); val conseq1_ss_fun = simpset_of (put_simpset conseq1_ss_base @{context} addsimprocs (state_simprocs Function)); fun conseq1_ss Record = conseq1_ss_record | conseq1_ss Function = conseq1_ss_fun; val conseq2_ss_base = simpset_of (put_simpset HOL_basic_ss @{context} addsimps (@{thms Hoare.all_imp_eq_triv} @ @{thms simp_thms} @ @{thms ex_simps} @ @{thms all_simps}) delsimps [@{thm Hoare.all_imp_to_ex}] |> Simplifier.add_cong @{thm imp_cong}); val conseq2_ss_record = simpset_of (put_simpset conseq2_ss_base @{context} addsimprocs [state_upd_simproc Record, state_ex_sel_eq_simproc Record]); val conseq2_ss_fun = simpset_of (put_simpset conseq2_ss_base @{context} addsimprocs [state_upd_simproc Function, state_ex_sel_eq_simproc Function]); fun conseq2_ss Record = conseq2_ss_record | conseq2_ss Function = conseq2_ss_fun; in fun raw_conseq_simp_tac ctxt state_kind thms i = let val ctxt' = Config.put simp_depth_limit 0 ctxt; in simp_tac (put_simpset (conseq1_ss state_kind) ctxt' addsimps thms) i THEN_MAYBE simp_tac (put_simpset (conseq2_ss state_kind) ctxt') i end end val conseq_simp_tac = raw_conseq_simp_tac; (* Generates the hoare-quadruples that can be derived out of the hoare-context T *) fun gen_context_thms ctxt mode params G T F = let val Type (_,[comT]) = range_type (fastype_of G); fun destQuadruple (Const (@{const_name Set.insert},_) $ PpQA $ Const (@{const_name Orderings.bot}, _)) = PpQA | destQuadruple t = raise Match; fun mkCallQuadruple (Const (@{const_name Pair}, _) $ P $ (Const (@{const_name Pair}, _) $ p $ (Const(@{const_name Pair}, _) $ Q $ A))) = let val Call_p = Const (@{const_name Language.com.Call}, fastype_of p --> comT) $ p; in (P, Call_p, Q, A) end; fun mkHoare mode G T F (vars,PpQA) = let val hoare = (case mode of Partial => @{const_name HoarePartialDef.hoarep} | Total => @{const_name HoareTotalDef.hoaret}); (* FIXME: Use future Proof_Context.rename_vars or make closed term and remove by hand *) (* fun free_params ps t = foldr (fn ((x,xT),t) => snd (variant_abs (x,xT,t))) (ps,t); val PpQA' = mkCallQuadruple (strip_qnt_body @{const_name Pure.all} (free_params params (Term.list_all (vars,PpQA)))); *) val params' = (Variable.variant_frees ctxt [PpQA] params); val bnds = map Bound (0 upto (length vars - 1)); fun free_params_vars t = subst_bounds (bnds @ rev (map Free params' ), t) fun free_params t = subst_bounds (rev (map Free params' ), t) val (P',p',Q',A') = mkCallQuadruple (free_params_vars PpQA); val T' = free_params T; val G' = free_params G; val F' = free_params F; val bdy = mk_hoare_abs [] (P',p',Q',A',mode,G',T',F'); in (HOLogic.mk_Trueprop (HOLogic.list_all (vars,bdy)), map fst params') end; fun hoare_context_specs mode G T F = let fun mk t = try (mkHoare mode G T F o apsnd destQuadruple o dest_UN) t; in map_filter mk (dest_Un T) end; fun mk_prove mode (prop,params) = let val vars = map fst (strip_qnt_vars @{const_name All} (HOLogic.dest_Trueprop (Logic.strip_assums_concl prop))); in Goal.prove ctxt params [] prop (fn {context = ctxt', ...} => EVERY[trace_tac ctxt' "extracting specifications from hoare context", resolve_tac ctxt' (adapt_aux_var ctxt' true vars [get_aux_tvar (AsmUN mode)]) 1, DEPTH_SOLVE_1 (resolve_tac ctxt' [subset_refl,refl] 1 ORELSE ((resolve_tac ctxt' [@{thm Hoare.subset_unI1}] 1 APPEND resolve_tac ctxt' [@{thm Hoare.subset_unI2}] 1) ORELSE (resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert1}] 1 APPEND resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert2}] 1))) ORELSE error_tac ("vcg: cannot extract specifications from context") ]) end; val specs = hoare_context_specs mode G T F; in map (mk_prove mode) specs end; fun is_modifies_clause t = exists_subterm (fn (Const (@{const_name Hoare.meq},_)) => true| _ => false) (#3 (dest_hoare (Logic.strip_assums_concl t))) handle (TERM _) => false; val is_spec_clause = not o is_modifies_clause; (* e.g: Intg => the_Intg lift Intg => lift the_Intg map Ingt => map the_Intg Hp o lift Intg => lift the_Intg o the_Hp *) fun swap_constr_destr f (t as (Const (@{const_name Fun.id},_))) = t | swap_constr_destr f (t as (Const (c,Type ("fun",[T,valT])))) = (Const (f c, Type ("fun",[valT,T])) handle Empty => raise TERM ("Hoare.swap_constr_destr",[t])) | swap_constr_destr f (Const ("StateFun.map_fun",Type ("fun", (* FIXME unknown "StateFun.map_fun" !? *) [Type ("fun",[T,valT]), Type ("fun",[Type ("fun",[xT,T']), Type ("fun",[xT',valT'])])]))$g) = Const ("StateFun.map_fun",Type("fun",[Type ("fun",[valT,T]), Type ("fun",[Type ("fun",[xT,valT']), Type ("fun",[xT',T'])])]))$ swap_constr_destr f g | swap_constr_destr f (Const (@{const_name Fun.comp},Type ("fun", [Type ("fun",[bT',cT]), Type ("fun",[Type ("fun",[aT ,bT]), Type ("fun",[aT',cT'])])]))$h$g) = let val h'=swap_constr_destr f h; val g'=swap_constr_destr f g; in Const (@{const_name Fun.comp},Type ("fun", [Type ("fun",[bT,aT]), Type ("fun",[Type ("fun",[cT,bT']), Type ("fun",[cT',aT'])])]))$g'$h' end | swap_constr_destr f (Const (@{const_name List.map},Type ("fun", [Type ("fun",[aT,bT]), Type ("fun",[asT,bsT])]))$g) = (Const (@{const_name List.map},Type ("fun", [Type ("fun",[bT,aT]), Type ("fun",[bsT,asT])]))$swap_constr_destr f g) | swap_constr_destr f t = raise TERM ("Hoare.swap_constr_destr",[t]); (* FIXME: unused? *) val destr_to_constr = let fun convert c = let val (path,base) = split_last (Long_Name.explode c); in Long_Name.implode (path @ ["val",unprefix "the_" base]) end; in swap_constr_destr convert end; fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx pname return has_args _ = let val thy = Proof_Context.theory_of ctxt; val pname' = unsuffix proc_deco pname; val spec = (case AList.lookup (op =) asms pname of SOME s => SOME s | NONE => try (Proof_Context.get_thm ctxt) (suffix spec_sfx pname')); fun auxvars_for p t = (case first_subterm_dest (try dest_call) t of SOME (vars,(_,p',_,_,m,_)) => (if m=Static andalso p=(dest_string' p') then SOME vars else NONE) | NONE => NONE); fun get_auxvars_for p t = (case (map_filter ((auxvars_for p) o snd) (max_subterms_dest tap_UN t)) of (vars::_) => vars | _ => []); fun spec_tac ctxt' augment_rule augment_emptyFaults _ spec i = let val spec' = augment_emptyFaults OF [spec] handle THM _ => spec; in EVERY [resolve_tac ctxt' [augment_rule] i, resolve_tac ctxt' [spec'] (i+1), TRY (resolve_tac ctxt' [subset_refl, @{thm Set.empty_subsetI}, @{thm Set.Un_upper1}, @{thm Set.Un_upper2}] i)] end; fun check_spec name P thm = (case try dest_hoare (Thm.concl_of thm) of SOME spc => (case try dest_call (#2 spc) of SOME (_,p,_,_,m,_) => if proc_name m p = name andalso P (Thm.concl_of thm) then SOME (#5 spc,thm) else NONE | _ => NONE) | _ => NONE) fun find_dyn_specs name P thms = map_filter (check_spec name P) thms; fun get_spec name P thms = case find_dyn_specs name P thms of (spec_mode,spec)::_ => SOME (spec_mode,spec) | _ => NONE; fun solve_spec ctxt' augment_rule _ augment_emptyFaults mode _ (SOME spec_mode) (SOME spec) i= if mode=Partial andalso spec_mode=Total then resolve_tac ctxt' [@{thm HoareTotal.hoaret_to_hoarep'}] i THEN spec_tac ctxt' augment_rule augment_emptyFaults mode spec i else if mode=spec_mode then spec_tac ctxt' augment_rule augment_emptyFaults mode spec i else error("vcg: cannot use a partial correctness specification of " ^ pname' ^ " for a total correctness proof") | solve_spec ctxt' _ asmUN_rule _ mode Static _ _ i =(* try to infer spec out of context *) EVERY[trace_tac ctxt' "inferring specification from hoare context1", resolve_tac ctxt' [asmUN_rule] i, DEPTH_SOLVE_1 (resolve_tac ctxt' [subset_refl,refl] i ORELSE ((resolve_tac ctxt' [@{thm Hoare.subset_unI1}] i APPEND resolve_tac ctxt' [@{thm Hoare.subset_unI2}] i) ORELSE (resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert1}] i APPEND resolve_tac ctxt' [@{thm Hoare.subset_singleton_insert2}] i))) ORELSE error_tac ("vcg: cannot infer specification of " ^ pname' ^ " from context") (* if tactic for DEPTH_SOLVE_1 would create new subgoals, use SELECT_GOAL and DEPTH_SOLVE *) ] | solve_spec ctxt' augment_rule asmUN_rule augment_emptyFaults mode Parameter _ _ i = (* try to infer spec out of assumptions *) let fun tac ({context = ctxt'', prems, ...}: Subgoal.focus) = (case (find_dyn_specs pname is_spec_clause prems) of (spec_mode,spec)::_ => solve_spec ctxt'' augment_rule asmUN_rule augment_emptyFaults mode Parameter (SOME spec_mode) (SOME spec) 1 | _ => all_tac) in Subgoal.FOCUS tac ctxt' i end val strip_spec_vars = strip_qnt_vars @{const_name All} o HOLogic.dest_Trueprop; fun apply_call_tac ctxt' pname mode cmode spec_mode spec_goal is_abr spec (subgoal,i) = let val spec_vars = map fst (case spec of SOME sp => (strip_spec_vars (Thm.concl_of sp)) | NONE => (case try (dest_hoare) subgoal of SOME (_,_,_,_,_,_,Theta,_) => get_auxvars_for pname Theta | _ => [])); fun get_call_rule Static mode is_abr = if is_abr then Proc mode else ProcNoAbr mode | get_call_rule Parameter mode is_abr = if is_abr then DynProcProcPar mode else DynProcProcParNoAbr mode; val [call_rule,augment_ctxt_rule,asmUN_rule, augment_emptyFaults] = adapt_aux_var ctxt' true spec_vars (map get_aux_tvar [get_call_rule cmode mode is_abr, AugmentContext mode, AsmUN mode, AugmentEmptyFaults mode]); in EVERY [resolve_tac ctxt' [call_rule] i, trace_tac ctxt' "call_tac -- basic_tac -- solving spec", solve_spec ctxt' augment_ctxt_rule asmUN_rule augment_emptyFaults mode cmode spec_mode spec spec_goal] end; fun basic_tac ctxt' spec i = let val msg ="Theorem " ^pname'^spec_sfx ^ " is no proper specification for procedure " ^pname'^ "; trying to infer specification from hoare context"; fun spec' s mode abr = if is_modifies_clause (Thm.concl_of s) then if abr then (TrivPost mode) OF [s] else (TrivPostNoAbr mode) OF [s] else s; val (is_abr,spec_mode,spec,spec_has_args) = (* is there a proper specification fact? *) case spec of NONE => (true,NONE,NONE,false) | SOME s => case try dest_hoare (Thm.concl_of s) of NONE => (warning msg;(true,NONE,NONE,false)) | SOME (_,c,Q,spec_abr,spec_mode,_,_,_) => case try dest_call c of NONE => (warning msg;(true,NONE,NONE,false)) | SOME (_,p,_,_,m,spec_has_args) => if proc_name m p = pname then if (mode=Total andalso spec_mode=Partial) then (warning msg;(true,NONE,NONE,false)) else if is_empty_set spec_abr then (false,SOME spec_mode, SOME (spec' s spec_mode false),spec_has_args) else (true,SOME spec_mode, SOME (spec' s spec_mode true),spec_has_args) else (warning msg;(true,NONE,NONE,false)); val () = if spec_has_args then error "procedure call in specification must be parameterless!" else (); val spec_goal = i+2; in EVERY[trace_tac ctxt' "call_tac -- basic_tac -- START --", SUBGOAL (apply_call_tac ctxt' pname mode cmode spec_mode spec_goal is_abr spec) i, resolve_tac ctxt' [allI] (i+1), resolve_tac ctxt' [allI] (i+1), cont_tac ctxt' (i+1), trace_tac ctxt' "call_tac -- basic_tac -- simplify", conseq_simp_tac ctxt' state_kind [@{thm StateSpace.upd_globals_def}] i, trace_tac ctxt' "call_tac -- basic_tac -- STOP --"] end; fun get_modifies (Const (@{const_name Collect},_) $ Abs (_,_,m)) = m | get_modifies t = raise TERM ("gen_call_tac.get_modifies",[t]); fun get_updates (Abs (_,_,t)) = get_updates t | get_updates (Const (@{const_name Hoare.mex},_) $ t) = get_updates t | get_updates (Const (@{const_name Hoare.meq},T) $ _ $ upd) = (T,upd) | get_updates t = raise TERM ("gen_call_tac.get_updates",[t]); (* return has the form: %s t. s(|globals:=globals t,...|) * should be translated to %s t. s(|globals := globals s(|m := m (globals t),...|),...|) * for all m in the modifies list. *) fun mk_subst gT meqT = fst (Sign.typ_unify thy (gT,domain_type meqT) (Vartab.empty,0)); fun mk_selR subst gT (upd,uT) = let val vT = range_type (hd (binder_types uT)); in Const (unsuffix Record.updateN upd,gT --> (Envir.norm_type subst vT)) end; (* lookup:: "('v => 'a) => 'n => ('n => 'v) => 'a" * update:: "('v => 'a) => ('a => 'v) => 'n => ('a => 'a) => ('n => 'v) => ('n => 'v)" *) fun mk_selF subst uT d n = let val vT_a::a_vT::nT::aT_aT::n_vT::_ = binder_types uT; val lT = (Envir.norm_type subst (vT_a --> nT --> n_vT --> (domain_type aT_aT))); val d' = map_types (Envir.norm_type subst) d; in Const (@{const_name StateFun.lookup},lT)$d'$n end; fun mk_rupdR subst gT (upd,uT) = let val [vT,_] = binder_types uT in Const (upd,(Envir.norm_type subst vT) --> gT --> gT) end; fun K_fun kn uT = let val T=range_type (hd (binder_types uT)) in Const (kn,T --> T --> T) end; fun K_rec uT t = let val T=range_type (hd (binder_types uT)) in Abs ("_", T, incr_boundvars 1 t) end; fun mk_supdF subst uT d c n = let val uT' = Envir.norm_type subst uT; val c' = map_types (Envir.norm_type subst) c; val d' = map_types (Envir.norm_type subst) d; in Const (@{const_name StateFun.update},uT')$d'$c'$n end; fun modify_updatesR subst gT glob ((Const (upd,uT))$_$(Const _$Z)) = mk_rupdR subst gT (upd,uT)$ (K_rec uT (mk_selR subst gT (upd,uT)$(glob$Bound 0)))$(glob$Bound 1) | modify_updatesR subst gT glob ((Const (upd,uT))$_$s) = mk_rupdR subst gT (upd,uT)$ (K_rec uT (mk_selR subst gT (upd,uT)$(glob$Bound 0)))$ modify_updatesR subst gT glob s | modify_updatesR subst gT glob ((_$Z)) = (glob$Bound 1) (* may_not_modify *) | modify_updatesR _ _ _ t = raise TERM ("gen_call_tac.modify_updatesR",[t]); fun modify_updatesF subst _ glob (Const (@{const_name StateFun.update},uT)$d$c$n$_$(Const globs$Z)) = mk_supdF subst uT d c n$ (K_fun KNF uT$(mk_selF subst uT d n$(glob$Bound 0)))$(glob$Bound 1) | modify_updatesF subst gT glob (Const (@{const_name StateFun.update},uT)$d$c$n$_$s) = mk_supdF subst uT d c n$ (K_fun KNF uT$(mk_selF subst uT d n$(glob$Bound 0)))$modify_updatesF subst gT glob s | modify_updatesF subst _ glob ((globs$Z)) = (glob$Bound 1) (* may_not_modify *) | modify_updatesF _ _ _ t = raise TERM ("gen_call_tac.modify_updatesF",[t]); fun modify_updates Record = modify_updatesR | modify_updates _ = modify_updatesF fun globalsT (Const (gupd,T)) = domain_type (hd (binder_types T)) | globalsT t = raise TERM ("gen_call_tac.globalsT",[t]); fun mk_upd meqT mods (gupd$(Abs (dmy,dmyT,(glob$Bound 1)))$Bound 1) = let val gT = (globalsT gupd); val subst = mk_subst gT meqT; in (gupd$(Abs (dmy,dmyT,incr_boundvars 1 (modify_updates state_kind subst gT glob mods)))$Bound 1) end | mk_upd meqT mods (upd$v$s) = upd$v$mk_upd meqT mods s | mk_upd _ _ t = raise TERM ("gen_call_tac.mk_upd",[t]); fun modify_return (meqT,mods) (Abs (s,T,Abs (t,U,upd))) = (Abs (s,T,Abs (t,U,mk_upd meqT mods upd))) | modify_return _ t = raise TERM ("get_call_tac.modify_return",[t]); fun modify_tac ctxt' spec modifies_thm i = try (fn () => let val (_,call,modif_spec_nrm,modif_spec_abr,modif_spec_mode,G,Theta,_) = dest_hoare (Thm.concl_of modifies_thm); val is_abr = not (is_empty_set modif_spec_abr); val emptyTheta = is_empty_set Theta; (*val emptyFaults = is_empty_set F;*) val spec_has_args = #6 (dest_call call); val () = if spec_has_args then error "procedure call in modifies-specification must be parameterless!" else (); val (mxprem,ModRet) = (case cmode of Static => (8,if is_abr then if emptyTheta then (ProcModifyReturn mode) else (ProcModifyReturnSameFaults mode) else if emptyTheta then (ProcModifyReturnNoAbr mode) else (ProcModifyReturnNoAbrSameFaults mode)) | Parameter => (9,if is_abr then if emptyTheta then (ProcProcParModifyReturn mode) else (ProcProcParModifyReturnSameFaults mode) else if emptyTheta then (ProcProcParModifyReturnNoAbr mode) else (ProcProcParModifyReturnNoAbrSameFaults mode))); val to_prove_prem = (case cmode of Static => 0 | Parameter => 1); val spec_goal = if is_abr then i + mxprem - 5 else i + mxprem - 6 val mods_nrm = modif_spec_nrm |> get_modifies |> get_updates; val return' = modify_return mods_nrm return; (* val return' = if is_abr then let val mods_abr = modif_spec_abr |> get_modifies |> get_updates; in modify_return mods_abr return end else return;*) val cret = Thm.cterm_of ctxt' return'; val (_,_,return'_var,_,_,_) = nth (Thm.prems_of ModRet) to_prove_prem |> dest_hoare |> #2 |> dest_call; val ModRet' = infer_instantiate ctxt' [(#1 (dest_Var return'_var), cret)] ModRet; val modifies_thm_partial = if modif_spec_mode = Total then @{thm HoareTotal.hoaret_to_hoarep'} OF [modifies_thm] else modifies_thm; fun solve_modifies_tac i = (clarsimp_tac ((ctxt' |> put_claset (claset_of @{theory_context Set}) |> put_simpset (simpset_of @{theory_context Set})) addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def},@{thm StateSpace.upd_globals_def}]@K_convs) addsimprocs (state_upd_simproc Record::(state_simprocs state_kind)) |> fold Simplifier.add_cong K_congs) i) THEN_MAYBE EVERY [trace_tac ctxt' "modify_tac: splitting record", state_split_simp_tac ctxt' [] state_space i]; val cnt = i + mxprem; in EVERY[trace_tac ctxt' "call_tac -- modifies_tac --", resolve_tac ctxt' [ModRet'] i, solve_spec ctxt' (AugmentContext Partial) (AsmUN Partial) (AugmentEmptyFaults Partial) Partial Static (SOME Partial) (SOME modifies_thm_partial) spec_goal, if is_abr then EVERY [trace_tac ctxt' "call_tac -- Solving abrupt modifies --", solve_modifies_tac (cnt - 6)] else all_tac, trace_tac ctxt' "call_tac -- Solving Modifies --", solve_modifies_tac (cnt - 7), basic_tac ctxt' spec (cnt - 8), if cmode = Parameter then EVERY [resolve_tac ctxt' [subset_refl] (cnt - 8), simp_tac (put_simpset HOL_basic_ss ctxt' addsimps (@{thm Hoare.CollectInt_iff} :: @{thms simp_thms})) 1] else all_tac] end) () |> (fn SOME res => res | NONE => raise TERM ("get_call_tac.modify_tac: no proper modifies spec", [])); fun specs_of_assms_tac ({context = ctxt', prems, ...}: Subgoal.focus) = (case get_spec pname is_spec_clause prems of SOME (_,spec) => (case get_spec pname is_modifies_clause prems of SOME (_,modifies_thm) => modify_tac ctxt' (SOME spec) modifies_thm 1 | NONE => basic_tac ctxt' (SOME spec) 1) | NONE => (warning ("no proper specification for procedure " ^pname^ " in assumptions"); all_tac)); val test_modify_in_ctxt_tac = let val mname = (suffix modifysfx pname'); val mspec = (case try (Proof_Context.get_thm ctxt) mname of SOME s => SOME s | NONE => (case AList.lookup (op =) asms pname of SOME s => if is_modifies_clause (Thm.concl_of s) then SOME s else NONE | NONE => NONE)); in (case mspec of NONE => basic_tac ctxt spec | SOME modifies_thm => (case check_spec pname is_modifies_clause modifies_thm of SOME _ => modify_tac ctxt spec modifies_thm | NONE => (warning ("ignoring theorem " ^ (suffix modifysfx pname') ^ "; no proper modifies specification for procedure "^pname'); basic_tac ctxt spec))) end; fun inline_bdy_tac has_args i = (case try (Proof_Context.get_thm ctxt) (suffix bodyP pname') of NONE => no_tac | SOME impl => (case try (Proof_Context.get_thm ctxt) (suffix (body_def_sfx^"_def") pname') of NONE => no_tac | SOME bdy => (tracing ("No specification found for procedure \"" ^ pname' ^ "\". Inlining procedure!"); if has_args then EVERY [trace_tac ctxt "inline_bdy_tac args", resolve_tac ctxt [CallBody mode] i, resolve_tac ctxt [impl] (i+3), resolve_tac ctxt [allI] (i+2), resolve_tac ctxt [allI] (i+2), in_assertion_simp_tac ctxt state_kind [] (i+2), cont_tac ctxt (i+2), resolve_tac ctxt [allI] (i+1),in_assertion_simp_tac ctxt state_kind [bdy] (i+1), cont_tac ctxt (i+1), in_assertion_simp_tac ctxt state_kind [@{thm StateSpace.upd_globals_def}] i] else EVERY [trace_tac ctxt "inline_bdy_tac no args", resolve_tac ctxt [ProcBody mode] i, resolve_tac ctxt [impl] (i+2), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [bdy]) (i+1), cont_tac ctxt (i+1)]))); in (case cmode of Static => if get_recursive pname ctxt = SOME false andalso is_none spec then inline_bdy_tac has_args else test_modify_in_ctxt_tac | Parameter => (case spec of NONE => (tracing "no spec found!"; Subgoal.FOCUS specs_of_assms_tac ctxt) | SOME spec => (tracing "found spec!"; case check_spec pname is_spec_clause spec of SOME _ => test_modify_in_ctxt_tac | NONE => (warning ("ignoring theorem " ^ (suffix spec_sfx pname') ^ "; no proper specification for procedure " ^pname'); Subgoal.FOCUS specs_of_assms_tac ctxt)))) end; fun call_tac cont_tac mode state_kind state_space ctxt asms spec_sfx t = let val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); fun gen_tac (_,pname,return,c,cmode,has_args) = gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx (proc_name cmode pname) return has_args F; in gen_tac (dest_call c) end handle TERM _ => K no_tac; fun solve_in_Faults_tac ctxt i = resolve_tac ctxt [UNIV_I, @{thm in_insert_hd}] i ORELSE SELECT_GOAL (SOLVE (simp_tac (put_simpset (simpset_of @{theory_context Set}) ctxt) 1)) i; local fun triv_simp ctxt = merge_assertion_simp_tac ctxt [mem_Collect_eq] THEN' simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms simp_thms} |> fold Simplifier.add_cong [@{thm conj_cong}, @{thm imp_cong}]); (* a guarded while produces stupid things, since the guards are put at the end of the body and in the invariant (rule WhileAnnoG): - guard: g /\ g - guarantee: g --> g *) in fun guard_tac ctxt strip cont_tac mode (t,i) = let val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); val (_,_,_,doStrip) = dest_Guard c; val guarantees = if strip orelse doStrip then [GuardStrip mode, GuaranteeStrip mode] else [Guarantee mode] fun basic_tac i = EVERY [resolve_tac ctxt [Guard mode, GuaranteeAsGuard mode] i, trace_tac ctxt "Guard", cont_tac ctxt (i+1), triv_simp ctxt i] fun guarantee_tac i = EVERY [resolve_tac ctxt guarantees i, solve_in_Faults_tac ctxt (i+2), cont_tac ctxt (i+1), triv_simp ctxt i] in if is_empty_set F then EVERY [trace_tac ctxt "Guard: basic_tac", basic_tac i] else EVERY [trace_tac ctxt "Guard: trying guarantee_tac", guarantee_tac i ORELSE basic_tac i] end handle TERM _ => no_tac end; fun wf_tac ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Wellfounded.wf_measure},@{thm Wellfounded.wf_lex_prod},@{thm Wfrec.wf_same_fst}, @{thm Hoare.wf_measure_lex_prod},@{thm Wellfounded.wf_inv_image}]); fun in_rel_simp ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Hoare.in_measure_iff},@{thm Hoare.in_lex_iff},@{thm Hoare.in_mlex_iff},@{thm Hoare.in_inv_image_iff}, @{thm split_conv}]); fun while_annotate_tac ctxt inv i st = let val annotateWhile = Thm.lift_rule (Thm.cprem_of st i) @{thm HoarePartial.reannotateWhileNoGuard}; val lifted_inv = fold_rev Term.abs (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)) inv; val invVar = (#1 o strip_comb o #3 o dest_whileAnno o #2 o dest_hoare) (List.last (Thm.prems_of annotateWhile)); val annotate = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt lifted_inv)] annotateWhile; in ((trace_tac ctxt ("annotating While with: " ^ Syntax.string_of_term ctxt lifted_inv )) THEN compose_tac ctxt (false,annotate,1) i) st end; fun cond_annotate_tac ctxt inv mode (_,i) st = let val annotateCond = Thm.lift_rule (Thm.cprem_of st i) (CondInv' mode); val lifted_inv = fold_rev Term.abs (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)) inv; val invVar = List.last (Thm.prems_of annotateCond) |> dest_hoare |> #3 |> strip_comb |> #1; val annotate = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt lifted_inv)] annotateCond; in ((trace_tac ctxt ("annotating Cond with: "^ Syntax.string_of_term ctxt lifted_inv)) THEN compose_tac ctxt (false,annotate,5) i) st end; fun basic_while_tac ctxt state_kind cont_tac tac mode i = let fun common_tac i = EVERY[if mode=Total then wf_tac ctxt (i+3) else all_tac, BasicSimpTac ctxt state_kind true [] tac (i+2), if mode=Total then in_rel_simp ctxt (i+1) THEN (resolve_tac ctxt [allI] (i+1)) else all_tac, cont_tac ctxt (i+1) ] fun basic_tac i = EVERY [resolve_tac ctxt [While mode] i, common_tac i] in EVERY [trace_tac ctxt "basic_while_tac: basic_tac", basic_tac i] end; fun while_tac ctxt state_kind inv cont_tac tac mode t i= let val basic_tac = basic_while_tac ctxt state_kind cont_tac tac mode; in (case inv of NONE => basic_tac i | SOME I => EVERY [while_annotate_tac ctxt I i, basic_tac i]) end handle TERM _ => no_tac fun dest_split (Abs (x,T,t)) = let val (vs,recomb,bdy) = dest_split t; in ((x,T)::vs,fn t' => Abs (x,T,recomb t'),bdy) end | dest_split (c as Const (@{const_name case_prod},_)$Abs(x,T,t)) = let val (vs,recomb,bdy) = dest_split t; in ((x,T)::vs,fn t' => c$Abs (x,T,recomb t'),bdy) end | dest_split t = ([],I,t); fun whileAnnoG_tac ctxt strip_guards mode t i st = let val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); val (SOME grds,_,I,_,_,fix) = dest_whileAnno c; val Rule = if fix then WhileAnnoGFix mode else WhileAnnoG mode; fun extract_faults (Const (@{const_name Set.insert}, _) $ t $ _) = [t] | extract_faults _ = []; fun leave_grd fs (Const (@{const_name Pair}, _) $ f $ g) = if member (op =) fs f andalso strip_guards then NONE else SOME g | leave_grd fs (Const (@{const_name Language.guaranteeStripPair}, _) $ f $ g) = if member (op =) fs f then NONE else SOME g | leave_grd fs _ = NONE; val (I_vs,I_recomb,I') = dest_split I; val grds' = map_filter (leave_grd (extract_faults F)) (HOLogic.dest_list grds); val pars = (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)); val J = fold_rev Term.abs pars (I_recomb (fold_rev (mk_Int (map snd (pars@I_vs))) grds' I')); val WhileG = Thm.lift_rule (Thm.cprem_of st i) Rule; val invVar = (fst o strip_comb o #3 o dest_whileAnno o (fn xs => nth xs 1) o snd o strip_comb o #2 o dest_hoare) (List.last (Thm.prems_of WhileG)); val WhileGInst = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt J)] WhileG; in ((trace_tac ctxt ("WhileAnnoG, adding guards to invariant: " ^ Syntax.string_of_term ctxt J)) THEN compose_tac ctxt (false,WhileGInst,1) i) st end handle TERM _ => no_tac st | Bind => no_tac st (* renames bound state variable according to name given in goal, * before rule specAnno is applied, and solves sidecondition *) fun gen_Anno_tac dest rules tac cont_tac ctxt state_kind (t,i) st = let val vars = (dest o #2 o dest_hoare) (Logic.strip_assums_concl t); val rules' = (case (List.filter (not o null) (map dest_splits vars)) of [] => rules |(xs::_) => adapt_aux_var ctxt false (map fst xs) (map get_aux_tvar rules)); in EVERY [resolve_tac ctxt rules' i, tac, simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([@{thm split_conv}, refl, @{thm Hoare.triv_All_eq}]@anno_defs) addsimprocs [@{simproc case_prod_beta}]) (i+2), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm split_conv}]) (i+1), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm split_conv}]) i, REPEAT (resolve_tac ctxt [allI] (i+1)), cont_tac ctxt (i+1), conseq_simp_tac ctxt state_kind [] i] st end handle TERM _ => no_tac st; fun specAnno_tac ctxt state_kind cont_tac mode = let fun dest_specAnno (Const (@{const_name Language.specAnno},_)$P$c$Q$A) = [P,c,Q,A] | dest_specAnno t = raise TERM ("dest_specAnno",[t]); val rules = [SpecAnnoNoAbrupt mode,SpecAnno mode]; in gen_Anno_tac dest_specAnno rules all_tac cont_tac ctxt state_kind end; fun whileAnnoFix_tac ctxt state_kind cont_tac mode (t,i) = let fun dest (Const (@{const_name Language.whileAnnoFix},_)$b$I$V$c) = [I,V,c] | dest t = raise TERM ("dest_whileAnnoFix",[t]); val rules = [WhileAnnoFix mode]; fun wf_tac' i = EVERY [REPEAT (resolve_tac ctxt [allI] i), simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm split_conv}]) i, wf_tac ctxt i]; val tac = if mode=Total then EVERY [wf_tac' (i+3),in_rel_simp ctxt (i+1)] else all_tac in gen_Anno_tac dest rules tac cont_tac ctxt state_kind (t,i) end; fun lemAnno_tac ctxt state_kind mode (t,i) st = let fun dest_name (Const (x,_)) = x | dest_name (Free (x,_)) = x | dest_name t = raise TERM ("dest_name",[t]); fun dest_lemAnno (Const (@{const_name Language.lem},_)$n$c) = let val x = Long_Name.base_name (dest_name n); in (case try (Proof_Context.get_thm ctxt) x of NONE => error ("No lemma: '" ^ x ^ "' found.") | SOME spec => (strip_qnt_vars @{const_name All} (HOLogic.dest_Trueprop (Thm.concl_of spec)),spec)) end | dest_lemAnno t = raise TERM ("dest_lemAnno",[t]); val (vars,spec) = dest_lemAnno (#2 (dest_hoare t)); val rules = [LemAnnoNoAbrupt mode,LemAnno mode]; val rules' = (case vars of [] => rules | xs => adapt_aux_var ctxt true (map fst xs) (map get_aux_tvar rules)); in EVERY [resolve_tac ctxt rules' i, resolve_tac ctxt [spec] (i+1), conseq_simp_tac ctxt state_kind [] i] st end handle TERM _ => no_tac st; fun prems_tac ctxt i = TRY (resolve_tac ctxt (Assumption.all_prems_of ctxt) i); fun mk_proc_assoc thms = let fun name (_,p,_,_,cmode,_) = proc_name cmode p; fun proc_name thm = thm |> Thm.concl_of |> dest_hoare |> #2 |> dest_call |> name; in map (fn thm => (proc_name thm,thm)) thms end; fun mk_hoare_tac cont ctxt mode i (name,tac) = EVERY [trace_tac ctxt ("trying: " ^ name),tac cont ctxt mode i]; (* the main hoare tactic *) fun HoareTac annotate_inv exspecs strip_guards mode state_kind state_space spec_sfx ctxt tac st = let val (P,c,Q,A,_,G,T,F) = dest_hoare (Logic.strip_assums_concl (Logic.get_goal (Thm.prop_of st) 1)); val wp_tacs = #wp_tacs (get_data ctxt); val hoare_tacs = #hoare_tacs (get_data ctxt); val params = (strip_vars (Logic.get_goal (Thm.prop_of st) 1)); val Inv = (if annotate_inv then (* Take the postcondition of the triple as invariant for all *) (* while loops (makes sense for the modifies clause) *) SOME Q else NONE); val exspecthms = map (Proof_Context.get_thm ctxt) exspecs; val asms = try (fn () => mk_proc_assoc (gen_context_thms ctxt mode params G T F @ exspecthms)) () |> the_default []; fun while_annoG_tac (t,i) = whileAnnoG_tac ctxt (annotate_inv orelse strip_guards) mode t i; fun WlpTac tac i = (* WlpTac does not end with subset_refl *) FIRST ([EVERY [resolve_tac ctxt [Seq mode] i,trace_tac ctxt "Seq",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [Catch mode] i,trace_tac ctxt "Catch",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [CondCatch mode] i,trace_tac ctxt "CondCatch",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [BSeq mode] i,trace_tac ctxt "BSeq",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [FCall mode] i,trace_tac ctxt "FCall"], EVERY [resolve_tac ctxt [GuardsNil mode] i,trace_tac ctxt "GuardsNil"], EVERY [resolve_tac ctxt [GuardsConsGuaranteeStrip mode] i, trace_tac ctxt "GuardsConsGuaranteeStrip"], EVERY [resolve_tac ctxt [GuardsCons mode] i,trace_tac ctxt "GuardsCons"], EVERY [SUBGOAL while_annoG_tac i] ] @ map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) wp_tacs) and HoareRuleTac tac pre_cond ctxt i st = let fun call (t,i) = call_tac (HoareRuleTac tac false) mode state_kind state_space ctxt asms spec_sfx t i fun cond_tac i = if annotate_inv andalso Config.get ctxt use_cond_inv_modifies then EVERY[SUBGOAL (cond_annotate_tac ctxt (the Inv) mode) i, HoareRuleTac tac false ctxt (i+4), HoareRuleTac tac false ctxt (i+3), BasicSimpTac ctxt state_kind true [] tac (i+2), BasicSimpTac ctxt state_kind true [] tac (i+1) ] else EVERY[resolve_tac ctxt [Cond mode] i,trace_tac ctxt "Cond", HoareRuleTac tac false ctxt (i+2), HoareRuleTac tac false ctxt (i+1)]; fun switch_tac i = EVERY[resolve_tac ctxt [SwitchNil mode] i, trace_tac ctxt "SwitchNil"] ORELSE EVERY[resolve_tac ctxt [SwitchCons mode] i,trace_tac ctxt "SwitchCons", HoareRuleTac tac false ctxt (i+2), HoareRuleTac tac false ctxt (i+1)]; fun while_tac' (t,i) = while_tac ctxt state_kind Inv (HoareRuleTac tac true) tac mode t i; in st |> ( (WlpTac tac i THEN HoareRuleTac tac pre_cond ctxt i) ORELSE (FIRST([EVERY[resolve_tac ctxt [Skip mode] i,trace_tac ctxt "Skip"], EVERY[resolve_tac ctxt [BasicCond mode] i, trace_tac ctxt "BasicCond", assertion_simp_tac ctxt state_kind [] i], (resolve_tac ctxt [Basic mode] i THEN trace_tac ctxt "Basic") THEN_MAYBE (assertion_simp_tac ctxt state_kind [] i), (* we don't really need simplificaton here. The question is if it is better to simplify the assertion after each Basic step, so that intermediate assertions stay "small", or if we just accumulate the raw assertions and leave the simplification to the final BasicSimpTac *) EVERY[resolve_tac ctxt [Throw mode] i, trace_tac ctxt "Throw"], (resolve_tac ctxt [Raise mode] i THEN trace_tac ctxt "Raise") THEN_MAYBE (assertion_string_eq_simp_tac ctxt state_kind [] i), cond_tac i, switch_tac i, EVERY[resolve_tac ctxt [Block mode] i, trace_tac ctxt "Block", resolve_tac ctxt [allI] (i+2), resolve_tac ctxt [allI] (i+2), HoareRuleTac tac false ctxt (i+2), resolve_tac ctxt [allI] (i+1), in_assertion_simp_tac ctxt state_kind [] (i+1), HoareRuleTac tac false ctxt (i+1)], SUBGOAL while_tac' i, SUBGOAL (guard_tac ctxt (annotate_inv orelse strip_guards) (HoareRuleTac tac false) mode) i, EVERY[SUBGOAL (specAnno_tac ctxt state_kind (HoareRuleTac tac true) mode) i], EVERY[SUBGOAL (whileAnnoFix_tac ctxt state_kind (HoareRuleTac tac true) mode) i], EVERY[resolve_tac ctxt [SpecIf mode] i, trace_tac ctxt "SpecIf", assertion_simp_tac ctxt state_kind [] i], (resolve_tac ctxt [Spec mode] i THEN trace_tac ctxt "Spec") THEN_MAYBE (assertion_simp_tac ctxt state_kind [@{thm split_conv}] i), EVERY[resolve_tac ctxt [BindR mode] i, trace_tac ctxt "Bind", resolve_tac ctxt [allI] (i+1), HoareRuleTac tac false ctxt (i+1)], EVERY[resolve_tac ctxt [DynCom mode] i, trace_tac ctxt "DynCom"], EVERY[trace_tac ctxt "calling call_tac",SUBGOAL call i], EVERY[trace_tac ctxt "LemmaAnno",SUBGOAL (lemAnno_tac ctxt state_kind mode) i]] @ map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) hoare_tacs) THEN (if pre_cond then EVERY [trace_tac ctxt "pre_cond", TRY (BasicSimpTac ctxt state_kind true [] tac i), (* FIXME: Do we need TRY *) trace_tac ctxt "after BasicSimpTac"] else (resolve_tac ctxt [subset_refl] i)))) end; in ((K (EVERY [REPEAT (resolve_tac ctxt [allI] 1), HoareRuleTac tac true ctxt 1])) THEN_ALL_NEW (prems_tac ctxt)) 1 st (*Procedure specifications may have an locale assumption as premise. These are accumulated by the vcg and are be solved afterward by prems_tac *) end; fun prefer_tac i = (Tactic.defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1)); fun HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac st = let val asms = try (fn () => let val (_,_,_,_,_,G,T,F) = dest_hoare (Logic.strip_assums_concl (Logic.get_goal (Thm.prop_of st) 1)); val params = (strip_vars (Logic.get_goal (Thm.prop_of st) 1)); in mk_proc_assoc (gen_context_thms ctxt mode params G T F) end) () |> the_default []; fun result_tac ctxt' i = TRY (EVERY [resolve_tac ctxt' [Basic mode] i, resolve_tac ctxt' [subset_refl] i]); fun call (t,i) = call_tac result_tac mode state_kind state_space ctxt asms spec_sfx t i fun final_simp_tac i = EVERY [full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq]) i, REPEAT (eresolve_tac ctxt [conjE] i), TRY (hyp_subst_tac_thin true ctxt i), BasicSimpTac ctxt state_kind true [] tac i] fun while_annoG_tac (t,i) = whileAnnoG_tac ctxt strip_guards mode t i; in st |> (REPEAT (resolve_tac ctxt [allI] 1) THEN FIRST [resolve_tac ctxt [subset_refl] 1, EVERY[resolve_tac ctxt [Skip mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [BasicCond mode] 1,trace_tac ctxt "BasicCond", TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Basic mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Throw mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Raise mode] 1,TRY (assertion_string_eq_simp_tac ctxt state_kind [] 1)], resolve_tac ctxt [SeqSwap mode] 1 THEN_MAYBE HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac, EVERY[resolve_tac ctxt [BSeq mode] 1, prefer_tac 2 THEN_MAYBE HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac], resolve_tac ctxt [CondSwap mode] 1, resolve_tac ctxt [SwitchNil mode] 1, resolve_tac ctxt [SwitchCons mode] 1, EVERY [SUBGOAL while_annoG_tac 1], EVERY[resolve_tac ctxt [While mode] 1, if mode=Total then wf_tac ctxt 4 else all_tac, BasicSimpTac ctxt state_kind false [] tac 3, if mode=Total then in_rel_simp ctxt 2 THEN (resolve_tac ctxt [allI] 2) else all_tac, BasicSimpTac ctxt state_kind false [] tac 1], resolve_tac ctxt [CatchSwap mode] 1, resolve_tac ctxt [CondCatchSwap mode] 1, EVERY[resolve_tac ctxt [BlockSwap mode] 1, resolve_tac ctxt [allI] 1, resolve_tac ctxt [allI] 1, resolve_tac ctxt [allI] 2, BasicSimpTac ctxt state_kind false [] tac 2], resolve_tac ctxt [GuardsNil mode] 1, resolve_tac ctxt [GuardsConsGuaranteeStrip mode] 1, resolve_tac ctxt [GuardsCons mode] 1, SUBGOAL (guard_tac ctxt strip_guards (K (K all_tac)) mode) 1, EVERY[SUBGOAL (specAnno_tac ctxt state_kind (K (K all_tac)) mode) 1], EVERY[SUBGOAL (whileAnnoFix_tac ctxt state_kind (K (K all_tac)) mode) 1], EVERY[resolve_tac ctxt [SpecIf mode] 1,trace_tac ctxt "SpecIf", TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Spec mode] 1, TRY (BasicSimpTac ctxt state_kind false [@{thm split_conv}] tac 1)], EVERY[resolve_tac ctxt [BindR mode] 1, resolve_tac ctxt [allI] 2, prefer_tac 2], EVERY[resolve_tac ctxt [FCall mode] 1], EVERY[resolve_tac ctxt [DynCom mode] 1], EVERY[SUBGOAL call 1, BasicSimpTac ctxt state_kind false [] tac 1], EVERY[SUBGOAL (lemAnno_tac ctxt state_kind mode) 1, BasicSimpTac ctxt state_kind false [] tac 1], final_simp_tac 1 ]) end; (*****************************************************************************) (** Generalise verification condition **) (*****************************************************************************) structure RecordSplitState : SPLIT_STATE = struct val globals = @{const_name StateSpace.state.globals}; fun isState (Const _$Abs (s,T,t)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" andalso is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | _ => false) | isState _ = false; fun isFreeState (Free (_,T)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" | _ => false) | isFreeState _ = false; val abs_state = Option.map snd o first_subterm isFreeState; fun sel_eq (Const (x,_)$_) y = (x=y) | sel_eq t y = raise TERM ("RecordSplitState.sel_eq",[t]); val sel_idx = idx sel_eq; fun bound xs (t as (Const (x,_)$_)) = let val i = sel_idx xs x in if i < 0 then (length xs, xs@[t]) else (i,xs) end | bound xs t = raise TERM ("RecordSplitState.bound",[t]); fun abs_var _ (Const (x,T)$_) = (remdeco' (Long_Name.base_name x),range_type T) | abs_var _ t = raise TERM ("RecordSplitState.abs_var",[t]); fun fld_eq (x, _) y = (x = y) fun fld_idx xs x = idx fld_eq xs x; fun sort_vars ctxt T vars = let val thy = Proof_Context.theory_of ctxt; val (flds,_) = Record.get_recT_fields thy T; val gT = the (AList.lookup (fn (x:string,y) => x=y) flds globals); val (gflds,_) = (Record.get_recT_fields thy gT handle TYPE _ => ([],("",dummyT))); fun compare (Const _$Free _, Const _$(Const _$Free _)) = GREATER | compare (Const (s1,_)$Free _, Const (s2,_)$Free _) = int_ord (fld_idx flds s1, fld_idx flds s2) | compare (Const (s1,_)$(Const _$Free _), Const (s2,_)$(Const _$Free _)) = int_ord (fld_idx gflds s1, fld_idx gflds s2) | compare _ = LESS; in sort (rev_order o compare) vars end; fun fold_state_prop loc glob app abs other inc s res (t as (Const (sel,_)$Free (s',_))) = if s'=s then if is_state_var sel then loc inc res t else raise TERM ("RecordSplitState.fold_state_prop",[t]) else other res t | fold_state_prop loc glob app abs other inc s res (t as ((t1 as (Const (sel,_)))$(t2 as (Const (glb,_)$Free (s',_))))) = if s'=s andalso is_state_var sel andalso (glb=globals) then glob inc res t else let val res1 = fold_state_prop loc glob app abs other inc s res t1 val res2 = fold_state_prop loc glob app abs other inc s res1 t2 in app res1 res2 end | fold_state_prop loc glob app abs other inc s res (t as (Free (s',_))) = if s'=s then raise TERM ("RecordSplitState.fold_state_prop",[t]) else other res t | fold_state_prop loc glob app abs other inc s res (t1$t2) = let val res1 = fold_state_prop loc glob app abs other inc s res t1 val res2 = fold_state_prop loc glob app abs other inc s res1 t2 in app res1 res2 end | fold_state_prop loc glob app abs other inc s res (Abs (x,T,t)) = let val res1 = fold_state_prop loc glob app abs other (inc+1) s res t in abs x T res1 end | fold_state_prop loc glob app abs other inc s res t = other res t fun collect_vars s t = let fun loc _ vars t = snd (bound vars t); fun glob _ vars t = snd (bound vars t); fun app _ vars2 = vars2; fun abs _ _ vars = vars; fun other vars _ = vars; in fold_state_prop loc glob app abs other 0 s [] t end; fun abstract_vars vars s t = let fun loc inc _ t = let val i = fst (bound vars t) in Bound (i+inc) end; fun glob inc _ t = let val i = fst (bound vars t) in Bound (i+inc) end; fun app t1 t2 = t1$t2; fun abs x T t = Abs (x,T,t); fun other _ t = t; val dummy = Bound 0; in fold_state_prop loc glob app abs other 0 s dummy t end; fun split_state ctxt s T t = let val vars = collect_vars s t; val vars' = if Config.get ctxt sort_variables then sort_vars ctxt T vars else vars; in (abstract_vars vars' s t,rev vars') end; fun ex_tac ctxt _ st = Record.split_simp_tac ctxt @{thms simp_thms} (K ~1) 1 st; end; structure FunSplitState : SPLIT_STATE = struct val full_globalsN = @{const_name StateSpace.state.globals}; fun isState (Const _$Abs (s,T,t)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" andalso is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | _ => false) | isState _ = false; fun isFreeState (Free (_,T)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" | _ => false) | isFreeState _ = false; val abs_state = Option.map snd o first_subterm isFreeState; fun comp_name t = case try (implode o dest_string) t of SOME str => str | NONE => (case t of Free (s,_) => s | Const (s,_) => s | t => raise TERM ("FunSplitState.comp_name",[t])) fun sel_name (Const _$_$name$_) = comp_name name | sel_name t = raise TERM ("FunSplitState.sel_name",[t]); fun sel_raw_name (Const _$_$name$_) = name | sel_raw_name t = raise TERM ("FunSplitState.sel_raw_name",[t]); fun component_type (Const _$_$_$(sel$_)) = range_type (fastype_of sel) | component_type t = raise TERM ("FunSplitState.component_type",[t]); fun component_name (Const _$_$_$((Const (sel,_)$_))) = sel | component_name t = raise TERM ("FunSplitState.component_name",[t]); fun sel_type (Const _$destr$_$_) = range_type (fastype_of destr) | sel_type t = raise TERM ("FunSplitState.sel_type",[t]); fun sel_destr (Const _$destr$_$_) = destr | sel_destr t = raise TERM ("FunSplitState.sel_destr",[t]); fun sel_eq t y = (sel_name t = y) | sel_eq t y = raise TERM ("FunSplitState.sel_eq",[t]); val sel_idx = idx sel_eq; fun bound xs t = let val i = sel_idx xs (sel_name t) in if i < 0 then (length xs, xs@[t]) else (i,xs) end | bound xs t = raise TERM ("FunSplitState.bound",[t]); fun fold_state_prop var app abs other inc s res (t as (Const (@{const_name StateFun.lookup},_)$destr$name$(Const _$Free (s',_)))) = if s'=s then var inc res t else other res t (*raise TERM ("FunSplitState.fold_state_prop",[t])*) | fold_state_prop var app abs other inc s res (t as (Free (s',_))) = if s'=s then raise TERM ("FunSplitState.fold_state_prop",[t]) else other res t | fold_state_prop var app abs other inc s res (t1$t2) = let val res1 = fold_state_prop var app abs other inc s res t1 val res2 = fold_state_prop var app abs other inc s res1 t2 in app res1 res2 end | fold_state_prop var app abs other inc s res (Abs (x,T,t)) = let val res1 = fold_state_prop var app abs other (inc+1) s res t in abs x T res1 end | fold_state_prop var app abs other inc s res t = other res t fun collect_vars s t = let fun var _ vars t = snd (bound vars t); fun app _ vars2 = vars2; fun abs _ _ vars = vars; fun other vars _ = vars; in fold_state_prop var app abs other 0 s [] t end; fun abstract_vars vars s t = let fun var inc _ t = let val i = fst (bound vars t) in Bound (i+inc) end; fun app t1 t2 = t1$t2; fun abs x T t = Abs (x,T,t); fun other _ t = t; val dummy = Bound 0; in fold_state_prop var app abs other 0 s dummy t end; fun sort_vars _ vars = let val fld_idx = idx (fn s1:string => fn s2 => s1 = s2); fun compare (_$_$n$(Const (s1,_)$_),_$_$m$(Const (s2,_)$_)) = let val n' = remdeco' (comp_name n); val m' = remdeco' (comp_name m); in if s1 = full_globalsN then if s2 = full_globalsN then string_ord (n',m') else LESS else if s2 = full_globalsN then GREATER else string_ord (n',m') end | compare (t1,t2) = raise TERM ("FunSplitState.sort_vars.compare",[t1,t2]); in sort (rev_order o compare) vars end; fun split_state ctxt s _ t = let val vars = collect_vars s t; val vars' = if Config.get ctxt sort_variables then sort_vars ctxt vars else vars; in (abstract_vars vars' s t,rev vars') end; fun abs_var _ t = (remdeco' (sel_name t), sel_type t); (* Proof for: EX x_1 ... x_n. P x_1 ... x_n * ==> EX s. P (lookup destr_1 "x_1" s) ... (lookup destr_n "x_n" s) * Implementation: * 1. Eliminate existential quantifiers in premise * 2. Instantiate s with: (%x. undefined)("x_1" := constr_1 x_1, ..., "x_n" := constr_n x_n) * 3. Simplify *) local val ss = simpset_of (put_simpset (simpset_of @{theory_context Fun}) @{context} addsimps (@{thm StateFun.lookup_def} :: @{thm StateFun.id_id_cancel} :: @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms}) addsimprocs [Record.simproc, StateFun.lazy_conj_simproc] |> fold Simplifier.add_cong @{thms block_conj_cong}); in fun ex_tac ctxt vs st = let val vs' = rev vs; val (Const (_,exT)$_) = HOLogic.dest_Trueprop (Logic.strip_imp_concl (Logic.get_goal (Thm.prop_of st) 1)); val sT = domain_type (domain_type exT); val s0 = Const (@{const_name HOL.undefined},sT); fun streq (s1:string,s2) = s1=s2 ; fun mk_init [] = [] | mk_init (t::ts) = let val xs = mk_init ts; val n = component_name t; val T = component_type t; in if AList.defined streq xs n then xs else (n,(T,Const (n,sT --> component_type t)$s0))::xs end; fun mk_upd (i,t) xs = let val selN = component_name t; val selT = component_type t; val (_,s) = the (AList.lookup streq xs selN); val strT = domain_type selT; val valT = range_type selT; val constr = destr_to_constr (sel_destr t); val name = (sel_raw_name t); val upd = Const (@{const_name Fun.fun_upd}, (strT --> valT)-->strT-->valT--> (strT --> valT)) $ s $ name $ (constr $ Bound i) in AList.update streq (selN,(selT,upd)) xs end; val upds = fold_index mk_upd vs' (mk_init vs'); val upd = fold (fn (n,(T,upd)) => fn s => Const (n ^ Record.updateN, T --> sT --> sT)$upd$s) upds s0; val inst = fold_rev (Term.abs o (fn t => (sel_name t, sel_type t))) vs upd; fun lift_inst_ex_tac i st = let val rule = Thm.lift_rule (Thm.cprem_of st i) (Drule.incr_indexes st exI); val (_$x) = HOLogic.dest_Trueprop (Logic.strip_assums_concl (hd (Thm.prems_of rule))); val inst_rule = infer_instantiate ctxt [(#1 (dest_Var (head_of x)), Thm.cterm_of ctxt inst)] rule; in (compose_tac ctxt (false,inst_rule, Thm.nprems_of exI) i st) end; in EVERY [REPEAT_DETERM_N (length vs) (eresolve_tac ctxt [exE] 1), lift_inst_ex_tac 1, simp_tac (put_simpset ss ctxt) 1 ] st end end (* Test: What happens when there are no lookups., EX s. True *) end; structure GeneraliseRecord = GeneraliseFun (structure SplitState=RecordSplitState); structure GeneraliseStateFun = GeneraliseFun (structure SplitState=FunSplitState); fun generalise Record = GeneraliseRecord.GENERALISE | generalise Function = GeneraliseStateFun.GENERALISE; (*****************************************************************************) (** record_vanish_tac splits up the records of a verification condition, **) (** trying to generate a predicate without records. **) (** A typical verification condition with a procedure call will have the **) (** form "!!s Z. s=Z ==> ..., where s and Z are records **) (*****************************************************************************) (* FIXME: Check out if removing the useless vars is a performance issue. If so, maybe we can remove all useless vars at once (no iterated simplification) or try to avoid introducing them. Bevore splitting the gaol we can simplifiy the goal with state_simproc this may leed to better performance... *) fun record_vanish_tac ctxt state_kind state_space i = if Config.get ctxt record_vanish then let val rem_useless_vars_simps = [Drule.triv_forall_equality,@{thm Hoare.triv_All_eq},@{thm Hoare.triv_Ex_eq}]; val rem_useless_vars_simpset = empty_simpset ctxt addsimps rem_useless_vars_simps; fun no_spec (t as (Const (@{const_name All},_)$_)) = is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | no_spec _ = true; fun state_space_no_spec t = if state_space t <> 0 andalso no_spec t then ~1 else 0; in EVERY [trace_tac ctxt "record_vanish_tac -- START --", REPEAT (eresolve_tac ctxt [conjE] i), trace_tac ctxt "record_vanish_tac -- hyp_subst_tac ctxt --", TRY (hyp_subst_tac_thin true ctxt i), full_simp_tac rem_useless_vars_simpset i, (* hyp_subst_tac may have made some state variables unnecessary. We do not want to split them to avoid naming conflicts and increase performance *) trace_tac ctxt "record_vanish_tac -- Splitting records --", if Config.get ctxt use_generalise orelse state_kind = Function then generalise state_kind ctxt i else state_split_simp_tac ctxt rem_useless_vars_simps state_space_no_spec i (*THEN_MAYBE EVERY [trace_tac ctxt "record_vanish_tac -- removing useless vars --", full_simp_tac rem_useless_vars_simpset i, trace_tac ctxt "record_vanish_tac -- STOP --"]*) ] end else all_tac; (* solve_modifies_tac tries to solve modifies-clauses automatically; * The following strategy is followed: * After clar-simplifying the modifies clause we remain with a goal of the form * * EX a b. s(|A := x|) = s(|A:=a,B:=b|) * * (or because of conditional statements conjunctions of these kind of goals) * We split up the state-records and simplify (record_vanish_tac) and get to a goal of the form: * * EX a b. (|A=x,B=B|) = (|A=a,B=b|). * * If the modifies clause was correct we just have to introduce the existential quantifies * and apply reflexivity. * If not we just simplify the goal. *) local val state_fun_update_ss = simpset_of (put_simpset HOL_basic_ss @{context} addsimps ([@{thm StateFun.update_def}, @{thm id_def}, @{thm fun_upd_apply}, @{thm if_True}, @{thm if_False}] @ @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms} @ K_fun_convs) addsimprocs [DistinctTreeProver.distinct_simproc ["distinct_fields", "distinct_fields_globals"]] |> Simplifier.add_cong @{thm imp_cong} (* K_fun_congs FIXME: Stefan fragen*) |> Splitter.add_split @{thm if_split}); in fun solve_modifies_tac ctxt state_kind state_space i st = let val thy = Proof_Context.theory_of ctxt; fun is_split_state (trm as (Const (@{const_name Pure.all},_)$Abs(x,T,t))) = if state_space trm <> 0 then try (fn () => let fun seed (_ $ v $ st) = seed st | seed (_ $ t) = (1,t) (* split only state pair *) | seed t = (~1,t) (* split globals completely *) val all_vars = strip_qnt_vars @{const_name Pure.all} t; val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl t); val ex_vars = strip_qnt_vars @{const_name Ex} concl; val state = Bound (length all_vars + length ex_vars); val (Const (@{const_name HOL.eq},_)$x_upd$x_upd') = strip_qnt_body @{const_name Ex} concl; val (split,sd) = seed x_upd; in if sd = state then split else 0 end) () |> the_default 0 else 0 | is_split_state t = 0; val simp_ctxt = put_simpset HOL_ss ctxt addsimps (@{thm Ex_True} :: @{thm Ex_False} :: Record.get_extinjects thy); fun try_solve Record i = (*(SOLVE*) (((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) THEN_ALL_NEW (fn k => EVERY [state_split_simp_tac ctxt [] is_split_state k, simp_tac simp_ctxt k THEN_MAYBE rename_goal ctxt remdeco' k ])) i) (*)*) | try_solve _ i = ((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) THEN_ALL_NEW (fn k => REPEAT (resolve_tac ctxt [exI] k) THEN resolve_tac ctxt [ext] k THEN simp_tac (put_simpset state_fun_update_ss ctxt) k THEN_MAYBE (REPEAT_ALL_NEW (resolve_tac ctxt [conjI,impI,refl]) k))) i in ((trace_tac ctxt "solve_modifies_tac" THEN clarsimp_tac ((ctxt |> put_claset (claset_of @{theory_context HOL}) |> put_simpset (simpset_of @{theory_context Set})) addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def}]@K_convs) addsimprocs (state_upd_simproc Record::(state_simprocs Record)) |> fold Simplifier.add_cong K_congs) i) THEN_MAYBE try_solve state_kind i) st end; end fun proc_lookup_simp_tac ctxt i st = try (fn () => let val name = (Logic.concl_of_goal (Thm.prop_of st) i) |> dest_hoare |> #2 |> strip_comb |> #2 |> last |> strip_comb |> #2 |> last; (* the$(Gamma$name) or the$(strip$Gamma$name) *) val pname = (unsuffix proc_deco (dest_string' name)); val thms = map_filter I (map (try (Proof_Context.get_thm ctxt)) [suffix bodyP pname, suffix (body_def_sfx^"_def") pname, suffix procL pname^"."^ (suffix (body_def_sfx^"_def") pname)]); in simp_tac (put_simpset HOL_basic_ss ctxt addsimps thms @ strip_simps @ @{thms option.sel}) i st end) () |> the_default (Seq.single st); fun proc_lookup_in_dom_simp_tac ctxt i st = try (fn () => let val _$name$_ = (HOLogic.dest_Trueprop (Logic.concl_of_goal (Thm.prop_of st) i)); (* name : Gamma *) val pname = (unsuffix proc_deco (dest_string' name)); val thms = map_filter I (map (try (Proof_Context.get_thm ctxt)) [suffix bodyP pname]); in simp_tac (put_simpset HOL_basic_ss ctxt addsimps (@{thm Hoare.lookup_Some_in_dom} :: @{thm dom_strip} :: thms)) i st end) () |> the_default (Seq.single st); fun HoareRuleTac ctxt insts fixes st = let val annotate_simp_tac = simp_tac (put_simpset HOL_basic_ss ctxt addsimps (anno_defs@normalize_simps) addsimprocs [@{simproc case_prod_beta}]); fun is_com_eq (Const (@{const_name Trueprop},_)$(Const (@{const_name HOL.eq},T)$_$_)) = (case (binder_types T) of (Type (@{type_name Language.com},_)::_) => true | _ => false) | is_com_eq _ = false; fun annotate_tac i st = if is_com_eq (Logic.concl_of_goal (Thm.prop_of st) i) then annotate_simp_tac i st else all_tac st; in ((fn i => REPEAT (resolve_tac ctxt [allI] i)) THEN' Rule_Insts.res_inst_tac ctxt insts fixes st) THEN_ALL_NEW annotate_tac end; fun HoareCallRuleTac state_kind state_space ctxt thms i st = let fun dest_All (Const (@{const_name All},_)$t) = SOME t | dest_All _ = NONE; fun auxvars t = (case (map_filter ((first_subterm is_hoare) o snd) (max_subterms_dest dest_All t)) of ((vars,_)::_) => vars | _ => []); fun auxtype rule = (case (auxvars (Thm.prop_of rule)) of [] => NONE | vs => (case (last vs) of (_,TVar (z,_)) => SOME (z,rule) | _ => NONE)); val thms' = let val auxvs = map fst (auxvars (Logic.concl_of_goal (Thm.prop_of st) i)); val tvar_thms = map_filter auxtype thms in if length thms = length tvar_thms then adapt_aux_var ctxt true auxvs tvar_thms else thms end; val is_sidecondition = not o can dest_hoare; fun solve_sidecondition_tac (t,i) = if is_sidecondition t then FIRST [CHANGED_PROP (wf_tac ctxt i), (*init_conforms_tac state_kind state_space i,*) post_conforms_tac ctxt state_kind i THEN_MAYBE (if is_modifies_clause t then solve_modifies_tac ctxt state_kind state_space i else all_tac), proc_lookup_in_dom_simp_tac ctxt i ] else in_rel_simp ctxt i THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Un_empty_left},@{thm Un_empty_right}]) i THEN proc_lookup_simp_tac ctxt i fun basic_tac i = (((resolve_tac ctxt thms') THEN_ALL_NEW (fn k => (SUBGOAL solve_sidecondition_tac k))) i) in (basic_tac ORELSE' (fn k => (REPEAT (resolve_tac ctxt [allI] k)) THEN EVERY [resolve_tac ctxt thms' k])) i st end; (* vcg_polish_tac tries to solve modifies-clauses automatically; for other specifications the * records are only splitted and simplified. *) fun vcg_polish_tac solve_modifies ctxt state_kind state_space i = if solve_modifies then solve_modifies_tac ctxt state_kind state_space i else record_vanish_tac ctxt state_kind state_space i THEN_MAYBE EVERY [rename_goal ctxt remdeco' i(*, simp_tac (HOL_basic_ss addsimps @{thms simp_thms})) i*)]; fun is_funtype (Type ("fun", _)) = true | is_funtype _ = false; fun state_kind_of ctxt T = let val thy = Proof_Context.theory_of ctxt; val (s,sT) = nth (fst (Record.get_recT_fields thy T)) 1; in if Long_Name.base_name s = "locals" andalso is_funtype sT then Function else Record end handle Subscript => Record; fun find_state_space_in_triple ctxt t = try (fn () => (case first_subterm is_hoare t of NONE => NONE | SOME (abs_vars,triple) => let val (_,com,_,_,mode,_,_,_) = dest_hoare_raw triple; val T = fastype_of1 (map snd abs_vars,com) val Type(_,state_spaceT::_) = T; val SOME Tids = stateT_ids state_spaceT; in SOME (Tids,mode, state_kind_of ctxt state_spaceT) end)) () |> Option.join; fun get_state_space_in_subset_eq ctxt t = (* get state type from the following kind of terms: P <= Q, s: P *) try (fn () => let val (subset_eq,_) = (strip_comb o HOLogic.dest_Trueprop o strip_qnt_body @{const_name Pure.all}) t; val Ts = map snd (strip_vars t); val T = fastype_of1 (Ts,subset_eq); val Type (_, [_,Type (_, [Type (_, [state_spaceT]), _])]) = T; (* also works for "in": x : P *) val SOME Tids = stateT_ids state_spaceT; in (Tids,Partial, state_kind_of ctxt state_spaceT) end) (); fun get_state_space ctxt i st = (case try (Logic.concl_of_goal (Thm.prop_of st)) i of SOME t => (case find_state_space_in_triple ctxt t of SOME sp => SOME sp | NONE => get_state_space_in_subset_eq ctxt t) | NONE => NONE); fun mk_hoare_tac hoare_tac finish_tac annotate_inv exnames strip_guards spec_sfx ctxt i st = case get_state_space ctxt i st of SOME (Tids,mode,kind) => SELECT_GOAL (hoare_tac annotate_inv exnames strip_guards mode kind (is_state_space_var Tids) spec_sfx ctxt (finish_tac kind (is_state_space_var Tids))) i st | NONE => no_tac st fun vcg_tac spec_sfx strip_guards exnames ctxt i st = mk_hoare_tac HoareTac (vcg_polish_tac (spec_sfx="_modifies") ctxt) (spec_sfx="_modifies") exnames (strip_guards="true") spec_sfx ctxt i st; fun hoare_tac spec_sfx strip_guards _ ctxt i st = let fun tac state_kind state_space i = if spec_sfx="_modifies" then solve_modifies_tac ctxt state_kind state_space i else all_tac; in mk_hoare_tac HoareTac tac (spec_sfx="_modifies") [] (strip_guards="true") spec_sfx ctxt i st end; fun hoare_raw_tac spec_sfx strip_guards exnames ctxt i st = mk_hoare_tac HoareTac (K (K (K all_tac))) (spec_sfx="_modifies") [] (strip_guards="true") spec_sfx ctxt i st; fun hoare_step_tac spec_sfx strip_guards exnames ctxt i st = mk_hoare_tac (K (K HoareStepTac)) (vcg_polish_tac (spec_sfx="_modifies") ctxt) false [] (strip_guards="true") spec_sfx ctxt i st; fun hoare_rule_tac ctxt thms i st = SUBGOAL (fn _ => (case get_state_space ctxt i st of SOME (Tids,_,kind) => HoareCallRuleTac kind (is_state_space_var Tids) ctxt thms i | NONE => error "could not find proper state space type (structure or record) in goal")) i st; (*** Methods ***) val hoare_rule = Rule_Insts.method HoareRuleTac hoare_rule_tac; val argP = Args.name --| @{keyword "="} -- Args.name val argsP = Scan.repeat argP val default_args = [("spec","spec"),("strip_guards","false")] val vcg_simp_modifiers = [Args.add -- Args.colon >> K (Method.modifier vcg_simp_add \<^here>), Args.del -- Args.colon >> K (Method.modifier vcg_simp_del \<^here>)]; fun assocs2 key = map snd o filter (curry (op =) key o fst); fun gen_simp_method tac = Scan.lift (argsP >> (fn args => args @ default_args)) --| Method.sections vcg_simp_modifiers >> (fn args => fn ctxt => Method.SIMPLE_METHOD' (tac ("_" ^ the (AList.lookup (op =) args "spec")) (the (AList.lookup (op =) args "strip_guards")) (assocs2 "exspec" args) ctxt)); val hoare = gen_simp_method hoare_tac; val hoare_raw = gen_simp_method hoare_raw_tac; val vcg = gen_simp_method vcg_tac; val vcg_step = gen_simp_method hoare_step_tac; val trace_hoare_users = Unsynchronized.ref false fun print_subgoal_tac ctxt s i = SUBGOAL (fn (prem, _) => trace_tac ctxt (s ^ (Syntax.string_of_term ctxt prem))) i fun mk_hoare_thm thm _ ctxt _ i = EVERY [resolve_tac ctxt [thm] i, if !trace_hoare_users then print_subgoal_tac ctxt "Tracing: " i else all_tac] val vcg_hoare_add = Thm.declaration_attribute (fn thm => add_hoare_tacs [(Thm.derivation_name thm, mk_hoare_thm thm)]) exception UNDEF val vcg_hoare_del = Thm.declaration_attribute (fn _ => fn _ => raise UNDEF) (* setup theory *) val _ = Theory.setup (Attrib.setup @{binding vcg_simp} (Attrib.add_del vcg_simp_add vcg_simp_del) "declaration of Simplifier rule for vcg" #> Attrib.setup @{binding vcg_hoare} (Attrib.add_del vcg_hoare_add vcg_hoare_del) "declaration of wp rule for vcg") (*#> add_wp_tacs initial_wp_tacs*) end; diff --git a/thys/Transcendence_Series_Hancl_Rucki/document/root.bib b/thys/Transcendence_Series_Hancl_Rucki/document/root.bib --- a/thys/Transcendence_Series_Hancl_Rucki/document/root.bib +++ b/thys/Transcendence_Series_Hancl_Rucki/document/root.bib @@ -1,13 +1,36 @@ +%% This BibTeX bibliography file was created using BibDesk. +%% http://bibdesk.sourceforge.net/ + + +%% Created for Larry Paulson at 2023-05-16 12:07:07 +0100 + + +%% Saved with string encoding Unicode (UTF-8) + + + @article{hancl2005, - author = "Han\v{c}l, J. and Rucki, P.", - title = "The transcendence of certain infinite series", - journal = "Rocky Mountain Journal of Mathematics", - - volume = "35", number = "2", - year = "2005", - pages = "531--537", - publisher = "Rocky Mountain Mathematics Consortium", - url = "https://doi.org/10.1216/rmjm/1181069744"} + author = {Han\v{c}l, J. and Rucki, P.}, + date-modified = {2023-05-16 12:06:58 +0100}, + journal = {Rocky Mountain Journal of Mathematics}, + number = {2}, + pages = {531-537}, + publisher = {Rocky Mountain Mathematics Consortium}, + title = {The Transcendence Of Certain Infinite Series}, + url = {https://doi.org/10.1216/rmjm/1181069744}, + volume = {35}, + year = {2005}, + bdsk-url-1 = {https://doi.org/10.1216/rmjm/1181069744}} -@article{roth_1955, author={Roth, K. F.}, title={Rational approximations to algebraic numbers}, journal={Mathematika}, volume={2}, part={1}, number={3}, year={1955}, pages={1--20}, publisher={London Mathematical Society and University College London}, DOI={10.1112/S0025579300000644}}. - +@article{roth_1955, + author = {Roth, K. F.}, + doi = {10.1112/S0025579300000644}, + journal = {Mathematika}, + number = {3}, + pages = {1--20}, + part = {1}, + publisher = {London Mathematical Society and University College London}, + title = {Rational approximations to algebraic numbers}, + volume = {2}, + year = {1955}, + bdsk-url-1 = {https://doi.org/10.1112/S0025579300000644}} diff --git a/thys/Types_To_Sets_Extension/ETTS/ETTS_Lemmas.ML b/thys/Types_To_Sets_Extension/ETTS/ETTS_Lemmas.ML --- a/thys/Types_To_Sets_Extension/ETTS/ETTS_Lemmas.ML +++ b/thys/Types_To_Sets_Extension/ETTS/ETTS_Lemmas.ML @@ -1,370 +1,370 @@ (* Title: ETTS/ETTS_Lemmas.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins Implementation of the command tts_lemmas. *) signature TTS_LEMMAS = sig val tts_lemmas : Proof.context -> ETTS_Algorithm.etts_output_type -> ((binding * Token.src list) * (thm list * (string * Token.src list))) list -> Proof.context * int list end; structure TTS_Lemmas : TTS_LEMMAS = struct (**** Prerequisites ****) open ETTS_Algorithm; open ETTS_Context; open ETTS_Active; (**** Implicit statement of theorems ****) fun register_output ctxt ab out_thms = let val ((thmc, out_thms), lthy) = let val facts' = (ab ||> map (Attrib.check_src ctxt), single (out_thms, [])) |> single |> Attrib.partial_evaluation ctxt in ctxt |> Local_Theory.notes facts' |>> the_single end val _ = CTR_Utilities.thm_printer lthy true thmc out_thms in (lthy, "") end (**** Output to an active area ****) local (*number of repeated premises*) fun num_rep_prem eq ts = let val premss = map Logic.strip_imp_prems ts val min_length = min_list (map length premss) val premss = map (take min_length) premss val template_prems = hd premss val num_eq_prems = premss |> tl |> map ( compare_each eq template_prems #> take_prefix (curry op= true) #> length ) val num_rep_prems = if length premss = 1 then length template_prems else min_list num_eq_prems in (num_rep_prems, premss) end; (*elimination of premises*) fun elim_assms assm_thms thm = fold (flip Thm.implies_elim) assm_thms thm; (*create a single theorem from a fact via Pure conjunction*) fun thm_of_fact ctxt thms = let val ts = map Thm.full_prop_of thms val (num_rep_prems, _) = num_rep_prem (op aconv) ts val rep_prems = thms |> hd |> Thm.full_prop_of |> Logic.strip_imp_prems |> take num_rep_prems |> map (Thm.cterm_of ctxt); val all_ftv_rels = let val subtract = swap #> uncurry (subtract op=) in rep_prems |> map ( Thm.term_of #> Logic.forall_elim_all #> apfst (fn t => Term.add_frees t []) #> apsnd dup #> reroute_sp_ps #> apfst (apfst dup) #> apfst reroute_ps_sp #> apfst (apsnd subtract) #> apfst subtract ) end val index_of_ftvs = all_ftv_rels |> map ( #1 #> map_index I #> map swap #> AList.lookup op= #> curry (swap #> op#>) the ) val all_indicess = (map #2 all_ftv_rels) ~~ index_of_ftvs |> map (fn (x, f) => map f x) val (assms, ctxt') = Assumption.add_assumes rep_prems ctxt val stvss = map ( Thm.full_prop_of #> (fn t => Term.add_vars t []) #> map Var #> map (Thm.cterm_of ctxt) ) assms val stvss = stvss ~~ all_indicess |> map (fn (stvs, indices) => map (nth stvs) indices) val assms = map2 forall_intr_list stvss assms val thm = thms |> map (elim_assms assms) |> Conjunction.intr_balanced - |> singleton (Proof_Context.goal_export ctxt' ctxt) + |> singleton (Proof_Context.export_goal ctxt' ctxt) in thm end; in (*output to an active area*) fun active_output ctxt thm_out_str attrs_out thm_in_str attrs_in thms = let val (thms, ctxt') = Thm.unvarify_local_fact ctxt thms val thmc = thms |> thm_of_fact ctxt' |> Thm.full_prop_of |> theorem_string_of_term ctxt tts_lemma thm_out_str attrs_out thm_in_str attrs_in in (ctxt, thmc) end; end; (**** Implementation ****) fun tts_lemmas ctxt tts_output_type thm_specs = let fun process_thm_out_str c = if Symbol_Pos.is_identifier c then c else quote c val { mpespc_opt = mpespc_opt, rispec = rispec, sbtspec = sbtspec, sbrr_opt = sbrr_opt, subst_thms = subst_thms, attrbs = attrbs } = get_tts_ctxt_data ctxt val writer = ETTS_Writer.initialize 4 fun folder ((b, attrs_out), (thms, (thm_in_str, attrs_in))) (ctxt, thmcs, writer) = let val ((out_thms, writer), ctxt) = ETTS_Algorithm.etts_fact ctxt tts_output_type writer rispec sbtspec sbrr_opt subst_thms mpespc_opt attrbs thms val writer = ETTS_Writer.increment_index 0 writer val (lthy, thmc) = if is_default tts_output_type orelse is_verbose tts_output_type then register_output ctxt (b, attrs_out) out_thms else active_output ctxt (b |> Name_Space.base_name |> process_thm_out_str) attrs_out thm_in_str attrs_in out_thms val thmcs = thmcs ^ thmc in (lthy, thmcs, writer) end val (ctxt'', thmcs, writer) = fold folder thm_specs (ctxt, "", writer) val _ = if is_active tts_output_type then thmcs |> Active.sendback_markup_command |> writeln else () in (ctxt'', writer) end; (**** Parser ****) local val parse_output_mode = Scan.optional (\<^keyword>\!\ || \<^keyword>\?\) ""; val parse_facts = \<^keyword>\in\ |-- Parse_Spec.name_facts; in val parse_tts_lemmas = parse_output_mode -- parse_facts; end; (**** User input analysis ****) fun mk_msg_tts_lemmas msg = "tts_lemmas: " ^ msg; fun thm_specs_raw_input thm_specs_raw = let val msg_multiple_facts = mk_msg_tts_lemmas "only one fact per entry is allowed" val _ = thm_specs_raw |> map (#2 #> length) |> List.all (fn n => n = 1) orelse error msg_multiple_facts in () end; (**** Evaluation ****) local fun mk_thm_specs ctxt thm_specs_raw = let (*auxiliary functions*) fun process_thm_in_name c = let val flag_identifier = c |> Long_Name.explode |> map Symbol_Pos.is_identifier |> List.all I in if flag_identifier then c else quote c end (*based on Facts.string_of_ref from Facts.ML in src/Pure*) fun process_thm_in_ref (Facts.Named ((name, _), sel)) = process_thm_in_name name ^ Facts.string_of_selection sel | process_thm_in_ref (Facts.Fact _) = raise Fail "Illegal literal fact"; fun binding_last c = let val binding_last_h = Long_Name.base_name #> Binding.qualified_name in if size c = 0 then Binding.empty else binding_last_h c end fun binding_of_binding_spec (b, (factb, thmbs)) = if Binding.is_empty b then if length thmbs = 1 then if Binding.is_empty (the_single thmbs) then factb else the_single thmbs else factb else b (*main*) val thm_specs = thm_specs_raw |> map (apsnd the_single) |> ( Facts.string_of_ref #> binding_last |> apdupl |> apfst #> reroute_ps_sp |> apsnd |> map ) |> map reroute_sp_ps |> map (reroute_ps_sp #> (swap |> apsnd) #> reroute_sp_ps |> apfst) |> map (apsnd dup) |> ( single #> (ctxt |> Attrib.eval_thms) #> (Thm.derivation_name #> binding_last |> map |> apdupl) |> apfst |> apsnd |> map ) |> map (reroute_sp_ps #> apfst reroute_sp_ps #> reroute_ps_sp) |> ( reroute_ps_sp #> (swap |> apsnd) #> reroute_sp_ps #> (reroute_ps_sp #> binding_of_binding_spec |> apfst) |> apfst |> map ) |> map (process_thm_in_ref |> apfst |> apsnd |> apsnd) in thm_specs end; in fun process_tts_lemmas args ctxt = let (*unpacking*) val tts_output_type = args |> #1 |> etts_output_type_of_string val thm_specs_raw = #2 args (*user input analysis*) val _ = thm_specs_raw_input thm_specs_raw (*pre-processing*) val thm_specs = mk_thm_specs ctxt thm_specs_raw in thm_specs |> tts_lemmas ctxt tts_output_type |> #1 end; end; (**** Interface ****) val _ = Outer_Syntax.local_theory \<^command_keyword>\tts_lemmas\ "automated relativization of facts" (parse_tts_lemmas >> process_tts_lemmas); end; \ No newline at end of file diff --git a/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML b/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML --- a/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML +++ b/thys/Types_To_Sets_Extension/ETTS/ETTS_Substitution.ML @@ -1,353 +1,353 @@ (* Title: ETTS/ETTS_Substitution.ML Author: Mihails Milehins Copyright 2021 (C) Mihails Milehins Implementation of the functionality associated with the sbterms. *) signature ETTS_SUBSTITUTION = sig val sbt_data_of : Proof.context -> Ctermtab.key -> thm option val is_sbt_data_key : Proof.context -> cterm -> bool val process_tts_register_sbts : string * string list -> Proof.context -> Proof.state end; structure ETTS_Substitution : ETTS_SUBSTITUTION = struct (**** Prerequisites ****) open ETTS_Utilities; open ETTS_RI; (**** Data containers ****) (*** Data ***) structure SBTData_Args = struct type T = thm Ctermtab.table val empty = Ctermtab.empty val merge : (T * T -> T) = Ctermtab.merge (K true) fun init _ = Ctermtab.empty end; structure Global_SBTData = Theory_Data (SBTData_Args); structure Local_SBTData = Proof_Data (SBTData_Args); (*** Generic operations ***) val sbt_data_of = Local_SBTData.get #> Ctermtab.lookup; val sbt_data_keys = Local_SBTData.get #> Ctermtab.keys fun map_sbt_data f (Context.Proof ctxt) = ctxt |> Local_SBTData.map f |> Context.Proof | map_sbt_data f (Context.Theory thy) = thy |> Global_SBTData.map f |> Context.Theory; fun update_sbt_data k v = let fun declaration phi = (Morphism.cterm phi k, Morphism.thm phi v) |> Ctermtab.update |> map_sbt_data - in Local_Theory.declaration {pervasive=true, syntax=false} declaration end; + in Local_Theory.declaration {pervasive=true, syntax=false, pos = \<^here>} declaration end; fun is_sbt_data_key ctxt ct = member (op aconvc) (sbt_data_keys ctxt) ct; (**** Evaluation : tts_find_sbts *****) fun process_tts_find_sbts args st = let val ctxt = Toplevel.context_of st val args = case args of [] => sbt_data_keys ctxt | args => map (ctxt |> Syntax.read_term #> Thm.cterm_of ctxt) args in args |> map (sbt_data_of ctxt #> the #> Thm.string_of_thm ctxt |> apdupr) |> map (Thm.term_of #> Syntax.string_of_term ctxt |> apfst) |> map ((fn (c, thmc) => c ^ " : " ^ thmc) #> writeln) |> K () end; (**** Parser : tts_find_sbts ****) val parse_tts_find_sbts = Parse.and_list Parse.term; (**** Interface : tts_find_sbts *****) val _ = Outer_Syntax.command \<^command_keyword>\tts_find_sbts\ "lookup a theorem associated with a constant or a fixed variable" (parse_tts_find_sbts >> (process_tts_find_sbts #> Toplevel.keep)); (**** Evaluation : tts_register_sbts *****) local fun mk_msg_tts_register_sbts msg = "tts_register_sbts: " ^ msg; (*create the goals for the function register_sbts_cmd*) fun mk_goal_register_sbts ctxt sbt risset = let val msg_repeated_risset = mk_msg_tts_register_sbts "the type variables associated with the risset must be distinct" (*auxiliary functions*) fun mk_rel_assms (brelt, rissett) = [ mk_Domainp_sc brelt rissett, Transfer.mk_bi_unique brelt, Transfer.mk_right_total brelt ]; (*risset \ unique ftvs of risset*) val rissetftv_specs = map (type_of #> dest_rissetT) risset (*input verification*) val _ = rissetftv_specs |> has_duplicates op= |> not orelse error msg_repeated_risset (*sbt \ (sbt, ftvs of sbt)*) val sbt = sbt |> (type_of #> (fn t => Term.add_tfreesT t []) |> apdupr) (* (sbt, ftvs of sbt), rissetftv_specs \ ((sbtftv_int, rcdftv_int)s, (sbtftv_sub, rcdftv_sub)s), ctxt), where sbtftv_ints = unique ftvs of sbt \ ftvs of risset sbtftv_subs = unique ftvs of sbt - ftvs of risset *) val (sbtftv_specs, ctxt) = let fun mk_ri_rhs_Ts ctxt f = map (apdupr f) #> map_slice_side_r (fn Ss => Variable.invent_types Ss ctxt) in sbt |> #2 |> distinct op= |> dup |>> inter op= rissetftv_specs ||> subtract op= rissetftv_specs |>> mk_ri_rhs_Ts ctxt (K \<^sort>\HOL.type\) |>> swap |> reroute_ps_sp |> swap |>> apsnd (map dup) end (*(sbt, ftvs of sbt) \ (sbt, sbtftv_ints)*) val sbt = apsnd (filter (member op= (sbtftv_specs |> #1 |> map #1))) sbt (* (sbtftv_int, rcdftv_int)s, sbtftv_subs) \ (((sbtftv, rcdftv), ri brel)s, ctxt) *) val (sbtftv_specs, ctxt') = let val un_of_typ = #1 #> term_name_of_type_name in sbtftv_specs |>> map (apfst un_of_typ #> apsnd un_of_typ |> apdupr) |>> map (apsnd op^) |>> map_slice_side_r (fn cs => Variable.variant_fixes cs ctxt) |>> (apfst TFree #> apsnd TFree |> apdupr |> apfst |> map |> apfst) |>> (reroute_ps_sp |> map |> apfst) |>> (swap #> HOLogic.mk_rel |> apsnd |> map |> apfst) |>> swap |> reroute_ps_sp |> swap |>> (#1 #> TFree #> HOLogic.eq_const |> apdupr |> map |> apsnd) end (*((sbtftv, rcdftv), ri brel)s, ctxt \ (premises, conclusion)*) val sbt_specs = let val ftv_map = sbtftv_specs |> #1 |> map (apfst #1) |> AList.lookup op= #> the val ftv_map' = sbtftv_specs |> op@ |> map (apfst #1) val risset_of_ftv_spec = ((risset |> map (type_of #> dest_rissetT)) ~~ risset) |> AList.lookup op= val map_specTs_to_rcdTs = sbtftv_specs |> op@ |> map (#1 #> apsnd TFree) |> AList.lookup op= #> the val (rct_name, ctxt'') = ctxt' |> Variable.variant_fixes (single "rcdt") |>> the_single in sbt |> ( ( ftv_map |> apdupl #> (risset_of_ftv_spec #> the |> apsnd) #> mk_rel_assms |> map #> flat #> map HOLogic.mk_Trueprop |> apsnd ) #> (#1 #> type_of |> apdupl) #> (ftv_map' |> CTR_Relators.pr_of_typ ctxt'' |> apfst) ) |> (fn x => (x, rct_name)) |> ( (#1 #> #2 #> #1 #> type_of |> apdupr) #> (map_specTs_to_rcdTs |> map_type_tfree |> apsnd) #> reroute_ps_sp #> (Free |> apdupl |> apsnd) ) |> reroute_sp_ps |> ( apfst reroute_sp_ps #> reroute_ps_sp #> apsnd swap |> apfst #> apfst reroute_sp_ps #> reroute_ps_sp #> apsnd swap #> reroute_sp_ps ) |> ( apfst op$ #> op$ |> apfst #> swap #> reroute_ps_triple #> HOLogic.mk_exists #> HOLogic.mk_Trueprop #> Syntax.check_term ctxt'' |> apfst ) |> swap end (*introduce the side conditions for each ex_pr*) val goal = let fun add_premts (premts, conclt) = fold_rev (fn premt => fn t => Logic.mk_implies (premt, t)) premts conclt in add_premts sbt_specs end in (goal, ctxt') end in (*implementation of the functionality of the command tts_register_sbts*) fun process_tts_register_sbts args ctxt = let (*error messages*) val msg_fv_not_fixed = mk_msg_tts_register_sbts "all fixed variables that occur in the sbterm " ^ "must be fixed in the context" val msg_ftv_not_fixed = mk_msg_tts_register_sbts "all fixed type variables that occur in the sbterm " ^ "must be fixed in the context" val msg_sv = mk_msg_tts_register_sbts "the sbterm must contain no schematic variables" val msg_stv = mk_msg_tts_register_sbts "the sbterm must contain no schematic type variables" (*pre-processing and input verification*) val sbt = args |> #1 |> Syntax.read_term ctxt val risset = args |> #2 |> map (Syntax.read_term ctxt) val _ = ETTS_RI.risset_input ctxt "tts_register_sbts" risset val _ = sbt |> (fn t => Term.add_frees t []) |> distinct op= |> map #1 |> map (Variable.is_fixed ctxt) |> List.all I orelse error msg_fv_not_fixed val _ = sbt |> (fn t => Term.add_tfrees t []) |> distinct op= |> map #1 |> map (Variable.is_declared ctxt) |> List.all I orelse error msg_ftv_not_fixed val _ = sbt |> (fn t => Term.add_vars t []) |> length |> curry op= 0 orelse error msg_sv val _ = sbt |> (fn t => Term.add_tvars t []) |> length |> curry op= 0 orelse error msg_stv (*main*) val (goalt, _) = mk_goal_register_sbts ctxt sbt risset val goal_specs = (goalt, []) |> single |> single val ct = Thm.cterm_of ctxt sbt fun after_qed thmss lthy = update_sbt_data ct (thmss |> hd |> hd) lthy in Proof.theorem NONE after_qed goal_specs ctxt end; end; (**** Parser : tts_register_sbts ****) val parse_tts_register_sbts = Parse.term -- (\<^keyword>\|\ |-- Parse.and_list Parse.term); (**** Interface : tts_register_sbts ****) val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\tts_register_sbts\ "command for the registration of the set-based terms" (parse_tts_register_sbts >> process_tts_register_sbts) end; \ No newline at end of file diff --git a/thys/X86_Semantics/X86_Parse.ML b/thys/X86_Semantics/X86_Parse.ML --- a/thys/X86_Semantics/X86_Parse.ML +++ b/thys/X86_Semantics/X86_Parse.ML @@ -1,356 +1,355 @@ (* TODO: segment registers *) datatype Operand = (* size (in bytes) segment offset base index scale *) Mem of ( int * string option * int * string * string * int) | Reg of string | Imm of LargeInt.int datatype Instr = Instr of (LargeInt.int * LargeInt.int * string * Operand option * Operand option * Operand option) (* PRETTY PRINTING *) fun pp_option NONE = "" | pp_option (SOME s) = s fun pp_mem_size 1 = "BYTE PTR" | pp_mem_size 2 = "WORD PTR" | pp_mem_size 4 = "DWORD PTR" | pp_mem_size 8 = "QWORD PTR" | pp_mem_size 16 = "XMMWORD PTR" | pp_mem_size n = "SIZEDIR " ^ Int.toString (n*8) ^ " PTR" fun pp_operand (Mem (si,segment,offset,base, index, scale)) = pp_mem_size si ^ " " ^ pp_option segment ^ ":[" ^ Int.toString offset ^ " + " ^ base ^ " + " ^ index ^ " * " ^ Int.toString scale ^ "]" | pp_operand (Reg r) = r | pp_operand (Imm i) = Int.toString i fun pp_operands [] = "" | pp_operands (NONE::_) = "" | pp_operands [SOME op1] = pp_operand op1 | pp_operands [SOME op1,NONE] = pp_operand op1 | pp_operands (SOME op1::op2::ops) = pp_operand op1 ^ ", " ^ pp_operands (op2::ops) fun pp_instr (Instr (a,si,m,op1,op2,op3)) = LargeInt.toString a ^ ": " ^ m ^ " " ^ pp_operands [op1,op2,op3] ^ " (" ^ LargeInt.toString si ^ ")" val intFromHexString = StringCvt.scanString (LargeInt.scan StringCvt.HEX) o Substring.string fun intFromHexString_forced s = case intFromHexString s of SOME i => i | NONE => raise Fail ("Could not convert string '" ^ Substring.string s ^ "' to int.") fun is_whitespace c = (c = #" " orelse c = #"\t" orelse c = #"\n") fun trim str = let val (_,x) = Substring.splitl is_whitespace str val (y,_) = Substring.splitr is_whitespace x in y end; (* PARSING *) val registers = [ "rip", "rax", "eax", "ax", "ah", "al", "rbx", "ebx", "bx", "bh", "bl", "rcx", "ecx", "cx", "ch", "cl", "rdx", "edx", "dx", "dh", "dl", "rbp", "ebp", "bp", "bpl", "rsp", "esp", "sp", "spl", "rdi", "edi", "di", "dil", "rsi", "esi", "si", "sil", "r15", "r15d", "r15w", "r15b", "r14", "r14d", "r14w", "r14b", "r13", "r13d", "r13w", "r13b", "r12", "r12d", "r12w", "r12b", "r11", "r11d", "r11w", "r11b", "r10", "r10d", "r10w", "r10b", "r9", "r9d", "r9w", "r9b", "r8", "r8d", "r8w", "r8b", "xmm0","xmm1","xmm2","xmm3","xmm4","xmm5","xmm6","xmm7","xmm8", "xmm9","xmm10","xmm11","xmm12","xmm13","xmm14","xmm15" ] fun is_register str = List.find (fn (str') => String.compare (Substring.string str,str') = EQUAL) registers <> NONE fun overwrite_str "" s = s | overwrite_str s "" = s | overwrite_str _ s = s fun overwrite_str_option NONE s = s | overwrite_str_option s NONE = s | overwrite_str_option _ s = s fun max x y = if x >= y then x else y fun overwrite_Mem (Mem (si,seg,off,base,ind,sc)) (Mem (si',seg',off',base',ind',sc')) = Mem (max si si',overwrite_str_option seg seg',max off off',overwrite_str base base',overwrite_str ind ind',max sc sc') fun parse_operand_address_between_brackets_inner str = if is_register str then Mem (0,NONE,0,Substring.string str,"",0) (* base *) else let val tokens = map trim (Substring.tokens (fn c => c = #"*") str) in if length tokens = 1 then case intFromHexString str of SOME i => Mem (0,NONE,i,"","",0) (* offset *) | NONE => raise Fail ("Don't know how to parse operand part:" ^ Substring.string str) else if length tokens = 2 then if is_register (nth tokens 0) then Mem (0,NONE,0,"",Substring.string (nth tokens 0),intFromHexString_forced (nth tokens 1)) (* index * scale *) else if is_register (nth tokens 1) then Mem (0,NONE,0,"",Substring.string (nth tokens 1),intFromHexString_forced (nth tokens 0)) (* scale * index *) else raise Fail ("Don't know how to parse operand part:" ^ Substring.string str) else raise Fail ("Don't know how to parse operand part:" ^ Substring.string str) end fun parse_operand_address_between_brackets_sum si segment_reg str = let val tokens = map trim (Substring.tokens (fn c => c = #"+") str) in fold (overwrite_Mem o parse_operand_address_between_brackets_inner) tokens (Mem (si,segment_reg ,0,"","",0)) end; fun parse_operand_address_between_brackets_sub si segment_reg str = let val (lhs,num) = Substring.splitl (fn c => c <> #"-") str; val (Mem (x0,x1,_,x3,x4,x5)) = parse_operand_address_between_brackets_sum si segment_reg lhs in Mem (x0,x1,intFromHexString_forced num,x3,x4,x5) end fun parse_operand_address_between_brackets si segment_reg str = let val (_,num) = Substring.splitl (fn c => c <> #"-") str in if Substring.isEmpty num then parse_operand_address_between_brackets_sum si segment_reg str else parse_operand_address_between_brackets_sub si segment_reg str end fun skip_brackets str = let val (x,y) = Substring.splitAt (trim str,1) val (z,_) = Substring.splitl (fn c => c <> #"]") y in if Substring.compare (x,Substring.full "[") = EQUAL then z else raise Fail ("Expecting non-empty bracketed string preceded with colon or an immediate in hex-format, but got: " ^ Substring.string str) end; fun parse_operand_address_bracketed si segment_reg str = case intFromHexString str of SOME imm => Mem (si,segment_reg,imm,"", "",0) | NONE => parse_operand_address_between_brackets si segment_reg (skip_brackets str) fun tail str = case Substring.getc str of NONE => raise Fail ("Expecting non-empty string, but got: " ^ Substring.string str) | SOME (_,s) => s; fun parse_operand_address si str = case Substring.splitl (fn c => c <> #":") str of (before_colon, after_colon) => if Substring.isEmpty after_colon then parse_operand_address_bracketed si NONE before_colon else parse_operand_address_bracketed si (SOME (Substring.string (trim before_colon))) (tail after_colon); fun parse_operand str' = let val str = trim str' in if Substring.isPrefix "BYTE PTR" str then parse_operand_address 1 (snd (Substring.splitAt (str,8))) else if Substring.isPrefix "WORD PTR" str then parse_operand_address 2 (snd (Substring.splitAt (str,8))) else if Substring.isPrefix "DWORD PTR" str then parse_operand_address 4 (snd (Substring.splitAt (str,9))) else if Substring.isPrefix "QWORD PTR" str then parse_operand_address 8 (snd (Substring.splitAt (str,9))) else if Substring.isPrefix "XMMWORD PTR" str then parse_operand_address 16 (snd (Substring.splitAt (str,11))) else if Substring.isPrefix "[" str then (* happens in case of a LEA instruction *) parse_operand_address 0 str else if List.find (fn (str') => String.compare (Substring.string str,str') = EQUAL) registers <> NONE then Reg (Substring.string str) else case intFromHexString str of NONE => raise Fail ("Cannot read hex number in string: " ^ (Substring.string str)) | SOME imm => Imm imm end; fun parse_operands str = let val tokens = map trim (Substring.tokens (fn c => c = #",") (trim str)) val ops = map parse_operand tokens in case ops of [] => (NONE,NONE,NONE) | [op1] => (SOME op1,NONE,NONE) | [op1,op2] => (SOME op1,SOME op2,NONE) | [op1,op2,op3] => (SOME op1,SOME op2,SOME op3) | _ => raise Fail ("Unexpected number of operands in : " ^ Substring.string str) end; fun remove_comment str = let val (str0,str1) = Substring.splitl (fn c => c <> #"#" andalso c <> #"<") str in if Substring.isEmpty str1 then str0 else Substring.trimr 1 str0 end fun parse_external_func a si str = let val (m,func) = Substring.splitl (fn c => c <> #" ") str val func_name = Substring.string (trim func) in Instr (a, si, Substring.string m, SOME (Reg func_name), NONE, NONE) end fun parse_normal_instr a si str = let val (_,rem1) = Substring.splitl (fn c => c = #":" orelse c = #" ") str val (m,rem2) = Substring.splitl (fn c => c <> #" ") rem1 val (op1,op2,op3) = parse_operands rem2 in Instr (a, si, Substring.string m, op1,op2,op3) end; fun parse_instr si str = let val str' = remove_comment (Substring.full str) val (addr,rem0) = Substring.splitl (fn c => c <> #":") str' val a = intFromHexString_forced (Substring.full ("0x" ^ Substring.string (trim addr))) in if Substring.isPrefix "EXTERNAL_FUNCTION" (trim (tail (rem0))) then parse_external_func a si (trim (tail (rem0))) else parse_normal_instr a si rem0 end; fun read_instr_addr str = let val instr = parse_instr 0 str val (Instr (a,_,_,_,_,_)) = instr in a end (* EMBEDDING INTO HOL *) val mk_nat = HOLogic.mk_number @{typ nat} val mk_string = HOLogic.mk_string fun mk_word_typ_from_num s = Syntax.read_typ @{context} ("num \ " ^ Int.toString s ^ " word") fun mk_word_typ s = Syntax.read_typ @{context} (Int.toString s ^ " word") fun mk_word i b = if i=0 then Const ("Groups.zero_class.zero", mk_word_typ b) else if i=1 then Const ("Groups.one_class.one", mk_word_typ b) else if i < 0 then Syntax.read_term @{context} ("uminus :: " ^ Int.toString b ^ " word \ " ^ Int.toString b ^ " word") $ (Const ("Num.numeral_class.numeral", mk_word_typ_from_num b) $ HOLogic.mk_numeral (0 - i)) else Const ("Num.numeral_class.numeral", mk_word_typ_from_num b) $ HOLogic.mk_numeral i fun mk_operand (Mem (8,segment,offset,base,index,scale)) = @{term "qword_ptr"} $ HOLogic.mk_prod (mk_word offset 64, HOLogic.mk_prod (mk_string base, HOLogic.mk_prod (mk_string index, mk_nat scale))) | mk_operand (Mem (4,segment,offset,base,index,scale)) = @{term "dword_ptr"} $ HOLogic.mk_prod (mk_word offset 64, HOLogic.mk_prod (mk_string base, HOLogic.mk_prod (mk_string index, mk_nat scale))) | mk_operand (Mem (2,segment,offset,base,index,scale)) = @{term "word_ptr"} $ HOLogic.mk_prod (mk_word offset 64, HOLogic.mk_prod (mk_string base, HOLogic.mk_prod (mk_string index, mk_nat scale))) | mk_operand (Mem (1,segment,offset,base,index,scale)) = @{term "byte_ptr"} $ HOLogic.mk_prod (mk_word offset 64, HOLogic.mk_prod (mk_string base, HOLogic.mk_prod (mk_string index, mk_nat scale))) | mk_operand (Mem (si,segment,offset,base,index,scale)) = @{term Mem} $ mk_nat si $ mk_word offset 64 $ mk_string base $ mk_string index $ mk_nat scale | mk_operand (Reg reg) = @{term Reg} $ mk_string reg | mk_operand (Imm imm) = @{term Imm} $ mk_word imm 256 fun mk_operand_option NONE = @{term "None :: Operand option"} | mk_operand_option (SOME op1) = @{term "Some :: Operand \ Operand option"} $ mk_operand op1 fun mk_instr (Instr (_,_,"EXTERNAL_FUNCTION",SOME (Reg f),NONE,NONE)) lthy = let val def = Syntax.read_term (Local_Theory.target_of lthy) ("EXTERNAL_FUNCTION_" ^ f) in if fastype_of def = (@{typ state} --> @{typ state}) then @{term ExternalFunc} $ def else raise Fail ("Unknown external function: " ^ f ^ "; expecting a function named EXTERNAL_FUNCTION_" ^ f ^ " in locale unknowns of type state \ state") end | mk_instr (Instr (a,si,m,op1,op2,op3)) _ = @{term Instr} $ mk_string m $ mk_operand_option op1 $ mk_operand_option op2 $ mk_operand_option op3 $ mk_word (a+si) 64 (* Make a definition in HOL with name "name" and as body "value". Value can be any HOL term, e.g.,: HOLogic.mk_number @{typ nat} 42 Note that HOL terms can be produced using antiquotations, e.g., @{term "42::nat"} does the same as the above code. *) fun mk_definition name value lthy = let val binding = Binding.name name val (_, lthy) = Local_Theory.define ((binding, NoSyn), ((Thm.def_binding binding, []), value)) lthy val _ = tracing ("Added definition: " ^ (Local_Theory.full_name lthy binding)) in lthy end fun main localename assembly lthy = let (* Build a locale name *) val _ = not (Long_Name.is_qualified localename) orelse raise Fail ("Given localename looks like qualified Isabelle ID: " ^ localename) val _ = localename <> "" orelse raise Fail ("Given localename is illegal") (* The locale fixes a variable called "fetch" of type "64 word \ I" *) val fixes_fetch = Element.Fixes [( Binding.name "fetch" , SOME (@{typ "64 word => I"}), NoSyn)] (* the locale contains a list of assumptions, one for each instruction. They are given the [simp] attribute. *) - val simp_attrib = Attrib.internal (fn (_) => Simplifier.simp_add) - fun mk_assume thm_name term = ((Binding.name thm_name, [simp_attrib]), [term]); + fun mk_assume thm_name term = ((Binding.name thm_name, @{attributes [simp]}), [term]); val mk_fetch = Free ("fetch", @{typ "64 word => I"}) fun mk_fetch_equality_assume si str = let val instr = parse_instr si str val (Instr (a,_,_,_,_,_)) = instr val asm_name = "fetch_" ^ LargeInt.toString a val eq_term = HOLogic.mk_eq (mk_fetch $ mk_word a 64, mk_instr instr lthy) in mk_assume asm_name (HOLogic.Trueprop $ eq_term, []) end fun mk_fetch_equality_assumes [] = [] | mk_fetch_equality_assumes [str] = [mk_fetch_equality_assume 1 str] | mk_fetch_equality_assumes (str0::str1::strs) = (mk_fetch_equality_assume (read_instr_addr str1 - read_instr_addr str0) str0) :: mk_fetch_equality_assumes (str1::strs) val assembly = String.tokens (fn c => c = #"\n") assembly |> List.filter (Substring.full #> remove_comment #> Substring.explode #> List.all Char.isSpace #> not) val loc_bindings = Binding.name localename val loc_elems = [fixes_fetch,Element.Assumes (mk_fetch_equality_assumes assembly)] val thy = Local_Theory.exit_global lthy val loc_expr : (string, term) Expression.expr = [(Locale.intern thy "unknowns",(("",false),(Expression.Named [], [])))] val (_,lthy) = Expression.add_locale loc_bindings loc_bindings [] (loc_expr,[]) loc_elems thy val _ = tracing ("Added locale: " ^ localename ^ " with a fetch function for " ^ Int.toString (length assembly) ^ " instructions. To get started, execute:\n\ncontext " ^ localename ^ "\nbegin\n find_theorems fetch\nend\n") in lthy end (* Add the command "x86_64_parser" to the Isabelle syntax. Its argument is parsed by Parse.embedded, which simply returns the embedded source. The parsed text is given to the "main" function. *) val _ = Outer_Syntax.local_theory \<^command_keyword>\x86_64_parser\ "Generate a locale from a list of assembly instructions." (Parse.embedded -- Parse.embedded >> (fn (localename, assembly) => main localename assembly))