diff --git a/ROOT b/ROOT index 76426046..3ef9ecfe 100644 --- a/ROOT +++ b/ROOT @@ -22,6 +22,8 @@ session Binders in "thys" = Prelim + MRBNF_Composition MRBNF_FP MRBNF_Recursor + Swapping + Support session Operations in "operations" = Untyped_Lambda_Calculus + theories @@ -36,6 +38,8 @@ session Operations in "operations" = Untyped_Lambda_Calculus + VVSubst_Corec TVSubst Sugar + BMV_Monad + BMV_Fixpoint session Tests in "tests" = Case_Studies + sessions @@ -116,3 +120,7 @@ session System_Fsub in "case_studies/POPLmark" = Case_Studies + Pattern POPLmark_1B POPLmark_2B + +session STLC in "case_studies/STLC" = Binders + + theories + STLC diff --git a/Tools/binder_induction.ML b/Tools/binder_induction.ML index 5a9690d7..e59827b8 100644 --- a/Tools/binder_induction.ML +++ b/Tools/binder_induction.ML @@ -121,14 +121,6 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking | NONE => error "Automatic detection of induction rule is not supported yet, please specify with rule:" ); - fun dest_ordLess t = - let val t' = case HOLogic.dest_mem t of - (t', Const (@{const_name ordLess}, _)) => t' - | _ => raise TERM ("dest_ordLess", [t]) - in HOLogic.dest_prod t' end - fun dest_card_of (Const (@{const_name card_of}, _) $ t) = t - | dest_card_of t = raise TERM ("dest_card_of", [t]) - fun strip_all (Const (@{const_name HOL.All}, _) $ t) = (case t of Abs (x, T, t) => let val a = Free (x, T) in apfst (curry (op::) a) (strip_all (Term.subst_bound (a, t))) end @@ -153,8 +145,8 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking val vars_prems = map (try ( HOLogic.dest_Trueprop #> snd o strip_all - #> fst o dest_ordLess - #> dest_card_of + #> fst o MRBNF_Util.dest_ordLess + #> MRBNF_Util.dest_card_of #> fst o Term.strip_comb #> snd o Term.dest_Var #> HOLogic.dest_setT o range_type @@ -463,6 +455,10 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking rotate_tac ~1 ], SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms de_Morgan_disj singleton_iff Int_Un_distrib Un_empty}), + REPEAT_DETERM o CHANGED o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms conj_assoc}), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms conj_assoc[symmetric]}) + ], REPEAT_DETERM o EVERY' [ etac ctxt conjE, rotate_tac ~2 @@ -471,9 +467,9 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking Subgoal.FOCUS_PREMS (fn {context=ctxt, prems=inner_prems, ...} => EVERY1 [ DETERM o resolve_tac ctxt (IH :: repeat_mp IH), IF_UNSOLVED o EVERY' [ - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj singleton_iff Int_Un_distrib Un_empty}), + K (Local_Defs.unfold0_tac ctxt @{thms notin_Un Un_iff de_Morgan_disj singleton_iff Int_Un_distrib Un_empty}), EVERY' (map (fn inner_prem => EVERY' (map (fn tac => DETERM o tac) [ - TRY o rtac ctxt conjI, + REPEAT_DETERM o rtac ctxt conjI, let val x = length (fst (Logic.strip_horn (Thm.prop_of inner_prem))); in REPEAT_DETERM_N x o rtac ctxt @{thm induct_impliesI} end, REPEAT_DETERM o rtac ctxt @{thm induct_forallI}, @@ -484,7 +480,7 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking val simpset = Simplifier.add_cong @{thm imp_cong} ( (BNF_Util.ss_only @{thms split_paired_All HOL.simp_thms all_simps HOL.induct_forall_def prod.inject induct_implies_equal_eq - disjoint_single trans[OF arg_cong2[OF Int_commute refl, of "(=)"] disjoint_single] + disjoint_single trans[OF arg_cong2[OF Int_commute refl, of "(=)"] disjoint_single] conj_assoc } ctxt) addsimprocs [@{simproc HOL.defined_All}, @{simproc HOL.defined_Ex}] ) diff --git a/Tools/binder_inductive.ML b/Tools/binder_inductive.ML index fbf7035e..58e0c6e7 100644 --- a/Tools/binder_inductive.ML +++ b/Tools/binder_inductive.ML @@ -66,6 +66,7 @@ fun binder_inductive_cmd (((options, pred_name), binds_opt: (string * string lis (MRBNF_Util.subst_typ_morphism (snd (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf)) ~~ Ts)) mrbnf)) | collect_params _ = []; + val pot_bind_Ts = foldl1 (fn (xs, ys) => if subset (op=) (xs, ys) then ys else union (op=) ys xs ) (map collect_params param_Ts); @@ -78,7 +79,7 @@ fun binder_inductive_cmd (((options, pred_name), binds_opt: (string * string lis | collect_binders (Abs (_, _, t)) = collect_binders t | collect_binders (t as (t1 $ t2)) = case try (dest_Type o Term.body_type o fastype_of) t of NONE => map2 (curry (op@)) (collect_binders t1) (collect_binders t2) - | SOME (s, _) => (case MRBNF_Sugar.binder_sugar_of no_defs_lthy s of + | SOME (s, _) => (case Binder_Sugar.binder_sugar_of no_defs_lthy s of NONE => map2 (curry (op@)) (collect_binders t1) (collect_binders t2) | SOME sugar => let @@ -115,7 +116,8 @@ fun binder_inductive_cmd (((options, pred_name), binds_opt: (string * string lis val intro = unvarify_global (Term.subst_TVars subst (Thm.prop_of intro)); val binderss = map (distinct (op=)) (collect_binders intro); val xs_binders = map (fn binders => fold_rev (fn t => fn (a, b) => case t of - Const (@{const_name insert}, _) $ x $ Const (@{const_name bot}, _) => (x::a, b) + Const (@{const_name insert}, _) $ x $ Const (@{const_name bot}, _) => (case x of + Bound _ => (a, b) | _ => (x::a, b)) | _ => (a, t::b) ) binders ([], [])) binderss; val binders = map (fn (xs, binders) => @@ -539,7 +541,7 @@ fun binder_inductive_cmd (((options, pred_name), binds_opt: (string * string lis map_filter (try dest_Type o snd) (fold Term.add_frees (flat bind_ts) []) ); - val bset_bounds = maps (fn Type (s, _) => (case MRBNF_Sugar.binder_sugar_of lthy s of + val bset_bounds = maps (fn Type (s, _) => (case Binder_Sugar.binder_sugar_of lthy s of SOME sugar => #bset_bounds sugar | NONE => []) | _ => []) param_Ts; @@ -550,7 +552,7 @@ fun binder_inductive_cmd (((options, pred_name), binds_opt: (string * string lis REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], hyp_subst_tac ctxt, REPEAT_DETERM o resolve_tac ctxt ( - @{thms conjI emp_bound iffD2[OF insert_bound] ordLeq_refl} + @{thms conjI emp_bound iffD2[OF insert_bound_UNIV] ordLeq_refl} @ infinite_UNIVs @ [Un_bound, UN_bound] @ maps (fn thm => [thm, @{thm ordLess_ordLeq_trans} OF [thm]]) ( maps set_bd_UNIVs_of_mr_bnfs binder_mr_bnfs diff --git a/Tools/binder_sugar.ML b/Tools/binder_sugar.ML new file mode 100644 index 00000000..4fa40839 --- /dev/null +++ b/Tools/binder_sugar.ML @@ -0,0 +1,88 @@ +signature BINDER_SUGAR = sig + +type binder_sugar = { + map_simps: thm list, + set_simpss: thm list list, + permute_simps: thm list, + map_permute: thm option, + subst_simps: thm list option, + IImsupp_permute_commutes: thm list option, + IImsupp_Diffs: thm list option, + tvsubst_permute: thm option, + bsetss: term option list list, + bset_bounds: thm list, + pset_ctors: thm list, + mrbnf: MRBNF_Def.mrbnf, + strong_induct: thm option, + distinct: thm list, + inject: thm list, + ctors: (term * thm) list +}; + +val morph_binder_sugar: morphism -> binder_sugar -> binder_sugar; + +val binder_sugar_of: local_theory -> string -> binder_sugar option +val register_binder_sugar: string -> binder_sugar -> local_theory -> local_theory + +end + +structure Binder_Sugar : BINDER_SUGAR = struct + +type binder_sugar = { + map_simps: thm list, + set_simpss: thm list list, + permute_simps: thm list, + map_permute: thm option, + subst_simps: thm list option, + IImsupp_permute_commutes: thm list option, + IImsupp_Diffs: thm list option, + tvsubst_permute: thm option, + bsetss: term option list list, + bset_bounds: thm list, + pset_ctors: thm list, + mrbnf: MRBNF_Def.mrbnf, + strong_induct: thm option, + distinct: thm list, + inject: thm list, + ctors: (term * thm) list +}; + +fun morph_binder_sugar phi { map_simps, permute_simps, map_permute, set_simpss, subst_simps, mrbnf, + strong_induct, distinct, inject, ctors, bsetss, bset_bounds, IImsupp_permute_commutes, IImsupp_Diffs, + tvsubst_permute, pset_ctors +} = { + map_simps = map (Morphism.thm phi) map_simps, + permute_simps = map (Morphism.thm phi) permute_simps, + map_permute = Option.map (Morphism.thm phi) map_permute, + set_simpss = map (map (Morphism.thm phi)) set_simpss, + subst_simps = Option.map (map (Morphism.thm phi)) subst_simps, + IImsupp_permute_commutes = Option.map (map (Morphism.thm phi)) IImsupp_permute_commutes, + IImsupp_Diffs = Option.map (map (Morphism.thm phi)) IImsupp_Diffs, + tvsubst_permute = Option.map (Morphism.thm phi) tvsubst_permute, + bsetss = map (map (Option.map (Morphism.term phi))) bsetss, + bset_bounds = map (Morphism.thm phi) bset_bounds, + pset_ctors = map (Morphism.thm phi) pset_ctors, + mrbnf = MRBNF_Def.morph_mrbnf phi mrbnf, + strong_induct = Option.map (Morphism.thm phi) strong_induct, + distinct = map (Morphism.thm phi) distinct, + inject = map (Morphism.thm phi) inject, + ctors = map (MRBNF_Util.map_prod (Morphism.term phi) (Morphism.thm phi)) ctors +} : binder_sugar; + +structure Data = Generic_Data ( + type T = binder_sugar Symtab.table; + val empty = Symtab.empty; + fun merge data : T = Symtab.merge (K true) data; +); + +fun register_binder_sugar name sugar = + Local_Theory.declaration {syntax = false, pervasive = true, pos = Position.none} + (fn phi => Data.map (Symtab.update (name, morph_binder_sugar phi sugar))); + +fun binder_sugar_of_generic context = + Option.map (morph_binder_sugar (Morphism.transfer_morphism (Context.theory_of context))) + o Symtab.lookup (Data.get context); + +val binder_sugar_of = binder_sugar_of_generic o Context.Proof; + +end \ No newline at end of file diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML new file mode 100644 index 00000000..0933b38f --- /dev/null +++ b/Tools/bmv_monad_def.ML @@ -0,0 +1,2712 @@ +signature BMV_MONAD_DEF = sig + type bmv_monad + + type 'a supported_functor_axioms = { + Map_id: 'a, + Map_comp: 'a, + Supp_Map: 'a list, + Supp_bd: 'a list, + Map_cong: 'a + }; + + type 'a bmv_monad_axioms = { + Sb_Inj: 'a, + Sb_comp_Injs: 'a list, + Sb_comp: 'a, + Sb_cong: 'a, + Vrs_bds: 'a list, + Vrs_Injss: 'a list list, + Vrs_Sbs: 'a list + }; + + type bmv_monad_facts = { + Inj_inj: thm list, + Supp_Injss: thm list list, + SSupp_Map_subsets: thm list option, + SSupp_Map_bounds: thm list option, + IImsupp_Map_subsets: thm list list option, + IImsupp_Map_bounds: thm list list option, + SSupp_Sb_subsets: thm list, + SSupp_Sb_bounds: thm list, + IImsupp_Sb_subsetss: thm list list, + IImsupp_Sb_boundss: thm list list + }; + + type bmv_monad_consts = { + bd: term, + Sbs: term list, + RVrs: term list list, + Injs: term list list, + Vrs: term list list, + extra_Vrs: term list list, + params: { Map: term, Supps: term list } option list + }; + + type 'a bmv_monad_param = { + axioms: 'a supported_functor_axioms, + Map_Sb: 'a, + Supp_Sb: 'a list, + Vrs_Map: 'a list, + Map_Injs: 'a list + }; + + type 'a bmv_monad_model = { + ops: typ list, + var_class: class, + bmv_ops: bmv_monad list, + frees: typ list list, + deads: typ list list, + leader: int, + lives: typ list list, + lives': typ list list, + consts: bmv_monad_consts, + params: 'a bmv_monad_param option list, + bd_infinite_regular_card_order: 'a, + tacs: 'a bmv_monad_axioms list + } + + val ops_of_bmv_monad: bmv_monad -> typ list; + val bd_of_bmv_monad: bmv_monad -> term; + val bd_infinite_regular_card_order_of_bmv_monad: bmv_monad -> thm; + val var_class_of_bmv_monad: bmv_monad -> class; + val leader_of_bmv_monad: bmv_monad -> int; + val frees_of_bmv_monad: bmv_monad -> typ list list; + val lives_of_bmv_monad: bmv_monad -> typ list list; + val lives'_of_bmv_monad: bmv_monad -> typ list list; + val deads_of_bmv_monad: bmv_monad -> typ list list; + val Injs_of_bmv_monad: bmv_monad -> term list list; + val Sbs_of_bmv_monad: bmv_monad -> term list; + val Maps_of_bmv_monad: bmv_monad -> term option list; + val Supps_of_bmv_monad: bmv_monad -> term list option list; + val Vrs_of_bmv_monad: bmv_monad -> term list list; + val RVrs_of_bmv_monad: bmv_monad -> term list list; + val axioms_of_bmv_monad: bmv_monad -> thm bmv_monad_axioms list; + val facts_of_bmv_monad: bmv_monad -> bmv_monad_facts list; + val params_of_bmv_monad: bmv_monad -> thm bmv_monad_param option list; + val unfolds_of_bmv_monad: bmv_monad -> thm list; + val defs_of_bmv_monad: bmv_monad -> thm list; + + val mk_small_prems_of_bmv_monad: bmv_monad -> int -> term list -> term list -> term list list; + + val leader: (bmv_monad -> 'a list) -> bmv_monad -> 'a; + + val map_bmv_monad_axioms: ('a -> 'b) -> 'a bmv_monad_axioms -> 'b bmv_monad_axioms; + val apply_bmv_monad_axioms: ('a -> 'b) bmv_monad_axioms -> 'a bmv_monad_axioms -> 'b bmv_monad_axioms; + val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; + + val register_pbmv_monad: string -> bmv_monad -> local_theory -> local_theory; + val pbmv_monad_of_generic: Context.generic -> string -> bmv_monad option; + val pbmv_monad_of: Proof.context -> string -> bmv_monad option; + + val pbmv_monad_of_mrbnf: (binding -> binding) -> MRBNF_Def.mrbnf -> local_theory -> bmv_monad * local_theory + val register_mrbnf_as_pbmv_monad: string -> local_theory -> local_theory + val note_bmv_monad_thms: (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) + -> binding option -> bmv_monad -> local_theory -> (string * thm list) list * local_theory + val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) + -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model + -> thm list -> local_theory -> (bmv_monad * thm list) * local_theory + + val unsafe_slice_bmv_monad: int -> bmv_monad -> bmv_monad; + + datatype var_type = Dead_Var | Free_Var | Live_Var; + + val demote_bmv_monad: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) + -> (binding -> binding) -> binding option -> bmv_monad + -> { frees: bool list, lives: var_type list } + -> local_theory -> (bmv_monad * thm list) * local_theory + + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list + -> { frees: typ list, deads: typ list } + -> { frees: typ list, deads: typ list, lives: typ list } option list -> local_theory + -> (bmv_monad * thm list) * local_theory + + val seal_bmv_monad: (binding -> binding) -> thm list -> binding -> (var_type * typ) list -> bmv_monad + -> (string * Typedef.info) option -> local_theory + -> (bmv_monad * thm list * thm list * (string * Typedef.info)) * local_theory +end + +structure BMV_Monad_Def : BMV_MONAD_DEF = struct + +open MRBNF_Util + +datatype var_type = Dead_Var | Free_Var | Live_Var; + +type 'a bmv_monad_axioms = { + Sb_Inj: 'a, + Sb_comp_Injs: 'a list, + Sb_comp: 'a, + Sb_cong: 'a, + Vrs_bds: 'a list, + Vrs_Injss: 'a list list, + Vrs_Sbs: 'a list +}; + +fun map_bmv_monad_axioms f ({ + Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_bds, Vrs_Injss, Vrs_Sbs +}: 'a bmv_monad_axioms) = { + Sb_Inj = f Sb_Inj, + Sb_comp_Injs = map f Sb_comp_Injs, + Sb_comp = f Sb_comp, + Sb_cong = f Sb_cong, + Vrs_bds = map f Vrs_bds, + Vrs_Injss = map (map f) Vrs_Injss, + Vrs_Sbs = map f Vrs_Sbs +} : 'b bmv_monad_axioms; + +val morph_bmv_monad_axioms = map_bmv_monad_axioms o Morphism.thm; + +fun apply_bmv_monad_axioms ({ + Sb_Inj=f1, Sb_comp_Injs=f2s, Sb_comp=f3, Sb_cong=f4, Vrs_bds=f5s, Vrs_Injss=f6s, Vrs_Sbs=f7s +}: ('a -> 'b) bmv_monad_axioms) ({ + Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_bds, Vrs_Injss, Vrs_Sbs +}: 'a bmv_monad_axioms) = +let + fun checkLength name xs ys = if length xs <> length ys then error ( + "UnequalLength: " ^ name ^ " (" ^ string_of_int (length xs) ^ " vs. " ^ string_of_int (length ys) ^ ")" + ) else () + val _ = checkLength "Sb_comp_Injs" Sb_comp_Injs f2s + val _ = checkLength "Vrs_bds" Vrs_bds f5s + val _ = checkLength "Vrs_Injss" Vrs_Injss f6s + val _ = map_index (fn (i, (a, b)) => checkLength ("Vrs_Injs." ^ string_of_int i) a b) (Vrs_Injss ~~ f6s) +in { + Sb_Inj = f1 Sb_Inj, + Sb_comp_Injs = map2 (curry (op|>)) Sb_comp_Injs f2s, + Sb_comp = f3 Sb_comp, + Sb_cong = f4 Sb_cong, + Vrs_bds = map2 (curry (op|>)) Vrs_bds f5s, + Vrs_Injss = map2 (map2 (curry (op|>))) Vrs_Injss f6s, + Vrs_Sbs = map2 (curry (op|>)) Vrs_Sbs f7s +} : 'b bmv_monad_axioms end; + +type bmv_monad_facts = { + Inj_inj: thm list, + Supp_Injss: thm list list, + SSupp_Map_subsets: thm list option, + SSupp_Map_bounds: thm list option, + IImsupp_Map_subsets: thm list list option, + IImsupp_Map_bounds: thm list list option, + SSupp_Sb_subsets: thm list, + SSupp_Sb_bounds: thm list, + IImsupp_Sb_subsetss: thm list list, + IImsupp_Sb_boundss: thm list list +}; + +fun morph_bmv_monad_facts phi { Inj_inj, Supp_Injss, SSupp_Map_subsets, SSupp_Map_bounds, + SSupp_Sb_subsets, SSupp_Sb_bounds, IImsupp_Map_subsets, IImsupp_Map_bounds, + IImsupp_Sb_subsetss, IImsupp_Sb_boundss +} = { + Inj_inj = map (Morphism.thm phi) Inj_inj, + Supp_Injss = map (map (Morphism.thm phi)) Supp_Injss, + SSupp_Map_subsets = Option.map (map (Morphism.thm phi)) SSupp_Map_subsets, + SSupp_Map_bounds = Option.map (map (Morphism.thm phi)) SSupp_Map_bounds, + IImsupp_Map_subsets = Option.map (map (map (Morphism.thm phi))) IImsupp_Map_subsets, + IImsupp_Map_bounds = Option.map (map (map (Morphism.thm phi))) IImsupp_Map_bounds, + SSupp_Sb_subsets = map (Morphism.thm phi) SSupp_Sb_subsets, + SSupp_Sb_bounds = map (Morphism.thm phi) SSupp_Sb_bounds, + IImsupp_Sb_subsetss = map (map (Morphism.thm phi)) IImsupp_Sb_subsetss, + IImsupp_Sb_boundss = map (map (Morphism.thm phi)) IImsupp_Sb_boundss +}: bmv_monad_facts; + +type 'a supported_functor_axioms = { + Map_id: 'a, + Map_comp: 'a, + Supp_Map: 'a list, + Supp_bd: 'a list, + Map_cong: 'a +}; + +fun map_supported_functor_axioms f { Map_id, Map_comp, Supp_Map, Supp_bd, Map_cong } = { + Map_id = f Map_id, + Map_comp = f Map_comp, + Supp_Map = map f Supp_Map, + Supp_bd = map f Supp_bd, + Map_cong = f Map_cong +} : 'b supported_functor_axioms; + +type 'a bmv_monad_param = { + axioms: 'a supported_functor_axioms, + Map_Sb: 'a, + Supp_Sb: 'a list, + Vrs_Map: 'a list, + Map_Injs: 'a list +}; + +fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Vrs_Map, Map_Injs }: 'a bmv_monad_param) = { + axioms = map_supported_functor_axioms f axioms, + Map_Sb = f Map_Sb, + Supp_Sb = map f Supp_Sb, + Vrs_Map = map f Vrs_Map, + Map_Injs = map f Map_Injs +}: 'b bmv_monad_param; + + +type bmv_monad_consts = { + bd: term, + Sbs: term list, + RVrs: term list list, + Injs: term list list, + Vrs: term list list, + extra_Vrs: term list list, + params: { Map: term, Supps: term list} option list +}; + +fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs, extra_Vrs } = { + bd = Morphism.term phi bd, + RVrs = map (map (Morphism.term phi)) RVrs, + params = map (Option.map (fn { Map, Supps } => { + Map = Morphism.term phi Map, + Supps = map (Morphism.term phi) Supps + })) params, + Injs = map (map (Morphism.term phi)) Injs, + Sbs = map (Morphism.term phi) Sbs, + Vrs = map (map (Morphism.term phi)) Vrs, + extra_Vrs = map (map (Morphism.term phi)) extra_Vrs +}: bmv_monad_consts; + +datatype bmv_monad = BMV of { + ops: typ list, + var_class: class, + leader: int, + frees: typ list list, + lives: typ list list, + lives': typ list list, + deads: typ list list, + consts: bmv_monad_consts, + params: thm bmv_monad_param option list, + bd_infinite_regular_card_order: thm, + axioms: thm bmv_monad_axioms list, + facts: bmv_monad_facts list, + unfolds: thm list, + defs: thm list +} + +fun morph_bmv_monad phi (BMV { + ops, var_class, leader, frees, lives, lives', deads, consts, params, axioms, bd_infinite_regular_card_order, + facts, unfolds, defs +}) = BMV { + ops = map (Morphism.typ phi) ops, + leader = leader, + var_class = var_class, + frees = map (map (Morphism.typ phi)) frees, + lives = map (map (Morphism.typ phi)) lives, + lives' = map (map (Morphism.typ phi)) lives', + deads = map (map (Morphism.typ phi)) deads, + consts = morph_bmv_monad_consts phi consts, + params = map (Option.map (map_bmv_monad_param (Morphism.thm phi))) params, + axioms = map (morph_bmv_monad_axioms phi) axioms, + facts = map (morph_bmv_monad_facts phi) facts, + bd_infinite_regular_card_order = Morphism.thm phi bd_infinite_regular_card_order, + unfolds = map (Morphism.thm phi) unfolds, + defs = map (Morphism.thm phi) defs +} + +fun Rep_bmv (BMV x) = x + +val ops_of_bmv_monad = #ops o Rep_bmv +val bd_of_bmv_monad = #bd o #consts o Rep_bmv +val var_class_of_bmv_monad = #var_class o Rep_bmv; +val leader_of_bmv_monad = #leader o Rep_bmv +val frees_of_bmv_monad = #frees o Rep_bmv +val lives_of_bmv_monad = #lives o Rep_bmv +val lives'_of_bmv_monad = #lives' o Rep_bmv +val deads_of_bmv_monad = #deads o Rep_bmv +val Injs_of_bmv_monad = #Injs o #consts o Rep_bmv +val Sbs_of_bmv_monad = #Sbs o #consts o Rep_bmv +val Maps_of_bmv_monad = map (Option.map #Map) o #params o #consts o Rep_bmv +val Supps_of_bmv_monad = map (Option.map #Supps) o #params o #consts o Rep_bmv +val Vrs_of_bmv_monad = #Vrs o #consts o Rep_bmv +val extra_Vrs_of_bmv_monad = #extra_Vrs o #consts o Rep_bmv +val RVrs_of_bmv_monad = #RVrs o #consts o Rep_bmv +val consts_of_bmv_monad = #consts o Rep_bmv +val axioms_of_bmv_monad = #axioms o Rep_bmv +val facts_of_bmv_monad = #facts o Rep_bmv +val params_of_bmv_monad = #params o Rep_bmv +val bd_infinite_regular_card_order_of_bmv_monad = #bd_infinite_regular_card_order o Rep_bmv +val unfolds_of_bmv_monad = #unfolds o Rep_bmv +val defs_of_bmv_monad = #defs o Rep_bmv + +fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) + +type 'a bmv_monad_model = { + ops: typ list, + var_class: class, + frees: typ list list, + lives: typ list list, + lives': typ list list, + deads: typ list list, + consts: bmv_monad_consts, + params: 'a bmv_monad_param option list, + bmv_ops: bmv_monad list, + leader: int, + bd_infinite_regular_card_order: 'a, + tacs: 'a bmv_monad_axioms list +} + +fun morph_bmv_monad_model phi f ({ ops, var_class, frees, lives, lives', consts, bmv_ops, leader, + params, tacs, bd_infinite_regular_card_order, deads } +) = { + ops = map (Morphism.typ phi) ops, + var_class = var_class, + frees = map (map (Morphism.typ phi)) frees, + lives = map (map (Morphism.typ phi)) lives, + lives' = map (map (Morphism.typ phi)) lives', + deads = map (map (Morphism.typ phi)) deads, + consts = morph_bmv_monad_consts phi consts, + params = params, + bmv_ops = map (morph_bmv_monad phi) bmv_ops, + leader = leader, + tacs = map (map_bmv_monad_axioms f) tacs, + bd_infinite_regular_card_order = bd_infinite_regular_card_order +} : 'a bmv_monad_model; + +fun update_consts (consts: bmv_monad_consts) (model: 'a bmv_monad_model) = { + ops = #ops model, + var_class = #var_class model, + frees = #frees model, + lives = #lives model, + lives' = #lives' model, + deads = #deads model, + consts = consts, + params = #params model, + bmv_ops = #bmv_ops model, + leader = #leader model, + tacs = #tacs model, + bd_infinite_regular_card_order = #bd_infinite_regular_card_order model +}: 'a bmv_monad_model; + +structure Data = Generic_Data ( + type T = bmv_monad Symtab.table; + val empty = Symtab.empty; + fun merge data : T = Symtab.merge (K true) data; +); + +fun register_pbmv_monad name bmv = + Local_Theory.declaration {syntax = false, pervasive = true, pos = Position.none} + (fn phi => Data.map (Symtab.update (name, morph_bmv_monad phi bmv))); + +fun pbmv_monad_of_generic context = + Option.map (morph_bmv_monad (Morphism.transfer_morphism (Context.theory_of context))) + o Symtab.lookup (Data.get context); + +val pbmv_monad_of = pbmv_monad_of_generic o Context.Proof; + +fun mk_small_prems ops RVrss Vrss extra_Vrss fs rhos Injs extra_Vrs = + let val Vrss = map2 (curry (op@)) (map2 (curry (op@)) RVrss Vrss) extra_Vrss; + in map (single o HOLogic.mk_Trueprop o mk_supp_bound) fs + @ map2 (fn rho => fn Inj => + let + val extra_Vrs = filter (fn Vrs => + domain_type (fastype_of Vrs) = body_type (fastype_of Inj) + ) extra_Vrs; + val aT = domain_type (fastype_of Inj); + val Vrs = nth Vrss (find_index (curry (op=) (body_type (fastype_of Inj))) ops); + in map HOLogic.mk_Trueprop ( + (mk_ordLess + (mk_card_of (MRBNF_Util.mk_SSupp Inj $ rho)) + (mk_card_of (HOLogic.mk_UNIV aT)) + ) :: map_filter (fn Vrs => + let val bT = HOLogic.dest_setT (body_type (fastype_of Vrs)); + in if bT = aT then NONE else SOME ( + mk_ordLess (mk_card_of (MRBNF_Util.mk_IImsupp Inj Vrs $ rho)) + (mk_card_of (HOLogic.mk_UNIV bT)) + ) end + ) (Vrs @ extra_Vrs) + ) end + ) rhos Injs end; + +fun mk_small_prems_of_bmv_monad bmv i fs rhos = + mk_small_prems (ops_of_bmv_monad bmv) (RVrs_of_bmv_monad bmv) + (Vrs_of_bmv_monad bmv) (extra_Vrs_of_bmv_monad bmv) fs rhos + (nth (Injs_of_bmv_monad bmv) i) (nth (extra_Vrs_of_bmv_monad bmv) i); + +fun mk_bmv_monad_axioms ops consts bmv_ops lthy = + let + val Ts = ops @ maps ops_of_bmv_monad bmv_ops; + val Sbs = #Sbs consts @ maps Sbs_of_bmv_monad bmv_ops; + val Injss = #Injs consts @ maps Injs_of_bmv_monad bmv_ops; + val RVrss = #RVrs consts @ maps RVrs_of_bmv_monad bmv_ops; + val Vrss = #Vrs consts @ maps Vrs_of_bmv_monad bmv_ops; + val extra_Vrss = #extra_Vrs consts @ maps extra_Vrs_of_bmv_monad bmv_ops; + + val axioms = @{map 6} (fn T => fn Injs => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => fn extra_Vrs => + let + val (own_Injs, other_Injs) = partition (fn Inj => body_type (fastype_of Inj) = T) Injs; + val other_idxs = map (fn Inj => find_index (fn T => body_type (fastype_of Inj) = T) Ts) other_Injs; + + val f_Ts = filter ((op=) o dest_funT) (fst (split_last (binder_types (fastype_of Sb)))); + + val ((((((fs, gs), rhos), rhos'), aa), x), _) = lthy + |> mk_Frees "f" f_Ts + ||>> mk_Frees "g" f_Ts + ||>> mk_Frees "\" (map fastype_of Injs) + ||>> mk_Frees "\'" (map fastype_of Injs) + ||>> mk_Frees "a" (distinct (op=) (map (fst o dest_funT o fastype_of) Injs @ map (fst o dest_funT) f_Ts)) + ||>> apfst hd o mk_Frees "x" [T]; + val (own_rhos, other_rhos) = partition (curry (op=) T o body_type o fastype_of) rhos; + + val f_ids = map (HOLogic.id_const o fst o dest_funT o fastype_of) fs; + + val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, f_ids @ Injs), HOLogic.id_const T); + + val mk_small_prems = mk_small_prems Ts RVrss Vrss extra_Vrss; + val small_prems = flat (mk_small_prems fs rhos Injs extra_Vrs); + val small_prems' = flat (mk_small_prems gs rhos' Injs extra_Vrs); + + val Sb_comp_Injs = map2 (fn Inj => fn rho => + fold_rev Logic.all (fs @ rhos) (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (Sb, fs @ rhos), Inj), rho + ))) + ) own_Injs own_rhos; + + val Sb_comp = fold_rev Logic.all (gs @ rhos' @ fs @ rhos) ( + fold_rev (curry Logic.mk_implies) (small_prems @ small_prems') (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (Sb, gs @ rhos'), Term.list_comb (Sb, fs @ rhos)), + Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) gs fs @ + fst (fold_map (fn rho => fn acc as (Sbs, Injs, RVrs) => if member (op=) own_rhos rho then + (HOLogic.mk_comp ( + Term.list_comb (Sb, gs @ rhos'), rho + ), acc) + else + (HOLogic.mk_comp (Term.list_comb (hd Sbs, map (fn RVr => + the (List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of RVr))) o domain_type o fastype_of) gs) + ) (hd RVrs) @ map (fn Inj => + case List.find (fn rho' => fastype_of rho' = fastype_of Inj) rhos' of + NONE => Inj | SOME t => t + ) (hd Injs)), rho), (tl Sbs, tl Injs, tl RVrs)) + ) rhos (map (nth Sbs) other_idxs, map (nth Injss) other_idxs, map (nth RVrss) other_idxs))) + )) + ); + + val Vrs_bds = map (fn Vrs => Logic.all x ( + HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) (#bd consts)) + )) (RVrs @ Vrs); + + val Vrs_Injss = map2 (fn Inj'_opt => fn Vrs => map (fn Inj => + let + val a = the (List.find (fn a => fastype_of a = hd (binder_types (fastype_of Inj))) aa); + val T = HOLogic.dest_setT (body_type (fastype_of Vrs)); + in Logic.all a (mk_Trueprop_eq ( + Vrs $ (Inj $ a), + case Inj'_opt of + SOME t => if t = Inj then mk_singleton a else mk_bot T + | NONE => mk_bot T + )) end + ) own_Injs) (replicate (length RVrs) NONE @ map SOME Injs @ replicate (length extra_Vrs) NONE) (RVrs @ Vrs @ extra_Vrs); + + val Vrs_Sbs = map2 (fn f => fn RVr => + let val UNs = @{map_filter 2} (fn Vr' => fn rho => + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) Ts; + val RVrs = nth RVrss idx; + in Option.map (fn RVr => + mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (body_type (fastype_of Vr'))) ( + RVr $ (rho $ Bound 0) + )) + ) (List.find (curry (op=) (body_type (fastype_of RVr)) o body_type o fastype_of) RVrs) end + ) Vrs rhos in fold_rev Logic.all (fs @ rhos @ [x]) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + RVr $ (Term.list_comb (Sb, fs @ rhos) $ x), foldl1 mk_Un ((mk_image f $ (RVr $ x)) :: UNs) + )) + ) end + ) fs RVrs @ map2 (fn Vr => fn Inj => + let + val UNs = @{map_filter 2} (fn Vr' => fn rho => + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) Ts; + val Injs = nth Injss idx; + val Vrs = nth Vrss idx; + val idx = find_index (curry (op=) Inj) Injs; + val inner_Vr = case idx of ~1 => NONE | n => SOME (nth Vrs n); + val X = Vr' $ x; + in Option.map (fn inner_Vr => + mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (fastype_of X)) ( + inner_Vr $ (rho $ Bound 0) + )) + ) inner_Vr end + ) Vrs rhos; + in fold_rev Logic.all (fs @ rhos @ [x]) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + Vr $ (Term.list_comb (Sb, fs @ rhos) $ x), foldl1 mk_Un UNs + )) + ) end + ) Vrs Injs; + + val Sb_cong = fold_rev Logic.all (fs @ rhos @ gs @ rhos' @ [x]) ( + fold_rev (curry Logic.mk_implies) (small_prems @ small_prems' @ @{map 3} (fn rho => fn rho' => fn Vrs => + let val a = the (List.find (fn t => fastype_of t = HOLogic.dest_setT (body_type (fastype_of Vrs))) aa) + in Logic.all a (Logic.mk_implies ( + HOLogic.mk_Trueprop (HOLogic.mk_mem (a, Vrs $ x)), + mk_Trueprop_eq (rho $ a, rho' $ a) + )) end + ) (fs @ rhos) (gs @ rhos') (RVrs @ Vrs)) (mk_Trueprop_eq ( + Term.list_comb (Sb, fs @ rhos) $ x, + Term.list_comb (Sb, gs @ rhos') $ x + ) + )); + in { + Sb_Inj = Sb_Inj, + Sb_comp_Injs = Sb_comp_Injs, + Sb_comp = Sb_comp, + Vrs_Injss = Vrs_Injss, + Vrs_bds = Vrs_bds, + Vrs_Sbs = Vrs_Sbs, + Sb_cong = Sb_cong + } : term bmv_monad_axioms end + ) ops (#Injs consts) (#Sbs consts) (#Vrs consts) (#RVrs consts) (#extra_Vrs consts); + in axioms end; + +fun mk_param_axiom Map Supps Sb Injs RVrs Vrs extra_Vrs bd ops RVrss Vrss extra_Vrss params lthy = + let + val (f_Ts, T) = split_last (binder_types (fastype_of Map)); + val (lives, lives') = split_list (map dest_funT f_Ts); + + val h_Ts = filter ((op=) o dest_funT) (fst (split_last (binder_types (fastype_of Sb)))); + + val (Cs, _) = lthy + |> fold Variable.declare_typ (lives @ lives' @ map TFree (Term.add_tfrees Sb [])) + |> mk_TFrees (length lives); + val (((((fs, gs), hs), rhos), x), _) = lthy + |> mk_Frees "f" (map2 (curry (op-->)) lives lives') + ||>> mk_Frees "g" (map2 (curry (op-->)) lives' Cs) + ||>> mk_Frees "f" h_Ts + ||>> mk_Frees "\" (map fastype_of Injs) + ||>> apfst hd o mk_Frees "x" [T]; + + val small_prems = flat (mk_small_prems ops RVrss Vrss extra_Vrss hs rhos Injs extra_Vrs); + + val Map_id = Term.subst_atomic_types (lives' ~~ lives) ( + mk_Trueprop_eq ( + Term.list_comb (Map, map HOLogic.id_const lives), HOLogic.id_const T + ) + ); + + val Map_comp = fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb ( + Term.subst_atomic_types ((lives @ lives') ~~ (lives' @ Cs)) Map, gs + ), Term.list_comb (Map, fs)), + Term.list_comb (Term.subst_atomic_types (lives' ~~ Cs) Map, map2 (curry HOLogic.mk_comp) gs fs) + )); + + val Supp_Maps = map2 (fn Supp => fn f => + fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( + Term.subst_atomic_types (lives ~~ lives') Supp $ (Term.list_comb (Map, fs) $ x), + mk_image f $ (Supp $ x) + )) + ) Supps fs; + + val Supp_bds = map (fn Supp => Logic.all x (HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (Supp $ x)) bd + ))) Supps; + + val (gs', _) = lthy + |> mk_Frees "g" (map fastype_of fs); + val Map_cong = fold_rev Logic.all (fs @ gs' @ [x]) ( + fold_rev (curry Logic.mk_implies) (@{map 3} (fn Supp => fn f => fn g => + let val a = Free ("a", hd (binder_types (fastype_of f))); + in Logic.all a (Logic.mk_implies ( + HOLogic.mk_Trueprop (HOLogic.mk_mem (a, Supp $ x)), + mk_Trueprop_eq (f $ a, g $ a) + )) end + ) Supps fs gs') (mk_Trueprop_eq ( + Term.list_comb (Map, fs) $ x, + Term.list_comb (Map, gs') $ x + ))); + + val Map_Sb = fold_rev Logic.all (fs @ hs @ rhos) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (Map, fs), Term.list_comb (Sb, hs @ rhos)), + HOLogic.mk_comp (Term.list_comb ( + Term.subst_atomic_types (lives ~~ lives') Sb, hs @ map (fn rho => + case List.find (fn { Map, ...} => snd (split_last (binder_types (fastype_of Map))) = body_type (fastype_of rho)) params of + NONE => rho | SOME { Map, ... } => + let + val (lives, lives') = split_list (map dest_funT (fst (split_last (binder_types (fastype_of Map))))); + val fs = map (fn l => the_default (HOLogic.id_const l) (List.find (curry (op=) l o domain_type o fastype_of) fs)) lives; + val subst = @{map 3} (fn l => fn l' => fn f => if (op=) (dest_funT (fastype_of f)) then + (l', l) else (l', body_type (fastype_of f)) + ) lives lives' fs; + in HOLogic.mk_comp (Term.list_comb (Term.subst_atomic_types subst Map, fs), rho) end + ) rhos + ), Term.list_comb (Map, fs)) + )) + ); + + val Vrs_Map = map (fn Vrs => + fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( + Term.subst_atomic_types (lives ~~ lives') Vrs $ (Term.list_comb (Map, fs) $ x), + Vrs $ x + )) + ) (RVrs @ Vrs); + + val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ hs @ [x]) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + Supp $ (Term.list_comb (Sb, hs @ rhos) $ x), foldl1 mk_Un ((Supp $ x) :: + @{map_filter 2} (fn rho => fn Vrs => + let val param = List.find (fn { Map, ... } => + snd (split_last (binder_types (fastype_of Map))) = body_type (fastype_of rho) + ) params + in Option.mapPartial (fn { Supps, ... } => Option.map (fn Supp' => + mk_UNION (Vrs $ x) (Term.abs ("x", HOLogic.dest_setT (body_type (fastype_of Vrs))) ( + Supp' $ (rho $ Bound 0) + )) + ) (List.find (curry (op=) (body_type (fastype_of Supp)) o body_type o fastype_of) Supps) + ) param end) rhos Vrs + ) + )) + )) Supps; + + val Map_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else SOME ( + fold_rev Logic.all fs (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (Map, fs), Inj), + Term.subst_atomic_types (lives ~~ lives') Inj + )) + )) Injs; + in { + axioms = { + Map_id = Map_id, + Map_comp = Map_comp, + Supp_Map = Supp_Maps, + Supp_bd = Supp_bds, + Map_cong = Map_cong + } : term supported_functor_axioms, + Map_Sb = Map_Sb, + Supp_Sb = Supp_Sb, + Vrs_Map = Vrs_Map, + Map_Injs = Map_Injs + }: term bmv_monad_param end; + +val smart_max_inline_term_size = 25; (*FUDGE*) + +fun maybe_define const_policy fact_policy b rhs lthy = + let + val inline = case const_policy of + BNF_Def.Dont_Inline => false + | BNF_Def.Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs + | BNF_Def.Smart_Inline => Term.size_of_term rhs <= smart_max_inline_term_size + | BNF_Def.Do_Inline => true; + val thm_b = Thm.def_binding b; + (* TODO: difference between define_internal and define *) + val (define, thm_b) = if fact_policy = BNF_Def.Dont_Note then + (Local_Theory.define_internal, Binding.concealed thm_b) + else (Local_Theory.define, thm_b) + + in if inline then + ((rhs, NONE), lthy) + else + apfst (apsnd (SOME o snd)) (define ((b, NoSyn), ((thm_b, []), rhs)) lthy) + end + +fun fold_map_option _ NONE b = (NONE, b) + | fold_map_option f (SOME x) b = apfst SOME (f x b) + +fun define_bmv_monad_consts bmv_b_opt const_policy fact_policy qualify leader ops frees lives' (consts: bmv_monad_consts) lthy = + let + val maybe_define' = maybe_define (*const_policy*) BNF_Def.Hardly_Inline fact_policy o qualify; + + val suffixes = map_index (fn (i, T) => if i = leader andalso Option.isSome bmv_b_opt then + fn b => Binding.prefix_name (Binding.name_of b ^ "_") (Binding.name (short_type_name (Binding.name_of (the bmv_b_opt)))) + else Binding.suffix_name ("_" ^ (case T of + Type (n, Ts) => if forall Term.is_TFree Ts then short_type_name n else string_of_int i + | _ => string_of_int i + ))) ops; + val suffixess = map2 (fn suffix => fn Injs => case Injs of + [_] => [suffix] + | _ => map_index (fn (i, _) => Binding.suffix_name ("_" ^ string_of_int i) o suffix) Injs + ) suffixes (#Injs consts); + + val (_, lthy) = Local_Theory.begin_nested lthy; + val ((Sbs, Sb_defs), lthy) = apfst split_list (@{fold_map 2} (fn Sb => fn suffix => + maybe_define' (suffix (Binding.name "Sb")) Sb + ) (#Sbs consts) suffixes lthy); + + val ((Injs, Inj_defs), lthy) = apfst (split_list o map split_list) (@{fold_map 2} ( + @{fold_map 2} (fn Inj => fn suffix => maybe_define' (suffix (Binding.name "Inj")) Inj) + ) (#Injs consts) suffixess lthy); + + val (RVrs', lthy) = (@{fold_map 3} (fn suffix => fn Sb => @{fold_map 2} (fn j => fn Vrs => + maybe_define' (Binding.suffix_name ("_" ^ string_of_int j) (suffix (Binding.name "RVrs"))) Vrs + ) (1 upto length (filter ((op=) o dest_funT) (fst (split_last (binder_types (fastype_of Sb))))))) suffixes Sbs (#RVrs consts) lthy); + + val (Vrs', lthy) = (@{fold_map 2} (@{fold_map 2} (fn suffix => fn Vrs => + maybe_define' (suffix (Binding.name "Vrs")) Vrs + )) suffixess (#Vrs consts) lthy); + + val (extra_Vrs', lthy) = @{fold_map 2} (fn suffix => fn Vrs => @{fold_map 2} (fn i => fn Vrs => + maybe_define' (Binding.suffix_name ("_" ^ string_of_int i) (suffix (Binding.name "extra_Vrs"))) Vrs + ) (1 upto length Vrs) Vrs) suffixes (#extra_Vrs consts) lthy; + + val Vrs = map (map fst) Vrs'; + val Vrs_defs = maps (map snd) Vrs'; + + val RVrs = map (map fst) RVrs'; + val RVrs_defs = maps (map snd) RVrs'; + + val extra_Vrs = map (map fst) extra_Vrs'; + val extra_Vrs_defs = maps (map snd) extra_Vrs'; + + val (params', lthy) = @{fold_map 2} (fn suffix => fold_map_option (fn param => fn lthy => + let + val ((Map, Map_def), lthy) = maybe_define' (suffix (Binding.name "Map")) (#Map param) lthy; + val ((Supps, Supp_defs), lthy) = apfst split_list (@{fold_map 2} (fn i => + maybe_define' (Binding.suffix_name ("_" ^ string_of_int i) (suffix (Binding.name "Supp"))) + ) (0 upto length (#Supps param) - 1) (#Supps param) lthy); + val param = { + Map = Map, + Supps = Supps + }; + in ((param, Map_def :: Supp_defs), lthy) end + )) suffixes (#params consts) lthy; + val params = map (Option.map fst) params'; + val param_defs = map_filter (Option.map snd) params'; + + val ((bd, bd_def), lthy) = maybe_define' (Binding.name "bd") (#bd consts) lthy; + + val consts' = { + bd = bd, + params = params, + Injs = Injs, + Sbs = Sbs, + RVrs = RVrs, + Vrs = Vrs, + extra_Vrs = extra_Vrs + } : bmv_monad_consts; + + val (lthy, old_lthy) = `Local_Theory.end_nested lthy; + val phi = Proof_Context.export_morphism old_lthy lthy; + + val vars = map TFree (rev (Term.add_tfreesT (nth ops leader) [])) @ flat lives'; + val subst = (map (Morphism.typ phi) vars ~~ vars); + + val phi' = Morphism.term_morphism "bmv_monad_export" (Term.subst_atomic_types subst o Morphism.term phi) + val consts' = morph_bmv_monad_consts phi' consts'; + + val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ RVrs_defs @ extra_Vrs_defs @ [bd_def] @ flat param_defs); + in (consts', map (Morphism.thm phi) defs, lthy) end; + +fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = + let + fun bmv_b () = case bmv_b_opt of + NONE => Binding.name (short_type_name (fst (dest_Type (nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv))))) + | SOME b => b; + fun tl_maybe (_::x::xs) = x::xs + | tl_maybe xs = xs + + fun bmv_name () = implode (tl (maps (fn x => [".", x]) (tl_maybe (String.tokens (fn c => c = #".") (Binding.name_of (bmv_b ())))))); + val axioms = axioms_of_bmv_monad bmv; + val facts = facts_of_bmv_monad bmv; + val params = params_of_bmv_monad bmv; + val unfolds = unfolds_of_bmv_monad bmv; + + fun note_unless_dont_note (noted, lthy) = + let val notes = + [ + ("Sb_Inj", map #Sb_Inj axioms, []), + ("Sb_comp_Inj", maps #Sb_comp_Injs axioms, []), + ("Sb_comp", map #Sb_comp axioms, []), + ("Sb_cong", map #Sb_cong axioms, []), + ("Vrs_bd", maps #Vrs_bds axioms, []), + ("Vrs_Inj", flat (maps #Vrs_Injss axioms), []), + ("Vrs_Sb", maps #Vrs_Sbs axioms, []), + ("Map_Sb", map_filter (Option.map #Map_Sb) params, []), + ("Vrs_Map", flat (map_filter (Option.map #Vrs_Map) params), []), + ("Map_Inj", flat (map_filter (Option.map #Map_Injs) params), []), + ("Map_id", map_filter (Option.map (#Map_id o #axioms)) params, []), + ("Map_comp", map_filter (Option.map (#Map_comp o #axioms)) params, []), + ("Map_cong", map_filter (Option.map (#Map_cong o #axioms)) params, []), + ("Supp_Sb", flat (map_filter (Option.map #Supp_Sb) params), []), + ("Supp_Map", flat (map_filter (Option.map (#Supp_Map o #axioms)) params), []), + ("Supp_bd", flat (map_filter (Option.map (#Supp_bd o #axioms)) params), []), + ("Inj_inj", maps #Inj_inj facts, []), + ("Supp_Inj", flat (maps #Supp_Injss facts), []), + ("SSupp_Map_subset", maps (the_default [] o #SSupp_Map_subsets) facts, []), + ("SSupp_Map_bound", maps (the_default [] o #SSupp_Map_bounds) facts, []), + ("IImsupp_Map_subset", maps (flat o the_default [] o #IImsupp_Map_subsets) facts, []), + ("IImsupp_Map_bound", maps (flat o the_default [] o #IImsupp_Map_bounds) facts, []), + ("SSupp_Sb_subset", maps #SSupp_Sb_subsets facts, []), + ("SSupp_Sb_bound", maps #SSupp_Sb_bounds facts, []), + ("IImsupp_Sb_subset", maps (flat o #IImsupp_Sb_subsetss) facts, []), + ("IImsupp_Sb_bound", maps (flat o #IImsupp_Sb_boundss) facts, []) + ] + |> filter_out (null o #2) + |> map (fn (thmN, thms, attrs) => ((Binding.qualify true (bmv_name ()) (Binding.name thmN), attrs), [ + (map (Local_Defs.unfold0 lthy unfolds) thms, []) + ])); + in Local_Theory.notes notes lthy |>> append noted end + val fact_policy = fact_policy lthy; + in ([], lthy) + |> fact_policy <> BNF_Def.Dont_Note ? note_unless_dont_note + end + +fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_monad_model) unfolds defs lthy = + let + val consts = { + bd = #bd (#consts model), + params = #params (#consts model) @ maps (#params o #consts o Rep_bmv) (#bmv_ops model), + Injs = #Injs (#consts model) @ maps (#Injs o #consts o Rep_bmv) (#bmv_ops model), + Sbs = #Sbs (#consts model) @ maps (#Sbs o #consts o Rep_bmv) (#bmv_ops model), + Vrs = #Vrs (#consts model) @ maps (#Vrs o #consts o Rep_bmv) (#bmv_ops model), + RVrs = #RVrs (#consts model) @ maps (#RVrs o #consts o Rep_bmv) (#bmv_ops model), + extra_Vrs = #extra_Vrs (#consts model) @ maps (#extra_Vrs o #consts o Rep_bmv) (#bmv_ops model) + }: bmv_monad_consts; + val axioms' = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model); + val names = map (fst o dest_Free); + + val Inj_injs = map2 (@{map_filter 2} (fn Inj => fn Vrs => if body_type (fastype_of Inj) = domain_type (fastype_of Vrs) then + let + val ([a, b], _) = lthy |> mk_Frees "a" (replicate 2 (domain_type (fastype_of Inj))); + val goal = mk_Trueprop_eq (HOLogic.mk_eq (Inj $ a, Inj $ b), HOLogic.mk_eq (a, b)); + in SOME (Goal.prove_sorry lthy (names [a, b]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt iffI, + dtac ctxt (mk_arg_cong lthy 1 Vrs), + K (Local_Defs.unfold0_tac ctxt (flat (maps #Vrs_Injss axioms'))), + etac ctxt @{thm singleton_inject}, + hyp_subst_tac ctxt, + rtac ctxt refl + ])) end + else NONE + )) (#Injs (#consts model)) (#Vrs (#consts model)); + + val UNIV_cinfinite = @{thm var_class.UNIV_cinfinite}; + + val Injss = #Injs (#consts model); + + val (((rhoss, hss), fss), names_lthy) = lthy + |> mk_Freess "\" (map (map fastype_of) Injss) + ||>> mk_Freess "h" (map (map (fn RVrs => + let val T = HOLogic.dest_setT (body_type (fastype_of RVrs)); + in T --> T end + )) (#RVrs (#consts model))) + ||>> mk_Freess "f" (map2 (map2 (curry (op-->))) (#lives model) (#lives' model)); + + val Supp_Injss = @{map 5} (fn lives => fn lives' => fn params => fn Injs => the_default [] o Option.map (fn { Supps, Map } => map (fn Supp => map_filter (fn Inj => + if body_type (fastype_of Inj) = domain_type (fastype_of Supp) then + let + val a = Free ("a", domain_type (fastype_of Inj)) + val goal = mk_Trueprop_eq ( + Supp $ (Inj $ a), mk_bot (HOLogic.dest_setT (body_type (fastype_of Supp))) + ) + val Map = Term.subst_atomic_types (lives' ~~ map (K @{typ nat}) lives') Map; + val SSupp' = Term.subst_atomic_types (lives ~~ map (K @{typ nat}) lives) Supp; + val thm = Goal.prove_sorry lthy ["a"] [] (mk_Trueprop_eq ( + SSupp' $ (Term.list_comb (Map, map (fn live => Term.abs ("_", live) @{term "0::nat"}) lives) $ (Inj $ a)), + SSupp' $ (Term.list_comb (Map, map (fn live => Term.abs ("_", live) @{term "1::nat"}) lives) $ (Inj $ a)) + )) (fn {context = ctxt, ...} => EVERY1 [ + K (Local_Defs.unfold_tac ctxt ( + map (fn thm => Local_Defs.unfold0 ctxt @{thms comp_def} (thm RS fun_cong)) (#Map_Injs (the params)) + )), + rtac ctxt refl + ]); + in SOME (Goal.prove_sorry lthy ["a"] [] goal (fn {context=ctxt, ...} => EVERY1 [ + Method.insert_tac ctxt [infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt a)] thm], + K (Local_Defs.unfold0_tac ctxt (#Supp_Map (#axioms (the params)))), + dtac ctxt @{thm image_const_empty[rotated]}, + rtac ctxt @{thm zero_neq_one}, + etac ctxt conjE, + assume_tac ctxt + ])) end else NONE + ) Injs) Supps)) (#lives model) (#lives' model) (#params model) Injss (#params (#consts model)) + + val ops = #ops model @ maps ops_of_bmv_monad (#bmv_ops model) + + val SSupp_premss = @{map 4} (mk_small_prems ops (#RVrs consts) (#Vrs consts) (#extra_Vrs consts)) + hss rhoss Injss (#extra_Vrs (#consts model)); + + fun split_Uns thm = case try (fn () => thm RS @{thm Un_empty[THEN iffD1]}) () of + NONE => [thm] + | SOME thm' => split_Uns (thm' RS conjunct1) @ [thm' RS conjunct2] + val Vrs_Injs' = maps split_Uns (flat (maps #Vrs_Injss axioms')); + + val SSupp_thms = @{map 15} (fn params => fn param_consts => fn axioms => fn T => fn SSupp_premss => fn lives => fn lives' => fn frees => fn fs => fn Injs => fn rhos => fn hs => fn Sb => fn Vrs => fn RVrs => + let + val SSupp_prems = flat SSupp_premss; + val SSupp_Map_subsets = Option.map (fn Map => @{map_filter 2} (fn Inj => fn rho => + if body_type (fastype_of Inj) <> T then NONE else + let val goal = HOLogic.mk_Trueprop ( + mk_leq (Term.subst_atomic_types (lives ~~ lives') ( + mk_SSupp Inj + ) $ HOLogic.mk_comp (Term.list_comb (Map, fs), rho)) (mk_SSupp Inj $ rho) + ) in SOME (Goal.prove_sorry lthy (names (fs @ [rho])) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt @{thm subsetI}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_def mem_Collect_eq}), + etac ctxt @{thm contrapos_nn}, + rtac ctxt @{thm trans[OF comp_apply]}, + etac ctxt @{thm subst[OF sym]}, + rtac ctxt @{thm trans[rotated]}, + resolve_tac ctxt (map (fn thm => thm RS fun_cong) (#Map_Injs (the params))), + rtac ctxt @{thm comp_apply[symmetric]} + ])) end + ) Injs rhos) (Option.map #Map param_consts); + + val SSupp_Map_bounds = Option.map (map (fn thm => @{thm card_of_subset_bound} OF [thm])) SSupp_Map_subsets; + + val IImsupp_Map_subsets = Option.map (fn Map => @{map_filter 2} (fn Inj => fn rho => + if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vrs => + let val goal = HOLogic.mk_Trueprop ( + mk_leq (Term.subst_atomic_types (lives ~~ lives') ( + mk_IImsupp Inj Vrs + ) $ HOLogic.mk_comp (Term.list_comb (Map, fs), rho)) (mk_IImsupp Inj Vrs $ rho) + ) in Goal.prove_sorry lthy (names (fs @ [rho])) [] goal (fn {context=ctxt, ...} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), + rtac ctxt @{thm UN_mono}, + resolve_tac ctxt (the SSupp_Map_subsets), + K (Local_Defs.unfold0_tac ctxt (@{thms comp_apply} @ #Vrs_Map (the params))), + rtac ctxt @{thm subset_refl} + ]) end + ) (RVrs @ Vrs))) Injs rhos) (Option.map #Map param_consts); + + val IImsupp_Map_bounds = Option.map (map (map (fn thm => @{thm card_of_subset_bound} OF [thm]))) IImsupp_Map_subsets; + + val SSupp_Sb_subsets = BMV_Monad_Tactics.mk_SSupp_Sb_subsets + T Injs SSupp_prems Sb hs rhos + (map (fn thm => thm RS fun_cong RS @{thm trans[OF comp_apply[symmetric]]}) (#Sb_comp_Injs axioms)) + lthy; + + val SSupp_Sb_bounds = BMV_Monad_Tactics.mk_SSupp_Sb_bounds + T Injs Sb hs rhos SSupp_prems SSupp_Sb_subsets + UNIV_cinfinite lthy; + + val IImsupp_Sb_subsetss = BMV_Monad_Tactics.mk_IImsupp_Sb_subsetss T ops + Sb SSupp_prems (#RVrs consts) (#Vrs consts) (RVrs @ Vrs) Injs hs rhos SSupp_Sb_subsets + (#Vrs_Sbs axioms) Vrs_Injs' lthy; + + val IImsupp_Sb_boundss = BMV_Monad_Tactics.mk_IImsupp_Sb_boundss (#var_class model) T Sb Injs (RVrs @ Vrs) + hs rhos SSupp_prems IImsupp_Sb_subsetss (maps #Vrs_bds axioms') lthy; + in { + SSupp_Map_subsets = SSupp_Map_subsets, + SSupp_Map_bounds = SSupp_Map_bounds, + IImsupp_Map_subsets = IImsupp_Map_subsets, + IImsupp_Map_bounds = IImsupp_Map_bounds, + SSupp_Sb_subsets = SSupp_Sb_subsets, + SSupp_Sb_bounds = SSupp_Sb_bounds, + IImsupp_Sb_subsetss = IImsupp_Sb_subsetss, + IImsupp_Sb_boundss = IImsupp_Sb_boundss + } end + ) (#params model) (#params (#consts model)) (#tacs model) (#ops model) SSupp_premss + (#lives model) (#lives' model) (#frees model) fss Injss rhoss hss (#Sbs (#consts model)) + (#Vrs (#consts model)) (#RVrs (#consts model)); + + val facts = @{map 3} (fn Inj_inj => fn SSupp_thms => fn Supp_Injss => { + Inj_inj = Inj_inj, + Supp_Injss = Supp_Injss, + SSupp_Map_subsets = #SSupp_Map_subsets SSupp_thms, + SSupp_Map_bounds = #SSupp_Map_bounds SSupp_thms, + IImsupp_Map_subsets = #IImsupp_Map_subsets SSupp_thms, + IImsupp_Map_bounds = #IImsupp_Map_bounds SSupp_thms, + SSupp_Sb_subsets = #SSupp_Sb_subsets SSupp_thms, + SSupp_Sb_bounds = #SSupp_Sb_bounds SSupp_thms, + IImsupp_Sb_subsetss = #IImsupp_Sb_subsetss SSupp_thms, + IImsupp_Sb_boundss = #IImsupp_Sb_boundss SSupp_thms + }: bmv_monad_facts) Inj_injs SSupp_thms Supp_Injss; + + val bmv = BMV { + ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), + var_class = #var_class model, + leader = #leader model, + frees = #frees model @ maps (#frees o Rep_bmv) (#bmv_ops model), + lives = #lives model @ maps (#lives o Rep_bmv) (#bmv_ops model), + lives' = #lives' model @ maps (#lives' o Rep_bmv) (#bmv_ops model), + deads = #deads model @ maps (#deads o Rep_bmv) (#bmv_ops model), + consts = consts, + params = #params model @ maps (#params o Rep_bmv) (#bmv_ops model), + axioms = axioms', + facts = facts @ maps facts_of_bmv_monad (#bmv_ops model), + bd_infinite_regular_card_order = #bd_infinite_regular_card_order model, + unfolds = unfolds, + defs = defs + } : bmv_monad; + + val (_, lthy) = note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy; + in (bmv, lthy) end + +fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = + let + val goals = mk_bmv_monad_axioms (#ops model) (#consts model) (#bmv_ops model) lthy; + val tacs' = map (map_bmv_monad_axioms (fn tac => fn ctxt => Local_Defs.unfold0_tac ctxt defs THEN tac ctxt)) (#tacs model); + in (map2 apply_bmv_monad_axioms + (map (map_bmv_monad_axioms (fn goal => fn tac => Goal.prove_sorry lthy [] [] goal (tac o #context))) goals) + tacs' + ) + end; + +fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = + let + val goals = @{map 6} (fn Sb => fn RVrs => fn Vrs => fn extra_Vrs => fn Injs => Option.map (fn param => + mk_param_axiom (#Map param) (#Supps param) Sb Injs RVrs Vrs extra_Vrs (#bd (#consts model)) (#ops model @ maps ops_of_bmv_monad (#bmv_ops model)) + (#RVrs (#consts model) @ maps RVrs_of_bmv_monad (#bmv_ops model)) + (#Vrs (#consts model) @ maps Vrs_of_bmv_monad (#bmv_ops model)) + (#extra_Vrs (#consts model) @ maps extra_Vrs_of_bmv_monad (#bmv_ops model)) + (map_filter I (#params (#consts model) @ maps (#params o consts_of_bmv_monad) (#bmv_ops model))) lthy + )) (#Sbs (#consts model)) (#RVrs (#consts model)) (#Vrs (#consts model)) (#extra_Vrs (#consts model)) (#Injs (#consts model)) (#params (#consts model)) + val tacs' = map (Option.map (map_bmv_monad_param (fn tac => fn goal => + Goal.prove_sorry lthy [] [] goal (fn {context=ctxt, ...} => + Local_Defs.unfold0_tac ctxt defs THEN tac ctxt + ) + ))) (#params model); + in map2 (@{map_option 2} ( + fn { axioms=tacs, Map_Sb=f1, Supp_Sb=f2s, Vrs_Map=f3s, Map_Injs=f4s } => + fn { axioms, Map_Sb, Supp_Sb, Vrs_Map, Map_Injs } => { + Map_Sb = f1 Map_Sb, + Supp_Sb = map2 (curry (op|>)) Supp_Sb f2s, + Vrs_Map = map2 (curry (op|>)) Vrs_Map f3s, + Map_Injs = map2 (curry (op|>)) Map_Injs f4s, + axioms = { + Map_id = #Map_id tacs (#Map_id axioms), + Map_comp = #Map_comp tacs (#Map_comp axioms), + Supp_Map = map2 (curry (op|>)) (#Supp_Map axioms) (#Supp_Map tacs), + Supp_bd = map2 (curry (op|>)) (#Supp_bd axioms) (#Supp_bd tacs), + Map_cong = #Map_cong tacs (#Map_cong axioms) + } + } : thm bmv_monad_param)) tacs' goals end; + +fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { + ops = #ops model, + var_class = #var_class model, + leader = #leader model, + frees = #frees model, + lives = #lives model, + lives' = #lives' model, + deads = #deads model, + bmv_ops = #bmv_ops model, + consts = #consts model, + params = params, + bd_infinite_regular_card_order = bd_irco, + tacs = axioms +} : thm bmv_monad_model; + +fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = + let + val frees = map (fn T => TFree (apsnd ( + Sign.minimize_sort (Proof_Context.theory_of lthy) o cons (#var_class model) + ) (dest_TFree T))) (nth (#frees model) (#leader model)); + val phi = MRBNF_Util.subst_typ_morphism (nth (#frees model) (#leader model) ~~ frees); + val model = morph_bmv_monad_model phi I model; + + val (consts, unfold_set, lthy) = define_bmv_monad_consts bmv_b_opt const_policy (fact_policy lthy) qualify + (#leader model) (#ops model) (#frees model) (#lives' model) (#consts model) lthy; + val model = update_consts consts model; + + val axioms = prove_axioms model unfold_set lthy; + val params = prove_params model unfold_set lthy; + + val bd_irco = Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop ( + mk_infinite_regular_card_order (#bd (#consts model)) + )) (fn {context=ctxt, ...} => Local_Defs.unfold0_tac ctxt unfold_set THEN #bd_infinite_regular_card_order model ctxt); + + val model = mk_thm_model model params axioms bd_irco; + in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy qualify bmv_b_opt model unfold_set defs lthy) end + +fun pbmv_monad_of_mrbnf qualify mrbnf lthy = + let + val (((((lives, lives'), frees), bounds), deads), names_lthy) = lthy + |> mk_TFrees (MRBNF_Def.live_of_mrbnf mrbnf) + ||>> mk_TFrees (MRBNF_Def.live_of_mrbnf mrbnf) + ||>> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.frees_of_mrbnf mrbnf)) + ||>> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.bounds_of_mrbnf mrbnf)) + ||>> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.deads_of_mrbnf mrbnf)); + + val ((fs, gs), _) = names_lthy + |> mk_Frees "f" (map (fn a => a --> a) frees) + ||>> mk_Frees "g" (map2 (curry (op-->)) lives lives'); + val T = MRBNF_Def.mk_T_of_mrbnf deads lives bounds frees mrbnf; + val n = MRBNF_Def.live_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.free_of_mrbnf mrbnf; + val (var_class, lthy) = Var_Classes.mk_class_for_bound + (Binding.prefix_name "var_" (MRBNF_Def.name_of_mrbnf mrbnf)) (MRBNF_Def.bd_of_mrbnf mrbnf) lthy + + val (lsets, _, fsets) = MRBNF_Def.deinterlace (MRBNF_Def.mk_sets_of_mrbnf + (replicate n deads) (replicate n lives) (replicate n bounds) (replicate n frees) mrbnf + ) (MRBNF_Def.var_types_of_mrbnf mrbnf); + + val Sb = if null fs then HOLogic.id_const T else + fold_rev (Term.absfree o dest_Free) fs (Term.list_comb ( + MRBNF_Def.mk_map_of_mrbnf deads lives lives bounds frees mrbnf, + MRBNF_Def.interlace (map HOLogic.id_const lives) (map HOLogic.id_const bounds) fs (MRBNF_Def.var_types_of_mrbnf mrbnf) + )); + val Map = if null lives then NONE else SOME ( + fold_rev (Term.absfree o dest_Free) gs (Term.list_comb ( + MRBNF_Def.mk_map_of_mrbnf deads lives lives' bounds frees mrbnf, + MRBNF_Def.interlace gs (map HOLogic.id_const bounds) (map HOLogic.id_const frees) (MRBNF_Def.var_types_of_mrbnf mrbnf) + )) + ); + val name = MRBNF_Def.name_of_mrbnf mrbnf; + in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify (SOME name) { + ops = [T], + var_class = var_class, + leader = 0, + frees = [frees], + lives = [lives], + lives' = [lives'], + deads = [bounds @ deads], + bmv_ops = [], + consts = { + bd = MRBNF_Def.bd_of_mrbnf mrbnf, + Injs = [[]], + Sbs = [Sb], + Vrs = [[]], + RVrs = [fsets], + extra_Vrs = [[]], + params = [Option.map (fn Map => { + Map = Map, + Supps = lsets + }) Map] + }, + params = [Option.map (fn _ => { + axioms = { + Map_id = fn ctxt => rtac ctxt (MRBNF_Def.map_id0_of_mrbnf mrbnf) 1, + Map_comp = fn ctxt => EVERY1 [ + rtac ctxt (trans OF [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym]), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ], + Supp_Map = map (fn _ => fn ctxt => EVERY1 [ + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} + ]) lsets, + Supp_bd = map (fn _ => fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf mrbnf) 1) lsets, + Map_cong = fn ctxt => EVERY1 [ + rtac ctxt (MRBNF_Def.map_cong0_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + REPEAT_DETERM o (rtac ctxt refl ORELSE' Goal.assume_rule_tac ctxt) + ] + }, + Map_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt (trans OF [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt sym, + rtac ctxt (trans OF [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ] + ], + Supp_Sb = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt trans, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt @{thm image_id} + ] + ]) lsets, + Vrs_Map = map (fn _ => fn ctxt => EVERY1 [ + rtac ctxt trans, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms bij_id supp_id_bound}, + rtac ctxt @{thm image_id} + ]) fsets, + Map_Injs = [] + }) Map], + bd_infinite_regular_card_order = fn ctxt => rtac ctxt (MRBNF_Def.bd_infinite_regular_card_order_of_mrbnf mrbnf) 1, + tacs = [{ + Sb_Inj = fn ctxt => resolve_tac ctxt [refl, MRBNF_Def.map_id0_of_mrbnf mrbnf] 1, + Sb_comp_Injs = [], + Sb_comp = fn ctxt => EVERY1 [ + TRY o EVERY' [ + rtac ctxt (trans OF [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ], + Vrs_bds = map (fn _ => fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf mrbnf) 1) fsets, + Vrs_Injss = replicate (length fsets) [], + Vrs_Sbs = map (fn _ => fn ctxt => EVERY1 [ + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ]) fsets, + Sb_cong = fn ctxt => rtac ctxt refl 1 ORELSE EVERY1 [ + rtac ctxt (MRBNF_Def.map_cong0_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + REPEAT_DETERM o (rtac ctxt refl ORELSE' Goal.assume_rule_tac ctxt) + ] + }] + } [] lthy) end; + +fun register_mrbnf_as_pbmv_monad name lthy = + let + val mrbnf = the (MRBNF_Def.mrbnf_of lthy name); + val (bmv, lthy) = pbmv_monad_of_mrbnf I mrbnf lthy; + val lthy = register_pbmv_monad name bmv lthy; + in lthy end + +fun unsafe_slice_bmv_monad n bmv = + let + fun f xs = nth xs n; + val Sb = f (Sbs_of_bmv_monad bmv); + in BMV { + ops = [f (ops_of_bmv_monad bmv)], + var_class = var_class_of_bmv_monad bmv, + leader = 0, + frees = [f (frees_of_bmv_monad bmv)], + lives = [f (lives_of_bmv_monad bmv)], + lives' = [f (lives'_of_bmv_monad bmv)], + deads = [f (deads_of_bmv_monad bmv)], + consts = { + bd = bd_of_bmv_monad bmv, + params = [@{map_option 2} (fn Map => fn Supps => { + Map = Map, Supps = Supps + }) (f (Maps_of_bmv_monad bmv)) (f (Supps_of_bmv_monad bmv))], + Injs = [f (Injs_of_bmv_monad bmv)], + Sbs = [Sb], + RVrs = [f (RVrs_of_bmv_monad bmv)], + Vrs = [f (Vrs_of_bmv_monad bmv)], + extra_Vrs = [f (extra_Vrs_of_bmv_monad bmv)] + }, + params = [f (params_of_bmv_monad bmv)], + bd_infinite_regular_card_order = bd_infinite_regular_card_order_of_bmv_monad bmv, + axioms = [f (axioms_of_bmv_monad bmv)], + facts = [f (facts_of_bmv_monad bmv)], + unfolds = unfolds_of_bmv_monad bmv, + defs = defs_of_bmv_monad bmv + } end; + +fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives, frees=dfrees } lthy = + let + fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv); + val (((frees, lives), deads), names_lthy) = lthy + |> mk_TFrees' (map Type.sort_of_atyp (leader frees_of_bmv_monad bmv)) + ||>> mk_TFrees (length (leader lives_of_bmv_monad bmv)) + ||>> mk_TFrees' (map Type.sort_of_atyp (leader deads_of_bmv_monad bmv)); + + val new_deads = deads @ cond_keep frees dfrees @ + @{map_filter 2} (fn Dead_Var => SOME | _ => K NONE) dlives lives; + + val new_frees = map (resort_tfree_or_tvar @{sort var}) ( + subtract (op=) new_deads (distinct (op=) (take (length (leader RVrs_of_bmv_monad bmv)) frees + @ @{map_filter 2} (fn Free_Var => SOME | _ => K NONE) dlives lives @ frees + )) + ); + val new_lives = @{map_filter 2} (fn Live_Var => SOME | _ => K NONE) dlives lives; + + val (new_lives', _) = names_lthy + |> mk_TFrees (length new_lives); + + val vars = new_frees @ new_lives @ new_deads; + + fun find_var a = the (List.find (curry ((op=) o apply2 (fst o dest_TFree)) a) vars); + val bmv = morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( + (leader frees_of_bmv_monad bmv ~~ map find_var frees) + @ flat (@{map 3} (fn l => fn l' => fn new_l => + let val idx = find_index (curry ((op=) o apply2 (fst o dest_TFree)) new_l) new_lives; + in if idx > ~1 then [(l, nth new_lives idx), (l', nth new_lives' idx)] + else [(l, find_var new_l), (l', find_var new_l)] end + ) (leader lives_of_bmv_monad bmv) (leader lives'_of_bmv_monad bmv) lives) + @ (leader deads_of_bmv_monad bmv ~~ map find_var deads) + )) bmv; + + val n = length (ops_of_bmv_monad bmv); + val slices = map (fn i => unsafe_slice_bmv_monad i bmv) (0 upto n - 1); + + val (bmv_ops, demoted_bmvs) = partition (fn bmv => + forall (member (op=) new_frees) (hd (frees_of_bmv_monad bmv)) + andalso forall (member (op=) new_deads) (hd (deads_of_bmv_monad bmv)) + andalso forall (member (op=) new_lives) (hd (lives_of_bmv_monad bmv)) + ) slices; + + val new_RVrss = map (fn bmv => + filter (member (op=) new_frees o HOLogic.dest_setT o body_type o fastype_of) (hd (RVrs_of_bmv_monad bmv)) + @ (if null (hd (lives_of_bmv_monad bmv)) then [] else @{map_filter 2} (fn l => fn Supp => + if member (op=) new_frees l then SOME Supp else NONE + ) (hd (lives_of_bmv_monad bmv)) (the (hd (Supps_of_bmv_monad bmv)))) + ) demoted_bmvs; + + val new_Injss = map (filter (member (op=) new_frees o domain_type o fastype_of) o hd o Injs_of_bmv_monad) demoted_bmvs; + val new_Vrss = map2 (fn new_Injs => fn bmv => @{map_filter 2} (fn Vr => fn Inj => + if member (op=) new_Injs Inj then SOME Vr else NONE + ) (hd (Vrs_of_bmv_monad bmv)) (hd (Injs_of_bmv_monad bmv))) new_Injss demoted_bmvs; + + val new_params = map (fn bmv => + let + val (new_lives, new_lives') = split_list (filter_out (op=) (hd (lives_of_bmv_monad bmv) ~~ hd (lives'_of_bmv_monad bmv))); + in if null new_lives then NONE else + let + val (fs, _) = lthy + |> mk_Frees "f" (map2 (curry (op-->)) new_lives new_lives'); + + val Map = fold_rev (Term.absfree o dest_Free) fs (Term.list_comb (the (hd (Maps_of_bmv_monad bmv)), + map2 (fn l => fn l' => + if l = l' then HOLogic.id_const l else the (List.find (curry (op=) l o domain_type o fastype_of) fs) + ) (hd (lives_of_bmv_monad bmv)) (hd (lives'_of_bmv_monad bmv)) + )); + val Supps = @{map_filter 3} (fn l => fn l' => fn Supp => if l = l' then NONE else SOME Supp) + (hd (lives_of_bmv_monad bmv)) (hd (lives'_of_bmv_monad bmv)) (the (hd (Supps_of_bmv_monad bmv))); + in SOME { Map = Map, Supps = Supps } end + end + ) demoted_bmvs; + + val new_Sbs = @{map 3} (fn RVrs => fn Injs => fn bmv => + let + val ((fs, rhos), _) = lthy + |> mk_Frees "f" (map (fn a => a --> a) (map (HOLogic.dest_setT o body_type o fastype_of) RVrs)) + ||>> mk_Frees "\" (map fastype_of Injs); + + val Map_fs = map (fn l => case List.find (curry (op=) l o domain_type o fastype_of) fs of + SOME f => f | NONE => HOLogic.id_const l + ) (hd (lives_of_bmv_monad bmv)); + val with_Map = if null (inter (op=) Map_fs fs) then I else fn t => + HOLogic.mk_comp (t, Term.list_comb (Term.subst_atomic_types ( + hd (lives'_of_bmv_monad bmv) ~~ hd (lives_of_bmv_monad bmv) + ) (the (hd (Maps_of_bmv_monad bmv))), Map_fs)); + in fold_rev (Term.absfree o dest_Free) (fs @ rhos) (with_Map ( + Term.list_comb (hd (Sbs_of_bmv_monad bmv), map (fn Inj' => + case List.find (curry (op=) (fastype_of Inj') o fastype_of) rhos of + SOME rho => rho | NONE => Inj' + ) (hd (Injs_of_bmv_monad bmv))) + )) end + ) new_RVrss new_Injss demoted_bmvs; + + val extra_Vrs = @{map 3} (fn bmv => fn RVrs => fn Vrs => + subtract (op=) (RVrs @ Vrs) (hd (RVrs_of_bmv_monad bmv) @ hd (Vrs_of_bmv_monad bmv)) + ) demoted_bmvs new_RVrss new_Vrss; + + val consts = { + Injs = new_Injss, + RVrs = new_RVrss, + Sbs = new_Sbs, + Vrs = new_Vrss, + params = new_params, + bd = bd_of_bmv_monad bmv, + extra_Vrs = extra_Vrs + }: bmv_monad_consts; + + val (livess, livess') = split_list (map (split_list o the_default [] o Option.map (fn { Map, ... } => + map dest_funT (fst (split_last (binder_types (fastype_of Map)))) + )) new_params); + + val freess = map ( + distinct (op=) o map domain_type o fst o split_last o binder_types o fastype_of + ) new_Sbs; + + val deadss = @{map 3} (fn lives => fn frees => fn bmv => + subtract (op=) (lives @ frees) (map TFree (rev (Term.add_tfreesT (hd (ops_of_bmv_monad bmv)) []))) + ) livess freess demoted_bmvs; + + val new_ops = map (hd o ops_of_bmv_monad) demoted_bmvs; + + val model = { + ops = new_ops, + bmv_ops = bmv_ops, + leader = find_index (curry (op=) (leader ops_of_bmv_monad bmv)) (map (hd o ops_of_bmv_monad) demoted_bmvs), + consts = consts, + lives = livess, + lives' = livess', + frees = freess, + deads = deadss, + var_class = var_class_of_bmv_monad bmv, + bd_infinite_regular_card_order = fn ctxt => rtac ctxt (bd_infinite_regular_card_order_of_bmv_monad bmv) 1, + params = @{map 5} (fn Injs => fn RVrs => fn params => fn facts => Option.map (fn { Supps, ... } => { + axioms = { + Map_id = fn ctxt => rtac ctxt (#Map_id (#axioms (the params))) 1, + Map_comp = fn ctxt => EVERY1 [ + rtac ctxt trans, + rtac ctxt (#Map_comp (#axioms (the params))), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ], + Map_cong = fn ctxt => EVERY1 [ + rtac ctxt (#Map_cong (#axioms (the params))), + REPEAT_DETERM o (rtac ctxt refl ORELSE' Goal.assume_rule_tac ctxt) + ], + Supp_Map = map (K (fn ctxt => resolve_tac ctxt (#Supp_Map (#axioms (the params))) 1)) Supps, + Supp_bd = map (K (fn ctxt => resolve_tac ctxt (#Supp_bd (#axioms (the params))) 1)) Supps + }, + Map_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) = domain_type (fastype_of (hd Supps)) then + SOME (fn ctxt => resolve_tac ctxt (#Map_Injs (the params)) 1) + else NONE) Injs, + Map_Sb = fn ctxt => EVERY1 [ + rtac ctxt trans, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} + ], + rtac ctxt (#Map_Sb (the params)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}), + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} + @ #Map_Injs (the params) + @ [#Map_comp (#axioms (the params))] + )), + rtac ctxt refl + ], + Supp_Sb = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_apply})), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Supp_Sb (the params)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms image_id UN_empty2 Un_empty_left Un_empty_right} + @ #Supp_Map (#axioms (the params)) + @ #Vrs_Map (the params) @ flat (#Supp_Injss facts) + )), + rtac ctxt refl + ])) Supps, + Vrs_Map = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms image_id} + @ #Supp_Map (#axioms (the params)) + @ #Vrs_Map (the params) + )), + rtac ctxt refl + ])) (RVrs @ Injs) + })) new_Injss new_RVrss (map (hd o params_of_bmv_monad) demoted_bmvs) + (map (hd o facts_of_bmv_monad) demoted_bmvs) new_params, + tacs = @{map 7} (fn T => fn Injs => fn RVrs => fn extra_Vrs => fn axioms => fn params => fn facts => { + Sb_Inj = fn ctxt => Local_Defs.unfold0_tac ctxt ( + [@{thm id_o}, #Sb_Inj axioms] @ the_default [] (Option.map (single o #Map_id o #axioms) params) + ) THEN rtac ctxt refl 1, + Sb_comp_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc} @ the_default [] (Option.map #Map_Injs params))), + resolve_tac ctxt (#Sb_comp_Injs axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ]) + ) Injs, + Sb_comp = fn ctxt => EVERY1 [ + rtac ctxt trans, + rtac ctxt (#Sb_comp axioms) ORELSE' EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + resolve_tac ctxt (the_default [] (Option.map (single o #Map_Sb) params)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}), + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + resolve_tac ctxt (the_default [] (Option.map (single o #Map_comp o #axioms) params)), + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt trans, + rtac ctxt (#Sb_comp axioms) + ], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms SSupp_Inj_bound IImsupp_Inj_bound} + @ maps (the_default [] o #SSupp_Map_bounds) (facts_of_bmv_monad bmv) + @ maps (flat o the_default [] o #IImsupp_Map_bounds) (facts_of_bmv_monad bmv) + )), + K (Local_Defs.unfold0_tac ctxt (@{thm comp_assoc} :: the_default [] (Option.map #Map_Injs params))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (axioms_of_bmv_monad bmv)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + rtac ctxt refl + ], + Vrs_Injss = map (K (map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => resolve_tac ctxt (flat (#Vrs_Injss axioms @ #Supp_Injss facts)) 1) + ) Injs)) (RVrs @ Injs @ extra_Vrs), + Vrs_Sbs = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs axioms @ the_default [] (Option.map #Supp_Sb params)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms UN_empty2 Un_empty_left Un_empty_right Un_assoc} + @ flat (#Vrs_Injss axioms) + @ flat (#Supp_Injss facts) + @ the_default [] (Option.map (fn params => + #Supp_Map (#axioms params) @ #Vrs_Map params + ) params) + )), + rtac ctxt refl + ])) (RVrs @ Injs), + Vrs_bds = map (K (fn ctxt => + resolve_tac ctxt (#Vrs_bds axioms @ the_default [] (Option.map (#Supp_bd o #axioms) params)) 1 + )) (RVrs @ Injs), + Sb_cong = fn ctxt => EVERY1 [ + the_default (K all_tac) (Option.map (fn params => TRY o EVERY' [ + rtac ctxt @{thm comp_apply_eq}, + rtac ctxt (@{thm cong'[rotated]} OF [#Map_cong (#axioms params)]), + REPEAT_DETERM o (rtac ctxt refl ORELSE' Goal.assume_rule_tac ctxt) + ]) params), + rtac ctxt (#Sb_cong axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}), + K (Local_Defs.unfold0_tac ctxt (the_default [] (Option.map #Vrs_Map params))), + REPEAT_DETERM o (rtac ctxt refl ORELSE' Goal.assume_rule_tac ctxt) + ] + }) new_ops new_Injss new_RVrss extra_Vrs (map (hd o axioms_of_bmv_monad) demoted_bmvs) + (map (hd o params_of_bmv_monad) demoted_bmvs) (map (hd o facts_of_bmv_monad) demoted_bmvs) + }: (Proof.context -> tactic) bmv_monad_model; + in bmv_monad_def inline_policy const_policy qualify b_opt model [] lthy end + +fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) + (oAs: { frees: typ list, deads: typ list }) (Ass : ({ frees: typ list, lives: typ list, deads: typ list }) option list) lthy = + let + val _ = if length (nth (lives_of_bmv_monad outer) (leader_of_bmv_monad outer)) <> length inners then + error "Outer needs exactly as many lives as there are inners" else () + + fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) + + fun eq_name (a, b) = case try (apply2 (fst o dest_TFree)) (a, b) of + SOME (x, y) => x = y + | NONE => a = b + val deads = distinct eq_name ( + #deads oAs @ flat (map2 (fn SOME { deads, ...} => K deads | + NONE => fn Inr T => map TFree (rev (Term.add_tfreesT T [])) + ) Ass inners) + ); + (* TODO: other bounds *) + val frees = map (resort_tfree_or_tvar @{sort var}) (distinct eq_name (#frees oAs @ flat (map_filter (Option.map #frees) Ass))) + val killed_frees = inter eq_name deads frees; + val deads = map (fn d => the_default d (List.find (curry eq_name d) killed_frees)) deads; + val frees = subtract eq_name deads frees; + + val lives = subtract eq_name (deads @ frees) ( + distinct eq_name (flat (map_filter (Option.map #lives) Ass)) + ); + val vars = deads @ frees @ lives; + + val (lives', names_lthy) = lthy + |> fold Variable.declare_typ vars + |> mk_TFrees (length lives); + + fun find_vars xs = map (fn x => the ( + List.find (curry eq_name x) vars + )) xs; + val ((inners, unfold_set), lthy) = apfst (apsnd flat o split_list) (@{fold_map 2} (fn As => fn Inl bmv => (fn lthy => + let + val new_frees = find_vars (#frees (the As)); + val new_deads = find_vars (#deads (the As)); + val new_lives = find_vars (#lives (the As)); + val new_lives' = map (fn a => case find_index (curry (op=) a) lives of + ~1 => a | i => nth lives' i + ) new_lives; + + val phi = MRBNF_Util.subst_typ_morphism ( + (leader frees_of_bmv_monad bmv ~~ new_frees) + @ (leader deads_of_bmv_monad bmv ~~ new_deads) + @ (leader lives_of_bmv_monad bmv ~~ new_lives) + @ (leader lives'_of_bmv_monad bmv ~~ new_lives') + ); + val bmv = morph_bmv_monad phi bmv; + + val dlives = map (fn l => if member (op=) lives l then Live_Var + else if member (op=) frees l then Free_Var else Dead_Var + ) new_lives; + val dfrees = map (member (op=) deads) new_frees; + val lives' = @{map_filter 2} (fn Live_Var => SOME | _ => K NONE) dlives new_lives'; + val ((bmv, unfold_set), lthy) = if forall (curry (op=) Live_Var) dlives andalso forall not dfrees then + ((bmv, []), lthy) + else + let + val ((bmv', unfold_set), lthy) = demote_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) + (Binding.prefix_name "demote_" o qualify) NONE bmv + { frees = dfrees, lives = dlives } lthy; + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) ( + Logic.varifyT_global (leader ops_of_bmv_monad bmv'), + leader ops_of_bmv_monad bmv + ) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism ( + map (fn (x, (s, T)) => (TFree (fst x, s), T)) (Vartab.dest tyenv) + @ (leader lives'_of_bmv_monad bmv' ~~ lives') + ); + in ((morph_bmv_monad phi bmv', unfold_set), lthy) end; + in ((Inl bmv, unfold_set), lthy) end + ) | Inr T => fn lthy => + let + val old_vars = map TFree (Term.add_tfreesT T []); + val subst = map (fn a => (a, the (List.find (curry eq_name a) vars))) old_vars; + in ((Inr (Term.typ_subst_atomic subst T), []), lthy) end + ) Ass inners lthy); + + val outer = + let + val new_frees = find_vars (#frees oAs); + val new_deads = find_vars (#deads oAs); + val new_lives = map (either (leader ops_of_bmv_monad) I) inners; + val new_lives' = map (Term.typ_subst_atomic (lives ~~ lives')) new_lives; + + val phi = MRBNF_Util.subst_typ_morphism ( + (leader frees_of_bmv_monad outer ~~ new_frees) + @ (leader deads_of_bmv_monad outer ~~ new_deads) + @ (leader lives_of_bmv_monad outer ~~ new_lives) + @ (leader lives'_of_bmv_monad outer ~~ new_lives') + ); + in morph_bmv_monad phi outer end; + + val inners' = map_filter (fn Inl x => SOME x | _ => NONE) inners; + + val (x, _) = names_lthy + |> apfst hd o mk_Frees "x" [leader ops_of_bmv_monad outer]; + + val new_Injs = distinct (op=) (filter (member (op=) frees o domain_type o fastype_of) ( + maps (leader Injs_of_bmv_monad) (outer :: inners') + )); + + fun option x f y = the_default x (Option.map f y) + val new_RVrs = map_filter (fn a => + let + fun get_RVrs bmv = List.find (curry (op=) a o HOLogic.dest_setT o body_type o fastype_of) ( + (if null (leader lives_of_bmv_monad bmv) then [] else + @{map_filter 3} (fn l => fn l' => fn set => + if l = l' then SOME set else NONE + ) (leader lives_of_bmv_monad bmv) (leader lives'_of_bmv_monad bmv) (the (leader Supps_of_bmv_monad bmv)) + ) @ leader RVrs_of_bmv_monad bmv + ); + val outer_RVrs = option [] (fn set => [set $ x]) (get_RVrs outer); + val inner_RVrs = @{map_filter 2} (fn Inr _ => K NONE | Inl inner => fn set => Option.map (fn RVrs => + mk_UNION (set $ x) RVrs + ) (get_RVrs inner)) inners (the (leader Supps_of_bmv_monad outer)) + in case inner_RVrs of + [] => try (foldl1 mk_Un) (map (fst o dest_comb) outer_RVrs) + | _ => Option.map (Term.absfree (dest_Free x)) ( + try (foldl1 mk_Un) (outer_RVrs @ inner_RVrs) + ) + end + ) frees; + + val new_Vrs = map (fn Inj => + let + fun get_Vrs bmv = case find_index ((op=) o apply2 fastype_of o pair Inj) (leader Injs_of_bmv_monad bmv) of + ~1 => NONE | n => SOME (nth (leader Vrs_of_bmv_monad bmv) n); + + val outer_Vrs = option [] (fn Vr => [Vr $ x]) (get_Vrs outer); + val inner_Vrs = @{map_filter 2} (fn Inr _ => K NONE | Inl inner => fn set => Option.map (fn Vr => + mk_UNION (set $ x) Vr + ) (get_Vrs inner)) inners (the (leader Supps_of_bmv_monad outer)); + in case inner_Vrs of + [] => foldl1 mk_Un (map (fst o dest_comb) outer_Vrs) + | _ => Term.absfree (dest_Free x) (foldl1 mk_Un (outer_Vrs @ inner_Vrs)) + end + ) new_Injs; + + val (((hs, rhos), fs), _) = names_lthy + |> mk_Frees "h" (map (fn Vr => let val T = HOLogic.dest_setT (body_type (fastype_of Vr)) in T --> T end) new_RVrs) + ||>> mk_Frees "\" (map fastype_of new_Injs) + ||>> mk_Frees "f" (map2 (curry (op-->)) lives lives'); + + val new_Sb = + let + val osubst = lives' ~~ lives; + val map_t = Term.list_comb (Term.subst_atomic_types osubst ( + the (leader Maps_of_bmv_monad outer) + ), map (fn Inr T => HOLogic.id_const T | Inl inner => + Term.list_comb (leader Sbs_of_bmv_monad inner, map (fn RVrs => + the (List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of RVrs))) o domain_type o fastype_of) hs) + ) (leader RVrs_of_bmv_monad inner) @ map (fn Inj => + the (List.find (curry (op=) (fastype_of Inj) o fastype_of) rhos) + ) (leader Injs_of_bmv_monad inner)) + ) inners); + val add_Sb = if null (leader RVrs_of_bmv_monad outer @ leader Vrs_of_bmv_monad outer) then I else fn t => HOLogic.mk_comp ( + Term.list_comb (leader Sbs_of_bmv_monad outer, map (fn RVrs => + let val T = HOLogic.dest_setT (body_type (fastype_of RVrs)); + in the_default (HOLogic.id_const T) (List.find (curry (op=) T o domain_type o fastype_of) hs) end + ) (leader RVrs_of_bmv_monad outer) @ map (fn Inj => the_default Inj ( + List.find (curry (op=) (fastype_of Inj) o fastype_of) rhos + )) (leader Injs_of_bmv_monad outer) + ), t); + in fold_rev (Term.absfree o dest_Free) (hs @ rhos) (add_Sb map_t) end; + + val param = if null lives then NONE else + let + val Map = fold_rev (Term.absfree o dest_Free) fs ( + Term.list_comb (the (leader Maps_of_bmv_monad outer), + map (fn Inr T => HOLogic.id_const T | Inl inner => if null (leader lives_of_bmv_monad inner) then + HOLogic.id_const (leader ops_of_bmv_monad inner) else Term.list_comb (the (leader Maps_of_bmv_monad inner), + map (fn l => the_default (HOLogic.id_const l) + (List.find (curry (op=) l o domain_type o fastype_of) fs) + ) (leader lives_of_bmv_monad inner) + ) + ) inners + ) + ); + val Supps = map (fn live => Term.absfree (dest_Free x) (foldl1 mk_Un (@{map_filter 2} ( + fn Inr _ => K NONE | Inl inner => fn set => if null (leader lives_of_bmv_monad inner) then NONE + else case filter (curry (op=) live o HOLogic.dest_setT o body_type o fastype_of) (the (leader Supps_of_bmv_monad inner)) of + [] => NONE + | xs => SOME (mk_UNION (set $ x) (Term.abs ("a", HOLogic.dest_setT (fastype_of (set $ x))) ( + foldl1 mk_Un (map (fn s => s $ Bound 0) xs))) + ) + ) inners (the (leader Supps_of_bmv_monad outer))))) lives; + in SOME { Map = Map, Supps = Supps } end; + + val new_minions = maps (fn bmv => map_index (fn (i, T) => (T, unsafe_slice_bmv_monad i bmv)) (ops_of_bmv_monad bmv)) ( + filter_out (curry (op=) (leader ops_of_bmv_monad outer) o hd o ops_of_bmv_monad) ( + distinct ((op=) o apply2 (leader ops_of_bmv_monad)) (outer :: inners') + ) + ); + val new_minions = map_filter (AList.lookup (op=) new_minions) (distinct (op=) (map (body_type o fastype_of) new_Injs)); + val axiomss = map (leader axioms_of_bmv_monad) inners'; + + val consts = { + bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) + Injs = [new_Injs], + Sbs = [new_Sb], + Vrs = [new_Vrs], + RVrs = [new_RVrs], + params = [param], + extra_Vrs = [subtract (op=) (new_RVrs @ new_Vrs) (leader RVrs_of_bmv_monad outer @ leader Vrs_of_bmv_monad outer)] + }: bmv_monad_consts; + + val T = leader ops_of_bmv_monad outer; + + val no_reflexive = filter_out (fn thm => the_default false (Option.map (fn (lhs, rhs) => + lhs = rhs + ) (try (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm))); + + val model = { + ops = [T], + bmv_ops = new_minions, + bd_infinite_regular_card_order = fn ctxt => rtac ctxt (bd_infinite_regular_card_order_of_bmv_monad outer) 1, + var_class = var_class_of_bmv_monad outer, + frees = [frees], + lives = [lives], + lives' = [lives'], + deads = [deads], + consts = consts, + params = [Option.map (fn { Supps, ...} => + let + val param = the (leader params_of_bmv_monad outer); + val facts = leader facts_of_bmv_monad outer; + in { + axioms = { + Map_id = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (#Map_id (#axioms param) :: + map_filter (Option.map (#Map_id o #axioms) o leader params_of_bmv_monad) inners' + )), + rtac ctxt refl + ], + Map_comp = fn ctxt => EVERY1 [ + rtac ctxt (trans OF [#Map_comp (#axioms param)]), + rtac ctxt ext, + rtac ctxt (#Map_cong (#axioms param)), + REPEAT_DETERM o resolve_tac ctxt (@{thms refl id_o[THEN fun_cong]} @ map (fn thm => thm RS fun_cong) ( + map_filter (Option.map (#Map_comp o #axioms) o leader params_of_bmv_monad) inners' + )) + ], + Supp_Map = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms image_Un image_UN}), + SUBGOAL (fn (goal, _) => + let + fun strip_all (Const (@{const_name Pure.all}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) (strip_all t) + | strip_all t = ([], t) + val T = snd (snd (split_last (fst (strip_all goal)))) + val thms = map (fn thm => + let + val arg = Var (hd (Term.add_vars (Thm.prop_of thm) [])); + val tyenv = Sign.typ_match (Proof_Context.theory_of ctxt) + (fastype_of arg, T) Vartab.empty; + val insts = map (fn (x, (s, T)) => ((x, s), Thm.ctyp_of ctxt T)) (Vartab.dest tyenv) + in instantiate_normalize (TVars.make insts, Vars.empty) thm end + ) (#Supp_Map (#axioms param)); + in Local_Defs.unfold0_tac ctxt (@{thms UN_simps(10)} @ thms) end + ), + EVERY' (map (fn thm => TRY o EqSubst.eqsubst_tac ctxt [0] [thm]) + (flat (map_filter (Option.map (#Supp_Map o #axioms) o leader params_of_bmv_monad) inners')) + ), + K (Local_Defs.unfold0_tac ctxt @{thms image_UN[symmetric] image_Un[symmetric]}), + rtac ctxt refl + ]) Supps, + Supp_bd = map (fn _ => fn ctxt => REPEAT_DETERM (resolve_tac ctxt ( + flat (map_filter (Option.map (#Supp_bd o #axioms) o leader params_of_bmv_monad) inners') + @ #Supp_bd (#axioms param) + @ @{thms infinite_regular_card_order_UN infinite_regular_card_order_Un} + @ [bd_infinite_regular_card_order_of_bmv_monad outer] + ) 1)) Supps, + Map_cong = fn ctxt => Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ + rtac ctxt (#Map_cong (#axioms param)), + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => case leader params_of_bmv_monad inner of + NONE => rtac ctxt refl + | SOME param => EVERY' [ + rtac ctxt (#Map_cong (#axioms param)), + REPEAT_DETERM o EVERY' [ + resolve_tac ctxt prems, + etac ctxt @{thm UN_I} ORELSE' REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt @{thm UnI2} THEN' etac ctxt @{thm UN_I}, + rtac ctxt @{thm UnI1} THEN' etac ctxt @{thm UN_I}, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ], + TRY o assume_tac ctxt + ] + ] + ) inners) + ]) ctxt 1 + }, + Map_Sb = fn ctxt => EVERY1 [ + TRY o EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt (#Map_Sb param), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} + @ #Map_Injs param + )), + TRY o rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + REPEAT_DETERM_N 2 o EVERY' [ + rtac ctxt trans, + rtac ctxt (#Map_comp (#axioms param)), + rtac ctxt sym + ], + rtac ctxt ext, + rtac ctxt (#Map_cong (#axioms param)), + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => FIRST' [ + rtac ctxt refl, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}) THEN' rtac ctxt refl, + EVERY' [ + rtac ctxt trans, + resolve_tac ctxt (the_default [] (Option.map (fn param => [#Map_Sb param RS fun_cong]) (leader params_of_bmv_monad inner))), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}), + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + rtac ctxt refl + ] + ]) inners) + ], + Supp_Sb = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Supp_Sb param), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + SUBGOAL (fn (goal, _) => + let + fun strip_all (Const (@{const_name Pure.all}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) (strip_all t) + | strip_all t = ([], t) + val T = snd (snd (split_last (fst (strip_all goal)))) + val thms = map (fn thm => + let + val arg = Var (hd (Term.add_vars (Thm.prop_of thm) [])); + val tyenv = Sign.typ_match (Proof_Context.theory_of ctxt) + (fastype_of arg, T) Vartab.empty; + val insts = map (fn (x, (s, T)) => ((x, s), Thm.ctyp_of ctxt T)) (Vartab.dest tyenv) + in instantiate_normalize (TVars.make insts, Vars.empty) thm end + ) (#Supp_Map (#axioms param)); + in Local_Defs.unfold0_tac ctxt (@{thms UN_simps(10)} @ thms) end + ), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (flat (maps (map_filter (Option.map #Supp_Sb) o params_of_bmv_monad) inners')), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt ( + @{thms image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib} + @ #Vrs_Map param @ flat (#Supp_Injss facts) + )), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (flat (maps (map_filter (Option.map #Supp_Sb) o params_of_bmv_monad) inners')), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms id_apply image_Un Union_UN_swap image_UN UN_empty2 Un_empty_left Un_empty_right UN_UN_flatten UN_Un_distrib Un_assoc[symmetric]}), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt @{thm set_eqI}, + K (Local_Defs.unfold0_tac ctxt @{thms Un_iff}), + rtac ctxt iffI, + REPEAT_DETERM_N 2 o EVERY' [ + rotate_tac ~1, + etac ctxt @{thm contrapos_pp}, + K (Local_Defs.unfold0_tac ctxt @{thms de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + REPEAT_DETERM o rtac ctxt conjI, + REPEAT_DETERM o assume_tac ctxt + ] + ] + ]) Supps, + Vrs_Map = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms image_id image_comp[unfolded comp_def]} + @ #Vrs_Map param @ #Supp_Map (#axioms param) + @ flat (map_filter (Option.map #Vrs_Map o leader params_of_bmv_monad) inners') + )), + rtac ctxt refl + ]) (new_RVrs @ new_Vrs), + Map_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => resolve_tac ctxt (#Map_Injs param) 1) + ) new_Injs + } end) param], + leader = 0, + tacs = @{map 9} (fn axioms => fn param => fn facts => fn T => fn Map => fn Injs => fn RVrs => fn Vrs => fn extra_Vrs => { + Sb_Inj = fn ctxt => EVERY1 [ + K (Local_Defs.unfold_tac ctxt (@{thms id_o o_id} + @ no_reflexive (map #Sb_Inj (axioms :: axiomss)) + @ [#Map_id (#axioms param)] + )), + rtac ctxt refl + ], + Sb_comp_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc} @ #Map_Injs param)), + resolve_tac ctxt (#Sb_comp_Injs axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ]) + ) new_Injs, + Sb_comp = fn ctxt => EVERY1 [ + rtac ctxt trans, + TRY o EVERY'[ + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt (#Map_Sb param), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}), + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} + ], + rtac ctxt (#Map_comp (#axioms param)), + TRY o EVERY' [ + rtac ctxt @{thm comp_assoc[symmetric]}, + EqSubst.eqsubst_tac ctxt [0] [#Sb_comp axioms], + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt (@{thms SSupp_Inj_bound IImsupp_Inj_bound} + @ the (#SSupp_Map_bounds facts) @ flat (the (#IImsupp_Map_bounds facts)) + ) + ], + rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, + rtac ctxt ext, + SELECT_GOAL (EVERY1 [ + rtac ctxt (#Sb_cong axioms), + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ #Map_Injs param)), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt ( + @{thms refl supp_comp_bound infinite_class.infinite_UNIV SSupp_Inj_bound IImsupp_Inj_bound} + @ #SSupp_Sb_bounds facts @ the (#SSupp_Map_bounds facts) + @ flat (#IImsupp_Sb_boundss facts) @ flat (the (#IImsupp_Map_bounds facts)) + @ maps (map (fn thm => thm RS fun_cong) o #Sb_comp_Injs o leader axioms_of_bmv_monad) (outer :: inners') + ) + ] + ]) + ], + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt ext ORELSE' K (print_tac ctxt "Sb_comp: Sb_cong step failed"), + rtac ctxt (#Map_cong (#axioms param)), + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' EVERY' [ + rtac (Config.put Pattern.unify_trace_failure true ctxt) (#Sb_comp (leader axioms_of_bmv_monad inner) RS fun_cong), + REPEAT_DETERM o assume_tac ctxt + ]) inners) + ], + Vrs_bds = map (K (fn ctxt => EVERY1 [ + REPEAT_DETERM o resolve_tac ctxt ( + #Vrs_bds axioms + @ maps (maps #Vrs_bds o axioms_of_bmv_monad) inners' + @ #Supp_bd (#axioms param) + @ map (fn thm => + thm OF [bd_infinite_regular_card_order_of_bmv_monad outer] + ) @{thms infinite_regular_card_order_Un infinite_regular_card_order_UN} + ) + ])) (RVrs @ Vrs), + Vrs_Injss = map (K (map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms UN_empty Un_empty_left Un_empty_right} @ flat (#Supp_Injss facts))), + resolve_tac ctxt (refl :: flat (#Vrs_Injss axioms)) + ]) + ) new_Injs)) (new_RVrs @ new_Vrs @ extra_Vrs), + Vrs_Sbs = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs axioms @ #Supp_Sb param), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + SUBGOAL (fn (goal, _) => + let + fun strip_all (Const (@{const_name Pure.all}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) (strip_all t) + | strip_all t = ([], t) + val T = snd (snd (split_last (fst (strip_all goal)))) + val thms = map (fn thm => + let + val arg = Var (hd (Term.add_vars (Thm.prop_of thm) [])); + val tyenv = Sign.typ_match (Proof_Context.theory_of ctxt) + (fastype_of arg, T) Vartab.empty; + val insts = map (fn (x, (s, T)) => ((x, s), Thm.ctyp_of ctxt T)) (Vartab.dest tyenv) + in instantiate_normalize (TVars.make insts, Vars.empty) thm end + ) (#Supp_Map (#axioms param)); + in Local_Defs.unfold0_tac ctxt (@{thms UN_simps(10)} @ thms) end + ), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps (maps #Vrs_Sbs o axioms_of_bmv_monad) inners' + @ #Supp_Sb param @ flat (map_filter (Option.map #Supp_Sb o leader params_of_bmv_monad) inners') + ), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt ( + @{thms image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap Un_assoc[symmetric] + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib id_bnf_apply} + @ #Vrs_Map param @ flat (#Vrs_Injss axioms) + @ flat (maps ( + #Supp_Injss o leader facts_of_bmv_monad + ) (outer :: inners')) + )), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps (maps #Vrs_Sbs o axioms_of_bmv_monad) inners' + @ #Supp_Sb param @ flat (map_filter (Option.map #Supp_Sb o leader params_of_bmv_monad) inners') + ), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_single image_Un Union_UN_swap image_UN UN_empty2 Un_empty_left Un_empty_right UN_UN_flatten UN_Un_distrib Un_assoc[symmetric]}), + EVERY' (map_filter (fn inner => if Term.is_TFree (hd (ops_of_bmv_monad inner)) then SOME (EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms id_bnf_apply} @ unfolds_of_bmv_monad inner)) + ]) else NONE) inners'), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt @{thm set_eqI}, + K (Local_Defs.unfold0_tac ctxt @{thms Un_iff}), + rtac ctxt iffI, + REPEAT_DETERM_N 2 o EVERY' [ + rotate_tac ~1, + etac ctxt @{thm contrapos_pp}, + K (Local_Defs.unfold0_tac ctxt @{thms de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + REPEAT_DETERM o rtac ctxt conjI, + REPEAT_DETERM o assume_tac ctxt + ] + ] + ])) (RVrs @ Vrs), + Sb_cong = fn ctxt => EVERY1 [ + TRY o rtac ctxt @{thm comp_apply_eq}, + Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ + resolve_tac ctxt [#Map_cong (#axioms param), @{thm cong'[rotated]} OF [#Map_cong (#axioms param)]], + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt (#Sb_cong (leader axioms_of_bmv_monad inner)), + REPEAT_DETERM o resolve_tac ctxt ( + filter (null o fst o Logic.strip_horn o Thm.prop_of) prems + ), + REPEAT_DETERM o EVERY' [ + resolve_tac ctxt prems, + dtac ctxt @{thm UN_I}, + assume_tac ctxt, + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ] + ]) inners), + IF_UNSOLVED o EVERY' [ + rtac ctxt (#Sb_cong axioms), + K (Local_Defs.unfold0_tac ctxt (#Vrs_Map param)), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt (refl :: @{thms SSupp_Inj_bound IImsupp_Inj_bound} @ prems), + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ] + ]) ctxt + ] + } : (Proof.context -> tactic) bmv_monad_axioms) + [leader axioms_of_bmv_monad outer] + [the (leader params_of_bmv_monad outer)] + [leader facts_of_bmv_monad outer] + [leader ops_of_bmv_monad outer] + [the (leader Maps_of_bmv_monad outer)] + [new_Injs] [new_RVrs] [new_Vrs] (#extra_Vrs consts) + } : (Proof.context -> tactic) bmv_monad_model; + + val name = qualify (Binding.conglomerate (map_filter ( + try (Binding.name o short_type_name o fst o dest_Type) o leader ops_of_bmv_monad + ) (outer :: inners'))); + val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify (SOME name) model + (maps defs_of_bmv_monad (outer :: inners')) lthy + in (res, lthy) end; + +fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = + let + val rep_T = leader ops_of_bmv_monad bmv; + val ((T_name, info), lthy) = (case info_opt of + SOME info => (info, lthy) + | NONE => BNF_Util.typedef (name, map (dest_TFree o snd) tys, NoSyn) + (HOLogic.mk_UNIV rep_T) NONE (fn ctxt => rtac ctxt @{thm UNIV_witness} 1) lthy) + + val T = #abs_type (fst info); + val abs = Const (#Abs_name (fst info), rep_T --> #abs_type (fst info)); + val rep = Const (#Rep_name (fst info), #abs_type (fst info) --> rep_T); + + val frees = map_filter (fn (Free_Var, a) => SOME a | _ => NONE) tys; + val lives = map_filter (fn (Live_Var, a) => SOME a | _ => NONE) tys; + val deads = map_filter (fn (Dead_Var, a) => SOME a | _ => NONE) tys; + val lives' = map (the o AList.lookup (op=) (leader lives_of_bmv_monad bmv ~~ leader lives'_of_bmv_monad bmv)) lives; + + val (ifrees, rfrees) = partition ( + member (op=) (map (domain_type o fastype_of) (leader Injs_of_bmv_monad bmv)) + ) frees; + + val (((fs, rhos), gs), _) = lthy + |> mk_Frees "f" (map (fn a => a --> a) rfrees) + ||>> mk_Frees "\" (map ((fn T' => if body_type T' = rep_T then domain_type T' --> T else T') o fastype_of) (leader Injs_of_bmv_monad bmv)) + ||>> mk_Frees "g" (map2 (curry (op-->)) lives lives') + + val rep_fs = map (fn RVrs => the (List.find (fn f => + domain_type (fastype_of f) = HOLogic.dest_setT (range_type (fastype_of RVrs)) + ) fs)) (leader RVrs_of_bmv_monad bmv); + + val mk_def_t = mk_def_t false Binding.empty qualify + val mk_defs_t = mk_defs_t false Binding.empty qualify + + fun mk_name s = s ^ "_" ^ short_type_name T_name + val (_, lthy) = Local_Theory.begin_nested lthy; + + val (((((Sb, RVrs), Injs), Vrs), extra_Vrs), lthy) = lthy + |> mk_def_t (mk_name "Sb") 0 (fold_rev (Term.absfree o dest_Free) (fs @ rhos) ( + HOLogic.mk_comp (HOLogic.mk_comp (abs, Term.list_comb (leader Sbs_of_bmv_monad bmv, + rep_fs @ map (fn rho => if body_type (fastype_of rho) = T then HOLogic.mk_comp (rep, rho) else rho) rhos + )), rep))) + ||>> mk_defs_t (mk_name "RVrs") 0 (map (fn free => case List.find (fn RVrs => HOLogic.dest_setT (range_type (fastype_of RVrs)) = free) (leader RVrs_of_bmv_monad bmv) of + SOME RVrs => HOLogic.mk_comp (RVrs, rep) + | NONE => Term.abs ("_", T) (mk_bot free) + ) rfrees) + ||>> mk_defs_t (mk_name "Inj") 0 (map_filter (fn Inj => + if body_type (fastype_of Inj) = rep_T then SOME (HOLogic.mk_comp (abs, Inj)) else NONE + ) (leader Injs_of_bmv_monad bmv)) + ||>> mk_defs_t (mk_name "Vrs") 0 (map (fn Vrs => HOLogic.mk_comp (Vrs, rep)) (leader Vrs_of_bmv_monad bmv)) + ||>> mk_defs_t (mk_name "extra_Vrs") 0 (map (fn Vrs => HOLogic.mk_comp (Vrs, rep)) (leader extra_Vrs_of_bmv_monad bmv)) + + val subst = Term.subst_atomic_types (leader lives_of_bmv_monad bmv ~~ leader lives'_of_bmv_monad bmv); + val ((Map_opt, Supps_opt), lthy) = case leader Maps_of_bmv_monad bmv of + NONE => ((NONE, NONE), lthy) + | SOME Map => + lthy + |> apfst SOME o mk_def_t (mk_name "Map") 0 (fold_rev (Term.absfree o dest_Free) gs ( + HOLogic.mk_comp (HOLogic.mk_comp (subst abs, Term.list_comb (Map, map (fn live => + the (List.find (fn g => domain_type (fastype_of g) = live) gs) + ) (leader lives_of_bmv_monad bmv))), rep) + )) + ||>> apfst SOME o mk_defs_t (mk_name "Supp") 0 (map (fn live => HOLogic.mk_comp ( + the (List.find (fn Supp => HOLogic.dest_setT (range_type (fastype_of Supp)) = live) (the (leader Supps_of_bmv_monad bmv))), + rep)) lives) + + val (lthy, old_lthy) = `Local_Theory.end_nested lthy; + val phi = Proof_Context.export_morphism old_lthy lthy; + + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (apply2 fastype_of ( + Morphism.term phi (fst (the_default Sb Map_opt)), (fst (the_default Sb Map_opt)) + )) Vartab.empty; + val morph = map_prod (Envir.subst_term (tyenv, Vartab.empty) o Morphism.term phi) (Morphism.thm phi); + + val Sb = morph Sb; + val RVrs = map morph RVrs; + val Injs = map morph Injs; + val Vrs = map morph Vrs; + val extra_Vrs = map morph extra_Vrs; + val Map_opt = Option.map morph Map_opt; + val Supps_opt = Option.map (map morph) Supps_opt; + + val Inj_defs = map snd Injs; + val Injs = fst (fold_map (fn Inj => fn Injs => if body_type (fastype_of Inj) = rep_T then + (fst (hd Injs), tl Injs) else (Inj, Injs) + ) (leader Injs_of_bmv_monad bmv) Injs); + + val defs = snd Sb :: map snd RVrs @ Inj_defs @ map snd Vrs @ map snd extra_Vrs @ the_default [] (Option.map (fn Map => snd Map :: map snd (the Supps_opt)) Map_opt); + + val consts = { + bd = bd_of_bmv_monad bmv, + Injs = [Injs], + Sbs = [fst Sb], + Vrs = [map fst Vrs], + RVrs = [map fst RVrs], + extra_Vrs = [map fst extra_Vrs], + params = [Option.map (fn Map => { Map = fst Map, Supps = map fst (the Supps_opt) }) Map_opt] + }: bmv_monad_consts; + + val axioms = leader axioms_of_bmv_monad bmv; + val params = leader params_of_bmv_monad bmv; + val copy = #type_definition (snd info); + + val model = { + ops = [T], + bmv_ops = map_filter (fn i => if i = leader_of_bmv_monad bmv then NONE else SOME (unsafe_slice_bmv_monad i bmv)) (0 upto length (ops_of_bmv_monad bmv) - 1), + bd_infinite_regular_card_order = fn ctxt => rtac ctxt (bd_infinite_regular_card_order_of_bmv_monad bmv) 1, + var_class = var_class_of_bmv_monad bmv, + frees = [frees], + lives = [lives], + lives' = [lives'], + deads = [deads], + consts = consts, + leader = 0, + params = [Option.map (fn Supps => { + axioms = { + Map_id = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ [snd (the Map_opt), #Map_id (#axioms (the params))])), + rtac ctxt @{thm type_copy_Abs_o_Rep}, + rtac ctxt copy + ], + Map_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt [snd (the Map_opt)]), + rtac ctxt @{thm type_copy_map_comp0[symmetric]}, + rtac ctxt copy, + rtac ctxt (#Map_comp (#axioms (the params)) RS sym) + ], + Supp_Map = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd (the Map_opt), #Abs_inverse (snd info) OF @{thms UNIV_I}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_apply}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt (subst rep))] @{thm comp_apply}, + infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (subst abs))] @{thm comp_apply} + ] @ map snd Supps)), + resolve_tac ctxt (#Supp_Map (#axioms (the params))) + ]) Supps, + Supp_bd = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([ + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_apply} + ] @ map snd Supps)), + resolve_tac ctxt (#Supp_bd (#axioms (the params))) + ]) Supps, + Map_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd (the Map_opt)] @ map snd Supps)), + rtac ctxt @{thm type_copy_map_cong0}, + rtac ctxt (#Map_cong (#axioms (the params))), + K (Local_Defs.unfold0_tac ctxt [infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_apply}]), + REPEAT_DETERM o Goal.assume_rule_tac ctxt + ] + }, + Map_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd (the Map_opt), snd Sb, @{thm SSupp_type_copy} OF [copy], @{thm IImsupp_type_copy} OF [copy]] @ defs)), + rtac ctxt @{thm type_copy_Map_Sb}, + rtac ctxt copy, + rtac ctxt copy, + K (Local_Defs.unfold_tac ctxt [ + @{thm type_copy_Rep_o_Abs_o} OF [copy], + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_assoc}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt (subst rep))] @{thm comp_assoc}, + infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (subst abs))] @{thm comp_assoc} + ]), + rtac ctxt (#Map_Sb (the params)) THEN_ALL_NEW assume_tac ctxt + ], + Supp_Sb = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([ + snd Sb, @{thm SSupp_type_copy} OF [copy], @{thm IImsupp_type_copy} OF [copy], + #Abs_inverse (snd info) OF @{thms UNIV_I}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_apply}, + infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt abs)] @{thm comp_apply} + ] @ defs)), + rtac ctxt trans, + resolve_tac ctxt (#Supp_Sb (the params)) THEN_ALL_NEW assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ]) Supps, + Vrs_Map = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms image_empty} @ [ + snd (the Map_opt), #Abs_inverse (snd info) OF @{thms UNIV_I}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_apply}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt (subst rep))] @{thm comp_apply}, + infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (subst abs))] @{thm comp_apply} + ] @ map snd Vrs @ map snd RVrs)), + resolve_tac ctxt (@{thms refl} @ #Vrs_Map (the params)) + ]) (RVrs @ Vrs), + Map_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd (the Map_opt), + @{thm type_copy_Rep_o_Abs_o} OF [copy], + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_assoc} + ] @ Inj_defs)), + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + resolve_tac ctxt (#Map_Injs (the params)) + ]) + ) Injs + }) Supps_opt], + tacs = [{ + Sb_Inj = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ + [snd Sb, #Sb_Inj axioms, @{thm type_copy_Rep_o_Abs_o} OF [copy]] + @ Inj_defs + )), + rtac ctxt @{thm type_copy_Abs_o_Rep}, + rtac ctxt copy + ], + Sb_comp_Injs = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd Sb, @{thm SSupp_type_copy} OF [copy], @{thm IImsupp_type_copy} OF [copy]] @ defs)), + rtac ctxt @{thm trans[OF comp_assoc]}, + K (Local_Defs.unfold0_tac ctxt [@{thm type_copy_Rep_o_Abs_o} OF [copy]]), + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + resolve_tac ctxt (#Sb_comp_Injs axioms), + REPEAT_DETERM o assume_tac ctxt, + rtac ctxt (@{thm type_copy_Abs_o_Rep_o} OF [copy]) + ]) + ) Injs, + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd Sb, @{thm SSupp_type_copy} OF [copy], @{thm IImsupp_type_copy} OF [copy]] @ defs)), + rtac ctxt trans, + rtac ctxt @{thm type_copy_map_comp0[symmetric]}, + rtac ctxt copy, + rtac ctxt (#Sb_comp axioms RS sym) THEN_ALL_NEW assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc} @ [@{thm type_copy_Rep_o_Abs_o} OF [copy]])), + rtac ctxt refl + ], + Vrs_bds = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ map snd Vrs @ map snd RVrs)), + resolve_tac ctxt (@{thms Cinfinite_gt_empty} @ #Vrs_bds axioms), + TRY o rtac ctxt (@{thm infinite_regular_card_order.Cinfinite} OF [bd_infinite_regular_card_order_of_bmv_monad bmv]) + ])) (RVrs @ Vrs), + Vrs_Injss = map (K (map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ defs @ [#Abs_inverse (snd info) OF @{thms UNIV_I}])), + resolve_tac ctxt (flat (#Vrs_Injss axioms)) + ]) + ) Injs)) (RVrs @ Vrs @ extra_Vrs), + Vrs_Sbs = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms image_empty} @ [ + snd Sb, @{thm SSupp_type_copy} OF [copy], @{thm IImsupp_type_copy} OF [copy], + #Abs_inverse (snd info) OF @{thms UNIV_I}, + infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt rep)] @{thm comp_apply}, + infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt abs)] @{thm comp_apply} + ] @ defs)), + TRY o EVERY' [ + rtac ctxt trans, + resolve_tac ctxt (#Vrs_Sbs axioms) THEN_ALL_NEW assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}) + ], + rtac ctxt refl + ])) (RVrs @ Vrs), + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([snd Sb, @{thm SSupp_type_copy} OF [copy], @{thm IImsupp_type_copy} OF [copy]] @ defs)), + rtac ctxt @{thm type_copy_map_cong0}, + rtac ctxt (#Sb_cong axioms), + REPEAT_DETERM o assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), + REPEAT_DETERM o FIRST' [ + Goal.assume_rule_tac ctxt, + rtac ctxt (mk_arg_cong lthy 1 rep) + ] + ] + }] + } : (Proof.context -> tactic) bmv_monad_model; + + val new_defs = map (Local_Defs.unfold lthy unfolds) defs; + val ((bmv, _), lthy) = bmv_monad_def BNF_Def.Hardly_Inline (K BNF_Def.Note_Some) qualify NONE model new_defs lthy; + + in ((bmv, new_defs, defs, (T_name, info)), lthy) end + +fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), extra_Vrs) lthy = + let + val b = fst (hd b_ops); + val (opss, bmv_ops) = split_list (map_index (fn (i, (b, s)) => + let + val T = Syntax.read_typ lthy s + val name = if Binding.is_empty b then fst (dest_Type T) else Local_Theory.full_name lthy b + in the_default ([T], NONE) (Option.map (fn bmv => + let + val T' = nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv); + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global T, T') + Vartab.empty; + val T = Term.typ_subst_atomic (map (fn (x, (s, y)) => + let val T = Logic.unvarifyT_global (TVar (x, s)); + in (T, resort_tfree_or_tvar (Type.sort_of_atyp y) T) end + ) (Vartab.dest tyenv)) T; + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (T', T) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism (map (fn (x, (s, y)) => (TVar (x, s), y)) (Vartab.dest tyenv)); + val bmv = morph_bmv_monad phi bmv; + in (ops_of_bmv_monad bmv, SOME bmv) end + ) (if i = 0 then NONE else pbmv_monad_of lthy name)) end + ) b_ops); + + val ops = @{map_filter 2} (fn NONE => SOME o hd | SOME _ => K NONE) bmv_ops opss; + val bmv_ops = map_filter I bmv_ops; + + val bd = Syntax.read_term lthy bd; + val (ops, Sbs) = split_list (map2 (fn Sb => fn T => + let + val body_T = Logic.varifyT_global (body_type (fastype_of Sb)); + val (tyenv, _) = Sign.typ_unify (Proof_Context.theory_of lthy) + (Logic.varifyT_global T, Logic.incr_tvar (maxidx_of_typ body_T + 1) body_T) + (Vartab.empty, maxidx_of_typ body_T + 1); + val T = Term.typ_subst_atomic (map_filter (fn (x, (s, y)) => + if snd x = 0 then + let val T = Logic.unvarifyT_global (TVar (x, s)); + in SOME (T, resort_tfree_or_tvar (Type.sort_of_atyp y) T) end + else NONE + ) (Vartab.dest tyenv)) T; + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) [ + (Logic.varifyT_global (body_type (fastype_of Sb)), T), + (Logic.varifyT_global (snd (split_last (binder_types (fastype_of Sb)))), T) + ] Vartab.empty; + in (T, Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global Sb)) end + ) (map (Syntax.read_term lthy) Sbs) ops); + + val f_Tss = map (fst o split_last o binder_types o fastype_of) Sbs; + + val frees' = map (distinct (op=) o map (fst o dest_funT)) f_Tss; + (* TODO: other var classes *) + val frees = map (map (resort_tfree_or_tvar @{sort var})) frees'; + + val bmv_ops = map (morph_bmv_monad (MRBNF_Util.subst_typ_morphism (hd frees' ~~ hd frees))) bmv_ops; + val ops = map (Term.typ_subst_atomic (hd frees' ~~ hd frees)) ops; + val Sbs = map (Term.subst_atomic_types (hd frees' ~~ hd frees)) Sbs; + val f_Tss = map (fst o split_last o binder_types o fastype_of) Sbs; + + val b = if Binding.is_empty b then fst (dest_Type (hd ops)) else Local_Theory.full_name lthy b + + val vars = distinct (op=) (rev (map TFree (fold Term.add_tfreesT ops []))); + + val names_lthy = lthy + |> fold Variable.declare_typ vars + + val (lives, lives', param_consts) = case param_opt of + NONE => (replicate (length ops) [], replicate (length ops) [], replicate (length ops) NONE) + | SOME (Maps, Suppss) => + let + val Maps = map (fn "_" => NONE | s => SOME (Syntax.read_term lthy s)) Maps; + val Suppss = map (fn [] => NONE | xs => SOME (map (Syntax.read_term lthy) xs)) Suppss; + val Maps = Maps @ replicate (length ops - length Maps) NONE; + + val lives = map2 (fn T => the_default [] o Option.map (fn Map => + let + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global (snd (split_last (binder_types (fastype_of Map)))), T) Vartab.empty; + val Map = Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global Map); + in map (fst o dest_funT) (fst (split_last (binder_types (fastype_of Map)))) end + )) ops Maps; + val (lives', _) = names_lthy + |> fold_map mk_TFrees (map length lives); + + val Maps = @{map 4} (fn T => fn lives => fn lives' => Option.map (fn Map => + let + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) [ + (Logic.varifyT_global (snd (split_last (binder_types (fastype_of Map)))), T), + (Logic.varifyT_global (body_type (fastype_of Map)), Term.typ_subst_atomic (lives ~~ lives') T) + ] Vartab.empty; + in Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global Map) end + )) ops lives lives' Maps; + + val Suppss = map2 (fn T => Option.map (map (fn Supp => + let val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global (domain_type (fastype_of Supp)), T) Vartab.empty; + in Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global Supp) end + ))) ops (Suppss @ replicate (length ops - length Suppss) NONE); + + in (lives, lives', + map2 (@{map_option 2} (fn Map => fn Supps => { Map = Map, Supps = Supps })) Maps Suppss + ) end; + + val bmv_ops = map (fn bmv => + let + val lives' = map (fn a => nth (hd lives') (find_index (curry (op=) a) (hd lives))) (hd (lives_of_bmv_monad bmv)); + val subst = hd (lives'_of_bmv_monad bmv) ~~ lives'; + in morph_bmv_monad (MRBNF_Util.subst_typ_morphism subst) bmv end + ) bmv_ops; + + val deadss = @{map 3} (fn frees => fn lives => fn T => + subtract (op=) (frees @ lives) (rev (map TFree (Term.add_tfreesT T []))) + ) frees lives ops; + + val subst = map (fn a => (resort_tfree_or_tvar @{sort type} a, a)) (hd deadss); + val ops = map (Term.typ_subst_atomic subst) ops; + val bmv_ops = map (morph_bmv_monad (MRBNF_Util.subst_typ_morphism subst)) bmv_ops; + + val Injs = map (map (fn s => + let + val t = Syntax.read_term lthy s; + val tyenvs = map_filter (fn T => try ( + Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global (body_type (fastype_of t)), T)) + Vartab.empty + ) (ops @ maps ops_of_bmv_monad bmv_ops); + val t = case tyenvs of + [] => raise TYPE ("An injection needs to return one of the operators of the BMV Monad, but " + ^ Syntax.string_of_term lthy t ^ " has type " ^ Syntax.string_of_typ lthy (fastype_of t) ^ ", operators are:", ops, []) + | tyenv::_ => Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global t); + in t end + )) (the_default (replicate (length ops) []) Injs); + + val _ = @{map 4} (fn Sb => fn T => fn Injs => fn f_Ts => map (fn f_T => case List.find (curry (op=) f_T o fastype_of) Injs of + NONE => raise TYPE ("\n\nExpected injection of type \n" ^ Syntax.string_of_typ lthy f_T ^ "\nfor operator \n" ^ Syntax.string_of_typ lthy T + ^ "\n\nSubstitution has type " ^ Syntax.string_of_typ lthy (fastype_of Sb) ^ "\nbut got injections:", map fastype_of Injs, []) + | _ => () + ) (filter_out ((op=) o dest_funT) f_Ts)) Sbs ops Injs f_Tss; + + val Vrs = map (map (Syntax.read_term lthy)) (the_default (replicate (length ops) []) Vrs); + val Vrs = map2 (fn T => map (fn Vr => + let val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global (domain_type (fastype_of Vr)), T) Vartab.empty; + in Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global Vr) end + )) ops Vrs; + + val RVrs = map (map (Syntax.read_term lthy)) (the_default (replicate (length ops) []) RVrs); + val RVrs = map2 (fn T => map (fn RVr => + let val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global (domain_type (fastype_of RVr)), T) Vartab.empty; + in Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global RVr) end + )) (take (length RVrs) ops) RVrs; + val RVrs = RVrs @ replicate (length Injs - length RVrs) []; + + val extra_Vrs = map2 (fn T => map_filter (fn extra_Vrs => if extra_Vrs = "_" then NONE else + let + val t = Syntax.read_term lthy extra_Vrs; + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (Logic.varifyT_global (domain_type (fastype_of t)), T) Vartab.empty; + val t = Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global t) + in SOME t end + )) (take (length extra_Vrs) ops) extra_Vrs @ replicate (length Injs - length extra_Vrs) []; + + val Injs = map (map (Term.subst_atomic_types subst)) Injs; + val Vrs = map (map (Term.subst_atomic_types subst)) Vrs; + val RVrs = map (map (Term.subst_atomic_types subst)) RVrs; + val Sbs = map (Term.subst_atomic_types subst) Sbs; + val extra_Vrs = map (map (Term.subst_atomic_types subst)) extra_Vrs; + + val param_consts = map (Option.map (fn { Map, Supps } => { + Map = Term.subst_atomic_types subst Map, + Supps = map (Term.subst_atomic_types subst) Supps + })) param_consts; + + val consts = { + bd = bd, + Injs = Injs, + Sbs = Sbs, + Vrs = Vrs, + RVrs = RVrs, + extra_Vrs = extra_Vrs, + params = param_consts + }: bmv_monad_consts; + val (consts, bmv_defs, lthy) = define_bmv_monad_consts (SOME (Binding.name b)) BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 + ops frees lives' consts lthy; + + val param_goals = @{map 6} (fn Sb => fn Injs => fn RVrs => fn Vrs => fn extra_Vrs => Option.map (fn { Map, Supps } => + mk_param_axiom Map Supps Sb Injs RVrs Vrs extra_Vrs bd (ops @ maps ops_of_bmv_monad bmv_ops) + (#RVrs consts @ maps RVrs_of_bmv_monad bmv_ops) + (#Vrs consts @ maps Vrs_of_bmv_monad bmv_ops) + (#extra_Vrs consts @ maps extra_Vrs_of_bmv_monad bmv_ops) + (map_filter I (#params consts @ maps (#params o consts_of_bmv_monad) bmv_ops)) lthy + )) (#Sbs consts) (#Injs consts) (#RVrs consts) (#Vrs consts) (#extra_Vrs consts) (#params consts); + + val goals = mk_bmv_monad_axioms ops consts bmv_ops lthy; + + fun after_qed thmss lthy = + let + val thms = map hd thmss; + val bd_irco = hd thms; + + val ((axioms, params), _) = apfst split_list (@{fold_map 3} (fn goal => fn param => fn param_consts => fn thms => + let + val (((((((Sb_Inj, Sb_comp_Injs), Sb_comp), Vrs_bds), Vrs_Injss), Vrs_Sbs), Sb_cong), thms) = thms + |> apfst hd o chop 1 + ||>> chop (length (#Sb_comp_Injs goal)) + ||>> apfst hd o chop 1 + ||>> chop (length (#Vrs_bds goal)) + ||>> fold_map (chop o length) (#Vrs_Injss goal) + ||>> chop (length (#Vrs_Sbs goal)) + ||>> apfst hd o chop 1; + val (param, thms) = case param of NONE => (NONE, thms) | SOME goals => + let val (((((((((Map_id, Map_comp), Supp_maps), Supp_bds), Map_cong), Map_Sb), Supp_Sb), Vrs_Map), Map_Injs), thms) = thms + |> apfst hd o chop 1 + ||>> apfst hd o chop 1 + ||>> chop (length (#Supps (the param_consts))) + ||>> chop (length (#Supps (the param_consts))) + ||>> apfst hd o chop 1 + ||>> apfst hd o chop 1 + ||>> chop (length (#Supps (the param_consts))) + ||>> chop (length (#Vrs_Map goals)) + ||>> chop (length (#Map_Injs goals)) + in (SOME ({ + axioms = { + Map_id = Map_id, + Map_comp = Map_comp, + Supp_Map = Supp_maps, + Supp_bd = Supp_bds, + Map_cong = Map_cong + }, + Map_Sb = Map_Sb, + Supp_Sb = Supp_Sb, + Vrs_Map = Vrs_Map, + Map_Injs = Map_Injs + } : thm bmv_monad_param), thms) end; + in ((({ + Sb_Inj = Sb_Inj, + Sb_comp_Injs = Sb_comp_Injs, + Sb_comp = Sb_comp, + Vrs_bds = Vrs_bds, + Vrs_Injss = Vrs_Injss, + Vrs_Sbs = Vrs_Sbs, + Sb_cong = Sb_cong + }: thm bmv_monad_axioms), param), thms) end + ) goals param_goals param_consts (tl thms)); + + val model = { + ops = ops, + var_class = @{class var}, (* TODO: change *) + leader = 0, + frees = frees, + lives = lives, + lives' = lives', + deads = deadss, + bmv_ops = bmv_ops, + consts = consts, + params = params, + bd_infinite_regular_card_order = bd_irco, + tacs = axioms + } : thm bmv_monad_model; + + val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I (SOME (Binding.name b)) model (bmv_defs @ maps unfolds_of_bmv_monad bmv_ops) [] lthy; + + val lthy = register_pbmv_monad b bmv lthy; + in lthy end; + in Proof.theorem NONE after_qed (map (single o rpair []) ( + [HOLogic.mk_Trueprop (mk_infinite_regular_card_order bd)] + @ flat (map2 (fn goal => fn param => #Sb_Inj goal :: #Sb_comp_Injs goal @ [#Sb_comp goal] + @ #Vrs_bds goal @ flat (#Vrs_Injss goal) @ #Vrs_Sbs goal + @ [#Sb_cong goal] @ the_default [] (Option.map (fn param => + [#Map_id (#axioms param), #Map_comp (#axioms param)] @ #Supp_Map (#axioms param) + @ #Supp_bd (#axioms param) @ [#Map_cong (#axioms param), #Map_Sb param] + @ #Supp_Sb param @ #Vrs_Map param @ #Map_Injs param + ) param) + ) goals param_goals) + )) lthy + |> Proof.unfolding ([[(bmv_defs @ maps unfolds_of_bmv_monad bmv_ops, [])]]) + |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) + end; + +fun print_pbmv_monads ctxt = + let + val and_list = Library.separate (Pretty.block [Pretty.brk 1, Pretty.keyword2 "and", Pretty.brk 1]) + fun map_filter_end [] _ = [] + | map_filter_end (SOME x::xs) ys = ys @ [SOME x] @ map_filter_end xs ys + | map_filter_end (NONE::xs) ys = map_filter_end xs (NONE::ys) + fun pretty_mrbnf (key, bmv as BMV {ops, frees, lives, deads, consts, leader, ...}) = + Pretty.big_list + (Pretty.string_of (Pretty.block ([Pretty.str key, Pretty.str ":", Pretty.brk 1] @ + and_list (map (Pretty.quote o Syntax.pretty_typ ctxt) ops)))) + ([Pretty.block [Pretty.str "frees:", Pretty.brk 1, Pretty.str (string_of_int (length (nth frees leader))), + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) (nth frees leader))]] @ + (if length lives > 0 then + [Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int (length (nth lives leader))), + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) (nth lives leader))]] + else []) @ + (if length deads > 0 then + [Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int (length (nth deads leader))), + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) (nth deads leader))]] + else []) @ + [ Pretty.block ([Pretty.str "Sb:", Pretty.brk 1] @ and_list (map (Pretty.quote o Syntax.pretty_term ctxt) (#Sbs consts))) + ] @ (case map_filter I (Maps_of_bmv_monad bmv) of [] => [] | _ => [ + Pretty.block ([Pretty.str "Map:", Pretty.brk 1] @ and_list (map (fn x => case x of + NONE => Pretty.str "_" | SOME y => Pretty.quote (Syntax.pretty_term ctxt y)) ( + map_filter_end (Maps_of_bmv_monad bmv) [] + ))) + ]) @ [Pretty.block [Pretty.str ("bd:"), Pretty.brk 1, + Pretty.quote (Syntax.pretty_term ctxt (#bd consts))]]); + in + Pretty.big_list "Registered parametrized bounded multi-variate monads:" + (map pretty_mrbnf (sort_by fst (Symtab.dest (Data.get (Context.Proof ctxt))))) + |> Pretty.writeln + end; + +val _ = + Outer_Syntax.command @{command_keyword print_pbmv_monads} + "print all parametrized bounded multi-variate monads" + (Scan.succeed (Toplevel.keep (print_pbmv_monads o Toplevel.context_of))); + +val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} + "register a parametrized bounded multi-variate monad" + ((Parse.and_list1 (parse_opt_binding_colon -- Parse.typ) -- + ((Parse.reserved "Sbs" -- @{keyword ":"}) |-- Parse.and_list1 Parse.term) -- + (Scan.option ((Parse.reserved "RVrs" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Injs" || Parse.reserved "bd" || Parse.reserved "Maps") Parse.term)))) -- + (Scan.option ((Parse.reserved "Injs" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") Parse.term)))) -- + (Scan.option ((Parse.reserved "Vrs" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "SSupps" || Parse.reserved "Maps" || Parse.reserved "bd") Parse.term)))) -- + Scan.option ( + ((Parse.reserved "Maps" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.underscore || Parse.term)) -- + ((Parse.reserved "Supps" -- @{keyword ":"}) |-- Parse.and_list1 ( + (Parse.underscore >> K []) || + Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term) + )) + ) -- + ((Parse.reserved "bd" -- @{keyword ":"}) |-- Parse.term)) -- + (Scan.optional ((Parse.reserved "extra_Vrs" -- @{keyword ":"}) |-- + Parse.and_list1 (Scan.repeat (Parse.underscore || Parse.term)) + ) []) + >> pbmv_monad_cmd) + +end diff --git a/Tools/bmv_monad_tacs.ML b/Tools/bmv_monad_tacs.ML new file mode 100644 index 00000000..7a6bb67c --- /dev/null +++ b/Tools/bmv_monad_tacs.ML @@ -0,0 +1,168 @@ +structure BMV_Monad_Tactics = struct + +open BNF_Util +open MRBNF_Util + +val names = map (fst o dest_Free); + +fun mk_SSupp_Sb_subsets T Injs SSupp_prems Sb hs rhos Sb_Injs lthy = + @{map_filter 2} (fn Inj => fn rho => if body_type (fastype_of Inj) <> T then NONE else + let + val (rho', _) = lthy + |> apfst hd o mk_Frees "\'" [fastype_of Inj]; + val goal = HOLogic.mk_Trueprop (mk_leq + (mk_SSupp Inj $ HOLogic.mk_comp ( + Term.list_comb (Sb, hs @ rhos), rho' + )) + (mk_Un (mk_SSupp Inj $ rho, mk_SSupp Inj $ rho')) + ); + in SOME (Goal.prove_sorry lthy (names (rho' :: hs @ rhos)) SSupp_prems goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm subsetI}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_def mem_Collect_eq Un_iff de_Morgan_conj[symmetric]}), + etac ctxt @{thm contrapos_nn}, + etac ctxt conjE, + rtac ctxt @{thm trans[OF comp_apply]}, + rotate_tac 1, + etac ctxt @{thm subst[OF sym]}, + rtac ctxt trans, + resolve_tac ctxt Sb_Injs, + REPEAT_DETERM o resolve_tac ctxt prems, + assume_tac ctxt + ])) end + ) Injs rhos; + +fun mk_SSupp_Sb_bounds T Injs Sb hs rhos SSupp_prems SSupp_Sb_subsets UNIV_cinfinite lthy = + map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + let + val (rho, _) = lthy + |> apfst hd o mk_Frees "\'" [fastype_of Inj]; + val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj))))); + val goal = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (mk_SSupp Inj $ HOLogic.mk_comp ( + Term.list_comb (Sb, hs @ rhos), rho + ))) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj)))) + ); + in SOME (Goal.prove_sorry lthy (names (rho :: hs @ rhos)) (SSupp_prem :: SSupp_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm card_of_subset_bound}, + resolve_tac ctxt SSupp_Sb_subsets, + REPEAT_DETERM o resolve_tac ctxt ([UNIV_cinfinite] @ + @{thms Un_Cinfinite_ordLess cmin_Cinfinite card_of_Card_order} @ prems @ @{thms conjI} + ) + ])) end + ) Injs + +fun mk_IImsupp_Sb_subsetss T ops Sb SSupp_prems RVrss Vrss Vrs Injs hs rhos SSupp_Sb_subsets Vrs_Sbs Vrs_Injs' lthy = + map_filter (fn Inj => + if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vrs => + let + val (rho', _) = lthy + |> apfst hd o mk_Frees "\'" [fastype_of Inj]; + + val (Vrs', IImsupps) = split_list (flat (map2 (fn Inj => fn rho => + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) ops; + val Vrss = nth RVrss idx @ nth Vrss idx; + in map_filter (fn Vrs' => if body_type (fastype_of Vrs') <> body_type (fastype_of Vrs) + then NONE else SOME (Vrs', mk_IImsupp Inj Vrs' $ rho) + ) Vrss end + ) (Injs @ [Inj]) (rhos @ [rho']))); + val Vrs' = distinct (op=) (Vrs :: Vrs'); + + val goal = HOLogic.mk_Trueprop (mk_leq + (mk_IImsupp Inj Vrs $ HOLogic.mk_comp (Term.list_comb (Sb, hs @ rhos), rho')) + (foldl1 mk_Un ( + map mk_imsupp (filter (fn h => + domain_type (fastype_of h) = HOLogic.dest_setT (body_type (fastype_of Vrs)) + ) hs) @ IImsupps + )) + ) in Goal.prove_sorry lthy (names (hs @ rhos @ [rho'])) SSupp_prems goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm subset_trans}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), + rtac ctxt @{thm UN_mono[OF _ subset_refl]}, + resolve_tac ctxt SSupp_Sb_subsets, + REPEAT_DETERM o resolve_tac ctxt prems, + K (Local_Defs.unfold0_tac ctxt [infer_instantiate' ctxt [ + SOME (Thm.cterm_of ctxt (Term.list_comb (Sb, hs @ rhos))) + ] @{thm comp_apply}]), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] Vrs_Sbs, + REPEAT_DETERM o resolve_tac ctxt prems + ], + K (Local_Defs.unfold0_tac ctxt @{thms UN_Un Un_Union_image Un_assoc[symmetric] image_UN[symmetric]}), + K (Local_Defs.unfold0_tac ctxt @{thms image_Un}), + rtac ctxt @{thm subsetI}, + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o SELECT_GOAL (FIRST1 [ + EVERY' [ + dresolve_tac ctxt (map_filter (fn Vrs => try (infer_instantiate' ctxt [ + NONE, SOME (Thm.cterm_of ctxt Vrs), NONE, SOME (Thm.cterm_of ctxt rho') + ]) @{thm IImsupp_chain1[THEN set_mp, rotated -1]}) Vrs'), + resolve_tac ctxt Vrs_Injs', + resolve_tac ctxt @{thms disjI1[OF refl] disjI2[OF refl]}, + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o (eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' rtac ctxt @{thm UnI1}) + ], + EVERY' [ + dtac ctxt @{thm IImsupp_chain4[THEN set_mp, rotated -1]}, + resolve_tac ctxt Vrs_Injs', + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o (eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' rtac ctxt @{thm UnI1}) + ], + EVERY' [ + dresolve_tac ctxt (map (fn Vrs => infer_instantiate' ctxt [ + NONE, SOME (Thm.cterm_of ctxt Vrs), NONE, NONE, SOME (Thm.cterm_of ctxt rho') + ] @{thm IImsupp_chain2[THEN set_mp, rotated -1]}) Vrs'), + K (prefer_tac 3), + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o (eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' rtac ctxt @{thm UnI1}), + resolve_tac ctxt Vrs_Injs', + resolve_tac ctxt Vrs_Injs' + ], + EVERY' [ + dresolve_tac ctxt (map (fn Vrs => infer_instantiate' ctxt [ + NONE, SOME (Thm.cterm_of ctxt Vrs), NONE, NONE, SOME (Thm.cterm_of ctxt rho') + ] @{thm IImsupp_chain3[THEN set_mp, rotated -1]}) Vrs'), + K (prefer_tac 2), + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o (eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' rtac ctxt @{thm UnI1}), + resolve_tac ctxt Vrs_Injs' + ] + ]) + ]) end + ) Vrs)) Injs; + +fun mk_IImsupp_Sb_boundss var_class T Sb Injs Vrs hs rhos SSupp_prems IImsupp_Sb_subsetss Vrs_bds lthy = + map_filter (fn Inj => + if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vr => + let + val (rho', _) = lthy + |> apfst hd o mk_Frees "\'" [fastype_of Inj]; + + val card = mk_card_of (HOLogic.mk_UNIV (HOLogic.dest_setT (body_type (fastype_of Vr)))); + + val SSupp_prems' = map (fn A => HOLogic.mk_Trueprop (mk_ordLess A card)) ( + if domain_type (fastype_of Inj) = HOLogic.dest_setT (body_type (fastype_of Vr)) then + [mk_card_of (mk_SSupp Inj $ rho')] + else + map_filter (fn Vrs' => if body_type (fastype_of Vrs') <> body_type (fastype_of Vr) + then NONE else SOME (mk_card_of (mk_IImsupp Inj Vrs' $ rho')) + ) Vrs + ); + val goal = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (mk_IImsupp Inj Vr $ HOLogic.mk_comp (Term.list_comb (Sb, hs @ rhos), rho'))) + card + ); + in Goal.prove_sorry lthy (names (hs @ rhos @ [rho'])) (SSupp_prems' @ SSupp_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm card_of_subset_bound}, + resolve_tac ctxt (flat IImsupp_Sb_subsetss), + REPEAT_DETERM o FIRST' [ + resolve_tac ctxt (prems @ map (fn thm => thm RS @{thm ordLess_ordLeq_trans}) Vrs_bds + @ [Var_Classes.get_class_assumption var_class "large'" lthy] @ + @{thms infinite_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV} + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ] + ]) end + ) Vrs)) Injs + +end diff --git a/Tools/mrbnf_comp.ML b/Tools/mrbnf_comp.ML index 6d146180..95513bb8 100644 --- a/Tools/mrbnf_comp.ML +++ b/Tools/mrbnf_comp.ML @@ -27,6 +27,8 @@ sig (string * sort) list -> ((string * sort) * MRBNF_Def.var_type) list -> typ -> (comp_cache * unfold_set) * local_theory -> (MRBNF_Def.mrbnf * (typ list * typ list)) * ((comp_cache * unfold_set) * local_theory) + val demote_mrbnf: (binding -> binding) -> MRBNF_Def.var_type list -> MRBNF_Def.mrbnf + -> (comp_cache * unfold_set) * local_theory -> MRBNF_Def.mrbnf * ((comp_cache * unfold_set) * local_theory) val clean_compose_mrbnf: MRBNF_Def.inline_policy -> (binding -> binding) -> binding -> MRBNF_Def.mrbnf -> MRBNF_Def.mrbnf list -> unfold_set * local_theory -> MRBNF_Def.mrbnf * (unfold_set * local_theory) val permute_mrbnf: (binding -> binding) -> int list -> int list -> MRBNF_Def.mrbnf -> @@ -56,7 +58,8 @@ sig val mk_abs: typ -> term -> term val mk_rep: typ -> term -> term val seal_mrbnf: (binding -> binding) -> unfold_set -> binding -> bool -> typ list -> typ list -> - MRBNF_Def.mrbnf -> local_theory -> (MRBNF_Def.mrbnf * (typ list * absT_info)) * local_theory + MRBNF_Def.mrbnf -> (string * Typedef.info) option -> local_theory + -> (MRBNF_Def.mrbnf * (string * Typedef.info) * (typ list * absT_info)) * local_theory end; structure MRBNF_Comp : MRBNF_COMP = @@ -212,14 +215,17 @@ fun clean_compose_mrbnf const_policy qualify binding outer inners (unfold_set, l in Binding.concealed (qualify (Binding.name name)) end; val (class, lthy) = apfst single (Var_Classes.mk_comp_class (mk_name "" sort) bd' (map bd_Cinfinite_of_mrbnf (outer :: inners)) sort lthy); - val ((((((oDs, iDss), As), As'), Fs), Bs), names_lthy) = lthy - |> mk_TFrees' (map Type.sort_of_atyp (deads_of_mrbnf outer)) - ||>> fold_map mk_TFrees' (map (map Type.sort_of_atyp o deads_of_mrbnf) inners) + val ((((((oDs', iDss'), As), As'), Fs), Bs), names_lthy) = lthy + |> mk_TFrees' (map_filter (try Type.sort_of_atyp) (deads_of_mrbnf outer)) + ||>> fold_map mk_TFrees' (map (map_filter (try Type.sort_of_atyp) o deads_of_mrbnf) inners) ||>> mk_TFrees num_ilives ||>> mk_TFrees num_ilives ||>> mk_TFrees' (replicate (free_of_mrbnf outer) class) ||>> mk_TFrees' (replicate (bound_of_mrbnf outer) class); + val oDs = fst (fold_map (fn x as Type _ => (fn xs => (x, xs)) | _ => fn xs => (hd xs, tl xs)) (deads_of_mrbnf outer) oDs'); + val iDss = map2 (fn inner => fst o fold_map (fn x as Type _ => (fn xs => (x, xs)) | _ => fn xs => (hd xs, tl xs)) (deads_of_mrbnf inner)) inners iDss'; + val iTs = map2 (fn deads => mk_T_of_mrbnf deads As Bs Fs) iDss inners; val iTs' = map2 (fn deads => mk_T_of_mrbnf deads As' Bs Fs) iDss inners; @@ -505,13 +511,15 @@ fun raw_permute_mrbnf qualify src dest mrbnf (accum as (unfold_set, lthy)) = fun permute_live xs = permute_like_unique (op =) src_live dest_live xs; fun unpermute_live xs = permute_like_unique (op =) dest_live src_live xs; - val (((((Ds, As), As'), Fs), Bs), _) = lthy - |> mk_TFrees' (map Type.sort_of_atyp deads) + val (((((Ds', As), As'), Fs), Bs), _) = lthy + |> mk_TFrees' (map_filter (try Type.sort_of_atyp) deads) ||>> mk_TFrees live ||>> mk_TFrees live ||>> mk_TFrees' (map Type.sort_of_atyp frees) ||>> mk_TFrees' (map Type.sort_of_atyp bounds); + val Ds = fst (fold_map (fn x as Type _ => (fn xs => (x, xs)) | _ => fn xs => (hd xs, tl xs)) deads Ds'); + val T = mk_T_of_mrbnf Ds As Bs Fs mrbnf; val count = live + bound + free; @@ -907,13 +915,15 @@ fun raw_lift_mrbnf qualify (n1, n2, n3) mrbnf (accum as (unfold_set, lthy)) = (* TODO: check 0 < n, m < 0, l < 0 *) - val (((((Ds, (newAs, As)), (newAs', As')), (newFs, Fs)), (newBs, Bs)), _) = lthy - |> mk_TFrees' (map Type.sort_of_atyp deads) + val (((((Ds', (newAs, As)), (newAs', As')), (newFs, Fs)), (newBs, Bs)), _) = lthy + |> mk_TFrees' (map_filter (try Type.sort_of_atyp) deads) ||>> apfst (chop n1) o mk_TFrees (n1 + live) ||>> apfst (chop n1) o mk_TFrees (n1 + live) ||>> apfst (chop n2) o mk_TFrees' (replicate n2 class @ map Type.sort_of_atyp frees) ||>> apfst (chop n3) o mk_TFrees' (replicate n3 class @ map Type.sort_of_atyp bounds); + val Ds = fst (fold_map (fn x as Type _ => (fn xs => (x, xs)) | _ => fn xs => (hd xs, tl xs)) deads Ds'); + val newVars = newAs @ newFs @ newBs val newVars' = newAs' @ newFs @ newBs @@ -976,9 +986,6 @@ fun raw_lift_mrbnf qualify (n1, n2, n3) mrbnf (accum as (unfold_set, lthy)) = fun le_rel_OO_tac ctxt = rtac ctxt (le_rel_OO_of_mrbnf mrbnf) 1; - fun mr_mk_simple_rel_OO_Grp_tac ctxt rel_OO_Grp in_alt_thm = - HEADGOAL (rtac ctxt (trans OF [rel_OO_Grp, in_alt_thm RS @{thm OO_Grp_cong} RS sym])); - fun rel_OO_Grp_tac ctxt = unfold_thms_tac ctxt (the_list in_alt_thm_opt) THEN rtac ctxt (rel_OO_Grp_of_mrbnf mrbnf) 1 THEN TRYALL (assume_tac ctxt); @@ -1035,10 +1042,11 @@ fun normalize_mrbnfs qualify (oAs: typ option list) (Ass: (string * sort) list l ) | NONE => NONE ) (oAs ~~ var_types_of_mrbnf outer); + val Ds' = map TFree (fold_rev Term.add_tfreesT Ds []); val var_map = fold (fold (fn (A, var_type) => Typtab.map_default (A, var_type) (fn var_type' => case var_type_ord (var_type, var_type') of LESS => var_type | _ => var_type' ))) (oAs' :: map (apfst TFree) Xs :: map2 (fn As => fn mrbnf => map TFree As ~~ var_types_of_mrbnf mrbnf) Ass mrbnfs) - (Typtab.make (Ds ~~ replicate (length Ds) MRBNF_Def.Dead_Var)) + (Typtab.make (Ds' ~~ replicate (length Ds') MRBNF_Def.Dead_Var)) val odemote_target_types = map (fn x => case x of SOME y => the (Typtab.lookup var_map y) @@ -1181,7 +1189,7 @@ fun mk_abs_or_rep _ absU (Const (@{const_name BNF_Composition.id_bnf}, _)) = in Term.subst_atomic_types (Ts ~~ Us) abs end; val mk_abs = mk_abs_or_rep range_type; val mk_rep = mk_abs_or_rep domain_type; -fun maybe_typedef force_out_of_line (b, As, mx) set opt_morphs tac lthy = +fun maybe_typedef info_opt force_out_of_line (b, As, mx) set opt_morphs tac lthy = let val threshold = Config.get lthy typedef_threshold; val repT = HOLogic.dest_setT (fastype_of set); @@ -1189,21 +1197,23 @@ fun maybe_typedef force_out_of_line (b, As, mx) set opt_morphs tac lthy = (threshold >= 0 andalso Term.size_of_typ repT >= threshold); in if out_of_line then - typedef (b, As, mx) set opt_morphs tac lthy - |>> (fn (T_name, ({Rep_name, Abs_name, ...}, + (case info_opt of + SOME info => (info, lthy) + | NONE => typedef (b, As, mx) set opt_morphs tac lthy) + |>> (fn info as (T_name, ({Rep_name, Abs_name, ...}, {type_definition, Abs_inverse, Abs_inject, Abs_cases, ...}) : Typedef.info) => - (Type (T_name, map TFree As), - (Rep_name, Abs_name, type_definition, Abs_inverse, Abs_inject, Abs_cases))) + (SOME info, (Type (T_name, map TFree As), + (Rep_name, Abs_name, type_definition, Abs_inverse, Abs_inject, Abs_cases)))) else - ((repT, + ((NONE, (repT, (@{const_name BNF_Composition.id_bnf}, @{const_name BNF_Composition.id_bnf}, @{thm BNF_Composition.type_definition_id_bnf_UNIV}, @{thm type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV]}, @{thm type_definition.Abs_inject[OF BNF_Composition.type_definition_id_bnf_UNIV]}, - @{thm type_definition.Abs_cases[OF BNF_Composition.type_definition_id_bnf_UNIV]})), lthy) + @{thm type_definition.Abs_cases[OF BNF_Composition.type_definition_id_bnf_UNIV]}))), lthy) end; -fun seal_mrbnf qualify (unfold_set : unfold_set) b force_out_of_line Ds all_Ds mrbnf lthy = +fun seal_mrbnf qualify (unfold_set : unfold_set) b force_out_of_line Ds all_Ds mrbnf info_opt lthy = let val live = live_of_mrbnf mrbnf; val frees = frees_of_mrbnf mrbnf; @@ -1211,11 +1221,14 @@ fun seal_mrbnf qualify (unfold_set : unfold_set) b force_out_of_line Ds all_Ds m val nwits = nwits_of_mrbnf mrbnf; val nondead = live + length bounds + length frees; val var_types = var_types_of_mrbnf mrbnf; - val ((As, As'), lthy1) = apfst (`(map TFree)) - (Variable.invent_types (replicate live @{sort type}) (fold Variable.declare_typ all_Ds lthy)); - val (Xs, lthy2) = apfst (map TFree) (Variable.invent_types (replicate live @{sort type}) lthy1); - val (Bs, lthy3) = apfst (map TFree) (Variable.invent_types (map (snd o Term.dest_TVar) bounds) lthy2); - val (Fs, lthy4) = apfst (map TFree) (Variable.invent_types (map (snd o Term.dest_TVar) frees) lthy3); + + val ((((As, Xs), Bs), Fs), _) = lthy + |> fold Variable.declare_typ all_Ds + |> mk_TFrees live + ||>> mk_TFrees live + ||>> mk_TFrees' (map Type.sort_of_atyp bounds) + ||>> mk_TFrees' (map Type.sort_of_atyp frees) + val ((((fs, fs'), (Rs, Rs')), (Ps, Ps')), _(*names_lthy*)) = lthy |> mk_Frees' "f" (map2 (curry op -->) (interlace As Bs Fs var_types) (interlace Xs Bs Fs var_types)) ||>> mk_Frees' "R" (map2 mk_pred2T As Xs) @@ -1223,12 +1236,18 @@ fun seal_mrbnf qualify (unfold_set : unfold_set) b force_out_of_line Ds all_Ds m val repTA = mk_T_of_mrbnf Ds As Bs Fs mrbnf; val T_bind = qualify b; val repTA_tfrees = Term.add_tfreesT repTA []; - val all_TA_params_in_order = fold_rev Term.add_tfreesT all_Ds (interlace As' (map dest_TFree Bs) (map dest_TFree Fs) var_types); + val all_TA_params_in_order = case info_opt of + NONE => fold_rev Term.add_tfreesT all_Ds (interlace (map dest_TFree As) (map dest_TFree Bs) (map dest_TFree Fs) var_types) + | SOME (_, ({ rep_type, abs_type, ...} ,_)) => + let + val subst = (op~~) (apply2 (fn T => map TFree (Term.add_tfreesT T [])) (rep_type, repTA)) + in map dest_TFree (snd (dest_Type (Term.typ_subst_atomic subst abs_type))) end + val TA_params = (if force_out_of_line then all_TA_params_in_order else inter (op =) repTA_tfrees all_TA_params_in_order); - val ((TA, (Rep_name, Abs_name, type_definition, Abs_inverse, Abs_inject, _)), lthy) = - maybe_typedef force_out_of_line (T_bind, TA_params, NoSyn) (HOLogic.mk_UNIV repTA) NONE + val ((info_opt, (TA, (Rep_name, Abs_name, type_definition, Abs_inverse, Abs_inject, _))), lthy) = + maybe_typedef info_opt force_out_of_line (T_bind, TA_params, NoSyn) (HOLogic.mk_UNIV repTA) NONE (fn ctxt => EVERY' [rtac ctxt exI, rtac ctxt @{thm UNIV_I}] 1) lthy; val repTB = mk_T_of_mrbnf Ds Xs Bs Fs mrbnf; val TB = Term.typ_subst_atomic (As ~~ Xs) TA; @@ -1254,8 +1273,8 @@ fun seal_mrbnf qualify (unfold_set : unfold_set) b force_out_of_line Ds all_Ds m val bdT_bind = qualify (Binding.suffix_name ("_" ^ bdTN) b); val params = Term.add_tfreesT bd_repT []; val all_deads = map TFree (fold_rev Term.add_tfreesT all_Ds []); - val ((bdT, (_, Abs_bd_name, type_definition_bdT, _, Abs_bdT_inject, Abs_bdT_cases)), lthy) = - maybe_typedef false (bdT_bind, params, NoSyn) (HOLogic.mk_UNIV bd_repT) NONE + val ((_, (bdT, (_, Abs_bd_name, type_definition_bdT, _, Abs_bdT_inject, Abs_bdT_cases))), lthy) = + maybe_typedef NONE false (bdT_bind, params, NoSyn) (HOLogic.mk_UNIV bd_repT) NONE (fn ctxt => EVERY' [rtac ctxt exI, rtac ctxt @{thm UNIV_I}] 1) lthy; val (mrbnf_bd', bd_ordIso, bd_infinite_regular_card_order) = if bdT = bd_repT then (mrbnf_bd, bd_Card_order_of_mrbnf mrbnf RS @{thm ordIso_refl}, @@ -1414,7 +1433,7 @@ fun seal_mrbnf qualify (unfold_set : unfold_set) b force_out_of_line Ds all_Ds m |> Local_Theory.notes notes ||> (if repTA = TA then I else register_mrbnf_raw (fst (dest_Type TA)) mrbnf'') in - ((morph_mrbnf (substitute_noted_thm noted) mrbnf'', (all_deads, absT_info)), lthy'') + ((morph_mrbnf (substitute_noted_thm noted) mrbnf'', the info_opt, (all_Ds, absT_info)), lthy'') end; exception BAD_DEAD of typ * typ; diff --git a/Tools/mrbnf_comp_tactics.ML b/Tools/mrbnf_comp_tactics.ML index 123d50ba..324815b1 100644 --- a/Tools/mrbnf_comp_tactics.ML +++ b/Tools/mrbnf_comp_tactics.ML @@ -404,7 +404,7 @@ fun mr_mk_comp_wit_tac ctxt set'_eq_sets outer inners = EVERY (map (etac ctxt @{thm UnE}) (1 upto num_olive - 1)) THEN EVERY (replicate num_olive (HEADGOAL (EVERY' [ etac ctxt @{thm UN_E}, - dresolve_tac ctxt (G_wit_thms @ map (Local_Defs.unfold0 ctxt set_maps) G_wit_thms), + TRY o dresolve_tac ctxt (G_wit_thms @ map (Local_Defs.unfold0 ctxt set_maps) G_wit_thms), FIRST' [ K (unfold_thms_tac ctxt @{thms False_implies_equals}) THEN' rtac ctxt @{thm TrueI}, etac ctxt @{thm emptyE}, diff --git a/Tools/mrbnf_def.ML b/Tools/mrbnf_def.ML index bffa5605..d7a6ae4b 100644 --- a/Tools/mrbnf_def.ML +++ b/Tools/mrbnf_def.ML @@ -40,6 +40,7 @@ sig val var_type_ord: var_type ord val interlace: 'a list -> 'a list -> 'a list -> var_type list -> 'a list + val deinterlace: 'a list -> var_type list -> 'a list * 'a list * 'a list val name_of_mrbnf: mrbnf -> binding val T_of_mrbnf: mrbnf -> typ @@ -789,6 +790,11 @@ fun interlace _ _ _ [] = [] | interlace als (b::bs) fs (Bound_Var::ts) = b :: interlace als bs fs ts | interlace als bs (f::fs) (Free_Var::ts) = f :: interlace als bs fs ts +fun deinterlace [] _ = ([], [], []) + | deinterlace (x :: xs) (Live_Var::ts) = let val (a, b, c) = deinterlace xs ts in (x::a, b, c) end + | deinterlace (x :: xs) (Bound_Var::ts) = let val (a, b, c) = deinterlace xs ts in (a, x::b, c) end + | deinterlace (x :: xs) (Free_Var::ts) = let val (a, b, c) = deinterlace xs ts in (a, b, x::c) end + (*terms*) val map_of_mrbnf = #map o rep_mrbnf; val sets_of_mrbnf = #sets o rep_mrbnf; @@ -1601,14 +1607,13 @@ fun define_mrbnf_consts const_policy fact_policy internal Ds_opt class_opt map_b in bs ~~ set_rhss end; val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs); - val ((((mrbnf_map_term, raw_map_def), + val (((mrbnf_map_term, raw_map_def), (mrbnf_set_terms, raw_set_defs)), - _ (* (mrbnf_bd_term, raw_bd_def) *)), (lthy, lthy_old)) = + (lthy, lthy_old)) = no_defs_lthy |> Local_Theory.begin_nested |> snd |> maybe_define true map_bind_def ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs - ||>> (fn lthy => ((bd_rhs, Drule.reflexive_thm), lthy)) (* maybe_define true bd_bind_def*) ||> `Local_Theory.end_nested; val phi = Proof_Context.export_morphism lthy_old lthy; @@ -1704,7 +1709,10 @@ fun define_mrbnf_consts const_policy fact_policy internal Ds_opt class_opt map_b |-> mk_TFree_betas var_types I ||>> mk_TFrees (length deads); - val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds; + val Ds = map2 (fn d => fn D => case try (resort_tfree_or_tvar o Type.sort_of_atyp) d of + SOME f => f D + | NONE => D + ) deads unsorted_Ds; val (lAs, lBs) = apply2 filter_lives (As, Bs); val mrbnf_lsets = filter_lives mrbnf_sets; @@ -1884,7 +1892,10 @@ fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term ||> the_single ||> `(replicate non_dead); - val Ds = map2 (resort_tfree_or_tvar o Type.sort_of_atyp) deads unsorted_Ds; + val Ds = map2 (fn d => fn D => case try (resort_tfree_or_tvar o Type.sort_of_atyp) d of + SOME f => f D + | NONE => D + ) deads unsorted_Ds; val Ts' = map_VT I (K T) As'; val (lAs', lBs', lCs, lEs, lB1Ts, lB2Ts) = @{apply 6} filter_lives (As', Bs', Cs, Es, B1Ts, B2Ts); diff --git a/Tools/mrbnf_fp.ML b/Tools/mrbnf_fp.ML index efda4178..bdcc1e7e 100644 --- a/Tools/mrbnf_fp.ML +++ b/Tools/mrbnf_fp.ML @@ -3647,7 +3647,8 @@ fun construct_binder_fp fp_kind models binding_relation lthy = rec_vars = rec_vars, bfree_vars = map (fn bfree => find_index (curry (op=) bfree) frees) bfrees, raw_fps = raw_results, - quotient_fps = quotient_results, + quotient_fps = quotient_results, + is_free_inducts = map #induct is_freess, fp_thms = case least_fp_thms of SOME x => SOME (Inl x) | NONE => Option.map Inr greatest_fp_thms, diff --git a/Tools/mrbnf_fp_def_sugar.ML b/Tools/mrbnf_fp_def_sugar.ML index 5f0e1b52..f3bd3f11 100644 --- a/Tools/mrbnf_fp_def_sugar.ML +++ b/Tools/mrbnf_fp_def_sugar.ML @@ -90,6 +90,7 @@ sig bfree_vars: int list, raw_fps: raw_result fp_result_T list, quotient_fps: quotient_result fp_result_T list, + is_free_inducts: thm list, fp_thms: (least_fp_thms, greatest_fp_thms) MRBNF_Util.either option, pre_mrbnfs: MRBNF_Def.mrbnf list }; @@ -284,14 +285,16 @@ type fp_result = { bfree_vars: int list, raw_fps: raw_result fp_result_T list, quotient_fps: quotient_result fp_result_T list, + is_free_inducts: thm list, fp_thms: (least_fp_thms, greatest_fp_thms) MRBNF_Util.either option, pre_mrbnfs: MRBNF_Def.mrbnf list }; -fun morph_fp_result phi ({ fp, binding_relation, rec_vars, bfree_vars, raw_fps, quotient_fps, fp_thms, pre_mrbnfs }) = { +fun morph_fp_result phi ({ fp, binding_relation, rec_vars, bfree_vars, raw_fps, quotient_fps, fp_thms, pre_mrbnfs, is_free_inducts }) = { fp = fp, binding_relation = binding_relation, rec_vars = rec_vars, bfree_vars = bfree_vars, raw_fps = map (morph_fp_result_T morph_raw_result phi) raw_fps, quotient_fps = map (morph_fp_result_T morph_quotient_result phi) quotient_fps, + is_free_inducts = map (Morphism.thm phi) is_free_inducts, fp_thms = Option.map (MRBNF_Util.map_sum (morph_least_fp_thms phi) (morph_greatest_fp_thms phi)) fp_thms, pre_mrbnfs = map (MRBNF_Def.morph_mrbnf phi) pre_mrbnfs } : fp_result; diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 89f401b2..50c8d996 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -13,36 +13,16 @@ type spec = { FVars_bs: binding option list }; -type binder_sugar = { - map_simps: thm list, - set_simpss: thm list list, - permute_simps: thm list, - map_permute: thm option, - subst_simps: thm list option, - bsetss: term option list list, - bset_bounds: thm list, - mrbnf: MRBNF_Def.mrbnf, - strong_induct: thm option, - distinct: thm list, - inject: thm list, - ctors: (term * thm) list -}; - -val morph_binder_sugar: morphism -> binder_sugar -> binder_sugar; - type mr_bnf = (MRBNF_Def.mrbnf, (BNF_Def.bnf, MRBNF_FP_Def_Sugar.quotient_result MRBNF_FP_Def_Sugar.fp_result_T) MRBNF_Util.either) MRBNF_Util.either val mr_bnf_of: local_theory -> bool -> string -> mr_bnf option; val morph_mr_bnf: morphism -> mr_bnf -> mr_bnf; val build_permute_for: Proof.context -> term list -> typ list -> typ -> (string * mr_bnf) list * term; -val binder_sugar_of: local_theory -> string -> binder_sugar option -val register_binder_sugar: string -> binder_sugar -> local_theory -> local_theory - val create_binder_type : MRBNF_Util.fp_kind -> spec -> local_theory - -> (MRBNF_FP_Def_Sugar.fp_result * typ * MRBNF_Def.mrbnf * MRBNF_Comp.absT_info) * local_theory -val create_binder_datatype : bool -> spec -> local_theory -> binder_sugar * local_theory + -> (MRBNF_FP_Def_Sugar.fp_result * typ * MRSBNF_Def.mrsbnf * MRBNF_Comp.absT_info) * local_theory +val create_binder_datatype : bool -> spec -> local_theory -> Binder_Sugar.binder_sugar * local_theory end structure MRBNF_Sugar : MRBNF_SUGAR = @@ -67,53 +47,6 @@ type spec = { FVars_bs: binding option list }; -type binder_sugar = { - map_simps: thm list, - set_simpss: thm list list, - permute_simps: thm list, - map_permute: thm option, - subst_simps: thm list option, - bsetss: term option list list, - bset_bounds: thm list, - mrbnf: MRBNF_Def.mrbnf, - strong_induct: thm option, - distinct: thm list, - inject: thm list, - ctors: (term * thm) list -}; - -fun morph_binder_sugar phi { map_simps, permute_simps, map_permute, set_simpss, subst_simps, mrbnf, - strong_induct, distinct, inject, ctors, bsetss, bset_bounds } = { - map_simps = map (Morphism.thm phi) map_simps, - permute_simps = map (Morphism.thm phi) permute_simps, - map_permute = Option.map (Morphism.thm phi) map_permute, - set_simpss = map (map (Morphism.thm phi)) set_simpss, - subst_simps = Option.map (map (Morphism.thm phi)) subst_simps, - bsetss = map (map (Option.map (Morphism.term phi))) bsetss, - bset_bounds = map (Morphism.thm phi) bset_bounds, - mrbnf = MRBNF_Def.morph_mrbnf phi mrbnf, - strong_induct = Option.map (Morphism.thm phi) strong_induct, - distinct = map (Morphism.thm phi) distinct, - inject = map (Morphism.thm phi) inject, - ctors = map (map_prod (Morphism.term phi) (Morphism.thm phi)) ctors -} : binder_sugar; - -structure Data = Generic_Data ( - type T = binder_sugar Symtab.table; - val empty = Symtab.empty; - fun merge data : T = Symtab.merge (K true) data; -); - -fun register_binder_sugar name sugar = - Local_Theory.declaration {syntax = false, pervasive = true, pos = Position.none} - (fn phi => Data.map (Symtab.update (name, morph_binder_sugar phi sugar))); - -fun binder_sugar_of_generic context = - Option.map (morph_binder_sugar (Morphism.transfer_morphism (Context.theory_of context))) - o Symtab.lookup (Data.get context); - -val binder_sugar_of = binder_sugar_of_generic o Context.Proof; - fun add_nesting_mrbnf_names Us = let fun add (Type (s, Ts)) ss = @@ -130,20 +63,23 @@ fun create_binder_type (fp : MRBNF_Util.fp_kind) (spec : spec) lthy = let val fp_pre_T = BNF_FP_Util.mk_sumprodT_balanced (map snd (#ctors spec)); - val (resBs, Xs) = (*fold_rev ( - fn (x, Free_Var) => (fn (a, b) => (x::a, b)) - | (x, _) => (fn (a, b) => (a, x::b)) - ) (#vars spec) ([], []);*) (map fst (#vars spec), []) - fun flatten_tyargs Ass = subtract (op =) Xs (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs) @ Xs; + val Xs = map fst (#vars spec); + fun flatten_tyargs Ass = inter (op=) (flat Ass) Xs; val name = Binding.name_of (#fp_b spec); val pre_name = name ^ "_pre" (* ^ name *); - val ((mrbnf, tys), (accum, lthy)) = MRBNF_Comp.mrbnf_of_typ true MRBNF_Def.Smart_Inline - (Binding.prefix_name pre_name) flatten_tyargs Xs [] (#vars spec) fp_pre_T ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy); - val (_, _, (mrbnfs, (accum, lthy))) = MRBNF_Comp.normalize_mrbnfs (K I) [] [map dest_TFree (snd tys)] - [] (#vars spec) (K (map fst (#vars spec))) NONE [mrbnf] (accum, lthy); - val mrbnf = hd mrbnfs; - val ((mrbnf, (Ds, absinfo)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name pre_name) true (fst tys) [] mrbnf lthy; + val ((mrsbnf_opt, tys), (((_, bmv_unfolds), accum), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) + (Binding.prefix_name pre_name) [] (#vars spec) flatten_tyargs fp_pre_T (((Symtab.empty, []), (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy); + + val (mrsbnf, lthy) = case mrsbnf_opt of + Inl mrsbnf => (mrsbnf, lthy) | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf I mrbnf lthy + + val ((mrsbnf, (Ds, absinfo)), lthy) = MRSBNF_Comp.seal_mrsbnf I (bmv_unfolds + @ BMV_Monad_Def.unfolds_of_bmv_monad (MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf), snd accum) + (Binding.name pre_name) (#vars spec) tys mrsbnf NONE lthy; + + val mrbnf = hd (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf); + val (bnf, lthy) = MRBNF_Def.register_mrbnf_as_bnf mrbnf lthy val (res, lthy) = MRBNF_FP.construct_binder_fp fp [{ T_name = name, @@ -152,7 +88,7 @@ fun create_binder_type (fp : MRBNF_Util.fp_kind) (spec : spec) lthy = permute = Option.map Binding.name_of (#permute_b spec), FVars = map (Option.map Binding.name_of) (take (length (#binding_rel spec)) (#FVars_bs spec)) }] (map single (#binding_rel spec)) lthy; - in ((res, fp_pre_T, mrbnf, absinfo), lthy) end + in ((res, fp_pre_T, mrsbnf, absinfo), lthy) end fun mr_bnf_of lthy prefer_quot s = let @@ -248,15 +184,29 @@ fun build_set_for _ aT x (TFree (s, _)) = if s = fst (dest_TFree aT) then SOME ( end ) (mr_bnf_of lthy false C); +fun message quiet_mode s = if quiet_mode then () else writeln s; +fun clean_message ctxt quiet_mode s = + if Config.get ctxt quick_and_dirty then () else message quiet_mode s; + fun create_binder_datatype co (spec : spec) lthy = let val fp_kind = if co then MRBNF_Util.Greatest_FP else MRBNF_Util.Least_FP; - val ((res, fp_pre_T, mrbnf, absinfo), lthy) = create_binder_type fp_kind spec lthy; + val quiet_mode = false; + + val _ = clean_message lthy quiet_mode " Creating quotient type ..."; + + val ((res, fp_pre_T, mrsbnf, absinfo), lthy) = create_binder_type fp_kind spec lthy; + val mrbnf = hd (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf); + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; val (vvsubst_res_opt, lthy) = if co then (NONE, lthy) else (* TODO: Automate renaming for codatatypes *) let + val _ = clean_message lthy quiet_mode " Creating recursor locale ..."; + val (recursor_result, lthy) = MRBNF_Recursor.create_binding_recursor I res lthy; + val _ = clean_message lthy quiet_mode " Creating renaming function and proving MRBNF axioms ..."; + val ([(rec_mrbnf, vvsubst_res)], lthy) = MRBNF_VVSubst.mrbnf_of_quotient_fixpoint [#map_b spec] I res (#QREC_fixed recursor_result) lthy; val lthy = MRBNF_Def.register_mrbnf_raw (fst (dest_Type (#T (hd (#quotient_fps res))))) rec_mrbnf lthy; in (SOME { @@ -282,6 +232,8 @@ fun create_binder_datatype co (spec : spec) lthy = val (_, lthy) = Local_Theory.begin_nested lthy; + val _ = clean_message lthy quiet_mode " Defining high-level constructors and lifting theorems ..."; + val (ctors, (_, lthy)) = fold_map (fn ((name, syn), Ts) => fn (i, lthy) => let val Ts' = map (Term.typ_subst_atomic replace) Ts; @@ -602,6 +554,14 @@ fun create_binder_datatype co (spec : spec) lthy = ])] end ) ctors_tys) ctors_tys)); + fun find_bnfs lthy (Type (n, Ts)) xs = + let + val insert = case BNF_Def.bnf_of lthy n of + SOME bnf => insert ((op=) o apply2 fst) (n, bnf) | NONE => I + in insert (fold (find_bnfs lthy) Ts xs) end + | find_bnfs _ _ xs = xs + val bnfs = fold (find_bnfs lthy) (maps (map (Term.typ_subst_atomic replace) o snd) ctors_tys) []; + val injects = @{map_filter 2} (fn ((ctor, ctor_def), tys) => fn setss => if null tys then NONE else let val class = if co then (* TODO *) @@ -680,6 +640,7 @@ fun create_binder_datatype co (spec : spec) lthy = K (Local_Defs.unfold0_tac ctxt ( @{thms map_sum.simps map_prod_simp sum.inject prod.inject id_apply} @ set_simp_thms + @ map (BNF_Def.map_id_of_bnf o snd) bnfs @ maps MRBNF_Def.set_map_of_mrbnf fp_nesting_mrbnfs @ map MRBNF_Def.map_id_of_mrbnf fp_nesting_mrbnfs @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf @@ -860,17 +821,27 @@ fun create_binder_datatype co (spec : spec) lthy = val Ts' = take x Ts @ fresh_tvars; val abs' = Const (s, pre_repT --> Type (n, Ts')); - val etas = map_filter I (map_index (fn (i, (_, tys)) => - if length tys = 1 andalso member (op=) frees (hd tys) then - SOME (Term.abs ("a", Term.typ_subst_atomic replace' (hd tys)) (mk_ctor (i + 1) [Bound 0] abs')) + val etas = map_filter I (map_index (fn (i, ((_, tys), (ctor, _))) => + if length tys = 1 andalso member (op=) frees (hd tys) andalso + not (member (op=) (map TFree ( + fold Term.add_tfreesT (maps snd (take i (#ctors spec) @ drop (i + 1) (#ctors spec))) [] + )) (hd tys)) + then + SOME { + eta = Term.abs ("a", Term.typ_subst_atomic replace' (hd tys)) (mk_ctor (i + 1) [Bound 0] abs'), + Inj = ctor + } else NONE - ) (#ctors spec)); + ) ((#ctors spec) ~~ ctors_tys)); in etas end; fun eta_free_tac ctxt = EVERY1 [ K (Local_Defs.unfold0_tac ctxt ( - @{thms map_sum.simps map_prod_simp comp_def sum_set_simps cSup_singleton Union_empty Un_empty_left Un_empty_right} - @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @{thms map_sum.simps map_prod_simp comp_def sum_set_simps cSup_singleton + Union_empty Un_empty_left Un_empty_right UN_single UN_singleton Un_absorb + } @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @ BMV_Monad_Def.unfolds_of_bmv_monad bmv + @ BMV_Monad_Def.defs_of_bmv_monad bmv @ [#Abs_inverse (snd info) OF @{thms UNIV_I}] )), rtac ctxt refl @@ -881,8 +852,11 @@ fun create_binder_datatype co (spec : spec) lthy = ]; fun eta_compl_free_tac ctxt = EVERY1 [ K (Local_Defs.unfold0_tac ctxt ( - @{thms comp_def sum.set_map UN_empty2 Un_empty_right Un_empty_left UN_singleton} - @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @{thms comp_def sum.set_map UN_empty2 Un_empty_right Un_empty_left UN_singleton + Un_absorb + } @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @ BMV_Monad_Def.unfolds_of_bmv_monad bmv + @ BMV_Monad_Def.defs_of_bmv_monad bmv )), Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => rtac ctxt (infer_instantiate' ctxt [SOME (snd (hd params))] (#Abs_cases (snd info))) 1 @@ -891,6 +865,7 @@ fun create_binder_datatype co (spec : spec) lthy = K (Local_Defs.unfold0_tac ctxt (@{thms image_iff bex_UNIV} @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, #Abs_inject (snd info) OF @{thms UNIV_I UNIV_I}] )), + dtac ctxt @{thm iffD2[OF not_ex]}, etac ctxt @{thm contrapos_np}, dtac ctxt @{thm iffD2[OF ex_in_conv]}, etac ctxt exE, @@ -906,8 +881,28 @@ fun create_binder_datatype co (spec : spec) lthy = )), rtac ctxt refl ]; + fun eta_Sb_tac ctxt = EVERY1 [ + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + rtac ctxt (infer_instantiate' ctxt [SOME (snd (snd (split_last params)))] ( + BNF_FP_Util.mk_absumprodE (#type_definition (snd info)) (map (length o snd) ctors_tys) + )) 1 + ) ctxt THEN_ALL_NEW hyp_subst_tac ctxt, + K (Local_Defs.unfold0_tac ctxt ( + @{thms comp_def sum.set_map UN_empty2 Un_empty_right Un_empty_left UN_singleton map_sum.simps map_prod_simp id_apply sum.inject} + @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @ [MRBNF_Def.map_def_of_mrbnf pre_mrbnf] + @ BMV_Monad_Def.unfolds_of_bmv_monad bmv + @ BMV_Monad_Def.defs_of_bmv_monad bmv + @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, #Abs_inject (snd info) OF @{thms UNIV_I UNIV_I}] + )), + REPEAT_DETERM o FIRST' [ + rtac ctxt exI THEN' rtac ctxt refl, + eresolve_tac ctxt @{thms sum.distinct[THEN notE]} + ] + ]; val tvsubst_axioms = { + eta_Sb = eta_Sb_tac, eta_free = eta_free_tac, eta_inj = eta_inj_tac, eta_compl_free = eta_compl_free_tac, @@ -915,24 +910,24 @@ fun create_binder_datatype co (spec : spec) lthy = }; val tvsubst_model = { binding = #tvsubst_b spec, - etas = map (fn a => Option.map (rpair tvsubst_axioms) ( - List.find (fn t => domain_type (fastype_of t) = a) etas + etas = map (fn a => Option.map (fn { Inj, eta } => { Inj = Inj, eta = eta, tacs = tvsubst_axioms }) ( + List.find (fn t => domain_type (fastype_of (#eta t)) = a) etas )) vars - } + }; val thms = @{thms prod.set_map sum.set_map prod_set_simps sum_set_simps UN_empty UN_empty2 Un_empty_left Un_empty_right UN_singleton comp_def map_sum.simps map_prod_simp UN_single Int_Un_distrib Int_Un_distrib2 Un_empty notin_Un }; val nvars = length vars; - fun mk_map_simps lthy do_permute do_noclash plives' fs mk_supp_bound_opt mk_imsupp_opt mk_extra_prems extra_apply_args mapx tac = + fun mk_map_simps lthy do_permute do_noclash leaf_maps plives' fs mk_supp_bound_opt mk_imsupp_opt mk_extra_prems extra_apply_args mapx tac = let val mapx = Term.list_comb (mapx, fs); val (prem_fs, prems) = split_list (@{map_filter 2} (fn var_type => fn f => if var_type = MRBNF_Def.Live_Var then NONE else case mk_supp_bound_opt f of NONE => NONE - | SOME t => SOME (f, map HOLogic.mk_Trueprop (if var_type = MRBNF_Def.Bound_Var then - [mk_bij f, t] else [t] + | SOME ts => SOME (f, map HOLogic.mk_Trueprop (if var_type = MRBNF_Def.Bound_Var then + (mk_bij f::ts) else ts )) ) (take (length fs) (MRBNF_Def.var_types_of_mrbnf mrbnf)) fs); @@ -948,6 +943,18 @@ fun create_binder_datatype co (spec : spec) lthy = ) (MRBNF_Def.map_of_mrbnf mrbnf); in if forall (fn Const ("Fun.id", _) => true | _ => false) gs then HOLogic.id_const T + else if exists (fn t => fst (dest_Type (snd (split_last (binder_types (fastype_of t))))) = fst (dest_Type T)) leaf_maps then + let val subst = the (List.find (fn t => fst (dest_Type (snd (split_last (binder_types (fastype_of t))))) = fst (dest_Type T)) leaf_maps); + in Term.list_comb (subst, gs) end + else if not (null leaf_maps) andalso Option.isSome (BMV_Monad_Def.pbmv_monad_of lthy n) then + let + val Sb = hd (BMV_Monad_Def.Sbs_of_bmv_monad (the (BMV_Monad_Def.pbmv_monad_of lthy n))); + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (body_type (fastype_of Sb), body_type (fastype_of inner_map)) Vartab.empty; + val Sb = Envir.subst_term (tyenv, Vartab.empty) Sb; + in Term.list_comb (Sb, map (fn T => + the (List.find (curry (op=) T o fastype_of) gs) + ) (fst (split_last (binder_types (fastype_of Sb))))) end else if do_permute andalso forall (fn Const ("Fun.id", _) => true | Free _ => true | _ => false) gs then case MRBNF_FP_Def_Sugar.fp_result_of lthy n of NONE => Term.list_comb (inner_map, gs) @@ -1010,7 +1017,8 @@ fun create_binder_datatype co (spec : spec) lthy = val gs = map mk_map tys; val ts = map2 (fn g => fn x => case g of Const ("Fun.id", _) => x - | _ => g $ x + | _ => let val T = domain_type (fastype_of g) + in if fastype_of x = T orelse T = qT then g $ x else x end ) gs xs; fun mk_sets vars recs FVars_opt = @@ -1019,16 +1027,16 @@ fun create_binder_datatype co (spec : spec) lthy = | NONE => replicate nvars NONE in map2 (fn b => fn FVars => map_filter I (map2 (mk_set (b::recs) FVars) tys xs)) vars FVars end; val bound_sets = mk_sets bounds [] NONE; - fun get_fs T = filter (fn t' => case mk_imsupp_opt t' T of - NONE => false - | SOME t => HOLogic.dest_setT (fastype_of t) = T - ) fs; + fun mk_imsupp_prems t mk T = flat (map_filter (fn f => + let val aT = the_default (fastype_of t) (try HOLogic.dest_setT (fastype_of t)) + in Option.map (fn prems => + let val prems = filter (curry (op=) aT o HOLogic.dest_setT o fastype_of) prems; + in map (HOLogic.mk_Trueprop o mk o pair t) prems end + ) (mk_imsupp_opt f T) end + ) fs); val imsupp_prems = maps (maps (fn t => case Term.subst_atomic_types replace t of - (Const (@{const_name Set.insert}, _) $ (t as Free (_, T)) $ _) => - map (fn f => HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_mem (t, the (mk_imsupp_opt f T))))) (get_fs T) - | t => - let val T = HOLogic.dest_setT (fastype_of t); - in map (fn f => HOLogic.mk_Trueprop (mk_int_empty (t, the (mk_imsupp_opt f T)))) (get_fs T) end + (Const (@{const_name Set.insert}, _) $ (t as Free (_, T)) $ _) => mk_imsupp_prems t (HOLogic.mk_not o HOLogic.mk_mem) T + | t => mk_imsupp_prems t mk_int_empty (HOLogic.dest_setT (fastype_of t)) )) bound_sets; val free_rec_vars = subtract (op=) (map (nth rec_vars) (flat (map snd (#binding_rel spec)))) rec_vars; @@ -1074,7 +1082,8 @@ fun create_binder_datatype co (spec : spec) lthy = ) (MRBNF_Def.map_of_mrbnf rec_mrbnf); fun tac ctxt prems = EVERY1 [ rtac ctxt (trans OF [#vvsubst_ctor vvsubst_res]), - K (Local_Defs.unfold0_tac ctxt (thms @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf @ [ + K (Local_Defs.unfold0_tac ctxt (thms @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @ map (BNF_Def.map_id_of_bnf o snd) bnfs @ [ MRBNF_Def.map_def_of_mrbnf pre_mrbnf, #Abs_inverse (snd info) OF @{thms UNIV_I}, snd (#noclash (hd (#quotient_fps res))) @@ -1094,9 +1103,9 @@ fun create_binder_datatype co (spec : spec) lthy = K (Local_Defs.unfold0_tac ctxt @{thms id_def}), rtac ctxt refl ]; - in mk_map_simps lthy false true plives' fs (SOME o MRBNF_Recursor.mk_supp_bound) (fn t => fn _ => SOME (mk_imsupp t)) (K []) [] mapx tac end; + in mk_map_simps lthy false true [] plives' fs (SOME o single o MRBNF_Util.mk_supp_bound) (fn t => fn _ => SOME [mk_imsupp t]) (K []) [] mapx tac end; - val nesting_binder_sugars = map_filter (fn mrbnf => binder_sugar_of lthy + val nesting_binder_sugars = map_filter (fn mrbnf => Binder_Sugar.binder_sugar_of lthy (fst (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf))) ) fp_nesting_mrbnfs; @@ -1108,66 +1117,100 @@ fun create_binder_datatype co (spec : spec) lthy = val mapx = Term.subst_atomic_types (Ts' ~~ (vars @ passives)) (#permute quotient); fun tac ctxt prems = EVERY1 [ rtac ctxt (trans OF [#permute_ctor quotient]), - K (Local_Defs.unfold0_tac ctxt (thms @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf @ [ + K (Local_Defs.unfold0_tac ctxt (thms @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf + @ map (BNF_Def.map_id_of_bnf o snd) bnfs @ [ MRBNF_Def.map_def_of_mrbnf pre_mrbnf, #Abs_inverse (snd info) OF @{thms UNIV_I} ])), REPEAT_DETERM o resolve_tac ctxt prems, REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (map (the o #map_permute) nesting_binder_sugars), - REPEAT_DETERM o resolve_tac ctxt prems + REPEAT_DETERM o resolve_tac ctxt prems ], K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), rtac ctxt refl ]; - in mk_map_simps lthy true false plives fs (SOME o MRBNF_Recursor.mk_supp_bound) (K (K NONE)) + in mk_map_simps lthy true false [] plives fs (SOME o single o MRBNF_Recursor.mk_supp_bound) (K (K NONE)) (single o HOLogic.mk_Trueprop o mk_bij) bounds mapx tac end; - val cmin_UNIV = foldl1 mk_cmin (map (mk_card_of o HOLogic.mk_UNIV) vars); - val Cinfinite_card = Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop (HOLogic.mk_conj ( - mk_cinfinite cmin_UNIV, mk_Card_order cmin_UNIV - ))) (fn {context=ctxt, ...} => EVERY1 [ - REPEAT_DETERM o resolve_tac ctxt (MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf :: @{thms cmin_Cinfinite conjI card_of_Card_order}) - ]); - val (lthy, tvsubst_opt) = if not (null (map_filter I (#etas tvsubst_model))) andalso not co then let val recursor_result = #recursor_result (the vvsubst_res_opt); - val (tvsubst_ress, lthy) = MRBNF_TVSubst.create_tvsubst_of_mrbnf (Binding.prefix_name "tv") res [tvsubst_model] (#QREC_cmin_fixed recursor_result) lthy; - val tvsubst_res = hd tvsubst_ress; + val rec_mrbnf = #rec_mrbnf (the vvsubst_res_opt); + val vvsubst_res = #vvsubst_res (the vvsubst_res_opt); + + val _ = clean_message lthy quiet_mode " Creating substition function ..."; + + val (tvsubst_res, lthy) = TVSubst.create_tvsubst_of_mrsbnf (Binding.prefix_name "tv") res mrsbnf + rec_mrbnf (#vvsubst_ctor vvsubst_res) (#vvsubst_permute vvsubst_res) (#pset_ctors (#vvsubst_res (the vvsubst_res_opt))) (#tvsubst_b spec) + (#etas tvsubst_model) (#QREC_fixed recursor_result) lthy; + + val lthy = BMV_Monad_Def.register_pbmv_monad (fst (dest_Type qT)) + (MRSBNF_Def.bmv_monad_of_mrsbnf (#mrsbnf tvsubst_res)) lthy; + val lthy = MRSBNF_Def.register_mrsbnf (fst (dest_Type qT)) (#mrsbnf tvsubst_res) lthy; + val (_, lthy) = MRSBNF_Def.note_mrsbnf_thms (K BNF_Def.Note_Some) + I NONE (#mrsbnf tvsubst_res) lthy; + val (_, lthy) = BMV_Monad_Def.note_bmv_monad_thms (K BNF_Def.Note_Some) I NONE ( + MRSBNF_Def.bmv_monad_of_mrsbnf (#mrsbnf tvsubst_res) + ) lthy; + val tvsubst_simps = let - val (fs, _) = lthy - |> mk_Frees "f" (map (fn a => a --> range_type (fastype_of quotient_ctor)) vars); - val fs = map_filter I (map2 (fn f => Option.map (fn _ => f)) fs (#etas tvsubst_model)); - fun mk_supp h = Option.map (fn t => t $ h) (List.find (fn s => - domain_type (domain_type (fastype_of s)) = domain_type (fastype_of h) - ) (#SSupps tvsubst_res)); - fun mk_supp_bound h = Option.map (fn s => mk_ordLess (mk_card_of s) cmin_UNIV) (mk_supp h); - fun mk_imsupp h T = SOME (foldl1 mk_Un (map_filter (fn f => Option.map (fn t => t $ f) ( - List.find (fn s => domain_type (fastype_of s) = fastype_of h - andalso domain_type (fastype_of s) = fastype_of f - andalso HOLogic.dest_setT (range_type (fastype_of s)) = T - ) (flat (#IImsuppss tvsubst_res)) - )) fs)); + val T = range_type (fastype_of quotient_ctor); + val bmv = + let + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf (#mrsbnf tvsubst_res); + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (hd (BMV_Monad_Def.ops_of_bmv_monad bmv), T) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism (map (fn (n, (s, T)) => (TVar (n, s), T)) (Vartab.dest tyenv)); + in BMV_Monad_Def.morph_bmv_monad phi bmv end + val Injs = hd (BMV_Monad_Def.Injs_of_bmv_monad bmv); + val RVrs = hd (BMV_Monad_Def.RVrs_of_bmv_monad bmv); + + val ((fs, rhos), _) = lthy + |> mk_Frees "f" (map ((fn a => a --> a) o HOLogic.dest_setT o range_type o fastype_of) RVrs) + ||>> mk_Frees "\" (map fastype_of Injs); + val Sbs = BMV_Monad_Def.Sbs_of_bmv_monad bmv; + + val small_premss = map (map HOLogic.dest_Trueprop) ( + BMV_Monad_Def.mk_small_prems_of_bmv_monad bmv 0 fs rhos + ); + + fun mk_supp_bound f = if Term.is_TFree (body_type (fastype_of f)) then SOME [MRBNF_Util.mk_supp_bound f] else + List.find (fn xs => Term.exists_subterm (curry (op=) f) (hd xs)) small_premss; + + fun mk_imsupp h _ = if Term.is_TFree (body_type (fastype_of h)) then SOME [MRBNF_Util.mk_imsupp h] else + let + val Inj = the (List.find (fn Inj => fastype_of Inj = fastype_of h) Injs); + val idx = find_index (curry (op=) (body_type (fastype_of Inj))) (BMV_Monad_Def.ops_of_bmv_monad bmv); + val Vrs = nth (BMV_Monad_Def.RVrs_of_bmv_monad bmv) idx @ nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) idx; + val IImsupps = (mk_SSupp Inj $ h) :: map (fn Vrs => mk_IImsupp Inj Vrs $ h) Vrs; + in SOME IImsupps end + + fun collect_bmvs (Type (n, Ts)) = map_filter I [BMV_Monad_Def.pbmv_monad_of lthy n] @ maps collect_bmvs Ts + | collect_bmvs _ = [] + val bmvs = maps (maps collect_bmvs o snd) ctors_tys; + + val bmv_unfolds = maps BMV_Monad_Def.unfolds_of_bmv_monad bmvs; fun tac ctxt prems = EVERY1 [ - K (Local_Defs.unfold0_tac ctxt (map (Thm.symmetric o snd) (#VVrs tvsubst_res))), + K (Local_Defs.unfold0_tac ctxt (map (Thm.symmetric o snd) (map_filter (Option.map #Inj) (#etas tvsubst_model)))), EVERY' [ - resolve_tac ctxt (#tvsubst_VVrs tvsubst_res), + resolve_tac ctxt (#tvsubst_Injs tvsubst_res), REPEAT_DETERM o resolve_tac ctxt prems ] ORELSE' EVERY' [ rtac ctxt trans, - rtac ctxt (#tvsubst_cctor_not_isVVr tvsubst_res), + rtac ctxt (#tvsubst_not_isInj tvsubst_res), REPEAT_DETERM o resolve_tac ctxt prems, K (Local_Defs.unfold0_tac ctxt (thms @ MRBNF_Def.set_defs_of_mrbnf pre_mrbnf - @ #isVVrs tvsubst_res @ map snd (#VVrs tvsubst_res) + @ map (BNF_Def.map_id_of_bnf o snd) bnfs + @ map snd (#isInjs tvsubst_res) @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, snd (#noclash quotient)] )), K (TRYALL (REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (maps MRBNF_Def.set_map_of_mrbnf fp_nesting_mrbnfs), - REPEAT_DETERM o resolve_tac ctxt (@{thms bij_id supp_id_bound} @ [@{thm supp_id_bound'} OF [Cinfinite_card]]), + REPEAT_DETERM o resolve_tac ctxt (@{thms bij_id supp_id_bound}), K (Local_Defs.unfold0_tac ctxt thms) ])), REPEAT_DETERM o resolve_tac ctxt ( @@ -1177,20 +1220,31 @@ fun create_binder_datatype co (spec : spec) lthy = REPEAT_DETERM o EVERY' [ rtac ctxt @{thm notI}, etac ctxt exE, - dtac ctxt (iffD1 OF [#inject quotient]), - REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], - K (Local_Defs.unfold0_tac ctxt (@{thms comp_def map_sum.simps map_prod_simp sum.inject} - @ [MRBNF_Def.map_def_of_mrbnf pre_mrbnf, #Abs_inverse (snd info) OF @{thms UNIV_I}, - #Abs_inject (snd info) OF @{thms UNIV_I UNIV_I} - ])), - eresolve_tac ctxt @{thms sum.distinct[THEN notE]} + SELECT_GOAL (Local_Defs.unfold_tac ctxt (map (Thm.symmetric o snd) ctors)), + eresolve_tac ctxt (map (fn thm => thm RS notE) distinct) ], - K (Local_Defs.unfold0_tac ctxt (map MRBNF_Def.map_id0_of_mrbnf fp_nesting_mrbnfs)), - K (Local_Defs.unfold0_tac ctxt @{thms id_def}), + K (Local_Defs.unfold0_tac ctxt (@{thms id_apply} + @ map MRBNF_Def.map_id0_of_mrbnf fp_nesting_mrbnfs + @ map (BNF_Def.map_id_of_bnf o snd) bnfs + @ map #Sb_Inj (BMV_Monad_Def.axioms_of_bmv_monad (MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf)) + )), + K (Local_Defs.unfold0_tac ctxt (@{thms comp_def map_sum.simps map_prod_simp sum.inject} + @ map MRBNF_Def.map_id_of_mrbnf fp_nesting_mrbnfs + @ map MRBNF_Def.map_id0_of_mrbnf fp_nesting_mrbnfs + @ BMV_Monad_Def.unfolds_of_bmv_monad (MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf) + @ BMV_Monad_Def.defs_of_bmv_monad (MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf) + @ map (BNF_Def.map_id_of_bnf o snd) bnfs + @ [MRBNF_Def.map_def_of_mrbnf pre_mrbnf, #Abs_inverse (snd info) OF @{thms UNIV_I}, + #Abs_inject (snd info) OF @{thms UNIV_I UNIV_I} + ])), + K (Local_Defs.unfold0_tac ctxt bmv_unfolds), + K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), rtac ctxt refl ] ]; - in mk_map_simps lthy false true plives fs mk_supp_bound mk_imsupp (K []) [] (#tvsubst tvsubst_res) tac end; + in map (Local_Defs.unfold0 lthy bmv_unfolds) ( + mk_map_simps lthy false true Sbs plives (fs @ rhos) mk_supp_bound mk_imsupp (K []) [] (#tvsubst tvsubst_res) tac + ) end; in (lthy, SOME (tvsubst_res, tvsubst_simps)) end else (lthy, NONE); @@ -1198,6 +1252,18 @@ fun create_binder_datatype co (spec : spec) lthy = val induct_attrib = Attrib.internal Position.none (K (Induct.induct_type (fst (dest_Type qT)))) val equiv = @{attributes [simp, equiv]} + val unfold_tvsubst = map ( + Local_Defs.unfold lthy ( + @{thms SSupp_def[symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong]} + @ map (Thm.symmetric o snd) ctors + @ [@{lemma "\((Vrs \ \) ` SSupp Inj \) = IImsupp Inj Vrs \" + by (auto simp: IImsupp_def)}] + ) + ); + + val IImsupp_permute_commutes = Option.map (fn (res, _) => unfold_tvsubst (#IImsupp_permute_commutes res)) tvsubst_opt; + val IImsupp_Diffs = Option.map (fn (res, _) => unfold_tvsubst (#IImsupp_Diffs res)) tvsubst_opt; + val (sugar, lthy) = if co then let val (locale_name, lthy) = MRBNF_Corecursor.create_binding_corecursor I res lthy; @@ -1208,13 +1274,17 @@ fun create_binder_datatype co (spec : spec) lthy = map_permute = NONE, strong_induct = NONE, subst_simps = NONE, + IImsupp_permute_commutes = IImsupp_permute_commutes, + IImsupp_Diffs = IImsupp_Diffs, + tvsubst_permute = Option.map (#tvsubst_permute o fst) tvsubst_opt, bsetss = [], bset_bounds = [], + pset_ctors = [], mrbnf = mrbnf, distinct = [], inject = [], ctors = [] - } : binder_sugar; + } : Binder_Sugar.binder_sugar; in (sugar, lthy) end else let @@ -1225,16 +1295,20 @@ fun create_binder_datatype co (spec : spec) lthy = map_permute = SOME (#vvsubst_permute (#vvsubst_res (the vvsubst_res_opt))), strong_induct = strong_induct_opt, subst_simps = Option.map snd tvsubst_opt, + IImsupp_permute_commutes = IImsupp_permute_commutes, + IImsupp_Diffs = IImsupp_Diffs, + tvsubst_permute = Option.map (#tvsubst_permute o fst) tvsubst_opt, bsetss = bset_optss, bset_bounds = [], + pset_ctors = #pset_ctors (#vvsubst_res (the vvsubst_res_opt)), mrbnf = mrbnf, distinct = distinct, inject = injects, ctors = ctors - } : binder_sugar; + } : Binder_Sugar.binder_sugar; in (sugar, lthy) end - val lthy = register_binder_sugar (fst (dest_Type qT)) sugar lthy; + val lthy = Binder_Sugar.register_binder_sugar (fst (dest_Type qT)) sugar lthy; val note_inducts = Option.map (fn strong_induct => [ ("strong_induct", [strong_induct], []), @@ -1248,8 +1322,12 @@ fun create_binder_datatype co (spec : spec) lthy = ("permute", permute_simps, equiv), ("distinct", distinct, simp), ("inject", injects, simp) - ] @ the_default [] (Option.map (fn (_, tvsubst_simps) => [("subst", tvsubst_simps, simp)]) tvsubst_opt) - ) + ] @ the_default [] (Option.map (fn (res, tvsubst_simps) => [ + ("subst", tvsubst_simps, simp), + ("IImsupp_permute_commute", #IImsupp_permute_commutes res, []), + ("IImsupp_Diff", #IImsupp_Diffs res, []), + ("tvsubst_permute", [#tvsubst_permute res], []) + ]) tvsubst_opt)) |> filter_out (null o #2) |> (map (fn (thmN, thms, attrs) => ((Binding.qualify true (Binding.name_of (#fp_b spec)) (Binding.name thmN), attrs), [(thms, [])]) diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML deleted file mode 100644 index f758979b..00000000 --- a/Tools/mrbnf_tvsubst.ML +++ /dev/null @@ -1,1464 +0,0 @@ -signature MRBNF_TVSUBST = -sig - type 'a eta_axioms = { - eta_free: 'a, - eta_inj: 'a, - eta_compl_free: 'a, - eta_natural: 'a - }; - - type 'a tvsubst_model = { - binding: binding, - etas: (term * 'a eta_axioms) option list - }; - - type tvsubst_result = { - tvsubst: term, - SSupps: term list, - IImsuppss: term list list, - VVrs: (term * thm) list, - isVVrs: thm list, - tvsubst_VVrs: thm list, - tvsubst_cctor_not_isVVr: thm, - tvsubst_permute: thm - }; - - val create_tvsubst_of_mrbnf: (binding -> binding) -> MRBNF_FP_Def_Sugar.fp_result - -> (Proof.context -> tactic) tvsubst_model list -> string -> local_theory - -> tvsubst_result list * local_theory -end - -structure MRBNF_TVSubst : MRBNF_TVSUBST = -struct - -open BNF_Tactics -open BNF_Util -open MRBNF_Util -open MRBNF_Recursor - -type 'a eta_axioms = { - eta_free: 'a, - eta_inj: 'a, - eta_compl_free: 'a, - eta_natural: 'a -}; - -type 'a tvsubst_model = { - binding: binding, - etas: (term * 'a eta_axioms) option list -}; - -type tvsubst_result = { - tvsubst: term, - SSupps: term list, - IImsuppss: term list list, - VVrs: (term * thm) list, - isVVrs: thm list, - tvsubst_VVrs: thm list, - tvsubst_cctor_not_isVVr: thm, - tvsubst_permute: thm -}; - -val names = map (fst o dest_Free); - -fun prove_model_axioms qualify res (models : (Proof.context -> tactic) tvsubst_model list) lthy = - let - val eta_namess = lthy - |> mk_Freess "\" (map (map_filter (Option.map (fastype_of o fst)) o #etas) models) - |> fst - |> map (map (fst o dest_Free)) - |> map2 (fn quot => map (fn s => s ^ "_" ^ short_type_name (fst (dest_Type (#T quot))))) (#quotient_fps res); - - val eta_names_opts = map2 (fn model => fn eta_names => - fst (fold_map (fn x => fn names => case x of - SOME _ => (SOME (hd names), tl names) - | NONE => (NONE, names) - ) (#etas model) eta_names) - ) models eta_namess; - - val mrbnfs = #pre_mrbnfs res; - val nvars = length (#binding_relation res); - val pfree = MRBNF_Def.free_of_mrbnf (hd mrbnfs) - nvars - length (#bfree_vars res); - val plive = MRBNF_Def.live_of_mrbnf (hd mrbnfs) - foldl1 (op+) (#rec_vars res); - val pbound = MRBNF_Def.bound_of_mrbnf (hd mrbnfs) - nvars; - - val (etass, lthy) = @{fold_map 3} (fn model => fn mrbnf => fn eta_names_opt => fn lthy => - let val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf in apsnd snd ( - @{fold_map 3} (fn set => fn eta_opt => fn eta_name => fn (i, lthy) => let val eta_opt' = Option.map (fn (eta, tacs) => - let - val (aT, preT) = dest_funT (fastype_of eta); - val args = snd (dest_Type preT); - val old_vars = rev (map TVar (Term.add_tvars set []) @ map TFree (Term.add_tfrees set [])); - val set' = Term.subst_atomic_types (old_vars ~~ args) set; - val vars = rev (fold (Term.add_tfreesT) args []); - - val ((((((frees, pfrees), plives), pbounds), bounds), bfrees), rec_vars) = args - |> chop nvars - ||>> chop pfree - ||>> chop plive - ||>> chop pbound - ||>> chop nvars - ||>> chop (length (#bfree_vars res)); - - val names_lthy = fold (Variable.declare_constraints o Logic.mk_type o TFree) vars lthy; - val ((((a, b), x), Bs), names_lthy) = names_lthy - |> apfst hd o mk_Frees "a" [aT] - ||>> apfst hd o mk_Frees "b" [aT] - ||>> apfst hd o mk_Frees "x" [preT] - ||>> mk_TFrees (length rec_vars); - - val fTs = map (fn a => a --> a) (frees @ bounds @ bfrees) @ map2 (curry op-->) rec_vars Bs; - - val (((free_fs, bound_fs), bfree_fs), live_fs) = names_lthy - |> mk_Frees "f" fTs - |> fst - |> chop nvars - ||>> chop nvars - ||>> chop (length (#bfree_vars res)); - val fs = free_fs @ bound_fs @ bfree_fs @ live_fs; - - val lthy = snd (Local_Theory.begin_nested lthy); - val (raw_eta, lthy) = mk_def_t false (#binding model) qualify (the eta_name) 0 eta lthy - val (lthy, old_lthy) = `Local_Theory.end_nested lthy; - val phi = Proof_Context.export_morphism old_lthy lthy; - - val eta' = Morphism.term phi (fst raw_eta); - val vars = snd (dest_Type (range_type (fastype_of eta'))); - val eta = (Term.subst_atomic_types (vars ~~ args) eta', Morphism.thm phi (snd raw_eta)); - - val eta_free = Goal.prove_sorry lthy (names [a]) [] - (mk_Trueprop_eq (set' $ (fst eta $ a), mk_singleton a)) - (fn {context, ...} => unfold_thms_tac context [snd eta] THEN #eta_free tacs context); - - val eta_inj = Goal.prove_sorry lthy (names [a, b]) [] - (Logic.mk_implies (mk_Trueprop_eq (fst eta $ a, fst eta $ b), mk_Trueprop_eq (a, b))) - (fn {context, ...} => unfold_thms_tac context [snd eta] THEN #eta_inj tacs context); - - val eta_compl_free = Goal.prove_sorry lthy [] [] - (Logic.all x (Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_mem ( - x, mk_image (fst eta) $ HOLogic.mk_UNIV aT - ))), - mk_Trueprop_eq (set' $ x, mk_bot aT) - ))) - (fn {context, ...} => unfold_thms_tac context [snd eta] THEN #eta_compl_free tacs context); - - val f_prems = map mk_supp_bound free_fs - @ maps (fn f => [mk_bij f, mk_supp_bound f]) bound_fs - @ map mk_supp_bound bfree_fs; - - val eta' = - let - val (n, T) = dest_Const (fst eta); - val (n2, _) = dest_Type (range_type T); - val Ts' = frees @ pfrees @ plives @ pbounds @ bounds @ bfrees @ Bs; - in Const (n, domain_type T --> Type (n2, Ts')) end; - val eta_natural = Goal.prove_sorry lthy (names fs) [] - (fold_rev (curry Logic.mk_implies o HOLogic.mk_Trueprop) f_prems (mk_Trueprop_eq ( - HOLogic.mk_comp ( - MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) - (map HOLogic.id_const plives @ live_fs) - (map HOLogic.id_const pbounds @ bound_fs) - (free_fs @ map HOLogic.id_const pfrees @ bfree_fs) mrbnf, - fst eta - ), - HOLogic.mk_comp (eta', nth free_fs i) - ))) - (fn {context, ...} => unfold_thms_tac context [snd eta] THEN #eta_natural tacs context); - in ((eta, { - eta_free = eta_free, - eta_inj = eta_inj, - eta_compl_free = eta_compl_free, - eta_natural = eta_natural - }), lthy) end - ) eta_opt in (Option.map fst eta_opt', (i + 1, the_default lthy (Option.map snd eta_opt'))) end) - (take nvars (map_filter (fn (MRBNF_Def.Free_Var, set) => SOME set | _ => NONE) ( - var_types ~~ MRBNF_Def.sets_of_mrbnf mrbnf - ))) (#etas model) eta_names_opt (0, lthy) - ) end - ) models mrbnfs eta_names_opts lthy; - - val sort = snd (dest_TFree (domain_type (fastype_of (fst (fst (hd (map_filter I (flat etass)))))))); - val (Ts, _) = mk_TFrees' ( - replicate (nvars + pfree) sort @ replicate plive @{sort type} @ replicate pbound sort - ) lthy; - val ctor = #ctor (hd (#quotient_fps res)); - val vars = map TVar (rev (Term.add_tvars ctor [])) @ map TFree (rev (Term.add_tfrees ctor [])); - val res = MRBNF_FP_Def_Sugar.substitute_vars (vars ~~ Ts) res - val ctor = #ctor (hd (#quotient_fps res)); - val args = snd (dest_Type (domain_type (fastype_of ctor))); - - val etass = map (map (Option.map (fn ((eta, eta_def), thms) => - let - val Ts' = snd (dest_Type (range_type (fastype_of eta))); - val eta' = Term.subst_atomic_types (Ts' ~~ args) eta; - in ((eta', eta_def), thms) end - ))) etass; - val Ts' = Ts - |> chop nvars - ||>> chop pfree - ||>> chop plive - - in (res, maps (map_filter (Option.map (snd o fst))) etass, Ts', - map2 (fn model => fn etas => { - binding = #binding model, - etas = map (Option.map (apfst fst)) etas - } : thm tvsubst_model) models etass, lthy - ) end; - -fun define_tvsubst_consts qualify (fp_res : MRBNF_FP_Def_Sugar.fp_result) (vars, pfrees, plives, pbounds) (models : thm tvsubst_model list) lthy = - let - val nvars = length vars; - val mk_def_t = MRBNF_Util.mk_def_t false (Binding.conglomerate (map #binding models)) qualify; - val mk_def_public = MRBNF_Util.mk_def_t true Binding.empty I; - - val suffixes = - let fun mk_ss s etas = case map_filter I etas of - [_] => map (Option.map (K s)) etas - | _ => fst (fold_map (fn eta_opt => fn i => case eta_opt of - NONE => (NONE, i) | SOME _ => (SOME (s ^ string_of_int i), i + 1) - ) etas 1); - in case models of - [m] => [mk_ss "" (#etas m)] - | _ => map2 (fn i => mk_ss (string_of_int i) o #etas) (1 upto length models) models - end; - - val (_, lthy) = Local_Theory.begin_nested lthy; - - val (defss, lthy) = @{fold_map 3} (fn quot => fn model => fn suffix => - @{fold_map 3} (fn eta_opt => fn suffix => fn i => fn lthy => let val opt = Option.map (fn (eta, _) => - let - val qT = #T quot; - val aT = domain_type (fastype_of eta); - val (VVr, lthy) = mk_def_t ("VVr" ^ the suffix) 0 (HOLogic.mk_comp (#ctor quot, eta)) lthy; - - val ((h, t), _) = lthy - |> apfst hd o mk_Frees "f" [aT --> qT] - ||>> apfst hd o mk_Frees "t" [qT]; - - val (SSupp, lthy) = mk_def_public ("SSupp" ^ the suffix ^ "_" ^ short_type_name (fst (dest_Type qT))) - 1 (Term.absfree (dest_Free h) (HOLogic.mk_Collect ("a", aT, HOLogic.mk_not (HOLogic.mk_eq ( - h $ Bound 0, fst VVr $ Bound 0 - ))) - )) lthy; - - val (IImsupps, lthy) = @{fold_map 2} (fn FVars => fn s => - mk_def_public ("IImsupp" ^ the suffix ^ s ^ "_" ^ short_type_name (fst (dest_Type qT))) 1 (Term.absfree (dest_Free h) ( - let val UN = mk_UNION (fst SSupp $ h) (HOLogic.mk_comp (FVars, h)); - in if fastype_of (fst SSupp $ h) = range_type (fastype_of FVars) then - mk_Un (fst SSupp $ h, UN) - else UN end - ))) (#FVarss quot) (if nvars = 1 then [""] else map (fn i => "_" ^ string_of_int i) (1 upto nvars)) lthy; - - val (isVVr, lthy) = mk_def_t ("isVVr" ^ the suffix) 1 (Term.absfree (dest_Free t) ( - HOLogic.mk_exists ("a", aT, HOLogic.mk_eq (t, fst VVr $ Bound 0)) - )) lthy; - - val (asVVr, lthy) = mk_def_t ("asVVr" ^ the suffix) 1 (Term.absfree (dest_Free t) ( - BNF_FP_Util.mk_If (fst isVVr $ t) - (HOLogic.choice_const aT $ Term.abs ("a", aT) (HOLogic.mk_eq (fst VVr $ Bound 0, t))) - (BNF_GFP_Util.mk_undefined aT) - )) lthy; - in ({ - aT = aT, - SSfun = fastype_of h, - VVr = VVr, - SSupp = SSupp, - IImsupps = IImsupps, - isVVr = isVVr, - asVVr = asVVr - }, lthy) end - ) eta_opt in ( - Option.map fst opt, the_default lthy (Option.map snd opt)) - end) (#etas model) suffix (0 upto nvars - 1) - ) (#quotient_fps fp_res) models suffixes lthy; - - val bfrees = map (nth vars) (#bfree_vars fp_res); - - val card = foldl1 mk_cmin (map (mk_card_of o HOLogic.mk_UNIV) vars); - val some_defs = maps (map_filter I) defss; - - val (lthy, old_lthy) = `Local_Theory.end_nested lthy; - val phi = Proof_Context.export_morphism old_lthy lthy; - - val morph = - let - val t = fst (#isVVr (hd some_defs)); - val t' = Morphism.term phi t; - val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (fastype_of t', fastype_of t) Vartab.empty; - val subst = Envir.subst_term (tyenv, Vartab.empty); - in fn (t, thm) => ( - Morphism.term (phi $> Morphism.term_morphism "fix_tyvars" subst) t, - Morphism.thm phi thm - ) end; - - val defss = map (map (Option.map (fn { aT, SSfun, VVr, SSupp, IImsupps, isVVr, asVVr } => { - aT = aT, - SSfun = SSfun, - VVr = morph VVr, - SSupp = morph SSupp, - IImsupps = map morph IImsupps, - isVVr = morph isVVr, - asVVr = morph asVVr - }))) defss; - - in (defss, lthy) end; - -fun option_map2 f (SOME x) (SOME y) = SOME (f x y) - | option_map2 _ _ _ = NONE -fun traverse_pair (SOME (x, y)) = (SOME x, SOME y) - | traverse_pair NONE = (NONE, NONE) - -fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_lthy = - let - val (fp_res, eta_defs, vars, models, lthy) = prove_model_axioms qualify fp_res models no_defs_lthy; - val (((vars, pfrees), plives), pbounds) = vars; - val bfrees = map (nth vars) (#bfree_vars fp_res); - - val (defss, lthy) = define_tvsubst_consts qualify fp_res (vars, pfrees, plives, pbounds) models lthy; - - val nvars = length vars; - val card = foldl1 mk_cmin (map (mk_card_of o HOLogic.mk_UNIV) vars); - - val defss = map2 (fn model => map2 (option_map2 (fn eta => fn def => { - eta = fst eta, - axioms = snd eta, - aT = #aT def, - VVr = #VVr def, - SSupp = #SSupp def, - IImsupps = #IImsupps def, - isVVr = #isVVr def, - asVVr = #asVVr def, - SSfun = #SSfun def, - mk_SSupp_bound = fn t => mk_ordLess (mk_card_of (fst (#SSupp def) $ t)) card - })) (#etas model)) models defss; - - val card_thms = @{thms card_of_Card_order cmin_Card_order ordLeq_refl cmin2 ordLeq_transitive[OF cmin1] ordLess_ordLeq_trans}; - val (SSupp_VVr_emptiess, SSupp_VVr_boundss) = split_list (map (split_list o map (traverse_pair o Option.map (fn def => - let - val empty = Goal.prove_sorry lthy [] [] (mk_Trueprop_eq (fst (#SSupp def) $ fst (#VVr def), mk_bot (#aT def))) (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt (@{thms HOL.simp_thms(6) not_True_eq_False empty_def[symmetric]} @ [snd (#SSupp def)])), - rtac ctxt TrueI - ]); - val bound = Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop (#mk_SSupp_bound def (fst (#VVr def)))) (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt [empty]), - REPEAT_DETERM o resolve_tac ctxt (@{thms emp_bound cmin_greater} @ card_thms) - ]); - in (empty, bound) end - ))) defss); - - val VVr_injss = map2 (fn quot => map (Option.map (fn def => - let - val (a, b) = (Free ("a", #aT def), Free ("b", #aT def)); - val ax = #axioms def; - in Goal.prove_sorry lthy ["a", "b"] [] (Logic.mk_implies ( - mk_Trueprop_eq (fst (#VVr def) $ a, fst (#VVr def) $ b), - mk_Trueprop_eq (a, b) - )) (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt (@{thms comp_def} @ [snd (#VVr def)])), - rtac ctxt (#eta_inj ax), - dtac ctxt (iffD1 OF [#inject quot]), - REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], - dtac ctxt @{thm trans[rotated]}, - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt (Local_Defs.unfold0 ctxt @{thms comp_def} (fun_cong OF [#eta_natural ax])), - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), - rtac ctxt @{thm arg_cong[OF id_apply]}, - assume_tac ctxt - ]) end - ))) (#quotient_fps fp_res) defss; - - val ((fs, gs), _) = lthy - |> mk_Frees "f" (map (fn a => a --> a) vars) - ||>> mk_Frees "g" (map (fn a => a --> a) vars); - fun mk_supp_bound' f = mk_ordLess (mk_card_of (mk_supp f)) card; - val f_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) fs; - val f_prems' = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound' f]) fs; - - val permute_VVrss = map2 (fn quot => map_index (fn (i, opt) => Option.map (fn def => - let - val a = Free ("a", #aT def); - val VVr = fst (#VVr def) - val goal = mk_Trueprop_eq ( - Term.list_comb (#permute quot, fs) $ (VVr $ a), - VVr $ (nth fs i $ a) - ); - in Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ - K (unfold_thms_tac ctxt [snd (#VVr def), @{thm comp_def}]), - rtac ctxt trans, - rtac ctxt (#permute_ctor quot), - REPEAT_DETERM o resolve_tac ctxt (prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}), - rtac ctxt (infer_instantiate' ctxt [NONE, NONE, SOME (Thm.cterm_of ctxt (#ctor quot))] arg_cong), - rtac ctxt (Local_Defs.unfold0 ctxt @{thms comp_def} (fun_cong OF [#eta_natural (#axioms def)])), - REPEAT_DETERM o resolve_tac ctxt (prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}) - ]) end - ) opt)) (#quotient_fps fp_res) defss; - - val mrbnfs = #pre_mrbnfs fp_res; - val cmin_UNIV = foldl1 mk_cmin (map (mk_card_of o HOLogic.mk_UNIV) vars); - val Cinfinite_card = Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop (HOLogic.mk_conj ( - mk_cinfinite cmin_UNIV, mk_Card_order cmin_UNIV - ))) (fn {context=ctxt, ...} => EVERY1 [ - REPEAT_DETERM o resolve_tac ctxt (MRBNF_Def.UNIV_cinfinite_of_mrbnf (hd mrbnfs) :: @{thms cmin_Cinfinite conjI card_of_Card_order}) - ]); - val regularCard_card = Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop (mk_regularCard cmin_UNIV)) (fn {context=ctxt, ...} => EVERY1 [ - REPEAT_DETERM o resolve_tac ctxt (#var_regular (MRBNF_Def.class_thms_of_mrbnf (hd mrbnfs)) :: MRBNF_Def.UNIV_cinfinite_of_mrbnf (hd mrbnfs) :: @{thms cmin_regularCard cmin_Cinfinite conjI card_of_Card_order}) - ]); - val Un_bound = @{thm Un_Cinfinite_ordLess} OF [@{thm _}, @{thm _}, Cinfinite_card]; - val UNION_bound = @{thm regularCard_UNION_bound} OF [Cinfinite_card, regularCard_card]; - - val SSupp_compss = @{map 3} (fn quotient => @{map 3} (fn f => fn permute_VVr => Option.map (fn def => - let - val g = Free ("g", #aT def --> #T quotient); - val goal = HOLogic.mk_Trueprop (mk_leq - (fst (#SSupp def) $ HOLogic.mk_comp (g, f)) - (mk_Un (fst (#SSupp def) $ g, mk_supp f)) - ); - val SSupp_comp_subset = Goal.prove_sorry lthy (names [f, g]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt (@{thms supp_def subset_iff mem_Collect_eq Un_iff comp_def} @ [snd (#SSupp def)])), - rtac ctxt allI, - rtac ctxt impI, - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - let val t = Thm.term_of (snd (hd params)) - in rtac ctxt (infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (HOLogic.mk_eq (f $ t, t)))] @{thm case_split}) 1 end - ) ctxt, - dtac ctxt @{thm iffD1[OF arg_cong2[OF _ refl, of _ _ "(\)"], rotated]}, - rtac ctxt (mk_arg_cong lthy 1 g), - assume_tac ctxt, - rtac ctxt disjI1, - assume_tac ctxt, - rtac ctxt disjI2, - assume_tac ctxt - ]); - - val SSupp_comp_bound = Goal.prove_sorry lthy (names [f, g]) (map HOLogic.mk_Trueprop [ - #mk_SSupp_bound def g, mk_supp_bound' f - ]) (HOLogic.mk_Trueprop (#mk_SSupp_bound def (HOLogic.mk_comp (g, f)))) (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt @{thm ordLeq_ordLess_trans[OF card_of_mono1]}, - rtac ctxt SSupp_comp_subset, - rtac ctxt Un_bound, - REPEAT_DETERM o resolve_tac ctxt prems - ]); - - val SSupp_comp_rename_subset = Goal.prove_sorry lthy (names (fs @ [g])) f_prems - (HOLogic.mk_Trueprop (mk_leq - (fst (#SSupp def) $ HOLogic.mk_comp (Term.list_comb (#permute quotient, fs), g)) - (mk_Un (fst (#SSupp def) $ g, mk_supp f)) - )) (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt @{thm subsetI}, - K (unfold_thms_tac ctxt (@{thms supp_def mem_Collect_eq Un_iff comp_def} @ [snd (#SSupp def)])), - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - let val x = Thm.term_of (snd (hd params)) - in rtac ctxt (infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (HOLogic.mk_eq (g $ x, fst (#VVr def) $ x)))] @{thm case_split}) 1 end - ) ctxt, - dtac ctxt @{thm iffD1[OF arg_cong2[OF _ refl, of _ _ "(\)"], rotated]}, - rtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quotient, fs))), - assume_tac ctxt, - K (unfold_thms_tac ctxt [the permute_VVr OF prems]), - rtac ctxt disjI2, - etac ctxt @{thm contrapos_nn}, - rtac ctxt (mk_arg_cong lthy 1 (fst (#VVr def))), - assume_tac ctxt, - rtac ctxt disjI1, - assume_tac ctxt - ]); - - val SSupp_comp_rename_bound = Goal.prove_sorry lthy (names (fs @ [g])) ( - [HOLogic.mk_Trueprop (#mk_SSupp_bound def g)] @ f_prems' - ) (HOLogic.mk_Trueprop (#mk_SSupp_bound def (HOLogic.mk_comp ( - Term.list_comb (#permute quotient, fs), g - )))) (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt @{thm ordLeq_ordLess_trans[OF card_of_mono1]}, - rtac ctxt SSupp_comp_rename_subset, - REPEAT_DETERM o resolve_tac ctxt (Un_bound :: prems @ card_thms @ @{thms ordLess_ordLeq_trans}) - ]); - in { - SSupp_comp_subset = SSupp_comp_subset, - SSupp_comp_bound = SSupp_comp_bound, - SSupp_comp_rename_subset = SSupp_comp_rename_subset, - SSupp_comp_rename_bound = SSupp_comp_rename_bound - } end - )) fs) (#quotient_fps fp_res) permute_VVrss defss; - - val g_prems' = maps (fn g => map HOLogic.mk_Trueprop [mk_bij g, mk_supp_bound' g]) gs; - - val some_defss = map (map_filter I) defss; - - val SSupp_naturalss = @{map 3} (fn model => fn quotient => map2 (fn f => Option.map (fn def => - let - val h = Free ("h", #SSfun def); - val goal = mk_Trueprop_eq ( - fst (#SSupp def) $ (HOLogic.mk_comp ( - HOLogic.mk_comp (Term.list_comb (#permute quotient, fs), h), - mk_inv f - )), - mk_image f $ (fst (#SSupp def) $ h) - ); - val inv_simp = infer_instantiate' lthy [SOME (Thm.cterm_of lthy f)] @{thm inv_simp2}; - val eta_naturals = map (fn thm => Local_Defs.unfold0 lthy @{thms comp_def} ( - fun_cong OF [thm] - )) (map_filter (Option.map (#eta_natural o snd)) (#etas model)); - in Goal.prove_sorry lthy (names (fs @ [h])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ - K (unfold_thms_tac ctxt [snd (#SSupp def)]), - rtac ctxt @{thm iffD2[OF set_eq_iff]}, - rtac ctxt allI, - rtac ctxt iffI, - K (unfold_thms_tac ctxt (snd (#VVr def) :: @{thms mem_Collect_eq comp_def image_Collect})), - etac ctxt @{thm contrapos_np}, - dtac ctxt @{thm Meson.not_exD}, - etac ctxt allE, - dtac ctxt @{thm iffD1[OF de_Morgan_conj]}, - etac ctxt disjE, - EqSubst.eqsubst_asm_tac ctxt [0] [inv_simp], - resolve_tac ctxt prems, - etac ctxt notE, - rtac ctxt refl, - dtac ctxt @{thm notnotD}, - dtac ctxt sym, - etac ctxt @{thm subst}, - rtac ctxt trans, - rtac ctxt (#permute_ctor quotient), - REPEAT_DETERM o resolve_tac ctxt prems, - EqSubst.eqsubst_tac ctxt [0] eta_naturals, - REPEAT_DETERM o resolve_tac ctxt prems, - EqSubst.eqsubst_tac ctxt [0] [inv_simp], - resolve_tac ctxt prems, - rtac ctxt refl, - etac ctxt exE, - etac ctxt conjE, - hyp_subst_tac ctxt, - EqSubst.eqsubst_tac ctxt [0] @{thms inv_simp1}, - resolve_tac ctxt prems, - etac ctxt @{thm contrapos_nn}, - dtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quotient, map mk_inv fs))), - EqSubst.eqsubst_asm_tac ctxt [0] [#permute_comp quotient], - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound bij_imp_bij_inv} @ prems), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_asm_tac ctxt [0] @{thms inv_o_simp1}, - resolve_tac ctxt prems - ], - K (unfold_thms_tac ctxt [#permute_id quotient]), - etac ctxt trans, - rtac ctxt trans, - rtac ctxt (#permute_ctor quotient), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound bij_imp_bij_inv} @ prems), - EqSubst.eqsubst_tac ctxt [0] eta_naturals, - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound bij_imp_bij_inv} @ prems), - EqSubst.eqsubst_tac ctxt [0] @{thms inv_simp1}, - resolve_tac ctxt prems, - rtac ctxt refl - ]) end - )) fs) models (#quotient_fps fp_res) defss; - - val IImsupp_VVrss = map2 (fn quotient => @{map 3} (fn f => fn i => Option.map (fn def => - let - val a = Free ("a", #aT def); - val g = Free ("g", #aT def --> #T quotient); - val IImsupp = nth (#IImsupps def) i; - val goal = Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (f $ a, a))), - Logic.mk_implies ( - HOLogic.mk_Trueprop (mk_int_empty (mk_imsupp f, fst IImsupp $ g)), - mk_Trueprop_eq (g $ a, fst (#VVr def) $ a) - ) - ); - in Goal.prove_sorry lthy (names [f, g, a]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt (@{thms imsupp_def supp_def} @ [snd (#SSupp def), snd IImsupp])), - dtac ctxt @{thm iffD1[OF disjoint_iff]}, - etac ctxt allE, - etac ctxt impE, - rtac ctxt @{thm UnI1}, - rtac ctxt @{thm CollectI}, - assume_tac ctxt, - K (unfold_thms_tac ctxt @{thms Un_iff de_Morgan_disj mem_Collect_eq not_not}), - etac ctxt conjE, - assume_tac ctxt - ]) end - )) fs (0 upto nvars - 1)) (#quotient_fps fp_res) defss; - - val IImsupp_imsupp_permute_commutess = @{map 4} (fn quotient => @{map 4} (fn i => fn permute_VVr => fn IImsupp_VVr => Option.map (fn def => - let - val g = Free ("g", #aT def --> #T quotient); - val int_empties = map2 (fn f => fn IImsupp => - HOLogic.mk_Trueprop (mk_int_empty (mk_imsupp f, fst IImsupp $ g)) - ) fs (#IImsupps def); - val goal = mk_Trueprop_eq ( - HOLogic.mk_comp (Term.list_comb (#permute quotient, fs), g), - HOLogic.mk_comp (g, nth fs i) - ); - in Goal.prove_sorry lthy (names (fs @ [g])) (f_prems @ int_empties) goal (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt ext, - K (unfold_thms_tac ctxt @{thms comp_def}), - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - let - val a = Thm.term_of (snd (hd params)); - fun case_split t = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt t)] @{thm case_split}; - in EVERY1 [ - rtac ctxt (case_split (HOLogic.mk_eq (nth fs i $ a, a))), - rtac ctxt (case_split (HOLogic.mk_eq (g $ a, fst (#VVr def) $ a))) - ] end - ) ctxt, - rtac ctxt trans, - rtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quotient, fs))), - assume_tac ctxt, - rtac ctxt trans, - rtac ctxt (the permute_VVr), - REPEAT_DETERM o resolve_tac ctxt prems, - rtac ctxt trans, - rtac ctxt (mk_arg_cong lthy 1 (fst (#VVr def))), - assume_tac ctxt, - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt (mk_arg_cong lthy 1 g), - assume_tac ctxt, - assume_tac ctxt, - rtac ctxt trans, - rtac ctxt (#permute_cong_id (#inner quotient)), - REPEAT_DETERM o resolve_tac ctxt (prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}), - REPEAT_DETERM o EVERY' [ - rtac ctxt @{thm id_onD[rotated]}, - assume_tac ctxt, - rtac ctxt @{thm imsupp_id_on}, - rtac ctxt @{thm Int_subset_empty2}, - resolve_tac ctxt prems, - SELECT_GOAL (unfold_thms_tac ctxt (snd (#SSupp def) :: map snd (#IImsupps def))), - rtac ctxt @{thm subsetI}, - TRY o rtac ctxt @{thm UnI2}, - rtac ctxt @{thm UN_I[rotated]}, - K (unfold_thms_tac ctxt @{thms comp_def}), - assume_tac ctxt, - rtac ctxt @{thm CollectI}, - assume_tac ctxt - ], - rtac ctxt (mk_arg_cong lthy 1 g), - rtac ctxt sym, - assume_tac ctxt, - rtac ctxt trans, - rtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quotient, fs))), - defer_tac, - rtac ctxt trans, - K (prefer_tac 3), - etac ctxt (the IImsupp_VVr), - resolve_tac ctxt prems, - rtac ctxt (the permute_VVr), - REPEAT_DETERM o resolve_tac ctxt prems, - rtac ctxt sym, - rtac ctxt (the IImsupp_VVr), - dtac ctxt @{thm bij_not_eq_twice[rotated]}, - resolve_tac ctxt prems, - assume_tac ctxt, - resolve_tac ctxt prems - ]) end - )) (0 upto nvars - 1)) (#quotient_fps fp_res) permute_VVrss IImsupp_VVrss defss; - - val asVVr_VVrss = map2 (map2 (fn VVr_inj => Option.map (fn def => - let val a = Free ("a", #aT def) - in Goal.prove_sorry lthy (names [a]) [] - (mk_Trueprop_eq (fst (#asVVr def) $ (fst (#VVr def) $ a), a)) - (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt [snd (#asVVr def), snd (#isVVr def)]), - rtac ctxt trans, - rtac ctxt @{thm if_P}, - rtac ctxt exI, - rtac ctxt refl, - rtac ctxt @{thm some_equality}, - rtac ctxt refl, - rtac ctxt (the VVr_inj), - assume_tac ctxt - ]) end - ))) VVr_injss defss; - - val isVVr_renamess = @{map 3} (fn quotient => map2 (fn permute_VVr => Option.map (fn def => - let - val x = Free ("x", #T quotient); - val goal = mk_Trueprop_eq ( - fst (#isVVr def) $ (Term.list_comb (#permute quotient, fs) $ x), - fst (#isVVr def) $ x - ); - in Goal.prove_sorry lthy (names (fs @ [x])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ - K (unfold_thms_tac ctxt [snd (#isVVr def)]), - rtac ctxt iffI, - etac ctxt exE, - dtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quotient, map mk_inv fs))), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_asm_tac ctxt [0] [@{thm inv_o_simp1}, #permute_comp quotient, the permute_VVr], - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound bij_imp_bij_inv} @ prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}) - ], - K (unfold_thms_tac ctxt [#permute_id quotient]), - rtac ctxt exI, - assume_tac ctxt, - etac ctxt exE, - hyp_subst_tac ctxt, - EqSubst.eqsubst_tac ctxt [0] [the permute_VVr], - REPEAT_DETERM o resolve_tac ctxt prems, - rtac ctxt exI, - rtac ctxt refl - ]) end - ))) (#quotient_fps fp_res) permute_VVrss defss; - - val some_defs = flat some_defss; - - val npassive = length plives + length pfrees + length pbounds; - val var_types = MRBNF_Def.var_types_of_mrbnf (hd mrbnfs); - val free = MRBNF_Def.free_of_mrbnf (hd mrbnfs); - val bound = MRBNF_Def.bound_of_mrbnf (hd mrbnfs); - val live = MRBNF_Def.live_of_mrbnf (hd mrbnfs); - val n = free + bound + live; - - val setss = map (fn mrbnf => - MRBNF_Def.mk_sets_of_mrbnf (replicate n (MRBNF_Def.deads_of_mrbnf mrbnf)) - (replicate n (plives @ flat (map2 replicate (#rec_vars fp_res) (map #T (#quotient_fps fp_res))))) - (replicate n (pbounds @ vars)) (replicate n (vars @ pfrees @ bfrees)) mrbnf - ) mrbnfs; - val preTs = map (fn mrbnf => - MRBNF_Def.mk_T_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) - (plives @ flat (map2 replicate (#rec_vars fp_res) (map #T (#quotient_fps fp_res)))) - (pbounds @ vars) (vars @ pfrees @ bfrees) mrbnf - ) mrbnfs; - - val eta_naturalss' = map (fn model => - map (Option.map (fn eta => Local_Defs.unfold0 lthy @{thms comp_def} ( - fun_cong OF [#eta_natural (snd eta)] - ))) (#etas model) - ) models; - - val eta_set_emptiess = map2 (fn mrbnf => map (Option.map (fn def => - let - val args = (snd o dest_Type o snd o dest_funT o fastype_of o #eta) def; - val (live_args, bound_args, free_args) = fold_rev ( - fn (MRBNF_Def.Live_Var, x) => (fn (a, b, c) => (x::a, b, c)) - | (MRBNF_Def.Bound_Var, x) => (fn (a, b, c) => (a, x::b, c)) - | (MRBNF_Def.Free_Var, x) => (fn (a, b, c) => (a, b, x::c)) - ) (var_types ~~ args) ([], [], []); - val sets = MRBNF_Def.mk_sets_of_mrbnf (replicate n (MRBNF_Def.deads_of_mrbnf mrbnf)) - (replicate n live_args) (replicate n bound_args) (replicate n free_args) mrbnf; - val sets = take nvars sets @ drop (nvars + npassive) sets; - val var_types = replicate nvars MRBNF_Def.Free_Var @ replicate nvars MRBNF_Def.Bound_Var - @ replicate (length (#bfree_vars fp_res)) MRBNF_Def.Free_Var - @ replicate (foldr1 (op+) (#rec_vars fp_res)) MRBNF_Def.Live_Var; - val (xs1, xs2) = chop nvars (var_types ~~ sets); - val sets' = filter (fn (_, set) => #aT def <> HOLogic.dest_setT (range_type (fastype_of set))) xs1 @ xs2; - val a = Free ("a", #aT def); - val eta_natural' = Local_Defs.unfold0 lthy @{thms comp_def} (fun_cong OF [#eta_natural (#axioms def)]); - in map (fn (ty, set) => - let - val infinite_UNIV = @{thm cinfinite_imp_infinite} OF [MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf]; - val T = (HOLogic.dest_setT o snd o dest_funT o fastype_of) set; - val goal = mk_Trueprop_eq (set $ (#eta def $ a), mk_bot T) - in Goal.prove_sorry lthy (names [a]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - rtac ctxt @{thm iffD2[OF set_eq_iff]}, - rtac ctxt allI, - K (unfold_thms_tac ctxt @{thms empty_iff}), - rtac ctxt iffI, - if ty <> MRBNF_Def.Live_Var then EVERY' [ - rtac ctxt (infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (set $ (#eta def $ a)))] @{thm exE[OF exists_fresh]}), - resolve_tac ctxt (MRBNF_Def.set_bd_UNIV_of_mrbnf mrbnf), - dtac ctxt @{thm iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]}, - rtac ctxt (mk_arg_cong lthy 1 set), - K (prefer_tac 2), - EqSubst.eqsubst_asm_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), - K (prefer_tac (free + 2 * bound + 1)), - etac ctxt @{thm swap_fresh}, - assume_tac ctxt, - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_swap_bound bij_swap} @ [infinite_UNIV]), - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt eta_natural', - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_swap_bound bij_swap} @ [infinite_UNIV]), - K (unfold_thms_tac ctxt @{thms id_def}), - rtac ctxt refl - ] else EVERY' [ - dtac ctxt @{thm image_const}, - dtac ctxt @{thm iffD1[OF all_cong1, rotated]}, - rtac ctxt sym, - rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, - resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), - REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, - EqSubst.eqsubst_asm_tac ctxt [0] [eta_natural'], - REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, - K (unfold_thms_tac ctxt @{thms id_def}), - dtac ctxt @{thm forall_in_eq_UNIV}, - dtac ctxt @{thm trans[symmetric]}, - rtac ctxt (@{thm conjunct1[OF card_order_on_Card_order]} OF [MRBNF_Def.bd_card_order_of_mrbnf mrbnf]), - dtac ctxt @{thm card_of_ordIso_subst}, - dtac ctxt @{thm ordIso_symmetric}, - dtac ctxt @{thm ordIso_transitive}, - rtac ctxt @{thm ordIso_symmetric}, - rtac ctxt @{thm iffD1[OF Card_order_iff_ordIso_card_of]}, - rtac ctxt (@{thm conjunct2[OF card_order_on_Card_order]} OF [MRBNF_Def.bd_card_order_of_mrbnf mrbnf]), - etac ctxt @{thm ordIso_ordLess_False}, - resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf mrbnf) - ], - etac ctxt FalseE - ]) end - ) sets' end - ))) (#pre_mrbnfs fp_res) defss; - - val (_, lthy) = Local_Theory.begin_nested lthy; - - val (rhos, _) = no_defs_lthy - |> mk_Frees "\" (map (domain_type o fastype_of o fst o #SSupp) some_defs); - - val lthy = snd (Proof_Context.add_fixes (map (fn Free (x, T) => (Binding.name x, SOME T, NoSyn)) rhos) lthy); - - val (_, lthy) = Element.activate_i ( - Element.Assumes (map (fn (b, ts) => ((Binding.concealed (Binding.name b), []), map (rpair []) ts)) [ - ("f_prems", map2 (fn def => HOLogic.mk_Trueprop o #mk_SSupp_bound def) some_defs rhos) - ]) - ) lthy; - - val rho_prems = Proof_Context.get_thms lthy "f_prems"; - - val rhoss = fst (fold_map ( - fold_map (fn NONE => (fn xs => (NONE, xs)) | SOME _ => fn xs => (SOME (hd xs), tl xs)) - ) defss rhos); - - val avoiding_sets = map (fn i => - foldl1 mk_Un (flat (map2 (@{map_filter 2} (fn NONE => K NONE | SOME def => fn rho => - SOME (fst (nth (#IImsupps def) i) $ the rho) - )) defss rhoss)) - ) (0 upto nvars - 1); - - val Uctors = @{map 4} (fn defs => fn rhos => fn mrbnf => fn quot => - let - val ctor = #ctor quot; - val (name, (args, rec_args)) = dest_Type (fst (dest_funT (fastype_of ctor))) - |> apsnd (chop (nvars * 2 + length pfrees + length plives + length pbounds + length (#bfree_vars fp_res))); - val rec_args' = map (fn T => HOLogic.mk_prodT (T, T)) rec_args; - val args = args @ rec_args'; - - val free_ids = map HOLogic.id_const (vars @ pfrees @ bfrees); - val bound_ids = map HOLogic.id_const (pbounds @ vars); - - val deads = MRBNF_Def.deads_of_mrbnf mrbnf; - val map_id_fst = ctor $ (MRBNF_Def.mk_map_comb_of_mrbnf deads - (map HOLogic.id_const plives @ map fst_const rec_args') - bound_ids free_ids mrbnf $ Bound 0); - - in Term.abs ("F", Type (name, args)) ( - @{fold 2} (fn def => fn rho => - BNF_FP_Util.mk_If (fst (#isVVr def) $ map_id_fst) (rho $ (fst (#asVVr def) $ map_id_fst)) - ) (rev (map_filter I defs)) (rev (map_filter I rhos)) (ctor $ (MRBNF_Def.mk_map_comb_of_mrbnf deads - (map HOLogic.id_const plives @ map snd_const rec_args') bound_ids free_ids mrbnf $ Bound 0)) - ) end - ) defss rhoss (#pre_mrbnfs fp_res) (#quotient_fps fp_res); - - val state = Interpretation.interpretation ([ (QREC_cmin_fixed_name, - (("tvsubst", true), (Expression.Positional (map SOME ( - avoiding_sets @ Uctors - )), [])) - )], []) lthy; - - val lthy = Proof.global_terminal_proof ((Method.Basic (fn ctxt => SIMPLE_METHOD (EVERY1 [ - rtac ctxt (the (fst (Locale.intros_of (Proof_Context.theory_of lthy) QREC_cmin_fixed_name))), - REPEAT_DETERM o SELECT_GOAL (EVERY1 [ - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thm comp_def} :: maps (map snd o #IImsupps) some_defs)), - REPEAT_DETERM1 o FIRST' [ - assume_tac ctxt, - resolve_tac ctxt ([Un_bound, UNION_bound] @ rho_prems - @ @{thms cmin_greater cmin_Card_order card_of_Card_order} - @ maps #card_of_FVars_bound_UNIVs (#quotient_fps fp_res) - ) - ] - ]), - EVERY' (@{map 5} (fn mrbnf => fn quot => fn isVVr_renames => fn defs => fn IImsupp_commutes => EVERY' [ - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ card_thms)) - ], - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - Local_Defs.unfold0_tac ctxt (@{thms Product_Type.fst_comp_map_prod Product_Type.snd_comp_map_prod comp_assoc case_prod_beta prod.collapse} - @ map (fn f => infer_instantiate' ctxt [SOME (snd f)] @{thm id_o_commute}) (take nvars params) - ) - ) ctxt, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] ([ - MRBNF_Def.map_comp_of_mrbnf mrbnf RS sym, - #permute_ctor quot RS sym - ] @ map_filter I isVVr_renames), - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ card_thms)) - ], - EVERY' (map_filter (Option.map (fn def => EVERY' [ - rtac ctxt @{thm case_split}, - EqSubst.eqsubst_tac ctxt [0] @{thms if_P}, - assume_tac ctxt, - K (Local_Defs.unfold0_tac ctxt @{thms if_P if_not_P}), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isVVr def)]), - etac ctxt exE, - rotate_tac ~1, - etac ctxt @{thm subst[OF sym]}, - EqSubst.eqsubst_tac ctxt [0] (map_filter I (flat permute_VVrss)), - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt card_thms), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter I (flat asVVr_VVrss))), - resolve_tac ctxt (map_filter (Option.map (fn thm => Local_Defs.unfold0 ctxt @{thms comp_def} (thm RS fun_cong))) IImsupp_commutes), - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt card_thms), - REPEAT_DETERM o EVERY' [ - etac ctxt @{thm Int_subset_empty2}, - rtac ctxt @{thm subsetI}, - REPEAT_DETERM o (eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' rtac ctxt @{thm UnI1}) - ] - ])) defs), - rtac ctxt refl - ]) mrbnfs (#quotient_fps fp_res) isVVr_renamess defss IImsupp_imsupp_permute_commutess), - EVERY' (@{map 4} (fn mrbnf => fn quot => fn defs => fn rhos' => REPEAT_DETERM o Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ - EVERY' (@{map_filter 2} (fn rho => Option.map (fn def => EVERY' [ - rtac ctxt @{thm case_split}, - EqSubst.eqsubst_tac ctxt [0] @{thms if_P}, - assume_tac ctxt, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isVVr def)]), - etac ctxt exE, - etac ctxt @{thm subst[OF sym]}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter I (flat asVVr_VVrss))), - rtac ctxt @{thm case_split[of "_ = _"]}, - rtac ctxt @{thm iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]}, - resolve_tac ctxt (map (mk_arg_cong no_defs_lthy 1) (#FVarss quot)), - assume_tac ctxt, - rtac ctxt @{thm Un_upper1}, - rtac ctxt @{thm subsetI}, - rtac ctxt @{thm UnI2}, - rtac ctxt (BNF_Util.mk_UnIN (length some_defs) (find_index (curry (op=) (the rho)) rhos + 1)), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (snd (#SSupp def) :: map snd (#IImsupps def))), - TRY o rtac ctxt @{thm UnI2}, - rtac ctxt @{thm UN_I}, - rtac ctxt @{thm CollectI}, - assume_tac ctxt, - rtac ctxt @{thm iffD2[OF arg_cong2[OF refl comp_apply, of "(\)"]]}, - assume_tac ctxt, - K (Local_Defs.unfold0_tac ctxt @{thms if_not_P}) - ])) rhos' defs), - K (Local_Defs.unfold0_tac ctxt (#FVars_ctors quot)), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), - REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} - ], - REPEAT_DETERM_N (length (map_filter I defs)) o etac ctxt @{thm thin_rl}, - K (Local_Defs.unfold0_tac ctxt @{thms image_id image_comp comp_def}), - REPEAT_DETERM o rtac ctxt @{thm Un_mono'}, - REPEAT_DETERM o rtac ctxt @{thm Un_upper1}, - REPEAT_DETERM o EVERY' [ - TRY o EVERY' [ - rtac ctxt @{thm iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]}, - rtac ctxt @{thm Diff_Un_disjunct}, - resolve_tac ctxt prems, - rtac ctxt @{thm Diff_mono[OF _ subset_refl]} - ], - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_extend_simps(2)}), - rtac ctxt @{thm subset_If}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_empty'}), - rtac ctxt @{thm empty_subsetI}, - rtac ctxt @{thm UN_mono[OF subset_refl]}, - resolve_tac ctxt prems, - K (Local_Defs.unfold0_tac ctxt @{thms prod.collapse}), - eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' assume_tac ctxt - ] - ]) ctxt) mrbnfs (#quotient_fps fp_res) defss rhoss) - ])), Position.no_range), NONE) state; - - val (tvsubsts, lthy) = @{fold_map 2} (fn model => - mk_def_t true Binding.empty I (Binding.name_of (#binding model)) 0 - ) models (MRBNF_Recursor.get_RECs true "tvsubst" lthy) lthy; - - val tvsubst_not_isVVrs = @{map 5} (fn i => fn mrbnf => fn quotient => fn sets => fn preT => - let - val x = Free ("x", preT); - val bound_sets = drop (length pbounds) ( - map_filter (fn (MRBNF_Def.Bound_Var, x) => SOME x | _ => NONE) (var_types ~~ sets) - ); - val int_empty_prems = map2 (fn bset => fn i => HOLogic.mk_Trueprop ( - mk_int_empty (bset $ x, foldl1 mk_Un (map2 (fn f => fn def => - fst (nth (#IImsupps def) i) $ f - ) rhos some_defs)) - )) bound_sets (0 upto nvars - 1); - val VVr_prems = map (fn def => - HOLogic.mk_Trueprop (HOLogic.mk_not (fst (#isVVr def) $ (#ctor quotient $ x))) - ) (nth some_defss i); - val prems = int_empty_prems @ [HOLogic.mk_Trueprop (fst (#noclash quotient) $ x)] @ VVr_prems; - val ids = map HOLogic.id_const; - val tvsubst_ts = map fst tvsubsts; - val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) - (ids plives @ flat (map2 replicate (#rec_vars fp_res) tvsubst_ts)) - (ids (pbounds @ vars)) (ids (vars @ pfrees @ bfrees)) mrbnf; - val goal = mk_Trueprop_eq (nth tvsubst_ts i $ (#ctor quotient $ x), #ctor quotient $ (map_t $ x)); - in Goal.prove_sorry lthy (names [x]) prems goal (fn {context=ctxt, prems} => EVERY1 [ - K (unfold_thms_tac ctxt (map snd tvsubsts)), - rtac ctxt trans, - resolve_tac ctxt (Proof_Context.get_thms lthy "tvsubst.REC_ctor"), - REPEAT_DETERM o resolve_tac ctxt prems, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], - REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} - ], - K (Local_Defs.unfold0_tac ctxt ( - @{thms id_o o_id comp_def[of fst] comp_def[of snd] snd_conv fst_conv id_def[symmetric]} - @ [MRBNF_Def.map_id_of_mrbnf mrbnf] - )), - REPEAT_DETERM o (rtac ctxt @{thm trans[OF if_not_P]} THEN' resolve_tac ctxt prems), - rtac ctxt refl - ]) end - ) (0 upto length models - 1) (#pre_mrbnfs fp_res) (#quotient_fps fp_res) setss preTs; - - val tvsubst_VVrss = @{map 9} (fn mrbnf => fn model => fn tvsubst => fn quotient => fn defs => fn rhos => fn eta_set_empties => fn asVVr_VVrs => fn sets => - @{map 7} (fn i => fn set => fn eta => fn f => fn set_empties => fn asVVr_VVr => Option.map (fn def => - let val a = Free ("a", #aT def); - in Goal.prove_sorry lthy (names [a]) [] ( - mk_Trueprop_eq (fst tvsubst $ (fst (#VVr def) $ a), the f $ a) - ) (fn {context=ctxt, ...} => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt [snd tvsubst, snd (#VVr def), @{thm comp_def}]), - rtac ctxt trans, - resolve_tac ctxt (Proof_Context.get_thms lthy "tvsubst.REC_ctor"), - K (Local_Defs.unfold0_tac ctxt (snd (#noclash quotient) :: the set_empties)), - REPEAT_DETERM o resolve_tac ctxt @{thms Int_empty_left conjI}, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], - REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} - ], - K (Local_Defs.unfold0_tac ctxt ( - @{thms id_o o_id comp_def[of fst] comp_def[of snd] snd_conv fst_conv id_def[symmetric]} - @ [MRBNF_Def.map_id_of_mrbnf mrbnf] - )), - REPEAT_DETERM_N i o EVERY' [ - rtac ctxt @{thm trans[OF if_not_P]}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ [#inject quotient] - @ maps (fn def => [snd (#isVVr def), snd (#VVr def)]) some_defs - )), - rtac ctxt @{thm iffD2[OF not_ex]}, - rtac ctxt allI, - rtac ctxt notI, - REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], - EqSubst.eqsubst_asm_tac ctxt [0] (map_filter I (flat eta_naturalss')), - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_apply}), - dtac ctxt (mk_arg_cong no_defs_lthy 1 set), - K (unfold_thms_tac ctxt (#eta_free (snd (the eta)) :: flat (maps (map_filter I) eta_set_emptiess))), - rotate_tac ~1, - etac ctxt @{thm contrapos_pp}, - rtac ctxt @{thm insert_not_empty} - ], - rtac ctxt @{thm trans[OF if_P]}, - K (Local_Defs.unfold_tac ctxt ([snd (#isVVr def), Local_Defs.unfold0 ctxt @{thms comp_def} ( - @{thm meta_eq_to_obj_eq} OF [snd (#VVr def)] RS fun_cong - ) RS sym] @ map_filter I (flat asVVr_VVrss))), - rtac ctxt exI, - rtac ctxt refl, - rtac ctxt refl - ]) end - )) (0 upto nvars - 1) (take nvars sets) (#etas model) rhos eta_set_empties asVVr_VVrs defs - ) mrbnfs models tvsubsts (#quotient_fps fp_res) defss rhoss eta_set_emptiess asVVr_VVrss setss; - - val (lthy, old_lthy) = `Local_Theory.end_nested lthy; - val phi = Proof_Context.export_morphism old_lthy lthy; - - val tvsubsts = - let - val tvsubst_new = Morphism.term phi (fst (hd tvsubsts)); - val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) - (fastype_of tvsubst_new, fastype_of (fst (hd tvsubsts))) Vartab.empty - fun morph t = ( - Envir.subst_term (tyenv, Vartab.empty) (Morphism.term phi (fst t)), - Morphism.thm phi (snd t) - ) - in map (map_prod (fst o Term.strip_comb) I o morph) tvsubsts end; - - val tvsubst_not_isVVrs = map (Morphism.thm phi) tvsubst_not_isVVrs; - val tvsubst_VVrss = map (map (Option.map (Morphism.thm phi))) tvsubst_VVrss; - - val FVars_VVrss = map2 (fn quotient => map (Option.map (fn def => map (fn FVars => - let - val a = Free ("a", #aT def); - val T = HOLogic.dest_setT (range_type (fastype_of FVars)); - val set = if #aT def = T then mk_singleton a else Const (@{const_name bot}, HOLogic.mk_setT T) - in Goal.prove_sorry lthy (names [a]) [] (mk_Trueprop_eq (FVars $ (fst (#VVr def) $ a), set)) (fn {context=ctxt,...} => - unfold_thms_tac ctxt (@{thms comp_def UN_empty Diff_empty Un_empty_right Un_empty_left empty_Diff} - @ #FVars_ctors quotient @ [snd (#VVr def)] @ flat (maps (map_filter I) eta_set_emptiess) - ) THEN resolve_tac ctxt [refl, #eta_free (#axioms def)] 1 - ) end - ) (#FVarss quotient)))) (#quotient_fps fp_res) defss; - - val bfrees = map (nth vars) (#bfree_vars fp_res); - val f'_prems = map2 (fn h => fn def => HOLogic.mk_Trueprop (#mk_SSupp_bound def h)) rhos some_defs; - - val not_isVVr_freess = @{map 4} (fn sets => fn quotient => fn preT => map2 (fn fset => Option.map (fn def => - let - val x = Free ("x", preT); - val goal = Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_not (fst (#isVVr def) $ (#ctor quotient $ x))), - mk_Trueprop_eq (fset $ x, mk_bot (#aT def)) - ) - in Goal.prove_sorry lthy (names [x]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - rtac ctxt (#eta_compl_free (#axioms def)), - K (unfold_thms_tac ctxt (@{thms image_iff Set.bex_simps not_ex comp_def} @ [snd (#isVVr def), snd (#VVr def)])), - rtac ctxt allI, - etac ctxt allE, - etac ctxt @{thm contrapos_nn}, - hyp_subst_tac ctxt, - rtac ctxt refl - ]) end - )) (take nvars sets)) setss (#quotient_fps fp_res) preTs defss; - - val in_IImsuppsss = map2 (fn quotient => map (Option.map (fn def => map2 (fn FVars => fn IImsupp => - let - val a = Free ("a", #aT def); - val z = Free ("z", HOLogic.dest_setT (range_type (fastype_of FVars))); - val f = Free ("f", #aT def --> #T quotient); - val goal = Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq ( - f $ a, fst (#VVr def) $ a - ))), - Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_mem (z, FVars $ (f $ a))), - HOLogic.mk_Trueprop (HOLogic.mk_mem (z, fst IImsupp $ f)) - ) - ); - in Goal.prove_sorry lthy (names [f, a, z]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - K (unfold_thms_tac ctxt (@{thms comp_def} @ [snd (#SSupp def), snd IImsupp])), - TRY o rtac ctxt @{thm UnI2}, - rtac ctxt @{thm iffD2[OF UN_iff]}, - rtac ctxt @{thm bexI}, - assume_tac ctxt, - rtac ctxt @{thm CollectI}, - assume_tac ctxt - ]) end - ) (#FVarss quotient) (#IImsupps def)))) (#quotient_fps fp_res) defss; - - val IImsupp_Diffss = @{map 4} (fn quotient => fn in_IImsuppss => fn hs => - @{map 5} (fn FVars => fn f => fn i => fn in_IImsupps => Option.map (fn def => - let - val a = Free ("a", #aT def); - val A = Free ("A", HOLogic.mk_setT (#aT def)); - val B = Free ("B", HOLogic.mk_setT (#aT def)); - val inner = Term.absfree (dest_Free a) (FVars $ (the f $ a)) - val goal = Logic.mk_implies ( - HOLogic.mk_Trueprop (mk_int_empty (B, fst (nth (#IImsupps def) i) $ the f)), - mk_Trueprop_eq ( - mk_UNION (HOLogic.mk_binop @{const_name minus} (A, B)) inner, - HOLogic.mk_binop @{const_name minus} (mk_UNION A inner, B) - ) - ); - in Goal.prove_sorry lthy (names [the f, A, B]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - rtac ctxt @{thm iffD2[OF set_eq_iff]}, - rtac ctxt allI, - rtac ctxt iffI, - let fun helper_tac inv = EVERY' [ - REPEAT_DETERM o eresolve_tac ctxt @{thms UN_E DiffE}, - REPEAT_DETERM o resolve_tac ctxt @{thms DiffI UN_I}, - assume_tac ctxt, - if not inv then assume_tac ctxt else K all_tac, - rtac ctxt @{thm case_split[of "_ = _"]}, - if inv then rotate_tac ~2 else K all_tac, - dtac ctxt @{thm iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]}, - rtac ctxt trans, - rtac ctxt (mk_arg_cong lthy 1 FVars), - assume_tac ctxt, - resolve_tac ctxt (flat (maps (map_filter I) FVars_VVrss)), - dtac ctxt @{thm singletonD}, - rtac ctxt @{thm iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]}, - if inv then rtac ctxt sym else K all_tac, - assume_tac ctxt, - assume_tac ctxt, - forward_tac ctxt (the in_IImsupps), - assume_tac ctxt, - dtac ctxt @{thm trans[OF Int_commute]}, - dtac ctxt @{thm iffD1[OF disjoint_iff]}, - etac ctxt allE, - etac ctxt impE, - if inv then K (prefer_tac 2) else assume_tac ctxt, - assume_tac ctxt - ] in EVERY' [ - helper_tac false, - helper_tac true - ] end, - REPEAT_DETERM o EqSubst.eqsubst_tac ctxt [0] (snd (#SSupp def) :: map snd (#IImsupps def)), - rtac ctxt @{thm UnI1}, - rtac ctxt @{thm iffD2[OF mem_Collect_eq]}, - assume_tac ctxt, - assume_tac ctxt - ]) end - )) (#FVarss quotient) hs (0 upto nvars - 1) in_IImsuppss - ) (#quotient_fps fp_res) in_IImsuppsss rhoss defss; - - val IImsupp_naturalsss = @{map 3} (fn quotient => @{map 3} (fn f => fn SSupp_natural => Option.map (fn def => map2 (fn f' => fn IImsupp => - let - val g = Free ("g", #aT def --> #T quotient); - val goal = mk_Trueprop_eq ( - fst IImsupp $ HOLogic.mk_comp ( - HOLogic.mk_comp (Term.list_comb (#permute quotient, fs), g), - mk_inv f - ), - mk_image f' $ (fst IImsupp $ g) - ); - in Goal.prove_sorry lthy (names (fs @ [g])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ - K (unfold_thms_tac ctxt (@{thms image_Un image_UN} @ [snd IImsupp])), - TRY o (rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]} THEN' rtac ctxt (the SSupp_natural OF prems)), - EqSubst.eqsubst_tac ctxt [0] [the SSupp_natural OF prems], - K (Local_Defs.unfold0_tac ctxt @{thms image_comp comp_assoc}), - EqSubst.eqsubst_tac ctxt [0] @{thms inv_o_simp1}, - resolve_tac ctxt prems, - K (Local_Defs.unfold0_tac ctxt @{thms o_id}), - K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), - EqSubst.eqsubst_tac ctxt [0] (maps #FVars_permutes (#quotient_fps fp_res)), - REPEAT_DETERM o resolve_tac ctxt (refl :: prems) - ]) end - ) fs (#IImsupps def))) fs) (#quotient_fps fp_res) SSupp_naturalss defss; - - val fp_thms = Option.map (fn Inl x => x | Inr _ => error "wrong fp kind") (#fp_thms fp_res); - - fun SELECT_GOALS n tac i st = - if Thm.nprems_of st = 1 andalso i = 1 then tac st - else (PRIMITIVE (Goal.restrict i n) THEN tac THEN PRIMITIVE (Goal.unrestrict i)) st; - - val tvsubst_permutes = - let - val (ts, _) = lthy - |> mk_Frees "t" (map #T (#quotient_fps fp_res)); - fun mk_goals comb = @{map 3} (fn quotient => fn tvsubst => fn t => - let - val hs' = map_filter I (flat (map2 (fn quotient => map2 (fn f => Option.map (fn h => HOLogic.mk_comp ( - HOLogic.mk_comp (Term.list_comb (#permute quotient, fs), h), - mk_inv f - ))) fs) (#quotient_fps fp_res) rhoss)); - in HOLogic.mk_eq ( - comb (Term.list_comb (#permute quotient, fs)) (Term.list_comb (fst tvsubst, rhos)) t, - comb (Term.list_comb (fst tvsubst, hs')) (Term.list_comb (#permute quotient, fs)) t - ) end - ) (#quotient_fps fp_res) tvsubsts ts; - val As = map (fn i => - foldl1 mk_Un (map2 (fn f => fn def => - fst (nth (#IImsupps def) i) $ f - ) rhos some_defs) - ) (0 upto nvars - 1); - - val goal = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj ( - mk_goals (fn t1 => fn t2 => fn t => t1 $ (t2 $ t)) - )); - val thms = split_conj (length mrbnfs) (Goal.prove_sorry lthy (names (fs @ rhos @ ts)) (f_prems @ f'_prems) goal (fn {context=ctxt, prems} => - let val (f_prems, f'_prems) = chop (length f_prems) prems; - in EVERY1 [ - DETERM o rtac ctxt (infer_instantiate' ctxt ( - map (SOME o Thm.cterm_of ctxt) As @ replicate (length mrbnfs) NONE @ map (SOME o Thm.cterm_of ctxt) ts - ) (#fresh_induct (the fp_thms))), - SELECT_GOALS (length As) (EVERY1 [ - K (Local_Defs.unfold0_tac ctxt (@{thm comp_def} :: maps (map snd o #IImsupps) some_defs)), - REPEAT_DETERM o resolve_tac ctxt ( - @{thms ordLeq_refl cmin1 cmin2 ordLeq_transitive[OF cmin1] cmin_Card_order card_of_Card_order} - @ map (fn thm => @{thm ordLess_ordLeq_trans} OF [thm]) f'_prems - @ maps (fn mrbnf => [ - MRBNF_Def.Un_bound_of_mrbnf mrbnf, MRBNF_Def.UNION_bound_of_mrbnf mrbnf - ]) mrbnfs - @ maps #card_of_FVars_bound_UNIVs (#quotient_fps fp_res) - ) - ]), - EVERY' (@{map 7} (fn mrbnf => fn quotient => fn defs => fn tvsubst_not_isVVr => fn isVVr_renames => fn rrename_VVrs => fn tvsubst_VVrs => - let val n = length (map_filter I defs); - in Subgoal.FOCUS_PREMS (fn {context=ctxt, prems=IHs, ...} => EVERY1 [ - REPEAT_DETERM_N n o rtac ctxt @{thm case_split[rotated]}, - EqSubst.eqsubst_tac ctxt [0] [#permute_ctor quotient OF f_prems], - EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~1 - n) tvsubst_not_isVVr], - resolve_tac ctxt IHs, - REPEAT_DETERM o assume_tac ctxt, - REPEAT_DETERM o resolve_tac ctxt f'_prems, - REPEAT_DETERM o resolve_tac ctxt IHs, - EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~1 - n) tvsubst_not_isVVr], - rtac ctxt (iffD2 OF [#noclash_permute (#inner quotient) OF f_prems]), - resolve_tac ctxt IHs, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] [#permute_ctor quotient RS sym OF f_prems], - EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (fn thm => thm OF f_prems)) isVVr_renames), - assume_tac ctxt - ], - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (fn thm => thm OF f_prems)) (flat SSupp_naturalss)), - rtac ctxt @{thm ordLeq_ordLess_trans[OF card_of_image]}, - resolve_tac ctxt f'_prems - ], - REPEAT_DETERM o EVERY' [ - REPEAT_DETERM1 o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf @ flat (map_filter I (flat IImsupp_naturalsss))), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ f_prems) - ], - K (Local_Defs.unfold0_tac ctxt @{thms image_Un[symmetric]}), - rtac ctxt @{thm trans[OF image_Int[OF bij_is_inj, symmetric]]}, - resolve_tac ctxt f_prems, - rtac ctxt @{thm iffD2[OF image_is_empty]}, - resolve_tac ctxt IHs - ], - rtac ctxt (trans OF [#permute_ctor quotient OF f_prems]), - rtac ctxt (mk_arg_cong lthy 1 (#ctor quotient)), - rtac ctxt (trans OF [MRBNF_Def.map_comp_of_mrbnf mrbnf]), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ f_prems), - rtac ctxt sym, - rtac ctxt (trans OF [MRBNF_Def.map_comp_of_mrbnf mrbnf]), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ f_prems), - K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), - rtac ctxt (MRBNF_Def.map_cong0_of_mrbnf mrbnf), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id refl} @ f_prems), - REPEAT_DETERM o EVERY' [ - rtac ctxt @{thm trans[OF comp_apply]}, - rtac ctxt sym, - rtac ctxt @{thm trans[OF comp_apply]}, - eresolve_tac ctxt IHs - ], - EVERY' (map_filter (Option.map (fn def => EVERY' [ - K (Local_Defs.unfold0_tac ctxt [snd (#isVVr def)]), - etac ctxt exE, - etac ctxt @{thm subst[OF sym]}, - EqSubst.eqsubst_tac ctxt [0] (map_filter I rrename_VVrs), - REPEAT_DETERM o resolve_tac ctxt f_prems, - EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_VVrs), - REPEAT_DETERM o resolve_tac ctxt f'_prems, - EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_VVrs), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (fn thm => thm OF f_prems)) (flat SSupp_naturalss)), - rtac ctxt @{thm ordLeq_ordLess_trans[OF card_of_image]}, - resolve_tac ctxt f'_prems - ], - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), - EqSubst.eqsubst_tac ctxt [0] @{thms inv_simp1}, - resolve_tac ctxt f_prems, - rtac ctxt refl - ])) (rev defs)) - ]) ctxt end - ) mrbnfs (#quotient_fps fp_res) defss tvsubst_not_isVVrs isVVr_renamess permute_VVrss tvsubst_VVrss) - ] end - )); - - val goals = map HOLogic.mk_Trueprop (mk_goals (fn t1 => fn t2 => fn _ => HOLogic.mk_comp (t1, t2))); - in map2 (fn thm => fn goal => Goal.prove_sorry lthy (names (fs @ rhos)) (f_prems @ f'_prems) goal (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt ext, - rtac ctxt @{thm trans[OF comp_apply]}, - rtac ctxt sym, - rtac ctxt @{thm trans[OF comp_apply]}, - rtac ctxt (thm RS sym OF prems) - ])) thms goals end; - - (*val FFVars_tvsubsts = @{map 8} (fn FVars => fn i => fn f => fn tvsubst_VVr => fn FVars_VVr => fn not_isVVr_free => fn IImsupp_Diff => Option.map (fn def => - let - val t = Free ("t", #T quotient); - val goal = mk_Trueprop_eq ( - FVars $ (Term.list_comb (fst tvsubst, some_fs') $ t), - foldl1 mk_Un (map_filter I (map2 (fn FVars' => Option.map (fn f => mk_UNION (FVars' $ t) (Term.abs ("a", HOLogic.dest_setT (range_type (fastype_of FVars'))) ( - FVars $ (f $ Bound 0) - )))) (#FVarss quotient) fs')) - ); - in Goal.prove_sorry lthy (names (some_fs' @ [t])) f'_prems goal (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) (map_filter I (map2 (fn i => Option.map (fn _ => - foldl1 mk_Un (map_filter I (map2 (fn f => Option.map (fn def => - fst (nth (#IImsupps def) i) $ the f - )) fs' defs)) - )) (0 upto nvars - 1) defs)) @ [NONE, SOME (Thm.cterm_of ctxt t)]) (#fresh_co_induct (#inner quotient))), - REPEAT_DETERM o EVERY' [ - SELECT_GOAL (unfold_thms_tac ctxt (@{thm comp_def} :: maps (map snd o #IImsupps) some_defs)), - REPEAT_DETERM1 o resolve_tac ctxt ( - map (fn thm => @{thm ordLess_ordLeq_trans} OF [thm]) (take nvars prems) - @ #card_of_FVars_bound_UNIVs quotient - @ [MRBNF_Def.Un_bound_of_mrbnf mrbnf, MRBNF_Def.UNION_bound_of_mrbnf mrbnf] - @ @{thms cmin1 cmin2 card_of_Card_order ordLeq_refl} - ) - ], - EVERY' (map_filter (Option.map (fn def => EVERY' [ - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - rtac ctxt (infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (fst (#isVVr def) $ (#ctor quotient $ Thm.term_of (snd (hd params)))))] @{thm case_split}) 1 - ) ctxt, - SELECT_GOAL (unfold_thms_tac ctxt [snd (#isVVr def)]), - etac ctxt exE, - Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => - REPEAT_DETERM (EVERY1 [ - EqSubst.eqsubst_tac ctxt [0] [snd (split_last prems)] - ]) - ) ctxt, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_VVrs @ flat (map_filter I FVars_VVrs)), - REPEAT_DETERM o resolve_tac ctxt prems - ], - SELECT_GOAL (unfold_thms_tac ctxt @{thms UN_single UN_empty Un_empty_right Un_empty_left}), - rtac ctxt refl - ])) defs), - (* goal 2: not (isVVr (ctor x)) *) - rtac ctxt trans, - rtac ctxt (mk_arg_cong ctxt FVars), - rtac ctxt tvsubst_not_isVVr, - REPEAT_DETERM o resolve_tac ctxt prems, - REPEAT_DETERM o EVERY' [ - TRY o EVERY' [ - rtac ctxt (@{thm iffD2[OF meta_eq_to_obj_eq]} OF [snd (#noclash rec_res)]), - SELECT_GOAL (unfold_thms_tac ctxt @{thms Int_Un_distrib Un_empty}) - ], - REPEAT_DETERM o rtac ctxt conjI, - rtac ctxt @{thm iffD2[OF disjoint_iff]}, - rtac ctxt allI, - rtac ctxt impI, - SELECT_GOAL (unfold_thms_tac ctxt @{thms UN_iff Set.bex_simps}), - TRY o rtac ctxt ballI, - Goal.assume_rule_tac ctxt - ], - REPEAT_DETERM o assume_tac ctxt, - K (unfold_thms_tac' ctxt (@{thms image_id image_comp UN_Un} @ #FVars_ctors quotient @ MRBNF_Def.set_map_of_mrbnf mrbnf) - (fn ctxt => ALLGOALS (resolve_tac ctxt (@{thms supp_id_bound bij_id} @ [@{thm supp_id_bound'} OF [Cinfinite_card]]))) - ), - K (print_tac ctxt "1"), - K (unfold_thms_tac ctxt (@{thms UN_empty Un_empty_left} @ map_filter I not_isVVr_frees)), - K (print_tac ctxt "2"), - REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, - K (print_tac ctxt "3"), - REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ - TRY o EVERY' [ - rtac ctxt @{thm trans[rotated]}, - rtac ctxt sym, - rtac ctxt (the IImsupp_Diff), - rtac ctxt @{thm iffD2[OF disjoint_iff]}, - rtac ctxt allI, - rtac ctxt impI, - Goal.assume_rule_tac ctxt, - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(-)"]} - ], - SELECT_GOAL (unfold_thms_tac ctxt @{thms UN_simps comp_def}), - rtac ctxt @{thm UN_cong}, - Goal.assume_rule_tac ctxt - ]) - ]) end - )) (#FVarss quotient) (0 upto nvars - 1) fs' tvsubst_VVrs FVars_VVrs not_isVVr_frees IImsupp_Diffs defs;*) - - val VVrss' = map (map_filter (Option.map ((fn (VVr, VVr_def) => (VVr, @{thm eq_reflection} OF [mk_unabs_def 1 ( - @{thm meta_eq_to_obj_eq} OF [Local_Defs.unfold0 lthy (@{thms comp_def} @ eta_defs) VVr_def] - )])) o #VVr))) defss; - - val results = @{map 6} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => fn VVrs' => fn tvsubst_permute => { - tvsubst = fst tvsubst, - SSupps = map_filter (Option.map (fst o #SSupp)) defs, - IImsuppss = map_filter (Option.map (map fst o #IImsupps)) defs, - VVrs = VVrs', - isVVrs = map_filter (Option.map (snd o #isVVr)) defs, - tvsubst_VVrs = map_filter I tvsubst_VVrs, - tvsubst_cctor_not_isVVr = tvsubst_not_isVVr, - tvsubst_permute = tvsubst_permute - }: tvsubst_result) tvsubsts defss tvsubst_VVrss tvsubst_not_isVVrs VVrss' tvsubst_permutes; - - (* TODO: Remove *) - val notes = - [("SSupp_VVr_empty", maps (map_filter I) SSupp_VVr_emptiess), - ("SSupp_VVr_bound", maps (map_filter I) SSupp_VVr_boundss), - ("in_IImsupp", flat (maps (map_filter I) in_IImsuppsss)), - ("is_VVr_rrename", maps (map_filter I) isVVr_renamess), - ("rrename_VVr", maps (map_filter I) permute_VVrss), - ("SSupp_natural", maps (map_filter I) SSupp_naturalss), - ("SSupp_comp_rename_bound", maps (map_filter (Option.map #SSupp_comp_rename_bound)) SSupp_compss), - ("SSupp_comp_bound", maps (map_filter (Option.map #SSupp_comp_bound)) SSupp_compss), - ("eta_set_empties", flat (maps (map_filter I) eta_set_emptiess)), - ("FVars_VVr", flat (maps (map_filter I) FVars_VVrss)), - ("tvsubst_VVr", maps (map_filter I) tvsubst_VVrss), - ("tvsubst_cctor_not_isVVr", tvsubst_not_isVVrs), - ("tvsubst_permutes", tvsubst_permutes), - ("not_isVVr_free", maps (map_filter I) not_isVVr_freess), - ("IImsupp_permute_commute", maps (map_filter I) IImsupp_imsupp_permute_commutess), - ("IImsupp_Diff", maps (map_filter I) IImsupp_Diffss), - ("IImsupp_natural", flat (maps (map_filter I) IImsupp_naturalsss)) - (*("FFVars_tvsubst", map_filter I FFVars_tvsubsts)*) - ] |> (map (fn (thmN, thms) => - ((Binding.qualify true (short_type_name (fst (dest_Type (#T (hd (#quotient_fps fp_res)))))) - (Binding.name thmN), []), [(thms, [])]) - )); - val (_, lthy) = Local_Theory.notes notes lthy - - in (results, lthy) end; - -end \ No newline at end of file diff --git a/Tools/mrbnf_util.ML b/Tools/mrbnf_util.ML index d2d0489f..ad63a65c 100644 --- a/Tools/mrbnf_util.ML +++ b/Tools/mrbnf_util.ML @@ -19,6 +19,8 @@ sig val mk_supp: term -> term val mk_supp_bound: term -> term val mk_imsupp: term -> term + val mk_SSupp: term -> term + val mk_IImsupp: term -> term -> term val mk_inv: term -> term val mk_bij: term -> term val mk_Un: term * term -> term @@ -37,6 +39,10 @@ sig val mk_ex: string * typ -> term -> term; val mk_insert: term -> term -> term; + val dest_ordLess: term -> term * term; + val dest_ordLeq: term -> term * term; + val dest_card_of: term -> term; + val strip_ex: term -> (string * typ) list * term val mk_conj_thms: int -> local_theory -> thm * thm * thm @@ -91,6 +97,8 @@ fun strip_ex (Const (@{const_name Ex}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) | strip_ex t = ([], t) fun swap (a, b) = (b, a) +fun partition _ [] = ([], []) + | partition f (x::xs) = (if f x then apfst else apsnd) (cons x) (partition f xs) fun partition _ [] = ([], []) | partition f (x::xs) = (if f x then apfst else apsnd) (cons x) (partition f xs) @@ -108,6 +116,19 @@ fun subst_typ_morphism subst = Morphism.morphism "subst_typ" { typ = [K (Term.typ_subst_atomic subst)] }; +fun dest_ordLess t = + let val t' = case HOLogic.dest_mem t of + (t', Const (@{const_name ordLess}, _)) => t' + | _ => raise TERM ("dest_ordLess", [t]) + in HOLogic.dest_prod t' end +fun dest_ordLeq t = + let val t' = case HOLogic.dest_mem t of + (t', Const (@{const_name ordLeq}, _)) => t' + | _ => raise TERM ("dest_ordLeq", [t]) + in HOLogic.dest_prod t' end +fun dest_card_of (Const (@{const_name card_of}, _) $ t) = t + | dest_card_of t = raise TERM ("dest_card_of", [t]) + fun mk_def_t_syn syn public b qualify name n rhs lthy = let val b' = qualify (Binding.name name); @@ -262,6 +283,16 @@ fun mk_imsupp u = let val T = fastype_of u in Const (@{const_name imsupp}, T --> HOLogic.mk_setT (fst (dest_funT T))) $ u end; +fun mk_SSupp Inj = + let val (a, T) = Term.dest_funT (fastype_of Inj) + in \<^Const>\SSupp a T for Inj\ end; + +fun mk_IImsupp Inj Vr = + let + val (a, T) = Term.dest_funT (fastype_of Inj); + val b = HOLogic.dest_setT (body_type (fastype_of Vr)); + in \<^Const>\IImsupp a T b for Inj Vr\ end + fun mk_supp_bound f = mk_ordLess (mk_card_of (mk_supp f)) (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of f))))); @@ -372,6 +403,7 @@ val parameter = Parse.position Parse.nat >> (fn (n, pos) => fun indices n = map string_of_int (1 upto n); fun cons n = implode (map (fn a => " (x" ^ a ^ " :: xs" ^ a ^ ")") (indices n)); +fun some n = implode (map (fn a => " (SOME x" ^ a ^ ")") (indices n)); fun vars x n = implode (map (fn a => " " ^ x ^ a) (indices n)); in @@ -385,6 +417,16 @@ val _ = Theory.setup \ | map_filter f" ^ cons n ^ " = let val ys = map_filter f" ^ vars "xs" n ^ " in the_default ys (Option.map (fn y => y::ys) (f" ^ vars "x" n ^ ")) end\n\ \ | map_filter _" ^ replicate_string n " _" ^ " = raise ListPair.UnequalLengths\n" ^ " in map_filter f end"))) + +val _ = Theory.setup + (ML_Antiquotation.value \<^binding>\map_option\ + (Scan.lift parameter >> (fn n => + "fn f =>\n\ + \ let\n\ + \ fun map_option _" ^ replicate_string n " NONE" ^ " = NONE\n\ + \ | map_option f" ^ some n ^ " = SOME (f" ^ vars "x" n ^ ")\n\ + \ | map_option _" ^ replicate_string n " _" ^ " = raise ListPair.UnequalLengths\n" ^ + " in map_option f end"))) end; end; diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML new file mode 100644 index 00000000..c57e8598 --- /dev/null +++ b/Tools/mrsbnf_comp.ML @@ -0,0 +1,707 @@ +signature MRSBNF_COMP = sig + + val compose_mrsbnfs: BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) + -> (int -> binding -> binding) -> MRSBNF_Def.mrsbnf -> MRSBNF_Def.mrsbnf list + -> typ list -> typ list list -> typ option list -> typ list list -> ((string * sort) * MRBNF_Def.var_type) list + -> ((string * sort) list list -> (string * sort) list) + -> (thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory + -> (MRSBNF_Def.mrsbnf * (typ list * typ list)) * ((thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) + + val mrsbnf_of_typ: bool -> (theory -> BNF_Def.fact_policy) + -> (binding -> binding) -> (string * sort) list -> ((string * sort) * MRBNF_Def.var_type) list + -> ((string * sort) list list -> (string * sort) list) + -> typ -> (((MRSBNF_Def.mrsbnf Symtab.table * thm list) * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) + -> ((MRSBNF_Def.mrsbnf, MRBNF_Def.mrbnf) MRBNF_Util.either * (typ list * typ list)) + * (((MRSBNF_Def.mrsbnf Symtab.table * thm list) * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) + + val seal_mrsbnf: (binding -> binding) -> (thm list * MRBNF_Comp.unfold_set) -> binding + -> ((string * sort) * MRBNF_Def.var_type) list -> typ list * typ list -> MRSBNF_Def.mrsbnf -> (string * Typedef.info) option -> local_theory + -> (MRSBNF_Def.mrsbnf * (typ list * MRBNF_Comp.absT_info)) * local_theory + +end + +structure MRSBNF_Comp : MRSBNF_COMP = struct + +open MRBNF_Util + +fun mrsbnf_of lthy s = case MRSBNF_Def.mrsbnf_of lthy s of + SOME mrsbnf => SOME (Inl mrsbnf, lthy) + | NONE => (case MRBNF_Def.mrbnf_of lthy s of + SOME mrbnf => SOME (Inr mrbnf, lthy) + | NONE => Option.map (fn bnf => + apfst Inr (MRBNF_Def.register_bnf_as_mrbnf NONE bnf lthy) + ) (BNF_Def.bnf_of lthy s) + ) + +fun is_Inl (Inl _) = true + | is_Inl _ = false + +fun morph_info phi ({rep_type, abs_type, Rep_name: string, Abs_name: string, axiom_name: string}, x) = ({ + rep_type = Morphism.typ phi rep_type, + abs_type = Morphism.typ phi abs_type, + Rep_name = Rep_name, + Abs_name = Abs_name, + axiom_name = axiom_name +}, x) + +fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt lthy = + let + val Ds = fst tys; + val vars = map (TFree o fst) Xs; + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val mrbnf' = nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad bmv); + + val ((_, _, new_tys), _, (mrbnfs', (_, lthy))) = MRBNF_Comp.normalize_mrbnfs (K I) [] [map dest_TFree (snd tys)] + [] Xs (K (map fst Xs)) NONE [mrbnf'] ((MRBNF_Comp.empty_comp_cache, mrbnf_unfolds), lthy); + val mrbnf' = hd mrbnfs'; + val ((mrbnf, info, (Ds, absT_info)), lthy) = MRBNF_Comp.seal_mrbnf qualify mrbnf_unfolds name true Ds Ds mrbnf' info_opt lthy; + + val var_class = MRBNF_Def.class_of_mrbnf mrbnf; + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf'; + val (lives, bounds, frees) = MRBNF_Def.deinterlace (map TFree new_tys) var_types; + val bounds = map (resort_tfree_or_tvar var_class) bounds; + val frees = map (resort_tfree_or_tvar var_class) frees; + val new_tys = map dest_TFree (MRBNF_Def.interlace lives bounds frees var_types); + + val rep_T = MRBNF_Def.mk_T_of_mrbnf Ds lives bounds frees mrbnf'; + + val (lives', _) = lthy + |> fold Variable.declare_typ (vars @ map TFree (fold Term.add_tfreesT Ds [])) + |> mk_TFrees (length lives); + + val T = MRBNF_Def.mk_T_of_mrbnf (map TFree (rev (fold_rev Term.add_tfreesT Ds []))) lives bounds frees mrbnf; + + val info = map_prod I (morph_info (MRBNF_Util.subst_typ_morphism ( + (op~~) (apply2 (fn T => map TFree (Term.add_tfreesT T [])) (#abs_type (fst (snd info)), T)) + ))) info; + + val bmv = + let + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (BMV_Monad_Def.leader BMV_Monad_Def.ops_of_bmv_monad bmv, rep_T) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism ( + map (fn (n, (s, T)) => (TVar (n, s), T) + ) (Vartab.dest tyenv)); + val bmv = BMV_Monad_Def.morph_bmv_monad phi bmv; + val subst = map2 (fn l => fn l' => (l', nth lives' (find_index (curry (op=) l) lives))) + (BMV_Monad_Def.leader BMV_Monad_Def.lives_of_bmv_monad bmv) + (BMV_Monad_Def.leader BMV_Monad_Def.lives'_of_bmv_monad bmv); + in BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism subst) bmv end; + + val var_types' = map (fn MRBNF_Def.Free_Var => BMV_Monad_Def.Free_Var + | MRBNF_Def.Live_Var => BMV_Monad_Def.Live_Var + | _ => BMV_Monad_Def.Dead_Var + ) var_types; + + val ((bmv, _, bmv_defs, _), lthy) = BMV_Monad_Def.seal_bmv_monad qualify ( + bmv_unfolds @ #map_unfolds mrbnf_unfolds @ flat (#set_unfoldss mrbnf_unfolds) + ) name (var_types' ~~ map TFree new_tys) bmv (SOME info) lthy; + + val mrbnfs = map_index (fn (i, x) => if i = BMV_Monad_Def.leader_of_bmv_monad bmv then mrbnf else x) + (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf); + + val mrbnf_defs = #map_unfolds mrbnf_unfolds @ flat (#set_unfoldss mrbnf_unfolds); + val defs = mrbnf_defs @ bmv_defs @ [MRBNF_Def.map_def_of_mrbnf mrbnf] @ MRBNF_Def.set_defs_of_mrbnf mrbnf; + val copy = #type_definition (snd (snd info)); + + val abs = Term.map_types (Logic.incr_tvar_same 1) ( + Logic.varify_types_global (Const (#Abs_name (fst (snd info)), rep_T --> T)) + ); + val rep = Term.map_types (Logic.incr_tvar_same 1) ( + Logic.varify_types_global (Const (#Rep_name (fst (snd info)), T --> rep_T)) + ); + + val mrbnfs = map2 (fn T => fn mrbnf => + let + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (MRBNF_Def.T_of_mrbnf mrbnf, T) Vartab.empty; + val mrbnf = MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism (map (fn (n, (s, T)) => (TVar (n, s), T)) (Vartab.dest tyenv))) mrbnf; + val subst = map2 (fn l => fn l' => (l', nth lives' (find_index (curry (op=) l) lives))) + (MRBNF_Def.lives_of_mrbnf mrbnf) (MRBNF_Def.lives'_of_mrbnf mrbnf); + in MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism subst) mrbnf end + ) (BMV_Monad_Def.ops_of_bmv_monad bmv) mrbnfs; + + val subst = Term.subst_atomic_types (lives ~~ lives'); + val unfold_defs = Local_Defs.unfold lthy mrbnf_defs; + + val comp_assocs = [ + infer_instantiate' lthy [SOME (Thm.cterm_of lthy (subst abs))] @{thm comp_assoc}, + infer_instantiate' lthy [NONE, SOME (Thm.cterm_of lthy (subst rep))] @{thm comp_assoc} + ]; + val comp_applys = [ + infer_instantiate' lthy [SOME (Thm.cterm_of lthy (subst abs))] @{thm comp_apply}, + infer_instantiate' lthy [NONE, SOME (Thm.cterm_of lthy (subst rep))] @{thm comp_apply} + ]; + + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Note_Some) qualify NONE mrbnfs bmv + (map_index (fn (i, axioms) => if i <> BMV_Monad_Def.leader_of_bmv_monad bmv then { + map_Sb = Option.map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#map_Sb axioms), + map_Injs = Option.map (map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt))) (#map_Injs axioms), + map_is_Sb = fn ctxt => HEADGOAL (rtac ctxt (#map_is_Sb axioms) THEN_ALL_NEW assume_tac ctxt), + set_Sb = map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#set_Sb axioms), + set_Vrs = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Vrs axioms) + } else { + map_Sb = Option.map (fn thm => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), + rtac ctxt @{thm type_copy_Map_Sb}, + rtac ctxt copy, + rtac ctxt copy, + K (Local_Defs.unfold0_tac ctxt (comp_assocs @ [@{thm type_copy_Rep_o_Abs_o} OF [copy]])), + rtac ctxt (unfold_defs thm), + REPEAT_DETERM o assume_tac ctxt + ]) (#map_Sb axioms), + map_Injs = Option.map (map (fn thm => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt defs), + REPEAT_DETERM o rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + K (Local_Defs.unfold0_tac ctxt [@{thm type_copy_Rep_o_Abs_o} OF [copy]]), + rtac ctxt (unfold_defs thm) THEN_ALL_NEW assume_tac ctxt + ])) (#map_Injs axioms), + map_is_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), + resolve_tac ctxt @{thms type_copy_map_comp0 type_copy_map_cong0 arg_cong[of _ _ "\x. _ \ x \ _"]}, + TRY o EVERY' [ + rtac ctxt copy, + K (Local_Defs.unfold0_tac ctxt (comp_assocs @ [@{thm type_copy_Rep_o_Abs_o} OF [copy]])) + ], + rtac ctxt (unfold_defs (#map_is_Sb axioms)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + set_Sb = map (fn _ => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), + K (Local_Defs.unfold0_tac ctxt (comp_applys @ [#Abs_inverse (snd (snd info)) OF @{thms UNIV_I}])), + rtac ctxt trans, + resolve_tac ctxt (map unfold_defs (#set_Sb axioms)), + REPEAT_DETERM o assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ]) (bounds @ lives), + set_Vrs = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), + rtac ctxt @{thm trans[OF comp_apply]}, + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt trans, + resolve_tac ctxt (map unfold_defs (#set_Vrs axioms)), + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ] + ])) frees + } + ) (MRSBNF_Def.axioms_of_mrsbnf mrsbnf)) lthy; + in ((mrsbnf, (snd (dest_Type T), absT_info)), lthy) end + +fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs Ass Xs flatten_tyargs ((old_bmv_unfold, accum), lthy) = + let + val outer_bmv = MRSBNF_Def.bmv_monad_of_mrsbnf outer; + + fun separate_vars vars Ds mrsbnf = + let + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val mrbnfs = MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf; + val mrbnf = nth mrbnfs (BMV_Monad_Def.leader_of_bmv_monad bmv); + val (lives, bounds, frees) = MRBNF_Def.deinterlace vars (MRBNF_Def.var_types_of_mrbnf mrbnf); + + val bounds = map_filter (Option.map (resort_tfree_or_tvar @{sort var})) bounds; + val frees = map_filter (Option.map (resort_tfree_or_tvar @{sort var})) frees; + + val lives' = case lives of + NONE::_ => replicate (length lives) @{typ unit} + | _ => map_filter I lives + + val T = MRBNF_Def.mk_T_of_mrbnf Ds lives' bounds frees mrbnf; + + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (BMV_Monad_Def.leader BMV_Monad_Def.ops_of_bmv_monad bmv, T) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism (map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv)); + val bmv = BMV_Monad_Def.morph_bmv_monad phi bmv; + in { + frees = BMV_Monad_Def.leader BMV_Monad_Def.frees_of_bmv_monad bmv, + deads = BMV_Monad_Def.leader BMV_Monad_Def.deads_of_bmv_monad bmv, + lives = BMV_Monad_Def.leader BMV_Monad_Def.lives_of_bmv_monad bmv + } end; + + val oAs' = let val x = separate_vars oAs oDs outer in { frees = #frees x, deads = #deads x } end; + val Ass' = @{map 3} (separate_vars o map SOME) Ass Dss inners; + + val ((bmv, bmv_unfolds), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) (MRSBNF_Def.bmv_monad_of_mrsbnf outer) + (map (Inl o MRSBNF_Def.bmv_monad_of_mrsbnf) inners) oAs' (map SOME Ass') lthy; + + val leader = BMV_Monad_Def.leader_of_bmv_monad outer_bmv; + val outer_mrbnf = nth (MRSBNF_Def.mrbnfs_of_mrsbnf outer) leader; + val inner_mrbnfs = map (fn mrsbnf => nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) leader) inners; + + val ((mrbnf, tys), (mrbnf_unfolds, lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline + qualify flatten_tyargs outer_mrbnf inner_mrbnfs oDs Dss oAs Ass Xs (accum, lthy); + + val mrbnf = + let + val T = hd (BMV_Monad_Def.ops_of_bmv_monad bmv); + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (MRBNF_Def.T_of_mrbnf mrbnf, T) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism (map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv)); + in MRBNF_Def.morph_mrbnf phi mrbnf end + + val (mrbnfs, axioms') = split_list ((mrbnf, NONE) :: maps (fn mrsbnf => + let + val mrbnfs = MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf; + fun find_match mrbnf T = case T of + T as Type _ => map_filter (fn T' => Option.map (fn tyenv => + MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism ( + map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv) + )) mrbnf + ) (try (Sign.typ_match (Proof_Context.theory_of lthy) (T, T')) Vartab.empty)) + (BMV_Monad_Def.ops_of_bmv_monad bmv) + | _ => [] + in @{map_filter 2} (fn mrbnf => fn i => case find_match mrbnf (MRBNF_Def.T_of_mrbnf mrbnf) of + [] => NONE | x::_ => SOME (x, SOME (nth (MRSBNF_Def.axioms_of_mrsbnf mrsbnf) i)) + ) mrbnfs (0 upto length mrbnfs - 1) end + ) inners); + val (mrbnfs, axioms') = split_list (distinct ((op=) o apply2 (MRBNF_Def.T_of_mrbnf o fst)) (mrbnfs ~~ axioms')); + + val mrbnfs = map (fn mrbnf => + let + val leader = BMV_Monad_Def.leader_of_bmv_monad bmv; + val lives = nth (BMV_Monad_Def.lives_of_bmv_monad bmv) leader; + val lives' = nth (BMV_Monad_Def.lives'_of_bmv_monad bmv) leader; + val subst = map2 (fn l => fn l' => (l', nth lives' (find_index (curry (op=) l) lives))) + (MRBNF_Def.lives_of_mrbnf mrbnf) (MRBNF_Def.lives'_of_mrbnf mrbnf); + in MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism subst) mrbnf end + ) mrbnfs; + + val no_reflexive = filter_out (fn thm => case try (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm of + NONE => false | SOME (lhs, rhs) => lhs = rhs + ); + + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def fact_policy (qualify 0 o @{print warning}) NONE mrbnfs bmv + (map (fn axioms => case axioms of SOME axioms => { + map_Sb = Option.map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#map_Sb axioms), + map_Injs = Option.map (map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt))) (#map_Injs axioms), + map_is_Sb = fn ctxt => HEADGOAL (rtac ctxt (#map_is_Sb axioms) THEN_ALL_NEW assume_tac ctxt), + set_Sb = map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#set_Sb axioms), + set_Vrs = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Vrs axioms) + } | NONE => { + map_Sb = if MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf - length (BMV_Monad_Def.leader BMV_Monad_Def.frees_of_bmv_monad bmv) > 0 then + SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds))), + rtac ctxt trans, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + resolve_tac ctxt (map_filter #map_Sb (MRSBNF_Def.axioms_of_mrsbnf outer)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}), + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (no_reflexive (map_filter #Map_map (MRSBNF_Def.facts_of_mrsbnf outer)))), + rtac ctxt (MRBNF_Def.map_comp0_of_mrbnf outer_mrbnf RS sym), + REPEAT_DETERM o rtac ctxt @{thm supp_id_bound}, + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt sym, + rtac ctxt trans, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (no_reflexive (map_filter #Map_map (MRSBNF_Def.facts_of_mrsbnf outer)))), + rtac ctxt (MRBNF_Def.map_comp0_of_mrbnf outer_mrbnf RS sym), + REPEAT_DETERM o rtac ctxt @{thm supp_id_bound}, + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + TRY o EVERY' [ + rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt ( + map (fn thm => thm RS sym) (no_reflexive (map_filter #Map_map (MRSBNF_Def.facts_of_mrsbnf outer))) + @ flat (map_filter (Option.map #Map_Injs) (BMV_Monad_Def.params_of_bmv_monad outer_bmv)) + )), + rtac ctxt refl + ], + rtac ctxt sym, + rtac ctxt ext, + rtac ctxt (MRBNF_Def.map_cong0_of_mrbnf outer_mrbnf), + REPEAT_DETERM o rtac ctxt @{thm supp_id_bound}, + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ no_reflexive (maps (map MRBNF_Def.map_id0_of_mrbnf o MRSBNF_Def.mrbnfs_of_mrsbnf) inners))), + REPEAT_DETERM o FIRST' (rtac ctxt refl :: map (fn inner => EVERY' [ + resolve_tac ctxt (map (Local_Defs.unfold0 ctxt ( + no_reflexive (maps (map MRBNF_Def.map_id0_of_mrbnf o MRSBNF_Def.mrbnfs_of_mrsbnf) inners) + )) (map_filter (Option.map (fn thm => Local_Defs.unfold0 ctxt (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds)) + (thm RS fun_cong) + ) o #map_Sb) (MRSBNF_Def.axioms_of_mrsbnf inner))), + REPEAT_DETERM o assume_tac ctxt + ]) inners) + ]) else NONE, + map_is_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds))), + rtac ctxt trans, + resolve_tac ctxt (map #map_is_Sb (MRSBNF_Def.axioms_of_mrsbnf outer)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm supp_id_bound}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt sym, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} + ], + rtac ctxt trans, + resolve_tac ctxt (map_filter (Option.map (#Map_comp o #axioms)) (BMV_Monad_Def.params_of_bmv_monad outer_bmv)), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt ext, + rtac ctxt sym, + resolve_tac ctxt (map_filter (Option.map (#Map_cong o #axioms)) (BMV_Monad_Def.params_of_bmv_monad outer_bmv)), + EVERY' (map (fn inner => FIRST' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_bnf_apply}) THEN' rtac ctxt refl, + EVERY' [ + resolve_tac ctxt (map (fn ax => Local_Defs.unfold0 ctxt (@{thms id_o o_id id_bnf_apply} @ bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds)) + (#map_is_Sb ax RS fun_cong) + ) (MRSBNF_Def.axioms_of_mrsbnf inner)), + REPEAT_DETERM o assume_tac ctxt + ] + ]) inners) + ], + map_Injs = if MRBNF_Def.bound_of_mrbnf mrbnf = 0 then NONE else SOME (map_filter (fn Inj => + if body_type (fastype_of Inj) <> MRBNF_Def.T_of_mrbnf mrbnf then NONE else SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds) @ flat (#set_unfoldss (snd mrbnf_unfolds)))), + if MRBNF_Def.bound_of_mrbnf outer_mrbnf = 0 then K all_tac else + let val thm = Local_Defs.unfold0 ctxt @{thms id_o o_id} ( + infer_instantiate' ctxt (map (Option.map (fn t => + let + val t' = case t of + Const (@{const_name id}, Type ("fun", [TVar ((n, i), s), _])) => + HOLogic.id_const (TVar ((n, i+1), s)) + | t => t + in Thm.cterm_of lthy t' end + )) (flat (MRBNF_Def.interlace (replicate (MRBNF_Def.live_of_mrbnf outer_mrbnf) []) + (replicate (MRBNF_Def.bound_of_mrbnf outer_mrbnf) [NONE]) + (map (single o SOME o HOLogic.id_const) (MRBNF_Def.frees_of_mrbnf outer_mrbnf)) + (MRBNF_Def.var_types_of_mrbnf outer_mrbnf) + ) @ flat (MRBNF_Def.interlace (replicate (MRBNF_Def.live_of_mrbnf outer_mrbnf) []) + (map (single o SOME o HOLogic.id_const) (MRBNF_Def.bounds_of_mrbnf outer_mrbnf)) + (replicate (MRBNF_Def.free_of_mrbnf outer_mrbnf) [NONE]) + (MRBNF_Def.var_types_of_mrbnf outer_mrbnf) + ) @ maps (fn a => [NONE, SOME (HOLogic.id_const a)]) (MRBNF_Def.lives_of_mrbnf outer_mrbnf) + )) (MRBNF_Def.map_comp0_of_mrbnf outer_mrbnf) + ); + in EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt thm, + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt trans, + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + resolve_tac ctxt (maps (the_default [] o #map_Injs) (MRSBNF_Def.axioms_of_mrsbnf outer)), + REPEAT_DETERM o assume_tac ctxt + ] end, + K (Local_Defs.unfold0_tac ctxt (map (fn ax => the (#Map_map ax) RS sym) (MRSBNF_Def.facts_of_mrsbnf outer))), + resolve_tac ctxt (flat (map_filter (Option.map #Map_Injs) (BMV_Monad_Def.params_of_bmv_monad outer_bmv))) + ]) + ) (hd (BMV_Monad_Def.Injs_of_bmv_monad bmv))), + set_Sb = replicate (MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf) (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds) @ flat (#set_unfoldss (snd mrbnf_unfolds)))), + SUBGOAL (fn (goal, _) => + let + val outer_set_maps = @{map_filter 2} (fn MRBNF_Def.Live_Var => SOME | _ => K NONE) (MRBNF_Def.var_types_of_mrbnf outer_mrbnf) (MRBNF_Def.set_map_of_mrbnf outer_mrbnf); + fun strip_all (Const (@{const_name Pure.all}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) (strip_all t) + | strip_all t = ([], t) + val T = snd (snd (split_last (fst (strip_all goal)))) + val thms = map (fn thm => + let + val arg = Var (hd (Term.add_vars (Thm.prop_of thm) [])); + val tyenv = Sign.typ_match (Proof_Context.theory_of ctxt) + (fastype_of arg, T) Vartab.empty; + val insts = map (fn (x, (s, T)) => ((x, s), Thm.ctyp_of ctxt T)) (Vartab.dest tyenv) + in instantiate_normalize (TVars.make insts, Vars.empty) thm end + ) outer_set_maps; + val comp_apply = + let + val thm = @{thm comp_apply}; + val arg = Var (hd (rev (Term.add_vars (Thm.prop_of thm) []))); + val tyenv = Sign.typ_match (Proof_Context.theory_of ctxt) + (fastype_of arg, T --> T) Vartab.empty; + val insts = map (fn (x, (s, T)) => ((x, s), Thm.ctyp_of ctxt T)) (Vartab.dest tyenv) + in instantiate_normalize (TVars.make insts, Vars.empty) thm end + in EVERY1 [ + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] thms, + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} + ], + K (Local_Defs.unfold0_tac ctxt (comp_apply :: @{thms UN_empty2 Un_empty_right Un_empty_left image_id})), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps #set_Sb (MRSBNF_Def.axioms_of_mrsbnf outer)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (#Vrs_Map (the (BMV_Monad_Def.leader BMV_Monad_Def.params_of_bmv_monad outer_bmv)))), + K (Local_Defs.unfold0_tac ctxt (no_reflexive (map_filter #Map_map (MRSBNF_Def.facts_of_mrsbnf outer)))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] thms, + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_comp[unfolded comp_def] image_Un}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps (maps (map ( + Local_Defs.unfold0 ctxt (flat (#set_unfoldss (snd mrbnf_unfolds))) + ) o #set_Sb) o MRSBNF_Def.axioms_of_mrsbnf) inners), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold_tac ctxt ( + @{thms Un_Union_image Union_Un_distrib UN_UN_flatten UN_empty UN_empty2 Un_empty_left Un_empty_right} + @ flat (maps #set_Injs (MRSBNF_Def.facts_of_mrsbnf outer)) + @ flat (maps #Supp_Injss (BMV_Monad_Def.facts_of_bmv_monad outer_bmv)) + )) + ] end + ), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt @{thm set_eqI}, + K (Local_Defs.unfold0_tac ctxt @{thms Un_assoc[symmetric]}), + K (Local_Defs.unfold0_tac ctxt @{thms Un_iff}), + rtac ctxt iffI, + REPEAT_DETERM_N 2 o EVERY' [ + rotate_tac ~1, + etac ctxt @{thm contrapos_pp}, + K (Local_Defs.unfold0_tac ctxt @{thms de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + REPEAT_DETERM o rtac ctxt conjI, + REPEAT_DETERM o assume_tac ctxt + ] + ] + ]), + set_Vrs = replicate (length (BMV_Monad_Def.leader BMV_Monad_Def.frees_of_bmv_monad bmv)) (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds) @ flat (#set_unfoldss (snd mrbnf_unfolds)))), + SUBGOAL (fn (goal, _) => + let + val outer_set_maps = @{map_filter 2} (fn MRBNF_Def.Live_Var => SOME | _ => K NONE) (MRBNF_Def.var_types_of_mrbnf outer_mrbnf) (MRBNF_Def.set_map_of_mrbnf outer_mrbnf); + fun strip_all (Const (@{const_name Pure.all}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) (strip_all t) + | strip_all t = ([], t) + val T = snd (snd (split_last (fst (strip_all goal)))) + val thms = map (fn thm => + let + val arg = Var (hd (Term.add_vars (Thm.prop_of thm) [])); + val tyenv = Sign.typ_match (Proof_Context.theory_of ctxt) + (fastype_of arg, T) Vartab.empty; + val insts = map (fn (x, (s, T)) => ((x, s), Thm.ctyp_of ctxt T)) (Vartab.dest tyenv) + in instantiate_normalize (TVars.make insts, Vars.empty) thm end + ) outer_set_maps; + in REPEAT_DETERM (EVERY1 [ + EqSubst.eqsubst_tac ctxt [0] thms, + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} + ]) end + ), + K (Local_Defs.unfold_tac ctxt (@{thms UN_empty2 Un_empty_right Un_empty_left image_id + Un_assoc[symmetric] Un_Union_image UN_singleton Un_absorb + } @ no_reflexive (map (Local_Defs.unfold0 ctxt ( + flat (#set_unfoldss (snd mrbnf_unfolds)) + )) (flat (maps (map #set_Vrs o MRSBNF_Def.axioms_of_mrsbnf) inners))) + )), + EVERY' (map_filter (fn inner => + let + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf inner; + val T = hd (BMV_Monad_Def.ops_of_bmv_monad bmv); + in if Term.is_TFree T orelse Term.is_TVar T then SOME (EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt ( + @{thms id_bnf_apply UN_singleton Un_absorb} + @ BMV_Monad_Def.unfolds_of_bmv_monad bmv + )) + ]) else NONE end + ) inners), + rtac ctxt refl + ]) + }) axioms') lthy; + in ((mrsbnf, tys), ((old_bmv_unfold @ bmv_unfolds, mrbnf_unfolds), lthy)) end + +fun demote_mrsbnf qualify var_types mrsbnf ((bmv_unfolds, accum), lthy) = + let + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val mrbnfs = MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf; + val mrbnf = nth mrbnfs (BMV_Monad_Def.leader_of_bmv_monad bmv); + + val prev_var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val vars = MRBNF_Def.interlace (MRBNF_Def.lives_of_mrbnf mrbnf) (MRBNF_Def.bounds_of_mrbnf mrbnf) + (MRBNF_Def.frees_of_mrbnf mrbnf) prev_var_types; + + val free_demote = map (fn free => the (AList.lookup (op=) (vars ~~ var_types) free) = MRBNF_Def.Bound_Var) (BMV_Monad_Def.leader BMV_Monad_Def.frees_of_bmv_monad bmv); + val live_demote = map (fn live => case the (AList.lookup (op=) (vars ~~ var_types) live) of + MRBNF_Def.Live_Var => BMV_Monad_Def.Live_Var + | MRBNF_Def.Free_Var => BMV_Monad_Def.Free_Var + | _ => BMV_Monad_Def.Dead_Var + ) (BMV_Monad_Def.leader BMV_Monad_Def.lives_of_bmv_monad bmv) + + val bmv' = bmv; + val ((bmv, unfolds), lthy) = BMV_Monad_Def.demote_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify NONE bmv { + frees = free_demote, lives = live_demote + } lthy; + + val (mrbnfs, (accum, lthy)) = fold_map (fn mrbnf => + let + val var_types' = map (fn a => the (AList.lookup (op=) (vars ~~ var_types) a)) ( + MRBNF_Def.interlace (MRBNF_Def.lives_of_mrbnf mrbnf) (MRBNF_Def.bounds_of_mrbnf mrbnf) + (MRBNF_Def.frees_of_mrbnf mrbnf) (MRBNF_Def.var_types_of_mrbnf mrbnf) + ); + in MRBNF_Comp.demote_mrbnf qualify var_types' mrbnf end + ) mrbnfs (accum, lthy) + + val mrbnfs = map2 (fn T => fn mrbnf => + let + val lives = BMV_Monad_Def.leader BMV_Monad_Def.lives_of_bmv_monad bmv; + val lives' = BMV_Monad_Def.leader BMV_Monad_Def.lives'_of_bmv_monad bmv; + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (MRBNF_Def.T_of_mrbnf mrbnf, T) Vartab.empty; + val mrbnf = MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism (map (fn (n, (s, T)) => (TVar (n, s), T)) (Vartab.dest tyenv))) mrbnf; + val subst = map2 (fn l => fn l' => (l', nth lives' (find_index (curry (op=) l) lives))) + (MRBNF_Def.lives_of_mrbnf mrbnf) (MRBNF_Def.lives'_of_mrbnf mrbnf); + in MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism subst) mrbnf end + ) (BMV_Monad_Def.ops_of_bmv_monad bmv) mrbnfs; + + val axioms = MRSBNF_Def.axioms_of_mrsbnf mrsbnf; + + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Dont_Note) qualify NONE mrbnfs bmv (@{map 4} (fn mrbnf => fn Injs => fn Vrs => fn RVrs => { + map_Injs = if MRBNF_Def.bound_of_mrbnf mrbnf = 0 then NONE else SOME (map_filter (fn Inj => + if range_type (fastype_of Inj) <> MRBNF_Def.T_of_mrbnf mrbnf then NONE else SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt unfolds), + K (print_tac ctxt "map_Inj") + ]) + ) Injs), + map_Sb = if MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf = 0 then NONE else SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ unfolds @ map #Sb_Inj (BMV_Monad_Def.axioms_of_bmv_monad bmv'))), + rtac ctxt refl + ]), + map_is_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt unfolds), + rtac ctxt trans, + resolve_tac ctxt (map #map_is_Sb axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ], + set_Sb = replicate (MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf) (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_apply} @ unfolds @ map #Sb_Inj (BMV_Monad_Def.axioms_of_bmv_monad bmv'))), + resolve_tac ctxt (refl :: maps #set_Sb axioms) + ]), + set_Vrs = replicate (length (RVrs @ Vrs)) (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt unfolds), + K (print_tac ctxt "set_Vrs") + ]) + }) mrbnfs (BMV_Monad_Def.Injs_of_bmv_monad bmv) (BMV_Monad_Def.Vrs_of_bmv_monad bmv) (BMV_Monad_Def.RVrs_of_bmv_monad bmv)) lthy + + in (mrsbnf, ((bmv_unfolds @ unfolds, accum), lthy)) end + +fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_Def.mrsbnf Symtab.table * thm list) * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)), lthy:local_theory) = + (if member (op =) Ds0 T' then ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), (accum, lthy)) else + (case map_filter (fn a => if fst a = T' then SOME (snd a) else NONE) var_types of + [] => ((Inr MRBNF_Comp.ID_mrbnf, ([], [T])), (accum, lthy)) + | [MRBNF_Def.Dead_Var] => error "var_types may only be Live, Free or Bound, use Ds0 for deads" + | [var_type] => + let + val qualify' = qualify o Binding.suffix_name ("_" ^ fst T') + val (ID', accum') = MRBNF_Comp.demote_mrbnf qualify' [var_type] MRBNF_Comp.ID_mrbnf (snd accum, lthy) + in ((Inr ID', ([], [T])), ((fst accum, fst accum'), snd accum')) end + | _ => error "Same variable appears twice in var_types" + ) + ) + | mrsbnf_of_typ _ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" + | mrsbnf_of_typ optim const_policy qualify' Ds0 var_types flatten_tyargs (T as Type (n, Ts)) (((mrsbnf_cache, (bmv_unfolds:thm list)), accum), lthy) = (case mrsbnf_of lthy n of + NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), (((mrsbnf_cache, bmv_unfolds), accum), lthy)) + | SOME (outer, lthy) => + if optim andalso forall is_TFree Ts andalso length Ts = length (subtract (op=) Ds0 (Term.add_tfreesT T [])) then + let + val mrbnf = case outer of + Inl mrsbnf => nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad (MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf)) + | Inr mrbnf => mrbnf; + val phi = MRBNF_Util.subst_typ_morphism ( + snd (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf)) ~~ Ts + ); + val mrbnf' = MRBNF_Def.morph_mrbnf phi mrbnf; + val deads = MRBNF_Def.deads_of_mrbnf mrbnf'; + val _ = case filter (Option.isSome o AList.lookup (op=) var_types o dest_TFree) deads of + T'::_ => error ("Variable " ^ Syntax.string_of_typ lthy T' ^ " is forced dead by type " ^ Syntax.string_of_typ lthy T ^ " but was specified as other usage") + | [] => () + val Ts' = subtract (op=) deads Ts; + + val var_types = map (AList.lookup (op=) var_types o dest_TFree) Ts'; + val var_types = @{map 3} (fn req => fn var_type => fn T => if member (op=) Ds0 (dest_TFree T) then + MRBNF_Def.Dead_Var else + let val x = the_default var_type req; + in if MRBNF_Def.var_type_ord (x, var_type) = LESS then x else var_type end + ) var_types (MRBNF_Def.var_types_of_mrbnf mrbnf) Ts'; + + val (mrsbnf, accum) = if MRBNF_Def.var_types_of_mrbnf mrbnf = var_types then + (outer, ((bmv_unfolds, accum), lthy)) + else case outer of + Inl mrsbnf => apfst Inl (demote_mrsbnf qualify' var_types mrsbnf ((bmv_unfolds, accum), lthy)) + | Inr mrbnf => apsnd (apfst (pair bmv_unfolds)) (apfst Inr (MRBNF_Comp.demote_mrbnf qualify' var_types mrbnf (accum, lthy))); + in ((mrsbnf, (inter (op=) Ts (deads @ map TFree Ds0), subtract (op=) (map TFree Ds0) Ts')), apfst (apfst (pair mrsbnf_cache)) accum) end + else + let + val name = Long_Name.base_name n; + fun qualify i = + let val namei = name ^ nonzero_string_of_int i; + in qualify' o Binding.qualify true namei end; + val mrbnf = case outer of + Inl mrsbnf => hd (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + | Inr mrbnf => mrbnf + + val odead = MRBNF_Def.dead_of_mrbnf mrbnf; + val olive = MRBNF_Def.live_of_mrbnf mrbnf; + val obound = MRBNF_Def.bound_of_mrbnf mrbnf; + val ofree = MRBNF_Def.free_of_mrbnf mrbnf; + val Ds = map (fn i => TFree (string_of_int i, [])) (1 upto odead); + val Us = snd (Term.dest_Type (MRBNF_Def.mk_T_of_mrbnf Ds (replicate olive dummyT) (replicate obound dummyT) (replicate ofree dummyT) mrbnf)); + val oDs_pos = map (fn x => find_index (fn y => x = y) Us) Ds + |> filter (fn x => x >= 0); + val oAs = map (fn (T, var_type) => case var_type of + MRBNF_Def.Live_Var => NONE | _ => SOME T + ) (Ts ~~ MRBNF_Def.var_types_of_mrbnf mrbnf) + val oDs = map (nth Ts) oDs_pos; + val ofree_bound_pos = map_filter I (map_index (fn (i, x) => case x of + SOME _ => SOME i | NONE => NONE + ) oAs) + val Ts' = map (nth Ts) (subtract (op =) (oDs_pos @ ofree_bound_pos) (0 upto length Ts - 1)); + + val ((inners, (Dss, Ass)), (((mrsbnf_cache, bmv_unfolds), accum), lthy)) = + apfst (apsnd split_list o split_list) (@{fold_map 2} + (fn i => mrsbnf_of_typ optim const_policy (qualify i) Ds0 var_types flatten_tyargs) + (1 upto length Ts') Ts' (((mrsbnf_cache, bmv_unfolds), accum), lthy)); + + val Xs = rev (Term.add_tfreesT T []); + val Xs' = map (swap o `(the_default MRBNF_Def.Live_Var o AList.lookup (op=) var_types)) Xs + + in if exists is_Inl inners orelse is_Inl outer then + let + fun upgrade_mrbnf mrbnf (mrsbnf_cache, lthy) = + let + val T = MRBNF_Def.T_of_mrbnf mrbnf; + fun is_leaf (Type (_, Ts)) = forall Term.is_TVar Ts + | is_leaf (TVar _) = true + | is_leaf _ = false + val name = Binding.name_of (MRBNF_Def.name_of_mrbnf mrbnf); + in if not (is_leaf T) then + let + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_of_mrbnf (qualify 0) mrbnf lthy; + val mrsbnf_cache = Symtab.insert (K true) (name, mrsbnf) mrsbnf_cache; + in (mrsbnf, (mrsbnf_cache, lthy)) end + else case MRSBNF_Def.mrsbnf_of lthy name of + SOME mrsbnf => (mrsbnf, (mrsbnf_cache, lthy)) + | NONE => (case Symtab.lookup mrsbnf_cache name of + SOME mrsbnf => (mrsbnf, (mrsbnf_cache, lthy)) + | NONE => + let + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_of_mrbnf I mrbnf lthy; + val mrsbnf_cache = Symtab.insert (K true) (name, mrsbnf) mrsbnf_cache; + in (mrsbnf, (mrsbnf_cache, lthy)) end + ) + end + + val (outer', (mrsbnf_cache, lthy)) = case outer of + Inl mrsbnf => (mrsbnf, (mrsbnf_cache, lthy)) + | Inr mrbnf => upgrade_mrbnf mrbnf (mrsbnf_cache, lthy) + val (inners', (mrsbnf_cache, lthy)) = fold_map (fn Inl mrsbnf => pair mrsbnf + | Inr mrbnf => upgrade_mrbnf mrbnf + ) inners (mrsbnf_cache, lthy); + + val unfolds' = bmv_unfolds @ maps (BMV_Monad_Def.unfolds_of_bmv_monad o MRSBNF_Def.bmv_monad_of_mrsbnf) (outer' :: inners'); + + val ((mrsbnf, tys), ((unfolds, accum), lthy)) = compose_mrsbnfs BNF_Def.Smart_Inline const_policy qualify outer' inners' + oDs Dss oAs Ass Xs' flatten_tyargs ((bmv_unfolds, accum), lthy); + in ((Inl mrsbnf, tys), (((mrsbnf_cache, unfolds' @ unfolds), accum), lthy)) end + else + (apsnd (apfst (pair (mrsbnf_cache, bmv_unfolds))) (apfst (apfst Inr) (MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline qualify (distinct (op=) o flat) + mrbnf (map (fn Inr x => x | _ => error "impossible") inners) oDs Dss oAs Ass Xs' (accum, lthy) + ))) + end + ); + +end \ No newline at end of file diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML new file mode 100644 index 00000000..02ef16c2 --- /dev/null +++ b/Tools/mrsbnf_def.ML @@ -0,0 +1,1214 @@ +signature MRSBNF_DEF = sig + type mrsbnf + + type 'a mrsbnf_axioms = { + map_is_Sb: 'a, + set_Vrs: 'a list, + map_Sb: 'a option, + map_Injs: 'a list option, + set_Sb: 'a list + }; + + type mrsbnf_facts = { + SSupp_map_subset: thm option list, + SSupp_map_bound: thm option list, + SSupp_naturals: thm list, + IImsupp_naturals: thm list list, + IImsupp_map_bound: thm list list, + map_Inj: thm option list, + map_Sb_strong: thm, + Map_map: thm option, + set_Injs: thm list list + }; + + val bmv_monad_of_mrsbnf: mrsbnf -> BMV_Monad_Def.bmv_monad + val mrbnfs_of_mrsbnf: mrsbnf -> MRBNF_Def.mrbnf list + val axioms_of_mrsbnf: mrsbnf -> thm mrsbnf_axioms list + val facts_of_mrsbnf: mrsbnf -> mrsbnf_facts list + + val morph_mrsbnf: morphism -> mrsbnf -> mrsbnf + + val mrsbnf_def: (theory -> BNF_Def.fact_policy) -> (binding -> binding) -> string option + -> MRBNF_Def.mrbnf list -> BMV_Monad_Def.bmv_monad -> (Proof.context -> tactic) mrsbnf_axioms list + -> local_theory -> mrsbnf * local_theory; + + val mrsbnf_of_mrbnf: (binding -> binding) -> MRBNF_Def.mrbnf -> local_theory -> mrsbnf * local_theory; + + val note_mrsbnf_thms: (theory -> BNF_Def.fact_policy) -> (binding -> binding) -> string option -> mrsbnf + -> local_theory -> (string * thm list) list * local_theory + val register_mrsbnf: string -> mrsbnf -> local_theory -> local_theory; + val mrsbnf_of_generic: Context.generic -> string -> mrsbnf option; + val mrsbnf_of: Proof.context -> string -> mrsbnf option; +end + +structure MRSBNF_Def : MRSBNF_DEF = struct + +open MRBNF_Util +open BMV_Monad_Def + +type 'a mrsbnf_axioms = { + map_is_Sb: 'a, + set_Vrs: 'a list, + map_Sb: 'a option, + map_Injs: 'a list option, + set_Sb: 'a list +} + +fun map_mrsbnf_axioms (f:'a -> 'b) ({ map_is_Sb, set_Vrs, map_Sb, set_Sb, map_Injs }: 'a mrsbnf_axioms) = { + map_is_Sb = f map_is_Sb, + set_Vrs = map f set_Vrs, + map_Sb = Option.map f map_Sb, + map_Injs = Option.map (map f) map_Injs, + set_Sb = map f set_Sb +}: 'b mrsbnf_axioms; + +val morph_mrsbnf_axioms = map_mrsbnf_axioms o Morphism.thm + +fun apply_mrsbnf_axioms ({ + map_is_Sb=f1, map_Sb=f2, set_Sb=f3s, set_Vrs=f4s, map_Injs=f5s +}: ('a -> 'b) mrsbnf_axioms) ({ + map_is_Sb, map_Sb, set_Sb, set_Vrs, map_Injs +}: 'a mrsbnf_axioms) = +let + fun checkLength name xs ys = if length xs <> length ys then error ( + "UnequalLength: " ^ name ^ " (" ^ string_of_int (length xs) ^ " vs. " ^ string_of_int (length ys) ^ ")" + ) else () + val _ = checkLength "set_Sb" set_Sb f3s + val _ = checkLength "set_Vrs" set_Vrs f4s + val _ = Option.map (fn map_Injs => checkLength "map_Injs" map_Injs (the f5s)) map_Injs +in { + map_is_Sb = f1 map_is_Sb, + map_Sb = Option.map (fn t => the f2 t) map_Sb, + map_Injs = Option.map (fn ts => map2 (curry (op|>)) ts (the f5s)) map_Injs, + set_Sb = map2 (curry (op|>)) set_Sb f3s, + set_Vrs = map2 (curry (op|>)) set_Vrs f4s +}: 'b mrsbnf_axioms end + +type mrsbnf_facts = { + SSupp_map_subset: thm option list, + SSupp_map_bound: thm option list, + SSupp_naturals: thm list, + IImsupp_naturals: thm list list, + IImsupp_map_bound: thm list list, + map_Inj: thm option list, + map_Sb_strong: thm, + Map_map: thm option, + set_Injs: thm list list +} + +fun morph_mrsbnf_facts phi ({ + SSupp_map_subset, SSupp_map_bound, map_Inj, map_Sb_strong, Map_map, set_Injs, SSupp_naturals, + IImsupp_naturals, IImsupp_map_bound +}: mrsbnf_facts) = { + SSupp_map_subset = map (Option.map (Morphism.thm phi)) SSupp_map_subset, + SSupp_map_bound = map (Option.map (Morphism.thm phi)) SSupp_map_bound, + SSupp_naturals = map (Morphism.thm phi) SSupp_naturals, + IImsupp_naturals = map (map (Morphism.thm phi)) IImsupp_naturals, + IImsupp_map_bound = map (map (Morphism.thm phi)) IImsupp_map_bound, + map_Inj = map (Option.map (Morphism.thm phi)) map_Inj, + map_Sb_strong = Morphism.thm phi map_Sb_strong, + Map_map = Option.map (Morphism.thm phi) Map_map, + set_Injs = map (map (Morphism.thm phi)) set_Injs +}: mrsbnf_facts + +datatype mrsbnf = MRSBNF of { + mrbnfs: MRBNF_Def.mrbnf list, + pbmv_monad: BMV_Monad_Def.bmv_monad, + axioms: thm mrsbnf_axioms list, + facts: mrsbnf_facts list +} + +fun morph_mrsbnf phi (MRSBNF { + mrbnfs, pbmv_monad, axioms, facts +}) = MRSBNF { + mrbnfs = map (MRBNF_Def.morph_mrbnf phi) mrbnfs, + pbmv_monad = BMV_Monad_Def.morph_bmv_monad phi pbmv_monad, + axioms = map (morph_mrsbnf_axioms phi) axioms, + facts = map (morph_mrsbnf_facts phi) facts +} + +fun Rep_mrsbnf (MRSBNF x) = x + +val bmv_monad_of_mrsbnf = #pbmv_monad o Rep_mrsbnf +val mrbnfs_of_mrsbnf = #mrbnfs o Rep_mrsbnf +val axioms_of_mrsbnf = #axioms o Rep_mrsbnf +val facts_of_mrsbnf = #facts o Rep_mrsbnf + +structure Data = Generic_Data ( + type T = mrsbnf Symtab.table; + val empty = Symtab.empty; + fun merge data : T = Symtab.merge (K true) data; +); + +fun register_mrsbnf name mrsbnf = + Local_Theory.declaration {syntax = false, pervasive = true, pos = Position.none} + (fn phi => Data.map (Symtab.update (name, morph_mrsbnf phi mrsbnf))); + +fun mrsbnf_of_generic context = + Option.map (morph_mrsbnf (Morphism.transfer_morphism (Context.theory_of context))) + o Symtab.lookup (Data.get context); + +val mrsbnf_of = mrsbnf_of_generic o Context.Proof; + +fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = + let + val bmv = bmv_monad_of_mrsbnf mrsbnf; + fun name () = case name_opt of + NONE => fst (dest_Type (nth (BMV_Monad_Def.ops_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv))) + | SOME b => b; + val axioms = axioms_of_mrsbnf mrsbnf; + val facts = facts_of_mrsbnf mrsbnf; + val unfolds = BMV_Monad_Def.unfolds_of_bmv_monad bmv; + + fun note_unless_dont_note (noted, lthy) = + let val notes = + [("map_is_Sb", map #map_is_Sb axioms, []), + ("set_Vrs", maps #set_Vrs axioms, []), + ("set_Sb", maps #set_Sb axioms, []), + ("map_Sb", maps (the_default [] o Option.map single o #map_Sb) axioms, []), + ("SSupp_map_subset", maps (map_filter I o #SSupp_map_subset) facts, []), + ("SSupp_map_bound", maps (map_filter I o #SSupp_map_bound) facts, []), + ("SSupp_natural", maps #SSupp_naturals facts, []), + ("IImsupp_natural", flat (maps #IImsupp_naturals facts), []), + ("IImsupp_map_bound", flat (maps #IImsupp_map_bound facts), []), + ("map_Inj_raw", maps (the_default [] o #map_Injs) axioms, []), + ("map_Inj", maps (map_filter I o #map_Inj) facts, []), + ("map_Sb_strong", map #map_Sb_strong facts, []), + ("Map_map", map_filter #Map_map facts, []), + ("set_Inj", flat (maps #set_Injs facts), []) + ] + |> filter_out (null o #2) + |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (short_type_name (name ())) (Binding.name thmN)), attrs), [ + (map (Local_Defs.unfold0 lthy unfolds) thms, []) + ])); + in Local_Theory.notes notes lthy |>> append noted end + val fact_policy = fact_policy (Proof_Context.theory_of lthy); + in ([], lthy) + |> fact_policy <> BNF_Def.Dont_Note ? note_unless_dont_note + end + +fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs bmv axioms' lthy = + let + val no_reflexive = filter_out (fn thm => case try (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm of + NONE => false + | SOME (rhs, lhs) => rhs = lhs + ); + + val names = map (fst o dest_Free); + val facts' = @{map 12} (fn lives => fn lives' => fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn Injs => fn RVrs => fn Vrs => fn Map_opt => + let + val mapx = MRBNF_Def.map_of_mrbnf mrbnf; + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + + val T = body_type (fastype_of Sb); + val fs = map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of mapx)))); + + val f_prems = map HOLogic.mk_Trueprop (flat (map2 (fn f => fn MRBNF_Def.Live_Var => [] + | MRBNF_Def.Bound_Var => [mk_bij f, mk_supp_bound f] + | MRBNF_Def.Free_Var => [mk_supp_bound f] + ) fs var_types)); + val (live_fs, bound_fs, free_fs) = MRBNF_Def.deinterlace fs var_types; + + val RVrs_aTs = map (HOLogic.dest_setT o body_type o fastype_of) RVrs; + + val ((((hs, gs), aa), x), _) = lthy + |> mk_Frees "h" (map (fn a => a --> a) RVrs_aTs) + ||>> mk_Frees "g" (map fastype_of Injs) + ||>> mk_Frees "a" (map (domain_type o fastype_of) Injs) + ||>> apfst hd o mk_Frees "x" [T]; + val frees = inter (op=) Fs (MRBNF_Def.frees_of_mrbnf mrbnf); + val free = length frees; + + val live = MRBNF_Def.live_of_mrbnf mrbnf; + + val g_prems = map2 (fn Inj => fn g => HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (mk_SSupp Inj $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) + )) Injs gs; + fun find_f T = List.find (fn f => T = domain_type (fastype_of f)) fs; + + val h_fs = map (the o find_f o domain_type o fastype_of) hs; + val h_fs_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) h_fs; + val h_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs; + + val map_Inj = map (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + let + val a = the (List.find (curry (op=) (domain_type (fastype_of Inj)) o fastype_of) aa); + val f = the (List.find (curry (op=) (fastype_of a) o domain_type o fastype_of) fs); + val goal = mk_Trueprop_eq (Term.list_comb (mapx, fs) $ (Inj $ a), Term.subst_atomic_types (lives ~~ lives') Inj $ (f $ a)) + + in SOME (Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt trans, + case #map_Injs axioms of NONE => K all_tac | SOME map_Injs => + let + val mk_id = HOLogic.id_const o domain_type o fastype_of; + val thm = Local_Defs.unfold0 ctxt @{thms id_o o_id} ( + infer_instantiate' ctxt (map (SOME o Thm.cterm_of lthy) (maps (fn f => [f, mk_id f]) live_fs)) ( + infer_instantiate' ctxt (map (SOME o Thm.cterm_of lthy) ( + flat (MRBNF_Def.interlace (replicate live []) (map single bound_fs) + (map (single o mk_id) free_fs) (MRBNF_Def.var_types_of_mrbnf mrbnf) + ) @ flat (MRBNF_Def.interlace (replicate live []) (map (single o mk_id) bound_fs) + (map single free_fs) (MRBNF_Def.var_types_of_mrbnf mrbnf) + ) + )) (MRBNF_Def.map_comp_of_mrbnf mrbnf RS sym) + ) + ); + val map_Injs = map (fn thm => @{thm trans[OF comp_apply[symmetric]]} OF [thm RS fun_cong] RS arg_cong) map_Injs; + in EVERY' [ + rtac ctxt (trans OF [thm]), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + EqSubst.eqsubst_tac ctxt [0] map_Injs, + REPEAT_DETERM o resolve_tac ctxt prems + ] end, + rtac ctxt (#map_is_Sb axioms RS fun_cong), + REPEAT_DETERM o resolve_tac ctxt prems, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_apply]}, + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt (the_default [] (Option.map (fn param => + map (fn thm => Local_Defs.unfold0 ctxt @{thms comp_apply} (thm RS fun_cong)) (#Map_Injs param) + ) bmv_params))) + ], + rtac ctxt trans, + resolve_tac ctxt (map (fn thm => @{thm trans[OF comp_apply[symmetric]]} OF [thm RS fun_cong]) (#Sb_comp_Injs bmv_axioms)), + REPEAT_DETERM o resolve_tac ctxt ( + @{thms SSupp_comp_bound SSupp_Inj_bound infinite_class.infinite_UNIV card_of_Card_order conjI cinfinite_iff_infinite[THEN iffD2] IImsupp_Inj_comp_bound} + @ prems @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad bmv) + ), + rtac ctxt @{thm comp_apply} + ])) end + ) Injs; + + val SSupp_map_subset = @{map 3} (fn Inj => fn g => fn g_prem => + let + val map_t = Term.list_comb (mapx, fs); + val goal = HOLogic.mk_Trueprop (uncurry mk_leq ( + mk_SSupp (Term.subst_atomic_types (As ~~ As') Inj) $ HOLogic.mk_comp (map_t, g), + mk_Un (mk_SSupp Inj $ g, mk_supp (the (find_f (domain_type (fastype_of Inj))))) + )); + in if body_type (fastype_of map_t) <> body_type (fastype_of (Term.subst_atomic_types (As ~~ As') Inj)) then NONE else + SOME (Goal.prove_sorry lthy (names (g :: fs)) (f_prems @ [g_prem]) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm subsetI}, + EqSubst.eqsubst_tac ctxt [0] @{thms SSupp_def}, + EqSubst.eqsubst_asm_tac ctxt [0] @{thms SSupp_def}, + K (Local_Defs.unfold0_tac ctxt @{thms mem_Collect_eq Un_iff comp_def}), + rtac ctxt @{thm case_split[rotated]}, + etac ctxt disjI1, + rtac ctxt disjI2, + dtac ctxt @{thm iffD1[OF arg_cong2[OF _ refl, of _ _ "(\)"], rotated]}, + rtac ctxt (mk_arg_cong lthy 1 map_t), + assume_tac ctxt, + EqSubst.eqsubst_asm_tac ctxt [0] (map_filter I map_Inj), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + rotate_tac ~1, + etac ctxt @{thm contrapos_np}, + K (Local_Defs.unfold0_tac ctxt (#Inj_inj bmv_facts)), + etac ctxt @{thm notin_supp} + ])) + end + ) Injs gs g_prems; + + val Un_bound = @{thm infinite_class.Un_bound}; + + val SSupp_map_bound = @{map 4} (fn Inj => fn g => fn g_prem => Option.map (fn thm => + let val goal = HOLogic.mk_Trueprop (uncurry mk_ordLess ( + mk_card_of (mk_SSupp (Term.subst_atomic_types (As ~~ As') Inj) $ HOLogic.mk_comp (Term.list_comb (mapx, fs), g)), + mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) + )); + in Goal.prove_sorry lthy (names (fs @ [g])) (f_prems @ [g_prem]) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm card_of_subset_bound}, + rtac ctxt thm, + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt Un_bound, + REPEAT_DETERM o resolve_tac ctxt prems + ]) end + )) Injs gs g_prems SSupp_map_subset; + + val Map_map = Option.map (fn Map => + let val goal = mk_Trueprop_eq ( + Term.list_comb (Map, map (fn T => the (List.find (curry (op=) T o fastype_of) live_fs)) (fst (split_last (binder_types (fastype_of Map))))), + MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) live_fs (map HOLogic.id_const (MRBNF_Def.bounds_of_mrbnf mrbnf)) (map HOLogic.id_const (MRBNF_Def.frees_of_mrbnf mrbnf)) mrbnf + ) in Goal.prove_sorry lthy (names live_fs) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt (#map_is_Sb axioms), + REPEAT_DETERM o rtac ctxt @{thm supp_id_bound}, + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ no_reflexive [#Sb_Inj bmv_axioms])), + rtac ctxt refl + ]) end + ) Map_opt; + + val SSupp_naturals = @{map_filter 2} (fn Inj => fn g => if body_type (fastype_of Inj) <> T then NONE else + let + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val f = the (List.find (curry (op=) (domain_type (fastype_of Inj)) o domain_type o fastype_of) fs); + val fs = map2 (fn MRBNF_Def.Live_Var => HOLogic.id_const o domain_type o fastype_of | _ => I) var_types fs; + val map_t = Term.list_comb (Term.subst_atomic_types (As' ~~ As) mapx, fs); + val goal = mk_Trueprop_eq ( + mk_SSupp Inj $ (HOLogic.mk_comp (HOLogic.mk_comp (map_t, g), mk_inv f)), + mk_image f $ (mk_SSupp Inj $ g) + ); + val f_prems = flat (map2 (fn MRBNF_Def.Live_Var => K [] | _ => fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) var_types fs); + in SOME (Goal.prove_sorry lthy (names (g :: filter_out (fn Const _ => true | _ => false) fs)) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_def}), + rtac ctxt @{thm set_eqI}, + rtac ctxt iffI, + K (Local_Defs.unfold0_tac ctxt @{thms mem_Collect_eq comp_apply image_Collect}), + etac ctxt @{thm contrapos_np}, + dtac ctxt @{thm Meson.not_exD}, + etac ctxt allE, + dtac ctxt @{thm iffD1[OF de_Morgan_conj]}, + etac ctxt disjE, + EqSubst.eqsubst_asm_tac ctxt [0] [infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt f)] @{thm inv_simp2}], + resolve_tac ctxt prems, + etac ctxt notE, + rtac ctxt refl, + dtac ctxt @{thm notnotD}, + etac ctxt @{thm subst[OF sym]}, + rtac ctxt trans, + resolve_tac ctxt (map_filter I map_Inj), + REPEAT_DETERM o resolve_tac ctxt prems, + EqSubst.eqsubst_tac ctxt [0] [infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt f)] @{thm inv_simp2}], + resolve_tac ctxt prems, + rtac ctxt refl, + etac ctxt exE, + etac ctxt conjE, + hyp_subst_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] [infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt f)] @{thm inv_simp1}], + resolve_tac ctxt prems, + etac ctxt @{thm contrapos_nn}, + dtac ctxt @{thm trans}, + resolve_tac ctxt (map_filter (Option.map (fn thm => + (thm RS sym) OF (flat (fst (fold_map ( + fn MRBNF_Def.Free_Var => apfst tl o chop 2 + | MRBNF_Def.Bound_Var => chop 2 + | _ => pair [] + ) var_types prems))) + )) map_Inj), + etac ctxt @{thm injD[rotated]}, + rtac ctxt (MRBNF_Def.inj_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt (@{thms bij_is_inj bij_id} @ prems) + ])) end + ) Injs gs; + + val (lsets, bsets, fsets) = MRBNF_Def.deinterlace (MRBNF_Def.sets_of_mrbnf mrbnf) var_types; + + val IImsupp_naturals = @{map_filter 2} (fn Inj => fn g => if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vrs => + let + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val f = the (List.find (curry (op=) (domain_type (fastype_of Inj)) o domain_type o fastype_of) fs); + val f' = the (List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of Vrs))) o domain_type o fastype_of) fs); + val fs = map2 (fn MRBNF_Def.Live_Var => HOLogic.id_const o domain_type o fastype_of | _ => I) var_types fs; + val map_t = Term.list_comb (Term.subst_atomic_types (As' ~~ As) mapx, fs); + val goal = mk_Trueprop_eq ( + mk_IImsupp Inj Vrs $ (HOLogic.mk_comp (HOLogic.mk_comp (map_t, g), mk_inv f)), + mk_image f' $ (mk_IImsupp Inj Vrs $ g) + ); + val f_prems = flat (map2 (fn MRBNF_Def.Live_Var => K [] | _ => fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) var_types fs); + in Goal.prove_sorry lthy (names (g :: filter_out (fn Const _ => true | _ => false) fs)) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def image_Un image_UN}), + EqSubst.eqsubst_tac ctxt [0] SSupp_naturals, + REPEAT_DETERM o resolve_tac ctxt prems, + K (Local_Defs.unfold0_tac ctxt @{thms image_comp comp_def}), + EqSubst.eqsubst_tac ctxt [0] @{thms inv_simp1}, + resolve_tac ctxt prems, + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt refl + ]) end + ) fsets)) Injs gs; + + val IImsupp_Map_bound = @{map_filter 3} (fn Inj => fn g => fn g_prem => if body_type (fastype_of Inj) <> T then NONE else Option.map (fn Map => (map (fn Vrs => + let + val fs = map (fn f_T => the (List.find (curry (op=) f_T o fastype_of) fs)) + (fst (split_last (binder_types (fastype_of Map)))); + val map_t = Term.list_comb (Map, fs); + val bT = HOLogic.dest_setT (body_type (fastype_of Vrs)); + val card = mk_card_of (HOLogic.mk_UNIV bT); + val goal = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (Term.subst_atomic_types (lives ~~ lives') (mk_IImsupp Inj Vrs) $ HOLogic.mk_comp (map_t, g))) + card + ); + val g_prem = if bT = domain_type (fastype_of Inj) then g_prem else + HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_IImsupp Inj Vrs $ g)) card); + in Goal.prove_sorry lthy (names (fs @ [g])) [g_prem] goal (fn {context=ctxt, prems} => EVERY1 [ + K (Local_Defs.unfold_tac ctxt (@{thms IImsupp_Un} @ no_reflexive (#set_Vrs axioms))), + rtac ctxt @{thm card_of_subset_bound}, + REPEAT_DETERM o rtac ctxt @{thm Un_mono}, + REPEAT_DETERM o resolve_tac ctxt (flat (the_default [] (#IImsupp_Map_subsets bmv_facts))), + K (Local_Defs.unfold_tac ctxt (@{thms IImsupp_Un[symmetric]} @ map (fn thm => thm RS sym) (no_reflexive (#set_Vrs axioms)))), + resolve_tac ctxt prems ORELSE' EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), + rtac ctxt @{thm var_class.UN_bound}, + resolve_tac ctxt prems, + resolve_tac ctxt (MRBNF_Def.set_bd_UNIV_of_mrbnf mrbnf) + ] + ]) end + ) fsets)) Map_opt) Injs gs g_prems; + + val IImsupp_map_bound = @{map_filter 3} (fn Inj => fn g => fn g_prem => if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vrs => + let + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val f = the (List.find (curry (op=) (domain_type (fastype_of Inj)) o domain_type o fastype_of) fs); + val map_t = Term.list_comb (mapx, fs); + val bT = HOLogic.dest_setT (body_type (fastype_of Vrs)); + val card = mk_card_of (HOLogic.mk_UNIV bT); + val goal = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (Term.subst_atomic_types (lives ~~ lives') (mk_IImsupp Inj Vrs) $ (HOLogic.mk_comp (HOLogic.mk_comp (map_t, g), mk_inv f)))) + card + ); + val g_prem = if bT = domain_type (fastype_of Inj) then g_prem else + HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_IImsupp Inj Vrs $ g)) card); + val fs' = @{map_filter 2} (fn MRBNF_Def.Live_Var => K NONE | _ => SOME) var_types fs; + val live_fs = subtract (op=) fs' fs; + val f_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) fs'; + in Goal.prove_sorry lthy (names (g :: fs)) (g_prem :: f_prems) goal (fn {context=ctxt, prems} => + let val map_comp = Local_Defs.unfold0 ctxt (@{thms id_o o_id} + @ the_default [] (Option.map (fn thm => [thm RS sym]) Map_map) + ) (infer_instantiate' ctxt ( + map (SOME o Thm.cterm_of ctxt) fs' + @ map (SOME o Thm.cterm_of ctxt o HOLogic.id_const o domain_type o fastype_of) fs' + @ maps (fn f => map (SOME o Thm.cterm_of ctxt) [f, HOLogic.id_const (domain_type (fastype_of f))]) live_fs + ) (MRBNF_Def.map_comp0_of_mrbnf mrbnf)) + in EVERY1 [ + EqSubst.eqsubst_tac ctxt [0] [map_comp], + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + resolve_tac ctxt (flat IImsupp_Map_bound) ORELSE' EVERY' [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ [MRBNF_Def.map_id0_of_mrbnf mrbnf])) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + EqSubst.eqsubst_tac ctxt [0] (flat IImsupp_naturals @ SSupp_naturals), + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt @{thm ordLeq_ordLess_trans[OF card_of_image]}, + REPEAT_DETERM o EVERY' [ + TRY o rtac ctxt @{thm infinite_class.Un_bound}, + resolve_tac ctxt prems ORELSE' EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), + rtac ctxt @{thm var_class.UN_bound}, + resolve_tac ctxt prems, + resolve_tac ctxt (MRBNF_Def.set_bd_UNIV_of_mrbnf mrbnf) ORELSE' + EVERY' [rtac ctxt @{thm ordLess_ordLeq_trans}, + resolve_tac ctxt (#Vrs_bds bmv_axioms), + rtac ctxt @{thm var_class.large'} + ] + ] + ] + ] end + ) end + ) fsets)) Injs gs g_prems; + + fun split_Un_bd thm = case try (fn () => thm RS @{thm Un_boundD}) () of + NONE => [thm] | SOME thm' => split_Un_bd (thm' RS conjunct1) @ [thm' RS conjunct2] + + val IImsupp_map_bound' = map (maps (fn thm => split_Un_bd ( + Local_Defs.unfold lthy (@{thms IImsupp_Un} @ no_reflexive (#set_Vrs axioms)) thm + ))) IImsupp_map_bound; + + val sets = MRBNF_Def.sets_of_mrbnf mrbnf; + val (_, bound_sets, _) = MRBNF_Def.deinterlace sets var_types; + + val set_Injs = map (fn bset => @{map_filter 2} (fn Inj => fn a => + if body_type (fastype_of Inj) <> T then NONE else + let val goal = mk_Trueprop_eq (bset $ (Inj $ a), mk_bot (HOLogic.dest_setT (body_type (fastype_of bset)))) + in SOME (Goal.prove_sorry lthy (names [a]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt @{thm ccontr}, + forward_tac ctxt @{thms ex_distinct_bijs}, + resolve_tac ctxt (MRBNF_Def.set_bd_UNIV_of_mrbnf mrbnf), + REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], + Subgoal.FOCUS (fn {context=ctxt, prems, params, ...} => + let + val mk_id = HOLogic.id_const o domain_type o fastype_of + fun mk_map_t g = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) + (map mk_id live_fs) (map (fn f => + let val T = domain_type (fastype_of f); + in if T = HOLogic.dest_setT (body_type (fastype_of bset)) then g else HOLogic.id_const T end + ) bound_fs) (map mk_id free_fs) mrbnf; + val goal = mk_Trueprop_eq ( + bset $ (mk_map_t (Thm.term_of (snd (hd params))) $ (Inj $ a)), + bset $ (mk_map_t (Thm.term_of (snd (nth params 1))) $ (Inj $ a)) + ); + val thm = Goal.prove_sorry ctxt [] [] goal (fn {context=ctxt, ...} => EVERY1 [ + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map (fn thm => + Local_Defs.unfold0 ctxt @{thms comp_apply} (thm RS fun_cong) + ) (the (#map_Injs axioms))), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + rtac ctxt sym + ], + rtac ctxt refl + ]); + in EVERY1 [ + Method.insert_tac ctxt [thm], + REPEAT_DETERM_N 2 o EVERY' [ + EqSubst.eqsubst_asm_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems) + ], + etac ctxt @{thm contrapos_pp}, + resolve_tac ctxt prems + ] end + ) ctxt + ])) end + ) Injs aa) bound_sets; + + in { + SSupp_map_subset = SSupp_map_subset, + SSupp_map_bound = SSupp_map_bound, + SSupp_naturals = SSupp_naturals, + IImsupp_naturals = IImsupp_naturals, + IImsupp_map_bound = IImsupp_map_bound, + IImsupp_map_bound' = IImsupp_map_bound', + map_Inj = map_Inj, + Map_map = Map_map, + set_Injs = set_Injs + } end + ) (BMV_Monad_Def.lives_of_bmv_monad bmv) (BMV_Monad_Def.lives'_of_bmv_monad bmv) + axioms' mrbnfs (BMV_Monad_Def.axioms_of_bmv_monad bmv) (BMV_Monad_Def.params_of_bmv_monad bmv) (BMV_Monad_Def.facts_of_bmv_monad bmv) + (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) + (BMV_Monad_Def.RVrs_of_bmv_monad bmv) (BMV_Monad_Def.Vrs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); + + val facts' = @{map 10} (fn i => fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn RVrs => fn Injs => + let + val mapx = MRBNF_Def.map_of_mrbnf mrbnf; + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val live = MRBNF_Def.live_of_mrbnf mrbnf; + + val T = body_type (fastype_of Sb); + val fs = map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of mapx)))); + val (live_fs, bound_fs, free_fs) = MRBNF_Def.deinterlace fs var_types; + + val RVrs_aTs = map (HOLogic.dest_setT o body_type o fastype_of) RVrs; + + val ((((hs, gs), aa), x), _) = lthy + |> mk_Frees "h" (map (fn a => a --> a) RVrs_aTs) + ||>> mk_Frees "g" (map fastype_of Injs) + ||>> mk_Frees "a" (map (domain_type o fastype_of) Injs) + ||>> apfst hd o mk_Frees "x" [T]; + val frees = inter (op=) Fs (MRBNF_Def.frees_of_mrbnf mrbnf); + val free = length frees; + + (*val g_prems = map2 (fn Inj => fn g => HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (mk_SSupp Inj $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) + )) Injs gs;*) + val small_prems = flat (BMV_Monad_Def.mk_small_prems_of_bmv_monad bmv i hs gs); + + fun find_f T = List.find (curry (op=) T o domain_type o fastype_of) fs; + (*val h_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs;*) + val h_fs = map (the o find_f o domain_type o fastype_of) hs; + + val map_Sb_strong = + let + val map_t = Term.list_comb (mapx, fs); + val mrbnfs' = map (fn Inj => + the (List.find (fn mrbnf => body_type (fastype_of (MRBNF_Def.map_of_mrbnf mrbnf)) = body_type (fastype_of (Term.subst_atomic_types (As ~~ As') Inj))) mrbnfs) + ) Injs; + val goal = mk_Trueprop_eq ( + HOLogic.mk_comp (map_t, Term.list_comb (Sb, hs @ gs)), + HOLogic.mk_comp (Term.list_comb (Term.subst_atomic_types (As ~~ As') Sb, + map2 (fn h => fn f => HOLogic.mk_comp (HOLogic.mk_comp (f, h), mk_inv f)) hs h_fs @ + map2 (fn g => fn mrbnf => + let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; + in HOLogic.mk_comp (HOLogic.mk_comp ( + Term.list_comb (mapx, + map (the o find_f o domain_type) (fst (split_last (binder_types (fastype_of mapx)))) + ), + g), mk_inv (the (find_f (domain_type (fastype_of g)))) + ) end + ) gs mrbnfs'), map_t) + ); + + val f_prems = flat (MRBNF_Def.interlace (replicate live []) + (map (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) bound_fs) + (map (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) free_fs) var_types); + val id_of_f = HOLogic.id_const o domain_type o fastype_of + val count = live + MRBNF_Def.bound_of_mrbnf mrbnf; + val map_is_Sb = filter_out ( + (op=) o HOLogic.dest_eq o HOLogic.dest_Trueprop o snd o Logic.strip_horn o Thm.prop_of + ) (map #map_is_Sb axioms'); + + val IImsupp_map_bound' = map (fn thm => Local_Defs.unfold0 lthy @{thms inv_id id_o o_id} (thm OF (@{thm _}:: + maps (fn MRBNF_Def.Free_Var => @{thms bij_id supp_id_bound} + | MRBNF_Def.Bound_Var => @{thms _ _} + | _ => [] + ) (MRBNF_Def.var_types_of_mrbnf mrbnf)) + )) (flat (#IImsupp_map_bound facts)); + + in Goal.prove_sorry lthy (names (fs @ hs @ gs)) (f_prems @ small_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ] ORELSE EVERY1 [ + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + let val comp_tac = EVERY' [ + if count > 0 then EVERY' [ + rtac ctxt trans, + rtac ctxt (Local_Defs.unfold0 ctxt @{thms id_o o_id} (infer_instantiate' ctxt ( + map (SOME o Thm.cterm_of ctxt) (flat ( + MRBNF_Def.interlace (replicate (2 * live) []) + (map single bound_fs @ map (single o id_of_f) bound_fs) + (map (single o id_of_f) free_fs @ map single free_fs) (var_types @ var_types) + ) @ maps (fn f => [f, HOLogic.id_const (domain_type (fastype_of f))]) live_fs) + ) (MRBNF_Def.map_comp0_of_mrbnf mrbnf))), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} + ] else K all_tac, + rtac ctxt (#map_is_Sb axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}) + ] in EVERY' [ + comp_tac, + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + comp_tac + ] end, + rtac ctxt sym, + EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm trans[OF comp_assoc]}, + if MRBNF_Def.live_of_mrbnf mrbnf = 0 then K all_tac else EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} + ], + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + resolve_tac ctxt (the_default [] (Option.map single (#map_Sb axioms))), + REPEAT_DETERM o resolve_tac ctxt prems, + if MRBNF_Def.live_of_mrbnf mrbnf = 0 then K all_tac else EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt (#Map_Sb (the bmv_params)) + THEN_ALL_NEW (SELECT_GOAL ( + REPEAT_DETERM (HEADGOAL (resolve_tac ctxt (@{thms supp_id_bound} + @ prems @ IImsupp_map_bound' + @ maps (map_filter I o #SSupp_map_bound) facts' + ) ORELSE' (CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ + [MRBNF_Def.map_id0_of_mrbnf mrbnf] + ))))))), + rtac ctxt @{thm comp_assoc} + ], + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} + ] ORELSE' rtac ctxt trans, + rtac ctxt (#Sb_comp bmv_axioms) + THEN_ALL_NEW (SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ [ + MRBNF_Def.map_id0_of_mrbnf mrbnf + ])), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV + SSupp_comp_bound SSupp_Inj_bound card_of_Card_order conjI + cinfinite_iff_infinite[THEN iffD2] IImsupp_Inj_comp_bound + } + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (flat o the_default [] o #IImsupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad bmv) + @ IImsupp_map_bound' + ) + ] + ]))), + rtac ctxt sym, + rtac ctxt trans, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + if MRBNF_Def.live_of_mrbnf mrbnf = 0 then K all_tac else EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} + ] + ], + rtac ctxt (#Sb_comp bmv_axioms), + REPEAT_DETERM o FIRST' [ + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + resolve_tac ctxt (maps (flat o #IImsupp_map_bound) facts' @ maps (flat o #IImsupp_map_bound') facts') + ], + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ [ + MRBNF_Def.map_id0_of_mrbnf mrbnf + ])), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV + SSupp_comp_bound SSupp_Inj_bound card_of_Card_order conjI + cinfinite_iff_infinite[THEN iffD2] IImsupp_Inj_comp_bound infinite_class.Un_bound + } + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (flat o the_default [] o #IImsupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad bmv) + @ IImsupp_map_bound' + ) + ] + ], + TRY o rtac ctxt @{thm trans[OF comp_assoc]}, + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt ext, + rtac ctxt (#Sb_cong bmv_axioms), + REPEAT_DETERM o FIRST' [ + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + resolve_tac ctxt (maps (flat o #IImsupp_map_bound) facts' @ maps (flat o #IImsupp_map_bound') facts') + ], + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ [ + MRBNF_Def.map_id0_of_mrbnf mrbnf + ])), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound + SSupp_Inj_bound card_of_Card_order conjI cinfinite_iff_infinite[THEN iffD2] IImsupp_Inj_comp_bound infinite_class.Un_bound} + @ flat (#IImsupp_map_bound facts) + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (flat o the_default [] o #IImsupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' + @ maps #SSupp_Sb_bounds (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (flat o #IImsupp_Sb_boundss) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad bmv) + @ IImsupp_map_bound' + ) + ] + ], + (* renaming-only subst functions *) + REPEAT_DETERM o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + EqSubst.eqsubst_tac ctxt [0] @{thms inv_o_simp1}, + resolve_tac ctxt prems, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms o_id}), + rtac ctxt refl + ], + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm trans[OF comp_assoc[symmetric], THEN fun_cong]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + resolve_tac ctxt (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), + REPEAT_DETERM o FIRST' [ + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + resolve_tac ctxt (maps (flat o #IImsupp_map_bound) facts' @ maps (flat o #IImsupp_map_bound') facts') + ], + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ [ + MRBNF_Def.map_id0_of_mrbnf mrbnf + ])), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV + SSupp_comp_bound SSupp_Inj_bound card_of_Card_order conjI + cinfinite_iff_infinite[THEN iffD2] IImsupp_Inj_comp_bound infinite_class.Un_bound + } + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (flat o the_default [] o #IImsupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad bmv) + @ IImsupp_map_bound' + ) + ] + ], + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + rtac ctxt @{thm inv_o_simp1}, + resolve_tac ctxt prems, + rtac ctxt @{thm o_id}, + rtac ctxt sym, + rtac ctxt trans, + EVERY' [ + resolve_tac ctxt @{thms arg_cong2[OF _ refl, of _ _ "(\)"] arg_cong2[OF _ refl, of _ _ "(\)", THEN fun_cong]}, + resolve_tac ctxt (map (fn thm => thm RS sym) map_is_Sb) + ] ORELSE' EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc[symmetric], THEN fun_cong]}, + resolve_tac ctxt @{thms arg_cong2[OF _ refl, of _ _ "(\)"] arg_cong2[OF _ refl, of _ _ "(\)", THEN fun_cong]}, + resolve_tac ctxt (map (fn thm => thm RS sym) map_is_Sb) + ], + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm trans[OF comp_assoc[symmetric], THEN fun_cong]}, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + resolve_tac ctxt (map (fn mrbnf => MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym) mrbnfs), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ] + ]) + ]) end; + in { + SSupp_map_subset = #SSupp_map_subset facts, + SSupp_map_bound = #SSupp_map_bound facts, + SSupp_naturals = #SSupp_naturals facts, + IImsupp_naturals = #IImsupp_naturals facts, + IImsupp_map_bound = #IImsupp_map_bound facts, + map_Inj = #map_Inj facts, + map_Sb_strong = map_Sb_strong, + Map_map = #Map_map facts, + set_Injs = #set_Injs facts + }: mrsbnf_facts end + ) (0 upto length axioms' - 1) axioms' facts' mrbnfs (BMV_Monad_Def.axioms_of_bmv_monad bmv) (BMV_Monad_Def.params_of_bmv_monad bmv) (BMV_Monad_Def.facts_of_bmv_monad bmv) + (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.RVrs_of_bmv_monad bmv) + (BMV_Monad_Def.Injs_of_bmv_monad bmv); + + val mrsbnf = MRSBNF { + mrbnfs = mrbnfs, + pbmv_monad = bmv, + axioms = axioms', + facts = facts' + }; + + val mrsbnf = morph_mrsbnf (MRBNF_Util.subst_typ_morphism ( + map (fn T => (T, Logic.varifyT_global T)) (deads @ As @ As' @ Bs @ Fs) + )) mrsbnf; + in (mrsbnf, lthy) end; + +fun mk_mrsbnf_axioms mrbnfs bmv lthy = + let + val l = BMV_Monad_Def.leader_of_bmv_monad bmv; + val lmrbnf = nth mrbnfs l; + val ldeads = distinct (op=) (filter_out Term.is_Type (MRBNF_Def.deads_of_mrbnf lmrbnf)); + + val ((((Fs, Bs), As), deads), names_lthy) = if forall Term.is_TVar ( + MRBNF_Def.frees_of_mrbnf lmrbnf @ MRBNF_Def.bounds_of_mrbnf lmrbnf @ MRBNF_Def.lives_of_mrbnf lmrbnf + ) then + lthy + |> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.frees_of_mrbnf lmrbnf)) + ||>> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.bounds_of_mrbnf lmrbnf)) + ||>> mk_TFrees (MRBNF_Def.live_of_mrbnf lmrbnf) + ||>> mk_TFrees' (map Type.sort_of_atyp ldeads) + else ( + (((MRBNF_Def.frees_of_mrbnf lmrbnf, MRBNF_Def.bounds_of_mrbnf lmrbnf), + MRBNF_Def.lives_of_mrbnf lmrbnf), ldeads), lthy + ) + + val (As', names_lthy) = if forall Term.is_TVar (MRBNF_Def.lives'_of_mrbnf lmrbnf) then + fold Variable.declare_typ (Fs @ Bs @ As @ deads) names_lthy + |> mk_TFrees (MRBNF_Def.live_of_mrbnf lmrbnf) + else (MRBNF_Def.lives'_of_mrbnf lmrbnf, names_lthy) + + val (fs, names_lthy) = names_lthy + |> mk_Frees "f" (MRBNF_Def.interlace (map2 (curry (op-->)) As As') (map (fn a => a --> a) Bs) (map (fn a => a --> a) Fs) (MRBNF_Def.var_types_of_mrbnf lmrbnf)); + + val subst = + (MRBNF_Def.frees_of_mrbnf lmrbnf ~~ Fs) + @ (MRBNF_Def.bounds_of_mrbnf lmrbnf ~~ Bs) + @ (MRBNF_Def.lives_of_mrbnf lmrbnf ~~ As) + @ (MRBNF_Def.lives'_of_mrbnf lmrbnf ~~ As') + @ (ldeads ~~ deads) + val subst_phi = MRBNF_Util.subst_typ_morphism subst; + val mrbnfs = map (MRBNF_Def.morph_mrbnf subst_phi) mrbnfs; + + local + val T = fastype_of (MRBNF_Def.map_of_mrbnf (hd mrbnfs)); + val T' = case BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv of + SOME Map => fastype_of Map + | NONE => fastype_of (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv) + val tyenv = try (Sign.typ_match (Proof_Context.theory_of lthy) + (snd (split_last (binder_types T')) --> body_type T', snd (split_last (binder_types T)) --> body_type T) + ) Vartab.empty; + val phi = Option.map (fn tyenv => MRBNF_Util.subst_typ_morphism (map (fn (n, (s, T)) => (TVar (n, s), T)) (Vartab.dest tyenv))) tyenv; + in + val bmv = BMV_Monad_Def.morph_bmv_monad (the_default subst_phi phi) bmv; + end + + val axioms = @{map 8} (fn i => fn mrbnf => fn Sb => fn Injs => fn RVrs => fn Vrs => fn Map_opt => fn lives => + let + val mapx = MRBNF_Def.map_of_mrbnf mrbnf; + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + + val fs = map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of mapx)))); + + val (live_fs, bound_fs, free_fs') = MRBNF_Def.deinterlace fs var_types; + + val frees = inter (op=) (take (length (leader BMV_Monad_Def.frees_of_bmv_monad bmv)) Fs) (MRBNF_Def.frees_of_mrbnf mrbnf); + val pfrees = subtract (op=) frees (MRBNF_Def.frees_of_mrbnf mrbnf); + + val free = length frees; + val free_fs = take free free_fs'; + + val free_prems' = map (HOLogic.mk_Trueprop o mk_supp_bound) free_fs'; + val free_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) free_fs; + val live_fs' = filter (member (op=) lives o domain_type o fastype_of) live_fs; + + val map_is_Sb = fold_rev Logic.all (free_fs' @ live_fs') (fold_rev (curry Logic.mk_implies) free_prems' (mk_Trueprop_eq ( + Term.list_comb (Term.subst_atomic_types (filter_out (member (op=) lives o snd) (As' ~~ As)) mapx, MRBNF_Def.interlace + (map (fn a => the_default (HOLogic.id_const a) ( + List.find (curry (op=) a o domain_type o fastype_of) live_fs' + )) As) (map HOLogic.id_const Bs) free_fs' + (MRBNF_Def.var_types_of_mrbnf mrbnf) + ), + let val add_Map = case Map_opt of + NONE => I + | SOME Map => fn t => HOLogic.mk_comp (Term.subst_atomic_types (filter (member (op=) lives o fst) (As ~~ As')) t, + Term.list_comb (Map, map (fn T => + the (List.find (curry (op=) T o fastype_of) live_fs') + ) (fst (split_last (binder_types (fastype_of Map))))) + ) + in add_Map (Term.list_comb (Sb, map (fn RVr => + let val T = HOLogic.dest_setT (body_type (fastype_of RVr)); + in the_default (HOLogic.id_const T) (List.find (fn f => + T = domain_type (fastype_of f) + ) free_fs') end) RVrs @ map (fn Inj => + HOLogic.mk_comp (Inj, the (List.find (fn f => (op=) (apply2 (domain_type o fastype_of) (Inj, f))) fs)) + ) Injs) + ) end + ))); + + val RVrs_aTs = map (HOLogic.dest_setT o body_type o fastype_of) RVrs; + + val (((gs, hs), x), _) = names_lthy + |> mk_Frees "g" (map fastype_of Injs) + ||>> mk_Frees "h" (map (fn a => a --> a) RVrs_aTs) + ||>> apfst hd o mk_Frees "x" [body_type (fastype_of Sb)]; + + val live = MRBNF_Def.live_of_mrbnf mrbnf; + val other_prems = flat (MRBNF_Def.interlace (replicate live []) + (map (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) bound_fs) + (replicate (length free_fs') []) + var_types + ); + val other_fs = flat (MRBNF_Def.interlace (map single live_fs) (map single bound_fs) + (replicate (length free_fs') []) var_types); + + val g_prems = flat (BMV_Monad_Def.mk_small_prems_of_bmv_monad bmv i hs gs); + + val count = live + MRBNF_Def.bound_of_mrbnf mrbnf; + val map_Sb = if count = 0 then NONE else + let + val map_t = Term.list_comb (mapx, MRBNF_Def.interlace live_fs bound_fs (map (HOLogic.id_const o domain_type o fastype_of) free_fs') var_types); + val Sb_t = Term.list_comb (Sb, hs @ gs); + in SOME (fold_rev Logic.all (other_fs @ hs @ gs) (fold_rev (curry Logic.mk_implies) (other_prems @ g_prems) (mk_Trueprop_eq ( + HOLogic.mk_comp (map_t, Sb_t), + HOLogic.mk_comp (Term.list_comb (Term.subst_atomic_types (As ~~ As') Sb, hs @ map (fn g => + let + val mapx = Option.map MRBNF_Def.map_of_mrbnf ( + List.find (curry (op=) (body_type (fastype_of g)) o MRBNF_Def.T_of_mrbnf) mrbnfs + ); + val add_map = case mapx of + NONE => I + | SOME mapx => fn t => + let val fs = map (fn T => the_default (HOLogic.id_const T) ( + List.find (curry (op=) T o domain_type o fastype_of) other_fs + )) (map domain_type (fst (split_last (binder_types (fastype_of mapx))))) + in if forall (fn Const (@{const_name id}, _) => true | _ => false) fs then t else + HOLogic.mk_comp (Term.list_comb (mapx, fs), t) + end + in add_map g end + ) gs), map_t) + )))) end; + + val sets = MRBNF_Def.sets_of_mrbnf mrbnf; + val (live_sets, bound_sets, free_sets) = MRBNF_Def.deinterlace sets var_types; + + val set_Sbs = + let + val sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) + (replicate (length free_fs') []) var_types); + in map (fn set => fold_rev Logic.all (hs @ gs @ [x]) (fold_rev (curry Logic.mk_implies) g_prems ( + mk_Trueprop_eq (set $ (Term.list_comb (Sb, hs @ gs) $ x), foldl1 mk_Un ((set $ x) :: + @{map_filter 2} (fn Vrs => fn g => Option.mapPartial (fn mrbnf => Option.map (fn set => + mk_UNION (Vrs $ x) (Term.abs ("x", HOLogic.dest_setT (body_type (fastype_of Vrs))) ( + set $ (g $ Bound 0) + )) + ) (List.find (curry (op=) (body_type (fastype_of set)) o body_type o fastype_of) (MRBNF_Def.sets_of_mrbnf mrbnf))) + (List.find (curry (op=) (body_type (fastype_of g)) o MRBNF_Def.T_of_mrbnf) mrbnfs) + ) Vrs gs)) + ))) sets' end; + + val set_Vrs = map (fn set => + let + val aT = HOLogic.dest_setT (fastype_of (set $ x)); + val Vrs = filter (curry (op=) aT o HOLogic.dest_setT o body_type o fastype_of) (RVrs @ Vrs); + val Vrs' = map (fn Vrs => Vrs $ x) Vrs; + in Logic.all x (mk_Trueprop_eq (set $ x, case Vrs' of + [] => mk_bot aT + | _ => foldl1 mk_Un Vrs' + )) end + ) free_sets; + + val map_Injs = if MRBNF_Def.bound_of_mrbnf mrbnf = 0 then NONE else SOME (map_filter (fn Inj => + if body_type (fastype_of Inj) <> body_type (fastype_of Sb) then NONE else + let + val mk_ids = map (HOLogic.id_const o domain_type o fastype_of); + val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) (mk_ids live_fs) bound_fs (mk_ids free_fs') mrbnf; + val goal = fold_rev Logic.all bound_fs (fold_rev (curry Logic.mk_implies) (maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) bound_fs) ( + mk_Trueprop_eq (HOLogic.mk_comp (map_t, Inj), Inj) + )); + in SOME goal end + ) Injs) + in { + map_is_Sb = map_is_Sb, + map_Injs = map_Injs, + set_Vrs = set_Vrs, + map_Sb = map_Sb, + set_Sb = set_Sbs + }: term mrsbnf_axioms end + ) (0 upto length mrbnfs - 1) mrbnfs + (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) + (BMV_Monad_Def.RVrs_of_bmv_monad bmv) + (BMV_Monad_Def.Vrs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv) (BMV_Monad_Def.lives_of_bmv_monad bmv); + in (axioms, (deads, As, As', Bs, Fs, fs), mrbnfs, bmv) end + +fun prove_axioms mrbnfs bmv tacs lthy = + let + val (goals, vars, mrbnfs, bmv) = mk_mrsbnf_axioms mrbnfs bmv lthy; + val tacs' = map (map_mrsbnf_axioms (fn tac => fn goal => Goal.prove_sorry lthy [] [] goal (tac o #context))) tacs; + val _ = if length tacs' = length goals then () else + error ("Expected " ^ string_of_int (length goals) ^ " sets of axiom tactics, but got " ^ string_of_int (length tacs')) + in (map2 apply_mrsbnf_axioms tacs' goals, vars, mrbnfs, bmv) end + +fun mrsbnf_def fact_policy qualify name_opt mrbnfs bmv tacs lthy = + let + val (axioms, vars, mrbnfs, bmv) = prove_axioms mrbnfs bmv tacs lthy; + in mk_mrsbnf fact_policy qualify vars name_opt mrbnfs bmv axioms lthy end + +fun mrsbnf_of_mrbnf qualify mrbnf lthy = + let + val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_mrbnf qualify mrbnf lthy; + val bmv_vars = BMV_Monad_Def.lives_of_bmv_monad bmv @ BMV_Monad_Def.lives'_of_bmv_monad bmv + @ BMV_Monad_Def.frees_of_bmv_monad bmv @ BMV_Monad_Def.deads_of_bmv_monad bmv; + val bmv = BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism (map (fn a => (a, Logic.varifyT_global a)) (flat bmv_vars))) bmv; + val n = MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf; + + val bmv = + let + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) + ((hd (BMV_Monad_Def.ops_of_bmv_monad bmv), MRBNF_Def.T_of_mrbnf mrbnf) + :: the_default [] (Option.map (fn Map => + [(body_type (fastype_of Map), body_type (fastype_of (MRBNF_Def.map_of_mrbnf mrbnf)))] + ) (hd (BMV_Monad_Def.Maps_of_bmv_monad bmv)) + )) Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism (map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv)) + in BMV_Monad_Def.morph_bmv_monad phi bmv end; + in mrsbnf_def (K BNF_Def.Dont_Note) qualify NONE [mrbnf] bmv [{ + map_Sb = SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ unfolds_of_bmv_monad bmv)), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt (trans OF [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt sym, + rtac ctxt (trans OF [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ] + ]), + map_is_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (unfolds_of_bmv_monad bmv)), + TRY o EVERY' [ + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt (MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + resolve_tac ctxt [refl, MRBNF_Def.map_id0_of_mrbnf mrbnf] + ], + map_Injs = if MRBNF_Def.bound_of_mrbnf mrbnf = 0 then NONE else SOME [], + set_Sb = replicate n (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms id_apply} @ unfolds_of_bmv_monad bmv)), + rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt trans, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt @{thm image_id} + ] + ]), + set_Vrs = replicate (MRBNF_Def.free_of_mrbnf mrbnf) (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (unfolds_of_bmv_monad bmv)), + rtac ctxt refl + ]) + }] lthy end; + +fun mrsbnf_cmd b_Ts lthy = + let + val Ts = map (Syntax.read_typ lthy o snd) b_Ts; + val ancestors = map Context.theory_base_name ( + Context.ancestors_of (Proof_Context.theory_of lthy) + ); + val b = fst (hd b_Ts); + val name = if Binding.is_empty b then fst (dest_Type (hd Ts)) else Local_Theory.full_name lthy b; + fun find_bmv [] = error ("Type " ^ name ^ " is not a PBMV Monad") + | find_bmv (x::xs) = (case BMV_Monad_Def.pbmv_monad_of lthy (Binding.name_of (Binding.prefix_name (x ^ ".") b)) of + NONE => find_bmv xs + | SOME bmv => bmv) + fun find_mrbnf [] = NONE + | find_mrbnf (x::xs) = (case MRBNF_Def.mrbnf_of lthy (Binding.name_of (Binding.prefix_name (x ^ ".") b)) of + NONE => find_mrbnf xs + | SOME mrbnf => SOME mrbnf) + + val (mrbnfs, lthy) = @{fold_map 2} (fn T => fn b => fn lthy => + let + val name = if Binding.is_empty b then fst (dest_Type T) else Local_Theory.full_name lthy b; + val (mrbnf, lthy) = case MRBNF_Def.mrbnf_of lthy name of + SOME mrbnf => (SOME mrbnf, lthy) + | NONE => case BNF_Def.bnf_of lthy name of + SOME bnf => apfst SOME (MRBNF_Def.mrbnf_of_bnf bnf lthy) + | NONE => (find_mrbnf ancestors, lthy) + val mrbnf = case mrbnf of SOME mrbnf => mrbnf | NONE => error ("Type " ^ name ^ " is not a (MR)BNF") + in (mrbnf, lthy) end + ) Ts (map fst b_Ts) lthy; + val bmv_monad = case BMV_Monad_Def.pbmv_monad_of lthy name of + SOME bmv => bmv + | NONE => find_bmv ancestors + + val mrbnfs = @{map 3} (fn T => fn Map_opt => fn mrbnf => + let + val xs = case Map_opt of + NONE => [(MRBNF_Def.T_of_mrbnf mrbnf, T)] + | SOME Map => let + fun get_T t = (snd (split_last (binder_types (fastype_of t))), body_type (fastype_of t)) + val T = get_T Map + val T' = get_T (MRBNF_Def.map_of_mrbnf mrbnf) + in [(fst T', fst T), (snd T', snd T)] end + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) xs Vartab.empty; + val phi = MRBNF_Util.subst_typ_morphism (map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv)); + in MRBNF_Def.morph_mrbnf phi mrbnf end + ) (BMV_Monad_Def.ops_of_bmv_monad bmv_monad) (BMV_Monad_Def.Maps_of_bmv_monad bmv_monad) mrbnfs; + + val (goals, vars, mrbnfs, bmv) = mk_mrsbnf_axioms mrbnfs bmv_monad lthy; + + fun after_qed thmss lthy = + let + val thms = map hd thmss; + + fun chop_opt _ NONE thms = (NONE, thms) + | chop_opt n (SOME _) thms = (SOME (take n thms), drop n thms) + + val axioms = fst (fold_map (fn goals => fn thms => + let val (((((map_is_Sb, map_Sb), map_Injs), set_Vrs), set_Sb), thms) = thms + |> apfst hd o chop 1 + ||>> apfst (Option.map hd) o chop_opt 1 (#map_Sb goals) + ||>> chop_opt (the_default 0 (Option.map length (#map_Injs goals))) (#map_Injs goals) + ||>> chop (length (#set_Vrs goals)) + ||>> chop (length (#set_Sb goals)); + in ({ + map_is_Sb = map_is_Sb, + map_Sb = map_Sb, + map_Injs = map_Injs, + set_Vrs = set_Vrs, + set_Sb = set_Sb + }: thm mrsbnf_axioms, thms) end + ) goals thms); + + val (mrsbnf, lthy) = mk_mrsbnf (K BNF_Def.Note_Some) I vars (SOME name) mrbnfs bmv axioms lthy; + val (_, lthy) = note_mrsbnf_thms (K BNF_Def.Note_Some) I (SOME name) mrsbnf lthy; + val lthy = register_mrsbnf name mrsbnf lthy; + in lthy end + + in Proof.theorem NONE after_qed (map (single o rpair []) (maps (fn goals => + #map_is_Sb goals :: the_default [] (Option.map single (#map_Sb goals)) @ the_default [] (#map_Injs goals) + @ #set_Vrs goals @ #set_Sb goals + ) goals)) lthy + |> Proof.unfolding ([[( + BMV_Monad_Def.unfolds_of_bmv_monad bmv + @ map MRBNF_Def.map_def_of_mrbnf mrbnfs + @ maps MRBNF_Def.set_defs_of_mrbnf mrbnfs + , [])]]) + |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) + end + +val _ = Outer_Syntax.local_theory_to_proof @{command_keyword mrsbnf} + "register a map-restricted substitutive bounded natural functor" + ((Parse.and_list1 (parse_opt_binding_colon -- Parse.typ)) >> mrsbnf_cmd) + +end diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML new file mode 100644 index 00000000..6b7d2c73 --- /dev/null +++ b/Tools/tvsubst.ML @@ -0,0 +1,2498 @@ +signature TVSUBST = +sig + type 'a eta_axioms = { + eta_free: 'a, + eta_compl_free: 'a, + eta_inj: 'a, + eta_natural: 'a, + eta_Sb: 'a + }; + + type 'a eta_model = { + eta: term, + Inj: term * thm, + tacs: 'a eta_axioms + }; + + type tvsubst_result = { + tvsubst: term, + isInjs: (term * thm) list, + tvsubst_Injs: thm list, + tvsubst_not_isInj: thm, + IImsupp_Diffs: thm list, + IImsupp_permute_commutes: thm list, + tvsubst_permute: thm, + mrsbnf: MRSBNF_Def.mrsbnf + }; + + val create_tvsubst_of_mrsbnf: (binding -> binding) -> MRBNF_FP_Def_Sugar.fp_result + -> MRSBNF_Def.mrsbnf -> MRBNF_Def.mrbnf -> thm -> thm -> thm list -> binding + -> (Proof.context -> tactic) eta_model option list -> string -> local_theory + -> tvsubst_result * local_theory +end + +structure TVSubst : TVSUBST = +struct + +open BNF_Tactics +open BNF_Util +open MRBNF_Util + +type 'a eta_axioms = { + eta_free: 'a, + eta_compl_free: 'a, + eta_inj: 'a, + eta_natural: 'a, + eta_Sb: 'a +}; + +type 'a eta_model = { + eta: term, + Inj: term * thm, + tacs: 'a eta_axioms +}; + +type tvsubst_result = { + tvsubst: term, + isInjs: (term * thm) list, + tvsubst_Injs: thm list, + tvsubst_not_isInj: thm, + IImsupp_Diffs: thm list, + IImsupp_permute_commutes: thm list, + tvsubst_permute: thm, + mrsbnf: MRSBNF_Def.mrsbnf +}; + +val names = map (fst o dest_Free); + +fun fold_map_option _ NONE x = (NONE, x) + | fold_map_option f (SOME x) y = apfst SOME (f x y) + +fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_model option list) lthy = + let + val (fp_res, mrsbnf) = + let + val pre_T = body_type (fastype_of (hd (map_filter (Option.map #eta) models))); + + val mrbnf = hd (#pre_mrbnfs fp_res'); + val (As', _) = lthy + |> fold Variable.declare_typ (map TFree (Term.add_tfreesT pre_T [])) + |> mk_TFrees (MRBNF_Def.live_of_mrbnf mrbnf) + + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) ( + MRBNF_Def.T_of_mrbnf mrbnf, pre_T + ) Vartab.empty; + val fp_res = MRBNF_FP_Def_Sugar.morph_fp_result (MRBNF_Util.subst_typ_morphism ( + map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv) + )) fp_res'; + + val fp_res = MRBNF_FP_Def_Sugar.morph_fp_result (MRBNF_Util.subst_typ_morphism ( + MRBNF_Def.lives'_of_mrbnf (hd (#pre_mrbnfs fp_res)) ~~ As' + )) fp_res; + val mrbnf = hd (#pre_mrbnfs fp_res); + + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf'; + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) ([ + (BMV_Monad_Def.leader BMV_Monad_Def.ops_of_bmv_monad bmv, pre_T) + ] @ the_default [] (Option.map (fn Map => [ + apply2 (body_type o fastype_of) (Map, MRBNF_Def.map_of_mrbnf mrbnf) + ]) (BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv))) Vartab.empty; + val mrsbnf = MRSBNF_Def.morph_mrsbnf (MRBNF_Util.subst_typ_morphism ( + map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv) + )) mrsbnf'; + in (fp_res, mrsbnf) end + + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val mrbnfs = #pre_mrbnfs fp_res; + val mrbnf = hd mrbnfs; + + val (etas, lthy) = fold_map (fold_map_option (fn { eta, Inj, tacs } => fn lthy => + let + fun mk_endo a = a --> a + + val f_Ts = MRBNF_Def.interlace + (map2 (curry (op-->)) (MRBNF_Def.lives_of_mrbnf mrbnf) (MRBNF_Def.lives'_of_mrbnf mrbnf)) + (map mk_endo (MRBNF_Def.bounds_of_mrbnf mrbnf)) + (map mk_endo (MRBNF_Def.frees_of_mrbnf mrbnf)) + (MRBNF_Def.var_types_of_mrbnf mrbnf); + + val ((((((a, b), fs), gs), rhos), x), _) = lthy + |> apfst hd o mk_Frees "a" [domain_type (fastype_of eta)] + ||>> apfst hd o mk_Frees "b" [domain_type (fastype_of eta)] + ||>> mk_Frees "f" f_Ts + ||>> mk_Frees "g" (map (mk_endo o HOLogic.dest_setT o body_type o fastype_of) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_of_bmv_monad bmv)) + ||>> mk_Frees "\" (map fastype_of (BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv)) + ||>> apfst hd o mk_Frees "x" [body_type (fastype_of eta)] + + val Vrs = the (List.find (fn RVrs => HOLogic.dest_setT (body_type (fastype_of RVrs)) = domain_type (fastype_of eta)) + (hd (BMV_Monad_Def.RVrs_of_bmv_monad bmv))); + + fun prove vars goal tac = Goal.prove_sorry lthy (names vars) [] goal (tac o #context) + + val eta_free_goal = mk_Trueprop_eq (Vrs $ (eta $ a), mk_singleton a); + val eta_free = prove [a] eta_free_goal (#eta_free tacs); + + val eta_compl_free_goal = Logic.all x (Logic.mk_implies ( + HOLogic.mk_Trueprop (mk_all (dest_Free a) (HOLogic.mk_not ( + HOLogic.mk_eq (x, eta $ a) + ))), + mk_Trueprop_eq (Vrs $ x, mk_bot (fastype_of a)) + )); + val eta_compl_free = prove [] eta_compl_free_goal (#eta_compl_free tacs); + + val eta_inj_goal = Logic.mk_implies ( + mk_Trueprop_eq (eta $ a, eta $ b), mk_Trueprop_eq (a, b) + ); + val eta_inj = prove [a, b] eta_inj_goal (#eta_inj tacs); + + val nvars = length (#FVarss (hd (#quotient_fps fp_res))); + + val f_prems = map HOLogic.mk_Trueprop (flat (map2 (fn f => + fn MRBNF_Def.Live_Var => [] + | MRBNF_Def.Free_Var => [mk_supp_bound f] + | MRBNF_Def.Bound_Var => [mk_bij f, mk_supp_bound f] + ) fs (MRBNF_Def.var_types_of_mrbnf mrbnf))); + + val subst = MRBNF_Def.lives_of_mrbnf mrbnf ~~ MRBNF_Def.lives'_of_mrbnf mrbnf; + + val eta_natural_goal = fold_rev Logic.all fs (fold_rev (curry Logic.mk_implies) f_prems (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (MRBNF_Def.map_of_mrbnf mrbnf, fs), eta), + HOLogic.mk_comp (Term.subst_atomic_types subst eta, the (List.find (curry (op=) (domain_type (fastype_of eta)) o domain_type o fastype_of) fs) + )))); + val eta_natural = prove [] eta_natural_goal (#eta_natural tacs); + + val g_prems = flat ( + BMV_Monad_Def.mk_small_prems_of_bmv_monad bmv (BMV_Monad_Def.leader_of_bmv_monad bmv) gs rhos + ); + val live_fs = map (fn l => the (List.find (curry (op=) l o domain_type o fastype_of) fs)) ( + BMV_Monad_Def.leader BMV_Monad_Def.lives_of_bmv_monad bmv + ); + val pbound = MRBNF_Def.bound_of_mrbnf mrbnf - nvars; + val bound_fs = map (fn l => the (List.find (curry (op=) l o domain_type o fastype_of) fs)) ( + MRBNF_Def.bounds_of_mrbnf mrbnf + ); + + val bf_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) (take pbound bound_fs); + + val eta_Sb_goal = fold_rev Logic.all (gs @ rhos @ live_fs @ take pbound bound_fs @ [a, x]) (fold_rev (curry Logic.mk_implies) (bf_prems @ g_prems) (Logic.mk_implies ( + mk_Trueprop_eq ( + Term.subst_atomic_types subst (Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, gs @ rhos)) + $ (if pbound + MRBNF_Def.live_of_mrbnf mrbnf = 0 then I else + fn t => MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) live_fs + (take pbound bound_fs @ map HOLogic.id_const (drop pbound (MRBNF_Def.bounds_of_mrbnf mrbnf))) + (map HOLogic.id_const (MRBNF_Def.frees_of_mrbnf mrbnf)) mrbnf $ t + ) x, + Term.subst_atomic_types subst eta $ a + ), + HOLogic.mk_Trueprop (mk_ex (dest_Free a) (HOLogic.mk_eq (x, eta $ a))) + ))); + val eta_Sb = prove [] eta_Sb_goal (#eta_Sb tacs); + in ({ + eta = eta, + Inj = Inj, + tacs = { + eta_free = eta_free, + eta_compl_free = eta_compl_free, + eta_inj = eta_inj, + eta_natural = eta_natural, + eta_Sb = eta_Sb + } + }: thm eta_model, lthy) end + )) models lthy; + + val (fp_res, mrsbnf) = + let + val T = body_type (fastype_of (hd (map_filter (Option.map (fst o #Inj)) models))); + + val quot = hd (#quotient_fps fp_res'); + + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) ( + body_type (fastype_of (#ctor quot)), T + ) Vartab.empty; + val fp_res = MRBNF_FP_Def_Sugar.morph_fp_result (MRBNF_Util.subst_typ_morphism ( + map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv) + )) fp_res'; + + val pre_T = domain_type (fastype_of (#ctor (hd (#quotient_fps fp_res)))); + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf'; + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) ([ + (BMV_Monad_Def.leader BMV_Monad_Def.ops_of_bmv_monad bmv, pre_T) + ] @ the_default [] (Option.map (fn Map => [ + (body_type (fastype_of Map), pre_T) + ]) (BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv))) Vartab.empty; + val mrsbnf = MRSBNF_Def.morph_mrsbnf (MRBNF_Util.subst_typ_morphism ( + map (fn (x, (s, T)) => (TVar (x, s), T)) (Vartab.dest tyenv) + )) mrsbnf'; + in (fp_res, mrsbnf) end + + val etas = map (Option.map (fn { eta, Inj, tacs } => + let + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) ( + Logic.varifyT_global (body_type (fastype_of eta)), + domain_type (fastype_of (#ctor (hd (#quotient_fps fp_res)))) + ) Vartab.empty; + in { + eta = Envir.subst_term (tyenv, Vartab.empty) (Logic.varify_types_global eta), + Inj = Inj, + tacs = tacs + }: thm eta_model end)) etas; + + in (fp_res, mrsbnf, etas, lthy) end; + +fun define_tvsubst_consts qualify (fp_res : MRBNF_FP_Def_Sugar.fp_result) (etas : thm eta_model option list) lthy = + let + val b = Binding.conglomerate (map (Binding.name o short_type_name o fst o dest_Type o #T) (#quotient_fps fp_res)); + val mk_def_t = MRBNF_Util.mk_def_t false b qualify; + + val (_, lthy) = Local_Theory.begin_nested lthy; + + val (defs, lthy) = @{fold_map 2} (fn i => fold_map_option (fn { Inj=(Inj, _), ... } => fn lthy => + let + val ((a, t), _) = lthy + |> apfst hd o mk_Frees "a" [domain_type (fastype_of Inj)] + ||>> apfst hd o mk_Frees "t" [body_type (fastype_of Inj)]; + + val (isInj, lthy) = mk_def_t ("isInj" ^ string_of_int i) 1 (Term.absfree (dest_Free t) ( + mk_ex (dest_Free a) (HOLogic.mk_eq (t, Inj $ a)) + )) lthy; + + val (asInj, lthy) = mk_def_t ("asInj" ^ string_of_int i) 1 (Term.absfree (dest_Free t) ( + BNF_FP_Util.mk_If (fst isInj $ t) + (HOLogic.choice_const (fastype_of a) $ Term.absfree (dest_Free a) (HOLogic.mk_eq (Inj $ a, t))) + (BNF_GFP_Util.mk_undefined (fastype_of a)) + )) lthy; + + in ({ + aT = fastype_of a, + isInj = isInj, + asInj = asInj + }, lthy) end + )) (1 upto length etas) etas lthy; + + val some_defs = map_filter I defs; + + val (lthy, old_lthy) = `Local_Theory.end_nested lthy; + val phi = Proof_Context.export_morphism old_lthy lthy; + + val morph = + let + val t = fst (#isInj (hd some_defs)); + val t' = Morphism.term phi t; + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (fastype_of t', fastype_of t) Vartab.empty; + val subst = Envir.subst_term (tyenv, Vartab.empty); + in fn (t, thm) => ( + Morphism.term (phi $> Morphism.term_morphism "fix_tyvars" subst) t, + Morphism.thm phi thm + ) end; + + val defs = map (Option.map (fn { aT, isInj, asInj } => { + aT = aT, + isInj = morph isInj, + asInj = morph asInj + })) defs; + + in (defs, lthy) end; + +fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_permute set_simps tvsubst_b models QREC_fixed_name no_defs_lthy = + let + val (fp_res, mrsbnf, etas, lthy) = prove_model_axioms fp_res mrsbnf models no_defs_lthy; + + val (defs, lthy) = define_tvsubst_consts qualify fp_res etas lthy; + + val quot = hd (#quotient_fps fp_res); + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + + val frees = map (HOLogic.dest_setT o body_type o fastype_of) (#FVarss (hd (#quotient_fps fp_res))); + + val mrbnf = hd (#pre_mrbnfs fp_res); + val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val free = MRBNF_Def.free_of_mrbnf mrbnf; + val bound = MRBNF_Def.bound_of_mrbnf mrbnf; + val live = MRBNF_Def.live_of_mrbnf mrbnf; + val n = free + bound + live; + val nrecs = foldr1 (op+) (#rec_vars fp_res); + val nvars = length frees; + + val args = (snd o dest_Type o body_type o fastype_of o #eta) (hd (map_filter I etas)); + val (live_args, bound_args, free_args) = fold_rev ( + fn (MRBNF_Def.Live_Var, x) => (fn (a, b, c) => (x::a, b, c)) + | (MRBNF_Def.Bound_Var, x) => (fn (a, b, c) => (a, x::b, c)) + | (MRBNF_Def.Free_Var, x) => (fn (a, b, c) => (a, b, x::c)) + ) (var_types ~~ args) ([], [], []); + + val pfrees = drop nvars free_args; + val pbounds = take (bound - nvars) bound_args; + val plives = take (live - nrecs) live_args; + + val defs = map (fn a => Option.map (fn (eta, def) => { + aT = #aT def, + eta = #eta eta, + Inj = #Inj eta, + isInj = #isInj def, + asInj = #asInj def, + axioms = #tacs eta + }) (List.find (curry (op=) a o domain_type o fastype_of o fst o #Inj o fst) (map_filter I etas ~~ map_filter I defs))) (frees @ pfrees); + + val Inj_injs = map (Option.map (fn def => + let + val (a, b) = (Free ("a", #aT def), Free ("b", #aT def)); + in Goal.prove_sorry lthy ["a", "b"] [] (Logic.mk_implies ( + mk_Trueprop_eq (fst (#Inj def) $ a, fst (#Inj def) $ b), + mk_Trueprop_eq (a, b) + )) (fn {context=ctxt, ...} => EVERY1 [ + K (unfold_thms_tac ctxt (@{thms comp_def} @ [snd (#Inj def)])), + rtac ctxt (#eta_inj (#axioms def)), + dtac ctxt (iffD1 OF [#inject quot]), + REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], + dtac ctxt @{thm trans[rotated]}, + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt (Local_Defs.unfold0 ctxt @{thms comp_def} (fun_cong OF [#eta_natural (#axioms def)])), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt @{thm arg_cong[OF id_apply]}, + assume_tac ctxt + ]) end + )) defs; + + val asInj_Injs = map2 (fn Inj_inj => Option.map (fn def => + let val a = Free ("a", #aT def) + in Goal.prove_sorry lthy (names [a]) [] + (mk_Trueprop_eq (fst (#asInj def) $ (fst (#Inj def) $ a), a)) + (fn {context=ctxt, ...} => EVERY1 [ + K (unfold_thms_tac ctxt [snd (#asInj def), snd (#isInj def)]), + rtac ctxt trans, + rtac ctxt @{thm if_P}, + rtac ctxt exI, + rtac ctxt refl, + rtac ctxt @{thm some_equality}, + rtac ctxt refl, + rtac ctxt (the Inj_inj), + assume_tac ctxt + ]) end + )) Inj_injs defs; + + val nvars = length frees; + val (((fs, gs), some_rhos), _) = lthy + |> mk_Frees "f" (map (fn a => a --> a) frees) + ||>> mk_Frees "g" (map (fn a => a --> a) frees) + ||>> mk_Frees "\" (map_filter (Option.map (fastype_of o fst o #Inj)) etas @ map fastype_of (BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv)); + val f_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) fs; + val g_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) gs; + + val rhos = map (fn a => List.find (curry (op=) a o domain_type o fastype_of) some_rhos) (frees @ pfrees); + + val permute_Injs = map2 (fn i => Option.map (fn def => + let + val a = Free ("a", #aT def); + val Inj = fst (#Inj def) + val goal = mk_Trueprop_eq ( + Term.list_comb (#permute quot, fs) $ (Inj $ a), + Inj $ (nth fs i $ a) + ); + in Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + K (unfold_thms_tac ctxt [snd (#Inj def), @{thm comp_def}]), + rtac ctxt trans, + rtac ctxt (#permute_ctor quot), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + rtac ctxt (infer_instantiate' ctxt [NONE, NONE, SOME (Thm.cterm_of ctxt (#ctor quot))] arg_cong), + rtac ctxt (Local_Defs.unfold0 ctxt @{thms comp_def} (fun_cong OF [#eta_natural (#axioms def)])), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems) + ]) end + )) (0 upto length defs - 1) defs; + + val isInj_permutes = map2 (fn permute_VVr => Option.map (fn def => + let + val x = Free ("x", #T quot); + val goal = mk_Trueprop_eq ( + fst (#isInj def) $ (Term.list_comb (#permute quot, fs) $ x), + fst (#isInj def) $ x + ); + in Goal.prove_sorry lthy (names (fs @ [x])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + K (unfold_thms_tac ctxt [snd (#isInj def)]), + rtac ctxt iffI, + etac ctxt exE, + dtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quot, map mk_inv (fs)))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_asm_tac ctxt [0] [@{thm inv_o_simp1}, #permute_comp quot, the permute_VVr], + REPEAT_DETERM o resolve_tac ctxt (@{thms bij_id supp_id_bound supp_inv_bound bij_imp_bij_inv} @ prems) + ], + K (unfold_thms_tac ctxt [#permute_id quot]), + rtac ctxt exI, + assume_tac ctxt, + etac ctxt exE, + hyp_subst_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] [the permute_VVr], + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt exI, + rtac ctxt refl + ]) end + )) permute_Injs defs; + + fun mk_IImsupp' a Inj rho Vrs = + if domain_type (fastype_of Inj) = a then + mk_Un (mk_SSupp Inj $ rho, mk_IImsupp Inj Vrs $ rho) + else mk_IImsupp Inj Vrs $ rho; + + val sets = MRBNF_Def.mk_sets_of_mrbnf (replicate n (MRBNF_Def.deads_of_mrbnf mrbnf)) + (replicate n live_args) (replicate n bound_args) (replicate n free_args) mrbnf; + val rec_n = MRBNF_Def.live_of_mrbnf rec_mrbnf + MRBNF_Def.bound_of_mrbnf rec_mrbnf + MRBNF_Def.free_of_mrbnf rec_mrbnf + val rec_sets = MRBNF_Def.mk_sets_of_mrbnf (replicate rec_n (MRBNF_Def.deads_of_mrbnf rec_mrbnf)) + (replicate rec_n plives) (replicate rec_n pbounds) (replicate rec_n free_args) rec_mrbnf; + val (live_sets, bound_sets, free_sets) = MRBNF_Def.deinterlace rec_sets (MRBNF_Def.var_types_of_mrbnf rec_mrbnf); + + val IImsuppss = map2 (fn def => fn rho => case def of + SOME def => map (fn FVars => SOME ( + mk_IImsupp' (HOLogic.dest_setT (body_type (fastype_of FVars))) (fst (#Inj def)) (the rho) FVars + )) free_sets + | NONE => the_default [] (Option.map (fn rho => + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) (BMV_Monad_Def.ops_of_bmv_monad bmv); + val Inj = the (List.find (curry (op=) (fastype_of rho) o fastype_of) (nth (BMV_Monad_Def.Injs_of_bmv_monad bmv) idx)); + val Vrs = nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) idx; + in map (fn a => Option.map (fn Vrs => + mk_IImsupp' a Inj rho Vrs + ) (List.find (curry (op=) a o HOLogic.dest_setT o body_type o fastype_of) Vrs)) (frees @ pfrees) end + ) rho)) defs rhos; + + val IImsupp_Injs = @{map 4} (fn f => fn rho => fn IImsupps => Option.map (fn def => + let + val a = Free ("a", #aT def); + val IImsupp = List.find (curry (op=) (domain_type (fastype_of f)) o HOLogic.dest_setT o body_type o fastype_of) + (map_filter I IImsupps); + val goal = Logic.mk_implies ( + HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (f $ a, a))), + Logic.mk_implies ( + HOLogic.mk_Trueprop (mk_int_empty (mk_imsupp f, the IImsupp)), + mk_Trueprop_eq (the rho $ a, fst (#Inj def) $ a) + ) + ); + in Goal.prove_sorry lthy (names [f, the rho, a]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + K (unfold_thms_tac ctxt @{thms imsupp_def supp_def SSupp_def}), + dtac ctxt @{thm iffD1[OF disjoint_iff]}, + etac ctxt allE, + etac ctxt impE, + rtac ctxt @{thm UnI1}, + rtac ctxt @{thm CollectI}, + assume_tac ctxt, + K (unfold_thms_tac ctxt @{thms Un_iff de_Morgan_disj mem_Collect_eq not_not}), + etac ctxt conjE, + assume_tac ctxt + ]) end + )) (fs @ replicate (length pfrees) Term.dummy) rhos IImsuppss defs; + + val IImsupp_imsupp_permute_commutes = @{map 6} (fn i => fn permute_Inj => fn IImsupp_Inj => fn IImsupps => fn rho => Option.map (fn def => + let + val int_empties = map2 (fn f => fn IImsupp => + HOLogic.mk_Trueprop (mk_int_empty (mk_imsupp f, the IImsupp)) + ) fs (take nvars IImsupps); + val goal = mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (#permute quot, fs), the rho), + HOLogic.mk_comp (the rho, nth fs i) + ); + in Goal.prove_sorry lthy (names (fs @ [the rho])) (f_prems @ int_empties) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt ext, + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + let + val a = Thm.term_of (snd (hd params)); + fun case_split t = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt t)] @{thm case_split}; + in EVERY1 [ + rtac ctxt (case_split (HOLogic.mk_eq (nth fs i $ a, a))), + rtac ctxt (case_split (HOLogic.mk_eq (the rho $ a, fst (#Inj def) $ a))) + ] end + ) ctxt, + rtac ctxt trans, + rtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quot, fs))), + assume_tac ctxt, + rtac ctxt trans, + rtac ctxt (the permute_Inj), + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt trans, + rtac ctxt (mk_arg_cong lthy 1 (fst (#Inj def))), + assume_tac ctxt, + rtac ctxt sym, + rotate_tac ~2, + etac ctxt @{thm subst[OF sym]}, + assume_tac ctxt, + rtac ctxt trans, + rtac ctxt (#permute_cong_id (#inner quot)), + REPEAT_DETERM o resolve_tac ctxt prems, + REPEAT_DETERM o EVERY' [ + Method.insert_tac ctxt (drop (length f_prems) prems), + etac ctxt @{thm id_onD[rotated]}, + rtac ctxt @{thm imsupp_id_on}, + etac ctxt @{thm Int_subset_empty2}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms SSupp_def IImsupp_def}), + rtac ctxt @{thm subsetI}, + TRY o rtac ctxt @{thm UnI2}, + rtac ctxt @{thm UN_I[rotated]}, + assume_tac ctxt, + rtac ctxt @{thm CollectI}, + assume_tac ctxt + ], + rotate_tac ~2, + etac ctxt @{thm subst[OF sym]}, + rtac ctxt refl, + rtac ctxt trans, + rtac ctxt (mk_arg_cong lthy 1 (Term.list_comb (#permute quot, fs))), + defer_tac, + rtac ctxt trans, + K (prefer_tac 3), + etac ctxt (the IImsupp_Inj), + resolve_tac ctxt prems, + rtac ctxt (the permute_Inj), + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt sym, + rtac ctxt (the IImsupp_Inj), + etac ctxt @{thm bij_not_eq_twice[rotated]}, + resolve_tac ctxt prems, + resolve_tac ctxt prems + ]) end + )) (0 upto length defs - 1) permute_Injs IImsupp_Injs IImsuppss rhos defs; + + val eta_naturals' = map (Option.map (fn { axioms, ... } => + Local_Defs.unfold0 lthy @{thms comp_def} (fun_cong OF [#eta_natural axioms]) + )) defs; + + val eta_set_emptiess = map (Option.map (fn def => + let + val var_types = replicate nvars MRBNF_Def.Free_Var + @ replicate (free - nvars) MRBNF_Def.Free_Var + @ replicate (live - nrecs) MRBNF_Def.Live_Var + @ replicate bound MRBNF_Def.Bound_Var + @ replicate (length (#bfree_vars fp_res)) MRBNF_Def.Free_Var + @ replicate nrecs MRBNF_Def.Live_Var; + val (xs1, xs2) = chop nvars (var_types ~~ sets); + val sets' = filter (fn (_, set) => #aT def <> HOLogic.dest_setT (range_type (fastype_of set))) xs1 @ xs2; + val a = Free ("a", #aT def); + val eta_natural' = Local_Defs.unfold0 lthy @{thms comp_def} (fun_cong OF [#eta_natural (#axioms def)]); + in map (fn (ty, set) => + let + val infinite_UNIV = @{thm cinfinite_imp_infinite} OF [MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf]; + val T = (HOLogic.dest_setT o snd o dest_funT o fastype_of) set; + val goal = mk_Trueprop_eq (set $ (#eta def $ a), mk_bot T) + in Goal.prove_sorry lthy (names [a]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt @{thm iffD2[OF set_eq_iff]}, + rtac ctxt allI, + K (unfold_thms_tac ctxt @{thms empty_iff}), + rtac ctxt iffI, + if ty <> MRBNF_Def.Live_Var then EVERY' [ + rtac ctxt (infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (set $ (#eta def $ a)))] @{thm exE[OF MRBNF_FP.exists_fresh]}), + resolve_tac ctxt (MRBNF_Def.set_bd_UNIV_of_mrbnf mrbnf), + dtac ctxt @{thm iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]}, + rtac ctxt (mk_arg_cong lthy 1 set), + K (prefer_tac 2), + EqSubst.eqsubst_asm_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + K (prefer_tac (free + 2 * bound + 1)), + etac ctxt @{thm swap_fresh}, + assume_tac ctxt, + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_swap_bound bij_swap} @ [infinite_UNIV]), + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt eta_natural', + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_swap_bound bij_swap} @ [infinite_UNIV]), + K (unfold_thms_tac ctxt @{thms id_def}), + rtac ctxt refl + ] else EVERY' [ + dtac ctxt @{thm image_const}, + dtac ctxt @{thm iffD1[OF all_cong1, rotated]}, + rtac ctxt sym, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + EqSubst.eqsubst_asm_tac ctxt [0] [eta_natural'], + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + K (unfold_thms_tac ctxt @{thms id_def}), + dtac ctxt @{thm forall_in_eq_UNIV}, + dtac ctxt @{thm trans[symmetric]}, + rtac ctxt (@{thm conjunct1[OF card_order_on_Card_order]} OF [MRBNF_Def.bd_card_order_of_mrbnf mrbnf]), + dtac ctxt @{thm card_of_ordIso_subst}, + dtac ctxt @{thm ordIso_symmetric}, + dtac ctxt @{thm ordIso_transitive}, + rtac ctxt @{thm ordIso_symmetric}, + rtac ctxt @{thm iffD1[OF Card_order_iff_ordIso_card_of]}, + rtac ctxt (@{thm conjunct2[OF card_order_on_Card_order]} OF [MRBNF_Def.bd_card_order_of_mrbnf mrbnf]), + etac ctxt @{thm ordIso_ordLess_False}, + resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf mrbnf) + ], + etac ctxt FalseE + ]) end + ) sets' end + )) defs; + + val nrecs = foldr1 (op+) (#rec_vars fp_res); + val rec_bounds = map (fn i => @{map_filter 2} (fn j => fn rel => + if member (op=) (flat rel) i then SOME j else NONE + ) (0 upto length (#binding_relation fp_res) - 1) (#binding_relation fp_res)) (0 upto nrecs - 1); + + val not_isInj_Sb = map (Option.map (fn def => + let + val (lives', _) = fold Variable.declare_typ (free_args @ bound_args @ live_args) lthy + |> mk_TFrees (length plives); + + val (((((fs, rhos), bound_hs), live_hs), x), _) = lthy + |> mk_Frees "f" (map ((fn a => a --> a) o HOLogic.dest_setT o body_type o fastype_of) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_of_bmv_monad bmv)) + ||>> mk_Frees "\" (map fastype_of (BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv)) + ||>> mk_Frees "h1" (map (fn a => a --> a) pbounds) + ||>> mk_Frees "h2" (map2 (curry (op-->)) live_args (map (Term.typ_subst_atomic (plives ~~ lives')) live_args)) + ||>> apfst hd o mk_Frees "x" [domain_type (fastype_of (#ctor quot))]; + + val prems = flat (BMV_Monad_Def.mk_small_prems_of_bmv_monad bmv + (BMV_Monad_Def.leader_of_bmv_monad bmv) fs rhos + ); + val bh_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) bound_hs; + val goal = Logic.mk_implies ( + HOLogic.mk_Trueprop (HOLogic.mk_not (fst (#isInj def) $ (#ctor quot $ x))), + HOLogic.mk_Trueprop (HOLogic.mk_not (Term.subst_atomic_types (plives ~~ lives') (fst (#isInj def)) $ (Term.subst_atomic_types (plives ~~ lives') (#ctor quot) $ ( + Term.subst_atomic_types (plives ~~ lives') (Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, fs @ rhos)) $ ( + MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) live_hs (bound_hs @ map HOLogic.id_const frees) + (map HOLogic.id_const (frees @ pfrees)) mrbnf $ x + ))) + ))); + in Goal.prove_sorry lthy (names (fs @ rhos @ bound_hs @ live_hs @ [x])) (bh_prems @ prems) goal (fn {context=ctxt, prems} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ map snd [#isInj def, #Inj def])), + etac ctxt @{thm contrapos_nn}, + etac ctxt exE, + EqSubst.eqsubst_asm_tac ctxt [0] [#inject quot], + REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + let + val fs = map (Thm.term_of o snd) (tl params); + val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (subtract (op=) (frees @ pbounds) (BMV_Monad_Def.leader BMV_Monad_Def.deads_of_bmv_monad bmv)) + (map (Term.subst_atomic_types (plives ~~ lives')) (map HOLogic.id_const plives @ map (fn xs => if null xs then HOLogic.id_const (#T quot) else + Term.list_comb (#permute quot, map_index (fn (i, f) => + if member (op=) xs i then mk_inv f else HOLogic.id_const (domain_type (fastype_of f)) + ) fs) + ) rec_bounds)) + (map HOLogic.id_const pbounds @ map mk_inv fs) (map HOLogic.id_const (frees @ pfrees)) mrbnf; + in dtac ctxt (mk_arg_cong lthy 1 map_t) 1 end + ) ctxt, + EqSubst.eqsubst_asm_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id bij_imp_bij_inv supp_inv_bound}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_asm_tac ctxt [0] [#permute_comp0 quot], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id bij_imp_bij_inv supp_inv_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id inv_o_simp1} @ [#permute_id0 quot, MRBNF_Def.map_id_of_mrbnf mrbnf])), + EqSubst.eqsubst_asm_tac ctxt [0] [Local_Defs.unfold0 ctxt @{thms comp_def} (#eta_natural (#axioms def) RS fun_cong)], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id bij_imp_bij_inv supp_inv_bound}), + dtac ctxt (#eta_Sb (#axioms def) OF prems), + etac ctxt exE, + hyp_subst_tac_thin true ctxt, + rtac ctxt exI, + rtac ctxt refl + ]) end + )) defs; + + val Injs = map_filter (Option.map (fn rho => + the (List.find (curry (op=) (fastype_of rho) o fastype_of) ( + map_filter (Option.map (fst o #Inj)) defs @ BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv + )) + )) rhos; + val Vrs = map (fn Inj => the (List.find (fn set => HOLogic.dest_setT (range_type (fastype_of set)) = domain_type (fastype_of Inj)) free_sets)) Injs; + val RVrs = subtract (op=) Vrs free_sets; + val (rfs, _) = mk_Frees "f" (map ((fn a => a --> a) o HOLogic.dest_setT o range_type o fastype_of) RVrs) lthy; + val rf_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) rfs; + + val (_, lthy) = Local_Theory.begin_nested lthy; + + val lthy = snd (Proof_Context.add_fixes (map (fn Free (x, T) => (Binding.name x, SOME T, NoSyn)) (rfs @ map_filter I rhos)) lthy); + + val rho_prems' = rf_prems @ maps (map_filter (Option.map (fn IImsupp => + let + val A = case IImsupp of + Const (@{const_name sup}, _) $ t $ _ => t + | t => t + in HOLogic.mk_Trueprop (mk_ordLess (mk_card_of A) + (mk_card_of (HOLogic.mk_UNIV (HOLogic.dest_setT (fastype_of A)))) + ) end + ))) IImsuppss; + + val (_, lthy) = Element.activate_i ( + Element.Assumes (map (fn (b, ts) => ((Binding.concealed (Binding.name b), []), map (rpair []) ts)) [ + ("f_prems", rho_prems') + ]) + ) lthy; + + val rho_prems = Proof_Context.get_thms lthy "f_prems"; + + val avoiding_sets = map2 (fn free => fn IImsupps => + let + val imsupps = case List.find (fn f => domain_type (fastype_of f) = free) rfs of + SOME f => [mk_imsupp f] | _ => [] + in the_default (mk_bot free) (try (foldl1 mk_Un) (map_filter I IImsupps @ imsupps)) end + ) (frees @ pfrees) (transpose (filter_out null IImsuppss)); + val passive = length plives + length pfrees + length pbounds; + + val Uctor = + let + val ctor = #ctor quot; + val (name, (args, rec_args)) = dest_Type (fst (dest_funT (fastype_of ctor))) + |> apsnd (chop (nvars * 2 + passive + length (#bfree_vars fp_res))); + val rec_args' = map (fn T => HOLogic.mk_prodT (T, T)) rec_args; + val args = args @ rec_args'; + + val free_ids = map HOLogic.id_const (frees @ pfrees); + val bound_ids = map HOLogic.id_const (pbounds @ frees); + + val deads = MRBNF_Def.deads_of_mrbnf mrbnf; + val map_id_fst = ctor $ (MRBNF_Def.mk_map_comb_of_mrbnf deads + (map HOLogic.id_const plives @ map fst_const rec_args') + bound_ids free_ids mrbnf $ Bound 0); + + val Sb = Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, + map (fn RVrs => + let val free = HOLogic.dest_setT (range_type (fastype_of RVrs)); + in case List.find (fn f => domain_type (fastype_of f) = free) rfs of + SOME f => f | NONE => HOLogic.id_const free + end + ) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_of_bmv_monad bmv) + @ map (fn Inj => the (List.find (curry (op=) (fastype_of Inj) o fastype_of) some_rhos)) (BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv) + ); + + in Term.abs ("F", Type (name, args)) ( + @{fold 2} (fn def => fn rho => fn t => case def of + SOME def => BNF_FP_Util.mk_If (fst (#isInj def) $ map_id_fst) (the rho $ (fst (#asInj def) $ map_id_fst)) t + | NONE => t + ) (rev defs) (rev rhos) (ctor $ (Sb $ (MRBNF_Def.mk_map_comb_of_mrbnf deads + (map HOLogic.id_const plives @ map snd_const rec_args') bound_ids free_ids mrbnf $ Bound 0))) + ) end; + + val no_reflexive = filter_out (fn thm => the_default false (Option.map (fn (lhs, rhs) => + lhs = rhs + ) (try (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm))); + + val state = Interpretation.interpretation ([ (QREC_fixed_name, + (("tvsubst", true), (Expression.Positional (map SOME ( + take nvars avoiding_sets @ [Uctor] + )), [])) + )], []) lthy; + + val sugars = map_filter (fn mrbnf => Binder_Sugar.binder_sugar_of lthy + (fst (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf))) + ) (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf); + + val mrsbnf_axioms = nth (MRSBNF_Def.axioms_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad bmv); + val mrsbnf_facts = nth (MRSBNF_Def.facts_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad bmv); + val bmv_axioms = BMV_Monad_Def.leader BMV_Monad_Def.axioms_of_bmv_monad bmv; + + val lthy = Proof.global_terminal_proof ((Method.Basic (fn ctxt => SIMPLE_METHOD (EVERY1 [ + DETERM o rtac ctxt (the (fst (Locale.intros_of (Proof_Context.theory_of lthy) QREC_fixed_name))), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound iffD2[OF imsupp_supp_bound] infinite_UNIV} + @ rho_prems + @ maps (MRBNF_Def.set_bd_UNIV_of_mrbnf) (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + @ #card_of_FVars_bound_UNIVs quot + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ])), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems)) + ], + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + Local_Defs.unfold0_tac ctxt (@{thms Product_Type.fst_comp_map_prod Product_Type.snd_comp_map_prod comp_assoc case_prod_beta prod.collapse} + @ map (fn f => infer_instantiate' ctxt [SOME (snd f)] @{thm id_o_commute}) (take nvars params) + ) + ) ctxt, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] ([ + MRBNF_Def.map_comp_of_mrbnf mrbnf RS sym, + #permute_ctor quot RS sym + ] @ map_filter I isInj_permutes), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems)) + ], + EVERY' (map_filter (Option.map (fn def => EVERY' [ + rtac ctxt @{thm case_split}, + EqSubst.eqsubst_tac ctxt [0] @{thms if_P}, + assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms if_P if_not_P}), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + EqSubst.eqsubst_tac ctxt [0] (map_filter I permute_Injs), + REPEAT_DETERM o assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter I asInj_Injs)), + resolve_tac ctxt (map_filter (Option.map (fn thm => Local_Defs.unfold0 ctxt @{thms comp_def} (thm RS fun_cong))) IImsupp_imsupp_permute_commutes), + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_assoc[symmetric]}), + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o (eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' rtac ctxt @{thm UnI1}) + ] + ])) defs), + rtac ctxt trans, + rtac ctxt (#permute_ctor quot), + REPEAT_DETERM o assume_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] [@{thm trans[OF comp_apply[symmetric]]} OF [ + #map_Sb_strong (nth (MRSBNF_Def.facts_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad bmv)) RS fun_cong + ]], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems)), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id inv_o_simp2 comp_apply}), + rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems)) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + DETERM o rtac ctxt (@{thm nested_cong[rotated]} OF [MRBNF_Def.map_cong0_of_mrbnf mrbnf]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id supp_comp_bound bij_comp infinite_UNIV} @ rho_prems)), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt @{thm imsupp_commute[THEN fun_cong]}, + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm Un_upper2} + ]), + TRY o EVERY' [ + rtac ctxt (#Sb_cong (BMV_Monad_Def.leader BMV_Monad_Def.axioms_of_bmv_monad bmv)), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt ( + @{thms supp_id_bound bij_id supp_inv_bound SSupp_comp_bound infinite_UNIV conjI card_of_Card_order supp_comp_bound} + @ [MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf] @ maps (map_filter I o #SSupp_map_bound) (MRSBNF_Def.facts_of_mrsbnf mrsbnf) + @ rho_prems + )), + K (Local_Defs.unfold0_tac ctxt (@{thms inv_id id_o o_id} @ map MRBNF_Def.map_id0_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf))), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + rtac ctxt @{thm trans[OF arg_cong2[OF imsupp_commute refl, of _ _ "(\)", THEN fun_cong]]}, + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm Un_upper2}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc inv_o_simp2 o_id}), + rtac ctxt refl + ]), + REPEAT_DETERM o EVERY' [ + TRY o EqSubst.eqsubst_asm_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ map (fn thm => thm RS sym) (no_reflexive (maps #set_Vrs (MRSBNF_Def.axioms_of_mrsbnf mrsbnf))))), + EqSubst.eqsubst_asm_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + etac ctxt @{thm imageE}, + hyp_subst_tac ctxt, + rtac ctxt @{thm trans[OF comp_apply]}, + K (Local_Defs.unfold0_tac ctxt @{thms inv_simp1}), + rtac ctxt @{thm trans[OF comp_apply]}, + EqSubst.eqsubst_tac ctxt [0] (map (the o #map_permute) sugars), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + resolve_tac ctxt (map (fn thm => Local_Defs.unfold ctxt @{thms comp_def} (thm RS fun_cong)) + (maps (the_default [] o #IImsupp_permute_commutes) sugars) + ), + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ] + ] + ], + (* FVars goals *) + REPEAT_DETERM o Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ + EVERY' (map_filter (Option.map (fn def => EVERY' [ + rtac ctxt @{thm case_split}, + EqSubst.eqsubst_tac ctxt [0] @{thms if_P}, + assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms if_not_P}), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + DETERM o etac ctxt @{thm subst[OF sym]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter I asInj_Injs)), + rtac ctxt @{thm case_split[of "_ = _"]}, + rtac ctxt @{thm iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]}, + resolve_tac ctxt (map (mk_arg_cong no_defs_lthy 1) (#FVarss quot)), + assume_tac ctxt, + rtac ctxt @{thm Un_upper1}, + rtac ctxt @{thm subsetI}, + rtac ctxt @{thm UnI2}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_assoc[symmetric]}), + REPEAT_DETERM o FIRST' [ + EVERY' [ + TRY o rtac ctxt @{thm UnI2}, + etac ctxt @{thm in_IImsupp[rotated]}, + assume_tac ctxt + ], + rtac ctxt @{thm UnI1} + ] + ])) defs), + etac ctxt @{thm thin_rl}, + EqSubst.eqsubst_tac ctxt [0] [Local_Defs.unfold0 ctxt @{thms comp_def} ( + the (#map_Sb mrsbnf_axioms) RS fun_cong RS sym + )], + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems), + K (Local_Defs.unfold0_tac ctxt (#FVars_ctors quot)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id image_comp[unfolded comp_def]}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems) + ], + REPEAT_DETERM o rtac ctxt @{thm Un_mono'}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Sb_Inj bmv_axioms :: #Vrs_Sbs bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} @ rho_prems) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id id_apply}), + TRY o rtac ctxt @{thm subset_trans[OF image_imsupp_subset]}, + FIRST' [ + rtac ctxt @{thm Un_upper1}, + SELECT_GOAL (EVERY1 [ + rtac ctxt @{thm subsetI}, + etac ctxt @{thm UnE}, + rtac ctxt @{thm UnI2}, + etac ctxt @{thm UnI2}, + etac ctxt @{thm UnI1}, + IF_UNSOLVED o K no_tac + ]), + EVERY' [ + rtac ctxt @{thm subsetI}, + etac ctxt @{thm UN_E}, + rtac ctxt @{thm case_split[of "_ = _", rotated]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms SSupp_def IImsupp_def Un_assoc[symmetric]}), + REPEAT_DETERM o FIRST' [ + EVERY' [ + REPEAT_DETERM o rtac ctxt @{thm UnI2}, + etac ctxt @{thm UN_I[rotated]}, + etac ctxt @{thm CollectI} + ], + rtac ctxt @{thm UnI1} + ], + rotate_tac ~2, + dtac ctxt @{thm iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]}, + etac ctxt arg_cong, + K (Local_Defs.unfold0_tac ctxt (maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad bmv))), + dtac ctxt @{thm singletonD}, + hyp_subst_tac ctxt, + assume_tac ctxt + ] + ], + REPEAT_DETERM o EVERY' [ + TRY o EVERY' [ + rtac ctxt @{thm iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]}, + rtac ctxt @{thm Diff_Un_disjunct}, + resolve_tac ctxt prems, + rtac ctxt @{thm Diff_mono[OF _ subset_refl]} + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_extend_simps(2)}), + rtac ctxt @{thm subset_If}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_empty'}), + rtac ctxt @{thm empty_subsetI}, + rtac ctxt @{thm UN_mono[OF subset_refl]}, + resolve_tac ctxt prems, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms prod.collapse}), + eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' assume_tac ctxt + ] + ]) ctxt + ])), Position.no_range), NONE) state; + + val (tvsubst, lthy) = mk_def_t true Binding.empty I (Binding.name_of tvsubst_b) 0 + (hd (MRBNF_Recursor.get_RECs true "tvsubst" lthy)) lthy; + + val tvsubst_not_isInj = + let + val x = Free ("x", domain_type (fastype_of (#ctor quot))); + val bound_sets = ( + map_filter (fn (MRBNF_Def.Bound_Var, x) => SOME x | _ => NONE) (var_types ~~ sets) + ); + val int_empty_prems = map2 (fn bset => fn avoiding_set => HOLogic.mk_Trueprop ( + mk_int_empty (bset $ x, avoiding_set) + )) (drop (length pbounds) bound_sets) (take nvars avoiding_sets); + val Inj_prems = map (fn def => + HOLogic.mk_Trueprop (HOLogic.mk_not (fst (#isInj def) $ (#ctor quot $ x))) + ) (map_filter I defs); + val prems = int_empty_prems @ [HOLogic.mk_Trueprop (fst (#noclash quot) $ x)] @ Inj_prems; + val ids = map HOLogic.id_const; + + val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) + (ids plives @ flat (map2 replicate (#rec_vars fp_res) [fst tvsubst])) + (ids (pbounds @ frees)) (ids (frees @ pfrees)) mrbnf; + val Sb = Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, + map (fn RVrs => + let val free = HOLogic.dest_setT (range_type (fastype_of RVrs)); + in case List.find (fn f => domain_type (fastype_of f) = free) rfs of + SOME f => f | NONE => HOLogic.id_const free + end + ) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_of_bmv_monad bmv) + @ map (fn Inj => the (List.find (curry (op=) (fastype_of Inj) o fastype_of) some_rhos)) (BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv) + ); + val goal = mk_Trueprop_eq (fst tvsubst $ (#ctor quot $ x), #ctor quot $ (Sb $ (map_t $ x))); + in Goal.prove_sorry lthy (names [x]) prems goal (fn {context=ctxt, prems} => EVERY1 [ + K (unfold_thms_tac ctxt [snd tvsubst]), + rtac ctxt trans, + resolve_tac ctxt (Proof_Context.get_thms lthy "tvsubst.REC_ctor"), + REPEAT_DETERM o resolve_tac ctxt prems, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems) + ], + K (Local_Defs.unfold0_tac ctxt ( + @{thms id_o o_id comp_def[of fst] comp_def[of snd] snd_conv fst_conv id_def[symmetric]} + @ [MRBNF_Def.map_id_of_mrbnf mrbnf] + )), + REPEAT_DETERM o (rtac ctxt @{thm trans[OF if_not_P]} THEN' resolve_tac ctxt prems), + rtac ctxt refl + ]) end; + + val tvsubst_Injs = + @{map 6} (fn i => fn set => fn f => fn set_empties => fn asVVr_VVr => Option.map (fn def => + let val a = Free ("a", #aT def); + in Goal.prove_sorry lthy (names [a]) [] ( + mk_Trueprop_eq (fst tvsubst $ (fst (#Inj def) $ a), the f $ a) + ) (fn {context=ctxt, ...} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt [snd tvsubst, snd (#Inj def), @{thm comp_def}]), + rtac ctxt trans, + resolve_tac ctxt (Proof_Context.get_thms lthy "tvsubst.REC_ctor"), + K (Local_Defs.unfold0_tac ctxt (snd (#noclash quot) :: the set_empties)), + REPEAT_DETERM o resolve_tac ctxt @{thms Int_empty_left conjI}, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems) + ], + K (Local_Defs.unfold0_tac ctxt ( + @{thms id_o o_id comp_def[of fst] comp_def[of snd] snd_conv fst_conv id_def[symmetric]} + @ [MRBNF_Def.map_id_of_mrbnf mrbnf] + )), + REPEAT_DETERM_N i o EVERY' [ + rtac ctxt @{thm trans[OF if_not_P]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ [#inject quot] + @ maps (fn def => [snd (#isInj def), snd (#Inj def)]) (map_filter I defs) + )), + rtac ctxt @{thm iffD2[OF not_ex]}, + rtac ctxt allI, + rtac ctxt notI, + REPEAT_DETERM o eresolve_tac ctxt [exE, conjE], + EqSubst.eqsubst_asm_tac ctxt [0] (map_filter I eta_naturals'), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems)), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_apply}), + dtac ctxt (mk_arg_cong no_defs_lthy 1 set), + K (unfold_thms_tac ctxt (map (Local_Defs.unfold0 ctxt (map (fn thm => thm RS sym) (no_reflexive (#set_Vrs mrsbnf_axioms)))) + (#eta_free (#axioms def) :: maps (the_default []) eta_set_emptiess) + )), + rotate_tac ~1, + etac ctxt @{thm contrapos_pp}, + rtac ctxt @{thm insert_not_empty} + ], + rtac ctxt @{thm trans[OF if_P]}, + K (Local_Defs.unfold_tac ctxt ([snd (#isInj def), + @{thm meta_eq_to_obj_eq} OF [snd (#Inj def)] RS sym + ] @ map_filter I asInj_Injs)), + rtac ctxt exI, + rtac ctxt refl, + rtac ctxt refl + ]) end + )) (0 upto nvars - 1) (take nvars sets) (take nvars rhos) (take nvars eta_set_emptiess) (take nvars asInj_Injs) (take nvars defs); + + val (lthy, old_lthy) = `Local_Theory.end_nested lthy; + val phi = Proof_Context.export_morphism old_lthy lthy; + + val tvsubsts = + let + val tvsubst_new = Morphism.term phi (fst tvsubst); + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (fastype_of tvsubst_new, fastype_of (fst tvsubst)) Vartab.empty + fun morph t = ( + Envir.subst_term (tyenv, Vartab.empty) (Morphism.term phi (fst t)), + Morphism.thm phi (snd t) + ) + in map (map_prod (fst o Term.strip_comb) I o morph) [tvsubst] end; + val tvsubst = hd tvsubsts; + + val tvsubst_not_isInj = Morphism.thm phi tvsubst_not_isInj; + val tvsubst_Injs = map (Option.map (Morphism.thm phi)) tvsubst_Injs; + + val FVars_Injs = map (Option.map (fn def => map (fn FVars => + let + val a = Free ("a", #aT def); + val T = HOLogic.dest_setT (range_type (fastype_of FVars)); + val set = if #aT def = T then mk_singleton a else Const (@{const_name bot}, HOLogic.mk_setT T) + in Goal.prove_sorry lthy (names [a]) [] (mk_Trueprop_eq (FVars $ (fst (#Inj def) $ a), set)) (fn {context=ctxt,...} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (@{thms comp_def UN_empty Diff_empty Un_empty_right Un_empty_left empty_Diff} + @ #FVars_ctors quot @ set_simps @ [snd (#Inj def)] @ maps (the_default []) eta_set_emptiess + )), + K (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), + resolve_tac ctxt [refl, #eta_free (#axioms def)] + ]) end + ) rec_sets)) defs; + + val IImsupp_Diffs = @{map 4} (fn rho => fn avoiding_set => fn FVars_Injs => Option.map (fn def => map (fn FVars => + let + val a = Free ("a", #aT def); + val A = Free ("A", HOLogic.mk_setT (#aT def)); + val B = Free ("B", HOLogic.mk_setT (#aT def)); + val bT = HOLogic.dest_setT (body_type (fastype_of FVars)); + val B2 = if bT = #aT def then B else Free ("B2", HOLogic.mk_setT bT) + val inner = Term.absfree (dest_Free a) (FVars $ (the rho $ a)) + val goal = fold_rev (curry Logic.mk_implies) ( + (HOLogic.mk_Trueprop (mk_int_empty (B, avoiding_set))) + :: the_default [] (if B = B2 then NONE else Option.map (fn set => [HOLogic.mk_Trueprop (mk_int_empty (B2, set))]) + (List.find (curry (op=) (fastype_of B2) o fastype_of) avoiding_sets)) + ) (mk_Trueprop_eq ( + mk_UNION (HOLogic.mk_binop @{const_name minus} (A, B)) inner, + if member (op=) free_sets FVars then + HOLogic.mk_binop @{const_name minus} (mk_UNION A inner, B2) + else mk_UNION A inner + )); + val vars = map fst (Term.add_frees goal []); + in Goal.prove_sorry lthy vars [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt @{thm set_eqI}, + rtac ctxt iffI, + let fun helper_tac inv = EVERY' [ + REPEAT_DETERM o eresolve_tac ctxt @{thms UN_E DiffE}, + REPEAT_DETERM o resolve_tac ctxt @{thms DiffI UN_I}, + assume_tac ctxt, + if not inv then assume_tac ctxt else K all_tac, + TRY o EVERY' [ + rtac ctxt @{thm case_split[of "_ = _"]}, + if inv then rotate_tac ~2 else K all_tac, + dtac ctxt @{thm iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]}, + rtac ctxt trans, + rtac ctxt (mk_arg_cong lthy 1 FVars), + assume_tac ctxt, + resolve_tac ctxt (the FVars_Injs), + etac ctxt @{thm emptyE} ORELSE' EVERY' [ + dtac ctxt @{thm singletonD}, + rtac ctxt @{thm iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]}, + if inv then rtac ctxt sym else K all_tac, + assume_tac ctxt, + assume_tac ctxt + ], + if not inv then EVERY' [ + rotate_tac ~1, + etac ctxt @{thm disjoint_iff[THEN iffD1, THEN spec, THEN mp, rotated]}, + rtac ctxt @{thm trans[OF Int_commute]}, + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI} + ] else etac ctxt @{thm disjoint_iff[THEN iffD1, THEN spec, THEN mp, OF trans[OF Int_commute]]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_assoc[symmetric]}), + REPEAT_DETERM o FIRST' [ + EVERY' [ + TRY o rtac ctxt @{thm UnI2}, + eresolve_tac ctxt @{thms in_IImsupp[rotated] in_SSupp}, + TRY o assume_tac ctxt + ], + rtac ctxt @{thm UnI1} + ] + ] + ] in EVERY' [ + helper_tac false, + helper_tac true + ] end + ]) end + ) rec_sets)) rhos avoiding_sets FVars_Injs defs; + + val netas = length (map_filter I defs); + + fun mk_Un_cong i j = + let + val (Ass, _) = lthy + |> mk_Freess "A" (replicate i (replicate (j + 1) (HOLogic.mk_setT (Term.aT @{sort type})))) + + val prems = map (fn As => mk_Trueprop_eq (hd As, foldl1 mk_Un (tl As))) Ass; + val goal = fold_rev (curry (Logic.mk_implies)) prems (mk_Trueprop_eq ( + foldl1 mk_Un (map hd Ass), + foldl1 mk_Un (map (fn i => foldl1 mk_Un (map (fn xs => nth (tl xs) i) Ass)) (0 upto j - 1)) + )); + in Goal.prove_sorry lthy (names (flat Ass)) [] goal (fn {context=ctxt, ...} => EVERY1 [ + hyp_subst_tac_thin true ctxt, + rtac ctxt @{thm set_eqI}, + rtac ctxt iffI, + REPEAT_DETERM_N (i - 1) o etac ctxt @{thm UnE}, + EVERY' (map (fn i' => EVERY' [ + REPEAT_DETERM_N (j - 1) o etac ctxt @{thm UnE}, + EVERY' (map (fn j' => EVERY' [ + rtac ctxt (mk_UnIN j j'), + etac ctxt (mk_UnIN i i') + ]) (1 upto j)) + ]) (1 upto i)), + REPEAT_DETERM_N (j - 1) o etac ctxt @{thm UnE}, + EVERY' (map (fn j' => EVERY' [ + REPEAT_DETERM o etac ctxt @{thm Un_forward}, + REPEAT_DETERM o etac ctxt (mk_UnIN j j') + ]) (1 upto j)) + ]) end; + + val fp_thms = case #fp_thms fp_res of + SOME (Inl x) => x + | _ => error "only works for datatypes" + val fresh_induct = #fresh_induct fp_thms; + + fun find_f T = List.find (fn f => T = domain_type (fastype_of f)) rfs; + + val ops = #T quot :: tl (BMV_Monad_Def.ops_of_bmv_monad bmv); + + val Vrs_Injs' = maps (the_default []) FVars_Injs @ flat (maps #Vrs_Injss (tl (BMV_Monad_Def.axioms_of_bmv_monad bmv))); + + val some_rhos = map_filter I rhos; + + val FVars_tvsubsts = map (fn FVars => + let + val t = Free ("t", domain_type (fastype_of FVars)); + + val rhss = map_filter (fn FVars' => Option.mapPartial (fn rho => + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) (BMV_Monad_Def.ops_of_bmv_monad bmv); + val Vrs = if idx = ~1 then free_sets else nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) idx; + val Vrs = List.find (curry (op=) (body_type (fastype_of FVars)) o body_type o fastype_of) Vrs; + in Option.map (fn Vrs => mk_UNION (FVars' $ t) (Term.abs ("a", domain_type (fastype_of rho)) (Vrs $ (rho $ Bound 0)))) Vrs end + ) (List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of FVars'))) o domain_type o fastype_of) (map_filter I rhos))) free_sets; + + val isRVrs = member (op=) RVrs FVars + val rhs' = if isRVrs then [mk_image (the (find_f (HOLogic.dest_setT (range_type (fastype_of FVars))))) $ (FVars $ t)] else [] + + val goal = mk_Trueprop_eq ( + FVars $ (Term.list_comb (fst tvsubst, rfs @ map_filter I rhos) $ t), + foldl1 mk_Un (rhs' @ rhss) + ); + in Goal.prove_sorry lthy (names (rfs @ map_filter I rhos @ [t])) rho_prems' goal (fn {context=ctxt, prems} => EVERY1 [ + DETERM o rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) (take nvars avoiding_sets)) fresh_induct), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_UNIV} @ prems + @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + @ #card_of_FVars_bound_UNIVs quot @ rho_prems + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ])), + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~netas) tvsubst_not_isInj], + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o (resolve_tac ctxt prems ORELSE' assume_tac ctxt), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (#FVars_ctors quot @ set_simps)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf @ #set_Sb mrsbnf_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms image_id image_comp[unfolded comp_def]} + @ no_reflexive (#set_Vrs mrsbnf_axioms) + )), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} @ prems) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map (fn thm => thm RS sym) (no_reflexive (#set_Vrs mrsbnf_axioms)))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf @ #set_Sb mrsbnf_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), + K (Local_Defs.unfold0_tac ctxt (@{thms image_id UN_Un id_apply} + @ #Vrs_Map (the (BMV_Monad_Def.leader BMV_Monad_Def.params_of_bmv_monad bmv)) + @ [#Sb_Inj bmv_axioms] + )), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms image_Un}), + rtac ctxt (mk_Un_cong (nrecs + 1) (length rhss + (if isRVrs then 1 else 0))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (#eta_compl_free o #axioms)) defs), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter (Option.map (snd o #isInj)) defs)), + rotate_tac ~1, + etac ctxt @{thm contrapos_np}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms not_all not_not comp_def} @ map_filter (Option.map (snd o #Inj)) defs)), + etac ctxt exE, + hyp_subst_tac ctxt, + rtac ctxt exI, + rtac ctxt refl + ], + K (Local_Defs.unfold0_tac ctxt (@{thms UN_empty Un_empty_left Un_empty_right image_id} + @ the_default [] (Option.map single (#Map_map mrsbnf_facts)) + )), + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms image_id})), + rtac ctxt refl, + rtac ctxt trans, + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + rtac ctxt @{thm UN_cong}, + Goal.assume_rule_tac ctxt, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] @{thms Diff_image_not_in_imsupp[symmetric]}, + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm Un_upper2} + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms image_UN}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs @ maps (the_default [] o #IImsupp_Diffs) sugars), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + SELECT_GOAL (EVERY1 [ + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ]) + ], + rtac ctxt @{thm Int_empty_left} + ] + ], + K (Local_Defs.unfold0_tac ctxt @{thms Un_Diff[symmetric] Diff_empty}), + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib Union_UN_swap}), + rtac ctxt refl, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib[symmetric] image_UN}), + TRY o EVERY' [ + rtac ctxt @{thm UN_cong}, + Goal.assume_rule_tac ctxt + ], + EVERY' (map_filter (Option.map (fn def => EVERY' [ + K (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), + REPEAT_DETERM o resolve_tac ctxt prems, + K (Local_Defs.unfold0_tac ctxt (@{thms UN_single UN_empty Union_empty Un_empty_left Un_empty_right image_empty} + @ maps (the_default []) FVars_Injs + )), + rtac ctxt refl + ])) (rev defs)) + ]) end + ) free_sets; + + val SSupp_tvsubst_subsets = BMV_Monad_Tactics.mk_SSupp_Sb_subsets (#T quot) + Injs rho_prems' (fst tvsubst) + rfs some_rhos (map_filter I tvsubst_Injs) lthy; + + val SSupp_tvsubst_bounds = BMV_Monad_Tactics.mk_SSupp_Sb_bounds (#T quot) + Injs (fst tvsubst) rfs some_rhos rho_prems' SSupp_tvsubst_subsets + (MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf) lthy; + + val IImsupp_Sb_subsetss = BMV_Monad_Tactics.mk_IImsupp_Sb_subsetss (#T quot) ops + (fst tvsubst) rho_prems' (RVrs :: tl (BMV_Monad_Def.RVrs_of_bmv_monad bmv)) + (Vrs :: tl (BMV_Monad_Def.Vrs_of_bmv_monad bmv)) + (RVrs @ Vrs) Injs rfs some_rhos SSupp_tvsubst_subsets + FVars_tvsubsts Vrs_Injs' lthy; + + val IImsupp_Sb_boundss = BMV_Monad_Tactics.mk_IImsupp_Sb_boundss (hd (MRBNF_Def.class_of_mrbnf mrbnf)) (#T quot) + (fst tvsubst) Injs (RVrs @ Vrs) rfs some_rhos rho_prems' IImsupp_Sb_subsetss + (MRBNF_Def.set_bd_of_mrbnf rec_mrbnf @ maps #Vrs_bds (BMV_Monad_Def.axioms_of_bmv_monad bmv)) lthy; + + val bmv_params = the (BMV_Monad_Def.leader BMV_Monad_Def.params_of_bmv_monad bmv); + fun mk_avoiding_sets rhos fs = map (Term.subst_atomic ((some_rhos ~~ rhos) @ (rfs ~~ fs))) avoiding_sets; + + val (plives', _) = fold Variable.declare_typ (frees @ pfrees @ pbounds @ plives) lthy + |> mk_TFrees (length plives); + val (live_fs, _) = lthy + |> mk_Frees "f" (map2 (curry (op-->)) plives plives') + + local + val (((free_fs, bound_fs), live_fs), _) = lthy + |> mk_Frees "f1" (map (fn a => a --> a) (frees @ pfrees)) + ||>> mk_Frees "f2" (map (fn a => a --> a) pbounds) + ||>> mk_Frees "f3" (map2 (curry (op-->)) plives plives'); + + val fs = free_fs @ bound_fs @ live_fs; + + val f_prems = map HOLogic.mk_Trueprop (flat (MRBNF_Def.interlace (replicate (length plives) []) + (map (fn f => [mk_bij f, mk_supp_bound f]) bound_fs) (map (single o mk_supp_bound) free_fs) (MRBNF_Def.var_types_of_mrbnf rec_mrbnf) + )); + + val g_prems = map2 (fn Inj => fn g => HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (mk_SSupp Inj $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) + )) Injs some_rhos; + + val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf rec_mrbnf) live_fs bound_fs free_fs rec_mrbnf; + in + val map_Injs = map (fn Inj => if range_type (fastype_of Inj) <> #T quot then NONE else + let + val (a, _) = lthy + |> apfst hd o mk_Frees "a" [domain_type (fastype_of Inj)] + + val f = the (List.find (fn f => domain_type (fastype_of f) = domain_type (fastype_of Inj)) free_fs); + + val goal = mk_Trueprop_eq (map_t $ (Inj $ a), Term.subst_atomic_types (plives ~~ plives') (Inj $ (f $ a))) + in SOME (Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (map_filter (Option.map (snd o #Inj)) defs)), + rtac ctxt trans, + rtac ctxt vvsubst_ctor, + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + K (Local_Defs.unfold0_tac ctxt (snd (#noclash quot) :: flat (map_filter I eta_set_emptiess))), + REPEAT_DETERM o resolve_tac ctxt @{thms conjI Int_empty_left}, + EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (fn def => + Local_Defs.unfold0 ctxt @{thms comp_def} (#eta_natural (#axioms def) RS fun_cong) + )) defs), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + rtac ctxt refl + ])) end + ) Injs; + + (* TODO: Share code with MRSBNF_Def *) + val SSupp_map_subset = @{map 3} (fn Inj => fn g => fn g_prem => + let + val f = the (List.find (fn f => domain_type (fastype_of f) = domain_type (fastype_of Inj)) free_fs); + + val goal = HOLogic.mk_Trueprop (uncurry mk_leq ( + mk_SSupp (Term.subst_atomic_types (plives ~~ plives') Inj) $ HOLogic.mk_comp (map_t, g), + mk_Un (mk_SSupp Inj $ g, mk_supp f) + )); + in if body_type (fastype_of map_t) <> body_type (fastype_of (Term.subst_atomic_types (plives ~~ plives') Inj)) then NONE else + SOME (Goal.prove_sorry lthy (names (g :: fs)) (f_prems @ [g_prem]) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm subsetI}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_def mem_Collect_eq Un_iff comp_def}), + rtac ctxt @{thm case_split[rotated]}, + etac ctxt disjI1, + rtac ctxt disjI2, + dtac ctxt @{thm iffD1[OF arg_cong2[OF _ refl, of _ _ "(\)"], rotated]}, + rtac ctxt (mk_arg_cong lthy 1 map_t), + assume_tac ctxt, + EqSubst.eqsubst_asm_tac ctxt [0] (map_filter I map_Injs), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + rotate_tac ~1, + etac ctxt @{thm contrapos_np}, + etac ctxt @{thm arg_cong[OF notin_supp]} + ])) + end + ) Injs some_rhos g_prems; + + val SSupp_map_bound = @{map 4} (fn Inj => fn g => fn g_prem => Option.map (fn thm => + let val goal = HOLogic.mk_Trueprop (uncurry mk_ordLess ( + mk_card_of (mk_SSupp (Term.subst_atomic_types (plives ~~ plives') Inj) $ HOLogic.mk_comp (map_t, g)), + mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) + )); + in Goal.prove_sorry lthy (names (fs @ [g])) (f_prems @ [g_prem]) goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt @{thm card_of_subset_bound}, + rtac ctxt thm, + REPEAT_DETERM o resolve_tac ctxt (@{thm infinite_class.Un_bound} :: prems) + ]) end + )) Injs some_rhos g_prems SSupp_map_subset; + + val rec_mrbnf = + let + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) + (MRBNF_Def.T_of_mrbnf rec_mrbnf, #T quot) Vartab.empty + in MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism ( + map (fn (n, (s, T)) => (TVar (n, s), T)) (Vartab.dest tyenv) + )) rec_mrbnf end; + val mrbnfs = rec_mrbnf :: tl (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf); + + val map_Sb = if null (pbounds @ plives) then NONE else SOME ( + let + val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf rec_mrbnf) + live_fs bound_fs (map HOLogic.id_const (frees @ pfrees)) rec_mrbnf; + + val bf_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) bound_fs; + + val goal = mk_Trueprop_eq ( + HOLogic.mk_comp (map_t, Term.list_comb (fst tvsubst, rfs @ some_rhos)), + HOLogic.mk_comp (Term.list_comb (Term.subst_atomic_types (plives ~~ plives') (fst tvsubst), rfs @ map (fn rho => + let + val mrbnf' = the (List.find (fn mrbnf => MRBNF_Def.T_of_mrbnf mrbnf = range_type (fastype_of rho)) mrbnfs); + val no_vars = null (inter (op=) (pbounds @ plives) (MRBNF_Def.bounds_of_mrbnf mrbnf' @ MRBNF_Def.lives_of_mrbnf mrbnf')); + in if no_vars then rho else + let + val map_t' = MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf') + (map (fn live => the_default (HOLogic.id_const live) (List.find (fn f => domain_type (fastype_of f) = live) live_fs)) (MRBNF_Def.lives_of_mrbnf mrbnf')) + (map (fn bound => the_default (HOLogic.id_const bound) (List.find (fn f => domain_type (fastype_of f) = bound) bound_fs)) (MRBNF_Def.bounds_of_mrbnf mrbnf')) + (map HOLogic.id_const (MRBNF_Def.frees_of_mrbnf mrbnf')) mrbnf'; + in HOLogic.mk_comp (map_t', rho) end + end + ) some_rhos) + , map_t)); + val goal = fold_rev Logic.all (live_fs @ bound_fs @ rfs @ some_rhos) (fold_rev (curry Logic.mk_implies) (bf_prems @ rho_prems') goal); + in Goal.prove_sorry lthy [] [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt ext, + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, concl, ...} => + let + val (fs, t) = split_last (map (Thm.term_of o snd) params); + val rhos = drop (length (plives @ pbounds)) fs; + val (fs, rhos) = chop (length rfs) rhos; + + val thm = infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) ( + [HOLogic.mk_UNIV (#T quot)] + @ map2 (fn FVars => fn s => Term.abs ("t", #T quot) (mk_Un ( + FVars $ (Term.list_comb (fst tvsubst, fs @ rhos) $ Bound 0), + s + ))) (#FVarss quot) (take nvars (mk_avoiding_sets rhos fs)) + ) @ [NONE, SOME (Thm.cterm_of ctxt t)]) (#fresh_induct_param fp_thms); + + val concl = HOLogic.dest_Trueprop (snd (Logic.strip_horn (Thm.term_of concl))); + + val thm = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt ( + Term.abs ("t", #T quot) (Term.abs ("\", #T quot) (HOLogic.mk_imp ( + HOLogic.eq_const (#T quot) $ Bound 1 $ Bound 0, + Term.subst_atomic [(t, Bound 1)] concl + ))) + ))] (Local_Defs.unfold0 ctxt @{thms ball_UNIV} thm RS spec); + in EVERY1 [ + DETERM o rtac ctxt (thm RS @{thm mp[OF _ refl]}), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound iffD2[OF imsupp_supp_bound] infinite_UNIV} + @ #card_of_FVars_bound_UNIVs quot @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ])), + rtac ctxt impI, + hyp_subst_tac ctxt, + rtac ctxt @{thm trans[OF comp_apply]}, + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + rtac ctxt trans, + rtac ctxt (arg_cong OF [Drule.rotate_prems (~netas) tvsubst_not_isInj]), + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm Un_upper2} + ], + assume_tac ctxt, + rtac ctxt trans, + rtac ctxt vvsubst_ctor, + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm supp_id_bound}), + K (Local_Defs.unfold0_tac ctxt (@{thms imsupp_id} @ [snd (#noclash quot)])), + REPEAT_DETERM o rtac ctxt @{thm Int_empty_right}, + K (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs bmv_axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms bij_id supp_id_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (map (fn thm => thm RS sym) (no_reflexive (#set_Vrs mrsbnf_axioms)))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms @ MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms bij_id supp_id_bound}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + K (Local_Defs.unfold0_tac ctxt @{thms image_comp[unfolded comp_def]}), + REPEAT_DETERM o etac ctxt conjE, + REPEAT_DETERM o EVERY' [ + TRY o rtac ctxt conjI, + rtac ctxt @{thm Int_subset_empty2}, + assume_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~netas) tvsubst_not_isInj], + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm Un_upper2} + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#noclash quot)]), + REPEAT_DETERM o EVERY' [ + TRY o rtac ctxt conjI, + assume_tac ctxt + ], + rtac ctxt @{thm subset_trans[rotated]}, + rtac ctxt @{thm Un_upper1}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (#FVars_ctors quot)), + K (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs bmv_axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms bij_id supp_id_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (map (fn thm => thm RS sym) (no_reflexive (#set_Vrs mrsbnf_axioms)))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms @ MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms bij_id supp_id_bound}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + K (Local_Defs.unfold0_tac ctxt @{thms image_comp[unfolded comp_def]}), + rtac ctxt @{thm subsetI}, + SELECT_GOAL (EVERY1 [ + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ]) + ], + rtac ctxt trans, + rtac ctxt (arg_cong OF [Local_Defs.unfold0 ctxt @{thms comp_def} ( + the (#map_Sb mrsbnf_axioms) RS fun_cong + )]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + K (Local_Defs.unfold0_tac ctxt [Thm.symmetric (snd (#noclash quot))]), + rtac ctxt sym, + rtac ctxt @{thm trans[OF comp_apply]}, + EqSubst.eqsubst_tac ctxt [0] [vvsubst_ctor], + K (Local_Defs.unfold0_tac ctxt @{thms imsupp_id}), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id Int_empty_right}), + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~netas) tvsubst_not_isInj], + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [#Sb_Inj bmv_axioms RS sym RS fun_cong RS @{thm trans[OF id_apply[symmetric]]}], + eresolve_tac ctxt (map_filter (Option.map (Drule.rotate_prems ~1)) not_isInj_Sb), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + REPEAT_DETERM o FIRST' [ + EVERY' [ + rtac ctxt @{thm equalityD1}, + rtac ctxt trans, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf rec_mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt @{thm image_id} + ], + assume_tac ctxt, + resolve_tac ctxt (@{thms supp_id_bound bij_id card_of_subset_bound[OF IImsupp_triv_subset]} + @ map_filter (Option.map (fn thm => @{thm subset_trans} OF [thm])) SSupp_map_subset + @ map_filter I SSupp_map_bound + ), + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms supp_id Un_empty_right}), + rtac ctxt @{thm subset_refl} + ] + ], + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subset_trans[OF _ Un_upper2]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_assoc[symmetric]}), + REPEAT_DETERM o rtac ctxt @{thm Un_mono}, + REPEAT_DETERM o FIRST' [ + EVERY' [ + rtac ctxt @{thm equalityD1}, + rtac ctxt trans, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf rec_mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt @{thm image_id} + ], + assume_tac ctxt, + resolve_tac ctxt (@{thms supp_id_bound bij_id IImsupp_triv_subset} + @ map_filter (Option.map (fn thm => @{thm subset_trans} OF [thm])) SSupp_map_subset + ), + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms supp_id Un_empty_right}), + rtac ctxt @{thm subset_refl} + ] + ] + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#noclash quot)]), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + K (Local_Defs.unfold0_tac ctxt @{thms image_comp[unfolded comp_def]}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf rec_mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + assume_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id atomize_imp[symmetric]}), + rtac ctxt sym, + Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ + rtac ctxt (arg_cong OF [Drule.rotate_prems (~nrecs) (MRBNF_Def.map_cong0_of_mrbnf mrbnf)]), + REPEAT_DETERM o EVERY' [ + eresolve_tac ctxt prems, + rtac ctxt @{thm UNIV_I}, + rtac ctxt refl + ], + REPEAT_DETERM o resolve_tac ctxt (@{thms refl supp_id_bound bij_id} @ prems) + ]) ctxt, + EVERY' (map_filter (Option.map (fn def => EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), + REPEAT_DETERM o assume_tac ctxt, + rtac ctxt sym, + rtac ctxt @{thm trans[OF comp_apply]}, + EqSubst.eqsubst_tac ctxt [0] (map_filter I map_Injs), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt trans, + resolve_tac ctxt (map_filter I tvsubst_Injs), + REPEAT_DETERM o FIRST' [ + EVERY' [ + rtac ctxt @{thm equalityD1}, + rtac ctxt trans, + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf rec_mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt @{thm image_id} + ], + assume_tac ctxt, + resolve_tac ctxt (@{thms supp_id_bound bij_id card_of_subset_bound[OF IImsupp_triv_subset]} + @ map_filter (Option.map (fn thm => @{thm subset_trans} OF [thm])) SSupp_map_subset + @ map_filter I SSupp_map_bound + ), + EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms supp_id Un_empty_right}), + rtac ctxt @{thm subset_refl} + ] + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_apply comp_def}), + rtac ctxt refl + ])) (rev defs)) + ] end + ) ctxt + ]) end + ); + end + + val set_Sb = map (fn set => + let + val t = Free ("t", #T quot); + val goal = mk_Trueprop_eq ( + set $ (Term.list_comb (fst tvsubst, rfs @ some_rhos) $ t), + foldl1 mk_Un (set $ t :: map2 (fn rho => fn Vrs => mk_UNION (Vrs $ t) ( + Term.abs ("a", HOLogic.dest_setT (range_type (fastype_of Vrs))) (set $ (rho $ Bound 0)) + )) some_rhos Vrs) + ); + val goal = fold_rev Logic.all (rfs @ some_rhos @ [t]) (fold_rev (curry Logic.mk_implies) rho_prems' goal); + in Goal.prove_sorry lthy [] [] goal (fn {context=ctxt, ...} => + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + let + val (fs, t) = split_last (map (Thm.term_of o snd) params); + val (fs, rhos) = chop (length rfs) fs; + val avoiding_sets = mk_avoiding_sets rhos fs; + in EVERY1 [ + DETERM o rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) (take nvars avoiding_sets) @ + [NONE, SOME (Thm.cterm_of ctxt t)] + ) fresh_induct), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound} @ MRBNF_Def.set_bd_UNIV_of_mrbnf rec_mrbnf), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ])), + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~netas) tvsubst_not_isInj], + REPEAT_DETERM o assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (#FVars_ctors quot @ set_simps)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms @ MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id image_comp[unfolded comp_def]}), + K (Local_Defs.unfold0_tac ctxt @{thms UN_Un}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (flat (map_filter I IImsupp_Diffs)), + assume_tac ctxt + ], + K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten}), + rtac ctxt (mk_Un_cong (nrecs + 1) (1 + netas)), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (#set_Vrs mrsbnf_axioms)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (#eta_compl_free o #axioms)) defs), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter (Option.map (snd o #isInj)) defs)), + rotate_tac ~1, + etac ctxt @{thm contrapos_np}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms not_all not_not comp_def} @ map_filter (Option.map (snd o #Inj)) defs)), + etac ctxt exE, + hyp_subst_tac ctxt, + rtac ctxt exI, + rtac ctxt refl + ], + K (Local_Defs.unfold0_tac ctxt @{thms UN_empty Un_empty_right UN_Un_distrib[symmetric]}), + rtac ctxt refl, + REPEAT_DETERM o EVERY' [ + rtac ctxt @{thm UN_cong}, + Goal.assume_rule_tac ctxt + ], + EVERY' (map_filter (Option.map (fn def => EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms Un_empty_left Un_empty_right UN_empty UN_single} + @ flat (map_filter I FVars_Injs) + )), + EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), + REPEAT_DETERM o assume_tac ctxt, + rtac ctxt refl + ])) (rev defs)) + ] end + ) ctxt 1 + ) end + ) (bound_sets @ live_sets); + + val ((rec_bmv, unfolds), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) + qualify NONE { + ops = [#T quot], + var_class = hd (MRBNF_Def.class_of_mrbnf mrbnf), + leader = 0, + frees = [frees @ pfrees], + lives = [plives], + lives' = [plives'], + deads = [pbounds @ MRBNF_Def.deads_of_mrbnf mrbnf], + bmv_ops = map_filter (fn i => if i = BMV_Monad_Def.leader_of_bmv_monad bmv then NONE else + SOME (BMV_Monad_Def.unsafe_slice_bmv_monad i bmv) + ) (0 upto length ops - 1), + consts = { + bd = MRBNF_Def.bd_of_mrbnf mrbnf, + Injs = [Injs], + Sbs = [fst tvsubst], + RVrs = [RVrs], + Vrs = [Vrs], + extra_Vrs = [[]], + params = [if null plives then NONE else SOME { + Map = fold_rev (Term.absfree o dest_Free) live_fs (MRBNF_Def.mk_map_comb_of_mrbnf (MRBNF_Def.deads_of_mrbnf mrbnf) + live_fs (map HOLogic.id_const pbounds) (map HOLogic.id_const (frees @ pfrees)) rec_mrbnf), + Supps = live_sets + }] + }, + params = [if null plives then NONE else SOME { + Map_Injs = replicate netas (fn ctxt => EVERY1 [ + rtac ctxt ext, + rtac ctxt @{thm trans[OF comp_apply]}, + rtac ctxt trans, + resolve_tac ctxt (map_filter I map_Injs), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), + rtac ctxt refl + ]), + Map_Sb = fn ctxt => EVERY1 [ + rtac ctxt (the map_Sb), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + Supp_Sb = replicate (length plives) (fn ctxt => EVERY1 [ + resolve_tac ctxt set_Sb, + REPEAT_DETERM o assume_tac ctxt + ]), + Vrs_Map = replicate (length (Vrs @ RVrs)) (fn ctxt => EVERY1 [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf rec_mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + rtac ctxt @{thm image_id} + ]), + axioms = { + Map_id = fn ctxt => rtac ctxt (MRBNF_Def.map_id0_of_mrbnf rec_mrbnf) 1, + Map_comp = fn ctxt => EVERY1 [ + rtac ctxt trans, + rtac ctxt (MRBNF_Def.map_comp0_of_mrbnf rec_mrbnf RS sym), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl + ], + Map_cong = fn ctxt => EVERY1 [ + rtac ctxt (MRBNF_Def.map_cong0_of_mrbnf rec_mrbnf), + REPEAT_DETERM o FIRST' [ + resolve_tac ctxt @{thms supp_id_bound bij_id refl}, + Goal.assume_rule_tac ctxt + ] + ], + Supp_Map = replicate (length plives) (fn ctxt => EVERY1 [ + resolve_tac ctxt (MRBNF_Def.set_map_of_mrbnf rec_mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} + ]), + Supp_bd = replicate (length plives) (fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf rec_mrbnf) 1) + } + }], + bd_infinite_regular_card_order = fn ctxt => rtac ctxt (MRBNF_Def.bd_infinite_regular_card_order_of_mrbnf mrbnf) 1, + tacs = [{ + Sb_Inj = fn ctxt => EVERY1 [ + rtac ctxt ext, + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ [MRBNF_Def.map_id0_of_mrbnf rec_mrbnf])), + rtac ctxt @{thm trans[rotated]}, + rtac ctxt @{thm id_apply[symmetric]}, + rtac ctxt (fresh_induct OF (replicate nvars @{thm emp_bound})), + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + rtac ctxt trans, + SELECT_GOAL (EVERY1 [ + rtac ctxt (Drule.rotate_prems (~netas) tvsubst_not_isInj), + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound supp_id_bound}, + K (Local_Defs.unfold0_tac ctxt (@{thms SSupp_Inj IImsupp_def UN_empty UN_empty2 Un_empty_left Un_empty_right imsupp_id} @ [snd (#noclash quot)])), + REPEAT_DETERM o rtac ctxt @{thm Int_empty_right}, + REPEAT_DETERM o assume_tac ctxt + ]), + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_cong0_of_mrbnf mrbnf], + REPEAT_DETERM o (Goal.assume_rule_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id refl}), + K (Local_Defs.unfold0_tac ctxt (@{thms id_def[symmetric] id_apply} @ [MRBNF_Def.map_id_of_mrbnf mrbnf, #Sb_Inj bmv_axioms])), + rtac ctxt refl, + EVERY' (map_filter (Option.map (fn def => EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + resolve_tac ctxt (map_filter I tvsubst_Injs), + REPEAT_DETERM o resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound supp_id_bound} + ])) (rev defs)) + ], + Sb_comp_Injs = map_filter (Option.map (fn _ => fn ctxt => EVERY1 [ + rtac ctxt ext, + rtac ctxt @{thm trans[OF comp_apply]}, + resolve_tac ctxt (map_filter I tvsubst_Injs), + REPEAT_DETERM o assume_tac ctxt + ])) defs, + Sb_comp = fn ctxt => EVERY1 [ + rtac ctxt ext, + rtac ctxt @{thm trans[OF comp_apply]}, + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, concl, ...} => + let + val ((((rfs', rhos'), rfs), rhos), x) = map (Thm.term_of o snd) params + |> chop (length rfs) + ||>> chop (length some_rhos) + ||>> chop (length rfs) + ||>> chop (length some_rhos); + + val thm = infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) ( + [HOLogic.mk_UNIV (#T quot)] + @ @{map 4} (fn FVars => fn s1 => fn s2 => fn s3 => Term.abs ("t", #T quot) (foldl1 mk_Un [ + FVars $ (Term.list_comb (fst tvsubst, rfs @ rhos) $ Bound 0), + s1, s2, s3 + ])) (#FVarss quot) (take nvars (mk_avoiding_sets rhos rfs)) (take nvars (mk_avoiding_sets rhos' rfs')) (take nvars (mk_avoiding_sets ( + map (fn rho => + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) ops; + val Sb = nth (fst tvsubst :: tl (BMV_Monad_Def.Sbs_of_bmv_monad bmv)) idx; + val rhos' = map (fn T => the (List.find (curry (op=) T o fastype_of) (rfs' @ rhos'))) + (fst (split_last (binder_types (fastype_of Sb)))); + in HOLogic.mk_comp (Term.list_comb (Sb, rhos'), rho) end + ) rhos + ) (map2 (curry HOLogic.mk_comp) rfs' rfs))) + ) @ [NONE, SOME (Thm.cterm_of ctxt (hd x))]) (#fresh_induct_param fp_thms); + + val concl = HOLogic.dest_Trueprop (snd (Logic.strip_horn (Thm.term_of concl))); + + val thm = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt ( + Term.abs ("t", #T quot) (Term.abs ("\", #T quot) (HOLogic.mk_imp ( + HOLogic.eq_const (#T quot) $ Bound 1 $ Bound 0, + Term.subst_atomic [(hd x, Bound 1)] concl + ))) + ))] (Local_Defs.unfold0 ctxt @{thms ball_UNIV} thm RS spec); + in DETERM (rtac ctxt (thm RS @{thm mp[OF _ refl]}) 1) end + ) ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound iffD2[OF imsupp_supp_bound] infinite_UNIV supp_comp_bound} + @ #card_of_FVars_bound_UNIVs quot @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + @ maps #SSupp_Sb_bounds (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ SSupp_tvsubst_bounds @ flat IImsupp_Sb_boundss + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ])), + rtac ctxt impI, + hyp_subst_tac ctxt, + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~netas) tvsubst_not_isInj], + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ])) + ], + assume_tac ctxt, + rtac ctxt trans, + rtac ctxt (Drule.rotate_prems (~netas) tvsubst_not_isInj), + REPEAT_DETERM o EVERY' [ + eresolve_tac ctxt (map_filter (Option.map (Drule.rotate_prems ~1)) not_isInj_Sb), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms bij_id supp_id_bound}) + ], + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm supp_id_bound}), + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms bij_id supp_id_bound}, + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ])) + ], + EqSubst.eqsubst_tac ctxt [0] [snd (#noclash quot)], + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms @ MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + REPEAT_DETERM o EVERY' [ + TRY o rtac ctxt @{thm conjI}, + rtac ctxt @{thm Int_subset_empty2}, + assume_tac ctxt, + rtac ctxt @{thm subsetI}, + REPEAT_DETERM o rtac ctxt @{thm UnI1}, + EqSubst.eqsubst_tac ctxt [0] [tvsubst_not_isInj], + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ])) + ], + REPEAT_DETERM o assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (#FVars_ctors quot)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#set_Sb mrsbnf_axioms @ MRBNF_Def.set_map_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_id}), + SELECT_GOAL (EVERY1 [ + REPEAT_DETERM o etac ctxt @{thm UnE}, + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ]) + ], + EqSubst.eqsubst_tac ctxt [0] [tvsubst_not_isInj], + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt (@{thms supp_comp_bound infinite_UNIV} + @ SSupp_tvsubst_bounds @ flat IImsupp_Sb_boundss + @ maps #SSupp_Sb_bounds (BMV_Monad_Def.facts_of_bmv_monad bmv) + ) + ], + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm Un_upper2} + ], + REPEAT_DETERM1 o assume_tac ctxt, + rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [the (#Map_map mrsbnf_facts) RS sym]), + EqSubst.eqsubst_tac ctxt [0] [Local_Defs.unfold0 ctxt @{thms comp_def} (#Map_Sb bmv_params RS fun_cong)], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [@{thm trans[OF comp_apply[symmetric]]} OF [ + #Map_comp (#axioms bmv_params) RS fun_cong + ]]), + rtac ctxt trans, + rtac ctxt (@{thm trans[OF comp_apply[symmetric]]} OF [#Sb_comp bmv_axioms RS fun_cong]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ [the (#Map_map mrsbnf_facts)])), + rtac ctxt (arg_cong OF [MRBNF_Def.map_cong0_of_mrbnf mrbnf]), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id refl}, + K (Local_Defs.unfold0_tac ctxt @{thms atomize_imp[symmetric]}), + REPEAT_DETERM o EVERY' [ + rotate_tac ~1, + etac ctxt @{thm mp[rotated]}, + Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ + rtac ctxt @{thm impI}, + rtac ctxt @{thm trans[OF comp_apply]}, + eresolve_tac ctxt prems, + rtac ctxt @{thm UNIV_I}, + rtac ctxt refl + ]) ctxt + ], + EVERY' (map_filter (Option.map (fn def => EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter I tvsubst_Injs)), + EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt (@{thms supp_comp_bound infinite_UNIV} + @ SSupp_tvsubst_bounds @ flat IImsupp_Sb_boundss + @ maps #SSupp_Sb_bounds (BMV_Monad_Def.facts_of_bmv_monad bmv) + ) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ])) (rev defs)) + ], + Vrs_bds = replicate (length free_sets) (fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf rec_mrbnf) 1), + Vrs_Injss = replicate (length free_sets) (map_filter (Option.map (fn def => fn ctxt => + resolve_tac ctxt (maps (the_default []) FVars_Injs) 1 + )) defs), + Vrs_Sbs = replicate (length free_sets) (fn ctxt => EVERY1 [ + resolve_tac ctxt FVars_tvsubsts, + REPEAT_DETERM o assume_tac ctxt + ]), + Sb_cong = fn ctxt => Subgoal.FOCUS (fn {context=ctxt, params, prems, ...} => + let + val ((((rfs', rhos'), rfs), rhos), t) = map (Thm.term_of o snd) params + |> chop (length rfs) + ||>> chop (length some_rhos) + ||>> chop (length rfs) + ||>> apsnd hd o chop (length some_rhos); + in EVERY1 [ + Method.insert_tac ctxt (drop (2 * length rho_prems') prems), + K (Local_Defs.unfold0_tac ctxt @{thms atomize_all atomize_imp}), + DETERM o rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) + (take nvars (map2 (curry mk_Un) (mk_avoiding_sets rhos rfs) (mk_avoiding_sets rhos' rfs'))) + @ [NONE, SOME (Thm.cterm_of ctxt t)] + ) fresh_induct), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound iffD2[OF imsupp_supp_bound] infinite_UNIV} + @ #card_of_FVars_bound_UNIVs quot @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + @ prems + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ])), + K (Local_Defs.unfold0_tac ctxt @{thms atomize_all[symmetric] atomize_imp[symmetric]}), + Subgoal.FOCUS_PREMS (fn {context=ctxt, prems=inner_prems, ...} => EVERY1 [ + Method.insert_tac ctxt (take (2 * length rho_prems') prems @ take (nvars + 1) (drop nrecs inner_prems)), + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems ~1 tvsubst_not_isInj], + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + resolve_tac ctxt @{thms Un_upper1 Un_upper2} + ], + REPEAT_DETERM1 o assume_tac ctxt + ], + rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), + rtac ctxt trans, + rtac ctxt (Drule.rotate_prems (~(length (BMV_Monad_Def.leader BMV_Monad_Def.Injs_of_bmv_monad bmv))) (#Sb_cong bmv_axioms)), + REPEAT_DETERM o EVERY' [ + resolve_tac ctxt inner_prems, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt ((the (#Map_map mrsbnf_facts) RS sym) :: #Vrs_Map bmv_params)), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map (fn thm => thm RS sym) (no_reflexive (#set_Vrs mrsbnf_axioms)))), + eresolve_tac ctxt (flat (#FVars_intross quot)) ORELSE' EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt set_simps), + REPEAT_DETERM o rtac ctxt @{thm UnI1}, + assume_tac ctxt + ] + ], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id refl}), + DETERM o rtac ctxt (@{thm nested_cong[rotated]} OF [MRBNF_Def.map_cong0_of_mrbnf mrbnf]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id refl}), + REPEAT_DETERM o EVERY' [ + rotate_tac ~1, + etac ctxt @{thm distinct_prems_rl[rotated]}, + eresolve_tac ctxt inner_prems, + REPEAT_DETERM_N (length (Vrs @ RVrs)) o (EVERY' [ + rtac ctxt @{thm case_split[of "_ \ _", rotated]}, + resolve_tac ctxt inner_prems, + eresolve_tac ctxt (flat (#FVars_intross quot)), + assume_tac ctxt, + assume_tac ctxt, + rotate_tac ~1, + dtac ctxt @{thm disjoint_iff[THEN iffD1, THEN spec, THEN mp, rotated]}, + assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + rtac ctxt trans, + eresolve_tac ctxt @{thms notin_SSupp notin_imsupp}, + rtac ctxt sym, + eresolve_tac ctxt @{thms notin_SSupp notin_imsupp} + ] ORELSE' EVERY' [ + resolve_tac ctxt inner_prems, + EVERY' [ + eresolve_tac ctxt (flat (#FVars_intross quot)), + assume_tac ctxt + ] ORELSE' EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt set_simps), + rotate_tac ~2, + DETERM o dtac ctxt @{thm UN_I}, + assume_tac ctxt, + REPEAT_DETERM1 o FIRST' [ + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ] + ]) + ], + rtac ctxt (#Sb_cong bmv_axioms), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm supp_id_bound}), + K (Local_Defs.unfold0_tac ctxt ((the (#Map_map mrsbnf_facts) RS sym) :: #Vrs_Map bmv_params)), + K (Local_Defs.unfold0_tac ctxt (map (fn thm => thm RS sym) (no_reflexive (#set_Vrs mrsbnf_axioms)))), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY'[ + resolve_tac ctxt inner_prems, + eresolve_tac ctxt (flat (#FVars_intross quot)) ORELSE' EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt set_simps), + REPEAT_DETERM1 o FIRST' [ + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ] + ]), + EVERY' (map_filter (Option.map (fn def => EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm distinct_prems_rl[rotated]}, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter I tvsubst_Injs)), + resolve_tac ctxt inner_prems, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (maps (the_default []) FVars_Injs)), + rtac ctxt @{thm singletonI} + ])) defs) + ]) ctxt + ] end + ) ctxt 1 + }] + } [] (*TODO: Put definitions here *) lthy; + + val isInj_Map = if null plives then [] else map (Option.map (fn def => + let + val t = Free ("t", #T quot); + val Map = the (hd (BMV_Monad_Def.Maps_of_bmv_monad rec_bmv)); + val goal = mk_Trueprop_eq ( + Term.subst_atomic_types (plives ~~ plives') (fst (#isInj def)) $ (Term.list_comb (Map, live_fs) $ t), + fst (#isInj def) $ t + ); + val unfolds = BMV_Monad_Def.unfolds_of_bmv_monad rec_bmv; + in Local_Defs.unfold0 lthy unfolds (Goal.prove_sorry lthy (names (live_fs @ [t])) [] goal (fn {context=ctxt, ...} => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (unfolds @ [snd (#isInj def)])), + rtac ctxt (infer_instantiate' ctxt (replicate nvars NONE @ [SOME (Thm.cterm_of ctxt t)]) (#fresh_cases (#inner quot))), + REPEAT_DETERM o rtac ctxt @{thm emp_bound}, + hyp_subst_tac_thin true ctxt, + rtac ctxt @{thm iffI}, + etac ctxt exE, + EqSubst.eqsubst_asm_tac ctxt [0] [vvsubst_ctor], + K (Local_Defs.unfold0_tac ctxt @{thms imsupp_id}), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id Int_empty_right}, + assume_tac ctxt, + EqSubst.eqsubst_asm_tac ctxt [0] [snd (#Inj def)], + rotate_tac ~1, + dtac ctxt sym, + dtac ctxt (iffD1 OF [#inject quot]), + REPEAT_DETERM o eresolve_tac ctxt @{thms exE conjE}, + EqSubst.eqsubst_asm_tac ctxt [0] (map_filter I eta_naturals'), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), + rotate_tac ~1, + dtac ctxt sym, + rotate_tac ~1, + EqSubst.eqsubst_asm_tac ctxt [0] [#Sb_Inj bmv_axioms RS sym RS fun_cong RS @{thm trans[OF id_apply[symmetric]]}], + dtac ctxt (Drule.rotate_prems ~1 (#eta_Sb (#axioms def))), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + etac ctxt exE, + hyp_subst_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] [snd (#Inj def)], + rtac ctxt exI, + rtac ctxt refl, + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + rtac ctxt exI, + rtac ctxt trans, + resolve_tac ctxt (map_filter I map_Injs), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + rtac ctxt refl + ])) end + )) defs; + + val (rec_mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Dont_Note) qualify NONE mrbnfs rec_bmv + (map (fn i => if i <> 0 then + let val axioms = nth (MRSBNF_Def.axioms_of_mrsbnf mrsbnf) i; + in { + map_Injs = Option.map (map (fn thm => fn ctxt => rtac ctxt thm 1)) (#map_Injs axioms), + map_Sb = Option.map (fn thm => + fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt) + ) (#map_Sb axioms), + map_is_Sb = fn ctxt => HEADGOAL (rtac ctxt (#map_is_Sb axioms) THEN_ALL_NEW assume_tac ctxt), + set_Sb = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Sb axioms), + set_Vrs = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Vrs axioms) + } end + else { + map_Injs = if null pbounds then NONE else SOME (replicate (length Injs) (fn ctxt => EVERY1 [ + rtac ctxt ext, + rtac ctxt @{thm trans[OF comp_apply]}, + rtac ctxt trans, + resolve_tac ctxt (map_filter I map_Injs), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), + rtac ctxt refl + ])), + map_Sb = if null (pbounds @ plives) then NONE else SOME (fn ctxt => EVERY1 [ + rtac ctxt (the map_Sb), + REPEAT_DETERM o assume_tac ctxt + ]), + map_is_Sb = fn ctxt => EVERY1 [ + rtac ctxt ext, + K (Local_Defs.unfold0_tac ctxt (BMV_Monad_Def.unfolds_of_bmv_monad rec_bmv)), + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + let val (fs, t) = split_last (map (Thm.term_of o snd) params); + in DETERM (rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt o mk_imsupp) (take nvars fs) @ + [NONE, SOME (Thm.cterm_of ctxt t)] + ) fresh_induct) 1) end + ) ctxt, + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms imsupp_supp_bound[THEN iffD2] infinite_UNIV})), + REPEAT_DETERM_N netas o rtac ctxt @{thm case_split[rotated]}, + rtac ctxt sym, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_apply]}, + rtac ctxt trans, + rtac ctxt (arg_cong OF [vvsubst_ctor]), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + REPEAT_DETERM o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms imsupp_id}), + rtac ctxt @{thm Int_empty_right} + ], + assume_tac ctxt + ], + rtac ctxt trans, + rtac ctxt (Drule.rotate_prems (~netas) tvsubst_not_isInj), + REPEAT_DETERM o EVERY' [ + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [vvsubst_ctor RS sym], + K (Local_Defs.unfold0_tac ctxt @{thms imsupp_id}), + REPEAT_DETERM o (eq_assume_tac ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id Int_empty_right}), + EqSubst.eqsubst_tac ctxt [0] (map_filter I isInj_Map) + ], + assume_tac ctxt + ], + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM_N (length rho_prems' - length rf_prems + nvars + 1) o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms IImsupp_Inj_comp_bound injI supp_id_bound bij_id} @ maps (the_default []) FVars_Injs + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad rec_bmv) + ), + eresolve_tac ctxt (map (fn thm => thm RS iffD1) (maps #Inj_inj (BMV_Monad_Def.facts_of_bmv_monad rec_bmv))), + EqSubst.eqsubst_tac ctxt [0] (@{thms IImsupp_Inj_comp SSupp_Inj_comp} + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad rec_bmv) + @ MRBNF_Def.set_map_of_mrbnf mrbnf @ MRBNF_Def.set_map_of_mrbnf rec_mrbnf + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt ( + @{thms image_id image_comp[unfolded comp_def] IImsupp_def comp_apply UN_empty2 Un_empty_left Un_empty_right} + @ [snd (#noclash quot)] + )) + ])), + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}) + ], + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt vvsubst_ctor, + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt sym, + SUBGOAL (fn (t, i) => + let + fun strip_all (Const (@{const_name Pure.all}, _) $ Abs (x, T, t)) = apfst (cons (x, T)) (strip_all t) + | strip_all t = ([], t) + val ctor = fst (Term.dest_comb (fst (HOLogic.dest_eq ( + HOLogic.dest_Trueprop (snd (Logic.strip_horn (snd (strip_all t)))) + )))); + in rtac ctxt (mk_arg_cong lthy 1 ctor) i end + ), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [the (#Map_map mrsbnf_facts) RS sym]), + rtac ctxt trans, + rtac ctxt (@{thm trans[OF comp_apply[symmetric]]} OF [ + #map_is_Sb mrsbnf_axioms RS sym RS fun_cong + ]), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm supp_id_bound}), + rtac ctxt sym, + rtac ctxt (MRBNF_Def.map_cong0_of_mrbnf mrbnf), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (#set_Vrs mrsbnf_axioms)), + EqSubst.eqsubst_asm_tac ctxt [0] (map_filter (Option.map (#eta_compl_free o #axioms)) defs), + rtac ctxt allI, + rotate_tac ~1, + etac ctxt @{thm contrapos_nn}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt ( + flat (map_filter (Option.map (fn def => [snd (#isInj def), snd (#Inj def)])) defs) + )), + hyp_subst_tac ctxt, + TRY o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [the (#Map_map mrsbnf_facts)]), + EqSubst.eqsubst_tac ctxt [0] (map_filter I eta_naturals'), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_apply}) + ], + rtac ctxt exI, + rtac ctxt refl, + etac ctxt @{thm emptyE} + ]), + REPEAT_DETERM o Goal.assume_rule_tac ctxt, + EVERY' (map_filter (Option.map (fn def => EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), + etac ctxt exE, + rotate_tac ~1, + etac ctxt @{thm subst[OF sym]}, + rtac ctxt trans, + resolve_tac ctxt (map_filter I map_Injs), + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), + rtac ctxt sym, + rtac ctxt trans, + TRY o EVERY' [ + rtac ctxt @{thm trans[OF comp_apply]}, + EqSubst.eqsubst_tac ctxt [0] (map_filter I map_Injs), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_apply}) + ], + resolve_tac ctxt (map_filter I tvsubst_Injs), + REPEAT_DETERM_N (length rho_prems') o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms IImsupp_Inj_comp_bound injI} @ maps (the_default []) FVars_Injs + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad rec_bmv) + ), + eresolve_tac ctxt (map (fn thm => thm RS iffD1) (maps #Inj_inj (BMV_Monad_Def.facts_of_bmv_monad rec_bmv))), + EqSubst.eqsubst_tac ctxt [0] (@{thms IImsupp_Inj_comp SSupp_Inj_comp IImsupp_def comp_apply UN_empty2 Un_empty_left Un_empty_right} + @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad rec_bmv) + ) + ])), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ])) (rev defs)) + ], + set_Sb = replicate (length (pbounds @ plives)) (fn ctxt => EVERY1 [ + resolve_tac ctxt set_Sb, + REPEAT_DETERM o assume_tac ctxt + ]), + set_Vrs = replicate (length (Vrs @ RVrs)) (fn ctxt => rtac ctxt refl 1) + }) (0 upto length ops - 1)) lthy; + + val tvsubst_permutes = + let + val quot = hd (#quotient_fps fp_res); + + val permutes = map_filter (Option.map (fn rho => + let + val T = body_type (fastype_of rho); + val fp_res = the (MRBNF_FP_Def_Sugar.fp_result_of lthy (fst (dest_Type T))) + val permute = #permute (hd (filter (fn quot => fst (dest_Type (#T quot)) = fst (dest_Type T)) (#quotient_fps fp_res))) + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (body_type (fastype_of permute), T) Vartab.empty; + in Envir.subst_term (tyenv, Vartab.empty) permute end + )) rhos; + + val goal = mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (#permute quot, gs), Term.list_comb (fst tvsubst, rfs @ map_filter I rhos)), + HOLogic.mk_comp ( + Term.list_comb (fst tvsubst, map (fn f => case List.find (fn g => fastype_of f = fastype_of g) gs of + SOME g => HOLogic.mk_comp (HOLogic.mk_comp (g, f), mk_inv g) + | NONE => f + ) rfs @ map_filter (Option.map (fn rho => + let + val permute = the (List.find (fn perm => body_type (fastype_of perm) = body_type (fastype_of rho)) permutes); + val funs = map (fn T => the_default + (HOLogic.id_const (domain_type T)) + (List.find (curry (op=) T o fastype_of) gs) + ) (fst (split_last (binder_types (fastype_of permute)))); + val inner = if forall (fn Const (@{const_name id}, _) => true | _ => false) funs then rho + else HOLogic.mk_comp (Term.list_comb (permute, funs), rho) + in case List.find (fn g => domain_type (fastype_of rho) = domain_type (fastype_of g)) gs of + SOME g => HOLogic.mk_comp (inner, mk_inv g) + | _ => inner + end + )) rhos), + Term.list_comb (#permute quot, gs) + ) + ); + in Goal.prove_sorry lthy (names (gs @ rfs @ map_filter I rhos)) (g_prems @ rho_prems') goal (fn {context=ctxt, prems} => EVERY1 [ + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map (fn thm => thm RS sym) (map_permute :: map (the o #map_permute) sugars)), + REPEAT_DETERM o resolve_tac ctxt prems + ], + rtac ctxt trans, + rtac ctxt (#map_Sb_strong (hd (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf))), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + K (Local_Defs.unfold0_tac ctxt (@{thms inv_id id_o o_id} @ map MRBNF_Def.map_id0_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf rec_mrsbnf))), + rtac ctxt refl + ]) end + + val result = { + tvsubst = fst tvsubst, + isInjs = map_filter (Option.map #isInj) defs, + tvsubst_Injs = map_filter I tvsubst_Injs, + tvsubst_not_isInj = tvsubst_not_isInj, + IImsupp_Diffs = flat (map_filter I IImsupp_Diffs), + IImsupp_permute_commutes = map_filter I IImsupp_imsupp_permute_commutes, + tvsubst_permute = tvsubst_permutes, + mrsbnf = rec_mrsbnf + }: tvsubst_result; + + in (result, lthy) end; +end diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC.thy b/case_studies/Infinitary_Lambda_Calculus/ILC.thy index a420ecff..ff7d6585 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC.thy @@ -44,7 +44,7 @@ declare [[inductive_internals]] declare [[mrbnf_internals]] (*infinitary untyped lambda calculus*) -binder_datatype 'a iterm +binder_datatype (FFVars: 'a) iterm = iVar 'a | iApp "'a iterm" "'a iterm stream" | iLam "(xs::'a) dstream" t::"'a iterm" binds xs in t @@ -140,34 +140,20 @@ by (meson injD iVariable_inj) type_synonym itrm = "ivar iterm" (* Some lighter notations: *) -abbreviation "VVr \ tvVVr_itvsubst" -lemmas VVr_def = tvVVr_itvsubst_def -abbreviation "isVVr \ tvisVVr_itvsubst" -lemmas isVVr_def = tvisVVr_itvsubst_def -abbreviation "IImsupp \ IImsupp_iterm" -lemmas IImsupp_def = IImsupp_iterm_def -abbreviation "SSupp \ SSupp_iterm" -lemmas SSupp_def = SSupp_iterm_def -abbreviation "FFVars \ FVars_iterm" +abbreviation "SSupp' \ SSupp" +abbreviation "IImsupp' \ IImsupp" +hide_const IImsupp SSupp +abbreviation "SSupp \ SSupp' iVar" +abbreviation "IImsupp f \ SSupp f \ IImsupp' iVar FFVars f" abbreviation "irrename \ permute_iterm" (* *) -lemma FFVars_itvsubst[simp]: - assumes "|SSupp (\ :: ivar \ itrm)| t) = (\ {FFVars (\ x) | x . x \ FFVars t})" - apply (binder_induction t avoiding: "IImsupp \" rule: iterm.strong_induct) - apply (rule iterm.fresh_induct[of "IImsupp \"]) - apply (auto simp: IImsupp_def assms intro!: infinite_class.Un_bound var_class.UN_bound iterm.set_bd_UNIV) - using iterm.FVars_VVr apply (fastforce simp add: SSupp_def) - using iterm.FVars_VVr apply (auto simp add: SSupp_def Int_Un_distrib) - apply (smt (verit) disjoint_insert(1) empty_iff insertE insert_absorb iterm.FVars_VVr mem_Collect_eq) - apply (smt (verit, del_insts) CollectI IntI UN_iff UnCI empty_iff insertE iterm.FVars_VVr) - done +lemmas FFVars_itvsubst[simp] = iterm.Vrs_Sb (* Enabling some simplification rules: *) -lemmas iterm.tvsubst_VVr[simp] -lemmas iterm.FVars_VVr[simp] +lemmas iterm.Sb_Inj[simp] +lemmas iterm.Vrs_Inj[simp] iterm.permute_id[simp] iterm.permute_cong_id[simp] iterm.FVars_permute[simp] @@ -181,67 +167,16 @@ lemma supp_id_update_le[simp,intro]: "|supp (id(x := y))| _iterm_itvsubst_def - by (rule refl) - (* *) (* Properties of term-for-variable substitution *) -lemma itvsubst_VVr_func[simp]: "itvsubst VVr t = t" - apply (rule iterm.TT_fresh_induct) - apply (rule emp_bound) - subgoal for x - apply (rule case_split[of "isVVr (iterm_ctor x)"]) - apply (unfold isVVr_def)[1] - apply (erule exE) - subgoal premises prems for a - unfolding prems - apply (rule iterm.tvsubst_VVr) - apply (rule iterm.SSupp_VVr_bound) - done - apply (rule trans) - apply (rule iterm.tvsubst_cctor_not_isVVr) - apply (rule iterm.SSupp_VVr_bound) - unfolding IImsupp_VVr_empty - apply (rule Int_empty_right) - unfolding noclash_iterm_def Int_Un_distrib Un_empty - apply assumption+ - apply (rule arg_cong[of _ _ iterm_ctor]) - apply (rule trans) - apply (rule iterm_pre.map_cong) - apply (rule supp_id_bound bij_id)+ - apply (assumption | rule refl)+ - unfolding id_def[symmetric] iterm_pre.map_id - apply (rule refl) - done - done +lemmas itvsubst_VVr_func[simp] = iterm.Sb_Inj[THEN fun_cong, unfolded id_apply] thm iterm.strong_induct[of "\\. A" "\t \. P t", rule_format, no_vars] lemmas iterm.inject(3)[simp del] -lemma itvsubst_cong: -assumes f: "|SSupp f| z. (z::ivar) \ FFVars P \ f z = g z)" -shows "itvsubst f P = itvsubst g P" -using eq proof (binder_induction P avoiding: "IImsupp f" "IImsupp g" rule: iterm.strong_induct) - case (iApp x1 x2) - then show ?case using f g by simp (metis stream.map_cong0) -next - case (iLam x1 x2) - then show ?case using f g apply simp - by (smt (verit, ccfv_threshold) IImsupp_def SSupp_def UnCI insert_absorb insert_disjoint(2) mem_Collect_eq) -qed (auto simp: IImsupp_def iterm.UN_bound iterm.Un_bound iterm.set_bd_UNIV f g) - +lemmas itvsubst_cong = iterm.Sb_cong (* *) lemma iLam_same_inject[simp]: "iLam (xs::ivar dstream) e = iLam xs e' \ e = e'" @@ -348,13 +283,9 @@ lemma SSupp_upd_bound: intro: card_of_mono1) -corollary SSupp_upd_VVr_bound[simp,intro!]: "|SSupp (VVr(a:=(t::itrm)))| | |IImsupp \| ::ivar\ivar)" "|supp \| \ iVar(x := e)) \ - imsupp \ \ {x} \ FVars_iterm e" + imsupp \ \ {x} \ FFVars e" unfolding IImsupp_def SSupp_def imsupp_def supp_def by (auto split: if_splits) lemma IImsupp_irrename_update_bound: @@ -470,7 +401,8 @@ proof- subgoal by simp subgoal by simp (metis (mono_tags, lifting) comp_apply stream.map_comp stream.map_cong) subgoal for xs t apply(subgoal_tac "dsset xs \ IImsupp (\a. itvsubst \ (\ a)) = {}") - subgoal by simp (metis Int_Un_emptyI1 Int_Un_emptyI2 assms(1) assms(2) iterm.subst(3)) + apply simp + apply (metis Int_Un_emptyI1 Int_Un_emptyI2 \|SSupp (\a. itvsubst \ (\ a))| iterm.subst(3) s(1,2)) subgoal using IImsupp_itvsubst_su'[OF s(1)] by blast . . qed @@ -485,7 +417,8 @@ proof- subgoal by simp subgoal by simp (metis (mono_tags, lifting) comp_apply stream.map_comp stream.map_cong) subgoal for xs t apply simp apply(subgoal_tac "dsset xs \ IImsupp (\a. irrename \ (\ a)) = {}") - subgoal by simp (metis Int_Un_emptyI1 Int_Un_emptyI2 assms(2) b iterm.map(3) iterm.subst(3) iterm.vvsubst_permute s(2)) + apply (metis (no_types, lifting) Int_Un_emptyI2 Un_commute \|SSupp (\a. irrename \ (\ a))| b iterm.map(3) iterm.subst(3) iterm.vvsubst_permute + s(1,2)) subgoal using IImsupp_irrename_su' b s(1) by blast . . qed @@ -531,7 +464,11 @@ proof- "dsset ys \ IImsupp ((\a. irrename \ (if a = x then e2 else iVar a))) = {} \ \ ` dsset ys \ IImsupp (\a. if a = \ x then irrename \ e2 else iVar a) = {}") subgoal - by simp (metis (no_types, lifting) Int_Un_emptyI2 dstream_map_ident_strong imsupp_empty_IntD2) + apply (subst iterm.subst) + apply auto + apply (subst iterm.subst) + apply auto + by (metis (no_types, lifting) Int_Un_emptyI2 dstream_map_ident_strong imsupp_empty_IntD2) subgoal unfolding IImsupp_def imsupp_def SSupp_def supp_def by (auto split: if_splits simp: bij_implies_inject) . . qed @@ -548,7 +485,10 @@ proof- subgoal for ys t apply simp apply(subgoal_tac "dsset ys \ IImsupp (iVar(x := e2)) = {} \ dsset ys \ IImsupp (iVar(xx := e2)) = {}") subgoal - by simp (metis SSupp_upd_iVar_bound dstream_map_ident_strong iterm.subst(3) swap_simps(3)) + apply (subst iterm.subst) + apply auto + apply (metis Int_Un_emptyI1 Int_Un_emptyI2 SSupp_upd_iVar_bound dstream_map_ident_strong iterm.subst(3) swap_simps(3)) + by (metis Int_Un_emptyI1 Int_Un_emptyI2 SSupp_upd_iVar_bound iterm.subst(3)) subgoal unfolding IImsupp_def imsupp_def SSupp_def supp_def by auto . . qed @@ -712,7 +652,7 @@ assumes \: "bij \" "|supp \| (usub t u (x::ivar)) = usub (irrename \ t) (\ u) (\ x)" using assms apply(induct t rule: iterm.fresh_induct[where A = "{x,u} \ supp \"]) - subgoal using assms by simp (meson le_UNIV_insert) + subgoal using assms by simp subgoal by (auto simp: sb_def bij_implies_inject) subgoal using assms apply simp unfolding stream.map_comp apply(rule stream.map_cong0) by auto subgoal using assms apply(subst usub_iLam) apply auto apply(subst usub_iLam) by (auto simp: bij_implies_inject) . diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy index a3ae91b1..521f2696 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy @@ -25,7 +25,7 @@ inductive istep :: "itrm \ itrm \ bool" where | Xi: "istep e e' \ istep (iLam xs e) (iLam xs e')" lemmas [equiv] = - iterm.tvsubst_permutes[THEN fun_cong, unfolded comp_def] + iterm.tvsubst_permute[THEN fun_cong, unfolded comp_def] imkSubst_smap_irrename[symmetric, THEN fun_cong, unfolded comp_def] binder_inductive istep @@ -97,10 +97,10 @@ thm istep.equiv (* Other properties: *) lemma SSupp_If_small[simp]: "|A :: ivar set| - |SSupp (\x. if x \ A then f x else iVar x)| x. if x \ A then f x else iVar x)| ILC.FFVars e' \ ILC.FFVars e" - by(induct rule: istep.induct) (auto simp: imkSubst_def card_dsset_ivar) + by (induct rule: istep.induct) (auto simp: imkSubst_def card_dsset_ivar split: if_splits) end diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_Head_Reduction.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_Head_Reduction.thy index 09ba0fce..c1e8cd9f 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_Head_Reduction.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_Head_Reduction.thy @@ -17,7 +17,7 @@ unfolding hred_def apply(elim exE) subgoal for xs e1 es2 apply(subst irrename_eq_itvsubst_iVar'[of _ e1]) unfolding isPerm_def apply auto apply(subst itvsubst_comp) subgoal by (metis SSupp_imkSubst imkSubst_smap_irrename_inv) - subgoal by (smt (verit, best) SSupp_def VVr_eq_Var card_of_subset_bound mem_Collect_eq not_in_supp_alt o_apply subsetI) + subgoal by (smt (verit, best) SSupp_def card_of_subset_bound mem_Collect_eq not_in_supp_alt o_apply subsetI) subgoal apply(rule itvsubst_cong) subgoal using SSupp_irrename_bound by blast subgoal using card_SSupp_itvsubst_imkSubst_irrename_inv isPerm_def by auto diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy index acceb43a..d972eccb 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy @@ -67,15 +67,16 @@ using affine.simps affine_iLam_case by blast (* *) lemma tvsubst_affine': -assumes f: "|SSupp f| x. affine (f x)" +assumes f: "|ILC.SSupp f| x. affine (f x)" and fv: "\x y. x \ y \ FFVars (f x) \ FFVars (f y) = {}" and r: "affine (e::itrm)" shows "affine (itvsubst f e)" -using r proof (binder_induction e avoiding: "IImsupp f" rule: affine.strong_induct) +using r proof (binder_induction e avoiding: "ILC.IImsupp f" rule: affine.strong_induct) case (iLam ea xs) show ?case using iLam apply(subst iterm.subst) subgoal using f by auto subgoal by auto + subgoal by auto subgoal apply(rule affine.iLam) by auto . next case (iApp e1 es2) @@ -89,7 +90,7 @@ qed (auto simp: f ILC.SSupp_IImsupp_bound af) (which seems to prevent the above proof by induction), otherwise the result is not strong enough to instantiate to imakeSubst... *) lemma tvsubst_affine: -assumes f: "|SSupp f| x. affine (f x)" +assumes f: "|ILC.SSupp f| x. affine (f x)" and fv: "\x y. {x,y} \ FFVars e \ x \ y \ FFVars (f x) \ FFVars (f y) = {}" and r: "affine (e::itrm)" shows "affine (itvsubst f e)" @@ -116,9 +117,9 @@ proof- define g where "g \ \x. if x \ FFVars e then f x else if x \ \ ((FFVars o f) ` (FFVars e)) then t else iVar x" - have sg: "SSupp g \ FFVars e \ \ ((FFVars o f) ` (FFVars e))" unfolding g_def SSupp_def by auto + have sg: "ILC.SSupp g \ FFVars e \ \ ((FFVars o f) ` (FFVars e))" unfolding g_def SSupp_def by auto - have g: "|SSupp g| x. affine (g x)" + have g: "|ILC.SSupp g| x. affine (g x)" "\x y. x \ y \ FFVars (g x) \ FFVars (g y) = {}" subgoal using sg by (meson card_of_subset_bound ffv fve infinite_class.Un_bound) subgoal by (simp add: af affine.iVar g_def t(2)) diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy index 4f5b5242..1567c101 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy @@ -262,7 +262,7 @@ unfolding Tperm_def isPerm_def presBnd_presSuper by auto (* Other properties: *) -lemma touchedSuperT_itvsubst: "|SSupp f| touchedSuperT (itvsubst f t) = \ ((touchedSuperT o f) ` (FFVars t))" +lemma touchedSuperT_itvsubst: "|ILC.SSupp f| touchedSuperT (itvsubst f t) = \ ((touchedSuperT o f) ` (FFVars t))" unfolding touchedSuperT_def by (auto simp: touchedSuper_UN ) lemma good_FFVars_RSuper: "good e \ FFVars e \ RSuper" @@ -296,14 +296,15 @@ assumes r: "good e" and rr: "\xs x. super xs \ x \ dsset xs \ good (f x)" "\xs x x'. super xs \ {x,x'} \ dsset xs \ touchedSuperT (f x) = touchedSuperT (f x')" -and s: "|SSupp f| (\e e'. {e,e'} \ sset es \ good e \ touchedSuperT e = touchedSuperT e') \ e \ sset es \ - touchedSuper (IImsupp (imkSubst xs es)) \ + touchedSuper (ILC.IImsupp (imkSubst xs es)) \ {xs} \ touchedSuper (FFVars e)" using touchedSuper_IImsupp_imkSubst good_sset_touchedSuper by blast lemma super_good_finite_touchedSuper_imkSubst: "super xs \ (\e e'. {e,e'} \ sset es \ good e \ touchedSuperT e = touchedSuperT e') - \ finite (touchedSuper (IImsupp (imkSubst xs es)))" + \ finite (touchedSuper (ILC.IImsupp (imkSubst xs es)))" by (metis Supervariables.touchedSuper_IImsupp_imkSubst bot.extremum finite.insertI finite_Un good_finite_touchedSuperT insert_subset rev_finite_subset snth_sset touchedSuperT_def good_sset_touchedSuper) diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy index 8214907b..924146b1 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy @@ -143,10 +143,10 @@ thm strong_induct_reneqv' strong_induct_reneqv'' (* *) (* requires strong induction: *) lemma reneqv_itvsubst: assumes r: "reneqv e e'" and rr: "\xs x x'. super xs \ {x, x'} \ dsset xs \ reneqv (f x) (f' x')" - and s: "|SSupp f| uniformS es \ e \ sset es \ touchedSuper (IImsupp (imkSubst xs es)) \ +"super xs \ uniformS es \ e \ sset es \ touchedSuper (ILC.IImsupp (imkSubst xs es)) \ {xs} \ touchedSuper (FFVars e)" using touchedSuper_IImsupp_imkSubst uniformS_touchedSuper by blast @@ -253,7 +255,7 @@ lemma uniformS_touchedSuper_IImsupp_imkSubst'': using uniformS_touchedSuper_IImsupp_imkSubst' unfolding touchedSuper_def by blast lemma super_uniformS_finite_touchedSuper_imkSubst: -"super xs \ uniformS es \ finite (touchedSuper (IImsupp (imkSubst xs es)))" +"super xs \ uniformS es \ finite (touchedSuper (ILC.IImsupp (imkSubst xs es)))" by (metis finite_insert insert_is_Un rev_finite_subset snth_sset touchedSuperT_def touchedSuper_IImsupp_imkSubst uniformS_sset_uniform uniformS_touchedSuper uniform_finite_touchedUponT) diff --git a/case_studies/Infinitary_Lambda_Calculus/Iso_LC_ILC.thy b/case_studies/Infinitary_Lambda_Calculus/Iso_LC_ILC.thy index c3ddc9fd..0d5b769c 100644 --- a/case_studies/Infinitary_Lambda_Calculus/Iso_LC_ILC.thy +++ b/case_studies/Infinitary_Lambda_Calculus/Iso_LC_ILC.thy @@ -73,9 +73,17 @@ next then show ?case apply(subst term.subst(3)) subgoal by auto subgoal using IImsupp_Var by fastforce + subgoal using IImsupp_Var by fastforce subgoal unfolding tr_Lam apply (subst iterm.subst(3)) subgoal by auto subgoal using uniformS_touchedSuper_IImsupp_imkSubst + subgoal apply(subgoal_tac "superOf y \ touchedSuper (ILC.IImsupp (imkSubst (superOf x) (smap (tr e) ps)))") + subgoal unfolding touchedSuper_def by auto + subgoal apply(rule uniformS_touchedSuper_IImsupp_imkSubst'[where e = "tr e (shd ps)"]) + subgoal by auto subgoal by auto + subgoal apply auto by (meson image_eqI shd_sset) + subgoal by simp subgoal by (metis FFVars_tr UnI2 image_eqI subOf_superOf subset_eq) . . . + subgoal using uniformS_touchedSuper_IImsupp_imkSubst subgoal apply(subgoal_tac "superOf y \ touchedSuper (ILC.IImsupp (imkSubst (superOf x) (smap (tr e) ps)))") subgoal unfolding touchedSuper_def by auto subgoal apply(rule uniformS_touchedSuper_IImsupp_imkSubst'[where e = "tr e (shd ps)"]) @@ -195,12 +203,20 @@ proof- then show ?case apply(subst tr'_iLam) apply auto apply(subst iterm.subst(3)) subgoal by auto - subgoal apply(rule uniformS_touchedSuper_IImsupp_imkSubst''[where e = "shd ts"]) + subgoal apply (rule Int_subset_empty2[OF _ Un_upper1]) + apply (rule uniformS_touchedSuper_IImsupp_imkSubst''[where e = "shd ts"]) + using shd_sset super_touchedSuper_dsset by fastforce+ + subgoal apply (rule Int_subset_empty2[OF _ Un_upper2]) + apply (rule uniformS_touchedSuper_IImsupp_imkSubst''[where e = "shd ts"]) using shd_sset super_touchedSuper_dsset by fastforce+ subgoal apply(subst term.subst(3)) - subgoal by auto subgoal apply(rule IImsupp_Var') - apply simp by (metis (no_types, lifting) FFVars_tr' Int_Un_emptyI1 - Int_Un_emptyI2 Int_absorb UN_I disjoint_iff empty_not_insert shd_sset + subgoal by auto subgoal apply (rule IImsupp_Var') + apply simp by (metis (no_types, lifting) FFVars_tr' + Int_absorb UN_I disjoint_iff empty_not_insert shd_sset + superOf_subOf super_touchedSuper_dsset touchedSuper_emp uniformS_good) + subgoal apply (rule IImsupp_Var') + apply simp by (metis (no_types, lifting) FFVars_tr' + Int_absorb UN_I disjoint_iff empty_not_insert shd_sset superOf_subOf super_touchedSuper_dsset touchedSuper_emp uniformS_good) subgoal apply(subst tr'_iLam) subgoal by auto diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index 626ebe91..745c4fe9 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -1,5 +1,5 @@ theory POPLmark_2B - imports Pattern "HOL-Library.List_Lexorder" "HOL-Library.Char_ord" + imports POPLmark_1B Pattern "HOL-Library.List_Lexorder" "HOL-Library.Char_ord" begin binder_datatype (FTVars: 'tv, FVars: 'v) trm = @@ -13,690 +13,9 @@ binder_datatype (FTVars: 'tv, FVars: 'v) trm = | Let "('tv, p::'v) pat" "('tv, 'v) trm" t::"('tv, 'v) trm" binds p in t print_theorems -definition tvsubst_trm_pre :: "('tv::var \ 'tv typ) \ ('tv, 'v::var, 'tv, 'v, 'a, 'b) trm_pre \ ('tv, 'v, 'tv, 'v, 'a, 'b) trm_pre" where - "tvsubst_trm_pre f x \ Abs_trm_pre (case Rep_trm_pre x of - Inl (Inl (Inr (x, T, t))) \ Inl (Inl (Inr (x, tvsubst_typ f T, t))) - | Inl (Inr (Inr (x, T, t))) \ Inl (Inr (Inr (x, tvsubst_typ f T, t))) - | Inr (Inl (Inl (t, T))) \ Inr (Inl (Inl (t, tvsubst_typ f T))) - | Inr (Inr (Inr (p, t, u))) \ Inr (Inr (Inr (tvsubst_pat f id p, t, u))) - | x \ x - )" -abbreviation \ :: "'v \ ('tv::var, 'v::var, 'btv::var, 'bv::var, 'a, 'b) trm_pre" where - "\ a \ Abs_trm_pre (Inl (Inl (Inl a)))" - -lemma eta_free: "set2_trm_pre (\ a) = {a}" - apply (unfold set2_trm_pre_def sum.set_map UN_empty2 Un_empty_left Un_empty_right prod.set_map comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_empty UN_single - ) - apply (rule refl) - done -lemma eta_inj: "\ a = \ b \ a = b" - apply (unfold Abs_trm_pre_inject[OF UNIV_I UNIV_I] sum.inject) - apply assumption - done -lemma eta_natural: - fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" - assumes "|supp f1| \ = \ \ f2" - apply (rule ext) - apply (unfold comp_def map_trm_pre_def Abs_trm_pre_inverse[OF UNIV_I] map_sum.simps) - apply (rule refl) - done +thm trm.subst -(* Construction of substitution *) -definition VVr :: "'v::var \ ('tv::var, 'v) trm" where - "VVr \ trm_ctor \ \" -definition isVVr :: "('tv::var, 'v::var) trm \ bool" where - "isVVr x \ \a. x = VVr a" -definition asVVr :: "('tv::var, 'v::var) trm \ 'v" where - "asVVr x \ (if isVVr x then SOME a. x = VVr a else undefined)" - -lemma asVVr_VVr: "asVVr (VVr a) = a" - apply (unfold asVVr_def isVVr_def) - apply (subst if_P) - apply (rule exI) - apply (rule refl) - apply (rule someI2) - apply (rule refl) - apply (unfold VVr_def comp_def) - apply (unfold trm.TT_inject0) - apply (erule exE conjE)+ - apply (unfold map_trm_pre_def comp_def Abs_trm_pre_inverse[OF UNIV_I] - map_sum.simps Abs_trm_pre_inject[OF UNIV_I UNIV_I] id_apply - sum.inject - ) - apply (erule sym) - done - -lemma permute_VVr: - fixes f1::"'var::var \ 'var" and f2::"'tyvar::var \ 'tyvar" - assumes f_prems: "bij f1" "|supp f1| 'var" and f2::"'tyvar::var \ 'tyvar" - assumes f_prems: "bij f1" "|supp f1| a \ imsupp f2 \ IImsupp_2_trm y = {} \ y a = VVr a" - apply (unfold imsupp_def supp_def IImsupp_2_trm_def SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def VVr_def[symmetric]) - apply (drule iffD1[OF disjoint_iff]) - apply (erule allE) - apply (erule impE) - apply (rule UnI1) - apply (erule iffD2[OF mem_Collect_eq]) - apply (unfold Un_iff de_Morgan_disj mem_Collect_eq not_not) - apply (erule conjE) - apply assumption - done - -lemma IImsupp_permute_commute: - fixes f1::"'var::var \ 'var" and f2::"'tyvar::var \ 'tyvar" - assumes f_prems: "bij f1" "|supp f1| IImsupp_1_trm y = {} \ imsupp f2 \ IImsupp_2_trm y = {} \ permute_trm f1 f2 \ y = y \ f2" - apply (rule ext) - apply (unfold comp_def) - subgoal for a - apply (rule case_split[of "f2 a = a"]) - apply (rule case_split[of "y a = VVr a"]) - apply (rule trans) - apply (rule arg_cong[of _ _ "permute_trm f1 f2"]) - apply assumption - apply (rule trans) - apply (rule permute_VVr) - apply (rule assms)+ - apply (rule trans) - apply (rule arg_cong[of _ _ VVr]) - apply assumption - apply (rule sym) - apply (rotate_tac -2) - apply (erule subst[OF sym]) - apply assumption - - apply (rule trans) - apply (rule trm.permute_cong_id) - apply (rule assms)+ - (* REPEAT_DETERM *) - apply (erule id_onD[rotated]) - apply (rule imsupp_id_on) - apply (erule Int_subset_empty2) - apply (unfold IImsupp_1_trm_def SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def VVr_def[symmetric])[1] - apply (unfold comp_def)[1] - apply (rule subsetI) - apply (rule UnI2)? - apply (rule UN_I[rotated]) - apply assumption - apply (rule CollectI) - apply assumption - (* repeated *) - (* REPEAT_DETERM *) - apply (erule id_onD[rotated]) - apply (rule imsupp_id_on) - apply (erule Int_subset_empty2) - apply (unfold IImsupp_2_trm_def SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def VVr_def[symmetric])[1] - apply (unfold comp_def)[1] - apply (rule subsetI) - apply (rule UnI2)? - apply (rule UN_I[rotated]) - apply assumption - apply (rule CollectI) - apply assumption - (* END REPEAT_DETERM *) - apply (rotate_tac -2) - apply (erule subst[OF sym]) - apply (rule refl) - - apply (rule trans) - apply (rule arg_cong[of _ _ "permute_trm f1 f2"]) - defer - apply (rule trans) - prefer 3 - apply (erule IImsupp_VVrs) - apply assumption - apply (rule permute_VVr) - apply (rule f_prems)+ - apply (rule sym) - apply (rule IImsupp_VVrs) - apply (erule bij_not_eq_twice[rotated]) - apply (rule f_prems) - apply assumption - done - done - -lemmas SSupp_naturals = typ.SSupp_natural trm.SSupp_natural -lemmas IImsupp_naturals = typ.IImsupp_natural trm.IImsupp_natural - -lemmas Cinfinite_UNIV = conjI[OF trm_pre.UNIV_cinfinite card_of_Card_order] -lemmas Cinfinite_card = cmin_Cinfinite[OF Cinfinite_UNIV Cinfinite_UNIV] -lemmas regularCard_card = cmin_regularCard[OF trm_pre.var_regular trm_pre.var_regular Cinfinite_UNIV Cinfinite_UNIV] -lemmas Un_bound = regularCard_Un[OF conjunct2[OF Cinfinite_card] conjunct1[OF Cinfinite_card] regularCard_card] -lemmas UN_bound = regularCard_UNION[OF conjunct2[OF Cinfinite_card] conjunct1[OF Cinfinite_card] regularCard_card] - -lemma sets_tvsubst_trm_pre: - "set2_trm_pre (tvsubst_trm_pre f x) = set2_trm_pre x" - "set3_trm_pre (tvsubst_trm_pre f x) = set3_trm_pre x" - "set4_trm_pre (tvsubst_trm_pre f x) = set4_trm_pre x" - "set5_trm_pre (tvsubst_trm_pre f x) = set5_trm_pre x" - "set6_trm_pre (tvsubst_trm_pre f x) = set6_trm_pre x" - apply (unfold set2_trm_pre_def set3_trm_pre_def set4_trm_pre_def set5_trm_pre_def set6_trm_pre_def UN_empty -sum.set_map UN_single UN_singleton UN_empty2 Un_empty_right Un_empty_left prod.set_map tvsubst_trm_pre_def - comp_def Abs_trm_pre_inverse[OF UNIV_I] - ) - by (auto simp: PVars_tvsubst_pat split: sum.splits) - -lemma map_subst: "|SSupp_typ (g::'tv \ _)| bij f4 \ - tvsubst_trm_pre g (map_trm_pre id f2 f3 f4 f5 f6 x) = map_trm_pre id f2 f3 f4 f5 f6 (tvsubst_trm_pre g x)" - apply (unfold tvsubst_trm_pre_def map_trm_pre_def comp_def Abs_trm_pre_inverse[OF UNIV_I] case_sum_map_sum - typ.map_id0 case_prod_map_prod - ) - apply (auto split: sum.split) - apply (subst (1 2) vvsubst_pat_tvsubst_pat; simp) - apply (subst (1 2) tvsubst_pat_comp; (auto simp: o_def intro: ordLess_ordLeq_trans[OF _ cmin1])?) - apply (subst (1) typ.subst; (auto simp: o_def intro: ordLess_ordLeq_trans[OF _ cmin1])?) - done - -lemma FVars_tvsubst_typ_cmin: - assumes "|SSupp_typ (g::'tv \ _)| ((FVars_typ \ g) ` FVars_typ x)" - apply (rule FVars_tvsubst_typ) - using assms cmin1 ordLess_ordLeq_trans by blast - -type_synonym ('tv, 'v) U1_pre = "('tv, 'v, 'tv, 'v, ('tv, 'v) trm, ('tv, 'v) trm) trm_pre" - -lemmas eta_natural' = fun_cong[OF eta_natural, unfolded comp_def] -lemma eta_set_empties: - fixes a::"'v::var" - shows - "set1_trm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" - "set3_trm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" - "set4_trm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" - "set5_trm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" - "set6_trm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" - apply - - subgoal - apply (rule set_eqI) - apply (unfold empty_iff) - apply (rule iffI) - apply (rule exE[OF MRBNF_FP.exists_fresh, of "set1_trm_pre (\ a)"]) - apply (rule trm_pre.set_bd_UNIV) - apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) - apply (rule arg_cong[of _ _ set1_trm_pre]) - prefer 2 - apply (subst (asm) trm_pre.set_map) - prefer 7 - apply (erule swap_fresh) - apply assumption - apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ - apply (rule sym) - apply (rule trans) - apply (rule fun_cong[OF eta_natural, unfolded comp_def]) - apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ - apply (unfold id_def) - apply (rule refl) - apply (erule FalseE) - done - subgoal - apply (rule set_eqI) - apply (unfold empty_iff) - apply (rule iffI) - apply (rule exE[OF MRBNF_FP.exists_fresh, of "set3_trm_pre (\ a)"]) - apply (rule trm_pre.set_bd_UNIV) - apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) - apply (rule arg_cong[of _ _ set3_trm_pre]) - prefer 2 - apply (subst (asm) trm_pre.set_map) - prefer 7 - apply (erule swap_fresh) - apply assumption - apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ - apply (rule sym) - apply (rule trans) - apply (rule fun_cong[OF eta_natural, unfolded comp_def]) - apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ - apply (unfold id_def) - apply (rule refl) - apply (erule FalseE) - done - subgoal - apply (rule set_eqI) - apply (unfold empty_iff) - apply (rule iffI) - apply (rule exE[OF MRBNF_FP.exists_fresh, of "set4_trm_pre (\ a)"]) - apply (rule trm_pre.set_bd_UNIV) - apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) - apply (rule arg_cong[of _ _ set4_trm_pre]) - prefer 2 - apply (subst (asm) trm_pre.set_map) - prefer 7 - apply (erule swap_fresh) - apply assumption - apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ - apply (rule sym) - apply (rule trans) - apply (rule eta_natural') - apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ - apply (unfold id_def) - apply (rule refl) - apply (erule FalseE) - done - subgoal - apply (rule set_eqI) - apply (unfold empty_iff) - apply (rule iffI) - apply (drule image_const) - apply (drule iffD1[OF all_cong1, rotated]) - apply (rule sym) - apply (rule arg_cong2[OF refl, of _ _ "(\)"]) - apply (rule trm_pre.set_map) - apply (rule supp_id_bound bij_id)+ - apply (subst (asm) eta_natural') - apply (rule supp_id_bound bij_id)+ - apply (unfold id_def) - apply (drule forall_in_eq_UNIV) - apply (drule trans[symmetric]) - apply (rule conjunct1[OF card_order_on_Card_order, OF trm_pre.bd_card_order]) - apply (drule card_of_ordIso_subst) - apply (drule ordIso_symmetric) - apply (drule ordIso_transitive) - apply (rule ordIso_symmetric) - apply (rule iffD1[OF Card_order_iff_ordIso_card_of]) - apply (rule conjunct2[OF card_order_on_Card_order, OF trm_pre.bd_card_order]) - apply (erule ordIso_ordLess_False) - apply (rule trm_pre.set_bd) - apply (erule FalseE) - done - subgoal - apply (rule set_eqI) - apply (unfold empty_iff) - apply (rule iffI) - apply (drule image_const) - apply (drule iffD1[OF all_cong1, rotated]) - apply (rule sym) - apply (rule arg_cong2[OF refl, of _ _ "(\)"]) - apply (rule trm_pre.set_map) - apply (rule supp_id_bound bij_id)+ - apply (subst (asm) eta_natural') - apply (rule supp_id_bound bij_id)+ - apply (unfold id_def) - apply (drule forall_in_eq_UNIV) - apply (drule trans[symmetric]) - apply (rule conjunct1[OF card_order_on_Card_order, OF trm_pre.bd_card_order]) - apply (drule card_of_ordIso_subst) - apply (drule ordIso_symmetric) - apply (drule ordIso_transitive) - apply (rule ordIso_symmetric) - apply (rule iffD1[OF Card_order_iff_ordIso_card_of]) - apply (rule conjunct2[OF card_order_on_Card_order, OF trm_pre.bd_card_order]) - apply (erule ordIso_ordLess_False) - apply (rule trm_pre.set_bd) - apply (erule FalseE) - done - done - -context - fixes \1::"'v \ ('tv::var, 'v::var) trm" and \2::"'tv \ 'tv typ" - assumes f_prems: "|SSupp_trm \1| 2| 1 \ IImsupp_typ \2" "IImsupp_2_trm \1" - "\y. if isVVr (trm_ctor (map_trm_pre id id id id fst fst y)) then - \1 (asVVr (trm_ctor (map_trm_pre id id id id fst fst y))) - else - trm_ctor (tvsubst_trm_pre \2 (map_trm_pre id id id id snd snd y))" - apply unfold_locales - apply (unfold IImsupp_1_trm_def IImsupp_typ_def IImsupp_2_trm_def comp_def)[2] - apply (rule Un_bound UN_bound f_prems trm.FVars_bd_UNIVs typ.FVars_bd_UNIVs cmin_greater card_of_Card_order)+ - - subgoal for f1 f2 y - apply (subst trm_pre.map_comp, (assumption | rule supp_id_bound bij_id ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ - apply (unfold id_o_commute[of f1] id_o_commute[of f2] Product_Type.fst_comp_map_prod Product_Type.snd_comp_map_prod) - apply (subst trm_pre.map_comp[symmetric], (assumption | rule supp_id_bound bij_id ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ - apply (subst trm.permute_ctor[symmetric] isVVr_permute, (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ - - apply (rule case_split) - apply (subst if_P) - apply assumption - apply (unfold if_P if_not_P) - apply (unfold isVVr_def)[1] - apply (erule exE) - apply (rotate_tac -1) - apply (erule subst[OF sym]) - apply (subst permute_VVr) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - apply (unfold asVVr_VVr)[1] - apply (rule IImsupp_permute_commute[THEN fun_cong, unfolded comp_def]) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - apply (erule Int_subset_empty2, rule subsetI, (erule UnI1 UnI2 | assumption)+) - - apply (rule trans) - apply (rule trm.permute_ctor) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - apply (subst map_subst) - apply (rule f_prems bij_id)+ - - apply (subst trm_pre.map_comp, (assumption | rule supp_id_bound bij_id ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ - apply (unfold id_o o_id) - apply (unfold comp_def) - apply (rule arg_cong[of _ _ trm_ctor]) - - apply (unfold tvsubst_trm_pre_def map_trm_pre_def comp_def typ.map_id0 Abs_trm_pre_inverse[OF UNIV_I]) - apply (frule ordLess_ordLeq_trans) - apply (rule cmin1 card_of_Card_order)+ - apply (rotate_tac -3) - apply (unfold typ.vvsubst_permute) - using typ.SSupp_natural[of f1 \2] SSupp_typ_TyVar_comp[of f1] - SSupp_typ_tvsubst_typ_bound[of "TyVar o f1" \2] f_prems(1) ordLess_ordLeq_trans[OF f_prems(2) cmin1[OF card_of_Card_order card_of_Card_order]] - SSupp_typ_tvsubst_typ_bound[of "permute_typ f1 o \2 o inv f1" "TyVar o f1"] - apply (auto split: sum.splits simp: Abs_trm_pre_inject trans[OF comp_apply[symmetric] typ.tvsubst_permutes[THEN fun_cong]] comp_def - ordLeq_ordLess_trans[OF card_of_image] typ.FVars_permute tvsubst_pat_comp - vvsubst_pat_tvsubst_pat intro!: tvsubst_typ_cong IImsupp_permute_commute[THEN fun_cong, unfolded comp_def] - typ.IImsupp_permute_commute[THEN fun_cong, unfolded comp_def] tvsubst_pat_cong) - apply auto - apply (auto simp: permute_typ_eq_tvsubst_typ_TyVar o_def vvsubst_typ_tvsubst_typ[unfolded comp_def, symmetric] - intro!: tvsubst_pat_cong typ.SSupp_comp_bound[unfolded comp_def]) - apply (unfold typ.vvsubst_permute) - apply (auto intro!: typ.IImsupp_permute_commute[THEN fun_cong, unfolded comp_def]) - done - - subgoal premises prems - apply (rule case_split) - apply (subst if_P) - apply assumption - apply (unfold isVVr_def)[1] - apply (erule exE) - apply (drule sym) - apply (erule subst) - apply (unfold asVVr_VVr) - apply (rule case_split[of "_ = _"]) - apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]) - apply (rule arg_cong[of _ _ FTVars]) - apply assumption - apply (rule Un_upper1) - apply (rule subsetI) - apply (rule UnI2) - apply (unfold IImsupp_1_trm_def SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def VVr_def[symmetric] image_comp[unfolded comp_def])[1] - apply (unfold comp_def)[1] - apply (rule UnI1) - apply (rule UN_I) - apply (rule CollectI) - apply assumption - apply assumption - apply (unfold if_not_P) - apply (erule thin_rl) - - apply (unfold prod.collapse trm.FVars_ctor sets_tvsubst_trm_pre) - apply (subst map_subst) - apply (rule f_prems) - apply (rule bij_id) - apply (subst trm_pre.set_map, (rule bij_id supp_id_bound)+)+ - apply (unfold image_id image_comp comp_def prod.collapse) - apply (rule Un_mono')+ - subgoal - apply (unfold set1_trm_pre_def tvsubst_trm_pre_def UN_empty - sum.set_map UN_single UN_singleton UN_empty2 Un_empty_right Un_empty_left prod.set_map tvsubst_trm_pre_def - comp_def Abs_trm_pre_inverse[OF UNIV_I] IImsupp_1_trm_def IImsupp_typ_def SSupp_typ_def fst_conv snd_conv - tvVVr_tvsubst_typ_def tv\_typ_tvsubst_typ_def TyVar_def[symmetric] map_trm_pre_def typ.map_id0 - SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def VVr_def[symmetric] typ.set_map - ) - using f_prems apply (auto split: sum.splits simp: FVars_tvsubst_typ_cmin) - apply (metis singletonD typ.set(1)) - apply (metis singletonD typ.set(1)) - apply (metis singletonD typ.set(1)) - apply (subst (asm) PTVars_tvsubst_pat; (auto intro: ordLess_ordLeq_trans[OF _ cmin1])?) - apply (metis singletonD typ.set(1)) - done - apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) - apply (rule Diff_Un_disjunct) - apply (rule prems) - apply (rule Diff_mono[OF _ subset_refl]) - apply (unfold UN_extend_simps(2)) - (* REPEAT_DETERM *) - apply (rule subset_If) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* repeated *) - apply (rule subset_If) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* END REPEAT_DETERM *) - done - - subgoal premises prems - apply (rule case_split) - apply (subst if_P) - apply assumption - apply (unfold isVVr_def)[1] - apply (erule exE) - apply (drule sym) - apply (erule subst) - apply (unfold asVVr_VVr) - apply (rule case_split[of "_ = _"]) - apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]) - apply (rule arg_cong[of _ _ FVars]) - apply assumption - apply (rule Un_upper1) - apply (rule subsetI) - apply (rule UnI2) - apply (unfold IImsupp_2_trm_def SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def VVr_def[symmetric] image_comp[unfolded comp_def])[1] - apply (rule UnI2) - apply (rule UN_I) - apply (rule CollectI) - apply assumption - apply (unfold comp_def)[1] - apply assumption - apply (unfold if_not_P) - apply (erule thin_rl) - - apply (unfold trm.FVars_ctor prod.collapse sets_tvsubst_trm_pre map_subst) - apply (subst trm_pre.set_map, (rule bij_id supp_id_bound)+)+ - apply (unfold image_id image_comp comp_def prod.collapse sets_tvsubst_trm_pre) - apply (rule Un_mono')+ - apply (rule Un_upper1) - apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) - apply (rule Diff_Un_disjunct) - apply (rule prems) - apply (rule Diff_mono[OF _ subset_refl]) - apply (unfold UN_extend_simps(2)) - (* REPEAT_DETERM *) - apply (rule subset_If) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* repeated *) - apply (rule subset_If) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* END REPEAT_DETERM *) - done - done - -definition tvsubst :: "('tv, 'v) trm \ ('tv, 'v) trm" where - "tvsubst \ tvsubst.REC_trm" - -lemma tvsubst_VVr: "tvsubst (VVr a :: ('tv::var, 'v::var) trm) = \1 a" - apply (unfold tvsubst_def VVr_def comp_def) - apply (rule trans) - apply (rule tvsubst.REC_ctor) - apply (unfold eta_set_empties noclash_trm_def Un_empty) - apply (rule Int_empty_left conjI)+ - apply (subst trm_pre.map_comp, (rule supp_id_bound bij_id)+)+ - apply (unfold id_o o_id comp_def[of fst] fst_conv id_def[symmetric] trm_pre.map_id) - apply (rule trans) - apply (rule if_P) - apply (unfold isVVr_def VVr_def comp_def ) - apply (rule exI) - apply (rule refl) - apply (unfold meta_eq_to_obj_eq[OF VVr_def, THEN fun_cong, unfolded comp_def, symmetric] asVVr_VVr) - apply (rule refl) - done - -lemma tvsubst_not_is_VVr: - fixes x::"('tv::var, 'v::var) U1_pre" - assumes empty_prems: "set3_trm_pre x \ (IImsupp_1_trm \1 \ IImsupp_typ \2) = {}" "set4_trm_pre x \ IImsupp_2_trm \1 = {}" - and noclash: "noclash_trm x" - and VVr_prems: "\isVVr (trm_ctor x)" - shows - "tvsubst (trm_ctor x) = trm_ctor (tvsubst_trm_pre \2 (map_trm_pre id id id id tvsubst tvsubst x))" - apply (unfold tvsubst_def) - apply (rule trans) - apply (rule tvsubst.REC_ctor) - apply (rule empty_prems noclash)+ - apply (subst trm_pre.map_comp, (rule supp_id_bound bij_id)+)+ - apply (unfold id_o o_id comp_def[of fst] fst_conv id_def[symmetric] trm_pre.map_id) - apply (subst if_not_P, rule VVr_prems)+ - apply (unfold comp_def snd_conv if_P) - apply (rule refl) - done - -end - -lemma tvsubst_simps[simp]: - fixes f1::"'v \ ('tv::var, 'v::var) trm" and f2::"'tv \ 'tv typ" - assumes f_prems: "|SSupp_trm f1| IImsupp_2_trm f1 \ tvsubst f1 f2 (Abs x T t) = Abs x (tvsubst_typ f2 T) (tvsubst f1 f2 t)" - "tvsubst f1 f2 (App t1 t2) = App (tvsubst f1 f2 t1) (tvsubst f1 f2 t2)" - "X \ IImsupp_1_trm f1 \ X \ IImsupp_typ f2 \ X \ FVars_typ T \ tvsubst f1 f2 (TAbs X T t) = TAbs X (tvsubst_typ f2 T) (tvsubst f1 f2 t)" - "tvsubst f1 f2 (TApp t T) = TApp (tvsubst f1 f2 t) (tvsubst_typ f2 T)" - "tvsubst f1 f2 (Rec XX) = Rec (map_lfset id (tvsubst f1 f2) XX)" - "tvsubst f1 f2 (Proj t l) = Proj (tvsubst f1 f2 t) l" - "PVars p \ IImsupp_2_trm f1 = {} \ PVars p \ FVars t = {} \ tvsubst f1 f2 (Let p t u) = Let (tvsubst_pat f2 id p) (tvsubst f1 f2 t) (tvsubst f1 f2 u)" - subgoal - apply (unfold Var_def VVr_def[unfolded comp_def, symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong]) - apply (rule tvsubst_VVr) - apply (rule assms)+ - done - subgoal - apply (unfold Abs_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - subgoal - apply (unfold App_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - subgoal - apply (unfold TAbs_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - subgoal - apply (unfold TApp_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - subgoal - apply (unfold Rec_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - subgoal - apply (unfold Proj_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - subgoal - apply (unfold Let_def) - apply (rule trans[OF tvsubst_not_is_VVr]) - apply (rule assms)+ - apply (unfold set3_trm_pre_def set4_trm_pre_def sum.set_map UN_empty UN_empty2 Un_empty_left comp_def - Abs_trm_pre_inverse[OF UNIV_I] sum_set_simps UN_single prod.set_map prod_set_simps Un_empty_right - noclash_trm_def set1_trm_pre_def set6_trm_pre_def set2_trm_pre_def isVVr_def VVr_def - Abs_trm_pre_inject[OF UNIV_I UNIV_I] trm.TT_inject0 set5_trm_pre_def map_trm_pre_def - map_prod_simp map_sum.simps - )[4] - apply (auto split: sum.splits simp: tvsubst_trm_pre_def trm.TT_inject0 map_trm_pre_def Abs_trm_pre_inverse typ.map_id) - done - done - -(* END OF MANUAL tvsubst construction *) +abbreviation "tvsubst f1 f2 \ tvsubst_trm f2 f1" inductive "value" where "value (Abs x T t)" @@ -792,16 +111,6 @@ lemma ty_proj_ctxt_equiv[equiv]: apply (rule assms)+ done -lemma SSupp_typ_fun_upd_bound'[simp]: "|SSupp_typ (f(X := T))| |SSupp_typ f| T = U \ (\f. bij (f::'v::var \ 'v) \ |supp f| id_on (FVars t - {x}) f \ f x = y \ permute_trm id f t = u)" @@ -874,9 +183,9 @@ lemma permute_tusubst[equiv]: assumes "bij f" "|supp f| \ OK \ a \ FFVars lemma typing_fresh_ty_extend: "\ \<^bold>, Inl x <: U \<^bold>\ t \<^bold>: T \ x \ Inl -` dom \ \ FFVars_ctxt \ \ x \ FVars_typ U" by (metis Pair_inject UnE subset_vimage_iff typing_wf_ctxt vimageD wf_ctxt_FFVars wf_ctxt_ConsE) -lemma SSupp_typ_TyVar_bound[simp]: "|SSupp_typ (TyVar :: 'tv \ _)| _trm_tvsubst_trm_def - by simp - -lemma SSupp_Var_bound[simp]: "|SSupp_trm (Var :: 'v \ _)| ('tv::var, 'v::var) trm" - assumes "|SSupp_trm g| _trm_tvsubst_trm_def comp_def Var_def[symmetric]) - using infinite_UNIV insert_bound apply fastforce - using infinite_UNIV insert_bound apply fastforce - done - -lemma vvsubst_tvsubst_pat: " - bij f1 \ |supp (f1::'a::var \ 'a)| bij f2 \ |supp (f2::'b::var \ 'b)| - |SSupp_typ g1| -vvsubst_pat f1 f2 (tvsubst_pat g1 id x1) = tvsubst_pat (permute_typ f1 \ g1 \ inv f1) id (vvsubst_pat f1 f2 x1)" - apply transfer - apply auto - subgoal premises prems for f1 f2 g1 x - apply (induction x) - using typ.tvsubst_permutes[THEN fun_cong, OF prems(1,2,5), unfolded comp_def] - by (auto simp: typ.vvsubst_permute[OF prems(1-2)] lfset.map_comp lfset.map_cong) - done - -lemma permute_tvsubst: - fixes f1::"'a::var \ 'a" and f2::"'b::var \ 'b" - assumes "bij f1" "|supp f1| g1 \ inv f2) (permute_typ f1 \ g2 \ inv f1) (permute_trm f1 f2 t)" -proof - - have 1: "|SSupp_trm (permute_trm f1 f2 \ g1 \ inv f2)| g2 \ inv f1)| g. |SSupp_typ g| |SSupp_typ g| _trm_tvsubst_trm_def Var_def by auto -lemma SSupp_trm_Var_bound[simp]: - "|SSupp_trm (Var :: _ \ ('tv::var, 't::var) trm)| insert x (SSupp_trm f)" - unfolding SSupp_trm_def by auto -lemma SSupp_trm_fun_upd_bound[simp]: - fixes t :: "('tv::var, 't::var) trm" - shows "|SSupp_trm f| - |SSupp_trm (f(x:=t))| ('tv::var) typ)(x := v))| _typ_tvsubst_typ_def comp_def TyVar_def[symmetric]) - apply (rule cmin_greater) - apply (rule card_of_Card_order)+ - using infinite_UNIV insert_bound apply fastforce - using infinite_UNIV insert_bound apply fastforce - done - -lemma emp_bound_cmin[simp]: "|{}| {X} \ FVars_typ T" - unfolding IImsupp_typ_def SSupp_typ_def tvVVr_tvsubst_typ_def tv\_typ_tvsubst_typ_def comp_def TyVar_def[symmetric] fun_upd_def - imsupp_def supp_def - by (auto simp: typ.FVars_permute) - -lemma IImsupp_fun_upd_permute[simp]: - fixes f::"'a::var \ 'a" - assumes "bij f" "|supp f| {X} \ imsupp f \ FVars_typ T" - unfolding IImsupp_typ_def SSupp_typ_def tvVVr_tvsubst_typ_def tv\_typ_tvsubst_typ_def comp_def TyVar_def[symmetric] fun_upd_def - imsupp_def supp_def - using assms by (auto simp: typ.FVars_permute) +lemmas [equiv] = typ.tvsubst_permute[THEN fun_cong, unfolded comp_def] lemma permute_TyVar[simp]: fixes f1::"'a::var \ 'a" @@ -1154,17 +224,21 @@ lemma fun_upd_comp_Var[simp]: shows "permute_trm f1 f2 \ Var(x := v) \ inv f2 = (Var(f2 x := permute_trm f1 f2 v))" using assms by (auto simp: comp_def fun_upd_def split!: if_splits) +lemmas [simp] = trm.set_bd_UNIV + lemma permute_tusubst_trm_trm[equiv]: fixes f1::"'a::var \ 'a" and f2::"'b::var \ 'b" assumes "bij f1" "|supp f1| 'a" and f2::"'b::var \ 'b" assumes "bij f1" "|supp f1| |SSupp_typ (TyVar(f X := T2))| f(2) typ.SSupp_comp_bound) - subgoal apply simp - subgoal - using \|SSupp_typ (TyVar(f X := T2))| bij_implies_inject f(1,3) id_onD by fastforce . . . . + show ?thesis unfolding 0 + apply (subst typ.vvsubst_permute[symmetric], (rule f)+) + apply (subst typ.map_is_Sb) + apply (rule f) + subgoal apply(subst trans[OF comp_apply[symmetric] typ.Sb_comp[THEN fun_cong]]) + apply (auto simp: f comp_assoc[symmetric] typ.Sb_comp_Inj) + apply (rule typ.Sb_cong) + apply (auto simp: f bij_implies_inject) + using f(3) id_onD by fastforce + done qed lemma in_context_equiv_Inr[equiv]: @@ -1260,7 +333,7 @@ binder_inductive typing subgoal for \' x T1 t T2 apply (rule disjI2, rule disjI1) apply (rule exE[OF MRBNF_FP.exists_fresh[where A="{x} \ FVars t \ Inr -` dom \"]]) - apply (auto simp: insert_bound infinite_UNIV intro!: trm.Un_bound trm.set_bd_UNIV) [] + apply (auto simp: insert_bound_UNIV infinite_UNIV intro!: trm.Un_bound trm.set_bd_UNIV) [] apply (meson finite_set cinfinite_imp_infinite finite_imageI finite_ordLess_infinite2 finite_vimageI inj_Inr lfset.UNIV_cinfinite) subgoal for y apply (rule exI[of _ "{}"]; simp) @@ -1279,7 +352,7 @@ binder_inductive typing subgoal for \' X T1 t T2 apply (rule disjI2, rule disjI2, rule disjI2, rule disjI1) apply (rule exE[OF MRBNF_FP.exists_fresh[where A="{X} \ FVars_typ T1 \ FVars_typ T2 \ FTVars t \ FFVars_ctxt \ \ Inl -` dom \"]]) - apply (auto simp: insert_bound infinite_UNIV intro!: typ.Un_bound typ.UN_bound typ.set_bd_UNIV trm.set_bd_UNIV) [] + apply (auto simp: insert_bound_UNIV infinite_UNIV intro!: typ.Un_bound typ.UN_bound typ.set_bd_UNIV trm.set_bd_UNIV) [] apply (meson finite_set cinfinite_imp_infinite finite_imageI finite_ordLess_infinite2 finite_vimageI inj_Inl lfset.UNIV_cinfinite) subgoal for Y apply (rule exI[of _ "{Y}"]; simp add: TAbs_inject) @@ -1298,14 +371,14 @@ binder_inductive typing subgoal for \' t X T11 T12 T2 apply (rule disjI2, rule disjI2, rule disjI2, rule disjI2, rule disjI1) apply (rule exE[OF MRBNF_FP.exists_fresh[where A="{X} \ FVars_typ T11 \ FVars_typ T12 \ FVars_typ T2 \ FTVars t \ FFVars_ctxt \ \ Inl -` dom \"]]) - apply (auto simp: insert_bound infinite_UNIV intro!: typ.Un_bound typ.UN_bound typ.set_bd_UNIV trm.set_bd_UNIV) [] + apply (auto simp: insert_bound_UNIV infinite_UNIV intro!: typ.Un_bound typ.UN_bound typ.set_bd_UNIV trm.set_bd_UNIV) [] apply (meson finite_set cinfinite_imp_infinite finite_imageI finite_ordLess_infinite2 finite_vimageI inj_Inl lfset.UNIV_cinfinite) subgoal for Y apply (rule exI[of _ "{Y}"]; simp add: TAbs_inject) apply (intro conjI) apply (metis imageI setl.cases) apply (subst FVars_tvsubst_typ) - apply (metis SSupp_typ_TyVar SSupp_typ_fun_upd_le card_of_Un_singl_ordLess_infinite emp_bound infinite_UNIV insert_bound sup.orderE) + apply simp apply auto [] apply (rule exI[of _ "T11"]) apply (rule exI[of _ "permute_typ (X \ Y) T12"]) @@ -1634,11 +707,7 @@ lemma wf_ctxt_weaken: "\ \ \<^bold>, Inr x <: Q \<^bold>, \ \ \<^bold>, x <: Q \<^bold>, \ OK \ x \ dom \ \ x \ dom \" by (induct \) auto -lemma tvVVr_tvsubst_trm_Var[simp]: "tvVVr_tvsubst_trm x = Var x" - by (auto simp: tvVVr_tvsubst_trm_def VVr_def Var_def tv\_trm_tvsubst_trm_def) - -lemma IImsupp_2_trm_unary: "IImsupp_2_trm (Var(x := q)) \ insert x (FVars q)" - by (auto simp: IImsupp_2_trm_def SSupp_trm_def) +thm trm.subst lemma typing_tvsubst: "\ \<^bold>, Inr x <: Q \<^bold>, \ \<^bold>\ t \<^bold>: T \ \ \<^bold>\ q \<^bold>: Q \ \ \<^bold>, \ \<^bold>\ tvsubst (Var(x := q)) TyVar t \<^bold>: T" proof (binder_induction "\ \<^bold>, Inr x <: Q \<^bold>, \" t T arbitrary: \ \ avoiding: \ \ x q Q t T rule: typing.strong_induct) @@ -1646,12 +715,12 @@ proof (binder_induction "\ \<^bold>, Inr x <: Q \<^bold>, \" t T a then have "\ \ \<^bold>, \ OK" "Inr x \ dom \" "Inr x \ dom \" by (auto dest: wf_ctxt_weaken wf_ctxt_notin) with TVar show ?case - by (auto simp add: cmin_greater image_iff intro!: typing.TVar elim: typing_weaken) + by (auto simp add: image_iff intro!: typing.TVar elim: typing_weaken) next case (TAbs x T1 t T2 \ \) then show ?case - by (subst tvsubst_simps) - (auto simp: cmin_greater IImsupp_2_trm_def simp flip: append_Cons dest!: set_mp[OF SSupp_trm_fun_upd] intro!: typing.TAbs) + by (subst trm.subst) + (auto simp flip: append_Cons dest!: set_mp[OF SSupp_fun_upd_subset] IImsupp_fun_upd_subset[THEN set_mp] intro!: typing.TAbs) next case (TApp t1 T11 T12 t2 \ \) then show ?case @@ -1659,7 +728,7 @@ next next case (TTAbs X T1 t T2 \ \) then show ?case - by (subst tvsubst_simps) (auto simp: cmin_greater IImsupp_1_trm_def simp flip: append_Cons intro!: typing.TTAbs) + by (subst trm.subst) (auto dest!: IImsupp_fun_upd_subset[THEN set_mp] simp flip: append_Cons intro!: typing.TTAbs) next case (TTApp t1 X T11 T12 T2 \ \) then show ?case @@ -1679,9 +748,9 @@ next next case (TLet t T p \' u U \ \) then show ?case - by (subst tvsubst_simps) + by (subst trm.subst) (auto simp: vvsubst_pat_tvsubst_pat[of id id, simplified, symmetric] - simp flip: append_assoc intro!: typing.TLet dest!: set_mp[OF IImsupp_2_trm_unary]) + simp flip: append_assoc intro!: typing.TLet dest!: set_mp[OF SSupp_fun_upd_subset] IImsupp_fun_upd_subset[THEN set_mp]) qed lemma Abs_inject_permute: "x \ FVars u \ Abs x T t = Abs y U u \ (T = U \ t = permute_trm id (x \ y) u)" @@ -1828,242 +897,21 @@ qed auto lemma ty_refl': "\ \ \ ok ; T closed_in \; T = U \ \ \ \ T <: U" using ty_refl by blast -lemma IImsupp_1_trm_bound: - fixes f ::"'v \ ('tv :: var, 'v :: var) trm" - assumes "|SSupp_trm f| ('tv :: var, 'v :: var) trm" - assumes "|SSupp_trm f| u \ f ` FVars t. FVars u)" -proof - - have [simp]: "|SSupp_typ g| u \ f ` FVars t. FTVars u) \ (\u \ g ` FTVars t. FVars_typ u)" -proof - - have [simp]: "|SSupp_typ g| ('tv :: var, 'v :: var) trm" and g ::"'tv::var \ 'tv typ" - assumes - "|SSupp_trm f| h) \ SSupp_trm f \ SSupp_trm h" - unfolding SSupp_trm_def - using assms by (auto simp: tvsubst_VVr) - -lemma IImsupp_1_trm_tvsubst: - fixes f h :: "'v \ ('tv :: var, 'v :: var) trm" and g ::"'tv::var \ 'tv typ" - assumes - "|SSupp_trm f| h) \ IImsupp_1_trm f \ IImsupp_typ g \ IImsupp_1_trm h" - using assms using SSupp_trm_tvsubst[of f g h] - apply (auto simp: IImsupp_1_trm_def IImsupp_typ_def FTVars_tvsubst) - using SSupp_trm_def trm.FVars_VVr(1) apply force - by (metis (mono_tags, lifting) SSupp_trm_def SSupp_typ_def empty_iff mem_Collect_eq singletonD - trm.FVars_VVr(1) typ.FVars_VVr) - -lemma IImsupp_2_trm_tvsubst: - fixes f h :: "'v \ ('tv :: var, 'v :: var) trm" and g ::"'tv::var \ 'tv typ" - assumes - "|SSupp_trm f| h) \ IImsupp_2_trm f \ IImsupp_2_trm h" - using assms using SSupp_trm_tvsubst[of f g h] - apply (auto simp: IImsupp_2_trm_def FVars_tvsubst) - by (metis (mono_tags, lifting) SSupp_trm_def Un_iff mem_Collect_eq singletonD subset_iff - trm.FVars_VVr(2)) - -lemma SSupp_trm_tvsubst_bound: - fixes f h :: "'v \ ('tv :: var, 'v :: var) trm" and g ::"'tv::var \ 'tv typ" - assumes - "|SSupp_trm f| h)| 'tv typ" - assumes "|SSupp_typ f| g)| x. x \ FVars t \ f x = f' x" "\x. x \ FTVars t \ g x = g' x" - shows "tvsubst f g t = tvsubst f' g' t" -proof - - have [simp]: "|SSupp_typ g| ) = supp \" - unfolding SSupp_trm_def supp_def - by auto - lemma finite_FVars[simp]: "finite (FVars t)" by (induct t) auto lemma finite_FTVars[simp]: "finite (FTVars t)" by (induct t) auto -lemma tvsubst_pat_id[simp]: "tvsubst_pat TyVar id x = x" - apply (rule trans) - apply (rule arg_cong3[OF _ refl refl, of _ _ tvsubst_pat]) - apply (rule o_id[symmetric]) - apply (unfold vvsubst_pat_tvsubst_pat[symmetric, OF supp_id_bound] pat.map_id) - apply (rule refl) - done - -lemma permute_trm_eq_tvsubst: - fixes \ :: "'v :: var \ 'v" and \ :: "'tv :: var \ 'tv" and t :: "('tv :: var, 'v :: var) trm" - assumes [simp]: - "bij \" - "|supp \| " - "|supp \| \ t = tvsubst (Var o \) (TyVar o \) t" -proof - - have [simp]: "|supp \| | )| )| " "supp \" t rule: trm.strong_induct) - apply (auto simp: permute_typ_eq_tvsubst_typ_TyVar lfset.set_map intro!: lfset.map_cong0) - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_2_trm_def SSupp_trm_Var_comp not_in_supp_alt bij_implies_inject[OF \bij \\]) - apply (meson not_in_supp_alt) - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_1_trm_def IImsupp_typ_def SSupp_typ_TyVar_comp not_in_supp_alt bij_implies_inject[OF \bij \\]) - apply (meson not_in_supp_alt) - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_2_trm_def SSupp_trm_Var_comp not_in_supp_alt vvsubst_pat_tvsubst_pat - Int_commute[of _ "supp _"] id_on_def SSupp_typ_TyVar_comp dest!: supp_id_on - intro!: arg_cong3[where h=Let] tvsubst_pat_cong) - apply (meson not_in_supp_alt) - apply (meson assms(1) bij_implies_inject not_in_supp_alt) - apply (rule exI[of _ id]) - apply (auto simp: trm.permute_id supp_inv_bound vvsubst_pat_tvsubst_pat[symmetric]) - by (simp add: pat.map_cong) -qed +lemmas tvsubst_pat_id[simp] = pat.Sb_Inj -lemma SSupp_restrict: "SSupp_typ (restrict f A TyVar) \ SSupp_typ f" +lemma SSupp_restrict: "SSupp TyVar (restrict f A TyVar) \ SSupp TyVar f" unfolding restrict_def - by (simp add: Collect_mono_iff SSupp_typ_def) -lemma SSupp_restrict_Var: "SSupp_trm (restrict f A Var) \ SSupp_trm f" + by (simp add: Collect_mono_iff SSupp_def) +lemma SSupp_restrict_Var: "SSupp Var (restrict f A Var) \ SSupp Var f" unfolding restrict_def - by (simp add: Collect_mono SSupp_trm_def) + by (simp add: Collect_mono SSupp_def) + +lemmas [simp] = SSupp_restrict_Var[THEN card_of_subset_bound] SSupp_restrict[THEN card_of_subset_bound] lemmas trm.inject(8)[simp del] lemma permute_trm_eq_tvsubst': @@ -2075,37 +923,43 @@ lemma permute_trm_eq_tvsubst': "|supp \| \ t = tvsubst (restrict (Var o \) (FVars t) Var) (restrict (TyVar o \) (FTVars t) TyVar) t" proof - - have [simp]: "|SSupp_trm (restrict (Var o \) (FVars t) Var)| ) (FTVars t) TyVar)| ) (FVars t) Var)| ) (FTVars t) TyVar)| " "supp \" t rule: trm.strong_induct) - apply (auto simp: permute_typ_eq_tvsubst_typ_TyVar lfset.set_map intro!: lfset.map_cong0) - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_2_trm_def SSupp_trm_Var_comp not_in_supp_alt bij_implies_inject[OF \bij \\] restrict_def) - apply (auto simp: SSupp_trm_def SSupp_typ_def restrict_def infinite_UNIV cmin_greater) [2] - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_1_trm_def IImsupp_2_trm_def IImsupp_typ_def SSupp_typ_TyVar_comp not_in_supp_alt bij_implies_inject[OF \bij \\] trm.permute_id) - apply (auto simp: SSupp_trm_def SSupp_typ_def restrict_def infinite_UNIV cmin_greater bij_implies_inject supp_def[symmetric] split: if_splits intro!: tvsubst_typ_cong tvsubst_cong lfset.map_cong) - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_1_trm_def IImsupp_2_trm_def IImsupp_typ_def SSupp_typ_TyVar_comp not_in_supp_alt bij_implies_inject[OF \bij \\] trm.permute_id) - apply (auto simp: SSupp_trm_def SSupp_typ_def restrict_def infinite_UNIV cmin_greater bij_implies_inject supp_def[symmetric] split: if_splits intro!: tvsubst_typ_cong tvsubst_cong lfset.map_cong) - apply (subst tvsubst_simps) - apply (auto simp: IImsupp_1_trm_def IImsupp_2_trm_def IImsupp_typ_def SSupp_typ_TyVar_comp not_in_supp_alt bij_implies_inject[OF \bij \\]) - apply (auto simp: SSupp_trm_def SSupp_typ_def restrict_def infinite_UNIV cmin_greater bij_implies_inject supp_def[symmetric] vvsubst_pat_tvsubst_pat split: if_splits intro!: tvsubst_typ_cong tvsubst_cong lfset.map_cong tvsubst_pat_cong arg_cong3[where h=Let]) + apply (auto simp: lfset.set_map intro!: lfset.map_cong0) + apply (subst trm.subst) + apply (auto simp: not_in_supp_alt bij_implies_inject[OF \bij \\] restrict_def) + apply (auto simp: IImsupp_def SSupp_def restrict_def)[1] + apply (subst trm.subst) + apply (auto simp: IImsupp_def not_in_supp_alt bij_implies_inject[OF \bij \\] trm.permute_id) + apply (auto simp: SSupp_def IImsupp_def typ.vvsubst_permute[symmetric] typ.map_is_Sb restrict_def bij_implies_inject supp_def[symmetric] split: if_splits intro!: trm.Sb_cong lfset.map_cong) + apply (subst trm.subst) + apply (auto simp: IImsupp_def not_in_supp_alt bij_implies_inject[OF \bij \\] trm.permute_id) + apply (auto simp: SSupp_def IImsupp_def typ.vvsubst_permute[symmetric] typ.map_is_Sb restrict_def bij_implies_inject supp_def[symmetric] split: if_splits intro!: trm.Sb_cong lfset.map_cong) + apply (subst trm.subst) + apply (auto simp: IImsupp_def not_in_supp_alt bij_implies_inject[OF \bij \\] trm.permute_id) + apply (auto simp: SSupp_def IImsupp_def typ.vvsubst_permute[symmetric] typ.map_is_Sb restrict_def bij_implies_inject supp_def[symmetric] split: if_splits intro!: trm.Sb_cong lfset.map_cong) apply (metis DiffD2 Diff_triv assms(1) bij_implies_inject not_in_supp_alt) apply (metis DiffD2 Diff_triv assms(1) bij_implies_inject not_in_supp_alt) - apply (meson disjoint_iff_not_equal not_in_supp_alt) - apply (meson disjoint_iff_not_equal not_in_supp_alt) - done -qed -lemma supp_swap_bound_cmin: "|supp (x \ y)| A Var) = SSupp_trm \ \ A" - unfolding SSupp_trm_def restrict_def +lemma SSupp_trm_restrict: "SSupp Var (restrict \ A Var) = SSupp Var \ \ A" + unfolding SSupp_def restrict_def by auto lemma Int_bound2: "|B| |A \ B| |A \ B| ::"'a::var \ ('b::var, 'a) trm" and p::"('b, 'a) pat" - shows "|SSupp_trm (restrict \ (PVars p) Var)| (PVars p) Var)| A TyVar) = SSupp_typ \ \ A" - unfolding SSupp_typ_def restrict_def +lemma SSupp_typ_restrict[simp]: "SSupp TyVar (restrict \ A TyVar) = SSupp TyVar \ \ A" + unfolding SSupp_def restrict_def by auto lemma FVars_restrict: "FVars (restrict \ A Var a) = (if a \ A then FVars (\ a) else {a})" @@ -2228,6 +1080,34 @@ fixes f1::"'a::var \ 'a" and f2::"'b::var \ 'b" using assms by (auto simp: equiv(26)) lemmas [equiv] = restrict_equiv[unfolded comp_def] match_equiv[unfolded comp_def] map_lfset_lfupdate +lemmas tvsubst_comp = trans[OF comp_apply[symmetric] trm.Sb_comp(1)[THEN fun_cong]] + +lemma IImsupp_restrict_bound[intro!]: "(\a. |Vrs a| |A| |IImsupp Inj Vrs (restrict \ A Inj)| |SSupp Inj (restrict \ A Inj)| 1::"'a::var \ 'a" and \2::"'b::var \ 'b" + assumes "bij \1" "|supp \1| 2" "|supp \2| 1 \2 (tvsubst (restrict \' (PVars p) Var) TyVar u) = + tvsubst (restrict (\a. permute_trm \1 \2 (\' (inv \2 a))) (\2 ` PVars p) Var) TyVar (permute_trm \1 \2 u)" + apply (rule trans) + apply (rule trans[OF comp_apply[symmetric] trm.tvsubst_permute[THEN fun_cong]]) + apply (rule assms SSupp_Inj_bound)+ + using pat.set_bd_UNIV(2) trm.FVars_bd_UNIVs(1) apply blast + using pat.set_bd_UNIV(2) apply blast + apply (rule trans[OF comp_apply]) + apply (rule trm.Sb_cong) + by (auto simp: assms supp_inv_bound pat.set_bd_UNIV trm.vvsubst_permute[symmetric] + trm.IImsupp_natural restrict_def trm.set_map + intro!: trm.SSupp_map_bound) + binder_inductive step subgoal premises prems for R B1 B2 t u unfolding ex_simps conj_disj_distribL ex_disj_distrib @@ -2237,40 +1117,45 @@ binder_inductive step subgoal for v x T t apply (rule disjI1) apply (rule exE[OF MRBNF_FP.exists_fresh[where A="{x} \ FVars t \ FVars v"]]) - apply (metis lfset.Un_bound trm.FVars_VVr(2) trm.set_bd_UNIV(2)) + apply (metis lfset.Un_bound trm.set(9) trm.set_bd_UNIV(2)) subgoal for y apply (rule exI[of _ "{}"]) apply (rule conjI) apply simp apply (rule exI[of _ "{y}"]) apply (rule conjI) - apply (auto simp: FVars_tvsubst) - apply (subst permute_trm_eq_tvsubst) - apply (simp_all add: supp_swap_bound_cmin supp_id) - apply (subst tvsubst_comp) - apply (auto simp: fun_upd_comp SSupp_trm_Var_comp supp_swap_bound_cmin) - apply (rule tvsubst_cong) - apply (auto simp: fun_upd_comp SSupp_trm_tvsubst_bound SSupp_typ_tvsubst_typ_bound' SSupp_trm_Var_comp supp_swap_bound_cmin) + apply (auto simp: trm.Vrs_Sb) + apply (subst trm.vvsubst_permute[symmetric]) + apply auto[4] + apply (subst trm.map_is_Sb) + apply (simp_all add: supp_id) + apply (subst trans[OF comp_apply[symmetric] trm.Sb_comp(1)[THEN fun_cong]]) + apply (auto simp: fun_upd_comp IImsupp_Inj_comp_bound) + apply (rule trm.Sb_cong) + apply (auto simp: fun_upd_comp trm.SSupp_Sb_bound trm.IImsupp_Sb_bound) + apply (simp add: IImsupp_Inj_comp_bound2 trm.IImsupp_Sb_bound(1)) apply (metis swap_simps(3)) by (metis swap_def) done subgoal for X T t T2 apply (rule disjI2, rule disjI1) apply (rule exE[OF MRBNF_FP.exists_fresh[where A="{X} \ FTVars t \ FVars_typ T \ FVars_typ T2"]]) - apply (metis lfset.Un_bound trm.FVars_bd_UNIVs(1) typ.FVars_VVr typ.FVars_bd_UNIVs) + apply (simp add: infinite_UNIV) subgoal for Y apply (rule exI[of _ "{Y}"]) apply (rule conjI) - apply (auto simp: FTVars_tvsubst) [] + apply (auto simp: trm.Vrs_Sb) [] apply (rule exI[of _ "{}"]) apply (rule conjI) apply auto - apply (subst permute_trm_eq_tvsubst) - apply (simp_all add: supp_swap_bound_cmin supp_id) + apply (subst trm.vvsubst_permute[symmetric]) + apply auto[4] + apply (subst trm.map_is_Sb) + apply (simp_all add: supp_id) apply (subst tvsubst_comp) - apply (auto simp: fun_upd_comp SSupp_typ_TyVar_comp supp_swap_bound_cmin) - apply (rule tvsubst_cong) - apply (auto simp: fun_upd_comp SSupp_trm_tvsubst_bound SSupp_typ_tvsubst_typ_bound' SSupp_typ_TyVar_comp supp_swap_bound_cmin) + apply (auto simp: fun_upd_comp) + apply (rule trm.Sb_cong) + apply (auto simp: fun_upd_comp trm.SSupp_Sb_bound trm.IImsupp_Sb_bound) apply (metis swap_def)+ done done @@ -2283,8 +1168,9 @@ binder_inductive step apply (rule exI[of _ "{}"]; simp) apply (rule exI[of _ "\ ` PVars p"]; simp) apply (rule conjI) - apply (subst FVars_tvsubst) - apply (auto simp: FVars_restrict infinite_UNIV intro!: cmin_greater finite_ordLess_infinite2 dest: match_FVars) [3] + apply (subst trm.Vrs_Sb) + apply (auto simp: FVars_restrict infinite_UNIV intro!: finite_ordLess_infinite2 dest: match_FVars) [4] + apply (auto simp: IImsupp_def SSupp_def restrict_def)[1] apply (rule exI[of _ v]) apply (rule exI[of _ "\ o \"]) apply (rule exI[of _ "vvsubst_pat id \ p"]) @@ -2298,15 +1184,15 @@ binder_inductive step apply (subst permute_trm_eq_tvsubst') apply (auto) apply (subst tvsubst_comp) - apply (auto simp: infinite_UNIV SSupp_trm_restrict intro!: cmin_greater) - apply (rule tvsubst_cong) - apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def intro: cmin_greater intro!: SSupp_trm_tvsubst_bound SSupp_typ_tvsubst_typ_bound') - apply (subst tvsubst_simps) - apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def intro!: cmin_greater) - apply (subst tvsubst_simps) - apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def intro!: cmin_greater) + apply (auto simp: supp_def[symmetric] intro!: var_class.UN_bound) + apply (rule trm.Sb_cong) + apply (auto simp: SSupp_trm_restrict restrict_def intro!: trm.SSupp_Sb_bound trm.IImsupp_Sb_bound) + apply (subst trm.subst) + apply (auto simp: SSupp_trm_restrict restrict_def) + apply (subst trm.subst) + apply (auto simp: SSupp_trm_restrict restrict_def) done - apply (auto simp: infinite_UNIV intro!: trm.Un_bound trm.set_bd_UNIV) + apply (auto intro!: trm.Un_bound trm.set_bd_UNIV) done subgoal for VV l v by auto @@ -2392,7 +1278,7 @@ next using SA_Trans_TVar(2) context_determ wf_context by blast note IH = SA_Trans_TVar(3)[OF SA_Trans_TVar(4), simplified] from ok have "tvsubst_typ (TyVar(X := P)) Q = Q" - by (intro trans[OF tvsubst_typ_cong tvsubst_typ_TyVar]) auto + by (intro trans[OF typ.Sb_cong tvsubst_typ_TyVar]) auto then have "\ \ P <: tvsubst_typ (TyVar(X := P)) Q" using SA_Trans_TVar(4) by simp with IH have "\ \<^bold>, map (map_prod id (tvsubst_typ (TyVar(X := P)))) \ \ P <: tvsubst_typ (TyVar(X := P)) T" by (meson ty_transitivity2 ty_weakening wf_context) @@ -2401,7 +1287,7 @@ next next case False from ok have "Y <: U \ \ \ tvsubst_typ (TyVar(X := P)) U = U" - by (intro trans[OF tvsubst_typ_cong tvsubst_typ_TyVar]) + by (intro trans[OF typ.Sb_cong tvsubst_typ_TyVar]) (auto simp: subset_iff dest: wf_ty_closed_in) with SA_Trans_TVar False show ?thesis apply auto @@ -2412,7 +1298,7 @@ next next case (SA_All T\<^sub>1 S\<^sub>1 x S\<^sub>2 T\<^sub>2 \) then show ?case - by (subst (1 2) typ.subst) (auto dest!: IImsupp_fun_upd[THEN set_mp]) + by (subst (1 2) typ.subst) (auto dest!: SSupp_fun_upd_subset[THEN set_mp] IImsupp_fun_upd_subset[THEN set_mp]) next case (SA_TRec YY XX \) then show ?case @@ -2446,13 +1332,15 @@ lemma wf_ctxt_weaken_ext: "\ \ \<^bold>, \ OK \ \ OK \ (Inr x, T) \ set \ \ FVars_typ T \ Inl -` dom \" by (induct \) auto +lemmas tvsubst_typ_comp = trans[OF comp_apply[symmetric] typ.Sb_comp[THEN fun_cong]] + lemma tvsubst_typ_tvsubst_typ: "X \ Y \ Y \ FVars_typ T \ tvsubst_typ (TyVar(X := T)) (tvsubst_typ (TyVar(Y := U)) Q) = tvsubst_typ (TyVar(Y := tvsubst_typ (TyVar(X := T)) U)) (tvsubst_typ (TyVar(X := T)) Q)" by (subst (1 2) tvsubst_typ_comp) - (auto simp: SSupp_typ_tvsubst_typ_bound intro!: tvsubst_typ_cong - sym[OF trans[OF tvsubst_typ_cong tvsubst_typ_TyVar]]) + (auto simp: typ.SSupp_Sb_bound intro!: typ.Sb_cong + sym[OF trans[OF typ.Sb_cong tvsubst_typ_TyVar]]) lemma pat_typing_tvsubst_typ: "\ p : T \ \ \ \ tvsubst_pat (TyVar(X := P)) id p : tvsubst_typ (TyVar(X := P)) T \ @@ -2468,12 +1356,18 @@ lemma typing_tvsubst_typ: "\ \<^bold>, Inl X <: Q \<^bold>, \ \<^b proof (binder_induction "\ \<^bold>, Inl X <: Q \<^bold>, \" t T arbitrary: \ avoiding: \ X Q \ t T P rule: typing.strong_induct) case (TVar x T \) then have "(Inr x, T) \ set \ \ tvsubst_typ (TyVar(X := P)) T = T" - by (intro trans[OF tvsubst_typ_cong tvsubst_typ_TyVar]) + by (intro trans[OF typ.Sb_cong tvsubst_typ_TyVar]) (auto dest!: wf_ctxt_closed[rotated] dest: wf_ctxt_notin wf_ctxt_weaken_ext) with TVar show ?case by (force dest: well_scoped(1) simp: wf_ctxt_extend_tvsubst_typ image_iff intro!: typing.TVar) next case (TTAbs Y T1 t T2 \) - with IImsupp_fun_upd[of X P] show ?case by (auto 0 3 simp: subset_eq intro: typing.TTAbs) + with IImsupp_fun_upd_subset[of TyVar FVars_typ TyVar X P] show ?case apply (auto 0 3 simp: subset_eq intro!: typing.TTAbs) + apply (subst trm.subst) + apply (auto dest!: SSupp_fun_upd_subset[THEN set_mp]) + apply (subst typ.subst) + apply (auto dest!: SSupp_fun_upd_subset[THEN set_mp]) + apply (auto 0 3 simp: subset_eq intro!: typing.TTAbs) + done next case (TTApp t1 Z T11 T12 T2 \) have "T11 closed_in proj_ctxt (\ \<^bold>, Inl X <: Q \<^bold>, \)" @@ -2485,11 +1379,11 @@ next ultimately have "\ \<^bold>, map (map_prod id (tvsubst_typ ?XP)) \ \<^bold>\ TApp (tvsubst Var ?XP t1) (tvsubst_typ ?XP T2) \<^bold>: tvsubst_typ (TyVar(Z := tvsubst_typ ?XP T2)) (tvsubst_typ ?XP T12)" - using IImsupp_fun_upd[of X P] TTApp(1-9) + using IImsupp_fun_upd_subset[of TyVar FVars_typ TyVar X P] TTApp(1-9) apply (intro typing.TTApp) apply (auto simp: FVars_tvsubst_typ) apply (subst (asm) typ.subst) - apply (auto simp: FVars_tvsubst_typ) + apply (auto simp: FVars_tvsubst_typ dest!: SSupp_fun_upd_subset[THEN set_mp]) apply (drule set_mp, assumption) apply (auto simp: set_proj_ctxt) done @@ -2510,7 +1404,7 @@ next next case (TLet ta Ta p \' u U \) then show ?case - by (subst tvsubst_simps) + by (subst trm.subst) (auto intro!: typing.TLet pat_typing_tvsubst_typ) qed (auto intro: typing.intros) @@ -2528,7 +1422,7 @@ lemma restrict_empty[simp]: "restrict \ {} v = v" lemma tvsubst_id[simp]: "tvsubst Var TyVar t = t" apply (binder_induction t avoiding: t rule: trm.strong_induct) apply (auto intro!: trans[OF lfset.map_cong_id lfset.map_id]) - apply (subst tvsubst_simps) + apply (subst trm.subst) apply auto done @@ -2625,22 +1519,16 @@ next apply (subst (asm) tvsubst_comp) apply (auto 0 0 intro!: cmin_greater) [3] apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2)) + apply (auto simp: IImsupp_restrict_bound) apply (erule arg_cong[where f="\t. typing _ t _", THEN iffD1, rotated]) - apply (rule tvsubst_cong) - apply (auto 0 0 simp: permute_typ_eq_tvsubst_typ_TyVar[of id, simplified, symmetric]) [5] - apply (subst SSupp_trm_tvsubst_bound) - apply (auto 0 0 intro!: cmin_greater) [5] - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict pat.set_bd_UNIV(2)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict pat.set_bd_UNIV(2)) - apply (auto simp: restrict_def nonrep_PRec_def values_lfin_iff) + apply (rule trm.Sb_cong) + apply (auto 0 0 intro!: trm.SSupp_Sb_bound trm.IImsupp_Sb_bound pat.set_bd_UNIV) [5] + apply (metis IImsupp_restrict_bound PVars_PRec pat.set_bd_UNIV(2) trm.set_bd_UNIV(1)) + apply (rule refl) + apply (auto simp: restrict_def nonrep_PRec_def values_lfin_iff) subgoal for x P' l' - apply (rule trans[OF tvsubst_cong tvsubst_id]) + apply (rule trans[OF trm.Sb_cong(1) tvsubst_id]) apply (auto 0 0 simp: restrict_def intro!: cmin_greater) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) apply (cases "l = l'") apply simp using match_FVars[of \ P v x] @@ -2648,20 +1536,16 @@ next apply fast done subgoal for x P' l' - apply (subst tvsubst_simps) - apply (auto 0 0 intro!: cmin_greater) [2] - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) + apply (subst trm.subst) + apply (auto 0 0) [3] apply (auto simp: restrict_def) apply (cases "l = l'") apply (metis lfin_label_inject) apply (meson lfin_lfdeleteI values_lfin_iff) done subgoal for x - apply (subst tvsubst_simps) - apply (auto 0 0 intro!: cmin_greater) [2] - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) + apply (subst trm.subst) + apply (auto 0 0) [3] apply (auto simp: restrict_def) apply (metis lfin_lfdelete values_lfin_iff) done diff --git a/case_studies/POPLmark/Pattern.thy b/case_studies/POPLmark/Pattern.thy index 9e2ad53a..8f53c55c 100644 --- a/case_studies/POPLmark/Pattern.thy +++ b/case_studies/POPLmark/Pattern.thy @@ -1,5 +1,5 @@ theory Pattern - imports POPLmark_1B + imports SystemFSub begin datatype ('tv::var, PPVars: 'v) prepat = PPVar 'v "'tv typ" | PPRec "(label, ('tv, 'v) prepat) lfset" @@ -232,7 +232,7 @@ lemma PPTVars_vvsubst_prepat[simp]: lemma PPTVars_tvsubst_prepat[simp]: fixes P :: "('tv::var, 'v::var) prepat" - shows "|SSupp_typ \| PPTVars (tvsubst_prepat \ \ P) = (\x \ PPTVars P. FVars_typ (\ x))" + shows "|SSupp TyVar \| PPTVars (tvsubst_prepat \ \ P) = (\x \ PPTVars P. FVars_typ (\ x))" by (induct P) (auto simp: lfset.set_map FVars_tvsubst_typ) lemma nonrep_prepat_vvsubst_prepat: @@ -276,14 +276,14 @@ lemma PTVars_vvsubst_pat: lemma PTVars_tvsubst_pat: fixes P :: "('tv::var, 'v::var) pat" - shows "|SSupp_typ \| bij \ \ PTVars (tvsubst_pat \ \ P) = (\x \ PTVars P. FVars_typ (\ x))" + shows "|SSupp TyVar \| bij \ \ PTVars (tvsubst_pat \ \ P) = (\x \ PTVars P. FVars_typ (\ x))" by transfer auto lemma vvsubst_prepat_tvsubst_prepat: fixes P :: "('tv::var, 'v::var) prepat" shows "|supp \| vvsubst_prepat \ \ P = tvsubst_prepat (TyVar o \) \ P" - by (induct P) (auto simp: vvsubst_typ_tvsubst_typ intro!: lfset.map_cong) + by (induct P) (auto simp: typ.map_is_Sb intro!: lfset.map_cong) lemma vvsubst_pat_tvsubst_pat: fixes P :: "('tv::var, 'v::var) pat" @@ -293,26 +293,26 @@ lemma vvsubst_pat_tvsubst_pat: lemma tvsubst_prepat_comp: fixes P :: "('tv::var, 'v::var) prepat" - shows "|SSupp_typ \| |SSupp_typ \'| + shows "|SSupp TyVar \| |SSupp TyVar \'| tvsubst_prepat \ \ (tvsubst_prepat \' \' P) = tvsubst_prepat (tvsubst_typ \ o \') (\ o \') P" - by (induct P) (auto simp: tvsubst_typ_comp lfset.map_comp intro!: lfset.map_cong) + by (induct P) (auto simp: trans[OF comp_apply[symmetric] typ.Sb_comp[THEN fun_cong]] lfset.map_comp intro!: lfset.map_cong) lemma tvsubst_prepat_cong: fixes P :: "('tv::var, 'v::var) prepat" - shows "|SSupp_typ \| |SSupp_typ \'| + shows "|SSupp TyVar \| |SSupp TyVar \'| (\x \ PPTVars P. \ x = \' x) \ (\x \ PPVars P. \ x = \' x) \ tvsubst_prepat \ \ P = tvsubst_prepat \' \' P" - by (induct P) (auto intro!: lfset.map_cong tvsubst_typ_cong) + by (induct P) (auto intro!: lfset.map_cong typ.Sb_cong) lemma tvsubst_pat_comp: fixes P :: "('tv::var, 'v::var) pat" - shows "|SSupp_typ \| |SSupp_typ \'| bij \ \ bij \' \ + shows "|SSupp TyVar \| |SSupp TyVar \'| bij \ \ bij \' \ tvsubst_pat \ \ (tvsubst_pat \' \' P) = tvsubst_pat (tvsubst_typ \ o \') (\ o \') P" by transfer (auto simp: tvsubst_prepat_comp) lemma tvsubst_pat_cong: fixes P :: "('tv::var, 'v::var) pat" - shows "|SSupp_typ \| |SSupp_typ \'| bij \ \ bij \' \ + shows "|SSupp TyVar \| |SSupp TyVar \'| bij \ \ bij \' \ (\x \ PTVars P. \ x = \' x) \ (\x \ PVars P. \ x = \' x) \ tvsubst_pat \ \ P = tvsubst_pat \' \' P" by transfer (auto simp: tvsubst_prepat_cong) @@ -469,4 +469,35 @@ lemma finite_PVars[simp]: "finite (PVars P)" lemma finite_PTVars[simp]: "finite (PTVars P)" by (auto simp: PTVars_def finite_PPTVars) +pbmv_monad "('tv::var, 'v::var) pat" and "'tv typ" + Sbs: "\\. tvsubst_pat \ id" + Injs: TyVar + Vrs: PTVars + bd: natLeq + apply (rule infinite_regular_card_order_natLeq) + subgoal + apply (rule ext) + apply transfer + apply auto + by (metis (full_types) Abs_pat_inverse bij_betw_id fcomp_comp id_fcomp mem_Collect_eq pat.rel_map(2) supp_id_bound vvsubst_pat.rep_eq + vvsubst_prepat_tvsubst_prepat) + subgoal + using tvsubst_pat_comp by force + apply (rule pat.set_bd)+ + + apply (simp add: PTVars_tvsubst_pat) + apply (simp add: tvsubst_pat_cong) + done + +mrsbnf "('tv::var, 'v::var) pat" and "'tv typ" + subgoal + using vvsubst_pat_tvsubst_pat by blast + subgoal + apply (rule ext) + apply (unfold comp_apply) + apply transfer + by (auto simp: tvsubst_prepat_comp typ.Sb_Inj typ.Sb_comp_Inj vvsubst_prepat_tvsubst_prepat) + subgoal by transfer auto + by (auto simp: typ.map_is_Sb) + end \ No newline at end of file diff --git a/case_studies/POPLmark/SystemFSub.thy b/case_studies/POPLmark/SystemFSub.thy index 8dc1b47b..69b44100 100644 --- a/case_studies/POPLmark/SystemFSub.thy +++ b/case_studies/POPLmark/SystemFSub.thy @@ -247,15 +247,8 @@ declare ty.intros[intro] lemma ty_fresh_extend: "\\<^bold>, x <: U \ S <: T \ x \ dom \ \ FFVars_ctxt \ \ x \ FVars_typ U" by (metis (no_types, lifting) UnE fst_conv snd_conv subsetD wf_ConsE wf_FFVars wf_context) -declare wf_eqvt[unfolded map_context_def, equiv] -declare lfin_equiv[equiv] - -declare closed_in_eqvt[unfolded map_context_def, equiv] -declare in_context_eqvt[unfolded map_context_def, equiv] - -thm equiv -thm equiv_sym -thm equiv_forward +lemmas [equiv] = wf_eqvt[unfolded map_context_def] lfin_equiv + closed_in_eqvt[unfolded map_context_def] in_context_eqvt[unfolded map_context_def] lemma typ_inject: "Forall x T1 T2 = Forall y R1 R2 \ T1 = R1 \ (\f. bij (f::'a::var \ 'a) \ |supp f| id_on (FVars_typ T2 - {x}) f \ f x = y \ permute_typ f T2 = R2)" by (smt (z3) Forall_rrename Swapping.bij_swap Swapping.supp_swap_bound id_on_def id_on_swap infinite_UNIV swap_simps(1) typ.inject(3)) @@ -268,141 +261,21 @@ binder_inductive ty [@{term "permute_typ :: ('a::var \ 'a) \ 'a typ \ 'a typ"}, @{term "(\f x. f x) :: ('a::var \ 'a) \ 'a \ 'a"}] [NONE, NONE, NONE, NONE, SOME [NONE, NONE, NONE, SOME 1, SOME 0, SOME 0], NONE] @{thm prems(3)} @{thm prems(2)} @{thms prems(1)[THEN ty_fresh_extend] id_onD} - @{thms emp_bound insert_bound ID.set_bd typ.Un_bound typ.UN_bound typ.set_bd_UNIV infinite_UNIV} + @{thms emp_bound insert_bound_UNIV ID.set_bd typ.Un_bound typ.UN_bound typ.set_bd_UNIV infinite_UNIV} @{thms typ_inject image_iff} @{thms typ.permute_cong_id context_map_cong_id map_idI} @{thms cong[OF cong[OF cong[OF refl[of R]] refl] refl, THEN iffD1, rotated -1] id_onD} @{context}\) done -lemma VVr_eq_TyVar[simp]: "tvVVr_tvsubst_typ a = TyVar a" - unfolding tvVVr_tvsubst_typ_def comp_def tv\_typ_tvsubst_typ_def TyVar_def - by (rule refl) - -lemma FVars_tvsubst_typ: - assumes "|SSupp_typ (g::'tv \ _)| ((FVars_typ \ g) ` FVars_typ x)" -proof (binder_induction x avoiding: x "IImsupp_typ g" rule: typ.strong_induct) - case Bound - then show ?case unfolding IImsupp_typ_def using infinite_class.Un_bound var_class.UN_bound typ.set_bd_UNIV assms - by (metis type_copy_set_bd) -next - case (Forall x1 x2 x3) - then show ?case apply (auto simp: assms) - using IImsupp_typ_def SSupp_typ_def typ.FVars_VVr apply fastforce - by (metis singletonD typ.FVars_VVr typ.in_IImsupp) -qed (auto simp: lfset.set_map assms) - -lemma SSupp_typ_TyVar_comp: "SSupp_typ (TyVar o \) = supp \" - unfolding SSupp_typ_def supp_def by auto - -lemma IImsupp_typ_TyVar_comp: "IImsupp_typ (TyVar o \) = imsupp \" - unfolding IImsupp_typ_def imsupp_def SSupp_typ_TyVar_comp by auto +lemmas FVars_tvsubst_typ = typ.Vrs_Sb -lemma SSupp_typ_TyVar[simp]: "SSupp_typ TyVar = {}" - unfolding SSupp_typ_def by simp +lemmas [simp] = typ.Vrs_Inj -lemma IImsupp_typ_TyVar[simp]: "IImsupp_typ TyVar = {}" - unfolding IImsupp_typ_def by simp +lemma inj_TyVar[simp, intro!]: "inj TyVar" + by (meson injI typ.inject(1)) -lemma SSupp_typ_fun_upd_le: "SSupp_typ (f(X := T)) \ insert X (SSupp_typ f)" - unfolding SSupp_typ_def by auto - -lemma SSupp_typ_fun_upd_bound[simp]: "|SSupp_typ (f(X := T))| |SSupp_typ f| ::'a\'a)" "|supp \| = tvsubst_typ (TyVar o \)" -proof - fix T - show "permute_typ \ T = tvsubst_typ (TyVar o \) T" - proof (binder_induction T avoiding: "IImsupp_typ (TyVar \ \)" T rule: typ.strong_induct) - case Bound - then show ?case using assms - by (auto simp: IImsupp_typ_def infinite_UNIV intro!: typ.Un_bound typ.UN_bound typ.SSupp_comp_bound) - next - case (Forall X T1 T2) - then show ?case - by (subst typ.subst) - (auto simp: assms infinite_UNIV SSupp_typ_TyVar_comp IImsupp_typ_TyVar_comp - typ_inject id_on_def FVars_tvsubst_typ supp_inv_bound imsupp_def not_in_supp_alt - intro!: exI[of _ id]) - qed (auto simp: assms infinite_UNIV SSupp_typ_TyVar_comp intro: lfset.map_cong) -qed +thm IImsupp_Inj_comp_bound1[of TyVar] -lemma permute_typ_eq_tvsubst_typ_TyVar': -"bij (\::'a::var\'a) \ |supp \| permute_typ \ T = tvsubst_typ (TyVar o \) T" - using permute_typ_eq_tvsubst_typ_TyVar by metis - -lemma IImsupp_typ_bound: - fixes f ::"'a::var \ 'a typ" - assumes "|SSupp_typ f| 'a typ" - assumes "|SSupp_typ f| g) \ SSupp_typ f \ SSupp_typ g" - using assms by (auto simp: SSupp_typ_def) - -lemma IImsupp_typ_tvsubst_typ: - fixes f g ::"'a::var \ 'a typ" - assumes "|SSupp_typ f| g) \ IImsupp_typ f \ IImsupp_typ g" - using assms using SSupp_typ_tvsubst_typ[of f g] - apply (auto simp: IImsupp_typ_def FVars_tvsubst_typ) - by (metis (mono_tags, lifting) SSupp_typ_def Un_iff mem_Collect_eq singletonD sup.orderE typ.FVars_VVr) - -lemma SSupp_typ_tvsubst_typ_bound: - fixes f g ::"'a::var \ 'a typ" - assumes "|SSupp_typ f| g)| 'a typ" - assumes "|SSupp_typ f| 'a typ" - assumes "|SSupp_typ f| x \ FVars_typ T. f x = g x) \ tvsubst_typ f T = tvsubst_typ g T" -proof (binder_induction T avoiding: "IImsupp_typ f" "IImsupp_typ g" T rule: typ.strong_induct) - case (Forall X T U) - then show ?case - apply (subst (1 2) typ.subst; simp add: assms) - by (metis (mono_tags, lifting) DiffI IImsupp_typ_def SSupp_typ_def Un_iff mem_Collect_eq singletonD) -qed (auto simp: assms IImsupp_typ_bound intro: lfset.map_cong) - -lemma vvsubst_typ_tvsubst_typ: - fixes T :: "'tv :: var typ" - assumes "|supp \| T = tvsubst_typ (TyVar o \) T" - by (binder_induction T avoiding: T "imsupp \" rule: typ.strong_induct) - (auto simp: SSupp_typ_TyVar_comp IImsupp_typ_TyVar_comp - assms imsupp_supp_bound infinite_UNIV intro: lfset.map_cong) +lemmas tvsubst_typ_TyVar[simp] = typ.Sb_Inj[THEN fun_cong, unfolded id_apply] lemma finite_FVars_typ[simp]:"finite (FVars_typ T)" by (induct T) auto diff --git a/case_studies/Pi_Calculus/Commitment.thy b/case_studies/Pi_Calculus/Commitment.thy index 81742353..530166e8 100644 --- a/case_studies/Pi_Calculus/Commitment.thy +++ b/case_studies/Pi_Calculus/Commitment.thy @@ -86,7 +86,7 @@ abbreviation "fvars \ fns" lemma bns_bound: "|bns \| ) (auto simp: emp_bound infinite_UNIV) -local_setup \MRBNF_Sugar.register_binder_sugar "Commitment.commit" { +local_setup \Binder_Sugar.register_binder_sugar "Commitment.commit" { ctors = [ (@{term Finp}, @{thm Finp_def}), (@{term Fout}, @{thm Fout_def}), @@ -108,11 +108,15 @@ local_setup \MRBNF_Sugar.register_binder_sugar "Commitment.commit" { SOME @{term "\x P. bns x"} ]], bset_bounds = @{thms bns_bound}, + pset_ctors = [], strong_induct = NONE, inject = @{thms commit.inject}, mrbnf = the (MRBNF_Def.mrbnf_of @{context} "Commitment.commit_pre"), set_simpss = [], - subst_simps = NONE + subst_simps = NONE, + IImsupp_Diffs = NONE, + IImsupp_permute_commutes = NONE, + tvsubst_permute = NONE }\ abbreviation "swapa act x y \ map_action (id(x:=y,y:=x)) act" diff --git a/case_studies/Pi_Calculus/Pi_Transition_Early.thy b/case_studies/Pi_Calculus/Pi_Transition_Early.thy index fba75717..6ad3969f 100644 --- a/case_studies/Pi_Calculus/Pi_Transition_Early.thy +++ b/case_studies/Pi_Calculus/Pi_Transition_Early.thy @@ -25,7 +25,7 @@ binder_inductive (verbose) trans SOME [SOME 0, NONE, SOME 1, SOME 0, SOME 1], SOME [NONE, SOME 2, SOME 0, SOME 0]] @{thm prems(3)} @{thm prems(2)} @{thms } - @{thms emp_bound singl_bound insert_bound card_of_minus_bound term.Un_bound term.set_bd_UNIV commit.FVars_bd_UNIVs infinite_UNIV bns_bound} + @{thms emp_bound singl_bound insert_bound_UNIV card_of_minus_bound term.Un_bound term.set_bd_UNIV commit.FVars_bd_UNIVs infinite_UNIV bns_bound} @{thms bij_implies_inject Res_inject Inp_inject Bout_inject FVars_commit_Cmt ns_alt vars_alt Int_Un_distrib} @{thms Inp_eq_usub term.permute_cong_id term.permute_cong_id[symmetric] arg_cong2[where f=Cmt, OF _ refl] arg_cong2[where f=Cmt, OF refl] action.map_ident_strong cong[OF arg_cong2[OF _ refl] refl, of _ _ Bout] Cmt_rrename_bound_action Cmt_rrename_bound_action_Par} diff --git a/case_studies/Pi_Calculus/Pi_Transition_Late.thy b/case_studies/Pi_Calculus/Pi_Transition_Late.thy index 9fa152e0..f7436fce 100644 --- a/case_studies/Pi_Calculus/Pi_Transition_Late.thy +++ b/case_studies/Pi_Calculus/Pi_Transition_Late.thy @@ -25,7 +25,7 @@ binder_inductive trans SOME [SOME 0, NONE, SOME 1, SOME 0, SOME 1], SOME [NONE, SOME 2, SOME 0, SOME 0]] @{thm prems(3)} @{thm prems(2)} @{thms } - @{thms emp_bound singl_bound insert_bound card_of_minus_bound term.Un_bound term.FVars_bd_UNIVs commit.FVars_bd_UNIVs infinite_UNIV bns_bound} + @{thms emp_bound singl_bound insert_bound_UNIV card_of_minus_bound term.Un_bound term.FVars_bd_UNIVs commit.FVars_bd_UNIVs infinite_UNIV bns_bound} @{thms bij_implies_inject Res_inject Inp_inject Bout_inject Binp_inject FVars_commit_Cmt ns_alt vars_alt Int_Un_distrib} @{thms Inp_eq_usub term.permute_cong term.permute_cong_id term.permute_cong_id[symmetric] arg_cong2[where f=Cmt, OF _ refl] arg_cong2[where f=Cmt, OF refl] action.map_ident_strong cong[OF arg_cong2[OF _ refl] refl, of _ _ Bout] Cmt_rrename_bound_action Cmt_rrename_bound_action_Par} @@ -37,4 +37,4 @@ binder_inductive trans done print_theorems -end \ No newline at end of file +end diff --git a/case_studies/STLC/STLC.thy b/case_studies/STLC/STLC.thy index 801a0a03..321cb655 100644 --- a/case_studies/STLC/STLC.thy +++ b/case_studies/STLC/STLC.thy @@ -16,60 +16,6 @@ for print_theorems -(* unary substitution *) -lemma IImsupp_terms_VVr_empty: "IImsupp_terms tvVVr_tvsubst = {}" - unfolding IImsupp_terms_def terms.SSupp_VVr_empty UN_empty Un_empty_left - apply (rule refl) - done - -lemma tvsubst_VVr_func: "tvsubst tvVVr_tvsubst t = t" - apply (rule terms.TT_fresh_induct) - apply (rule emp_bound) - subgoal for x - apply (rule case_split[of "tvisVVr_tvsubst (terms_ctor x)"]) - apply (unfold tvisVVr_tvsubst_def)[1] - apply (erule exE) - subgoal premises prems for a - unfolding prems - apply (rule terms.tvsubst_VVr) - apply (rule terms.SSupp_VVr_bound) - done - apply (rule trans) - apply (rule terms.tvsubst_cctor_not_isVVr) - apply (rule terms.SSupp_VVr_bound) - unfolding IImsupp_terms_VVr_empty - apply (rule Int_empty_right) - apply assumption+ - apply (rule arg_cong[of _ _ terms_ctor]) - apply (rule trans) - apply (rule terms_pre.map_cong) - apply (rule supp_id_bound bij_id)+ - apply (assumption | rule refl)+ - unfolding id_def[symmetric] terms_pre.map_id - apply (rule refl) - done - done - -lemma finite_singleton: "finite {x}" by blast -lemma singl_bound: "|{a}| 'a terms" - shows "|SSupp_terms (f (a:=t))| |SSupp_terms f| A \ id_on (B - A) f" - unfolding supp_def id_on_def by blast - lemma Abs_inject: "(Abs x \ e = Abs x' \' e') = (\f. bij f \ |supp (f::'a::var \ 'a)| id_on (FVars_terms (Abs x \ e)) f \ f x = x' \ \ = \' \ permute_terms f e = e')" unfolding terms.set @@ -165,10 +111,6 @@ lemma Abs_avoid: "|A::'a::var set| \ apply assumption done -lemma VVr_eq_Var: "tvVVr_tvsubst a = Var a" - unfolding tvVVr_tvsubst_def Var_def comp_def tv\_terms_tvsubst_def - by (rule refl) - (* small step semantics *) no_notation Set.member ("(_/ : _)" [51, 51] 50) @@ -182,7 +124,7 @@ abbreviation extend :: "('a * \) fset \ 'a::var \ \ "extend \ a \ \ finsert (a, \) \" inductive Step :: "'a::var terms \ 'a terms \ bool" (infixr "\<^bold>\" 25) where - ST_Beta: "App (Abs x \ e) e2 \<^bold>\ tvsubst (tvVVr_tvsubst(x:=e2)) e" + ST_Beta: "App (Abs x \ e) e2 \<^bold>\ tvsubst (Var(x:=e2)) e" | ST_App: "e1 \<^bold>\ e1' \ App e1 e2 \<^bold>\ App e1' e2" inductive Ty :: "('a::var * \) fset \ 'a terms \ \ \ bool" ("_ \\<^sub>t\<^sub>y _ : _" [25, 25, 25] 26) where @@ -331,7 +273,8 @@ shows "P" apply (rule cinfinite_imp_infinite[OF terms_pre.UNIV_cinfinite]) apply (rule terms.set_bd_UNIV) apply assumption - apply (rule singl_bound) + apply (rule insert_bound[THEN iffD2]) + apply (rule emp_bound) apply (rule iffD2[OF disjoint_single]) apply (rule assms(2)) apply (rule terms_pre.UN_bound) @@ -450,38 +393,42 @@ next ultimately show ?case using Ty_Abs by (auto intro: Ty.Ty_Abs) qed -lemma substitution: "\ \,x:\' \\<^sub>t\<^sub>y e : \ ; x \ \ ; {||} \\<^sub>t\<^sub>y v : \' \ \ \ \\<^sub>t\<^sub>y tvsubst (tvVVr_tvsubst(x:=v)) e : \" +lemma substitution: "\ \,x:\' \\<^sub>t\<^sub>y e : \ ; x \ \ ; {||} \\<^sub>t\<^sub>y v : \' \ \ \ \\<^sub>t\<^sub>y tvsubst (Var(x:=v)) e : \" proof (binder_induction e arbitrary: \ \ avoiding: \ x v rule: terms.strong_induct) case (Var a \ \) then have 2: "(a, \) |\| \,x:\'" by blast from \{||} \\<^sub>t\<^sub>y v : \'\ have 3: "\ \\<^sub>t\<^sub>y v : \'" using context_invariance by blast - then show ?case unfolding terms.subst[OF SSupp_upd_VVr_bound] unfolding fun_upd_def + then show ?case unfolding fun_upd_def apply (subst terms.subst) + apply (smt (verit, ccfv_threshold) Field_card_of Prelim.insert_bound SSupp_def UNIV_cinfinite card_of_card_order_on + card_of_subset_bound emp_bound insert_iff mem_Collect_eq subsetI) proof (cases "a = x") case True then have "\ = \'" using 2 Var(1) unfolding fresh_def by (metis Var(2) Pair_inject finsertE fresh_def fst_eqD rev_fimage_eqI) - then show "\ \\<^sub>t\<^sub>y (if a = x then v else tvVVr_tvsubst a) : \" using True 3 by simp + then show "\ \\<^sub>t\<^sub>y (if a = x then v else Var a) : \" using True 3 by simp next case False then have "(a, \) |\| \" using 2 by blast - then show "\ \\<^sub>t\<^sub>y (if a = x then v else tvVVr_tvsubst a) : \" unfolding VVr_eq_Var using False Ty.Ty_Var by auto + then show "\ \\<^sub>t\<^sub>y (if a = x then v else Var a) : \" using False Ty.Ty_Var by auto qed next case (App e1 e2 \ \) from App(3) obtain \\<^sub>1 where "\,x:\' \\<^sub>t\<^sub>y e1 : \\<^sub>1 \ \" "\,x:\' \\<^sub>t\<^sub>y e2 : \\<^sub>1" by blast - then have "\ \\<^sub>t\<^sub>y tvsubst (tvVVr_tvsubst(x := v)) e1 : \\<^sub>1 \ \" "\ \\<^sub>t\<^sub>y tvsubst (tvVVr_tvsubst(x := v)) e2 : \\<^sub>1" using App by blast+ - then have "\ \\<^sub>t\<^sub>y App (tvsubst (tvVVr_tvsubst(x := v)) e1) (tvsubst (tvVVr_tvsubst(x := v)) e2) : \" using Ty_App by blast - then show ?case unfolding terms.subst(2)[OF SSupp_upd_VVr_bound, symmetric] . + then have "\ \\<^sub>t\<^sub>y tvsubst (Var(x := v)) e1 : \\<^sub>1 \ \" "\ \\<^sub>t\<^sub>y tvsubst (Var(x := v)) e2 : \\<^sub>1" using App by blast+ + then have "\ \\<^sub>t\<^sub>y App (tvsubst (Var(x := v)) e1) (tvsubst (Var(x := v)) e2) : \" using Ty_App by blast + then show ?case by auto next case (Abs y \\<^sub>1 e \ \) - then have 1: "y \ IImsupp_terms (tvVVr_tvsubst(x:=v))" by (simp add: IImsupp_terms_def SSupp_terms_def) + then have 1: "y \ IImsupp Var FVars_terms (Var(x:=v))" by (simp add: IImsupp_def SSupp_def) have "y \ fst ` fset (\,x:\')" using Abs(1,2) unfolding fresh_def by auto then obtain \\<^sub>2 where 2: "(\,x:\'),y:\\<^sub>1 \\<^sub>t\<^sub>y e : \\<^sub>2" "\ = (\\<^sub>1 \ \\<^sub>2)" using Abs(5) Ty_AbsE' by metis moreover have "(\,x:\'),y:\\<^sub>1 = (\,y:\\<^sub>1),x:\'" by blast moreover have "x \ \,y:\\<^sub>1" using Abs(1,2,6) unfolding fresh_def by auto - ultimately have "\,y:\\<^sub>1 \\<^sub>t\<^sub>y tvsubst (tvVVr_tvsubst(x := v)) e : \\<^sub>2" using Abs(4,7) by metis + ultimately have "\,y:\\<^sub>1 \\<^sub>t\<^sub>y tvsubst (Var(x := v)) e : \\<^sub>2" using Abs(4,7) by metis moreover have "y \ \" using Abs(1) unfolding fresh_def by auto - ultimately show ?case unfolding terms.subst(3)[OF SSupp_upd_VVr_bound 1] using Ty_Abs 2(2) by blast + ultimately show ?case + by (smt (verit, del_insts) "1" "2"(2) Abs.fresh(2) SSupp_def SSupp_fun_upd_Inj_bound Ty_Abs fun_upd_def mem_Collect_eq + terms.subst(3)) qed theorem progress: "{||} \\<^sub>t\<^sub>y e : \ \ (\x \ e'. e = Abs x \ e') \ (\e'. e \<^bold>\ e')" @@ -500,7 +447,7 @@ proof (induction "{||} :: ('a::var * \) fset" e \ arbitrary: e' rule: have "{||} \\<^sub>t\<^sub>y Abs x \\<^sub>1 e : \\<^sub>1 \ \\<^sub>2" using Ty_App ST_Beta by (metis Ty_AbsE' \.inject all_not_fin_conv bot_fset.rep_eq image_is_empty terms.inject(2)) then have "{||},x:\\<^sub>1 \\<^sub>t\<^sub>y e : \\<^sub>2" by (auto elim: Ty_AbsE') - then have "{||} \\<^sub>t\<^sub>y tvsubst (tvVVr_tvsubst(x := e2')) e : \\<^sub>2" using substitution ST_Beta(1) Ty_App(3) unfolding fresh_def by fastforce + then have "{||} \\<^sub>t\<^sub>y tvsubst (Var(x := e2')) e : \\<^sub>2" using substitution ST_Beta(1) Ty_App(3) unfolding fresh_def by fastforce then show ?thesis using ST_Beta by simp next case (ST_App e e1' e2') diff --git a/case_studies/Untyped_Lambda_Calculus/LC.thy b/case_studies/Untyped_Lambda_Calculus/LC.thy index 38cf7ff6..b44915ae 100644 --- a/case_studies/Untyped_Lambda_Calculus/LC.thy +++ b/case_studies/Untyped_Lambda_Calculus/LC.thy @@ -10,7 +10,7 @@ begin (* DATATYPE DECLARTION *) declare [[mrbnf_internals]] -binder_datatype 'a "term" = +binder_datatype (FFVars: 'a) "term" = Var 'a | App "'a term" "'a term" | Lam x::'a t::"'a term" binds x in t @@ -31,15 +31,13 @@ apply standard type_synonym trm = "var term" (* Some lighter notations: *) -abbreviation "VVr \ tvVVr_tvsubst" -lemmas VVr_def = tvVVr_tvsubst_def -abbreviation "isVVr \ tvisVVr_tvsubst" -lemmas isVVr_def = tvisVVr_tvsubst_def -abbreviation "IImsupp \ IImsupp_term" -lemmas IImsupp_def = IImsupp_term_def -abbreviation "SSupp \ SSupp_term" -lemmas SSupp_def = SSupp_term_def -abbreviation "FFVars \ FVars_term" +abbreviation "IImsupp' \ IImsupp" +abbreviation "SSupp' \ SSupp" +hide_const IImsupp SSupp + +abbreviation "SSupp \ SSupp' Var" +abbreviation "IImsupp f \ SSupp f \ IImsupp' Var FFVars f" +lemmas IImsupp_def = SSupp_def IImsupp_def abbreviation "rrename \ permute_term" (* *) @@ -48,18 +46,16 @@ lemma FFVars_tvsubst[simp]: assumes "|SSupp (\ :: var \ trm)| t) = (\ {FFVars (\ x) | x . x \ FFVars t})" apply (binder_induction t avoiding: "IImsupp \" rule: term.strong_induct) - apply (auto simp: IImsupp_def assms intro!: term.Un_bound UN_bound term.set_bd_UNIV) - using term.FVars_VVr apply (fastforce simp add: SSupp_def) - using term.FVars_VVr apply (auto simp add: SSupp_def) - by (smt (verit) singletonD term.FVars_VVr) + apply (auto simp: IImsupp_def assms[unfolded SSupp_def] intro!: term.Un_bound UN_bound term.set_bd_UNIV) + apply (fastforce simp add: SSupp_def) + by (metis empty_iff insert_iff term.set(1)) lemma fsupp_le[simp]: "fsupp (\::var\var) \ |supp \| _term_tvsubst_def - by (rule refl) - (* *) (* Properties of term-for-variable substitution *) -lemma tvsubst_VVr_func[simp]: "tvsubst VVr t = t" - apply (rule term.TT_fresh_induct) - apply (rule emp_bound) - subgoal for x - apply (rule case_split[of "isVVr (term_ctor x)"]) - apply (unfold isVVr_def)[1] - apply (erule exE) - subgoal premises prems for a - unfolding prems - apply (rule term.tvsubst_VVr) - apply (rule term.SSupp_VVr_bound) - done - apply (rule trans) - apply (rule term.tvsubst_cctor_not_isVVr) - apply (rule term.SSupp_VVr_bound) - unfolding IImsupp_VVr_empty - apply (rule Int_empty_right) - unfolding noclash_term_def Int_Un_distrib Un_empty - apply assumption+ - apply (rule arg_cong[of _ _ term_ctor]) - apply (rule trans) - apply (rule term_pre.map_cong) - apply (rule supp_id_bound bij_id)+ - apply (assumption | rule refl)+ - unfolding id_def[symmetric] term_pre.map_id - apply (rule refl) - done - done +lemmas tvsubst_VVr_func[simp] = term.Sb_Inj[THEN fun_cong, unfolded id_apply] lemmas term.inject(3)[simp del] -lemma tvsubst_cong: -assumes f: "|SSupp f| z. (z::var) \ FFVars P \ f z = g z)" -shows "tvsubst f P = tvsubst g P" -proof- - have fg: "|IImsupp f| IImsupp g| |supp (f::var \ var)| bij (map_term_pre (id::var \var) f (rrename f) id)" apply (rule iffD2[OF bij_iff]) @@ -224,7 +164,7 @@ lemma Lam_avoid: "|A::var set| \x' lemma Lam_rrename: "bij (\::var\var) \ |supp \| - (\a'. a' \FVars_term e - {a::var} \ \ a' = a') \ Lam a e = Lam (\ a) (rrename \ e)" + (\a'. a' \FFVars e - {a::var} \ \ a' = a') \ Lam a e = Lam (\ a) (rrename \ e)" by (metis term.permute(3) term.permute_cong_id term.set(3)) @@ -238,16 +178,13 @@ lemma SSupp_upd_bound: elim!: ordLeq_ordLess_trans[OF card_of_mono1 ordLess_ordLeq_trans[OF term_pre.Un_bound], rotated, of _ "{a}"] intro: card_of_mono1) -corollary SSupp_upd_VVr_bound[simp,intro!]: "|SSupp (VVr(a:=(t::trm)))| xx)| | |IImsupp \| | | ::var\trm) o \)| | | ::var\trm) o \)| | | FFVars e \ {x}" -unfolding LC.IImsupp_def LC.SSupp_def by auto + unfolding IImsupp_def by auto -lemma IImsupp_Var': "y \ x \ y \ FFVars e \ y \ IImsupp (Var(x := e))" +lemma IImsupp_Var': "y \ x \ y \ FFVars e \ y \ IImsupp' Var FFVars (Var(x := e))" + "y \ x \ y \ FFVars e \ y \ SSupp (Var(x := e))" using IImsupp_Var by auto lemma IImsupp_rrename_su: @@ -310,8 +243,7 @@ by (metis SSupp_IImsupp_bound finite_Un finite_iff_le_card_var finite_subset ims lemma SSupp_rrename_bound: assumes s: "bij (\::var\var)" "|supp \| | ::var\var) o \)| ::var\var)" "|supp \| | (x::var) := rrename \ e))| ::var\var)" "|supp \| \ Var(x := e)) \ - imsupp \ \ {x} \ FVars_term e" + imsupp \ \ {x} \ FFVars e" unfolding IImsupp_def SSupp_def imsupp_def supp_def by (auto split: if_splits) lemma IImsupp_rrename_update_bound: @@ -339,7 +271,7 @@ lemma SSupp_rrename_update_bound: assumes s[simp]: "bij (\::var\var)" "|supp \| \ Var(x := e))| ::var\var)" "|supp \| = tvsubst (Var o \)" -proof - fix t - show "rrename \ t = tvsubst (Var o \) t" - proof (binder_induction t avoiding: "IImsupp (Var \ \)" rule: term.strong_induct) - case Bound - then show ?case using assms SSupp_IImsupp_bound by (metis supp_SSupp_Var_le) - next - case (Lam x1 x2) - then show ?case by (simp add: assms IImsupp_def disjoint_iff not_in_supp_alt) - qed (auto simp: assms) -qed + using term.vvsubst_permute term.map_is_Sb assms by metis lemma rrename_eq_tvsubst_Var': "bij (\::var\var) \ |supp \| rrename \ e = tvsubst (Var o \) e" @@ -419,7 +341,7 @@ proof- note SSupp_rrename_update_bound[OF assms, unfolded comp_def, simplified, simp] note SSupp_update_rrename_bound[unfolded fun_upd_def, simplified, simp] show ?thesis - apply(induct e1 rule: term.fresh_induct[where A = "{x} \ FVars_term e2 \ imsupp \"]) + apply(induct e1 rule: term.fresh_induct[where A = "{x} \ FFVars e2 \ imsupp \"]) subgoal by (meson Un_bound imsupp_supp_bound infinite_var s(2) singl_bound term.set_bd_UNIV) subgoal by (auto simp: bij_implies_inject) subgoal by simp @@ -434,10 +356,10 @@ lemma tvsubst_inv: assumes "bij (\::var\var)" "|supp \| \ (Var(x := e2)) \ inv \) (rrename \ e1) = tvsubst (rrename \ \ (Var(x := e2))) e1" proof - - have 1: "|SSupp_term (rrename \ \ (Var(x := e2)))| \ (Var(x := e2)) \ inv \)| \ (Var(x := e2)))| \ (Var(x := e2)) \ inv \)| " x e2 e1 rule: term.strong_induct) case Bound @@ -445,12 +367,12 @@ proof - next case (Lam x1 x2) then show ?case apply auto - by (metis (mono_tags, lifting) IImsupp_Var' SSupp_update_rrename_bound bij_not_equal_iff not_imageI term.FVars_permute term.IImsupp_natural term.subst(3)) + by (metis (no_types, opaque_lifting) comp_apply fun_upd_apply inv_simp1 inv_simp2 rrename_eq_tvsubst_Var supp_SSupp_Var_le term.subst(1)) qed auto qed lemmas [equiv] = - term.tvsubst_permutes[THEN fun_cong, unfolded comp_def] + term.tvsubst_permute[THEN fun_cong, unfolded comp_def] tvsubst_rrename_comp[unfolded comp_def] tvsubst_inv[unfolded comp_def] @@ -462,11 +384,11 @@ lemma permute_fun_upd[equiv]: (* Unary substitution versus swapping: *) lemma tvsubst_refresh: -assumes xx: "xx \ FVars_term e1 - {x}" +assumes xx: "xx \ FFVars e1 - {x}" shows "tvsubst (Var((x::var) := e2)) e1 = tvsubst (Var(xx := e2)) (rrename (x \ xx) e1)" proof- show ?thesis using xx - apply(induct e1 rule: term.fresh_induct[where A = "{x,xx} \ FVars_term e2"]) + apply(induct e1 rule: term.fresh_induct[where A = "{x,xx} \ FFVars e2"]) subgoal by (metis insert_is_Un term.set(1) term.set(2) term.set_bd_UNIV) subgoal by simp subgoal by auto @@ -611,46 +533,6 @@ apply(rule term.permute_cong) apply (auto simp: term_pre.supp_comp_bound) by (simp add: swap_def) - -(* *) - -(*term "swappingFvars sswap FFVars" -term "permutFvars (\f t. rrename t f) FFVars" - -lemma swappingFvars_swap_FFVars: "swappingFvars sswap FFVars" - unfolding swappingFvars_def apply auto - apply (metis Swapping.bij_swap inv_o_simp1 rrename_o_swap swap_inv term.permute_id) - apply (metis Swapping_vs_Permutation.sw_def swap_def) - by (metis Swapping_vs_Permutation.sw_def imageI swap_def) - -lemma nswapping_swap: "nswapping sswap" - unfolding nswapping_def apply auto - apply (metis Swapping.bij_swap id_apply inv_o_simp1 rrename_o_swap swap_inv term.permute_id0) - apply (auto simp: term.permute_comp) - sledgehammer -by (metis id_swapTwice2 rrename_o_swap) - -lemma permutFvars_rrename_FFVar: "permutFvars (\t f. rrename f (t::trm)) FFVars" -unfolding permutFvars_def apply auto - apply (simp add: finite_iff_le_card_var fsupp_def supp_def term.permute_comp) - apply (simp add: finite_iff_le_card_var fsupp_def supp_def) - apply (simp add: finite_iff_le_card_var fsupp_def image_in_bij_eq supp_def) . - -lemma permut_rrename: "permut (\t f. rrename f (t::trm))" -unfolding permut_def apply auto -by (simp add: finite_iff_le_card_var fsupp_def supp_def term.permute_comp) - -lemma toSwp_rrename: "toSwp (\t f. rrename f t) = swap" -by (meson toSwp_def) - -lemma fsupp_supp: "fsupp f \ |supp f| |supp f| toPerm swap t f = rrename f t" -apply(subst toSwp_rrename[symmetric]) -by (simp add: fsupp_supp permut_rrename toPerm_toSwp) -*) - (* *) (* Substitution from a sequence (here, a list) *) @@ -1177,7 +1059,7 @@ using assms by auto . end (* context LC_Rec *) lemma Lam_inject: "(Lam x e = Lam x' e') = (\f. bij f \ |supp (f::var \ var)| id_on (FVars_term (Lam x e)) f \ f x = x' \ rrename f e = e')" + \ id_on (FFVars (Lam x e)) f \ f x = x' \ rrename f e = e')" by (metis Lam_inject_strong id_on_def term.permute(3) term.permute_cong_id) end diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index cc619f93..91c06447 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -1,15 +1,798 @@ theory BMV_Composition imports "Binders.MRBNF_Recursor" + keywords "print_pbmv_monads" :: diag and + "pbmv_monad" :: thy_goal begin -binder_datatype 'a type = Var 'a | App "'a type" "'a type list" | Forall x::'a t::"'a type" binds x in t +(* live, free, free, live, live, dead, free *) +typedecl ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1 +(* dead, free, dead, free *) +typedecl ('a, 'b, 'c, 'd) T2 +(* free, free, free, live, dead, live *) +typedecl ('a, 'b, 'c, 'd, 'e, 'f) T3 +(* free, free *) +typedecl ('a, 'b) T4 -abbreviation "bd_type \ natLeq" +consts Sb_T1 :: "('b::var \ 'b) \ ('c::var \ ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1) \ ('g::var \ ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1) \ ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1 \ ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" +consts Map_T1 :: "('a \ 'a') \ ('d \ 'd') \ ('e \ 'e') \ ('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ ('a', 'b, 'c, 'd', 'e', 'f, 'g) T1" +consts set_1_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 'a set" +consts set_2_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 'd set" +consts set_3_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 'e set" +consts Vrs_1_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 'b set" +consts Vrs_2_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 'c set" +consts Vrs_3_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 'g set" +consts Inj_1_T1 :: "'c \ ('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1" +consts Inj_2_T1 :: "'g \ ('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1" -abbreviation "sb_type \ tvsubst_type" +consts Sb_T2 :: "('d::var \ 'd) \ ('b::var \ ('a::var, 'b, 'c, 'd) T2) \ ('a, 'b, 'c, 'd) T2 \ ('a, 'b, 'c, 'd) T2" +consts Vrs_1_T2 :: "('a::var, 'b::var, 'c, 'd::var) T2 \ 'd set" +consts Vrs_2_T2 :: "('a::var, 'b::var, 'c, 'd::var) T2 \ 'b set" +consts Inj_T2 :: "'b \ ('a::var, 'b::var, 'c, 'd::var) T2" +consts Sb_T3 :: "('a::var \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3) \ ('a::var \ ('a::var, 'c::var) T4) \ ('b::var \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3) \ ('c::var \ ('a, 'c) T4) \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3" +consts Map_T3 :: "('d \ 'd') \ ('f \ 'f') \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ ('a, 'b, 'c, 'd', 'e, 'f') T3" +consts set_1_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'd set" +consts set_2_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'e set" +consts set_3_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'f set" +consts Vrs_1_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'a set" +consts Vrs_2_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'a set" +consts Vrs_3_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'b set" +consts Vrs_4_T3 :: "('a::var, 'b, 'c::var, 'd, 'e, 'f) T3 \ 'c set" +consts Inj_1_T3 :: "'a \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3" +consts Inj_2_T3 :: "'b \ ('a::var, 'b, 'c::var, 'd, 'e, 'f) T3" -(* Comp *) -type_synonym 'a T = "'a + 'a type" +consts Sb_T4 :: "('a::var \ ('a, 'b) T4) \ ('b::var \ ('a, 'b) T4) \ ('a, 'b) T4 \ ('a, 'b) T4" +consts Vrs_1_T4 :: "('a::var, 'b::var) T4 \ 'a set" +consts Vrs_2_T4 :: "('a::var, 'b::var) T4 \ 'b set" +consts Inj_1_T4 :: "'a \ ('a::var, 'b::var) T4" +consts Inj_2_T4 :: "'b \ ('a::var, 'b::var) T4" -end \ No newline at end of file +ML_file \../Tools/bmv_monad_def.ML\ + +declare [[goals_limit=1000]] +declare [[ML_print_depth=1000]] + +pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" + Sbs: Sb_T1 + RVrs: Vrs_1_T1 + Injs: Inj_1_T1 Inj_2_T1 + Vrs: Vrs_2_T1 Vrs_3_T1 + Maps: Map_T1 + Supps: set_1_T1 set_2_T1 set_3_T1 + bd: natLeq + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done +print_theorems + +pbmv_monad "('a::var, 'b, 'c, 'd) T2" + Sbs: Sb_T2 + RVrs: Vrs_1_T2 + Injs: Inj_T2 + Vrs: Vrs_2_T2 + bd: natLeq + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" + Sbs: Sb_T3 and Sb_T4 + Injs: Inj_1_T3 Inj_1_T4 Inj_2_T3 Inj_2_T4 and Inj_1_T4 Inj_2_T4 + Vrs: Vrs_1_T3 Vrs_2_T3 Vrs_3_T3 Vrs_4_T3 and Vrs_1_T4 Vrs_2_T4 + Maps: Map_T3 + Supps: set_1_T3 set_3_T3 + bd: natLeq + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done +print_theorems +print_pbmv_monads + +type_synonym ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T = + "(('a, 'b, 'e, 'd) T2, 'b, 'c, 'f set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1" + +(* +deads: 'a, 'e, 'f, 'g +frees: 'b, 'c, 'd +lives: 'h +*) + +ML \ +val T1 = the (BMV_Monad_Def.pbmv_monad_of @{context} @{type_name T1}); +val T2 = the (BMV_Monad_Def.pbmv_monad_of @{context} @{type_name T2}); +val T3 = the (BMV_Monad_Def.pbmv_monad_of @{context} @{type_name T3}); +\ + +(* Demoting T3 *) +pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" + Sbs: "\f1 \1 \2 \3 \4. Sb_T3 \1 \2 \3 \4 \ Map_T3 f1 id" and Sb_T4 + RVrs: set_1_T3 + Injs: Inj_1_T3 Inj_1_T4 Inj_2_T3 Inj_2_T4 and Inj_1_T4 Inj_2_T4 + Vrs: Vrs_1_T3 Vrs_2_T3 Vrs_3_T3 Vrs_4_T3 and Vrs_1_T4 Vrs_2_T4 + Maps: "Map_T3 id" + Supps: set_3_T3 + bd: natLeq + apply (rule infinite_regular_card_order_natLeq) + apply (unfold T3.Sb_Inj T3.Map_id id_o) + apply (rule refl) + apply (unfold comp_assoc T3.Map_Inj) + + apply (rule T3.Sb_comp_Inj) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (rule T3.Sb_comp_Inj) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule trans[OF comp_assoc[symmetric]]) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (rule T3.Map_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (rule trans) + apply (unfold comp_assoc)[1] + apply (rule trans[OF comp_assoc[symmetric]]) + apply (rule arg_cong2[of _ _ _ _ "(\)"]) + apply (rule T3.Sb_comp) + apply (assumption | rule T3.SSupp_Map_bound T3.IImsupp_Map_bound SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (rule T3.Map_comp) + apply (unfold id_o T3.Map_Inj) + apply (rule refl) + + apply (rule T3.Supp_bd T3.Vrs_bd T3.Vrs_Inj T3.Supp_Inj)+ + + subgoal for f \1 \2 \3 x + apply (unfold comp_def) + apply (subst T3.Supp_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T3.Vrs_Map T3.Supp_Map T3.Supp_Inj UN_empty2 Un_empty_left Un_empty_right Un_assoc) + apply (rule refl) + done + subgoal for f \1 \2 \3 x + apply (unfold comp_def) + apply (rule trans) + apply (rule T3.Vrs_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) + apply (rule refl) + done + + subgoal for f \1 \2 \3 x + apply (unfold comp_def) + apply (rule trans) + apply (rule T3.Vrs_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) + apply (rule refl) + done + + subgoal for f \1 \2 \3 x + apply (unfold comp_def) + apply (rule trans) + apply (rule T3.Vrs_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) + apply (rule refl) + done + + subgoal for f \1 \2 \3 x + apply (unfold comp_def) + apply (rule trans) + apply (rule T3.Vrs_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) + apply (rule refl) + done + + subgoal for f \1 \2 \3 g \'1 \'2 \'3 x + apply (rule comp_apply_eq) + apply (rule cong'[OF _ T3.Map_cong, rotated]) + apply (assumption | rule refl)+ + apply (rule T3.Sb_cong) + apply (unfold T3.Vrs_Map) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound refl)+ + done + apply (rule refl) + apply (rule trans) + apply (rule T3.Map_comp) + apply (unfold id_o) + apply (rule refl) + apply (rule T3.Supp_Map) + apply (rule T3.Supp_bd) + apply (rule T3.Map_cong) + apply (rule refl) + apply assumption + + subgoal for f fa \1 \2 \3 + apply (rule trans) + apply (rule trans[OF comp_assoc[symmetric]]) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (rule T3.Map_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T3.Map_Inj comp_assoc) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule trans) + apply (rule T3.Map_comp) + apply (rule sym) + apply (rule trans) + apply (rule T3.Map_comp) + apply (unfold id_o o_id) + apply (rule refl) + done + + apply (unfold comp_def)[1] + apply (subst T3.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+) + apply (unfold T3.Supp_Map image_id T3.Vrs_Map T3.Supp_Inj UN_empty2 Un_empty_left Un_empty_right) + apply (rule refl)+ + apply (rule T3.Sb_comp_Inj; assumption)+ + apply (rule T3.Sb_comp; assumption) + apply (rule T3.Vrs_bd T3.Vrs_Inj)+ + apply (rule T3.Vrs_Sb; assumption)+ + apply (rule T3.Sb_cong; assumption) + done +print_theorems +print_pbmv_monads + +(* Same demotion, but automated *) +local_setup \fn lthy => +let + open BMV_Monad_Def + val ((bmv, _), lthy) = demote_bmv_monad BNF_Def.Smart_Inline + (K BNF_Def.Note_Some) (Binding.prefix_name "demote") (SOME @{binding T3''}) + T3 + { frees = [false, false, false], lives = [Free_Var, Live_Var] } + lthy + val lthy = register_pbmv_monad "BMV_Composition.T3''" bmv lthy +in lthy end +\ +print_theorems + +abbreviation "Vrs_1_T \ Vrs_2_T1" +abbreviation "Vrs_2_T \ \x. \ (Vrs_2_T2 ` set_1_T1 x)" +abbreviation "Vrs_3_T \ \x. \ (Vrs_1_T3 ` set_3_T1 x)" + +pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3': "('b, 'a, 'c, 'd, 'e, 'h) T3" + Sbs: "\h1 h2 \1 \2 \3 \4 \5 \6 \7. Sb_T1 h1 \1 \2 \ Map_T1 (Sb_T2 h2 \3) id (Sb_T3 \4 \5 \6 \7 \ Map_T3 h2 id)" + RVrs: Vrs_1_T1 "\x. \ (Vrs_1_T2 ` set_1_T1 x) \ \ (set_1_T3 ` set_3_T1 x)" + Injs: Inj_1_T1 Inj_2_T1 Inj_T2 Inj_1_T3 Inj_1_T4 Inj_2_T3 Inj_2_T4 + Vrs: Vrs_2_T1 Vrs_3_T1 "\x. \ (Vrs_2_T2 ` set_1_T1 x)" "\x. \ (Vrs_1_T3 ` set_3_T1 x)" "\x. \ (Vrs_2_T3 ` set_3_T1 x)" "\x. \ (Vrs_3_T3 ` set_3_T1 x)" "\x. \ (Vrs_4_T3 ` set_3_T1 x)" + Maps: "\f. Map_T1 id id (Map_T3 id f)" + Supps: "\x. \ (set_3_T3 ` set_3_T1 x)" + bd: natLeq + apply (rule infinite_regular_card_order_natLeq) + subgoal + apply (unfold id_o T1.Sb_Inj T1.Map_id T2.Sb_Inj T3.Sb_Inj T3.Map_id) + apply (rule refl) + done + subgoal for f1 f2 \1 \2 \3 \4 \5 + apply (rule trans) + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule T1.Map_Inj) + apply (rule T1.Sb_comp_Inj) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 + apply (rule trans) + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule T1.Map_Inj) + apply (rule T1.Sb_comp_Inj) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + done + + subgoal for g1 g2 \'1 \'2 \'3 \'4 \'5 f1 f2 \1 \2 \3 \4 \5 + apply (rule trans) + apply (rule trans[OF comp_assoc]) + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule trans[OF comp_assoc[symmetric]]) + apply (rule trans) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (rule T1.Map_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule T1.Map_comp) + apply (rule comp_assoc[symmetric]) + apply (subst T1.Sb_comp) + apply (assumption | rule T1.SSupp_Map_bound T1.IImsupp_Map_bound SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (rule arg_cong2[of _ _ _ _ "(\)"]) + apply (rule ext) + apply (rule T1.Sb_cong) + apply (unfold comp_assoc T1.Map_Inj id_o o_id)[9] + apply (unfold id_o o_id) + apply (assumption | rule supp_comp_bound infinite_UNIV T1.SSupp_Sb_bound SSupp_Inj_bound T1.SSupp_Map_bound refl + T1.Sb_comp_Inj[THEN fun_cong] SSupp_Inj_bound IImsupp_Inj_bound T1.IImsupp_Sb_bound T1.IImsupp_Map_bound + | subst T1.Map_Inj | (subst comp_assoc, rule refl T1.SSupp_Sb_bound T1.IImsupp_Sb_bound) + )+ + + apply (rule ext) + apply (rule T1.Map_cong) + (* REPEAT for inner *) + apply (rule T2.Sb_comp[THEN fun_cong], assumption+) + apply (rule refl) + apply (rule T3'.Sb_comp[THEN fun_cong], assumption+) + done + + apply (unfold T1.Supp_Inj UN_empty) + apply (rule refl Un_empty_left Un_empty_right T1.Vrs_bd T2.Vrs_bd T3.Vrs_bd T1.Vrs_Inj T3'.Vrs_bd infinite_regular_card_order_Un infinite_regular_card_order_UN infinite_regular_card_order_natLeq T1.Supp_bd)+ + + apply (unfold0 comp_apply)[1] + apply (rule trans) + apply (rule T1.Vrs_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj UN_empty2 Un_empty_left Un_empty_right)[1] + apply (rule refl) + + apply (unfold0 comp_apply)[1] + apply (subst T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T2.Vrs_Sb T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T3'.Vrs_Sb T2.Vrs_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold Un_assoc[symmetric] Un_Union_image)[1] + apply (rule set_eqI) + apply (rule iffI) + apply (unfold Un_iff)[1] + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (unfold Un_iff)[1] + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj UN_empty2 Un_empty_right) + apply (rule refl) + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right + UN_Un T1.Supp_Inj + ) + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T2.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T2.Vrs_Sb T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold UN_Un_distrib)[1] + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T2.Vrs_Sb T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold UN_Un_distrib)[1] + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T2.Vrs_Sb T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold UN_Un_distrib)[1] + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + done + + subgoal for f1 f2 \1 \2 \3 \4 \5 x + apply (unfold0 comp_apply) + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T2.Vrs_Sb T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold UN_Un_distrib)[1] + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + done + + subgoal premises prems for f1 f2 \1 \2 \3 \4 \5 g1 g2 \'1 \'2 \'3 \'4 \'5 x + apply (rule comp_apply_eq) + apply (rule cong'[OF _ T1.Map_cong, rotated]) + (* REPEAT for inners *) + apply (rule T2.Sb_cong) + apply (rule prems)+ + (* REPEAT_DETERM *) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* repeated *) + apply (rule prems) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* END REPEAT_DETERM *) + (* second inner *) + apply (rule refl) + (* third inner *) + apply (rule T3'.Sb_cong) + apply (rule prems)+ + (* REPEAT_DETERM *) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* repeated *) + apply (rule prems) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* repeated *) + apply (rule prems) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* repeated *) + apply (rule prems) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* repeated *) + apply (rule prems) + apply (drule UN_I) + apply assumption + apply (assumption | erule UnI1 UnI2 | rule UnI2)+ + (* END REPEAT_DETERM *) + apply (rule T1.Sb_cong) + apply (unfold T1.Vrs_Map) + apply (rule refl prems SSupp_Inj_bound SSupp_Inj_bound IImsupp_Inj_bound | assumption | erule UnI1 UnI2 | rule UnI2)+ + done + + apply (unfold T3'.Map_id T1.Map_id)[1] + apply (rule refl) + + apply (unfold T1.Map_comp id_o o_id T3'.Map_comp)[1] + apply (rule refl) + + apply (unfold T1.Supp_Map image_comp[unfolded comp_def] T3'.Supp_Map image_UN)[1] + apply (rule refl) + + apply (rule infinite_regular_card_order_UN infinite_regular_card_order_natLeq T1.Supp_bd T3'.Supp_bd)+ + + subgoal premises prems for f g x + apply (rule T1.Map_cong) + apply (rule refl)+ + apply (rule T3'.Map_cong) + apply (rule prems) + apply (erule UN_I) + apply assumption + done + + subgoal for f f1 f2 \1 \2 \3 \4 \5 + apply (unfold comp_assoc[symmetric]) + apply (rule trans) + apply (rule arg_cong2[OF T1.Map_Sb refl]) + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+ + apply (rule trans[OF comp_assoc]) + apply (rule sym) + apply (rule trans[OF comp_assoc]) + apply (unfold T1.Map_Inj T1.Map_comp id_o o_id T3'.Map_Sb) + apply (rule refl) + done + + apply (unfold0 comp_apply)[1] + apply (subst T1.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T1.Supp_Inj + image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap + Un_empty_right Un_empty_left UN_Un Union_Un_distrib UN_UN_flatten UN_Un_distrib + )[1] + apply (subst T3'.Supp_Sb, (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound)+)+ + apply (unfold UN_Un_distrib)[1] + apply (rule set_eqI) + apply (unfold Un_iff)[1] + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj) + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold de_Morgan_disj) + apply (erule conjE)+ + apply (rule conjI)+ + apply assumption+ + + apply (unfold T1.Vrs_Map T1.Supp_Map image_id image_comp[unfolded comp_def] T3'.Vrs_Map T1.Map_Inj) + apply (rule refl)+ + done +print_theorems + +(* Sealing of composed bmv *) +typedef ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T' = + "UNIV :: (('a, 'b, 'e, 'd) T2, 'b, 'c, 'f set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1 set" + by (rule UNIV_witness) +print_theorems + +definition "Sb_T' \ \h1 h2 \1 \2 \3 \4 \5 \6 \7. Abs_T' \ (Sb_T1 h1 (Rep_T' \ \1) (Rep_T' \ \2) \ Map_T1 (Sb_T2 h2 \3) id (Sb_T3 \4 \5 \6 \7 \ Map_T3 h2 id)) \ Rep_T'" +definition "RVrs_1_T' \ Vrs_1_T1 \ Rep_T'" +definition "RVrs_2_T' \ (\x. \ (Vrs_1_T2 ` set_1_T1 x) \ \ (set_1_T3 ` set_3_T1 x)) \ Rep_T'" +definition "Inj_1_T' \ Abs_T' \ Inj_1_T1" +definition "Inj_2_T' \ Abs_T' \ Inj_2_T1" +definition "Vrs_1_T' \ Vrs_2_T1 \ Rep_T'" +definition "Vrs_2_T' \ Vrs_3_T1 \ Rep_T'" +definition "Vrs_3_T' \ (\x. \ (Vrs_2_T2 ` set_1_T1 x)) \ Rep_T'" +definition "Vrs_4_T' \ (\x. \ (Vrs_1_T3 ` set_3_T1 x)) \ Rep_T'" +definition "Vrs_5_T' \ (\x. \ (Vrs_2_T3 ` set_3_T1 x)) \ Rep_T'" +definition "Vrs_6_T' \ (\x. \ (Vrs_3_T3 ` set_3_T1 x)) \ Rep_T'" +definition "Vrs_7_T' \ (\x. \ (Vrs_4_T3 ` set_3_T1 x)) \ Rep_T'" +definition "Map_T' \ \f. Abs_T' \ Map_T1 id id (Map_T3 id f) \ Rep_T'" +definition "Supp_T' \ (\x. \ (set_3_T3 ` set_3_T1 x)) \ Rep_T'" + +lemmas defs = Sb_T'_def RVrs_1_T'_def RVrs_2_T'_def Inj_1_T'_def Inj_2_T'_def Vrs_1_T'_def Vrs_2_T'_def Vrs_3_T'_def + Vrs_4_T'_def Vrs_5_T'_def Vrs_6_T'_def Vrs_7_T'_def Map_T'_def Supp_T'_def + +pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T3': "('b, 'a, 'c, 'd, 'e, 'h) T3" + Sbs: Sb_T' + RVrs: RVrs_1_T' RVrs_2_T' + Injs: Inj_1_T' Inj_2_T' Inj_T2 Inj_1_T3 Inj_1_T4 Inj_2_T3 Inj_2_T4 + Vrs: Vrs_1_T' Vrs_2_T' Vrs_3_T' Vrs_4_T' Vrs_5_T' Vrs_6_T' Vrs_7_T' + Maps: Map_T' + Supps: Supp_T' + bd: natLeq + apply (unfold SSupp_type_copy[OF type_definition_T'] IImsupp_type_copy[OF type_definition_T'] defs) + + apply (rule infinite_regular_card_order_natLeq) + + apply (unfold type_copy_Rep_o_Abs_o[OF type_definition_T'] T.Sb_Inj(1) o_id)[1] + apply (rule type_copy_Abs_o_Rep) + apply (rule type_definition_T') + + apply (rule trans[OF comp_assoc]) + apply (unfold type_copy_Rep_o_Abs_o[OF type_definition_T']) + apply (rule trans[OF comp_assoc]) + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule T.Sb_comp_Inj) + apply assumption+ + apply (rule type_copy_Abs_o_Rep_o) + apply (rule type_definition_T') + + apply (rule trans[OF comp_assoc]) + apply (unfold type_copy_Rep_o_Abs_o[OF type_definition_T']) + apply (rule trans[OF comp_assoc]) + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule T.Sb_comp_Inj) + apply assumption+ + apply (rule type_copy_Abs_o_Rep_o) + apply (rule type_definition_T') + + apply (rule trans) + apply (rule type_copy_map_comp0[symmetric]) + apply (rule type_definition_T') + apply (rule T.Sb_comp[symmetric]; assumption) + apply (unfold comp_assoc[of Rep_T', symmetric] id_o comp_assoc[of _ Rep_T'] type_copy_Rep_o_Abs[OF type_definition_T'])[1] + apply (rule refl) + + apply ((unfold comp_apply)[1], rule T.Vrs_bd)+ + + apply ((unfold comp_def Abs_T'_inverse[OF UNIV_I])[1], rule T.Vrs_Inj)+ + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Vrs_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + apply (rule type_copy_map_cong0) + apply (rule T.Sb_cong) + apply (assumption | ((unfold0 comp_apply)[1], (assumption | rule arg_cong[of _ _ Rep_T'])))+ + + apply (unfold T.Map_id(1) o_id)[1] + apply (rule type_copy_Abs_o_Rep) + apply (rule type_definition_T') + + apply (rule type_copy_map_comp0[symmetric]) + apply (rule type_definition_T') + apply (rule T.Map_comp(1)[symmetric]) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule T.Supp_Map) + + apply ((unfold comp_apply)[1], rule T.Supp_bd) + + apply (rule type_copy_map_cong0) + apply (rule T.Map_cong) + apply (unfold comp_apply)[1] + apply assumption + + apply (rule type_copy_Map_Sb) + apply (rule type_definition_T')+ + apply (unfold comp_assoc[of _ Rep_T'] comp_assoc[of Abs_T'] type_copy_Rep_o_Abs_o[OF type_definition_T']) + apply (rule T.Map_Sb; assumption) + + apply (unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.Supp_Sb; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply ((unfold0 comp_apply[of _ Rep_T'] comp_apply[of Abs_T'] Abs_T'_inverse[OF UNIV_I])[1], (rule T.Vrs_Map))+ + + apply (unfold T.Map_Inj) + apply (rule refl)+ + + done +print_theorems + +local_setup \fn lthy => +let + open MRBNF_Util + val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (Binding.prefix_name "comp") T1 [Inl T2, Inr @{typ "'g set"}, Inl T3] + { frees = [@{typ 'b}, @{typ 'c}, @{typ 'g}], deads = [@{typ 'f}] } + [ SOME { frees = [@{typ 'd}, @{typ 'b}], lives = [], deads = [@{typ "'a::var"}, @{typ 'e}] }, + NONE, + SOME { frees = [@{typ 'b}, @{typ 'a}, @{typ 'c}], lives = [@{typ 'd}, @{typ 'h}], deads = [@{typ 'e}] } + ] lthy + + val ((bmv, _, _, _), lthy) = BMV_Monad_Def.seal_bmv_monad I unfold_set @{binding T''} + [@{typ "'a::var"}, @{typ "'b::var"}, @{typ "'c::var"}, @{typ "'d::var"}, @{typ 'e}, @{typ 'f}, @{typ "'g::var"}, @{typ 'h}] + bmv NONE lthy + val _ = @{print} bmv +in lthy end +\ + +end diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy new file mode 100644 index 00000000..35aefa6a --- /dev/null +++ b/operations/BMV_Fixpoint.thy @@ -0,0 +1,1556 @@ +theory BMV_Fixpoint + imports BMV_Monad +begin + +type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = + "('v \\Var 'v\ + + 'd * 'd \\App \('tv, 'v) FTerm\ \('tv, 'v) FTerm\\ + \\+ 'v list\ + ) + 'd * 'tv FType \\TyApp \('tv, 'v) FTerm\ \'tv FType\\ + + 'bv * 'tv FType * 'c \\Lam x::'v \'tv FType\ t::\('tv, 'v) FTerm\ binds x in t\ + + 'btv * 'c \\TyLam a::'tv t::\('tv, 'v) FTerm\ binds a in t\" + +local_setup \fn lthy => +let + val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; + val Xs = map (apfst dest_TFree) [(@{typ 'tv}, MRBNF_Def.Free_Var), (@{typ 'v}, MRBNF_Def.Free_Var), + (@{typ 'btv}, MRBNF_Def.Bound_Var), (@{typ 'bv}, MRBNF_Def.Bound_Var), + (@{typ 'c}, MRBNF_Def.Live_Var), (@{typ 'd}, MRBNF_Def.Live_Var)]; + + val ((mrsbnf, tys), (((_, bmv_unfolds), (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) + I [] Xs + (fn xss => inter (op=) (flat xss) (map fst Xs)) + T + (((Symtab.empty, []), (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy); + + val mrsbnf = case mrsbnf of MRBNF_Util.Inl x => x | _ => error "impossible" + + val notes = [ + ("bmv_defs", bmv_unfolds) + ] |> (map (fn (thmN, thms) => + ((Binding.name thmN, []), [(thms, [])]) + )); + + val (noted, lthy) = Local_Theory.notes notes lthy + + val ((mrsbnf, (tys, info)), lthy) = MRSBNF_Comp.seal_mrsbnf I (bmv_unfolds, mrbnf_unfolds) + @{binding FTerm_pre} Xs tys mrsbnf NONE lthy + val (_, lthy) = MRSBNF_Def.note_mrsbnf_thms (K BNF_Def.Note_Some) I NONE mrsbnf lthy + + val lthy = MRSBNF_Def.register_mrsbnf "BMV_Fixpoint.FTerm_pre" mrsbnf lthy; + + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val mrbnf = nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad bmv) + + (* Step 3: Register the pre-MRBNF as a BNF in its live variables *) + val (bnf, lthy) = MRBNF_Def.register_mrbnf_as_bnf mrbnf lthy + + (* Step 4: Construct the binder fixpoint *) + val (fp_res, lthy) = MRBNF_FP.construct_binder_fp BNF_Util.Least_FP + [{ + FVars = [SOME "FTVars", SOME "FVars"], + T_name = "FTerm", + nrecs = 2, + permute = NONE, + pre_mrbnf = mrbnf + }] [[([], [0])], [([], [0])]] lthy + + (* Step 5: Define recursor locales *) + val (recursor_result, lthy) = MRBNF_Recursor.create_binding_recursor I fp_res lthy; + + val ([(rec_mrbnf, vvsubst_res)], lthy) = MRBNF_VVSubst.mrbnf_of_quotient_fixpoint [@{binding vvsubst_FTerm}] + I fp_res (#QREC_fixed recursor_result) lthy; + val lthy = MRBNF_Def.register_mrbnf_raw (fst (dest_Type (#T (hd (#quotient_fps fp_res))))) rec_mrbnf lthy; + +in lthy end +\ +print_theorems + +(* Substitution axioms *) +abbreviation \ :: "'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre" where + "\ a \ Abs_FTerm_pre (Inl (Inl a))" + +(* Because RVrs is completely overwritten *) +lemma eta_free: "RVrs_FTerm_pre (\ a) = {a}" + apply (unfold set2_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left Un_empty_right prod.set_map comp_def + Abs_FTerm_pre_inverse[OF UNIV_I] sum_set_simps UN_empty UN_single RVrs_FTerm_pre_def bmv_defs + ) + apply (rule refl) + done +lemma eta_compl_free: "\a. x \ \ a \ RVrs_FTerm_pre x = {}" + apply (tactic \resolve_tac @{context} [infer_instantiate' @{context} [SOME @{cterm x}] ( + BNF_FP_Util.mk_absumprodE @{thm type_definition_FTerm_pre} [1, 2, 2, 3, 2] + )] 1\; hypsubst_thin) + apply (unfold Sb_FTerm_pre_def comp_def Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] bmv_defs Abs_FTerm_pre_inverse[OF UNIV_I] + map_sum.simps Map_FTerm_pre_def sum.inject RVrs_FTerm_pre_def bmv_defs sum_set_simps UN_single cSup_singleton + Union_empty Un_empty_right UN_empty + ) + apply (erule contrapos_pp) + apply (unfold not_all not_not) + apply (rule exI) + apply (rule refl)+ + done + +lemma eta_inj: "\ a = \ b \ a = b" + apply (unfold Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] sum.inject) + apply assumption + done + +lemma eta_natural: + fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" + assumes "|supp f1| \ = \ \ f2" + apply (rule ext) + apply (unfold comp_def map_FTerm_pre_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps) + apply (rule refl) + done + +lemma eta_Sb: + fixes x::"('tv::var, 'v::var, 'c::var, 'd::var, 'e, 'f) FTerm_pre" + assumes "|supp f| | (Map_FTerm_pre h1 h2 x) = \ a \ \a. x = \ a" + apply (tactic \resolve_tac @{context} [infer_instantiate' @{context} [SOME @{cterm x}] ( + BNF_FP_Util.mk_absumprodE @{thm type_definition_FTerm_pre} [1, 2, 2, 3, 2] + )] 1\; hypsubst_thin) + apply (unfold Sb_FTerm_pre_def comp_def Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] bmv_defs Abs_FTerm_pre_inverse[OF UNIV_I] + map_sum.simps Map_FTerm_pre_def) + apply (rule exI, rule refl) + (* orelse *) + apply (((unfold sum.inject)[1])?, erule sum.distinct[THEN notE])+ + done + +definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where + "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl (Inl a)))" + +(* Construction of substitution *) +definition VVr :: "'v::var \ ('tv::var, 'v) FTerm" where + "VVr \ FTerm_ctor \ \" +definition isVVr :: "('tv::var, 'v::var) FTerm \ bool" where + "isVVr x \ \a. x = VVr a" +definition asVVr :: "('tv::var, 'v::var) FTerm \ 'v" where + "asVVr x \ (if isVVr x then SOME a. x = VVr a else undefined)" + +abbreviation "IImsupp_FTerm1 \ IImsupp VVr FTVars" +abbreviation "IImsupp_FTerm2 f \ SSupp VVr f \ IImsupp VVr FVars f" + +lemma asVVr_VVr: "asVVr (VVr a) = a" + apply (unfold asVVr_def isVVr_def) + apply (subst if_P) + apply (rule exI) + apply (rule refl) + apply (rule someI2) + apply (rule refl) + apply (unfold VVr_def comp_def) + apply (unfold FTerm.TT_inject0) + apply (erule exE conjE)+ + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] + map_sum.simps Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] id_apply + sum.inject + ) + apply (erule sym) + done + +lemma permute_VVr: + fixes f1::"'var::var \ 'var" and f2::"'tyvar::var \ 'tyvar" + assumes f_prems: "bij f1" "|supp f1| 'var" and f2::"'tyvar::var \ 'tyvar" + assumes f_prems: "bij f1" "|supp f1| a \ imsupp f2 \ IImsupp_FTerm2 y = {} \ y a = VVr a" + apply (unfold imsupp_def supp_def SSupp_def) + apply (drule iffD1[OF disjoint_iff]) + apply (erule allE) + apply (erule impE) + apply (rule UnI1) + apply (erule iffD2[OF mem_Collect_eq]) + apply (unfold Un_iff de_Morgan_disj mem_Collect_eq not_not) + apply (erule conjE) + apply assumption + done + +lemma IImsupp_permute_commute: + fixes f1::"'var::var \ 'var" and f2::"'tyvar::var \ 'tyvar" + assumes f_prems: "bij f1" "|supp f1| IImsupp_FTerm1 y = {} \ imsupp f2 \ IImsupp_FTerm2 y = {} \ permute_FTerm f1 f2 \ y = y \ f2" + apply (rule ext) + apply (unfold comp_def) + subgoal for a + apply (rule case_split[of "f2 a = a"]) + apply (rule case_split[of "y a = VVr a"]) + apply (rule trans) + apply (rule arg_cong[of _ _ "permute_FTerm f1 f2"]) + apply assumption + apply (rule trans) + apply (rule permute_VVr) + apply (rule assms)+ + apply (rule trans) + apply (rule arg_cong[of _ _ VVr]) + apply assumption + apply (rule sym) + apply (rotate_tac -2) + apply (erule subst[OF sym]) + apply assumption + + apply (rule trans) + apply (rule FTerm.permute_cong_id) + apply (rule assms)+ + (* REPEAT_DETERM *) + apply (erule id_onD[rotated]) + apply (rule imsupp_id_on) + apply (erule Int_subset_empty2) + apply (unfold SSupp_def IImsupp_def)[1] + apply (rule subsetI) + apply (rule UnI2)? + apply (rule UN_I[rotated]) + apply assumption + apply (rule CollectI) + apply assumption + (* repeated *) + (* REPEAT_DETERM *) + apply (erule id_onD[rotated]) + apply (rule imsupp_id_on) + apply (erule Int_subset_empty2) + apply (unfold SSupp_def IImsupp_def)[1] + apply (rule subsetI) + apply (rule UnI2)? + apply (rule UN_I[rotated]) + apply assumption + apply (rule CollectI) + apply assumption + (* END REPEAT_DETERM *) + apply (rotate_tac -2) + apply (erule subst[OF sym]) + apply (rule refl) + + apply (rule trans) + apply (rule arg_cong[of _ _ "permute_FTerm f1 f2"]) + defer + apply (rule trans) + prefer 3 + apply (erule IImsupp_VVrs) + apply assumption + apply (rule permute_VVr) + apply (rule f_prems)+ + apply (rule sym) + apply (rule IImsupp_VVrs) + apply (erule bij_not_eq_twice[rotated]) + apply (rule f_prems) + apply assumption + done + done + +type_synonym ('tv, 'v) U1_pre = "('tv, 'v, 'tv, 'v, ('tv, 'v) FTerm, ('tv, 'v) FTerm) FTerm_pre" + +lemmas eta_natural' = fun_cong[OF eta_natural, unfolded comp_def] + +lemma eta_set_empties: + fixes a::"'v::var" + shows + "set1_FTerm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" + "set3_FTerm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" + "set4_FTerm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" + "set5_FTerm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" + "set6_FTerm_pre (\ a :: ('tv::var, 'v) U1_pre) = {}" + apply - + subgoal + apply (rule set_eqI) + apply (unfold empty_iff) + apply (rule iffI) + apply (rule exE[OF exists_fresh, of "set1_FTerm_pre (\ a)"]) + apply (rule FTerm_pre.set_bd_UNIV) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule arg_cong[of _ _ set1_FTerm_pre]) + prefer 2 + apply (subst (asm) FTerm_pre.set_map) + prefer 7 + apply (erule swap_fresh) + apply assumption + apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ + apply (rule sym) + apply (rule trans) + apply (rule fun_cong[OF eta_natural, unfolded comp_def]) + apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ + apply (unfold id_def) + apply (rule refl) + apply (erule FalseE) + done + subgoal + apply (rule set_eqI) + apply (unfold empty_iff) + apply (rule iffI) + apply (rule exE[OF exists_fresh, of "set3_FTerm_pre (\ a)"]) + apply (rule FTerm_pre.set_bd_UNIV) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule arg_cong[of _ _ set3_FTerm_pre]) + prefer 2 + apply (subst (asm) FTerm_pre.set_map) + prefer 7 + apply (erule swap_fresh) + apply assumption + apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ + apply (rule sym) + apply (rule trans) + apply (rule fun_cong[OF eta_natural, unfolded comp_def]) + apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ + apply (unfold id_def) + apply (rule refl) + apply (erule FalseE) + done + subgoal + apply (rule set_eqI) + apply (unfold empty_iff) + apply (rule iffI) + apply (rule exE[OF exists_fresh, of "set4_FTerm_pre (\ a)"]) + apply (rule FTerm_pre.set_bd_UNIV) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule arg_cong[of _ _ set4_FTerm_pre]) + prefer 2 + apply (subst (asm) FTerm_pre.set_map) + prefer 7 + apply (erule swap_fresh) + apply assumption + apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ + apply (rule sym) + apply (rule trans) + apply (rule eta_natural') + apply (rule supp_id_bound bij_id supp_swap_bound bij_swap infinite_UNIV)+ + apply (unfold id_def) + apply (rule refl) + apply (erule FalseE) + done + subgoal + apply (rule set_eqI) + apply (unfold empty_iff) + apply (rule iffI) + apply (drule image_const) + apply (drule iffD1[OF all_cong1, rotated]) + apply (rule sym) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule FTerm_pre.set_map) + apply (rule supp_id_bound bij_id)+ + apply (subst (asm) eta_natural') + apply (rule supp_id_bound bij_id)+ + apply (unfold id_def) + apply (drule forall_in_eq_UNIV) + apply (drule trans[symmetric]) + apply (rule conjunct1[OF card_order_on_Card_order, OF FTerm_pre.bd_card_order]) + apply (drule card_of_ordIso_subst) + apply (drule ordIso_symmetric) + apply (drule ordIso_transitive) + apply (rule ordIso_symmetric) + apply (rule iffD1[OF Card_order_iff_ordIso_card_of]) + apply (rule conjunct2[OF card_order_on_Card_order, OF FTerm_pre.bd_card_order]) + apply (erule ordIso_ordLess_False) + apply (rule FTerm_pre.set_bd) + apply (erule FalseE) + done + subgoal + apply (rule set_eqI) + apply (unfold empty_iff) + apply (rule iffI) + apply (drule image_const) + apply (drule iffD1[OF all_cong1, rotated]) + apply (rule sym) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule FTerm_pre.set_map) + apply (rule supp_id_bound bij_id)+ + apply (subst (asm) eta_natural') + apply (rule supp_id_bound bij_id)+ + apply (unfold id_def) + apply (drule forall_in_eq_UNIV) + apply (drule trans[symmetric]) + apply (rule conjunct1[OF card_order_on_Card_order, OF FTerm_pre.bd_card_order]) + apply (drule card_of_ordIso_subst) + apply (drule ordIso_symmetric) + apply (drule ordIso_transitive) + apply (rule ordIso_symmetric) + apply (rule iffD1[OF Card_order_iff_ordIso_card_of]) + apply (rule conjunct2[OF card_order_on_Card_order, OF FTerm_pre.bd_card_order]) + apply (erule ordIso_ordLess_False) + apply (rule FTerm_pre.set_bd) + apply (erule FalseE) + done + done + +lemma not_is_VVr_Sb: + fixes x::"('tv::var, 'v::var, 'tv, 'v, ('tv, 'v) FTerm, ('tv, 'v) FTerm) FTerm_pre" + assumes "|supp f| | isVVr (FTerm_ctor x) \ \isVVr (FTerm_ctor (Sb_FTerm_pre f \ (Map_FTerm_pre h1 h2 x)))" + apply (unfold isVVr_def VVr_def comp_def) + apply (erule contrapos_nn) + apply (erule exE) + apply (subst (asm) FTerm.TT_inject0) + apply (erule exE conjE)+ + subgoal for a f1 f2 + apply (drule arg_cong[of _ _ "map_FTerm_pre id id (inv f1) (inv f2) (permute_FTerm (inv f1) (inv f2)) id"]) + apply (subst (asm) FTerm_pre.map_comp) + apply (rule supp_id_bound bij_id bij_imp_bij_inv supp_inv_bound | assumption)+ + apply (subst (asm) FTerm.permute_comp0, (rule supp_id_bound bij_id bij_imp_bij_inv supp_inv_bound | assumption)+)+ + apply (unfold id_o o_id inv_o_simp1 FTerm.permute_id0 FTerm_pre.map_id) + apply (subst (asm) eta_natural[THEN fun_cong, unfolded comp_def]) + apply (rule supp_id_bound bij_id bij_imp_bij_inv supp_inv_bound | assumption)+ + apply (drule eta_Sb[OF assms]) + apply (erule exE) + apply hypsubst_thin + apply (rule exI) + apply (rule refl) + done + done + +abbreviation (input) "avoiding_set1 f1 f2 \ IImsupp_FTerm1 f1 \ (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2)" +abbreviation (input) "avoiding_set2 f1 \ SSupp VVr f1 \ IImsupp_FTerm2 f1" + +context + fixes f1::"'var::var \ ('tyvar::var, 'var) FTerm" and f2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr f1| y. if isVVr (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) then + f1 (asVVr (FTerm_ctor (map_FTerm_pre id id id id fst fst y))) + else FTerm_ctor (Sb_FTerm_pre id f2 (map_FTerm_pre id id id id snd snd y))" + apply unfold_locales + + apply ((rule infinite_class.Un_bound var_class.UN_bound f_prems FType.set_bd_UNIV + FTerm.FVars_bd_UNIVs + | (unfold IImsupp_def)[1])+)[2] + + subgoal for g1 g2 y + apply (subst FTerm_pre.map_comp, (assumption | rule supp_id_bound bij_id)+)+ + apply (unfold Product_Type.snd_comp_map_prod Product_Type.fst_comp_map_prod id_o_commute[of g1] id_o_commute[of g2]) + apply (subst FTerm_pre.map_comp[symmetric], (assumption | rule supp_id_bound bij_id)+)+ + apply (subst FTerm.permute_ctor[symmetric] isVVr_permute, assumption+)+ + + apply (rule case_split) + apply (subst if_P) + apply assumption + apply (unfold if_P if_not_P) + apply (unfold isVVr_def)[1] + apply (erule exE) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (subst permute_VVr) + apply assumption+ + apply (unfold asVVr_VVr) + apply (rule IImsupp_permute_commute[THEN fun_cong, unfolded comp_def]) + apply assumption+ + apply (erule Int_subset_empty2) + apply (rule Un_upper1) + apply (erule Int_subset_empty2) + apply (rule Un_upper1 Un_upper2) + + apply (rule trans) + apply (rule FTerm.permute_ctor) + apply (assumption)+ + apply (subst trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]]) + apply (assumption | rule supp_id_bound bij_id f_prems)+ + apply (unfold0 id_o o_id inv_o_simp2 comp_apply) + apply (rule arg_cong[of _ _ FTerm_ctor]) + apply (rule FTerm_pre.Sb_cong) + apply (assumption | rule supp_id_bound supp_inv_bound SSupp_comp_bound infinite_UNIV FType.SSupp_map_bound + f_prems conjI FTerm.UNIV_cinfinite card_of_Card_order + | (unfold comp_assoc)[1])+ + apply (rule refl) + apply (subst (asm) FTerm_pre.map_comp, (assumption | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] | rule card_of_Card_order supp_id_bound bij_id)+) + apply (unfold id_o o_id FTerm_pre.set_Vrs(1)[symmetric]) + apply (subst (asm) FTerm_pre.set_map, (assumption | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] | rule card_of_Card_order supp_id_bound bij_id)+) + apply (erule imageE) + apply hypsubst + apply (rule trans[OF comp_apply]) + apply (unfold inv_simp1) + apply (rule trans[OF comp_apply]) + apply (subst FType.vvsubst_permute, (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+) + apply (rule FType.IImsupp_permute_commute[THEN fun_cong, unfolded comp_def]) + apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI2) + apply assumption + done + + subgoal premises prems + apply (rule case_split) + apply (subst if_P) + apply assumption + apply (unfold if_not_P) + apply (unfold isVVr_def)[1] + apply (erule exE) + apply (erule subst[OF sym]) + apply (unfold asVVr_VVr) + apply (rule case_split[of "_ = _"]) + apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]) + apply (rule arg_cong[of _ _ FTVars]) + apply assumption + apply (rule Un_upper1) + apply (rule subsetI) + apply (rule UnI2) + apply (rule UnI1) + apply (unfold IImsupp_def SSupp_def)[1] + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply assumption + + apply (erule thin_rl) + apply (subst FTerm_pre.map_Sb[THEN fun_cong, unfolded comp_def, symmetric]) + apply (rule supp_id_bound bij_id f_prems)+ + apply (unfold FTerm.FVars_ctor) + apply (subst FTerm_pre.set_map, (rule supp_id_bound bij_id)+)+ + apply (unfold image_id image_comp[unfolded comp_def]) + apply (subst FTerm_pre.set_Sb, (rule supp_id_bound bij_id f_prems)+)+ + apply (rule Un_mono')+ + + apply (unfold FTerm_pre.set_Vrs(1))[1] + apply (subst FTerm_pre.Vrs_Sb, (rule supp_id_bound bij_id f_prems)+) + apply (rule subsetI) + apply (erule UN_E) + apply (rule case_split[of "_ = _", rotated]) + apply (unfold IImsupp_def SSupp_def)[1] + apply (rule UnI2)+ + apply (erule UN_I[rotated]) + apply (erule CollectI) + apply (rule UnI1) + apply (rotate_tac -2) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (erule arg_cong) + apply (unfold FType.Vrs_Inj) + apply (drule singletonD) + apply hypsubst + apply assumption + + apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) + apply (rule Diff_Un_disjunct) + apply (rule prems) + apply (rule Diff_mono[OF _ subset_refl]) + apply (unfold UN_extend_simps(2)) + (* REPEAT_DETERM *) + apply (rule subset_If) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* repeated *) + apply (rule subset_If) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* END REPEAT_DETERM *) + done + + + subgoal premises prems + apply (rule case_split) + apply (subst if_P) + apply assumption + apply (unfold if_not_P) + apply (unfold isVVr_def)[1] + apply (erule exE) + apply (erule subst[OF sym]) + apply (unfold asVVr_VVr) + apply (rule case_split[of "_ = _"]) + apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]) + apply (rule arg_cong[of _ _ FVars]) + apply assumption + apply (rule Un_upper1) + apply (rule subsetI) + apply (rule UnI2)+ + apply (unfold IImsupp_def SSupp_def)[1] + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply assumption + + apply (erule thin_rl) + apply (subst FTerm_pre.map_Sb[THEN fun_cong, unfolded comp_def, symmetric]) + apply (rule supp_id_bound bij_id f_prems)+ + apply (unfold FTerm.FVars_ctor) + apply (subst FTerm_pre.set_map, (rule supp_id_bound bij_id)+)+ + apply (unfold image_id image_comp[unfolded comp_def]) + apply (subst FTerm_pre.set_Sb, (rule supp_id_bound bij_id f_prems)+)+ + apply (rule Un_mono')+ + + apply (unfold FTerm_pre.set_Vrs(2))[1] + apply (subst FTerm_pre.Vrs_Sb, (rule supp_id_bound bij_id f_prems)+) + apply (unfold image_id) + apply (rule Un_upper1) + + apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) + apply (rule Diff_Un_disjunct) + apply (rule prems) + apply (rule Diff_mono[OF _ subset_refl]) + apply (unfold UN_extend_simps(2)) + (* REPEAT_DETERM *) + apply (rule subset_If) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* repeated *) + apply (rule subset_If) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* END REPEAT_DETERM *) + done + done + +definition "tvsubst_FTerm = tvsubst.REC_FTerm" + +lemma tvsubst_VVr: "tvsubst_FTerm (VVr a) = f1 a" + apply (unfold VVr_def comp_def) + apply (unfold tvsubst_FTerm_def) + apply (rule trans) + apply (rule tvsubst.REC_ctor) + apply (unfold eta_set_empties noclash_FTerm_def) + apply (rule Int_empty_left conjI)+ + apply (subst FTerm_pre.map_comp, (rule supp_id_bound bij_id)+)+ + apply (unfold id_o o_id comp_def[of fst] fst_conv id_def[symmetric] FTerm_pre.map_id + VVr_def[THEN meta_eq_to_obj_eq, THEN fun_cong, unfolded comp_def, symmetric] asVVr_VVr + ) + apply (subst if_P) + apply (unfold isVVr_def) + apply (rule exI) + apply (rule refl) + apply (rule refl) + done + +lemma tvsubst_not_is_VVr: + assumes empty_prems: "set3_FTerm_pre x \ avoiding_set1 f1 f2 = {}" "set4_FTerm_pre x \ avoiding_set2 f1 = {}" + and noclash: "noclash_FTerm x" + and VVr_prems: "\isVVr (FTerm_ctor x)" + shows "tvsubst_FTerm (FTerm_ctor x) = FTerm_ctor (Sb_FTerm_pre id f2 (map_FTerm_pre id id id id tvsubst_FTerm tvsubst_FTerm x))" + apply (unfold tvsubst_FTerm_def) + apply (rule trans) + apply (rule tvsubst.REC_ctor) + apply (rule assms)+ + apply (subst FTerm_pre.map_comp, (rule supp_id_bound bij_id)+)+ + apply (unfold id_o o_id comp_def[of fst] comp_def[of snd] snd_conv fst_conv id_def[symmetric] FTerm_pre.map_id) + apply (rule if_not_P) + apply (rule assms) + done +end + +lemma in_IImsupps: + "f1 a \ VVr a \ z \ FVars (f1 a) \ z \ IImsupp VVr FVars f1" + "f1 a \ VVr a \ z2 \ FTVars (f1 a) \ z2 \ IImsupp VVr FTVars f1" + apply (unfold IImsupp_def SSupp_def) + apply (rule UN_I) + apply (erule CollectI) + apply assumption + apply (rule UN_I) + apply (erule CollectI) + apply assumption + done + +lemma FVars_VVr: + "FVars (VVr a) = {a}" + "FTVars (VVr a) = {}" + apply (unfold VVr_def comp_def FTerm.FVars_ctor eta_set_empties UN_empty Diff_empty Un_empty_right FTerm_pre.set_Vrs) + apply (rule eta_free) + apply (unfold FTerm_pre.set_Vrs[symmetric]) + apply (rule eta_set_empties) + done + +lemma IImsupp_Diff: + "B \ avoiding_set2 f1 = {} \ (\a\(A - B). FVars (f1 a)) = (\a\A. FVars (f1 a)) - B" + "B \ avoiding_set2 f1 = {} \ B2 \ avoiding_set1 f1 f2 = {} \ (\a\(A - B). FTVars (f1 a)) = (\a\A. FTVars (f1 a)) - B2" + apply (rule set_eqI) + apply (rule iffI) + (* helper_tac false *) + apply (erule UN_E DiffE)+ + apply (rule DiffI UN_I)+ + apply assumption + apply assumption + apply (rule case_split[of "_ = _"]) + (* apply (rotate_tac -2) *) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule trans) + apply (rule arg_cong[of _ _ FVars]) + apply assumption + apply (rule FVars_VVr) + apply (drule singletonD) + apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]) + (* apply (rule sym) *) + apply assumption + apply assumption + apply (frule in_IImsupps[rotated]) + apply assumption + apply (drule trans[OF Int_commute]) + apply (drule iffD1[OF disjoint_iff]) + apply (erule allE) + apply (erule impE) + (* prefer 2 *) + apply (rule UnI2)+ + apply assumption + apply assumption + (* END helper_tac false *) + (* helper_tac true *) + apply (erule UN_E DiffE)+ + apply (rule DiffI UN_I)+ + apply assumption + (*apply assumption*) + apply (rule case_split[of "_ = _"]) + apply (rotate_tac -2) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule trans) + apply (rule arg_cong[of _ _ FVars]) + apply assumption + apply (rule FVars_VVr) + apply (drule singletonD) + apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"], rotated]) + apply assumption + apply (erule sym) + apply (frule in_IImsupps(1)) + apply assumption + apply (drule trans[OF Int_commute]) + apply (drule iffD1[OF disjoint_iff]) + apply (erule allE) + apply (erule impE) + prefer 2 + apply assumption + (* apply assumption *) + (* END helper_tac true *) + apply (unfold IImsupp_def SSupp_def)[1] + apply (rule UnI1) + apply (rule CollectI) + apply assumption + apply assumption +(* second goal *) + apply (rule set_eqI) + apply (rule iffI) + (* helper_tac false *) + apply (erule UN_E DiffE)+ + apply (rule DiffI UN_I)+ + apply assumption + apply assumption + apply (rule case_split[of "_ = _"]) + (* apply (rotate_tac -2) *) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule trans) + apply (rule arg_cong[of _ _ FTVars]) + apply assumption + apply (rule FVars_VVr) + apply (drule singletonD | erule emptyE) + apply (frule in_IImsupps[rotated]) + apply assumption + apply (rotate_tac -1) + apply (erule disjoint_iff[THEN iffD1, THEN spec, THEN mp, rotated]) + apply (rule trans[OF Int_commute]) + apply (erule Int_subset_empty2) + apply (rule Un_upper1) + (* helper_tac true *) + apply (erule UN_E DiffE)+ + apply (rule DiffI UN_I)+ + apply assumption + (*apply assumption*) + apply (rule case_split[of "_ = _"]) + apply (rotate_tac -2) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (rule trans) + apply (rule arg_cong[of _ _ FTVars]) + apply assumption + apply (rule FVars_VVr) + apply (drule singletonD | erule emptyE) + apply (frule in_IImsupps[rotated]) + apply assumption + apply (erule disjoint_iff[THEN iffD1, THEN spec, THEN mp, OF trans[OF Int_commute]]) + (* apply assumption *) + (* END helper_tac true *) + apply (unfold IImsupp_def SSupp_def)[1] + apply (rule UnI1) + apply (rule CollectI) + apply assumption + apply assumption + done + +lemma FVars_tvsubst1: + fixes f1::"'var::var \ ('tyvar::var, 'var) FTerm" and f2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr f1| a\FVars t. FVars (f1 a))" + apply (rule FTerm.TT_fresh_induct[of "avoiding_set1 f1 f2" "avoiding_set2 f1" _ t]) + + apply ((rule infinite_class.Un_bound var_class.UN_bound f_prems FType.set_bd_UNIV + FTerm.FVars_bd_UNIVs + | (unfold IImsupp_def)[1])+)[2] + + apply (rule case_split[rotated]) + apply (subst tvsubst_not_is_VVr[rotated -1]) + apply assumption + apply (rule assms | assumption)+ + apply (unfold FTerm.FVars_ctor)[1] + apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order assms assms[THEN ordLess_ordLeq_trans])+)+ + apply (unfold image_id FTerm_pre.set_Vrs(1-2) image_comp[unfolded comp_def] FTerm_pre.Map_map[symmetric])[1] + apply (subst FTerm_pre.Vrs_Sb, (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order assms assms[THEN ordLess_ordLeq_trans])+)+ + apply (unfold image_id FTerm_pre.Vrs_Map UN_Un) + apply (rule arg_cong2[of _ _ _ _ "(\)"])+ + apply (subst eta_compl_free) + apply (unfold isVVr_def)[1] + apply (rotate_tac -1) + apply (erule contrapos_np) + apply (unfold not_all not_not VVr_def comp_def)[1] + apply (erule exE) + apply hypsubst + apply (rule exI) + apply (rule refl) + apply (subst eta_compl_free) + apply (unfold isVVr_def)[1] + apply (rotate_tac -1) + apply (erule contrapos_np) + apply (unfold not_all not_not VVr_def comp_def)[1] + apply (erule exE) + apply hypsubst + apply (rule exI) + apply (rule refl) + apply (unfold UN_empty) + apply (rule refl) + apply (subst IImsupp_Diff) + apply assumption + apply (rule arg_cong2[OF _ refl, of _ _ "minus"]) + apply (unfold UN_UN_flatten) + apply (rule UN_cong) + apply assumption + + apply (rule UN_cong) + apply assumption + + apply (unfold isVVr_def) + apply (erule exE) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (subst tvsubst_VVr) + apply (rule assms)+ + apply (unfold FVars_VVr UN_single) + apply (rule refl) + done + +lemma Un_cong_FTVars: "A = A1 \ A2 \ B = B1 \ B2 \ C = C1 \ C2 \ A \ B \ C = (A1 \ B1 \ C1) \ (A2 \ B2 \ C2)" + apply hypsubst_thin + apply (rule set_eqI) + apply (rule iffI) + apply (erule UnE) + apply (erule UnE) + (* REPEAT_DETERM *) + apply (erule UnE) + apply (rule UnI1) + apply (tactic \eresolve_tac @{context} [BNF_Util.mk_UnIN 3 1] 1\) + apply (rule UnI2) + apply (tactic \eresolve_tac @{context} [BNF_Util.mk_UnIN 3 1] 1\) + (* repeated *) + apply (erule UnE) + apply (rule UnI1) + apply (tactic \eresolve_tac @{context} [BNF_Util.mk_UnIN 3 2] 1\) + apply (rule UnI2) + apply (tactic \eresolve_tac @{context} [BNF_Util.mk_UnIN 3 2] 1\) + (* repeated *) + apply (erule UnE) + apply (rule UnI1) + apply (tactic \eresolve_tac @{context} [BNF_Util.mk_UnIN 3 3] 1\) + apply (rule UnI2) + apply (tactic \eresolve_tac @{context} [BNF_Util.mk_UnIN 3 3] 1\) + (* END REPEAT_DETERM *) + apply (erule UnE) + apply (erule Un_forward)+ + apply (erule UnI1)+ + apply (erule Un_forward)+ + apply (erule UnI2)+ + done + +lemma FVars_tvsubst2: + fixes \1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr \1| 1| 2| 1 \2 t) = (\x\FVars t. FTVars (\1 x)) \ (\x\FTVars t. FVars_FType (\2 x))" + apply (rule FTerm.TT_fresh_induct[of "avoiding_set1 \1 \2" "avoiding_set2 \1" _ t]) + apply ((rule infinite_class.Un_bound var_class.UN_bound f_prems FType.set_bd_UNIV + FTerm.FVars_bd_UNIVs + | (unfold IImsupp_def)[1])+)[2] + + apply (rule case_split[rotated]) + apply (subst tvsubst_not_is_VVr[rotated -1]) + apply assumption + apply (rule assms | assumption)+ + apply (unfold FTerm.FVars_ctor)[1] + apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order assms assms[THEN ordLess_ordLeq_trans])+)+ + apply (unfold image_id FTerm_pre.set_Vrs(1-2) image_comp[unfolded comp_def] FTerm_pre.Map_map[symmetric])[1] + apply (subst FTerm_pre.Vrs_Sb, (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order assms assms[THEN ordLess_ordLeq_trans])+)+ + apply (unfold image_id FTerm_pre.Vrs_Map UN_Un) + apply (rule Un_cong_FTVars) + apply (subst eta_compl_free) + apply (unfold isVVr_def)[1] + apply (rotate_tac -1) + apply (erule contrapos_np) + apply (unfold not_all not_not VVr_def comp_def)[1] + apply (erule exE) + apply hypsubst + apply (rule exI) + apply (rule refl) + apply (unfold UN_empty Un_empty_left) + apply (rule refl) + apply (rule trans) + apply (rule arg_cong2[OF _ refl, of _ _ "minus"]) + apply (rule UN_cong) + apply assumption + + apply (subst IImsupp_Diff, assumption+) + apply (subst FType.IImsupp_Diff) + apply (erule Int_subset_empty2) + apply (rule Un_upper2) + apply (unfold Un_Diff[symmetric]) + apply (rule arg_cong2[OF _ refl, of _ _ "minus"]) + apply (unfold UN_UN_flatten UN_Un_distrib[symmetric]) + apply (rule refl) + + apply (rule UN_cong) + apply assumption + + apply (unfold isVVr_def) + apply (erule exE) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (subst tvsubst_VVr) + apply (rule assms)+ + apply (unfold FVars_VVr UN_single UN_empty Un_empty_right) + apply (rule refl) + done +lemmas FVars_tvsubst = FVars_tvsubst1 FVars_tvsubst2 + +lemma SSupp_tvsubst_subset: + fixes \1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr \1| 1| 2| 1 \2 \ \1') \ SSupp VVr \1 \ SSupp VVr \1'" + apply (rule subsetI) + apply (unfold SSupp_def mem_Collect_eq Un_iff de_Morgan_conj[symmetric]) + apply (erule contrapos_nn) + apply (erule conjE) + apply (rule trans[OF comp_apply]) + apply (rotate_tac) + apply (erule subst[OF sym]) + apply (rule trans) + apply (rule tvsubst_VVr[OF assms]) + apply assumption + done + +lemma SSupp_tvsubst_bound: + fixes \1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr \1| 1| 2| 1'| 1 \2 \ \1')| 1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr \1| 1| 2| 1 \2 \ \1') \ IImsupp VVr FTVars \1 \ IImsupp TyVar FVars_FType \2 \ IImsupp VVr FTVars \1'" + apply (rule subset_trans) + apply (unfold IImsupp_def)[1] + apply (rule UN_mono[OF _ subset_refl]) + apply (rule SSupp_tvsubst_subset) + apply (rule assms)+ + apply (unfold comp_def) + apply (subst FVars_tvsubst) + apply (rule assms)+ + apply (unfold UN_Un Un_Union_image Un_assoc[symmetric]) + apply (rule subsetI) + apply (erule UnE)+ + apply (drule IImsupp_chain3[THEN set_mp, rotated -1, of _ FTVars _ _ \1']) + prefer 2 + apply (erule UnI1 UnI2 | rule UnI1)+ + apply (rule FVars_VVr) + (* repeated *) + apply (drule IImsupp_chain3[THEN set_mp, rotated -1, of _ FTVars _ _ \1']) + prefer 2 + apply (erule UnI1 UnI2 | rule UnI1)+ + apply (rule FVars_VVr) + (* repeated *) + apply (drule IImsupp_chain2[THEN set_mp, rotated -1, of _ FVars_FType _ _ \1']) + prefer 3 + apply (erule UnE)+ + apply (erule UnI1 UnI2 | rule UnI1)+ + apply (rule FType.Vrs_Inj FVars_VVr)+ + (* repeated *) + apply (drule IImsupp_chain2[THEN set_mp, rotated -1, of _ FVars_FType _ _ \1']) + prefer 3 + apply (erule UnE)+ + apply (erule UnI1 UnI2 | rule UnI1)+ + apply (rule FType.Vrs_Inj FVars_VVr)+ + done + +lemma IImsupp_tvsubst_bound: + fixes \1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr \1| 1| 2| 1'| 1 \2 \ \1')| '1 \'2 \1 \2 x + apply (rule FTerm.fresh_induct_param[of UNIV + "\t. FTVars (tvsubst_FTerm \1 \2 t) \ (avoiding_set1 \1 \2 \ avoiding_set1 \'1 \'2) \ avoiding_set1 (tvsubst_FTerm \'1 \'2 \ \1) (Sb_FType \'2 \ \2)" + "\t. FVars (tvsubst_FTerm \1 \2 t) \ avoiding_set2 \1 \ avoiding_set2 \'1 \ avoiding_set2 (tvsubst_FTerm \'1 \'2 \ \1)" + _ x, unfolded ball_UNIV, THEN spec, of "\t \. t = \ \ _ t", THEN mp[OF _ refl] + ]) + + apply ((assumption | rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs + FType.SSupp_Sb_bound infinite_UNIV var_class.UN_bound infinite_class.Un_bound IImsupp_tvsubst_bound + FType.IImsupp_Sb_bound SSupp_tvsubst_bound | (unfold IImsupp_def)[1])+)[2] + + apply (rule impI) + apply hypsubst + + apply (rule case_split[rotated]) + apply (subst tvsubst_not_is_VVr[rotated -1]) + apply assumption+ + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI2) + apply (rule UnI1) + apply assumption + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI1) + apply (rule UnI2) + apply assumption + apply assumption + + apply (rule trans) + apply (rule tvsubst_not_is_VVr[rotated -1]) + apply (unfold FTerm_pre.Map_map[symmetric])[1] + apply (erule not_is_VVr_Sb[rotated -1]) + apply (rule supp_id_bound cmin1 cmin2 card_of_Card_order | assumption | erule ordLess_ordLeq_trans)+ + (* REPEAT_DETERM *) + apply (subst FTerm_pre.set_Sb) + apply (rule supp_id_bound cmin1 cmin2 card_of_Card_order | assumption | erule ordLess_ordLeq_trans)+ + apply (subst FTerm_pre.set_map) + apply (rule supp_id_bound bij_id)+ + apply (unfold image_id) + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI2) + apply (rule UnI2) + apply assumption + apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id | assumption)+)+ + apply (unfold image_id) + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI2) + apply assumption + apply (subst noclash_FTerm_def) + apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id | assumption)+)+ + apply (unfold image_id) + apply (rule conjI) + apply (rule Int_subset_empty2) + apply assumption + apply (rule subsetI) + apply (rule UnI1)+ + apply (subst tvsubst_not_is_VVr, assumption+) + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI2) + apply (rule UnI1) + apply assumption + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI1) + apply (rule UnI2) + apply assumption + apply assumption + apply assumption + apply (unfold FTerm.FVars_ctor)[1] + apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id | assumption)+)+ + apply (unfold image_id) + apply (erule UnE) + apply (erule UnI1 UnI2 | assumption | rule UnI1)+ + + + apply (rule Int_subset_empty2) + apply assumption + apply (rule subsetI) + apply (rule UnI1)+ + apply (subst tvsubst_not_is_VVr, assumption+) + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI2) + apply (rule UnI1) + apply assumption + apply (erule Int_subset_empty2) + apply (rule subsetI) + apply (rule UnI1) + apply (rule UnI1) + apply (rule UnI2) + apply assumption + apply assumption + apply assumption + apply (unfold FTerm.FVars_ctor)[1] + apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id | assumption)+)+ + apply (unfold image_id) + apply (erule UnE) + apply (erule UnI1 UnI2 | assumption | rule UnI1)+ + + apply (subst tvsubst_not_is_VVr) + apply (assumption | rule SSupp_tvsubst_bound IImsupp_tvsubst_bound FType.SSupp_Sb_bound)+ + apply (erule Int_subset_empty2, rule Un_upper2)+ + apply assumption + apply assumption + apply (rule arg_cong[of _ _ FTerm_ctor]) + apply (unfold FTerm_pre.Map_map[symmetric])[1] + apply (subst FTerm_pre.Map_Sb[THEN fun_cong, unfolded comp_def]) + apply (rule supp_id_bound | assumption)+ + apply (unfold trans[OF comp_apply[symmetric] FTerm_pre.Map_comp[THEN fun_cong]])[1] + apply (rule trans) + apply (rule trans[OF comp_apply[symmetric] FTerm_pre.Sb_comp(1)[THEN fun_cong]]) + apply (rule supp_id_bound | assumption)+ + apply (unfold id_o o_id) + apply (unfold FTerm_pre.Map_map) + + apply (rule arg_cong[OF FTerm_pre.map_cong0]) + apply (rule supp_id_bound bij_id refl)+ + apply (unfold atomize_imp[symmetric]) + apply (rotate_tac -1) + apply (erule mp[rotated]) + subgoal premises prems + apply (rule impI) + apply (rule trans[OF comp_apply]) + apply (erule prems) + apply (rule refl UNIV_I)+ + done + apply (rotate_tac -1) + apply (erule mp[rotated]) + subgoal premises prems + apply (rule impI) + apply (rule trans[OF comp_apply]) + apply (erule prems) + apply (rule refl UNIV_I)+ + done + + apply (unfold isVVr_def) + apply (erule exE) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (unfold tvsubst_VVr) + apply (subst tvsubst_VVr) + apply (rule SSupp_tvsubst_bound IImsupp_tvsubst_bound FType.SSupp_Sb_bound | assumption)+ + apply (unfold comp_def) + apply (rule refl) + done + + apply (rule FTerm.FVars_bd)+ + apply (rule FVars_VVr)+ + apply (rule FVars_tvsubst; assumption)+ + + subgoal premises prems for \1 \2 \1' \2' t + apply (insert prems(7,8)) + apply (unfold atomize_all atomize_imp) + apply (rule FTerm.TT_fresh_induct[of "avoiding_set1 \1 \2 \ avoiding_set1 \1' \2'" "avoiding_set2 \1 \ avoiding_set2 \1'" _ t]) + apply (insert prems(1-6))[2] + + apply ((assumption | rule infinite_UNIV Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs + FType.SSupp_Sb_bound var_class.UN_bound infinite_class.Un_bound IImsupp_tvsubst_bound + FType.IImsupp_Sb_bound SSupp_tvsubst_bound | (unfold IImsupp_def)[1])+)[2] + + apply (unfold atomize_all[symmetric] atomize_imp[symmetric]) + subgoal premises inner_prems for x + apply (insert prems(1-6) inner_prems(3-5)) + apply (rule case_split[rotated]) + apply (subst tvsubst_not_is_VVr[rotated -1]) + apply assumption+ + apply (erule Int_subset_empty2, rule Un_upper1)+ + apply assumption + apply (subst tvsubst_not_is_VVr[rotated -1]) + apply assumption+ + apply (erule Int_subset_empty2, rule Un_upper2)+ + apply assumption + apply (rule arg_cong[of _ _ FTerm_ctor]) + apply (rule trans) + apply (rule FTerm_pre.Sb_cong[rotated -1]) + apply (rule inner_prems) + apply (unfold FTerm_pre.Map_map[symmetric] FTerm_pre.Vrs_Map)[1] + apply (unfold FTerm_pre.set_Vrs(1-2)[symmetric])[1] + apply (erule FTerm.FVars_intros) + apply (rule supp_id_bound refl | assumption)+ + + apply (rule arg_cong[OF FTerm_pre.map_cong0]) + apply (rule supp_id_bound bij_id refl)+ + apply (rotate_tac -1) + apply (erule distinct_prems_rl[rotated]) + apply (erule inner_prems) + (* REPEAT_DETERM *) + apply (rule case_split[of "_ \ _", rotated]) + apply (rule inner_prems) + apply (erule FTerm.FVars_intros) + apply assumption + apply assumption + apply (rotate_tac -1) + apply (drule disjoint_iff[THEN iffD1, THEN spec, THEN mp, rotated]) + apply assumption + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule trans) + apply (erule notin_SSupp) + apply (rule sym) + apply (erule notin_SSupp) + (* repeated *) + apply (rule case_split[of "_ \ _", rotated]) + apply (rule inner_prems) + apply (erule FTerm.FVars_intros) + apply assumption + apply assumption + apply (rotate_tac -1) + apply (drule disjoint_iff[THEN iffD1, THEN spec, THEN mp, rotated]) + apply assumption + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ + apply (rule trans) + apply (erule notin_SSupp) + apply (rule sym) + apply (erule notin_SSupp) + (* END REPEAT_DETERM *) + apply (rotate_tac -1) + apply (erule distinct_prems_rl[rotated]) + apply (erule inner_prems) + (* REPEAT_DETERM *) + apply (rule inner_prems) + apply (erule FTerm.FVars_intros) + apply assumption + (* repeated *) + apply (rule inner_prems) + apply (erule FTerm.FVars_intros) + apply assumption + (* END REPEAT_DETERM *) + + apply (unfold isVVr_def) + apply (erule exE) + apply (rotate_tac -1) + apply (erule distinct_prems_rl[rotated]) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (unfold tvsubst_VVr) + apply (rule inner_prems) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (unfold FVars_VVr) + apply (rule singletonI) + done + done + done +print_theorems + +mrsbnf "('tv, 'v) FTerm" and "'tv FType" + apply (rule ext) + subgoal for f1 f2 t + apply (rule FTerm.TT_fresh_induct[of "imsupp f1" "imsupp f2" _ t]) + apply (rule imsupp_supp_bound[THEN iffD2] infinite_UNIV | assumption)+ + apply (rule case_split[rotated]) + apply (rule sym) + apply (rule trans) + apply (erule tvsubst_not_is_VVr[rotated -1]) + apply (subst SSupp_Inj_comp, rule injI, erule FTerm.Inj_inj[THEN iffD1]) + apply assumption + + apply ((assumption | rule IImsupp_Inj_comp_bound2 FVars_VVr FType.Vrs_Inj injI + | erule FType.Inj_inj[THEN iffD1] FTerm.Inj_inj[THEN iffD1] + | subst IImsupp_Inj_comp SSupp_Inj_comp IImsupp_def comp_apply FVars_VVr UN_empty2 Un_empty_left + imsupp_absorb + )+)[5] + + apply (rule sym) + apply (rule trans) + apply (rule FTerm.vvsubst_cctor) + apply assumption+ + apply (rule sym) + apply (rule arg_cong[of _ _ FTerm_ctor]) + apply (unfold FTerm_pre.Map_map[symmetric])[1] + apply (rule trans) + apply (rule trans[OF comp_apply[symmetric] FTerm_pre.map_is_Sb(1)[symmetric, THEN fun_cong]]) + apply (rule supp_id_bound | assumption)+ + apply (rule sym) + apply (rule FTerm_pre.map_cong0) + apply (rule supp_id_bound bij_id | assumption)+ + apply (rule refl) + apply (unfold FTerm_pre.set_Vrs)[1] + apply (subst (asm) eta_compl_free) + apply (rule allI) + apply (rotate_tac -1) + apply (erule contrapos_nn) + apply (unfold isVVr_def VVr_def comp_def)[1] + apply (rule exI) + apply hypsubst + apply (rule refl) + apply (erule emptyE) + apply (rule refl)+ + apply assumption+ + + apply (unfold isVVr_def)[1] + apply (erule exE) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (rule sym) + apply (rule trans) + apply (rule tvsubst_VVr) + + apply ((assumption | rule IImsupp_Inj_comp_bound2 FVars_VVr FType.Vrs_Inj injI + | erule FType.Inj_inj[THEN iffD1] FTerm.Inj_inj[THEN iffD1] + | subst IImsupp_Inj_comp SSupp_Inj_comp IImsupp_def comp_apply FVars_VVr UN_empty2 Un_empty_left + imsupp_absorb + )+)[3] + + apply (subst VVr_def comp_apply)+ + apply (rule sym) + apply (rule trans) + apply (rule FTerm.vvsubst_cctor) + apply assumption+ + apply (unfold eta_set_empties noclash_FTerm_def) + apply (rule Int_empty_left conjI)+ + apply (rule arg_cong[OF eta_natural']) + apply (rule supp_id_bound bij_id | assumption)+ + done + apply (rule FType.map_is_Sb; assumption) + done +print_theorems + +(* Sugar theorems for substitution *) +definition App :: "('tv, 'v) FTerm \ ('tv, 'v) FTerm \ ('tv::var, 'v::var) FTerm" where + "App t1 t2 \ FTerm_ctor (Abs_FTerm_pre (Inl (Inr (t1, t2))))" +definition TyApp :: "('tv, 'v) FTerm \ 'tv FType \ ('tv::var, 'v::var) FTerm" where + "TyApp t T \ FTerm_ctor (Abs_FTerm_pre ((Inr (Inl (t, T)))))" +definition Lam :: "'v \ 'tv FType \ ('tv, 'v) FTerm \ ('tv::var, 'v::var) FTerm" where + "Lam x T t \ FTerm_ctor (Abs_FTerm_pre (Inr (Inr (Inl (x, T, t)))))" +definition TyLam :: "'tv \ ('tv, 'v) FTerm \ ('tv::var, 'v::var) FTerm" where + "TyLam a t \ FTerm_ctor (Abs_FTerm_pre (Inr (Inr (Inr (a, t)))))" + +lemma FTerm_subst: + fixes f1::"'v \ ('tv::var, 'v::var) FTerm" and f2::"'tv \ 'tv FType" + assumes "|SSupp VVr f1| IImsupp_FTerm2 f1 \ tvsubst_FTerm f1 f2 (Lam x T t) = Lam x (tvsubst_FType f2 T) (tvsubst_FTerm f1 f2 t)" + "a \ IImsupp_FTerm1 f1 \ (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2) \ tvsubst_FTerm f1 f2 (TyLam a t) = TyLam a (tvsubst_FTerm f1 f2 t)" + apply (unfold Var_def App_def TyApp_def Lam_def TyLam_def) + apply (unfold meta_eq_to_obj_eq[OF VVr_def, THEN fun_cong, unfolded comp_def, symmetric]) + apply (rule tvsubst_VVr) + apply (rule assms)+ + + apply (rule trans) + apply (rule tvsubst_not_is_VVr) + apply (rule assms)+ + apply (unfold set3_FTerm_pre_def sum.set_map prod.set_map UN_empty2 Un_empty_left Un_empty_right UN_singleton comp_def + Abs_FTerm_pre_inverse[OF UNIV_I] sum_set_simps UN_single UN_empty set4_FTerm_pre_def noclash_FTerm_def + ) + apply (rule Int_empty_left conjI)+ + apply (unfold isVVr_def VVr_def comp_def FTerm.TT_inject0)[1] + apply (rule notI) + apply (erule exE conjE)+ + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] sum.inject + )[1] + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (rule sum.distinct) + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] Sb_FTerm_pre_def id_def map_prod_simp bmv_defs + )[1] + apply (rule refl) + + apply (rule trans) + apply (rule tvsubst_not_is_VVr) + apply (rule assms)+ + apply (unfold set3_FTerm_pre_def sum.set_map prod.set_map UN_empty2 Un_empty_left Un_empty_right UN_singleton comp_def + Abs_FTerm_pre_inverse[OF UNIV_I] sum_set_simps UN_single UN_empty set4_FTerm_pre_def noclash_FTerm_def + ) + apply (rule Int_empty_left conjI)+ + apply (unfold isVVr_def VVr_def comp_def FTerm.TT_inject0)[1] + apply (rule notI) + apply (erule exE conjE)+ + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] + )[1] + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (rule sum.distinct) + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] Sb_FTerm_pre_def id_def map_prod_simp bmv_defs + )[1] + apply (unfold id_def[symmetric] FType.map_id) + apply (rule refl) + + apply (rule trans) + apply (rule tvsubst_not_is_VVr) + apply (rule assms)+ + apply (unfold set2_FTerm_pre_def set6_FTerm_pre_def set3_FTerm_pre_def sum.set_map prod.set_map UN_empty2 Un_empty_left Un_empty_right UN_singleton comp_def + Abs_FTerm_pre_inverse[OF UNIV_I] sum_set_simps UN_single UN_empty set4_FTerm_pre_def noclash_FTerm_def prod_set_simps + Un_absorb Un_assoc[symmetric] + ) + apply (rule Int_empty_left Int_empty_right conjI iffD2[OF disjoint_single] | assumption)+ + apply (unfold isVVr_def VVr_def comp_def FTerm.TT_inject0)[1] + + apply (rule notI) + apply (erule exE conjE)+ + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] + )[1] + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (rule sum.distinct) + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] Sb_FTerm_pre_def id_def map_prod_simp bmv_defs + )[1] + apply (unfold id_def[symmetric] FType.map_id) + apply (rule refl) + + apply (rule trans) + apply (rule tvsubst_not_is_VVr) + apply (rule assms)+ + apply (unfold set2_FTerm_pre_def set6_FTerm_pre_def set3_FTerm_pre_def sum.set_map prod.set_map UN_empty2 Un_empty_left Un_empty_right UN_singleton comp_def + Abs_FTerm_pre_inverse[OF UNIV_I] sum_set_simps UN_single UN_empty set4_FTerm_pre_def noclash_FTerm_def prod_set_simps + set1_FTerm_pre_def Un_absorb Un_assoc[symmetric] + ) + apply (rule Int_empty_left Int_empty_right conjI iffD2[OF disjoint_single] | assumption)+ + apply (unfold isVVr_def VVr_def comp_def FTerm.TT_inject0)[1] + apply (rule notI) + apply (erule exE conjE)+ + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] + )[1] + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (rule sum.distinct) + apply (unfold map_FTerm_pre_def comp_def Abs_FTerm_pre_inverse[OF UNIV_I] map_sum.simps prod.map_id + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] Sb_FTerm_pre_def id_def map_prod_simp bmv_defs + )[1] + apply (rule refl) + done + +local_setup \fn lthy => +let + +val fp_res = the (MRBNF_FP_Def_Sugar.fp_result_of lthy @{type_name FTerm}) +val mrsbnf = the (MRSBNF_Def.mrsbnf_of lthy @{type_name FTerm_pre}) +val mrbnf = the (MRBNF_Def.mrbnf_of lthy @{type_name FTerm}); + +open BNF_Util + +val x = TVSubst.create_tvsubst_of_mrsbnf + I fp_res mrsbnf mrbnf @{thm FTerm.vvsubst_cctor} @{thm FTerm.vvsubst_permute} [] @{binding tvsubst_FTerm'} [SOME { + eta = @{term "\ :: 'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre"}, + Inj = (@{term "Var :: 'v \ ('tv::var, 'v::var) FTerm"}, @{thm Var_def}), + tacs = { + eta_free = fn ctxt => rtac ctxt @{thm eta_free} 1, + eta_compl_free = fn ctxt => etac ctxt @{thm eta_compl_free} 1, + eta_inj = fn ctxt => etac ctxt @{thm eta_inj} 1, + eta_natural = fn ctxt => HEADGOAL (rtac ctxt @{thm eta_natural} THEN_ALL_NEW assume_tac ctxt), + eta_Sb = fn ctxt => HEADGOAL (etac ctxt @{thm eta_Sb[unfolded FTerm_pre.Map_map, rotated -1]} THEN_ALL_NEW assume_tac ctxt) + } + }] "BMV_Fixpoint.QREC_fixed_FTerm" lthy + +in lthy end\ + +end diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index e9331571..418cd1ab 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -3,6 +3,7 @@ theory BMV_Monad begin declare [[mrbnf_internals]] +declare [[ML_print_depth=1000]] binder_datatype 'a FType = TyVar 'a | TyApp "'a FType" "'a FType" @@ -17,80 +18,220 @@ abbreviation Inj_FType_1 :: "'tyvar::var \ 'tyvar FType" where "Inj_ abbreviation Sb_FType :: "('tyvar::var \ 'tyvar FType) \ 'tyvar FType \ 'tyvar FType" where "Sb_FType \ tvsubst_FType" abbreviation Vrs_FType_1 :: "'tyvar::var FType \ 'tyvar set" where "Vrs_FType_1 \ FVars_FType" -lemma SSupp_Inj_FType[simp]: "SSupp_FType Inj_FType_1 = {}" unfolding SSupp_FType_def tvVVr_tvsubst_FType_def TyVar_def tv\_FType_tvsubst_FType_def by simp -lemma IImsupp_Inj_FType[simp]: "IImsupp_FType Inj_FType_1 = {}" unfolding IImsupp_FType_def by simp -lemma SSupp_IImsupp_bound[simp]: - fixes \::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| | \'::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| \ \') \ SSupp_FType \ \ SSupp_FType \'" - unfolding SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def comp_def - apply (unfold TyVar_def[symmetric]) +binder_datatype 'a LM = + Var 'a + | Lst "'a list" + | App "'a LM" "'a LM" + | Lam x::'a t::"'a LM" binds x in t + +abbreviation "SSupp_LM \ SSupp Var" +abbreviation "IImsupp_LM h \ SSupp Var h \ IImsupp Var FVars_LM h" + +axiomatization Vrs_1 :: "'a::var LM \ 'a set" where + Vrs_1_simp1[simp]: "Vrs_1 (Var x) = {}" + and Vrs_1_simp2[simp]: "Vrs_1 (Lst xs) = set xs" + and Vrs_1_simp3[simp]: "Vrs_1 (App t1 t2) = Vrs_1 t1 \ Vrs_1 t2" + and Vrs_1_simp4[simp]: "Vrs_1 (Lam x t) = Vrs_1 t - {x}" +axiomatization Vrs_2 :: "'a::var LM \ 'a set" where + Vrs_2_simp1[simp]: "Vrs_2 (Var x) = {x}" + and Vrs_2_simp2[simp]: "Vrs_2 (Lst xs) = {}" + and Vrs_2_simp3[simp]: "Vrs_2 (App t1 t2) = Vrs_2 t1 \ Vrs_2 t2" + and Vrs_2_simp4[simp]: "Vrs_2 (Lam x t) = Vrs_2 t - {x}" + +axiomatization Sb_LM :: "('a::var \ 'a) \ ('a \ 'a LM) \ 'a LM \ 'a LM" where + Sb_LM_simp1[simp]: "Sb_LM f1 f2 (Var x) = f2 x" + and Sb_LM_simp2[simp]: "Sb_LM f1 f2 (Lst xs) = Lst (map f1 xs)" + and Sb_LM_simp3[simp]: "Sb_LM f1 f2 (App t1 t2) = App (Sb_LM f1 f2 t1) (Sb_LM f1 f2 t2)" + and Sb_LM_simp4[simp]: "x \ imsupp f1 \ x \ IImsupp_LM f2 \ Sb_LM f1 f2 (Lam x t) = Lam x (Sb_LM f1 f2 t)" + +lemma Vrs_Un: "FVars_LM t = Vrs_1 t \ Vrs_2 t" + apply (induction t rule: LM.induct) + apply auto + done + +lemma IImsupp_Diff_Vrs_1: "B \ IImsupp_LM h = {} \ (\a\A - B. Vrs_1 (h a)) = (\a\A. Vrs_1 (h a)) - B" + apply (rule UN_Diff_distrib'[of _ Var]) + apply (subst Vrs_1_simp1) + apply (rule subset_refl empty_subsetI) + apply (erule disjE) + apply (drule Int_emptyD) + apply assumption + apply (unfold IImsupp_def Un_iff de_Morgan_disj SSupp_def mem_Collect_eq not_not)[1] + apply (erule conjE) + apply assumption + apply (erule contrapos_np) + apply (rule trans[OF Int_commute]) + apply (erule Int_subset_empty2) + apply (unfold IImsupp_def SSupp_def comp_def Vrs_Un) apply (rule subsetI) - apply (unfold mem_Collect_eq) - apply simp - using assms(1) by force -lemma SSupp_comp_bound[simp]: - fixes \ \'::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| '| \ \')| ::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| \ Inj_FType_1 = \" - using assms by auto - -lemma Sb_comp_FType: - fixes \ \'::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| '| \ Sb_FType \' = Sb_FType (Sb_FType \ \ \')" - apply (rule ext) - apply (rule trans[OF comp_apply]) - subgoal for x - apply (binder_induction x avoiding: "IImsupp_FType \" "IImsupp_FType \'" "IImsupp_FType (Sb_FType \ \ \')" rule: FType.strong_induct) - using assms by (auto simp: IImsupp_FType_def FType.Un_bound FType.UN_bound FType.set_bd_UNIV) + +lemma IImsupp_Diff_Vrs_2: "B \ IImsupp_LM h = {} \ (\a\A - B. Vrs_2 (h a)) = (\a\A. Vrs_2 (h a)) - B" + apply (rule UN_Diff_distrib'[of _ Var]) + apply (subst Vrs_2_simp1) + apply (rule subset_refl empty_subsetI) + apply (erule disjE) + apply (drule Int_emptyD) + apply assumption + apply (unfold IImsupp_def Un_iff de_Morgan_disj SSupp_def mem_Collect_eq not_not)[1] + apply (erule conjE) + apply assumption + apply (erule contrapos_np) + apply (rule trans[OF Int_commute]) + apply (erule Int_subset_empty2) + apply (unfold IImsupp_def SSupp_def comp_def Vrs_Un) + apply (rule subsetI) + apply (rule UnI2) + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply (erule UnI2) done -lemma Vrs_Inj_FType: "Vrs_FType_1 (Inj_FType_1 a) = {a}" - by simp +lemma Vrs_1_Sb_LM: + fixes f1::"'a::var \ 'a" + assumes "|supp f1| (\x\Vrs_2 t. Vrs_1 (f2 x))" +proof (binder_induction t avoiding: "imsupp f1" "SSupp_LM f2" "IImsupp Var FVars_LM f2" rule: LM.strong_induct) + case Bound3 + then show ?case unfolding IImsupp_def + by (meson LM.set_bd_UNIV UN_bound assms(2)) +next + case (Lam x1 x2) + then show ?case + apply auto + using not_in_imsupp_same apply fastforce + using notin_SSupp apply fastforce + using imsupp_def supp_def apply fastforce + by (metis (mono_tags, lifting) IImsupp_def UN_iff Un_iff Vrs_1_simp1 Vrs_Un insert_iff notin_SSupp singletonD) +qed (auto simp: assms imsupp_supp_bound) -lemma Vrs_Sb_FType: - fixes \::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| x) = (\a\Vrs_FType_1 x. Vrs_FType_1 (\ a))" -proof (binder_induction x avoiding: "IImsupp_FType \" rule: FType.strong_induct) - case (TyAll x1 x2) - then show ?case using assms by (auto intro!: FType.IImsupp_Diff[symmetric]) -qed (auto simp: assms) +lemma Vrs_2_Sb_LM: + fixes f1::"'a::var \ 'a" + assumes "|supp f1| x\Vrs_2 t. Vrs_2 (f2 x))" +proof (binder_induction t avoiding: "imsupp f1" "SSupp_LM f2" "IImsupp Var FVars_LM f2" rule: LM.strong_induct) + case Bound3 + then show ?case unfolding IImsupp_def + by (meson LM.set_bd_UNIV UN_bound assms(2)) +next + case (Lam x1 x2) + then show ?case + apply (subst Sb_LM_simp4) + apply assumption+ + apply (unfold Vrs_2_simp4 Lam) + using IImsupp_Diff_Vrs_2[symmetric] apply blast + apply (rule IImsupp_Diff_Vrs_2[symmetric]) + by blast +qed (auto simp: assms imsupp_supp_bound infinite_UNIV) -lemma Sb_cong_FType: - fixes \ \'::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| '| a. a \ Vrs_FType_1 t \ \ a = \' a" - shows "Sb_FType \ t = Sb_FType \' t" -using assms(3) proof (binder_induction t avoiding: "IImsupp_FType \" "IImsupp_FType \'" rule: FType.strong_induct) - case (TyAll x1 x2) - then show ?case using assms apply auto - by (smt (verit, ccfv_threshold) CollectI IImsupp_FType_def SSupp_FType_def Un_iff) -qed (auto simp: assms(1-2)) +lemma FVars_LM_Sb_LM: +fixes \::"'a::var \ 'a" and \::"'a::var \ 'a LM" +assumes "|supp \| | \ t) = \ ` Vrs_1 t \ (\x\Vrs_2 t. FVars_LM (\ x))" +unfolding Vrs_Un apply(subst Vrs_1_Sb_LM) + subgoal using assms by auto + subgoal using assms by auto + subgoal apply(subst Vrs_2_Sb_LM) + subgoal using assms by auto + subgoal using assms by auto + subgoal by auto . . -(* *) +lemma IImsupp_o: +fixes g::"'a::var \ 'a" +assumes "|supp g| '| | ' \ \) \ imsupp g \ IImsupp_LM \' \ IImsupp_LM \" +unfolding IImsupp_def SSupp_def imsupp_def supp_def using assms apply safe + subgoal by auto + subgoal unfolding o_def apply(subst (asm) FVars_LM_Sb_LM) unfolding image_def + subgoal by simp + subgoal by simp + subgoal by simp (metis Vrs_Un LM.set(1) Sb_LM_simp1 UnCI emptyE insert_iff) . . -type_synonym ('var, 'tyvar, 'bvar, 'btyvar, 'rec, 'brec) FTerm_pre' = "('var + 'rec * 'rec + 'btyvar * 'brec) + ('bvar * 'tyvar FType * 'brec + 'rec * 'tyvar FType)" +lemma Vrs_1_bd: "|Vrs_1 t::'a::var set| 'a" + assumes "|supp g| '| | a. a \ Vrs_1 t \ f a = g a" "\a. a \ Vrs_2 t \ \ a = \' a" + shows "Sb_LM f \ t = Sb_LM g \' t" + using foo apply (binder_induction t avoiding: "imsupp g" "SSupp_LM \'" "IImsupp Var FVars_LM \'" "imsupp f" "SSupp_LM \" "IImsupp Var FVars_LM \" rule: LM.strong_induct) + apply (auto simp: imsupp_supp_bound infinite_UNIV assms LM.permute_id IImsupp_def) + apply (meson LM.FVars_bd_UNIVs UN_bound assms(2)) + apply (meson LM.FVars_bd_UNIVs UN_bound assms(4)) + by (metis not_in_imsupp_same notin_SSupp) +pbmv_monad "'b::var LM" + Sbs: Sb_LM + RVrs: Vrs_1 + Injs: Var + Vrs: Vrs_2 + bd: natLeq + apply (rule infinite_regular_card_order_natLeq) + + apply (rule ext) + subgoal for x + apply (rule LM.induct[of _ x]) + apply auto + apply (rule trans[OF Sb_LM_simp4]) + by (auto simp: imsupp_def supp_def IImsupp_def SSupp_def Var_def) + apply fastforce + + apply (rule ext) + apply (rule trans[OF comp_apply]) + subgoal premises prems for g \' f \ x + apply (binder_induction x avoiding: "imsupp g" "imsupp f" "SSupp_LM \" "IImsupp Var FVars_LM \" "SSupp_LM \'" "IImsupp Var FVars_LM \'" rule: LM.strong_induct) + apply (auto simp: imsupp_supp_bound infinite_UNIV prems IImsupp_def LM.set_bd_UNIV intro!: infinite_class.Un_bound var_class.UN_bound)[7] + apply (auto simp: prems) + apply (subst Sb_LM_simp4) + apply (rule contra_subsetD[OF imsupp_o]) + apply blast + apply (rule contra_subsetD[OF IImsupp_o]) + apply (rule prems)+ + apply blast + apply (rule refl) + done + + apply (rule Vrs_1_bd) + apply (rule Vrs_2_bd) + apply (rule Vrs_1_simp1) + apply (rule Vrs_2_simp1) + apply (rule Vrs_1_Sb_LM; assumption) + apply (rule Vrs_2_Sb_LM; assumption) + apply (rule Sb_LM_cong; assumption) + done +print_theorems + +lemma vvsubst_Sb: + fixes f::"'a::var \ 'a" + assumes "|supp f| f)" + apply (rule ext) + subgoal for x + apply (binder_induction x avoiding: "imsupp f" rule: LM.strong_induct) + apply (auto simp: imsupp_supp_bound assms) + apply (subst Sb_LM_simp4) + apply assumption + apply (unfold IImsupp_def SSupp_def comp_def LM.Inj_inj LM.set UN_singleton imsupp_def supp_def)[1] + apply blast + apply (rule refl) + done + done + +mrsbnf "'b::var LM" + apply (rule vvsubst_Sb; assumption) + apply (rule Vrs_Un) + done +print_theorems -end \ No newline at end of file +end diff --git a/operations/Composition.thy b/operations/Composition.thy index f5e68b14..a54f67a6 100644 --- a/operations/Composition.thy +++ b/operations/Composition.thy @@ -34,7 +34,6 @@ val name2 = "T2"; val rel = [[1,3], [1]]; \ -declare [[quick_and_dirty]] declare [[ML_print_depth=1000]] declare [[mrbnf_internals]] local_setup \fn lthy => @@ -71,9 +70,9 @@ let val _ = @{print} tys (* Step 2: Seal the pre-MRBNF with a typedef *) - val ((mrbnf1, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name1 ^ "_pre")) true (fst tys1) [] mrbnf1 lthy + val ((mrbnf1, _, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name1 ^ "_pre")) true (fst tys1) [] mrbnf1 NONE lthy val _ = @{print} "seal1" - val ((mrbnf2, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name2 ^ "_pre")) true (fst tys2) [] mrbnf2 lthy + val ((mrbnf2, _, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name2 ^ "_pre")) true (fst tys2) [] mrbnf2 NONE lthy val _ = @{print} "seal2" (* Step 3: Register the pre-MRBNF as a BNF in its live variables *) @@ -85,6 +84,4 @@ in lthy end print_theorems print_mrbnfs -declare [[quick_and_dirty=false]] - end \ No newline at end of file diff --git a/operations/Greatest_Fixpoint.thy b/operations/Greatest_Fixpoint.thy index cead3068..7fedf1a1 100644 --- a/operations/Greatest_Fixpoint.thy +++ b/operations/Greatest_Fixpoint.thy @@ -25,7 +25,6 @@ ML \ val rel = [[([], [0]), ([], [0, 1])]]; \ -declare [[quick_and_dirty]] declare [[ML_print_depth=1000]] declare [[mrbnf_internals]] local_setup \fn lthy => @@ -44,7 +43,7 @@ local_setup \fn lthy => val _ = @{print} "comp" (* Step 2: Seal the pre-MRBNF with a typedef *) - val ((mrbnf1, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name1 ^ "_pre")) true (fst tys1) [] mrbnf1 lthy + val ((mrbnf1, _, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name1 ^ "_pre")) true (fst tys1) [] mrbnf1 NONE lthy val _ = @{print} "seal" (* Step 3: Register the pre-MRBNF as a BNF in its live variables *) @@ -62,8 +61,6 @@ set3_term_pre := recursive occurences that bind variables set4_term_pre := recursive non-binding occurences *) -declare [[quick_and_dirty=false]] - lemmas infinite_UNIV = cinfinite_imp_infinite[OF term_pre.UNIV_cinfinite] (********************** BINDER FIXPOINT CONSTRUCTION **************************************) @@ -1809,4 +1806,4 @@ let in lthy end \ -end \ No newline at end of file +end diff --git a/operations/Least_Fixpoint.thy b/operations/Least_Fixpoint.thy index ed282651..bed82a48 100644 --- a/operations/Least_Fixpoint.thy +++ b/operations/Least_Fixpoint.thy @@ -6700,6 +6700,7 @@ val fp_res = { fp = BNF_Util.Least_FP, fresh_induct_param = @{thm fresh_induct_param}, fresh_induct = @{thm fresh_induct} }), + is_free_inducts = @{thms free1_raw_T1_free1_raw_T2.induct free2_raw_T1_free2_raw_T2.induct}, quotient_fps = [ { T = @{typ "('a::var, 'b::var, 'c::var, 'd) T1"}, ctor = @{term "T1_ctor :: _ \ ('a::var, 'b::var, 'c::var, 'd) T1"}, diff --git a/operations/Least_Fixpoint2.thy b/operations/Least_Fixpoint2.thy index 69b8be95..734f1405 100644 --- a/operations/Least_Fixpoint2.thy +++ b/operations/Least_Fixpoint2.thy @@ -25,7 +25,6 @@ val name1 = "term"; val rel = [[([], [0]), ([], [0, 1])]]; \ -declare [[quick_and_dirty]] declare [[ML_print_depth=1000]] declare [[mrbnf_internals]] local_setup \fn lthy => @@ -45,7 +44,7 @@ let val _ = @{print} "comp" (* Step 2: Seal the pre-MRBNF with a typedef *) - val ((mrbnf1, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name1 ^ "_pre")) true (fst tys1) [] mrbnf1 lthy + val ((mrbnf1, _, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name (name1 ^ "_pre")) true (fst tys1) [] mrbnf1 NONE lthy val _ = @{print} "seal" (* Step 3: Register the pre-MRBNF as a BNF in its live variables *) @@ -56,8 +55,6 @@ in lthy end print_theorems print_mrbnfs -declare [[quick_and_dirty=false]] - lemmas infinite_UNIV = cinfinite_imp_infinite[OF term_pre.UNIV_cinfinite] (********************** BINDER FIXPOINT CONSTRUCTION **************************************) @@ -2268,4 +2265,4 @@ lemma nnoclash_noclashs: apply (rule refl) done -end \ No newline at end of file +end diff --git a/operations/MRSBNF_Composition.thy b/operations/MRSBNF_Composition.thy new file mode 100644 index 00000000..6c9c8ff3 --- /dev/null +++ b/operations/MRSBNF_Composition.thy @@ -0,0 +1,361 @@ +theory MRSBNF_Composition + imports BMV_Composition + keywords "mrsbnf" :: thy_goal +begin + +consts map_T1 :: "('a \ 'a') \ ('b \ 'b) \ ('c \ 'c) \ ('d \ 'd') \ ('e \ 'e') \ ('g \ 'g) \ ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1 \ ('a', 'b, 'c, 'd', 'e', 'f, 'g) T1" +consts rel_T1 :: "('a \ 'a' \ bool) \ ('d \ 'd' \ bool) \ ('e \ 'e' \ bool) \ ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1 \ ('a', 'b, 'c, 'd', 'e', 'f, 'g) T1 \ bool" + +consts map_T2 :: "('a \ 'a) \ ('b => 'b) => ('d \ 'd) \ ('a, 'b, 'c, 'd) T2 \ ('a, 'b, 'c, 'd) T2" +consts set_1_T2 :: "('a, 'b, 'c, 'd) T2 \ 'a set" + +consts map_T3 :: "('a \ 'a) \ ('b \ 'b) \ ('c \ 'c) \ ('d \ 'd') \ ('e \ 'e) \ ('f \ 'f') \ ('a, 'b, 'c, 'd, 'e, 'f) T3 \ ('a, 'b, 'c, 'd', 'e, 'f') T3" +consts set_a_T3 :: "('a, 'b, 'c, 'd, 'e, 'f) T3 \ 'a set" +consts rel_T3 :: "('d \ 'd' \ bool) \ ('f \ 'f' \ bool) \ ('a, 'b, 'c, 'd, 'e, 'f) T3 \ ('a, 'b, 'c, 'd', 'e, 'f') T3 \ bool" + +consts map_T4 :: "('a \ 'a) \ ('b \ 'b) \ ('a, 'b) T4 \ ('a, 'b) T4" + +declare [[mrbnf_internals]] +mrbnf "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" +map: map_T1 +sets: + live: set_1_T1 + free: Vrs_1_T1 + free: Vrs_2_T1 + live: set_2_T1 + live: set_3_T1 + free: Vrs_3_T1 +bd: natLeq +rel: rel_T1 + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +mrbnf "('a, 'b, 'c, 'd) T2" + map: map_T2 + sets: + bound: set_1_T2 + free: Vrs_2_T2 + free: Vrs_1_T2 + bd: natLeq + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +mrbnf "('a, 'b, 'c, 'd, 'e, 'f) T3" + map: map_T3 + sets: + free: set_a_T3 + free: Vrs_3_T3 + free: Vrs_4_T3 + live: set_1_T3 + bound: set_2_T3 + live: set_3_T3 + bd: natLeq + rel: rel_T3 + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +local_setup \fn lthy => +let + open MRBNF_Def + val (mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I + [Free_Var, Free_Var, Free_Var, Free_Var, Bound_Var, Live_Var] + (the (MRBNF_Def.mrbnf_of lthy @{type_name T3})) + ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy) + val lthy = MRBNF_Def.register_mrbnf_raw "MRSBNF_Composition.T3'" mrbnf lthy + val (_, lthy) = MRBNF_Def.note_mrbnf_thms (MRBNF_Def.Note_All) I @{binding T3'} mrbnf lthy +in lthy end\ + +mrbnf "('a, 'b) T4" + map: map_T4 + sets: + free: Vrs_1_T4 + free: Vrs_2_T4 + bd: natLeq + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +ML_file \../Tools/mrsbnf_def.ML\ + +mrsbnf "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +mrsbnf "('a, 'b, 'c, 'd) T2" + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +mrsbnf T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ + done + +local_setup \fn lthy => +let + val Xs = map dest_TFree [@{typ 'a}, @{typ 'b}, @{typ 'c}, @{typ 'd}, @{typ 'e}, @{typ 'f}, @{typ 'g}, @{typ 'h}] + val ((mrbnf, tys), ((_, unfolds), lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Do_Inline (Binding.prefix_name o string_of_int) (fn xss => inter (op=) (flat xss) Xs) + (the (MRBNF_Def.mrbnf_of lthy @{type_name T1})) [ + the (MRBNF_Def.mrbnf_of lthy @{type_name T2}), + MRBNF_Comp.DEADID_mrbnf, + the (MRBNF_Def.mrbnf_of lthy "MRSBNF_Composition.T3'") + ] [@{typ 'f}] [ + [@{typ 'e}], + [@{typ "'f set"}], + [@{typ 'e}] + ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g"}] [ + [@{typ 'a}, @{typ 'b}, @{typ 'd}], + [], + [@{typ 'b}, @{typ 'a}, @{typ 'c}, @{typ 'd}, @{typ 'h}] + ] [] ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy) + + val defs = [("comp_defs", #map_unfolds unfolds, [])] + |> map (fn (thmN, thms, attrs) => (((Binding.name thmN, attrs), [(thms, [])]))); + val (_, lthy) = Local_Theory.notes defs lthy + + val lthy = MRBNF_Def.register_mrbnf_raw "MRSBNF_Composition.T" mrbnf lthy; + + val info = hd (Typedef.get_info lthy "BMV_Composition.T'"); + val ((mrbnf, info, (Ds, absT_info)), lthy) = MRBNF_Comp.seal_mrbnf I unfolds Binding.empty + true (fst tys) (fst tys) mrbnf (SOME ("BMV_Composition.T'", info)) lthy; + + val lthy = MRBNF_Def.register_mrbnf_raw "MRSBNF_Composition.T'" mrbnf lthy; +in lthy end +\ + +print_pbmv_monads + +mrsbnf T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3': "('b, 'a, 'c, 'd, 'e, 'h) T3" and "('a, 'c) T4" + apply (unfold comp_defs) + apply (rule trans) + apply (rule T1.map_is_Sb) + apply (assumption | rule supp_id_bound)+ + apply (unfold id_o o_id) + apply (rule sym) + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule trans) + apply (rule T1.Map_comp) + apply (unfold id_o o_id) + apply (rule ext) + apply (rule sym) + apply (rule T1.Map_cong) + apply (rule T2.map_is_Sb[THEN fun_cong]; assumption) + apply (rule refl) + apply (rule T3'.map_is_Sb[THEN fun_cong]; assumption) + + + apply (rule trans) + apply (rule trans[OF comp_assoc[symmetric]]) + apply (rule trans) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (rule T1.map_Sb) + apply (assumption | rule SSupp_Inj_bound)+ + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (unfold T1.Map_map)[1] + apply (rule T1.map_comp0[symmetric]) + apply (rule supp_id_bound)+ + apply (unfold id_o o_id) + apply (rule sym) + apply (rule trans) + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (unfold T1.Map_map)[1] + apply (rule T1.map_comp0[symmetric]) + apply (rule supp_id_bound)+ + apply (unfold id_o o_id) + apply (rule arg_cong2[of _ _ _ _ "(\)"]) + apply (unfold T1.Map_map[symmetric] T1.Map_Inj)[1] + apply (rule refl) + apply (rule sym) + apply (rule ext) + apply (rule T1.map_cong0) + apply (rule supp_id_bound)+ + apply (rule T2.map_Sb[THEN fun_cong]) + apply assumption+ + apply (rule refl)+ + apply (rule T3'.map_Sb[THEN fun_cong]) + apply assumption+ + apply (rule refl) + + apply (unfold T1.Map_map[symmetric])[1] + apply (rule T1.Map_Inj) + + subgoal for x + apply (subst T1.set_map, (rule supp_id_bound)+)+ + apply (unfold UN_empty2 Un_empty_left Un_empty_right Un_assoc[symmetric] + T3'.set_Vrs(1) (* need to filter reflexive theorems *) Un_Union_image + ) + apply (rule refl) + done + subgoal for x + apply (subst T1.set_map, (rule supp_id_bound)+)+ + apply (unfold UN_empty2 Un_empty_left Un_empty_right Un_assoc[symmetric] + T3'.set_Vrs(1) Un_Union_image + ) + apply (rule refl) + done + subgoal for x + apply (subst T1.set_map, (rule supp_id_bound)+)+ + apply (unfold UN_empty2 Un_empty_left Un_empty_right Un_assoc[symmetric] + T3'.set_Vrs(1) Un_Union_image + ) + apply (rule refl) + done + + subgoal + supply outer_set_maps = T1.set_map[where v="_::(('d, 'a, 'i, 'c) T2, 'a, 'b, 'h set, ('a, 'd, 'b, 'c, 'i, 'e) T3, 'g, 'h) T1"] + supply comp_apply' = comp_apply[of "_::(('d, 'a, 'i, 'c) T2, 'a, 'b, 'h set, + ('a, 'd, 'b, 'c, 'i, 'e) T3, 'g, 'h) T1 \ (('d, 'a, 'i, 'c) T2, 'a, 'b, 'h set, + ('a, 'd, 'b, 'c, 'i, 'e) T3, 'g, 'h) T1"] + apply (subst outer_set_maps, (rule supp_id_bound bij_id)+)+ + apply (unfold comp_apply' UN_empty2 Un_empty_right Un_empty_left image_id) + apply (subst T1.set_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold T1.Vrs_Map) + apply (unfold T1.Map_map) + apply (subst outer_set_maps, (rule supp_id_bound bij_id)+)+ + apply (unfold image_comp[unfolded comp_def] image_Un) + apply (subst T2.set_Sb T3'.set_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold Un_Union_image Union_Un_distrib UN_UN_flatten) + apply (unfold (* T1.set_Inj *) T1.Supp_Inj UN_empty UN_empty2 Un_empty_left Un_empty_right) + apply (rule set_eqI) + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ + apply ((rule conjI)+, assumption+)+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ + apply ((rule conjI)+, assumption+)+ + done + + + subgoal + supply outer_set_maps = T1.set_map[where v="_::(('d, 'a, 'i, 'c) T2, 'a, 'b, 'h set, ('a, 'd, 'b, 'c, 'i, 'e) T3, 'g, 'h) T1"] + supply comp_apply' = comp_apply[of "_::(('d, 'a, 'i, 'c) T2, 'a, 'b, 'h set, + ('a, 'd, 'b, 'c, 'i, 'e) T3, 'g, 'h) T1 \ (('d, 'a, 'i, 'c) T2, 'a, 'b, 'h set, + ('a, 'd, 'b, 'c, 'i, 'e) T3, 'g, 'h) T1"] + apply (subst outer_set_maps, (rule supp_id_bound bij_id)+)+ + apply (unfold comp_apply' UN_empty2 Un_empty_right Un_empty_left image_id) + apply (subst T1.set_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold T1.Vrs_Map) + apply (unfold T1.Map_map) + apply (subst outer_set_maps, (rule supp_id_bound bij_id)+)+ + apply (unfold image_comp[unfolded comp_def] image_Un) + apply (subst T2.set_Sb T3'.set_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold Un_Union_image Union_Un_distrib UN_UN_flatten) + apply (unfold (* T1.set_Inj *) T1.Supp_Inj UN_empty UN_empty2 Un_empty_left Un_empty_right) + apply (rule set_eqI) + apply (rule iffI) + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ + apply ((rule conjI)+, assumption+)+ + apply (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ + apply ((rule conjI)+, assumption+)+ + done + + apply (rule T2.map_is_Sb; assumption) + apply (rule T2.map_Sb; assumption) + apply (rule T2.map_Inj_raw; assumption) + apply (rule T2.set_Sb; assumption) + + apply (rule T3'.map_is_Sb; assumption) + apply (rule T3'.map_Sb; assumption) + apply (rule ext) + apply (rule trans[OF comp_apply]) + apply (rule trans) + apply (rule T3'.map_Inj) + apply (assumption | rule supp_id_bound bij_id)+ + apply (rule arg_cong[OF id_apply]) + apply (rule T3'.set_Vrs) + apply (rule T3'.set_Sb; assumption)+ + apply (rule T3'.map_is_Sb; assumption) + done +print_theorems + +(* Sealing of mrsbnf *) +mrsbnf "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T3': "('b, 'a, 'c, 'd, 'e, 'h) T3" and "('a, 'c) T4" + apply (unfold defs SSupp_type_copy[OF type_definition_T']) + + apply (rule type_copy_map_comp0 type_copy_map_cong0) + apply (rule type_definition_T') + apply (unfold comp_assoc[of Abs_T'] type_copy_Rep_o_Abs_o[OF type_definition_T'])[1] + apply (rule T.map_is_Sb[unfolded comp_defs]; assumption) + + apply (rule type_copy_Map_Sb) + apply (rule type_definition_T') + apply (rule type_definition_T') + apply (unfold comp_assoc[of Abs_T'] comp_assoc[of _ Rep_T'] type_copy_Rep_o_Abs_o[OF type_definition_T'])[1] + apply (rule T.map_Sb[unfolded comp_defs]; assumption) + + apply (rule trans[OF comp_assoc])+ + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (unfold type_copy_Rep_o_Abs_o[OF type_definition_T'])[1] + apply (rule T.map_Inj_raw[unfolded comp_defs]; assumption) + + apply (rule trans[OF comp_apply], rule T.set_Vrs[unfolded comp_defs])+ + + apply (unfold comp_apply[of Abs_T'] comp_apply[of _ Rep_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.set_Sb[unfolded comp_defs]; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (unfold comp_apply[of Abs_T'] comp_apply[of _ Rep_T'] Abs_T'_inverse[OF UNIV_I])[1] + apply (rule trans) + apply (rule T.set_Sb[unfolded comp_defs]; assumption) + apply (unfold comp_def)[1] + apply (rule refl) + + apply (rule T2.map_is_Sb; assumption) + apply (rule T2.map_Sb; assumption) + apply (rule T2.map_Inj_raw; assumption) + apply (rule T2.set_Sb; assumption) + + apply (rule T3'.map_is_Sb; assumption) + apply (rule T3'.map_Sb; assumption) + apply (rule ext) + apply (rule trans[OF comp_apply]) + apply (rule trans) + apply (rule T3'.map_Inj) + apply (assumption | rule supp_id_bound bij_id)+ + apply (rule arg_cong[OF id_apply]) + apply (rule T3'.set_Vrs) + apply (rule T3'.set_Sb; assumption)+ + apply (rule T3'.map_is_Sb; assumption) + done + +ML_file \../Tools/mrsbnf_comp.ML\ +local_setup \fn lthy => +let + val (deadid, lthy) = MRSBNF_Def.mrsbnf_of_mrbnf MRBNF_Comp.DEADID_mrbnf lthy + val ((mrsbnf, tys), ((bmv_unfolds, (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.compose_mrsbnfs BNF_Def.Do_Inline (K BNF_Def.Note_Some) + (Binding.suffix_name o string_of_int) (the (MRSBNF_Def.mrsbnf_of lthy @{type_name T1})) + [ + the (MRSBNF_Def.mrsbnf_of lthy @{type_name T2}), + deadid, + the (MRSBNF_Def.mrsbnf_of lthy "MRSBNF_Composition.T3'") + ] [@{typ 'f}] [ + [@{typ 'e}], + [@{typ "'g::var"}], + [@{typ 'e}] + ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g::var"}] [ + [@{typ "'a"}, @{typ 'b}, @{typ 'd}], + [], + [@{typ 'b}, @{typ 'a}, @{typ 'c}, @{typ 'd}, @{typ 'h}] + ] [] (distinct (op=) o flat) (([], (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy) + + val ((mrsbnf, _), lthy) = MRSBNF_Comp.seal_mrsbnf I (bmv_unfolds, mrbnf_unfolds) @{binding "T''"} + (subtract ((op=) o apply2 (fst o dest_TFree)) (fst tys) [@{typ 'a}, @{typ 'b}, @{typ 'c}, @{typ 'd}, @{typ 'e}, @{typ 'f}, @{typ "'g"}, @{typ 'h}]) + (fst tys) mrsbnf NONE lthy; + + val _ = @{print} mrsbnf +in lthy end\ + +end \ No newline at end of file diff --git a/operations/Sugar.thy b/operations/Sugar.thy index c3b88e9e..3b3708cf 100644 --- a/operations/Sugar.thy +++ b/operations/Sugar.thy @@ -812,13 +812,11 @@ val T1_model = { SOME (@{term "eta11"}, { eta_free = fn ctxt => resolve_tac ctxt @{thms eta_frees} 1, eta_inj = fn ctxt => eresolve_tac ctxt @{thms eta_injs} 1, - eta_compl_free = fn ctxt => eresolve_tac ctxt @{thms eta_compl_frees} 1, eta_natural = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms eta_naturals} THEN_ALL_NEW assume_tac ctxt) }), SOME (@{term "eta12"}, { eta_free = fn ctxt => resolve_tac ctxt @{thms eta_frees} 1, eta_inj = fn ctxt => eresolve_tac ctxt @{thms eta_injs} 1, - eta_compl_free = fn ctxt => eresolve_tac ctxt @{thms eta_compl_frees} 1, eta_natural = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms eta_naturals} THEN_ALL_NEW assume_tac ctxt) }) ] @@ -829,7 +827,6 @@ val T2_model = { SOME (@{term "eta21"}, { eta_free = fn ctxt => resolve_tac ctxt @{thms eta_frees} 1, eta_inj = fn ctxt => eresolve_tac ctxt @{thms eta_injs} 1, - eta_compl_free = fn ctxt => eresolve_tac ctxt @{thms eta_compl_frees} 1, eta_natural = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms eta_naturals} THEN_ALL_NEW assume_tac ctxt) }), NONE @@ -837,26 +834,6 @@ val T2_model = { }; \ -ML_file \../Tools/mrbnf_tvsubst.ML\ - -local_setup \fn lthy => -let - val (res', lthy) = MRBNF_TVSubst.create_tvsubst_of_mrbnf I res [T1_model, T2_model] "Recursor.QREC_cmin_fixed" lthy; - - val notes = [ - ("VVr_defs", maps (map snd o #VVrs) res'), - ("tvsubst_VVrs", maps #tvsubst_VVrs res'), - ("tvsubst_not_is_VVr", map #tvsubst_cctor_not_isVVr res'), - ("isVVrs", maps #isVVrs res') - ] |> (map (fn (thmN, thms) => - ((Binding.name thmN, []), [(thms, [])]) - )); - - val (noted, lthy) = Local_Theory.notes notes lthy - val _ = @{print} res' -in lthy end\ -print_theorems - lemmas prod_sum_simps = prod.set_map sum.set_map prod_set_simps sum_set_simps UN_empty UN_empty2 Un_empty_left Un_empty_right UN_singleton comp_def map_sum.simps map_prod_simp UN_single @@ -1114,332 +1091,4 @@ lemma permute_simps[simp]: apply (rule refl) done -lemma tvsubst_simps[simp]: - fixes h1::"'a::var \ ('a, 'b::var, 'c::var, 'd) T1" and h2::"'b \ ('a, 'b, 'c, 'd) T1" - and h3::"'a \ ('a, 'b, 'c, 'd) T2" - assumes "|SSupp11_T1 h1| IImsupp11_1_T1 h1 \ IImsupp12_1_T1 h2 \ IImsupp2_1_T2 h3 \ tvsubst_T1 h1 h2 h3 (BFree_T1 a xs) = BFree_T1 a xs" - "a \ IImsupp11_1_T1 h1 \ IImsupp12_1_T1 h2 \ IImsupp2_1_T2 h3 \ tvsubst_T1 h1 h2 h3 (Lam_T1 a x1) = Lam_T1 a (tvsubst_T1 h1 h2 h3 x1)" - "b \ IImsupp11_2_T1 h1 \ IImsupp12_2_T1 h2 \ IImsupp2_2_T2 h3 \ tvsubst_T1 h1 h2 h3 (TyLam_T1 b x1) = TyLam_T1 b (tvsubst_T1 h1 h2 h3 x1)" - "tvsubst_T1 h1 h2 h3 (Ext_T1 c) = Ext_T1 c" - - "tvsubst_T2 h1 h2 h3 (Var_T2 a) = h3 a" - "tvsubst_T2 h1 h2 h3 (TyVar_T2 b) = TyVar_T2 b" - "tvsubst_T2 h1 h2 h3 (App_T2 x1 x2) = App_T2 (tvsubst_T1 h1 h2 h3 x1) (tvsubst_T2 h1 h2 h3 x2)" - "a \ IImsupp11_1_T1 h1 \ IImsupp12_1_T1 h2 \ IImsupp2_1_T2 h3 \ tvsubst_T2 h1 h2 h3 (Lam_T2 a xs2) = Lam_T2 a (map (tvsubst_T1 h1 h2 h3) xs2)" - "b \ IImsupp11_2_T1 h1 \ IImsupp12_2_T1 h2 \ IImsupp2_2_T2 h3 \ b \ FVars_T22 x2 \ tvsubst_T2 h1 h2 h3 (TyLam_T2 b x2) = TyLam_T2 b (tvsubst_T2 h1 h2 h3 x2)" - "tvsubst_T2 h1 h2 h3 (Ext_T2 d x1) = Ext_T2 d (tvsubst_T1 h1 h2 h3 x1)" - apply (unfold T1_ctors_defs T2_ctors_defs) - - subgoal - apply (unfold VVr_defs[symmetric]) - (* EVERY *) - apply (rule tvsubst_VVrs) - apply (rule assms)+ - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T1_pre_set_defs isVVrs VVr_defs Abs_T1_pre_inverse[OF UNIV_I] noclash_T1_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* repeated *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric]) - (* EVERY *) - apply (rule tvsubst_VVrs) - apply (rule assms)+ - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T1_pre_set_defs isVVrs VVr_defs Abs_T1_pre_inverse[OF UNIV_I] noclash_T1_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* repeated *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T1_pre_set_defs isVVrs VVr_defs Abs_T1_pre_inverse[OF UNIV_I] noclash_T1_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* repeated *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T1_pre_set_defs isVVrs VVr_defs Abs_T1_pre_inverse[OF UNIV_I] noclash_T1_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* repeated *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T1_pre_set_defs isVVrs VVr_defs Abs_T1_pre_inverse[OF UNIV_I] noclash_T1_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* repeated *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T1_pre_set_defs isVVrs VVr_defs Abs_T1_pre_inverse[OF UNIV_I] noclash_T1_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* repeated *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T1_pre_def Abs_T1_pre_inverse[OF UNIV_I] Abs_T1_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric]) - (* EVERY *) - apply (rule tvsubst_VVrs) - apply (rule assms)+ - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T2_pre_set_defs isVVrs VVr_defs Abs_T2_pre_inverse[OF UNIV_I] noclash_T2_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T2_pre_def Abs_T2_pre_inverse[OF UNIV_I] Abs_T2_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T2_pre_set_defs isVVrs VVr_defs Abs_T2_pre_inverse[OF UNIV_I] noclash_T2_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T2_pre_def Abs_T2_pre_inverse[OF UNIV_I] Abs_T2_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T2_pre_set_defs isVVrs VVr_defs Abs_T2_pre_inverse[OF UNIV_I] noclash_T2_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T2_pre_def Abs_T2_pre_inverse[OF UNIV_I] Abs_T2_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T2_pre_set_defs isVVrs VVr_defs Abs_T2_pre_inverse[OF UNIV_I] noclash_T2_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T2_pre_def Abs_T2_pre_inverse[OF UNIV_I] Abs_T2_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - (* repeated *) - subgoal - apply (unfold VVr_defs[symmetric])? - (* ORELSE *) - apply (rule trans) - apply (rule tvsubst_not_is_VVr) - apply (rule assms)+ - apply (unfold prod_sum_simps T2_pre_set_defs isVVrs VVr_defs Abs_T2_pre_inverse[OF UNIV_I] noclash_T2_def) - apply (rule Int_empty_left Int_empty_right iffD2[OF disjoint_single] iffD2[OF notin_empty_eq_True TrueI] conjI assms - | assumption)+ - (* REPEAT_DETERM *) - apply (rule notI) - apply (erule exE) - apply (drule TT_inject0s[THEN iffD1]) - apply (erule exE conjE)+ - apply (unfold comp_def map_sum.simps map_prod_simp sum.inject map_T2_pre_def Abs_T2_pre_inverse[OF UNIV_I] Abs_T2_pre_inject[OF UNIV_I UNIV_I]) - apply (erule sum.distinct[THEN notE]) - (* END REPEAT_DETERM *) - apply (unfold map_id0_nesting)? - apply (unfold id_def)? - apply (rule refl) - done - done - -end \ No newline at end of file +end diff --git a/thys/Classes.thy b/thys/Classes.thy index b686cc87..3b253f13 100644 --- a/thys/Classes.thy +++ b/thys/Classes.thy @@ -1,5 +1,5 @@ theory Classes - imports "Prelim.Prelim" + imports "Prelim.Prelim" Support begin ML_file \../Tools/mrbnf_util.ML\ @@ -96,11 +96,32 @@ local_setup \ #> Var_Classes.register_class_for_bound @{class covar} @{term "card_suc natLeq"} \ -(* Theorems *) +(* Theorems *) lemma supp_comp_bound_var: assumes bound: "|supp f| f)| |A| |supp (f::'a::var \ 'a)| + (\a. Vrs (Inj a) = {a}) \ |IImsupp Inj Vrs (Inj \ f)| a. Vrs (Inj a) = {}) \ |IImsupp Inj Vrs (Inj \ f)| |SSupp Inj f| x. |Vrs x| |IImsupp Inj Vrs (Inj(x := t))| a z = z \ (a \ b z = z \ a z = b z" by simp lemma not_imageI: "bij f \ a \ A \ f a \ f ` A" by (force simp: bij_implies_inject) +lemma Un_forward: "a \ A \ B \ (a \ A \ a \ C) \ (a \ B \ a \ D) \ a \ C \ D" + by blast +(* TODO: Remove *) lemma Un_bound: assumes inf: "infinite (UNIV :: 'a set)" and "|A1| A = {} \ x \ A" lemma finite_singleton: "finite {x}" by blast +lemma UN_Diff_distrib: +assumes "(\a. a \ B \ V (h a) \ B \ {} \ V (h a) \ {a})" +shows "(\a\A - B. V (h a)) = (\a\A. V (h a)) - B" +using assms apply safe + apply blast + apply (metis Int_emptyD singletonD subset_eq) + by fastforce + +lemma UN_Diff_distrib': + assumes "\a. V (g a) \ {a}" "\a. a \ B \ V (h a) \ B \ {} \ h a = g a" + shows "(\a\A - B. V (h a)) = (\a\A. V (h a)) - B" +apply(rule UN_Diff_distrib) using assms by metis + lemma ex_avoiding_bij: fixes f :: "'a \ 'a" and I D A :: "'a set" assumes "|supp f| {} \ |A| \(f::'a::infinite \ 'a) g. bij f \ |supp f| bij g \ |supp g| f ` A \ g ` A" +proof - + assume a: "A \ {}" "|A| A" by blast + obtain y where "x \ y" "y \ A" by (metis \x \ A\ a(2) exists_fresh) + obtain z where "z \ y" "z \ A" + by (metis UNIV_eq_I Un_empty_left Un_insert_left a(2) card_of_Un_singl_ordLess_infinite infinite_UNIV insertCI ordLess_irreflexive) + + let ?f = "x \ y" + let ?g = "x \ z" + + have "?f ` A \ ?g ` A" + by (metis Swapping.bij_swap \x \ A\ \z \ y\ \z \ A\ imageI image_in_bij_eq swap_fresh swap_inv swap_simps(3)) + then show ?thesis + apply - + apply (rule exI[of _ ?f]) + apply (rule exI[of _ ?g]) + by (simp add: infinite_UNIV) +qed + lemma id_on_empty: "id_on {} f" unfolding id_on_def by simp @@ -307,9 +343,6 @@ lemma eq_bij_betw_prems: lemma id_on_eq: "id_on A f \ id_on B g \ A = B \ x \ A \ f x = g x" unfolding id_on_def by simp -lemma notin_supp: "x \ supp f \ f x = x" - unfolding supp_def by blast - lemmas imsupp_id_empty = trans[OF arg_cong2[OF imsupp_id refl, of "(\)"] Int_empty_left] lemma pred_fun_If: "pred_fun P Q f \ pred_fun P Q (\x. if P x then f x else undefined)" @@ -346,7 +379,7 @@ lemma induct_implies_equal_eq: "HOL.induct_implies (HOL.induct_equal x y) P = (x lemma large_imp_infinite: "natLeq \o |UNIV::'a set| \ infinite (UNIV::'a set)" using infinite_iff_natLeq_ordLeq by blast -lemma insert_bound: "infinite (UNIV::'a set) \ |insert x A| |A| |insert x A| |A| id_on A g \ id_on A (f \ g)" @@ -381,6 +414,17 @@ lemma conj_mp: "(P1 \ Q1) \ (P2 \ Q2) \ B| |A| |B| Rep \ (Abs \ f) = f" + by (metis comp_assoc fun.map_id type_copy_Rep_o_Abs) +lemma type_copy_Abs_o_Rep_o: "type_definition Rep Abs UNIV \ Abs \ (Rep \ f) = f" + by (simp add: type_definition_def type_copy_Rep_o_Abs_o) + +lemma type_copy_Map_Sb: "type_definition Rep Abs UNIV \ type_definition Rep' Abs' UNIV \ Map \ Sb = Sb' \ Map \ Abs' \ Map \ Rep \ (Abs \ Sb \ Rep) = Abs' \ Sb' \ Rep' \ (Abs' \ Map \ Rep)" + by (metis (no_types, lifting) rewriteR_comp_comp type_copy_Rep_o_Abs_o) + ML_file \../Tools/mrbnf_fp_def_sugar.ML\ ML_file \../Tools/mrbnf_fp.ML\ diff --git a/thys/MRBNF_Recursor.thy b/thys/MRBNF_Recursor.thy index 84df7336..31145584 100644 --- a/thys/MRBNF_Recursor.thy +++ b/thys/MRBNF_Recursor.thy @@ -3,7 +3,10 @@ theory MRBNF_Recursor keywords "binder_datatype" :: thy_defn and "binder_codatatype" :: thy_defn and "binder_inductive" :: thy_goal_defn - and "binds" + and "binds" + and "print_pbmv_monads" :: diag + and "pbmv_monad" :: thy_goal + and "mrsbnf" :: thy_goal begin context begin @@ -34,10 +37,19 @@ lemma neq_equiv[equiv]: "bij f \ f a \ f b \ A \ B \ (x \ A \ y \ C) \ (x \ B \ y \ D) \ y \ C \ D" by blast +lemma nested_cong: "f x = f' x \ x = x' \ f x = f' x'" + by simp + ML_file \../Tools/mrbnf_vvsubst.ML\ -ML_file \../Tools/mrbnf_tvsubst.ML\ +ML_file \../Tools/bmv_monad_tacs.ML\ +ML_file \../Tools/bmv_monad_def.ML\ +ML_file \../Tools/mrsbnf_def.ML\ +ML_file \../Tools/mrsbnf_comp.ML\ + +ML_file \../Tools/binder_sugar.ML\ +ML_file \../Tools/tvsubst.ML\ ML_file \../Tools/mrbnf_sugar.ML\ context begin diff --git a/thys/Prelim/Prelim.thy b/thys/Prelim/Prelim.thy index 583efa6b..9af652cd 100644 --- a/thys/Prelim/Prelim.thy +++ b/thys/Prelim/Prelim.thy @@ -509,6 +509,12 @@ lemma supp_inv_bound: unfolding supp_inv[OF b] using s card_of_image ordLeq_ordLess_trans by blast +lemma insert_bound: "Cinfinite r \ |A| |insert x A| |{x}| |B| Cinfinite r \ |A \ B| |A| (\a. a \ A \ |B a| |\(B ` A)| infinite_regular_card_order p \ |x| |x| A R" + shows R +proof (cases "r1 nat" where @@ -1003,4 +1028,9 @@ qed lemma image_inv_iff: "bij f \ (A = f ` B) = (inv f ` A = B)" by force +lemma image_const_empty: "x \ y \ (\_. x) ` A = (\_. y) ` B \ A = {} \ B = {}" + by fast +lemma cong': "f x = g x \ x = y \ f x = g y" + by simp + end \ No newline at end of file diff --git a/thys/Support.thy b/thys/Support.thy new file mode 100644 index 00000000..3605e9a7 --- /dev/null +++ b/thys/Support.thy @@ -0,0 +1,195 @@ +theory Support + imports "Prelim.Prelim" +begin + +lemma notin_supp: "x \ supp f \ f x = x" + unfolding supp_def by blast +lemma notin_imsupp: "x \ imsupp f \ f x = x" + unfolding imsupp_def notin_supp + by (simp add: not_in_supp_alt) + +lemma imsupp_absorb[simp]: "supp f \ imsupp f = imsupp f" + unfolding imsupp_def by blast + +definition SSupp :: "('a \ 't) \ ('a \ 't) \ 'a set" where + "SSupp Inj \ \f. { a. f a \ Inj a }" + +definition IImsupp :: "('a \ 't) \ ('t \ 'b set) \ ('a \ 't) \ 'b set" where + "IImsupp Inj Vr \ \\. (\a\SSupp Inj \. Vr (\ a))" + +lemma in_SSupp: "\ a \ Inj a \ a \ SSupp Inj \" + unfolding SSupp_def by blast +lemma in_IImsupp: "\ a \ Inj a \ b \ Vrs (\ a) \ b \ IImsupp Inj Vrs \" + unfolding IImsupp_def SSupp_def by blast + +lemma SSupp_Inj[simp]: "SSupp Inj Inj = {}" + unfolding SSupp_def by simp + +lemma SSupp_Inj_comp[simp]: "inj Inj \ SSupp Inj (Inj \ f) = supp f" + unfolding SSupp_def supp_def using injD by fastforce +lemma IImsupp_Inj_comp[simp]: "inj Inj \ (\a. FVars (Inj a) = {a}) \ SSupp Inj (Inj \ f) \ IImsupp Inj FVars (Inj \ f) = imsupp f" + unfolding IImsupp_def SSupp_def imsupp_def supp_def comp_def using injD + by (smt (verit, ccfv_SIG) Collect_cong UNION_singleton_eq_range image_cong) + +lemma IImsupp_Inj[simp]: "IImsupp Inj Vr Inj = {}" + unfolding IImsupp_def by simp + +lemma IImsupp_triv_subset: "SSupp Inj' (f \ g) \ SSupp Inj g \ (\a. Vrs' (f (g a)) \ Vrs (g a)) \ IImsupp Inj' Vrs' (f \ g) \ IImsupp Inj Vrs g" + unfolding IImsupp_def SSupp_def by auto + +lemma SSupp_Inj_bound[simp]: "|SSupp Inj Inj| |SSupp Inj Inj| insert x (SSupp Inj f)" + by (simp add: SSupp_def subset_eq) + +lemma IImsupp_fun_upd_subset: + "IImsupp Inj (Vrs::_ \ 'a set) (f(x := t)) \ insert x (Vrs t \ IImsupp Inj Vrs f)" + "IImsupp Inj (Vrs2:: _ \ 'b set) (g(x := t)) \ Vrs2 t \ IImsupp Inj Vrs2 g" + unfolding IImsupp_def + apply (smt (verit) SSupp_fun_upd_subset UN_iff UnCI fun_upd_apply insert_iff subset_eq) + by (smt (verit, ccfv_threshold) SSupp_fun_upd_subset UN_iff UnCI fun_upd_apply insert_iff subset_eq) + +lemma SSupp_fun_upd_bound[simp]: "Cinfinite r \ |SSupp Inj (f(x := t))| |SSupp Inj f| x. Vrs1 x \ Vrs2 x) \ = IImsupp Inj Vrs1 \ \ IImsupp Inj Vrs2 \" + unfolding IImsupp_def by blast + +lemma SSupp_comp_subset: "SSupp Inj (g \ f) \ SSupp Inj g \ supp f" +proof (rule subsetI, unfold SSupp_def mem_Collect_eq Un_iff comp_apply) + fix x + assume a: "g (f x) \ Inj x" + show "g x \ Inj x \ x \ supp f" + proof (cases "x \ supp f") + case False + then show ?thesis using a notin_supp by metis + qed blast +qed + +lemma SSupp_comp_bound: "Cinfinite r \ |SSupp Inj g| |supp f| |SSupp Inj (g \ f)| SSupp (Abs \ Inj) \ = SSupp Inj (Rep \ \)" + unfolding SSupp_def by (metis UNIV_I comp_apply type_definition_def) + +lemma IImsupp_type_copy: "type_definition Rep Abs UNIV \ IImsupp (Abs \ Inj) (Vrs \ Rep) \ = IImsupp Inj Vrs (Rep \ \)" + unfolding IImsupp_def using SSupp_type_copy by fastforce + +lemma notin_SSupp: "a \ SSupp Inj f \ f a = Inj a" + unfolding SSupp_def by blast + +lemma IImsupp_chain1: + assumes "\a. Vrs2 (Inj2 a) = {a}" "\1 = \' \ \1 = \2" + shows "(\x\SSupp Inj2 \1. \x\Vrs2 (\' x). Vrs2 (\2 x)) \ IImsupp Inj2 Vrs2 \2 \ IImsupp Inj2 Vrs2 \'" + apply (unfold IImsupp_def) + apply (rule subsetI) + apply (erule UN_E)+ + subgoal for x y z + apply (rule case_split[of "z \ SSupp Inj2 \2"]) + apply blast + apply (drule notin_SSupp) + apply (simp only:) + apply (subst (asm) assms) + apply (drule singletonD) + apply hypsubst_thin + apply (rule case_split[of "y \ SSupp Inj2 \'"]) + apply (rule UnI2) + apply (rule UN_I) + apply assumption + apply assumption + apply (drule notin_SSupp) + apply (simp only:) + apply (subst (asm) assms) + apply (drule singletonD) + apply hypsubst_thin + apply (rule UnI1) + apply (rule UN_I) + using assms(2) + apply (metis (mono_tags, lifting) SSupp_def mem_Collect_eq) + apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) + apply (rule arg_cong[of _ _ Vrs2]) + apply assumption + apply (subst assms) + apply (rule singletonI) + done + done + +lemma IImsupp_chain2: + assumes "\a. Vrs2 (Inj2 a) = {a}" "\a. Vrs3 (Inj1 a) = {}" + shows "(\x\SSupp Inj1 \1. \x\Vrs3 (\' x). Vrs2 (\2 x)) \ IImsupp Inj2 Vrs2 \2 \ IImsupp Inj1 Vrs3 \'" + apply (unfold IImsupp_def) + apply (rule subsetI) + apply (erule UN_E)+ + subgoal for x y z + apply (rule case_split[of "z \ SSupp Inj2 \2"]) + apply blast + apply (drule notin_SSupp) + apply (simp only:) + apply (subst (asm) assms) + apply (drule singletonD) + apply hypsubst_thin + apply (rule case_split[of "y \ SSupp Inj1 \'"]) + apply (rule UnI2) + apply (rule UN_I) + apply assumption + apply assumption + apply (drule notin_SSupp) + apply (simp only:) + apply (subst (asm) assms) + apply (erule emptyE) + done + done + +lemma IImsupp_chain3: + assumes "\a. Vrs2 (Inj2 a) = {}" + shows "(\x\SSupp Inj1 \1. \x\Vrs3 (\' x). Vrs2 (\2 x)) \ IImsupp Inj2 Vrs2 \2" + apply (unfold IImsupp_def) + apply (rule subsetI) + apply (erule UN_E)+ + subgoal for x y z + apply (rule case_split[of "z \ SSupp Inj2 \2"]) + apply blast + apply (drule notin_SSupp) + apply (simp only:) + apply (subst (asm) assms) + apply (erule emptyE) + done + done + +lemma IImsupp_chain4: + assumes "\a. Vrs (Inj a) = {}" + shows "h ` (\x\SSupp Inj \2. Vrs (\' x)) \ imsupp h \ IImsupp Inj Vrs \'" + apply (rule subsetI) + apply (erule imageE) + apply hypsubst + subgoal for _ x + apply (rule case_split[of "h x = x"]) + apply (rule UnI2) + apply (unfold IImsupp_def)[1] + apply (rule iffD2[OF arg_cong2[OF _ refl, of _ _ "(\)"]]) + apply assumption + apply (erule UN_E) + apply (erule thin_rl) + subgoal for y + apply (rule case_split[of "y \ SSupp Inj \'"]) + apply (rule UN_I) + apply assumption + apply assumption + apply (drule notin_SSupp) + apply (simp only:) + apply (subst (asm) assms) + apply (erule emptyE) + done + apply (rule UnI1) + apply (unfold imsupp_def supp_def) by blast + done + +end \ No newline at end of file