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/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/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/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/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_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/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/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))