From 5cf9e6fb04d34c0bb6df346bd612fe43325c089c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 10 Dec 2024 09:44:47 +0000 Subject: [PATCH 01/90] Add basic axiomatization for BMV monads --- Tools/bmv_monad_def.ML | 225 +++++++++++++++++++++ Tools/mrbnf_util.ML | 2 + operations/BMV_Monad.thy | 416 +++++++++++++++++++++++++++++++++++++-- 3 files changed, 628 insertions(+), 15 deletions(-) create mode 100644 Tools/bmv_monad_def.ML diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML new file mode 100644 index 00000000..0a125d15 --- /dev/null +++ b/Tools/bmv_monad_def.ML @@ -0,0 +1,225 @@ +signature BMV_MONAD_DEF = sig + type bmv_monad + + type 'a bmv_monad_axioms = { + Sb_Inj: 'a, + Sb_comp_Injs: 'a list, + Sb_comp: 'a, + Sb_cong: 'a, + Vrs_Injs: 'a list, + Vrs_Sbs: 'a list + }; + + type bmv_monad_model = { + ops: typ list, + bmv_ops: bmv_monad list, + frees: typ list, + lives: typ list, + leader: int, + Injs: (term list * (term * int) list) list, + Sbs: term list, + Maps: term option list, + Vrs: term list list, + tacs: (Proof.context -> tactic) bmv_monad_axioms list + } + + val ops_of_bmv_monad: bmv_monad -> typ list; + val leader_of_bmv_monad: bmv_monad -> int; + val frees_of_bmv_monad: bmv_monad -> typ list; + val lives_of_bmv_monad: bmv_monad -> typ 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 Vrs_of_bmv_monad: bmv_monad -> term list list; + + val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; + + val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) + -> (binding -> binding) -> bmv_monad_model -> local_theory -> bmv_monad +end + +structure BMV_Monad_Def : BMV_MONAD_DEF = struct + +open MRBNF_Util + +type 'a bmv_monad_axioms = { + Sb_Inj: 'a, + Sb_comp_Injs: 'a list, + Sb_comp: 'a, + Sb_cong: 'a, + Vrs_Injs: 'a list, + Vrs_Sbs: 'a list +}; + +fun morph_bmv_axioms phi { + Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_Injs, Vrs_Sbs +} = { + Sb_Inj = Morphism.thm phi Sb_Inj, + Sb_comp_Injs = map (Morphism.thm phi) Sb_comp_Injs, + Sb_comp = Morphism.thm phi Sb_comp, + Sb_cong = Morphism.thm phi Sb_cong, + Vrs_Injs = map (Morphism.thm phi) Vrs_Injs, + Vrs_Sbs = map (Morphism.thm phi) Vrs_Sbs +} : thm bmv_monad_axioms + +datatype bmv_monad = BMV of { + ops: typ list, + leader: int, + frees: typ list, + lives: typ list, + Injs: term list list, + Sbs: term list, + Maps: term option list, + Vrs: term list list, + axioms: thm bmv_monad_axioms list +} + +fun Rep_bmv (BMV x) = x + +val ops_of_bmv_monad = #ops 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 Injs_of_bmv_monad = #Injs o Rep_bmv +val Sbs_of_bmv_monad = #Sbs o Rep_bmv +val Maps_of_bmv_monad = #Maps o Rep_bmv +val Vrs_of_bmv_monad = #Vrs o Rep_bmv + +type bmv_monad_model = { + ops: typ list, + frees: typ list, + lives: typ list, + bmv_ops: bmv_monad list, + leader: int, + Injs: (term list * (term * int) list) list, + Sbs: term list, + Maps: term option list, + Vrs: term list list, + tacs: (Proof.context -> tactic) bmv_monad_axioms list +} + +fun morph_bmv_monad phi (BMV { + ops, leader, frees, lives, Injs, Sbs, Maps, Vrs, axioms +}) = BMV { + ops = map (Morphism.typ phi) ops, + leader = leader, + frees = map (Morphism.typ phi) frees, + lives = map (Morphism.typ phi) lives, + Injs = map (map (Morphism.term phi)) Injs, + Sbs = map (Morphism.term phi) Sbs, + Maps = map (Option.map (Morphism.term phi)) Maps, + Vrs = map (map (Morphism.term phi)) Vrs, + axioms = map (morph_bmv_axioms phi) axioms +} + +fun prove_axioms (model: bmv_monad_model) lthy = + let + val Ts = #ops model @ maps ops_of_bmv_monad (#bmv_ops model); + val Sbs = #Sbs model @ maps Sbs_of_bmv_monad (#bmv_ops model); + val Injss = #Injs model @ map (rpair []) (maps Injs_of_bmv_monad (#bmv_ops model)); + val Vrss = #Vrs model @ maps Vrs_of_bmv_monad (#bmv_ops model); + + val axioms = @{map 5} (fn T => fn (own_Injs, other_Injs) => fn Sb => fn Vrs => fn tacs => + let + val (other_Injs, other_idxs) = split_list other_Injs; + val Injs = own_Injs @ other_Injs; + val ((((rhos, rhos'), aa), x), _) = lthy + |> mk_Frees "\" (map fastype_of Injs) + ||>> mk_Frees "\'" (map fastype_of Injs) + ||>> mk_Frees "a" (map (fst o dest_funT o fastype_of) Injs) + ||>> apfst hd o mk_Frees "x" [T]; + val nown = length own_Injs; + val (own_rhos, other_rhos) = chop nown rhos; + val (own_rhos', other_rhos') = chop nown rhos'; + + val Sb_Inj = Goal.prove_sorry lthy [] [] ( + mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T) + ) (fn {context=ctxt, ...} => #Sb_Inj tacs ctxt); + + fun mk_small_prems rhos = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (HOLogic.mk_Collect ("a", fst (dest_funT (fastype_of Inj)), + HOLogic.mk_not (HOLogic.mk_eq (rho $ Bound 0, Inj $ Bound 0)) + ))) + (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of Inj))))) + )) rhos Injs; + val small_prems = mk_small_prems rhos; + val small_prems' = mk_small_prems rhos'; + + val Sb_comp_Injs = @{map 3} (fn Inj => fn rho => fn tac => Goal.prove_sorry lthy [] [] ( + fold_rev Logic.all rhos (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (Sb, rhos), Inj), rho + ))) + ) (fn {context=ctxt, ...} => tac ctxt)) own_Injs own_rhos (#Sb_comp_Injs tacs); + + val Sb_comp = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos') ( + fold_rev (curry Logic.mk_implies) (small_prems @ small_prems') (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (Sb, rhos'), Term.list_comb (Sb, rhos)), + Term.list_comb (Sb, map (fn rho => HOLogic.mk_comp ( + Term.list_comb (Sb, rhos'), rho + )) own_rhos @ @{map 3} (fn rho => fn Sb => fn Injs => + HOLogic.mk_comp (Term.list_comb (Sb, map (fn Inj => + case List.find (fn rho' => fastype_of rho' = fastype_of Inj) rhos' of + NONE => Inj | SOME t => t + ) (fst Injs @ map fst (snd Injs))), rho) + ) other_rhos (map (nth Sbs) other_idxs) (map (nth Injss) other_idxs)) + )) + )) (fn {context=ctxt, ...} => #Sb_comp tacs ctxt); + + val Vrs_Injs = @{map 4} (fn Vrs => fn Inj => fn a => fn tac => Goal.prove_sorry lthy [] [] ( + Logic.all a (mk_Trueprop_eq (Vrs $ (Inj $ a), mk_singleton a)) + ) (fn {context=ctxt, ...} => tac ctxt)) (take nown Vrs) own_Injs (take nown aa) (#Vrs_Injs tacs); + + val Vrs_Sbs = map2 (fn Vr => fn tac => Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ [x]) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + Vr $ (Term.list_comb (Sb, rhos) $ x), + foldl1 mk_Un (@{map_filter 2} (fn rho => Option.map (fn Vrs' => mk_UNION (Vr $ x) ( + Term.abs ("a", HOLogic.dest_setT (snd (dest_funT (fastype_of Vrs')))) ( + Vrs' $ (rho $ Bound 0) + ) + ))) rhos (map SOME (take nown Vrs) @ map (fn idx => + List.find (fn t => body_type (fastype_of t) = body_type (fastype_of Vr)) (nth Vrss idx) + ) other_idxs)) + )) + )) (fn {context=ctxt, ...} => tac ctxt)) Vrs (#Vrs_Sbs tacs); + + val Sb_cong = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos' @ [x]) ( + fold_rev (curry Logic.mk_implies) (small_prems @ small_prems' @ @{map 4} (fn rho => fn rho' => fn Vrs => fn a => + Logic.all a (Logic.mk_implies ( + HOLogic.mk_Trueprop (HOLogic.mk_mem (a, Vrs $ x)), + mk_Trueprop_eq (rho $ a, rho' $ a) + )) + ) rhos rhos' Vrs aa) (mk_Trueprop_eq ( + Term.list_comb (Sb, rhos) $ x, + Term.list_comb (Sb, rhos') $ x + ) + ))) (fn {context=ctxt, ...} => #Sb_cong tacs ctxt); + + in { + Sb_Inj = Sb_Inj, + Sb_comp_Injs = Sb_comp_Injs, + Sb_comp = Sb_comp, + Vrs_Injs = Vrs_Injs, + Vrs_Sbs = Vrs_Sbs, + Sb_cong = Sb_cong + } end + ) (#ops model) (#Injs model) (#Sbs model) (#Vrs model) (#tacs model); + in axioms end; + +fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lthy = + let + val axioms = prove_axioms model lthy; + + val bmv = BMV { + ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), + leader = #leader model, + frees = #frees model, + lives = #lives model, + Injs = map (fn (xs, ys) => xs @ map fst ys) (#Injs model) @ maps (#Injs o Rep_bmv) (#bmv_ops model), + Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), + Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), + Maps = #Maps model @ maps (#Maps o Rep_bmv) (#bmv_ops model), + axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model) + } : bmv_monad; + in bmv end + +end \ No newline at end of file diff --git a/Tools/mrbnf_util.ML b/Tools/mrbnf_util.ML index d2d0489f..4e5cf129 100644 --- a/Tools/mrbnf_util.ML +++ b/Tools/mrbnf_util.ML @@ -16,6 +16,8 @@ sig val subst_typ_morphism: (typ * typ) list -> morphism + val subst_typ_morphism: (typ * typ) list -> morphism + val mk_supp: term -> term val mk_supp_bound: term -> term val mk_imsupp: term -> term diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index e9331571..6f877a13 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -17,6 +17,9 @@ 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 VVr_eq_Var: "tvVVr_tvsubst_FType = TyVar" + unfolding tvVVr_tvsubst_FType_def TyVar_def comp_def tv\_FType_tvsubst_FType_def by (rule refl) + 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]: @@ -54,43 +57,426 @@ lemma Sb_comp_Inj_FType: using assms by auto lemma Sb_comp_FType: - fixes \ \'::"'tyvar::var \ 'tyvar FType" - assumes "|SSupp_FType \| '| \ Sb_FType \' = Sb_FType (Sb_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) + 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) done - +thm Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]] lemma Vrs_Inj_FType: "Vrs_FType_1 (Inj_FType_1 a) = {a}" by simp 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) + 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 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) + 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)) +ML_file \../Tools/bmv_monad_def.ML\ + +ML \ +Multithreading.parallel_proofs := 0 +\ + +ML \ +val model_FType = { + ops = [@{typ "'a::var FType"}], + leader = 0, + frees = [@{typ "'a::var"}], + lives = [], + bmv_ops = [], + Injs = [([@{term "TyVar :: 'a::var \ _"}], [])], + Sbs = [@{term "tvsubst_FType :: _ => 'a::var FType => _"}], + Maps = [NONE], + Vrs = [[@{term "FVars_FType :: _ => 'a::var set"}]], + tacs = [{ + Sb_Inj = fn ctxt => resolve_tac ctxt @{thms Sb_Inj_FType} 1, + Sb_comp_Injs = [fn ctxt => EVERY1 [ + resolve_tac ctxt @{thms Sb_comp_Inj_FType}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), + assume_tac ctxt + ]], + Sb_comp = fn ctxt => EVERY1 [ + resolve_tac ctxt @{thms Sb_comp_FType}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), + REPEAT_DETERM o assume_tac ctxt + ], + Vrs_Injs = [fn ctxt => resolve_tac ctxt @{thms Vrs_Inj_FType} 1], + Vrs_Sbs = [fn ctxt => EVERY1 [ + resolve_tac ctxt @{thms Vrs_Sb_FType}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), + assume_tac ctxt + ]], + Sb_cong = fn ctxt => EVERY1 [ + resolve_tac ctxt @{thms Sb_cong_FType}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), + REPEAT_DETERM o assume_tac ctxt, + Goal.assume_rule_tac ctxt + ] + } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] +} : BMV_Monad_Def.bmv_monad_model; +\ + +ML \ +val FType_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_FType @{context} +\ + + (* *) +type_synonym ('a1, 'a2, 'c1, 'c2) L = "'a1 * 'a1 * ('c1 + 'c2)" (* PBMV *) + type_synonym ('a1, 'a2, 'c1, 'c2) L_M1 = "'a1" (* PBMV *) + +type_synonym ('a1, 'a2) L1 = "'a1 * 'a2" + type_synonym ('a1, 'a2) L1_M1 = "'a1" + type_synonym ('a1, 'a2) L1_M2 = "'a2" + +type_synonym ('a1, 'a2) L2 = "'a1 * 'a2 FType" + type_synonym ('a1, 'a2) L2_M1 = "'a1" + type_synonym ('a1, 'a2) L2_M2 = "'a2 FType" + +(* Dispatcher *) + (* from L_M1 *) +definition Sb_L :: "('a1 \ 'a1) \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1, 'c2) L" where + "Sb_L \ \f. map_prod f (map_prod f id)" +definition Vrs_L_1 :: "('a1, 'a2, 'c1, 'c2) L \ 'a1 set" where + "Vrs_L_1 \ \(a1, a1', p). {a1, a1'}" (* corresponds to L_M1 and Inj_L_M1_1 *) +definition Vrs_L_2 :: "('a1, 'a2, 'c1, 'c2) L \ 'a2 set" where + "Vrs_L_2 \ \x. {}" (* corresponds to nothing *) +definition Map_L :: "('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" where + "Map_L \ \f1 f2 (a1, a2, p). (a1, a2, map_sum f1 f2 p)" + +(* and its minion *) +definition Inj_L_M1_1 :: "'a1 \ 'a1" where "Inj_L_M1_1 \ id" +definition Sb_L_M1 :: "('a1 \ 'a1) \ ('a1, 'a2, 'c1, 'c2) L_M1 \ ('a1, 'a2, 'c1, 'c2) L_M1" where + "Sb_L_M1 \ \f. f" +definition Vrs_L_M1_1 :: "'a1 \ 'a1 set" where "Vrs_L_M1_1 \ \x. {x}" +definition Vrs_L_M1_2 :: "'a2 \ 'a2 set" where "Vrs_L_M1_2 \ \x. {}" +definition Map_L_M1 :: "('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L_M1 \ ('a1, 'a2, 'c1', 'c2') L_M1" where + "Map_L_M1 \ \f1 f2 x. x" + +(* L1 *) +definition Sb_L1 :: "('a1 \ 'a1) \ ('a2 \ 'a2) \ ('a1, 'a2) L1 \ ('a1, 'a2) L1" where + "Sb_L1 \ \f1 f2. map_prod f1 f2" +definition Vrs_L1_1 :: "('a1, 'a2) L1 \ 'a1 set" where + "Vrs_L1_1 \ \(a1, a2). {a1}" (* corresponds to L1_M1 and Inj_L1_M1_1 *) +definition Vrs_L1_2 :: "('a1, 'a2) L1 \ 'a2 set" where + "Vrs_L1_2 \ \(a1, a2). {a2}" (* corresponds to L1_M2 and Inj_L1_M2_2 *) +(* and its minions M1 *) +definition Sb_L1_M1 :: "('a1 \ 'a1) \ ('a1, 'a2) L1_M1 \ ('a1, 'a2) L1_M1" where + "Sb_L1_M1 \ \f. f" +definition Vrs_L1_M1_1 :: "('a1, 'a2) L1_M1 \ 'a1 set" where + "Vrs_L1_M1_1 \ \a. {a}" (* corresponds to L1_M1 and Inj_L1_M1_1 *) +definition Vrs_L1_M1_2 :: "('a1, 'a2) L1_M1 \ 'a2 set" where + "Vrs_L1_M1_2 \ \a. {}" (* corresponds to L1_M2 and Inj_L1_M2_2 *) +(* and its minions M2 *) +definition Sb_L1_M2 :: "('a2 \ 'a2) \ ('a1, 'a2) L1_M2 \ ('a1, 'a2) L1_M2" where + "Sb_L1_M2 \ \f. f" +definition Vrs_L1_M2_1 :: "('a1, 'a2) L1_M2 \ 'a1 set" where + "Vrs_L1_M2_1 \ \a. {}" (* corresponds to L1_M1 and Inj_L1_M1_1 *) +definition Vrs_L1_M2_2 :: "('a1, 'a2) L1_M2 \ 'a2 set" where + "Vrs_L1_M2_2 \ \a. {a}" (* corresponds to L1_M2 and Inj_L1_M2_2 *) + +(* L2 *) +(* its minions M1, shared with L1_M1 *) +(*definition Sb_L2_M1 :: "('a1 \ 'a1) \ ('a1, 'a2) L2_M1 \ ('a1, 'a2) L2_M1" where + "Sb_L2_M1 \ \f. f" +definition Vrs_L2_M1_1 :: "('a1, 'a2) L2_M1 \ 'a1 set" where + "Vrs_L2_M1_1 \ \a. {a}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) +definition Vrs_L2_M1_2 :: "('a1, 'a2) L2_M1 \ 'a2 set" where + "Vrs_L2_M1_2 \ \a. {}" (* corresponds to L2_M2 and Inj_L2_M2_2 *) *) +(* and its minions M2 *) +definition Sb_L2_M2 :: "('a2::var \ 'a2 FType) \ ('a1, 'a2) L2_M2 \ ('a1, 'a2) L2_M2" where + "Sb_L2_M2 \ tvsubst_FType" +definition Vrs_L2_M2_1 :: "('a1, 'a2) L2_M2 \ 'a1 set" where + "Vrs_L2_M2_1 \ \a. {}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) +definition Vrs_L2_M2_2 :: "('a1, 'a2::var) L2_M2 \ 'a2 set" where + "Vrs_L2_M2_2 \ FVars_FType" (* corresponds to L2_M2 and Inj_L2_M2_2 *) +(* and then the leader L2 itself *) +definition Sb_L2 :: "('a1 \ 'a1) \ ('a2::var \ 'a2 FType) \ ('a1, 'a2) L2 \ ('a1, 'a2) L2" where + "Sb_L2 \ \f1 f2. map_prod (id f1) (tvsubst_FType f2)" +definition Vrs_L2_1 :: "('a1, 'a2) L2 \ 'a1 set" where + "Vrs_L2_1 \ Vrs_L1_M1_1 \ fst" (* corresponds to L2_M1 and Inj_L2_M1_1 *) +definition Vrs_L2_2 :: "('a1, 'a2::var) L2 \ 'a2 set" where + "Vrs_L2_2 \ Vrs_L2_M2_2 \ snd" (* corresponds to L2_M2 and Inj_L2_M2_2 *) + +(* Composition *) +type_synonym ('a1, 'a2) LC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L" +type_synonym ('a1, 'a2) L_MC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L_M1" +typ "('a1, 'a2) L_MC" (* is the same as LC_M1, so do not add *) + +type_synonym ('a1, 'a2) LC_M1 = "('a1, 'a2) L1_M1" +type_synonym ('a1, 'a2) LC_M2 = "('a1, 'a2) L1_M2" +type_synonym ('a1, 'a2) LC_M3 = "('a1, 'a2) L2_M2" + + + +ML \ +val model_ID = { + ops = [@{typ "'a"}], + leader = 0, + frees = [@{typ "'a"}], + lives = [], + bmv_ops = [], + Maps = [NONE], + Injs = [([@{term "id :: 'a \ _"}], [])], + Sbs = [@{term "id :: _ => 'a => 'a"}], + Vrs = [[@{term "\(x::'a). {x}"}]], + tacs = [{ + Sb_Inj = fn ctxt => resolve_tac ctxt @{thms id_apply} 1, + Sb_comp_Injs = [fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), + resolve_tac ctxt [refl] + ]], + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), + resolve_tac ctxt [refl] + ], + Vrs_Injs = [fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), + resolve_tac ctxt [refl] + ]], + Vrs_Sbs = [fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms UN_single id_def}), + resolve_tac ctxt [refl] + ]], + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms singletonI}, + assume_tac ctxt + ] + } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] +} : BMV_Monad_Def.bmv_monad_model; +\ +ML \ +val id_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_ID @{context} +\ -type_synonym ('var, 'tyvar, 'bvar, 'btyvar, 'rec, 'brec) FTerm_pre' = "('var + 'rec * 'rec + 'btyvar * 'brec) + ('bvar * 'tyvar FType * 'brec + 'rec * 'tyvar FType)" +ML \ +val model_L = { + ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], + leader = 0, + frees = [@{typ "'a1"}, @{typ "'a2"}], + lives = [@{typ "'c1"}, @{typ "'c2"}], + bmv_ops = [BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + )) id_bmv], + Maps = [SOME @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}], + Injs = [([], [(@{term "id :: 'a1 \ 'a1"}, 1)])], + Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], + Vrs = [[ + @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} + ]], + tacs = [{ + Sb_Inj = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def prod.map_id0}), + resolve_tac ctxt [refl] + ], + Sb_comp_Injs = [], + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ( + (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) + :: @{thms Sb_L_def id_o id_apply} + )), + resolve_tac ctxt [refl] + ], + Vrs_Injs = [], + Vrs_Sbs = [fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta + Product_Type.fst_map_prod Product_Type.snd_map_prod + UN_insert UN_empty Un_empty_right insert_is_Un[symmetric] + }), + resolve_tac ctxt [refl] + ]], + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta}), + resolve_tac ctxt @{thms prod.map_cong0}, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms insertI1}, + eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + hyp_subst_tac ctxt, + assume_tac ctxt, + resolve_tac ctxt @{thms prod.map_cong0}, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms insertI2}, + resolve_tac ctxt @{thms singletonI}, + eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, + hyp_subst_tac ctxt, + assume_tac ctxt, + resolve_tac ctxt [refl] + ] + } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] +} : BMV_Monad_Def.bmv_monad_model; +\ +ML \ +val L_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L @{context} +\ +ML \ +val model_L1 = { + ops = [@{typ "'a1 * 'a2"}], + leader = 0, + frees = [@{typ "'a1"}, @{typ "'a2"}], + lives = [], + bmv_ops = [ + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + )) id_bmv, + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2"}] + )) id_bmv + ], + Maps = [NONE], + Injs = [([], [(@{term "id :: 'a1 \ 'a1"}, 1), (@{term "id :: 'a2 \ 'a2"}, 2)])], + Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], + Vrs = [[@{term "\(x::'a1, x2::'a2). {x}"}, @{term "\(x::'a1, x2::'a2). {x2}"}]], + tacs = [{ + Sb_Inj = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def prod.map_id0}), + resolve_tac ctxt [refl] + ], + Sb_comp_Injs = [], + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ( + (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) + :: @{thms Sb_L1_def id_apply} + )), + resolve_tac ctxt [refl] + ], + Vrs_Injs = [], + Vrs_Sbs = [ + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), + resolve_tac ctxt [refl] + ], + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), + resolve_tac ctxt [refl] + ] + ], + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_beta}), + resolve_tac ctxt @{thms prod.map_cong0}, + eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms singletonI}, + hyp_subst_tac ctxt, + assume_tac ctxt, + eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, + rotate_tac ~1, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms singletonI}, + hyp_subst_tac ctxt, + assume_tac ctxt + ] + } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] +} : BMV_Monad_Def.bmv_monad_model; +\ +ML \ +val L1_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L1 @{context} +\ +ML \ +val model_L2 = { + ops = [@{typ "'a1 * 'a2::var FType"}], + leader = 0, + frees = [@{typ "'a1"}, @{typ "'a2::var"}], + lives = [], + bmv_ops = [ + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + )) id_bmv, + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad FType_bmv ~~ [@{typ "'a2::var"}] + )) FType_bmv + ], + Maps = [NONE], + Injs = [([], [(@{term "id :: 'a1 \ 'a1"}, 1), (@{term "TyVar :: 'a2::var \ 'a2 FType"}, 2)])], + Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ ('a1, 'a2::var) L2"}], + Vrs = [[@{term "\(x::'a1, x2::'a2::var FType). {x}"}, @{term "\(x::'a1, x2::'a2::var FType). FVars_FType x2"}]], + tacs = [{ + Sb_Inj = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), + resolve_tac ctxt [refl] + ], + Sb_comp_Injs = [], + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ( + (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) + :: @{thms Sb_L2_def id_apply Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]} + )), + resolve_tac ctxt [refl] + ], + Vrs_Injs = [], + Vrs_Sbs = [ + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), + resolve_tac ctxt [refl] + ], + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), + resolve_tac ctxt @{thms Vrs_Sb_FType}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), + assume_tac ctxt + ] + ], + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def case_prod_beta id_apply}), + resolve_tac ctxt @{thms prod.map_cong0}, + eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms singletonI}, + hyp_subst_tac ctxt, + assume_tac ctxt, + eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, + resolve_tac ctxt @{thms Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]}, + REPEAT_DETERM o assume_tac ctxt, + rotate_tac ~3, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + hyp_subst_tac ctxt, + assume_tac ctxt, + assume_tac ctxt + ] + } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] +} : BMV_Monad_Def.bmv_monad_model; +\ +ML \ +val L2_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context} +\ end \ No newline at end of file From 7ea31c3d551ffaf9d8b832bed2d830f4b0d6c85c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 12 Dec 2024 13:44:56 +0000 Subject: [PATCH 02/90] Do not seperate between own/other injections, use types instead --- Tools/bmv_monad_def.ML | 47 ++++++++++++---- Tools/mrbnf_util.ML | 4 +- operations/BMV_Monad.thy | 112 +++++++++++++++++++++++++++++++++------ 3 files changed, 134 insertions(+), 29 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 0a125d15..b3499e7e 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1,13 +1,16 @@ signature BMV_MONAD_DEF = sig type bmv_monad + type supported_functor (* TODO *) type 'a bmv_monad_axioms = { Sb_Inj: 'a, Sb_comp_Injs: 'a list, - Sb_comp: 'a, + Sb_comp: 'a, (* require typeclass on free vars to bound *) Sb_cong: 'a, - Vrs_Injs: 'a list, + (* TODO: Add Vrs_bd axiom *) + Vrs_Injs: 'a list, (* TODO: One per Inj AND var kind *) Vrs_Sbs: 'a list + (* Add optional Map_Sb axiom (dependent on iff Map exists) *) }; type bmv_monad_model = { @@ -16,7 +19,7 @@ signature BMV_MONAD_DEF = sig frees: typ list, lives: typ list, leader: int, - Injs: (term list * (term * int) list) list, + Injs: term list list, Sbs: term list, Maps: term option list, Vrs: term list list, @@ -36,6 +39,8 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> bmv_monad_model -> local_theory -> bmv_monad + + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory -> bmv_monad end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -62,6 +67,7 @@ fun morph_bmv_axioms phi { Vrs_Sbs = map (Morphism.thm phi) Vrs_Sbs } : thm bmv_monad_axioms +(* TODO: Add bound *) datatype bmv_monad = BMV of { ops: typ list, leader: int, @@ -70,10 +76,12 @@ datatype bmv_monad = BMV of { Injs: term list list, Sbs: term list, Maps: term option list, - Vrs: term list list, + Vrs: term list list (*list*), (* TODO: Need Vr operator per Injection *) axioms: thm bmv_monad_axioms list } +datatype supported_functor = Supported_Functor (* TODO *) + fun Rep_bmv (BMV x) = x val ops_of_bmv_monad = #ops o Rep_bmv @@ -91,7 +99,7 @@ type bmv_monad_model = { lives: typ list, bmv_ops: bmv_monad list, leader: int, - Injs: (term list * (term * int) list) list, + Injs: term list list, Sbs: term list, Maps: term option list, Vrs: term list list, @@ -116,13 +124,13 @@ fun prove_axioms (model: bmv_monad_model) lthy = let val Ts = #ops model @ maps ops_of_bmv_monad (#bmv_ops model); val Sbs = #Sbs model @ maps Sbs_of_bmv_monad (#bmv_ops model); - val Injss = #Injs model @ map (rpair []) (maps Injs_of_bmv_monad (#bmv_ops model)); + val Injss = #Injs model @ maps Injs_of_bmv_monad (#bmv_ops model); val Vrss = #Vrs model @ maps Vrs_of_bmv_monad (#bmv_ops model); - val axioms = @{map 5} (fn T => fn (own_Injs, other_Injs) => fn Sb => fn Vrs => fn tacs => + val axioms = @{map 5} (fn T => fn Injs => fn Sb => fn Vrs => fn tacs => let - val (other_Injs, other_idxs) = split_list other_Injs; - val Injs = own_Injs @ other_Injs; + 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 ((((rhos, rhos'), aa), x), _) = lthy |> mk_Frees "\" (map fastype_of Injs) ||>> mk_Frees "\'" (map fastype_of Injs) @@ -160,7 +168,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = HOLogic.mk_comp (Term.list_comb (Sb, map (fn Inj => case List.find (fn rho' => fastype_of rho' = fastype_of Inj) rhos' of NONE => Inj | SOME t => t - ) (fst Injs @ map fst (snd Injs))), rho) + ) Injs), rho) ) other_rhos (map (nth Sbs) other_idxs) (map (nth Injss) other_idxs)) )) )) (fn {context=ctxt, ...} => #Sb_comp tacs ctxt); @@ -214,7 +222,7 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth leader = #leader model, frees = #frees model, lives = #lives model, - Injs = map (fn (xs, ys) => xs @ map fst ys) (#Injs model) @ maps (#Injs o Rep_bmv) (#bmv_ops model), + Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), Maps = #Maps model @ maps (#Maps o Rep_bmv) (#bmv_ops model), @@ -222,4 +230,21 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth } : bmv_monad; in bmv end +(* Cleanup: Throw away op iff any: +- not the leader +- does not appear in the codomain of any (=of any **other** SOp) Injection, +*) + +fun compose_bmv_monad qualify outer inners lthy = + let + val _ = if length (lives_of_bmv_monad outer) <> length inners then + error "Outer needs exactly as many lives as there are inners" else () + + val ops' = map (Term.typ_subst_atomic (lives_of_bmv_monad outer ~~ map (fn bmv => + nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv) + ) inners)) (ops_of_bmv_monad outer); + + val _ = @{print} ops' + in error "unfinished" end; + end \ No newline at end of file diff --git a/Tools/mrbnf_util.ML b/Tools/mrbnf_util.ML index 4e5cf129..15ff738c 100644 --- a/Tools/mrbnf_util.ML +++ b/Tools/mrbnf_util.ML @@ -16,8 +16,6 @@ sig val subst_typ_morphism: (typ * typ) list -> morphism - val subst_typ_morphism: (typ * typ) list -> morphism - val mk_supp: term -> term val mk_supp_bound: term -> term val mk_imsupp: term -> term @@ -93,6 +91,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) diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 6f877a13..acd354f9 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -103,7 +103,7 @@ val model_FType = { frees = [@{typ "'a::var"}], lives = [], bmv_ops = [], - Injs = [([@{term "TyVar :: 'a::var \ _"}], [])], + Injs = [[@{term "TyVar :: 'a::var \ _"}]], Sbs = [@{term "tvsubst_FType :: _ => 'a::var FType => _"}], Maps = [NONE], Vrs = [[@{term "FVars_FType :: _ => 'a::var set"}]], @@ -213,20 +213,23 @@ definition Vrs_L2_M2_2 :: "('a1, 'a2::var) L2_M2 \ 'a2 set" where definition Sb_L2 :: "('a1 \ 'a1) \ ('a2::var \ 'a2 FType) \ ('a1, 'a2) L2 \ ('a1, 'a2) L2" where "Sb_L2 \ \f1 f2. map_prod (id f1) (tvsubst_FType f2)" definition Vrs_L2_1 :: "('a1, 'a2) L2 \ 'a1 set" where - "Vrs_L2_1 \ Vrs_L1_M1_1 \ fst" (* corresponds to L2_M1 and Inj_L2_M1_1 *) + "Vrs_L2_1 \ \(x,x2). {x}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) definition Vrs_L2_2 :: "('a1, 'a2::var) L2 \ 'a2 set" where - "Vrs_L2_2 \ Vrs_L2_M2_2 \ snd" (* corresponds to L2_M2 and Inj_L2_M2_2 *) + "Vrs_L2_2 \ \(x,x2). FVars_FType x2" (* corresponds to L2_M2 and Inj_L2_M2_2 *) (* Composition *) type_synonym ('a1, 'a2) LC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L" +typ "('a1, 'a2, 'c1, 'c2) L" +typ "('a1, 'a2) L1" +typ "('a1, 'a2) LC" type_synonym ('a1, 'a2) L_MC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L_M1" typ "('a1, 'a2) L_MC" (* is the same as LC_M1, so do not add *) -type_synonym ('a1, 'a2) LC_M1 = "('a1, 'a2) L1_M1" -type_synonym ('a1, 'a2) LC_M2 = "('a1, 'a2) L1_M2" -type_synonym ('a1, 'a2) LC_M3 = "('a1, 'a2) L2_M2" - +typ "('a1, 'a2) L1_M1" +typ "('a1, 'a2) L1_M2" +typ "('a1, 'a2) L2_M2" +declare [[ML_print_depth=10000]] ML \ val model_ID = { @@ -236,7 +239,7 @@ val model_ID = { lives = [], bmv_ops = [], Maps = [NONE], - Injs = [([@{term "id :: 'a \ _"}], [])], + Injs = [[@{term "id :: 'a \ _"}]], Sbs = [@{term "id :: _ => 'a => 'a"}], Vrs = [[@{term "\(x::'a). {x}"}]], tacs = [{ @@ -282,7 +285,7 @@ val model_L = { BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] )) id_bmv], Maps = [SOME @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}], - Injs = [([], [(@{term "id :: 'a1 \ 'a1"}, 1)])], + Injs = [[@{term "id :: 'a1 \ 'a1"}]], Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], Vrs = [[ @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} @@ -352,7 +355,7 @@ val model_L1 = { )) id_bmv ], Maps = [NONE], - Injs = [([], [(@{term "id :: 'a1 \ 'a1"}, 1), (@{term "id :: 'a2 \ 'a2"}, 2)])], + Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], Vrs = [[@{term "\(x::'a1, x2::'a2). {x}"}, @{term "\(x::'a1, x2::'a2). {x2}"}]], tacs = [{ @@ -405,11 +408,84 @@ ML \ val L1_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L1 @{context} \ +(* ML \ +val model_L2 = { + ops = [@{typ "'a2 * 'a2::var FType"}], + leader = 0, + frees = [@{typ "'a2::var"}], + lives = [], + bmv_ops = [ + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2::var"}] + )) id_bmv, + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad FType_bmv ~~ [@{typ "'a2::var"}] + )) FType_bmv + ], + Maps = [NONE], + Injs = [([], [(@{term "id :: 'a2::var \ 'a2"}, 1), (@{term "TyVar :: 'a2::var \ 'a2 FType"}, 2)])], + Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ ('a2, 'a2::var) L2"}], + Vrs = [[@{term "Vrs_L2_1 :: ('a2, 'a2::var) L2 \ _"}, @{term "Vrs_L2_2 :: ('a2, 'a2::var) L2 \ _"}]], + tacs = [{ + Sb_Inj = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), + resolve_tac ctxt [refl] + ], + Sb_comp_Injs = [], + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ( + (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) + :: @{thms Sb_L2_def id_apply Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]} + )), + resolve_tac ctxt [refl] + ], + Vrs_Injs = [], + Vrs_Sbs = [ + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), + resolve_tac ctxt [refl] + ], + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), + resolve_tac ctxt @{thms Vrs_Sb_FType}, + K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), + assume_tac ctxt + ] + ], + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def case_prod_beta id_apply}), + resolve_tac ctxt @{thms prod.map_cong0}, + eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms singletonI}, + hyp_subst_tac ctxt, + assume_tac ctxt, + eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, + resolve_tac ctxt @{thms Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]}, + REPEAT_DETERM o assume_tac ctxt, + rotate_tac ~3, + dresolve_tac ctxt @{thms meta_spec}, + dresolve_tac ctxt @{thms meta_mp}, + hyp_subst_tac ctxt, + assume_tac ctxt, + assume_tac ctxt + ] + } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] +} : BMV_Monad_Def.bmv_monad_model; +\ +ML \ +val L2_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context} +\ *) ML \ val model_L2 = { ops = [@{typ "'a1 * 'a2::var FType"}], leader = 0, - frees = [@{typ "'a1"}, @{typ "'a2::var"}], + frees = [@{typ 'a1}, @{typ "'a2::var"}], lives = [], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( @@ -422,9 +498,9 @@ val model_L2 = { )) FType_bmv ], Maps = [NONE], - Injs = [([], [(@{term "id :: 'a1 \ 'a1"}, 1), (@{term "TyVar :: 'a2::var \ 'a2 FType"}, 2)])], + Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ ('a1, 'a2::var) L2"}], - Vrs = [[@{term "\(x::'a1, x2::'a2::var FType). {x}"}, @{term "\(x::'a1, x2::'a2::var FType). FVars_FType x2"}]], + Vrs = [[@{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}]], tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), @@ -441,12 +517,12 @@ val model_L2 = { Vrs_Injs = [], Vrs_Sbs = [ fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), resolve_tac ctxt [refl] ], fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), resolve_tac ctxt @{thms Vrs_Sb_FType}, K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), @@ -454,7 +530,7 @@ val model_L2 = { ] ], Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def case_prod_beta id_apply}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def case_prod_beta id_apply}), resolve_tac ctxt @{thms prod.map_cong0}, eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, dresolve_tac ctxt @{thms meta_spec}, @@ -479,4 +555,8 @@ ML \ val L2_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context} \ +ML \ +val x = BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv] @{context} +\ + end \ No newline at end of file From 36882fd93fbc9821af45ae8d9e708758576cabaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 12 Dec 2024 14:27:13 +0000 Subject: [PATCH 03/90] Add var class and bound to bmv monad --- Tools/binder_induction.ML | 12 ++------ Tools/bmv_monad_def.ML | 61 ++++++++++++++++++++++++++++++++------- Tools/mrbnf_def.ML | 7 +++-- Tools/mrbnf_util.ML | 17 +++++++++++ operations/BMV_Monad.thy | 24 ++++++++++----- 5 files changed, 89 insertions(+), 32 deletions(-) diff --git a/Tools/binder_induction.ML b/Tools/binder_induction.ML index 5a9690d7..93c8435b 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 diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index b3499e7e..a218d0ba 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -5,7 +5,7 @@ signature BMV_MONAD_DEF = sig type 'a bmv_monad_axioms = { Sb_Inj: 'a, Sb_comp_Injs: 'a list, - Sb_comp: 'a, (* require typeclass on free vars to bound *) + Sb_comp: 'a, Sb_cong: 'a, (* TODO: Add Vrs_bd axiom *) Vrs_Injs: 'a list, (* TODO: One per Inj AND var kind *) @@ -15,6 +15,8 @@ signature BMV_MONAD_DEF = sig type bmv_monad_model = { ops: typ list, + bd: term, + var_class: class, bmv_ops: bmv_monad list, frees: typ list, lives: typ list, @@ -27,6 +29,8 @@ signature BMV_MONAD_DEF = sig } val ops_of_bmv_monad: bmv_monad -> typ list; + val bd_of_bmv_monad: bmv_monad -> term; + 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; val lives_of_bmv_monad: bmv_monad -> typ list; @@ -38,9 +42,9 @@ signature BMV_MONAD_DEF = sig val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) - -> (binding -> binding) -> bmv_monad_model -> local_theory -> bmv_monad + -> (binding -> binding) -> bmv_monad_model -> local_theory -> bmv_monad * local_theory - val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory -> bmv_monad + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory -> bmv_monad * local_theory end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -67,9 +71,10 @@ fun morph_bmv_axioms phi { Vrs_Sbs = map (Morphism.thm phi) Vrs_Sbs } : thm bmv_monad_axioms -(* TODO: Add bound *) datatype bmv_monad = BMV of { ops: typ list, + bd: term, + var_class: class, leader: int, frees: typ list, lives: typ list, @@ -80,11 +85,29 @@ datatype bmv_monad = BMV of { axioms: thm bmv_monad_axioms list } +fun morph_bmv_monad phi (BMV { + ops, bd, var_class, leader, frees, lives, Injs, Sbs, Maps, Vrs, axioms +}) = BMV { + ops = map (Morphism.typ phi) ops, + bd = Morphism.term phi bd, + leader = leader, + var_class = var_class, + frees = map (Morphism.typ phi) frees, + lives = map (Morphism.typ phi) lives, + Injs = map (map (Morphism.term phi)) Injs, + Sbs = map (Morphism.term phi) Sbs, + Maps = map (Option.map (Morphism.term phi)) Maps, + Vrs = map (map (Morphism.term phi)) Vrs, + axioms = map (morph_bmv_axioms phi) axioms +} + datatype supported_functor = Supported_Functor (* TODO *) fun Rep_bmv (BMV x) = x val ops_of_bmv_monad = #ops o Rep_bmv +val bd_of_bmv_monad = #bd 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 @@ -95,6 +118,8 @@ val Vrs_of_bmv_monad = #Vrs o Rep_bmv type bmv_monad_model = { ops: typ list, + bd: term, + var_class: class, frees: typ list, lives: typ list, bmv_ops: bmv_monad list, @@ -106,19 +131,20 @@ type bmv_monad_model = { tacs: (Proof.context -> tactic) bmv_monad_axioms list } -fun morph_bmv_monad phi (BMV { - ops, leader, frees, lives, Injs, Sbs, Maps, Vrs, axioms -}) = BMV { +fun morph_bmv_monad_model phi { ops, bd, var_class, frees, lives, bmv_ops, leader, Injs, Sbs, Maps, Vrs, tacs } = { ops = map (Morphism.typ phi) ops, - leader = leader, + bd = Morphism.term phi bd, + var_class = var_class, frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, + bmv_ops = map (morph_bmv_monad phi) bmv_ops, + leader = leader, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Maps = map (Option.map (Morphism.term phi)) Maps, Vrs = map (map (Morphism.term phi)) Vrs, - axioms = map (morph_bmv_axioms phi) axioms -} + tacs = tacs +} : bmv_monad_model; fun prove_axioms (model: bmv_monad_model) lthy = let @@ -215,10 +241,23 @@ fun prove_axioms (model: bmv_monad_model) lthy = fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lthy = let + val _ = let + val var_large = MRBNF_Def.get_class_assumption [#var_class model] "large" lthy; + val bd' = snd (dest_comb (dest_card_of ( + fst (dest_ordLeq (HOLogic.dest_Trueprop (Thm.prop_of var_large))) + ))); + in if bd' <> #bd model then error "var_class does not match bound" else () end + val frees = map (fn T => TFree (apsnd ( + Sign.minimize_sort (Proof_Context.theory_of lthy) o cons (#var_class model) + ) (dest_TFree T))) (#frees model); + val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) model; + val axioms = prove_axioms model lthy; val bmv = BMV { ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), + bd = #bd model, + var_class = #var_class model, leader = #leader model, frees = #frees model, lives = #lives model, @@ -228,7 +267,7 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth Maps = #Maps model @ maps (#Maps o Rep_bmv) (#bmv_ops model), axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model) } : bmv_monad; - in bmv end + in (bmv, lthy) end (* Cleanup: Throw away op iff any: - not the leader diff --git a/Tools/mrbnf_def.ML b/Tools/mrbnf_def.ML index bffa5605..18629f59 100644 --- a/Tools/mrbnf_def.ML +++ b/Tools/mrbnf_def.ML @@ -254,6 +254,8 @@ sig val mrbnf_cmd: ((((((((binding * string) * string) * (var_type * string) list) * string) * string list) * string option) * string option) * string option) * (Proof.context -> Plugin_Name.filter) -> Proof.context -> Proof.state + + val get_class_assumption: string list -> string -> Proof.context -> thm; end; structure MRBNF_Def : MRBNF_DEF = @@ -1601,14 +1603,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; diff --git a/Tools/mrbnf_util.ML b/Tools/mrbnf_util.ML index 15ff738c..a3beb74a 100644 --- a/Tools/mrbnf_util.ML +++ b/Tools/mrbnf_util.ML @@ -37,6 +37,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 @@ -110,6 +114,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); diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index acd354f9..0839f5e0 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -99,6 +99,8 @@ Multithreading.parallel_proofs := 0 ML \ val model_FType = { ops = [@{typ "'a::var FType"}], + bd = @{term natLeq}, + var_class = @{class var}, leader = 0, frees = [@{typ "'a::var"}], lives = [], @@ -136,7 +138,7 @@ val model_FType = { \ ML \ -val FType_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_FType @{context} +val FType_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_FType @{context}) \ @@ -234,6 +236,8 @@ declare [[ML_print_depth=10000]] ML \ val model_ID = { ops = [@{typ "'a"}], + bd = @{term natLeq}, + var_class = @{class var}, leader = 0, frees = [@{typ "'a"}], lives = [], @@ -271,12 +275,14 @@ val model_ID = { } : BMV_Monad_Def.bmv_monad_model; \ ML \ -val id_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_ID @{context} +val id_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_ID @{context}) \ ML \ val model_L = { ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], + bd = @{term natLeq}, + var_class = @{class var}, leader = 0, frees = [@{typ "'a1"}, @{typ "'a2"}], lives = [@{typ "'c1"}, @{typ "'c2"}], @@ -335,12 +341,14 @@ val model_L = { } : BMV_Monad_Def.bmv_monad_model; \ ML \ -val L_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L @{context} +val L_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L @{context}) \ ML \ val model_L1 = { ops = [@{typ "'a1 * 'a2"}], + bd = @{term natLeq}, + var_class = @{class var}, leader = 0, frees = [@{typ "'a1"}, @{typ "'a2"}], lives = [], @@ -405,7 +413,7 @@ val model_L1 = { } : BMV_Monad_Def.bmv_monad_model; \ ML \ -val L1_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L1 @{context} +val L1_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L1 @{context}) \ (* ML \ @@ -484,6 +492,8 @@ val L2_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_No ML \ val model_L2 = { ops = [@{typ "'a1 * 'a2::var FType"}], + bd = @{term natLeq}, + var_class = @{class var}, leader = 0, frees = [@{typ 'a1}, @{typ "'a2::var"}], lives = [], @@ -552,11 +562,9 @@ val model_L2 = { } : BMV_Monad_Def.bmv_monad_model; \ ML \ -val L2_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context} +val L2_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context}) \ -ML \ -val x = BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv] @{context} -\ +local_setup \snd o BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv]\ end \ No newline at end of file From 912eb6e988aba7c579f303bb3b2dbf9c5305a17a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 12 Dec 2024 18:03:16 +0000 Subject: [PATCH 04/90] Have one Vrs operator per injection and (optionally) var type --- Tools/bmv_monad_def.ML | 82 ++++++++++-------- Tools/mrbnf_util.ML | 11 +++ operations/BMV_Monad.thy | 182 ++++++++++++++++----------------------- 3 files changed, 133 insertions(+), 142 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index a218d0ba..93fd0f25 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -8,8 +8,8 @@ signature BMV_MONAD_DEF = sig Sb_comp: 'a, Sb_cong: 'a, (* TODO: Add Vrs_bd axiom *) - Vrs_Injs: 'a list, (* TODO: One per Inj AND var kind *) - Vrs_Sbs: 'a list + Vrs_Injs: 'a option list list, + Vrs_Sbs: 'a option list list (* Add optional Map_Sb axiom (dependent on iff Map exists) *) }; @@ -24,7 +24,7 @@ signature BMV_MONAD_DEF = sig Injs: term list list, Sbs: term list, Maps: term option list, - Vrs: term list list, + Vrs: term option list list list, tacs: (Proof.context -> tactic) bmv_monad_axioms list } @@ -37,7 +37,7 @@ signature BMV_MONAD_DEF = sig 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 Vrs_of_bmv_monad: bmv_monad -> term list list; + val Vrs_of_bmv_monad: bmv_monad -> term option list list list; val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; @@ -56,8 +56,8 @@ type 'a bmv_monad_axioms = { Sb_comp_Injs: 'a list, Sb_comp: 'a, Sb_cong: 'a, - Vrs_Injs: 'a list, - Vrs_Sbs: 'a list + Vrs_Injs: 'a option list list, + Vrs_Sbs: 'a option list list }; fun morph_bmv_axioms phi { @@ -67,8 +67,8 @@ fun morph_bmv_axioms phi { Sb_comp_Injs = map (Morphism.thm phi) Sb_comp_Injs, Sb_comp = Morphism.thm phi Sb_comp, Sb_cong = Morphism.thm phi Sb_cong, - Vrs_Injs = map (Morphism.thm phi) Vrs_Injs, - Vrs_Sbs = map (Morphism.thm phi) Vrs_Sbs + Vrs_Injs = map (map (Option.map (Morphism.thm phi))) Vrs_Injs, + Vrs_Sbs = map (map (Option.map (Morphism.thm phi))) Vrs_Sbs } : thm bmv_monad_axioms datatype bmv_monad = BMV of { @@ -81,7 +81,7 @@ datatype bmv_monad = BMV of { Injs: term list list, Sbs: term list, Maps: term option list, - Vrs: term list list (*list*), (* TODO: Need Vr operator per Injection *) + Vrs: term option list list list, axioms: thm bmv_monad_axioms list } @@ -97,7 +97,7 @@ fun morph_bmv_monad phi (BMV { Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Maps = map (Option.map (Morphism.term phi)) Maps, - Vrs = map (map (Morphism.term phi)) Vrs, + Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, axioms = map (morph_bmv_axioms phi) axioms } @@ -127,11 +127,11 @@ type bmv_monad_model = { Injs: term list list, Sbs: term list, Maps: term option list, - Vrs: term list list, + Vrs: term option list list list, tacs: (Proof.context -> tactic) bmv_monad_axioms list } -fun morph_bmv_monad_model phi { ops, bd, var_class, frees, lives, bmv_ops, leader, Injs, Sbs, Maps, Vrs, tacs } = { +fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, bmv_ops, leader, Injs, Sbs, Maps, Vrs, tacs }: bmv_monad_model) = { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, var_class = var_class, @@ -142,7 +142,7 @@ fun morph_bmv_monad_model phi { ops, bd, var_class, frees, lives, bmv_ops, leade Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Maps = map (Option.map (Morphism.term phi)) Maps, - Vrs = map (map (Morphism.term phi)) Vrs, + Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, tacs = tacs } : bmv_monad_model; @@ -155,7 +155,8 @@ fun prove_axioms (model: bmv_monad_model) lthy = val axioms = @{map 5} (fn T => fn Injs => fn Sb => fn Vrs => fn tacs => let - val (own_Injs, other_Injs) = partition (fn Inj => body_type (fastype_of Inj) = T) Injs; + val (own_Injs, other_Injs) = partition (fn Inj => member (op=) (#ops model) (body_type (fastype_of Inj))) Injs; + val is_own_Inj = map (member (op=) (#ops model) o body_type o fastype_of) Injs; val other_idxs = map (fn Inj => find_index (fn T => body_type (fastype_of Inj) = T) Ts) other_Injs; val ((((rhos, rhos'), aa), x), _) = lthy |> mk_Frees "\" (map fastype_of Injs) @@ -199,30 +200,42 @@ fun prove_axioms (model: bmv_monad_model) lthy = )) )) (fn {context=ctxt, ...} => #Sb_comp tacs ctxt); - val Vrs_Injs = @{map 4} (fn Vrs => fn Inj => fn a => fn tac => Goal.prove_sorry lthy [] [] ( - Logic.all a (mk_Trueprop_eq (Vrs $ (Inj $ a), mk_singleton a)) - ) (fn {context=ctxt, ...} => tac ctxt)) (take nown Vrs) own_Injs (take nown aa) (#Vrs_Injs tacs); - - val Vrs_Sbs = map2 (fn Vr => fn tac => Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ [x]) ( - fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( - Vr $ (Term.list_comb (Sb, rhos) $ x), - foldl1 mk_Un (@{map_filter 2} (fn rho => Option.map (fn Vrs' => mk_UNION (Vr $ x) ( - Term.abs ("a", HOLogic.dest_setT (snd (dest_funT (fastype_of Vrs')))) ( - Vrs' $ (rho $ Bound 0) - ) - ))) rhos (map SOME (take nown Vrs) @ map (fn idx => - List.find (fn t => body_type (fastype_of t) = body_type (fastype_of Vr)) (nth Vrss idx) - ) other_idxs)) - )) - )) (fn {context=ctxt, ...} => tac ctxt)) Vrs (#Vrs_Sbs tacs); + val Vrs_Injs = @{map 3} (fn Inj => map2 (@{map_option 2} (fn tac => fn Vrs => + 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 Goal.prove_sorry lthy [] [] ( + Logic.all a (mk_Trueprop_eq ( + Vrs $ (Inj $ a), + if fastype_of a = T then mk_singleton a else mk_bot T)) + ) (fn {context=ctxt, ...} => tac ctxt) end))) own_Injs (#Vrs_Injs tacs) (cond_keep Vrs is_own_Inj); + + val Vrs_Sbs = @{map 3} (fn rho => map2 (@{map_option 2} (fn Vrs => fn tac => + let + val var = HOLogic.dest_setT (body_type (fastype_of Vrs)); + val idx = find_index (fn T => body_type (fastype_of rho) = T) Ts; + val idx' = find_index (fn t => fastype_of t = fastype_of rho) (nth Injss idx); + val Vrs' = hd (map_filter (Option.mapPartial (fn t => + if HOLogic.dest_setT (body_type (fastype_of t)) = var then SOME t else NONE + )) (nth (nth Vrss idx) idx')); + + val goal = fold_rev Logic.all (rhos @ [x]) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + Vrs $ (Term.list_comb (Sb, rhos) $ x), + mk_UNION (Vrs $ x) (Term.abs ("a", var) (Vrs' $ (rho $ Bound 0))) + )) + ); + in Goal.prove_sorry lthy [] [] goal (fn {context=ctxt, ...} => tac ctxt) end + ))) rhos Vrs (#Vrs_Sbs tacs); val Sb_cong = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos' @ [x]) ( - fold_rev (curry Logic.mk_implies) (small_prems @ small_prems' @ @{map 4} (fn rho => fn rho' => fn Vrs => fn a => - Logic.all a (Logic.mk_implies ( + fold_rev (curry Logic.mk_implies) (small_prems @ small_prems' @ flat (@{map 3} (fn rho => fn rho' => map_filter (Option.map (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) - )) - ) rhos rhos' Vrs aa) (mk_Trueprop_eq ( + )) end + ))) rhos rhos' Vrs)) (mk_Trueprop_eq ( Term.list_comb (Sb, rhos) $ x, Term.list_comb (Sb, rhos') $ x ) @@ -247,6 +260,7 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth fst (dest_ordLeq (HOLogic.dest_Trueprop (Thm.prop_of var_large))) ))); in if bd' <> #bd model then error "var_class does not match bound" else () end + val frees = map (fn T => TFree (apsnd ( Sign.minimize_sort (Proof_Context.theory_of lthy) o cons (#var_class model) ) (dest_TFree T))) (#frees model); diff --git a/Tools/mrbnf_util.ML b/Tools/mrbnf_util.ML index a3beb74a..b65fb8b0 100644 --- a/Tools/mrbnf_util.ML +++ b/Tools/mrbnf_util.ML @@ -391,6 +391,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 @@ -404,6 +405,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/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 0839f5e0..059d85cd 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -108,7 +108,7 @@ val model_FType = { Injs = [[@{term "TyVar :: 'a::var \ _"}]], Sbs = [@{term "tvsubst_FType :: _ => 'a::var FType => _"}], Maps = [NONE], - Vrs = [[@{term "FVars_FType :: _ => 'a::var set"}]], + Vrs = [[[SOME @{term "FVars_FType :: _ => 'a::var set"}]]], tacs = [{ Sb_Inj = fn ctxt => resolve_tac ctxt @{thms Sb_Inj_FType} 1, Sb_comp_Injs = [fn ctxt => EVERY1 [ @@ -121,12 +121,12 @@ val model_FType = { K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), REPEAT_DETERM o assume_tac ctxt ], - Vrs_Injs = [fn ctxt => resolve_tac ctxt @{thms Vrs_Inj_FType} 1], - Vrs_Sbs = [fn ctxt => EVERY1 [ + Vrs_Injs = [[SOME (fn ctxt => resolve_tac ctxt @{thms Vrs_Inj_FType} 1)]], + Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ resolve_tac ctxt @{thms Vrs_Sb_FType}, K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), assume_tac ctxt - ]], + ])]], Sb_cong = fn ctxt => EVERY1 [ resolve_tac ctxt @{thms Sb_cong_FType}, K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), @@ -150,9 +150,10 @@ type_synonym ('a1, 'a2) L1 = "'a1 * 'a2" type_synonym ('a1, 'a2) L1_M1 = "'a1" type_synonym ('a1, 'a2) L1_M2 = "'a2" -type_synonym ('a1, 'a2) L2 = "'a1 * 'a2 FType" +type_synonym ('a1, 'a2) L2 = "'a1 * 'a2 * 'a2 * 'a2 FType" type_synonym ('a1, 'a2) L2_M1 = "'a1" - type_synonym ('a1, 'a2) L2_M2 = "'a2 FType" + type_synonym ('a1, 'a2) L2_M2 = "'a2" + type_synonym ('a1, 'a2) L2_M3 = "'a2 FType" (* Dispatcher *) (* from L_M1 *) @@ -205,19 +206,21 @@ definition Vrs_L2_M1_1 :: "('a1, 'a2) L2_M1 \ 'a1 set" where definition Vrs_L2_M1_2 :: "('a1, 'a2) L2_M1 \ 'a2 set" where "Vrs_L2_M1_2 \ \a. {}" (* corresponds to L2_M2 and Inj_L2_M2_2 *) *) (* and its minions M2 *) -definition Sb_L2_M2 :: "('a2::var \ 'a2 FType) \ ('a1, 'a2) L2_M2 \ ('a1, 'a2) L2_M2" where +definition Sb_L2_M2 :: "('a2::var \ 'a2 FType) \ ('a1, 'a2) L2_M3 \ ('a1, 'a2) L2_M3" where "Sb_L2_M2 \ tvsubst_FType" definition Vrs_L2_M2_1 :: "('a1, 'a2) L2_M2 \ 'a1 set" where "Vrs_L2_M2_1 \ \a. {}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) -definition Vrs_L2_M2_2 :: "('a1, 'a2::var) L2_M2 \ 'a2 set" where +definition Vrs_L2_M2_2 :: "('a1, 'a2::var) L2_M3 \ 'a2 set" where "Vrs_L2_M2_2 \ FVars_FType" (* corresponds to L2_M2 and Inj_L2_M2_2 *) (* and then the leader L2 itself *) -definition Sb_L2 :: "('a1 \ 'a1) \ ('a2::var \ 'a2 FType) \ ('a1, 'a2) L2 \ ('a1, 'a2) L2" where - "Sb_L2 \ \f1 f2. map_prod (id f1) (tvsubst_FType f2)" +definition Sb_L2 :: "('a1 \ 'a1) \ ('a2 \ 'a2) \ ('a2::var \ 'a2 FType) \ ('a1, 'a2) L2 \ ('a1, 'a2) L2" where + "Sb_L2 \ \f1 f2 f3. map_prod (id f1) (map_prod (id f2) (map_prod (id f2) (tvsubst_FType f3)))" definition Vrs_L2_1 :: "('a1, 'a2) L2 \ 'a1 set" where - "Vrs_L2_1 \ \(x,x2). {x}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) + "Vrs_L2_1 \ \(x,x2,x3,x4). {x}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) definition Vrs_L2_2 :: "('a1, 'a2::var) L2 \ 'a2 set" where - "Vrs_L2_2 \ \(x,x2). FVars_FType x2" (* corresponds to L2_M2 and Inj_L2_M2_2 *) + "Vrs_L2_2 \ \(x,x2,x3,x4). {x2,x3}" (* corresponds to L2_M2 and Inj_L2_M2_2 *) +definition Vrs_L2_3 :: "('a1, 'a2::var) L2 \ 'a2 set" where + "Vrs_L2_3 \ \(x,x2,x3,x4). FVars_FType x4" (* corresponds to L2_M2 and Inj_L2_M2_2 *) (* Composition *) type_synonym ('a1, 'a2) LC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L" @@ -245,7 +248,7 @@ val model_ID = { Maps = [NONE], Injs = [[@{term "id :: 'a \ _"}]], Sbs = [@{term "id :: _ => 'a => 'a"}], - Vrs = [[@{term "\(x::'a). {x}"}]], + Vrs = [[[SOME @{term "\(x::'a). {x}"}]]], tacs = [{ Sb_Inj = fn ctxt => resolve_tac ctxt @{thms id_apply} 1, Sb_comp_Injs = [fn ctxt => EVERY1 [ @@ -256,14 +259,14 @@ val model_ID = { K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), resolve_tac ctxt [refl] ], - Vrs_Injs = [fn ctxt => EVERY1 [ + Vrs_Injs = [[SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), resolve_tac ctxt [refl] - ]], - Vrs_Sbs = [fn ctxt => EVERY1 [ + ])]], + Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms UN_single id_def}), resolve_tac ctxt [refl] - ]], + ])]], Sb_cong = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), dresolve_tac ctxt @{thms meta_spec}, @@ -284,7 +287,7 @@ val model_L = { bd = @{term natLeq}, var_class = @{class var}, leader = 0, - frees = [@{typ "'a1"}, @{typ "'a2"}], + frees = [@{typ "'a1"}], lives = [@{typ "'c1"}, @{typ "'c2"}], bmv_ops = [BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( @@ -293,9 +296,9 @@ val model_L = { Maps = [SOME @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}], Injs = [[@{term "id :: 'a1 \ 'a1"}]], Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], - Vrs = [[ - @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} - ]], + Vrs = [[[ + SOME @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} + ]]], tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def prod.map_id0}), @@ -310,13 +313,13 @@ val model_L = { resolve_tac ctxt [refl] ], Vrs_Injs = [], - Vrs_Sbs = [fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta + Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta Product_Type.fst_map_prod Product_Type.snd_map_prod UN_insert UN_empty Un_empty_right insert_is_Un[symmetric] }), resolve_tac ctxt [refl] - ]], + ])]], Sb_cong = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta}), resolve_tac ctxt @{thms prod.map_cong0}, @@ -365,7 +368,10 @@ val model_L1 = { Maps = [NONE], Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], - Vrs = [[@{term "\(x::'a1, x2::'a2). {x}"}, @{term "\(x::'a1, x2::'a2). {x2}"}]], + Vrs = [[ + [SOME @{term "\(x::'a1, x2::'a2). {x}"}, NONE], + [NONE, SOME @{term "\(x::'a1, x2::'a2). {x2}"}] + ]], tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def prod.map_id0}), @@ -381,16 +387,16 @@ val model_L1 = { ], Vrs_Injs = [], Vrs_Sbs = [ - fn ctxt => EVERY1 [ + [SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), resolve_tac ctxt [refl] - ], - fn ctxt => EVERY1 [ + ]), NONE], + [NONE, SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), resolve_tac ctxt [refl] - ] + ])] ], Sb_cong = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_beta}), @@ -416,16 +422,22 @@ ML \ val L1_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L1 @{context}) \ -(* ML \ +ML \ val model_L2 = { - ops = [@{typ "'a2 * 'a2::var FType"}], + ops = [@{typ "('a1, 'a2) L2"}], + bd = @{term natLeq}, + var_class = @{class var}, leader = 0, - frees = [@{typ "'a2::var"}], + frees = [@{typ 'a1}, @{typ "'a2"}], lives = [], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2::var"}] + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + )) id_bmv, + BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2"}] )) id_bmv, BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( @@ -433,9 +445,13 @@ val model_L2 = { )) FType_bmv ], Maps = [NONE], - Injs = [([], [(@{term "id :: 'a2::var \ 'a2"}, 1), (@{term "TyVar :: 'a2::var \ 'a2 FType"}, 2)])], - Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ ('a2, 'a2::var) L2"}], - Vrs = [[@{term "Vrs_L2_1 :: ('a2, 'a2::var) L2 \ _"}, @{term "Vrs_L2_2 :: ('a2, 'a2::var) L2 \ _"}]], + Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], + Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], + Vrs = [[ + [SOME @{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, NONE], + [NONE, SOME @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}], + [NONE, SOME @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"}] + ]], tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), @@ -451,21 +467,26 @@ val model_L2 = { ], Vrs_Injs = [], Vrs_Sbs = [ - fn ctxt => EVERY1 [ + [SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), resolve_tac ctxt [refl] - ], - fn ctxt => EVERY1 [ + ]), NONE], + [NONE, SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta insert_is_Un[symmetric] UN_insert UN_empty Un_empty_right id_apply}), + resolve_tac ctxt [refl] + ])], + [NONE, SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_3_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), resolve_tac ctxt @{thms Vrs_Sb_FType}, K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), assume_tac ctxt - ] + ])] ], Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def case_prod_beta id_apply}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def Vrs_L2_3_def case_prod_beta id_apply}), resolve_tac ctxt @{thms prod.map_cong0}, eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, dresolve_tac ctxt @{thms meta_spec}, @@ -474,87 +495,32 @@ val model_L2 = { hyp_subst_tac ctxt, assume_tac ctxt, eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, - resolve_tac ctxt @{thms Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]}, - REPEAT_DETERM o assume_tac ctxt, - rotate_tac ~3, + resolve_tac ctxt @{thms prod.map_cong0}, + eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + hyp_subst_tac ctxt, + rotate_tac ~2, dresolve_tac ctxt @{thms meta_spec}, dresolve_tac ctxt @{thms meta_mp}, - hyp_subst_tac ctxt, + resolve_tac ctxt @{thms insertI1}, assume_tac ctxt, - assume_tac ctxt - ] - } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : BMV_Monad_Def.bmv_monad_model; -\ -ML \ -val L2_bmv = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context} -\ *) -ML \ -val model_L2 = { - ops = [@{typ "'a1 * 'a2::var FType"}], - bd = @{term natLeq}, - var_class = @{class var}, - leader = 0, - frees = [@{typ 'a1}, @{typ "'a2::var"}], - lives = [], - bmv_ops = [ - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] - )) id_bmv, - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad FType_bmv ~~ [@{typ "'a2::var"}] - )) FType_bmv - ], - Maps = [NONE], - Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], - Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ ('a1, 'a2::var) L2"}], - Vrs = [[@{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}]], - tacs = [{ - Sb_Inj = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), - resolve_tac ctxt [refl] - ], - Sb_comp_Injs = [], - Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ( - (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) - :: @{thms Sb_L2_def id_apply Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]} - )), - resolve_tac ctxt [refl] - ], - Vrs_Injs = [], - Vrs_Sbs = [ - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), - resolve_tac ctxt [refl] - ], - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), - resolve_tac ctxt @{thms Vrs_Sb_FType}, - K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), - assume_tac ctxt - ] - ], - Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def case_prod_beta id_apply}), + hyp_subst_tac ctxt, + eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, resolve_tac ctxt @{thms prod.map_cong0}, eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, + hyp_subst_tac ctxt, + rotate_tac ~2, dresolve_tac ctxt @{thms meta_spec}, dresolve_tac ctxt @{thms meta_mp}, + resolve_tac ctxt @{thms insertI2}, resolve_tac ctxt @{thms singletonI}, - hyp_subst_tac ctxt, assume_tac ctxt, eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, + hyp_subst_tac ctxt, resolve_tac ctxt @{thms Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]}, REPEAT_DETERM o assume_tac ctxt, - rotate_tac ~3, + rotate_tac ~2, dresolve_tac ctxt @{thms meta_spec}, dresolve_tac ctxt @{thms meta_mp}, - hyp_subst_tac ctxt, assume_tac ctxt, assume_tac ctxt ] From 70a5a1a1d5ceb93c0f25e998c350c290a8017286 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 12 Dec 2024 18:23:47 +0000 Subject: [PATCH 05/90] Add vars_bd theorems to BMV Monad --- Tools/bmv_monad_def.ML | 15 ++++++++++++--- operations/BMV_Monad.thy | 25 +++++++++++++++++++++++++ 2 files changed, 37 insertions(+), 3 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 93fd0f25..0aad33d3 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -7,7 +7,7 @@ signature BMV_MONAD_DEF = sig Sb_comp_Injs: 'a list, Sb_comp: 'a, Sb_cong: 'a, - (* TODO: Add Vrs_bd axiom *) + Vrs_bds: 'a option list list, Vrs_Injs: 'a option list list, Vrs_Sbs: 'a option list list (* Add optional Map_Sb axiom (dependent on iff Map exists) *) @@ -56,17 +56,19 @@ type 'a bmv_monad_axioms = { Sb_comp_Injs: 'a list, Sb_comp: 'a, Sb_cong: 'a, + Vrs_bds: 'a option list list, Vrs_Injs: 'a option list list, Vrs_Sbs: 'a option list list }; fun morph_bmv_axioms phi { - Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_Injs, Vrs_Sbs + Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_bds, Vrs_Injs, Vrs_Sbs } = { Sb_Inj = Morphism.thm phi Sb_Inj, Sb_comp_Injs = map (Morphism.thm phi) Sb_comp_Injs, Sb_comp = Morphism.thm phi Sb_comp, Sb_cong = Morphism.thm phi Sb_cong, + Vrs_bds = map (map (Option.map (Morphism.thm phi))) Vrs_bds, Vrs_Injs = map (map (Option.map (Morphism.thm phi))) Vrs_Injs, Vrs_Sbs = map (map (Option.map (Morphism.thm phi))) Vrs_Sbs } : thm bmv_monad_axioms @@ -200,6 +202,12 @@ fun prove_axioms (model: bmv_monad_model) lthy = )) )) (fn {context=ctxt, ...} => #Sb_comp tacs ctxt); + val Vrs_bds = map2 (map2 (@{map_option 2} (fn Vrs => fn tac => + Goal.prove_sorry lthy [] [] (Logic.all x (HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (Vrs $ x)) (#bd model) + ))) (fn {context=ctxt, ...} => tac ctxt) + ))) Vrs (#Vrs_bds tacs); + val Vrs_Injs = @{map 3} (fn Inj => map2 (@{map_option 2} (fn tac => fn Vrs => let val a = the (List.find (fn a => fastype_of a = hd (binder_types (fastype_of Inj))) aa); @@ -246,9 +254,10 @@ fun prove_axioms (model: bmv_monad_model) lthy = Sb_comp_Injs = Sb_comp_Injs, Sb_comp = Sb_comp, Vrs_Injs = Vrs_Injs, + Vrs_bds = Vrs_bds, Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong - } end + } : thm bmv_monad_axioms end ) (#ops model) (#Injs model) (#Sbs model) (#Vrs model) (#tacs model); in axioms end; diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 059d85cd..db218791 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -121,6 +121,7 @@ val model_FType = { K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), REPEAT_DETERM o assume_tac ctxt ], + Vrs_bds = [[SOME (fn ctxt => resolve_tac ctxt @{thms FType.set_bd} 1)]], Vrs_Injs = [[SOME (fn ctxt => resolve_tac ctxt @{thms Vrs_Inj_FType} 1)]], Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ resolve_tac ctxt @{thms Vrs_Sb_FType}, @@ -259,6 +260,7 @@ val model_ID = { K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), resolve_tac ctxt [refl] ], + Vrs_bds = [[SOME (fn ctxt => resolve_tac ctxt @{thms ID.set_bd} 1)]], Vrs_Injs = [[SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), resolve_tac ctxt [refl] @@ -281,6 +283,9 @@ ML \ val id_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_ID @{context}) \ +lemma insert_bound: "Cinfinite r \ |A| |insert x A| val model_L = { ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], @@ -312,6 +317,12 @@ val model_L = { )), resolve_tac ctxt [refl] ], + Vrs_bds = [[SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta}), + resolve_tac ctxt @{thms insert_bound}, + resolve_tac ctxt @{thms natLeq_Cinfinite}, + resolve_tac ctxt @{thms ID.set_bd} + ])]], Vrs_Injs = [], Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta @@ -385,6 +396,10 @@ val model_L1 = { )), resolve_tac ctxt [refl] ], + Vrs_bds = [ + [SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1), NONE], + [NONE, SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1)] + ], Vrs_Injs = [], Vrs_Sbs = [ [SOME (fn ctxt => EVERY1 [ @@ -465,6 +480,16 @@ val model_L2 = { )), resolve_tac ctxt [refl] ], + Vrs_bds = [ + [SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_1_def} THEN resolve_tac ctxt @{thms ID.set_bd} 1), NONE], + [NONE, SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_2_def}), + resolve_tac ctxt @{thms insert_bound}, + resolve_tac ctxt @{thms natLeq_Cinfinite}, + resolve_tac ctxt @{thms ID.set_bd} + ])], + [NONE, SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_3_def} THEN resolve_tac ctxt @{thms FType.set_bd} 1)] + ], Vrs_Injs = [], Vrs_Sbs = [ [SOME (fn ctxt => EVERY1 [ From 49636dc8b01712a88c97256edd9871736b207e39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 15 Dec 2024 14:17:09 +0000 Subject: [PATCH 06/90] Prove supported functor structure --- Tools/bmv_monad_def.ML | 184 ++++++++++++++++++++++++++++++++++----- operations/BMV_Monad.thy | 54 ++++++++++-- 2 files changed, 211 insertions(+), 27 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 0aad33d3..ff9bb30f 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1,6 +1,12 @@ signature BMV_MONAD_DEF = sig type bmv_monad - type supported_functor (* TODO *) + + type 'a supported_functor_axioms = { + Map_id: 'a, + Map_comp: 'a, + Supp_Map: 'a list, + Map_cong: 'a + }; type 'a bmv_monad_axioms = { Sb_Inj: 'a, @@ -10,7 +16,12 @@ signature BMV_MONAD_DEF = sig Vrs_bds: 'a option list list, Vrs_Injs: 'a option list list, Vrs_Sbs: 'a option list list - (* Add optional Map_Sb axiom (dependent on iff Map exists) *) + }; + + type supported_functor_model = { + Map: term, + Supps: term list, + tacs: (Proof.context -> tactic) supported_functor_axioms }; type bmv_monad_model = { @@ -19,11 +30,15 @@ signature BMV_MONAD_DEF = sig var_class: class, bmv_ops: bmv_monad list, frees: typ list, - lives: typ list, leader: int, + lives: typ list, + lives': typ list, + params: { + model: supported_functor_model, + Map_Sb: Proof.context -> tactic + } option list, Injs: term list list, Sbs: term list, - Maps: term option list, Vrs: term option list list list, tacs: (Proof.context -> tactic) bmv_monad_axioms list } @@ -34,9 +49,11 @@ signature BMV_MONAD_DEF = sig val leader_of_bmv_monad: bmv_monad -> int; val frees_of_bmv_monad: bmv_monad -> typ list; val lives_of_bmv_monad: bmv_monad -> typ list; + val lives'_of_bmv_monad: bmv_monad -> typ 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 option list list list; val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; @@ -73,6 +90,26 @@ fun morph_bmv_axioms phi { Vrs_Sbs = map (map (Option.map (Morphism.thm phi))) Vrs_Sbs } : thm bmv_monad_axioms +type 'a supported_functor_axioms = { + Map_id: 'a, + Map_comp: 'a, + Supp_Map: 'a list, + Map_cong: 'a +}; + +fun morph_supported_functor_axioms phi { Map_id, Map_comp, Supp_Map, Map_cong } = { + Map_id = Morphism.thm phi Map_id, + Map_comp = Morphism.thm phi Map_comp, + Supp_Map = map (Morphism.thm phi) Supp_Map, + Map_cong = Morphism.thm phi Map_cong +} : thm supported_functor_axioms; + +type supported_functor_model = { + Map: term, + Supps: term list, + tacs: (Proof.context -> tactic) supported_functor_axioms +}; + datatype bmv_monad = BMV of { ops: typ list, bd: term, @@ -80,15 +117,28 @@ datatype bmv_monad = BMV of { leader: int, frees: typ list, lives: typ list, + lives': typ list, + params: { + Map: term, + Supps: term list, + axioms: thm supported_functor_axioms, + Map_Sb: thm + } option list, Injs: term list list, Sbs: term list, - Maps: term option list, Vrs: term option list list list, axioms: thm bmv_monad_axioms list } +fun morph_bmv_param phi { Map, Supps, axioms, Map_Sb } = { + Map = Morphism.term phi Map, + Supps = map (Morphism.term phi) Supps, + axioms = morph_supported_functor_axioms phi axioms, + Map_Sb = Morphism.thm phi Map_Sb +}; + fun morph_bmv_monad phi (BMV { - ops, bd, var_class, leader, frees, lives, Injs, Sbs, Maps, Vrs, axioms + ops, bd, var_class, leader, frees, lives, lives', params, Injs, Sbs, Vrs, axioms }) = BMV { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, @@ -96,15 +146,14 @@ fun morph_bmv_monad phi (BMV { var_class = var_class, frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, + lives' = map (Morphism.typ phi) lives', + params = map (Option.map (morph_bmv_param phi)) params, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, - Maps = map (Option.map (Morphism.term phi)) Maps, Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, axioms = map (morph_bmv_axioms phi) axioms } -datatype supported_functor = Supported_Functor (* TODO *) - fun Rep_bmv (BMV x) = x val ops_of_bmv_monad = #ops o Rep_bmv @@ -113,41 +162,70 @@ 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 Injs_of_bmv_monad = #Injs o Rep_bmv val Sbs_of_bmv_monad = #Sbs o Rep_bmv -val Maps_of_bmv_monad = #Maps o Rep_bmv +val Maps_of_bmv_monad = map (Option.map #Map) o #params o Rep_bmv +val Supps_of_bmv_monad = map (Option.map #Supps) o #params o Rep_bmv val Vrs_of_bmv_monad = #Vrs o Rep_bmv +type supported_functor_model = { + Map: term, + Supps: term list, + tacs: (Proof.context -> tactic) supported_functor_axioms +}; + +fun morph_supported_functor_model phi { Map, Supps, tacs } = { + Map = Morphism.term phi Map, + Supps = map (Morphism.term phi) Supps, + tacs = tacs +} : supported_functor_model; + type bmv_monad_model = { ops: typ list, bd: term, var_class: class, frees: typ list, lives: typ list, + lives': typ list, + params: { + model: supported_functor_model, + Map_Sb: Proof.context -> tactic + } option list, bmv_ops: bmv_monad list, leader: int, Injs: term list list, Sbs: term list, - Maps: term option list, Vrs: term option list list list, tacs: (Proof.context -> tactic) bmv_monad_axioms list } -fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, bmv_ops, leader, Injs, Sbs, Maps, Vrs, tacs }: bmv_monad_model) = { +fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, Injs, Sbs, Vrs, tacs }: bmv_monad_model) = { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, var_class = var_class, frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, + lives' = map (Morphism.typ phi) lives', + params = map (Option.map (fn { model, Map_Sb } => { + model = morph_supported_functor_model phi model, + Map_Sb = Map_Sb + })) params, bmv_ops = map (morph_bmv_monad phi) bmv_ops, leader = leader, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, - Maps = map (Option.map (Morphism.term phi)) Maps, Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, tacs = tacs } : bmv_monad_model; +val mk_small_prems = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (HOLogic.mk_Collect ("a", fst (dest_funT (fastype_of Inj)), + HOLogic.mk_not (HOLogic.mk_eq (rho $ Bound 0, Inj $ Bound 0)) + ))) + (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of Inj))))) +)); + fun prove_axioms (model: bmv_monad_model) lthy = let val Ts = #ops model @ maps ops_of_bmv_monad (#bmv_ops model); @@ -173,14 +251,8 @@ fun prove_axioms (model: bmv_monad_model) lthy = mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T) ) (fn {context=ctxt, ...} => #Sb_Inj tacs ctxt); - fun mk_small_prems rhos = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (HOLogic.mk_Collect ("a", fst (dest_funT (fastype_of Inj)), - HOLogic.mk_not (HOLogic.mk_eq (rho $ Bound 0, Inj $ Bound 0)) - ))) - (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of Inj))))) - )) rhos Injs; - val small_prems = mk_small_prems rhos; - val small_prems' = mk_small_prems rhos'; + val small_prems = mk_small_prems rhos Injs; + val small_prems' = mk_small_prems rhos' Injs; val Sb_comp_Injs = @{map 3} (fn Inj => fn rho => fn tac => Goal.prove_sorry lthy [] [] ( fold_rev Logic.all rhos (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( @@ -261,6 +333,72 @@ fun prove_axioms (model: bmv_monad_model) lthy = ) (#ops model) (#Injs model) (#Sbs model) (#Vrs model) (#tacs model); in axioms end; +fun prove_params (model: bmv_monad_model) lthy = @{map 4} (fn T => fn Sb => fn Injs => Option.map (fn param => + let + val (Cs, _) = lthy + |> mk_TFrees (length (#lives model)); + val ((((fs, gs), rhos), x), _) = lthy + |> mk_Frees "f" (map2 (curry (op-->)) (#lives model) (#lives' model)) + ||>> mk_Frees "g" (map2 (curry (op-->)) (#lives' model) Cs) + ||>> mk_Frees "\" (map fastype_of Injs) + ||>> apfst hd o mk_Frees "x" [T]; + val pmodel = #model param; + + val Map_id = Goal.prove_sorry lthy [] [] (Term.subst_atomic_types (#lives' model ~~ #lives model) ( + mk_Trueprop_eq ( + Term.list_comb (#Map pmodel, map HOLogic.id_const (#lives model)), HOLogic.id_const T + ) + )) (fn {context=ctxt, ...} => #Map_id (#tacs pmodel) ctxt); + + val Map_comp = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb ( + Term.subst_atomic_types ((#lives model @ #lives' model) ~~ (#lives' model @ Cs)) (#Map pmodel), gs + ), Term.list_comb (#Map pmodel, fs)), + Term.list_comb (Term.subst_atomic_types (#lives' model ~~ Cs) (#Map pmodel), map2 (curry HOLogic.mk_comp) gs fs) + ))) (fn {context=ctxt, ...} => #Map_comp (#tacs pmodel) ctxt); + + val Supp_Maps = @{map 3} (fn Supp => fn f => fn tac => + Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( + Term.subst_atomic_types (#lives model ~~ #lives' model) Supp $ (Term.list_comb (#Map pmodel, fs) $ x), + mk_image f $ (Supp $ x) + ))) (fn {context=ctxt, ...} => tac ctxt) + ) (#Supps pmodel) fs (#Supp_Map (#tacs pmodel)); + + val (gs', _) = lthy + |> mk_Frees "g" (map fastype_of fs); + val Map_cong = Goal.prove_sorry lthy [] [] (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 pmodel) fs gs') (mk_Trueprop_eq ( + Term.list_comb (#Map pmodel, fs) $ x, + Term.list_comb (#Map pmodel, gs') $ x + )))) (fn {context=ctxt, ...} => #Map_cong (#tacs pmodel) ctxt); + + val Map_Sb = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ rhos) ( + fold_rev (curry Logic.mk_implies) (mk_small_prems rhos Injs) (mk_Trueprop_eq ( + HOLogic.mk_comp (Term.list_comb (#Map pmodel, fs), Term.list_comb (Sb, rhos)), + HOLogic.mk_comp (Term.list_comb ( + Term.subst_atomic_types (#lives model ~~ #lives' model) Sb, rhos + ), Term.list_comb (#Map pmodel, fs)) + )) + )) (fn {context=ctxt, ...} => #Map_Sb param ctxt); + in { + Map = #Map pmodel, + Supps = #Supps pmodel, + axioms = { + Map_id = Map_id, + Map_comp = Map_comp, + Supp_Map = Supp_Maps, + Map_cong = Map_cong + }, + Map_Sb = Map_Sb + } end +)) (#ops model) (#Sbs model) (#Injs model) (#params model); + fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lthy = let val _ = let @@ -276,6 +414,7 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) model; val axioms = prove_axioms model lthy; + val params = prove_params model lthy; val bmv = BMV { ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), @@ -284,10 +423,11 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth leader = #leader model, frees = #frees model, lives = #lives model, + lives' = #lives' model, + params = params, Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), - Maps = #Maps model @ maps (#Maps o Rep_bmv) (#bmv_ops model), axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model) } : bmv_monad; in (bmv, lthy) end diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index db218791..7aba33f1 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -104,10 +104,11 @@ val model_FType = { leader = 0, frees = [@{typ "'a::var"}], lives = [], + lives' = [], + params = [NONE], bmv_ops = [], Injs = [[@{term "TyVar :: 'a::var \ _"}]], Sbs = [@{term "tvsubst_FType :: _ => 'a::var FType => _"}], - Maps = [NONE], Vrs = [[[SOME @{term "FVars_FType :: _ => 'a::var set"}]]], tacs = [{ Sb_Inj = fn ctxt => resolve_tac ctxt @{thms Sb_Inj_FType} 1, @@ -245,8 +246,9 @@ val model_ID = { leader = 0, frees = [@{typ "'a"}], lives = [], + lives' = [], bmv_ops = [], - Maps = [NONE], + params = [NONE], Injs = [[@{term "id :: 'a \ _"}]], Sbs = [@{term "id :: _ => 'a => 'a"}], Vrs = [[[SOME @{term "\(x::'a). {x}"}]]], @@ -294,11 +296,51 @@ val model_L = { leader = 0, frees = [@{typ "'a1"}], lives = [@{typ "'c1"}, @{typ "'c2"}], + lives' = [@{typ "'c1'"}, @{typ "'c2'"}], bmv_ops = [BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] )) id_bmv], - Maps = [SOME @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}], + params = [SOME { + model = { + Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}, + Supps = [ + @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, + @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} + ], + tacs = { + Map_id = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms sum.map_id0 id_apply}), + resolve_tac ctxt [ext], + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta prod.collapse}), + resolve_tac ctxt @{thms id_apply[symmetric]} + ], + Map_comp = fn ctxt => EVERY1 [ + resolve_tac ctxt [ext], + resolve_tac ctxt @{thms trans[OF comp_apply]}, + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum.map_comp}), + resolve_tac ctxt [refl] + ], + Supp_Map = replicate 2 (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), + resolve_tac ctxt [refl] + ]), + Map_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv}), + K (Local_Defs.unfold0_tac ctxt @{thms prod.inject}), + REPEAT_DETERM o resolve_tac ctxt @{thms conjI[OF refl]}, + resolve_tac ctxt @{thms sum.map_cong0}, + REPEAT_DETERM o Goal.assume_rule_tac ctxt + ] + } + }, + Map_Sb = fn ctxt => EVERY1 [ + resolve_tac ctxt [ext], + K (Local_Defs.unfold0_tac ctxt @{thms comp_def Sb_L_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta id_apply map_prod_simp}), + resolve_tac ctxt [refl] + ] + }], Injs = [[@{term "id :: 'a1 \ 'a1"}]], Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], Vrs = [[[ @@ -366,6 +408,7 @@ val model_L1 = { leader = 0, frees = [@{typ "'a1"}, @{typ "'a2"}], lives = [], + lives' = [], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( @@ -376,7 +419,7 @@ val model_L1 = { BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2"}] )) id_bmv ], - Maps = [NONE], + params = [NONE], Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], Vrs = [[ @@ -445,6 +488,7 @@ val model_L2 = { leader = 0, frees = [@{typ 'a1}, @{typ "'a2"}], lives = [], + lives' = [], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( @@ -459,7 +503,7 @@ val model_L2 = { BMV_Monad_Def.frees_of_bmv_monad FType_bmv ~~ [@{typ "'a2::var"}] )) FType_bmv ], - Maps = [NONE], + params = [NONE], Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], Vrs = [[ From c690d1c8b2a38bf95552202df769a1faaaedc827 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 24 Dec 2024 16:12:27 +0000 Subject: [PATCH 07/90] Generate composed constants --- Tools/bmv_monad_def.ML | 171 +++++++++++++++++++++++++++++++++++++-- operations/BMV_Monad.thy | 9 ++- 2 files changed, 171 insertions(+), 9 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index ff9bb30f..6a99ee34 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -55,6 +55,13 @@ signature BMV_MONAD_DEF = sig 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 option list list list; + val axioms_of_bmv_monad: bmv_monad -> thm bmv_monad_axioms list; + val params_of_bmv_monad: bmv_monad -> { + Map: term, + Supps: term list, + axioms: thm supported_functor_axioms, + Map_Sb: thm + } option list; val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; @@ -168,6 +175,8 @@ val Sbs_of_bmv_monad = #Sbs o Rep_bmv val Maps_of_bmv_monad = map (Option.map #Map) o #params o Rep_bmv val Supps_of_bmv_monad = map (Option.map #Supps) o #params o Rep_bmv val Vrs_of_bmv_monad = #Vrs o Rep_bmv +val axioms_of_bmv_monad = #axioms o Rep_bmv +val params_of_bmv_monad = #params o Rep_bmv type supported_functor_model = { Map: term, @@ -424,7 +433,7 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth frees = #frees model, lives = #lives model, lives' = #lives' model, - params = params, + params = params @ maps (#params o Rep_bmv) (#bmv_ops model), Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), @@ -437,16 +446,166 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth - does not appear in the codomain of any (=of any **other** SOp) Injection, *) -fun compose_bmv_monad qualify outer inners lthy = +fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy = let val _ = if length (lives_of_bmv_monad outer) <> length inners then error "Outer needs exactly as many lives as there are inners" else () - val ops' = map (Term.typ_subst_atomic (lives_of_bmv_monad outer ~~ map (fn bmv => - nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv) - ) inners)) (ops_of_bmv_monad outer); + val bmvs = Typtab.make_distinct (flat (map (fn bmv => (#ops bmv ~~ + ((#params bmv) ~~ (#Injs bmv) ~~ (#Sbs bmv) ~~ (#Vrs bmv) ~~ map SOME (#axioms bmv) ~~ replicate (length (#Sbs bmv)) (SOME bmv)) + )) (map Rep_bmv inners))); + + val outer_ops' = map (fn T => if Typtab.defined bmvs T then NONE else SOME T) ( + map (Term.typ_subst_atomic (lives_of_bmv_monad outer ~~ map (fn bmv => + nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv) + ) inners)) (ops_of_bmv_monad outer) + ); + + val ((Sbs, Injs), Vrs) = apfst split_list (split_list (@{map 5} (fn NONE => K (K (K (K ((NONE, NONE), NONE)))) | SOME T => (fn NONE => K (K (K ((NONE, NONE), NONE))) + | SOME param => fn Sb => fn Injs => fn Vrs => + let + val ((Sbs, Ts), (Injss, Vrsss)) = apfst split_list (apsnd split_list (split_list (map (fn bmv => + let fun pick xs = nth xs (leader_of_bmv_monad bmv) + in ( + (pick (Sbs_of_bmv_monad bmv), pick (ops_of_bmv_monad bmv)), + (pick (Injs_of_bmv_monad bmv), pick (Vrs_of_bmv_monad bmv)) + ) end + ) inners))); + val subst = (lives_of_bmv_monad outer @ lives'_of_bmv_monad outer) ~~ (Ts @ Ts); + val Injs' = distinct ((op=) o apply2 fastype_of) (Injs @ flat Injss); + val ((fs, x), _) = lthy + |> mk_Frees "f" (map fastype_of Injs') + ||>> apfst hd o mk_Frees "x" [T]; + + val Vrs' = @{fold 4} (fn i => fn inner => @{fold 2} (fn Inj => fn Vrs => fn tab => + case Typtab.lookup tab (fastype_of Inj) of + NONE => tab + | SOME inner_tab => + let val inner_tab' = @{fold 2} (fn NONE => K I | SOME Vrs => fn free => + Typtab.map_default (free, [(i, Vrs)]) (cons (i, Vrs)) + ) Vrs (frees_of_bmv_monad inner) inner_tab; + in Typtab.update (fastype_of Inj, inner_tab') tab end + )) (0 upto length inners) (outer :: inners) (Injs :: Injss) (Vrs :: Vrsss) (Typtab.make (map (rpair Typtab.empty o fastype_of) Injs')); - val _ = @{print} ops' + val frees = distinct (op=) (maps snd (Typtab.dest (Typtab.map (K Typtab.keys) Vrs'))); + + val Supps = map (Term.subst_atomic_types subst) (#Supps param) + val Vrs' = map (fn Inj => map (fn free => Option.mapPartial (fn xs => + let + val Vrss = distinct (op=) (rev xs); + val Vrs' = the_default [] (Option.map (fn s => + [Term.subst_atomic_types subst (s $ x)] + ) (AList.lookup (op=) Vrss 0)) + @ @{map_filter 2} (fn i => fn Supp => Option.map (fn t => + mk_UNION (Supp $ x) t + ) (AList.lookup (op=) Vrss i)) (1 upto length Supps) Supps; + + in case Vrs' of + [] => NONE + | _ => SOME (Term.absfree (dest_Free x) (foldl1 mk_Un Vrs')) + end + ) (Typtab.lookup (the (Typtab.lookup Vrs' (fastype_of Inj))) free)) frees) Injs'; + + val find_fs = map (fn Inj => + the (List.find (fn f => fastype_of f = fastype_of Inj) fs) + ); + in (( + SOME (Term.subst_atomic_types subst ( + fold_rev (Term.absfree o dest_Free) fs (HOLogic.mk_comp ( + Term.list_comb (#Map param, + map2 (fn Sb => fn Injs => Term.list_comb (Sb, find_fs Injs)) Sbs Injss + ), Term.list_comb (Sb, find_fs Injs) + )) + )), + SOME Injs'), + SOME Vrs' + ) end + )) outer_ops' (#params (Rep_bmv outer)) (Sbs_of_bmv_monad outer) (Injs_of_bmv_monad outer) (Vrs_of_bmv_monad outer))); + + fun drop_lead xs = map_filter I (nth_drop (leader_of_bmv_monad outer) xs); + + val bmvs = @{fold 3} (fn T => fn Sb => fn Injs => Typtab.map_default (T, + (((((NONE, Injs), Sb), []), NONE), NONE) + ) I) (drop_lead outer_ops') (drop_lead Sbs) (drop_lead Injs) bmvs; + + fun add_ops T Injs bmvs = T :: flat (map_filter I (fst (fold_map (fn Inj => fn bmvs => + let val T = body_type (fastype_of Inj); + in case Typtab.lookup bmvs T of + NONE => (NONE, bmvs) + | SOME (((((_, Injs), _), _), _), _) => + let val bmvs' = Typtab.delete T bmvs + in (SOME (add_ops T Injs bmvs'), bmvs') end + end + ) Injs bmvs))) + + fun pick xs = nth xs (leader_of_bmv_monad outer) + val ops = add_ops (the (pick outer_ops')) (the (pick Injs)) bmvs; + + val bmv_ops = map_filter (fn T => case Typtab.lookup bmvs T of + SOME (((((param, Injs), Sb), Vrs), SOME axioms), SOME bmv) => SOME (BMV { + ops = [T], + bd = #bd bmv, + var_class = #var_class bmv, + leader = 0, + frees = #frees bmv, + lives = #lives bmv, + lives' = #lives' bmv, + params = [param], + Injs = [Injs], + Sbs = [Sb], + Vrs = [Vrs], + axioms = [axioms] + }) | _ => NONE + ) ops; + + val ops' = subtract (fn (bmv, T) => hd (ops_of_bmv_monad bmv) = T) bmv_ops ops; + + val idxs = map (fn T => find_index (curry (op=) T) ops) ops'; + val Vrs = map (the o nth Vrs) idxs; + val frees = distinct (op=) (maps frees_of_bmv_monad (outer :: inners)); + + val model = { + ops = ops', + bmv_ops = bmv_ops, + bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) + var_class = var_class_of_bmv_monad outer, + frees = frees, + lives = distinct (op=) (maps lives_of_bmv_monad inners), + lives' = distinct (op=) (maps lives'_of_bmv_monad inners), + params = replicate (length ops') NONE, + leader = 0, + Injs = map (the o nth Injs) idxs, + Sbs = map (the o nth Sbs) idxs, + Vrs = Vrs, + tacs = map2 (fn axioms => fn param => { + Sb_Inj = fn ctxt => EVERY [ + Local_Defs.unfold0_tac ctxt (#Sb_Inj axioms :: @{thms o_id}), + Local_Defs.unfold0_tac ctxt ( + #Map_id (#axioms param) + :: maps (map #Sb_Inj o axioms_of_bmv_monad) inners + ), + rtac ctxt refl 1 + ], + Sb_comp_Injs = map (fn thm => fn ctxt => + print_tac ctxt "Sb_comp_Inj" + ) (#Sb_comp_Injs axioms), + Sb_comp = fn ctxt => print_tac ctxt "Sb_comp", + Vrs_bds = map (map (fn Vrs => SOME (fn ctxt => + print_tac ctxt "Vrs_bds" + ))) Vrs, + Vrs_Injs = map (map (Option.map (fn thm => fn ctxt => + print_tac ctxt "Vrs_Injs" + ))) (#Vrs_Injs axioms), + Vrs_Sbs = map (map (fn Vrs => SOME (fn ctxt => + print_tac ctxt "Vrs_Sbs" + ))) Vrs, + Sb_cong = fn ctxt => print_tac ctxt "Sb_cong" + } : (Proof.context -> tactic) bmv_monad_axioms) + (map (nth (axioms_of_bmv_monad outer)) idxs) + (map (the o nth (params_of_bmv_monad outer)) idxs) + } : bmv_monad_model; + + val (bmv, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model lthy in error "unfinished" end; end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 7aba33f1..f05df20e 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -304,29 +304,31 @@ val model_L = { params = [SOME { model = { Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}, + (*Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" },*) Supps = [ @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} ], tacs = { Map_id = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms sum.map_id0 id_apply}), + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def sum.map_id0 id_apply}), resolve_tac ctxt [ext], K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta prod.collapse}), resolve_tac ctxt @{thms id_apply[symmetric]} ], Map_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), resolve_tac ctxt [ext], resolve_tac ctxt @{thms trans[OF comp_apply]}, K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum.map_comp}), resolve_tac ctxt [refl] ], Supp_Map = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), resolve_tac ctxt [refl] ]), Map_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv}), + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def case_prod_beta fst_conv snd_conv}), K (Local_Defs.unfold0_tac ctxt @{thms prod.inject}), REPEAT_DETERM o resolve_tac ctxt @{thms conjI[OF refl]}, resolve_tac ctxt @{thms sum.map_cong0}, @@ -335,6 +337,7 @@ val model_L = { } }, Map_Sb = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), resolve_tac ctxt [ext], K (Local_Defs.unfold0_tac ctxt @{thms comp_def Sb_L_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta id_apply map_prod_simp}), From 0792e36a0caf2aeefc92ced544cfaa47d0b2a7ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 25 Dec 2024 18:03:53 +0000 Subject: [PATCH 08/90] Implement proofs for bmv composition --- Tools/bmv_monad_def.ML | 191 +++++++++++++++++++++++++++++++++------ operations/BMV_Monad.thy | 64 +++++++++---- thys/Prelim/Prelim.thy | 3 + 3 files changed, 212 insertions(+), 46 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 6a99ee34..72dcbbb5 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -5,6 +5,7 @@ signature BMV_MONAD_DEF = sig Map_id: 'a, Map_comp: 'a, Supp_Map: 'a list, + Supp_bd: 'a list, Map_cong: 'a }; @@ -35,16 +36,20 @@ signature BMV_MONAD_DEF = sig lives': typ list, params: { model: supported_functor_model, - Map_Sb: Proof.context -> tactic + Map_Sb: Proof.context -> tactic, + Supp_Sb: (Proof.context -> tactic) list, + Map_Vrs: (Proof.context -> tactic) option list list } option list, Injs: term list list, Sbs: term list, Vrs: term option list list list, + bd_infinite_regular_card_order: Proof.context -> tactic, tacs: (Proof.context -> tactic) 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; @@ -60,7 +65,9 @@ signature BMV_MONAD_DEF = sig Map: term, Supps: term list, axioms: thm supported_functor_axioms, - Map_Sb: thm + Map_Sb: thm, + Supp_Sb: thm list, + Map_Vrs: thm option list list } option list; val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; @@ -101,13 +108,15 @@ type 'a supported_functor_axioms = { Map_id: 'a, Map_comp: 'a, Supp_Map: 'a list, + Supp_bd: 'a list, Map_cong: 'a }; -fun morph_supported_functor_axioms phi { Map_id, Map_comp, Supp_Map, Map_cong } = { +fun morph_supported_functor_axioms phi { Map_id, Map_comp, Supp_Map, Supp_bd, Map_cong } = { Map_id = Morphism.thm phi Map_id, Map_comp = Morphism.thm phi Map_comp, Supp_Map = map (Morphism.thm phi) Supp_Map, + Supp_bd = map (Morphism.thm phi) Supp_bd, Map_cong = Morphism.thm phi Map_cong } : thm supported_functor_axioms; @@ -129,23 +138,29 @@ datatype bmv_monad = BMV of { Map: term, Supps: term list, axioms: thm supported_functor_axioms, - Map_Sb: thm + Map_Sb: thm, + Supp_Sb: thm list, + Map_Vrs: thm option list list } option list, Injs: term list list, Sbs: term list, Vrs: term option list list list, + bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list } -fun morph_bmv_param phi { Map, Supps, axioms, Map_Sb } = { +fun morph_bmv_param phi { Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs } = { Map = Morphism.term phi Map, Supps = map (Morphism.term phi) Supps, axioms = morph_supported_functor_axioms phi axioms, - Map_Sb = Morphism.thm phi Map_Sb + Map_Sb = Morphism.thm phi Map_Sb, + Supp_Sb = map (Morphism.thm phi) Supp_Sb, + Map_Vrs = map (map (Option.map (Morphism.thm phi))) Map_Vrs }; fun morph_bmv_monad phi (BMV { - ops, bd, var_class, leader, frees, lives, lives', params, Injs, Sbs, Vrs, axioms + ops, bd, var_class, leader, frees, lives, lives', params, Injs, Sbs, Vrs, axioms, + bd_infinite_regular_card_order }) = BMV { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, @@ -158,7 +173,8 @@ fun morph_bmv_monad phi (BMV { Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, - axioms = map (morph_bmv_axioms phi) axioms + axioms = map (morph_bmv_axioms phi) axioms, + bd_infinite_regular_card_order = Morphism.thm phi bd_infinite_regular_card_order } fun Rep_bmv (BMV x) = x @@ -177,6 +193,7 @@ val Supps_of_bmv_monad = map (Option.map #Supps) o #params o Rep_bmv val Vrs_of_bmv_monad = #Vrs o Rep_bmv val axioms_of_bmv_monad = #axioms 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 type supported_functor_model = { Map: term, @@ -199,33 +216,41 @@ type bmv_monad_model = { lives': typ list, params: { model: supported_functor_model, - Map_Sb: Proof.context -> tactic + Map_Sb: Proof.context -> tactic, + Supp_Sb: (Proof.context -> tactic) list, + Map_Vrs: (Proof.context -> tactic) option list list } option list, bmv_ops: bmv_monad list, leader: int, Injs: term list list, Sbs: term list, Vrs: term option list list list, + bd_infinite_regular_card_order: Proof.context -> tactic, tacs: (Proof.context -> tactic) bmv_monad_axioms list } -fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, Injs, Sbs, Vrs, tacs }: bmv_monad_model) = { +fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, + Injs, Sbs, Vrs, tacs, bd_infinite_regular_card_order }: bmv_monad_model +) = { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, var_class = var_class, frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', - params = map (Option.map (fn { model, Map_Sb } => { + params = map (Option.map (fn { model, Map_Sb, Supp_Sb, Map_Vrs } => { model = morph_supported_functor_model phi model, - Map_Sb = Map_Sb + Map_Sb = Map_Sb, + Supp_Sb = Supp_Sb, + Map_Vrs = Map_Vrs })) params, bmv_ops = map (morph_bmv_monad phi) bmv_ops, leader = leader, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, - tacs = tacs + tacs = tacs, + bd_infinite_regular_card_order = bd_infinite_regular_card_order } : bmv_monad_model; val mk_small_prems = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess @@ -342,7 +367,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = ) (#ops model) (#Injs model) (#Sbs model) (#Vrs model) (#tacs model); in axioms end; -fun prove_params (model: bmv_monad_model) lthy = @{map 4} (fn T => fn Sb => fn Injs => Option.map (fn param => +fun prove_params (model: bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn Injs => fn Vrs => Option.map (fn param => let val (Cs, _) = lthy |> mk_TFrees (length (#lives model)); @@ -373,6 +398,10 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 4} (fn T => fn Sb => fn I ))) (fn {context=ctxt, ...} => tac ctxt) ) (#Supps pmodel) fs (#Supp_Map (#tacs pmodel)); + val Supp_bds = map2 (fn Supp => fn tac => Goal.prove_sorry lthy [] [] (Logic.all x (HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (Supp $ x)) (#bd model) + ))) (fn {context=ctxt, ...} => tac ctxt)) (#Supps pmodel) (#Supp_bd (#tacs pmodel)); + val (gs', _) = lthy |> mk_Frees "g" (map fastype_of fs); val Map_cong = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ gs' @ [x]) ( @@ -395,6 +424,19 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 4} (fn T => fn Sb => fn I ), Term.list_comb (#Map pmodel, fs)) )) )) (fn {context=ctxt, ...} => #Map_Sb param ctxt); + + val Map_Vrs = map2 (map2 (@{map_option 2} (fn Vrs => fn tac => + Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( + Term.subst_atomic_types (#lives model ~~ #lives' model) Vrs $ (Term.list_comb (#Map pmodel, fs) $ x), + Vrs $ x + ))) (fn {context=ctxt, ...} => tac ctxt) + ))) Vrs (#Map_Vrs param); + + val Supp_Sb = map2 (fn Supp => fn tac => + Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( + Supp $ (Term.list_comb (Sb, rhos) $ x), Supp $ x + ))) (fn {context=ctxt, ...} => tac ctxt) + ) (#Supps pmodel) (#Supp_Sb param); in { Map = #Map pmodel, Supps = #Supps pmodel, @@ -402,11 +444,14 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 4} (fn T => fn Sb => fn I Map_id = Map_id, Map_comp = Map_comp, Supp_Map = Supp_Maps, + Supp_bd = Supp_bds, Map_cong = Map_cong - }, - Map_Sb = Map_Sb + } : thm supported_functor_axioms, + Map_Sb = Map_Sb, + Supp_Sb = Supp_Sb, + Map_Vrs = Map_Vrs } end -)) (#ops model) (#Sbs model) (#Injs model) (#params model); +)) (#ops model) (#Sbs model) (#Injs model) (#Vrs model) (#params model); fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lthy = let @@ -425,6 +470,10 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth val axioms = prove_axioms model lthy; val params = prove_params model lthy; + val bd_irco = Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop ( + mk_infinite_regular_card_order (#bd model) + )) (fn {context=ctxt, ...} => #bd_infinite_regular_card_order model ctxt); + val bmv = BMV { ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), bd = #bd model, @@ -437,7 +486,8 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), - axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model) + axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model), + bd_infinite_regular_card_order = bd_irco } : bmv_monad; in (bmv, lthy) end @@ -554,7 +604,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy Injs = [Injs], Sbs = [Sb], Vrs = [Vrs], - axioms = [axioms] + axioms = [axioms], + bd_infinite_regular_card_order = #bd_infinite_regular_card_order bmv }) | _ => NONE ) ops; @@ -562,22 +613,25 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy val idxs = map (fn T => find_index (curry (op=) T) ops) ops'; val Vrs = map (the o nth Vrs) idxs; + val Injs = map (the o nth Injs) idxs; val frees = distinct (op=) (maps frees_of_bmv_monad (outer :: inners)); + val outer_Vrs = map (nth (Vrs_of_bmv_monad outer)) idxs; val model = { ops = ops', bmv_ops = bmv_ops, bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) + 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 = distinct (op=) (maps lives_of_bmv_monad inners), lives' = distinct (op=) (maps lives'_of_bmv_monad inners), params = replicate (length ops') NONE, leader = 0, - Injs = map (the o nth Injs) idxs, + Injs = Injs, Sbs = map (the o nth Sbs) idxs, Vrs = Vrs, - tacs = map2 (fn axioms => fn param => { + tacs = @{map 5} (fn axioms => fn param => fn Injs => fn Vrs => fn outer_Vrs => { Sb_Inj = fn ctxt => EVERY [ Local_Defs.unfold0_tac ctxt (#Sb_Inj axioms :: @{thms o_id}), Local_Defs.unfold0_tac ctxt ( @@ -589,23 +643,100 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy Sb_comp_Injs = map (fn thm => fn ctxt => print_tac ctxt "Sb_comp_Inj" ) (#Sb_comp_Injs axioms), - Sb_comp = fn ctxt => print_tac ctxt "Sb_comp", - Vrs_bds = map (map (fn Vrs => SOME (fn ctxt => - print_tac ctxt "Vrs_bds" - ))) Vrs, + Sb_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt (#Map_Sb param RS sym), + REPEAT_DETERM o assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + rtac ctxt (#Sb_comp axioms), + REPEAT_DETERM o assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt trans, + rtac ctxt (#Map_comp (#axioms param)), + rtac ctxt ext, + rtac ctxt (#Map_cong (#axioms param)), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps (map #Sb_comp o axioms_of_bmv_monad) inners), + REPEAT_DETERM o assume_tac ctxt, + rtac ctxt refl + ] + ], + Vrs_bds = map (map (Option.map (K (fn ctxt => EVERY1 [ + REPEAT_DETERM o resolve_tac ctxt ( + 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} + @ maps (map_filter I) (#Vrs_bds axioms) + @ maps (maps (maps (map_filter I) o #Vrs_bds) o axioms_of_bmv_monad) inners + @ #Supp_bd (#axioms param) + ) + ])))) Vrs, Vrs_Injs = map (map (Option.map (fn thm => fn ctxt => print_tac ctxt "Vrs_Injs" ))) (#Vrs_Injs axioms), - Vrs_Sbs = map (map (fn Vrs => SOME (fn ctxt => - print_tac ctxt "Vrs_Sbs" - ))) Vrs, - Sb_cong = fn ctxt => print_tac ctxt "Sb_cong" + Vrs_Sbs = map (map (Option.map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms UN_Un}), + REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [#Map_Sb param], + REPEAT_DETERM1 o assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt trans, + resolve_tac ctxt (maps (map_filter I) (#Vrs_Sbs axioms)), + REPEAT_DETERM1 o assume_tac ctxt, + EqSubst.eqsubst_tac ctxt [0] (maps (map_filter I) (#Map_Vrs param)), + rtac ctxt refl + ], + K (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ #Supp_Map (#axioms param) @ #Supp_Sb param)), + K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def] UN_UN_flatten} + @ maps (maps (maps (map_filter I) o #Vrs_Sbs) o axioms_of_bmv_monad) inners + )), + REPEAT_DETERM o rtac ctxt refl + ])))) Vrs, + Sb_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~(length ( + maps (map_filter I) outer_Vrs + ))) (#Sb_cong axioms)], + resolve_tac ctxt prems, + etac ctxt @{thm contrapos_pp}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + assume_tac ctxt, + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt (#Map_cong (#axioms param)), + K (Local_Defs.unfold0_tac ctxt (#Supp_Sb param)), + EVERY' (map (fn inner => EVERY' [ + resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), + REPEAT_DETERM o EVERY' [ + REPEAT_DETERM o resolve_tac ctxt prems, + rotate_tac ~1, + etac ctxt @{thm contrapos_pp}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms bex_simps(8) Un_iff UN_iff de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + dtac ctxt @{thm bspec[rotated]}, + assume_tac ctxt, + assume_tac ctxt + ] + ]) inners) + ]) ctxt + ] } : (Proof.context -> tactic) bmv_monad_axioms) (map (nth (axioms_of_bmv_monad outer)) idxs) (map (the o nth (params_of_bmv_monad outer)) idxs) + Injs Vrs outer_Vrs } : bmv_monad_model; val (bmv, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model lthy - in error "unfinished" end; + val _ = @{print} bmv + in (bmv, lthy) end; end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index f05df20e..bc4fa282 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -110,6 +110,7 @@ val model_FType = { Injs = [[@{term "TyVar :: 'a::var \ _"}]], Sbs = [@{term "tvsubst_FType :: _ => 'a::var FType => _"}], Vrs = [[[SOME @{term "FVars_FType :: _ => 'a::var set"}]]], + bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => resolve_tac ctxt @{thms Sb_Inj_FType} 1, Sb_comp_Injs = [fn ctxt => EVERY1 [ @@ -167,6 +168,10 @@ definition Vrs_L_2 :: "('a1, 'a2, 'c1, 'c2) L \ 'a2 set" where "Vrs_L_2 \ \x. {}" (* corresponds to nothing *) definition Map_L :: "('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" where "Map_L \ \f1 f2 (a1, a2, p). (a1, a2, map_sum f1 f2 p)" +definition Supp_L_1 :: "('a1, 'a2, 'c1, 'c2) L \ 'c1 set" where + "Supp_L_1 \ \(a1, a1', p). Basic_BNFs.setl p" +definition Supp_L_2 :: "('a1, 'a2, 'c1, 'c2) L \ 'c2 set" where + "Supp_L_2 \ \(a1, a1', p). Basic_BNFs.setr p" (* and its minion *) definition Inj_L_M1_1 :: "'a1 \ 'a1" where "Inj_L_M1_1 \ id" @@ -252,6 +257,7 @@ val model_ID = { Injs = [[@{term "id :: 'a \ _"}]], Sbs = [@{term "id :: _ => 'a => 'a"}], Vrs = [[[SOME @{term "\(x::'a). {x}"}]]], + bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => resolve_tac ctxt @{thms id_apply} 1, Sb_comp_Injs = [fn ctxt => EVERY1 [ @@ -303,11 +309,15 @@ val model_L = { )) id_bmv], params = [SOME { model = { - Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"}, - (*Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" },*) - Supps = [ + (*Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"},*) + Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, + (*Supps = [ @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} + ],*) + Supps = [ + @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, + @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} ], tacs = { Map_id = fn ctxt => EVERY1 [ @@ -324,11 +334,15 @@ val model_L = { resolve_tac ctxt [refl] ], Supp_Map = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), resolve_tac ctxt [refl] ]), + Supp_bd = replicate 2 (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Supp_L_1_def Supp_L_2_def}), + resolve_tac ctxt @{thms sum.set_bd} + ]), Map_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def case_prod_beta fst_conv snd_conv}), + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv}), K (Local_Defs.unfold0_tac ctxt @{thms prod.inject}), REPEAT_DETERM o resolve_tac ctxt @{thms conjI[OF refl]}, resolve_tac ctxt @{thms sum.map_cong0}, @@ -342,13 +356,25 @@ val model_L = { K (Local_Defs.unfold0_tac ctxt @{thms comp_def Sb_L_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta id_apply map_prod_simp}), resolve_tac ctxt [refl] - ] + ], + Supp_Sb = replicate 2 (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_map_prod id_apply Sb_L_def Supp_L_1_def Supp_L_2_def}), + resolve_tac ctxt [refl] + ]), + Map_Vrs = [[SOME (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Map_L_def case_prod_beta fst_conv snd_conv}), + resolve_tac ctxt [refl] + ])]] }], Injs = [[@{term "id :: 'a1 \ 'a1"}]], Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], - Vrs = [[[ + (*Vrs = [[[ SOME @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} + ]]],*) + Vrs = [[[ + SOME @{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"} ]]], + bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def prod.map_id0}), @@ -363,21 +389,21 @@ val model_L = { resolve_tac ctxt [refl] ], Vrs_bds = [[SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta}), + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def case_prod_beta}), resolve_tac ctxt @{thms insert_bound}, resolve_tac ctxt @{thms natLeq_Cinfinite}, resolve_tac ctxt @{thms ID.set_bd} ])]], Vrs_Injs = [], Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta Product_Type.fst_map_prod Product_Type.snd_map_prod UN_insert UN_empty Un_empty_right insert_is_Un[symmetric] }), resolve_tac ctxt [refl] ])]], Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def case_prod_beta}), + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta}), resolve_tac ctxt @{thms prod.map_cong0}, dresolve_tac ctxt @{thms meta_spec}, dresolve_tac ctxt @{thms meta_mp}, @@ -425,10 +451,15 @@ val model_L1 = { params = [NONE], Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], - Vrs = [[ + (*Vrs = [[ [SOME @{term "\(x::'a1, x2::'a2). {x}"}, NONE], [NONE, SOME @{term "\(x::'a1, x2::'a2). {x2}"}] + ]],*) + Vrs = [[ + [SOME @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, NONE], + [NONE, SOME @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"}] ]], + bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def prod.map_id0}), @@ -443,24 +474,24 @@ val model_L1 = { resolve_tac ctxt [refl] ], Vrs_bds = [ - [SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1), NONE], - [NONE, SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1)] + [SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1), NONE], + [NONE, SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1)] ], Vrs_Injs = [], Vrs_Sbs = [ [SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Sb_L1_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), resolve_tac ctxt [refl] ]), NONE], [NONE, SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def Sb_L1_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), resolve_tac ctxt [refl] ])] ], Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def case_prod_beta}), + K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Vrs_L1_2_def Sb_L1_def case_prod_beta}), resolve_tac ctxt @{thms prod.map_cong0}, eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, dresolve_tac ctxt @{thms meta_spec}, @@ -514,6 +545,7 @@ val model_L2 = { [NONE, SOME @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}], [NONE, SOME @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"}] ]], + bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), diff --git a/thys/Prelim/Prelim.thy b/thys/Prelim/Prelim.thy index 583efa6b..f15f47ce 100644 --- a/thys/Prelim/Prelim.thy +++ b/thys/Prelim/Prelim.thy @@ -591,6 +591,9 @@ lemma infinite_regular_card_order_Un: "infinite_regular_card_order r \ |A| (\a. a \ A \ |B a| |\(B ` A)| infinite_regular_card_order p \ |x| |x| Date: Thu, 26 Dec 2024 14:00:10 +0000 Subject: [PATCH 09/90] Introduce definitions if terms get too big --- Tools/bmv_monad_def.ML | 169 ++++++++++++++++++++++++++++++++------- operations/BMV_Monad.thy | 44 +++++----- 2 files changed, 162 insertions(+), 51 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 72dcbbb5..823c8ef9 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -73,9 +73,10 @@ signature BMV_MONAD_DEF = sig val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) - -> (binding -> binding) -> bmv_monad_model -> local_theory -> bmv_monad * local_theory + -> (binding -> binding) -> bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory - val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory -> bmv_monad * local_theory + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory + -> (bmv_monad * thm list) * local_theory end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -260,13 +261,15 @@ val mk_small_prems = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of Inj))))) )); -fun prove_axioms (model: bmv_monad_model) lthy = +fun prove_axioms (model: bmv_monad_model) defs lthy = let val Ts = #ops model @ maps ops_of_bmv_monad (#bmv_ops model); val Sbs = #Sbs model @ maps Sbs_of_bmv_monad (#bmv_ops model); val Injss = #Injs model @ maps Injs_of_bmv_monad (#bmv_ops model); val Vrss = #Vrs model @ maps Vrs_of_bmv_monad (#bmv_ops model); + fun prove tac {context=ctxt, ...} = Local_Defs.unfold0_tac ctxt defs THEN tac ctxt; + val axioms = @{map 5} (fn T => fn Injs => fn Sb => fn Vrs => fn tacs => let val (own_Injs, other_Injs) = partition (fn Inj => member (op=) (#ops model) (body_type (fastype_of Inj))) Injs; @@ -283,7 +286,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = val Sb_Inj = Goal.prove_sorry lthy [] [] ( mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T) - ) (fn {context=ctxt, ...} => #Sb_Inj tacs ctxt); + ) (prove (#Sb_Inj tacs)); val small_prems = mk_small_prems rhos Injs; val small_prems' = mk_small_prems rhos' Injs; @@ -292,7 +295,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = fold_rev Logic.all rhos (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb (Sb, rhos), Inj), rho ))) - ) (fn {context=ctxt, ...} => tac ctxt)) own_Injs own_rhos (#Sb_comp_Injs tacs); + ) (prove tac)) own_Injs own_rhos (#Sb_comp_Injs tacs); val Sb_comp = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos') ( fold_rev (curry Logic.mk_implies) (small_prems @ small_prems') (mk_Trueprop_eq ( @@ -306,12 +309,12 @@ fun prove_axioms (model: bmv_monad_model) lthy = ) Injs), rho) ) other_rhos (map (nth Sbs) other_idxs) (map (nth Injss) other_idxs)) )) - )) (fn {context=ctxt, ...} => #Sb_comp tacs ctxt); + )) (prove (#Sb_comp tacs)); val Vrs_bds = map2 (map2 (@{map_option 2} (fn Vrs => fn tac => Goal.prove_sorry lthy [] [] (Logic.all x (HOLogic.mk_Trueprop ( mk_ordLess (mk_card_of (Vrs $ x)) (#bd model) - ))) (fn {context=ctxt, ...} => tac ctxt) + ))) (prove tac) ))) Vrs (#Vrs_bds tacs); val Vrs_Injs = @{map 3} (fn Inj => map2 (@{map_option 2} (fn tac => fn Vrs => @@ -322,7 +325,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = Logic.all a (mk_Trueprop_eq ( Vrs $ (Inj $ a), if fastype_of a = T then mk_singleton a else mk_bot T)) - ) (fn {context=ctxt, ...} => tac ctxt) end))) own_Injs (#Vrs_Injs tacs) (cond_keep Vrs is_own_Inj); + ) (prove tac) end))) own_Injs (#Vrs_Injs tacs) (cond_keep Vrs is_own_Inj); val Vrs_Sbs = @{map 3} (fn rho => map2 (@{map_option 2} (fn Vrs => fn tac => let @@ -339,7 +342,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = mk_UNION (Vrs $ x) (Term.abs ("a", var) (Vrs' $ (rho $ Bound 0))) )) ); - in Goal.prove_sorry lthy [] [] goal (fn {context=ctxt, ...} => tac ctxt) end + in Goal.prove_sorry lthy [] [] goal (prove tac) end ))) rhos Vrs (#Vrs_Sbs tacs); val Sb_cong = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos' @ [x]) ( @@ -353,7 +356,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = Term.list_comb (Sb, rhos) $ x, Term.list_comb (Sb, rhos') $ x ) - ))) (fn {context=ctxt, ...} => #Sb_cong tacs ctxt); + ))) (prove (#Sb_cong tacs)); in { Sb_Inj = Sb_Inj, @@ -367,7 +370,7 @@ fun prove_axioms (model: bmv_monad_model) lthy = ) (#ops model) (#Injs model) (#Sbs model) (#Vrs model) (#tacs model); in axioms end; -fun prove_params (model: bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn Injs => fn Vrs => Option.map (fn param => +fun prove_params (model: bmv_monad_model) defs lthy = @{map 5} (fn T => fn Sb => fn Injs => fn Vrs => Option.map (fn param => let val (Cs, _) = lthy |> mk_TFrees (length (#lives model)); @@ -378,29 +381,31 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn I ||>> apfst hd o mk_Frees "x" [T]; val pmodel = #model param; + fun prove tac {context=ctxt, ...} = Local_Defs.unfold0_tac ctxt defs THEN tac ctxt + val Map_id = Goal.prove_sorry lthy [] [] (Term.subst_atomic_types (#lives' model ~~ #lives model) ( mk_Trueprop_eq ( Term.list_comb (#Map pmodel, map HOLogic.id_const (#lives model)), HOLogic.id_const T ) - )) (fn {context=ctxt, ...} => #Map_id (#tacs pmodel) ctxt); + )) (prove (#Map_id (#tacs pmodel))); val Map_comp = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb ( Term.subst_atomic_types ((#lives model @ #lives' model) ~~ (#lives' model @ Cs)) (#Map pmodel), gs ), Term.list_comb (#Map pmodel, fs)), Term.list_comb (Term.subst_atomic_types (#lives' model ~~ Cs) (#Map pmodel), map2 (curry HOLogic.mk_comp) gs fs) - ))) (fn {context=ctxt, ...} => #Map_comp (#tacs pmodel) ctxt); + ))) (prove (#Map_comp (#tacs pmodel))); val Supp_Maps = @{map 3} (fn Supp => fn f => fn tac => Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( Term.subst_atomic_types (#lives model ~~ #lives' model) Supp $ (Term.list_comb (#Map pmodel, fs) $ x), mk_image f $ (Supp $ x) - ))) (fn {context=ctxt, ...} => tac ctxt) + ))) (prove tac) ) (#Supps pmodel) fs (#Supp_Map (#tacs pmodel)); val Supp_bds = map2 (fn Supp => fn tac => Goal.prove_sorry lthy [] [] (Logic.all x (HOLogic.mk_Trueprop ( mk_ordLess (mk_card_of (Supp $ x)) (#bd model) - ))) (fn {context=ctxt, ...} => tac ctxt)) (#Supps pmodel) (#Supp_bd (#tacs pmodel)); + ))) (prove tac)) (#Supps pmodel) (#Supp_bd (#tacs pmodel)); val (gs', _) = lthy |> mk_Frees "g" (map fastype_of fs); @@ -414,7 +419,7 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn I ) (#Supps pmodel) fs gs') (mk_Trueprop_eq ( Term.list_comb (#Map pmodel, fs) $ x, Term.list_comb (#Map pmodel, gs') $ x - )))) (fn {context=ctxt, ...} => #Map_cong (#tacs pmodel) ctxt); + )))) (prove (#Map_cong (#tacs pmodel))); val Map_Sb = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ rhos) ( fold_rev (curry Logic.mk_implies) (mk_small_prems rhos Injs) (mk_Trueprop_eq ( @@ -423,19 +428,19 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn I Term.subst_atomic_types (#lives model ~~ #lives' model) Sb, rhos ), Term.list_comb (#Map pmodel, fs)) )) - )) (fn {context=ctxt, ...} => #Map_Sb param ctxt); + )) (prove (#Map_Sb param)); val Map_Vrs = map2 (map2 (@{map_option 2} (fn Vrs => fn tac => Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( Term.subst_atomic_types (#lives model ~~ #lives' model) Vrs $ (Term.list_comb (#Map pmodel, fs) $ x), Vrs $ x - ))) (fn {context=ctxt, ...} => tac ctxt) + ))) (prove tac) ))) Vrs (#Map_Vrs param); val Supp_Sb = map2 (fn Supp => fn tac => Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( Supp $ (Term.list_comb (Sb, rhos) $ x), Supp $ x - ))) (fn {context=ctxt, ...} => tac ctxt) + ))) (prove tac) ) (#Supps pmodel) (#Supp_Sb param); in { Map = #Map pmodel, @@ -453,26 +458,133 @@ fun prove_params (model: bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn I } end )) (#ops model) (#Sbs model) (#Injs model) (#Vrs model) (#params model); -fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lthy = +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 const_policy fact_policy qualify (model: bmv_monad_model) lthy = + let + val maybe_define = maybe_define const_policy fact_policy o qualify; + + val suffixes = map_index (fn (i, T) => 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 model); + val suffixess = map2 (fn suffix => map_index (fn (i, _) => + Binding.suffix_name ("_" ^ string_of_int i) o suffix + )) suffixes (#Injs model); + + 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 model) 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 model) suffixess lthy); + + val (Vrs', lthy) = + (@{fold_map 2} (@{fold_map 2} (fn suffix => fn Vrs => @{fold_map 2} (fn i => fold_map_option (fn Vrs => + maybe_define (Binding.suffix_name ("_" ^ string_of_int i) (suffix (Binding.name "Vrs"))) Vrs + )) (0 upto length Vrs - 1) Vrs)) suffixess (#Vrs model) lthy); + + val Vrs = map (map (map (Option.map fst))) Vrs'; + val Vrs_defs = maps (maps (map (Option.mapPartial snd))) 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 (#model 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 (#model param)) - 1) (#Supps (#model param)) lthy); + val param = { + model = { + Map = Map, + Supps = Supps, + tacs = #tacs (#model param) + }, + Map_Sb = #Map_Sb param, + Supp_Sb = #Supp_Sb param, + Map_Vrs = #Map_Vrs param + } + in ((param, Map_def :: Supp_defs), lthy) end + )) suffixes (#params model) 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 model) lthy; + + val model' = { + ops = #ops model, + bd = bd, + var_class = #var_class model, + leader = #leader model, + frees = #frees model, + lives = #lives model, + lives' = #lives' model, + bmv_ops = #bmv_ops model, + params = params, + Injs = Injs, + Sbs = Sbs, + Vrs = Vrs, + bd_infinite_regular_card_order = #bd_infinite_regular_card_order model, + tacs = #tacs model + } : bmv_monad_model; + + val (lthy, old_lthy) = `Local_Theory.end_nested lthy; + val phi = Proof_Context.export_morphism old_lthy lthy; + + val vars = #frees model @ #lives model @ #lives' model; + 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 model' = morph_bmv_monad_model phi' model'; + + val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ [bd_def] @ flat param_defs); + in (model', map (Morphism.thm phi) defs, lthy) end; + +fun bmv_monad_def const_policy fact_policy qualify (model: bmv_monad_model) lthy = let - val _ = let + (*val _ = let val var_large = MRBNF_Def.get_class_assumption [#var_class model] "large" lthy; val bd' = snd (dest_comb (dest_card_of ( fst (dest_ordLeq (HOLogic.dest_Trueprop (Thm.prop_of var_large))) ))); - in if bd' <> #bd model then error "var_class does not match bound" else () end + in if bd' <> #bd model then error "var_class does not match bound" else () end*) val frees = map (fn T => TFree (apsnd ( Sign.minimize_sort (Proof_Context.theory_of lthy) o cons (#var_class model) ) (dest_TFree T))) (#frees model); val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) model; - val axioms = prove_axioms model lthy; - val params = prove_params model lthy; + val (model, unfold_set, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify model lthy; + + 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 model) - )) (fn {context=ctxt, ...} => #bd_infinite_regular_card_order model ctxt); + )) (fn {context=ctxt, ...} => Local_Defs.unfold0_tac ctxt unfold_set THEN #bd_infinite_regular_card_order model ctxt); val bmv = BMV { ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), @@ -489,7 +601,7 @@ fun bmv_monad_def inline_policy fact_policy qualify (model: bmv_monad_model) lth axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model), bd_infinite_regular_card_order = bd_irco } : bmv_monad; - in (bmv, lthy) end + in ((bmv, unfold_set), lthy) end (* Cleanup: Throw away op iff any: - not the leader @@ -735,8 +847,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy Injs Vrs outer_Vrs } : bmv_monad_model; - val (bmv, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model lthy - val _ = @{print} bmv - in (bmv, lthy) end; + val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model lthy + in (res, lthy) end; end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index bc4fa282..629bc9b4 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -139,9 +139,12 @@ val model_FType = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] } : BMV_Monad_Def.bmv_monad_model; \ - ML \ -val FType_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_FType @{context}) +val lthy = Unsynchronized.ref (NONE : local_theory option) +\ +local_setup \fn x => (lthy := SOME x ; x)\ +ML \ +val FType_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_FType (the (!lthy))) \ @@ -241,6 +244,9 @@ typ "('a1, 'a2) L1_M1" typ "('a1, 'a2) L1_M2" typ "('a1, 'a2) L2_M2" +lemma insert_bound: "Cinfinite r \ |A| |insert x A| @@ -287,15 +293,9 @@ val model_ID = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] } : BMV_Monad_Def.bmv_monad_model; \ -ML \ -val id_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_ID @{context}) -\ - -lemma insert_bound: "Cinfinite r \ |A| |insert x A| -val model_L = { +val mk_model_L = fn id_bmv => { ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], bd = @{term natLeq}, var_class = @{class var}, @@ -425,12 +425,9 @@ val model_L = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] } : BMV_Monad_Def.bmv_monad_model; \ -ML \ -val L_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L @{context}) -\ ML \ -val model_L1 = { +val mk_model_L1 = fn id_bmv => { ops = [@{typ "'a1 * 'a2"}], bd = @{term natLeq}, var_class = @{class var}, @@ -510,12 +507,9 @@ val model_L1 = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] } : BMV_Monad_Def.bmv_monad_model; \ -ML \ -val L1_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L1 @{context}) -\ ML \ -val model_L2 = { +val mk_model_L2 = fn id_bmv => fn FType_bmv => { ops = [@{typ "('a1, 'a2) L2"}], bd = @{term natLeq}, var_class = @{class var}, @@ -631,10 +625,16 @@ val model_L2 = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] } : BMV_Monad_Def.bmv_monad_model; \ -ML \ -val L2_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_L2 @{context}) -\ -local_setup \snd o BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv]\ +local_setup \fn lthy => + let + val ((id_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "ID_") model_ID lthy; + val ((FType_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "FType_") model_FType lthy; + val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") (mk_model_L id_bmv) lthy; + val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") (mk_model_L1 id_bmv) lthy; + val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") (mk_model_L2 id_bmv FType_bmv) lthy; -end \ No newline at end of file + val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv] lthy + val _ = @{print} comp_bmv + in lthy end +\ \ No newline at end of file From d275cd89f2d4ba22d08748e0768db88bdd5b0b8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 26 Dec 2024 14:35:08 +0000 Subject: [PATCH 10/90] Add function to convert bnf to pbmv monad --- Tools/bmv_monad_def.ML | 58 ++++++++++++++++++++++++++++++++++++++++ operations/BMV_Monad.thy | 7 +++++ 2 files changed, 65 insertions(+) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 823c8ef9..65b82ac4 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -72,6 +72,7 @@ signature BMV_MONAD_DEF = sig val morph_bmv_monad: morphism -> bmv_monad -> bmv_monad; + val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory @@ -603,6 +604,63 @@ fun bmv_monad_def const_policy fact_policy qualify (model: bmv_monad_model) lthy } : bmv_monad; in ((bmv, unfold_set), lthy) end +fun pbmv_monad_of_bnf bnf lthy = + let + val (((lives, lives'), deads), _) = lthy + |> mk_TFrees (BNF_Def.live_of_bnf bnf) + ||>> mk_TFrees (BNF_Def.live_of_bnf bnf) + ||>> mk_TFrees' (map Type.sort_of_atyp (BNF_Def.deads_of_bnf bnf)) + val T = BNF_Def.mk_T_of_bnf deads lives bnf; + val n = BNF_Def.live_of_bnf bnf; + val _ = @{print} () + in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I { + ops = [T], + bd = BNF_Def.bd_of_bnf bnf, + var_class = @{class type}, + leader = 0, + frees = [], + lives = lives, + lives' = lives', + bmv_ops = [], + params = [SOME { + model = { + Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, + Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf, + tacs = { + Map_id = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, + Map_comp = fn ctxt => rtac ctxt (BNF_Def.map_comp0_of_bnf bnf RS sym) 1, + Supp_Map = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_map_of_bnf bnf), + Supp_bd = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_bd_of_bnf bnf), + Map_cong = fn ctxt => EVERY1 [ + rtac ctxt (BNF_Def.map_cong0_of_bnf bnf), + REPEAT_DETERM o Goal.assume_rule_tac ctxt + ] + } + }, + Map_Sb = fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_o o_id} THEN rtac ctxt refl 1, + Supp_Sb = replicate n (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_apply} THEN rtac ctxt refl 1), + Map_Vrs = [] + }], + Injs = [[]], + Sbs = [HOLogic.id_const T], + Vrs = [[]], + bd_infinite_regular_card_order = fn ctxt => EVERY1 [ + rtac ctxt @{thm infinite_regular_card_order.intro}, + rtac ctxt (BNF_Def.bd_card_order_of_bnf bnf), + rtac ctxt (BNF_Def.bd_cinfinite_of_bnf bnf), + rtac ctxt (BNF_Def.bd_regularCard_of_bnf bnf) + ], + tacs = [{ + Sb_Inj = fn ctxt => rtac ctxt refl 1, + Sb_comp_Injs = [], + Sb_comp = fn ctxt => rtac ctxt @{thm id_o} 1, + Vrs_bds = [], + Vrs_Injs = [], + Vrs_Sbs = [], + Sb_cong = fn ctxt => rtac ctxt refl 1 + }] + } lthy) end + (* Cleanup: Throw away op iff any: - not the leader - does not appear in the codomain of any (=of any **other** SOp) Injection, diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 629bc9b4..3aa6d7f0 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -637,4 +637,11 @@ local_setup \fn lthy => val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv] lthy val _ = @{print} comp_bmv in lthy end +\ + +local_setup \fn lthy => + let + val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf (the (BNF_Def.bnf_of lthy "Sum_Type.sum")) lthy; + val _ = @{print} bmv + in lthy end \ \ No newline at end of file From 2ef45ebfd28db4f40ff9c53ae49e70136ba185ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 26 Dec 2024 17:08:55 +0000 Subject: [PATCH 11/90] Allow to register pbmv monads --- Tools/bmv_monad_def.ML | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 65b82ac4..b7fe7e66 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -72,6 +72,10 @@ signature BMV_MONAD_DEF = sig 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_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory @@ -255,6 +259,22 @@ fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, lives', param bd_infinite_regular_card_order = bd_infinite_regular_card_order } : 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; + val mk_small_prems = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (HOLogic.mk_Collect ("a", fst (dest_funT (fastype_of Inj)), HOLogic.mk_not (HOLogic.mk_eq (rho $ Bound 0, Inj $ Bound 0)) @@ -612,11 +632,13 @@ fun pbmv_monad_of_bnf bnf lthy = ||>> mk_TFrees' (map Type.sort_of_atyp (BNF_Def.deads_of_bnf bnf)) val T = BNF_Def.mk_T_of_bnf deads lives bnf; val n = BNF_Def.live_of_bnf bnf; - val _ = @{print} () + val var_class = case BNF_Def.bd_of_bnf bnf of + @{term natLeq} => @{class var} + | _ => error "TODO: other var classes" in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I { ops = [T], bd = BNF_Def.bd_of_bnf bnf, - var_class = @{class type}, + var_class = var_class, leader = 0, frees = [], lives = lives, @@ -905,7 +927,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy Injs Vrs outer_Vrs } : bmv_monad_model; - val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model lthy + val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify model lthy in (res, lthy) end; end \ No newline at end of file From 86ecdd3b109502b3c914b335fcc286fab17f5d29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 1 Jan 2025 13:15:39 +0000 Subject: [PATCH 12/90] Add command to register pbmv monads --- Tools/bmv_monad_def.ML | 538 +++++++++++++++++++++++---------------- operations/BMV_Monad.thy | 223 ++++++---------- 2 files changed, 399 insertions(+), 362 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index b7fe7e66..acf78ea0 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -19,13 +19,16 @@ signature BMV_MONAD_DEF = sig Vrs_Sbs: 'a option list list }; - type supported_functor_model = { + type 'a bmv_monad_param = { Map: term, Supps: term list, - tacs: (Proof.context -> tactic) supported_functor_axioms + axioms: 'a supported_functor_axioms, + Map_Sb: 'a, + Supp_Sb: 'a list, + Map_Vrs: 'a option list list }; - type bmv_monad_model = { + type 'a bmv_monad_model = { ops: typ list, bd: term, var_class: class, @@ -34,17 +37,12 @@ signature BMV_MONAD_DEF = sig leader: int, lives: typ list, lives': typ list, - params: { - model: supported_functor_model, - Map_Sb: Proof.context -> tactic, - Supp_Sb: (Proof.context -> tactic) list, - Map_Vrs: (Proof.context -> tactic) option list list - } option list, + params: 'a bmv_monad_param option list, Injs: term list list, Sbs: term list, Vrs: term option list list list, - bd_infinite_regular_card_order: Proof.context -> tactic, - tacs: (Proof.context -> tactic) bmv_monad_axioms list + bd_infinite_regular_card_order: 'a, + tacs: 'a bmv_monad_axioms list } val ops_of_bmv_monad: bmv_monad -> typ list; @@ -70,6 +68,8 @@ signature BMV_MONAD_DEF = sig Map_Vrs: thm option list list } option list; + 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; @@ -78,7 +78,7 @@ signature BMV_MONAD_DEF = sig val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) - -> (binding -> binding) -> bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory + -> (binding -> binding) -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory -> (bmv_monad * thm list) * local_theory @@ -98,17 +98,33 @@ type 'a bmv_monad_axioms = { Vrs_Sbs: 'a option list list }; -fun morph_bmv_axioms phi { +fun map_bmv_monad_axioms f ({ Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_bds, Vrs_Injs, Vrs_Sbs -} = { - Sb_Inj = Morphism.thm phi Sb_Inj, - Sb_comp_Injs = map (Morphism.thm phi) Sb_comp_Injs, - Sb_comp = Morphism.thm phi Sb_comp, - Sb_cong = Morphism.thm phi Sb_cong, - Vrs_bds = map (map (Option.map (Morphism.thm phi))) Vrs_bds, - Vrs_Injs = map (map (Option.map (Morphism.thm phi))) Vrs_Injs, - Vrs_Sbs = map (map (Option.map (Morphism.thm phi))) Vrs_Sbs -} : thm bmv_monad_axioms +}: '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 (map (Option.map f)) Vrs_bds, + Vrs_Injs = map (map (Option.map f)) Vrs_Injs, + Vrs_Sbs = map (map (Option.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_Injs=f6s, Vrs_Sbs=f7s +}: ('a -> 'b) bmv_monad_axioms) ({ + Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_bds, Vrs_Injs, Vrs_Sbs +}: 'a bmv_monad_axioms) = { + 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 (map2 (@{map_option 2} (curry (op|>)))) Vrs_bds f5s, + Vrs_Injs = map2 (map2 (@{map_option 2} (curry (op|>)))) Vrs_Injs f6s, + Vrs_Sbs = map2 (map2 (@{map_option 2} (curry (op|>)))) Vrs_Sbs f7s +} : 'b bmv_monad_axioms; type 'a supported_functor_axioms = { Map_id: 'a, @@ -118,20 +134,32 @@ type 'a supported_functor_axioms = { Map_cong: 'a }; -fun morph_supported_functor_axioms phi { Map_id, Map_comp, Supp_Map, Supp_bd, Map_cong } = { - Map_id = Morphism.thm phi Map_id, - Map_comp = Morphism.thm phi Map_comp, - Supp_Map = map (Morphism.thm phi) Supp_Map, - Supp_bd = map (Morphism.thm phi) Supp_bd, - Map_cong = Morphism.thm phi Map_cong -} : thm supported_functor_axioms; +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 supported_functor_model = { +type 'a bmv_monad_param = { Map: term, Supps: term list, - tacs: (Proof.context -> tactic) supported_functor_axioms + axioms: 'a supported_functor_axioms, + Map_Sb: 'a, + Supp_Sb: 'a list, + Map_Vrs: 'a option list list }; +fun morph_bmv_monad_param phi f ({ Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs }: 'a bmv_monad_param) = { + Map = Morphism.term phi Map, + Supps = map (Morphism.term phi) Supps, + axioms = map_supported_functor_axioms f axioms, + Map_Sb = f Map_Sb, + Supp_Sb = map f Supp_Sb, + Map_Vrs = map (map (Option.map f)) Map_Vrs +}: 'b bmv_monad_param; + datatype bmv_monad = BMV of { ops: typ list, bd: term, @@ -140,14 +168,7 @@ datatype bmv_monad = BMV of { frees: typ list, lives: typ list, lives': typ list, - params: { - Map: term, - Supps: term list, - axioms: thm supported_functor_axioms, - Map_Sb: thm, - Supp_Sb: thm list, - Map_Vrs: thm option list list - } option list, + params: thm bmv_monad_param option list, Injs: term list list, Sbs: term list, Vrs: term option list list list, @@ -155,15 +176,6 @@ datatype bmv_monad = BMV of { axioms: thm bmv_monad_axioms list } -fun morph_bmv_param phi { Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs } = { - Map = Morphism.term phi Map, - Supps = map (Morphism.term phi) Supps, - axioms = morph_supported_functor_axioms phi axioms, - Map_Sb = Morphism.thm phi Map_Sb, - Supp_Sb = map (Morphism.thm phi) Supp_Sb, - Map_Vrs = map (map (Option.map (Morphism.thm phi))) Map_Vrs -}; - fun morph_bmv_monad phi (BMV { ops, bd, var_class, leader, frees, lives, lives', params, Injs, Sbs, Vrs, axioms, bd_infinite_regular_card_order @@ -175,11 +187,11 @@ fun morph_bmv_monad phi (BMV { frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', - params = map (Option.map (morph_bmv_param phi)) params, + params = map (Option.map (morph_bmv_monad_param phi (Morphism.thm phi))) params, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, - axioms = map (morph_bmv_axioms phi) axioms, + axioms = map (morph_bmv_monad_axioms phi) axioms, bd_infinite_regular_card_order = Morphism.thm phi bd_infinite_regular_card_order } @@ -201,42 +213,25 @@ val axioms_of_bmv_monad = #axioms 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 -type supported_functor_model = { - Map: term, - Supps: term list, - tacs: (Proof.context -> tactic) supported_functor_axioms -}; - -fun morph_supported_functor_model phi { Map, Supps, tacs } = { - Map = Morphism.term phi Map, - Supps = map (Morphism.term phi) Supps, - tacs = tacs -} : supported_functor_model; - -type bmv_monad_model = { +type 'a bmv_monad_model = { ops: typ list, bd: term, var_class: class, frees: typ list, lives: typ list, lives': typ list, - params: { - model: supported_functor_model, - Map_Sb: Proof.context -> tactic, - Supp_Sb: (Proof.context -> tactic) list, - Map_Vrs: (Proof.context -> tactic) option list list - } option list, + params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, leader: int, Injs: term list list, Sbs: term list, Vrs: term option list list list, - bd_infinite_regular_card_order: Proof.context -> tactic, - tacs: (Proof.context -> tactic) bmv_monad_axioms list + bd_infinite_regular_card_order: 'a, + tacs: 'a bmv_monad_axioms list } -fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, - Injs, Sbs, Vrs, tacs, bd_infinite_regular_card_order }: bmv_monad_model +fun morph_bmv_monad_model phi f ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, + Injs, Sbs, Vrs, tacs, bd_infinite_regular_card_order } ) = { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, @@ -244,20 +239,15 @@ fun morph_bmv_monad_model phi ({ ops, bd, var_class, frees, lives, lives', param frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', - params = map (Option.map (fn { model, Map_Sb, Supp_Sb, Map_Vrs } => { - model = morph_supported_functor_model phi model, - Map_Sb = Map_Sb, - Supp_Sb = Supp_Sb, - Map_Vrs = Map_Vrs - })) params, + params = map (Option.map (morph_bmv_monad_param phi f)) params, bmv_ops = map (morph_bmv_monad phi) bmv_ops, leader = leader, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, - tacs = tacs, + tacs = map (map_bmv_monad_axioms f) tacs, bd_infinite_regular_card_order = bd_infinite_regular_card_order -} : bmv_monad_model; +} : 'b bmv_monad_model; structure Data = Generic_Data ( type T = bmv_monad Symtab.table; @@ -282,19 +272,17 @@ val mk_small_prems = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of Inj))))) )); -fun prove_axioms (model: bmv_monad_model) defs lthy = +fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = let - val Ts = #ops model @ maps ops_of_bmv_monad (#bmv_ops model); - val Sbs = #Sbs model @ maps Sbs_of_bmv_monad (#bmv_ops model); - val Injss = #Injs model @ maps Injs_of_bmv_monad (#bmv_ops model); - val Vrss = #Vrs model @ maps Vrs_of_bmv_monad (#bmv_ops model); + val Ts = ops @ maps ops_of_bmv_monad bmv_ops; + val Sbs = Sb @ maps Sbs_of_bmv_monad bmv_ops; + val Injss = Injs @ maps Injs_of_bmv_monad bmv_ops; + val Vrss = Vrs @ maps Vrs_of_bmv_monad bmv_ops; - fun prove tac {context=ctxt, ...} = Local_Defs.unfold0_tac ctxt defs THEN tac ctxt; - - val axioms = @{map 5} (fn T => fn Injs => fn Sb => fn Vrs => fn tacs => + val axioms = @{map 4} (fn T => fn Injs => fn Sb => fn Vrs => let - val (own_Injs, other_Injs) = partition (fn Inj => member (op=) (#ops model) (body_type (fastype_of Inj))) Injs; - val is_own_Inj = map (member (op=) (#ops model) o body_type o fastype_of) Injs; + val (own_Injs, other_Injs) = partition (fn Inj => member (op=) ops (body_type (fastype_of Inj))) Injs; + val is_own_Inj = map (member (op=) ops o body_type o fastype_of) Injs; val other_idxs = map (fn Inj => find_index (fn T => body_type (fastype_of Inj) = T) Ts) other_Injs; val ((((rhos, rhos'), aa), x), _) = lthy |> mk_Frees "\" (map fastype_of Injs) @@ -303,22 +291,19 @@ fun prove_axioms (model: bmv_monad_model) defs lthy = ||>> apfst hd o mk_Frees "x" [T]; val nown = length own_Injs; val (own_rhos, other_rhos) = chop nown rhos; - val (own_rhos', other_rhos') = chop nown rhos'; - val Sb_Inj = Goal.prove_sorry lthy [] [] ( - mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T) - ) (prove (#Sb_Inj tacs)); + val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T); val small_prems = mk_small_prems rhos Injs; val small_prems' = mk_small_prems rhos' Injs; - val Sb_comp_Injs = @{map 3} (fn Inj => fn rho => fn tac => Goal.prove_sorry lthy [] [] ( + val Sb_comp_Injs = map2 (fn Inj => fn rho => fold_rev Logic.all rhos (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb (Sb, rhos), Inj), rho ))) - ) (prove tac)) own_Injs own_rhos (#Sb_comp_Injs tacs); + ) own_Injs own_rhos; - val Sb_comp = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos') ( + val Sb_comp = fold_rev Logic.all (rhos' @ rhos) ( fold_rev (curry Logic.mk_implies) (small_prems @ small_prems') (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb (Sb, rhos'), Term.list_comb (Sb, rhos)), Term.list_comb (Sb, map (fn rho => HOLogic.mk_comp ( @@ -330,25 +315,22 @@ fun prove_axioms (model: bmv_monad_model) defs lthy = ) Injs), rho) ) other_rhos (map (nth Sbs) other_idxs) (map (nth Injss) other_idxs)) )) - )) (prove (#Sb_comp tacs)); + ); - val Vrs_bds = map2 (map2 (@{map_option 2} (fn Vrs => fn tac => - Goal.prove_sorry lthy [] [] (Logic.all x (HOLogic.mk_Trueprop ( - mk_ordLess (mk_card_of (Vrs $ x)) (#bd model) - ))) (prove tac) - ))) Vrs (#Vrs_bds tacs); + val Vrs_bds = map (map (Option.map (fn Vrs => Logic.all x ( + HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) bd) + )))) Vrs; - val Vrs_Injs = @{map 3} (fn Inj => map2 (@{map_option 2} (fn tac => fn Vrs => + val Vrs_Injs = map2 (fn Inj => map (Option.map (fn Vrs => 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 Goal.prove_sorry lthy [] [] ( - Logic.all a (mk_Trueprop_eq ( - Vrs $ (Inj $ a), - if fastype_of a = T then mk_singleton a else mk_bot T)) - ) (prove tac) end))) own_Injs (#Vrs_Injs tacs) (cond_keep Vrs is_own_Inj); + in Logic.all a (mk_Trueprop_eq ( + Vrs $ (Inj $ a), + if fastype_of a = T then mk_singleton a else mk_bot T)) + end))) own_Injs (cond_keep Vrs is_own_Inj); - val Vrs_Sbs = @{map 3} (fn rho => map2 (@{map_option 2} (fn Vrs => fn tac => + val Vrs_Sbs = map2 (fn rho => map (Option.map (fn Vrs => let val var = HOLogic.dest_setT (body_type (fastype_of Vrs)); val idx = find_index (fn T => body_type (fastype_of rho) = T) Ts; @@ -356,17 +338,15 @@ fun prove_axioms (model: bmv_monad_model) defs lthy = val Vrs' = hd (map_filter (Option.mapPartial (fn t => if HOLogic.dest_setT (body_type (fastype_of t)) = var then SOME t else NONE )) (nth (nth Vrss idx) idx')); + in fold_rev Logic.all (rhos @ [x]) ( + fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( + Vrs $ (Term.list_comb (Sb, rhos) $ x), + mk_UNION (Vrs $ x) (Term.abs ("a", var) (Vrs' $ (rho $ Bound 0))) + )) + ) end + ))) rhos Vrs; - val goal = fold_rev Logic.all (rhos @ [x]) ( - fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( - Vrs $ (Term.list_comb (Sb, rhos) $ x), - mk_UNION (Vrs $ x) (Term.abs ("a", var) (Vrs' $ (rho $ Bound 0))) - )) - ); - in Goal.prove_sorry lthy [] [] goal (prove tac) end - ))) rhos Vrs (#Vrs_Sbs tacs); - - val Sb_cong = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ rhos' @ [x]) ( + val Sb_cong = fold_rev Logic.all (rhos @ rhos' @ [x]) ( fold_rev (curry Logic.mk_implies) (small_prems @ small_prems' @ flat (@{map 3} (fn rho => fn rho' => map_filter (Option.map (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 ( @@ -377,7 +357,7 @@ fun prove_axioms (model: bmv_monad_model) defs lthy = Term.list_comb (Sb, rhos) $ x, Term.list_comb (Sb, rhos') $ x ) - ))) (prove (#Sb_cong tacs)); + )); in { Sb_Inj = Sb_Inj, @@ -387,11 +367,11 @@ fun prove_axioms (model: bmv_monad_model) defs lthy = Vrs_bds = Vrs_bds, Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong - } : thm bmv_monad_axioms end - ) (#ops model) (#Injs model) (#Sbs model) (#Vrs model) (#tacs model); + } : term bmv_monad_axioms end + ) ops Injs Sb Vrs; in axioms end; -fun prove_params (model: bmv_monad_model) defs lthy = @{map 5} (fn T => fn Sb => fn Injs => fn Vrs => Option.map (fn param => +fun mk_param_axioms (model: 'a bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn Injs => fn Vrs => Option.map (fn param => let val (Cs, _) = lthy |> mk_TFrees (length (#lives model)); @@ -399,84 +379,81 @@ fun prove_params (model: bmv_monad_model) defs lthy = @{map 5} (fn T => fn Sb => |> mk_Frees "f" (map2 (curry (op-->)) (#lives model) (#lives' model)) ||>> mk_Frees "g" (map2 (curry (op-->)) (#lives' model) Cs) ||>> mk_Frees "\" (map fastype_of Injs) - ||>> apfst hd o mk_Frees "x" [T]; - val pmodel = #model param; + ||>> apfst hd o mk_Frees "x" [T];; - fun prove tac {context=ctxt, ...} = Local_Defs.unfold0_tac ctxt defs THEN tac ctxt - - val Map_id = Goal.prove_sorry lthy [] [] (Term.subst_atomic_types (#lives' model ~~ #lives model) ( + val Map_id = Term.subst_atomic_types (#lives' model ~~ #lives model) ( mk_Trueprop_eq ( - Term.list_comb (#Map pmodel, map HOLogic.id_const (#lives model)), HOLogic.id_const T + Term.list_comb (#Map param, map HOLogic.id_const (#lives model)), HOLogic.id_const T ) - )) (prove (#Map_id (#tacs pmodel))); + ); - val Map_comp = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq ( + val Map_comp = fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb ( - Term.subst_atomic_types ((#lives model @ #lives' model) ~~ (#lives' model @ Cs)) (#Map pmodel), gs - ), Term.list_comb (#Map pmodel, fs)), - Term.list_comb (Term.subst_atomic_types (#lives' model ~~ Cs) (#Map pmodel), map2 (curry HOLogic.mk_comp) gs fs) - ))) (prove (#Map_comp (#tacs pmodel))); - - val Supp_Maps = @{map 3} (fn Supp => fn f => fn tac => - Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( - Term.subst_atomic_types (#lives model ~~ #lives' model) Supp $ (Term.list_comb (#Map pmodel, fs) $ x), + Term.subst_atomic_types ((#lives model @ #lives' model) ~~ (#lives' model @ Cs)) (#Map param), gs + ), Term.list_comb (#Map param, fs)), + Term.list_comb (Term.subst_atomic_types (#lives' model ~~ Cs) (#Map param), 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 model ~~ #lives' model) Supp $ (Term.list_comb (#Map param, fs) $ x), mk_image f $ (Supp $ x) - ))) (prove tac) - ) (#Supps pmodel) fs (#Supp_Map (#tacs pmodel)); + )) + ) (#Supps param) fs; - val Supp_bds = map2 (fn Supp => fn tac => Goal.prove_sorry lthy [] [] (Logic.all x (HOLogic.mk_Trueprop ( + val Supp_bds = map (fn Supp => Logic.all x (HOLogic.mk_Trueprop ( mk_ordLess (mk_card_of (Supp $ x)) (#bd model) - ))) (prove tac)) (#Supps pmodel) (#Supp_bd (#tacs pmodel)); + ))) (#Supps param); val (gs', _) = lthy |> mk_Frees "g" (map fastype_of fs); - val Map_cong = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ gs' @ [x]) ( + 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 pmodel) fs gs') (mk_Trueprop_eq ( - Term.list_comb (#Map pmodel, fs) $ x, - Term.list_comb (#Map pmodel, gs') $ x - )))) (prove (#Map_cong (#tacs pmodel))); + ) (#Supps param) fs gs') (mk_Trueprop_eq ( + Term.list_comb (#Map param, fs) $ x, + Term.list_comb (#Map param, gs') $ x + ))); - val Map_Sb = Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ rhos) ( + val Map_Sb = fold_rev Logic.all (fs @ rhos) ( fold_rev (curry Logic.mk_implies) (mk_small_prems rhos Injs) (mk_Trueprop_eq ( - HOLogic.mk_comp (Term.list_comb (#Map pmodel, fs), Term.list_comb (Sb, rhos)), + HOLogic.mk_comp (Term.list_comb (#Map param, fs), Term.list_comb (Sb, rhos)), HOLogic.mk_comp (Term.list_comb ( Term.subst_atomic_types (#lives model ~~ #lives' model) Sb, rhos - ), Term.list_comb (#Map pmodel, fs)) + ), Term.list_comb (#Map param, fs)) )) - )) (prove (#Map_Sb param)); + ); - val Map_Vrs = map2 (map2 (@{map_option 2} (fn Vrs => fn tac => - Goal.prove_sorry lthy [] [] (fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( - Term.subst_atomic_types (#lives model ~~ #lives' model) Vrs $ (Term.list_comb (#Map pmodel, fs) $ x), + val Map_Vrs = map (map (Option.map (fn Vrs => + fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( + Term.subst_atomic_types (#lives model ~~ #lives' model) Vrs $ (Term.list_comb (#Map param, fs) $ x), Vrs $ x - ))) (prove tac) - ))) Vrs (#Map_Vrs param); + )) + ))) Vrs; - val Supp_Sb = map2 (fn Supp => fn tac => - Goal.prove_sorry lthy [] [] (fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( + val Supp_Sb = map (fn Supp => + fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( Supp $ (Term.list_comb (Sb, rhos) $ x), Supp $ x - ))) (prove tac) - ) (#Supps pmodel) (#Supp_Sb param); + )) + ) (#Supps param); in { - Map = #Map pmodel, - Supps = #Supps pmodel, + Map = #Map param, + Supps = #Supps param, axioms = { Map_id = Map_id, Map_comp = Map_comp, Supp_Map = Supp_Maps, Supp_bd = Supp_bds, Map_cong = Map_cong - } : thm supported_functor_axioms, + } : term supported_functor_axioms, Map_Sb = Map_Sb, Supp_Sb = Supp_Sb, Map_Vrs = Map_Vrs - } end + }: term bmv_monad_param end )) (#ops model) (#Sbs model) (#Injs model) (#Vrs model) (#params model); val smart_max_inline_term_size = 25; (*FUDGE*) @@ -503,7 +480,7 @@ fun maybe_define const_policy fact_policy b rhs lthy = 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 const_policy fact_policy qualify (model: bmv_monad_model) lthy = +fun define_bmv_monad_consts const_policy fact_policy qualify (model: 'a bmv_monad_model) lthy = let val maybe_define = maybe_define const_policy fact_policy o qualify; @@ -534,20 +511,18 @@ fun define_bmv_monad_consts const_policy fact_policy qualify (model: bmv_monad_m 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 (#model param)) lthy; + 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 (#model param)) - 1) (#Supps (#model param)) lthy); + ) (0 upto length (#Supps param) - 1) (#Supps param) lthy); val param = { - model = { - Map = Map, - Supps = Supps, - tacs = #tacs (#model param) - }, + Map = Map, + Supps = Supps, + axioms = #axioms param, Map_Sb = #Map_Sb param, Supp_Sb = #Supp_Sb param, Map_Vrs = #Map_Vrs param - } + }: 'a bmv_monad_param; in ((param, Map_def :: Supp_defs), lthy) end )) suffixes (#params model) lthy; val params = map (Option.map fst) params'; @@ -570,7 +545,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify (model: bmv_monad_m Vrs = Vrs, bd_infinite_regular_card_order = #bd_infinite_regular_card_order model, tacs = #tacs model - } : bmv_monad_model; + } : 'a bmv_monad_model; val (lthy, old_lthy) = `Local_Theory.end_nested lthy; val phi = Proof_Context.export_morphism old_lthy lthy; @@ -579,24 +554,85 @@ fun define_bmv_monad_consts const_policy fact_policy qualify (model: bmv_monad_m 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 model' = morph_bmv_monad_model phi' model'; + val model' = morph_bmv_monad_model phi' I model'; val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ [bd_def] @ flat param_defs); in (model', map (Morphism.thm phi) defs, lthy) end; -fun bmv_monad_def const_policy fact_policy qualify (model: bmv_monad_model) lthy = +fun mk_bmv_monad const_policy fact_policy (model: thm bmv_monad_model) lthy = let - (*val _ = let - val var_large = MRBNF_Def.get_class_assumption [#var_class model] "large" lthy; - val bd' = snd (dest_comb (dest_card_of ( - fst (dest_ordLeq (HOLogic.dest_Trueprop (Thm.prop_of var_large))) - ))); - in if bd' <> #bd model then error "var_class does not match bound" else () end*) + (* TODO: Derived theorems *) + val bmv = BMV { + ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), + bd = #bd model, + var_class = #var_class model, + leader = #leader model, + frees = #frees model, + lives = #lives model, + lives' = #lives' model, + params = #params model @ maps (#params o Rep_bmv) (#bmv_ops model), + Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), + Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), + Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), + axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model), + bd_infinite_regular_card_order = #bd_infinite_regular_card_order model + } : bmv_monad; + 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) (#bd model) (#Sbs model) (#Injs model) (#Vrs 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 = mk_param_axioms model lthy; + val tacs' = map (Option.map (morph_bmv_monad_param Morphism.identity (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, Map_Vrs=f3s, ...} => + fn { Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs } => { + Map = Map, Supps = Supps, Map_Sb = f1 Map_Sb, Supp_Sb = map2 (curry (op|>)) Supp_Sb f2s, + Map_Vrs = map2 (map2 (@{map_option 2} (curry (op|>)))) Map_Vrs f3s, 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, + bd = #bd model, + var_class = #var_class model, + leader = #leader model, + frees = #frees model, + lives = #lives model, + lives' = #lives' model, + bmv_ops = #bmv_ops model, + params = params, + Injs = #Injs model, + Sbs = #Sbs model, + Vrs = #Vrs model, + bd_infinite_regular_card_order = bd_irco, + tacs = axioms +} : thm bmv_monad_model; + +fun bmv_monad_def const_policy fact_policy qualify (model: (Proof.context -> tactic) bmv_monad_model) 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))) (#frees model); - val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) model; + val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) I model; val (model, unfold_set, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify model lthy; @@ -607,22 +643,8 @@ fun bmv_monad_def const_policy fact_policy qualify (model: bmv_monad_model) lthy mk_infinite_regular_card_order (#bd model) )) (fn {context=ctxt, ...} => Local_Defs.unfold0_tac ctxt unfold_set THEN #bd_infinite_regular_card_order model ctxt); - val bmv = BMV { - ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), - bd = #bd model, - var_class = #var_class model, - leader = #leader model, - frees = #frees model, - lives = #lives model, - lives' = #lives' model, - params = params @ maps (#params o Rep_bmv) (#bmv_ops model), - Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), - Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), - Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), - axioms = axioms @ maps (#axioms o Rep_bmv) (#bmv_ops model), - bd_infinite_regular_card_order = bd_irco - } : bmv_monad; - in ((bmv, unfold_set), lthy) end + val model = mk_thm_model model params axioms bd_irco; + in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy model lthy) end fun pbmv_monad_of_bnf bnf lthy = let @@ -645,19 +667,17 @@ fun pbmv_monad_of_bnf bnf lthy = lives' = lives', bmv_ops = [], params = [SOME { - model = { - Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, - Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf, - tacs = { - Map_id = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, - Map_comp = fn ctxt => rtac ctxt (BNF_Def.map_comp0_of_bnf bnf RS sym) 1, - Supp_Map = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_map_of_bnf bnf), - Supp_bd = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_bd_of_bnf bnf), - Map_cong = fn ctxt => EVERY1 [ - rtac ctxt (BNF_Def.map_cong0_of_bnf bnf), - REPEAT_DETERM o Goal.assume_rule_tac ctxt - ] - } + Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, + Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf, + axioms = { + Map_id = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, + Map_comp = fn ctxt => rtac ctxt (BNF_Def.map_comp0_of_bnf bnf RS sym) 1, + Supp_Map = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_map_of_bnf bnf), + Supp_bd = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_bd_of_bnf bnf), + Map_cong = fn ctxt => EVERY1 [ + rtac ctxt (BNF_Def.map_cong0_of_bnf bnf), + REPEAT_DETERM o Goal.assume_rule_tac ctxt + ] }, Map_Sb = fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_o o_id} THEN rtac ctxt refl 1, Supp_Sb = replicate n (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_apply} THEN rtac ctxt refl 1), @@ -925,9 +945,95 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy (map (nth (axioms_of_bmv_monad outer)) idxs) (map (the o nth (params_of_bmv_monad outer)) idxs) Injs Vrs outer_Vrs - } : bmv_monad_model; + } : (Proof.context -> tactic) bmv_monad_model; val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify model lthy in (res, lthy) end; +fun pbmv_monad_cmd (((((((b, ops), frees), Sbs), Injs), Vrs), param_opt), bd) lthy = + let + val ops = map (Syntax.read_typ lthy) ops; + val bd = Syntax.read_term lthy bd; + val frees = map (Syntax.read_typ lthy) frees; + val Sbs = map (Syntax.read_term lthy) Sbs; + val Injs = map (map (Syntax.read_term lthy)) Injs; + val Vrs = map (map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t)))) Vrs; + + val b = if Binding.is_empty b then fst (dest_Type (hd ops)) else Local_Theory.full_name lthy b + + val goals = mk_bmv_monad_axioms ops bd Sbs Injs Vrs [] lthy; + + fun after_qed thmss lthy = + let + val thms = map hd thmss; + val model = { + ops = ops, + bd = bd, + var_class = @{class var}, (* TODO: change *) + leader = 0, + frees = frees, + lives = [], + lives' = [], + bmv_ops = [], + params = replicate (length ops) NONE, + Injs = Injs, + Sbs = Sbs, + Vrs = Vrs, + bd_infinite_regular_card_order = hd thms, + tacs = fst (fold_map (fn goal => fn thms => + let + val chop_many = fold_map (fold_map ( + fn NONE => (fn thms => (NONE, thms)) + | SOME _ => fn thms => (SOME (hd thms), tl thms) + )); + val ((((((Sb_Inj, Sb_comp_Injs), Sb_comp), Vrs_bds), Vrs_Injs), Vrs_Sbs), thms) = thms + |> apfst hd o chop 1 + ||>> chop (length (#Sb_comp_Injs goal)) + ||>> apfst hd o chop 1 + ||>> chop_many (#Vrs_bds goal) + ||>> chop_many (#Vrs_Injs goal) + ||>> chop_many (#Vrs_Sbs goal); + in ({ + Sb_Inj = Sb_Inj, + Sb_comp_Injs = Sb_comp_Injs, + Sb_comp = Sb_comp, + Vrs_bds = Vrs_bds, + Vrs_Injs = Vrs_Injs, + Vrs_Sbs = Vrs_Sbs, + Sb_cong = hd thms + }: thm bmv_monad_axioms, thms) end + ) goals (tl thms)) + } : thm bmv_monad_model; + + val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) model 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)] + @ maps (fn goal => #Sb_Inj goal :: #Sb_comp_Injs goal @ [#Sb_comp goal] + @ maps (map_filter I) (#Vrs_bds goal @ #Vrs_Injs goal @ #Vrs_Sbs goal) + @ [#Sb_cong goal] + ) goals + )) lthy + |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) + end + +val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} + "register a parametrized bounded multi-variate monad" + (parse_opt_binding_colon -- Scan.repeat1 (Scan.unless (Parse.reserved "frees") Parse.typ) --| + (Parse.reserved "frees" -- @{keyword ":"}) -- Scan.repeat1 (Scan.unless (Parse.reserved "Sbs") Parse.typ) --| + (Parse.reserved "Sbs" -- @{keyword ":"}) -- Scan.repeat1 (Scan.unless (Parse.reserved "Injs") Parse.term) --| + (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.list (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") Parse.term)) --| + (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list (Parse.list ( + Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.term || Parse.reserved "_")) + )) -- + Scan.optional ( + (Parse.reserved "Map" -- @{keyword ":"}) |-- Scan.repeat1 (Scan.unless (Parse.reserved "Supps") Parse.term) --| + (Parse.reserved "Supps" -- @{keyword ":"}) -- Parse.list (Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) + >> SOME + ) NONE --| + (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term + >> pbmv_monad_cmd) + end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 3aa6d7f0..00c4e32b 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -1,7 +1,10 @@ theory BMV_Monad imports "Binders.MRBNF_Recursor" + keywords "pbmv_monad" :: thy_goal begin + + declare [[mrbnf_internals]] binder_datatype 'a FType = TyVar 'a @@ -92,62 +95,34 @@ qed (auto simp: assms(1-2)) ML_file \../Tools/bmv_monad_def.ML\ -ML \ -Multithreading.parallel_proofs := 0 -\ +pbmv_monad ID: 'a + frees: 'a + Sbs: "id :: ('a \ 'a) \ 'a \ 'a" + Injs: "id :: 'a \ 'a" + Vrs: "\(x::'a). {x}" + bd: natLeq + by (auto simp: ID.set_bd infinite_regular_card_order_natLeq) + +pbmv_monad "'a::var FType" + frees: "'a::var" + Sbs: tvsubst_FType + Injs: TyVar + Vrs: FVars_FType + bd: natLeq + apply (rule infinite_regular_card_order_natLeq) + apply (rule Sb_Inj_FType) + apply (rule Sb_comp_Inj_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) + apply (rule Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) + apply (rule FType.set_bd) + apply (rule Vrs_Inj_FType) + apply (rule Vrs_Sb_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) + apply (rule Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) + done ML \ -val model_FType = { - ops = [@{typ "'a::var FType"}], - bd = @{term natLeq}, - var_class = @{class var}, - leader = 0, - frees = [@{typ "'a::var"}], - lives = [], - lives' = [], - params = [NONE], - bmv_ops = [], - Injs = [[@{term "TyVar :: 'a::var \ _"}]], - Sbs = [@{term "tvsubst_FType :: _ => 'a::var FType => _"}], - Vrs = [[[SOME @{term "FVars_FType :: _ => 'a::var set"}]]], - bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, - tacs = [{ - Sb_Inj = fn ctxt => resolve_tac ctxt @{thms Sb_Inj_FType} 1, - Sb_comp_Injs = [fn ctxt => EVERY1 [ - resolve_tac ctxt @{thms Sb_comp_Inj_FType}, - K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), - assume_tac ctxt - ]], - Sb_comp = fn ctxt => EVERY1 [ - resolve_tac ctxt @{thms Sb_comp_FType}, - K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), - REPEAT_DETERM o assume_tac ctxt - ], - Vrs_bds = [[SOME (fn ctxt => resolve_tac ctxt @{thms FType.set_bd} 1)]], - Vrs_Injs = [[SOME (fn ctxt => resolve_tac ctxt @{thms Vrs_Inj_FType} 1)]], - Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ - resolve_tac ctxt @{thms Vrs_Sb_FType}, - K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), - assume_tac ctxt - ])]], - Sb_cong = fn ctxt => EVERY1 [ - resolve_tac ctxt @{thms Sb_cong_FType}, - K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def VVr_eq_Var}), - REPEAT_DETERM o assume_tac ctxt, - Goal.assume_rule_tac ctxt - ] - } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : BMV_Monad_Def.bmv_monad_model; -\ -ML \ -val lthy = Unsynchronized.ref (NONE : local_theory option) -\ -local_setup \fn x => (lthy := SOME x ; x)\ -ML \ -val FType_bmv = fst (BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I model_FType (the (!lthy))) +Multithreading.parallel_proofs := 0 \ - (* *) type_synonym ('a1, 'a2, 'c1, 'c2) L = "'a1 * 'a1 * ('c1 + 'c2)" (* PBMV *) type_synonym ('a1, 'a2, 'c1, 'c2) L_M1 = "'a1" (* PBMV *) @@ -250,52 +225,12 @@ lemma insert_bound: "Cinfinite r \ |A| |i declare [[ML_print_depth=10000]] ML \ -val model_ID = { - ops = [@{typ "'a"}], - bd = @{term natLeq}, - var_class = @{class var}, - leader = 0, - frees = [@{typ "'a"}], - lives = [], - lives' = [], - bmv_ops = [], - params = [NONE], - Injs = [[@{term "id :: 'a \ _"}]], - Sbs = [@{term "id :: _ => 'a => 'a"}], - Vrs = [[[SOME @{term "\(x::'a). {x}"}]]], - bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, - tacs = [{ - Sb_Inj = fn ctxt => resolve_tac ctxt @{thms id_apply} 1, - Sb_comp_Injs = [fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), - resolve_tac ctxt [refl] - ]], - Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), - resolve_tac ctxt [refl] - ], - Vrs_bds = [[SOME (fn ctxt => resolve_tac ctxt @{thms ID.set_bd} 1)]], - Vrs_Injs = [[SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), - resolve_tac ctxt [refl] - ])]], - Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms UN_single id_def}), - resolve_tac ctxt [refl] - ])]], - Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms comp_def id_def}), - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms singletonI}, - assume_tac ctxt - ] - } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : BMV_Monad_Def.bmv_monad_model; +val id_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID") +val FType_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.FType") \ ML \ -val mk_model_L = fn id_bmv => { +val model_L = { ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], bd = @{term natLeq}, var_class = @{class var}, @@ -308,47 +243,45 @@ val mk_model_L = fn id_bmv => { BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] )) id_bmv], params = [SOME { - model = { - (*Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"},*) - Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, - (*Supps = [ - @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, - @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} - ],*) - Supps = [ - @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, - @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} + (*Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"},*) + Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, + (*Supps = [ + @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, + @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} + ],*) + Supps = [ + @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, + @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} + ], + axioms = { + Map_id = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def sum.map_id0 id_apply}), + resolve_tac ctxt [ext], + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta prod.collapse}), + resolve_tac ctxt @{thms id_apply[symmetric]} ], - tacs = { - Map_id = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def sum.map_id0 id_apply}), - resolve_tac ctxt [ext], - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta prod.collapse}), - resolve_tac ctxt @{thms id_apply[symmetric]} - ], - Map_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), - resolve_tac ctxt [ext], - resolve_tac ctxt @{thms trans[OF comp_apply]}, - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum.map_comp}), - resolve_tac ctxt [refl] - ], - Supp_Map = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), - resolve_tac ctxt [refl] - ]), - Supp_bd = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Supp_L_1_def Supp_L_2_def}), - resolve_tac ctxt @{thms sum.set_bd} - ]), - Map_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv}), - K (Local_Defs.unfold0_tac ctxt @{thms prod.inject}), - REPEAT_DETERM o resolve_tac ctxt @{thms conjI[OF refl]}, - resolve_tac ctxt @{thms sum.map_cong0}, - REPEAT_DETERM o Goal.assume_rule_tac ctxt - ] - } + Map_comp = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), + resolve_tac ctxt [ext], + resolve_tac ctxt @{thms trans[OF comp_apply]}, + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum.map_comp}), + resolve_tac ctxt [refl] + ], + Supp_Map = replicate 2 (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), + resolve_tac ctxt [refl] + ]), + Supp_bd = replicate 2 (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Supp_L_1_def Supp_L_2_def}), + resolve_tac ctxt @{thms sum.set_bd} + ]), + Map_cong = fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv}), + K (Local_Defs.unfold0_tac ctxt @{thms prod.inject}), + REPEAT_DETERM o resolve_tac ctxt @{thms conjI[OF refl]}, + resolve_tac ctxt @{thms sum.map_cong0}, + REPEAT_DETERM o Goal.assume_rule_tac ctxt + ] }, Map_Sb = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), @@ -423,11 +356,11 @@ val mk_model_L = fn id_bmv => { resolve_tac ctxt [refl] ] } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : BMV_Monad_Def.bmv_monad_model; +} : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; \ ML \ -val mk_model_L1 = fn id_bmv => { +val model_L1 = { ops = [@{typ "'a1 * 'a2"}], bd = @{term natLeq}, var_class = @{class var}, @@ -505,11 +438,11 @@ val mk_model_L1 = fn id_bmv => { assume_tac ctxt ] } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : BMV_Monad_Def.bmv_monad_model; +} : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; \ ML \ -val mk_model_L2 = fn id_bmv => fn FType_bmv => { +val model_L2 = { ops = [@{typ "('a1, 'a2) L2"}], bd = @{term natLeq}, var_class = @{class var}, @@ -623,16 +556,14 @@ val mk_model_L2 = fn id_bmv => fn FType_bmv => { assume_tac ctxt ] } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : BMV_Monad_Def.bmv_monad_model; +} : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; \ local_setup \fn lthy => let - val ((id_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "ID_") model_ID lthy; - val ((FType_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "FType_") model_FType lthy; - val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") (mk_model_L id_bmv) lthy; - val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") (mk_model_L1 id_bmv) lthy; - val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") (mk_model_L2 id_bmv FType_bmv) lthy; + val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") model_L lthy; + val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") model_L1 lthy; + val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") model_L2 lthy; val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv] lthy val _ = @{print} comp_bmv @@ -644,4 +575,4 @@ local_setup \fn lthy => val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf (the (BNF_Def.bnf_of lthy "Sum_Type.sum")) lthy; val _ = @{print} bmv in lthy end -\ \ No newline at end of file +\ From 35f9e93b17ddaa5cca42707c61f883da6d5bff2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 1 Jan 2025 13:37:53 +0000 Subject: [PATCH 13/90] Add command to print registered pbmv monads --- Tools/bmv_monad_def.ML | 37 +++++++++++++++++++++++++++++++++++-- operations/BMV_Monad.thy | 16 +++++++--------- 2 files changed, 42 insertions(+), 11 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index acf78ea0..8ad0b522 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -77,6 +77,7 @@ signature BMV_MONAD_DEF = sig val pbmv_monad_of: Proof.context -> string -> bmv_monad option; val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory + val register_bnf_as_pbmv_monad: string -> local_theory -> local_theory val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory @@ -701,7 +702,14 @@ fun pbmv_monad_of_bnf bnf lthy = Vrs_Sbs = [], Sb_cong = fn ctxt => rtac ctxt refl 1 }] - } lthy) end + } lthy) end; + +fun register_bnf_as_pbmv_monad name lthy = + let + val bnf = the (BNF_Def.bnf_of lthy name); + val (bmv, lthy) = pbmv_monad_of_bnf bnf lthy; + val lthy = register_pbmv_monad name bmv lthy; + in lthy end (* Cleanup: Throw away op iff any: - not the leader @@ -1017,7 +1025,32 @@ fun pbmv_monad_cmd (((((((b, ops), frees), Sbs), Injs), Vrs), param_opt), bd) lt ) goals )) lthy |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) - end + end; + +fun print_pbmv_monads ctxt = + let + fun pretty_mrbnf (key, BMV {ops, frees, lives, bd, ...}) = + Pretty.big_list + (Pretty.string_of (Pretty.block ([Pretty.str key, Pretty.str ":", Pretty.brk 1] @ + map (Pretty.quote o Syntax.pretty_typ ctxt) ops))) + ([Pretty.block [Pretty.str "frees:", Pretty.brk 1, Pretty.str (string_of_int (length frees)), + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) frees)]] @ + (if length lives > 0 then + [Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int (length lives)), + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)]] + else []) @ + [Pretty.block [Pretty.str ("bd:"), Pretty.brk 1, + Pretty.quote (Syntax.pretty_term ctxt bd)]]); + 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" diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 00c4e32b..39a93699 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -1,6 +1,7 @@ theory BMV_Monad imports "Binders.MRBNF_Recursor" - keywords "pbmv_monad" :: thy_goal + keywords "print_pbmv_monads" :: diag and + "pbmv_monad" :: thy_goal begin @@ -95,7 +96,9 @@ qed (auto simp: assms(1-2)) ML_file \../Tools/bmv_monad_def.ML\ -pbmv_monad ID: 'a +local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ + +pbmv_monad ID: "'a" frees: 'a Sbs: "id :: ('a \ 'a) \ 'a \ 'a" Injs: "id :: 'a \ 'a" @@ -119,6 +122,8 @@ pbmv_monad "'a::var FType" apply (rule Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) done +print_pbmv_monads + ML \ Multithreading.parallel_proofs := 0 \ @@ -569,10 +574,3 @@ local_setup \fn lthy => val _ = @{print} comp_bmv in lthy end \ - -local_setup \fn lthy => - let - val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf (the (BNF_Def.bnf_of lthy "Sum_Type.sum")) lthy; - val _ = @{print} bmv - in lthy end -\ From 5759609de34d66ef5fafa48e03698a9291cc5149 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sat, 4 Jan 2025 16:23:47 +0000 Subject: [PATCH 14/90] Add bmv_monad_of_typ function --- Tools/bmv_monad_def.ML | 210 ++++++++++++++++++++++++--------------- Tools/pbmv_monad_comp.ML | 57 +++++++++++ operations/BMV_Monad.thy | 34 ++++++- 3 files changed, 219 insertions(+), 82 deletions(-) create mode 100644 Tools/pbmv_monad_comp.ML diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 8ad0b522..427c6d53 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -81,7 +81,7 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory - val compose_bmv_monad: (binding -> binding) -> bmv_monad -> bmv_monad list -> local_theory + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list -> local_theory -> (bmv_monad * thm list) * local_theory end @@ -160,7 +160,7 @@ fun morph_bmv_monad_param phi f ({ Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs Supp_Sb = map f Supp_Sb, Map_Vrs = map (map (Option.map f)) Map_Vrs }: 'b bmv_monad_param; - + datatype bmv_monad = BMV of { ops: typ list, bd: term, @@ -551,7 +551,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify (model: 'a bmv_mona val (lthy, old_lthy) = `Local_Theory.end_nested lthy; val phi = Proof_Context.export_morphism old_lthy lthy; - val vars = #frees model @ #lives model @ #lives' model; + val vars = map TFree (rev (Term.add_tfreesT (nth (#ops model) (#leader model)) [])) @ #lives' model; 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) @@ -716,50 +716,75 @@ fun register_bnf_as_pbmv_monad name lthy = - does not appear in the codomain of any (=of any **other** SOp) Injection, *) -fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy = +fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = let val _ = if length (lives_of_bmv_monad outer) <> length inners then error "Outer needs exactly as many lives as there are inners" else () + val filter_bmvs = map_filter (fn Inl x => SOME x | _ => NONE); + + val frees = fold (fn a => + let val (n, s) = dest_TFree a + in Symtab.map_default (n, s) (curry (Sign.inter_sort (Proof_Context.theory_of lthy)) s) end + ) (frees_of_bmv_monad outer @ maps frees_of_bmv_monad (filter_bmvs inners)) Symtab.empty; + + fun mk_sign_morph bmv = + morph_bmv_monad (MRBNF_Util.subst_typ_morphism (map (fn a => + let val (n, _) = dest_TFree a; + in (a, TFree (n, the (Symtab.lookup frees n))) end + ) (frees_of_bmv_monad bmv))) bmv; + fun mk_T_morph T = + let val vars = Term.add_tfreesT T []; + in Term.typ_subst_atomic (map (fn x => + (TFree x, the_default (TFree x) (Option.map (TFree o pair (fst x)) (Symtab.lookup frees (fst x)))) + ) vars) T end + val outer = mk_sign_morph outer; + val inners = map (map_sum mk_sign_morph mk_T_morph) inners; + val bmvs = Typtab.make_distinct (flat (map (fn bmv => (#ops bmv ~~ ((#params bmv) ~~ (#Injs bmv) ~~ (#Sbs bmv) ~~ (#Vrs bmv) ~~ map SOME (#axioms bmv) ~~ replicate (length (#Sbs bmv)) (SOME bmv)) - )) (map Rep_bmv inners))); + )) (map_filter (fn Inl bmv => SOME (Rep_bmv bmv) | Inr _ => NONE) inners))); val outer_ops' = map (fn T => if Typtab.defined bmvs T then NONE else SOME T) ( - map (Term.typ_subst_atomic (lives_of_bmv_monad outer ~~ map (fn bmv => - nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv) + map (Term.typ_subst_atomic (lives_of_bmv_monad outer ~~ map ( + fn Inl bmv => nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv) + | Inr T => T ) inners)) (ops_of_bmv_monad outer) ); val ((Sbs, Injs), Vrs) = apfst split_list (split_list (@{map 5} (fn NONE => K (K (K (K ((NONE, NONE), NONE)))) | SOME T => (fn NONE => K (K (K ((NONE, NONE), NONE))) | SOME param => fn Sb => fn Injs => fn Vrs => let - val ((Sbs, Ts), (Injss, Vrsss)) = apfst split_list (apsnd split_list (split_list (map (fn bmv => + val ((Sbs, Ts), (Injss, Vrsss)) = apfst split_list (apsnd split_list (split_list (map (fn Inl bmv => let fun pick xs = nth xs (leader_of_bmv_monad bmv) in ( - (pick (Sbs_of_bmv_monad bmv), pick (ops_of_bmv_monad bmv)), - (pick (Injs_of_bmv_monad bmv), pick (Vrs_of_bmv_monad bmv)) + (SOME (pick (Sbs_of_bmv_monad bmv)), pick (ops_of_bmv_monad bmv)), + (SOME (pick (Injs_of_bmv_monad bmv)), SOME (pick (Vrs_of_bmv_monad bmv))) ) end + | Inr T => ((NONE, T), (NONE, NONE)) ) inners))); val subst = (lives_of_bmv_monad outer @ lives'_of_bmv_monad outer) ~~ (Ts @ Ts); - val Injs' = distinct ((op=) o apply2 fastype_of) (Injs @ flat Injss); + val Injs' = distinct ((op=) o apply2 fastype_of) (Injs @ flat (map_filter I Injss)); val ((fs, x), _) = lthy |> mk_Frees "f" (map fastype_of Injs') ||>> apfst hd o mk_Frees "x" [T]; - val Vrs' = @{fold 4} (fn i => fn inner => @{fold 2} (fn Inj => fn Vrs => fn tab => - case Typtab.lookup tab (fastype_of Inj) of - NONE => tab - | SOME inner_tab => - let val inner_tab' = @{fold 2} (fn NONE => K I | SOME Vrs => fn free => - Typtab.map_default (free, [(i, Vrs)]) (cons (i, Vrs)) - ) Vrs (frees_of_bmv_monad inner) inner_tab; - in Typtab.update (fastype_of Inj, inner_tab') tab end - )) (0 upto length inners) (outer :: inners) (Injs :: Injss) (Vrs :: Vrsss) (Typtab.make (map (rpair Typtab.empty o fastype_of) Injs')); + val Vrs' = @{fold 4} (fn i => fn inner => fn Injs => fn Vrss => fn tab => case inner of + Inr _ => tab + | Inl inner => @{fold 2} (fn Inj => fn Vrs => fn tab => + case Typtab.lookup tab (fastype_of Inj) of + NONE => tab + | SOME inner_tab => + let val inner_tab' = @{fold 2} (fn NONE => K I | SOME Vrs => fn free => + Typtab.map_default (free, [(i, Vrs)]) (cons (i, Vrs)) + ) Vrs (frees_of_bmv_monad inner) inner_tab; + in Typtab.update (fastype_of Inj, inner_tab') tab end + ) (the Injs) (the Vrss) tab + ) (0 upto length inners) (Inl outer :: inners) (SOME Injs :: Injss) (SOME Vrs :: Vrsss) (Typtab.make (map (rpair Typtab.empty o fastype_of) Injs')); val frees = distinct (op=) (maps snd (Typtab.dest (Typtab.map (K Typtab.keys) Vrs'))); + val Supps = map (Term.subst_atomic_types subst) (#Supps param); - val Supps = map (Term.subst_atomic_types subst) (#Supps param) val Vrs' = map (fn Inj => map (fn free => Option.mapPartial (fn xs => let val Vrss = distinct (op=) (rev xs); @@ -779,12 +804,15 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy val find_fs = map (fn Inj => the (List.find (fn f => fastype_of f = fastype_of Inj) fs) ); + fun mk_comp t = if true orelse length (binder_types (fastype_of Sb)) > 1 then + HOLogic.mk_comp (t, Term.list_comb (Sb, find_fs Injs)) + else t in (( SOME (Term.subst_atomic_types subst ( - fold_rev (Term.absfree o dest_Free) fs (HOLogic.mk_comp ( - Term.list_comb (#Map param, - map2 (fn Sb => fn Injs => Term.list_comb (Sb, find_fs Injs)) Sbs Injss - ), Term.list_comb (Sb, find_fs Injs) + fold_rev (Term.absfree o dest_Free) fs (mk_comp ( + Term.list_comb (#Map param, @{map 3} (fn Inr T => K (K (HOLogic.id_const T)) + | _ => fn Sb => fn Injs => Term.list_comb (the Sb, find_fs (the Injs)) + ) inners Sbs Injss) )) )), SOME Injs'), @@ -806,7 +834,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy let val bmvs' = Typtab.delete T bmvs in (SOME (add_ops T Injs bmvs'), bmvs') end end - ) Injs bmvs))) + ) Injs bmvs))); fun pick xs = nth xs (leader_of_bmv_monad outer) val ops = add_ops (the (pick outer_ops')) (the (pick Injs)) bmvs; @@ -831,10 +859,12 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy val ops' = subtract (fn (bmv, T) => hd (ops_of_bmv_monad bmv) = T) bmv_ops ops; + val inners' = filter_bmvs inners; + val idxs = map (fn T => find_index (curry (op=) T) ops) ops'; val Vrs = map (the o nth Vrs) idxs; val Injs = map (the o nth Injs) idxs; - val frees = distinct (op=) (maps frees_of_bmv_monad (outer :: inners)); + val frees = distinct (op=) (maps frees_of_bmv_monad (outer :: inners')); val outer_Vrs = map (nth (Vrs_of_bmv_monad outer)) idxs; val model = { @@ -844,58 +874,61 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy 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 = distinct (op=) (maps lives_of_bmv_monad inners), - lives' = distinct (op=) (maps lives'_of_bmv_monad inners), + lives = distinct (op=) (maps lives_of_bmv_monad inners'), + lives' = distinct (op=) (maps lives'_of_bmv_monad inners'), params = replicate (length ops') NONE, leader = 0, Injs = Injs, Sbs = map (the o nth Sbs) idxs, Vrs = Vrs, tacs = @{map 5} (fn axioms => fn param => fn Injs => fn Vrs => fn outer_Vrs => { - Sb_Inj = fn ctxt => EVERY [ - Local_Defs.unfold0_tac ctxt (#Sb_Inj axioms :: @{thms o_id}), - Local_Defs.unfold0_tac ctxt ( - #Map_id (#axioms param) - :: maps (map #Sb_Inj o axioms_of_bmv_monad) inners - ), - rtac ctxt refl 1 + Sb_Inj = fn ctxt => EVERY1 [ + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt ext, + rtac ctxt (trans OF [#Map_cong (#axioms param), #Map_id (#axioms param) RS fun_cong]), + REPEAT_DETERM o resolve_tac ctxt (refl :: maps (map (fn ax => + #Sb_Inj ax RS fun_cong + ) o axioms_of_bmv_monad) inners'), + rtac ctxt @{thm trans[OF id_o]}, + rtac ctxt (#Sb_Inj axioms) ], Sb_comp_Injs = map (fn thm => fn ctxt => print_tac ctxt "Sb_comp_Inj" ) (#Sb_comp_Injs axioms), Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Map_Sb param RS sym), REPEAT_DETERM o assume_tac ctxt, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, rtac ctxt (#Sb_comp axioms), REPEAT_DETERM o assume_tac ctxt, - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt trans, rtac ctxt (#Map_comp (#axioms param)), rtac ctxt ext, rtac ctxt (#Map_cong (#axioms param)), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps (map #Sb_comp o axioms_of_bmv_monad) inners), + EqSubst.eqsubst_tac ctxt [0] (maps (map #Sb_comp o axioms_of_bmv_monad) inners'), REPEAT_DETERM o assume_tac ctxt, rtac ctxt refl ] ], Vrs_bds = map (map (Option.map (K (fn ctxt => EVERY1 [ REPEAT_DETERM o resolve_tac ctxt ( - map (fn thm => + maps (map_filter I) (#Vrs_bds axioms) + @ maps (maps (maps (map_filter I) o #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} - @ maps (map_filter I) (#Vrs_bds axioms) - @ maps (maps (maps (map_filter I) o #Vrs_bds) o axioms_of_bmv_monad) inners - @ #Supp_bd (#axioms param) ) ])))) Vrs, Vrs_Injs = map (map (Option.map (fn thm => fn ctxt => @@ -904,37 +937,46 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy Vrs_Sbs = map (map (Option.map (K (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms UN_Un}), REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, - TRY o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] [#Map_Sb param], - REPEAT_DETERM1 o assume_tac ctxt, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), - rtac ctxt trans, - resolve_tac ctxt (maps (map_filter I) (#Vrs_Sbs axioms)), - REPEAT_DETERM1 o assume_tac ctxt, - EqSubst.eqsubst_tac ctxt [0] (maps (map_filter I) (#Map_Vrs param)), - rtac ctxt refl - ], - K (Local_Defs.unfold0_tac ctxt (@{thms comp_def} @ #Supp_Map (#axioms param) @ #Supp_Sb param)), - K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def] UN_UN_flatten} - @ maps (maps (maps (map_filter I) o #Vrs_Sbs) o axioms_of_bmv_monad) inners - )), - REPEAT_DETERM o rtac ctxt refl + REPEAT_DETERM o FIRST' [ + EVERY' [ + rtac ctxt @{thm trans[OF arg_cong[OF comp_apply]]}, + rtac ctxt trans, + resolve_tac ctxt (maps (map_filter I) (#Map_Vrs param)), + rtac ctxt trans, + resolve_tac ctxt (maps (map_filter I) (#Vrs_Sbs axioms)), + REPEAT_DETERM o assume_tac ctxt, + rtac ctxt refl + ], + EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm arg_cong[of _ _ "\x. \(_ ` x)"]}, + rtac ctxt trans, + rtac ctxt @{thm trans[OF arg_cong[OF comp_apply]]}, + resolve_tac ctxt (#Supp_Map (#axioms param)), + rtac ctxt @{thm arg_cong[of _ _ "\x. _ ` x"]}, + resolve_tac ctxt (#Supp_Sb param), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_simps(10)}), + rtac ctxt trans, + rtac ctxt @{thm UN_cong}, + resolve_tac ctxt (maps (maps (maps (map_filter I) o #Vrs_Sbs) o axioms_of_bmv_monad) inners'), + REPEAT_DETERM o assume_tac ctxt, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_extend_simps(9)}), + rtac ctxt refl + ] + ] ])))) Vrs, Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt @{thm comp_apply_eq}, Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ - EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~(length ( - maps (map_filter I) outer_Vrs - ))) (#Sb_cong axioms)], - resolve_tac ctxt prems, - etac ctxt @{thm contrapos_pp}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj}), - REPEAT_DETERM o etac ctxt conjE, - assume_tac ctxt, - REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt @{thm trans[rotated]}, + rtac ctxt ( + let val n = length (lives_of_bmv_monad outer); + in mk_arg_cong lthy (n + 1) (#Map param) OF (replicate n refl) end + ), + K (prefer_tac 2), rtac ctxt (#Map_cong (#axioms param)), K (Local_Defs.unfold0_tac ctxt (#Supp_Sb param)), - EVERY' (map (fn inner => EVERY' [ + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), REPEAT_DETERM o EVERY' [ REPEAT_DETERM o resolve_tac ctxt prems, @@ -946,7 +988,17 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy assume_tac ctxt, assume_tac ctxt ] - ]) inners) + ]) inners), + rtac ctxt (#Sb_cong axioms), + REPEAT_DETERM o EVERY' [ + resolve_tac ctxt prems, + TRY o EVERY' [ + etac ctxt @{thm contrapos_pp}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj}), + REPEAT_DETERM o etac ctxt conjE, + assume_tac ctxt + ] + ] ]) ctxt ] } : (Proof.context -> tactic) bmv_monad_axioms) @@ -958,12 +1010,14 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : bmv_monad list) lthy val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify model lthy in (res, lthy) end; -fun pbmv_monad_cmd (((((((b, ops), frees), Sbs), Injs), Vrs), param_opt), bd) lthy = +fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = let val ops = map (Syntax.read_typ lthy) ops; val bd = Syntax.read_term lthy bd; - val frees = map (Syntax.read_typ lthy) frees; val Sbs = map (Syntax.read_term lthy) Sbs; + val frees = distinct (op=) (maps ( + map (fst o dest_funT) o fst o split_last o binder_types o fastype_of + ) Sbs); val Injs = map (map (Syntax.read_term lthy)) Injs; val Vrs = map (map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t)))) Vrs; @@ -1029,7 +1083,7 @@ fun pbmv_monad_cmd (((((((b, ops), frees), Sbs), Injs), Vrs), param_opt), bd) lt fun print_pbmv_monads ctxt = let - fun pretty_mrbnf (key, BMV {ops, frees, lives, bd, ...}) = + fun pretty_mrbnf (key, BMV {ops, frees, lives, bd, Sbs, ...}) = Pretty.big_list (Pretty.string_of (Pretty.block ([Pretty.str key, Pretty.str ":", Pretty.brk 1] @ map (Pretty.quote o Syntax.pretty_typ ctxt) ops))) @@ -1039,7 +1093,8 @@ fun print_pbmv_monads ctxt = [Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int (length lives)), Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)]] else []) @ - [Pretty.block [Pretty.str ("bd:"), Pretty.brk 1, + [ Pretty.block ([Pretty.str "Sb:", Pretty.brk 1] @ map (Pretty.quote o Syntax.pretty_term ctxt) Sbs), + Pretty.block [Pretty.str ("bd:"), Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt bd)]]); in Pretty.big_list "Registered parametrized bounded multi-variate monads:" @@ -1054,8 +1109,7 @@ val _ = val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} "register a parametrized bounded multi-variate monad" - (parse_opt_binding_colon -- Scan.repeat1 (Scan.unless (Parse.reserved "frees") Parse.typ) --| - (Parse.reserved "frees" -- @{keyword ":"}) -- Scan.repeat1 (Scan.unless (Parse.reserved "Sbs") Parse.typ) --| + (parse_opt_binding_colon -- Scan.repeat1 (Scan.unless (Parse.reserved "Sbs") Parse.typ) --| (Parse.reserved "Sbs" -- @{keyword ":"}) -- Scan.repeat1 (Scan.unless (Parse.reserved "Injs") Parse.term) --| (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.list (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") Parse.term)) --| (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list (Parse.list ( diff --git a/Tools/pbmv_monad_comp.ML b/Tools/pbmv_monad_comp.ML new file mode 100644 index 00000000..718ac975 --- /dev/null +++ b/Tools/pbmv_monad_comp.ML @@ -0,0 +1,57 @@ +signature PBMV_MONAD_COMP = sig + + val id_bmv_monad: BMV_Monad_Def.bmv_monad + val mk_id_bmv_monad: string * sort -> BMV_Monad_Def.bmv_monad + + val pbmv_monad_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) + -> (binding -> binding) -> typ -> (thm list * local_theory) + -> BMV_Monad_Def.bmv_monad option * (thm list * local_theory) +end + +structure PBMV_Monad_Comp : PBMV_MONAD_COMP = struct + +open MRBNF_Util + +val id_bmv_monad = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID"); + +fun mk_id_bmv_monad free = BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism [(hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad), TFree free)] +) id_bmv_monad; + +fun pbmv_monad_of_typ _ _ _ _ (TFree x) accum = (SOME (mk_id_bmv_monad x), accum) + | pbmv_monad_of_typ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" + | pbmv_monad_of_typ optim const_policy inline_policy qualify' (T as Type (n, Ts)) (accum, lthy) = + let val (bmv_opt, lthy) = case BMV_Monad_Def.pbmv_monad_of lthy n of + SOME bmv => (SOME bmv, lthy) + | NONE => case BNF_Def.bnf_of lthy n of + SOME bnf => + let val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf bnf lthy + in (SOME bmv, BMV_Monad_Def.register_pbmv_monad n bmv lthy) end + | NONE => (NONE, lthy); + in case bmv_opt of + NONE => (NONE, (accum, lthy)) + | SOME bmv => if null (BMV_Monad_Def.lives_of_bmv_monad bmv) then + let val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv) + in (SOME (BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( + rev (map TFree (Term.add_tfreesT T []) @ map TVar (Term.add_tvarsT T [])) ~~ Ts + )) bmv), (accum, lthy)) end + else let + (* TODO: outer with mixed/frees lives *) + 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 qualifies = map qualify (1 upto length Ts); + val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy) qualifies Ts (accum, lthy) + val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) Ts bmv_opts; + in if exists Option.isSome bmv_opts then + let val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) bmv bmvs lthy; + in (SOME bmv, (unfold_set @ accum, lthy)) end + else + (NONE, (accum, lthy)) + end + end; + +end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 39a93699..635b66b7 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -99,7 +99,6 @@ ML_file \../Tools/bmv_monad_def.ML\ local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ pbmv_monad ID: "'a" - frees: 'a Sbs: "id :: ('a \ 'a) \ 'a \ 'a" Injs: "id :: 'a \ 'a" Vrs: "\(x::'a). {x}" @@ -107,7 +106,6 @@ pbmv_monad ID: "'a" by (auto simp: ID.set_bd infinite_regular_card_order_natLeq) pbmv_monad "'a::var FType" - frees: "'a::var" Sbs: tvsubst_FType Injs: TyVar Vrs: FVars_FType @@ -122,11 +120,39 @@ pbmv_monad "'a::var FType" apply (rule Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) done -print_pbmv_monads +typedef ('a1, 'a2, 'c1, 'c2) L = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" + by (rule exI, rule UNIV_I) + +(*pbmv_monad "('a1, 'a2, 'c1, 'c2) L" + frees: 'a1 'a2 + Sbs: "\f x. Abs_L (map_prod f (map_prod f id) (Rep_L x))" + Injs: "id :: 'a1 \ 'a1" + Vrs: "\x. case Rep_L x of (x1, x2, _) \ {x1, x2}" + bd: natLeq + lives: 'c1 'c2*) + +ML_file \../Tools/pbmv_monad_comp.ML\ ML \ Multithreading.parallel_proofs := 0 \ +declare [[ML_print_depth=1000]] +local_setup \fn lthy => + let + val (bmv, (thms, lthy)) = PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I + @{typ "'a1 * 'a1 * (('a1 * 'a2) + ('a1 * 'a2 * 'a2 * 'a2 FType))"} + ([], lthy) + + val _ = @{print} (map (map (map (Option.map (Thm.cterm_of lthy o + Raw_Simplifier.rewrite_term (Proof_Context.theory_of lthy) + (@{thms } @ thms) [] + )))) ( + BMV_Monad_Def.Vrs_of_bmv_monad (the bmv) + )) + + val _ = @{print} bmv + in lthy end\ +print_pbmv_monads (* *) type_synonym ('a1, 'a2, 'c1, 'c2) L = "'a1 * 'a1 * ('c1 + 'c2)" (* PBMV *) @@ -570,7 +596,7 @@ local_setup \fn lthy => val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") model_L1 lthy; val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") model_L2 lthy; - val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [L1_bmv, L2_bmv] lthy + val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [MRBNF_Util.Inl L1_bmv, MRBNF_Util.Inl L2_bmv] lthy val _ = @{print} comp_bmv in lthy end \ From 8a869e30e2234f995e9f34d6a4407767eb2d0cca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 6 Jan 2025 12:25:19 +0000 Subject: [PATCH 15/90] Automatically infer/fix types in pbmv_monad command --- Tools/binder_inductive.ML | 2 +- Tools/bmv_monad_def.ML | 46 +++++++++++++++---- Tools/mrbnf_def.ML | 2 - case_studies/POPLmark/POPLmark_2B.thy | 18 ++++---- case_studies/POPLmark/SystemFSub.thy | 14 ++---- .../Pi_Calculus/Pi_Transition_Early.thy | 2 +- .../Pi_Calculus/Pi_Transition_Late.thy | 4 +- operations/BMV_Monad.thy | 37 ++++++++------- thys/MRBNF_FP.thy | 2 +- thys/Prelim/Prelim.thy | 3 ++ 10 files changed, 79 insertions(+), 51 deletions(-) diff --git a/Tools/binder_inductive.ML b/Tools/binder_inductive.ML index fbf7035e..6e7045ba 100644 --- a/Tools/binder_inductive.ML +++ b/Tools/binder_inductive.ML @@ -550,7 +550,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/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 427c6d53..eee83d83 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -34,6 +34,7 @@ signature BMV_MONAD_DEF = sig var_class: class, bmv_ops: bmv_monad list, frees: typ list, + deads: typ list, leader: int, lives: typ list, lives': typ list, @@ -53,6 +54,7 @@ signature BMV_MONAD_DEF = sig val frees_of_bmv_monad: bmv_monad -> typ list; val lives_of_bmv_monad: bmv_monad -> typ list; val lives'_of_bmv_monad: bmv_monad -> typ list; + val deads_of_bmv_monad: bmv_monad -> typ 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; @@ -169,6 +171,7 @@ datatype bmv_monad = BMV of { frees: typ list, lives: typ list, lives': typ list, + deads: typ list, params: thm bmv_monad_param option list, Injs: term list list, Sbs: term list, @@ -178,7 +181,7 @@ datatype bmv_monad = BMV of { } fun morph_bmv_monad phi (BMV { - ops, bd, var_class, leader, frees, lives, lives', params, Injs, Sbs, Vrs, axioms, + ops, bd, var_class, leader, frees, lives, lives', deads, params, Injs, Sbs, Vrs, axioms, bd_infinite_regular_card_order }) = BMV { ops = map (Morphism.typ phi) ops, @@ -188,6 +191,7 @@ fun morph_bmv_monad phi (BMV { frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', + deads = map (Morphism.typ phi) deads, params = map (Option.map (morph_bmv_monad_param phi (Morphism.thm phi))) params, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, @@ -205,6 +209,7 @@ 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 Rep_bmv val Sbs_of_bmv_monad = #Sbs o Rep_bmv val Maps_of_bmv_monad = map (Option.map #Map) o #params o Rep_bmv @@ -221,6 +226,7 @@ type 'a bmv_monad_model = { frees: typ list, lives: typ list, lives': typ list, + deads: typ list, params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, leader: int, @@ -232,7 +238,7 @@ type 'a bmv_monad_model = { } fun morph_bmv_monad_model phi f ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, - Injs, Sbs, Vrs, tacs, bd_infinite_regular_card_order } + Injs, Sbs, Vrs, tacs, bd_infinite_regular_card_order, deads } ) = { ops = map (Morphism.typ phi) ops, bd = Morphism.term phi bd, @@ -240,6 +246,7 @@ fun morph_bmv_monad_model phi f ({ ops, bd, var_class, frees, lives, lives', par frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', + deads = map (Morphism.typ phi) deads, params = map (Option.map (morph_bmv_monad_param phi f)) params, bmv_ops = map (morph_bmv_monad phi) bmv_ops, leader = leader, @@ -282,8 +289,8 @@ fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = val axioms = @{map 4} (fn T => fn Injs => fn Sb => fn Vrs => let - val (own_Injs, other_Injs) = partition (fn Inj => member (op=) ops (body_type (fastype_of Inj))) Injs; - val is_own_Inj = map (member (op=) ops o body_type o fastype_of) Injs; + val (own_Injs, other_Injs) = partition (fn Inj => body_type (fastype_of Inj) = T) Injs; + val is_own_Inj = map (curry (op=) T o body_type o fastype_of) Injs; val other_idxs = map (fn Inj => find_index (fn T => body_type (fastype_of Inj) = T) Ts) other_Injs; val ((((rhos, rhos'), aa), x), _) = lthy |> mk_Frees "\" (map fastype_of Injs) @@ -539,6 +546,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify (model: 'a bmv_mona frees = #frees model, lives = #lives model, lives' = #lives' model, + deads = #deads model, bmv_ops = #bmv_ops model, params = params, Injs = Injs, @@ -572,6 +580,7 @@ fun mk_bmv_monad const_policy fact_policy (model: thm bmv_monad_model) lthy = frees = #frees model, lives = #lives model, lives' = #lives' model, + deads = #deads model, params = #params model @ maps (#params o Rep_bmv) (#bmv_ops model), Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), @@ -619,6 +628,7 @@ fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { frees = #frees model, lives = #lives model, lives' = #lives' model, + deads = #deads model, bmv_ops = #bmv_ops model, params = params, Injs = #Injs model, @@ -666,6 +676,7 @@ fun pbmv_monad_of_bnf bnf lthy = frees = [], lives = lives, lives' = lives', + deads = deads, bmv_ops = [], params = [SOME { Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, @@ -848,6 +859,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit frees = #frees bmv, lives = #lives bmv, lives' = #lives' bmv, + deads = #deads bmv, params = [param], Injs = [Injs], Sbs = [Sb], @@ -867,6 +879,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val frees = distinct (op=) (maps frees_of_bmv_monad (outer :: inners')); val outer_Vrs = map (nth (Vrs_of_bmv_monad outer)) idxs; + val vars = distinct (op=) (map TFree (fold Term.add_tfreesT (ops' @ maps ops_of_bmv_monad inners') [])); + val lives = distinct (op=) (maps lives_of_bmv_monad inners'); + val model = { ops = ops', bmv_ops = bmv_ops, @@ -874,8 +889,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 = distinct (op=) (maps lives_of_bmv_monad inners'), + lives = lives, lives' = distinct (op=) (maps lives'_of_bmv_monad inners'), + deads = subtract (op=) (lives @ frees) vars, params = replicate (length ops') NONE, leader = 0, Injs = Injs, @@ -1014,17 +1030,26 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = let val ops = map (Syntax.read_typ lthy) ops; val bd = Syntax.read_term lthy bd; - val Sbs = map (Syntax.read_term lthy) Sbs; + val Sbs = map2 (fn Sb => fn T => Term.subst_atomic_types ( + map (apply2 TFree) (Term.add_tfreesT (body_type (fastype_of Sb)) [] ~~ Term.add_tfreesT T []) + @ map (apply2 TFree) (Term.add_tfreesT (snd (split_last (binder_types (fastype_of Sb)))) [] ~~ Term.add_tfreesT T []) + ) Sb) (map (Syntax.read_term lthy) Sbs) ops; val frees = distinct (op=) (maps ( map (fst o dest_funT) o fst o split_last o binder_types o fastype_of ) Sbs); val Injs = map (map (Syntax.read_term lthy)) Injs; val Vrs = map (map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t)))) Vrs; + val Vrs = map2 (fn T => map (map (Option.map (fn Vrs => Term.subst_atomic_types ( + map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of Vrs))) [] ~~ Term.add_tfreesT T []) + ) Vrs)))) ops Vrs; val b = if Binding.is_empty b then fst (dest_Type (hd ops)) else Local_Theory.full_name lthy b val goals = mk_bmv_monad_axioms ops bd Sbs Injs Vrs [] lthy; + val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); + val lives = []; + fun after_qed thmss lthy = let val thms = map hd thmss; @@ -1036,6 +1061,7 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = frees = frees, lives = [], lives' = [], + deads = subtract (op=) (lives @ frees) vars, bmv_ops = [], params = replicate (length ops) NONE, Injs = Injs, @@ -1109,10 +1135,10 @@ val _ = val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} "register a parametrized bounded multi-variate monad" - (parse_opt_binding_colon -- Scan.repeat1 (Scan.unless (Parse.reserved "Sbs") Parse.typ) --| - (Parse.reserved "Sbs" -- @{keyword ":"}) -- Scan.repeat1 (Scan.unless (Parse.reserved "Injs") Parse.term) --| - (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.list (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") Parse.term)) --| - (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list (Parse.list ( + (parse_opt_binding_colon -- Parse.and_list1 Parse.typ --| + (Parse.reserved "Sbs" -- @{keyword ":"}) -- Parse.and_list1 Parse.term --| + (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") Parse.term)) --| + (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list1 (Parse.list1 ( Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.term || Parse.reserved "_")) )) -- Scan.optional ( diff --git a/Tools/mrbnf_def.ML b/Tools/mrbnf_def.ML index 18629f59..334aa94c 100644 --- a/Tools/mrbnf_def.ML +++ b/Tools/mrbnf_def.ML @@ -254,8 +254,6 @@ sig val mrbnf_cmd: ((((((((binding * string) * string) * (var_type * string) list) * string) * string list) * string option) * string option) * string option) * (Proof.context -> Plugin_Name.filter) -> Proof.context -> Proof.state - - val get_class_assumption: string list -> string -> Proof.context -> thm; end; structure MRBNF_Def : MRBNF_DEF = diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index 626ebe91..c8b7b25d 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -876,7 +876,7 @@ lemma permute_tusubst[equiv]: apply (rule trans) apply (rule trans[OF comp_apply[symmetric] typ.tvsubst_permutes[THEN fun_cong]]) apply (rule assms)+ - apply (metis SSupp_typ_TyVar SSupp_typ_fun_upd_le card_of_mono1 emp_bound infinite_UNIV insert_bound ordLeq_ordLess_trans) + apply (metis SSupp_typ_TyVar SSupp_typ_fun_upd_le card_of_mono1 emp_bound infinite_UNIV insert_bound_UNIV ordLeq_ordLess_trans) apply (unfold fun_upd_def comp_def) apply (rule arg_cong2[OF _ refl, of _ _ tvsubst_typ]) apply (rule ext) @@ -974,8 +974,8 @@ lemma SSupp_Var_upd_bound[simp]: "|SSupp_trm (Var(x := v::('tv::var, 'v::var) tr apply (rule cmin_greater) apply (rule card_of_Card_order)+ apply (unfold fun_upd_def SSupp_trm_def tvVVr_tvsubst_trm_def tv\_trm_tvsubst_trm_def comp_def Var_def[symmetric]) - using infinite_UNIV insert_bound apply fastforce - using infinite_UNIV insert_bound apply fastforce + using infinite_UNIV insert_bound_UNIV apply fastforce + using infinite_UNIV insert_bound_UNIV apply fastforce done lemma vvsubst_tvsubst_pat: " @@ -1109,8 +1109,8 @@ lemma SSupp_typ_TyVar_upd_bound[simp]: "|SSupp_typ ((TyVar :: _ \ (' apply (unfold fun_upd_def SSupp_typ_def tvVVr_tvsubst_typ_def tv\_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 + using infinite_UNIV insert_bound_UNIV apply fastforce + using infinite_UNIV insert_bound_UNIV apply fastforce done lemma emp_bound_cmin[simp]: "|{}| ' 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 +1279,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 +1298,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 (metis SSupp_typ_TyVar SSupp_typ_fun_upd_le card_of_Un_singl_ordLess_infinite emp_bound infinite_UNIV insert_bound_UNIV sup.orderE) apply auto [] apply (rule exI[of _ "T11"]) apply (rule exI[of _ "permute_typ (X \ Y) T12"]) diff --git a/case_studies/POPLmark/SystemFSub.thy b/case_studies/POPLmark/SystemFSub.thy index 8dc1b47b..77d338e9 100644 --- a/case_studies/POPLmark/SystemFSub.thy +++ b/case_studies/POPLmark/SystemFSub.thy @@ -250,12 +250,8 @@ lemma ty_fresh_extend: "\\<^bold>, x <: U \ S <: T \ 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,7 +264,7 @@ 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 @@ -308,8 +304,8 @@ lemma SSupp_typ_fun_upd_le: "SSupp_typ (f(X := T)) \ insert X (SSupp_t lemma SSupp_typ_fun_upd_bound[simp]: "|SSupp_typ (f(X := T))| |SSupp_typ f| ''" "IIm by (smt (verit, ccfv_threshold) CollectI IImsupp_FType_def SSupp_FType_def Un_iff) qed (auto simp: assms(1-2)) +declare [[ML_print_depth=1000]] + ML_file \../Tools/bmv_monad_def.ML\ local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ @@ -120,27 +120,34 @@ pbmv_monad "'a::var FType" apply (rule Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) done -typedef ('a1, 'a2, 'c1, 'c2) L = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" +typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" by (rule exI, rule UNIV_I) -(*pbmv_monad "('a1, 'a2, 'c1, 'c2) L" - frees: 'a1 'a2 - Sbs: "\f x. Abs_L (map_prod f (map_prod f id) (Rep_L x))" - Injs: "id :: 'a1 \ 'a1" - Vrs: "\x. case Rep_L x of (x1, x2, _) \ {x1, x2}" +declare [[ML_print_depth=1000]] +pbmv_monad "('a1, 'a2, 'c1, 'c2) L'" and 'a1 + Sbs: "\f x. Abs_L' (map_prod f (map_prod f id) (Rep_L' x))" and "id :: ('a1 \ 'a1) \ 'a1 \ 'a1" + Injs: "id :: 'a1 \ 'a1" and "id :: 'a1 \ 'a1" + Vrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1, x2}" and "\x. {x}" bd: natLeq - lives: 'c1 'c2*) + apply (rule infinite_regular_card_order_natLeq) + apply (auto simp: Abs_L'_inject Abs_L'_inverse Rep_L'_inverse prod.map_comp comp_def + id_def case_prod_beta insert_bound[OF natLeq_Cinfinite] + Cinfinite_gt_empty[OF natLeq_Cinfinite] + )[4] + apply (unfold Abs_L'_inject[OF UNIV_I UNIV_I] case_prod_beta)[1] + apply (metis (no_types, lifting) fst_map_prod insertCI prod.collapse snd_map_prod) + apply (auto simp: insert_bound[OF natLeq_Cinfinite] Cinfinite_gt_empty[OF natLeq_Cinfinite]) + done ML_file \../Tools/pbmv_monad_comp.ML\ ML \ Multithreading.parallel_proofs := 0 \ -declare [[ML_print_depth=1000]] local_setup \fn lthy => let val (bmv, (thms, lthy)) = PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I - @{typ "'a1 * 'a1 * (('a1 * 'a2) + ('a1 * 'a2 * 'a2 * 'a2 FType))"} + @{typ "'a1 * 'a1 * (('a1 * 'a2) + ('a1 * ('a2 * ('a2 * 'a2 FType))))"} ([], lthy) val _ = @{print} (map (map (map (Option.map (Thm.cterm_of lthy o @@ -250,11 +257,6 @@ typ "('a1, 'a2) L1_M1" typ "('a1, 'a2) L1_M2" typ "('a1, 'a2) L2_M2" -lemma insert_bound: "Cinfinite r \ |A| |insert x A| val id_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID") val FType_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.FType") @@ -269,6 +271,7 @@ val model_L = { frees = [@{typ "'a1"}], lives = [@{typ "'c1"}, @{typ "'c2"}], lives' = [@{typ "'c1'"}, @{typ "'c2'"}], + deads = [], bmv_ops = [BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] @@ -399,6 +402,7 @@ val model_L1 = { frees = [@{typ "'a1"}, @{typ "'a2"}], lives = [], lives' = [], + deads = [], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( @@ -481,6 +485,7 @@ val model_L2 = { frees = [@{typ 'a1}, @{typ "'a2"}], lives = [], lives' = [], + deads = [], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index c7c6b7f4..4482cfa7 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -346,7 +346,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)" diff --git a/thys/Prelim/Prelim.thy b/thys/Prelim/Prelim.thy index f15f47ce..2e61aaa2 100644 --- a/thys/Prelim/Prelim.thy +++ b/thys/Prelim/Prelim.thy @@ -509,6 +509,9 @@ 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| |B| Cinfinite r \ |A \ B| Date: Thu, 9 Jan 2025 16:07:37 +0000 Subject: [PATCH 16/90] Fix composition for types that have lives and frees --- Tools/bmv_monad_def.ML | 240 +++++++++++++++++++++++++++------------ Tools/pbmv_monad_comp.ML | 17 ++- operations/BMV_Monad.thy | 22 +++- 3 files changed, 196 insertions(+), 83 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index eee83d83..80f62ac6 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -379,39 +379,42 @@ fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = ) ops Injs Sb Vrs; in axioms end; -fun mk_param_axioms (model: 'a bmv_monad_model) lthy = @{map 5} (fn T => fn Sb => fn Injs => fn Vrs => Option.map (fn param => +fun mk_param_axiom Map Supps Sb Injs Vrs bd lthy = let + val (f_Ts, T) = split_last (binder_types (fastype_of Map)); + val (lives, lives') = split_list (map dest_funT f_Ts); + val (Cs, _) = lthy - |> mk_TFrees (length (#lives model)); + |> mk_TFrees (length lives); val ((((fs, gs), rhos), x), _) = lthy - |> mk_Frees "f" (map2 (curry (op-->)) (#lives model) (#lives' model)) - ||>> mk_Frees "g" (map2 (curry (op-->)) (#lives' model) Cs) + |> mk_Frees "f" (map2 (curry (op-->)) lives lives') + ||>> mk_Frees "g" (map2 (curry (op-->)) lives' Cs) ||>> mk_Frees "\" (map fastype_of Injs) ||>> apfst hd o mk_Frees "x" [T];; - val Map_id = Term.subst_atomic_types (#lives' model ~~ #lives model) ( + val Map_id = Term.subst_atomic_types (lives' ~~ lives) ( mk_Trueprop_eq ( - Term.list_comb (#Map param, map HOLogic.id_const (#lives model)), HOLogic.id_const T + 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 model @ #lives' model) ~~ (#lives' model @ Cs)) (#Map param), gs - ), Term.list_comb (#Map param, fs)), - Term.list_comb (Term.subst_atomic_types (#lives' model ~~ Cs) (#Map param), map2 (curry HOLogic.mk_comp) gs fs) + 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 model ~~ #lives' model) Supp $ (Term.list_comb (#Map param, fs) $ x), + Term.subst_atomic_types (lives ~~ lives') Supp $ (Term.list_comb (Map, fs) $ x), mk_image f $ (Supp $ x) )) - ) (#Supps param) fs; + ) Supps fs; val Supp_bds = map (fn Supp => Logic.all x (HOLogic.mk_Trueprop ( - mk_ordLess (mk_card_of (Supp $ x)) (#bd model) - ))) (#Supps param); + mk_ordLess (mk_card_of (Supp $ x)) bd + ))) Supps; val (gs', _) = lthy |> mk_Frees "g" (map fastype_of fs); @@ -422,23 +425,23 @@ fun mk_param_axioms (model: 'a bmv_monad_model) lthy = @{map 5} (fn T => fn Sb = HOLogic.mk_Trueprop (HOLogic.mk_mem (a, Supp $ x)), mk_Trueprop_eq (f $ a, g $ a) )) end - ) (#Supps param) fs gs') (mk_Trueprop_eq ( - Term.list_comb (#Map param, fs) $ x, - Term.list_comb (#Map param, gs') $ x + ) 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 @ rhos) ( fold_rev (curry Logic.mk_implies) (mk_small_prems rhos Injs) (mk_Trueprop_eq ( - HOLogic.mk_comp (Term.list_comb (#Map param, fs), Term.list_comb (Sb, rhos)), + HOLogic.mk_comp (Term.list_comb (Map, fs), Term.list_comb (Sb, rhos)), HOLogic.mk_comp (Term.list_comb ( - Term.subst_atomic_types (#lives model ~~ #lives' model) Sb, rhos - ), Term.list_comb (#Map param, fs)) + Term.subst_atomic_types (lives ~~ lives') Sb, rhos + ), Term.list_comb (Map, fs)) )) ); val Map_Vrs = map (map (Option.map (fn Vrs => fold_rev Logic.all (fs @ [x]) (mk_Trueprop_eq ( - Term.subst_atomic_types (#lives model ~~ #lives' model) Vrs $ (Term.list_comb (#Map param, fs) $ x), + Term.subst_atomic_types (lives ~~ lives') Vrs $ (Term.list_comb (Map, fs) $ x), Vrs $ x )) ))) Vrs; @@ -447,10 +450,10 @@ fun mk_param_axioms (model: 'a bmv_monad_model) lthy = @{map 5} (fn T => fn Sb = fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( Supp $ (Term.list_comb (Sb, rhos) $ x), Supp $ x )) - ) (#Supps param); + ) Supps; in { - Map = #Map param, - Supps = #Supps param, + Map = Map, + Supps = Supps, axioms = { Map_id = Map_id, Map_comp = Map_comp, @@ -461,8 +464,7 @@ fun mk_param_axioms (model: 'a bmv_monad_model) lthy = @{map 5} (fn T => fn Sb = Map_Sb = Map_Sb, Supp_Sb = Supp_Sb, Map_Vrs = Map_Vrs - }: term bmv_monad_param end -)) (#ops model) (#Sbs model) (#Injs model) (#Vrs model) (#params model); + }: term bmv_monad_param end; val smart_max_inline_term_size = 25; (*FUDGE*) @@ -601,7 +603,9 @@ fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let - val goals = mk_param_axioms model lthy; + val goals = @{map 4} (fn Sb => fn Vrs => fn Injs => Option.map (fn param => + mk_param_axiom (#Map param) (#Supps param) Sb Injs Vrs (#bd model) lthy + )) (#Sbs model) (#Vrs model) (#Injs model) (#params model) val tacs' = map (Option.map (morph_bmv_monad_param Morphism.identity (fn tac => fn goal => Goal.prove_sorry lthy [] [] goal (fn {context=ctxt, ...} => Local_Defs.unfold0_tac ctxt defs THEN tac ctxt @@ -734,23 +738,31 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val filter_bmvs = map_filter (fn Inl x => SOME x | _ => NONE); - val frees = fold (fn a => - let val (n, s) = dest_TFree a - in Symtab.map_default (n, s) (curry (Sign.inter_sort (Proof_Context.theory_of lthy)) s) end - ) (frees_of_bmv_monad outer @ maps frees_of_bmv_monad (filter_bmvs inners)) Symtab.empty; + fun vars_of_bmv_monad bmv = @{fold 2} (fn T => fn param => case param of + SOME param => Term.add_tfrees (#Map param) + | NONE => Term.add_tfreesT T + ) (ops_of_bmv_monad bmv) (params_of_bmv_monad bmv) []; + + fun sum_collapse (Inl x) = x + | sum_collapse (Inr x) = x + + val vars = fold (fn (n, s) => + Symtab.map_default (n, s) (curry (Sign.inter_sort (Proof_Context.theory_of lthy)) s) + ) (vars_of_bmv_monad outer @ maps ( + sum_collapse o map_sum vars_of_bmv_monad (fn T => Term.add_tfreesT T []) + ) inners) Symtab.empty; fun mk_sign_morph bmv = - morph_bmv_monad (MRBNF_Util.subst_typ_morphism (map (fn a => - let val (n, _) = dest_TFree a; - in (a, TFree (n, the (Symtab.lookup frees n))) end - ) (frees_of_bmv_monad bmv))) bmv; + morph_bmv_monad (MRBNF_Util.subst_typ_morphism (map (fn (n, s) => + (TFree (n, s), TFree (n, the (Symtab.lookup vars n))) + ) (vars_of_bmv_monad bmv))) bmv; fun mk_T_morph T = - let val vars = Term.add_tfreesT T []; - in Term.typ_subst_atomic (map (fn x => - (TFree x, the_default (TFree x) (Option.map (TFree o pair (fst x)) (Symtab.lookup frees (fst x)))) - ) vars) T end + Term.typ_subst_atomic (map (fn x => + (TFree x, the_default (TFree x) (Option.map (TFree o pair (fst x)) (Symtab.lookup vars (fst x)))) + ) (Term.add_tfreesT T [])) T val outer = mk_sign_morph outer; val inners = map (map_sum mk_sign_morph mk_T_morph) inners; + val inners' = filter_bmvs inners; val bmvs = Typtab.make_distinct (flat (map (fn bmv => (#ops bmv ~~ ((#params bmv) ~~ (#Injs bmv) ~~ (#Sbs bmv) ~~ (#Vrs bmv) ~~ map SOME (#axioms bmv) ~~ replicate (length (#Sbs bmv)) (SOME bmv)) @@ -848,6 +860,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) Injs bmvs))); fun pick xs = nth xs (leader_of_bmv_monad outer) + val ops = add_ops (the (pick outer_ops')) (the (pick Injs)) bmvs; val bmv_ops = map_filter (fn T => case Typtab.lookup bmvs T of @@ -871,8 +884,6 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val ops' = subtract (fn (bmv, T) => hd (ops_of_bmv_monad bmv) = T) bmv_ops ops; - val inners' = filter_bmvs inners; - val idxs = map (fn T => find_index (curry (op=) T) ops) ops'; val Vrs = map (the o nth Vrs) idxs; val Injs = map (the o nth Injs) idxs; @@ -1048,49 +1059,125 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = val goals = mk_bmv_monad_axioms ops bd Sbs Injs Vrs [] lthy; val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); - val lives = []; + + val names_lthy = lthy + |> fold Variable.declare_typ vars + + val (lives, lives', params) = case param_opt of + NONE => ([], [], 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 lives = the_default [] (Option.map (fn Map => + let + val Map = Term.subst_atomic_types (map (apply2 TFree) ( + Term.add_tfreesT (snd (split_last (binder_types (fastype_of Map)))) [] + ~~ Term.add_tfreesT (hd ops) [] + )) Map; + in map (fst o dest_funT) (fst (split_last (binder_types (fastype_of Map)))) end + ) (hd Maps)); + val (lives', _) = names_lthy + |> mk_TFrees' (map Type.sort_of_atyp lives); + + val Maps = map2 (fn T => Option.map (fn Map => + let + val l' = map (snd o dest_funT) (fst (split_last (binder_types (fastype_of Map)))); + val TA = snd (split_last (binder_types (fastype_of Map))); + val Map = Term.subst_atomic_types (map (apply2 TFree) ( + Term.add_tfreesT TA [] ~~ Term.add_tfreesT T [] + )) Map; + val TA = snd (split_last (binder_types (fastype_of Map))); + val TB = body_type (fastype_of Map); + val old_vars = map TFree (Term.add_tfreesT TB []); + in Term.subst_atomic_types ( + (l' ~~ lives') @ ( + subtract (op=) l' old_vars ~~ subtract (op=) lives (map TFree (Term.add_tfreesT TA [])) + ) + ) Map end + )) ops (Maps @ replicate (length ops - length Maps) NONE); + + val Suppss = map2 (fn T => Option.map (map (fn Supp => Term.subst_atomic_types (map (apply2 TFree) ( + Term.add_tfreesT (hd (binder_types (fastype_of Supp))) [] ~~ Term.add_tfreesT T [] + )) Supp))) ops (Suppss @ replicate (length ops - length Suppss) NONE); + + in (lives, lives', @{map 5} (fn Sb => fn Injs => fn Vrs => @{map_option 2} (fn Map => fn Supps => + mk_param_axiom Map Supps Sb Injs Vrs bd lthy + )) Sbs Injs Vrs Maps Suppss + ) end; fun after_qed thmss lthy = let val thms = map hd thmss; + val bd_irco = hd thms; + + val chop_many = fold_map (fold_map ( + fn NONE => (fn thms => (NONE, thms)) + | SOME _ => fn thms => (SOME (hd thms), tl thms) + )); + + val ((axioms, params), _) = apfst split_list (@{fold_map 2} (fn goal => fn param => fn thms => + let + val (((((((Sb_Inj, Sb_comp_Injs), Sb_comp), Vrs_bds), Vrs_Injs), Vrs_Sbs), Sb_cong), thms) = thms + |> apfst hd o chop 1 + ||>> chop (length (#Sb_comp_Injs goal)) + ||>> apfst hd o chop 1 + ||>> chop_many (#Vrs_bds goal) + ||>> chop_many (#Vrs_Injs goal) + ||>> chop_many (#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), Map_Vrs), thms) = thms + |> apfst hd o chop 1 + ||>> apfst hd o chop 1 + ||>> chop (length (#Supps goals)) + ||>> chop (length (#Supps goals)) + ||>> apfst hd o chop 1 + ||>> apfst hd o chop 1 + ||>> chop (length (#Supps goals)) + ||>> chop_many (#Map_Vrs goals) + in (SOME ({ + Map = #Map goals, + Supps = #Supps goals, + 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, + Map_Vrs = Map_Vrs + } : 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_Injs = Vrs_Injs, + Vrs_Sbs = Vrs_Sbs, + Sb_cong = Sb_cong + }: thm bmv_monad_axioms, param), thms) end + ) goals params (tl thms)); + val model = { ops = ops, bd = bd, var_class = @{class var}, (* TODO: change *) leader = 0, frees = frees, - lives = [], - lives' = [], + lives = lives, + lives' = lives', deads = subtract (op=) (lives @ frees) vars, bmv_ops = [], - params = replicate (length ops) NONE, + params = params, Injs = Injs, Sbs = Sbs, Vrs = Vrs, - bd_infinite_regular_card_order = hd thms, - tacs = fst (fold_map (fn goal => fn thms => - let - val chop_many = fold_map (fold_map ( - fn NONE => (fn thms => (NONE, thms)) - | SOME _ => fn thms => (SOME (hd thms), tl thms) - )); - val ((((((Sb_Inj, Sb_comp_Injs), Sb_comp), Vrs_bds), Vrs_Injs), Vrs_Sbs), thms) = thms - |> apfst hd o chop 1 - ||>> chop (length (#Sb_comp_Injs goal)) - ||>> apfst hd o chop 1 - ||>> chop_many (#Vrs_bds goal) - ||>> chop_many (#Vrs_Injs goal) - ||>> chop_many (#Vrs_Sbs goal); - in ({ - Sb_Inj = Sb_Inj, - Sb_comp_Injs = Sb_comp_Injs, - Sb_comp = Sb_comp, - Vrs_bds = Vrs_bds, - Vrs_Injs = Vrs_Injs, - Vrs_Sbs = Vrs_Sbs, - Sb_cong = hd thms - }: thm bmv_monad_axioms, thms) end - ) goals (tl thms)) + 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) model lthy; @@ -1099,10 +1186,14 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = in lthy end; in Proof.theorem NONE after_qed (map (single o rpair []) ( [HOLogic.mk_Trueprop (mk_infinite_regular_card_order bd)] - @ maps (fn goal => #Sb_Inj goal :: #Sb_comp_Injs goal @ [#Sb_comp goal] + @ flat (map2 (fn goal => fn param => #Sb_Inj goal :: #Sb_comp_Injs goal @ [#Sb_comp goal] @ maps (map_filter I) (#Vrs_bds goal @ #Vrs_Injs goal @ #Vrs_Sbs goal) - @ [#Sb_cong goal] - ) goals + @ [#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 @ maps (map_filter I) (#Map_Vrs param) + ) param) + ) goals params) )) lthy |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) end; @@ -1142,8 +1233,11 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.term || Parse.reserved "_")) )) -- Scan.optional ( - (Parse.reserved "Map" -- @{keyword ":"}) |-- Scan.repeat1 (Scan.unless (Parse.reserved "Supps") Parse.term) --| - (Parse.reserved "Supps" -- @{keyword ":"}) -- Parse.list (Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) + (Parse.reserved "Map" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.term || Parse.reserved "_") --| + (Parse.reserved "Supps" -- @{keyword ":"}) -- Parse.and_list1 ( + Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term) + || (Parse.reserved "_" >> K []) + ) >> SOME ) NONE --| (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term diff --git a/Tools/pbmv_monad_comp.ML b/Tools/pbmv_monad_comp.ML index 718ac975..a508ce0d 100644 --- a/Tools/pbmv_monad_comp.ML +++ b/Tools/pbmv_monad_comp.ML @@ -36,16 +36,25 @@ fun pbmv_monad_of_typ _ _ _ _ (TFree x) accum = (SOME (mk_id_bmv_monad x), accum rev (map TFree (Term.add_tfreesT T []) @ map TVar (Term.add_tvarsT T [])) ~~ Ts )) bmv), (accum, lthy)) end else let - (* TODO: outer with mixed/frees lives *) 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 qualifies = map qualify (1 upto length Ts); - val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy) qualifies Ts (accum, lthy) - val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) Ts bmv_opts; + val leader = BMV_Monad_Def.leader_of_bmv_monad bmv; + val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) leader; + val bmv = BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism (snd (dest_Type T) ~~ Ts) + ) bmv; + val bmv = BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.lives'_of_bmv_monad bmv ~~ BMV_Monad_Def.lives_of_bmv_monad bmv + )) bmv; + val live_Ts = BMV_Monad_Def.lives_of_bmv_monad bmv; + + val qualifies = map qualify (1 upto length live_Ts); + val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy) qualifies live_Ts (accum, lthy) + val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) live_Ts bmv_opts; in if exists Option.isSome bmv_opts then let val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) bmv bmvs lthy; in (SOME bmv, (unfold_set @ accum, lthy)) end diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 180b9608..9347144f 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -121,13 +121,15 @@ pbmv_monad "'a::var FType" done typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" - by (rule exI, rule UNIV_I) + by (rule UNIV_witness) declare [[ML_print_depth=1000]] -pbmv_monad "('a1, 'a2, 'c1, 'c2) L'" and 'a1 +pbmv_monad "('a1, 'a2, 'c1, 'c2) L'" and 'a1 Sbs: "\f x. Abs_L' (map_prod f (map_prod f id) (Rep_L' x))" and "id :: ('a1 \ 'a1) \ 'a1 \ 'a1" - Injs: "id :: 'a1 \ 'a1" and "id :: 'a1 \ 'a1" - Vrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1, x2}" and "\x. {x}" + Injs: "id :: 'a1 \ 'a1" and "id :: 'a1 \ 'a1" + Vrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1, x2}" and "\x. {x}" + Map: "\f1 f2 x. Abs_L' (map_prod id (map_prod id (map_sum f1 f2)) (Rep_L' x))" + Supps: "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setl y" "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setr y" bd: natLeq apply (rule infinite_regular_card_order_natLeq) apply (auto simp: Abs_L'_inject Abs_L'_inverse Rep_L'_inverse prod.map_comp comp_def @@ -136,9 +138,17 @@ pbmv_monad "('a1, 'a2, 'c1, 'c2) L'" and 'a1 )[4] apply (unfold Abs_L'_inject[OF UNIV_I UNIV_I] case_prod_beta)[1] apply (metis (no_types, lifting) fst_map_prod insertCI prod.collapse snd_map_prod) - apply (auto simp: insert_bound[OF natLeq_Cinfinite] Cinfinite_gt_empty[OF natLeq_Cinfinite]) + apply (auto simp: insert_bound[OF natLeq_Cinfinite] Cinfinite_gt_empty[OF natLeq_Cinfinite] + sum.map_id0 Rep_L'_inverse Abs_L'_inverse Abs_L'_inject prod.map_comp sum.map_comp comp_def + id_def[symmetric] case_prod_beta sum.set_map sum.set_bd + ) + apply (rule prod.map_cong0[OF refl])+ + apply (rule sum.map_cong0) + apply (auto elim!: snds.cases) done +print_pbmv_monads + ML_file \../Tools/pbmv_monad_comp.ML\ ML \ @@ -147,7 +157,7 @@ Multithreading.parallel_proofs := 0 local_setup \fn lthy => let val (bmv, (thms, lthy)) = PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I - @{typ "'a1 * 'a1 * (('a1 * 'a2) + ('a1 * ('a2 * ('a2 * 'a2 FType))))"} + @{typ "('a1, 'a2, 'a1 * 'a2, 'a1 * 'a2 * 'a2 * 'a2 FType) L'"} ([], lthy) val _ = @{print} (map (map (map (Option.map (Thm.cterm_of lthy o From fe1a95f4a39b36b77d0648accc8403b3039c8099 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 18 Feb 2025 10:55:22 +0000 Subject: [PATCH 17/90] Make composed Sb_cong tactic more robust --- Tools/bmv_monad_def.ML | 18 ++++++++++-------- operations/BMV_Monad.thy | 2 +- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 80f62ac6..45397803 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1006,14 +1006,16 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), REPEAT_DETERM o EVERY' [ - REPEAT_DETERM o resolve_tac ctxt prems, - rotate_tac ~1, - etac ctxt @{thm contrapos_pp}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms bex_simps(8) Un_iff UN_iff de_Morgan_disj}), - REPEAT_DETERM o etac ctxt conjE, - dtac ctxt @{thm bspec[rotated]}, - assume_tac ctxt, - assume_tac ctxt + REPEAT_DETERM o resolve_tac ctxt (take (2 * length vars) prems), + FIRST' (map (fn thm => EVERY' [ + rtac ctxt thm, + REPEAT_DETERM o FIRST' [ + rtac ctxt @{thm UnI2} THEN' etac ctxt @{thm UN_I}, + rtac ctxt @{thm UnI1} + ], + REPEAT_DETERM o etac ctxt @{thm UN_I}, + assume_tac ctxt + ]) (drop (2 * length vars) prems)) ] ]) inners), rtac ctxt (#Sb_cong axioms), diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 9347144f..5144386a 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -123,7 +123,6 @@ pbmv_monad "'a::var FType" typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" by (rule UNIV_witness) -declare [[ML_print_depth=1000]] pbmv_monad "('a1, 'a2, 'c1, 'c2) L'" and 'a1 Sbs: "\f x. Abs_L' (map_prod f (map_prod f id) (Rep_L' x))" and "id :: ('a1 \ 'a1) \ 'a1 \ 'a1" Injs: "id :: 'a1 \ 'a1" and "id :: 'a1 \ 'a1" @@ -615,3 +614,4 @@ local_setup \fn lthy => val _ = @{print} comp_bmv in lthy end \ +end From 796ed4da8f521d832870418c23b8a357b1264345 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 19 Feb 2025 10:54:20 +0000 Subject: [PATCH 18/90] Allow to blacklist positions for bmv structure --- Tools/bmv_monad_def.ML | 8 ++++---- Tools/pbmv_monad_comp.ML | 11 ++++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 45397803..5a4684e0 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -943,7 +943,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt ext, rtac ctxt (#Map_cong (#axioms param)), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps (map #Sb_comp o axioms_of_bmv_monad) inners'), + EqSubst.eqsubst_tac ctxt [0] (@{thm id_o} :: maps (map #Sb_comp o axioms_of_bmv_monad) inners'), REPEAT_DETERM o assume_tac ctxt, rtac ctxt refl ] @@ -1005,17 +1005,17 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit K (Local_Defs.unfold0_tac ctxt (#Supp_Sb param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), - REPEAT_DETERM o EVERY' [ + REPEAT_DETERM1 o EVERY' [ REPEAT_DETERM o resolve_tac ctxt (take (2 * length vars) prems), FIRST' (map (fn thm => EVERY' [ - rtac ctxt thm, + TRY o rtac ctxt thm, REPEAT_DETERM o FIRST' [ rtac ctxt @{thm UnI2} THEN' etac ctxt @{thm UN_I}, rtac ctxt @{thm UnI1} ], REPEAT_DETERM o etac ctxt @{thm UN_I}, assume_tac ctxt - ]) (drop (2 * length vars) prems)) + ]) (@{thm refl} :: drop (2 * length vars) prems)) ] ]) inners), rtac ctxt (#Sb_cong axioms), diff --git a/Tools/pbmv_monad_comp.ML b/Tools/pbmv_monad_comp.ML index a508ce0d..879f38a2 100644 --- a/Tools/pbmv_monad_comp.ML +++ b/Tools/pbmv_monad_comp.ML @@ -4,7 +4,7 @@ signature PBMV_MONAD_COMP = sig val mk_id_bmv_monad: string * sort -> BMV_Monad_Def.bmv_monad val pbmv_monad_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) - -> (binding -> binding) -> typ -> (thm list * local_theory) + -> (string * sort) list -> (binding -> binding) -> typ -> (thm list * local_theory) -> BMV_Monad_Def.bmv_monad option * (thm list * local_theory) end @@ -18,9 +18,10 @@ fun mk_id_bmv_monad free = BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism [(hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad), TFree free)] ) id_bmv_monad; -fun pbmv_monad_of_typ _ _ _ _ (TFree x) accum = (SOME (mk_id_bmv_monad x), accum) - | pbmv_monad_of_typ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" - | pbmv_monad_of_typ optim const_policy inline_policy qualify' (T as Type (n, Ts)) (accum, lthy) = +fun pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x + then (NONE, accum) else (SOME (mk_id_bmv_monad x), accum) + | pbmv_monad_of_typ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" + | pbmv_monad_of_typ optim const_policy inline_policy xs qualify' (T as Type (n, Ts)) (accum, lthy) = let val (bmv_opt, lthy) = case BMV_Monad_Def.pbmv_monad_of lthy n of SOME bmv => (SOME bmv, lthy) | NONE => case BNF_Def.bnf_of lthy n of @@ -53,7 +54,7 @@ fun pbmv_monad_of_typ _ _ _ _ (TFree x) accum = (SOME (mk_id_bmv_monad x), accum val live_Ts = BMV_Monad_Def.lives_of_bmv_monad bmv; val qualifies = map qualify (1 upto length live_Ts); - val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy) qualifies live_Ts (accum, lthy) + val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy xs) qualifies live_Ts (accum, lthy) val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) live_Ts bmv_opts; in if exists Option.isSome bmv_opts then let val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) bmv bmvs lthy; From 43203af2f967f9cc54111c2c25161a4e24ae5cc7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 19 Feb 2025 12:54:08 +0000 Subject: [PATCH 19/90] Improve printing of bmv monads --- Tools/bmv_monad_def.ML | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 5a4684e0..b03e97a9 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -263,6 +263,7 @@ structure Data = Generic_Data ( fun merge data : T = Symtab.merge (K true) data; ); +(* TODO: prefix with theory *) 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))); @@ -1202,18 +1203,27 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = fun print_pbmv_monads ctxt = let - fun pretty_mrbnf (key, BMV {ops, frees, lives, bd, Sbs, ...}) = + val and_list = Library.separate (Pretty.keyword2 " and ") + 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, bd, Sbs, ...}) = Pretty.big_list (Pretty.string_of (Pretty.block ([Pretty.str key, Pretty.str ":", Pretty.brk 1] @ - map (Pretty.quote o Syntax.pretty_typ ctxt) ops))) + 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 frees)), Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) frees)]] @ (if length lives > 0 then [Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int (length lives)), Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)]] else []) @ - [ Pretty.block ([Pretty.str "Sb:", Pretty.brk 1] @ map (Pretty.quote o Syntax.pretty_term ctxt) Sbs), - Pretty.block [Pretty.str ("bd:"), Pretty.brk 1, + [ Pretty.block ([Pretty.str "Sb:", Pretty.brk 1] @ and_list (map (Pretty.quote o Syntax.pretty_term ctxt) Sbs)) + ] @ (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)]]); in Pretty.big_list "Registered parametrized bounded multi-variate monads:" From 6f3f00b70ffbea41b99acb18085605756656adcf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 19 Feb 2025 12:55:07 +0000 Subject: [PATCH 20/90] Add initial BMV fixpoint operations theory --- operations/BMV_Fixpoint.thy | 205 ++++++++++++++++++++++++++++++++++++ 1 file changed, 205 insertions(+) create mode 100644 operations/BMV_Fixpoint.thy diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy new file mode 100644 index 00000000..47f1127e --- /dev/null +++ b/operations/BMV_Fixpoint.thy @@ -0,0 +1,205 @@ +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\\ + + '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 Xs = map dest_TFree [] + val resBs = map dest_TFree [@{typ 'tv}, @{typ 'v}, @{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}] + + fun flatten_tyargs Ass = subtract (op =) Xs (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs) @ Xs; + val qualify = Binding.prefix_name "FTerm_pre_" + val accum = (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds) + + (* Step 1: Create pre-MRBNF *) + val ((mrbnf, tys), (accum, lthy)) = MRBNF_Comp.mrbnf_of_typ true MRBNF_Def.Smart_Inline qualify flatten_tyargs Xs [] + [(dest_TFree @{typ 'tv}, MRBNF_Def.Free_Var), (dest_TFree @{typ 'v}, MRBNF_Def.Free_Var), + (dest_TFree @{typ 'btv}, MRBNF_Def.Bound_Var), (dest_TFree @{typ 'bv}, MRBNF_Def.Bound_Var) + ] @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} (accum, lthy) + + (* Step 2: Seal the pre-MRBNF with a typedef *) + val ((mrbnf, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name "FTerm_pre") true (fst tys) [] mrbnf lthy + + (* 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 = replicate 2 NONE, + T_name = "FTerm", + nrecs = 2, + permute = NONE, + pre_mrbnf = mrbnf + }] [[([], [0])], [([], [0])]] lthy + + (* Step 5: Prove BMV structure of pre-MRBNF by composition *) + val (bmv, (thms, lthy)) = apfst the (PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) + (map dest_TFree [@{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}]) + I @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} ([], lthy)) + + (* Register bmv to access theorems later *) + val lthy = BMV_Monad_Def.register_pbmv_monad "FTerm_pre'" bmv lthy; + + val notes = [ + ("bmv_defs", thms) + ] |> (map (fn (thmN, thms) => + ((Binding.name thmN, []), [(thms, [])]) + )); + + val (noted, lthy) = Local_Theory.notes notes lthy + + val _ = @{print} bmv + in lthy end\ + +ML \ +val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "FTerm_pre'") +val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv; +val laxioms = nth axioms (BMV_Monad_Def.leader_of_bmv_monad bmv) +\ + +lemma comp_assoc_middle: "(\x. f2 (f1 x) = x) \ f1 \ g1 \ f2 \ (f1 \ g2 \ f2) = f1 \ (g1 \ g2) \ f2" + by auto +lemma typedef_Rep_comp: "type_definition Rep Abs UNIV \ Rep ((Abs \ f \ Rep) x) = f (Rep x)" + unfolding comp_def type_definition.Abs_inverse[OF _ UNIV_I] .. + +(* Transfer pbmv structure of pre-datatype to sealed version *) +pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var" and "'tv::var FType" + Sbs: "\(f1::'v::var \ 'v) (f2::'tv::var \ 'tv FType). (Abs_FTerm_pre :: _ \ ('tv, 'v, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre) \ (map_sum (id f1) (map_sum id (BMV_Fixpoint.sum2.sum2.sum.Sb_0 f2) \ id) \ id) \ Rep_FTerm_pre" and "id :: ('v \ 'v) \ 'v \ 'v" and "tvsubst_FType :: ('tv::var \ 'tv FType) \ 'tv FType \ 'tv FType" + Injs: "id :: 'v::var \ 'v" "TyVar :: 'tv::var \ 'tv FType" and "id :: 'v::var \ 'v" and "TyVar :: 'tv::var \ 'tv FType" + Vrs: "\x. \x\Basic_BNFs.setl (Rep_FTerm_pre x). {x}", "\x. \x\Basic_BNFs.setr (Rep_FTerm_pre x). \ (BMV_Fixpoint.sum2.sum2.sum.Vrs_0_0_0 ` Basic_BNFs.setr x)" and "\(x::'v). {x}" and "Vrs_FType_1 :: _ \ 'tv::var set" + Map: "\(f1::'c \ 'c') (f2::'d \ 'd'). map_FTerm_pre id id id id f1 f2" + Supps: "set5_FTerm_pre :: _ \ 'c set" "set6_FTerm_pre :: _ \ 'd set" + bd: natLeq + subgoal + apply (tactic \resolve_tac @{context} [BMV_Monad_Def.bd_infinite_regular_card_order_of_bmv_monad bmv] 1\) + done + subgoal + apply (tactic \Local_Defs.unfold0_tac @{context} [#Sb_Inj laxioms]\) + apply (unfold o_id) + apply (rule ext) + apply (rule trans[OF comp_apply]) + apply (rule trans[OF Rep_FTerm_pre_inverse]) + apply (rule id_apply[symmetric]) + done + subgoal + apply (rule trans[OF comp_assoc_middle]) + apply (rule Abs_FTerm_pre_inverse[OF UNIV_I]) + apply (rule arg_cong[of _ _ "\x. _ \ x \ _"]) + apply (tactic \resolve_tac @{context} [#Sb_comp laxioms] 1\; assumption) + done + subgoal + apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_bds laxioms)) 1\) + done + subgoal + apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_bds laxioms)) 1\) + done + subgoal + apply (unfold typedef_Rep_comp[OF type_definition_FTerm_pre]) + apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_Sbs laxioms)) 1\) + apply assumption+ + done + subgoal + apply (unfold typedef_Rep_comp[OF type_definition_FTerm_pre]) + apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_Sbs laxioms)) 1\) + apply assumption+ + done + subgoal + apply (rule trans[OF comp_apply])+ + apply (rule trans[OF _ comp_apply[symmetric]])+ + apply (rule arg_cong[of _ _ Abs_FTerm_pre]) + apply (tactic \resolve_tac @{context} [#Sb_cong laxioms] 1\) + apply assumption+ + done + subgoal + apply (rule FTerm_pre.map_id0) + done + subgoal + apply (rule trans) + apply (rule FTerm_pre.map_comp0[symmetric]) + apply (rule supp_id_bound bij_id)+ + apply (unfold id_o) + apply (rule refl) + done + subgoal + apply (rule FTerm_pre.set_map) + apply (rule supp_id_bound bij_id)+ + done + subgoal + apply (rule FTerm_pre.set_map) + apply (rule supp_id_bound bij_id)+ + done + subgoal + apply (rule FTerm_pre.set_bd) + done + subgoal + apply (rule FTerm_pre.set_bd) + done + subgoal + apply (rule FTerm_pre.map_cong0) + apply (rule bij_id supp_id_bound)+ + apply (rule refl | assumption)+ + done + subgoal + apply (rule ext) + apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms map_FTerm_pre_def bmv_defs + comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply + FType.map_id0 + })\) + apply (rule refl) + done + subgoal + apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms set5_FTerm_pre_def set6_FTerm_pre_def bmv_defs + comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply + FType.map_id0 id_def[symmetric] + })\) + apply (rule refl) + done + subgoal + apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms set5_FTerm_pre_def set6_FTerm_pre_def bmv_defs + comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply + FType.map_id0 id_def[symmetric] + })\) + apply (rule refl) + done + subgoal + apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms map_FTerm_pre_def bmv_defs + comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply + FType.map_id0 sum.set_map prod.set_map image_id UN_simps(10) + })\) + apply (rule refl) + done + subgoal + apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms map_FTerm_pre_def bmv_defs + comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply + FType.map_id0 sum.set_map prod.set_map image_id UN_simps(10) + })\) + apply (rule refl) + done + (********************* BMV Structure of minions, no transfer needed *) + apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) + apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) + (* also for FType *) + apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) + apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) + done +print_pbmv_monads + +end \ No newline at end of file From bb956cc9463b2d1c1f017d487ce2cc4b074d5c05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sat, 22 Feb 2025 10:46:27 +0000 Subject: [PATCH 21/90] Obtain fixpoint substitution with recursor --- Tools/bmv_monad_def.ML | 3 +- case_studies/POPLmark/SystemFSub.thy | 3 - operations/BMV_Fixpoint.thy | 1229 +++++++++++++++++++++++++- operations/BMV_Monad.thy | 2 +- 4 files changed, 1226 insertions(+), 11 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index b03e97a9..4bd9ac80 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -263,7 +263,6 @@ structure Data = Generic_Data ( fun merge data : T = Symtab.merge (K true) data; ); -(* TODO: prefix with theory *) 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))); @@ -1203,7 +1202,7 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = fun print_pbmv_monads ctxt = let - val and_list = Library.separate (Pretty.keyword2 " and ") + 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) diff --git a/case_studies/POPLmark/SystemFSub.thy b/case_studies/POPLmark/SystemFSub.thy index 77d338e9..f2f63e64 100644 --- a/case_studies/POPLmark/SystemFSub.thy +++ b/case_studies/POPLmark/SystemFSub.thy @@ -247,9 +247,6 @@ 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] - lemmas [equiv] = wf_eqvt[unfolded map_context_def] lfin_equiv closed_in_eqvt[unfolded map_context_def] in_context_eqvt[unfolded map_context_def] diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 47f1127e..b9cbacad 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -33,7 +33,7 @@ local_setup \fn lthy => (* Step 4: Construct the binder fixpoint *) val (fp_res, lthy) = MRBNF_FP.construct_binder_fp BNF_Util.Least_FP [{ - FVars = replicate 2 NONE, + FVars = [SOME "FTVars", SOME "FVars"], T_name = "FTerm", nrecs = 2, permute = NONE, @@ -46,7 +46,7 @@ local_setup \fn lthy => I @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} ([], lthy)) (* Register bmv to access theorems later *) - val lthy = BMV_Monad_Def.register_pbmv_monad "FTerm_pre'" bmv lthy; + val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Fixpoint.FTerm_pre'" bmv lthy; val notes = [ ("bmv_defs", thms) @@ -60,7 +60,7 @@ local_setup \fn lthy => in lthy end\ ML \ -val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "FTerm_pre'") +val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre'") val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv; val laxioms = nth axioms (BMV_Monad_Def.leader_of_bmv_monad bmv) \ @@ -70,14 +70,19 @@ lemma comp_assoc_middle: "(\x. f2 (f1 x) = x) \ f1 \ lemma typedef_Rep_comp: "type_definition Rep Abs UNIV \ Rep ((Abs \ f \ Rep) x) = f (Rep x)" unfolding comp_def type_definition.Abs_inverse[OF _ UNIV_I] .. +definition "Sb_FTerm_pre \ \(f1::'v::var \ 'v) (f2::'tv::var \ 'tv FType). (Abs_FTerm_pre :: _ \ ('tv, 'v, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre) \ (map_sum (id f1) (map_sum id (BMV_Fixpoint.sum2.sum2.sum.Sb_0 f2) \ id) \ id) \ Rep_FTerm_pre" +definition "Vrs1_FTerm_pre \ \x. \x\Basic_BNFs.setl (Rep_FTerm_pre x). {x}" +definition "Vrs2_FTerm_pre \ \x. \x\Basic_BNFs.setr (Rep_FTerm_pre x). \ (BMV_Fixpoint.sum2.sum2.sum.Vrs_0_0_0 ` Basic_BNFs.setr x)" + (* Transfer pbmv structure of pre-datatype to sealed version *) pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var" and "'tv::var FType" - Sbs: "\(f1::'v::var \ 'v) (f2::'tv::var \ 'tv FType). (Abs_FTerm_pre :: _ \ ('tv, 'v, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre) \ (map_sum (id f1) (map_sum id (BMV_Fixpoint.sum2.sum2.sum.Sb_0 f2) \ id) \ id) \ Rep_FTerm_pre" and "id :: ('v \ 'v) \ 'v \ 'v" and "tvsubst_FType :: ('tv::var \ 'tv FType) \ 'tv FType \ 'tv FType" + Sbs: "Sb_FTerm_pre :: _ \ _ \ _ \ ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "id :: ('v \ 'v) \ 'v \ 'v" and "tvsubst_FType :: ('tv::var \ 'tv FType) \ 'tv FType \ 'tv FType" Injs: "id :: 'v::var \ 'v" "TyVar :: 'tv::var \ 'tv FType" and "id :: 'v::var \ 'v" and "TyVar :: 'tv::var \ 'tv FType" - Vrs: "\x. \x\Basic_BNFs.setl (Rep_FTerm_pre x). {x}", "\x. \x\Basic_BNFs.setr (Rep_FTerm_pre x). \ (BMV_Fixpoint.sum2.sum2.sum.Vrs_0_0_0 ` Basic_BNFs.setr x)" and "\(x::'v). {x}" and "Vrs_FType_1 :: _ \ 'tv::var set" + Vrs: "Vrs1_FTerm_pre :: ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre \ _", "Vrs2_FTerm_pre :: ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre \ _" and "\(x::'v). {x}" and "Vrs_FType_1 :: _ \ 'tv::var set" Map: "\(f1::'c \ 'c') (f2::'d \ 'd'). map_FTerm_pre id id id id f1 f2" Supps: "set5_FTerm_pre :: _ \ 'c set" "set6_FTerm_pre :: _ \ 'd set" bd: natLeq + apply (unfold Sb_FTerm_pre_def Vrs1_FTerm_pre_def Vrs2_FTerm_pre_def) subgoal apply (tactic \resolve_tac @{context} [BMV_Monad_Def.bd_infinite_regular_card_order_of_bmv_monad bmv] 1\) done @@ -202,4 +207,1218 @@ pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v: done print_pbmv_monads +lemma set1_Vrs: "set1_FTerm_pre x = Vrs2_FTerm_pre x" + apply (unfold set1_FTerm_pre_def Vrs2_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left + prod.set_map Un_empty_right comp_def bmv_defs + ) + apply (rule refl) + done +lemma set2_Vrs: "set2_FTerm_pre x = Vrs1_FTerm_pre x" + apply (unfold set2_FTerm_pre_def Vrs1_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left + prod.set_map Un_empty_right comp_def bmv_defs + ) + apply (rule refl) + done +lemma set3_Sb: "set3_FTerm_pre (Sb_FTerm_pre f1 f2 x) = set3_FTerm_pre x" + apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set3_FTerm_pre_def + prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right + Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) + ) + apply (rule refl) + done +lemma set4_Sb: "set4_FTerm_pre (Sb_FTerm_pre f1 f2 x) = set4_FTerm_pre x" + apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set4_FTerm_pre_def + prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right + Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) + ) + apply (rule refl) + done + +lemma permute_Sb_FType: + fixes f::"'tv::var \ 'tv" + assumes "bij f" "|supp f| g \ inv f) = permute_FType f \ Sb_FType g \ permute_FType (inv f)" + apply (rule ext) + apply (rule trans[OF _ comp_apply[symmetric]]) + subgoal for x + apply (subgoal_tac "|SSupp_FType (permute_FType f \ g \ inv f)| g \ inv f)" rule: FType.strong_induct) + apply (unfold IImsupp_FType_def)[1] + apply (rule FType.Un_bound) + apply (subst FType.SSupp_natural) + apply (rule assms)+ + apply (rule ordLeq_ordLess_trans[OF card_of_image]) + apply (rule assms) + apply (rule FType.UN_bound) + apply (subst FType.SSupp_natural) + apply (rule assms)+ + apply (rule ordLeq_ordLess_trans[OF card_of_image]) + apply (rule assms) + apply (unfold comp_def)[1] + apply (rule FType.set_bd_UNIV) + + apply (rule trans) + apply (rule FType.subst) + apply assumption + apply (unfold comp_def)[1] + apply (rule arg_cong[of _ _ "permute_FType _"]) + apply (rule sym) + apply (rule trans) + apply (subst FType.permute) + apply (rule assms bij_imp_bij_inv supp_inv_bound)+ + apply (rule FType.subst) + apply (rule assms) + apply (rule refl) + + apply (rule trans) + apply (rule FType.subst) + apply assumption + apply (subst FType.permute) + apply (rule assms bij_imp_bij_inv supp_inv_bound)+ + apply (unfold comp_def)[1] + apply (subst FType.subst) + apply (rule assms) + apply (subst FType.permute) + apply (rule assms)+ + apply (rule arg_cong2[of _ _ _ _ TyApp]) + apply assumption+ + + apply (rule trans) + apply (rule FType.subst) + apply assumption+ + apply (subst FType.permute) + apply (rule assms bij_imp_bij_inv supp_inv_bound)+ + apply (rule trans[OF _ comp_apply[symmetric]]) + apply (subst FType.subst) + apply (rule assms) + apply (subst (asm) FType.IImsupp_natural) + apply (rule assms)+ + apply (subst (asm) image_in_bij_eq) + apply (rule assms) + apply assumption + apply (subst FType.permute) + apply (rule assms)+ + apply (subst inv_simp2[of f]) + apply (rule assms) + apply (rule arg_cong2[of _ _ _ _ TyAll]) + apply (rule refl) + apply (unfold comp_def) + apply assumption + done + done + +lemma Map_Sb': + fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" + assumes "bij f1" "|supp f1| Inj_FType_1 a}| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre (f2 \ g1 \ inv f2) (permute_FType f1 \ g2 \ inv f1) \ map_FTerm_pre f1 f2 f3 f4 f5 f6" + apply (rule ext) + apply (subgoal_tac "|SSupp_FType g2| _FType_tvsubst_FType_def comp_def TyVar_def[symmetric])[1] + apply (rule assms) + apply (tactic \Local_Defs.unfold0_tac @{context} @{thms + comp_apply map_FTerm_pre_def bmv_defs Sb_FTerm_pre_def Abs_FTerm_pre_inverse[OF UNIV_I] o_id id_apply + sum.map_comp prod.map_comp + }\) + apply (subst permute_Sb_FType, (rule assms | assumption)+)+ + apply (unfold comp_def) + apply (unfold sum.map_comp id_apply prod.map_comp comp_def) + apply (subst inv_simp1, rule assms)+ + apply (subst FType.vvsubst_permute FType.permute_comp inv_o_simp1, (rule assms bij_imp_bij_inv supp_inv_bound)+)+ + apply (unfold FType.permute_id) + apply (rule refl) + done + +ML \ +val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre") +val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv +val laxioms = hd axioms +val param = the (hd (BMV_Monad_Def.params_of_bmv_monad bmv)) +\ + +(* Substitution axioms *) +abbreviation \ :: "'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre" where + "\ a \ Abs_FTerm_pre (Inl a)" + +lemma eta_free: "set2_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 + ) + 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 + +(* Construction of substitution *) +type_synonym ('tv, 'v) P = "('v \ ('tv, 'v) FTerm) \ ('tv \ 'tv FType)" + +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)" + +definition SSupp_FTerm :: "('v \ ('tv::var, 'v::var) FTerm) \ 'v set" where + "SSupp_FTerm f \ { a. f a \ VVr a }" +definition IImsupp_FTerm1 :: "('v \ ('tv::var, 'v::var) FTerm) \ 'tv set" where + "IImsupp_FTerm1 f \ \(FTVars ` f ` SSupp_FTerm f)" +definition IImsupp_FTerm2 :: "('v \ ('tv::var, 'v::var) FTerm) \ 'v set" where + "IImsupp_FTerm2 f \ SSupp_FTerm f \ \(FVars ` f ` SSupp_FTerm f)" + +definition Uctor :: "('tv::var, 'v::var, 'tv, 'v, ('tv, 'v) FTerm \ (('tv, 'v) P \ ('tv, 'v) FTerm), ('tv, 'v) FTerm \ (('tv, 'v) P \ ('tv, 'v) FTerm)) FTerm_pre + \ ('tv, 'v) P \ ('tv, 'v) FTerm" where + "Uctor y p \ case p of (f1, f2) \ 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 ((\R. R (f1, f2)) \ snd) ((\R. R (f1, f2)) \ snd) y))" + +definition PFVars_1 :: "('tv::var, 'v::var) P \ 'tv set" where + "PFVars_1 p \ case p of (f1, f2) \ IImsupp_FTerm1 f1 \ IImsupp_FType f2" +definition PFVars_2 :: "('tv::var, 'v::var) P \ 'v set" where + "PFVars_2 p \ case p of (f1, _) \ IImsupp_FTerm2 f1" + +definition compSS_FType :: "('tv \ 'tv) \ ('tv \ 'tv::var FType) \ 'tv \ 'tv FType" where + "compSS_FType g f \ permute_FType g \ f \ inv g" +definition compSS_FTerm :: "('tv \ 'tv) \ ('v \ 'v) \ ('v \ ('tv::var, 'v::var) FTerm) \ 'v \ ('tv, 'v) FTerm" where + "compSS_FTerm g1 g2 f \ permute_FTerm g1 g2 \ f \ inv g2" +definition Pmap :: "('tv \ 'tv) \ ('v \ 'v) \ ('tv::var, 'v::var) P \ ('tv, 'v) P" where + "Pmap g1 g2 p \ case p of (f1, f2) \ (compSS_FTerm g1 g2 f1, compSS_FType g1 f2)" +lemmas compSS_defs = compSS_FType_def compSS_FTerm_def + +definition valid_P :: "('tv::var, 'v::var) P \ bool" where + "valid_P p \ case p of (f1, f2) \ + |SSupp_FTerm f1| |SSupp_FType f2| +val Map_Sb' = Local_Defs.unfold0 @{context} @{thms comp_apply} (#Map_Sb param RS fun_cong) RS sym +val Vrs_Sb = maps (map_filter I) (#Vrs_Sbs laxioms); +val Vrs_Injs = maps (maps (map_filter I) o #Vrs_Injs) axioms; +\ + +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| 'tyvar" and f2 g2::"'var::var \ 'var" + assumes g_prems: "bij g1" "|supp g1| compSS_FTerm g1 g2 = compSS_FTerm (f1 \ g1) (f2 \ g2)" + apply (unfold compSS_FTerm_def) + apply (subst o_inv_distrib FTerm.permute_comp0[symmetric], (rule supp_id_bound bij_id assms ordLess_ordLeq_trans cmin2 cmin1 card_of_Card_order)+)+ + apply (rule ext) + apply (rule trans[OF comp_apply]) + apply (unfold comp_assoc) + apply (rule refl) + done +lemmas compSS_comp0s = FType.compSS_comp0[unfolded tvcompSS_tvsubst_FType_def compSS_FType_def[symmetric]] compSS_comp0_FTerm + +lemma IImsupp_VVrs: "f2 a \ a \ imsupp f2 \ IImsupp_FTerm2 y = {} \ y a = VVr a" + apply (unfold imsupp_def supp_def IImsupp_FTerm2_def SSupp_FTerm_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 IImsupp_FTerm1_def SSupp_FTerm_def)[1] + apply (rule subsetI) + apply (rule UnI2)? + apply (rule UN_I[rotated]) + apply assumption + apply (rule imageI) + 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_FTerm2_def SSupp_FTerm_def)[1] + apply (rule subsetI) + apply (rule UnI2)? + apply (rule UN_I[rotated]) + apply assumption + apply (rule imageI) + 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 + +lemma compSS_cong_id_FTerm: + fixes f1 g1::"'tyvar::var \ 'tyvar" and f2 g2::"'var::var \ 'var" + assumes g_prems: "bij g1" "|supp g1| a. a \ IImsupp_FTerm1 h \ f1 a = a) \ (\a. a \ IImsupp_FTerm2 h \ f2 a = a) \ compSS_FTerm f1 f2 h = h" + apply (unfold compSS_FTerm_def) + subgoal premises prems + apply (subst IImsupp_permute_commute) + apply (rule assms cmin1 cmin2 card_of_Card_order ordLess_ordLeq_trans)+ + (* REPEAT_DETERM *) + apply (rule trans[OF Int_commute]) + apply (rule disjointI) + apply (drule prems) + apply (erule bij_id_imsupp[rotated]) + apply (rule assms) + (* repeated *) + apply (rule trans[OF Int_commute]) + apply (rule disjointI) + apply (drule prems) + apply (erule bij_id_imsupp[rotated]) + apply (rule assms) + (* END REPEAT_DETERM *) + apply (unfold comp_assoc) + apply (subst inv_o_simp2) + apply (rule assms) + apply (rule o_id) + done + done +lemmas compSS_cong_ids = FType.compSS_cong_id[unfolded tvcompSS_tvsubst_FType_def compSS_FType_def[symmetric]] compSS_cong_id_FTerm + +lemma SSupp_natural_FTerm: + fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" + assumes f_prems: "bij f1" "|supp f1| y \ inv f2) = f2 ` SSupp_FTerm y" + apply (unfold SSupp_FTerm_def) + apply (rule set_eqI) + apply (rule iffI) + apply (unfold mem_Collect_eq comp_def VVr_def image_Collect) + apply (erule contrapos_np) + apply (drule Meson.not_exD) + apply (erule allE) + apply (drule iffD1[OF de_Morgan_conj]) + apply (erule disjE) + apply (subst (asm) inv_simp2[of f2]) + apply (rule assms) + apply (erule notE) + apply (rule refl) + apply (drule notnotD) + apply (drule sym) + apply (erule subst) + apply (rule trans) + apply (rule FTerm.permute_ctor) + apply (rule assms)+ + apply (subst fun_cong[OF eta_natural, unfolded comp_def]) + apply (rule assms)+ + apply (subst inv_simp2[of f2]) + apply (rule f_prems) + apply (rule refl) + apply (erule exE) + apply (erule conjE) + apply hypsubst + apply (subst inv_simp1) + apply (rule f_prems) + apply (erule contrapos_nn) + apply (drule arg_cong[of _ _ "permute_FTerm (inv f1) (inv f2)"]) + apply (subst (asm) FTerm.permute_comp) + apply (rule assms supp_inv_bound bij_imp_bij_inv)+ + apply (subst (asm) inv_o_simp1, rule assms)+ + apply (unfold FTerm.permute_id) + apply (erule trans) + apply (rule trans) + apply (rule FTerm.permute_ctor) + apply (rule assms supp_inv_bound bij_imp_bij_inv)+ + apply (subst fun_cong[OF eta_natural, unfolded comp_def]) + apply (rule assms supp_inv_bound bij_imp_bij_inv)+ + apply (subst inv_simp1) + apply (rule assms) + apply (rule refl) + done +lemmas SSupp_naturals = FType.SSupp_natural SSupp_natural_FTerm + +lemma IImsupp_natural_FTerm: + fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" + assumes f_prems: "bij f1" "|supp f1| y \ inv f2) = f1 ` IImsupp_FTerm1 y" + "IImsupp_FTerm2 (permute_FTerm f1 f2 \ y \ inv f2) = f2 ` IImsupp_FTerm2 y" + apply (unfold IImsupp_FTerm1_def IImsupp_FTerm2_def image_UN image_Un) + apply (rule arg_cong2[of _ _ _ _ "(\)"])? + apply (subst SSupp_naturals) + apply (rule assms)+ + apply (unfold image_comp comp_assoc)[1] + apply (subst inv_o_simp1, rule assms) + apply (unfold o_id) + apply (unfold comp_def)[1] + apply (subst FTerm.FVars_permute, (rule assms)+) + apply (rule refl) + (* repeated *) + apply (rule arg_cong2[of _ _ _ _ "(\)"])? + apply (subst SSupp_naturals) + apply (rule assms)+ + apply (rule refl) + (* repeated *) + apply (rule arg_cong2[of _ _ _ _ "(\)"])? + apply (subst SSupp_naturals) + apply (rule assms)+ + apply (unfold image_comp comp_assoc)[1] + apply (subst inv_o_simp1, rule assms) + apply (unfold o_id) + apply (unfold comp_def)[1] + apply (subst FTerm.FVars_permute, (rule assms)+) + apply (rule refl) + done +lemmas IImsupp_naturals = FType.IImsupp_natural IImsupp_natural_FTerm + +(* Recursor axioms *) +lemma Pmap_id0: "Pmap id id = id" + apply (rule ext) + apply (unfold Pmap_def case_prod_beta compSS_id0s) + apply (unfold id_def prod.collapse) + apply (rule refl) + done + +lemma Pmap_comp0: + fixes f1 g1::"'tyvar::var \ 'tyvar" and f2 g2::"'var::var \ 'var" + assumes g_prems: "bij g1" "|supp g1| Pmap g1 g2 = Pmap (f1 \ g1) (f2 \ g2)" + apply (rule ext) + apply (unfold Pmap_def case_prod_beta) + apply (rule trans[OF comp_apply]) + apply (unfold prod.inject fst_conv snd_conv) + apply (rule conjI bij_id supp_id_bound assms ordLess_ordLeq_trans cmin1 card_of_Card_order + trans[OF comp_apply[symmetric] fun_cong[OF compSS_comp0s(1)]] + trans[OF comp_apply[symmetric] fun_cong[OF compSS_comp0s(2)]] + )+ + done + +lemma valid_Pmap: + fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" + assumes f_prems: "bij f1" "|supp f1| valid_P (Pmap f1 f2 p)" + apply (unfold valid_P_def Pmap_def case_prod_beta compSS_defs fst_conv snd_conv) + apply (erule conj_forward)+ + apply (subst SSupp_naturals; (assumption | rule assms cmin1 cmin2 card_of_Card_order ordLeq_ordLess_trans[OF card_of_image] ordLess_ordLeq_trans)+)+ + done + +lemma PFVars_Pmaps: + fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" + assumes f_prems: "bij f1" "|supp f1| 'tyvar" and f2::"'var::var \ 'var" + assumes f_prems: "bij f1" "|supp f1| a. a \ PFVars_1 p \ f1 a = a) \ (\a. a \ PFVars_2 p \ f2 a = a) \ Pmap f1 f2 p = p" + apply (unfold PFVars_1_def PFVars_2_def Pmap_def case_prod_beta) + subgoal premises prems + apply (subst compSS_cong_ids, (rule f_prems prems cmin1 cmin2 card_of_Card_order ordLess_ordLeq_trans | erule UnI2 UnI1 | rule UnI1)+)+ + apply assumption + apply (unfold prod.collapse) + apply (rule refl) + done + done + +lemmas Cinfinite_UNIV = conjI[OF FTerm_pre.UNIV_cinfinite card_of_Card_order] +lemmas Cinfinite_card = cmin_Cinfinite[OF Cinfinite_UNIV Cinfinite_UNIV] +lemmas regularCard_card = cmin_regularCard[OF FTerm_pre.var_regular FTerm_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 small_PFVarss: + "valid_P p \ |PFVars_1 (p::('tyvar::var, 'var::var) P)| |PFVars_2 p| set3_FTerm_pre y \ PFVars_1 p = {} \ + (\t pu p. valid_P p \ (t, pu) \ set5_FTerm_pre y \ set6_FTerm_pre y \ FTVars (pu p) \ FTVars t \ PFVars_1 p) \ + FTVars (Uctor y p) \ FTVars (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) \ PFVars_1 p" + subgoal premises prems + apply (unfold Uctor_def case_prod_beta) + 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 PFVars_1_def case_prod_beta IImsupp_FTerm1_def SSupp_FTerm_def image_comp[unfolded 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 (subgoal_tac "|{ a. id a \ id a }| TyVar a }| _FType_tvsubst_FType_def TyVar_def[symmetric] comp_def)[1] + apply (erule conjE) + apply (erule ordLess_ordLeq_trans) + apply (rule cmin1) + apply (rule card_of_Card_order)+ + + apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) + apply assumption + apply assumption + apply (unfold FTerm.FVars_ctor) + apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ + apply (unfold image_id image_comp comp_def prod.collapse) + apply (rule Un_mono')+ + apply (unfold set3_Sb set4_Sb set1_Vrs set2_Vrs) + apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) + apply assumption+ + apply (unfold PFVars_1_def case_prod_beta IImsupp_FType_def SSupp_FType_def + tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric] comp_def + )[1] + apply (rule subsetI) + apply (erule UN_E) + apply (rule case_split[of "_ = _", rotated]) + apply (rule UnI2)+ + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply assumption + apply (rule UnI1) + apply (rotate_tac -2) + apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) + apply (erule arg_cong) + apply (tactic \Local_Defs.unfold0_tac @{context} Vrs_Injs\) + 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 (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* repeated *) + apply (rule subset_If) + apply (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* END REPEAT_DETERM *) + done + done + +lemma FVars_subset: "valid_P p \ set4_FTerm_pre y \ PFVars_2 p = {} \ + (\t pu p. valid_P p \ (t, pu) \ set5_FTerm_pre y \ set6_FTerm_pre y \ FVars (pu p) \ FVars t \ PFVars_2 p) \ + FVars (Uctor y p) \ FVars (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) \ PFVars_2 p" + subgoal premises prems + apply (unfold Uctor_def case_prod_beta) + 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 PFVars_2_def case_prod_beta IImsupp_FTerm2_def SSupp_FTerm_def image_comp[unfolded comp_def])[1] + apply (rule UnI2) + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply assumption + apply (unfold if_not_P) + apply (erule thin_rl) + + apply (subgoal_tac "|{ a. id a \ id a }| TyVar a }| _FType_tvsubst_FType_def TyVar_def[symmetric] comp_def)[1] + apply (erule conjE) + apply (erule ordLess_ordLeq_trans) + apply (rule cmin1) + apply (rule card_of_Card_order)+ + + apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) + apply assumption + apply assumption + apply (unfold FTerm.FVars_ctor) + apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ + apply (unfold image_id image_comp comp_def prod.collapse) + apply (rule Un_mono')+ + apply (unfold set3_Sb set4_Sb set1_Vrs set2_Vrs) + apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) + apply assumption+ + apply (unfold PFVars_2_def case_prod_beta IImsupp_FTerm2_def SSupp_FType_def + tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric] comp_def + )[1] + apply (rule subsetI) + apply (erule UN_E) + apply (rule UnI1) + apply (tactic \Local_Defs.unfold0_tac @{context} Vrs_Injs\) + 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 (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* repeated *) + apply (rule subset_If) + apply (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) + apply (unfold UN_empty')[1] + apply (rule empty_subsetI) + apply (rule UN_mono[OF subset_refl]) + apply (rule prems) + apply (rule prems) + apply (unfold prod.collapse) + apply (erule UnI2 UnI1) + (* END REPEAT_DETERM *) + done + done + +lemma permute_Uctor: + fixes f1::"'tv::var \ 'tv" and f2::"'v::var \ 'v" + shows "valid_P p \ bij f1 \ |supp f1| bij f2 \ |supp f2| permute_FTerm f1 f2 (Uctor y p) = Uctor (map_FTerm_pre f1 f2 f1 f2 + (\(t, pu). (permute_FTerm f1 f2 t, \p. if valid_P p then permute_FTerm f1 f2 (pu (Pmap (inv f1) (inv f2) p)) else undefined)) + (\(t, pu). (permute_FTerm f1 f2 t, \p. if valid_P p then permute_FTerm f1 f2 (pu (Pmap (inv f1) (inv f2) p)) else undefined)) + y) (Pmap f1 f2 p)" + apply (unfold Uctor_def) + apply (subst FTerm_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] fst_o_f comp_assoc comp_def[of snd] snd_conv case_prod_beta prod.collapse) + apply (subst FTerm_pre.map_comp[symmetric], (assumption | rule supp_id_bound bij_id ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ + apply (subst FTerm.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 (erule subst[OF sym]) + apply (subst permute_VVr) + apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + apply (unfold Pmap_def case_prod_beta fst_conv snd_conv asVVr_VVr compSS_FTerm_def comp_def)[1] + apply (subst inv_simp1) + apply assumption + apply (rule refl) + + apply (rule trans) + apply (rule FTerm.permute_ctor) + apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + + apply (subgoal_tac "|{ a. id a \ id a }| TyVar a }| _FType_tvsubst_FType_def TyVar_def[symmetric] comp_def)[1] + apply (erule conjE) + apply (erule ordLess_ordLeq_trans) + apply (rule cmin1) + apply (rule card_of_Card_order)+ + + apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) + apply assumption + apply assumption + + apply (subst FTerm_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 (subst if_P inv_o_simp1 trans[OF comp_apply[symmetric] Pmap_comp0[THEN fun_cong]], (rule valid_Pmap bij_imp_bij_inv supp_inv_bound | assumption)+)+ + apply (unfold trans[OF Pmap_id0[THEN fun_cong] id_apply]) + apply (unfold Pmap_def case_prod_beta snd_conv compSS_FType_def) + apply (subst trans[OF comp_apply[symmetric] Map_Sb'[THEN fun_cong]]) + apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + apply (unfold id_o o_id inv_o_simp2) + apply (unfold comp_def) + apply (rule refl) + done + +ML \ +val nvars: int = 2 + +val parameters = { + P = @{typ "('tv::var, 'v::var) P"}, + Pmap = @{term "Pmap :: _ \ _ \ _ \ ('tv::var, 'v::var) P"}, + PFVarss = [ + @{term "PFVars_1 :: ('tv::var, 'v::var) P \ _"}, + @{term "PFVars_2 :: ('tv::var, 'v::var) P \ _"} + ], + avoiding_sets = [@{term "{} :: 'tv::var set"}, @{term "{} :: 'v::var set"}], + min_bound = true, + validity = SOME { + pred = @{term "valid_P :: ('tv::var, 'v::var) P \ _"}, + valid_Pmap = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms valid_Pmap} THEN_ALL_NEW assume_tac ctxt) + }, + axioms = { + Pmap_id0 = fn ctxt => EVERY1 [ + resolve_tac ctxt [trans], + resolve_tac ctxt @{thms fun_cong[OF Pmap_id0]}, + resolve_tac ctxt @{thms id_apply} + ], + Pmap_comp0 = fn ctxt => resolve_tac ctxt @{thms fun_cong[OF Pmap_comp0[symmetric]]} 1 THEN REPEAT_DETERM (assume_tac ctxt 1), + Pmap_cong_id = fn ctxt => resolve_tac ctxt @{thms Pmap_cong_id} 1 THEN REPEAT_DETERM (assume_tac ctxt 1 ORELSE Goal.assume_rule_tac ctxt 1), + PFVars_Pmaps = replicate nvars (fn ctxt => resolve_tac ctxt @{thms PFVars_Pmaps} 1 THEN REPEAT_DETERM (assume_tac ctxt 1)), + small_PFVarss = replicate nvars (fn ctxt => resolve_tac ctxt @{thms small_PFVarss} 1 THEN assume_tac ctxt 1), + small_avoiding_sets = replicate nvars (fn ctxt => HEADGOAL (resolve_tac ctxt @{thms cmin_greater} + THEN_ALL_NEW resolve_tac ctxt @{thms card_of_Card_order emp_bound})) + } +} : (Proof.context -> tactic) MRBNF_Recursor.parameter; +\ + +ML \ +val fp_res = the (MRBNF_FP_Def_Sugar.fp_result_of @{context} "BMV_Fixpoint.FTerm") +val quot = hd (#quotient_fps fp_res); +val vars = map TVar (rev (Term.add_tvarsT (#T quot) [])); +\ + +ML \ +val model = MRBNF_Recursor.mk_quotient_model quot (vars ~~ [@{typ "'tv::var"}, @{typ "'v::var"}]) { + binding = @{binding "tvsubst_FTerm"}, + Uctor = @{term "Uctor :: _ \ ('tv::var, 'v::var) P \ _"}, + validity = NONE, + axioms = { + FVars_subsets = [ + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Un_empty_right}), + resolve_tac ctxt @{thms FTVars_subset}, + REPEAT_DETERM o assume_tac ctxt, + Goal.assume_rule_tac ctxt + ], + fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms Un_empty_right}), + resolve_tac ctxt @{thms FVars_subset}, + REPEAT_DETERM o assume_tac ctxt, + Goal.assume_rule_tac ctxt + ] + ], + permute_Uctor = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms permute_Uctor} THEN_ALL_NEW assume_tac ctxt) + } +} +\ + +local_setup \fn lthy => +let + val qualify = I + val (ress, lthy) = MRBNF_Recursor.create_binding_recursor qualify fp_res parameters [model] lthy + + val notes = + [ ("rec_Uctor", map (Local_Defs.unfold0 lthy @{thms Un_empty_right} o #rec_Uctor) ress) + ] |> (map (fn (thmN, thms) => + ((Binding.qualify true "FTerm" (Binding.name thmN), []), [(thms, [])]) + )); + val (_, lthy) = Local_Theory.notes notes lthy + val _ = @{print} ress +in lthy end +\ +print_theorems + +definition tvsubst_FTerm :: "('v \ ('tv::var, 'v::var) FTerm) \ ('tv \ 'tv FType) \ ('tv, 'v) FTerm \ ('tv, 'v) FTerm" where + "tvsubst_FTerm f1 f2 t \ ff0_tvsubst_FTerm t (f1, f2)" + +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 tvsubst_VVr: + assumes + "|SSupp_FTerm f1| (IImsupp_FTerm1 f1 \ IImsupp_FType f2) = {}" "set4_FTerm_pre x \ IImsupp_FTerm2 f1 = {}" + and noclash: "noclash_FTerm x" + and VVr_prems: "\isVVr (FTerm_ctor x)" + shows + "tvsubst_FTerm f1 f2 (FTerm_ctor x) = FTerm_ctor (Sb_FTerm_pre id f2 (map_FTerm_pre id id id id (tvsubst_FTerm f1 f2) (tvsubst_FTerm f1 f2) x))" + apply (unfold tvsubst_FTerm_def) + apply (subgoal_tac "valid_P (f1, f2)") + prefer 2 + apply (unfold valid_P_def prod.case)[1] + apply (rule conjI f_prems)+ + apply (rule trans) + apply (rule FTerm.rec_Uctor) + apply assumption + apply (unfold PFVars_1_def PFVars_2_def prod.case) + apply (rule empty_prems noclash)+ + apply (unfold Uctor_def prod.case) + 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) + apply (subst if_not_P, rule VVr_prems)+ + apply (unfold comp_def snd_conv if_P) + apply (rule refl) + done + +(* Sugar theorems for substitution *) +definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where + "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl a))" +definition App :: "('tv, 'v) FTerm \ ('tv, 'v) FTerm \ ('tv::var, 'v::var) FTerm" where + "App t1 t2 \ FTerm_ctor (Abs_FTerm_pre (Inr (Inl (t1, t2))))" +definition TyApp :: "('tv, 'v) FTerm \ 'tv FType \ ('tv::var, 'v::var) FTerm" where + "TyApp t T \ FTerm_ctor (Abs_FTerm_pre (Inr (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 (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 (Inr (a, t))))))" + +lemma FTerm_subst: + fixes f1::"'v \ ('tv::var, 'v::var) FTerm" and f2::"'tv \ 'tv FType" + assumes "|SSupp_FTerm 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 \ IImsupp_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_FTerm_no_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 + )[1] + apply (rule refl) + + apply (rule trans) + apply (rule tvsubst_FTerm_no_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_FTerm_no_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 + ) + 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_FTerm_no_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 + ) + 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 + + end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 5144386a..753d014b 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -155,7 +155,7 @@ Multithreading.parallel_proofs := 0 \ local_setup \fn lthy => let - val (bmv, (thms, lthy)) = PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I + val (bmv, (thms, lthy)) = PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) [] I @{typ "('a1, 'a2, 'a1 * 'a2, 'a1 * 'a2 * 'a2 * 'a2 FType) L'"} ([], lthy) From 788b3638bb013c1326f4597a9243e746045b3665 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 3 Mar 2025 15:15:55 +0000 Subject: [PATCH 22/90] Allow BMV monads to carry predefined SSupp operators Introduce definitions for all SSupp operators not specified from the outside --- Tools/bmv_monad_def.ML | 412 +++++++++++++++++++++++---------------- operations/BMV_Monad.thy | 13 +- 2 files changed, 247 insertions(+), 178 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 4bd9ac80..76b92fe3 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -19,9 +19,16 @@ signature BMV_MONAD_DEF = sig Vrs_Sbs: 'a option list list }; + type 'a bmv_monad_consts = { + bd: term, + params: { Map: term, Supps: term list} option list, + Injs: term list list, + SSupps: 'a list list, + Sbs: term list, + Vrs: term option list list list + }; + type 'a bmv_monad_param = { - Map: term, - Supps: term list, axioms: 'a supported_functor_axioms, Map_Sb: 'a, Supp_Sb: 'a list, @@ -30,7 +37,6 @@ signature BMV_MONAD_DEF = sig type 'a bmv_monad_model = { ops: typ list, - bd: term, var_class: class, bmv_ops: bmv_monad list, frees: typ list, @@ -38,11 +44,10 @@ signature BMV_MONAD_DEF = sig leader: int, lives: typ list, lives': typ list, + consts: (term option) bmv_monad_consts, params: 'a bmv_monad_param option list, - Injs: term list list, - Sbs: term list, - Vrs: term option list list list, bd_infinite_regular_card_order: 'a, + SSupp_eq: 'a option list list, tacs: 'a bmv_monad_axioms list } @@ -56,14 +61,13 @@ signature BMV_MONAD_DEF = sig val lives'_of_bmv_monad: bmv_monad -> typ list; val deads_of_bmv_monad: bmv_monad -> typ list; val Injs_of_bmv_monad: bmv_monad -> term list list; + val SSupps_of_bmv_monad: bmv_monad -> (term * thm) 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 option list list list; val axioms_of_bmv_monad: bmv_monad -> thm bmv_monad_axioms list; val params_of_bmv_monad: bmv_monad -> { - Map: term, - Supps: term list, axioms: thm supported_functor_axioms, Map_Sb: thm, Supp_Sb: thm list, @@ -83,8 +87,8 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory - val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list -> local_theory - -> (bmv_monad * thm list) * local_theory + (*val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list -> local_theory + -> (bmv_monad * thm list) * local_theory*) end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -146,56 +150,67 @@ fun map_supported_functor_axioms f { Map_id, Map_comp, Supp_Map, Supp_bd, Map_co } : 'b supported_functor_axioms; type 'a bmv_monad_param = { - Map: term, - Supps: term list, axioms: 'a supported_functor_axioms, Map_Sb: 'a, Supp_Sb: 'a list, Map_Vrs: 'a option list list }; -fun morph_bmv_monad_param phi f ({ Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs }: 'a bmv_monad_param) = { - Map = Morphism.term phi Map, - Supps = map (Morphism.term phi) Supps, +fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Map_Vrs }: 'a bmv_monad_param) = { axioms = map_supported_functor_axioms f axioms, Map_Sb = f Map_Sb, Supp_Sb = map f Supp_Sb, Map_Vrs = map (map (Option.map f)) Map_Vrs }: 'b bmv_monad_param; + +type 'a bmv_monad_consts = { + bd: term, + params: { Map: term, Supps: term list} option list, + Injs: term list list, + SSupps: 'a list list, + Sbs: term list, + Vrs: term option list list list +}; + +fun morph_bmv_monad_consts phi f { bd, params, Injs, SSupps, Sbs, Vrs } = { + bd = Morphism.term phi bd, + 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, + SSupps = map (map f) SSupps, + Sbs = map (Morphism.term phi) Sbs, + Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs +}: 'a bmv_monad_consts; + datatype bmv_monad = BMV of { ops: typ list, - bd: term, var_class: class, leader: int, frees: typ list, lives: typ list, lives': typ list, deads: typ list, + consts: (term * thm) bmv_monad_consts, params: thm bmv_monad_param option list, - Injs: term list list, - Sbs: term list, - Vrs: term option list list list, bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list } fun morph_bmv_monad phi (BMV { - ops, bd, var_class, leader, frees, lives, lives', deads, params, Injs, Sbs, Vrs, axioms, - bd_infinite_regular_card_order + ops, var_class, leader, frees, lives, lives', deads, consts, params, axioms, bd_infinite_regular_card_order }) = BMV { ops = map (Morphism.typ phi) ops, - bd = Morphism.term phi bd, leader = leader, var_class = var_class, frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', deads = map (Morphism.typ phi) deads, - params = map (Option.map (morph_bmv_monad_param phi (Morphism.thm phi))) params, - Injs = map (map (Morphism.term phi)) Injs, - Sbs = map (Morphism.term phi) Sbs, - Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, + consts = morph_bmv_monad_consts phi (map_prod (Morphism.term phi) (Morphism.thm phi)) consts, + params = map (Option.map (map_bmv_monad_param (Morphism.thm phi))) params, axioms = map (morph_bmv_monad_axioms phi) axioms, bd_infinite_regular_card_order = Morphism.thm phi bd_infinite_regular_card_order } @@ -203,60 +218,73 @@ fun morph_bmv_monad phi (BMV { fun Rep_bmv (BMV x) = x val ops_of_bmv_monad = #ops o Rep_bmv -val bd_of_bmv_monad = #bd 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 Rep_bmv -val Sbs_of_bmv_monad = #Sbs o Rep_bmv -val Maps_of_bmv_monad = map (Option.map #Map) o #params o Rep_bmv -val Supps_of_bmv_monad = map (Option.map #Supps) o #params o Rep_bmv -val Vrs_of_bmv_monad = #Vrs o Rep_bmv +val Injs_of_bmv_monad = #Injs o #consts o Rep_bmv +val SSupps_of_bmv_monad = #SSupps 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 axioms_of_bmv_monad = #axioms 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 type 'a bmv_monad_model = { ops: typ list, - bd: term, var_class: class, frees: typ list, lives: typ list, lives': typ list, deads: typ list, + consts: (term option) bmv_monad_consts, params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, leader: int, - Injs: term list list, - Sbs: term list, - Vrs: term option list list list, bd_infinite_regular_card_order: 'a, + SSupp_eq: 'a option list list, tacs: 'a bmv_monad_axioms list } -fun morph_bmv_monad_model phi f ({ ops, bd, var_class, frees, lives, lives', params, bmv_ops, leader, - Injs, Sbs, Vrs, tacs, bd_infinite_regular_card_order, deads } +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, SSupp_eq } ) = { ops = map (Morphism.typ phi) ops, - bd = Morphism.term phi bd, var_class = var_class, frees = map (Morphism.typ phi) frees, lives = map (Morphism.typ phi) lives, lives' = map (Morphism.typ phi) lives', deads = map (Morphism.typ phi) deads, - params = map (Option.map (morph_bmv_monad_param phi f)) params, + consts = morph_bmv_monad_consts phi (Option.map (Morphism.term phi)) consts, + params = params, bmv_ops = map (morph_bmv_monad phi) bmv_ops, leader = leader, - Injs = map (map (Morphism.term phi)) Injs, - Sbs = map (Morphism.term phi) Sbs, - Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs, tacs = map (map_bmv_monad_axioms f) tacs, + SSupp_eq = map (map (Option.map f)) SSupp_eq, bd_infinite_regular_card_order = bd_infinite_regular_card_order } : 'b bmv_monad_model; +fun update_consts 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, + SSupp_eq = #SSupp_eq 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; @@ -273,21 +301,21 @@ fun pbmv_monad_of_generic context = val pbmv_monad_of = pbmv_monad_of_generic o Context.Proof; -val mk_small_prems = map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (HOLogic.mk_Collect ("a", fst (dest_funT (fastype_of Inj)), - HOLogic.mk_not (HOLogic.mk_eq (rho $ Bound 0, Inj $ Bound 0)) - ))) - (mk_card_of (HOLogic.mk_UNIV (fst (dest_funT (fastype_of Inj))))) +val mk_small_prems = map2 (fn rho => fn SSupp => HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (the SSupp $ rho)) + (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of rho)))) )); -fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = +fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = let val Ts = ops @ maps ops_of_bmv_monad bmv_ops; - val Sbs = Sb @ maps Sbs_of_bmv_monad bmv_ops; - val Injss = Injs @ maps Injs_of_bmv_monad bmv_ops; - val Vrss = Vrs @ maps Vrs_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 SSupps = #SSupps consts @ maps (map (map (K NONE)) o SSupps_of_bmv_monad) bmv_ops; + val SSupp_defs = SSupp_defs @ maps (map (map (K NONE)) o SSupps_of_bmv_monad) bmv_ops; + val Vrss = #Vrs consts @ maps Vrs_of_bmv_monad bmv_ops; - val axioms = @{map 4} (fn T => fn Injs => fn Sb => fn Vrs => + val (axioms, SSupp_eq) = split_list (@{map 6} (fn T => fn Injs => fn SSupps => fn SSupp_defs => fn Sb => fn Vrs => let val (own_Injs, other_Injs) = partition (fn Inj => body_type (fastype_of Inj) = T) Injs; val is_own_Inj = map (curry (op=) T o body_type o fastype_of) Injs; @@ -302,8 +330,8 @@ fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T); - val small_prems = mk_small_prems rhos Injs; - val small_prems' = mk_small_prems rhos' Injs; + val small_prems = mk_small_prems rhos SSupps; + val small_prems' = mk_small_prems rhos' SSupps; val Sb_comp_Injs = map2 (fn Inj => fn rho => fold_rev Logic.all rhos (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( @@ -326,7 +354,7 @@ fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = ); val Vrs_bds = map (map (Option.map (fn Vrs => Logic.all x ( - HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) bd) + HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) (#bd consts)) )))) Vrs; val Vrs_Injs = map2 (fn Inj => map (Option.map (fn Vrs => @@ -367,7 +395,15 @@ fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = ) )); - in { + val SSupp_eq = @{map 5} (fn Inj => fn rho => fn a => fn SSupp => (fn NONE => + SOME (Logic.all rho (mk_Trueprop_eq ( + the SSupp $ rho, HOLogic.mk_Collect ("a", fastype_of a, HOLogic.mk_not (HOLogic.mk_eq ( + rho $ Bound 0, Inj $ Bound 0 + ))) + ))) + | SOME _ => NONE + )) Injs rhos aa SSupps SSupp_defs; + in ({ Sb_Inj = Sb_Inj, Sb_comp_Injs = Sb_comp_Injs, Sb_comp = Sb_comp, @@ -375,11 +411,11 @@ fun mk_bmv_monad_axioms ops bd Sb Injs Vrs bmv_ops lthy = Vrs_bds = Vrs_bds, Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong - } : term bmv_monad_axioms end - ) ops Injs Sb Vrs; - in axioms end; + } : term bmv_monad_axioms, SSupp_eq) end + ) ops Injss SSupps SSupp_defs Sbs Vrss); + in (axioms, SSupp_eq) end; -fun mk_param_axiom Map Supps Sb Injs Vrs bd lthy = +fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = let val (f_Ts, T) = split_last (binder_types (fastype_of Map)); val (lives, lives') = split_list (map dest_funT f_Ts); @@ -431,7 +467,7 @@ fun mk_param_axiom Map Supps Sb Injs Vrs bd lthy = ))); val Map_Sb = fold_rev Logic.all (fs @ rhos) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems rhos Injs) (mk_Trueprop_eq ( + fold_rev (curry Logic.mk_implies) (mk_small_prems rhos SSupps) (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb (Map, fs), Term.list_comb (Sb, rhos)), HOLogic.mk_comp (Term.list_comb ( Term.subst_atomic_types (lives ~~ lives') Sb, rhos @@ -452,8 +488,6 @@ fun mk_param_axiom Map Supps Sb Injs Vrs bd lthy = )) ) Supps; in { - Map = Map, - Supps = Supps, axioms = { Map_id = Map_id, Map_comp = Map_comp, @@ -490,131 +524,142 @@ fun maybe_define const_policy fact_policy b rhs lthy = 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 const_policy fact_policy qualify (model: 'a bmv_monad_model) lthy = +fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' (consts: (term option) bmv_monad_consts) lthy = let - val maybe_define = maybe_define const_policy fact_policy o qualify; + val maybe_define' = maybe_define const_policy fact_policy o qualify; val suffixes = map_index (fn (i, T) => 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 model); - val suffixess = map2 (fn suffix => map_index (fn (i, _) => - Binding.suffix_name ("_" ^ string_of_int i) o suffix - )) suffixes (#Injs model); + ))) 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 model) suffixes lthy); + 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 model) suffixess lthy); + @{fold_map 2} (fn Inj => fn suffix => maybe_define' (suffix (Binding.name "Inj")) Inj) + ) (#Injs consts) suffixess lthy); + + val ((SSupps, SSupp_defs), lthy) = apfst (split_list o map split_list) (@{fold_map 3} (@{fold_map 3} ( + fn Inj => fn suffix => fn SSupp_opt => fn lthy => case SSupp_opt of + SOME t => ((t, NONE), lthy) + | NONE => apfst (apsnd SOME) (MRBNF_Util.mk_def_t true Binding.empty I (Binding.name_of (suffix (Binding.name "SSupp"))) 1 ( + Term.absfree ("\", fastype_of Inj) (HOLogic.mk_Collect ("a", domain_type (fastype_of Inj), + HOLogic.mk_not (HOLogic.mk_eq (Free ("\", fastype_of Inj) $ Bound 0, Inj $ Bound 0)) + )) + ) lthy) + ) + ) (#Injs consts) suffixess (#SSupps consts) lthy); val (Vrs', lthy) = (@{fold_map 2} (@{fold_map 2} (fn suffix => fn Vrs => @{fold_map 2} (fn i => fold_map_option (fn Vrs => - maybe_define (Binding.suffix_name ("_" ^ string_of_int i) (suffix (Binding.name "Vrs"))) Vrs - )) (0 upto length Vrs - 1) Vrs)) suffixess (#Vrs model) lthy); + maybe_define' (Binding.suffix_name ("_" ^ string_of_int i) (suffix (Binding.name "Vrs"))) Vrs + )) (0 upto length Vrs - 1) Vrs)) suffixess (#Vrs consts) lthy); val Vrs = map (map (map (Option.map fst))) Vrs'; val Vrs_defs = maps (maps (map (Option.mapPartial snd))) 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 ((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"))) + 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, - axioms = #axioms param, - Map_Sb = #Map_Sb param, - Supp_Sb = #Supp_Sb param, - Map_Vrs = #Map_Vrs param - }: 'a bmv_monad_param; + Supps = Supps + }; in ((param, Map_def :: Supp_defs), lthy) end - )) suffixes (#params model) lthy; + )) 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 model) lthy; + val ((bd, bd_def), lthy) = maybe_define' (Binding.name "bd") (#bd consts) lthy; - val model' = { - ops = #ops model, + val consts' = { bd = bd, - 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, params = params, Injs = Injs, + SSupps = map (map SOME) SSupps, Sbs = Sbs, - Vrs = Vrs, - bd_infinite_regular_card_order = #bd_infinite_regular_card_order model, - tacs = #tacs model - } : 'a bmv_monad_model; + Vrs = Vrs + } : (term option) 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 model) (#leader model)) [])) @ #lives' model; + val vars = map TFree (rev (Term.add_tfreesT (nth ops leader) [])) @ 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 model' = morph_bmv_monad_model phi' I model'; + val consts' = morph_bmv_monad_consts phi' (Option.map (Morphism.term phi')) consts'; val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ [bd_def] @ flat param_defs); - in (model', map (Morphism.thm phi) defs, lthy) end; + in (consts', map (Morphism.thm phi) defs, map (map (Option.map (Morphism.thm phi))) SSupp_defs, lthy) end; -fun mk_bmv_monad const_policy fact_policy (model: thm bmv_monad_model) lthy = +fun mk_bmv_monad const_policy fact_policy SSupp_defs (model: thm bmv_monad_model) lthy = let (* TODO: Derived theorems *) + val SSupp_defs = map2 (map2 (fn SOME def => K def + | NONE => fn thm => @{thm eq_reflection} OF [the thm] + )) SSupp_defs (#SSupp_eq model); + 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), + SSupps = map2 (map2 (pair o the)) (#SSupps (#consts model)) SSupp_defs, + 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) + }; val bmv = BMV { ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), - bd = #bd model, var_class = #var_class model, leader = #leader model, frees = #frees model, lives = #lives model, lives' = #lives' model, deads = #deads model, + consts = consts, params = #params model @ maps (#params o Rep_bmv) (#bmv_ops model), - Injs = #Injs model @ maps (#Injs o Rep_bmv) (#bmv_ops model), - Sbs = #Sbs model @ maps (#Sbs o Rep_bmv) (#bmv_ops model), - Vrs = #Vrs model @ maps (#Vrs o Rep_bmv) (#bmv_ops model), axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model), bd_infinite_regular_card_order = #bd_infinite_regular_card_order model } : bmv_monad; in (bmv, lthy) end -fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = +fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs SSupp_defs lthy = let - val goals = mk_bmv_monad_axioms (#ops model) (#bd model) (#Sbs model) (#Injs model) (#Vrs model) (#bmv_ops model) lthy; + val (goals, SSupp_eq) = mk_bmv_monad_axioms (#ops model) (#consts model) SSupp_defs (#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 + 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' + tacs', + map2 (map2 (fn tac => Option.map (fn SSupp_eq => Goal.prove_sorry lthy [] [] SSupp_eq (fn {context=ctxt, ...} => + Local_Defs.unfold0_tac ctxt defs THEN the tac ctxt + )))) (#SSupp_eq model) SSupp_eq + ) end; fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let - val goals = @{map 4} (fn Sb => fn Vrs => fn Injs => Option.map (fn param => - mk_param_axiom (#Map param) (#Supps param) Sb Injs Vrs (#bd model) lthy - )) (#Sbs model) (#Vrs model) (#Injs model) (#params model) - val tacs' = map (Option.map (morph_bmv_monad_param Morphism.identity (fn tac => fn goal => + val goals = @{map 5} (fn Sb => fn Vrs => fn Injs => fn SSupps => Option.map (fn param => + mk_param_axiom (#Map param) (#Supps param) SSupps Sb Injs Vrs (#bd (#consts model)) lthy + )) (#Sbs (#consts model)) (#Vrs (#consts model)) (#Injs (#consts model)) (#SSupps (#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, Map_Vrs=f3s, ...} => - fn { Map, Supps, axioms, Map_Sb, Supp_Sb, Map_Vrs } => { - Map = Map, Supps = Supps, Map_Sb = f1 Map_Sb, Supp_Sb = map2 (curry (op|>)) Supp_Sb f2s, + fn { axioms, Map_Sb, Supp_Sb, Map_Vrs } => { + Map_Sb = f1 Map_Sb, Supp_Sb = map2 (curry (op|>)) Supp_Sb f2s, Map_Vrs = map2 (map2 (@{map_option 2} (curry (op|>)))) Map_Vrs f3s, axioms = { Map_id = #Map_id tacs (#Map_id axioms), Map_comp = #Map_comp tacs (#Map_comp axioms), @@ -624,9 +669,8 @@ fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = } } : thm bmv_monad_param)) tacs' goals end; -fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { +fun mk_thm_model (model: 'a bmv_monad_model) params axioms SSupp_eq bd_irco = { ops = #ops model, - bd = #bd model, var_class = #var_class model, leader = #leader model, frees = #frees model, @@ -634,11 +678,10 @@ fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { lives' = #lives' model, deads = #deads model, bmv_ops = #bmv_ops model, + consts = #consts model, params = params, - Injs = #Injs model, - Sbs = #Sbs model, - Vrs = #Vrs model, bd_infinite_regular_card_order = bd_irco, + SSupp_eq = SSupp_eq, tacs = axioms } : thm bmv_monad_model; @@ -649,17 +692,18 @@ fun bmv_monad_def const_policy fact_policy qualify (model: (Proof.context -> tac ) (dest_TFree T))) (#frees model); val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) I model; - val (model, unfold_set, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify model lthy; + val (consts, unfold_set, SSupp_defs, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify + (#leader model) (#ops model) (#lives' model) (#consts model) lthy; - val axioms = prove_axioms model unfold_set lthy; + val (axioms, SSupp_eq) = prove_axioms model unfold_set SSupp_defs 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 model) + 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 model lthy) end + val model = mk_thm_model (update_consts consts model) params axioms SSupp_eq bd_irco; + in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy SSupp_defs model lthy) end fun pbmv_monad_of_bnf bnf lthy = let @@ -674,7 +718,6 @@ fun pbmv_monad_of_bnf bnf lthy = | _ => error "TODO: other var classes" in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I { ops = [T], - bd = BNF_Def.bd_of_bnf bnf, var_class = var_class, leader = 0, frees = [], @@ -682,9 +725,18 @@ fun pbmv_monad_of_bnf bnf lthy = lives' = lives', deads = deads, bmv_ops = [], + consts = { + bd = BNF_Def.bd_of_bnf bnf, + Injs = [[]], + SSupps = [[]], + Sbs = [HOLogic.id_const T], + Vrs = [[]], + params = [SOME { + Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, + Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf + }] + }, params = [SOME { - Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, - Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf, axioms = { Map_id = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, Map_comp = fn ctxt => rtac ctxt (BNF_Def.map_comp0_of_bnf bnf RS sym) 1, @@ -699,15 +751,13 @@ fun pbmv_monad_of_bnf bnf lthy = Supp_Sb = replicate n (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_apply} THEN rtac ctxt refl 1), Map_Vrs = [] }], - Injs = [[]], - Sbs = [HOLogic.id_const T], - Vrs = [[]], bd_infinite_regular_card_order = fn ctxt => EVERY1 [ rtac ctxt @{thm infinite_regular_card_order.intro}, rtac ctxt (BNF_Def.bd_card_order_of_bnf bnf), rtac ctxt (BNF_Def.bd_cinfinite_of_bnf bnf), rtac ctxt (BNF_Def.bd_regularCard_of_bnf bnf) ], + SSupp_eq = [[]], tacs = [{ Sb_Inj = fn ctxt => rtac ctxt refl 1, Sb_comp_Injs = [], @@ -731,7 +781,7 @@ fun register_bnf_as_pbmv_monad name lthy = - does not appear in the codomain of any (=of any **other** SOp) Injection, *) -fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = +(*fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = let val _ = if length (lives_of_bmv_monad outer) <> length inners then error "Outer needs exactly as many lives as there are inners" else () @@ -1006,7 +1056,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), REPEAT_DETERM1 o EVERY' [ - REPEAT_DETERM o resolve_tac ctxt (take (2 * length vars) prems), + REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), FIRST' (map (fn thm => EVERY' [ TRY o rtac ctxt thm, REPEAT_DETERM o FIRST' [ @@ -1015,7 +1065,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ], REPEAT_DETERM o etac ctxt @{thm UN_I}, assume_tac ctxt - ]) (@{thm refl} :: drop (2 * length vars) prems)) + ]) (@{thm refl} :: drop (2 * length Injs) prems)) ] ]) inners), rtac ctxt (#Sb_cong axioms), @@ -1037,9 +1087,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit } : (Proof.context -> tactic) bmv_monad_model; val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify model lthy - in (res, lthy) end; + in (res, lthy) end;*) -fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = +fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), bd) lthy = let val ops = map (Syntax.read_typ lthy) ops; val bd = Syntax.read_term lthy bd; @@ -1051,6 +1101,9 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = map (fst o dest_funT) o fst o split_last o binder_types o fastype_of ) Sbs); val Injs = map (map (Syntax.read_term lthy)) Injs; + val SSupps = case SSupps_opt of + SOME SSupps => map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t))) SSupps + | NONE => map (map (K NONE)) Injs; val Vrs = map (map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t)))) Vrs; val Vrs = map2 (fn T => map (map (Option.map (fn Vrs => Term.subst_atomic_types ( map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of Vrs))) [] ~~ Term.add_tfreesT T []) @@ -1058,14 +1111,12 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = val b = if Binding.is_empty b then fst (dest_Type (hd ops)) else Local_Theory.full_name lthy b - val goals = mk_bmv_monad_axioms ops bd Sbs Injs Vrs [] lthy; - val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); val names_lthy = lthy |> fold Variable.declare_typ vars - val (lives, lives', params) = case param_opt of + val (lives, lives', param_consts) = case param_opt of NONE => ([], [], replicate (length ops) NONE) | SOME (Maps, Suppss) => let @@ -1104,44 +1155,59 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = Term.add_tfreesT (hd (binder_types (fastype_of Supp))) [] ~~ Term.add_tfreesT T [] )) Supp))) ops (Suppss @ replicate (length ops - length Suppss) NONE); - in (lives, lives', @{map 5} (fn Sb => fn Injs => fn Vrs => @{map_option 2} (fn Map => fn Supps => - mk_param_axiom Map Supps Sb Injs Vrs bd lthy - )) Sbs Injs Vrs Maps Suppss + in (lives, lives', + map2 (@{map_option 2} (fn Map => fn Supps => { Map = Map, Supps = Supps })) Maps Suppss ) end; + val consts = { + bd = bd, + Injs = Injs, + SSupps = SSupps, + Sbs = Sbs, + Vrs = Vrs, + params = param_consts + }: (term option) bmv_monad_consts; + val (consts, bmv_defs, SSupp_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 + ops lives' consts lthy; + + val param_goals = @{map 5} (fn Sb => fn Injs => fn SSupps => fn Vrs => Option.map (fn { Map, Supps } => + mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy + )) Sbs Injs (#SSupps consts) Vrs (#params consts); + + val (goals, SSupp_eq_goals) = mk_bmv_monad_axioms ops consts SSupp_defs [] lthy; + fun after_qed thmss lthy = let val thms = map hd thmss; val bd_irco = hd thms; - val chop_many = fold_map (fold_map ( + val chop_many = fold_map ( fn NONE => (fn thms => (NONE, thms)) | SOME _ => fn thms => (SOME (hd thms), tl thms) - )); + ); - val ((axioms, params), _) = apfst split_list (@{fold_map 2} (fn goal => fn param => fn thms => + val (((axioms, SSupp_eq), params), _) = apfst (apfst split_list o split_list) (@{fold_map 4} (fn goal => fn SSupp_eq_goals => fn param => fn param_consts => fn thms => let - val (((((((Sb_Inj, Sb_comp_Injs), Sb_comp), Vrs_bds), Vrs_Injs), Vrs_Sbs), Sb_cong), thms) = thms + val ((((((((Sb_Inj, Sb_comp_Injs), SSupp_eq), Sb_comp), Vrs_bds), Vrs_Injs), Vrs_Sbs), Sb_cong), thms) = thms |> apfst hd o chop 1 ||>> chop (length (#Sb_comp_Injs goal)) + ||>> chop_many SSupp_eq_goals ||>> apfst hd o chop 1 - ||>> chop_many (#Vrs_bds goal) - ||>> chop_many (#Vrs_Injs goal) - ||>> chop_many (#Vrs_Sbs goal) + ||>> fold_map chop_many (#Vrs_bds goal) + ||>> fold_map chop_many (#Vrs_Injs goal) + ||>> fold_map chop_many (#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), Map_Vrs), thms) = thms |> apfst hd o chop 1 ||>> apfst hd o chop 1 - ||>> chop (length (#Supps goals)) - ||>> chop (length (#Supps goals)) + ||>> 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 goals)) - ||>> chop_many (#Map_Vrs goals) + ||>> chop (length (#Supps (the param_consts))) + ||>> fold_map chop_many (#Map_Vrs goals) in (SOME ({ - Map = #Map goals, - Supps = #Supps goals, axioms = { Map_id = Map_id, Map_comp = Map_comp, @@ -1153,7 +1219,7 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = Supp_Sb = Supp_Sb, Map_Vrs = Map_Vrs } : thm bmv_monad_param), thms) end; - in (({ + in ((({ Sb_Inj = Sb_Inj, Sb_comp_Injs = Sb_comp_Injs, Sb_comp = Sb_comp, @@ -1161,12 +1227,11 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = Vrs_Injs = Vrs_Injs, Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong - }: thm bmv_monad_axioms, param), thms) end - ) goals params (tl thms)); + }: thm bmv_monad_axioms, SSupp_eq), param), thms) end + ) goals SSupp_eq_goals param_goals param_consts (tl thms)); val model = { ops = ops, - bd = bd, var_class = @{class var}, (* TODO: change *) leader = 0, frees = frees, @@ -1174,29 +1239,29 @@ fun pbmv_monad_cmd ((((((b, ops), Sbs), Injs), Vrs), param_opt), bd) lthy = lives' = lives', deads = subtract (op=) (lives @ frees) vars, bmv_ops = [], + consts = consts, params = params, - Injs = Injs, - Sbs = Sbs, - Vrs = Vrs, bd_infinite_regular_card_order = bd_irco, + SSupp_eq = SSupp_eq, tacs = axioms } : thm bmv_monad_model; - val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) model lthy; + val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) SSupp_defs model 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] + @ flat (@{map 3} (fn goal => fn SSupp_eq_goals => fn param => #Sb_Inj goal :: #Sb_comp_Injs goal @ map_filter I SSupp_eq_goals @ [#Sb_comp goal] @ maps (map_filter I) (#Vrs_bds goal @ #Vrs_Injs 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 @ maps (map_filter I) (#Map_Vrs param) ) param) - ) goals params) + ) goals SSupp_eq_goals param_goals) )) lthy + |> Proof.unfolding ([[(bmv_defs, [])]]) |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) end; @@ -1206,7 +1271,7 @@ fun print_pbmv_monads ctxt = 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, bd, Sbs, ...}) = + fun pretty_mrbnf (key, bmv as BMV {ops, frees, lives, consts, ...}) = 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)))) @@ -1216,14 +1281,14 @@ fun print_pbmv_monads ctxt = [Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int (length lives)), Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)]] else []) @ - [ Pretty.block ([Pretty.str "Sb:", Pretty.brk 1] @ and_list (map (Pretty.quote o Syntax.pretty_term ctxt) Sbs)) + [ 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)]]); + 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))))) @@ -1239,12 +1304,13 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} "register a parametrized bounded multi-variate monad" (parse_opt_binding_colon -- Parse.and_list1 Parse.typ --| (Parse.reserved "Sbs" -- @{keyword ":"}) -- Parse.and_list1 Parse.term --| - (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") Parse.term)) --| + (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs" || Parse.reserved "SSupps") Parse.term)) -- + (Scan.option ((Parse.reserved "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") (Parse.reserved "_" || Parse.term))))) --| (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list1 (Parse.list1 ( - Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.term || Parse.reserved "_")) + Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.reserved "_" || Parse.term)) )) -- Scan.optional ( - (Parse.reserved "Map" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.term || Parse.reserved "_") --| + (Parse.reserved "Map" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.reserved "_" || Parse.term) --| (Parse.reserved "Supps" -- @{keyword ":"}) -- Parse.and_list1 ( Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term) || (Parse.reserved "_" >> K []) diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 753d014b..78e54f3b 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -101,23 +101,26 @@ local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name su pbmv_monad ID: "'a" Sbs: "id :: ('a \ 'a) \ 'a \ 'a" Injs: "id :: 'a \ 'a" + SSupps: "supp :: ('a \ 'a) \ 'a set" Vrs: "\(x::'a). {x}" bd: natLeq - by (auto simp: ID.set_bd infinite_regular_card_order_natLeq) + by (auto simp: ID.set_bd infinite_regular_card_order_natLeq supp_def) pbmv_monad "'a::var FType" Sbs: tvsubst_FType Injs: TyVar + SSupps: SSupp_FType Vrs: FVars_FType bd: natLeq apply (rule infinite_regular_card_order_natLeq) apply (rule Sb_Inj_FType) - apply (rule Sb_comp_Inj_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) - apply (rule Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) + apply (rule Sb_comp_Inj_FType; assumption) + apply ((unfold SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def comp_def TyVar_def)[1], rule refl) + apply (rule Sb_comp_FType; assumption) apply (rule FType.set_bd) apply (rule Vrs_Inj_FType) - apply (rule Vrs_Sb_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) - apply (rule Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]; assumption) + apply (rule Vrs_Sb_FType; assumption) + apply (rule Sb_cong_FType; assumption) done typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" From eee8eb475866a8c25ba7ab2bbb763e9b55cd9971 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 9 Mar 2025 21:52:28 +0000 Subject: [PATCH 23/90] Rewrite bmv composition to be easier to understand --- Tools/bmv_monad_def.ML | 295 +++++++++++++++++------------------- operations/BMV_Fixpoint.thy | 122 ++++++++++++--- operations/BMV_Monad.thy | 102 ++++++++----- 3 files changed, 305 insertions(+), 214 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 76b92fe3..8c4668f2 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -87,8 +87,8 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory - (*val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list -> local_theory - -> (bmv_monad * thm list) * local_theory*) + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list + -> local_theory -> (bmv_monad * thm list) * local_theory end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -311,8 +311,6 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = 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 SSupps = #SSupps consts @ maps (map (map (K NONE)) o SSupps_of_bmv_monad) bmv_ops; - val SSupp_defs = SSupp_defs @ maps (map (map (K NONE)) o SSupps_of_bmv_monad) bmv_ops; val Vrss = #Vrs consts @ maps Vrs_of_bmv_monad bmv_ops; val (axioms, SSupp_eq) = split_list (@{map 6} (fn T => fn Injs => fn SSupps => fn SSupp_defs => fn Sb => fn Vrs => @@ -395,14 +393,14 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = ) )); - val SSupp_eq = @{map 5} (fn Inj => fn rho => fn a => fn SSupp => (fn NONE => + val SSupp_eq = @{map 4} (fn Inj => fn rho => fn SSupp => (fn NONE => SOME (Logic.all rho (mk_Trueprop_eq ( - the SSupp $ rho, HOLogic.mk_Collect ("a", fastype_of a, HOLogic.mk_not (HOLogic.mk_eq ( + the SSupp $ rho, HOLogic.mk_Collect ("a", domain_type (fastype_of rho), HOLogic.mk_not (HOLogic.mk_eq ( rho $ Bound 0, Inj $ Bound 0 ))) ))) | SOME _ => NONE - )) Injs rhos aa SSupps SSupp_defs; + )) Injs rhos SSupps SSupp_defs; in ({ Sb_Inj = Sb_Inj, Sb_comp_Injs = Sb_comp_Injs, @@ -412,7 +410,7 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong } : term bmv_monad_axioms, SSupp_eq) end - ) ops Injss SSupps SSupp_defs Sbs Vrss); + ) ops (#Injs consts) (#SSupps consts) SSupp_defs (#Sbs consts) (#Vrs consts)); in (axioms, SSupp_eq) end; fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = @@ -614,7 +612,7 @@ fun mk_bmv_monad const_policy fact_policy SSupp_defs (model: thm bmv_monad_model 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), - SSupps = map2 (map2 (pair o the)) (#SSupps (#consts model)) SSupp_defs, + SSupps = map2 (map2 (pair o the)) (#SSupps (#consts model)) SSupp_defs @ maps (#SSupps 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) }; @@ -694,6 +692,7 @@ fun bmv_monad_def const_policy fact_policy qualify (model: (Proof.context -> tac val (consts, unfold_set, SSupp_defs, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify (#leader model) (#ops model) (#lives' model) (#consts model) lthy; + val model = update_consts consts model; val (axioms, SSupp_eq) = prove_axioms model unfold_set SSupp_defs lthy; val params = prove_params model unfold_set lthy; @@ -702,7 +701,7 @@ fun bmv_monad_def const_policy fact_policy qualify (model: (Proof.context -> tac 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 (update_consts consts model) params axioms SSupp_eq bd_irco; + val model = mk_thm_model model params axioms SSupp_eq bd_irco; in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy SSupp_defs model lthy) end fun pbmv_monad_of_bnf bnf lthy = @@ -781,17 +780,45 @@ fun register_bnf_as_pbmv_monad name lthy = - does not appear in the codomain of any (=of any **other** SOp) Injection, *) -(*fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = +fun slice_bmv_monad n bmv = + let + fun f xs = nth xs n; + val Sb = f (Sbs_of_bmv_monad bmv); + val vars = map TFree (Term.add_tfrees Sb []); + in BMV { + ops = [f (ops_of_bmv_monad bmv)], + var_class = var_class_of_bmv_monad bmv, + leader = 0, + frees = filter (member (op=) vars) (frees_of_bmv_monad bmv), + lives = lives_of_bmv_monad bmv, + lives' = lives'_of_bmv_monad bmv, + deads = 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)], + SSupps = [f (SSupps_of_bmv_monad bmv)], + Sbs = [Sb], + Vrs = [f (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)] + } end; + +fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = let val _ = if length (lives_of_bmv_monad outer) <> length inners then error "Outer needs exactly as many lives as there are inners" else () val filter_bmvs = map_filter (fn Inl x => SOME x | _ => NONE); - fun vars_of_bmv_monad bmv = @{fold 2} (fn T => fn param => case param of - SOME param => Term.add_tfrees (#Map param) + fun vars_of_bmv_monad bmv = @{fold 2} (fn T => fn Map => case Map of + SOME t => Term.add_tfrees t | NONE => Term.add_tfreesT T - ) (ops_of_bmv_monad bmv) (params_of_bmv_monad bmv) []; + ) (ops_of_bmv_monad bmv) (Maps_of_bmv_monad bmv) []; fun sum_collapse (Inl x) = x | sum_collapse (Inr x) = x @@ -814,151 +841,103 @@ fun register_bnf_as_pbmv_monad name lthy = val inners = map (map_sum mk_sign_morph mk_T_morph) inners; val inners' = filter_bmvs inners; - val bmvs = Typtab.make_distinct (flat (map (fn bmv => (#ops bmv ~~ - ((#params bmv) ~~ (#Injs bmv) ~~ (#Sbs bmv) ~~ (#Vrs bmv) ~~ map SOME (#axioms bmv) ~~ replicate (length (#Sbs bmv)) (SOME bmv)) - )) (map_filter (fn Inl bmv => SOME (Rep_bmv bmv) | Inr _ => NONE) inners))); + val inner_leaders' = map (map_sum (fn bmv => slice_bmv_monad (leader_of_bmv_monad bmv) bmv) I) inners; + val inner_leaders = map_filter (fn Inr _ => NONE | Inl bmv => SOME bmv) inner_leaders'; + + val subst = + let val Ts = map (sum_collapse o map_sum (hd o ops_of_bmv_monad) I) inner_leaders' + in (lives_of_bmv_monad outer ~~ Ts) @ (lives'_of_bmv_monad outer ~~ Ts) end; + val new_leader = Term.typ_subst_atomic subst (nth (ops_of_bmv_monad outer) (leader_of_bmv_monad outer)); - val outer_ops' = map (fn T => if Typtab.defined bmvs T then NONE else SOME T) ( - map (Term.typ_subst_atomic (lives_of_bmv_monad outer ~~ map ( - fn Inl bmv => nth (ops_of_bmv_monad bmv) (leader_of_bmv_monad bmv) - | Inr T => T - ) inners)) (ops_of_bmv_monad outer) + val new_Injs = distinct (op=) ( + map (Term.subst_atomic_types subst) (nth (Injs_of_bmv_monad outer) (leader_of_bmv_monad outer)) + @ maps (hd o Injs_of_bmv_monad) inner_leaders ); + val outer' = morph_bmv_monad (MRBNF_Util.subst_typ_morphism subst) outer; + val minions = fold_rev (fn bmv => fold_rev (fn i => fn xs => + let val T = nth (ops_of_bmv_monad bmv) i; + in if member (fn (a, b) => a = fst b) xs T + then xs else (T, slice_bmv_monad i bmv) :: xs end + ) (0 upto length (ops_of_bmv_monad bmv) - 1)) (outer' :: inners') []; + val minions = map_filter (AList.lookup (op=) minions o body_type o fastype_of) new_Injs; + + val (lSSupps, SSuppss) = split_list (map (fn bmv => apfst hd (apply2 (map snd) ( + partition (fn (i, _) => i = leader_of_bmv_monad bmv) + ((0 upto length (ops_of_bmv_monad bmv) - 1) ~~ SSupps_of_bmv_monad bmv) + ))) (outer' :: inners')); + val SSupps = flat (flat SSuppss) @ flat lSSupps; + val new_SSupps = map (fn t => + the (List.find (fn (SSupp, _) => domain_type (fastype_of SSupp) = fastype_of t) SSupps) + ) new_Injs; + + val ((fs, x), _) = lthy + |> mk_Frees "f" (map fastype_of new_Injs) + ||>> apfst hd o mk_Frees "x" [new_leader]; + + fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv); + fun mk_Sb (Inl bmv) = + let val Sb = leader Sbs_of_bmv_monad bmv; + in Term.list_comb (Sb, + map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of Sb)))) + ) end + | mk_Sb (Inr T) = HOLogic.id_const T; + val new_Sb = fold_rev Term.absfree (map dest_Free fs) (HOLogic.mk_comp ( + Term.list_comb (the (leader Maps_of_bmv_monad outer'), map mk_Sb inners), + mk_Sb (Inl outer') + )); - val ((Sbs, Injs), Vrs) = apfst split_list (split_list (@{map 5} (fn NONE => K (K (K (K ((NONE, NONE), NONE)))) | SOME T => (fn NONE => K (K (K ((NONE, NONE), NONE))) - | SOME param => fn Sb => fn Injs => fn Vrs => + val frees = map TFree (rev (fold Term.add_tfrees new_Injs [])); + val new_Vrs = map (fn Inj => let - val ((Sbs, Ts), (Injss, Vrsss)) = apfst split_list (apsnd split_list (split_list (map (fn Inl bmv => - let fun pick xs = nth xs (leader_of_bmv_monad bmv) - in ( - (SOME (pick (Sbs_of_bmv_monad bmv)), pick (ops_of_bmv_monad bmv)), - (SOME (pick (Injs_of_bmv_monad bmv)), SOME (pick (Vrs_of_bmv_monad bmv))) - ) end - | Inr T => ((NONE, T), (NONE, NONE)) - ) inners))); - val subst = (lives_of_bmv_monad outer @ lives'_of_bmv_monad outer) ~~ (Ts @ Ts); - val Injs' = distinct ((op=) o apply2 fastype_of) (Injs @ flat (map_filter I Injss)); - val ((fs, x), _) = lthy - |> mk_Frees "f" (map fastype_of Injs') - ||>> apfst hd o mk_Frees "x" [T]; - - val Vrs' = @{fold 4} (fn i => fn inner => fn Injs => fn Vrss => fn tab => case inner of - Inr _ => tab - | Inl inner => @{fold 2} (fn Inj => fn Vrs => fn tab => - case Typtab.lookup tab (fastype_of Inj) of - NONE => tab - | SOME inner_tab => - let val inner_tab' = @{fold 2} (fn NONE => K I | SOME Vrs => fn free => - Typtab.map_default (free, [(i, Vrs)]) (cons (i, Vrs)) - ) Vrs (frees_of_bmv_monad inner) inner_tab; - in Typtab.update (fastype_of Inj, inner_tab') tab end - ) (the Injs) (the Vrss) tab - ) (0 upto length inners) (Inl outer :: inners) (SOME Injs :: Injss) (SOME Vrs :: Vrsss) (Typtab.make (map (rpair Typtab.empty o fastype_of) Injs')); - - val frees = distinct (op=) (maps snd (Typtab.dest (Typtab.map (K Typtab.keys) Vrs'))); - val Supps = map (Term.subst_atomic_types subst) (#Supps param); - - val Vrs' = map (fn Inj => map (fn free => Option.mapPartial (fn xs => - let - val Vrss = distinct (op=) (rev xs); - val Vrs' = the_default [] (Option.map (fn s => - [Term.subst_atomic_types subst (s $ x)] - ) (AList.lookup (op=) Vrss 0)) - @ @{map_filter 2} (fn i => fn Supp => Option.map (fn t => - mk_UNION (Supp $ x) t - ) (AList.lookup (op=) Vrss i)) (1 upto length Supps) Supps; - - in case Vrs' of - [] => NONE - | _ => SOME (Term.absfree (dest_Free x) (foldl1 mk_Un Vrs')) - end - ) (Typtab.lookup (the (Typtab.lookup Vrs' (fastype_of Inj))) free)) frees) Injs'; - - val find_fs = map (fn Inj => - the (List.find (fn f => fastype_of f = fastype_of Inj) fs) + fun get_sets bmv = + let val idx = find_index (curry ((op=) o apply2 fastype_of) Inj) (leader Injs_of_bmv_monad bmv); + in if idx < 0 then [] else map_filter I (nth (leader Vrs_of_bmv_monad bmv) idx) end; + + val sets = flat (map (fn t => t $ x) (get_sets outer') + :: @{map_filter 2} (fn Inr _ => K NONE | Inl bmv => fn Supp => + let val sets = get_sets bmv; + in if null sets then NONE else SOME (map (mk_UNION (Supp $ x)) sets) end + ) inners (the (leader Supps_of_bmv_monad outer')) ); - fun mk_comp t = if true orelse length (binder_types (fastype_of Sb)) > 1 then - HOLogic.mk_comp (t, Term.list_comb (Sb, find_fs Injs)) - else t - in (( - SOME (Term.subst_atomic_types subst ( - fold_rev (Term.absfree o dest_Free) fs (mk_comp ( - Term.list_comb (#Map param, @{map 3} (fn Inr T => K (K (HOLogic.id_const T)) - | _ => fn Sb => fn Injs => Term.list_comb (the Sb, find_fs (the Injs)) - ) inners Sbs Injss) - )) - )), - SOME Injs'), - SOME Vrs' - ) end - )) outer_ops' (#params (Rep_bmv outer)) (Sbs_of_bmv_monad outer) (Injs_of_bmv_monad outer) (Vrs_of_bmv_monad outer))); - - fun drop_lead xs = map_filter I (nth_drop (leader_of_bmv_monad outer) xs); - - val bmvs = @{fold 3} (fn T => fn Sb => fn Injs => Typtab.map_default (T, - (((((NONE, Injs), Sb), []), NONE), NONE) - ) I) (drop_lead outer_ops') (drop_lead Sbs) (drop_lead Injs) bmvs; - - fun add_ops T Injs bmvs = T :: flat (map_filter I (fst (fold_map (fn Inj => fn bmvs => - let val T = body_type (fastype_of Inj); - in case Typtab.lookup bmvs T of - NONE => (NONE, bmvs) - | SOME (((((_, Injs), _), _), _), _) => - let val bmvs' = Typtab.delete T bmvs - in (SOME (add_ops T Injs bmvs'), bmvs') end - end - ) Injs bmvs))); - - fun pick xs = nth xs (leader_of_bmv_monad outer) - - val ops = add_ops (the (pick outer_ops')) (the (pick Injs)) bmvs; - - val bmv_ops = map_filter (fn T => case Typtab.lookup bmvs T of - SOME (((((param, Injs), Sb), Vrs), SOME axioms), SOME bmv) => SOME (BMV { - ops = [T], - bd = #bd bmv, - var_class = #var_class bmv, - leader = 0, - frees = #frees bmv, - lives = #lives bmv, - lives' = #lives' bmv, - deads = #deads bmv, - params = [param], - Injs = [Injs], - Sbs = [Sb], - Vrs = [Vrs], - axioms = [axioms], - bd_infinite_regular_card_order = #bd_infinite_regular_card_order bmv - }) | _ => NONE - ) ops; - - val ops' = subtract (fn (bmv, T) => hd (ops_of_bmv_monad bmv) = T) bmv_ops ops; - - val idxs = map (fn T => find_index (curry (op=) T) ops) ops'; - val Vrs = map (the o nth Vrs) idxs; - val Injs = map (the o nth Injs) idxs; - val frees = distinct (op=) (maps frees_of_bmv_monad (outer :: inners')); - val outer_Vrs = map (nth (Vrs_of_bmv_monad outer)) idxs; - - val vars = distinct (op=) (map TFree (fold Term.add_tfreesT (ops' @ maps ops_of_bmv_monad inners') [])); + in map (fn var => + let + val sets' = filter (curry (op=) var o HOLogic.dest_setT o fastype_of) sets; + in if null sets' then NONE else SOME (Term.absfree (dest_Free x) (foldl1 mk_Un sets')) end + ) frees end + ) new_Injs; + + val ops = new_leader :: map (hd o ops_of_bmv_monad) minions; + + val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); val lives = distinct (op=) (maps lives_of_bmv_monad inners'); - val model = { - ops = ops', - bmv_ops = bmv_ops, + val consts = { bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) + Injs = [new_Injs], + Sbs = [new_Sb], + Vrs = [new_Vrs], + SSupps = [map (SOME o fst) new_SSupps], + params = [NONE] + }: (term option) bmv_monad_consts; + + val SSupp_defs = map snd (flat (maps SSupps_of_bmv_monad (outer' :: inners'))); + + val model = { + ops = [new_leader], + bmv_ops = 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' = distinct (op=) (maps lives'_of_bmv_monad inners'), deads = subtract (op=) (lives @ frees) vars, - params = replicate (length ops') NONE, + consts = consts, + params = [NONE], leader = 0, - Injs = Injs, - Sbs = map (the o nth Sbs) idxs, - Vrs = Vrs, - tacs = @{map 5} (fn axioms => fn param => fn Injs => fn Vrs => fn outer_Vrs => { + SSupp_eq = [map (fn (_, thm) => SOME (fn ctxt => + Local_Defs.unfold0_tac ctxt [thm] THEN rtac ctxt refl 1 + )) new_SSupps], + tacs = @{map 5} (fn axioms => fn param => fn Map => fn Injs => fn Vrs => { Sb_Inj = fn ctxt => EVERY1 [ rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, @@ -981,10 +960,12 @@ fun register_bnf_as_pbmv_monad name lthy = rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Map_Sb param RS sym), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, rtac ctxt (#Sb_comp axioms), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, @@ -994,6 +975,7 @@ fun register_bnf_as_pbmv_monad name lthy = rtac ctxt (#Map_cong (#axioms param)), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (@{thm id_o} :: maps (map #Sb_comp o axioms_of_bmv_monad) inners'), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt refl ] @@ -1021,6 +1003,7 @@ fun register_bnf_as_pbmv_monad name lthy = resolve_tac ctxt (maps (map_filter I) (#Map_Vrs param)), rtac ctxt trans, resolve_tac ctxt (maps (map_filter I) (#Vrs_Sbs axioms)), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt refl ], @@ -1036,6 +1019,7 @@ fun register_bnf_as_pbmv_monad name lthy = rtac ctxt trans, rtac ctxt @{thm UN_cong}, resolve_tac ctxt (maps (maps (maps (map_filter I) o #Vrs_Sbs) o axioms_of_bmv_monad) inners'), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_extend_simps(9)}), rtac ctxt refl @@ -1044,17 +1028,19 @@ fun register_bnf_as_pbmv_monad name lthy = ])))) Vrs, Sb_cong = fn ctxt => EVERY1 [ rtac ctxt @{thm comp_apply_eq}, + K (Local_Defs.unfold0_tac ctxt SSupp_defs), Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ rtac ctxt @{thm trans[rotated]}, rtac ctxt ( let val n = length (lives_of_bmv_monad outer); - in mk_arg_cong lthy (n + 1) (#Map param) OF (replicate n refl) end + in mk_arg_cong lthy (n + 1) Map OF (replicate n refl) end ), K (prefer_tac 2), rtac ctxt (#Map_cong (#axioms param)), K (Local_Defs.unfold0_tac ctxt (#Supp_Sb param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM1 o EVERY' [ REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), FIRST' (map (fn thm => EVERY' [ @@ -1069,6 +1055,7 @@ fun register_bnf_as_pbmv_monad name lthy = ] ]) inners), rtac ctxt (#Sb_cong axioms), + K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o EVERY' [ resolve_tac ctxt prems, TRY o EVERY' [ @@ -1081,13 +1068,14 @@ fun register_bnf_as_pbmv_monad name lthy = ]) ctxt ] } : (Proof.context -> tactic) bmv_monad_axioms) - (map (nth (axioms_of_bmv_monad outer)) idxs) - (map (the o nth (params_of_bmv_monad outer)) idxs) - Injs Vrs outer_Vrs + [leader axioms_of_bmv_monad outer'] + [the (leader params_of_bmv_monad outer')] + [the (leader Maps_of_bmv_monad outer')] + [new_Injs] [new_Vrs] } : (Proof.context -> tactic) bmv_monad_model; val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify model lthy - in (res, lthy) end;*) + in (res, lthy) end; fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), bd) lthy = let @@ -1101,6 +1089,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b map (fst o dest_funT) o fst o split_last o binder_types o fastype_of ) Sbs); val Injs = map (map (Syntax.read_term lthy)) Injs; + val _ = @{print} SSupps_opt val SSupps = case SSupps_opt of SOME SSupps => map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t))) SSupps | NONE => map (map (K NONE)) Injs; @@ -1305,15 +1294,15 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} (parse_opt_binding_colon -- Parse.and_list1 Parse.typ --| (Parse.reserved "Sbs" -- @{keyword ":"}) -- Parse.and_list1 Parse.term --| (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs" || Parse.reserved "SSupps") Parse.term)) -- - (Scan.option ((Parse.reserved "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") (Parse.reserved "_" || Parse.term))))) --| + (Scan.option ((Parse.reserved "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") (Parse.underscore || Parse.term))))) --| (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list1 (Parse.list1 ( - Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.reserved "_" || Parse.term)) + Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.underscore || Parse.term)) )) -- Scan.optional ( - (Parse.reserved "Map" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.reserved "_" || Parse.term) --| + (Parse.reserved "Map" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.underscore || Parse.term) --| (Parse.reserved "Supps" -- @{keyword ":"}) -- Parse.and_list1 ( Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term) - || (Parse.reserved "_" >> K []) + || (Parse.underscore >> K []) ) >> SOME ) NONE --| diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index b9cbacad..1c45c777 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -72,12 +72,13 @@ lemma typedef_Rep_comp: "type_definition Rep Abs UNIV \ Rep ((Ab definition "Sb_FTerm_pre \ \(f1::'v::var \ 'v) (f2::'tv::var \ 'tv FType). (Abs_FTerm_pre :: _ \ ('tv, 'v, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre) \ (map_sum (id f1) (map_sum id (BMV_Fixpoint.sum2.sum2.sum.Sb_0 f2) \ id) \ id) \ Rep_FTerm_pre" definition "Vrs1_FTerm_pre \ \x. \x\Basic_BNFs.setl (Rep_FTerm_pre x). {x}" -definition "Vrs2_FTerm_pre \ \x. \x\Basic_BNFs.setr (Rep_FTerm_pre x). \ (BMV_Fixpoint.sum2.sum2.sum.Vrs_0_0_0 ` Basic_BNFs.setr x)" +definition "Vrs2_FTerm_pre \ \x. \y\Basic_BNFs.setr (Rep_FTerm_pre x). \ (sum2.sum2.sum.Vrs_0_0 ` Basic_BNFs.setr y)" (* Transfer pbmv structure of pre-datatype to sealed version *) pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var" and "'tv::var FType" Sbs: "Sb_FTerm_pre :: _ \ _ \ _ \ ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "id :: ('v \ 'v) \ 'v \ 'v" and "tvsubst_FType :: ('tv::var \ 'tv FType) \ 'tv FType \ 'tv FType" Injs: "id :: 'v::var \ 'v" "TyVar :: 'tv::var \ 'tv FType" and "id :: 'v::var \ 'v" and "TyVar :: 'tv::var \ 'tv FType" + SSupps: "supp :: _ \ 'v::var set" "SSupp_FType :: _ \ 'tv::var set" and "supp :: _ \ 'v::var set" and "SSupp_FType :: _ \ 'tv::var set" Vrs: "Vrs1_FTerm_pre :: ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre \ _", "Vrs2_FTerm_pre :: ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre \ _" and "\(x::'v). {x}" and "Vrs_FType_1 :: _ \ 'tv::var set" Map: "\(f1::'c \ 'c') (f2::'d \ 'd'). map_FTerm_pre id id id id f1 f2" Supps: "set5_FTerm_pre :: _ \ 'c set" "set6_FTerm_pre :: _ \ 'd set" @@ -94,6 +95,8 @@ pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v: apply (rule trans[OF Rep_FTerm_pre_inverse]) apply (rule id_apply[symmetric]) done + apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] + apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] subgoal apply (rule trans[OF comp_assoc_middle]) apply (rule Abs_FTerm_pre_inverse[OF UNIV_I]) @@ -189,16 +192,18 @@ pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v: apply (rule refl) done (********************* BMV Structure of minions, no transfer needed *) - apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) - apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) + apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) + apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] + apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) (* also for FType *) - apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) - apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) + apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) + apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) + apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) @@ -234,11 +239,71 @@ lemma set4_Sb: "set4_FTerm_pre (Sb_FTerm_pre f1 f2 x) = set4_FTerm_pre x" apply (rule refl) done +ML \ +val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre") +val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv +val laxioms = hd axioms +val param = the (hd (BMV_Monad_Def.params_of_bmv_monad bmv)) +\ + +lemma Map_is_Sb: "vvsubst_FType f = Sb_FType (Inj_FType_1 \ f)" + + sorry + +corollary permute_Sb: + fixes f::"'tv::var \ 'tv" + assumes "bij f" "|supp f| f)" + apply (rule trans) + apply (rule FType.vvsubst_permute[symmetric]) + apply (rule assms)+ + apply (rule Map_is_Sb) + done + +lemma Inj_inj: "Inj_FType_1 a = Inj_FType_1 b \ a = b" + apply (rule iffI) + apply (drule arg_cong[of _ _ Vrs_FType_1]) + apply (unfold Vrs_Inj_FType) + apply (erule singleton_inject) + apply hypsubst_thin + apply (rule refl) + done + lemma permute_Sb_FType: fixes f::"'tv::var \ 'tv" assumes "bij f" "|supp f| g \ inv f) = permute_FType f \ Sb_FType g \ permute_FType (inv f)" - apply (rule ext) + apply (subst permute_Sb, (rule assms bij_imp_bij_inv supp_inv_bound)+)+ + apply (unfold comp_assoc) + apply (subst Sb_comp_FType[symmetric]) + apply (unfold SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def comp_def TyVar_def[symmetric])[2] + apply (rule card_of_subset_bound) + apply (rule subsetI) + apply (erule CollectE) + apply (erule contrapos_np) + apply (rule iffD2[OF Inj_inj]) + apply (erule iffD1[OF not_in_supp_alt]) + apply (rule assms) + prefer 2 + apply (rule arg_cong2[OF refl _, of _ _ "(\)"]) + apply (subst Sb_comp_FType) + prefer 3 + apply (unfold comp_assoc[symmetric]) + apply (subst Sb_comp_Inj_FType) + apply (rule assms) + apply (rule refl) + apply (rule assms) + apply (unfold SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def comp_def TyVar_def[symmetric])[2] + apply (rule card_of_subset_bound) + apply (rule subsetI) + apply (erule CollectE) + apply (erule contrapos_np) + apply (rule iffD2[OF Inj_inj]) + apply (erule iffD1[OF not_in_supp_alt]) + apply (rule supp_inv_bound) + apply (rule assms)+ + sorry + (*apply (rule ext) apply (rule trans[OF _ comp_apply[symmetric]]) subgoal for x apply (subgoal_tac "|SSupp_FType (permute_FType f \ g \ inv f)| f2) (TyVar \ f1)" + sorry + + lemma Map_Sb': fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" - assumes "bij f1" "|supp f1| Inj_FType_1 a}| id a}| Inj_FType_1 a}| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre (f2 \ g1 \ inv f2) (permute_FType f1 \ g2 \ inv f1) \ map_FTerm_pre f1 f2 f3 f4 f5 f6" + apply (rule trans) + apply (rule trans) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (rule trans) + prefer 2 + apply (rule FTerm_pre.map_comp0[of f1 f2 id id id id f3 f4 _ id _ id]) + apply (rule assms bij_id supp_id_bound)+ + apply (unfold id_o o_id) + apply (rule refl) + apply (unfold comp_assoc Map_is_Sb_FTerm_pre)[1] + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (tactic \resolve_tac @{context} [#Sb_comp laxioms] 1\) + apply (rule ext) apply (subgoal_tac "|SSupp_FType g2| -val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre") -val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv -val laxioms = hd axioms -val param = the (hd (BMV_Monad_Def.params_of_bmv_monad bmv)) -\ - (* Substitution axioms *) abbreviation \ :: "'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre" where "\ a \ Abs_FTerm_pre (Inl a)" @@ -1035,6 +1114,7 @@ lemma permute_Uctor: apply (subst if_P inv_o_simp1 trans[OF comp_apply[symmetric] Pmap_comp0[THEN fun_cong]], (rule valid_Pmap bij_imp_bij_inv supp_inv_bound | assumption)+)+ apply (unfold trans[OF Pmap_id0[THEN fun_cong] id_apply]) apply (unfold Pmap_def case_prod_beta snd_conv compSS_FType_def) + apply (subst trans[OF comp_apply[symmetric] Map_Sb'[THEN fun_cong]]) apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ apply (unfold id_o o_id inv_o_simp2) @@ -1258,7 +1338,7 @@ lemma eta_set_empties: done lemma tvsubst_VVr: - assumes + assumes "|SSupp_FTerm f1| val model_L = { ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], - bd = @{term natLeq}, var_class = @{class var}, leader = 0, frees = [@{typ "'a1"}], @@ -288,17 +287,32 @@ val model_L = { MRBNF_Util.subst_typ_morphism ( BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] )) id_bmv], + consts = { + bd = @{term natLeq}, + Injs = [[@{term "id :: 'a1 \ 'a1"}]], + Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], + (*Vrs = [[[ + SOME @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} + ]]],*) + Vrs = [[[ + SOME @{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"} + ]]], + SSupps = [[NONE]], + params = [SOME { + (*Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"},*) + Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, + (*Supps = [ + @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, + @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} + ],*) + Supps = [ + @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, + @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} + ] + }] + }, + SSupp_eq = [[NONE]], params = [SOME { - (*Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"},*) - Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, - (*Supps = [ - @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, - @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} - ],*) - Supps = [ - @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, - @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} - ], axioms = { Map_id = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def sum.map_id0 id_apply}), @@ -345,14 +359,6 @@ val model_L = { resolve_tac ctxt [refl] ])]] }], - Injs = [[@{term "id :: 'a1 \ 'a1"}]], - Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], - (*Vrs = [[[ - SOME @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} - ]]],*) - Vrs = [[[ - SOME @{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"} - ]]], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ @@ -408,7 +414,6 @@ val model_L = { ML \ val model_L1 = { ops = [@{typ "'a1 * 'a2"}], - bd = @{term natLeq}, var_class = @{class var}, leader = 0, frees = [@{typ "'a1"}, @{typ "'a2"}], @@ -425,17 +430,23 @@ val model_L1 = { BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2"}] )) id_bmv ], + consts = { + bd = @{term natLeq}, + Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], + Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], + (*Vrs = [[ + [SOME @{term "\(x::'a1, x2::'a2). {x}"}, NONE], + [NONE, SOME @{term "\(x::'a1, x2::'a2). {x2}"}] + ]],*) + Vrs = [[ + [SOME @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, NONE], + [NONE, SOME @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"}] + ]], + params = [NONE], + SSupps = [[NONE, NONE]] + }, + SSupp_eq = [[NONE, NONE]], params = [NONE], - Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], - Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], - (*Vrs = [[ - [SOME @{term "\(x::'a1, x2::'a2). {x}"}, NONE], - [NONE, SOME @{term "\(x::'a1, x2::'a2). {x2}"}] - ]],*) - Vrs = [[ - [SOME @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, NONE], - [NONE, SOME @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"}] - ]], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ @@ -491,7 +502,6 @@ val model_L1 = { ML \ val model_L2 = { ops = [@{typ "('a1, 'a2) L2"}], - bd = @{term natLeq}, var_class = @{class var}, leader = 0, frees = [@{typ 'a1}, @{typ "'a2"}], @@ -512,14 +522,23 @@ val model_L2 = { BMV_Monad_Def.frees_of_bmv_monad FType_bmv ~~ [@{typ "'a2::var"}] )) FType_bmv ], + consts = { + bd = @{term natLeq}, + Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], + Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], + Vrs = [[ + [SOME @{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, NONE], + [NONE, SOME @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}], + [NONE, SOME @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"}] + ]], + params = [NONE], + SSupps = [[NONE, NONE, SOME @{term "SSupp_FType :: ('a2::var \ 'a2 FType) \ 'a2 set"}]] + }, + SSupp_eq = [[NONE, NONE, SOME (fn ctxt => + Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]} + THEN resolve_tac ctxt [refl] 1 + )]], params = [NONE], - Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], - Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], - Vrs = [[ - [SOME @{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, NONE], - [NONE, SOME @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}], - [NONE, SOME @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"}] - ]], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ Sb_Inj = fn ctxt => EVERY1 [ @@ -530,7 +549,7 @@ val model_L2 = { Sb_comp = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt ( (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) - :: @{thms Sb_L2_def id_apply Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]} + :: @{thms Sb_L2_def id_apply Sb_comp_FType} )), resolve_tac ctxt [refl] ], @@ -595,7 +614,7 @@ val model_L2 = { assume_tac ctxt, eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, hyp_subst_tac ctxt, - resolve_tac ctxt @{thms Sb_cong_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]]}, + resolve_tac ctxt @{thms Sb_cong_FType}, REPEAT_DETERM o assume_tac ctxt, rotate_tac ~2, dresolve_tac ctxt @{thms meta_spec}, @@ -607,6 +626,9 @@ val model_L2 = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; \ +ML \ +Multithreading.parallel_proofs := 0 +\ local_setup \fn lthy => let val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") model_L lthy; From 733330056c04e0e38832100dd460a64d20cc445c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 10 Mar 2025 10:52:29 +0000 Subject: [PATCH 24/90] Add initial bmv_monad facts (ie derived theorems) --- Tools/bmv_monad_def.ML | 167 +++++++++++++++++++++++++++++++++--- Tools/mrbnf_tvsubst.ML | 2 +- operations/BMV_Fixpoint.thy | 108 ++--------------------- operations/BMV_Monad.thy | 29 +++---- 4 files changed, 178 insertions(+), 128 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 8c4668f2..232e147f 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -19,6 +19,14 @@ signature BMV_MONAD_DEF = sig Vrs_Sbs: 'a option list list }; + type bmv_monad_facts = { + Inj_inj: thm list, + SSupp_Inj: thm list, + SSupp_Inj_bound: thm list, + SSupp_comp_subset: thm list, + SSupp_comp_bound: thm list + }; + type 'a bmv_monad_consts = { bd: term, params: { Map: term, Supps: term list} option list, @@ -67,6 +75,7 @@ signature BMV_MONAD_DEF = sig val Supps_of_bmv_monad: bmv_monad -> term list option list; val Vrs_of_bmv_monad: bmv_monad -> term option list 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 -> { axioms: thm supported_functor_axioms, Map_Sb: thm, @@ -85,7 +94,7 @@ signature BMV_MONAD_DEF = sig val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory val register_bnf_as_pbmv_monad: string -> local_theory -> local_theory val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) - -> (binding -> binding) -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory + -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list -> local_theory -> (bmv_monad * thm list) * local_theory @@ -133,6 +142,22 @@ fun apply_bmv_monad_axioms ({ Vrs_Sbs = map2 (map2 (@{map_option 2} (curry (op|>)))) Vrs_Sbs f7s } : 'b bmv_monad_axioms; +type bmv_monad_facts = { + Inj_inj: thm list, + SSupp_Inj: thm list, + SSupp_Inj_bound: thm list, + SSupp_comp_subset: thm list, + SSupp_comp_bound: thm list +}; + +fun morph_bmv_monad_facts phi { Inj_inj, SSupp_Inj, SSupp_Inj_bound, SSupp_comp_subset, SSupp_comp_bound } = { + Inj_inj = map (Morphism.thm phi) Inj_inj, + SSupp_Inj = map (Morphism.thm phi) SSupp_Inj, + SSupp_Inj_bound = map (Morphism.thm phi) SSupp_Inj_bound, + SSupp_comp_subset = map (Morphism.thm phi) SSupp_comp_subset, + SSupp_comp_bound = map (Morphism.thm phi) SSupp_comp_bound +}: bmv_monad_facts; + type 'a supported_functor_axioms = { Map_id: 'a, Map_comp: 'a, @@ -196,11 +221,13 @@ datatype bmv_monad = BMV of { consts: (term * thm) bmv_monad_consts, params: thm bmv_monad_param option list, bd_infinite_regular_card_order: thm, - axioms: thm bmv_monad_axioms list + axioms: thm bmv_monad_axioms list, + facts: bmv_monad_facts list } fun morph_bmv_monad phi (BMV { - ops, var_class, leader, frees, lives, lives', deads, consts, params, axioms, bd_infinite_regular_card_order + ops, var_class, leader, frees, lives, lives', deads, consts, params, axioms, bd_infinite_regular_card_order, + facts }) = BMV { ops = map (Morphism.typ phi) ops, leader = leader, @@ -212,6 +239,7 @@ fun morph_bmv_monad phi (BMV { consts = morph_bmv_monad_consts phi (map_prod (Morphism.term phi) (Morphism.thm 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 } @@ -232,6 +260,7 @@ 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 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 @@ -601,13 +630,37 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ [bd_def] @ flat param_defs); in (consts', map (Morphism.thm phi) defs, map (map (Option.map (Morphism.thm phi))) SSupp_defs, lthy) end; -fun mk_bmv_monad const_policy fact_policy SSupp_defs (model: thm bmv_monad_model) lthy = +fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = let - (* TODO: Derived theorems *) + val 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 + + val 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; + fun note_unless_dont_note (noted, lthy) = + let val notes = + [("Inj_inj", maps #Inj_inj facts, []), + ("SSupp_Inj", maps #SSupp_Inj facts, []), + ("SSupp_Inj_bound", maps #SSupp_Inj_bound facts, []), + ("SSupp_comp_subset", maps #SSupp_comp_subset facts, []), + ("SSupp_comp_bound", maps #SSupp_comp_bound facts, []) + ] |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true bmv_name (Binding.name thmN)), attrs), [(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 SSupp_defs bmv_b_opt (model: thm bmv_monad_model) lthy = + let val SSupp_defs = map2 (map2 (fn SOME def => K def | NONE => fn thm => @{thm eq_reflection} OF [the thm] )) SSupp_defs (#SSupp_eq model); + val consts = { bd = #bd (#consts model), params = #params (#consts model) @ maps (#params o #consts o Rep_bmv) (#bmv_ops model), @@ -616,6 +669,88 @@ fun mk_bmv_monad const_policy fact_policy SSupp_defs (model: thm bmv_monad_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) }; + val axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model); + val names = map (fst o dest_Free); + + val Inj_injs = map (map (fn Inj => + 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)); + val Vrs = the (List.find (fn a => domain_type (fastype_of a) = body_type (fastype_of Inj)) (map_filter I (flat (flat (#Vrs consts))))); + in 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 (map_filter I (flat (maps #Vrs_Injs axioms)))), + etac ctxt @{thm singleton_inject}, + hyp_subst_tac ctxt, + rtac ctxt refl + ]) end + )) (#Injs consts); + + val SSupp_Injs = map2 (map2 (fn Inj => fn (SSupp, SSupp_def) => + Goal.prove_sorry lthy [] [] (mk_Trueprop_eq (SSupp $ Inj, mk_bot (domain_type (fastype_of Inj)))) (fn {context=ctxt, ...} => EVERY [ + Local_Defs.unfold0_tac ctxt (SSupp_def :: @{thms HOL.simp_thms(6) not_True_eq_False empty_def}), + rtac ctxt @{thm TrueI} 1 + ]) + )) (#Injs consts) (#SSupps consts); + + val Un_bound = MRBNF_Def.get_class_assumption [#var_class model] "Un_bound" lthy; + + val SSupp_thms = map (split_list o map (fn (SSupp, SSupp_def) => + let + val gT = domain_type (fastype_of SSupp); + val aT = domain_type gT; + val ((f, g), _) = lthy + |> apfst hd o mk_Frees "f" [aT --> aT] + ||>> apfst hd o mk_Frees "g" [gT]; + val goal = HOLogic.mk_Trueprop (mk_leq + (SSupp $ HOLogic.mk_comp (g, f)) + (mk_Un (SSupp $ g, mk_supp f)) + ); + val comp_subset = Goal.prove_sorry lthy (names [f, g]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt @{thm subsetI}, + EqSubst.eqsubst_asm_tac ctxt [0] [SSupp_def], + EqSubst.eqsubst_tac ctxt [0] [SSupp_def], + K (Local_Defs.unfold0_tac ctxt @{thms mem_Collect_eq Un_iff comp_apply}), + rtac ctxt @{thm case_split}, + etac ctxt disjI2, + rtac ctxt disjI1, + dtac ctxt @{thm iffD1[OF arg_cong2[OF _ refl, of _ _ "(~=)"], rotated]}, + rtac ctxt (mk_arg_cong lthy 1 g), + etac ctxt @{thm notin_supp}, + assume_tac ctxt + ]); + fun mk_card_of_bound_UNIV t = HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of t) (mk_card_of (HOLogic.mk_UNIV (HOLogic.dest_setT (fastype_of t)))) + ); + val goal = Logic.mk_implies ( + mk_card_of_bound_UNIV (SSupp $ g), + Logic.mk_implies ( + mk_card_of_bound_UNIV (mk_supp f), + mk_card_of_bound_UNIV (SSupp $ HOLogic.mk_comp (g, f)) + ) + ); + val comp_bound = Goal.prove_sorry lthy (names [f, g]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + rtac ctxt @{thm card_of_subset_bound}, + rtac ctxt comp_subset, + rtac ctxt Un_bound, + assume_tac ctxt, + assume_tac ctxt + ]); + in (comp_subset, comp_bound) end + )) (#SSupps consts); + + val facts = @{map 3} (fn Inj_inj => fn SSupp_Inj => fn (SSupp_comp_subset, SSupp_comp_bound) => { + Inj_inj = Inj_inj, + SSupp_Inj = SSupp_Inj, + SSupp_Inj_bound = map (fn thm => @{thm card_of_subset_bound} OF [ + @{thm equalityD1} OF [thm], + @{thm emp_bound} + ]) SSupp_Inj, + SSupp_comp_subset = SSupp_comp_subset, + SSupp_comp_bound = SSupp_comp_bound + }: bmv_monad_facts) Inj_injs SSupp_Injs SSupp_thms; + val bmv = BMV { ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), var_class = #var_class model, @@ -626,9 +761,12 @@ fun mk_bmv_monad const_policy fact_policy SSupp_defs (model: thm bmv_monad_model deads = #deads model, consts = consts, params = #params model @ maps (#params o Rep_bmv) (#bmv_ops model), - axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model), + axioms = axioms, + facts = facts, bd_infinite_regular_card_order = #bd_infinite_regular_card_order model } : 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 SSupp_defs lthy = @@ -683,7 +821,7 @@ fun mk_thm_model (model: 'a bmv_monad_model) params axioms SSupp_eq bd_irco = { tacs = axioms } : thm bmv_monad_model; -fun bmv_monad_def const_policy fact_policy qualify (model: (Proof.context -> tactic) bmv_monad_model) lthy = +fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.context -> tactic) bmv_monad_model) lthy = let val frees = map (fn T => TFree (apsnd ( Sign.minimize_sort (Proof_Context.theory_of lthy) o cons (#var_class model) @@ -702,7 +840,7 @@ fun bmv_monad_def const_policy fact_policy qualify (model: (Proof.context -> tac )) (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 SSupp_eq bd_irco; - in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy SSupp_defs model lthy) end + in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt model lthy) end fun pbmv_monad_of_bnf bnf lthy = let @@ -715,7 +853,7 @@ fun pbmv_monad_of_bnf bnf lthy = val var_class = case BNF_Def.bd_of_bnf bnf of @{term natLeq} => @{class var} | _ => error "TODO: other var classes" - in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I { + in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I NONE { ops = [T], var_class = var_class, leader = 0, @@ -805,7 +943,8 @@ fun slice_bmv_monad n 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)] + axioms = [f (axioms_of_bmv_monad bmv)], + facts = [f (facts_of_bmv_monad bmv)] } end; fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = @@ -1074,7 +1213,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit [new_Injs] [new_Vrs] } : (Proof.context -> tactic) bmv_monad_model; - val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify model lthy + 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 lthy in (res, lthy) end; fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), bd) lthy = @@ -1089,7 +1231,6 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b map (fst o dest_funT) o fst o split_last o binder_types o fastype_of ) Sbs); val Injs = map (map (Syntax.read_term lthy)) Injs; - val _ = @{print} SSupps_opt val SSupps = case SSupps_opt of SOME SSupps => map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t))) SSupps | NONE => map (map (K NONE)) Injs; @@ -1235,7 +1376,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b tacs = axioms } : thm bmv_monad_model; - val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) SSupp_defs model lthy; + val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I SSupp_defs (SOME (Binding.name b)) model lthy; val lthy = register_pbmv_monad b bmv lthy; in lthy end; diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML index f758979b..eed4ecfd 100644 --- a/Tools/mrbnf_tvsubst.ML +++ b/Tools/mrbnf_tvsubst.ML @@ -1442,7 +1442,7 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l ("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), + (*("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), diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 1c45c777..5e7ef018 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -260,15 +260,6 @@ corollary permute_Sb: apply (rule Map_is_Sb) done -lemma Inj_inj: "Inj_FType_1 a = Inj_FType_1 b \ a = b" - apply (rule iffI) - apply (drule arg_cong[of _ _ Vrs_FType_1]) - apply (unfold Vrs_Inj_FType) - apply (erule singleton_inject) - apply hypsubst_thin - apply (rule refl) - done - lemma permute_Sb_FType: fixes f::"'tv::var \ 'tv" assumes "bij f" "|supp f| _FType_tvsubst_FType_def comp_def TyVar_def[symmetric])[2] - apply (rule card_of_subset_bound) - apply (rule subsetI) - apply (erule CollectE) - apply (erule contrapos_np) - apply (rule iffD2[OF Inj_inj]) - apply (erule iffD1[OF not_in_supp_alt]) + apply (rule FType.SSupp_comp_bound) + apply (rule FType.SSupp_Inj_bound) apply (rule assms) - prefer 2 + apply (rule FType.SSupp_comp_bound) + apply (rule assms supp_inv_bound)+ apply (rule arg_cong2[OF refl _, of _ _ "(\)"]) apply (subst Sb_comp_FType) prefer 3 @@ -293,87 +280,9 @@ lemma permute_Sb_FType: apply (rule assms) apply (rule refl) apply (rule assms) - apply (unfold SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def comp_def TyVar_def[symmetric])[2] - apply (rule card_of_subset_bound) - apply (rule subsetI) - apply (erule CollectE) - apply (erule contrapos_np) - apply (rule iffD2[OF Inj_inj]) - apply (erule iffD1[OF not_in_supp_alt]) - apply (rule supp_inv_bound) - apply (rule assms)+ - sorry - (*apply (rule ext) - apply (rule trans[OF _ comp_apply[symmetric]]) - subgoal for x - apply (subgoal_tac "|SSupp_FType (permute_FType f \ g \ inv f)| g \ inv f)" rule: FType.strong_induct) - apply (unfold IImsupp_FType_def)[1] - apply (rule FType.Un_bound) - apply (subst FType.SSupp_natural) - apply (rule assms)+ - apply (rule ordLeq_ordLess_trans[OF card_of_image]) - apply (rule assms) - apply (rule FType.UN_bound) - apply (subst FType.SSupp_natural) - apply (rule assms)+ - apply (rule ordLeq_ordLess_trans[OF card_of_image]) - apply (rule assms) - apply (unfold comp_def)[1] - apply (rule FType.set_bd_UNIV) - - apply (rule trans) - apply (rule FType.subst) - apply assumption - apply (unfold comp_def)[1] - apply (rule arg_cong[of _ _ "permute_FType _"]) - apply (rule sym) - apply (rule trans) - apply (subst FType.permute) - apply (rule assms bij_imp_bij_inv supp_inv_bound)+ - apply (rule FType.subst) - apply (rule assms) - apply (rule refl) - - apply (rule trans) - apply (rule FType.subst) - apply assumption - apply (subst FType.permute) - apply (rule assms bij_imp_bij_inv supp_inv_bound)+ - apply (unfold comp_def)[1] - apply (subst FType.subst) - apply (rule assms) - apply (subst FType.permute) - apply (rule assms)+ - apply (rule arg_cong2[of _ _ _ _ TyApp]) - apply assumption+ - - apply (rule trans) - apply (rule FType.subst) - apply assumption+ - apply (subst FType.permute) - apply (rule assms bij_imp_bij_inv supp_inv_bound)+ - apply (rule trans[OF _ comp_apply[symmetric]]) - apply (subst FType.subst) - apply (rule assms) - apply (subst (asm) FType.IImsupp_natural) - apply (rule assms)+ - apply (subst (asm) image_in_bij_eq) - apply (rule assms) - apply assumption - apply (subst FType.permute) - apply (rule assms)+ - apply (subst inv_simp2[of f]) - apply (rule assms) - apply (rule arg_cong2[of _ _ _ _ TyAll]) - apply (rule refl) - apply (unfold comp_def) - apply assumption - done - done*) + apply (rule FType.SSupp_comp_bound) + apply (rule FType.SSupp_Inj_bound assms supp_inv_bound)+ + done lemma Map_is_Sb_FTerm_pre: "map_FTerm_pre f1 f2 id id id id = Sb_FTerm_pre (id \ f2) (TyVar \ f1)" sorry @@ -384,7 +293,7 @@ lemma Map_Sb': fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" assumes "bij f1" "|supp f1| id a}| Inj_FType_1 a}| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre (f2 \ g1 \ inv f2) (permute_FType f1 \ g2 \ inv f1) \ map_FTerm_pre f1 f2 f3 f4 f5 f6" apply (rule trans) apply (rule trans) @@ -399,6 +308,7 @@ lemma Map_Sb': apply (rule trans) apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (tactic \resolve_tac @{context} [#Sb_comp laxioms] 1\) + apply (rule assms)+ apply (rule ext) apply (subgoal_tac "|SSupp_FType g2| ../Tools/bmv_monad_def.ML\ local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ -pbmv_monad ID: "'a" - Sbs: "id :: ('a \ 'a) \ 'a \ 'a" - Injs: "id :: 'a \ 'a" - SSupps: "supp :: ('a \ 'a) \ 'a set" - Vrs: "\(x::'a). {x}" +pbmv_monad ID: "'a::var" + Sbs: "id :: ('a \ 'a) \ 'a \ 'a::var" + Injs: "id :: 'a \ 'a::var" + SSupps: "supp :: ('a \ 'a) \ 'a::var set" + Vrs: "\(x::'a::var). {x}" bd: natLeq by (auto simp: ID.set_bd infinite_regular_card_order_natLeq supp_def) +print_theorems pbmv_monad "'a::var FType" Sbs: tvsubst_FType @@ -122,14 +123,15 @@ pbmv_monad "'a::var FType" apply (rule Vrs_Sb_FType; assumption) apply (rule Sb_cong_FType; assumption) done +print_theorems typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" by (rule UNIV_witness) -pbmv_monad "('a1, 'a2, 'c1, 'c2) L'" and 'a1 - Sbs: "\f x. Abs_L' (map_prod f (map_prod f id) (Rep_L' x))" and "id :: ('a1 \ 'a1) \ 'a1 \ 'a1" - Injs: "id :: 'a1 \ 'a1" and "id :: 'a1 \ 'a1" - Vrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1, x2}" and "\x. {x}" +pbmv_monad "('a1::var, 'a2, 'c1, 'c2) L'" and "'a1::var" + Sbs: "\f x. Abs_L' (map_prod (f::'a1::var \ 'a1) (map_prod f id) (Rep_L' x))" and "id :: ('a1 \ 'a1) \ 'a1 \ 'a1::var" + Injs: "id :: 'a1::var \ 'a1" and "id :: 'a1 \ 'a1::var" + Vrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1::'a1::var, x2}" and "\x. {x::'a1::var}" Map: "\f1 f2 x. Abs_L' (map_prod id (map_prod id (map_sum f1 f2)) (Rep_L' x))" Supps: "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setl y" "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setr y" bd: natLeq @@ -626,14 +628,11 @@ val model_L2 = { } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; \ -ML \ -Multithreading.parallel_proofs := 0 -\ local_setup \fn lthy => let - val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") model_L lthy; - val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") model_L1 lthy; - val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") model_L2 lthy; + val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") (SOME (Binding.name "L")) model_L lthy; + val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") (SOME (Binding.name "L1")) model_L1 lthy; + val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") (SOME (Binding.name "L2")) model_L2 lthy; val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [MRBNF_Util.Inl L1_bmv, MRBNF_Util.Inl L2_bmv] lthy val _ = @{print} comp_bmv From e2b7b935355436db5ffc6e8b0641d3a5f21e0613 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 11 Mar 2025 13:58:02 +0000 Subject: [PATCH 25/90] Add initial mrsbnf axiomatization --- Tools/bmv_monad_def.ML | 16 +- Tools/mrbnf_comp.ML | 2 + Tools/mrbnf_def.ML | 6 + Tools/mrbnf_tvsubst.ML | 2 +- Tools/mrsbnf_comp.ML | 10 + Tools/mrsbnf_def.ML | 547 ++++++++++++++++++++++++++++++++++++ Tools/pbmv_monad_comp.ML | 67 ----- operations/BMV_Fixpoint.thy | 58 ++-- operations/BMV_Monad.thy | 50 +++- 9 files changed, 662 insertions(+), 96 deletions(-) create mode 100644 Tools/mrsbnf_comp.ML create mode 100644 Tools/mrsbnf_def.ML delete mode 100644 Tools/pbmv_monad_comp.ML diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 232e147f..6e10d851 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -641,13 +641,19 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = val 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 lfacts = nth facts (leader_of_bmv_monad bmv); fun note_unless_dont_note (noted, lthy) = let val notes = - [("Inj_inj", maps #Inj_inj facts, []), - ("SSupp_Inj", maps #SSupp_Inj facts, []), - ("SSupp_Inj_bound", maps #SSupp_Inj_bound facts, []), - ("SSupp_comp_subset", maps #SSupp_comp_subset facts, []), - ("SSupp_comp_bound", maps #SSupp_comp_bound facts, []) + [ + ("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, []), + ("Inj_inj", #Inj_inj lfacts, []), + ("SSupp_Inj", #SSupp_Inj lfacts, []), + ("SSupp_Inj_bound", #SSupp_Inj_bound lfacts, []), + ("SSupp_comp_subset", #SSupp_comp_subset lfacts, []), + ("SSupp_comp_bound", #SSupp_comp_bound lfacts, []) ] |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true bmv_name (Binding.name thmN)), attrs), [(thms, [])])); in Local_Theory.notes notes lthy |>> append noted end val fact_policy = fact_policy lthy; diff --git a/Tools/mrbnf_comp.ML b/Tools/mrbnf_comp.ML index 6d146180..e0c5d83e 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 -> diff --git a/Tools/mrbnf_def.ML b/Tools/mrbnf_def.ML index 334aa94c..450fc026 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; diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML index eed4ecfd..05eec43c 100644 --- a/Tools/mrbnf_tvsubst.ML +++ b/Tools/mrbnf_tvsubst.ML @@ -1442,7 +1442,7 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l ("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),*) + ("SSupp_comp_bound_old", 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), diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML new file mode 100644 index 00000000..d976e68f --- /dev/null +++ b/Tools/mrsbnf_comp.ML @@ -0,0 +1,10 @@ +signature MRSBNF_COMP = sig + + val id_mrsbnf: MRSBNF_Def.mrsbnf +end + +structure MRSBNF_Comp : MRSBNF_COMP = struct + +val id_mrsbnf = the (MRSBNF_Def.mrsbnf_of @{context} "BMV_Monad.ID"); + +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..9de4f765 --- /dev/null +++ b/Tools/mrsbnf_def.ML @@ -0,0 +1,547 @@ +signature MRSBNF_DEF = sig + type mrsbnf + + type 'a mrsbnf_axioms = { + map_is_Sb: 'a, + map_Sb: 'a option, + set_Sb: 'a list + }; + + type mrsbnf_facts = { + SSupp_map_subset: thm list, + SSupp_map_bound: thm list, + map_Inj: thm list, + Sb_comp_right: thm, + map_Sb_strong: thm + }; + + val id_bmv_monad: BMV_Monad_Def.bmv_monad + val mk_id_bmv_monad: string * sort -> BMV_Monad_Def.bmv_monad + + 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 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; + + val pbmv_monad_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) + -> (string * sort) list -> (binding -> binding) -> typ -> (thm list * local_theory) + -> BMV_Monad_Def.bmv_monad option * (thm list * local_theory) +end + +structure MRSBNF_Def : MRSBNF_DEF = struct + +open MRBNF_Util + +type 'a mrsbnf_axioms = { + map_is_Sb: 'a, + map_Sb: 'a option, + set_Sb: 'a list +} + +fun map_mrsbnf_axioms (f:'a -> 'b) ({ map_is_Sb, map_Sb, set_Sb }: 'a mrsbnf_axioms) = { + map_is_Sb = f map_is_Sb, + map_Sb = Option.map f map_Sb, + 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 +}: ('a -> 'b) mrsbnf_axioms) ({ + map_is_Sb, map_Sb, set_Sb +}: 'a mrsbnf_axioms) = { + map_is_Sb = f1 map_is_Sb, + map_Sb = Option.map (fn t => the f2 t) map_Sb, + set_Sb = map2 (curry (op|>)) set_Sb f3s +}: 'b mrsbnf_axioms + +type mrsbnf_facts = { + SSupp_map_subset: thm list, + SSupp_map_bound: thm list, + map_Inj: thm list, + Sb_comp_right: thm, + map_Sb_strong: thm +} + +fun morph_mrsbnf_facts phi ({ + SSupp_map_subset, SSupp_map_bound, map_Inj, Sb_comp_right, map_Sb_strong +}: mrsbnf_facts) = { + SSupp_map_subset = map (Morphism.thm phi) SSupp_map_subset, + SSupp_map_bound = map (Morphism.thm phi) SSupp_map_bound, + map_Inj = map (Morphism.thm phi) map_Inj, + Sb_comp_right = Morphism.thm phi Sb_comp_right, + map_Sb_strong = Morphism.thm phi map_Sb_strong +}: 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 +} + +val id_bmv_monad = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID"); + +fun mk_id_bmv_monad free = BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism [(hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad), TFree free)] +) id_bmv_monad; + +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 bmv = + Local_Theory.declaration {syntax = false, pervasive = true, pos = Position.none} + (fn phi => Data.map (Symtab.update (name, morph_mrsbnf phi bmv))); + +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; + val 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; + + fun note_unless_dont_note (noted, lthy) = + let val notes = + [("map_is_Sb", map #map_is_Sb axioms, []), + ("set_Sb", maps #set_Sb axioms, []), + ("map_Sb'", maps (the_default [] o Option.map single o #map_Sb) axioms, []), + ("SSupp_map_subset", maps #SSupp_map_subset facts, []), + ("SSupp_map_bound", maps #SSupp_map_bound facts, []), + ("map_Inj", maps #map_Inj facts, []), + ("Sb_comp_right", map #Sb_comp_right facts, []), + ("map_Sb_strong", map #map_Sb_strong facts, []) + ] + |> filter_out (null o #2) + |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (short_type_name name) (Binding.name thmN)), attrs), [(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 names = map (fst o dest_Free); + val facts = @{map 7} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn SSupps => + 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 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 ((gs, aa), _) = lthy + |> mk_Frees "g" (map fastype_of Injs) + ||>> mk_Frees "a" (map (domain_type o fastype_of) Injs); + val frees = inter (op=) Fs (MRBNF_Def.frees_of_mrbnf mrbnf); + + val live = MRBNF_Def.live_of_mrbnf mrbnf; + + val g_prems = map2 (fn (SSupp, _) => fn g => HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (SSupp $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) + )) SSupps gs; + fun find_f T = List.find (fn f => T = domain_type (fastype_of f)) fs; + + val Sb_comp_right = + let + val fs' = map (the o find_f o domain_type o fastype_of) gs; + val f'_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) fs'; + val goal = mk_Trueprop_eq ( + Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) gs fs'), + HOLogic.mk_comp ( + Term.list_comb (Sb, gs), Term.list_comb (mapx, map (fn T => case find_f (domain_type T) of + SOME f => f | NONE => HOLogic.id_const (domain_type T) + ) (fst (split_last (binder_types (fastype_of mapx))))) + ) + ); + in Goal.prove_sorry lthy (names (fs' @ gs)) (f'_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt (#Sb_comp bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt refl + ]) end; + + val map_Inj = @{map 3} (fn Inj => fn f => fn a => + let val goal = mk_Trueprop_eq (Term.list_comb (mapx, fs) $ (Inj $ a), Inj $ (f $ a)) + in Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt trans, + rtac ctxt (#map_is_Sb axioms RS fun_cong), + REPEAT_DETERM o resolve_tac ctxt prems, + 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 (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + rtac ctxt @{thm comp_apply} + ]) end + ) Injs free_fs aa; + + val SSupp_map_subset = @{map 3} (fn (SSupp, SSupp_def) => fn g => fn g_prem => + let + val map_t = Term.list_comb (mapx, fs); + val goal = HOLogic.mk_Trueprop (uncurry mk_leq ( + SSupp $ HOLogic.mk_comp (map_t, g), + mk_Un (SSupp $ g, mk_supp (the (find_f (HOLogic.dest_setT (body_type (fastype_of SSupp)))))) + )); + in 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] [SSupp_def], + EqSubst.eqsubst_asm_tac ctxt [0] [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_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 + ) SSupps gs g_prems; + + val Un_bound = MRBNF_Def.get_class_assumption [BMV_Monad_Def.var_class_of_bmv_monad bmv] "Un_bound" lthy; + + val SSupp_map_bound = @{map 4} (fn (SSupp, _) => fn g => fn g_prem => fn thm => + let val goal = HOLogic.mk_Trueprop (uncurry mk_ordLess ( + mk_card_of (SSupp $ 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 + ) SSupps gs g_prems SSupp_map_subset; + + 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 Inj)) mrbnfs) + ) Injs; + val goal = mk_Trueprop_eq ( + HOLogic.mk_comp (map_t, Term.list_comb (Sb, gs)), + HOLogic.mk_comp (Term.list_comb (Sb, @{map 3} (fn f => 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 (fn T => + the (List.find (curry (op=) T o fastype_of) fs) + ) (fst (split_last (binder_types (fastype_of mapx))))), + g), mk_inv f + ) end + ) (take (length gs) free_fs) gs mrbnfs), map_t) + ); + val f_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) fs; + in Goal.prove_sorry lthy (names (fs @ gs)) (f_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + if live + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.free_of_mrbnf mrbnf - length frees = 0 then K all_tac else EVERY' [ + (* TODO: split map in two *) + ], + EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt trans, + rtac ctxt (#Sb_comp bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map (fn ax => #map_is_Sb ax RS sym) axioms'), + REPEAT_DETERM o resolve_tac ctxt prems + ], + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt (Sb_comp_right RS sym), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound} @ SSupp_map_bound @ prems @ #SSupp_comp_bound bmv_facts), + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] @{thms inv_o_simp1}, + resolve_tac ctxt prems + ], + K (Local_Defs.unfold0_tac ctxt @{thms o_id}), + rtac ctxt refl + ]) end + in { + SSupp_map_subset = SSupp_map_subset, + SSupp_map_bound = SSupp_map_bound, + map_Inj = map_Inj, + Sb_comp_right = Sb_comp_right, + map_Sb_strong = map_Sb_strong + } end + ) axioms' mrbnfs (BMV_Monad_Def.axioms_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.SSupps_of_bmv_monad bmv); + + val mrsbnf = MRSBNF { + mrbnfs = mrbnfs, + pbmv_monad = bmv, + axioms = axioms', + facts = facts + }; + + val (_, lthy) = note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy; + in (mrsbnf, lthy) end; + +fun mk_mrsbnf_axioms mrbnfs bmv lthy = + let + val leader = BMV_Monad_Def.leader_of_bmv_monad bmv; + val lmrbnf = nth mrbnfs leader; + val (((((Fs, Bs), As), As'), deads), names_lthy) = 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 (MRBNF_Def.live_of_mrbnf lmrbnf) + ||>> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.deads_of_mrbnf lmrbnf)); + + 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)); + + local + val mapx = MRBNF_Def.mk_map_of_mrbnf deads As As Bs Fs lmrbnf; + val Sb = the_default (nth (BMV_Monad_Def.Sbs_of_bmv_monad bmv) leader) (nth (BMV_Monad_Def.Maps_of_bmv_monad bmv) leader); + + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy) + ) [apply2 (snd o split_last o binder_types o fastype_of) (Sb, mapx), apply2 (body_type o fastype_of) (Sb, mapx)] Vartab.empty; + + val phi = Morphism.morphism "subst types" { + binding = [], fact = [], + typ = [K (Envir.subst_type tyenv)], + term = [K (Envir.subst_term (tyenv, Vartab.empty))] + } + in + val bmv = BMV_Monad_Def.morph_bmv_monad phi bmv; + + val mrbnfs = map2 (fn mrbnf => fn T => + let + val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (MRBNF_Def.T_of_mrbnf mrbnf, T) Vartab.empty; + val phi = Morphism.morphism "subst types" { + binding = [], fact = [], + typ = [K (Envir.subst_type tyenv)], + term = [K (Envir.subst_term (tyenv, Vartab.empty))] + }; + in MRBNF_Def.morph_mrbnf phi mrbnf end + ) mrbnfs (BMV_Monad_Def.ops_of_bmv_monad bmv); + end + + val axioms = @{map 3} (fn mrbnf => fn Sb => fn Injs => + 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 (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 (fn f => HOLogic.mk_Trueprop (mk_supp_bound f)) free_fs; + + val map_is_Sb = fold_rev Logic.all free_fs (fold_rev (curry Logic.mk_implies) free_prems (mk_Trueprop_eq ( + Term.list_comb (mapx, MRBNF_Def.interlace + (map HOLogic.id_const As) (map HOLogic.id_const Bs) (free_fs @ map HOLogic.id_const (drop (length frees) Fs)) + (MRBNF_Def.var_types_of_mrbnf mrbnf) + ), + Term.list_comb (Sb, map (fn Inj => + HOLogic.mk_comp (Inj, the (List.find (fn f => (op=) (apply2 (domain_type o fastype_of) (Inj, f))) fs)) + ) Injs) + ))); + + val ((gs, x), _) = names_lthy + |> mk_Frees "g" (map fastype_of Injs) + ||>> apfst hd o mk_Frees "x" [body_type (fastype_of Sb)]; + + val live = MRBNF_Def.live_of_mrbnf mrbnf; + val pfree_fs = drop free free_fs'; + 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 free [] @ map (fn f => [HOLogic.mk_Trueprop (mk_supp_bound f)]) pfree_fs) + var_types + ); + val other_fs = flat (MRBNF_Def.interlace (replicate live []) (map single bound_fs) + (replicate free [] @ map single pfree_fs) var_types); + + val map_Sb = if null (Bs @ As @ pfrees) then NONE else + let + val map_t = Term.list_comb (mapx, MRBNF_Def.interlace live_fs bound_fs (map HOLogic.id_const frees @ pfree_fs) var_types); + val Sb_t = Term.list_comb (Sb, gs); + in SOME (fold_rev Logic.all other_fs (fold_rev (curry Logic.mk_implies) other_prems (mk_Trueprop_eq ( + HOLogic.mk_comp (map_t, Sb_t), + HOLogic.mk_comp (Sb_t, 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 sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) + (replicate free [] @ map single (drop free free_sets)) var_types); + + val set_Sbs = map (fn set => mk_Trueprop_eq (set $ (Term.list_comb (Sb, gs) $ x), set $ x)) sets'; + in { + map_is_Sb = map_is_Sb, + map_Sb = map_Sb, + set_Sb = set_Sbs + }: term mrsbnf_axioms end + ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_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; + 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 pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x + then (NONE, accum) else (SOME (mk_id_bmv_monad x), accum) + | pbmv_monad_of_typ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" + | pbmv_monad_of_typ optim const_policy inline_policy xs qualify' (T as Type (n, Ts)) (accum, lthy) = + let val (bmv_opt, lthy) = case BMV_Monad_Def.pbmv_monad_of lthy n of + SOME bmv => (SOME bmv, lthy) + | NONE => case BNF_Def.bnf_of lthy n of + SOME bnf => + let val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf bnf lthy + in (SOME bmv, BMV_Monad_Def.register_pbmv_monad n bmv lthy) end + | NONE => (NONE, lthy); + in case bmv_opt of + NONE => (NONE, (accum, lthy)) + | SOME bmv => if null (BMV_Monad_Def.lives_of_bmv_monad bmv) then + let val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv) + in (SOME (BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( + rev (map TFree (Term.add_tfreesT T []) @ map TVar (Term.add_tvarsT T [])) ~~ Ts + )) bmv), (accum, lthy)) 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 leader = BMV_Monad_Def.leader_of_bmv_monad bmv; + val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) leader; + val bmv = BMV_Monad_Def.morph_bmv_monad ( + MRBNF_Util.subst_typ_morphism (snd (dest_Type T) ~~ Ts) + ) bmv; + val bmv = BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( + BMV_Monad_Def.lives'_of_bmv_monad bmv ~~ BMV_Monad_Def.lives_of_bmv_monad bmv + )) bmv; + val live_Ts = BMV_Monad_Def.lives_of_bmv_monad bmv; + + val qualifies = map qualify (1 upto length live_Ts); + val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy xs) qualifies live_Ts (accum, lthy) + val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) live_Ts bmv_opts; + in if exists Option.isSome bmv_opts then + let val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) bmv bmvs lthy; + in (SOME bmv, (unfold_set @ accum, lthy)) end + else + (NONE, (accum, lthy)) + end + end; + +fun mrsbnf_cmd (b, Ts) lthy = + let + val Ts = map (Syntax.read_typ lthy) Ts; + val name = if Binding.is_empty b then fst (dest_Type (hd Ts)) else Binding.name_of b; + val (mrbnfs, lthy) = fold_map (fn T => fn lthy => + let val name = fst (dest_Type T); + in case MRBNF_Def.mrbnf_of lthy name of + SOME mrbnf => (mrbnf, lthy) + | NONE => case BNF_Def.bnf_of lthy name of + SOME bnf => MRBNF_Def.mrbnf_of_bnf bnf lthy + | NONE => error ("Type " ^ name ^ " is not a (MR)BNF") + end + ) Ts lthy; + val bmv_monad = case BMV_Monad_Def.pbmv_monad_of lthy name of + SOME bmv => bmv + | NONE => error ("Type " ^ name ^ " is not a PBMV Monad") + + 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 (SOME _) thms = (SOME (hd thms), tl thms) + + val axioms = fst (fold_map (fn goals => fn thms => + let val (((map_is_Sb, map_Sb), set_Sb), thms) = thms + |> apfst hd o chop 1 + ||>> chop_opt (#map_Sb goals) + ||>> chop (length (#set_Sb goals)) + in ({ + map_is_Sb = map_is_Sb, + map_Sb = map_Sb, + 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 = 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)) @ #set_Sb goals + ) goals)) lthy end + +val _ = Outer_Syntax.local_theory_to_proof @{command_keyword mrsbnf} + "register a map-restricted substitutive bounded natural functor" + ((parse_opt_binding_colon -- Parse.and_list1 Parse.typ) >> mrsbnf_cmd) + +end \ No newline at end of file diff --git a/Tools/pbmv_monad_comp.ML b/Tools/pbmv_monad_comp.ML deleted file mode 100644 index 879f38a2..00000000 --- a/Tools/pbmv_monad_comp.ML +++ /dev/null @@ -1,67 +0,0 @@ -signature PBMV_MONAD_COMP = sig - - val id_bmv_monad: BMV_Monad_Def.bmv_monad - val mk_id_bmv_monad: string * sort -> BMV_Monad_Def.bmv_monad - - val pbmv_monad_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) - -> (string * sort) list -> (binding -> binding) -> typ -> (thm list * local_theory) - -> BMV_Monad_Def.bmv_monad option * (thm list * local_theory) -end - -structure PBMV_Monad_Comp : PBMV_MONAD_COMP = struct - -open MRBNF_Util - -val id_bmv_monad = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID"); - -fun mk_id_bmv_monad free = BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism [(hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad), TFree free)] -) id_bmv_monad; - -fun pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x - then (NONE, accum) else (SOME (mk_id_bmv_monad x), accum) - | pbmv_monad_of_typ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" - | pbmv_monad_of_typ optim const_policy inline_policy xs qualify' (T as Type (n, Ts)) (accum, lthy) = - let val (bmv_opt, lthy) = case BMV_Monad_Def.pbmv_monad_of lthy n of - SOME bmv => (SOME bmv, lthy) - | NONE => case BNF_Def.bnf_of lthy n of - SOME bnf => - let val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf bnf lthy - in (SOME bmv, BMV_Monad_Def.register_pbmv_monad n bmv lthy) end - | NONE => (NONE, lthy); - in case bmv_opt of - NONE => (NONE, (accum, lthy)) - | SOME bmv => if null (BMV_Monad_Def.lives_of_bmv_monad bmv) then - let val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv) - in (SOME (BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( - rev (map TFree (Term.add_tfreesT T []) @ map TVar (Term.add_tvarsT T [])) ~~ Ts - )) bmv), (accum, lthy)) 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 leader = BMV_Monad_Def.leader_of_bmv_monad bmv; - val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) leader; - val bmv = BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism (snd (dest_Type T) ~~ Ts) - ) bmv; - val bmv = BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.lives'_of_bmv_monad bmv ~~ BMV_Monad_Def.lives_of_bmv_monad bmv - )) bmv; - val live_Ts = BMV_Monad_Def.lives_of_bmv_monad bmv; - - val qualifies = map qualify (1 upto length live_Ts); - val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy xs) qualifies live_Ts (accum, lthy) - val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) live_Ts bmv_opts; - in if exists Option.isSome bmv_opts then - let val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) bmv bmvs lthy; - in (SOME bmv, (unfold_set @ accum, lthy)) end - else - (NONE, (accum, lthy)) - end - end; - -end \ No newline at end of file diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 5e7ef018..6a9bf407 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -210,6 +210,7 @@ pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v: apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) done +print_theorems print_pbmv_monads lemma set1_Vrs: "set1_FTerm_pre x = Vrs2_FTerm_pre x" @@ -286,45 +287,58 @@ lemma permute_Sb_FType: lemma Map_is_Sb_FTerm_pre: "map_FTerm_pre f1 f2 id id id id = Sb_FTerm_pre (id \ f2) (TyVar \ f1)" sorry +lemma Map_is_Sb_ID: "id f1 = id (id \ f1)" + by simp - +lemma Map_Sb: + fixes f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" + assumes "bij f3" "|supp f3| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre g1 g2 \ map_FTerm_pre id id f3 f4 f5 f6" + sorry lemma Map_Sb': fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" assumes "bij f1" "|supp f1| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre (f2 \ g1 \ inv f2) (permute_FType f1 \ g2 \ inv f1) \ map_FTerm_pre f1 f2 f3 f4 f5 f6" - apply (rule trans) + shows "map_FTerm_pre f1 f2 f3 f4 f5 f6 \ Sb_FTerm_pre g1 g2 = Sb_FTerm_pre (id f2 \ g1 \ inv f2) (permute_FType f1 \ g2 \ inv f1) \ map_FTerm_pre f1 f2 f3 f4 f5 f6" apply (rule trans) apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) apply (rule trans) prefer 2 - apply (rule FTerm_pre.map_comp0[of f1 f2 id id id id f3 f4 _ id _ id]) + apply (rule FTerm_pre.map_comp0[of id id f3 f4 f1 f2 id id id _ id]) apply (rule assms bij_id supp_id_bound)+ apply (unfold id_o o_id) apply (rule refl) apply (unfold comp_assoc Map_is_Sb_FTerm_pre)[1] apply (rule trans) apply (rule arg_cong2[OF refl, of _ _ "(\)"]) - apply (tactic \resolve_tac @{context} [#Sb_comp laxioms] 1\) - apply (rule assms)+ - - apply (rule ext) - apply (subgoal_tac "|SSupp_FType g2| _FType_tvsubst_FType_def comp_def TyVar_def[symmetric])[1] - apply (rule assms) - apply (tactic \Local_Defs.unfold0_tac @{context} @{thms - comp_apply map_FTerm_pre_def bmv_defs Sb_FTerm_pre_def Abs_FTerm_pre_inverse[OF UNIV_I] o_id id_apply - sum.map_comp prod.map_comp - }\) - apply (subst permute_Sb_FType, (rule assms | assumption)+)+ - apply (unfold comp_def) - apply (unfold sum.map_comp id_apply prod.map_comp comp_def) - apply (subst inv_simp1, rule assms)+ - apply (subst FType.vvsubst_permute FType.permute_comp inv_o_simp1, (rule assms bij_imp_bij_inv supp_inv_bound)+)+ - apply (unfold FType.permute_id) + apply (rule trans) + apply (rule Map_Sb) + apply (rule assms)+ + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule trans) + apply (rule ext) + apply (rule FTerm_pre.map_cong0[rotated -6]) + apply ((rule inv_o_simp1[symmetric, THEN fun_cong], rule assms) | rule id_o[symmetric, THEN fun_cong, of f3] id_o[symmetric, THEN fun_cong, of f4] id_o[symmetric, THEN fun_cong, of f5] id_o[symmetric, THEN fun_cong, of f6])+ + apply (rule assms supp_id_bound bij_id supp_comp_bound supp_inv_bound infinite_UNIV bij_comp)+ + apply (rule FTerm_pre.map_comp0) + apply (rule assms supp_id_bound bij_id supp_inv_bound)+ + apply (rule trans[OF comp_assoc[symmetric]]) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (subst Map_is_Sb_FTerm_pre) + apply (rule FTerm_pre.Sb_comp) + apply (rule FTerm_pre.SSupp_comp_bound FTerm_pre.SSupp_Inj_bound supp_inv_bound assms)+ + apply (unfold comp_assoc[symmetric]) + apply (subst FTerm_pre.Sb_comp_Inj, rule assms)+ + apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) + apply (rule trans) + apply (rule FTerm_pre.Sb_comp) + apply (rule FTerm_pre.SSupp_comp_bound FTerm_pre.SSupp_Inj_bound supp_inv_bound assms)+ + apply (unfold comp_assoc[symmetric]) + apply (subst permute_Sb[symmetric] Map_is_Sb_ID[symmetric], ((rule assms)+)?)+ apply (rule refl) done diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index bc637e60..3cabf41a 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -1,7 +1,8 @@ theory BMV_Monad imports "Binders.MRBNF_Recursor" keywords "print_pbmv_monads" :: diag and - "pbmv_monad" :: thy_goal + "pbmv_monad" :: thy_goal and + "mrsbnf" :: thy_goal begin declare [[mrbnf_internals]] @@ -92,6 +93,30 @@ using assms(3) proof (binder_induction t avoiding: "IImsupp_FType \''" "IIm by (smt (verit, ccfv_threshold) CollectI IImsupp_FType_def SSupp_FType_def Un_iff) qed (auto simp: assms(1-2)) +lemma map_is_Sb_FType: + fixes f::"'tyvar::var \ 'tyvar" + assumes "|supp f| f)" + apply (rule ext) + subgoal for x + proof (binder_induction x avoiding: "imsupp f" rule: FType.strong_induct) + case Bound + then show ?case using imsupp_supp_bound infinite_UNIV assms by blast + next + case (TyAll x1 x2) + then have 1: "x1 \ SSupp_FType (Inj_FType_1 \ f)" + by (simp add: SSupp_FType_def VVr_eq_Var not_in_imsupp_same) + then have "x1 \ IImsupp_FType (Inj_FType_1 \ f)" + unfolding IImsupp_FType_def Un_iff de_Morgan_disj + apply (rule conjI) + apply (insert 1) + apply (erule contrapos_nn) + apply (erule UN_E) + by (metis FType.set(1) TyAll.fresh comp_apply in_imsupp not_in_imsupp_same singletonD) + then show ?case using assms TyAll by (auto simp: FType.SSupp_comp_bound_old) + qed (auto simp: FType.SSupp_comp_bound_old assms) + done + declare [[ML_print_depth=1000]] ML_file \../Tools/bmv_monad_def.ML\ @@ -107,6 +132,24 @@ pbmv_monad ID: "'a::var" by (auto simp: ID.set_bd infinite_regular_card_order_natLeq supp_def) print_theorems +ML_file \../Tools/mrsbnf_def.ML\ + +local_setup \fn lthy => +let + val (id_mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I [MRBNF_Def.Free_Var] MRBNF_Comp.ID_mrbnf ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy) + val (id_mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Note_Some) I (SOME "BMV_Monad.ID") [id_mrbnf] + (the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.ID")) [{ + map_Sb = NONE, + map_is_Sb = fn ctxt => EVERY [ + Local_Defs.unfold0_tac ctxt @{thms id_def comp_def BNF_Composition.id_bnf_def}, + resolve_tac ctxt [refl] 1 + ], + set_Sb = [] + }] lthy; + val lthy = MRSBNF_Def.register_mrsbnf "BMV_Monad.ID" id_mrsbnf lthy +in lthy end +\ + pbmv_monad "'a::var FType" Sbs: tvsubst_FType Injs: TyVar @@ -125,6 +168,11 @@ pbmv_monad "'a::var FType" done print_theorems +mrsbnf "'a::var FType" + apply (rule map_is_Sb_FType; assumption) + done +print_theorems + typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" by (rule UNIV_witness) From cad2531eafd8d06bfc83b198f4a674fe46a7010b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 12 Mar 2025 10:10:15 +0000 Subject: [PATCH 26/90] Fix mrsbnf tactics when mrbnf has more than just frees --- Tools/bmv_monad_def.ML | 11 +- Tools/mrsbnf_def.ML | 270 ++++++++++++++++++++++++------------ operations/BMV_Fixpoint.thy | 258 +++++++++++----------------------- operations/BMV_Monad.thy | 30 ++-- 4 files changed, 280 insertions(+), 289 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 6e10d851..e4059ae3 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -91,6 +91,8 @@ signature BMV_MONAD_DEF = sig val pbmv_monad_of_generic: Context.generic -> string -> bmv_monad option; val pbmv_monad_of: Proof.context -> string -> bmv_monad option; + val id_mrbnf: MRBNF_Def.mrbnf; + val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory val register_bnf_as_pbmv_monad: string -> local_theory -> local_theory val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) @@ -104,6 +106,8 @@ structure BMV_Monad_Def : BMV_MONAD_DEF = struct open MRBNF_Util +val id_mrbnf = the (MRBNF_Def.mrbnf_of @{context} "BMV_Monad.ID"); + type 'a bmv_monad_axioms = { Sb_Inj: 'a, Sb_comp_Injs: 'a list, @@ -642,6 +646,8 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = val axioms = axioms_of_bmv_monad bmv; val facts = facts_of_bmv_monad bmv; val lfacts = nth facts (leader_of_bmv_monad bmv); + val params = params_of_bmv_monad bmv; + fun note_unless_dont_note (noted, lthy) = let val notes = [ @@ -649,12 +655,15 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("Sb_comp_Inj", maps #Sb_comp_Injs axioms, []), ("Sb_comp", map #Sb_comp axioms, []), ("Sb_cong", map #Sb_cong axioms, []), + ("Map_Sb", map_filter (Option.map #Map_Sb) params, []), ("Inj_inj", #Inj_inj lfacts, []), ("SSupp_Inj", #SSupp_Inj lfacts, []), ("SSupp_Inj_bound", #SSupp_Inj_bound lfacts, []), ("SSupp_comp_subset", #SSupp_comp_subset lfacts, []), ("SSupp_comp_bound", #SSupp_comp_bound lfacts, []) - ] |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true bmv_name (Binding.name thmN)), attrs), [(thms, [])])); + ] + |> filter_out (null o #2) + |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true bmv_name (Binding.name thmN)), attrs), [(thms, [])])); in Local_Theory.notes notes lthy |>> append noted end val fact_policy = fact_policy lthy; in ([], lthy) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 9de4f765..617f078c 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -8,9 +8,9 @@ signature MRSBNF_DEF = sig }; type mrsbnf_facts = { - SSupp_map_subset: thm list, - SSupp_map_bound: thm list, - map_Inj: thm list, + SSupp_map_subset: thm option list, + SSupp_map_bound: thm option list, + map_Inj: thm option list, Sb_comp_right: thm, map_Sb_strong: thm }; @@ -67,9 +67,9 @@ fun apply_mrsbnf_axioms ({ }: 'b mrsbnf_axioms type mrsbnf_facts = { - SSupp_map_subset: thm list, - SSupp_map_bound: thm list, - map_Inj: thm list, + SSupp_map_subset: thm option list, + SSupp_map_bound: thm option list, + map_Inj: thm option list, Sb_comp_right: thm, map_Sb_strong: thm } @@ -77,9 +77,9 @@ type mrsbnf_facts = { fun morph_mrsbnf_facts phi ({ SSupp_map_subset, SSupp_map_bound, map_Inj, Sb_comp_right, map_Sb_strong }: mrsbnf_facts) = { - SSupp_map_subset = map (Morphism.thm phi) SSupp_map_subset, - SSupp_map_bound = map (Morphism.thm phi) SSupp_map_bound, - map_Inj = map (Morphism.thm phi) map_Inj, + SSupp_map_subset = map (Option.map (Morphism.thm phi)) SSupp_map_subset, + SSupp_map_bound = map (Option.map (Morphism.thm phi)) SSupp_map_bound, + map_Inj = map (Option.map (Morphism.thm phi)) map_Inj, Sb_comp_right = Morphism.thm phi Sb_comp_right, map_Sb_strong = Morphism.thm phi map_Sb_strong }: mrsbnf_facts @@ -143,9 +143,9 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = [("map_is_Sb", map #map_is_Sb axioms, []), ("set_Sb", maps #set_Sb axioms, []), ("map_Sb'", maps (the_default [] o Option.map single o #map_Sb) axioms, []), - ("SSupp_map_subset", maps #SSupp_map_subset facts, []), - ("SSupp_map_bound", maps #SSupp_map_bound facts, []), - ("map_Inj", maps #map_Inj facts, []), + ("SSupp_map_subset", maps (map_filter I o #SSupp_map_subset) facts, []), + ("SSupp_map_bound", maps (map_filter I o #SSupp_map_bound) facts, []), + ("map_Inj", maps (map_filter I o #map_Inj) facts, []), ("Sb_comp_right", map #Sb_comp_right facts, []), ("map_Sb_strong", map #map_Sb_strong facts, []) ] @@ -160,11 +160,12 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs bmv axioms' lthy = let val names = map (fst o dest_Free); - val facts = @{map 7} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn SSupps => + val facts' = @{map 7} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn SSupps => 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 => [] @@ -173,10 +174,12 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ) fs var_types)); val (live_fs, bound_fs, free_fs) = MRBNF_Def.deinterlace fs var_types; - val ((gs, aa), _) = lthy + val (((gs, aa), x), _) = lthy |> mk_Frees "g" (map fastype_of Injs) - ||>> mk_Frees "a" (map (domain_type o 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; @@ -189,14 +192,15 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b let val fs' = map (the o find_f o domain_type o fastype_of) gs; val f'_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) fs'; - val goal = mk_Trueprop_eq ( + val goal = Term.subst_atomic_types (As' ~~ As) (mk_Trueprop_eq ( Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) gs fs'), HOLogic.mk_comp ( - Term.list_comb (Sb, gs), Term.list_comb (mapx, map (fn T => case find_f (domain_type T) of + Term.list_comb (Sb, gs), + Term.list_comb (mapx, map (fn T => case List.find (fn f => (domain_type T) = domain_type (fastype_of f)) fs' of SOME f => f | NONE => HOLogic.id_const (domain_type T) ) (fst (split_last (binder_types (fastype_of mapx))))) ) - ); + )); in Goal.prove_sorry lthy (names (fs' @ gs)) (f'_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], REPEAT_DETERM o resolve_tac ctxt prems, @@ -205,14 +209,16 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt (#Sb_comp bmv_axioms), REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), - EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), - REPEAT_DETERM o resolve_tac ctxt prems, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), + REPEAT_DETERM o resolve_tac ctxt prems + ], rtac ctxt refl ]) end; - val map_Inj = @{map 3} (fn Inj => fn f => fn a => + val map_Inj = @{map 3} (fn Inj => fn f => fn a => if body_type (fastype_of Inj) <> T then NONE else let val goal = mk_Trueprop_eq (Term.list_comb (mapx, fs) $ (Inj $ a), Inj $ (f $ a)) - in Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ + in SOME (Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ rtac ctxt trans, rtac ctxt (#map_is_Sb axioms RS fun_cong), REPEAT_DETERM o resolve_tac ctxt prems, @@ -220,39 +226,42 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), rtac ctxt @{thm comp_apply} - ]) end + ])) end ) Injs free_fs aa; val SSupp_map_subset = @{map 3} (fn (SSupp, SSupp_def) => fn g => fn g_prem => let val map_t = Term.list_comb (mapx, fs); + val SSupp' = Term.subst_atomic_types (As' ~~ As') SSupp; val goal = HOLogic.mk_Trueprop (uncurry mk_leq ( - SSupp $ HOLogic.mk_comp (map_t, g), + SSupp' $ HOLogic.mk_comp (map_t, g), mk_Un (SSupp $ g, mk_supp (the (find_f (HOLogic.dest_setT (body_type (fastype_of SSupp)))))) )); - in 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] [SSupp_def], - EqSubst.eqsubst_asm_tac ctxt [0] [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_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 + in if body_type (fastype_of map_t) <> body_type (domain_type (fastype_of SSupp')) 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] [SSupp_def], + EqSubst.eqsubst_asm_tac ctxt [0] [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 ) SSupps gs g_prems; val Un_bound = MRBNF_Def.get_class_assumption [BMV_Monad_Def.var_class_of_bmv_monad bmv] "Un_bound" lthy; - val SSupp_map_bound = @{map 4} (fn (SSupp, _) => fn g => fn g_prem => fn thm => + val SSupp_map_bound = @{map 4} (fn (SSupp, _) => fn g => fn g_prem => Option.map (fn thm => let val goal = HOLogic.mk_Trueprop (uncurry mk_ordLess ( mk_card_of (SSupp $ HOLogic.mk_comp (Term.list_comb (mapx, fs), g)), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) @@ -264,7 +273,37 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt Un_bound, REPEAT_DETERM o resolve_tac ctxt prems ]) end - ) SSupps gs g_prems SSupp_map_subset; + )) SSupps gs g_prems SSupp_map_subset; + in { + SSupp_map_subset = SSupp_map_subset, + SSupp_map_bound = SSupp_map_bound, + map_Inj = map_Inj, + Sb_comp_right = Sb_comp_right + } end + ) axioms' mrbnfs (BMV_Monad_Def.axioms_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.SSupps_of_bmv_monad bmv); + + val facts' = @{map 8} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn SSupps => + 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 (((gs, aa), x), _) = lthy + |> 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 (SSupp, _) => fn g => HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (SSupp $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) + )) SSupps gs; val map_Sb_strong = let @@ -272,22 +311,47 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b val mrbnfs = map (fn Inj => the (List.find (fn mrbnf => body_type (fastype_of (MRBNF_Def.map_of_mrbnf mrbnf)) = body_type (fastype_of Inj)) mrbnfs) ) Injs; + fun find_f T = List.find (curry (op=) T o domain_type o fastype_of) fs; val goal = mk_Trueprop_eq ( HOLogic.mk_comp (map_t, Term.list_comb (Sb, gs)), - HOLogic.mk_comp (Term.list_comb (Sb, @{map 3} (fn f => fn g => fn mrbnf => + HOLogic.mk_comp (Term.list_comb (Term.subst_atomic_types (As ~~ As') Sb, 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 (fn T => - the (List.find (curry (op=) T o fastype_of) fs) - ) (fst (split_last (binder_types (fastype_of mapx))))), - g), mk_inv f + 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 - ) (take (length gs) free_fs) gs mrbnfs), map_t) + ) gs mrbnfs), map_t) ); - val f_prems = maps (fn f => map HOLogic.mk_Trueprop [mk_bij f, mk_supp_bound f]) fs; + + 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 + MRBNF_Def.free_of_mrbnf mrbnf - length frees; in Goal.prove_sorry lthy (names (fs @ gs)) (f_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ - if live + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.free_of_mrbnf mrbnf - length frees = 0 then K all_tac else EVERY' [ - (* TODO: split map in two *) + if count = 0 then K all_tac else EVERY' [ + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt trans, + K (prefer_tac 2), + rtac ctxt (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 => [HOLogic.id_const (body_type (fastype_of f)), f]) live_fs) + ) (MRBNF_Def.map_comp0_of_mrbnf mrbnf)), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + rtac ctxt refl, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + EqSubst.eqsubst_tac ctxt [0] [the (#map_Sb axioms)], + REPEAT_DETERM o resolve_tac ctxt prems, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} ], EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], REPEAT_DETERM o resolve_tac ctxt prems, @@ -298,26 +362,32 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b EqSubst.eqsubst_tac ctxt [0] (map (fn ax => #map_is_Sb ax RS sym) axioms'), REPEAT_DETERM o resolve_tac ctxt prems ], + if count = 0 then K all_tac else rtac ctxt refl, rtac ctxt sym, rtac ctxt trans, - rtac ctxt (Sb_comp_right RS sym), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound} @ SSupp_map_bound @ prems @ #SSupp_comp_bound bmv_facts), + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt (#Sb_comp_right facts), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound} + @ maps (map_filter I o #SSupp_map_bound) facts' @ prems @ #SSupp_comp_bound bmv_facts + ), K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym], + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_inv_bound bij_imp_bij_inv} @ prems), REPEAT_DETERM o EVERY' [ 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 (MRBNF_Def.map_id0_of_mrbnf mrbnf :: @{thms id_o o_id})), rtac ctxt refl - ]) end - in { - SSupp_map_subset = SSupp_map_subset, - SSupp_map_bound = SSupp_map_bound, - map_Inj = map_Inj, - Sb_comp_right = Sb_comp_right, - map_Sb_strong = map_Sb_strong - } end - ) axioms' mrbnfs (BMV_Monad_Def.axioms_of_bmv_monad bmv) (BMV_Monad_Def.facts_of_bmv_monad bmv) + ]) end; + in { + SSupp_map_subset = #SSupp_map_subset facts, + SSupp_map_bound = #SSupp_map_bound facts, + map_Inj = #map_Inj facts, + Sb_comp_right = #Sb_comp_right facts, + map_Sb_strong = map_Sb_strong + }: mrsbnf_facts end + ) axioms' facts' mrbnfs (BMV_Monad_Def.axioms_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.SSupps_of_bmv_monad bmv); @@ -325,7 +395,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b mrbnfs = mrbnfs, pbmv_monad = bmv, axioms = axioms', - facts = facts + facts = facts' }; val (_, lthy) = note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy; @@ -346,8 +416,9 @@ fun mk_mrsbnf_axioms mrbnfs bmv 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)); local - val mapx = MRBNF_Def.mk_map_of_mrbnf deads As As Bs Fs lmrbnf; - val Sb = the_default (nth (BMV_Monad_Def.Sbs_of_bmv_monad bmv) leader) (nth (BMV_Monad_Def.Maps_of_bmv_monad bmv) leader); + val (mapx, Sb) = case nth (BMV_Monad_Def.Maps_of_bmv_monad bmv) leader of + NONE => (MRBNF_Def.mk_map_of_mrbnf deads As As Bs Fs lmrbnf, nth (BMV_Monad_Def.Sbs_of_bmv_monad bmv) leader) + | SOME Map => (MRBNF_Def.mk_map_of_mrbnf deads As As' Bs Fs lmrbnf, Map) val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy) ) [apply2 (snd o split_last o binder_types o fastype_of) (Sb, mapx), apply2 (body_type o fastype_of) (Sb, mapx)] Vartab.empty; @@ -360,19 +431,24 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = in val bmv = BMV_Monad_Def.morph_bmv_monad phi bmv; - val mrbnfs = map2 (fn mrbnf => fn T => + val mrbnfs = @{map 3} (fn mrbnf => fn Sb => fn Map => let - val tyenv = Sign.typ_match (Proof_Context.theory_of lthy) (MRBNF_Def.T_of_mrbnf mrbnf, T) Vartab.empty; + val Sb = the_default Sb Map; + val mapx = MRBNF_Def.map_of_mrbnf mrbnf; + + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy) + ) [apply2 (snd o split_last o binder_types o fastype_of) (mapx, Sb), apply2 (body_type o fastype_of) (mapx, Sb)] Vartab.empty; + val phi = Morphism.morphism "subst types" { binding = [], fact = [], typ = [K (Envir.subst_type tyenv)], term = [K (Envir.subst_term (tyenv, Vartab.empty))] }; in MRBNF_Def.morph_mrbnf phi mrbnf end - ) mrbnfs (BMV_Monad_Def.ops_of_bmv_monad bmv); - end + ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); + end; - val axioms = @{map 3} (fn mrbnf => fn Sb => fn Injs => + val axioms = @{map 4} (fn mrbnf => fn Sb => fn Injs => fn SSupps => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -389,7 +465,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val free_prems = map (fn f => HOLogic.mk_Trueprop (mk_supp_bound f)) free_fs; val map_is_Sb = fold_rev Logic.all free_fs (fold_rev (curry Logic.mk_implies) free_prems (mk_Trueprop_eq ( - Term.list_comb (mapx, MRBNF_Def.interlace + Term.list_comb (Term.subst_atomic_types (As' ~~ As) mapx, MRBNF_Def.interlace (map HOLogic.id_const As) (map HOLogic.id_const Bs) (free_fs @ map HOLogic.id_const (drop (length frees) Fs)) (MRBNF_Def.var_types_of_mrbnf mrbnf) ), @@ -409,31 +485,39 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = (replicate free [] @ map (fn f => [HOLogic.mk_Trueprop (mk_supp_bound f)]) pfree_fs) var_types ); - val other_fs = flat (MRBNF_Def.interlace (replicate live []) (map single bound_fs) + val other_fs = flat (MRBNF_Def.interlace (map single live_fs) (map single bound_fs) (replicate free [] @ map single pfree_fs) var_types); - val map_Sb = if null (Bs @ As @ pfrees) then NONE else + val g_prems = map2 (fn (SSupp, _) => fn g => HOLogic.mk_Trueprop (uncurry mk_ordLess ( + mk_card_of (SSupp $ g), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) + ))) SSupps gs; + + val count = live + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; + val map_Sb = if count - free = 0 then NONE else let val map_t = Term.list_comb (mapx, MRBNF_Def.interlace live_fs bound_fs (map HOLogic.id_const frees @ pfree_fs) var_types); val Sb_t = Term.list_comb (Sb, gs); - in SOME (fold_rev Logic.all other_fs (fold_rev (curry Logic.mk_implies) other_prems (mk_Trueprop_eq ( + in SOME (fold_rev Logic.all (other_fs @ gs) (fold_rev (curry Logic.mk_implies) (other_prems @ g_prems) (mk_Trueprop_eq ( HOLogic.mk_comp (map_t, Sb_t), - HOLogic.mk_comp (Sb_t, map_t) + HOLogic.mk_comp (Term.subst_atomic_types (As ~~ As') Sb_t, 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 sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) - (replicate free [] @ map single (drop free free_sets)) var_types); - - val set_Sbs = map (fn set => mk_Trueprop_eq (set $ (Term.list_comb (Sb, gs) $ x), set $ x)) sets'; + val set_Sbs = + let + val sets = MRBNF_Def.sets_of_mrbnf mrbnf; + + val (live_sets, bound_sets, free_sets) = MRBNF_Def.deinterlace sets var_types; + val sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) + (replicate free [] @ map single (drop free free_sets)) var_types); + in map (fn set => fold_rev Logic.all (gs @ [x]) (fold_rev (curry Logic.mk_implies) g_prems ( + mk_Trueprop_eq (set $ (Term.list_comb (Sb, gs) $ x), set $ x) + ))) sets' end; in { map_is_Sb = map_is_Sb, map_Sb = map_Sb, set_Sb = set_Sbs }: term mrsbnf_axioms end - ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv); + ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) (BMV_Monad_Def.SSupps_of_bmv_monad bmv); in (axioms, (deads, As, As', Bs, Fs, fs), mrbnfs, bmv) end @@ -497,15 +581,15 @@ fun pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x fun mrsbnf_cmd (b, Ts) lthy = let val Ts = map (Syntax.read_typ lthy) Ts; - val name = if Binding.is_empty b then fst (dest_Type (hd Ts)) else Binding.name_of b; - val (mrbnfs, lthy) = fold_map (fn T => fn lthy => - let val name = fst (dest_Type T); - in case MRBNF_Def.mrbnf_of lthy name of + val name = if Binding.is_empty b then fst (dest_Type (hd Ts)) else Local_Theory.full_name lthy b; + val (mrbnfs, lthy) = fold_map (fn T => fn lthy => case T of + TFree _ => (BMV_Monad_Def.id_mrbnf, lthy) + | TVar _ => error "Illegal schematic variable" + | Type (name, _) => case MRBNF_Def.mrbnf_of lthy name of SOME mrbnf => (mrbnf, lthy) | NONE => case BNF_Def.bnf_of lthy name of SOME bnf => MRBNF_Def.mrbnf_of_bnf bnf lthy | NONE => error ("Type " ^ name ^ " is not a (MR)BNF") - end ) Ts lthy; val bmv_monad = case BMV_Monad_Def.pbmv_monad_of lthy name of SOME bmv => bmv @@ -538,7 +622,9 @@ fun mrsbnf_cmd (b, Ts) lthy = 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)) @ #set_Sb goals - ) goals)) lthy end + ) goals)) lthy + |> 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" diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 6a9bf407..df667a8b 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -41,7 +41,7 @@ local_setup \fn lthy => }] [[([], [0])], [([], [0])]] lthy (* Step 5: Prove BMV structure of pre-MRBNF by composition *) - val (bmv, (thms, lthy)) = apfst the (PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) + val (bmv, (thms, lthy)) = apfst the (MRSBNF_Def.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (map dest_TFree [@{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}]) I @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} ([], lthy)) @@ -213,6 +213,54 @@ pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v: print_theorems print_pbmv_monads +mrsbnf "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var" and "'tv::var FType" + subgoal for f1 f2 + apply (rule ext) + apply (unfold map_FTerm_pre_def comp_def Sb_FTerm_pre_def bmv_defs id_def) + apply (subst FType.map_is_Sb, assumption+)+ + apply (unfold id_def[symmetric] sum.map_id prod.map_id comp_def) + apply (rule refl) + done + subgoal for f3 f4 f5 f6 g1 g2 + apply (rule ext) + apply (unfold map_FTerm_pre_def comp_def Sb_FTerm_pre_def bmv_defs FType.map_id0 Abs_FTerm_pre_inverse[OF UNIV_I]) + apply (unfold id_def) + apply (unfold sum.map_id prod.map_id comp_def sum.map_comp prod.map_comp) + apply (rule refl) + done + subgoal for g1 g2 + apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set3_FTerm_pre_def + prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right + Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) + ) + apply (rule refl) + done + subgoal for g1 g2 + apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set4_FTerm_pre_def + prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right + Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) + ) + apply (rule refl) + done + subgoal for g1 g2 + apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set5_FTerm_pre_def + prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right + Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) + ) + apply (rule refl) + done + subgoal for g1 g2 + apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set6_FTerm_pre_def + prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right + Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) + ) + apply (rule refl) + done + apply (rule ID.map_is_Sb; assumption) + apply (rule FType.map_is_Sb; assumption) + done +print_theorems + lemma set1_Vrs: "set1_FTerm_pre x = Vrs2_FTerm_pre x" apply (unfold set1_FTerm_pre_def Vrs2_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left prod.set_map Un_empty_right comp_def bmv_defs @@ -225,20 +273,6 @@ lemma set2_Vrs: "set2_FTerm_pre x = Vrs1_FTerm_pre x" ) apply (rule refl) done -lemma set3_Sb: "set3_FTerm_pre (Sb_FTerm_pre f1 f2 x) = set3_FTerm_pre x" - apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set3_FTerm_pre_def - prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right - Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) - ) - apply (rule refl) - done -lemma set4_Sb: "set4_FTerm_pre (Sb_FTerm_pre f1 f2 x) = set4_FTerm_pre x" - apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set4_FTerm_pre_def - prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right - Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) - ) - apply (rule refl) - done ML \ val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre") @@ -247,101 +281,6 @@ val laxioms = hd axioms val param = the (hd (BMV_Monad_Def.params_of_bmv_monad bmv)) \ -lemma Map_is_Sb: "vvsubst_FType f = Sb_FType (Inj_FType_1 \ f)" - - sorry - -corollary permute_Sb: - fixes f::"'tv::var \ 'tv" - assumes "bij f" "|supp f| f)" - apply (rule trans) - apply (rule FType.vvsubst_permute[symmetric]) - apply (rule assms)+ - apply (rule Map_is_Sb) - done - -lemma permute_Sb_FType: - fixes f::"'tv::var \ 'tv" - assumes "bij f" "|supp f| g \ inv f) = permute_FType f \ Sb_FType g \ permute_FType (inv f)" - apply (subst permute_Sb, (rule assms bij_imp_bij_inv supp_inv_bound)+)+ - apply (unfold comp_assoc) - apply (subst Sb_comp_FType[symmetric]) - apply (rule FType.SSupp_comp_bound) - apply (rule FType.SSupp_Inj_bound) - apply (rule assms) - apply (rule FType.SSupp_comp_bound) - apply (rule assms supp_inv_bound)+ - apply (rule arg_cong2[OF refl _, of _ _ "(\)"]) - apply (subst Sb_comp_FType) - prefer 3 - apply (unfold comp_assoc[symmetric]) - apply (subst Sb_comp_Inj_FType) - apply (rule assms) - apply (rule refl) - apply (rule assms) - apply (rule FType.SSupp_comp_bound) - apply (rule FType.SSupp_Inj_bound assms supp_inv_bound)+ - done - -lemma Map_is_Sb_FTerm_pre: "map_FTerm_pre f1 f2 id id id id = Sb_FTerm_pre (id \ f2) (TyVar \ f1)" - sorry -lemma Map_is_Sb_ID: "id f1 = id (id \ f1)" - by simp - -lemma Map_Sb: - fixes f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" - assumes "bij f3" "|supp f3| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre g1 g2 \ map_FTerm_pre id id f3 f4 f5 f6" - sorry - -lemma Map_Sb': - fixes f1::"'x1::var \ 'x1" and f2::"'x2::var \ 'x2" and f3::"'x3::var \ 'x3" and f4::"'x4::var \ 'x4" - assumes "bij f1" "|supp f1| Sb_FTerm_pre g1 g2 = Sb_FTerm_pre (id f2 \ g1 \ inv f2) (permute_FType f1 \ g2 \ inv f1) \ map_FTerm_pre f1 f2 f3 f4 f5 f6" - apply (rule trans) - apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) - apply (rule trans) - prefer 2 - apply (rule FTerm_pre.map_comp0[of id id f3 f4 f1 f2 id id id _ id]) - apply (rule assms bij_id supp_id_bound)+ - apply (unfold id_o o_id) - apply (rule refl) - apply (unfold comp_assoc Map_is_Sb_FTerm_pre)[1] - apply (rule trans) - apply (rule arg_cong2[OF refl, of _ _ "(\)"]) - apply (rule trans) - apply (rule Map_Sb) - apply (rule assms)+ - apply (rule trans) - apply (rule arg_cong2[OF refl, of _ _ "(\)"]) - apply (rule trans) - apply (rule ext) - apply (rule FTerm_pre.map_cong0[rotated -6]) - apply ((rule inv_o_simp1[symmetric, THEN fun_cong], rule assms) | rule id_o[symmetric, THEN fun_cong, of f3] id_o[symmetric, THEN fun_cong, of f4] id_o[symmetric, THEN fun_cong, of f5] id_o[symmetric, THEN fun_cong, of f6])+ - apply (rule assms supp_id_bound bij_id supp_comp_bound supp_inv_bound infinite_UNIV bij_comp)+ - apply (rule FTerm_pre.map_comp0) - apply (rule assms supp_id_bound bij_id supp_inv_bound)+ - apply (rule trans[OF comp_assoc[symmetric]]) - apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) - apply (subst Map_is_Sb_FTerm_pre) - apply (rule FTerm_pre.Sb_comp) - apply (rule FTerm_pre.SSupp_comp_bound FTerm_pre.SSupp_Inj_bound supp_inv_bound assms)+ - apply (unfold comp_assoc[symmetric]) - apply (subst FTerm_pre.Sb_comp_Inj, rule assms)+ - apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) - apply (rule trans) - apply (rule FTerm_pre.Sb_comp) - apply (rule FTerm_pre.SSupp_comp_bound FTerm_pre.SSupp_Inj_bound supp_inv_bound assms)+ - apply (unfold comp_assoc[symmetric]) - apply (subst permute_Sb[symmetric] Map_is_Sb_ID[symmetric], ((rule assms)+)?)+ - apply (rule refl) - done - (* Substitution axioms *) abbreviation \ :: "'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre" where "\ a \ Abs_FTerm_pre (Inl a)" @@ -783,6 +722,9 @@ lemma small_PFVarss: lemma FTVars_subset: "valid_P p \ set3_FTerm_pre y \ PFVars_1 p = {} \ (\t pu p. valid_P p \ (t, pu) \ set5_FTerm_pre y \ set6_FTerm_pre y \ FTVars (pu p) \ FTVars t \ PFVars_1 p) \ FTVars (Uctor y p) \ FTVars (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) \ PFVars_1 p" + apply (frule iffD1[OF meta_eq_to_obj_eq[OF valid_P_def]]) + apply (unfold case_prod_beta) + apply (erule conjE)+ subgoal premises prems apply (unfold Uctor_def case_prod_beta) apply (rule case_split) @@ -809,33 +751,16 @@ lemma FTVars_subset: "valid_P p \ set3_FTerm_pre y \ PFVa apply (unfold if_not_P) apply (erule thin_rl) - apply (subgoal_tac "|{ a. id a \ id a }| TyVar a }| _FType_tvsubst_FType_def TyVar_def[symmetric] comp_def)[1] - apply (erule conjE) - apply (erule ordLess_ordLeq_trans) - apply (rule cmin1) - apply (rule card_of_Card_order)+ - - apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) - apply assumption - apply assumption - apply (unfold FTerm.FVars_ctor) + apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) + apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ + + apply (unfold FTerm.FVars_ctor prod.collapse) apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ apply (unfold image_id image_comp comp_def prod.collapse) apply (rule Un_mono')+ - apply (unfold set3_Sb set4_Sb set1_Vrs set2_Vrs) + apply (unfold FTerm_pre.set_Sb set1_Vrs set2_Vrs) apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) - apply assumption+ + apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ apply (unfold PFVars_1_def case_prod_beta IImsupp_FType_def SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric] comp_def )[1] @@ -856,6 +781,8 @@ lemma FTVars_subset: "valid_P p \ set3_FTerm_pre y \ PFVa apply hypsubst apply assumption + apply (subst FTerm_pre.set_Sb) + apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) apply (rule Diff_Un_disjunct) apply (rule prems) @@ -888,6 +815,9 @@ lemma FTVars_subset: "valid_P p \ set3_FTerm_pre y \ PFVa lemma FVars_subset: "valid_P p \ set4_FTerm_pre y \ PFVars_2 p = {} \ (\t pu p. valid_P p \ (t, pu) \ set5_FTerm_pre y \ set6_FTerm_pre y \ FVars (pu p) \ FVars t \ PFVars_2 p) \ FVars (Uctor y p) \ FVars (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) \ PFVars_2 p" + apply (frule iffD1[OF meta_eq_to_obj_eq[OF valid_P_def]]) + apply (unfold case_prod_beta) + apply (erule conjE)+ subgoal premises prems apply (unfold Uctor_def case_prod_beta) apply (rule case_split) @@ -914,33 +844,15 @@ lemma FVars_subset: "valid_P p \ set4_FTerm_pre y \ PFVar apply (unfold if_not_P) apply (erule thin_rl) - apply (subgoal_tac "|{ a. id a \ id a }| TyVar a }| _FType_tvsubst_FType_def TyVar_def[symmetric] comp_def)[1] - apply (erule conjE) - apply (erule ordLess_ordLeq_trans) - apply (rule cmin1) - apply (rule card_of_Card_order)+ - - apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) - apply assumption - apply assumption - apply (unfold FTerm.FVars_ctor) + apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) + apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ + apply (unfold FTerm.FVars_ctor prod.collapse) apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ apply (unfold image_id image_comp comp_def prod.collapse) apply (rule Un_mono')+ - apply (unfold set3_Sb set4_Sb set1_Vrs set2_Vrs) + apply (unfold set1_Vrs set2_Vrs) apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) - apply assumption+ + apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ apply (unfold PFVars_2_def case_prod_beta IImsupp_FTerm2_def SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric] comp_def )[1] @@ -952,6 +864,8 @@ lemma FVars_subset: "valid_P p \ set4_FTerm_pre y \ PFVar apply hypsubst apply assumption + apply (subst FTerm_pre.set_Sb) + apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ apply (rule iffD2[OF arg_cong2[OF refl, of _ _ "(\)"]]) apply (rule Diff_Un_disjunct) apply (rule prems) @@ -988,6 +902,9 @@ lemma permute_Uctor: (\(t, pu). (permute_FTerm f1 f2 t, \p. if valid_P p then permute_FTerm f1 f2 (pu (Pmap (inv f1) (inv f2) p)) else undefined)) (\(t, pu). (permute_FTerm f1 f2 t, \p. if valid_P p then permute_FTerm f1 f2 (pu (Pmap (inv f1) (inv f2) p)) else undefined)) y) (Pmap f1 f2 p)" + apply (frule iffD1[OF meta_eq_to_obj_eq[OF valid_P_def]]) + apply (subst (asm) case_prod_beta) + apply (erule conjE)+ apply (unfold Uctor_def) apply (subst FTerm_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] fst_o_f comp_assoc comp_def[of snd] snd_conv case_prod_beta prod.collapse) @@ -1012,25 +929,9 @@ lemma permute_Uctor: apply (rule FTerm.permute_ctor) apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - apply (subgoal_tac "|{ a. id a \ id a }| TyVar a }| _FType_tvsubst_FType_def TyVar_def[symmetric] comp_def)[1] - apply (erule conjE) - apply (erule ordLess_ordLeq_trans) - apply (rule cmin1) - apply (rule card_of_Card_order)+ - - apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) - apply assumption - apply assumption + apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) + apply (rule FTerm_pre.SSupp_Inj_bound cmin1 cmin2 card_of_Card_order + | erule ordLess_ordLeq_trans)+ apply (subst FTerm_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) @@ -1039,10 +940,11 @@ lemma permute_Uctor: apply (unfold trans[OF Pmap_id0[THEN fun_cong] id_apply]) apply (unfold Pmap_def case_prod_beta snd_conv compSS_FType_def) - apply (subst trans[OF comp_apply[symmetric] Map_Sb'[THEN fun_cong]]) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + apply (subst trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]]) + apply (assumption | rule cmin1 cmin2 card_of_Card_order FTerm_pre.SSupp_Inj_bound | erule ordLess_ordLeq_trans)+ apply (unfold id_o o_id inv_o_simp2) - apply (unfold comp_def) + apply (subst FType.vvsubst_permute, (assumption | rule cmin1 cmin2 card_of_Card_order FTerm_pre.SSupp_Inj_bound | erule ordLess_ordLeq_trans)+) + apply (unfold comp_def BNF_Composition.id_bnf_def inv_simp2 id_def) apply (rule refl) done diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 3cabf41a..8880de95 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -5,6 +5,14 @@ theory BMV_Monad "mrsbnf" :: thy_goal begin +local_setup \fn lthy => + let + val (id_mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I [MRBNF_Def.Free_Var] MRBNF_Comp.ID_mrbnf + ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy); + val lthy = MRBNF_Def.register_mrbnf_raw "BMV_Monad.ID" id_mrbnf lthy + in lthy end +\ + declare [[mrbnf_internals]] binder_datatype 'a FType = TyVar 'a @@ -134,21 +142,9 @@ print_theorems ML_file \../Tools/mrsbnf_def.ML\ -local_setup \fn lthy => -let - val (id_mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I [MRBNF_Def.Free_Var] MRBNF_Comp.ID_mrbnf ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy) - val (id_mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Note_Some) I (SOME "BMV_Monad.ID") [id_mrbnf] - (the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.ID")) [{ - map_Sb = NONE, - map_is_Sb = fn ctxt => EVERY [ - Local_Defs.unfold0_tac ctxt @{thms id_def comp_def BNF_Composition.id_bnf_def}, - resolve_tac ctxt [refl] 1 - ], - set_Sb = [] - }] lthy; - val lthy = MRSBNF_Def.register_mrsbnf "BMV_Monad.ID" id_mrsbnf lthy -in lthy end -\ +mrsbnf ID: "'a::var" + unfolding id_def comp_def BNF_Composition.id_bnf_def by (rule refl) +print_theorems pbmv_monad "'a::var FType" Sbs: tvsubst_FType @@ -201,14 +197,12 @@ pbmv_monad "('a1::var, 'a2, 'c1, 'c2) L'" and "'a1::var print_pbmv_monads -ML_file \../Tools/pbmv_monad_comp.ML\ - ML \ Multithreading.parallel_proofs := 0 \ local_setup \fn lthy => let - val (bmv, (thms, lthy)) = PBMV_Monad_Comp.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) [] I + val (bmv, (thms, lthy)) = MRSBNF_Def.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) [] I @{typ "('a1, 'a2, 'a1 * 'a2, 'a1 * 'a2 * 'a2 * 'a2 FType) L'"} ([], lthy) From 76409ca7697daadef9cde705fb3725fb478d5af0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 12 Mar 2025 11:22:25 +0000 Subject: [PATCH 27/90] Save vars per op in bmv monad, add set_Vrs to mrsbnf axioms --- Tools/bmv_monad_def.ML | 125 +++++++++++++++++++----------------- Tools/mrsbnf_def.ML | 54 +++++++++++----- operations/BMV_Fixpoint.thy | 30 ++++----- operations/BMV_Monad.thy | 39 +++++------ 4 files changed, 137 insertions(+), 111 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index e4059ae3..129c6bf7 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -47,11 +47,11 @@ signature BMV_MONAD_DEF = sig ops: typ list, var_class: class, bmv_ops: bmv_monad list, - frees: typ list, - deads: typ list, + frees: typ list list, + deads: typ list list, leader: int, - lives: typ list, - lives': typ list, + lives: typ list list, + lives': typ list list, consts: (term option) bmv_monad_consts, params: 'a bmv_monad_param option list, bd_infinite_regular_card_order: 'a, @@ -64,10 +64,10 @@ signature BMV_MONAD_DEF = sig 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; - val lives_of_bmv_monad: bmv_monad -> typ list; - val lives'_of_bmv_monad: bmv_monad -> typ list; - val deads_of_bmv_monad: bmv_monad -> typ list; + 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 SSupps_of_bmv_monad: bmv_monad -> (term * thm) list list; val Sbs_of_bmv_monad: bmv_monad -> term list; @@ -218,10 +218,10 @@ datatype bmv_monad = BMV of { ops: typ list, var_class: class, leader: int, - frees: typ list, - lives: typ list, - lives': typ list, - deads: typ list, + frees: typ list list, + lives: typ list list, + lives': typ list list, + deads: typ list list, consts: (term * thm) bmv_monad_consts, params: thm bmv_monad_param option list, bd_infinite_regular_card_order: thm, @@ -236,10 +236,10 @@ fun morph_bmv_monad phi (BMV { ops = map (Morphism.typ phi) ops, leader = leader, var_class = var_class, - frees = map (Morphism.typ phi) frees, - lives = map (Morphism.typ phi) lives, - lives' = map (Morphism.typ phi) lives', - deads = map (Morphism.typ phi) deads, + 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 (map_prod (Morphism.term phi) (Morphism.thm phi)) consts, params = map (Option.map (map_bmv_monad_param (Morphism.thm phi))) params, axioms = map (morph_bmv_monad_axioms phi) axioms, @@ -271,10 +271,10 @@ val bd_infinite_regular_card_order_of_bmv_monad = #bd_infinite_regular_card_orde type 'a bmv_monad_model = { ops: typ list, var_class: class, - frees: typ list, - lives: typ list, - lives': typ list, - deads: typ list, + frees: typ list list, + lives: typ list list, + lives': typ list list, + deads: typ list list, consts: (term option) bmv_monad_consts, params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, @@ -289,10 +289,10 @@ fun morph_bmv_monad_model phi f ({ ops, var_class, frees, lives, lives', consts, ) = { ops = map (Morphism.typ phi) ops, var_class = var_class, - frees = map (Morphism.typ phi) frees, - lives = map (Morphism.typ phi) lives, - lives' = map (Morphism.typ phi) lives', - deads = map (Morphism.typ phi) deads, + 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 (Option.map (Morphism.term phi)) consts, params = params, bmv_ops = map (morph_bmv_monad phi) bmv_ops, @@ -625,7 +625,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( 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) [])) @ lives'; + 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) @@ -770,10 +770,10 @@ fun mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt (model: t ops = #ops model @ maps (#ops o Rep_bmv) (#bmv_ops model), var_class = #var_class model, leader = #leader model, - frees = #frees model, - lives = #lives model, - lives' = #lives' model, - deads = #deads 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, @@ -840,8 +840,8 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont let val frees = map (fn T => TFree (apsnd ( Sign.minimize_sort (Proof_Context.theory_of lthy) o cons (#var_class model) - ) (dest_TFree T))) (#frees model); - val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (#frees model ~~ frees)) I model; + ) (dest_TFree T))) (nth (#frees model) (#leader model)); + val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (nth (#frees model) (#leader model) ~~ frees)) I model; val (consts, unfold_set, SSupp_defs, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify (#leader model) (#ops model) (#lives' model) (#consts model) lthy; @@ -872,10 +872,10 @@ fun pbmv_monad_of_bnf bnf lthy = ops = [T], var_class = var_class, leader = 0, - frees = [], - lives = lives, - lives' = lives', - deads = deads, + frees = [[]], + lives = [lives], + lives' = [lives'], + deads = [deads], bmv_ops = [], consts = { bd = BNF_Def.bd_of_bnf bnf, @@ -942,10 +942,10 @@ fun slice_bmv_monad n bmv = ops = [f (ops_of_bmv_monad bmv)], var_class = var_class_of_bmv_monad bmv, leader = 0, - frees = filter (member (op=) vars) (frees_of_bmv_monad bmv), - lives = lives_of_bmv_monad bmv, - lives' = lives'_of_bmv_monad bmv, - deads = deads_of_bmv_monad bmv, + 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 => { @@ -964,7 +964,7 @@ fun slice_bmv_monad n bmv = fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = let - val _ = if length (lives_of_bmv_monad outer) <> length inners then + 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 () val filter_bmvs = map_filter (fn Inl x => SOME x | _ => NONE); @@ -1000,7 +1000,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val subst = let val Ts = map (sum_collapse o map_sum (hd o ops_of_bmv_monad) I) inner_leaders' - in (lives_of_bmv_monad outer ~~ Ts) @ (lives'_of_bmv_monad outer ~~ Ts) end; + in (nth (lives_of_bmv_monad outer) (leader_of_bmv_monad outer) ~~ Ts) + @ (nth (lives'_of_bmv_monad outer) (leader_of_bmv_monad outer) ~~ Ts) end; val new_leader = Term.typ_subst_atomic subst (nth (ops_of_bmv_monad outer) (leader_of_bmv_monad outer)); val new_Injs = distinct (op=) ( @@ -1063,7 +1064,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val ops = new_leader :: map (hd o ops_of_bmv_monad) minions; val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); - val lives = distinct (op=) (maps lives_of_bmv_monad inners'); + val lives = distinct (op=) (flat (maps lives_of_bmv_monad inners')); val consts = { bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) @@ -1081,10 +1082,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit bmv_ops = 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' = distinct (op=) (maps lives'_of_bmv_monad inners'), - deads = subtract (op=) (lives @ frees) vars, + frees = [frees], + lives = [lives], + lives' = [distinct (op=) (flat (maps lives'_of_bmv_monad inners'))], + deads = [subtract (op=) (lives @ frees) vars], consts = consts, params = [NONE], leader = 0, @@ -1186,7 +1187,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ rtac ctxt @{thm trans[rotated]}, rtac ctxt ( - let val n = length (lives_of_bmv_monad outer); + let val n = length (nth (lives_of_bmv_monad outer) (leader_of_bmv_monad outer)); in mk_arg_cong lthy (n + 1) Map OF (replicate n refl) end ), K (prefer_tac 2), @@ -1242,9 +1243,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b map (apply2 TFree) (Term.add_tfreesT (body_type (fastype_of Sb)) [] ~~ Term.add_tfreesT T []) @ map (apply2 TFree) (Term.add_tfreesT (snd (split_last (binder_types (fastype_of Sb)))) [] ~~ Term.add_tfreesT T []) ) Sb) (map (Syntax.read_term lthy) Sbs) ops; - val frees = distinct (op=) (maps ( - map (fst o dest_funT) o fst o split_last o binder_types o fastype_of - ) Sbs); + val frees = map (distinct (op=) o map (fst o dest_funT) o fst o split_last o binder_types o fastype_of) Sbs; val Injs = map (map (Syntax.read_term lthy)) Injs; val SSupps = case SSupps_opt of SOME SSupps => map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t))) SSupps @@ -1262,24 +1261,25 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b |> fold Variable.declare_typ vars val (lives, lives', param_consts) = case param_opt of - NONE => ([], [], replicate (length ops) NONE) + 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 = the_default [] (Option.map (fn Map => + val lives = map (the_default [] o Option.map (fn Map => let val Map = Term.subst_atomic_types (map (apply2 TFree) ( Term.add_tfreesT (snd (split_last (binder_types (fastype_of Map)))) [] ~~ Term.add_tfreesT (hd ops) [] )) Map; in map (fst o dest_funT) (fst (split_last (binder_types (fastype_of Map)))) end - ) (hd Maps)); + )) Maps; val (lives', _) = names_lthy - |> mk_TFrees' (map Type.sort_of_atyp lives); + |> fold_map mk_TFrees' (map (map Type.sort_of_atyp) lives); - val Maps = map2 (fn T => Option.map (fn Map => + val Maps = @{map 4} (fn T => fn lives => fn lives' => Option.map (fn Map => let val l' = map (snd o dest_funT) (fst (split_last (binder_types (fastype_of Map)))); val TA = snd (split_last (binder_types (fastype_of Map))); @@ -1294,7 +1294,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b subtract (op=) l' old_vars ~~ subtract (op=) lives (map TFree (Term.add_tfreesT TA [])) ) ) Map end - )) ops (Maps @ replicate (length ops - length Maps) NONE); + )) ops lives lives' Maps; val Suppss = map2 (fn T => Option.map (map (fn Supp => Term.subst_atomic_types (map (apply2 TFree) ( Term.add_tfreesT (hd (binder_types (fastype_of Supp))) [] ~~ Term.add_tfreesT T [] @@ -1304,6 +1304,10 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b map2 (@{map_option 2} (fn Map => fn Supps => { Map = Map, Supps = Supps })) Maps Suppss ) end; + val Vrs = map2 (fn frees => map (fn Vrs => map (fn var => Option.join ( + List.find (fn SOME Vrs => HOLogic.dest_setT (body_type (fastype_of Vrs)) = var | NONE => false) Vrs + )) frees)) frees Vrs; + val consts = { bd = bd, Injs = Injs, @@ -1375,6 +1379,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b }: thm bmv_monad_axioms, SSupp_eq), param), thms) end ) goals SSupp_eq_goals param_goals param_consts (tl thms)); + val _ = @{print} (lives, frees) val model = { ops = ops, var_class = @{class var}, (* TODO: change *) @@ -1382,7 +1387,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b frees = frees, lives = lives, lives' = lives', - deads = subtract (op=) (lives @ frees) vars, + deads = map2 (fn lives => fn frees => subtract (op=) (lives @ frees) vars) lives frees, bmv_ops = [], consts = consts, params = params, @@ -1416,15 +1421,15 @@ fun print_pbmv_monads ctxt = 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, consts, ...}) = + fun pretty_mrbnf (key, bmv as BMV {ops, frees, lives, 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 frees)), - Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) frees)]] @ + 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 lives)), - Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)]] + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) (nth lives 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 [] => [] | _ => [ diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 617f078c..34801528 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -3,6 +3,7 @@ signature MRSBNF_DEF = sig type 'a mrsbnf_axioms = { map_is_Sb: 'a, + set_Vrs: 'a list, map_Sb: 'a option, set_Sb: 'a list }; @@ -44,12 +45,14 @@ open MRBNF_Util type 'a mrsbnf_axioms = { map_is_Sb: 'a, + set_Vrs: 'a list, map_Sb: 'a option, set_Sb: 'a list } -fun map_mrsbnf_axioms (f:'a -> 'b) ({ map_is_Sb, map_Sb, set_Sb }: 'a mrsbnf_axioms) = { +fun map_mrsbnf_axioms (f:'a -> 'b) ({ map_is_Sb, set_Vrs, map_Sb, set_Sb }: 'a mrsbnf_axioms) = { map_is_Sb = f map_is_Sb, + set_Vrs = map f set_Vrs, map_Sb = Option.map f map_Sb, set_Sb = map f set_Sb }: 'b mrsbnf_axioms; @@ -57,13 +60,14 @@ fun map_mrsbnf_axioms (f:'a -> 'b) ({ map_is_Sb, map_Sb, set_Sb }: 'a mrsbnf_axi val morph_mrsbnf_axioms = map_mrsbnf_axioms o Morphism.thm fun apply_mrsbnf_axioms ({ - map_is_Sb=f1, map_Sb=f2, set_Sb=f3s + map_is_Sb=f1, map_Sb=f2, set_Sb=f3s, set_Vrs=f4s }: ('a -> 'b) mrsbnf_axioms) ({ - map_is_Sb, map_Sb, set_Sb + map_is_Sb, map_Sb, set_Sb, set_Vrs }: 'a mrsbnf_axioms) = { map_is_Sb = f1 map_is_Sb, map_Sb = Option.map (fn t => the f2 t) map_Sb, - set_Sb = map2 (curry (op|>)) set_Sb f3s + set_Sb = map2 (curry (op|>)) set_Sb f3s, + set_Vrs = map2 (curry (op|>)) set_Vrs f4s }: 'b mrsbnf_axioms type mrsbnf_facts = { @@ -103,7 +107,7 @@ fun morph_mrsbnf phi (MRSBNF { val id_bmv_monad = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID"); fun mk_id_bmv_monad free = BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism [(hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad), TFree free)] + MRBNF_Util.subst_typ_morphism [(hd (hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad)), TFree free)] ) id_bmv_monad; fun Rep_mrsbnf (MRSBNF x) = x @@ -141,6 +145,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = 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, []), @@ -448,7 +453,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); end; - val axioms = @{map 4} (fn mrbnf => fn Sb => fn Injs => fn SSupps => + val axioms = @{map 6} (fn mrbnf => fn Sb => fn Injs => fn SSupps => fn Vrs => fn bmv_frees => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -502,22 +507,37 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = HOLogic.mk_comp (Term.subst_atomic_types (As ~~ As') Sb_t, 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 = MRBNF_Def.sets_of_mrbnf mrbnf; - - val (live_sets, bound_sets, free_sets) = MRBNF_Def.deinterlace sets var_types; val sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) (replicate free [] @ map single (drop free free_sets)) var_types); in map (fn set => fold_rev Logic.all (gs @ [x]) (fold_rev (curry Logic.mk_implies) g_prems ( mk_Trueprop_eq (set $ (Term.list_comb (Sb, gs) $ x), set $ x) ))) sets' end; + + val Vrs' = bmv_frees ~~ transpose Vrs; + val set_Vrs = map (fn set => + let + val aT = HOLogic.dest_setT (fastype_of (set $ x)); + val Vrs = the (AList.lookup (op=) Vrs' aT); + val Vrs' = map_filter (Option.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 + ) (take free free_sets); in { map_is_Sb = map_is_Sb, + set_Vrs = set_Vrs, map_Sb = map_Sb, set_Sb = set_Sbs }: term mrsbnf_axioms end - ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) (BMV_Monad_Def.SSupps_of_bmv_monad bmv); + ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) + (BMV_Monad_Def.SSupps_of_bmv_monad bmv) (BMV_Monad_Def.Vrs_of_bmv_monad bmv) + (BMV_Monad_Def.frees_of_bmv_monad bmv); in (axioms, (deads, As, As', Bs, Fs, fs), mrbnfs, bmv) end @@ -545,7 +565,7 @@ fun pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x | NONE => (NONE, lthy); in case bmv_opt of NONE => (NONE, (accum, lthy)) - | SOME bmv => if null (BMV_Monad_Def.lives_of_bmv_monad bmv) then + | SOME bmv => if null (nth (BMV_Monad_Def.lives_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv)) then let val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv) in (SOME (BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( rev (map TFree (Term.add_tfreesT T []) @ map TVar (Term.add_tvarsT T [])) ~~ Ts @@ -563,9 +583,9 @@ fun pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x MRBNF_Util.subst_typ_morphism (snd (dest_Type T) ~~ Ts) ) bmv; val bmv = BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.lives'_of_bmv_monad bmv ~~ BMV_Monad_Def.lives_of_bmv_monad bmv + nth (BMV_Monad_Def.lives'_of_bmv_monad bmv) leader ~~ nth (BMV_Monad_Def.lives_of_bmv_monad bmv) leader )) bmv; - val live_Ts = BMV_Monad_Def.lives_of_bmv_monad bmv; + val live_Ts = nth (BMV_Monad_Def.lives_of_bmv_monad bmv) leader; val qualifies = map qualify (1 upto length live_Ts); val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy xs) qualifies live_Ts (accum, lthy) @@ -605,12 +625,14 @@ fun mrsbnf_cmd (b, Ts) lthy = | chop_opt (SOME _) thms = (SOME (hd thms), tl thms) val axioms = fst (fold_map (fn goals => fn thms => - let val (((map_is_Sb, map_Sb), set_Sb), thms) = thms + let val ((((map_is_Sb, set_Vrs), map_Sb), set_Sb), thms) = thms |> apfst hd o chop 1 + ||>> chop (length (#set_Vrs goals)) ||>> chop_opt (#map_Sb goals) - ||>> chop (length (#set_Sb goals)) + ||>> chop (length (#set_Sb goals)); in ({ map_is_Sb = map_is_Sb, + set_Vrs = set_Vrs, map_Sb = map_Sb, set_Sb = set_Sb }: thm mrsbnf_axioms, thms) end @@ -621,7 +643,7 @@ fun mrsbnf_cmd (b, Ts) 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)) @ #set_Sb goals + #map_is_Sb goals :: #set_Vrs goals @ the_default [] (Option.map single (#map_Sb goals)) @ #set_Sb goals ) goals)) lthy |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) end diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index df667a8b..75610395 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -221,6 +221,18 @@ mrsbnf "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var apply (unfold id_def[symmetric] sum.map_id prod.map_id comp_def) apply (rule refl) done + subgoal for x + apply (unfold set1_FTerm_pre_def Vrs2_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left + prod.set_map Un_empty_right comp_def bmv_defs + ) + apply (rule refl) + done + subgoal for x + apply (unfold set2_FTerm_pre_def Vrs1_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left + prod.set_map Un_empty_right comp_def bmv_defs + ) + apply (rule refl) + done subgoal for f3 f4 f5 f6 g1 g2 apply (rule ext) apply (unfold map_FTerm_pre_def comp_def Sb_FTerm_pre_def bmv_defs FType.map_id0 Abs_FTerm_pre_inverse[OF UNIV_I]) @@ -261,19 +273,6 @@ mrsbnf "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var done print_theorems -lemma set1_Vrs: "set1_FTerm_pre x = Vrs2_FTerm_pre x" - apply (unfold set1_FTerm_pre_def Vrs2_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left - prod.set_map Un_empty_right comp_def bmv_defs - ) - apply (rule refl) - done -lemma set2_Vrs: "set2_FTerm_pre x = Vrs1_FTerm_pre x" - apply (unfold set2_FTerm_pre_def Vrs1_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left - prod.set_map Un_empty_right comp_def bmv_defs - ) - apply (rule refl) - done - ML \ val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre") val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv @@ -758,7 +757,7 @@ lemma FTVars_subset: "valid_P p \ set3_FTerm_pre y \ PFVa apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ apply (unfold image_id image_comp comp_def prod.collapse) apply (rule Un_mono')+ - apply (unfold FTerm_pre.set_Sb set1_Vrs set2_Vrs) + apply (unfold FTerm_pre.set_Sb FTerm_pre.set_Vrs) apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ apply (unfold PFVars_1_def case_prod_beta IImsupp_FType_def SSupp_FType_def @@ -850,7 +849,7 @@ lemma FVars_subset: "valid_P p \ set4_FTerm_pre y \ PFVar apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ apply (unfold image_id image_comp comp_def prod.collapse) apply (rule Un_mono')+ - apply (unfold set1_Vrs set2_Vrs) + apply (unfold FTerm_pre.set_Vrs) apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ apply (unfold PFVars_2_def case_prod_beta IImsupp_FTerm2_def SSupp_FType_def @@ -1326,5 +1325,4 @@ lemma FTerm_subst: apply (rule refl) done - end \ No newline at end of file diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 8880de95..c4126dd1 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -143,7 +143,8 @@ print_theorems ML_file \../Tools/mrsbnf_def.ML\ mrsbnf ID: "'a::var" - unfolding id_def comp_def BNF_Composition.id_bnf_def by (rule refl) + unfolding id_def comp_def BNF_Composition.id_bnf_def + by (rule refl) print_theorems pbmv_monad "'a::var FType" @@ -323,13 +324,13 @@ val model_L = { ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], var_class = @{class var}, leader = 0, - frees = [@{typ "'a1"}], - lives = [@{typ "'c1"}, @{typ "'c2"}], - lives' = [@{typ "'c1'"}, @{typ "'c2'"}], - deads = [], + frees = [[@{typ "'a1"}]], + lives = [[@{typ "'c1"}, @{typ "'c2"}]], + lives' = [[@{typ "'c1'"}, @{typ "'c2'"}]], + deads = [[]], bmv_ops = [BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a1"}] )) id_bmv], consts = { bd = @{term natLeq}, @@ -460,18 +461,18 @@ val model_L1 = { ops = [@{typ "'a1 * 'a2"}], var_class = @{class var}, leader = 0, - frees = [@{typ "'a1"}, @{typ "'a2"}], - lives = [], - lives' = [], - deads = [], + frees = [[@{typ "'a1"}, @{typ "'a2"}]], + lives = [[]], + lives' = [[]], + deads = [[]], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a1"}] )) id_bmv, BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2"}] + hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a2"}] )) id_bmv ], consts = { @@ -548,22 +549,22 @@ val model_L2 = { ops = [@{typ "('a1, 'a2) L2"}], var_class = @{class var}, leader = 0, - frees = [@{typ 'a1}, @{typ "'a2"}], - lives = [], - lives' = [], - deads = [], + frees = [[@{typ 'a1}, @{typ "'a2"}]], + lives = [[]], + lives' = [[]], + deads = [[]], bmv_ops = [ BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a1"}] + hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a1"}] )) id_bmv, BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad id_bmv ~~ [@{typ "'a2"}] + hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a2"}] )) id_bmv, BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( - BMV_Monad_Def.frees_of_bmv_monad FType_bmv ~~ [@{typ "'a2::var"}] + hd (BMV_Monad_Def.frees_of_bmv_monad FType_bmv) ~~ [@{typ "'a2::var"}] )) FType_bmv ], consts = { From 0fad0a567a151ebf0704913996ae51c04f4c5c90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 28 Apr 2025 16:28:06 +0100 Subject: [PATCH 28/90] Add more complex lambda calculus example with second source of frees --- Tools/bmv_monad_def.ML | 293 +++++++++++++++++++++--------------- Tools/mrbnf_sugar.ML | 25 +-- Tools/mrbnf_tvsubst.ML | 33 +--- Tools/mrsbnf_comp.ML | 16 +- Tools/mrsbnf_def.ML | 129 ++++++---------- operations/BMV_Fixpoint.thy | 38 ++++- operations/BMV_Monad.thy | 243 +++++++++++++++++++++++++++--- thys/MRBNF_FP.thy | 13 ++ 8 files changed, 503 insertions(+), 287 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 129c6bf7..323d451b 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -14,9 +14,9 @@ signature BMV_MONAD_DEF = sig Sb_comp_Injs: 'a list, Sb_comp: 'a, Sb_cong: 'a, - Vrs_bds: 'a option list list, - Vrs_Injs: 'a option list list, - Vrs_Sbs: 'a option list list + Vrs_bds: 'a list, + Vrs_Injs: 'a list, + Vrs_Sbs: 'a list }; type bmv_monad_facts = { @@ -29,18 +29,19 @@ signature BMV_MONAD_DEF = sig type 'a bmv_monad_consts = { bd: term, - params: { Map: term, Supps: term list} option list, + Sbs: term list, + RVrs: term list list, Injs: term list list, SSupps: 'a list list, - Sbs: term list, - Vrs: term option list list list + 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, - Map_Vrs: 'a option list list + Map_Vrs: 'a list }; type 'a bmv_monad_model = { @@ -73,14 +74,14 @@ signature BMV_MONAD_DEF = sig 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 option list list list; + val Vrs_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 -> { axioms: thm supported_functor_axioms, Map_Sb: thm, Supp_Sb: thm list, - Map_Vrs: thm option list list + Map_Vrs: thm list } option list; val map_bmv_monad_axioms: ('a -> 'b) -> 'a bmv_monad_axioms -> 'b bmv_monad_axioms; @@ -98,8 +99,8 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory - val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list - -> local_theory -> (bmv_monad * thm list) * local_theory + (*val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list + -> local_theory -> (bmv_monad * thm list) * local_theory*) end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -113,9 +114,9 @@ type 'a bmv_monad_axioms = { Sb_comp_Injs: 'a list, Sb_comp: 'a, Sb_cong: 'a, - Vrs_bds: 'a option list list, - Vrs_Injs: 'a option list list, - Vrs_Sbs: 'a option list list + Vrs_bds: 'a list, + Vrs_Injs: 'a list, + Vrs_Sbs: 'a list }; fun map_bmv_monad_axioms f ({ @@ -125,9 +126,9 @@ fun map_bmv_monad_axioms f ({ Sb_comp_Injs = map f Sb_comp_Injs, Sb_comp = f Sb_comp, Sb_cong = f Sb_cong, - Vrs_bds = map (map (Option.map f)) Vrs_bds, - Vrs_Injs = map (map (Option.map f)) Vrs_Injs, - Vrs_Sbs = map (map (Option.map f)) Vrs_Sbs + Vrs_bds = map f Vrs_bds, + Vrs_Injs = map f Vrs_Injs, + Vrs_Sbs = map f Vrs_Sbs } : 'b bmv_monad_axioms; val morph_bmv_monad_axioms = map_bmv_monad_axioms o Morphism.thm; @@ -141,9 +142,9 @@ fun apply_bmv_monad_axioms ({ Sb_comp_Injs = map2 (curry (op|>)) Sb_comp_Injs f2s, Sb_comp = f3 Sb_comp, Sb_cong = f4 Sb_cong, - Vrs_bds = map2 (map2 (@{map_option 2} (curry (op|>)))) Vrs_bds f5s, - Vrs_Injs = map2 (map2 (@{map_option 2} (curry (op|>)))) Vrs_Injs f6s, - Vrs_Sbs = map2 (map2 (@{map_option 2} (curry (op|>)))) Vrs_Sbs f7s + Vrs_bds = map2 (curry (op|>)) Vrs_bds f5s, + Vrs_Injs = map2 (curry (op|>)) Vrs_Injs f6s, + Vrs_Sbs = map2 (curry (op|>)) Vrs_Sbs f7s } : 'b bmv_monad_axioms; type bmv_monad_facts = { @@ -182,28 +183,30 @@ type 'a bmv_monad_param = { axioms: 'a supported_functor_axioms, Map_Sb: 'a, Supp_Sb: 'a list, - Map_Vrs: 'a option list list + Map_Vrs: 'a list }; fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Map_Vrs }: 'a bmv_monad_param) = { axioms = map_supported_functor_axioms f axioms, Map_Sb = f Map_Sb, Supp_Sb = map f Supp_Sb, - Map_Vrs = map (map (Option.map f)) Map_Vrs + Map_Vrs = map f Map_Vrs }: 'b bmv_monad_param; type 'a bmv_monad_consts = { bd: term, - params: { Map: term, Supps: term list} option list, + Sbs: term list, + RVrs: term list list, Injs: term list list, SSupps: 'a list list, - Sbs: term list, - Vrs: term option list list list + Vrs: term list list, + params: { Map: term, Supps: term list} option list }; -fun morph_bmv_monad_consts phi f { bd, params, Injs, SSupps, Sbs, Vrs } = { +fun morph_bmv_monad_consts phi f { bd, params, Injs, SSupps, Sbs, Vrs, RVrs } = { 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 @@ -211,7 +214,7 @@ fun morph_bmv_monad_consts phi f { bd, params, Injs, SSupps, Sbs, Vrs } = { Injs = map (map (Morphism.term phi)) Injs, SSupps = map (map f) SSupps, Sbs = map (Morphism.term phi) Sbs, - Vrs = map (map (map (Option.map (Morphism.term phi)))) Vrs + Vrs = map (map (Morphism.term phi)) Vrs }: 'a bmv_monad_consts; datatype bmv_monad = BMV of { @@ -263,6 +266,7 @@ 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 RVrs_of_bmv_monad = #RVrs o #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 @@ -334,10 +338,11 @@ fun pbmv_monad_of_generic context = val pbmv_monad_of = pbmv_monad_of_generic o Context.Proof; -val mk_small_prems = map2 (fn rho => fn SSupp => HOLogic.mk_Trueprop (mk_ordLess +fun mk_small_prems fs rhos SSupps = map (HOLogic.mk_Trueprop o mk_supp_bound) fs + @ map2 (fn rho => fn SSupp => HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (the SSupp $ rho)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of rho)))) -)); +)) rhos SSupps; fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = let @@ -346,35 +351,42 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = val Injss = #Injs consts @ maps Injs_of_bmv_monad bmv_ops; val Vrss = #Vrs consts @ maps Vrs_of_bmv_monad bmv_ops; - val (axioms, SSupp_eq) = split_list (@{map 6} (fn T => fn Injs => fn SSupps => fn SSupp_defs => fn Sb => fn Vrs => + val (axioms, SSupp_eq) = split_list (@{map 7} (fn T => fn Injs => fn SSupps => fn SSupp_defs => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => let val (own_Injs, other_Injs) = partition (fn Inj => body_type (fastype_of Inj) = T) Injs; val is_own_Inj = map (curry (op=) T o body_type o fastype_of) Injs; val other_idxs = map (fn Inj => find_index (fn T => body_type (fastype_of Inj) = T) Ts) other_Injs; - val ((((rhos, rhos'), aa), x), _) = lthy - |> mk_Frees "\" (map fastype_of 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" (map (fst o dest_funT o fastype_of) Injs) ||>> apfst hd o mk_Frees "x" [T]; val nown = length own_Injs; val (own_rhos, other_rhos) = chop nown rhos; - val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, Injs), HOLogic.id_const T); + val f_ids = map (HOLogic.id_const o fst o dest_funT o fastype_of) fs; - val small_prems = mk_small_prems rhos SSupps; - val small_prems' = mk_small_prems rhos' SSupps; + val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, f_ids @ Injs), HOLogic.id_const T); + + val small_prems = mk_small_prems fs rhos SSupps; + val small_prems' = mk_small_prems gs rhos' SSupps; val Sb_comp_Injs = map2 (fn Inj => fn rho => - fold_rev Logic.all rhos (fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( - HOLogic.mk_comp (Term.list_comb (Sb, rhos), Inj), 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 (rhos' @ 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, rhos'), Term.list_comb (Sb, rhos)), - Term.list_comb (Sb, map (fn rho => HOLogic.mk_comp ( - Term.list_comb (Sb, rhos'), rho + 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 @ map (fn rho => HOLogic.mk_comp ( + Term.list_comb (Sb, gs @ rhos'), rho )) own_rhos @ @{map 3} (fn rho => fn Sb => fn Injs => HOLogic.mk_comp (Term.list_comb (Sb, map (fn Inj => case List.find (fn rho' => fastype_of rho' = fastype_of Inj) rhos' of @@ -384,45 +396,47 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = )) ); - val Vrs_bds = map (map (Option.map (fn Vrs => Logic.all x ( + val Vrs_bds = map (fn Vrs => Logic.all x ( HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) (#bd consts)) - )))) Vrs; + )) (RVrs @ Vrs); - val Vrs_Injs = map2 (fn Inj => map (Option.map (fn Vrs => + val Vrs_Injs = map2 (fn Inj => fn Vrs => 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), if fastype_of a = T then mk_singleton a else mk_bot T)) - end))) own_Injs (cond_keep Vrs is_own_Inj); + end + ) own_Injs (cond_keep Vrs is_own_Inj); - val Vrs_Sbs = map2 (fn rho => map (Option.map (fn Vrs => + val Vrs_Sbs = map2 (fn rho => fn Vr => let - val var = HOLogic.dest_setT (body_type (fastype_of Vrs)); - val idx = find_index (fn T => body_type (fastype_of rho) = T) Ts; - val idx' = find_index (fn t => fastype_of t = fastype_of rho) (nth Injss idx); - val Vrs' = hd (map_filter (Option.mapPartial (fn t => - if HOLogic.dest_setT (body_type (fastype_of t)) = var then SOME t else NONE - )) (nth (nth Vrss idx) idx')); - in fold_rev Logic.all (rhos @ [x]) ( + val RVrs = if (op=) (dest_funT (fastype_of rho)) then [mk_image rho $ (Vr $ x)] else []; + val UNs = @{map_filter 2} (fn Vr' => fn rho => + let + val X = Vr' $ x + in if body_type (fastype_of rho) = fst (dest_funT (fastype_of Vr)) then + SOME (mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (fastype_of X)) (Vr $ (rho $ Bound 0)))) + else NONE end + ) Vrs rhos; + in fold_rev Logic.all (fs @ rhos @ [x]) ( fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( - Vrs $ (Term.list_comb (Sb, rhos) $ x), - mk_UNION (Vrs $ x) (Term.abs ("a", var) (Vrs' $ (rho $ Bound 0))) + Vr $ (Term.list_comb (Sb, fs @ rhos) $ x), foldl1 mk_Un (RVrs @ UNs) )) ) end - ))) rhos Vrs; + ) (fs @ rhos) (RVrs @ Vrs); - val Sb_cong = fold_rev Logic.all (rhos @ rhos' @ [x]) ( - fold_rev (curry Logic.mk_implies) (small_prems @ small_prems' @ flat (@{map 3} (fn rho => fn rho' => map_filter (Option.map (fn Vrs => + 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 - ))) rhos rhos' Vrs)) (mk_Trueprop_eq ( - Term.list_comb (Sb, rhos) $ x, - Term.list_comb (Sb, rhos') $ x + ) (fs @ rhos) (gs @ rhos') (RVrs @ Vrs)) (mk_Trueprop_eq ( + Term.list_comb (Sb, fs @ rhos) $ x, + Term.list_comb (Sb, gs @ rhos') $ x ) )); @@ -443,7 +457,7 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong } : term bmv_monad_axioms, SSupp_eq) end - ) ops (#Injs consts) (#SSupps consts) SSupp_defs (#Sbs consts) (#Vrs consts)); + ) ops (#Injs consts) (#SSupps consts) SSupp_defs (#Sbs consts) (#Vrs consts) (#RVrs consts)); in (axioms, SSupp_eq) end; fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = @@ -451,11 +465,14 @@ fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = 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 |> mk_TFrees (length lives); - val ((((fs, gs), rhos), x), _) = lthy + 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];; @@ -498,7 +515,7 @@ fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = ))); val Map_Sb = fold_rev Logic.all (fs @ rhos) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems rhos SSupps) (mk_Trueprop_eq ( + fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos SSupps) (mk_Trueprop_eq ( HOLogic.mk_comp (Term.list_comb (Map, fs), Term.list_comb (Sb, rhos)), HOLogic.mk_comp (Term.list_comb ( Term.subst_atomic_types (lives ~~ lives') Sb, rhos @@ -506,12 +523,12 @@ fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = )) ); - val Map_Vrs = map (map (Option.map (fn Vrs => + val Map_Vrs = 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 )) - ))) Vrs; + ) Vrs; val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( @@ -588,13 +605,18 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( ) ) (#Injs consts) suffixess (#SSupps consts) lthy); - val (Vrs', lthy) = - (@{fold_map 2} (@{fold_map 2} (fn suffix => fn Vrs => @{fold_map 2} (fn i => fold_map_option (fn Vrs => - maybe_define' (Binding.suffix_name ("_" ^ string_of_int i) (suffix (Binding.name "Vrs"))) Vrs - )) (0 upto length Vrs - 1) Vrs)) suffixess (#Vrs consts) 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 Vrs = map (map fst) Vrs'; + val Vrs_defs = maps (map snd) Vrs'; - val Vrs = map (map (map (Option.map fst))) Vrs'; - val Vrs_defs = maps (maps (map (Option.mapPartial snd))) Vrs'; + val RVrs = map (map fst) RVrs'; + val RVrs_defs = maps (map snd) RVrs'; val (params', lthy) = @{fold_map 2} (fn suffix => fold_map_option (fn param => fn lthy => let @@ -619,6 +641,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( Injs = Injs, SSupps = map (map SOME) SSupps, Sbs = Sbs, + RVrs = RVrs, Vrs = Vrs } : (term option) bmv_monad_consts; @@ -636,13 +659,13 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = let - val bmv_b = case bmv_b_opt of + 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 - val bmv_name = implode (tl (maps (fn x => [".", x]) (tl_maybe (String.tokens (fn c => c = #".") (Binding.name_of bmv_b))))); + 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 lfacts = nth facts (leader_of_bmv_monad bmv); @@ -663,7 +686,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("SSupp_comp_bound", #SSupp_comp_bound lfacts, []) ] |> filter_out (null o #2) - |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true bmv_name (Binding.name thmN)), attrs), [(thms, [])])); + |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (bmv_name ()) (Binding.name thmN)), attrs), [(thms, [])])); in Local_Theory.notes notes lthy |>> append noted end val fact_policy = fact_policy lthy; in ([], lthy) @@ -682,25 +705,25 @@ fun mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt (model: t Injs = #Injs (#consts model) @ maps (#Injs o #consts o Rep_bmv) (#bmv_ops model), SSupps = map2 (map2 (pair o the)) (#SSupps (#consts model)) SSupp_defs @ maps (#SSupps 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) - }; + 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) + }: (term * thm) 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 = map (map (fn Inj => + val Inj_injs = map2 (map2 (fn Inj => fn Vrs => 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)); - val Vrs = the (List.find (fn a => domain_type (fastype_of a) = body_type (fastype_of Inj)) (map_filter I (flat (flat (#Vrs consts))))); in 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 (map_filter I (flat (maps #Vrs_Injs axioms)))), + K (Local_Defs.unfold0_tac ctxt (maps #Vrs_Injs axioms)), etac ctxt @{thm singleton_inject}, hyp_subst_tac ctxt, rtac ctxt refl ]) end - )) (#Injs consts); + )) (#Injs consts) (#Vrs consts); val SSupp_Injs = map2 (map2 (fn Inj => fn (SSupp, SSupp_def) => Goal.prove_sorry lthy [] [] (mk_Trueprop_eq (SSupp $ Inj, mk_bot (domain_type (fastype_of Inj)))) (fn {context=ctxt, ...} => EVERY [ @@ -810,8 +833,10 @@ fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = in map2 (@{map_option 2} ( fn { axioms=tacs, Map_Sb=f1, Supp_Sb=f2s, Map_Vrs=f3s, ...} => fn { axioms, Map_Sb, Supp_Sb, Map_Vrs } => { - Map_Sb = f1 Map_Sb, Supp_Sb = map2 (curry (op|>)) Supp_Sb f2s, - Map_Vrs = map2 (map2 (@{map_option 2} (curry (op|>)))) Map_Vrs f3s, axioms = { + Map_Sb = f1 Map_Sb, + Supp_Sb = map2 (curry (op|>)) Supp_Sb f2s, + Map_Vrs = map2 (curry (op|>)) Map_Vrs f3s, + 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), @@ -883,6 +908,7 @@ fun pbmv_monad_of_bnf bnf lthy = SSupps = [[]], Sbs = [HOLogic.id_const T], Vrs = [[]], + RVrs = [[]], params = [SOME { Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf @@ -954,6 +980,7 @@ fun slice_bmv_monad n bmv = Injs = [f (Injs_of_bmv_monad bmv)], SSupps = [f (SSupps_of_bmv_monad bmv)], Sbs = [Sb], + RVrs = [f (RVrs_of_bmv_monad bmv)], Vrs = [f (Vrs_of_bmv_monad bmv)] }, params = [f (params_of_bmv_monad bmv)], @@ -962,7 +989,7 @@ fun slice_bmv_monad n bmv = facts = [f (facts_of_bmv_monad bmv)] } end; -fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = +(*fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either 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 () @@ -1046,7 +1073,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit let fun get_sets bmv = let val idx = find_index (curry ((op=) o apply2 fastype_of) Inj) (leader Injs_of_bmv_monad bmv); - in if idx < 0 then [] else map_filter I (nth (leader Vrs_of_bmv_monad bmv) idx) end; + in if idx < 0 then [] else [nth (leader Vrs_of_bmv_monad bmv) idx] end; val sets = flat (map (fn t => t $ x) (get_sets outer') :: @{map_filter 2} (fn Inr _ => K NONE | Inl bmv => fn Supp => @@ -1054,11 +1081,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit in if null sets then NONE else SOME (map (mk_UNION (Supp $ x)) sets) end ) inners (the (leader Supps_of_bmv_monad outer')) ); - in map (fn var => - let - val sets' = filter (curry (op=) var o HOLogic.dest_setT o fastype_of) sets; - in if null sets' then NONE else SOME (Term.absfree (dest_Free x) (foldl1 mk_Un sets')) end - ) frees end + in Term.absfree (dest_Free x) (foldl1 mk_Un sets) end ) new_Injs; val ops = new_leader :: map (hd o ops_of_bmv_monad) minions; @@ -1234,8 +1257,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) (outer' :: inners'))); val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify (SOME name) model lthy in (res, lthy) end; +*) -fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), bd) lthy = +fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param_opt), bd) lthy = let val ops = map (Syntax.read_typ lthy) ops; val bd = Syntax.read_term lthy bd; @@ -1243,19 +1267,48 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b map (apply2 TFree) (Term.add_tfreesT (body_type (fastype_of Sb)) [] ~~ Term.add_tfreesT T []) @ map (apply2 TFree) (Term.add_tfreesT (snd (split_last (binder_types (fastype_of Sb)))) [] ~~ Term.add_tfreesT T []) ) Sb) (map (Syntax.read_term lthy) Sbs) ops; - val frees = map (distinct (op=) o map (fst o dest_funT) o fst o split_last o binder_types o fastype_of) Sbs; - val Injs = map (map (Syntax.read_term lthy)) Injs; + + 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; + val Injs = map (map (fn s => + let + val t = Syntax.read_term lthy s; + val T = case List.find (curry (op=) (fst (dest_Type (body_type (fastype_of t)))) o fst o dest_Type) ops of + NONE => 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, []) + | SOME T => T; + in Term.subst_atomic_types (map (apply2 TFree) (Term.add_tfreesT (body_type (fastype_of t)) [] ~~ Term.add_tfreesT T [])) 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 ("Expected injection of type " ^ Syntax.string_of_typ lthy f_T ^ " for operator " ^ Syntax.string_of_typ lthy T + ^ ". Substitution has type " ^ Syntax.string_of_typ lthy (fastype_of Sb) ^ ", but got injections:", map fastype_of Injs, []) + | _ => () + ) (filter_out ((op=) o dest_funT) f_Ts)) Sbs ops Injs f_Tss; + val SSupps = case SSupps_opt of - SOME SSupps => map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t))) SSupps + SOME SSupps => map2 (fn Injs => fn SSupps => map2 (fn "_" => K NONE | t => fn Inj => + let + val t = Syntax.read_term lthy t; + val t' = Term.subst_atomic_types (map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of t))) [] ~~ Term.add_tfreesT (fastype_of Inj) [])) t; + in SOME t' end + ) (SSupps @ replicate (length Injs - length SSupps) "_") Injs) Injs (SSupps @ replicate (length Injs - length SSupps) []) | NONE => map (map (K NONE)) Injs; - val Vrs = map (map (map (fn "_" => NONE | t => SOME (Syntax.read_term lthy t)))) Vrs; - val Vrs = map2 (fn T => map (map (Option.map (fn Vrs => Term.subst_atomic_types ( + + val Vrs = map (map (Syntax.read_term lthy )) (the_default (replicate (length ops) []) Vrs); + val Vrs = map2 (fn T => map (fn Vrs => Term.subst_atomic_types ( map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of Vrs))) [] ~~ Term.add_tfreesT T []) - ) Vrs)))) ops Vrs; + ) Vrs)) ops Vrs; + + val RVrs = map (map (Syntax.read_term lthy)) (the_default (replicate (length ops) []) RVrs); + val RVrs = map2 (fn T => map (fn RVrs => Term.subst_atomic_types ( + map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of RVrs))) [] ~~ Term.add_tfreesT T []) + ) RVrs)) ops RVrs; val b = if Binding.is_empty b then fst (dest_Type (hd ops)) else Local_Theory.full_name lthy b - val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); + val vars = distinct (op=) (rev (map TFree (fold Term.add_tfreesT ops []))); val names_lthy = lthy |> fold Variable.declare_typ vars @@ -1304,16 +1357,13 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b map2 (@{map_option 2} (fn Map => fn Supps => { Map = Map, Supps = Supps })) Maps Suppss ) end; - val Vrs = map2 (fn frees => map (fn Vrs => map (fn var => Option.join ( - List.find (fn SOME Vrs => HOLogic.dest_setT (body_type (fastype_of Vrs)) = var | NONE => false) Vrs - )) frees)) frees Vrs; - val consts = { bd = bd, Injs = Injs, SSupps = SSupps, Sbs = Sbs, Vrs = Vrs, + RVrs = RVrs, params = param_consts }: (term option) bmv_monad_consts; val (consts, bmv_defs, SSupp_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 @@ -1342,9 +1392,9 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b ||>> chop (length (#Sb_comp_Injs goal)) ||>> chop_many SSupp_eq_goals ||>> apfst hd o chop 1 - ||>> fold_map chop_many (#Vrs_bds goal) - ||>> fold_map chop_many (#Vrs_Injs goal) - ||>> fold_map chop_many (#Vrs_Sbs goal) + ||>> chop (length (#Vrs_bds goal)) + ||>> chop (length (#Vrs_Injs 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), Map_Vrs), thms) = thms @@ -1355,7 +1405,7 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b ||>> apfst hd o chop 1 ||>> apfst hd o chop 1 ||>> chop (length (#Supps (the param_consts))) - ||>> fold_map chop_many (#Map_Vrs goals) + ||>> chop (length (#Map_Vrs goals)) in (SOME ({ axioms = { Map_id = Map_id, @@ -1400,14 +1450,15 @@ fun pbmv_monad_cmd (((((((b, ops), Sbs), Injs), SSupps_opt), Vrs), param_opt), b val lthy = register_pbmv_monad b bmv lthy; in lthy end; + val _ = @{print} "foo" in Proof.theorem NONE after_qed (map (single o rpair []) ( [HOLogic.mk_Trueprop (mk_infinite_regular_card_order bd)] @ flat (@{map 3} (fn goal => fn SSupp_eq_goals => fn param => #Sb_Inj goal :: #Sb_comp_Injs goal @ map_filter I SSupp_eq_goals @ [#Sb_comp goal] - @ maps (map_filter I) (#Vrs_bds goal @ #Vrs_Injs goal @ #Vrs_Sbs goal) + @ #Vrs_bds goal @ #Vrs_Injs 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 @ maps (map_filter I) (#Map_Vrs param) + @ #Supp_Sb param @ #Map_Vrs param ) param) ) goals SSupp_eq_goals param_goals) )) lthy @@ -1452,22 +1503,20 @@ val _ = val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} "register a parametrized bounded multi-variate monad" - (parse_opt_binding_colon -- Parse.and_list1 Parse.typ --| - (Parse.reserved "Sbs" -- @{keyword ":"}) -- Parse.and_list1 Parse.term --| - (Parse.reserved "Injs" -- @{keyword ":"}) -- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs" || Parse.reserved "SSupps") Parse.term)) -- - (Scan.option ((Parse.reserved "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Vrs") (Parse.underscore || Parse.term))))) --| - (Parse.reserved "Vrs" -- @{keyword ":"}) -- Parse.and_list1 (Parse.list1 ( - Scan.repeat1 (Scan.unless (Parse.reserved "Map" || Parse.reserved "bd") (Parse.underscore || Parse.term)) - )) -- - Scan.optional ( - (Parse.reserved "Map" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.underscore || Parse.term) --| - (Parse.reserved "Supps" -- @{keyword ":"}) -- Parse.and_list1 ( + ((parse_opt_binding_colon -- Parse.and_list1 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.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 "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Maps" || Parse.reserved "bd") (Parse.underscore || Parse.term))))) -- + Scan.option ( + ((Parse.reserved "Maps" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.underscore || Parse.term)) -- + ((Parse.reserved "Supps" -- @{keyword ":"}) |-- Parse.and_list1 ( Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term) || (Parse.underscore >> K []) - ) - >> SOME - ) NONE --| - (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term + )) + ) -- + ((Parse.reserved "bd" -- @{keyword ":"}) |-- Parse.term)) >> pbmv_monad_cmd) end \ No newline at end of file diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 89f401b2..57f6221e 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -879,27 +879,6 @@ fun create_binder_datatype co (spec : spec) lthy = K (Local_Defs.unfold0_tac ctxt (@{thms sum.inject} @ [#Abs_inject (snd info) OF @{thms UNIV_I UNIV_I}])), assume_tac ctxt ]; - 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 - )), - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - rtac ctxt (infer_instantiate' ctxt [SOME (snd (hd params))] (#Abs_cases (snd info))) 1 - ) ctxt, - hyp_subst_tac ctxt, - 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}] - )), - etac ctxt @{thm contrapos_np}, - dtac ctxt @{thm iffD2[OF ex_in_conv]}, - etac ctxt exE, - REPEAT_DETERM o etac ctxt @{thm UN_E}, - REPEAT_DETERM o eresolve_tac ctxt @{thms setl.cases setr.cases}, - hyp_subst_tac ctxt, - rtac ctxt exI, - rtac ctxt refl - ]; fun eta_natural_tac ctxt = EVERY1 [ K (Local_Defs.unfold0_tac ctxt (@{thms comp_def map_sum.simps} @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, MRBNF_Def.map_def_of_mrbnf pre_mrbnf] @@ -910,7 +889,6 @@ fun create_binder_datatype co (spec : spec) lthy = val tvsubst_axioms = { eta_free = eta_free_tac, eta_inj = eta_inj_tac, - eta_compl_free = eta_compl_free_tac, eta_natural = eta_natural_tac }; val tvsubst_model = { @@ -1010,7 +988,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 = body_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 = diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML index 05eec43c..e656279e 100644 --- a/Tools/mrbnf_tvsubst.ML +++ b/Tools/mrbnf_tvsubst.ML @@ -3,7 +3,6 @@ sig type 'a eta_axioms = { eta_free: 'a, eta_inj: 'a, - eta_compl_free: 'a, eta_natural: 'a }; @@ -39,7 +38,6 @@ open MRBNF_Recursor type 'a eta_axioms = { eta_free: 'a, eta_inj: 'a, - eta_compl_free: 'a, eta_natural: 'a }; @@ -134,15 +132,6 @@ fun prove_model_axioms qualify res (models : (Proof.context -> tactic) tvsubst_m (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; @@ -168,7 +157,6 @@ fun prove_model_axioms qualify res (models : (Proof.context -> tactic) tvsubst_m 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) @@ -1078,24 +1066,6 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l 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); @@ -1448,7 +1418,6 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l ("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)) @@ -1461,4 +1430,4 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l in (results, lthy) end; -end \ No newline at end of file +end diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index d976e68f..1cac900f 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -1,10 +1,24 @@ signature MRSBNF_COMP = sig val id_mrsbnf: MRSBNF_Def.mrsbnf + + val mrsbnf_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) + -> (binding -> binding) -> ((string * sort) * MRBNF_Def.var_type) list -> typ + -> (thm list * local_theory) -> MRSBNF_Def.mrsbnf option * (thm list * local_theory) + end structure MRSBNF_Comp : MRSBNF_COMP = struct -val id_mrsbnf = the (MRSBNF_Def.mrsbnf_of @{context} "BMV_Monad.ID"); +val id_mrsbnf = the (MRSBNF_Def.mrsbnf_of @{context} "BNF_Composition.ID"); + +fun mrsbnf_of_typ _ _ _ _ var_types (TFree (x, _)) accum = (case AList.lookup ((op=) o apsnd fst) var_types x of + SOME MRBNF_Def.Free_Var => (SOME id_mrsbnf, accum) + | _ => (SOME id_mrsbnf, accum)) + | mrsbnf_of_typ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" + | mrsbnf_of_typ optim const_policy inline_policy qualify var_types (T as Type (n, Ts)) (accum, lthy) = + let + + in error "bar" end; end \ No newline at end of file diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 34801528..454029d2 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -16,9 +16,6 @@ signature MRSBNF_DEF = sig map_Sb_strong: thm }; - val id_bmv_monad: BMV_Monad_Def.bmv_monad - val mk_id_bmv_monad: string * sort -> BMV_Monad_Def.bmv_monad - 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 @@ -28,15 +25,13 @@ signature MRSBNF_DEF = sig 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 + -> local_theory -> mrsbnf * local_theory; + + val mrsbnf_of_bnf: BNF_Def.bnf -> local_theory -> mrsbnf * 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; - - val pbmv_monad_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) - -> (string * sort) list -> (binding -> binding) -> typ -> (thm list * local_theory) - -> BMV_Monad_Def.bmv_monad option * (thm list * local_theory) end structure MRSBNF_Def : MRSBNF_DEF = struct @@ -104,12 +99,6 @@ fun morph_mrsbnf phi (MRSBNF { facts = map (morph_mrsbnf_facts phi) facts } -val id_bmv_monad = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID"); - -fun mk_id_bmv_monad free = BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism [(hd (hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv_monad)), TFree free)] -) id_bmv_monad; - fun Rep_mrsbnf (MRSBNF x) = x val bmv_monad_of_mrsbnf = #pbmv_monad o Rep_mrsbnf @@ -123,9 +112,9 @@ structure Data = Generic_Data ( fun merge data : T = Symtab.merge (K true) data; ); -fun register_mrsbnf name bmv = +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 bmv))); + (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))) @@ -136,7 +125,7 @@ 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; - val name = case name_opt of + 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; @@ -155,7 +144,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("map_Sb_strong", map #map_Sb_strong facts, []) ] |> filter_out (null o #2) - |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (short_type_name name) (Binding.name thmN)), attrs), [(thms, [])])); + |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (short_type_name (name ())) (Binding.name thmN)), attrs), [(thms, [])])); in Local_Theory.notes notes lthy |>> append noted end val fact_policy = fact_policy (Proof_Context.theory_of lthy); in ([], lthy) @@ -362,28 +351,33 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b REPEAT_DETERM o resolve_tac ctxt prems, rtac ctxt trans, rtac ctxt (#Sb_comp bmv_axioms), - REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map (fn ax => #map_is_Sb ax RS sym) axioms'), - REPEAT_DETERM o resolve_tac ctxt prems - ], - if count = 0 then K all_tac else rtac ctxt refl, - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, - rtac ctxt (#Sb_comp_right facts), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound} - @ maps (map_filter I o #SSupp_map_bound) facts' @ prems @ #SSupp_comp_bound bmv_facts - ), - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym], - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_inv_bound bij_imp_bij_inv} @ prems), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] @{thms inv_o_simp1}, - resolve_tac ctxt prems - ], - K (Local_Defs.unfold0_tac ctxt (MRBNF_Def.map_id0_of_mrbnf mrbnf :: @{thms id_o o_id})), - rtac ctxt refl + EVERY' [ + rtac ctxt refl, + rtac ctxt refl + ] ORELSE' EVERY' [ + REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map (fn ax => #map_is_Sb ax RS sym) axioms'), + REPEAT_DETERM o resolve_tac ctxt prems + ], + if count = 0 then K all_tac else rtac ctxt refl, + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt (#Sb_comp_right facts), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound} + @ maps (map_filter I o #SSupp_map_bound) facts' @ prems @ #SSupp_comp_bound bmv_facts + ), + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym], + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_inv_bound bij_imp_bij_inv} @ prems), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] @{thms inv_o_simp1}, + resolve_tac ctxt prems + ], + K (Local_Defs.unfold0_tac ctxt (MRBNF_Def.map_id0_of_mrbnf mrbnf :: @{thms id_o o_id})), + rtac ctxt refl + ] ]) end; in { SSupp_map_subset = #SSupp_map_subset facts, @@ -552,51 +546,16 @@ fun mrsbnf_def fact_policy qualify name_opt mrbnfs bmv tacs lthy = 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 pbmv_monad_of_typ _ _ _ xs _ (TFree x) accum = if member (op=) xs x - then (NONE, accum) else (SOME (mk_id_bmv_monad x), accum) - | pbmv_monad_of_typ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" - | pbmv_monad_of_typ optim const_policy inline_policy xs qualify' (T as Type (n, Ts)) (accum, lthy) = - let val (bmv_opt, lthy) = case BMV_Monad_Def.pbmv_monad_of lthy n of - SOME bmv => (SOME bmv, lthy) - | NONE => case BNF_Def.bnf_of lthy n of - SOME bnf => - let val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf bnf lthy - in (SOME bmv, BMV_Monad_Def.register_pbmv_monad n bmv lthy) end - | NONE => (NONE, lthy); - in case bmv_opt of - NONE => (NONE, (accum, lthy)) - | SOME bmv => if null (nth (BMV_Monad_Def.lives_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv)) then - let val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv) - in (SOME (BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( - rev (map TFree (Term.add_tfreesT T []) @ map TVar (Term.add_tvarsT T [])) ~~ Ts - )) bmv), (accum, lthy)) 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 leader = BMV_Monad_Def.leader_of_bmv_monad bmv; - val T = nth (BMV_Monad_Def.ops_of_bmv_monad bmv) leader; - val bmv = BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism (snd (dest_Type T) ~~ Ts) - ) bmv; - val bmv = BMV_Monad_Def.morph_bmv_monad (MRBNF_Util.subst_typ_morphism ( - nth (BMV_Monad_Def.lives'_of_bmv_monad bmv) leader ~~ nth (BMV_Monad_Def.lives_of_bmv_monad bmv) leader - )) bmv; - val live_Ts = nth (BMV_Monad_Def.lives_of_bmv_monad bmv) leader; - - val qualifies = map qualify (1 upto length live_Ts); - val (bmv_opts, (accum, lthy)) = @{fold_map 2} (pbmv_monad_of_typ optim const_policy inline_policy xs) qualifies live_Ts (accum, lthy) - val bmvs = map2 (fn T => fn NONE => Inr T | SOME bmv => Inl bmv) live_Ts bmv_opts; - in if exists Option.isSome bmv_opts then - let val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) bmv bmvs lthy; - in (SOME bmv, (unfold_set @ accum, lthy)) end - else - (NONE, (accum, lthy)) - end - end; +fun mrsbnf_of_bnf bnf lthy = + let + val (mrbnf, lthy) = MRBNF_Def.mrbnf_of_bnf bnf lthy; + val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf bnf lthy; + in mrsbnf_def (K BNF_Def.Dont_Note) I NONE [mrbnf] bmv [{ + map_Sb = SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_o o_id} THEN rtac ctxt refl 1), + map_is_Sb = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, + set_Sb = replicate (BNF_Def.live_of_bnf bnf) (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_apply} THEN rtac ctxt refl 1), + set_Vrs = [] + }] lthy end; fun mrsbnf_cmd (b, Ts) lthy = let diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 75610395..0176b5f2 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -8,6 +8,42 @@ type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = + '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\" + +ML_file \../Tools/mrsbnf_comp.ML\ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + local_setup \fn lthy => let @@ -986,7 +1022,7 @@ val vars = map TVar (rev (Term.add_tvarsT (#T quot) [])); \ ML \ -val model = MRBNF_Recursor.mk_quotient_model quot (vars ~~ [@{typ "'tv::var"}, @{typ "'v::var"}]) { +val model = MRBNF_Recursor.mk_quotient_model quot (vars ~~ [@{typ "'tv::var"}, @{typ "'v::var"}]) [] { binding = @{binding "tvsubst_FTerm"}, Uctor = @{term "Uctor :: _ \ ('tv::var, 'v::var) P \ _"}, validity = NONE, diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index c4126dd1..943b3e0b 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -28,7 +28,7 @@ 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 VVr_eq_Var: "tvVVr_tvsubst_FType = TyVar" +lemma VVr_eq_Var_FType: "tvVVr_tvsubst_FType = TyVar" unfolding tvVVr_tvsubst_FType_def TyVar_def comp_def tv\_FType_tvsubst_FType_def by (rule refl) 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 @@ -97,8 +97,8 @@ lemma Sb_cong_FType: 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) + then show ?case using assms apply (auto simp: FType.permute_id) + by (metis (mono_tags, lifting) CollectI IImsupp_FType_def SSupp_FType_def Un_iff) qed (auto simp: assms(1-2)) lemma map_is_Sb_FType: @@ -113,7 +113,7 @@ lemma map_is_Sb_FType: next case (TyAll x1 x2) then have 1: "x1 \ SSupp_FType (Inj_FType_1 \ f)" - by (simp add: SSupp_FType_def VVr_eq_Var not_in_imsupp_same) + by (simp add: SSupp_FType_def VVr_eq_Var_FType not_in_imsupp_same) then have "x1 \ IImsupp_FType (Inj_FType_1 \ f)" unfolding IImsupp_FType_def Un_iff de_Morgan_disj apply (rule conjI) @@ -131,27 +131,13 @@ ML_file \../Tools/bmv_monad_def.ML\ local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ -pbmv_monad ID: "'a::var" - Sbs: "id :: ('a \ 'a) \ 'a \ 'a::var" - Injs: "id :: 'a \ 'a::var" - SSupps: "supp :: ('a \ 'a) \ 'a::var set" - Vrs: "\(x::'a::var). {x}" - bd: natLeq - by (auto simp: ID.set_bd infinite_regular_card_order_natLeq supp_def) -print_theorems - -ML_file \../Tools/mrsbnf_def.ML\ - -mrsbnf ID: "'a::var" - unfolding id_def comp_def BNF_Composition.id_bnf_def - by (rule refl) -print_theorems +(*ML_file \../Tools/mrsbnf_def.ML\*) -pbmv_monad "'a::var FType" +pbmv_monad "'tv::var FType" Sbs: tvsubst_FType Injs: TyVar - SSupps: SSupp_FType Vrs: FVars_FType + SSupps: SSupp_FType bd: natLeq apply (rule infinite_regular_card_order_natLeq) apply (rule Sb_Inj_FType) @@ -165,10 +151,221 @@ pbmv_monad "'a::var FType" done print_theorems -mrsbnf "'a::var FType" +(*mrsbnf "'a::var FType" apply (rule map_is_Sb_FType; assumption) done -print_theorems +print_theorems*) + +binder_datatype 'a LM = + Var 'a + | Lst "'a list" + | App "'a LM" "'a LM" + | Lam x::'a t::"'a LM" binds x in t +thm LM.subst + +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)" + +ML \ +Multithreading.parallel_proofs := 0 +\ + +lemma VVr_eq_Var_LM[simp]: "tvVVr_tvsubst_LM = Var" + apply (unfold tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def comp_def Var_def) + apply (rule refl) + done +lemma IImsupp_SSupp_bound[simp]: "( |IImsupp_LM (f::'a::var \ _)| ( |SSupp_LM f| 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_LM_def Un_iff de_Morgan_disj SSupp_LM_def VVr_eq_Var_LM 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_LM_def SSupp_LM_def VVr_eq_Var_LM comp_def Vrs_Un) + apply (rule subsetI) + apply (rule UnI2) + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply (erule UnI1) + done + +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_LM_def Un_iff de_Morgan_disj SSupp_LM_def VVr_eq_Var_LM 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_LM_def SSupp_LM_def VVr_eq_Var_LM 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_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" "IImsupp_LM f2" rule: LM.strong_induct) + case (Lam x1 x2) + then show ?case + apply simp + apply (unfold Un_Diff) + apply (rule arg_cong2[of _ _ _ _ "(\)"]) + apply (simp add: imsupp_def supp_def) + apply fastforce + apply (rule sym) + apply (rule IImsupp_Diff_Vrs_1) + apply blast + done +qed (auto simp: assms imsupp_supp_bound infinite_UNIV) + +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" "IImsupp_LM f2" rule: LM.strong_induct) + case (Lst x) + then show ?case by auto +next + case (App x1 x2) + then show ?case by simp +next + case (Lam x1 x2) + then show ?case + apply (subst Sb_LM_simp4) + apply assumption+ + apply (unfold Vrs_2_simp4 Lam) + apply (rule IImsupp_Diff_Vrs_2[symmetric]) + by blast +qed (auto simp: assms imsupp_supp_bound infinite_UNIV) + +(* lemma + fixes g::"'a LM \ 'a LM" and f ::"'a \ 'a LM" + shows "IImsupp_LM (g o f) \ IImsupp_LM g \ IImsupp_LM f" + unfolding IImsupp_LM_def +*) + +(* AtoJ: Proved this first (which is anyway generally useful) *) +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_LM_def SSupp_LM_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) . . + +(* + apply (rule subsetI) + apply (unfold IImsupp_LM_def) + apply (erule UnE) + apply (unfold SSupp_LM_def VVr_eq_Var_LM mem_Collect_eq comp_def)[1] + subgoal for x + apply (rule case_split[of "\ x = Var x"]) + apply simp + by blast + apply (erule UN_E) + apply (unfold0 comp_apply) + subgoal for x y + apply (rule case_split[of "\ y = Var y"]) + apply (unfold SSupp_LM_def VVr_eq_Var_LM mem_Collect_eq comp_def)[1] + apply auto[1] + apply (unfold Vrs_Un) + apply (erule UnE) + apply (subst (asm) Vrs_1_Sb_LM) + apply (rule assms)+ + apply (erule UnE) + oops +*) + + +pbmv_monad "'b::var LM" + Sbs: Sb_LM + RVrs: Vrs_1 + Injs: Var + Vrs: Vrs_2 + SSupps: SSupp_LM + 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_LM_def SSupp_LM_def tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def Var_def) + apply fastforce + + apply (unfold SSupp_LM_def tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def Var_def comp_def)[1] + apply (rule refl) + + 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" "IImsupp_LM \" "IImsupp_LM \'" rule: LM.strong_induct) + apply (auto simp: imsupp_supp_bound infinite_UNIV prems IImsupp_LM_def LM.set_bd_UNIV intro!: var_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 blast + apply (rule refl) + done typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" by (rule UNIV_witness) diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index 4482cfa7..be860b3b 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -274,6 +274,19 @@ lemma disjoint_single: "{x} \ 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| Date: Sat, 3 May 2025 21:44:14 +0100 Subject: [PATCH 29/90] Introduce RVrs to BMV Monads --- Tools/binder_induction.ML | 2 +- Tools/binder_inductive.ML | 3 +- Tools/bmv_monad_def.ML | 193 ++++++++++++++------------- Tools/mrsbnf_def.ML | 66 +++++---- operations/BMV_Fixpoint.thy | 3 +- operations/BMV_Monad.thy | 258 ++++++++++++++++-------------------- thys/MRBNF_FP.thy | 1 + thys/Prelim/Prelim.thy | 3 + 8 files changed, 269 insertions(+), 260 deletions(-) diff --git a/Tools/binder_induction.ML b/Tools/binder_induction.ML index 93c8435b..f9ec380d 100644 --- a/Tools/binder_induction.ML +++ b/Tools/binder_induction.ML @@ -471,7 +471,7 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking REPEAT_DETERM o rtac ctxt @{thm induct_forallI}, rtac ctxt inner_prem ORELSE' EVERY' [ - Method.insert_tac ctxt [inner_prem], + Method.insert_tac ctxt inner_prems, let val simpset = Simplifier.add_cong @{thm imp_cong} ( (BNF_Util.ss_only @{thms diff --git a/Tools/binder_inductive.ML b/Tools/binder_inductive.ML index 6e7045ba..8b1d9d3f 100644 --- a/Tools/binder_inductive.ML +++ b/Tools/binder_inductive.ML @@ -115,7 +115,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) => diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 323d451b..198bac9d 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -75,6 +75,7 @@ signature BMV_MONAD_DEF = sig 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 -> { @@ -96,11 +97,13 @@ signature BMV_MONAD_DEF = sig val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory val register_bnf_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 -> local_theory -> (bmv_monad * thm list) * local_theory - (*val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list - -> local_theory -> (bmv_monad * thm list) * local_theory*) + val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list + -> local_theory -> (bmv_monad * thm list) * local_theory end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -364,7 +367,7 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = ||>> mk_Frees "g" f_Ts ||>> mk_Frees "\" (map fastype_of Injs) ||>> mk_Frees "\'" (map fastype_of Injs) - ||>> mk_Frees "a" (map (fst o dest_funT o 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 nown = length own_Injs; val (own_rhos, other_rhos) = chop nown rhos; @@ -415,10 +418,16 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = val RVrs = if (op=) (dest_funT (fastype_of rho)) then [mk_image rho $ (Vr $ x)] else []; val UNs = @{map_filter 2} (fn Vr' => fn rho => let + val (aT, T) = dest_funT (fastype_of rho); val X = Vr' $ x - in if body_type (fastype_of rho) = fst (dest_funT (fastype_of Vr)) then - SOME (mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (fastype_of X)) (Vr $ (rho $ Bound 0)))) - else NONE end + val inner_Vr = if null RVrs then List.find (fn Vr'' => + T = fst (dest_funT (fastype_of Vr'')) + andalso HOLogic.dest_setT (body_type (fastype_of Vr)) = aT + ) (flat Vrss) else if T = fst (dest_funT (fastype_of Vr)) then + SOME Vr else NONE; + in Option.map (fn Vr => + mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (fastype_of X)) (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 ( @@ -460,7 +469,7 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = ) ops (#Injs consts) (#SSupps consts) SSupp_defs (#Sbs consts) (#Vrs consts) (#RVrs consts)); in (axioms, SSupp_eq) end; -fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = +fun mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy = let val (f_Ts, T) = split_last (binder_types (fastype_of Map)); val (lives, lives') = split_list (map dest_funT f_Ts); @@ -514,11 +523,11 @@ fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = Term.list_comb (Map, gs') $ x ))); - val Map_Sb = fold_rev Logic.all (fs @ rhos) ( + val Map_Sb = fold_rev Logic.all (fs @ hs @ rhos) ( fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos SSupps) (mk_Trueprop_eq ( - HOLogic.mk_comp (Term.list_comb (Map, fs), Term.list_comb (Sb, rhos)), + 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, rhos + Term.subst_atomic_types (lives ~~ lives') Sb, hs @ rhos ), Term.list_comb (Map, fs)) )) ); @@ -528,11 +537,11 @@ fun mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy = Term.subst_atomic_types (lives ~~ lives') Vrs $ (Term.list_comb (Map, fs) $ x), Vrs $ x )) - ) Vrs; + ) (RVrs @ Vrs); val Supp_Sb = map (fn Supp => - fold_rev Logic.all (rhos @ [x]) (mk_Trueprop_eq ( - Supp $ (Term.list_comb (Sb, rhos) $ x), Supp $ x + fold_rev Logic.all (rhos @ hs @ [x]) (mk_Trueprop_eq ( + Supp $ (Term.list_comb (Sb, hs @ rhos) $ x), Supp $ x )) ) Supps; in { @@ -678,7 +687,14 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("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", maps #Vrs_Injs axioms, []), + ("Vrs_Sb", maps #Vrs_Sbs axioms, []), ("Map_Sb", map_filter (Option.map #Map_Sb) params, []), + ("Map_Vrs", flat (map_filter (Option.map #Map_Vrs) 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), []), ("Inj_inj", #Inj_inj lfacts, []), ("SSupp_Inj", #SSupp_Inj lfacts, []), ("SSupp_Inj_bound", #SSupp_Inj_bound lfacts, []), @@ -711,8 +727,9 @@ fun mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt (model: t val axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model); val names = map (fst o dest_Free); - val Inj_injs = map2 (map2 (fn Inj => fn Vrs => + val Inj_injs = map (map (fn Inj => let + val Vrs = the (List.find (fn Vr => body_type (fastype_of Inj) = fst (dest_funT (fastype_of Vr))) (flat (#Vrs consts))); 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 Goal.prove_sorry lthy (names [a, b]) [] goal (fn {context=ctxt, ...} => EVERY1 [ @@ -723,7 +740,7 @@ fun mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt (model: t hyp_subst_tac ctxt, rtac ctxt refl ]) end - )) (#Injs consts) (#Vrs consts); + )) (#Injs consts); val SSupp_Injs = map2 (map2 (fn Inj => fn (SSupp, SSupp_def) => Goal.prove_sorry lthy [] [] (mk_Trueprop_eq (SSupp $ Inj, mk_bot (domain_type (fastype_of Inj)))) (fn {context=ctxt, ...} => EVERY [ @@ -822,9 +839,9 @@ fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs SSupp_d fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let - val goals = @{map 5} (fn Sb => fn Vrs => fn Injs => fn SSupps => Option.map (fn param => - mk_param_axiom (#Map param) (#Supps param) SSupps Sb Injs Vrs (#bd (#consts model)) lthy - )) (#Sbs (#consts model)) (#Vrs (#consts model)) (#Injs (#consts model)) (#SSupps (#consts model)) (#params (#consts model)) + val goals = @{map 6} (fn Sb => fn RVrs => fn Vrs => fn Injs => fn SSupps => Option.map (fn param => + mk_param_axiom (#Map param) (#Supps param) SSupps Sb Injs RVrs Vrs (#bd (#consts model)) lthy + )) (#Sbs (#consts model)) (#RVrs (#consts model)) (#Vrs (#consts model)) (#Injs (#consts model)) (#SSupps (#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 @@ -989,7 +1006,7 @@ fun slice_bmv_monad n bmv = facts = [f (facts_of_bmv_monad bmv)] } end; -(*fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = +fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either 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 () @@ -1019,6 +1036,7 @@ fun slice_bmv_monad n bmv = (TFree x, the_default (TFree x) (Option.map (TFree o pair (fst x)) (Symtab.lookup vars (fst x)))) ) (Term.add_tfreesT T [])) T val outer = mk_sign_morph outer; + val inners = map (map_sum mk_sign_morph mk_T_morph) inners; val inners' = filter_bmvs inners; @@ -1035,6 +1053,7 @@ fun slice_bmv_monad n bmv = map (Term.subst_atomic_types subst) (nth (Injs_of_bmv_monad outer) (leader_of_bmv_monad outer)) @ maps (hd o Injs_of_bmv_monad) inner_leaders ); + val outer' = morph_bmv_monad (MRBNF_Util.subst_typ_morphism subst) outer; val minions = fold_rev (fn bmv => fold_rev (fn i => fn xs => let val T = nth (ops_of_bmv_monad bmv) i; @@ -1052,23 +1071,27 @@ fun slice_bmv_monad n bmv = the (List.find (fn (SSupp, _) => domain_type (fastype_of SSupp) = fastype_of t) SSupps) ) new_Injs; - val ((fs, x), _) = lthy - |> mk_Frees "f" (map fastype_of new_Injs) + val RVrs_aTs = distinct (op=) (map (HOLogic.dest_setT o body_type o fastype_of) + (flat (maps RVrs_of_bmv_monad (outer' :: inners'))) + ); + + val (((fs, rhos), x), _) = lthy + |> mk_Frees "f" (map (fn a => a --> a) RVrs_aTs) + ||>> mk_Frees "\" (map fastype_of new_Injs) ||>> apfst hd o mk_Frees "x" [new_leader]; fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv); fun mk_Sb (Inl bmv) = let val Sb = leader Sbs_of_bmv_monad bmv; in Term.list_comb (Sb, - map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of Sb)))) + map (fn T => the (List.find (curry (op=) T o fastype_of) (fs @ rhos))) (fst (split_last (binder_types (fastype_of Sb)))) ) end | mk_Sb (Inr T) = HOLogic.id_const T; - val new_Sb = fold_rev Term.absfree (map dest_Free fs) (HOLogic.mk_comp ( + val new_Sb = fold_rev Term.absfree (map dest_Free (fs @ rhos)) (HOLogic.mk_comp ( Term.list_comb (the (leader Maps_of_bmv_monad outer'), map mk_Sb inners), mk_Sb (Inl outer') )); - val frees = map TFree (rev (fold Term.add_tfrees new_Injs [])); val new_Vrs = map (fn Inj => let fun get_sets bmv = @@ -1083,17 +1106,28 @@ fun slice_bmv_monad n bmv = ); in Term.absfree (dest_Free x) (foldl1 mk_Un sets) end ) new_Injs; + val new_RVrs = map (fn aT => + let + fun get_set bmv = List.find (curry (op=) aT o HOLogic.dest_setT o body_type o fastype_of) (leader RVrs_of_bmv_monad bmv) + val sets = the_default [] (Option.map (fn s => [s $ x]) (get_set outer')) + @ @{map_filter 2} (fn Inr _ => K NONE | Inl bmv => fn Supp => Option.map (fn s => + mk_UNION (Supp $ x) s + ) (get_set bmv)) inners (the (leader Supps_of_bmv_monad outer')) + in Term.absfree (dest_Free x) (foldl1 mk_Un sets) end + ) RVrs_aTs; val ops = new_leader :: map (hd o ops_of_bmv_monad) minions; val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); val lives = distinct (op=) (flat (maps lives_of_bmv_monad inners')); + val frees = distinct (op=) (map (HOLogic.dest_setT o body_type o fastype_of) (new_RVrs @ new_Vrs)); val consts = { bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) Injs = [new_Injs], Sbs = [new_Sb], Vrs = [new_Vrs], + RVrs = [new_RVrs], SSupps = [map (SOME o fst) new_SSupps], params = [NONE] }: (term option) bmv_monad_consts; @@ -1115,7 +1149,7 @@ fun slice_bmv_monad n bmv = SSupp_eq = [map (fn (_, thm) => SOME (fn ctxt => Local_Defs.unfold0_tac ctxt [thm] THEN rtac ctxt refl 1 )) new_SSupps], - tacs = @{map 5} (fn axioms => fn param => fn Map => fn Injs => fn Vrs => { + tacs = @{map 6} (fn axioms => fn param => fn Map => fn Injs => fn RVrs => fn Vrs => { Sb_Inj = fn ctxt => EVERY1 [ rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, @@ -1158,55 +1192,36 @@ fun slice_bmv_monad n bmv = rtac ctxt refl ] ], - Vrs_bds = map (map (Option.map (K (fn ctxt => EVERY1 [ + Vrs_bds = map (K (fn ctxt => EVERY1 [ REPEAT_DETERM o resolve_tac ctxt ( - maps (map_filter I) (#Vrs_bds axioms) - @ maps (maps (maps (map_filter I) o #Vrs_bds) o axioms_of_bmv_monad) inners' + #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} ) - ])))) Vrs, - Vrs_Injs = map (map (Option.map (fn thm => fn ctxt => + ])) (RVrs @ Vrs), + Vrs_Injs = map (fn thm => fn ctxt => print_tac ctxt "Vrs_Injs" - ))) (#Vrs_Injs axioms), - Vrs_Sbs = map (map (Option.map (K (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms UN_Un}), + ) (#Vrs_Injs axioms), + Vrs_Sbs = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ( + @{thms image_Un image_UN comp_def image_comp Union_UN_swap} + @ #Map_Vrs param + @ #Supp_Sb param + @ #Supp_Map (#axioms param) + )), REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, - REPEAT_DETERM o FIRST' [ - EVERY' [ - rtac ctxt @{thm trans[OF arg_cong[OF comp_apply]]}, - rtac ctxt trans, - resolve_tac ctxt (maps (map_filter I) (#Map_Vrs param)), - rtac ctxt trans, - resolve_tac ctxt (maps (map_filter I) (#Vrs_Sbs axioms)), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), - REPEAT_DETERM o assume_tac ctxt, - rtac ctxt refl - ], - EVERY' [ - rtac ctxt trans, - rtac ctxt @{thm arg_cong[of _ _ "\x. \(_ ` x)"]}, - rtac ctxt trans, - rtac ctxt @{thm trans[OF arg_cong[OF comp_apply]]}, - resolve_tac ctxt (#Supp_Map (#axioms param)), - rtac ctxt @{thm arg_cong[of _ _ "\x. _ ` x"]}, - resolve_tac ctxt (#Supp_Sb param), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_simps(10)}), - rtac ctxt trans, - rtac ctxt @{thm UN_cong}, - resolve_tac ctxt (maps (maps (maps (map_filter I) o #Vrs_Sbs) o axioms_of_bmv_monad) inners'), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), - REPEAT_DETERM o assume_tac ctxt, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms UN_extend_simps(9)}), - rtac ctxt refl - ] + TRY o (resolve_tac ctxt (#Vrs_Sbs axioms) THEN_ALL_NEW assume_tac ctxt), + REPEAT_DETERM o EVERY' [ + rtac ctxt @{thm UN_cong}, + resolve_tac ctxt (maps (maps #Vrs_Sbs o axioms_of_bmv_monad) inners'), + REPEAT_DETERM o assume_tac ctxt ] - ])))) Vrs, + ])) (RVrs @ Vrs), Sb_cong = fn ctxt => EVERY1 [ rtac ctxt @{thm comp_apply_eq}, - K (Local_Defs.unfold0_tac ctxt SSupp_defs), Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ rtac ctxt @{thm trans[rotated]}, rtac ctxt ( @@ -1218,38 +1233,35 @@ fun slice_bmv_monad n bmv = K (Local_Defs.unfold0_tac ctxt (#Supp_Sb param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), - REPEAT_DETERM1 o EVERY' [ - REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), - FIRST' (map (fn thm => EVERY' [ - TRY o rtac ctxt thm, - REPEAT_DETERM o FIRST' [ - rtac ctxt @{thm UnI2} THEN' etac ctxt @{thm UN_I}, - rtac ctxt @{thm UnI1} - ], - REPEAT_DETERM o etac ctxt @{thm UN_I}, - assume_tac ctxt - ]) (@{thm refl} :: drop (2 * length Injs) prems)) - ] + REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + TRY o (dtac ctxt @{thm UN_I} THEN' assume_tac ctxt), + resolve_tac ctxt (drop (2 * length Injs) prems), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + etac ctxt UnI2, + rtac ctxt UnI1 + ] + ]) ]) inners), rtac ctxt (#Sb_cong axioms), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), - REPEAT_DETERM o EVERY' [ - resolve_tac ctxt prems, - TRY o EVERY' [ - etac ctxt @{thm contrapos_pp}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj}), - REPEAT_DETERM o etac ctxt conjE, - assume_tac ctxt + REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + TRY o (dtac ctxt @{thm UN_I} THEN' assume_tac ctxt), + resolve_tac ctxt (drop (2 * length Injs) prems), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + etac ctxt UnI2, + rtac ctxt UnI1 ] - ] + ]) ]) ctxt ] } : (Proof.context -> tactic) bmv_monad_axioms) [leader axioms_of_bmv_monad outer'] [the (leader params_of_bmv_monad outer')] [the (leader Maps_of_bmv_monad outer')] - [new_Injs] [new_Vrs] + [new_Injs] [new_RVrs] [new_Vrs] } : (Proof.context -> tactic) bmv_monad_model; val name = qualify (Binding.conglomerate (map_filter ( @@ -1257,7 +1269,6 @@ fun slice_bmv_monad n bmv = ) (outer' :: inners'))); val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify (SOME name) model lthy in (res, lthy) end; -*) fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param_opt), bd) lthy = let @@ -1369,9 +1380,9 @@ fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param val (consts, bmv_defs, SSupp_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 ops lives' consts lthy; - val param_goals = @{map 5} (fn Sb => fn Injs => fn SSupps => fn Vrs => Option.map (fn { Map, Supps } => - mk_param_axiom Map Supps SSupps Sb Injs Vrs bd lthy - )) Sbs Injs (#SSupps consts) Vrs (#params consts); + val param_goals = @{map 6} (fn Sb => fn Injs => fn SSupps => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => + mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy + )) Sbs Injs (#SSupps consts) RVrs Vrs (#params consts); val (goals, SSupp_eq_goals) = mk_bmv_monad_axioms ops consts SSupp_defs [] lthy; @@ -1505,7 +1516,7 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} "register a parametrized bounded multi-variate monad" ((parse_opt_binding_colon -- Parse.and_list1 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.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 "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Maps" || Parse.reserved "bd") (Parse.underscore || Parse.term))))) -- diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 454029d2..aba77866 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -154,7 +154,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs bmv axioms' lthy = let val names = map (fst o dest_Free); - val facts' = @{map 7} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn SSupps => + val facts' = @{map 8} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn RVrs => fn SSupps => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -168,8 +168,11 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ) fs var_types)); val (live_fs, bound_fs, free_fs) = MRBNF_Def.deinterlace fs var_types; - val (((gs, aa), x), _) = lthy - |> mk_Frees "g" (map fastype_of Injs) + 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); @@ -182,20 +185,23 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b )) SSupps 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_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs; + val Sb_comp_right = let val fs' = map (the o find_f o domain_type o fastype_of) gs; val f'_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) fs'; val goal = Term.subst_atomic_types (As' ~~ As) (mk_Trueprop_eq ( - Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) gs fs'), + Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) (hs @ gs) (h_fs @ fs')), HOLogic.mk_comp ( - Term.list_comb (Sb, gs), + Term.list_comb (Sb, hs @ gs), Term.list_comb (mapx, map (fn T => case List.find (fn f => (domain_type T) = domain_type (fastype_of f)) fs' of SOME f => f | NONE => HOLogic.id_const (domain_type T) ) (fst (split_last (binder_types (fastype_of mapx))))) ) )); - in Goal.prove_sorry lthy (names (fs' @ gs)) (f'_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + in Goal.prove_sorry lthy (names (fs' @ hs @ gs)) (f'_prems @ h_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], REPEAT_DETERM o resolve_tac ctxt prems, rtac ctxt sym, @@ -276,9 +282,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b } end ) axioms' mrbnfs (BMV_Monad_Def.axioms_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.SSupps_of_bmv_monad bmv); + (BMV_Monad_Def.RVrs_of_bmv_monad bmv) (BMV_Monad_Def.SSupps_of_bmv_monad bmv); - val facts' = @{map 8} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn SSupps => + val facts' = @{map 9} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn RVrs => fn Injs => fn SSupps => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -288,8 +294,11 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 (((gs, aa), x), _) = lthy - |> mk_Frees "g" (map fastype_of Injs) + 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); @@ -299,16 +308,23 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b mk_ordLess (mk_card_of (SSupp $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) )) SSupps 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 infinite_UNIV = @{thm cinfinite_imp_infinite} OF [MRBNF_Def.UNIV_cinfinite_of_mrbnf (hd mrbnfs)]; + 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 Inj)) mrbnfs) ) Injs; - fun find_f T = List.find (curry (op=) T o domain_type o fastype_of) fs; val goal = mk_Trueprop_eq ( - HOLogic.mk_comp (map_t, Term.list_comb (Sb, gs)), - HOLogic.mk_comp (Term.list_comb (Term.subst_atomic_types (As ~~ As') Sb, map2 (fn g => fn mrbnf => + 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 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, @@ -324,7 +340,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b (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 + MRBNF_Def.free_of_mrbnf mrbnf - length frees; - in Goal.prove_sorry lthy (names (fs @ gs)) (f_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + in Goal.prove_sorry lthy (names (fs @ hs @ gs)) (f_prems @ h_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ if count = 0 then K all_tac else EVERY' [ rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, @@ -365,7 +381,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Sb_comp_right facts), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound} + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound supp_comp_bound} + @ [infinite_UNIV] @ maps (map_filter I o #SSupp_map_bound) facts' @ prems @ #SSupp_comp_bound bmv_facts ), K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), @@ -387,8 +404,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b map_Sb_strong = map_Sb_strong }: mrsbnf_facts end ) axioms' facts' mrbnfs (BMV_Monad_Def.axioms_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.SSupps_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) (BMV_Monad_Def.SSupps_of_bmv_monad bmv); val mrsbnf = MRSBNF { mrbnfs = mrbnfs, @@ -447,7 +464,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); end; - val axioms = @{map 6} (fn mrbnf => fn Sb => fn Injs => fn SSupps => fn Vrs => fn bmv_frees => + val axioms = @{map 7} (fn mrbnf => fn Sb => fn Injs => fn SSupps => fn RVrs => fn Vrs => fn bmv_frees => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -468,7 +485,9 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = (map HOLogic.id_const As) (map HOLogic.id_const Bs) (free_fs @ map HOLogic.id_const (drop (length frees) Fs)) (MRBNF_Def.var_types_of_mrbnf mrbnf) ), - Term.list_comb (Sb, map (fn Inj => + Term.list_comb (Sb, map (fn RVr => the (List.find (fn f => + HOLogic.dest_setT (body_type (fastype_of RVr)) = domain_type (fastype_of f) + ) fs)) RVrs @ map (fn Inj => HOLogic.mk_comp (Inj, the (List.find (fn f => (op=) (apply2 (domain_type o fastype_of) (Inj, f))) fs)) ) Injs) ))); @@ -512,12 +531,11 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = mk_Trueprop_eq (set $ (Term.list_comb (Sb, gs) $ x), set $ x) ))) sets' end; - val Vrs' = bmv_frees ~~ transpose Vrs; val set_Vrs = map (fn set => let val aT = HOLogic.dest_setT (fastype_of (set $ x)); - val Vrs = the (AList.lookup (op=) Vrs' aT); - val Vrs' = map_filter (Option.map (fn Vrs => Vrs $ x)) Vrs; + 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' @@ -530,8 +548,8 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = set_Sb = set_Sbs }: term mrsbnf_axioms end ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) - (BMV_Monad_Def.SSupps_of_bmv_monad bmv) (BMV_Monad_Def.Vrs_of_bmv_monad bmv) - (BMV_Monad_Def.frees_of_bmv_monad bmv); + (BMV_Monad_Def.SSupps_of_bmv_monad bmv) (BMV_Monad_Def.RVrs_of_bmv_monad bmv) + (BMV_Monad_Def.Vrs_of_bmv_monad bmv) (BMV_Monad_Def.frees_of_bmv_monad bmv); in (axioms, (deads, As, As', Bs, Fs, fs), mrbnfs, bmv) end diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 0176b5f2..6431f657 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -9,8 +9,7 @@ type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = + '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\" -ML_file \../Tools/mrsbnf_comp.ML\ - +(*ML_file \../Tools/mrsbnf_comp.ML\*) diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 943b3e0b..0e785d17 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -2,7 +2,7 @@ theory BMV_Monad imports "Binders.MRBNF_Recursor" keywords "print_pbmv_monads" :: diag and "pbmv_monad" :: thy_goal and - "mrsbnf" :: thy_goal + "mrsbnf" :: thy_goal begin local_setup \fn lthy => @@ -131,7 +131,7 @@ ML_file \../Tools/bmv_monad_def.ML\ local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ -(*ML_file \../Tools/mrsbnf_def.ML\*) +ML_file \../Tools/mrsbnf_def.ML\ pbmv_monad "'tv::var FType" Sbs: tvsubst_FType @@ -151,10 +151,10 @@ pbmv_monad "'tv::var FType" done print_theorems -(*mrsbnf "'a::var FType" +mrsbnf "'a::var FType" apply (rule map_is_Sb_FType; assumption) done -print_theorems*) +print_theorems binder_datatype 'a LM = Var 'a @@ -279,20 +279,20 @@ next by blast qed (auto simp: assms imsupp_supp_bound infinite_UNIV) -(* lemma +(* lemma fixes g::"'a LM \ 'a LM" and f ::"'a \ 'a LM" shows "IImsupp_LM (g o f) \ IImsupp_LM g \ IImsupp_LM f" unfolding IImsupp_LM_def *) (* AtoJ: Proved this first (which is anyway generally useful) *) -lemma FVars_LM_Sb_LM: +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 using assms by auto subgoal apply(subst Vrs_2_Sb_LM) subgoal using assms by auto subgoal using assms by auto @@ -302,36 +302,28 @@ lemma IImsupp_o: fixes g::"'a::var \ 'a" assumes "|supp g| '| | ' \ \) \ imsupp g \ IImsupp_LM \' \ IImsupp_LM \" -unfolding IImsupp_LM_def SSupp_LM_def imsupp_def supp_def using assms apply safe - subgoal by auto +unfolding IImsupp_LM_def SSupp_LM_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 subgoal by simp (metis Vrs_Un LM.set(1) Sb_LM_simp1 UnCI emptyE insert_iff) . . -(* - apply (rule subsetI) - apply (unfold IImsupp_LM_def) - apply (erule UnE) - apply (unfold SSupp_LM_def VVr_eq_Var_LM mem_Collect_eq comp_def)[1] - subgoal for x - apply (rule case_split[of "\ x = Var x"]) - apply simp - by blast - apply (erule UN_E) - apply (unfold0 comp_apply) - subgoal for x y - apply (rule case_split[of "\ y = Var y"]) - apply (unfold SSupp_LM_def VVr_eq_Var_LM mem_Collect_eq comp_def)[1] - apply auto[1] - apply (unfold Vrs_Un) - apply (erule UnE) - apply (subst (asm) Vrs_1_Sb_LM) - apply (rule assms)+ - apply (erule UnE) - oops -*) - +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" "IImsupp_LM \'" "imsupp f" "IImsupp_LM \" rule: LM.strong_induct) + apply (auto simp: imsupp_supp_bound infinite_UNIV assms LM.permute_id) + by (metis (mono_tags, lifting) IImsupp_LM_def SSupp_LM_def Un_iff imsupp_def mem_Collect_eq supp_def) pbmv_monad "'b::var LM" Sbs: Sb_LM @@ -363,18 +355,50 @@ pbmv_monad "'b::var LM" 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_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 infinite_UNIV) + apply (subst Sb_LM_simp4) + apply assumption + apply (unfold IImsupp_LM_def SSupp_LM_def VVr_eq_Var_LM 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 typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" by (rule UNIV_witness) -pbmv_monad "('a1::var, 'a2, 'c1, 'c2) L'" and "'a1::var" - Sbs: "\f x. Abs_L' (map_prod (f::'a1::var \ 'a1) (map_prod f id) (Rep_L' x))" and "id :: ('a1 \ 'a1) \ 'a1 \ 'a1::var" - Injs: "id :: 'a1::var \ 'a1" and "id :: 'a1 \ 'a1::var" - Vrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1::'a1::var, x2}" and "\x. {x::'a1::var}" - Map: "\f1 f2 x. Abs_L' (map_prod id (map_prod id (map_sum f1 f2)) (Rep_L' x))" +pbmv_monad "('a1::var, 'a2, 'c1, 'c2) L'" + Sbs: "\f x. Abs_L' (map_prod f (map_prod f id) (Rep_L' x))" + RVrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1, x2}" + Maps: "\f1 f2 x. Abs_L' (map_prod id (map_prod id (map_sum f1 f2)) (Rep_L' x))" Supps: "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setl y" "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setr y" bd: natLeq apply (rule infinite_regular_card_order_natLeq) @@ -392,28 +416,7 @@ pbmv_monad "('a1::var, 'a2, 'c1, 'c2) L'" and "'a1::var apply (rule sum.map_cong0) apply (auto elim!: snds.cases) done - -print_pbmv_monads - -ML \ -Multithreading.parallel_proofs := 0 -\ -local_setup \fn lthy => - let - val (bmv, (thms, lthy)) = MRSBNF_Def.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) [] I - @{typ "('a1, 'a2, 'a1 * 'a2, 'a1 * 'a2 * 'a2 * 'a2 FType) L'"} - ([], lthy) - - val _ = @{print} (map (map (map (Option.map (Thm.cterm_of lthy o - Raw_Simplifier.rewrite_term (Proof_Context.theory_of lthy) - (@{thms } @ thms) [] - )))) ( - BMV_Monad_Def.Vrs_of_bmv_monad (the bmv) - )) - - val _ = @{print} bmv - in lthy end\ -print_pbmv_monads +print_theorems (* *) type_synonym ('a1, 'a2, 'c1, 'c2) L = "'a1 * 'a1 * ('c1 + 'c2)" (* PBMV *) @@ -512,7 +515,6 @@ typ "('a1, 'a2) L1_M2" typ "('a1, 'a2) L2_M2" ML \ -val id_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.ID") val FType_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.FType") \ @@ -525,35 +527,23 @@ val model_L = { lives = [[@{typ "'c1"}, @{typ "'c2"}]], lives' = [[@{typ "'c1'"}, @{typ "'c2'"}]], deads = [[]], - bmv_ops = [BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a1"}] - )) id_bmv], + bmv_ops = [], consts = { bd = @{term natLeq}, - Injs = [[@{term "id :: 'a1 \ 'a1"}]], Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], - (*Vrs = [[[ - SOME @{term "\(x1::'a1, x2::'a1, p::'c1 + 'c2). {x1, x2}"} - ]]],*) - Vrs = [[[ - SOME @{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"} - ]]], - SSupps = [[NONE]], + RVrs = [[@{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}]], + Injs = [[]], + Vrs = [[]], + SSupps = [[]], params = [SOME { - (*Map = @{term "\(f1::'c1 => 'c1') (f2::'c2 => 'c2') (a1::'a1, a2::'a1, p). (a1, a2, map_sum f1 f2 p)"},*) Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, - (*Supps = [ - @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setl p"}, - @{term "\(a1::'a1, a2::'a1, p::('c1+'c2)). Basic_BNFs.setr p"} - ],*) Supps = [ @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} ] }] }, - SSupp_eq = [[NONE]], + SSupp_eq = [[]], params = [SOME { axioms = { Map_id = fn ctxt => EVERY1 [ @@ -596,10 +586,10 @@ val model_L = { K (Local_Defs.unfold0_tac ctxt @{thms case_prod_map_prod id_apply Sb_L_def Supp_L_1_def Supp_L_2_def}), resolve_tac ctxt [refl] ]), - Map_Vrs = [[SOME (fn ctxt => EVERY1 [ + Map_Vrs = [fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Map_L_def case_prod_beta fst_conv snd_conv}), resolve_tac ctxt [refl] - ])]] + ]] }], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ @@ -615,20 +605,20 @@ val model_L = { )), resolve_tac ctxt [refl] ], - Vrs_bds = [[SOME (fn ctxt => EVERY1 [ + Vrs_bds = [fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def case_prod_beta}), resolve_tac ctxt @{thms insert_bound}, resolve_tac ctxt @{thms natLeq_Cinfinite}, resolve_tac ctxt @{thms ID.set_bd} - ])]], + ]], Vrs_Injs = [], - Vrs_Sbs = [[SOME (fn ctxt => EVERY1 [ + Vrs_Sbs = [fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta - Product_Type.fst_map_prod Product_Type.snd_map_prod + Product_Type.fst_map_prod Product_Type.snd_map_prod image_insert image_empty UN_insert UN_empty Un_empty_right insert_is_Un[symmetric] }), resolve_tac ctxt [refl] - ])]], + ]], Sb_cong = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta}), resolve_tac ctxt @{thms prod.map_cong0}, @@ -662,32 +652,20 @@ val model_L1 = { lives = [[]], lives' = [[]], deads = [[]], - bmv_ops = [ - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a1"}] - )) id_bmv, - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a2"}] - )) id_bmv - ], + bmv_ops = [], consts = { bd = @{term natLeq}, - Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}]], + Injs = [[]], Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], - (*Vrs = [[ - [SOME @{term "\(x::'a1, x2::'a2). {x}"}, NONE], - [NONE, SOME @{term "\(x::'a1, x2::'a2). {x2}"}] - ]],*) - Vrs = [[ - [SOME @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, NONE], - [NONE, SOME @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"}] + Vrs = [[]], + RVrs = [[ + @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, + @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"} ]], params = [NONE], - SSupps = [[NONE, NONE]] + SSupps = [[]] }, - SSupp_eq = [[NONE, NONE]], + SSupp_eq = [[]], params = [NONE], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ @@ -704,21 +682,21 @@ val model_L1 = { resolve_tac ctxt [refl] ], Vrs_bds = [ - [SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1), NONE], - [NONE, SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1)] + fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1, + fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1 ], Vrs_Injs = [], Vrs_Sbs = [ - [SOME (fn ctxt => EVERY1 [ + fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Sb_L1_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single image_insert image_empty}), resolve_tac ctxt [refl] - ]), NONE], - [NONE, SOME (fn ctxt => EVERY1 [ + ], + fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def Sb_L1_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single image_insert image_empty}), resolve_tac ctxt [refl] - ])] + ] ], Sb_cong = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Vrs_L1_2_def Sb_L1_def case_prod_beta}), @@ -751,14 +729,6 @@ val model_L2 = { lives' = [[]], deads = [[]], bmv_ops = [ - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a1"}] - )) id_bmv, - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - hd (BMV_Monad_Def.frees_of_bmv_monad id_bmv) ~~ [@{typ "'a2"}] - )) id_bmv, BMV_Monad_Def.morph_bmv_monad ( MRBNF_Util.subst_typ_morphism ( hd (BMV_Monad_Def.frees_of_bmv_monad FType_bmv) ~~ [@{typ "'a2::var"}] @@ -766,17 +736,19 @@ val model_L2 = { ], consts = { bd = @{term natLeq}, - Injs = [[@{term "id :: 'a1 \ 'a1"}, @{term "id :: 'a2 \ 'a2"}, @{term "TyVar :: 'a2::var \ 'a2 FType"}]], + RVrs = [[ + @{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, + @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"} + ]], + Injs = [[@{term "TyVar :: 'a2::var \ 'a2 FType"}]], + SSupps = [[SOME @{term "SSupp_FType :: ('a2::var \ 'a2 FType) \ 'a2 set"}]], Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], Vrs = [[ - [SOME @{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, NONE], - [NONE, SOME @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"}], - [NONE, SOME @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"}] + @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"} ]], - params = [NONE], - SSupps = [[NONE, NONE, SOME @{term "SSupp_FType :: ('a2::var \ 'a2 FType) \ 'a2 set"}]] + params = [NONE] }, - SSupp_eq = [[NONE, NONE, SOME (fn ctxt => + SSupp_eq = [[SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]} THEN resolve_tac ctxt [refl] 1 )]], @@ -796,34 +768,34 @@ val model_L2 = { resolve_tac ctxt [refl] ], Vrs_bds = [ - [SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_1_def} THEN resolve_tac ctxt @{thms ID.set_bd} 1), NONE], - [NONE, SOME (fn ctxt => EVERY1 [ + fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_1_def} THEN resolve_tac ctxt @{thms ID.set_bd} 1, + fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_2_def}), resolve_tac ctxt @{thms insert_bound}, resolve_tac ctxt @{thms natLeq_Cinfinite}, resolve_tac ctxt @{thms ID.set_bd} - ])], - [NONE, SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_3_def} THEN resolve_tac ctxt @{thms FType.set_bd} 1)] + ], + fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_3_def} THEN resolve_tac ctxt @{thms FType.set_bd} 1 ], Vrs_Injs = [], Vrs_Sbs = [ - [SOME (fn ctxt => EVERY1 [ + fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply image_insert image_empty}), resolve_tac ctxt [refl] - ]), NONE], - [NONE, SOME (fn ctxt => EVERY1 [ + ], + fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta insert_is_Un[symmetric] UN_insert UN_empty Un_empty_right id_apply}), + K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta insert_is_Un[symmetric] UN_insert UN_empty Un_empty_right id_apply image_insert image_empty}), resolve_tac ctxt [refl] - ])], - [NONE, SOME (fn ctxt => EVERY1 [ + ], + fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_3_def case_prod_map_prod}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), resolve_tac ctxt @{thms Vrs_Sb_FType}, K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), assume_tac ctxt - ])] + ] ], Sb_cong = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def Vrs_L2_3_def case_prod_beta id_apply}), @@ -874,8 +846,12 @@ local_setup \fn lthy => val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") (SOME (Binding.name "L1")) model_L1 lthy; val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") (SOME (Binding.name "L2")) model_L2 lthy; + val (_, lthy) = @{fold_map 2} (BMV_Monad_Def.note_bmv_monad_thms (K BNF_Def.Note_All) I o SOME o Binding.name) ["L", "L1", "L2"] [L_bmv, L1_bmv, L2_bmv] lthy; + val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [MRBNF_Util.Inl L1_bmv, MRBNF_Util.Inl L2_bmv] lthy val _ = @{print} comp_bmv in lthy end \ +print_theorems + end diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index be860b3b..5af4faf8 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -174,6 +174,7 @@ lemma id_on_both: "a z = z \ b z = z \ a z = b z lemma not_imageI: "bij f \ a \ A \ f a \ f ` A" by (force simp: bij_implies_inject) +(* TODO: Remove *) lemma Un_bound: assumes inf: "infinite (UNIV :: 'a set)" and "|A1| |A| |insert x A| |{x}| |B| Cinfinite r \ |A \ B| Date: Mon, 5 May 2025 15:06:11 +0100 Subject: [PATCH 30/90] Make use of free vars in mrbnf when constructing mrsbnf/bmv from them --- Tools/bmv_monad_def.ML | 166 ++++++++++++++++++++++++------------ Tools/mrsbnf_comp.ML | 124 ++++++++++++++++++++++++--- Tools/mrsbnf_def.ML | 70 ++++++++++----- operations/BMV_Fixpoint.thy | 12 ++- operations/BMV_Monad.thy | 16 ++-- 5 files changed, 293 insertions(+), 95 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 198bac9d..becda5c2 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -93,10 +93,8 @@ signature BMV_MONAD_DEF = sig val pbmv_monad_of_generic: Context.generic -> string -> bmv_monad option; val pbmv_monad_of: Proof.context -> string -> bmv_monad option; - val id_mrbnf: MRBNF_Def.mrbnf; - - val pbmv_monad_of_bnf: BNF_Def.bnf -> local_theory -> bmv_monad * local_theory - val register_bnf_as_pbmv_monad: string -> local_theory -> local_theory + val pbmv_monad_of_mrbnf: 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) @@ -110,8 +108,6 @@ structure BMV_Monad_Def : BMV_MONAD_DEF = struct open MRBNF_Util -val id_mrbnf = the (MRBNF_Def.mrbnf_of @{context} "BMV_Monad.ID"); - type 'a bmv_monad_axioms = { Sb_Inj: 'a, Sb_comp_Injs: 'a list, @@ -539,11 +535,11 @@ fun mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy = )) ) (RVrs @ Vrs); - val Supp_Sb = map (fn Supp => - fold_rev Logic.all (rhos @ hs @ [x]) (mk_Trueprop_eq ( + val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ hs @ [x]) ( + fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos SSupps) (mk_Trueprop_eq ( Supp $ (Term.list_comb (Sb, hs @ rhos) $ x), Supp $ x )) - ) Supps; + )) Supps; in { axioms = { Map_id = Map_id, @@ -899,75 +895,139 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont val model = mk_thm_model model params axioms SSupp_eq bd_irco; in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt model lthy) end -fun pbmv_monad_of_bnf bnf lthy = +fun pbmv_monad_of_mrbnf mrbnf lthy = let - val (((lives, lives'), deads), _) = lthy - |> mk_TFrees (BNF_Def.live_of_bnf bnf) - ||>> mk_TFrees (BNF_Def.live_of_bnf bnf) - ||>> mk_TFrees' (map Type.sort_of_atyp (BNF_Def.deads_of_bnf bnf)) - val T = BNF_Def.mk_T_of_bnf deads lives bnf; - val n = BNF_Def.live_of_bnf bnf; - val var_class = case BNF_Def.bd_of_bnf bnf of + 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 = case MRBNF_Def.bd_of_mrbnf mrbnf of @{term natLeq} => @{class var} | _ => error "TODO: other var classes" + + 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) + )) + ); in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I NONE { ops = [T], var_class = var_class, leader = 0, - frees = [[]], + frees = [frees], lives = [lives], lives' = [lives'], - deads = [deads], + deads = [bounds @ deads], bmv_ops = [], consts = { - bd = BNF_Def.bd_of_bnf bnf, + bd = MRBNF_Def.bd_of_mrbnf mrbnf, Injs = [[]], SSupps = [[]], - Sbs = [HOLogic.id_const T], + Sbs = [Sb], Vrs = [[]], - RVrs = [[]], - params = [SOME { - Map = BNF_Def.mk_map_of_bnf deads lives lives' bnf, - Supps = BNF_Def.mk_sets_of_bnf (replicate n deads) (replicate n lives) bnf - }] + RVrs = [fsets], + params = [Option.map (fn Map => { + Map = Map, + Supps = lsets + }) Map] }, - params = [SOME { + params = [Option.map (fn _ => { axioms = { - Map_id = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, - Map_comp = fn ctxt => rtac ctxt (BNF_Def.map_comp0_of_bnf bnf RS sym) 1, - Supp_Map = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_map_of_bnf bnf), - Supp_bd = map (fn thm => fn ctxt => rtac ctxt thm 1) (BNF_Def.set_bd_of_bnf bnf), + 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 (BNF_Def.map_cong0_of_bnf bnf), - REPEAT_DETERM o Goal.assume_rule_tac ctxt + 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 => Local_Defs.unfold0_tac ctxt @{thms id_o o_id} THEN rtac ctxt refl 1, - Supp_Sb = replicate n (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_apply} THEN rtac ctxt refl 1), - Map_Vrs = [] - }], - bd_infinite_regular_card_order = fn ctxt => EVERY1 [ - rtac ctxt @{thm infinite_regular_card_order.intro}, - rtac ctxt (BNF_Def.bd_card_order_of_bnf bnf), - rtac ctxt (BNF_Def.bd_cinfinite_of_bnf bnf), - rtac ctxt (BNF_Def.bd_regularCard_of_bnf bnf) - ], + 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, + Map_Vrs = 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], + bd_infinite_regular_card_order = fn ctxt => rtac ctxt (MRBNF_Def.bd_infinite_regular_card_order_of_mrbnf mrbnf) 1, SSupp_eq = [[]], tacs = [{ - Sb_Inj = fn ctxt => rtac ctxt refl 1, + Sb_Inj = fn ctxt => resolve_tac ctxt [refl, MRBNF_Def.map_id0_of_mrbnf mrbnf] 1, Sb_comp_Injs = [], - Sb_comp = fn ctxt => rtac ctxt @{thm id_o} 1, - Vrs_bds = [], + 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_Injs = [], - Vrs_Sbs = [], - Sb_cong = fn ctxt => rtac ctxt refl 1 + 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_bnf_as_pbmv_monad name lthy = +fun register_mrbnf_as_pbmv_monad name lthy = let - val bnf = the (BNF_Def.bnf_of lthy name); - val (bmv, lthy) = pbmv_monad_of_bnf bnf lthy; + val mrbnf = the (MRBNF_Def.mrbnf_of lthy name); + val (bmv, lthy) = pbmv_monad_of_mrbnf mrbnf lthy; val lthy = register_pbmv_monad name bmv lthy; in lthy end @@ -980,7 +1040,6 @@ fun slice_bmv_monad n bmv = let fun f xs = nth xs n; val Sb = f (Sbs_of_bmv_monad bmv); - val vars = map TFree (Term.add_tfrees Sb []); in BMV { ops = [f (ops_of_bmv_monad bmv)], var_class = var_class_of_bmv_monad bmv, @@ -1230,8 +1289,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ), K (prefer_tac 2), rtac ctxt (#Map_cong (#axioms param)), - K (Local_Defs.unfold0_tac ctxt (#Supp_Sb param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ + EqSubst.eqsubst_asm_tac ctxt [0] (#Supp_Sb param), + REPEAT_DETERM o resolve_tac ctxt prems, resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 1cac900f..794e936d 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -1,24 +1,122 @@ signature MRSBNF_COMP = sig - val id_mrsbnf: MRSBNF_Def.mrsbnf - - val mrsbnf_of_typ: bool -> BNF_Def.inline_policy -> (theory -> BNF_Def.fact_policy) - -> (binding -> binding) -> ((string * sort) * MRBNF_Def.var_type) list -> typ - -> (thm list * local_theory) -> MRSBNF_Def.mrsbnf option * (thm list * local_theory) + val mrsbnf_of_typ: bool -> (theory -> BNF_Def.fact_policy) + -> (binding -> binding) -> (string * sort) list -> ((string * sort) * MRBNF_Def.var_type) list + -> typ -> ((MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory) + -> ((MRSBNF_Def.mrsbnf, MRBNF_Def.mrbnf) MRBNF_Util.either * (typ list * typ list)) + * ((MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory) end structure MRSBNF_Comp : MRSBNF_COMP = struct -val id_mrsbnf = the (MRSBNF_Def.mrsbnf_of @{context} "BNF_Composition.ID"); +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 mrsbnf_of_typ _ _ _ _ var_types (TFree (x, _)) accum = (case AList.lookup ((op=) o apsnd fst) var_types x of - SOME MRBNF_Def.Free_Var => (SOME id_mrsbnf, accum) - | _ => (SOME id_mrsbnf, accum)) +fun is_Inl (Inl _) = true + | is_Inl _ = false + +fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = + (if member (op =) Ds0 T' then ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), accum) 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) + | [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 accum + in ((Inr ID', ([], [T])), accum') end + | _ => error "Same variable appears twice in var_types" + ) + ) | mrsbnf_of_typ _ _ _ _ _ (TVar _) _ = error "unexpected schematic variable" - | mrsbnf_of_typ optim const_policy inline_policy qualify var_types (T as Type (n, Ts)) (accum, lthy) = - let - - in error "bar" end; + | mrsbnf_of_typ optim const_policy qualify' Ds0 var_types (T as Type (n, Ts)) (accum, lthy) = (case mrsbnf_of lthy n of + NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), (accum, lthy)) + | SOME (outer, lthy) => + if optim andalso forall is_TFree Ts then + let + val mrbnf = case outer of + Inl mrsbnf => hd (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + | Inr mrbnf => mrbnf; + val mrbnf' = MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism ( + snd (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf)) ~~ Ts + )) 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 _ = @{print} 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 the_default var_type req + ) 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, (accum, lthy)) + else case outer of + Inl mrsbnf => error "TODO: Demote MRSBNF" + | Inr mrbnf => 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')), 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)), (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) + (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' (accum, lthy)); + + val _ = @{print} T + 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 + val (outer', lthy) = case outer of + Inl mrsbnf => (mrsbnf, lthy) + | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf lthy + val (inners', lthy) = fold_map (fn Inl mrsbnf => (fn lthy => (mrsbnf, lthy)) + | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf + ) inners lthy; + val _ = @{print} (outer' :: inners') + val _ = () + in error "TODO: compose mrsbnfs" end + else + 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 index aba77866..e0e51f4f 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -27,7 +27,7 @@ signature MRSBNF_DEF = sig -> MRBNF_Def.mrbnf list -> BMV_Monad_Def.bmv_monad -> (Proof.context -> tactic) mrsbnf_axioms list -> local_theory -> mrsbnf * local_theory; - val mrsbnf_of_bnf: BNF_Def.bnf -> local_theory -> mrsbnf * local_theory; + val mrsbnf_of_mrbnf: MRBNF_Def.mrbnf -> local_theory -> mrsbnf * local_theory; val register_mrsbnf: string -> mrsbnf -> local_theory -> local_theory; val mrsbnf_of_generic: Context.generic -> string -> mrsbnf option; @@ -186,6 +186,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 Sb_comp_right = @@ -196,12 +197,12 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) (hs @ gs) (h_fs @ fs')), HOLogic.mk_comp ( Term.list_comb (Sb, hs @ gs), - Term.list_comb (mapx, map (fn T => case List.find (fn f => (domain_type T) = domain_type (fastype_of f)) fs' of + Term.list_comb (mapx, map (fn T => case List.find (fn f => (domain_type T) = domain_type (fastype_of f)) (h_fs @ fs') of SOME f => f | NONE => HOLogic.id_const (domain_type T) ) (fst (split_last (binder_types (fastype_of mapx))))) ) )); - in Goal.prove_sorry lthy (names (fs' @ hs @ gs)) (f'_prems @ h_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + in Goal.prove_sorry lthy (names (distinct (op=) (h_fs @ fs' @ hs @ gs))) (distinct (op=) (h_fs_prems @ f'_prems @ h_prems @ g_prems)) goal (fn {context=ctxt, prems} => EVERY1 [ EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], REPEAT_DETERM o resolve_tac ctxt prems, rtac ctxt sym, @@ -216,6 +217,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt refl ]) end; + val Inj_aas = distinct (op=) (map (domain_type o fastype_of) Injs); + val map_Inj = @{map 3} (fn Inj => fn f => fn a => if body_type (fastype_of Inj) <> T then NONE else let val goal = mk_Trueprop_eq (Term.list_comb (mapx, fs) $ (Inj $ a), Inj $ (f $ a)) in SOME (Goal.prove_sorry lthy (names (fs @ [a])) f_prems goal (fn {context=ctxt, prems} => EVERY1 [ @@ -227,7 +230,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), rtac ctxt @{thm comp_apply} ])) end - ) Injs free_fs aa; + ) Injs (filter (member (op=) Inj_aas o domain_type o fastype_of) free_fs) (map (fn aT => the (List.find (curry (op=) aT o fastype_of) aa)) Inj_aas); val SSupp_map_subset = @{map 3} (fn (SSupp, SSupp_def) => fn g => fn g_prem => let @@ -323,7 +326,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 fs @ + 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 ( @@ -340,6 +343,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b (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 + MRBNF_Def.free_of_mrbnf mrbnf - length frees; + 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'); in Goal.prove_sorry lthy (names (fs @ hs @ gs)) (f_prems @ h_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ if count = 0 then K all_tac else EVERY' [ rtac ctxt trans, @@ -373,7 +379,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ] ORELSE' EVERY' [ REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map (fn ax => #map_is_Sb ax RS sym) axioms'), + EqSubst.eqsubst_tac ctxt [0] (map (fn thm => thm RS sym) map_is_Sb), REPEAT_DETERM o resolve_tac ctxt prems ], if count = 0 then K all_tac else rtac ctxt refl, @@ -492,8 +498,11 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ) Injs) ))); - val ((gs, x), _) = names_lthy + 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; @@ -509,13 +518,14 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val g_prems = map2 (fn (SSupp, _) => fn g => HOLogic.mk_Trueprop (uncurry mk_ordLess ( mk_card_of (SSupp $ g), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) ))) SSupps gs; + val h_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs; val count = live + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; val map_Sb = if count - free = 0 then NONE else let val map_t = Term.list_comb (mapx, MRBNF_Def.interlace live_fs bound_fs (map HOLogic.id_const frees @ pfree_fs) var_types); - val Sb_t = Term.list_comb (Sb, gs); - in SOME (fold_rev Logic.all (other_fs @ gs) (fold_rev (curry Logic.mk_implies) (other_prems @ g_prems) (mk_Trueprop_eq ( + 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 @ h_prems @ g_prems) (mk_Trueprop_eq ( HOLogic.mk_comp (map_t, Sb_t), HOLogic.mk_comp (Term.subst_atomic_types (As ~~ As') Sb_t, map_t) )))) end; @@ -527,8 +537,8 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = let val sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) (replicate free [] @ map single (drop free free_sets)) var_types); - in map (fn set => fold_rev Logic.all (gs @ [x]) (fold_rev (curry Logic.mk_implies) g_prems ( - mk_Trueprop_eq (set $ (Term.list_comb (Sb, gs) $ x), set $ x) + in map (fn set => fold_rev Logic.all (hs @ gs @ [x]) (fold_rev (curry Logic.mk_implies) (h_prems @ g_prems) ( + mk_Trueprop_eq (set $ (Term.list_comb (Sb, hs @ gs) $ x), set $ x) ))) sets' end; val set_Vrs = map (fn set => @@ -564,15 +574,37 @@ fun mrsbnf_def fact_policy qualify name_opt mrbnfs bmv tacs lthy = 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_bnf bnf lthy = +fun mrsbnf_of_mrbnf mrbnf lthy = let - val (mrbnf, lthy) = MRBNF_Def.mrbnf_of_bnf bnf lthy; - val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_bnf bnf lthy; + val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_mrbnf 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; in mrsbnf_def (K BNF_Def.Dont_Note) I NONE [mrbnf] bmv [{ - map_Sb = SOME (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_o o_id} THEN rtac ctxt refl 1), - map_is_Sb = fn ctxt => rtac ctxt (BNF_Def.map_id0_of_bnf bnf) 1, - set_Sb = replicate (BNF_Def.live_of_bnf bnf) (fn ctxt => Local_Defs.unfold0_tac ctxt @{thms id_apply} THEN rtac ctxt refl 1), - set_Vrs = [] + map_Sb = SOME (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 + ] + ]), + map_is_Sb = fn ctxt => resolve_tac ctxt [refl, MRBNF_Def.map_id0_of_mrbnf mrbnf] 1, + set_Sb = replicate n (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} + ] + ]), + set_Vrs = replicate (MRBNF_Def.free_of_mrbnf mrbnf) (fn ctxt => rtac ctxt refl 1) }] lthy end; fun mrsbnf_cmd (b, Ts) lthy = @@ -580,7 +612,7 @@ fun mrsbnf_cmd (b, Ts) lthy = val Ts = map (Syntax.read_typ lthy) Ts; val name = if Binding.is_empty b then fst (dest_Type (hd Ts)) else Local_Theory.full_name lthy b; val (mrbnfs, lthy) = fold_map (fn T => fn lthy => case T of - TFree _ => (BMV_Monad_Def.id_mrbnf, lthy) + TFree _ => error "Illegal free variable" | TVar _ => error "Illegal schematic variable" | Type (name, _) => case MRBNF_Def.mrbnf_of lthy name of SOME mrbnf => (mrbnf, lthy) diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 6431f657..53abee51 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -9,9 +9,19 @@ type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = + '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\" -(*ML_file \../Tools/mrsbnf_comp.ML\*) +ML_file \../Tools/mrsbnf_comp.ML\ +local_setup \fn lthy => +let + val ((mrsbnf, tys), (_, lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) + I [] (map (apfst dest_TFree) [(@{typ 'v}, MRBNF_Def.Free_Var), + (@{typ 'btv}, MRBNF_Def.Bound_Var), (@{typ 'bv}, MRBNF_Def.Bound_Var)]) + @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} + ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy); + val _ = @{print} mrsbnf +in lthy end +\ diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 0e785d17..d32a74d8 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -5,14 +5,6 @@ theory BMV_Monad "mrsbnf" :: thy_goal begin -local_setup \fn lthy => - let - val (id_mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I [MRBNF_Def.Free_Var] MRBNF_Comp.ID_mrbnf - ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy); - val lthy = MRBNF_Def.register_mrbnf_raw "BMV_Monad.ID" id_mrbnf lthy - in lthy end -\ - declare [[mrbnf_internals]] binder_datatype 'a FType = TyVar 'a @@ -129,10 +121,16 @@ declare [[ML_print_depth=1000]] ML_file \../Tools/bmv_monad_def.ML\ -local_setup \fold BMV_Monad_Def.register_bnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ +local_setup \fold BMV_Monad_Def.register_mrbnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ ML_file \../Tools/mrsbnf_def.ML\ +local_setup \fn lthy => +let + val (mrsbnf, _) = MRSBNF_Def.mrsbnf_of_mrbnf (the (MRBNF_Def.mrbnf_of lthy @{type_name FType_pre})) lthy; + val _ = @{print} mrsbnf +in lthy end\ + pbmv_monad "'tv::var FType" Sbs: tvsubst_FType Injs: TyVar From c4fc4a460ba01b75c401dff2e8a2bd731b357033 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 26 May 2025 12:43:32 +0200 Subject: [PATCH 31/90] Add complicated example proof for composition and demotion Also fix a ton of issues in the original axiomatization in the process --- Tools/bmv_monad_def.ML | 1148 +++++++++++++++++++------------- Tools/mrbnf_util.ML | 12 + Tools/mrsbnf_comp.ML | 75 ++- Tools/mrsbnf_def.ML | 4 + operations/BMV_Composition.thy | 460 ++++++++++++- operations/BMV_Fixpoint.thy | 4 + operations/BMV_Monad.thy | 1 - tests/Regression_Tests.thy | 2 + thys/MRBNF_Composition.thy | 2 +- thys/MRBNF_FP.thy | 3 - thys/Support.thy | 37 + 11 files changed, 1259 insertions(+), 489 deletions(-) create mode 100644 thys/Support.thy diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index becda5c2..9a66c6e8 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -15,33 +15,34 @@ signature BMV_MONAD_DEF = sig Sb_comp: 'a, Sb_cong: 'a, Vrs_bds: 'a list, - Vrs_Injs: 'a list, + Vrs_Injss: 'a list list, Vrs_Sbs: 'a list }; type bmv_monad_facts = { Inj_inj: thm list, - SSupp_Inj: thm list, - SSupp_Inj_bound: thm list, - SSupp_comp_subset: thm list, - SSupp_comp_bound: thm list + Supp_Injss: thm list list, + SSupp_Map_subsets: thm list option, + SSupp_Map_bounds: thm list option, + SSupp_Sb_subsets: thm list, + SSupp_Sb_bounds: thm list }; - type 'a bmv_monad_consts = { + type bmv_monad_consts = { bd: term, Sbs: term list, RVrs: term list list, Injs: term list list, - SSupps: 'a list list, Vrs: term list list, - params: { Map: term, Supps: term list} option 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, - Map_Vrs: 'a list + Vrs_Map: 'a list, + Map_Injs: 'a list }; type 'a bmv_monad_model = { @@ -53,10 +54,9 @@ signature BMV_MONAD_DEF = sig leader: int, lives: typ list list, lives': typ list list, - consts: (term option) bmv_monad_consts, + consts: bmv_monad_consts, params: 'a bmv_monad_param option list, bd_infinite_regular_card_order: 'a, - SSupp_eq: 'a option list list, tacs: 'a bmv_monad_axioms list } @@ -70,7 +70,6 @@ signature BMV_MONAD_DEF = sig 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 SSupps_of_bmv_monad: bmv_monad -> (term * thm) 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; @@ -78,12 +77,7 @@ signature BMV_MONAD_DEF = sig 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 -> { - axioms: thm supported_functor_axioms, - Map_Sb: thm, - Supp_Sb: thm list, - Map_Vrs: thm list - } option list; + val params_of_bmv_monad: bmv_monad -> thm bmv_monad_param option list; 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; @@ -101,7 +95,9 @@ signature BMV_MONAD_DEF = sig -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory val compose_bmv_monad: (binding -> binding) -> bmv_monad -> (bmv_monad, typ) MRBNF_Util.either list - -> local_theory -> (bmv_monad * thm list) * local_theory + -> { 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 end structure BMV_Monad_Def : BMV_MONAD_DEF = struct @@ -114,52 +110,54 @@ type 'a bmv_monad_axioms = { Sb_comp: 'a, Sb_cong: 'a, Vrs_bds: 'a list, - Vrs_Injs: '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_Injs, Vrs_Sbs + 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_Injs = map f Vrs_Injs, + 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_Injs=f6s, Vrs_Sbs=f7s + 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_Injs, Vrs_Sbs + Sb_Inj, Sb_comp_Injs, Sb_comp, Sb_cong, Vrs_bds, Vrs_Injss, Vrs_Sbs }: 'a bmv_monad_axioms) = { 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_Injs = map2 (curry (op|>)) Vrs_Injs f6s, + Vrs_Injss = map2 (map2 (curry (op|>))) Vrs_Injss f6s, Vrs_Sbs = map2 (curry (op|>)) Vrs_Sbs f7s } : 'b bmv_monad_axioms; type bmv_monad_facts = { Inj_inj: thm list, - SSupp_Inj: thm list, - SSupp_Inj_bound: thm list, - SSupp_comp_subset: thm list, - SSupp_comp_bound: thm list + Supp_Injss: thm list list, + SSupp_Map_subsets: thm list option, + SSupp_Map_bounds: thm list option, + SSupp_Sb_subsets: thm list, + SSupp_Sb_bounds: thm list }; -fun morph_bmv_monad_facts phi { Inj_inj, SSupp_Inj, SSupp_Inj_bound, SSupp_comp_subset, SSupp_comp_bound } = { +fun morph_bmv_monad_facts phi { Inj_inj, Supp_Injss, SSupp_Map_subsets, SSupp_Map_bounds, SSupp_Sb_subsets, SSupp_Sb_bounds } = { Inj_inj = map (Morphism.thm phi) Inj_inj, - SSupp_Inj = map (Morphism.thm phi) SSupp_Inj, - SSupp_Inj_bound = map (Morphism.thm phi) SSupp_Inj_bound, - SSupp_comp_subset = map (Morphism.thm phi) SSupp_comp_subset, - SSupp_comp_bound = map (Morphism.thm phi) SSupp_comp_bound + 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, + SSupp_Sb_subsets = map (Morphism.thm phi) SSupp_Sb_subsets, + SSupp_Sb_bounds = map (Morphism.thm phi) SSupp_Sb_bounds }: bmv_monad_facts; type 'a supported_functor_axioms = { @@ -182,28 +180,29 @@ type 'a bmv_monad_param = { axioms: 'a supported_functor_axioms, Map_Sb: 'a, Supp_Sb: 'a list, - Map_Vrs: 'a list + Vrs_Map: 'a list, + Map_Injs: 'a list }; -fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Map_Vrs }: 'a bmv_monad_param) = { +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, - Map_Vrs = map f Map_Vrs + Vrs_Map = map f Vrs_Map, + Map_Injs = map f Map_Injs }: 'b bmv_monad_param; -type 'a bmv_monad_consts = { +type bmv_monad_consts = { bd: term, Sbs: term list, RVrs: term list list, Injs: term list list, - SSupps: 'a list list, Vrs: term list list, params: { Map: term, Supps: term list} option list }; -fun morph_bmv_monad_consts phi f { bd, params, Injs, SSupps, Sbs, Vrs, RVrs } = { +fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs } = { bd = Morphism.term phi bd, RVrs = map (map (Morphism.term phi)) RVrs, params = map (Option.map (fn { Map, Supps } => { @@ -211,10 +210,9 @@ fun morph_bmv_monad_consts phi f { bd, params, Injs, SSupps, Sbs, Vrs, RVrs } = Supps = map (Morphism.term phi) Supps })) params, Injs = map (map (Morphism.term phi)) Injs, - SSupps = map (map f) SSupps, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (Morphism.term phi)) Vrs -}: 'a bmv_monad_consts; +}: bmv_monad_consts; datatype bmv_monad = BMV of { ops: typ list, @@ -224,7 +222,7 @@ datatype bmv_monad = BMV of { lives: typ list list, lives': typ list list, deads: typ list list, - consts: (term * thm) bmv_monad_consts, + consts: bmv_monad_consts, params: thm bmv_monad_param option list, bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list, @@ -242,7 +240,7 @@ fun morph_bmv_monad phi (BMV { 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 (map_prod (Morphism.term phi) (Morphism.thm phi)) consts, + 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, @@ -260,12 +258,12 @@ 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 SSupps_of_bmv_monad = #SSupps 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 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 @@ -278,17 +276,16 @@ type 'a bmv_monad_model = { lives: typ list list, lives': typ list list, deads: typ list list, - consts: (term option) bmv_monad_consts, + consts: bmv_monad_consts, params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, leader: int, bd_infinite_regular_card_order: 'a, - SSupp_eq: 'a option list list, 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, SSupp_eq } + params, tacs, bd_infinite_regular_card_order, deads } ) = { ops = map (Morphism.typ phi) ops, var_class = var_class, @@ -296,12 +293,11 @@ fun morph_bmv_monad_model phi f ({ ops, var_class, frees, lives, lives', consts, 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 (Option.map (Morphism.term phi)) consts, + 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, - SSupp_eq = map (map (Option.map f)) SSupp_eq, bd_infinite_regular_card_order = bd_infinite_regular_card_order } : 'b bmv_monad_model; @@ -317,7 +313,6 @@ fun update_consts consts (model: 'a bmv_monad_model) = { bmv_ops = #bmv_ops model, leader = #leader model, tacs = #tacs model, - SSupp_eq = #SSupp_eq model, bd_infinite_regular_card_order = #bd_infinite_regular_card_order model }: 'a bmv_monad_model; @@ -337,23 +332,23 @@ fun pbmv_monad_of_generic context = val pbmv_monad_of = pbmv_monad_of_generic o Context.Proof; -fun mk_small_prems fs rhos SSupps = map (HOLogic.mk_Trueprop o mk_supp_bound) fs - @ map2 (fn rho => fn SSupp => HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (the SSupp $ rho)) +fun mk_small_prems fs rhos Injs = map (HOLogic.mk_Trueprop o mk_supp_bound) fs + @ map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (MRBNF_Util.mk_SSupp Inj $ rho)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of rho)))) -)) rhos SSupps; +)) rhos Injs; -fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = +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 (axioms, SSupp_eq) = split_list (@{map 7} (fn T => fn Injs => fn SSupps => fn SSupp_defs => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => + val axioms = @{map 5} (fn T => fn Injs => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => let val (own_Injs, other_Injs) = partition (fn Inj => body_type (fastype_of Inj) = T) Injs; - val is_own_Inj = map (curry (op=) T o body_type o fastype_of) 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)))); @@ -365,15 +360,14 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = ||>> 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 nown = length own_Injs; - val (own_rhos, other_rhos) = chop nown rhos; + 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 small_prems = mk_small_prems fs rhos SSupps; - val small_prems' = mk_small_prems gs rhos' SSupps; + val small_prems = mk_small_prems fs rhos Injs; + val small_prems' = mk_small_prems gs rhos' Injs; 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 ( @@ -384,14 +378,19 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = 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 @ map (fn rho => HOLogic.mk_comp ( - Term.list_comb (Sb, gs @ rhos'), rho - )) own_rhos @ @{map 3} (fn rho => fn Sb => fn Injs => - HOLogic.mk_comp (Term.list_comb (Sb, map (fn Inj => - case List.find (fn rho' => fastype_of rho' = fastype_of Inj) rhos' of - NONE => Inj | SOME t => t - ) Injs), rho) - ) other_rhos (map (nth Sbs) other_idxs) (map (nth Injss) other_idxs)) + 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))) )) ); @@ -399,38 +398,46 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) (#bd consts)) )) (RVrs @ Vrs); - val Vrs_Injs = map2 (fn Inj => fn Vrs => + val Vrs_Injss = map2 (fn Inj' => 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), - if fastype_of a = T then mk_singleton a else mk_bot T)) + if Inj' = Inj then mk_singleton a else mk_bot T)) end - ) own_Injs (cond_keep Vrs is_own_Inj); + ) own_Injs) Injs Vrs; - val Vrs_Sbs = map2 (fn rho => fn Vr => + val Vrs_Sbs = map2 (fn f => fn RVr => + 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), mk_image f $ (RVr $ x) + )) + ) + ) fs RVrs @ map2 (fn Vr => fn Inj => let - val RVrs = if (op=) (dest_funT (fastype_of rho)) then [mk_image rho $ (Vr $ x)] else []; val UNs = @{map_filter 2} (fn Vr' => fn rho => + if body_type (fastype_of rho) <> body_type (fastype_of Inj) then NONE else let - val (aT, T) = dest_funT (fastype_of rho); val X = Vr' $ x - val inner_Vr = if null RVrs then List.find (fn Vr'' => - T = fst (dest_funT (fastype_of Vr'')) - andalso HOLogic.dest_setT (body_type (fastype_of Vr)) = aT - ) (flat Vrss) else if T = fst (dest_funT (fastype_of Vr)) then - SOME Vr else NONE; - in Option.map (fn Vr => - mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (fastype_of X)) (Vr $ (rho $ Bound 0))) - ) inner_Vr end + val inner_Vr = if body_type (fastype_of rho) = domain_type (fastype_of Vr) then Vr else + let + val idx = find_index (curry (op=) (body_type (fastype_of rho))) Ts; + val Vrs = nth Vrss idx; + val Inj_idx = find_index (curry (op=) Inj) (nth Injss idx); + in nth Vrs Inj_idx end + in SOME ( + mk_UNION (Vr' $ x) (Term.abs ("x", HOLogic.dest_setT (fastype_of X)) ( + inner_Vr $ (rho $ Bound 0) + )) + ) 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 (RVrs @ UNs) + Vr $ (Term.list_comb (Sb, fs @ rhos) $ x), foldl1 mk_Un UNs )) ) end - ) (fs @ rhos) (RVrs @ Vrs); + ) 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 => @@ -444,28 +451,19 @@ fun mk_bmv_monad_axioms ops consts SSupp_defs bmv_ops lthy = Term.list_comb (Sb, gs @ rhos') $ x ) )); - - val SSupp_eq = @{map 4} (fn Inj => fn rho => fn SSupp => (fn NONE => - SOME (Logic.all rho (mk_Trueprop_eq ( - the SSupp $ rho, HOLogic.mk_Collect ("a", domain_type (fastype_of rho), HOLogic.mk_not (HOLogic.mk_eq ( - rho $ Bound 0, Inj $ Bound 0 - ))) - ))) - | SOME _ => NONE - )) Injs rhos SSupps SSupp_defs; - in ({ + in { Sb_Inj = Sb_Inj, Sb_comp_Injs = Sb_comp_Injs, Sb_comp = Sb_comp, - Vrs_Injs = Vrs_Injs, + Vrs_Injss = Vrs_Injss, Vrs_bds = Vrs_bds, Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong - } : term bmv_monad_axioms, SSupp_eq) end - ) ops (#Injs consts) (#SSupps consts) SSupp_defs (#Sbs consts) (#Vrs consts) (#RVrs consts)); - in (axioms, SSupp_eq) end; + } : term bmv_monad_axioms end + ) ops (#Injs consts) (#Sbs consts) (#Vrs consts) (#RVrs consts); + in axioms end; -fun mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy = +fun mk_param_axiom Map Supps Sb Injs RVrs Vrs bd params lthy = let val (f_Ts, T) = split_last (binder_types (fastype_of Map)); val (lives, lives') = split_list (map dest_funT f_Ts); @@ -520,15 +518,25 @@ fun mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy = ))); val Map_Sb = fold_rev Logic.all (fs @ hs @ rhos) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos SSupps) (mk_Trueprop_eq ( + fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs) (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 @ rhos + 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 Map_Vrs = map (fn Vrs => + 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 @@ -536,10 +544,17 @@ fun mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy = ) (RVrs @ Vrs); val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ hs @ [x]) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos SSupps) (mk_Trueprop_eq ( + fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs) (mk_Trueprop_eq ( Supp $ (Term.list_comb (Sb, hs @ rhos) $ x), Supp $ x )) )) 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, @@ -550,7 +565,8 @@ fun mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy = } : term supported_functor_axioms, Map_Sb = Map_Sb, Supp_Sb = Supp_Sb, - Map_Vrs = Map_Vrs + Vrs_Map = Vrs_Map, + Map_Injs = Map_Injs }: term bmv_monad_param end; val smart_max_inline_term_size = 25; (*FUDGE*) @@ -577,7 +593,7 @@ fun maybe_define const_policy fact_policy b rhs lthy = 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 const_policy fact_policy qualify leader ops lives' (consts: (term option) bmv_monad_consts) lthy = +fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' (consts: bmv_monad_consts) lthy = let val maybe_define' = maybe_define const_policy fact_policy o qualify; @@ -599,20 +615,10 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( @{fold_map 2} (fn Inj => fn suffix => maybe_define' (suffix (Binding.name "Inj")) Inj) ) (#Injs consts) suffixess lthy); - val ((SSupps, SSupp_defs), lthy) = apfst (split_list o map split_list) (@{fold_map 3} (@{fold_map 3} ( - fn Inj => fn suffix => fn SSupp_opt => fn lthy => case SSupp_opt of - SOME t => ((t, NONE), lthy) - | NONE => apfst (apsnd SOME) (MRBNF_Util.mk_def_t true Binding.empty I (Binding.name_of (suffix (Binding.name "SSupp"))) 1 ( - Term.absfree ("\", fastype_of Inj) (HOLogic.mk_Collect ("a", domain_type (fastype_of Inj), - HOLogic.mk_not (HOLogic.mk_eq (Free ("\", fastype_of Inj) $ Bound 0, Inj $ Bound 0)) - )) - ) lthy) - ) - ) (#Injs consts) suffixess (#SSupps consts) 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); + ) (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); @@ -644,11 +650,10 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( bd = bd, params = params, Injs = Injs, - SSupps = map (map SOME) SSupps, Sbs = Sbs, RVrs = RVrs, Vrs = Vrs - } : (term option) bmv_monad_consts; + } : bmv_monad_consts; val (lthy, old_lthy) = `Local_Theory.end_nested lthy; val phi = Proof_Context.export_morphism old_lthy lthy; @@ -657,10 +662,10 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops 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' (Option.map (Morphism.term phi')) consts'; + val consts' = morph_bmv_monad_consts phi' consts'; - val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ [bd_def] @ flat param_defs); - in (consts', map (Morphism.thm phi) defs, map (map (Option.map (Morphism.thm phi))) SSupp_defs, lthy) end; + val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ RVrs_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 @@ -673,7 +678,6 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = 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 lfacts = nth facts (leader_of_bmv_monad bmv); val params = params_of_bmv_monad bmv; fun note_unless_dont_note (noted, lthy) = @@ -684,18 +688,23 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("Sb_comp", map #Sb_comp axioms, []), ("Sb_cong", map #Sb_cong axioms, []), ("Vrs_bd", maps #Vrs_bds axioms, []), - ("Vrs_Inj", maps #Vrs_Injs axioms, []), + ("Vrs_Inj", flat (maps #Vrs_Injss axioms), []), ("Vrs_Sb", maps #Vrs_Sbs axioms, []), ("Map_Sb", map_filter (Option.map #Map_Sb) params, []), - ("Map_Vrs", flat (map_filter (Option.map #Map_Vrs) 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), []), - ("Inj_inj", #Inj_inj lfacts, []), - ("SSupp_Inj", #SSupp_Inj lfacts, []), - ("SSupp_Inj_bound", #SSupp_Inj_bound lfacts, []), - ("SSupp_comp_subset", #SSupp_comp_subset lfacts, []), - ("SSupp_comp_bound", #SSupp_comp_bound lfacts, []) + ("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, []), + ("SSupp_Sb_subset", maps #SSupp_Sb_subsets facts, []), + ("SSupp_Sb_bound", maps #SSupp_Sb_bounds facts, []) ] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (bmv_name ()) (Binding.name thmN)), attrs), [(thms, [])])); @@ -705,102 +714,163 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = |> fact_policy <> BNF_Def.Dont_Note ? note_unless_dont_note end -fun mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt (model: thm bmv_monad_model) lthy = +fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_monad_model) lthy = let - val SSupp_defs = map2 (map2 (fn SOME def => K def - | NONE => fn thm => @{thm eq_reflection} OF [the thm] - )) SSupp_defs (#SSupp_eq model); - 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), - SSupps = map2 (map2 (pair o the)) (#SSupps (#consts model)) SSupp_defs @ maps (#SSupps 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) - }: (term * thm) bmv_monad_consts; + }: 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 = map (map (fn Inj => + 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 Vrs = the (List.find (fn Vr => body_type (fastype_of Inj) = fst (dest_funT (fastype_of Vr))) (flat (#Vrs consts))); 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 Goal.prove_sorry lthy (names [a, b]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + 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 (maps #Vrs_Injs axioms)), + K (Local_Defs.unfold0_tac ctxt (flat (maps #Vrs_Injss axioms))), etac ctxt @{thm singleton_inject}, hyp_subst_tac ctxt, rtac ctxt refl - ]) end - )) (#Injs consts); - - val SSupp_Injs = map2 (map2 (fn Inj => fn (SSupp, SSupp_def) => - Goal.prove_sorry lthy [] [] (mk_Trueprop_eq (SSupp $ Inj, mk_bot (domain_type (fastype_of Inj)))) (fn {context=ctxt, ...} => EVERY [ - Local_Defs.unfold0_tac ctxt (SSupp_def :: @{thms HOL.simp_thms(6) not_True_eq_False empty_def}), - rtac ctxt @{thm TrueI} 1 - ]) - )) (#Injs consts) (#SSupps consts); + ])) end + else NONE + )) (#Injs (#consts model)) (#Vrs (#consts model)); val Un_bound = MRBNF_Def.get_class_assumption [#var_class model] "Un_bound" lthy; - val SSupp_thms = map (split_list o map (fn (SSupp, SSupp_def) => + 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 gT = domain_type (fastype_of SSupp); - val aT = domain_type gT; - val ((f, g), _) = lthy - |> apfst hd o mk_Frees "f" [aT --> aT] - ||>> apfst hd o mk_Frees "g" [gT]; - val goal = HOLogic.mk_Trueprop (mk_leq - (SSupp $ HOLogic.mk_comp (g, f)) - (mk_Un (SSupp $ g, mk_supp f)) - ); - val comp_subset = Goal.prove_sorry lthy (names [f, g]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - rtac ctxt @{thm subsetI}, - EqSubst.eqsubst_asm_tac ctxt [0] [SSupp_def], - EqSubst.eqsubst_tac ctxt [0] [SSupp_def], - K (Local_Defs.unfold0_tac ctxt @{thms mem_Collect_eq Un_iff comp_apply}), - rtac ctxt @{thm case_split}, - etac ctxt disjI2, - rtac ctxt disjI1, - dtac ctxt @{thm iffD1[OF arg_cong2[OF _ refl, of _ _ "(~=)"], rotated]}, - rtac ctxt (mk_arg_cong lthy 1 g), - etac ctxt @{thm notin_supp}, - assume_tac ctxt - ]); - fun mk_card_of_bound_UNIV t = HOLogic.mk_Trueprop ( - mk_ordLess (mk_card_of t) (mk_card_of (HOLogic.mk_UNIV (HOLogic.dest_setT (fastype_of t)))) - ); - val goal = Logic.mk_implies ( - mk_card_of_bound_UNIV (SSupp $ g), - Logic.mk_implies ( - mk_card_of_bound_UNIV (mk_supp f), - mk_card_of_bound_UNIV (SSupp $ HOLogic.mk_comp (g, f)) - ) - ); - val comp_bound = Goal.prove_sorry lthy (names [f, g]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - rtac ctxt @{thm card_of_subset_bound}, - rtac ctxt comp_subset, - rtac ctxt Un_bound, - assume_tac ctxt, - assume_tac ctxt + 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 (comp_subset, comp_bound) end - )) (#SSupps consts); + 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 SSupp_premss = @{map 3} (fn Injs => fn rhos => fn hs => + map (HOLogic.mk_Trueprop o mk_supp_bound) hs @ + map2 (fn Inj => fn rho => HOLogic.mk_Trueprop ( + mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj)))) + )) Injs rhos + ) Injss rhoss hss; + + val SSupp_thms = @{map 12} (fn params => fn param_consts => fn axioms => fn T => fn SSupp_prems => fn lives => fn lives' => fn fs => fn Injs => fn rhos => fn hs => fn Sb => + let + 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 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 facts = @{map 3} (fn Inj_inj => fn SSupp_Inj => fn (SSupp_comp_subset, SSupp_comp_bound) => { + val SSupp_Map_bounds = Option.map (map (fn thm => @{thm card_of_subset_bound} OF [thm])) SSupp_Map_subsets; + + val SSupp_Sb_subsets = @{map_filter 2} (fn Inj => fn rho => if body_type (fastype_of Inj) <> T then NONE else + let + val (rho', _) = names_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 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 (map (fn thm => thm RS fun_cong RS @{thm trans[OF comp_apply[symmetric]]}) (#Sb_comp_Injs axioms)), + REPEAT_DETERM o resolve_tac ctxt prems, + assume_tac ctxt + ])) end + ) Injs rhos; + + val SSupp_Sb_bounds = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else + let + val (rho, _) = names_lthy + |> apfst hd o mk_Frees "\'" [fastype_of Inj]; + val card = mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj))); + val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (mk_SSupp Inj $ rho)) card + ); + val goal = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (mk_SSupp Inj $ HOLogic.mk_comp ( + Term.list_comb (Sb, hs @ rhos), rho + ))) card + ); + 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 (Un_bound :: prems) + ])) end + ) Injs; + in { + SSupp_Map_subsets = SSupp_Map_subsets, + SSupp_Map_bounds = SSupp_Map_bounds, + SSupp_Sb_subsets = SSupp_Sb_subsets, + SSupp_Sb_bounds = SSupp_Sb_bounds + } end + ) (#params model) (#params (#consts model)) (#tacs model) (#ops model) SSupp_premss (#lives model) (#lives' model) fss Injss rhoss hss (#Sbs (#consts model)); + + val facts = @{map 3} (fn Inj_inj => fn SSupp_thms => fn Supp_Injss => { Inj_inj = Inj_inj, - SSupp_Inj = SSupp_Inj, - SSupp_Inj_bound = map (fn thm => @{thm card_of_subset_bound} OF [ - @{thm equalityD1} OF [thm], - @{thm emp_bound} - ]) SSupp_Inj, - SSupp_comp_subset = SSupp_comp_subset, - SSupp_comp_bound = SSupp_comp_bound - }: bmv_monad_facts) Inj_injs SSupp_Injs SSupp_thms; + Supp_Injss = Supp_Injss, + SSupp_Map_subsets = #SSupp_Map_subsets SSupp_thms, + SSupp_Map_bounds = #SSupp_Map_bounds SSupp_thms, + SSupp_Sb_subsets = #SSupp_Sb_subsets SSupp_thms, + SSupp_Sb_bounds = #SSupp_Sb_bounds 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), @@ -813,42 +883,40 @@ fun mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt (model: t consts = consts, params = #params model @ maps (#params o Rep_bmv) (#bmv_ops model), axioms = axioms, - facts = facts, + facts = facts @ maps facts_of_bmv_monad (#bmv_ops model), bd_infinite_regular_card_order = #bd_infinite_regular_card_order model } : 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 SSupp_defs lthy = +fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let - val (goals, SSupp_eq) = mk_bmv_monad_axioms (#ops model) (#consts model) SSupp_defs (#bmv_ops model) lthy; + 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', - map2 (map2 (fn tac => Option.map (fn SSupp_eq => Goal.prove_sorry lthy [] [] SSupp_eq (fn {context=ctxt, ...} => - Local_Defs.unfold0_tac ctxt defs THEN the tac ctxt - )))) (#SSupp_eq model) SSupp_eq + 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 Injs => fn SSupps => Option.map (fn param => - mk_param_axiom (#Map param) (#Supps param) SSupps Sb Injs RVrs Vrs (#bd (#consts model)) lthy - )) (#Sbs (#consts model)) (#RVrs (#consts model)) (#Vrs (#consts model)) (#Injs (#consts model)) (#SSupps (#consts model)) (#params (#consts model)) + val goals = @{map 5} (fn Sb => fn RVrs => fn Vrs => fn Injs => Option.map (fn param => + mk_param_axiom (#Map param) (#Supps param) Sb Injs RVrs Vrs (#bd (#consts model)) (map_filter I (#params (#consts model))) lthy + )) (#Sbs (#consts model)) (#RVrs (#consts model)) (#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, Map_Vrs=f3s, ...} => - fn { axioms, Map_Sb, Supp_Sb, Map_Vrs } => { + 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, - Map_Vrs = map2 (curry (op|>)) Map_Vrs f3s, + 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), @@ -858,7 +926,7 @@ fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = } } : thm bmv_monad_param)) tacs' goals end; -fun mk_thm_model (model: 'a bmv_monad_model) params axioms SSupp_eq bd_irco = { +fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { ops = #ops model, var_class = #var_class model, leader = #leader model, @@ -870,7 +938,6 @@ fun mk_thm_model (model: 'a bmv_monad_model) params axioms SSupp_eq bd_irco = { consts = #consts model, params = params, bd_infinite_regular_card_order = bd_irco, - SSupp_eq = SSupp_eq, tacs = axioms } : thm bmv_monad_model; @@ -881,19 +948,19 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont ) (dest_TFree T))) (nth (#frees model) (#leader model)); val model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (nth (#frees model) (#leader model) ~~ frees)) I model; - val (consts, unfold_set, SSupp_defs, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify + val (consts, unfold_set, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify (#leader model) (#ops model) (#lives' model) (#consts model) lthy; val model = update_consts consts model; - val (axioms, SSupp_eq) = prove_axioms model unfold_set SSupp_defs lthy; + 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 SSupp_eq bd_irco; - in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy qualify SSupp_defs bmv_b_opt model lthy) end + 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 lthy) end fun pbmv_monad_of_mrbnf mrbnf lthy = let @@ -940,7 +1007,6 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = consts = { bd = MRBNF_Def.bd_of_mrbnf mrbnf, Injs = [[]], - SSupps = [[]], Sbs = [Sb], Vrs = [[]], RVrs = [fsets], @@ -990,15 +1056,15 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = rtac ctxt @{thm image_id} ] ]) lsets, - Map_Vrs = map (fn _ => fn ctxt => EVERY1 [ + 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 + ]) fsets, + Map_Injs = [] }) Map], bd_infinite_regular_card_order = fn ctxt => rtac ctxt (MRBNF_Def.bd_infinite_regular_card_order_of_mrbnf mrbnf) 1, - SSupp_eq = [[]], tacs = [{ Sb_Inj = fn ctxt => resolve_tac ctxt [refl, MRBNF_Def.map_id0_of_mrbnf mrbnf] 1, Sb_comp_Injs = [], @@ -1011,7 +1077,7 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = rtac ctxt refl ], Vrs_bds = map (fn _ => fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf mrbnf) 1) fsets, - Vrs_Injs = [], + Vrs_Injss = [], 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}) @@ -1054,7 +1120,6 @@ fun slice_bmv_monad n bmv = Map = Map, Supps = Supps }) (f (Maps_of_bmv_monad bmv)) (f (Supps_of_bmv_monad bmv))], Injs = [f (Injs_of_bmv_monad bmv)], - SSupps = [f (SSupps_of_bmv_monad bmv)], Sbs = [Sb], RVrs = [f (RVrs_of_bmv_monad bmv)], Vrs = [f (Vrs_of_bmv_monad bmv)] @@ -1065,121 +1130,178 @@ fun slice_bmv_monad n bmv = facts = [f (facts_of_bmv_monad bmv)] } end; -fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) either list) lthy = +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 () - val filter_bmvs = map_filter (fn Inl x => SOME x | _ => NONE); - - fun vars_of_bmv_monad bmv = @{fold 2} (fn T => fn Map => case Map of - SOME t => Term.add_tfrees t - | NONE => Term.add_tfreesT T - ) (ops_of_bmv_monad bmv) (Maps_of_bmv_monad bmv) []; - - fun sum_collapse (Inl x) = x - | sum_collapse (Inr x) = x - - val vars = fold (fn (n, s) => - Symtab.map_default (n, s) (curry (Sign.inter_sort (Proof_Context.theory_of lthy)) s) - ) (vars_of_bmv_monad outer @ maps ( - sum_collapse o map_sum vars_of_bmv_monad (fn T => Term.add_tfreesT T []) - ) inners) Symtab.empty; - - fun mk_sign_morph bmv = - morph_bmv_monad (MRBNF_Util.subst_typ_morphism (map (fn (n, s) => - (TFree (n, s), TFree (n, the (Symtab.lookup vars n))) - ) (vars_of_bmv_monad bmv))) bmv; - fun mk_T_morph T = - Term.typ_subst_atomic (map (fn x => - (TFree x, the_default (TFree x) (Option.map (TFree o pair (fst x)) (Symtab.lookup vars (fst x)))) - ) (Term.add_tfreesT T [])) T - val outer = mk_sign_morph outer; - - val inners = map (map_sum mk_sign_morph mk_T_morph) inners; - val inners' = filter_bmvs inners; - - val inner_leaders' = map (map_sum (fn bmv => slice_bmv_monad (leader_of_bmv_monad bmv) bmv) I) inners; - val inner_leaders = map_filter (fn Inr _ => NONE | Inl bmv => SOME bmv) inner_leaders'; - - val subst = - let val Ts = map (sum_collapse o map_sum (hd o ops_of_bmv_monad) I) inner_leaders' - in (nth (lives_of_bmv_monad outer) (leader_of_bmv_monad outer) ~~ Ts) - @ (nth (lives'_of_bmv_monad outer) (leader_of_bmv_monad outer) ~~ Ts) end; - val new_leader = Term.typ_subst_atomic subst (nth (ops_of_bmv_monad outer) (leader_of_bmv_monad outer)); - - val new_Injs = distinct (op=) ( - map (Term.subst_atomic_types subst) (nth (Injs_of_bmv_monad outer) (leader_of_bmv_monad outer)) - @ maps (hd o Injs_of_bmv_monad) inner_leaders + fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) + + val eq_name = (op=) o apply2 (fst o dest_TFree) + 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 outer' = morph_bmv_monad (MRBNF_Util.subst_typ_morphism subst) outer; - val minions = fold_rev (fn bmv => fold_rev (fn i => fn xs => - let val T = nth (ops_of_bmv_monad bmv) i; - in if member (fn (a, b) => a = fst b) xs T - then xs else (T, slice_bmv_monad i bmv) :: xs end - ) (0 upto length (ops_of_bmv_monad bmv) - 1)) (outer' :: inners') []; - val minions = map_filter (AList.lookup (op=) minions o body_type o fastype_of) new_Injs; - - val (lSSupps, SSuppss) = split_list (map (fn bmv => apfst hd (apply2 (map snd) ( - partition (fn (i, _) => i = leader_of_bmv_monad bmv) - ((0 upto length (ops_of_bmv_monad bmv) - 1) ~~ SSupps_of_bmv_monad bmv) - ))) (outer' :: inners')); - val SSupps = flat (flat SSuppss) @ flat lSSupps; - val new_SSupps = map (fn t => - the (List.find (fn (SSupp, _) => domain_type (fastype_of SSupp) = fastype_of t) SSupps) - ) new_Injs; + val (lives', names_lthy) = lthy + |> fold Variable.declare_typ vars + |> mk_TFrees (length lives); - val RVrs_aTs = distinct (op=) (map (HOLogic.dest_setT o body_type o fastype_of) - (flat (maps RVrs_of_bmv_monad (outer' :: inners'))) - ); + fun find_vars xs = map (fn x => the ( + List.find (curry eq_name x) vars + )) xs; + val inners = map2 (fn As => map_sum (fn bmv => + 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') + ); + in morph_bmv_monad phi bmv end + ) (fn T => + 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 Term.typ_subst_atomic subst T end + )) Ass inners; + 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 (((fs, rhos), x), _) = lthy - |> mk_Frees "f" (map (fn a => a --> a) RVrs_aTs) - ||>> mk_Frees "\" (map fastype_of new_Injs) - ||>> apfst hd o mk_Frees "x" [new_leader]; + val inners' = map_filter (fn Inl x => SOME x | _ => NONE) inners; - fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv); - fun mk_Sb (Inl bmv) = - let val Sb = leader Sbs_of_bmv_monad bmv; - in Term.list_comb (Sb, - map (fn T => the (List.find (curry (op=) T o fastype_of) (fs @ rhos))) (fst (split_last (binder_types (fastype_of Sb)))) + val (x, _) = names_lthy + |> apfst hd o mk_Frees "x" [leader ops_of_bmv_monad outer]; + + val new_Injs = 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 Option.map (Term.absfree (dest_Free x)) ( + try (foldl1 mk_Un) (outer_RVrs @ inner_RVrs) ) end - | mk_Sb (Inr T) = HOLogic.id_const T; - val new_Sb = fold_rev Term.absfree (map dest_Free (fs @ rhos)) (HOLogic.mk_comp ( - Term.list_comb (the (leader Maps_of_bmv_monad outer'), map mk_Sb inners), - mk_Sb (Inl outer') - )); + ) frees; val new_Vrs = map (fn Inj => let - fun get_sets bmv = - let val idx = find_index (curry ((op=) o apply2 fastype_of) Inj) (leader Injs_of_bmv_monad bmv); - in if idx < 0 then [] else [nth (leader Vrs_of_bmv_monad bmv) idx] end; - - val sets = flat (map (fn t => t $ x) (get_sets outer') - :: @{map_filter 2} (fn Inr _ => K NONE | Inl bmv => fn Supp => - let val sets = get_sets bmv; - in if null sets then NONE else SOME (map (mk_UNION (Supp $ x)) sets) end - ) inners (the (leader Supps_of_bmv_monad outer')) - ); - in Term.absfree (dest_Free x) (foldl1 mk_Un sets) end + 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 Term.absfree (dest_Free x) (foldl1 mk_Un (outer_Vrs @ inner_Vrs)) end ) new_Injs; - val new_RVrs = map (fn aT => - let - fun get_set bmv = List.find (curry (op=) aT o HOLogic.dest_setT o body_type o fastype_of) (leader RVrs_of_bmv_monad bmv) - val sets = the_default [] (Option.map (fn s => [s $ x]) (get_set outer')) - @ @{map_filter 2} (fn Inr _ => K NONE | Inl bmv => fn Supp => Option.map (fn s => - mk_UNION (Supp $ x) s - ) (get_set bmv)) inners (the (leader Supps_of_bmv_monad outer')) - in Term.absfree (dest_Free x) (foldl1 mk_Un sets) end - ) RVrs_aTs; - val ops = new_leader :: map (hd o ops_of_bmv_monad) minions; + 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 => + let + val lives = leader lives_of_bmv_monad inner; + val lives' = leader lives'_of_bmv_monad inner; + val map_t_opt = if null lives orelse forall (op<>) (lives ~~ lives') then NONE else SOME ( + Term.list_comb ( + Term.subst_atomic_types (lives' ~~ lives) (the (leader Maps_of_bmv_monad inner)), + map (fn a => + case List.find (curry (op=) a o domain_type o fastype_of) hs of + NONE => HOLogic.id_const a | SOME h => h + ) lives + ) + ); + val Sb_t = Term.list_comb (leader Sbs_of_bmv_monad inner, map_filter (fn RVr => + List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of RVr))) o domain_type o fastype_of) hs + ) (leader RVrs_of_bmv_monad inner) @ map (fn Inj => + case List.find (curry (op=) (fastype_of Inj) o fastype_of) rhos of + NONE => Inj | SOME rho => rho + ) (leader Injs_of_bmv_monad inner)); + val mk_Map_comp = case map_t_opt of + NONE => I | SOME t => fn t' => HOLogic.mk_comp (t, t') + in mk_Map_comp Sb_t end + ) 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 (t, + 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) + )); + in fold_rev (Term.absfree o dest_Free) (hs @ rhos) (add_Sb map_t) end; - val vars = distinct (op=) (map TFree (fold Term.add_tfreesT ops [])); - val lives = distinct (op=) (flat (maps lives_of_bmv_monad inners')); - val frees = distinct (op=) (map (HOLogic.dest_setT o body_type o fastype_of) (new_RVrs @ new_Vrs)); + 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 Option.map (mk_UNION (set $ x)) ( + List.find (curry (op=) live o HOLogic.dest_setT o body_type o fastype_of) (the (leader Supps_of_bmv_monad inner)) + ) + ) inners (the (leader Supps_of_bmv_monad outer))))) lives; + in SOME { Map = Map, Supps = Supps } end; val consts = { bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) @@ -1187,42 +1309,71 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit Sbs = [new_Sb], Vrs = [new_Vrs], RVrs = [new_RVrs], - SSupps = [map (SOME o fst) new_SSupps], - params = [NONE] - }: (term option) bmv_monad_consts; + params = [param] + }: bmv_monad_consts; - val SSupp_defs = map snd (flat (maps SSupps_of_bmv_monad (outer' :: inners'))); + val new_minions = map (fn bmv => (hd (ops_of_bmv_monad bmv), bmv)) ( + filter_out (curry (op=) (leader ops_of_bmv_monad outer) o hd o ops_of_bmv_monad) ( + distinct ((op=) o apply2 (hd o ops_of_bmv_monad)) (outer :: inners') + ) + ); + val new_minions = map_filter (AList.lookup (op=) new_minions o body_type o fastype_of) new_Injs; + val axiomss = map (leader axioms_of_bmv_monad) inners'; val model = { - ops = [new_leader], - bmv_ops = minions, + ops = [leader ops_of_bmv_monad outer], + 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' = [distinct (op=) (flat (maps lives'_of_bmv_monad inners'))], - deads = [subtract (op=) (lives @ frees) vars], + lives' = [lives'], + deads = [deads], consts = consts, - params = [NONE], + params = [Option.map (fn { Supps, ...} => { + axioms = { + Map_id = fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_id") + ], + Map_comp = fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_comp") + ], + Supp_Map = map (fn _ => fn ctxt => EVERY1 [ + K (print_tac ctxt "Supp_map") + ]) Supps, + Supp_bd = map (fn _ => fn ctxt => EVERY1 [ + K (print_tac ctxt "Supp_bd") + ]) Supps, + Map_cong = fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_cong") + ] + }, + Map_Sb = fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_id") + ], + Supp_Sb = map (fn _ => fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_id") + ]) Supps, + Vrs_Map = map (fn _ => fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_id") + ]) new_Vrs, + Map_Injs = map (fn _ => fn ctxt => EVERY1 [ + K (print_tac ctxt "Map_Injs") + ]) new_Injs + }) param], leader = 0, - SSupp_eq = [map (fn (_, thm) => SOME (fn ctxt => - Local_Defs.unfold0_tac ctxt [thm] THEN rtac ctxt refl 1 - )) new_SSupps], tacs = @{map 6} (fn axioms => fn param => fn Map => fn Injs => fn RVrs => fn Vrs => { Sb_Inj = fn ctxt => EVERY1 [ - rtac ctxt trans, - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, - rtac ctxt ext, - rtac ctxt (trans OF [#Map_cong (#axioms param), #Map_id (#axioms param) RS fun_cong]), - REPEAT_DETERM o resolve_tac ctxt (refl :: maps (map (fn ax => - #Sb_Inj ax RS fun_cong - ) o axioms_of_bmv_monad) inners'), - rtac ctxt @{thm trans[OF id_o]}, - rtac ctxt (#Sb_Inj axioms) + K (Local_Defs.unfold_tac ctxt (@{thms id_o o_id} + @ map #Sb_Inj (axioms :: axiomss) + @ [#Map_id (#axioms param)] + @ map_filter (Option.map (#Map_id o #axioms) o leader params_of_bmv_monad) inners' + )), + rtac ctxt refl ], - Sb_comp_Injs = map (fn thm => fn ctxt => - print_tac ctxt "Sb_comp_Inj" - ) (#Sb_comp_Injs axioms), + Sb_comp_Injs = map (fn thm => fn ctxt => EVERY1 [ + K (print_tac ctxt "Sb_comp_Inj") + ]) (#Sb_comp_Injs axioms), Sb_comp = fn ctxt => EVERY1 [ rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt trans, @@ -1231,12 +1382,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Map_Sb param RS sym), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, rtac ctxt (#Sb_comp axioms), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, @@ -1246,7 +1395,6 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt (#Map_cong (#axioms param)), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (@{thm id_o} :: maps (map #Sb_comp o axioms_of_bmv_monad) inners'), - K (Local_Defs.unfold0_tac ctxt SSupp_defs), REPEAT_DETERM o assume_tac ctxt, rtac ctxt refl ] @@ -1261,13 +1409,13 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) @{thms infinite_regular_card_order_Un infinite_regular_card_order_UN} ) ])) (RVrs @ Vrs), - Vrs_Injs = map (fn thm => fn ctxt => + Vrs_Injss = map (map (fn thm => fn ctxt => print_tac ctxt "Vrs_Injs" - ) (#Vrs_Injs axioms), + )) (#Vrs_Injss axioms), Vrs_Sbs = map (K (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt ( @{thms image_Un image_UN comp_def image_comp Union_UN_swap} - @ #Map_Vrs param + @ #Vrs_Map param @ #Supp_Sb param @ #Supp_Map (#axioms param) )), @@ -1304,78 +1452,92 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ] ]) ]) inners), - rtac ctxt (#Sb_cong axioms), - REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), - REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ - TRY o (dtac ctxt @{thm UN_I} THEN' assume_tac ctxt), - resolve_tac ctxt (drop (2 * length Injs) prems), - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - etac ctxt UnI2, - rtac ctxt UnI1 - ] - ]) + TRY o EVERY' [ + rtac ctxt (#Sb_cong axioms), + REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), + REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ + TRY o (dtac ctxt @{thm UN_I} THEN' assume_tac ctxt), + resolve_tac ctxt (drop (2 * length Injs) prems), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + etac ctxt UnI2, + rtac ctxt UnI1 + ] + ]) + ] ]) ctxt ] } : (Proof.context -> tactic) bmv_monad_axioms) - [leader axioms_of_bmv_monad outer'] - [the (leader params_of_bmv_monad outer')] - [the (leader Maps_of_bmv_monad outer')] + [leader axioms_of_bmv_monad outer] + [the (leader params_of_bmv_monad outer)] + [the (leader Maps_of_bmv_monad outer)] [new_Injs] [new_RVrs] [new_Vrs] } : (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'))); + ) (outer :: inners'))); val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify (SOME name) model lthy in (res, lthy) end; -fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param_opt), bd) lthy = +fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = let - val ops = map (Syntax.read_typ lthy) ops; - val bd = Syntax.read_term lthy bd; - val Sbs = map2 (fn Sb => fn T => Term.subst_atomic_types ( - map (apply2 TFree) (Term.add_tfreesT (body_type (fastype_of Sb)) [] ~~ Term.add_tfreesT T []) - @ map (apply2 TFree) (Term.add_tfreesT (snd (split_last (binder_types (fastype_of Sb)))) [] ~~ Term.add_tfreesT T []) - ) Sb) (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; - val Injs = map (map (fn s => + val b = fst (hd b_ops); + val (opss, bmv_ops) = split_list (map_index (fn (i, (b, s)) => let - val t = Syntax.read_term lthy s; - val T = case List.find (curry (op=) (fst (dest_Type (body_type (fastype_of t)))) o fst o dest_Type) ops of - NONE => 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, []) - | SOME T => T; - in Term.subst_atomic_types (map (apply2 TFree) (Term.add_tfreesT (body_type (fastype_of t)) [] ~~ Term.add_tfreesT T [])) t end - )) (the_default (replicate (length ops) []) Injs); + 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 _ = @{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 ("Expected injection of type " ^ Syntax.string_of_typ lthy f_T ^ " for operator " ^ Syntax.string_of_typ lthy T - ^ ". Substitution has type " ^ Syntax.string_of_typ lthy (fastype_of Sb) ^ ", but got injections:", map fastype_of Injs, []) - | _ => () - ) (filter_out ((op=) o dest_funT) f_Ts)) Sbs ops Injs f_Tss; + 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 SSupps = case SSupps_opt of - SOME SSupps => map2 (fn Injs => fn SSupps => map2 (fn "_" => K NONE | t => fn Inj => - let - val t = Syntax.read_term lthy t; - val t' = Term.subst_atomic_types (map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of t))) [] ~~ Term.add_tfreesT (fastype_of Inj) [])) t; - in SOME t' end - ) (SSupps @ replicate (length Injs - length SSupps) "_") Injs) Injs (SSupps @ replicate (length Injs - length SSupps) []) - | NONE => map (map (K NONE)) Injs; + val f_Tss = map (fst o split_last o binder_types o fastype_of) Sbs; - val Vrs = map (map (Syntax.read_term lthy )) (the_default (replicate (length ops) []) Vrs); - val Vrs = map2 (fn T => map (fn Vrs => Term.subst_atomic_types ( - map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of Vrs))) [] ~~ Term.add_tfreesT T []) - ) Vrs)) ops Vrs; + 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 RVrs = map (map (Syntax.read_term lthy)) (the_default (replicate (length ops) []) RVrs); - val RVrs = map2 (fn T => map (fn RVrs => Term.subst_atomic_types ( - map (apply2 TFree) (Term.add_tfreesT (fst (dest_funT (fastype_of RVrs))) [] ~~ Term.add_tfreesT T []) - ) RVrs)) ops RVrs; + 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 @@ -1392,83 +1554,123 @@ fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param 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 = map (the_default [] o Option.map (fn Map => + val lives = map2 (fn T => the_default [] o Option.map (fn Map => let - val Map = Term.subst_atomic_types (map (apply2 TFree) ( - Term.add_tfreesT (snd (split_last (binder_types (fastype_of Map)))) [] - ~~ Term.add_tfreesT (hd ops) [] - )) Map; + 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 - )) Maps; + )) ops Maps; val (lives', _) = names_lthy - |> fold_map mk_TFrees' (map (map Type.sort_of_atyp) lives); + |> fold_map mk_TFrees (map length lives); val Maps = @{map 4} (fn T => fn lives => fn lives' => Option.map (fn Map => let - val l' = map (snd o dest_funT) (fst (split_last (binder_types (fastype_of Map)))); - val TA = snd (split_last (binder_types (fastype_of Map))); - val Map = Term.subst_atomic_types (map (apply2 TFree) ( - Term.add_tfreesT TA [] ~~ Term.add_tfreesT T [] - )) Map; - val TA = snd (split_last (binder_types (fastype_of Map))); - val TB = body_type (fastype_of Map); - val old_vars = map TFree (Term.add_tfreesT TB []); - in Term.subst_atomic_types ( - (l' ~~ lives') @ ( - subtract (op=) l' old_vars ~~ subtract (op=) lives (map TFree (Term.add_tfreesT TA [])) - ) - ) Map end + 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 => Term.subst_atomic_types (map (apply2 TFree) ( - Term.add_tfreesT (hd (binder_types (fastype_of Supp))) [] ~~ Term.add_tfreesT T [] - )) Supp))) ops (Suppss @ replicate (length ops - length Suppss) NONE); + 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 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 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 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, - SSupps = SSupps, Sbs = Sbs, Vrs = Vrs, RVrs = RVrs, params = param_consts - }: (term option) bmv_monad_consts; - val (consts, bmv_defs, SSupp_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 + }: bmv_monad_consts; + val (consts, bmv_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 ops lives' consts lthy; - val param_goals = @{map 6} (fn Sb => fn Injs => fn SSupps => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => - mk_param_axiom Map Supps SSupps Sb Injs RVrs Vrs bd lthy - )) Sbs Injs (#SSupps consts) RVrs Vrs (#params consts); + val param_goals = @{map 5} (fn Sb => fn Injs => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => + mk_param_axiom Map Supps Sb Injs RVrs Vrs bd (map_filter I (#params consts @ maps (#params o consts_of_bmv_monad) bmv_ops)) lthy + )) Sbs Injs RVrs Vrs (#params consts); - val (goals, SSupp_eq_goals) = mk_bmv_monad_axioms ops consts SSupp_defs [] lthy; + 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 chop_many = fold_map ( - fn NONE => (fn thms => (NONE, thms)) - | SOME _ => fn thms => (SOME (hd thms), tl thms) - ); - - val (((axioms, SSupp_eq), params), _) = apfst (apfst split_list o split_list) (@{fold_map 4} (fn goal => fn SSupp_eq_goals => fn param => fn param_consts => fn 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), SSupp_eq), Sb_comp), Vrs_bds), Vrs_Injs), Vrs_Sbs), Sb_cong), thms) = thms + 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)) - ||>> chop_many SSupp_eq_goals ||>> apfst hd o chop 1 ||>> chop (length (#Vrs_bds goal)) - ||>> chop (length (#Vrs_Injs 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), Map_Vrs), thms) = thms + 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))) @@ -1476,7 +1678,8 @@ fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param ||>> apfst hd o chop 1 ||>> apfst hd o chop 1 ||>> chop (length (#Supps (the param_consts))) - ||>> chop (length (#Map_Vrs goals)) + ||>> chop (length (#Vrs_Map goals)) + ||>> chop (length (#Map_Injs goals)) in (SOME ({ axioms = { Map_id = Map_id, @@ -1487,20 +1690,20 @@ fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param }, Map_Sb = Map_Sb, Supp_Sb = Supp_Sb, - Map_Vrs = Map_Vrs + 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_Injs = Vrs_Injs, + Vrs_Injss = Vrs_Injss, Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong - }: thm bmv_monad_axioms, SSupp_eq), param), thms) end - ) goals SSupp_eq_goals param_goals param_consts (tl thms)); + }: thm bmv_monad_axioms), param), thms) end + ) goals param_goals param_consts (tl thms)); - val _ = @{print} (lives, frees) val model = { ops = ops, var_class = @{class var}, (* TODO: change *) @@ -1508,30 +1711,28 @@ fun pbmv_monad_cmd ((((((((b, ops), Sbs), RVrs), Injs), Vrs), SSupps_opt), param frees = frees, lives = lives, lives' = lives', - deads = map2 (fn lives => fn frees => subtract (op=) (lives @ frees) vars) lives frees, - bmv_ops = [], + deads = deadss, + bmv_ops = bmv_ops, consts = consts, params = params, bd_infinite_regular_card_order = bd_irco, - SSupp_eq = SSupp_eq, tacs = axioms } : thm bmv_monad_model; - val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I SSupp_defs (SOME (Binding.name b)) model lthy; + val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I (SOME (Binding.name b)) model lthy; val lthy = register_pbmv_monad b bmv lthy; in lthy end; - val _ = @{print} "foo" in Proof.theorem NONE after_qed (map (single o rpair []) ( [HOLogic.mk_Trueprop (mk_infinite_regular_card_order bd)] - @ flat (@{map 3} (fn goal => fn SSupp_eq_goals => fn param => #Sb_Inj goal :: #Sb_comp_Injs goal @ map_filter I SSupp_eq_goals @ [#Sb_comp goal] - @ #Vrs_bds goal @ #Vrs_Injs goal @ #Vrs_Sbs goal + @ 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 @ #Map_Vrs param + @ #Supp_Sb param @ #Vrs_Map param @ #Map_Injs param ) param) - ) goals SSupp_eq_goals param_goals) + ) goals param_goals) )) lthy |> Proof.unfolding ([[(bmv_defs, [])]]) |> Proof.refine_singleton (Method.Basic (fn ctxt => Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl)))) @@ -1543,16 +1744,20 @@ fun print_pbmv_monads ctxt = 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, consts, leader, ...}) = + 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 frees)), + ([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 lives)), + [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 @@ -1574,17 +1779,16 @@ val _ = val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} "register a parametrized bounded multi-variate monad" - ((parse_opt_binding_colon -- Parse.and_list1 Parse.typ -- + ((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 "SSupps" -- @{keyword ":"}) |-- Parse.and_list1 (Scan.repeat1 (Scan.unless (Parse.reserved "Maps" || Parse.reserved "bd") (Parse.underscore || 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.underscore >> K []) )) ) -- ((Parse.reserved "bd" -- @{keyword ":"}) |-- Parse.term)) diff --git a/Tools/mrbnf_util.ML b/Tools/mrbnf_util.ML index b65fb8b0..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 @@ -281,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))))); diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 794e936d..876f89b2 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -1,5 +1,11 @@ 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 + -> (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory + -> MRSBNF_Def.mrsbnf * ((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 -> typ -> ((MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory) @@ -24,6 +30,56 @@ fun mrsbnf_of lthy s = case MRSBNF_Def.mrsbnf_of lthy s of fun is_Inl (Inl _) = true | is_Inl _ = false +fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs Ass Xs (accum, lthy) = + let + val outer_bmv = MRSBNF_Def.bmv_monad_of_mrsbnf outer; + val inner_bmvs = map MRSBNF_Def.bmv_monad_of_mrsbnf inners; + val leader = BMV_Monad_Def.leader_of_bmv_monad outer_bmv; + + val _ = @{print} ("outer", BMV_Monad_Def.ops_of_bmv_monad outer_bmv) + val _ = @{print} ("inners", map BMV_Monad_Def.ops_of_bmv_monad inner_bmvs) + + + val _ = @{print} ("vars", oAs, Ass) + + val ((bmv, unfold_set), 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 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), (unfold_set, lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline + qualify (distinct (op=) o flat) outer_mrbnf inner_mrbnfs oDs Dss oAs Ass Xs (accum, lthy); + + val outer_axioms = MRSBNF_Def.axioms_of_mrsbnf outer; + + (* TODO: Carry over minion mrbnfs from inners *) + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def fact_policy (qualify 0) NONE + (map_index (fn (i, x) => if i = leader then mrbnf else x) (MRSBNF_Def.mrbnfs_of_mrsbnf outer)) + bmv (map_index (fn (i, x) => if i <> leader then { + map_Sb = Option.map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#map_Sb x), + map_is_Sb = fn ctxt => HEADGOAL (rtac ctxt (#map_is_Sb x) 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 x), + set_Vrs = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Vrs x) + } else { + map_Sb = if MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf > length (BMV_Monad_Def.frees_of_bmv_monad bmv) then + SOME (fn ctxt => EVERY1 [ + K (print_tac ctxt "map_Sb") + ]) else NONE, + map_is_Sb = fn ctxt => EVERY1 [ + K (print_tac ctxt "map_is_Sb") + ], + set_Sb = replicate (MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf) (fn ctxt => EVERY1 [ + K (print_tac ctxt "set_Sb") + ]), + set_Vrs = replicate (length (BMV_Monad_Def.frees_of_bmv_monad bmv)) (fn ctxt => EVERY1 [ + K (print_tac ctxt "set_Vrs") + ]) + }) outer_axioms) lthy; + + val _ = @{print} mrbnf + in error "foo" end + fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = (if member (op =) Ds0 T' then ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), accum) else (case map_filter (fn a => if fst a = T' then SOME (snd a) else NONE) var_types of @@ -44,11 +100,12 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = if optim andalso forall is_TFree Ts then let val mrbnf = case outer of - Inl mrsbnf => hd (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) + 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 mrbnf' = MRBNF_Def.morph_mrbnf (MRBNF_Util.subst_typ_morphism ( + val phi = MRBNF_Util.subst_typ_morphism ( snd (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf)) ~~ Ts - )) mrbnf; + ); + 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") @@ -99,19 +156,23 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' (accum, lthy)); val _ = @{print} T + val _ = @{print} Ts' 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 val (outer', lthy) = case outer of Inl mrsbnf => (mrsbnf, lthy) | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf lthy - val (inners', lthy) = fold_map (fn Inl mrsbnf => (fn lthy => (mrsbnf, lthy)) + val (inners', lthy) = fold_map (fn Inl mrsbnf => pair mrsbnf | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf ) inners lthy; - val _ = @{print} (outer' :: inners') - val _ = () - in error "TODO: compose mrsbnfs" end + (*val _ = @{print} (outer' :: inners')*) + val (mrsbnf, accum) = compose_mrsbnfs BNF_Def.Smart_Inline const_policy qualify outer' inners' + oDs Dss oAs Ass Xs' (accum, lthy); + val _ = @{print} mrsbnf + in error "bar" end else 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) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index e0e51f4f..c145b77f 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -420,6 +420,10 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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; + val (_, lthy) = note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy; in (mrsbnf, lthy) end; diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index cc619f93..ba759afc 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -1,15 +1,465 @@ 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 +lemma image_const_empty: "x \ y \ (\_. x) ` A = (\_. y) ` B \ A = {} \ B = {}" + by fast -abbreviation "bd_type \ natLeq" +ML_file \../Tools/bmv_monad_def.ML\ -abbreviation "sb_type \ tvsubst_type" +(* 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, live *) +typedecl ('a, 'b) T4 +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" + +consts Sb_T2 :: "('d::var \ 'd) \ ('b::var \ ('a, 'b, 'c, 'd) T2) \ ('a, 'b, 'c, 'd) T2 \ ('a, 'b, 'c, 'd) T2" +consts Vrs_1_T2 :: "('a, 'b::var, 'c, 'd::var) T2 \ 'd set" +consts Vrs_2_T2 :: "('a, 'b::var, 'c, 'd::var) T2 \ 'b set" +consts Inj_T2 :: "'b \ ('a, '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 \ '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" + +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" + +ML \ +Multithreading.parallel_proofs := 0 +\ +declare [[goals_limit=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, '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_2_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, 'g set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1" + +(* +deads: 'a, 'e, 'f, 'g +frees: 'b, 'c, 'd +lives: 'h +*) + +lemma cong': "f x = g x \ x = y \ f x = g y" + by simp + +(* Demoting T3 *) +pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a::var, 'c::var) T4" + Sbs: "\f1 \1 \2 \4. Sb_T3 \1 \2 Inj_2_T3 \4 \ Map_T3 f1 id" and Sb_T4 + RVrs: set_1_T3 + Injs: Inj_1_T3 Inj_1_T4 Inj_2_T4 and Inj_1_T4 Inj_2_T4 + Vrs: Vrs_1_T3 Vrs_2_T3 Vrs_4_T3 and Vrs_1_T4 Vrs_2_T4 + Maps: "Map_T3 id" + Supps: set_2_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; (assumption | rule SSupp_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)+ + 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 SSupp_Inj_bound)+ + apply (rule T3.Map_comp) + apply (unfold id_o T3.Map_Inj) + apply (subst T3.Sb_comp_Inj, (assumption | rule SSupp_Inj_bound)+)+ + apply (rule refl) + + apply (rule T3.Supp_bd T3.Vrs_bd T3.Vrs_Inj)+ + + subgoal for f \1 \2 \3 x + apply (unfold comp_def) + apply (subst T3.Supp_Sb) + apply (assumption | rule SSupp_Inj_bound)+ + apply (rule T3.Supp_Map) + 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)+ + 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)+ + 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)+ + 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 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)+ + 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)+) + apply (rule trans) + apply (rule T3.Supp_Map) + apply (rule image_id) + apply (rule trans) + apply (rule T3.Supp_Map) + apply (rule image_id) + apply (unfold T3.Vrs_Map) + 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 + +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)" + +declare [[ML_print_depth=1000]] +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. Sb_T1 h1 \1 Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ 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_T2 Inj_1_T3 Inj_1_T4 Inj_2_T4 + Vrs: Vrs_2_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_4_T3 ` set_3_T1 x)" + Maps: "\f. Map_T1 id id (Map_T3 id f)" + Supps: "\x. \ (set_2_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 T1.SSupp_Map_bound SSupp_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)+ + 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 SSupp_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) + 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] + )+ + apply (rule ext) + apply (rule T1.Map_cong) + (* REPEAT for inner *) + apply (rule T2.Sb_comp[THEN fun_cong], assumption+) + apply (rule refl) + (* repeated *) + apply (rule trans) + apply (rule arg_cong2[OF refl, of _ _ "(\)", THEN fun_cong]) + 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)+ + apply (unfold T3.Map_Inj) + apply (rule trans[OF comp_assoc]) + apply (rule arg_cong2[OF refl, of _ _ "(\)"]) + apply (rule T3.Map_comp) + apply (unfold id_o o_id comp_assoc[symmetric]) + apply (rule arg_cong2[OF _ refl, of _ _ "(\)", THEN fun_cong]) + apply (rule trans) + apply (rule T3.Sb_comp) + apply (assumption | rule T3.SSupp_Map_bound SSupp_Inj_bound)+ + apply (subst T3.Sb_comp_Inj, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold comp_assoc[symmetric]) + apply (rule refl) + done + + apply (unfold T1.Supp_Inj UN_empty) + apply (rule refl 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)+ + apply (unfold T1.Vrs_Map)[1] + apply (rule refl) + + apply (unfold0 comp_apply)[1] + apply (subst T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold T1.Supp_Map image_comp[unfolded comp_def] T2.Vrs_Sb image_UN)[1] + apply (subst T3'.Vrs_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold image_Un image_UN)[1] + apply (rule refl) + + 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)+ + 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)+)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) + apply (subst T2.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold UN_UN_flatten) + 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)+)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj comp_apply T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) + apply (subst T3.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold UN_UN_flatten T3.Vrs_Map T3.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)+)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj comp_apply T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) + apply (subst T3.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold UN_UN_flatten T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right UN_Un_distrib) + 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)+)+ + apply (unfold T1.Vrs_Map T1.Vrs_Inj comp_apply T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) + apply (subst T3.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (unfold UN_UN_flatten T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right UN_Un_distrib) + apply (rule refl) + 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)+ + (* END REPEAT_DETERM *) + apply (rule T1.Sb_cong) + apply (unfold T1.Vrs_Map) + apply (rule prems SSupp_Inj_bound refl | 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)+ + apply (unfold T1.Map_Inj comp_assoc 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)+)+ + apply (unfold T1.Supp_Map image_comp[unfolded comp_def] T3'.Supp_Sb)[1] + apply (rule refl) + + 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 + +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} "BMV_Composition.T3'"); +\ + +local_setup \fn lthy => +let + open MRBNF_Util + val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I 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}, @{typ 'e}] }, + NONE, + SOME { frees = [@{typ 'b}, @{typ 'a}, @{typ 'c}], lives = [@{typ 'd}, @{typ 'h}], deads = [@{typ 'e}] } + ] lthy +in lthy end +\ -(* Comp *) -type_synonym 'a T = "'a + 'a type" end \ No newline at end of file diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 53abee51..ccf1654f 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -11,6 +11,10 @@ type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = ML_file \../Tools/mrsbnf_comp.ML\ +ML \ +Multithreading.parallel_proofs := 0 +\ + local_setup \fn lthy => let val ((mrsbnf, tys), (_, lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index d32a74d8..f80ab06a 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -159,7 +159,6 @@ binder_datatype 'a LM = | Lst "'a list" | App "'a LM" "'a LM" | Lam x::'a t::"'a LM" binds x in t -thm LM.subst axiomatization Vrs_1 :: "'a::var LM \ 'a set" where Vrs_1_simp1[simp]: "Vrs_1 (Var x) = {}" diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index 5886d146..4badb859 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -62,6 +62,8 @@ binder_datatype ('v, 'tv, 'ev, 'rv) expr = | Let x::'v "('v, 'tv, 'ev, 'rv) expr" e::"('v, 'tv, 'ev, 'rv) expr" binds x in e | RApp "('v, 'tv, 'ev, 'rv) expr" "'rv list" "('v, 'tv, 'ev, 'rv) expr" +print_locale REC_expr + (* #86 *) binder_datatype 'a "term" = Var 'a diff --git a/thys/MRBNF_Composition.thy b/thys/MRBNF_Composition.thy index 2ef8f5b5..f1f1eb20 100644 --- a/thys/MRBNF_Composition.thy +++ b/thys/MRBNF_Composition.thy @@ -1,5 +1,5 @@ theory MRBNF_Composition - imports "Prelim.Prelim" "Classes" + imports "Prelim.Prelim" Classes Support keywords "print_mrbnfs" :: diag and "mrbnf" :: thy_goal diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index 5af4faf8..2f724b8c 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -321,9 +321,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)" diff --git a/thys/Support.thy b/thys/Support.thy new file mode 100644 index 00000000..021d7739 --- /dev/null +++ b/thys/Support.thy @@ -0,0 +1,37 @@ +theory Support + imports "Prelim.Prelim" +begin + +lemma notin_supp: "x \ supp f \ f x = x" + unfolding supp_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 SSupp_Inj[simp]: "SSupp Inj Inj = {}" + unfolding SSupp_def by simp + +lemma IImsupp_Inj[simp]: "IImsupp Inj Vr Inj = {}" + unfolding IImsupp_def by simp + +lemma SSupp_Inj_bound[simp]: "|SSupp Inj Inj| 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: "infinite (UNIV::'a set) \ |SSupp Inj g| |supp f| |SSupp Inj (g \ f)| Date: Tue, 3 Jun 2025 12:39:15 +0200 Subject: [PATCH 32/90] Automate demoting of bmv monads --- Tools/bmv_monad_def.ML | 270 ++++++++++++++++++++++++++++++++- operations/BMV_Composition.thy | 34 +++-- 2 files changed, 288 insertions(+), 16 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 9a66c6e8..e9dcc018 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -94,6 +94,13 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory + 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 @@ -104,6 +111,8 @@ 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, @@ -707,7 +716,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("SSupp_Sb_bound", maps #SSupp_Sb_bounds facts, []) ] |> filter_out (null o #2) - |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (bmv_name ()) (Binding.name thmN)), attrs), [(thms, [])])); + |> map (fn (thmN, thms, attrs) => ((Binding.qualify true (bmv_name ()) (Binding.name thmN), attrs), [(thms, [])])); in Local_Theory.notes notes lthy |>> append noted end val fact_policy = fact_policy lthy; in ([], lthy) @@ -1097,11 +1106,6 @@ fun register_mrbnf_as_pbmv_monad name lthy = val lthy = register_pbmv_monad name bmv lthy; in lthy end -(* Cleanup: Throw away op iff any: -- not the leader -- does not appear in the codomain of any (=of any **other** SOp) Injection, -*) - fun slice_bmv_monad n bmv = let fun f xs = nth xs n; @@ -1130,6 +1134,260 @@ fun slice_bmv_monad n bmv = facts = [f (facts_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 => 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 consts = { + Injs = new_Injss, + RVrs = new_RVrss, + Sbs = new_Sbs, + Vrs = new_Vrss, + params = new_params, + bd = bd_of_bmv_monad bmv + }: 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 4} (fn Injs => fn RVrs => fn params => 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' rtac ctxt @{thm SSupp_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' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thm image_id} :: #Supp_Map (#axioms (the params)))), + 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) new_params, + tacs = @{map 5} (fn T => fn Injs => fn RVrs => fn axioms => fn params => { + 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' rtac ctxt @{thm SSupp_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' rtac ctxt @{thm SSupp_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 (@{thm SSupp_Inj_bound} + :: maps (the_default [] o #SSupp_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' rtac ctxt @{thm SSupp_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)) 1) + ) Injs)) Injs, + 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' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms UN_empty2 Un_empty_left Un_empty_right} + @ flat (#Vrs_Injss axioms) + @ 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' rtac ctxt @{thm SSupp_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 (map (hd o axioms_of_bmv_monad) demoted_bmvs) (map (hd o params_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 diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index ba759afc..dc7e5f09 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -6,6 +6,8 @@ begin 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 ML_file \../Tools/bmv_monad_def.ML\ @@ -97,11 +99,14 @@ frees: 'b, 'c, 'd lives: 'h *) -lemma cong': "f x = g x \ x = y \ f x = g y" - by simp +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::var, 'c::var) T4" +pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" Sbs: "\f1 \1 \2 \4. Sb_T3 \1 \2 Inj_2_T3 \4 \ Map_T3 f1 id" and Sb_T4 RVrs: set_1_T3 Injs: Inj_1_T3 Inj_1_T4 Inj_2_T4 and Inj_1_T4 Inj_2_T4 @@ -114,6 +119,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a::var, 'c::var) T4" apply (rule refl) apply (unfold comp_assoc T3.Map_Inj) apply (rule T3.Sb_comp_Inj; (assumption | rule SSupp_Inj_bound))+ + apply (rule trans) apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule trans[OF comp_assoc[symmetric]]) @@ -220,6 +226,20 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a::var, 'c::var) T4" done print_theorems +(* 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, true, 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)" @@ -443,16 +463,10 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and done print_theorems -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} "BMV_Composition.T3'"); -\ - local_setup \fn lthy => let open MRBNF_Util - val ((bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I T1 [Inl T2, Inr @{typ "'g set"}, Inl T3] + 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}, @{typ 'e}] }, NONE, From 94ceff1fa2aac1e43f5f7f5289fd571730d7ac45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 5 Jun 2025 16:29:13 +0200 Subject: [PATCH 33/90] Automate the new BMV composition --- Tools/bmv_monad_def.ML | 290 ++++++++++++++++++++++++++--------------- 1 file changed, 183 insertions(+), 107 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index e9dcc018..02cb5a2f 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -912,7 +912,7 @@ fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let val goals = @{map 5} (fn Sb => fn RVrs => fn Vrs => fn Injs => Option.map (fn param => - mk_param_axiom (#Map param) (#Supps param) Sb Injs RVrs Vrs (#bd (#consts model)) (map_filter I (#params (#consts model))) lthy + mk_param_axiom (#Map param) (#Supps param) Sb Injs RVrs Vrs (#bd (#consts 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)) (#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, ...} => @@ -1420,7 +1420,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit fun find_vars xs = map (fn x => the ( List.find (curry eq_name x) vars )) xs; - val inners = map2 (fn As => map_sum (fn bmv => + 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)); @@ -1435,13 +1435,37 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit @ (leader lives_of_bmv_monad bmv ~~ new_lives) @ (leader lives'_of_bmv_monad bmv ~~ new_lives') ); - in morph_bmv_monad phi bmv end - ) (fn T => + 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 Term.typ_subst_atomic subst T end - )) Ass inners; + in ((Inr (Term.typ_subst_atomic subst T), []), lthy) end + ) Ass inners lthy); + val outer = let val new_frees = find_vars (#frees oAs); @@ -1508,36 +1532,20 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 => - let - val lives = leader lives_of_bmv_monad inner; - val lives' = leader lives'_of_bmv_monad inner; - val map_t_opt = if null lives orelse forall (op<>) (lives ~~ lives') then NONE else SOME ( - Term.list_comb ( - Term.subst_atomic_types (lives' ~~ lives) (the (leader Maps_of_bmv_monad inner)), - map (fn a => - case List.find (curry (op=) a o domain_type o fastype_of) hs of - NONE => HOLogic.id_const a | SOME h => h - ) lives - ) - ); - val Sb_t = Term.list_comb (leader Sbs_of_bmv_monad inner, map_filter (fn RVr => - List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of RVr))) o domain_type o fastype_of) hs - ) (leader RVrs_of_bmv_monad inner) @ map (fn Inj => - case List.find (curry (op=) (fastype_of Inj) o fastype_of) rhos of - NONE => Inj | SOME rho => rho - ) (leader Injs_of_bmv_monad inner)); - val mk_Map_comp = case map_t_opt of - NONE => I | SOME t => fn t' => HOLogic.mk_comp (t, t') - in mk_Map_comp Sb_t end + 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 (t, + 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 @@ -1578,6 +1586,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val new_minions = map_filter (AList.lookup (op=) new_minions o body_type o fastype_of) new_Injs; val axiomss = map (leader axioms_of_bmv_monad) inners'; + val T = leader ops_of_bmv_monad outer; + val model = { ops = [leader ops_of_bmv_monad outer], bmv_ops = new_minions, @@ -1588,74 +1598,147 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit lives' = [lives'], deads = [deads], consts = consts, - params = [Option.map (fn { Supps, ...} => { + params = [Option.map (fn { Supps, ...} => + let + val param = the (leader params_of_bmv_monad outer); + in { axioms = { Map_id = fn ctxt => EVERY1 [ - K (print_tac ctxt "Map_id") + 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 [ - K (print_tac ctxt "Map_comp") + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ [#Map_comp (#axioms param)] @ + map_filter (Option.map (#Map_comp o #axioms) o leader params_of_bmv_monad) inners' + )), + rtac ctxt refl ], Supp_Map = map (fn _ => fn ctxt => EVERY1 [ - K (print_tac ctxt "Supp_map") - ]) Supps, - Supp_bd = map (fn _ => fn ctxt => EVERY1 [ - K (print_tac ctxt "Supp_bd") + K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def] image_UN} + @ #Supp_Map (#axioms param) @ + flat (map_filter (Option.map (#Supp_Map o #axioms) o leader params_of_bmv_monad) inners') + )), + rtac ctxt refl ]) Supps, - Map_cong = fn ctxt => EVERY1 [ - K (print_tac ctxt "Map_cong") - ] + Supp_bd = map (fn _ => fn ctxt => REPEAT_DETERM (resolve_tac ctxt ( + @{thms infinite_regular_card_order_UN infinite_regular_card_order_Un} + @ [bd_infinite_regular_card_order_of_bmv_monad outer] + @ #Supp_bd (#axioms param) + @ flat (map_filter (Option.map (#Supp_bd o #axioms) o leader params_of_bmv_monad) inners') + ) 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}, + assume_tac ctxt + ] + ] + ) inners) + ]) ctxt 1 }, Map_Sb = fn ctxt => EVERY1 [ - K (print_tac ctxt "Map_id") + 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' rtac ctxt @{thm SSupp_Inj_bound}), + K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} + @ #Map_Injs param @ [#Map_comp (#axioms param)] + )), + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + rtac ctxt ext, + rtac ctxt (#Map_cong (#axioms param)), + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' 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, + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + rtac ctxt refl + ]) inners) ], Supp_Sb = map (fn _ => fn ctxt => EVERY1 [ - K (print_tac ctxt "Map_id") + 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' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def]} @ #Supp_Map (#axioms param))), + TRY o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (flat (map_filter (Option.map #Supp_Sb o leader params_of_bmv_monad) inners')), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) + ], + rtac ctxt refl ]) Supps, Vrs_Map = map (fn _ => fn ctxt => EVERY1 [ - K (print_tac ctxt "Map_id") - ]) new_Vrs, - Map_Injs = map (fn _ => fn ctxt => EVERY1 [ - K (print_tac ctxt "Map_Injs") - ]) new_Injs - }) param], + 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 6} (fn axioms => fn param => fn Map => fn Injs => fn RVrs => fn Vrs => { + tacs = @{map 8} (fn axioms => fn param => fn facts => fn T => fn Map => fn Injs => fn RVrs => fn Vrs => { Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold_tac ctxt (@{thms id_o o_id} @ map #Sb_Inj (axioms :: axiomss) @ [#Map_id (#axioms param)] - @ map_filter (Option.map (#Map_id o #axioms) o leader params_of_bmv_monad) inners' )), rtac ctxt refl ], - Sb_comp_Injs = map (fn thm => fn ctxt => EVERY1 [ - K (print_tac ctxt "Sb_comp_Inj") - ]) (#Sb_comp_Injs axioms), + 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' rtac ctxt @{thm SSupp_Inj_bound}) + ]) + ) new_Injs, Sb_comp = fn ctxt => EVERY1 [ + rtac ctxt trans, rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt trans, - rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + 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 RS sym), - REPEAT_DETERM o assume_tac ctxt, + rtac ctxt (#Map_Sb param), + 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 _ _ "(\)"]}, - rtac ctxt (#Sb_comp axioms), - REPEAT_DETERM o assume_tac ctxt, - rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, - rtac ctxt trans, rtac ctxt (#Map_comp (#axioms param)), + rtac ctxt @{thm comp_assoc[symmetric]}, + EqSubst.eqsubst_tac ctxt [0] [#Sb_comp axioms], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms SSupp_Inj_bound} + @ the (#SSupp_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 (assume_tac ctxt ORELSE' resolve_tac ctxt ( + @{thms refl supp_comp_bound infinite_class.infinite_UNIV SSupp_Inj_bound} + @ #SSupp_Sb_bounds facts @ the (#SSupp_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)), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (@{thm id_o} :: maps (map #Sb_comp o axioms_of_bmv_monad) inners'), - REPEAT_DETERM o assume_tac ctxt, - rtac ctxt refl - ] + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ + rtac 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 ( @@ -1667,67 +1750,60 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) @{thms infinite_regular_card_order_Un infinite_regular_card_order_UN} ) ])) (RVrs @ Vrs), - Vrs_Injss = map (map (fn thm => fn ctxt => - print_tac ctxt "Vrs_Injs" - )) (#Vrs_Injss axioms), + 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} @ flat (#Supp_Injss facts))), + resolve_tac ctxt (refl :: flat (#Vrs_Injss axioms)) + ]) + ) new_Injs)) new_Vrs, Vrs_Sbs = map (K (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ( - @{thms image_Un image_UN comp_def image_comp Union_UN_swap} - @ #Vrs_Map param - @ #Supp_Sb param + 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' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def]} + @ #Vrs_Map param @ flat (#Vrs_Injss axioms) @ #Supp_Map (#axioms param) )), - REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, - TRY o (resolve_tac ctxt (#Vrs_Sbs axioms) THEN_ALL_NEW assume_tac ctxt), REPEAT_DETERM o EVERY' [ - rtac ctxt @{thm UN_cong}, - resolve_tac ctxt (maps (maps #Vrs_Sbs o axioms_of_bmv_monad) inners'), - REPEAT_DETERM o assume_tac ctxt - ] + EqSubst.eqsubst_tac ctxt [0] (maps (#Vrs_Sbs o leader axioms_of_bmv_monad) inners' @ #Supp_Sb param), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) + ], + K (Local_Defs.unfold0_tac ctxt @{thms image_Un Union_UN_swap image_UN UN_empty2 Un_empty_left Un_empty_right UN_UN_flatten UN_Un_distrib}), + rtac ctxt refl ])) (RVrs @ Vrs), Sb_cong = fn ctxt => EVERY1 [ rtac ctxt @{thm comp_apply_eq}, Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ - rtac ctxt @{thm trans[rotated]}, - rtac ctxt ( - let val n = length (nth (lives_of_bmv_monad outer) (leader_of_bmv_monad outer)); - in mk_arg_cong lthy (n + 1) Map OF (replicate n refl) end - ), - K (prefer_tac 2), - rtac ctxt (#Map_cong (#axioms param)), + rtac ctxt (@{thm cong'[rotated]} OF [#Map_cong (#axioms param)]), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ - EqSubst.eqsubst_asm_tac ctxt [0] (#Supp_Sb param), - REPEAT_DETERM o resolve_tac ctxt prems, - resolve_tac ctxt (map #Sb_cong (axioms_of_bmv_monad inner)), - REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), - REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ - TRY o (dtac ctxt @{thm UN_I} THEN' assume_tac ctxt), - resolve_tac ctxt (drop (2 * length Injs) prems), + 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, - etac ctxt UnI2, - rtac ctxt UnI1 + eresolve_tac ctxt [UnI1, UnI2], + rtac ctxt UnI2 ] - ]) + ] ]) inners), - TRY o EVERY' [ - rtac ctxt (#Sb_cong axioms), - REPEAT_DETERM o resolve_tac ctxt (take (2 * length Injs) prems), - REPEAT_DETERM o (rtac ctxt refl ORELSE' EVERY' [ - TRY o (dtac ctxt @{thm UN_I} THEN' assume_tac ctxt), - resolve_tac ctxt (drop (2 * length Injs) prems), - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - etac ctxt UnI2, - rtac ctxt UnI1 - ] - ]) + rtac ctxt (#Sb_cong axioms), + K (Local_Defs.unfold0_tac ctxt (#Vrs_Map param)), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt (@{thms SSupp_Inj_bound refl} @ prems) ] ]) 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] } : (Proof.context -> tactic) bmv_monad_model; From 0bd6edb9e6dcf878d6cd6620c08d5efb87d41842 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sat, 7 Jun 2025 13:21:40 +0200 Subject: [PATCH 34/90] Fix Supp_Sb axiom and Vrs_Sb goal generation --- Tools/bmv_monad_def.ML | 167 +++++++++++++------ Tools/mrsbnf_def.ML | 61 ++++--- case_studies/Untyped_Lambda_Calculus/LC.thy | 2 +- operations/BMV_Composition.thy | 172 +++++++++++++++----- operations/BMV_Monad.thy | 79 ++++----- thys/Prelim/Prelim.thy | 5 + 6 files changed, 329 insertions(+), 157 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 02cb5a2f..e7a643b2 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -141,7 +141,16 @@ 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) = { +}: '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, @@ -149,7 +158,7 @@ fun apply_bmv_monad_axioms ({ 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; +} : 'b bmv_monad_axioms end; type bmv_monad_facts = { Inj_inj: thm list, @@ -387,13 +396,13 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = 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 @ + 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 => + (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 @@ -407,39 +416,48 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (Vrs $ x)) (#bd consts)) )) (RVrs @ Vrs); - val Vrs_Injss = map2 (fn Inj' => fn Vrs => map (fn Inj => + 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), - if Inj' = Inj then mk_singleton a else mk_bot T)) - end - ) own_Injs) Injs Vrs; + 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) (RVrs @ Vrs); val Vrs_Sbs = map2 (fn f => fn RVr => - fold_rev Logic.all (fs @ rhos @ [x]) ( + 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), mk_image f $ (RVr $ x) + RVr $ (Term.list_comb (Sb, fs @ rhos) $ x), foldr1 mk_Un ((mk_image f $ (RVr $ x)) :: UNs) )) - ) - ) fs RVrs @ map2 (fn Vr => fn Inj => + ) end + ) fs RVrs @ map2 (fn Vr => fn Inj => let val UNs = @{map_filter 2} (fn Vr' => fn rho => - if body_type (fastype_of rho) <> body_type (fastype_of Inj) then NONE else let - val X = Vr' $ x - val inner_Vr = if body_type (fastype_of rho) = domain_type (fastype_of Vr) then Vr else - let - val idx = find_index (curry (op=) (body_type (fastype_of rho))) Ts; - val Vrs = nth Vrss idx; - val Inj_idx = find_index (curry (op=) Inj) (nth Injss idx); - in nth Vrs Inj_idx end - in SOME ( + 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) )) - ) end + ) inner_Vr end ) Vrs rhos; in fold_rev Logic.all (fs @ rhos @ [x]) ( fold_rev (curry Logic.mk_implies) small_prems (mk_Trueprop_eq ( @@ -554,7 +572,18 @@ fun mk_param_axiom Map Supps Sb Injs RVrs Vrs bd params lthy = val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ hs @ [x]) ( fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs) (mk_Trueprop_eq ( - Supp $ (Term.list_comb (Sb, hs @ rhos) $ x), Supp $ x + 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; @@ -626,7 +655,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( 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); + ) (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 @@ -791,7 +820,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona ])) end else NONE ) Injs) Supps)) (#lives model) (#lives' model) (#params model) Injss (#params (#consts model)) - val SSupp_premss = @{map 3} (fn Injs => fn rhos => fn hs => + val SSupp_premss = @{map 3} (fn Injs => fn rhos => fn hs => map (HOLogic.mk_Trueprop o mk_supp_bound) hs @ map2 (fn Inj => fn rho => HOLogic.mk_Trueprop ( mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj)))) @@ -1196,7 +1225,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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) @@ -1263,7 +1292,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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 4} (fn Injs => fn RVrs => fn params => Option.map (fn { Supps, ... } => { + 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 [ @@ -1302,7 +1331,10 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives EqSubst.eqsubst_tac ctxt [0] (#Supp_Sb (the params)), REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) ], - K (Local_Defs.unfold0_tac ctxt (@{thm image_id} :: #Supp_Map (#axioms (the params)))), + 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 [ @@ -1312,8 +1344,9 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives )), rtac ctxt refl ])) (RVrs @ Injs) - })) new_Injss new_RVrss (map (hd o params_of_bmv_monad) demoted_bmvs) new_params, - tacs = @{map 5} (fn T => fn Injs => fn RVrs => fn axioms => fn params => { + })) 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 6} (fn T => fn Injs => fn RVrs => 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, @@ -1354,8 +1387,8 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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)) 1) - ) Injs)) Injs, + SOME (fn ctxt => resolve_tac ctxt (flat (#Vrs_Injss axioms @ #Supp_Injss facts)) 1) + ) Injs)) (RVrs @ Injs), Vrs_Sbs = map (K (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), REPEAT_DETERM o EVERY' [ @@ -1364,6 +1397,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives ], K (Local_Defs.unfold0_tac ctxt (@{thms UN_empty2 Un_empty_left Un_empty_right} @ flat (#Vrs_Injss axioms) + @ flat (#Supp_Injss facts) @ the_default [] (Option.map (fn params => #Supp_Map (#axioms params) @ #Vrs_Map params ) params) @@ -1384,7 +1418,8 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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 (map (hd o axioms_of_bmv_monad) demoted_bmvs) (map (hd o params_of_bmv_monad) demoted_bmvs) + }) new_ops new_Injss new_RVrss (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 @@ -1489,7 +1524,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val new_Injs = 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 @@ -1553,7 +1588,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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), + 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) @@ -1578,9 +1613,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit params = [param] }: bmv_monad_consts; - val new_minions = map (fn bmv => (hd (ops_of_bmv_monad bmv), bmv)) ( + val new_minions = maps (fn bmv => map_index (fn (i, T) => (T, 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 (hd o ops_of_bmv_monad)) (outer :: inners') + distinct ((op=) o apply2 (leader ops_of_bmv_monad)) (outer :: inners') ) ); val new_minions = map_filter (AList.lookup (op=) new_minions o body_type o fastype_of) new_Injs; @@ -1601,6 +1636,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 [ @@ -1669,12 +1705,29 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit EqSubst.eqsubst_tac ctxt [0] (#Supp_Sb param), REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) ], - K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def]} @ #Supp_Map (#axioms param))), - TRY o EVERY' [ + 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} + @ #Supp_Map (#axioms param) @ #Vrs_Map param @ flat (#Supp_Injss facts) + )), + REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (flat (map_filter (Option.map #Supp_Sb o leader params_of_bmv_monad) inners')), REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) ], - rtac ctxt refl + K (Local_Defs.unfold0_tac ctxt @{thms 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]} @@ -1752,26 +1805,44 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ])) (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} @ flat (#Supp_Injss facts))), + 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_Vrs, + ) new_Injs)) (new_RVrs @ new_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' rtac ctxt @{thm SSupp_Inj_bound}) ], - K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def]} + 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} @ #Vrs_Map param @ flat (#Vrs_Injss axioms) - @ #Supp_Map (#axioms param) + @ #Supp_Map (#axioms param) @ flat (maps ( + #Supp_Injss o leader facts_of_bmv_monad + ) (outer :: inners')) )), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps (#Vrs_Sbs o leader axioms_of_bmv_monad) inners' @ #Supp_Sb param), + EqSubst.eqsubst_tac ctxt [0] (maps (#Vrs_Sbs o leader 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' rtac ctxt @{thm SSupp_Inj_bound}) ], - K (Local_Defs.unfold0_tac ctxt @{thms image_Un Union_UN_swap image_UN UN_empty2 Un_empty_left Un_empty_right UN_UN_flatten UN_Un_distrib}), - rtac ctxt refl + K (Local_Defs.unfold0_tac ctxt @{thms 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 + ] + ] ])) (RVrs @ Vrs), Sb_cong = fn ctxt => EVERY1 [ rtac ctxt @{thm comp_apply_eq}, @@ -1843,7 +1914,7 @@ fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = 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 => + 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) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index c145b77f..5307fc36 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -154,7 +154,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs bmv axioms' lthy = let val names = map (fst o dest_Free); - val facts' = @{map 8} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn RVrs => fn SSupps => + val facts' = @{map 7} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn RVrs => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -180,9 +180,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b val live = MRBNF_Def.live_of_mrbnf mrbnf; - val g_prems = map2 (fn (SSupp, _) => fn g => HOLogic.mk_Trueprop ( - mk_ordLess (mk_card_of (SSupp $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) - )) SSupps gs; + 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; @@ -208,7 +208,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt sym, rtac ctxt trans, rtac ctxt (#Sb_comp bmv_axioms), - REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound infinite_class.infinite_UNIV} @ prems), K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), @@ -227,24 +227,23 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b REPEAT_DETERM o resolve_tac ctxt prems, 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 (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound infinite_class.infinite_UNIV} @ prems), rtac ctxt @{thm comp_apply} ])) end ) Injs (filter (member (op=) Inj_aas o domain_type o fastype_of) free_fs) (map (fn aT => the (List.find (curry (op=) aT o fastype_of) aa)) Inj_aas); - val SSupp_map_subset = @{map 3} (fn (SSupp, SSupp_def) => fn g => fn g_prem => + val SSupp_map_subset = @{map 3} (fn Inj => fn g => fn g_prem => let val map_t = Term.list_comb (mapx, fs); - val SSupp' = Term.subst_atomic_types (As' ~~ As') SSupp; val goal = HOLogic.mk_Trueprop (uncurry mk_leq ( - SSupp' $ HOLogic.mk_comp (map_t, g), - mk_Un (SSupp $ g, mk_supp (the (find_f (HOLogic.dest_setT (body_type (fastype_of SSupp)))))) + mk_SSupp 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 (domain_type (fastype_of SSupp')) then NONE else + in if body_type (fastype_of map_t) <> body_type (fastype_of 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] [SSupp_def], - EqSubst.eqsubst_asm_tac ctxt [0] [SSupp_def], + 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, @@ -260,13 +259,13 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b etac ctxt @{thm notin_supp} ])) end - ) SSupps gs g_prems; + ) Injs gs g_prems; val Un_bound = MRBNF_Def.get_class_assumption [BMV_Monad_Def.var_class_of_bmv_monad bmv] "Un_bound" lthy; - val SSupp_map_bound = @{map 4} (fn (SSupp, _) => fn g => fn g_prem => Option.map (fn thm => + 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 (SSupp $ HOLogic.mk_comp (Term.list_comb (mapx, fs), g)), + mk_card_of (mk_SSupp 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 [ @@ -276,7 +275,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt Un_bound, REPEAT_DETERM o resolve_tac ctxt prems ]) end - )) SSupps gs g_prems SSupp_map_subset; + )) Injs gs g_prems SSupp_map_subset; in { SSupp_map_subset = SSupp_map_subset, SSupp_map_bound = SSupp_map_bound, @@ -285,9 +284,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b } end ) axioms' mrbnfs (BMV_Monad_Def.axioms_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.SSupps_of_bmv_monad bmv); + (BMV_Monad_Def.RVrs_of_bmv_monad bmv); - val facts' = @{map 9} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn RVrs => fn Injs => fn SSupps => + val facts' = @{map 8} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => 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; @@ -307,9 +306,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b val frees = inter (op=) Fs (MRBNF_Def.frees_of_mrbnf mrbnf); val free = length frees; - val g_prems = map2 (fn (SSupp, _) => fn g => HOLogic.mk_Trueprop ( - mk_ordLess (mk_card_of (SSupp $ g)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g)))) - )) SSupps gs; + 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 (curry (op=) T o domain_type o fastype_of) fs; val h_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs; @@ -377,7 +376,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt refl, rtac ctxt refl ] ORELSE' EVERY' [ - REPEAT_DETERM o resolve_tac ctxt (prems @ #SSupp_comp_bound bmv_facts @ #SSupp_Inj_bound bmv_facts), + REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound} @ [infinite_UNIV] @ prems), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (map (fn thm => thm RS sym) map_is_Sb), REPEAT_DETERM o resolve_tac ctxt prems @@ -387,9 +386,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Sb_comp_right facts), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound supp_comp_bound} + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound supp_comp_bound SSupp_comp_bound} @ [infinite_UNIV] - @ maps (map_filter I o #SSupp_map_bound) facts' @ prems @ #SSupp_comp_bound bmv_facts + @ maps (map_filter I o #SSupp_map_bound) facts' @ prems ), K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym], @@ -411,7 +410,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b }: mrsbnf_facts end ) axioms' facts' mrbnfs (BMV_Monad_Def.axioms_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) (BMV_Monad_Def.SSupps_of_bmv_monad bmv); + (BMV_Monad_Def.Injs_of_bmv_monad bmv); val mrsbnf = MRSBNF { mrbnfs = mrbnfs, @@ -474,7 +473,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); end; - val axioms = @{map 7} (fn mrbnf => fn Sb => fn Injs => fn SSupps => fn RVrs => fn Vrs => fn bmv_frees => + val axioms = @{map 6} (fn mrbnf => fn Sb => fn Injs => fn RVrs => fn Vrs => fn bmv_frees => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -519,9 +518,9 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val other_fs = flat (MRBNF_Def.interlace (map single live_fs) (map single bound_fs) (replicate free [] @ map single pfree_fs) var_types); - val g_prems = map2 (fn (SSupp, _) => fn g => HOLogic.mk_Trueprop (uncurry mk_ordLess ( - mk_card_of (SSupp $ g), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) - ))) SSupps gs; + val g_prems = map2 (fn Inj => fn g => HOLogic.mk_Trueprop (uncurry mk_ordLess ( + mk_card_of (mk_SSupp Inj $ g), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) + ))) Injs gs; val h_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs; val count = live + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; @@ -562,7 +561,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = set_Sb = set_Sbs }: term mrsbnf_axioms end ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) - (BMV_Monad_Def.SSupps_of_bmv_monad bmv) (BMV_Monad_Def.RVrs_of_bmv_monad bmv) + (BMV_Monad_Def.RVrs_of_bmv_monad bmv) (BMV_Monad_Def.Vrs_of_bmv_monad bmv) (BMV_Monad_Def.frees_of_bmv_monad bmv); in (axioms, (deads, As, As', Bs, Fs, fs), mrbnfs, bmv) end diff --git a/case_studies/Untyped_Lambda_Calculus/LC.thy b/case_studies/Untyped_Lambda_Calculus/LC.thy index 38cf7ff6..2ee81f13 100644 --- a/case_studies/Untyped_Lambda_Calculus/LC.thy +++ b/case_studies/Untyped_Lambda_Calculus/LC.thy @@ -9,7 +9,7 @@ begin (* DATATYPE DECLARTION *) -declare [[mrbnf_internals]] +(*declare [[mrbnf_internals]]*) binder_datatype 'a "term" = Var 'a | App "'a term" "'a term" diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index dc7e5f09..beb53b9d 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -4,11 +4,6 @@ theory BMV_Composition "pbmv_monad" :: thy_goal begin -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 - ML_file \../Tools/bmv_monad_def.ML\ (* live, free, free, live, live, dead, free *) @@ -56,6 +51,7 @@ consts Inj_2_T4 :: "'b \ ('a::var, 'b::var) T4" ML \ Multithreading.parallel_proofs := 0 \ + declare [[goals_limit=1000]] pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" Sbs: Sb_T1 @@ -119,7 +115,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (rule refl) apply (unfold comp_assoc T3.Map_Inj) apply (rule T3.Sb_comp_Inj; (assumption | rule SSupp_Inj_bound))+ - + apply (rule trans) apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule trans[OF comp_assoc[symmetric]]) @@ -137,13 +133,14 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (subst T3.Sb_comp_Inj, (assumption | rule SSupp_Inj_bound)+)+ apply (rule refl) - apply (rule T3.Supp_bd T3.Vrs_bd T3.Vrs_Inj)+ + 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)+ - apply (rule T3.Supp_Map) + apply (assumption | rule SSupp_Inj_bound)+ + apply (unfold T3.Vrs_Map T3.Supp_Map T3.Supp_Inj UN_empty2 Un_empty_left Un_empty_right) + apply (rule refl) done subgoal for f \1 \2 \3 x apply (unfold comp_def) @@ -210,13 +207,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def)[1] apply (subst T3.Supp_Sb, (assumption | rule SSupp_Inj_bound)+) - apply (rule trans) - apply (rule T3.Supp_Map) - apply (rule image_id) - apply (rule trans) - apply (rule T3.Supp_Map) - apply (rule image_id) - apply (unfold T3.Vrs_Map) + 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) @@ -318,21 +309,39 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and done apply (unfold T1.Supp_Inj UN_empty) - apply (rule refl 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 (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)+ - apply (unfold T1.Vrs_Map)[1] + 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)+)+ - apply (unfold T1.Supp_Map image_comp[unfolded comp_def] T2.Vrs_Sb image_UN)[1] - apply (subst T3'.Vrs_Sb, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold image_Un image_UN)[1] - apply (rule refl) + 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)+)+ + 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) @@ -345,37 +354,103 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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)+)+ - apply (unfold T1.Vrs_Map T1.Vrs_Inj T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) + 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 (subst T2.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold UN_UN_flatten) - apply (rule refl) + apply (unfold UN_UN_flatten UN_Un)[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)+)+ - apply (unfold T1.Vrs_Map T1.Vrs_Inj comp_apply T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) - apply (subst T3.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold UN_UN_flatten T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right) - apply (rule refl) + 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'.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_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)+)+ - apply (unfold T1.Vrs_Map T1.Vrs_Inj comp_apply T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) - apply (subst T3.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold UN_UN_flatten T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right UN_Un_distrib) - apply (rule refl) + 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)+)+ + 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)+)+ - apply (unfold T1.Vrs_Map T1.Vrs_Inj comp_apply T1.Supp_Map image_comp[unfolded comp_def] UN_empty2 Un_empty_right) - apply (subst T3.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold UN_UN_flatten T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right UN_Un_distrib) - apply (rule refl) + 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)+)+ + 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 @@ -455,8 +530,27 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (unfold0 comp_apply)[1] apply (subst T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold T1.Supp_Map image_comp[unfolded comp_def] T3'.Supp_Sb)[1] - apply (rule refl) + 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)+)+ + 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)+ diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index f80ab06a..130d36cf 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -31,7 +31,7 @@ lemma SSupp_IImsupp_bound[simp]: shows "|IImsupp_FType \| \'::"'tyvar::var \ 'tyvar FType" assumes "|SSupp_FType \| \ \') \ SSupp_FType \ \ SSupp_FType \'" @@ -41,11 +41,11 @@ lemma SSupp_comp_subset: apply (unfold mem_Collect_eq) apply simp using assms(1) by force -lemma SSupp_comp_bound[simp]: +lemma SSupp_comp_bound_FType[simp]: fixes \ \'::"'tyvar::var \ 'tyvar FType" assumes "|SSupp_FType \| '| \ \')| _FType_tvsubst_FType_def TyVar_def[symmetric]], symmetric]) apply (rule Sb_comp_Inj_FType; assumption) - apply ((unfold SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def comp_def TyVar_def)[1], rule refl) apply (rule Sb_comp_FType; assumption) apply (rule FType.set_bd) apply (rule Vrs_Inj_FType) @@ -327,9 +326,9 @@ pbmv_monad "'b::var LM" RVrs: Vrs_1 Injs: Var Vrs: Vrs_2 - SSupps: SSupp_LM bd: natLeq apply (rule infinite_regular_card_order_natLeq) + apply (unfold SSupp_def[of Var, unfolded SSupp_LM_def[unfolded tvVVr_tvsubst_LM_def comp_def tv\_LM_tvsubst_LM_def Var_def[symmetric], symmetric]]) apply (rule ext) subgoal for x @@ -337,10 +336,7 @@ pbmv_monad "'b::var LM" apply auto apply (rule trans[OF Sb_LM_simp4]) by (auto simp: imsupp_def supp_def IImsupp_LM_def SSupp_LM_def tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def Var_def) - apply fastforce - - apply (unfold SSupp_LM_def tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def Var_def comp_def)[1] - apply (rule refl) + apply fastforce apply (rule ext) apply (rule trans[OF comp_apply]) @@ -358,7 +354,8 @@ pbmv_monad "'b::var LM" done apply (rule Vrs_1_bd) - apply (rule Vrs_2_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) @@ -382,7 +379,6 @@ lemma vvsubst_Sb: done done - mrsbnf "'b::var LM" apply (rule vvsubst_Sb; assumption) apply (rule Vrs_Un) @@ -531,7 +527,6 @@ val model_L = { RVrs = [[@{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}]], Injs = [[]], Vrs = [[]], - SSupps = [[]], params = [SOME { Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, Supps = [ @@ -540,7 +535,6 @@ val model_L = { ] }] }, - SSupp_eq = [[]], params = [SOME { axioms = { Map_id = fn ctxt => EVERY1 [ @@ -579,11 +573,12 @@ val model_L = { K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta id_apply map_prod_simp}), resolve_tac ctxt [refl] ], + Map_Injs = [], Supp_Sb = replicate 2 (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms case_prod_map_prod id_apply Sb_L_def Supp_L_1_def Supp_L_2_def}), resolve_tac ctxt [refl] ]), - Map_Vrs = [fn ctxt => EVERY1 [ + Vrs_Map = [fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Map_L_def case_prod_beta fst_conv snd_conv}), resolve_tac ctxt [refl] ]] @@ -608,7 +603,7 @@ val model_L = { resolve_tac ctxt @{thms natLeq_Cinfinite}, resolve_tac ctxt @{thms ID.set_bd} ]], - Vrs_Injs = [], + Vrs_Injss = [], Vrs_Sbs = [fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta Product_Type.fst_map_prod Product_Type.snd_map_prod image_insert image_empty @@ -659,10 +654,8 @@ val model_L1 = { @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"} ]], - params = [NONE], - SSupps = [[]] + params = [NONE] }, - SSupp_eq = [[]], params = [NONE], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ @@ -682,7 +675,7 @@ val model_L1 = { fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1, fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1 ], - Vrs_Injs = [], + Vrs_Injss = [], Vrs_Sbs = [ fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Sb_L1_def case_prod_map_prod}), @@ -738,17 +731,12 @@ val model_L2 = { @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"} ]], Injs = [[@{term "TyVar :: 'a2::var \ 'a2 FType"}]], - SSupps = [[SOME @{term "SSupp_FType :: ('a2::var \ 'a2 FType) \ 'a2 set"}]], Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], Vrs = [[ @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"} ]], params = [NONE] }, - SSupp_eq = [[SOME (fn ctxt => - Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]} - THEN resolve_tac ctxt [refl] 1 - )]], params = [NONE], bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, tacs = [{ @@ -760,7 +748,7 @@ val model_L2 = { Sb_comp = fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt ( (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) - :: @{thms Sb_L2_def id_apply Sb_comp_FType} + :: @{thms Sb_L2_def id_apply Sb_comp_FType SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]} )), resolve_tac ctxt [refl] ], @@ -774,20 +762,20 @@ val model_L2 = { ], fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_3_def} THEN resolve_tac ctxt @{thms FType.set_bd} 1 ], - Vrs_Injs = [], + Vrs_Injss = [[]], Vrs_Sbs = [ fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply image_insert image_empty}), resolve_tac ctxt [refl] ], fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta insert_is_Un[symmetric] UN_insert UN_empty Un_empty_right id_apply image_insert image_empty}), resolve_tac ctxt [refl] ], fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_3_def case_prod_map_prod}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_3_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), resolve_tac ctxt @{thms Vrs_Sb_FType}, K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), @@ -795,7 +783,7 @@ val model_L2 = { ] ], Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def Vrs_L2_3_def case_prod_beta id_apply}), + K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def Vrs_L2_3_def case_prod_beta id_apply SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), resolve_tac ctxt @{thms prod.map_cong0}, eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, dresolve_tac ctxt @{thms meta_spec}, @@ -838,14 +826,29 @@ val model_L2 = { \ local_setup \fn lthy => - let - val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L_") (SOME (Binding.name "L")) model_L lthy; - val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L1_") (SOME (Binding.name "L1")) model_L1 lthy; - val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) (Binding.prefix_name "L2_") (SOME (Binding.name "L2")) model_L2 lthy; - - val (_, lthy) = @{fold_map 2} (BMV_Monad_Def.note_bmv_monad_thms (K BNF_Def.Note_All) I o SOME o Binding.name) ["L", "L1", "L2"] [L_bmv, L1_bmv, L2_bmv] lthy; +let + val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (Binding.prefix_name "L_") (SOME (Binding.name "L")) model_L lthy; + val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (Binding.prefix_name "L1_") (SOME (Binding.name "L1")) model_L1 lthy; + val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (Binding.prefix_name "L2_") (SOME (Binding.name "L2")) model_L2 lthy; + + val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Monad.L" L_bmv lthy + val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Monad.L1" L1_bmv lthy + val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Monad.L2" L2_bmv lthy +in lthy end +\ - val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [MRBNF_Util.Inl L1_bmv, MRBNF_Util.Inl L2_bmv] lthy +local_setup \fn lthy => + let + val L_bmv = the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.L"); + val L1_bmv = the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.L1"); + val L2_bmv = the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.L2"); + + val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [MRBNF_Util.Inl L1_bmv, MRBNF_Util.Inl L2_bmv] + { deads = [], frees = [@{typ "'a1"}] } + [ SOME { deads = [], lives = [], frees = [@{typ "'a1"}, @{typ "'a2"}] }, + SOME { deads = [], lives = [], frees = [@{typ 'a1}, @{typ "'a2"}] } + ] + lthy val _ = @{print} comp_bmv in lthy end \ diff --git a/thys/Prelim/Prelim.thy b/thys/Prelim/Prelim.thy index 0c16437c..bafe214a 100644 --- a/thys/Prelim/Prelim.thy +++ b/thys/Prelim/Prelim.thy @@ -1012,4 +1012,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 From 1e90ead730bdbade160d00c7eb8ed1d62cac963d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sat, 7 Jun 2025 13:36:58 +0200 Subject: [PATCH 35/90] Fix last errors in BMV_Monad operations theory --- Tools/bmv_monad_def.ML | 8 +++++--- operations/BMV_Monad.thy | 6 +++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index e7a643b2..a8dff26a 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1115,7 +1115,7 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = rtac ctxt refl ], Vrs_bds = map (fn _ => fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf mrbnf) 1) fsets, - Vrs_Injss = [], + 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}) @@ -1858,7 +1858,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit REPEAT_DETERM o FIRST' [ assume_tac ctxt, eresolve_tac ctxt [UnI1, UnI2], - rtac ctxt UnI2 + rtac ctxt UnI1 ] ] ]) inners), @@ -1866,7 +1866,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit K (Local_Defs.unfold0_tac ctxt (#Vrs_Map param)), REPEAT_DETERM o FIRST' [ assume_tac ctxt, - resolve_tac ctxt (@{thms SSupp_Inj_bound refl} @ prems) + resolve_tac ctxt (@{thms SSupp_Inj_bound refl} @ prems), + eresolve_tac ctxt [UnI1, UnI2], + rtac ctxt UnI1 ] ]) ctxt ] diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 130d36cf..3274c6ad 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -603,7 +603,7 @@ val model_L = { resolve_tac ctxt @{thms natLeq_Cinfinite}, resolve_tac ctxt @{thms ID.set_bd} ]], - Vrs_Injss = [], + Vrs_Injss = [[]], Vrs_Sbs = [fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta Product_Type.fst_map_prod Product_Type.snd_map_prod image_insert image_empty @@ -675,7 +675,7 @@ val model_L1 = { fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1, fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1 ], - Vrs_Injss = [], + Vrs_Injss = [[], []], Vrs_Sbs = [ fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Sb_L1_def case_prod_map_prod}), @@ -762,7 +762,7 @@ val model_L2 = { ], fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_3_def} THEN resolve_tac ctxt @{thms FType.set_bd} 1 ], - Vrs_Injss = [[]], + Vrs_Injss = [[], [], []], Vrs_Sbs = [ fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), From 7bf857eec9b122e929360e56ab535224937a76c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 16 Jun 2025 17:21:40 +0100 Subject: [PATCH 36/90] Fix several issues in MRSBNF axiomatization --- Tools/bmv_monad_def.ML | 105 +++++---- Tools/mrsbnf_comp.ML | 62 +++-- Tools/mrsbnf_def.ML | 361 +++++++++++++++++++++--------- operations/BMV_Composition.thy | 2 +- operations/MRSBNF_Composition.thy | 86 +++++++ tests/Regression_Tests.thy | 2 - 6 files changed, 448 insertions(+), 170 deletions(-) create mode 100644 operations/MRSBNF_Composition.thy diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index a8dff26a..3316820b 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -79,6 +79,8 @@ signature BMV_MONAD_DEF = sig 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 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; @@ -287,6 +289,8 @@ 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 +fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) + type 'a bmv_monad_model = { ops: typ list, var_class: class, @@ -498,6 +502,7 @@ fun mk_param_axiom Map Supps Sb Injs RVrs Vrs bd params lthy = 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') @@ -1623,6 +1628,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 = [leader ops_of_bmv_monad outer], bmv_ops = new_minions, @@ -1680,15 +1689,17 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ]) ctxt 1 }, Map_Sb = fn ctxt => EVERY1 [ - 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' rtac ctxt @{thm SSupp_Inj_bound}), + 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' rtac ctxt @{thm SSupp_Inj_bound}) + ], K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ #Map_Injs param @ [#Map_comp (#axioms param)] )), - rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + TRY o rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, rtac ctxt ext, rtac ctxt (#Map_cong (#axioms param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' EVERY' [ @@ -1744,7 +1755,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit tacs = @{map 8} (fn axioms => fn param => fn facts => fn T => fn Map => fn Injs => fn RVrs => fn Vrs => { Sb_Inj = fn ctxt => EVERY1 [ K (Local_Defs.unfold_tac ctxt (@{thms id_o o_id} - @ map #Sb_Inj (axioms :: axiomss) + @ no_reflexive (map #Sb_Inj (axioms :: axiomss)) @ [#Map_id (#axioms param)] )), rtac ctxt refl @@ -1758,37 +1769,41 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) new_Injs, Sb_comp = fn ctxt => EVERY1 [ rtac ctxt trans, - 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' rtac ctxt @{thm SSupp_Inj_bound}), - rtac ctxt @{thm trans[OF comp_assoc]}, - rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + 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' rtac ctxt @{thm SSupp_Inj_bound}), + rtac ctxt @{thm trans[OF comp_assoc]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} + ], rtac ctxt (#Map_comp (#axioms param)), - rtac ctxt @{thm comp_assoc[symmetric]}, - EqSubst.eqsubst_tac ctxt [0] [#Sb_comp axioms], - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms SSupp_Inj_bound} - @ the (#SSupp_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 (assume_tac ctxt ORELSE' resolve_tac ctxt ( - @{thms refl supp_comp_bound infinite_class.infinite_UNIV SSupp_Inj_bound} - @ #SSupp_Sb_bounds facts @ the (#SSupp_Map_bounds facts) - @ maps (map (fn thm => thm RS fun_cong) o #Sb_comp_Injs o leader axioms_of_bmv_monad) (outer :: inners') - )) - ]), + TRY o EVERY' [ + rtac ctxt @{thm comp_assoc[symmetric]}, + EqSubst.eqsubst_tac ctxt [0] [#Sb_comp axioms], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms SSupp_Inj_bound} + @ the (#SSupp_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 (assume_tac ctxt ORELSE' resolve_tac ctxt ( + @{thms refl supp_comp_bound infinite_class.infinite_UNIV SSupp_Inj_bound} + @ #SSupp_Sb_bounds facts @ the (#SSupp_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 => EVERY' [ + EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' EVERY' [ rtac ctxt (#Sb_comp (leader axioms_of_bmv_monad inner) RS fun_cong), REPEAT_DETERM o assume_tac ctxt ]) inners) @@ -1845,10 +1860,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ] ])) (RVrs @ Vrs), Sb_cong = fn ctxt => EVERY1 [ - rtac ctxt @{thm comp_apply_eq}, + TRY o rtac ctxt @{thm comp_apply_eq}, Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ - rtac ctxt (@{thm cong'[rotated]} OF [#Map_cong (#axioms param)]), - EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => EVERY' [ + 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' [ @@ -1862,13 +1877,15 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ] ] ]) inners), - rtac ctxt (#Sb_cong axioms), - K (Local_Defs.unfold0_tac ctxt (#Vrs_Map param)), - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - resolve_tac ctxt (@{thms SSupp_Inj_bound refl} @ prems), - eresolve_tac ctxt [UnI1, UnI2], - rtac ctxt UnI1 + 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 (@{thms SSupp_Inj_bound refl} @ prems), + eresolve_tac ctxt [UnI1, UnI2], + rtac ctxt UnI1 + ] ] ]) ctxt ] diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 876f89b2..5e388c63 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -34,29 +34,63 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A let val outer_bmv = MRSBNF_Def.bmv_monad_of_mrsbnf outer; val inner_bmvs = map MRSBNF_Def.bmv_monad_of_mrsbnf inners; - val leader = BMV_Monad_Def.leader_of_bmv_monad outer_bmv; - - val _ = @{print} ("outer", BMV_Monad_Def.ops_of_bmv_monad outer_bmv) - val _ = @{print} ("inners", map BMV_Monad_Def.ops_of_bmv_monad inner_bmvs) - - - val _ = @{print} ("vars", oAs, Ass) + fun leader f bmv = nth (f bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv); + + fun separate_vars vars bmv = + let + val Ts = (case leader BMV_Monad_Def.ops_of_bmv_monad bmv of + Type (_, Ts) => Ts + | T => [T] + ) ~~ vars; + fun lookup f = map_filter (Option.join o AList.lookup (op=) Ts) (leader f bmv); + in { + frees = lookup BMV_Monad_Def.frees_of_bmv_monad, + deads = lookup BMV_Monad_Def.deads_of_bmv_monad, + lives = lookup BMV_Monad_Def.lives_of_bmv_monad + } end; + + val oAs' = let val x = separate_vars oAs outer_bmv in { frees = #frees x, deads = #deads x } end; + val Ass' = map2 (separate_vars o map SOME) Ass inner_bmvs; val ((bmv, unfold_set), 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; - + (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), (unfold_set, lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline + val ((mrbnf, tys), (unfold_set', lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline qualify (distinct (op=) o flat) 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 outer_axioms = MRSBNF_Def.axioms_of_mrsbnf outer; + val mrbnfs = mrbnf :: map_filter (fn mrsbnf => + let + val bmv' = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val leader = BMV_Monad_Def.leader_of_bmv_monad bmv'; + val mrbnf = nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) leader; + fun find_match 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 case find_match (MRBNF_Def.T_of_mrbnf mrbnf) of + [] => NONE | x::_ => SOME x + end + ) inners; + (* TODO: Carry over minion mrbnfs from inners *) - val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def fact_policy (qualify 0) NONE - (map_index (fn (i, x) => if i = leader then mrbnf else x) (MRSBNF_Def.mrbnfs_of_mrsbnf outer)) - bmv (map_index (fn (i, x) => if i <> leader then { + val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def fact_policy (qualify 0) NONE mrbnfs bmv + (map_index (fn (i, x) => if i <> 0 then { map_Sb = Option.map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#map_Sb x), map_is_Sb = fn ctxt => HEADGOAL (rtac ctxt (#map_is_Sb x) 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 x), @@ -69,7 +103,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A map_is_Sb = fn ctxt => EVERY1 [ K (print_tac ctxt "map_is_Sb") ], - set_Sb = replicate (MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf) (fn ctxt => EVERY1 [ + set_Sb = replicate (MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.live_of_mrbnf mrbnf) (fn ctxt => EVERY1 [ K (print_tac ctxt "set_Sb") ]), set_Vrs = replicate (length (BMV_Monad_Def.frees_of_bmv_monad bmv)) (fn ctxt => EVERY1 [ diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 5307fc36..5f60bb29 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -37,6 +37,7 @@ end structure MRSBNF_Def : MRSBNF_DEF = struct open MRBNF_Util +open BMV_Monad_Def type 'a mrsbnf_axioms = { map_is_Sb: 'a, @@ -136,7 +137,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = [("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, []), + ("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, []), ("map_Inj", maps (map_filter I o #map_Inj) facts, []), @@ -154,7 +155,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs bmv axioms' lthy = let val names = map (fst o dest_Free); - val facts' = @{map 7} (fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn Injs => fn RVrs => + val facts' = @{map 10} (fn lives => fn lives' => fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn Injs => fn RVrs => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -205,6 +206,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b in Goal.prove_sorry lthy (names (distinct (op=) (h_fs @ fs' @ hs @ gs))) (distinct (op=) (h_fs_prems @ f'_prems @ h_prems @ g_prems)) goal (fn {context=ctxt, prems} => EVERY1 [ EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], REPEAT_DETERM o resolve_tac ctxt prems, + K (Local_Defs.unfold0_tac ctxt (@{thms o_id} + @ the_default [] (Option.map (single o #Map_id o #axioms) bmv_params) + )), rtac ctxt sym, rtac ctxt trans, rtac ctxt (#Sb_comp bmv_axioms), @@ -217,29 +221,36 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt refl ]) end; - val Inj_aas = distinct (op=) (map (domain_type o fastype_of) Injs); - - val map_Inj = @{map 3} (fn Inj => fn f => fn a => if body_type (fastype_of Inj) <> T then NONE else - let val goal = mk_Trueprop_eq (Term.list_comb (mapx, fs) $ (Inj $ a), Inj $ (f $ a)) + 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, 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} @ prems), rtac ctxt @{thm comp_apply} ])) end - ) Injs (filter (member (op=) Inj_aas o domain_type o fastype_of) free_fs) (map (fn aT => the (List.find (curry (op=) aT o fastype_of) aa)) Inj_aas); + ) 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 Inj $ HOLogic.mk_comp (map_t, g), + 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 Inj) then NONE else + 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}, @@ -265,7 +276,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 Inj $ HOLogic.mk_comp (Term.list_comb (mapx, fs), g)), + 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 [ @@ -282,11 +293,12 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b map_Inj = map_Inj, Sb_comp_right = Sb_comp_right } end - ) axioms' mrbnfs (BMV_Monad_Def.axioms_of_bmv_monad bmv) (BMV_Monad_Def.facts_of_bmv_monad bmv) + ) (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); - val facts' = @{map 8} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_facts => fn Sb => fn RVrs => fn Injs => + val facts' = @{map 9} (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; @@ -314,13 +326,15 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 count = MRBNF_Def.live_of_mrbnf mrbnf + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; + val infinite_UNIV = @{thm cinfinite_imp_infinite} OF [MRBNF_Def.UNIV_cinfinite_of_mrbnf (hd mrbnfs)]; 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 Inj)) mrbnfs) + 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)), @@ -341,63 +355,133 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b (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 + MRBNF_Def.free_of_mrbnf mrbnf - length frees; + val count = live + MRBNF_Def.bound_of_mrbnf mrbnf + MRBNF_Def.free_of_mrbnf mrbnf - free; 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'); in Goal.prove_sorry lthy (names (fs @ hs @ gs)) (f_prems @ h_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ - if count = 0 then K all_tac else EVERY' [ + 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 _ _ "(\)"]}, + rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, + comp_tac + ] end, + rtac ctxt sym, + (*SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}),*) + EVERY' [ + rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt trans, - K (prefer_tac 2), - rtac ctxt (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 => [HOLogic.id_const (body_type (fastype_of f)), f]) live_fs) - ) (MRBNF_Def.map_comp0_of_mrbnf mrbnf)), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), - rtac ctxt refl, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - EqSubst.eqsubst_tac ctxt [0] [the (#map_Sb axioms)], + 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, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + 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 @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + resolve_tac ctxt (the_default [] (Option.map (single o #Map_Sb) bmv_params)), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} + @ prems + @ map_filter I (#SSupp_map_bound facts) + ), + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt trans, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} + ] ORELSE' rtac ctxt trans, + rtac ctxt (#Sb_comp bmv_axioms), + REPEAT_DETERM o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} + @ prems @ the_default [] (#SSupp_Map_bounds bmv_facts) + @ map_filter I (#SSupp_map_bound facts) + ) ], - EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], - REPEAT_DETERM o resolve_tac ctxt prems, + 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 _ _ "(\)"]}, + rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} + ], rtac ctxt (#Sb_comp bmv_axioms), - EVERY' [ - rtac ctxt refl, + REPEAT_DETERM o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' + ) + ], + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + rtac ctxt ext, + rtac ctxt (#Sb_cong bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} + @ prems @ maps (the_default [] o #SSupp_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) + ), + (* 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 - ] ORELSE' EVERY' [ - REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound} @ [infinite_UNIV] @ prems), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map (fn thm => thm RS sym) map_is_Sb), - REPEAT_DETERM o resolve_tac ctxt prems - ], - if count = 0 then K all_tac else rtac ctxt refl, - rtac ctxt sym, + ], + REPEAT_DETERM o 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 _ _ "(\)"]}, - rtac ctxt (#Sb_comp_right facts), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_inv_bound supp_comp_bound SSupp_comp_bound} - @ [infinite_UNIV] - @ maps (map_filter I o #SSupp_map_bound) facts' @ prems - ), - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - EqSubst.eqsubst_tac ctxt [0] [MRBNF_Def.map_comp0_of_mrbnf mrbnf RS sym], - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id supp_inv_bound bij_imp_bij_inv} @ prems), + resolve_tac ctxt (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] @{thms inv_o_simp1}, - resolve_tac ctxt prems + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), + resolve_tac ctxt ( + @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' + ) ], - K (Local_Defs.unfold0_tac ctxt (MRBNF_Def.map_id0_of_mrbnf mrbnf :: @{thms id_o o_id})), + 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, + TRY o 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, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms o_id id_o} + @ map MRBNF_Def.map_id0_of_mrbnf mrbnfs + )), rtac ctxt refl ] ]) end; @@ -408,7 +492,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b Sb_comp_right = #Sb_comp_right facts, map_Sb_strong = map_Sb_strong }: mrsbnf_facts end - ) axioms' facts' mrbnfs (BMV_Monad_Def.axioms_of_bmv_monad bmv) (BMV_Monad_Def.facts_of_bmv_monad bmv) + ) 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); @@ -428,8 +512,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b fun mk_mrsbnf_axioms mrbnfs bmv lthy = let - val leader = BMV_Monad_Def.leader_of_bmv_monad bmv; - val lmrbnf = nth mrbnfs leader; + val l = BMV_Monad_Def.leader_of_bmv_monad bmv; + val lmrbnf = nth mrbnfs l; val (((((Fs, Bs), As), As'), deads), names_lthy) = 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)) @@ -441,39 +525,19 @@ fun mk_mrsbnf_axioms mrbnfs bmv 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)); local - val (mapx, Sb) = case nth (BMV_Monad_Def.Maps_of_bmv_monad bmv) leader of - NONE => (MRBNF_Def.mk_map_of_mrbnf deads As As Bs Fs lmrbnf, nth (BMV_Monad_Def.Sbs_of_bmv_monad bmv) leader) - | SOME Map => (MRBNF_Def.mk_map_of_mrbnf deads As As' Bs Fs lmrbnf, Map) - - val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy) - ) [apply2 (snd o split_last o binder_types o fastype_of) (Sb, mapx), apply2 (body_type o fastype_of) (Sb, mapx)] Vartab.empty; - - val phi = Morphism.morphism "subst types" { - binding = [], fact = [], - typ = [K (Envir.subst_type tyenv)], - term = [K (Envir.subst_term (tyenv, Vartab.empty))] - } + 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') + @ (MRBNF_Def.deads_of_mrbnf lmrbnf ~~ deads) + val phi = MRBNF_Util.subst_typ_morphism subst; in + val mrbnfs = map (MRBNF_Def.morph_mrbnf phi) mrbnfs; val bmv = BMV_Monad_Def.morph_bmv_monad phi bmv; - - val mrbnfs = @{map 3} (fn mrbnf => fn Sb => fn Map => - let - val Sb = the_default Sb Map; - val mapx = MRBNF_Def.map_of_mrbnf mrbnf; - - val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy) - ) [apply2 (snd o split_last o binder_types o fastype_of) (mapx, Sb), apply2 (body_type o fastype_of) (mapx, Sb)] Vartab.empty; - - val phi = Morphism.morphism "subst types" { - binding = [], fact = [], - typ = [K (Envir.subst_type tyenv)], - term = [K (Envir.subst_term (tyenv, Vartab.empty))] - }; - in MRBNF_Def.morph_mrbnf phi mrbnf end - ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); end; - val axioms = @{map 6} (fn mrbnf => fn Sb => fn Injs => fn RVrs => fn Vrs => fn bmv_frees => + val axioms = @{map 7} (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; @@ -482,23 +546,35 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val (live_fs, bound_fs, free_fs') = MRBNF_Def.deinterlace fs var_types; - val frees = inter (op=) (take (length (BMV_Monad_Def.frees_of_bmv_monad bmv)) Fs) (MRBNF_Def.frees_of_mrbnf mrbnf); + 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 (fn f => HOLogic.mk_Trueprop (mk_supp_bound f)) free_fs; - val map_is_Sb = fold_rev Logic.all free_fs (fold_rev (curry Logic.mk_implies) free_prems (mk_Trueprop_eq ( - Term.list_comb (Term.subst_atomic_types (As' ~~ As) mapx, MRBNF_Def.interlace - (map HOLogic.id_const As) (map HOLogic.id_const Bs) (free_fs @ map HOLogic.id_const (drop (length frees) 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 @ map HOLogic.id_const (drop (length frees) Fs)) (MRBNF_Def.var_types_of_mrbnf mrbnf) ), - Term.list_comb (Sb, map (fn RVr => the (List.find (fn f => - HOLogic.dest_setT (body_type (fastype_of RVr)) = domain_type (fastype_of f) - ) fs)) RVrs @ map (fn Inj => - HOLogic.mk_comp (Inj, the (List.find (fn f => (op=) (apply2 (domain_type o fastype_of) (Inj, f))) fs)) - ) Injs) + 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 => the (List.find (fn f => + HOLogic.dest_setT (body_type (fastype_of RVr)) = domain_type (fastype_of f) + ) fs)) 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; @@ -530,7 +606,22 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = 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 @ h_prems @ g_prems) (mk_Trueprop_eq ( HOLogic.mk_comp (map_t, Sb_t), - HOLogic.mk_comp (Term.subst_atomic_types (As ~~ As') Sb_t, map_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; @@ -541,7 +632,14 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) (replicate free [] @ map single (drop free free_sets)) var_types); in map (fn set => fold_rev Logic.all (hs @ gs @ [x]) (fold_rev (curry Logic.mk_implies) (h_prems @ g_prems) ( - mk_Trueprop_eq (set $ (Term.list_comb (Sb, hs @ gs) $ x), set $ x) + 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 => @@ -562,8 +660,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = }: term mrsbnf_axioms end ) 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.frees_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 = @@ -584,6 +681,16 @@ fun mrsbnf_of_mrbnf mrbnf lthy = @ 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 + fun get_T T = (snd (split_last (binder_types T)), body_type T); + val T = get_T (fastype_of (the (hd (BMV_Monad_Def.Maps_of_bmv_monad bmv)))) + val mr_T = get_T (fastype_of (MRBNF_Def.map_of_mrbnf mrbnf)); + val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) + [(fst T, fst mr_T), (snd T, snd mr_T)] 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) I NONE [mrbnf] bmv [{ map_Sb = SOME (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), @@ -597,7 +704,16 @@ fun mrsbnf_of_mrbnf mrbnf lthy = rtac ctxt refl ] ]), - map_is_Sb = fn ctxt => resolve_tac ctxt [refl, MRBNF_Def.map_id0_of_mrbnf mrbnf] 1, + map_is_Sb = fn ctxt => EVERY1 [ + 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] + ], set_Sb = replicate n (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms id_apply}), rtac ctxt refl ORELSE' EVERY' [ @@ -610,22 +726,49 @@ fun mrsbnf_of_mrbnf mrbnf lthy = set_Vrs = replicate (MRBNF_Def.free_of_mrbnf mrbnf) (fn ctxt => rtac ctxt refl 1) }] lthy end; -fun mrsbnf_cmd (b, Ts) lthy = +fun mrsbnf_cmd b_Ts lthy = let - val Ts = map (Syntax.read_typ lthy) Ts; + 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; - val (mrbnfs, lthy) = fold_map (fn T => fn lthy => case T of - TFree _ => error "Illegal free variable" - | TVar _ => error "Illegal schematic variable" - | Type (name, _) => case MRBNF_Def.mrbnf_of lthy name of + 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 [] = error ("Type " ^ name ^ " is not a (MR)BNF") + | 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 => 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; + in case MRBNF_Def.mrbnf_of lthy name of SOME mrbnf => (mrbnf, lthy) | NONE => case BNF_Def.bnf_of lthy name of SOME bnf => MRBNF_Def.mrbnf_of_bnf bnf lthy - | NONE => error ("Type " ^ name ^ " is not a (MR)BNF") - ) Ts lthy; + | NONE => (find_mrbnf ancestors, 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 => error ("Type " ^ name ^ " is not a PBMV Monad") + | 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; @@ -662,6 +805,6 @@ fun mrsbnf_cmd (b, Ts) lthy = val _ = Outer_Syntax.local_theory_to_proof @{command_keyword mrsbnf} "register a map-restricted substitutive bounded natural functor" - ((parse_opt_binding_colon -- Parse.and_list1 Parse.typ) >> mrsbnf_cmd) + ((Parse.and_list1 (parse_opt_binding_colon -- Parse.typ)) >> mrsbnf_cmd) end \ No newline at end of file diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index beb53b9d..e3847b13 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -12,7 +12,7 @@ typedecl ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1 typedecl ('a, 'b, 'c, 'd) T2 (* free, free, free, live, dead, live *) typedecl ('a, 'b, 'c, 'd, 'e, 'f) T3 -(* free, live *) +(* free, free *) typedecl ('a, 'b) T4 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" diff --git a/operations/MRSBNF_Composition.thy b/operations/MRSBNF_Composition.thy new file mode 100644 index 00000000..2bc3b6ea --- /dev/null +++ b/operations/MRSBNF_Composition.thy @@ -0,0 +1,86 @@ +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 :: "('b => 'b) => ('d \ 'd) \ ('a, 'b, 'c, 'd) T2 \ ('a, 'b, 'c, 'd) T2" + +consts map_T3 :: "('a \ 'a) \ ('b \ 'b) \ ('c \ 'c) \ ('d \ 'd') \ ('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" + +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: + 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 + live: set_2_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, Dead_Var, Free_Var, Free_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 +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 + +end \ No newline at end of file diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index 4badb859..5886d146 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -62,8 +62,6 @@ binder_datatype ('v, 'tv, 'ev, 'rv) expr = | Let x::'v "('v, 'tv, 'ev, 'rv) expr" e::"('v, 'tv, 'ev, 'rv) expr" binds x in e | RApp "('v, 'tv, 'ev, 'rv) expr" "'rv list" "('v, 'tv, 'ev, 'rv) expr" -print_locale REC_expr - (* #86 *) binder_datatype 'a "term" = Var 'a From 73c499fc5a63d32cda7a112cea6b5af28eefaca4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Wed, 18 Jun 2025 15:29:23 +0100 Subject: [PATCH 37/90] Prove MRSBNF composition for complex example --- Tools/bmv_monad_def.ML | 31 +++++--- Tools/mrsbnf_def.ML | 64 +++++++++++----- operations/BMV_Composition.thy | 2 +- operations/MRSBNF_Composition.thy | 117 ++++++++++++++++++++++++++++++ 4 files changed, 184 insertions(+), 30 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 3316820b..fee1b5f5 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -78,6 +78,7 @@ signature BMV_MONAD_DEF = sig 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 leader: (bmv_monad -> 'a list) -> bmv_monad -> 'a; @@ -246,12 +247,13 @@ datatype bmv_monad = BMV of { params: thm bmv_monad_param option list, bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list, - facts: bmv_monad_facts list + facts: bmv_monad_facts list, + unfolds: 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 + facts, unfolds }) = BMV { ops = map (Morphism.typ phi) ops, leader = leader, @@ -264,7 +266,8 @@ fun morph_bmv_monad phi (BMV { 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 + bd_infinite_regular_card_order = Morphism.thm phi bd_infinite_regular_card_order, + unfolds = map (Morphism.thm phi) unfolds } fun Rep_bmv (BMV x) = x @@ -288,6 +291,7 @@ 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 fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) @@ -757,7 +761,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv 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) lthy = +fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_monad_model) unfolds lthy = let val consts = { bd = #bd (#consts model), @@ -927,7 +931,8 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 + bd_infinite_regular_card_order = #bd_infinite_regular_card_order model, + unfolds = unfolds } : bmv_monad; val (_, lthy) = note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy; @@ -1003,7 +1008,7 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont )) (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 lthy) end + in apfst (rpair unfold_set) (mk_bmv_monad const_policy fact_policy qualify bmv_b_opt model unfold_set lthy) end fun pbmv_monad_of_mrbnf mrbnf lthy = let @@ -1165,7 +1170,8 @@ fun slice_bmv_monad n 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)] + facts = [f (facts_of_bmv_monad bmv)], + unfolds = unfolds_of_bmv_monad bmv } end; fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives, frees=dfrees } lthy = @@ -2007,6 +2013,13 @@ fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = 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; @@ -2074,7 +2087,7 @@ fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = val param_goals = @{map 5} (fn Sb => fn Injs => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => mk_param_axiom Map Supps Sb Injs RVrs Vrs bd (map_filter I (#params consts @ maps (#params o consts_of_bmv_monad) bmv_ops)) lthy - )) Sbs Injs RVrs Vrs (#params consts); + )) (#Sbs consts) (#Injs consts) (#RVrs consts) (#Vrs consts) (#params consts); val goals = mk_bmv_monad_axioms ops consts bmv_ops lthy; @@ -2143,7 +2156,7 @@ fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = 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 lthy; + val (bmv, lthy) = mk_bmv_monad BNF_Def.Smart_Inline (K BNF_Def.Note_Some) I (SOME (Binding.name b)) model bmv_defs lthy; val lthy = register_pbmv_monad b bmv lthy; in lthy end; diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 5f60bb29..30b5d42d 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -13,7 +13,8 @@ signature MRSBNF_DEF = sig SSupp_map_bound: thm option list, map_Inj: thm option list, Sb_comp_right: thm, - map_Sb_strong: thm + map_Sb_strong: thm, + Map_map: thm option }; val bmv_monad_of_mrsbnf: mrsbnf -> BMV_Monad_Def.bmv_monad @@ -71,17 +72,19 @@ type mrsbnf_facts = { SSupp_map_bound: thm option list, map_Inj: thm option list, Sb_comp_right: thm, - map_Sb_strong: thm + map_Sb_strong: thm, + Map_map: thm option } fun morph_mrsbnf_facts phi ({ - SSupp_map_subset, SSupp_map_bound, map_Inj, Sb_comp_right, map_Sb_strong + SSupp_map_subset, SSupp_map_bound, map_Inj, Sb_comp_right, map_Sb_strong, Map_map }: 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, map_Inj = map (Option.map (Morphism.thm phi)) map_Inj, Sb_comp_right = Morphism.thm phi Sb_comp_right, - map_Sb_strong = Morphism.thm phi map_Sb_strong + map_Sb_strong = Morphism.thm phi map_Sb_strong, + Map_map = Option.map (Morphism.thm phi) Map_map }: mrsbnf_facts datatype mrsbnf = MRSBNF of { @@ -142,7 +145,8 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("SSupp_map_bound", maps (map_filter I o #SSupp_map_bound) facts, []), ("map_Inj", maps (map_filter I o #map_Inj) facts, []), ("Sb_comp_right", map #Sb_comp_right facts, []), - ("map_Sb_strong", map #map_Sb_strong facts, []) + ("map_Sb_strong", map #map_Sb_strong facts, []), + ("Map_map", map_filter #Map_map facts, []) ] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((qualify (Binding.qualify true (short_type_name (name ())) (Binding.name thmN)), attrs), [(thms, [])])); @@ -155,7 +159,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs bmv axioms' lthy = let val names = map (fst o dest_Free); - val facts' = @{map 10} (fn lives => fn lives' => fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn Injs => fn RVrs => + val facts' = @{map 11} (fn lives => fn lives' => fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn Injs => fn RVrs => fn Map_opt => let val mapx = MRBNF_Def.map_of_mrbnf mrbnf; val var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; @@ -287,16 +291,31 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b REPEAT_DETERM o resolve_tac ctxt prems ]) end )) Injs gs g_prems SSupp_map_subset; - in { - SSupp_map_subset = SSupp_map_subset, - SSupp_map_bound = SSupp_map_bound, - map_Inj = map_Inj, - Sb_comp_right = Sb_comp_right - } end + + 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} @ [#Sb_Inj bmv_axioms])), + rtac ctxt refl + ]) end + ) Map_opt; + in { + SSupp_map_subset = SSupp_map_subset, + SSupp_map_bound = SSupp_map_bound, + map_Inj = map_Inj, + Sb_comp_right = Sb_comp_right, + Map_map = Map_map + } 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.RVrs_of_bmv_monad bmv) (BMV_Monad_Def.Maps_of_bmv_monad bmv); val facts' = @{map 9} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn RVrs => fn Injs => let @@ -386,7 +405,6 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b comp_tac ] end, rtac ctxt sym, - (*SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}),*) EVERY' [ rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt trans, @@ -401,7 +419,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b resolve_tac ctxt (the_default [] (Option.map (single o #Map_Sb) bmv_params)), REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} @ prems - @ map_filter I (#SSupp_map_bound facts) + @ maps (map_filter I o #SSupp_map_bound) facts' ), rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt trans, @@ -414,8 +432,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), resolve_tac ctxt ( @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} - @ prems @ the_default [] (#SSupp_Map_bounds bmv_facts) - @ map_filter I (#SSupp_map_bound facts) + @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) + @ maps (map_filter I o #SSupp_map_bound) facts' ) ], rtac ctxt sym, @@ -479,6 +497,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [ + MRBNF_Def.map_id0_of_mrbnf (nth mrbnfs (BMV_Monad_Def.leader_of_bmv_monad bmv)) + ]), SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms o_id id_o} @ map MRBNF_Def.map_id0_of_mrbnf mrbnfs )), @@ -490,7 +511,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b SSupp_map_bound = #SSupp_map_bound facts, map_Inj = #map_Inj facts, Sb_comp_right = #Sb_comp_right facts, - map_Sb_strong = map_Sb_strong + map_Sb_strong = map_Sb_strong, + Map_map = #Map_map facts }: mrsbnf_facts end ) 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) @@ -514,12 +536,14 @@ 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), As'), deads), names_lthy) = 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 (MRBNF_Def.live_of_mrbnf lmrbnf) - ||>> mk_TFrees' (map Type.sort_of_atyp (MRBNF_Def.deads_of_mrbnf lmrbnf)); + ||>> mk_TFrees' (map Type.sort_of_atyp ldeads); 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)); @@ -530,7 +554,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = @ (MRBNF_Def.bounds_of_mrbnf lmrbnf ~~ Bs) @ (MRBNF_Def.lives_of_mrbnf lmrbnf ~~ As) @ (MRBNF_Def.lives'_of_mrbnf lmrbnf ~~ As') - @ (MRBNF_Def.deads_of_mrbnf lmrbnf ~~ deads) + @ (ldeads ~~ deads) val phi = MRBNF_Util.subst_typ_morphism subst; in val mrbnfs = map (MRBNF_Def.morph_mrbnf phi) mrbnfs; diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index e3847b13..2eba7ffb 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -216,6 +216,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (rule T3.Sb_cong; assumption) done print_theorems +print_pbmv_monads (* Same demotion, but automated *) local_setup \fn lthy => @@ -569,5 +570,4 @@ let in lthy end \ - end \ No newline at end of file diff --git a/operations/MRSBNF_Composition.thy b/operations/MRSBNF_Composition.thy index 2bc3b6ea..2c76fb7d 100644 --- a/operations/MRSBNF_Composition.thy +++ b/operations/MRSBNF_Composition.thy @@ -14,6 +14,7 @@ consts rel_T3 :: "('d \ 'd' \ bool) \ ('f \< 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: @@ -83,4 +84,120 @@ 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 ((mrbnf, tys), (_, lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Do_Inline (Binding.prefix_name o string_of_int) (distinct (op=) o flat) + (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 'a}, @{typ 'e}], + [@{typ 'g}], + [@{typ 'a}, @{typ 'e}] + ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g"}] [ + [@{typ 'b}, @{typ 'd}], + [], + [@{typ 'b}, @{typ 'c}, @{typ 'd}, @{typ 'h}] + ] [] ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy) + + val lthy = MRBNF_Def.register_mrbnf_raw "MRSBNF_Composition.T" mrbnf lthy; +in lthy end +\ + +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 (tactic \Local_Defs.unfold0_tac @{context} (BMV_Monad_Def.unfolds_of_bmv_monad (the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Composition.T")))\)[5] + + 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) + + + 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 + + + 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 (unfold T2.map_id0 id_o o_id)[1] + apply (rule refl)+ + apply (rule T3'.map_Sb[THEN fun_cong]) + apply assumption+ + apply (rule refl) + + + subgoal + apply (subst T1.set_map, (rule supp_id_bound)+)+ + apply (unfold UN_empty2 Un_empty_left Un_empty_right) + apply (subst T.Supp_Sb) + apply assumption+ + apply (rule refl) + done + + apply (rule T2.map_is_Sb; assumption) + apply (rule T3'.map_is_Sb; assumption) + apply (rule T3'.set_Vrs) + apply (rule T3'.map_Sb; assumption) + apply (rule T3'.set_Sb; assumption) + apply (rule T3'.map_is_Sb; assumption) + done +print_theorems + end \ No newline at end of file From b422ebdd9b02e3717ef9974c0b0854671af1ebb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 22 Jun 2025 13:27:10 +0100 Subject: [PATCH 38/90] Make sure MRSBNF composition can handle bound positions --- Tools/bmv_monad_def.ML | 42 ++-- Tools/mrbnf_comp.ML | 3 - Tools/mrbnf_comp_tactics.ML | 4 +- Tools/mrsbnf_comp.ML | 313 ++++++++++++++++++++++++------ Tools/mrsbnf_def.ML | 272 +++++++++++++++++++------- operations/BMV_Composition.thy | 12 +- operations/MRSBNF_Composition.thy | 183 ++++++++++++----- thys/MRBNF_FP.thy | 20 ++ 8 files changed, 644 insertions(+), 205 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index fee1b5f5..d99a0370 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1629,7 +1629,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit distinct ((op=) o apply2 (leader ops_of_bmv_monad)) (outer :: inners') ) ); - val new_minions = map_filter (AList.lookup (op=) new_minions o body_type o fastype_of) new_Injs; + 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 T = leader ops_of_bmv_monad outer; @@ -1661,23 +1661,29 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt refl ], Map_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ [#Map_comp (#axioms param)] @ + 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' - )), - rtac ctxt refl + )) ], Supp_Map = map (fn _ => fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt (@{thms image_comp[unfolded comp_def] image_UN} - @ #Supp_Map (#axioms param) @ - flat (map_filter (Option.map (#Supp_Map o #axioms) o leader params_of_bmv_monad) inners') - )), - rtac ctxt refl + K (Local_Defs.unfold0_tac ctxt @{thms image_Un image_UN}), + REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Supp_Map (#axioms param)), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms image_comp[unfolded comp_def] image_Un image_UN}), + rtac ctxt @{thm UN_cong}, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms image_UN[symmetric]}), + resolve_tac ctxt (flat (map_filter (Option.map (#Supp_Map o #axioms) o leader params_of_bmv_monad) inners')) + ] ]) Supps, Supp_bd = map (fn _ => fn ctxt => REPEAT_DETERM (resolve_tac ctxt ( - @{thms infinite_regular_card_order_UN infinite_regular_card_order_Un} - @ [bd_infinite_regular_card_order_of_bmv_monad outer] + flat (map_filter (Option.map (#Supp_bd o #axioms) o leader params_of_bmv_monad) inners') @ #Supp_bd (#axioms param) - @ flat (map_filter (Option.map (#Supp_bd o #axioms) o leader params_of_bmv_monad) inners') + @ @{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)), @@ -1687,7 +1693,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt (#Map_cong (#axioms param)), REPEAT_DETERM o EVERY' [ resolve_tac ctxt prems, - etac ctxt @{thm UN_I}, + etac ctxt @{thm UN_I} ORELSE' REPEAT_DETERM o FIRST' [ + rtac ctxt @{thm UnI2} THEN' etac ctxt @{thm UN_I}, + rtac ctxt @{thm UnI1} THEN' etac ctxt @{thm UN_I}, + rtac ctxt @{thm UnI1} + ], assume_tac ctxt ] ] @@ -1728,10 +1738,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit @ #Supp_Map (#axioms param) @ #Vrs_Map param @ flat (#Supp_Injss facts) )), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (flat (map_filter (Option.map #Supp_Sb o leader params_of_bmv_monad) inners')), + 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' rtac ctxt @{thm SSupp_Inj_bound}) ], - K (Local_Defs.unfold0_tac ctxt @{thms image_Un Union_UN_swap image_UN UN_empty2 Un_empty_left Un_empty_right UN_UN_flatten UN_Un_distrib Un_assoc[symmetric]}), + 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}), @@ -1845,7 +1855,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) (outer :: inners')) )), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps (#Vrs_Sbs o leader axioms_of_bmv_monad) inners' + 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' rtac ctxt @{thm SSupp_Inj_bound}) diff --git a/Tools/mrbnf_comp.ML b/Tools/mrbnf_comp.ML index e0c5d83e..3899728a 100644 --- a/Tools/mrbnf_comp.ML +++ b/Tools/mrbnf_comp.ML @@ -978,9 +978,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); diff --git a/Tools/mrbnf_comp_tactics.ML b/Tools/mrbnf_comp_tactics.ML index 123d50ba..53818bb4 100644 --- a/Tools/mrbnf_comp_tactics.ML +++ b/Tools/mrbnf_comp_tactics.ML @@ -399,12 +399,12 @@ fun mr_mk_comp_wit_tac ctxt set'_eq_sets outer inners = unfold_thms_tac ctxt set'_eq_sets THEN unfold_thms_tac ctxt @{thms collect_def UN_insert Union_image_empty} THEN unfold_thms_tac ctxt set_maps THEN - unfold_thms_tac ctxt @{thms Union_Un_distrib id_def} THEN + unfold_thms_tac ctxt @{thms Union_Un_distrib} THEN REPEAT_DETERM ( 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/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 5e388c63..4ab785e6 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -3,14 +3,14 @@ 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 - -> (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory - -> MRSBNF_Def.mrsbnf * ((MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory) + -> (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 - -> typ -> ((MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory) + -> typ -> ((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)) - * ((MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set) * local_theory) + * ((thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) end @@ -30,36 +30,41 @@ fun mrsbnf_of lthy s = case MRSBNF_Def.mrsbnf_of lthy s of fun is_Inl (Inl _) = true | is_Inl _ = false -fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs Ass Xs (accum, lthy) = +fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs Ass Xs ((old_bmv_unfold, accum), lthy) = let val outer_bmv = MRSBNF_Def.bmv_monad_of_mrsbnf outer; - val inner_bmvs = map MRSBNF_Def.bmv_monad_of_mrsbnf inners; + val outer_mrbnf = nth (MRSBNF_Def.mrbnfs_of_mrsbnf outer) (BMV_Monad_Def.leader_of_bmv_monad outer_bmv); fun leader f bmv = nth (f bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv); - fun separate_vars vars bmv = + fun separate_vars vars Ds mrsbnf = let - val Ts = (case leader BMV_Monad_Def.ops_of_bmv_monad bmv of - Type (_, Ts) => Ts - | T => [T] + 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 (bounds, vars) = apply2 (map fst) (partition (fn (NONE, _) => false + | (SOME _, t) => t = MRBNF_Def.Bound_Var + ) (vars ~~ MRBNF_Def.var_types_of_mrbnf mrbnf)); + val Ts = (filter_out (member (op=) (leader BMV_Monad_Def.deads_of_bmv_monad bmv)) + (map TVar (rev (Term.add_tvarsT (leader BMV_Monad_Def.ops_of_bmv_monad bmv) []))) ) ~~ vars; fun lookup f = map_filter (Option.join o AList.lookup (op=) Ts) (leader f bmv); in { frees = lookup BMV_Monad_Def.frees_of_bmv_monad, - deads = lookup BMV_Monad_Def.deads_of_bmv_monad, + deads = map (resort_tfree_or_tvar @{sort var}) (map_filter I bounds) @ Ds, lives = lookup BMV_Monad_Def.lives_of_bmv_monad } end; - val oAs' = let val x = separate_vars oAs outer_bmv in { frees = #frees x, deads = #deads x } end; - val Ass' = map2 (separate_vars o map SOME) Ass inner_bmvs; + 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, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad (qualify 0) (MRSBNF_Def.bmv_monad_of_mrsbnf outer) + 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), (unfold_set', lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline + val ((mrbnf, tys), (mrbnf_unfolds, lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline qualify (distinct (op=) o flat) outer_mrbnf inner_mrbnfs oDs Dss oAs Ass Xs (accum, lthy); val mrbnf = @@ -68,14 +73,11 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 outer_axioms = MRSBNF_Def.axioms_of_mrsbnf outer; - val mrbnfs = mrbnf :: map_filter (fn mrsbnf => + val (mrbnfs, axioms') = split_list ((mrbnf, NONE) :: maps (fn mrsbnf => let - val bmv' = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; - val leader = BMV_Monad_Def.leader_of_bmv_monad bmv'; - val mrbnf = nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) leader; - fun find_match T = case T of + 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) @@ -83,53 +85,245 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A ) (try (Sign.typ_match (Proof_Context.theory_of lthy) (T, T')) Vartab.empty)) (BMV_Monad_Def.ops_of_bmv_monad bmv) | _ => [] - in case find_match (MRBNF_Def.T_of_mrbnf mrbnf) of - [] => NONE | x::_ => SOME x - end - ) inners; + 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 = 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 + ); - (* TODO: Carry over minion mrbnfs from inners *) val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def fact_policy (qualify 0) NONE mrbnfs bmv - (map_index (fn (i, x) => if i <> 0 then { - map_Sb = Option.map (fn thm => fn ctxt => HEADGOAL (rtac ctxt thm THEN_ALL_NEW assume_tac ctxt)) (#map_Sb x), - map_is_Sb = fn ctxt => HEADGOAL (rtac ctxt (#map_is_Sb x) 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 x), - set_Vrs = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Vrs x) - } else { - map_Sb = if MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf > length (BMV_Monad_Def.frees_of_bmv_monad bmv) then + (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 (print_tac ctxt "map_Sb") + 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 (print_tac ctxt "map_is_Sb") + 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 (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 (print_tac ctxt "set_Sb") + 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 (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 #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.frees_of_bmv_monad bmv)) (fn ctxt => EVERY1 [ - K (print_tac ctxt "set_Vrs") + 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)))), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf outer_mrbnf), + REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} + ], + K (Local_Defs.unfold_tac ctxt ( + @{thms UN_empty2 Un_empty_right Un_empty_left image_id Un_assoc[symmetric] Un_Union_image} + @ no_reflexive (flat (maps (map #set_Vrs o MRSBNF_Def.axioms_of_mrsbnf) inners)) + )), + rtac ctxt refl ]) - }) outer_axioms) lthy; - - val _ = @{print} mrbnf - in error "foo" end + }) axioms') lthy; + in ((mrsbnf, tys), ((old_bmv_unfold @ bmv_unfolds, mrbnf_unfolds), lthy)) end -fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = - (if member (op =) Ds0 T' then ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), accum) else +fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(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) + [] => ((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 accum - in ((Inr ID', ([], [T])), accum') end + 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 (T as Type (n, Ts)) (accum, lthy) = (case mrsbnf_of lthy n of - NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), (accum, lthy)) + | mrsbnf_of_typ optim const_policy qualify' Ds0 var_types (T as Type (n, Ts)) ((bmv_unfolds:thm list, accum), lthy) = (case mrsbnf_of lthy n of + NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), ((bmv_unfolds, accum), lthy)) | SOME (outer, lthy) => if optim andalso forall is_TFree Ts then let @@ -145,6 +339,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = 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 _ = @{print} T val _ = @{print} 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 @@ -152,10 +347,10 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = ) 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, (accum, lthy)) + (outer, ((bmv_unfolds, accum), lthy)) else case outer of Inl mrsbnf => error "TODO: Demote MRSBNF" - | Inr mrbnf => apfst Inr (MRBNF_Comp.demote_mrbnf qualify' var_types mrbnf (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')), accum) end else let @@ -184,10 +379,10 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = ) oAs) val Ts' = map (nth Ts) (subtract (op =) (oDs_pos @ ofree_bound_pos) (0 upto length Ts - 1)); - val ((inners, (Dss, Ass)), (accum, lthy)) = + val ((inners, (Dss, Ass)), ((bmv_unfolds:thm list, 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) - (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' (accum, lthy)); + (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' ((bmv_unfolds, accum), lthy)); val _ = @{print} T val _ = @{print} Ts' @@ -202,15 +397,13 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') accum = val (inners', lthy) = fold_map (fn Inl mrsbnf => pair mrsbnf | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf ) inners lthy; - (*val _ = @{print} (outer' :: inners')*) - val (mrsbnf, accum) = compose_mrsbnfs BNF_Def.Smart_Inline const_policy qualify outer' inners' - oDs Dss oAs Ass Xs' (accum, lthy); - val _ = @{print} mrsbnf - in error "bar" end + val ((mrsbnf, tys), accum) = compose_mrsbnfs BNF_Def.Smart_Inline const_policy qualify outer' inners' + oDs Dss oAs Ass Xs' ((bmv_unfolds, accum), lthy); + in ((Inl mrsbnf, tys), accum) end else - apfst (apfst Inr) (MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline qualify (distinct (op=) o flat) + apsnd (apfst (pair 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 ); diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 30b5d42d..c5ff862a 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -5,6 +5,7 @@ signature MRSBNF_DEF = sig map_is_Sb: 'a, set_Vrs: 'a list, map_Sb: 'a option, + map_Injs: 'a list option, set_Sb: 'a list }; @@ -14,7 +15,8 @@ signature MRSBNF_DEF = sig map_Inj: thm option list, Sb_comp_right: thm, map_Sb_strong: thm, - Map_map: thm option + Map_map: thm option, + set_Injs: thm list list }; val bmv_monad_of_mrsbnf: mrsbnf -> BMV_Monad_Def.bmv_monad @@ -44,25 +46,28 @@ 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 }: 'a mrsbnf_axioms) = { +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_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_is_Sb, map_Sb, set_Sb, set_Vrs, map_Injs }: 'a mrsbnf_axioms) = { 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 @@ -73,18 +78,20 @@ type mrsbnf_facts = { map_Inj: thm option list, Sb_comp_right: thm, map_Sb_strong: thm, - Map_map: thm option + Map_map: thm option, + set_Injs: thm list list } fun morph_mrsbnf_facts phi ({ - SSupp_map_subset, SSupp_map_bound, map_Inj, Sb_comp_right, map_Sb_strong, Map_map + SSupp_map_subset, SSupp_map_bound, map_Inj, Sb_comp_right, map_Sb_strong, Map_map, set_Injs }: 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, map_Inj = map (Option.map (Morphism.thm phi)) map_Inj, Sb_comp_right = Morphism.thm phi Sb_comp_right, map_Sb_strong = Morphism.thm phi map_Sb_strong, - Map_map = Option.map (Morphism.thm phi) Map_map + Map_map = Option.map (Morphism.thm phi) Map_map, + set_Injs = map (map (Morphism.thm phi)) set_Injs }: mrsbnf_facts datatype mrsbnf = MRSBNF of { @@ -146,7 +153,8 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("map_Inj", maps (map_filter I o #map_Inj) facts, []), ("Sb_comp_right", map #Sb_comp_right facts, []), ("map_Sb_strong", map #map_Sb_strong facts, []), - ("Map_map", map_filter #Map_map 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), [(thms, [])])); @@ -158,6 +166,11 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = 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 11} (fn lives => fn lives' => fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn Injs => fn RVrs => fn Map_opt => let @@ -213,14 +226,16 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b K (Local_Defs.unfold0_tac ctxt (@{thms o_id} @ the_default [] (Option.map (single o #Map_id o #axioms) bmv_params) )), - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt (#Sb_comp bmv_axioms), - REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound infinite_class.infinite_UNIV} @ prems), - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), - REPEAT_DETERM o resolve_tac ctxt prems + TRY o EVERY' [ + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt (#Sb_comp bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound infinite_class.infinite_UNIV} @ prems), + K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), + REPEAT_DETERM o resolve_tac ctxt prems + ] ], rtac ctxt refl ]) end; @@ -230,8 +245,31 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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) (live_fs @ map mk_id 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), + rtac ctxt trans, + resolve_tac ctxt 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' [ @@ -301,16 +339,64 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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} @ [#Sb_Inj bmv_axioms])), + K (Local_Defs.unfold0_tac ctxt (@{thms id_o o_id} @ no_reflexive [#Sb_Inj bmv_axioms])), rtac ctxt refl ]) end ) Map_opt; + + 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, map_Inj = map_Inj, Sb_comp_right = Sb_comp_right, - Map_map = Map_map + 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) @@ -345,14 +431,10 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 count = MRBNF_Def.live_of_mrbnf mrbnf + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; - - val infinite_UNIV = @{thm cinfinite_imp_infinite} OF [MRBNF_Def.UNIV_cinfinite_of_mrbnf (hd mrbnfs)]; - val map_Sb_strong = let val map_t = Term.list_comb (mapx, fs); - val mrbnfs = map (fn Inj => + 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 ( @@ -367,7 +449,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ), g), mk_inv (the (find_f (domain_type (fastype_of g)))) ) end - ) gs mrbnfs), map_t) + ) gs mrbnfs'), map_t) ); val f_prems = flat (MRBNF_Def.interlace (replicate live []) @@ -379,6 +461,9 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b (op=) o HOLogic.dest_eq o HOLogic.dest_Trueprop o snd o Logic.strip_horn o Thm.prop_of ) (map #map_is_Sb axioms'); in Goal.prove_sorry lthy (names (fs @ hs @ gs)) (f_prems @ h_prems @ g_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' [ @@ -406,25 +491,30 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ] end, rtac ctxt sym, EVERY' [ - rtac ctxt @{thm trans[OF comp_assoc]}, 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, - 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 @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, - resolve_tac ctxt (the_default [] (Option.map (single o #Map_Sb) bmv_params)), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} - @ prems - @ maps (map_filter I o #SSupp_map_bound) facts' - ), + 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)), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} + @ prems + @ maps (map_filter I o #SSupp_map_bound) facts' + ), + rtac ctxt @{thm comp_assoc} + ], rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt trans, - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, - rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} ] ORELSE' rtac ctxt trans, rtac ctxt (#Sb_comp bmv_axioms), @@ -441,8 +531,10 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b TRY o EVERY' [ rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, - 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 EVERY' [ @@ -453,7 +545,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b @ maps (map_filter I o #SSupp_map_bound) facts' ) ], - TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, + 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), @@ -471,7 +563,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms o_id}), rtac ctxt refl ], - REPEAT_DETERM o EVERY' [ + 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, @@ -493,18 +585,25 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b rtac ctxt @{thm o_id}, rtac ctxt sym, rtac ctxt trans, - TRY o 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), + 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, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt [ - MRBNF_Def.map_id0_of_mrbnf (nth mrbnfs (BMV_Monad_Def.leader_of_bmv_monad bmv)) - ]), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms o_id id_o} - @ map MRBNF_Def.map_id0_of_mrbnf mrbnfs - )), - rtac ctxt refl - ] + 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, @@ -512,7 +611,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b map_Inj = #map_Inj facts, Sb_comp_right = #Sb_comp_right facts, map_Sb_strong = map_Sb_strong, - Map_map = #Map_map facts + Map_map = #Map_map facts, + set_Injs = #set_Injs facts }: mrsbnf_facts end ) 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) @@ -676,8 +776,20 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = | _ => foldl1 mk_Un Vrs' )) end ) (take free 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 @@ -708,11 +820,12 @@ fun mrsbnf_of_mrbnf mrbnf lthy = val bmv = let - fun get_T T = (snd (split_last (binder_types T)), body_type T); - val T = get_T (fastype_of (the (hd (BMV_Monad_Def.Maps_of_bmv_monad bmv)))) - val mr_T = get_T (fastype_of (MRBNF_Def.map_of_mrbnf mrbnf)); val tyenv = fold (Sign.typ_match (Proof_Context.theory_of lthy)) - [(fst T, fst mr_T), (snd T, snd mr_T)] Vartab.empty; + ((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) I NONE [mrbnf] bmv [{ @@ -733,11 +846,12 @@ fun mrsbnf_of_mrbnf mrbnf lthy = 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}) + 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}), rtac ctxt refl ORELSE' EVERY' [ @@ -762,19 +876,21 @@ fun mrsbnf_cmd b_Ts lthy = | 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 [] = error ("Type " ^ name ^ " is not a (MR)BNF") + 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 => mrbnf) + | 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; - in case MRBNF_Def.mrbnf_of lthy name of - SOME mrbnf => (mrbnf, lthy) - | NONE => case BNF_Def.bnf_of lthy name of - SOME bnf => MRBNF_Def.mrbnf_of_bnf bnf lthy - | NONE => (find_mrbnf ancestors, lthy) - end + 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 @@ -800,19 +916,21 @@ fun mrsbnf_cmd b_Ts lthy = let val thms = map hd thmss; - fun chop_opt NONE thms = (NONE, thms) - | chop_opt (SOME _) thms = (SOME (hd thms), tl thms) + 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, set_Vrs), map_Sb), set_Sb), thms) = 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_opt (#map_Sb goals) ||>> chop (length (#set_Sb goals)); in ({ map_is_Sb = map_is_Sb, - set_Vrs = set_Vrs, map_Sb = map_Sb, + map_Injs = map_Injs, + set_Vrs = set_Vrs, set_Sb = set_Sb }: thm mrsbnf_axioms, thms) end ) goals thms); @@ -822,8 +940,14 @@ fun mrsbnf_cmd b_Ts lthy = in lthy end in Proof.theorem NONE after_qed (map (single o rpair []) (maps (fn goals => - #map_is_Sb goals :: #set_Vrs goals @ the_default [] (Option.map single (#map_Sb goals)) @ #set_Sb 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 diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index 2eba7ffb..1b02b030 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -26,10 +26,10 @@ consts Vrs_3_T1 :: "('a, 'b::var, 'c::var, 'd, 'e, 'f, 'g::var) T1 \ 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" -consts Sb_T2 :: "('d::var \ 'd) \ ('b::var \ ('a, 'b, 'c, 'd) T2) \ ('a, 'b, 'c, 'd) T2 \ ('a, 'b, 'c, 'd) T2" -consts Vrs_1_T2 :: "('a, 'b::var, 'c, 'd::var) T2 \ 'd set" -consts Vrs_2_T2 :: "('a, 'b::var, 'c, 'd::var) T2 \ 'b set" -consts Inj_T2 :: "'b \ ('a, 'b::var, 'c, 'd::var) T2" +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" @@ -65,7 +65,7 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" done print_theorems -pbmv_monad "('a, 'b, 'c, 'd) T2" +pbmv_monad "('a::var, 'b, 'c, 'd) T2" Sbs: Sb_T2 RVrs: Vrs_1_T2 Injs: Inj_T2 @@ -563,7 +563,7 @@ 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}, @{typ 'e}] }, + [ 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 diff --git a/operations/MRSBNF_Composition.thy b/operations/MRSBNF_Composition.thy index 2c76fb7d..19ec48ba 100644 --- a/operations/MRSBNF_Composition.thy +++ b/operations/MRSBNF_Composition.thy @@ -6,7 +6,8 @@ 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 :: "('b => 'b) => ('d \ 'd) \ ('a, 'b, 'c, 'd) T2 \ ('a, 'b, 'c, 'd) T2" +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') \ ('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" @@ -32,6 +33,7 @@ rel: rel_T1 mrbnf "('a, 'b, 'c, 'd) T2" map: map_T2 sets: + bound: set_1_T2 free: Vrs_2_T2 free: Vrs_1_T2 bd: natLeq @@ -55,10 +57,11 @@ local_setup \fn lthy => let open MRBNF_Def val (mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I - [Free_Var, Dead_Var, Free_Var, Free_Var, Live_Var] + [Free_Var, Bound_Var, Free_Var, Free_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" @@ -77,7 +80,7 @@ mrsbnf "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" done mrsbnf "('a, 'b, 'c, 'd) T2" - apply (tactic \Skip_Proof.cheat_tac @{context} 1\) + apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ done mrsbnf T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" @@ -86,28 +89,31 @@ mrsbnf T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" local_setup \fn lthy => let - val ((mrbnf, tys), (_, lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Do_Inline (Binding.prefix_name o string_of_int) (distinct (op=) o flat) + val ((mrbnf, tys), ((_, unfolds), lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Do_Inline (Binding.prefix_name o string_of_int) (distinct (op=) o flat) (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 'a}, @{typ 'e}], + [@{typ 'e}], [@{typ 'g}], - [@{typ 'a}, @{typ 'e}] + [@{typ 'e}] ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g"}] [ - [@{typ 'b}, @{typ 'd}], + [@{typ 'a}, @{typ 'b}, @{typ 'd}], [], - [@{typ 'b}, @{typ 'c}, @{typ 'd}, @{typ 'h}] + [@{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; in lthy end \ 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 (tactic \Local_Defs.unfold0_tac @{context} (BMV_Monad_Def.unfolds_of_bmv_monad (the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Composition.T")))\)[5] - + apply (unfold comp_defs) apply (rule trans) apply (rule T1.map_is_Sb) apply (assumption | rule supp_id_bound)+ @@ -126,29 +132,6 @@ mrsbnf T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3' apply (rule T3'.map_is_Sb[THEN fun_cong]; assumption) - 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 - - apply (rule trans) apply (rule trans[OF comp_assoc[symmetric]]) apply (rule trans) @@ -176,28 +159,140 @@ mrsbnf T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3' apply (rule ext) apply (rule T1.map_cong0) apply (rule supp_id_bound)+ - apply (unfold T2.map_id0 id_o o_id)[1] - apply (rule refl)+ + 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 (rule refl) + apply (unfold T1.Map_map[symmetric])[1] + apply (rule T1.Map_Inj) - subgoal + 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) - apply (subst T.Supp_Sb) - apply assumption+ + apply (unfold UN_empty2 Un_empty_left Un_empty_right Un_assoc[symmetric] + T3'.set_Vrs(1) Un_Union_image + ) apply (rule refl) done - apply (rule T2.map_is_Sb; assumption) - apply (rule T3'.map_is_Sb; assumption) + 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 ext) + apply (rule trans[OF comp_apply]) + apply (rule trans) + apply (rule T2.map_Inj) + apply (assumption | rule supp_id_bound bij_id)+ + apply (rule arg_cong[OF id_apply]) + 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'.map_Sb; assumption) - apply (rule T3'.set_Sb; assumption) + apply (rule T3'.set_Sb; assumption)+ apply (rule T3'.map_is_Sb; assumption) done print_theorems +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, _), (_, 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}], + [@{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) +in lthy end\ + end \ No newline at end of file diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index 2f724b8c..8599aee8 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -299,6 +299,26 @@ lemma ex_avoiding_bij: apply (rule conjI avoiding_bij assms)+ done +lemma ex_distinct_bijs: "A \ {} \ |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 From 26968a7642432a2b33662c231972c8e4aa9c4bc0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 23 Jun 2025 17:03:16 +0100 Subject: [PATCH 39/90] Get mrsbnf composition to work --- Tools/bmv_monad_def.ML | 85 +++++++++++++++++++++++++++++-------- Tools/mrsbnf_comp.ML | 47 +++++++++++++------- Tools/mrsbnf_def.ML | 14 +++++- operations/BMV_Fixpoint.thy | 27 ++++++++---- 4 files changed, 129 insertions(+), 44 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index d99a0370..61562eae 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1532,9 +1532,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val (x, _) = names_lthy |> apfst hd o mk_Frees "x" [leader ops_of_bmv_monad outer]; - val new_Injs = filter (member (op=) frees o domain_type o fastype_of) ( + 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 => @@ -1609,9 +1609,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ); 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 Option.map (mk_UNION (set $ x)) ( - List.find (curry (op=) live o HOLogic.dest_setT o body_type o fastype_of) (the (leader Supps_of_bmv_monad inner)) - ) + 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; @@ -1670,14 +1672,26 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ], Supp_Map = map (fn _ => fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt @{thms image_Un image_UN}), - REPEAT_DETERM o rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)"]}, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (#Supp_Map (#axioms param)), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms image_comp[unfolded comp_def] image_Un image_UN}), - rtac ctxt @{thm UN_cong}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms image_UN[symmetric]}), - resolve_tac ctxt (flat (map_filter (Option.map (#Supp_Map o #axioms) o leader params_of_bmv_monad) inners')) - ] + 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') @@ -1696,9 +1710,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit etac ctxt @{thm UN_I} ORELSE' REPEAT_DETERM o FIRST' [ 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} ], - assume_tac ctxt + TRY o assume_tac ctxt ] ] ) inners) @@ -1732,10 +1747,29 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit EqSubst.eqsubst_tac ctxt [0] (#Supp_Sb param), REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_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' rtac ctxt @{thm SSupp_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} - @ #Supp_Map (#axioms param) @ #Vrs_Map param @ flat (#Supp_Injss facts) + @ #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')), @@ -1846,11 +1880,26 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs axioms @ #Supp_Sb param), REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_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 + ), 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} + 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) - @ #Supp_Map (#axioms param) @ flat (maps ( + @ flat (maps ( #Supp_Injss o leader facts_of_bmv_monad ) (outer :: inners')) )), @@ -1860,7 +1909,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ), REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}) ], - K (Local_Defs.unfold0_tac ctxt @{thms image_Un Union_UN_swap image_UN UN_empty2 Un_empty_left Un_empty_right UN_UN_flatten UN_Un_distrib Un_assoc[symmetric]}), + 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]}), rtac ctxt refl ORELSE' EVERY' [ rtac ctxt @{thm set_eqI}, K (Local_Defs.unfold0_tac ctxt @{thms Un_iff}), diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 4ab785e6..9f1fd11a 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -89,6 +89,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A [] => 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 @@ -196,7 +197,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A infer_instantiate' ctxt (map (Option.map (fn t => let val t' = case t of - Const (@{const_name id}, Type("fun", [TVar ((n, i), s), _])) => + 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 @@ -261,14 +262,16 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 (map_filter #Map_map (MRSBNF_Def.facts_of_mrsbnf outer))), + 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 #set_Sb o MRSBNF_Def.axioms_of_mrsbnf) inners), + 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 ( @@ -295,13 +298,30 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A ]), 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)))), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf outer_mrbnf), - REPEAT_DETERM o resolve_tac ctxt @{thms supp_id_bound bij_id} - ], - K (Local_Defs.unfold_tac ctxt ( - @{thms UN_empty2 Un_empty_right Un_empty_left image_id Un_assoc[symmetric] Un_Union_image} - @ no_reflexive (flat (maps (map #set_Vrs o MRSBNF_Def.axioms_of_mrsbnf) inners)) + 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))) )), rtac ctxt refl ]) @@ -325,7 +345,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * ( | mrsbnf_of_typ optim const_policy qualify' Ds0 var_types (T as Type (n, Ts)) ((bmv_unfolds:thm list, accum), lthy) = (case mrsbnf_of lthy n of NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), ((bmv_unfolds, accum), lthy)) | SOME (outer, lthy) => - if optim andalso forall is_TFree Ts then + 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)) @@ -339,8 +359,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * ( 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 _ = @{print} T - val _ = @{print} 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 the_default var_type req @@ -384,8 +403,6 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * ( (fn i => mrsbnf_of_typ optim const_policy (qualify i) Ds0 var_types) (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' ((bmv_unfolds, accum), lthy)); - val _ = @{print} T - val _ = @{print} Ts' 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 diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index c5ff862a..938614a8 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -64,13 +64,21 @@ 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) = { +}: '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 +}: 'b mrsbnf_axioms end type mrsbnf_facts = { SSupp_map_subset: thm option list, @@ -803,6 +811,8 @@ 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 = diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index ccf1654f..8b1f2e44 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -17,24 +17,33 @@ Multithreading.parallel_proofs := 0 local_setup \fn lthy => let - val ((mrsbnf, tys), (_, lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) + val ((mrsbnf, tys), ((bmv_unfolds, (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) I [] (map (apfst dest_TFree) [(@{typ 'v}, MRBNF_Def.Free_Var), (@{typ 'btv}, MRBNF_Def.Bound_Var), (@{typ 'bv}, MRBNF_Def.Bound_Var)]) @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} - ((MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds), lthy); - - val _ = @{print} mrsbnf -in lthy end -\ - - - + (([], (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy); + val unfold_defs = Thm.cterm_of lthy o Raw_Simplifier.rewrite_term (Proof_Context.theory_of lthy) bmv_unfolds [] + val unfold_defs' = Local_Defs.unfold0 lthy (bmv_unfolds @ #map_unfolds mrbnf_unfolds) + val mrsbnf = case mrsbnf of MRBNF_Util.Inl x => x | _ => error "impossible" + val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; + val _ = @{print} (map unfold_defs (BMV_Monad_Def.Sbs_of_bmv_monad bmv)) + val _ = @{print} (map (map unfold_defs' o #set_Vrs) (MRSBNF_Def.axioms_of_mrsbnf mrsbnf)) + val (_, lthy) = BMV_Monad_Def.note_bmv_monad_thms (K BNF_Def.Note_All) I (SOME @{binding FTerm_pre'}) bmv lthy + val notes = [ + ("bmv_defs", bmv_unfolds) + ] |> (map (fn (thmN, thms) => + ((Binding.name thmN, []), [(thms, [])]) + )); + val (noted, lthy) = Local_Theory.notes notes lthy +in lthy end +\ +print_theorems From 6bb424be94a351a45578daa3d4418ed190b7592d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 27 Jun 2025 09:07:58 +0100 Subject: [PATCH 40/90] Implement sealing of bmvs and mrsbnfs --- Tools/bmv_monad_def.ML | 257 +++++++++++++++++++++++- Tools/mrbnf_comp.ML | 55 ++++-- Tools/mrbnf_sugar.ML | 2 +- Tools/mrsbnf_comp.ML | 179 +++++++++++++++-- Tools/mrsbnf_def.ML | 11 +- operations/BMV_Composition.thy | 146 ++++++++++++++ operations/BMV_Fixpoint.thy | 317 ++---------------------------- operations/MRSBNF_Composition.thy | 224 +++++++++++++-------- thys/MRBNF_FP.thy | 9 + thys/Support.thy | 3 + 10 files changed, 772 insertions(+), 431 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 61562eae..ace39f89 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -108,6 +108,10 @@ signature BMV_MONAD_DEF = sig -> { 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 -> 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 @@ -726,6 +730,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = 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 = @@ -754,7 +759,9 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("SSupp_Sb_bound", maps #SSupp_Sb_bounds facts, []) ] |> filter_out (null o #2) - |> map (fn (thmN, thms, attrs) => ((Binding.qualify true (bmv_name ()) (Binding.name thmN), attrs), [(thms, [])])); + |> 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) @@ -1895,6 +1902,12 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) (#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' rtac ctxt @{thm SSupp_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} @@ -1969,6 +1982,248 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val (res, lthy) = bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) qualify (SOME name) model 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 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 (((fs, rhos), gs), _) = lthy + |> mk_Frees "f" (map ((fn a => a --> a) o HOLogic.dest_setT o body_type o fastype_of) (leader RVrs_of_bmv_monad bmv)) + ||>> 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" (the_default [] (Option.map (fst o split_last o binder_types o fastype_of) (leader Maps_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), 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, + 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 RVrs => HOLogic.mk_comp (RVrs, rep)) (leader RVrs_of_bmv_monad bmv)) + ||>> 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)); + + 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, gs)), rep) + )) + ||>> apfst SOME o mk_defs_t (mk_name "Supp") 0 (map (fn Supp => HOLogic.mk_comp (Supp, rep)) (the (leader Supps_of_bmv_monad bmv))) + + + 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 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 @ 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], + 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 (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 = [leader frees_of_bmv_monad bmv], + lives = [leader lives_of_bmv_monad bmv], + lives' = [leader lives'_of_bmv_monad bmv], + deads = [leader deads_of_bmv_monad bmv], + 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]] @ Inj_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], #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} + ] @ Inj_defs @ map snd Supps @ map snd Vrs @ map snd RVrs)), + 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 ([ + 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 (#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]] @ Inj_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]] @ Inj_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 (#Vrs_bds axioms) + ])) (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} @ map snd Vrs @ map snd RVrs @ Inj_defs @ [#Abs_inverse (snd info) OF @{thms UNIV_I}])), + resolve_tac ctxt (flat (#Vrs_Injss axioms)) + ]) + ) Injs)) (RVrs @ Vrs), + Vrs_Sbs = map (K (fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt ([ + snd Sb, @{thm SSupp_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} + ] @ Inj_defs @ map snd Vrs @ map snd RVrs)), + 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]] @ Inj_defs @ map snd Vrs @ map snd RVrs)), + 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 ((bmv, _), lthy) = bmv_monad_def BNF_Def.Hardly_Inline (K BNF_Def.Note_Some) qualify NONE model lthy; + val new_unfolds = map (Local_Defs.unfold0 lthy unfolds) defs; + + in ((bmv, new_unfolds, defs, (T_name, info)), lthy) end + fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = let val b = fst (hd b_ops); diff --git a/Tools/mrbnf_comp.ML b/Tools/mrbnf_comp.ML index 3899728a..8dfae91c 100644 --- a/Tools/mrbnf_comp.ML +++ b/Tools/mrbnf_comp.ML @@ -58,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 = @@ -1034,10 +1035,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) @@ -1180,7 +1182,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); @@ -1188,21 +1190,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; @@ -1210,11 +1214,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) @@ -1222,12 +1229,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; @@ -1253,8 +1266,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}, @@ -1413,7 +1426,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_deads, absT_info)), lthy'') end; exception BAD_DEAD of typ * typ; diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 57f6221e..5f18f41a 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -143,7 +143,7 @@ fun create_binder_type (fp : MRBNF_Util.fp_kind) (spec : spec) 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 ((mrbnf, _, (Ds, absinfo)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name pre_name) true (fst tys) [] mrbnf NONE lthy; val (bnf, lthy) = MRBNF_Def.register_mrbnf_as_bnf mrbnf lthy val (res, lthy) = MRBNF_FP.construct_binder_fp fp [{ T_name = name, diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 9f1fd11a..9e3a5bf0 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -3,15 +3,21 @@ 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 -> ((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)) * ((thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) + val seal_mrsbnf: (binding -> binding) -> (thm list * MRBNF_Comp.unfold_set) -> binding + -> 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 @@ -30,28 +36,163 @@ fun mrsbnf_of lthy s = case MRSBNF_Def.mrsbnf_of lthy s of fun is_Inl (Inl _) = true | is_Inl _ = false -fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs Ass Xs ((old_bmv_unfold, accum), lthy) = +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 vars Ds mrsbnf info_opt lthy = + let + 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 var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; + val (lives, bounds, frees) = MRBNF_Def.deinterlace vars var_types; + val bounds = map (resort_tfree_or_tvar @{sort var}) bounds; + val frees = map (resort_tfree_or_tvar @{sort var}) frees; + val rep_T = MRBNF_Def.mk_T_of_mrbnf Ds lives bounds frees mrbnf; + + val ((mrbnf, info, (Ds, absT_info)), lthy) = MRBNF_Comp.seal_mrbnf qualify mrbnf_unfolds name true Ds Ds mrbnf info_opt lthy; + + 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 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 ((bmv, _, bmv_defs, _), lthy) = BMV_Monad_Def.seal_bmv_monad qualify bmv_unfolds name [] 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 defs = bmv_defs @ [MRBNF_Def.map_def_of_mrbnf mrbnf] @ MRBNF_Def.set_defs_of_mrbnf mrbnf; + val mrbnf_defs = #map_unfolds mrbnf_unfolds @ flat (#set_unfoldss mrbnf_unfolds); + 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.unfold0 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) THEN_ALL_NEW 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}, + 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)) THEN_ALL_NEW assume_tac ctxt + ], + set_Sb = map (fn thm => 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, + rtac ctxt (unfold_defs thm) THEN_ALL_NEW assume_tac ctxt, + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ]) (#set_Sb axioms), + set_Vrs = map (fn thm => fn ctxt => EVERY1 [ + K (Local_Defs.unfold0_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), + rtac ctxt @{thm trans[OF comp_apply]}, + rtac ctxt trans, + rtac ctxt (unfold_defs thm), + K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ]) (#set_Vrs axioms) + } + ) (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; - val outer_mrbnf = nth (MRSBNF_Def.mrbnfs_of_mrsbnf outer) (BMV_Monad_Def.leader_of_bmv_monad outer_bmv); - fun leader f bmv = nth (f bmv) (BMV_Monad_Def.leader_of_bmv_monad bmv); 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 (bounds, vars) = apply2 (map fst) (partition (fn (NONE, _) => false - | (SOME _, t) => t = MRBNF_Def.Bound_Var - ) (vars ~~ MRBNF_Def.var_types_of_mrbnf mrbnf)); - val Ts = (filter_out (member (op=) (leader BMV_Monad_Def.deads_of_bmv_monad bmv)) - (map TVar (rev (Term.add_tvarsT (leader BMV_Monad_Def.ops_of_bmv_monad bmv) []))) - ) ~~ vars; - fun lookup f = map_filter (Option.join o AList.lookup (op=) Ts) (leader f 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 = lookup BMV_Monad_Def.frees_of_bmv_monad, - deads = map (resort_tfree_or_tvar @{sort var}) (map_filter I bounds) @ Ds, - lives = lookup BMV_Monad_Def.lives_of_bmv_monad + 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; @@ -65,7 +206,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 (distinct (op=) o flat) outer_mrbnf inner_mrbnfs oDs Dss oAs Ass Xs (accum, lthy); + qualify flatten_tyargs outer_mrbnf inner_mrbnfs oDs Dss oAs Ass Xs (accum, lthy); val mrbnf = let @@ -328,7 +469,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A }) axioms') lthy; in ((mrsbnf, tys), ((old_bmv_unfold @ bmv_unfolds, mrbnf_unfolds), lthy)) end -fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)), lthy:local_theory) = +fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:(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)) @@ -341,8 +482,8 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * ( | _ => 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 (T as Type (n, Ts)) ((bmv_unfolds:thm list, accum), lthy) = (case mrsbnf_of lthy n of + | 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)) ((bmv_unfolds:thm list, accum), lthy) = (case mrsbnf_of lthy n of NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), ((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 @@ -400,7 +541,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * ( val ((inners, (Dss, Ass)), ((bmv_unfolds:thm list, 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) + (fn i => mrsbnf_of_typ optim const_policy (qualify i) Ds0 var_types flatten_tyargs) (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' ((bmv_unfolds, accum), lthy)); val Xs = rev (Term.add_tfreesT T []); @@ -415,7 +556,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types (T as TFree T') (accum:(thm list * ( | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf ) inners lthy; val ((mrsbnf, tys), accum) = compose_mrsbnfs BNF_Def.Smart_Inline const_policy qualify outer' inners' - oDs Dss oAs Ass Xs' ((bmv_unfolds, accum), lthy); + oDs Dss oAs Ass Xs' flatten_tyargs ((bmv_unfolds, accum), lthy); in ((Inl mrsbnf, tys), accum) end else apsnd (apfst (pair bmv_unfolds)) (apfst (apfst Inr) (MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline qualify (distinct (op=) o flat) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 938614a8..63f0dd04 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -32,6 +32,8 @@ signature MRSBNF_DEF = sig val mrsbnf_of_mrbnf: 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; @@ -149,6 +151,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = | 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 = @@ -158,6 +161,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("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, []), + ("map_Inj_raw", maps (the_default [] o #map_Injs) axioms, []), ("map_Inj", maps (map_filter I o #map_Inj) facts, []), ("Sb_comp_right", map #Sb_comp_right facts, []), ("map_Sb_strong", map #map_Sb_strong facts, []), @@ -165,7 +169,9 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("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), [(thms, [])])); + |> 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) @@ -636,8 +642,6 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b val mrsbnf = morph_mrsbnf (MRBNF_Util.subst_typ_morphism ( map (fn T => (T, Logic.varifyT_global T)) (deads @ As @ As' @ Bs @ Fs) )) mrsbnf; - - val (_, lthy) = note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy; in (mrsbnf, lthy) end; fun mk_mrsbnf_axioms mrbnfs bmv lthy = @@ -946,6 +950,7 @@ fun mrsbnf_cmd b_Ts lthy = ) 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 diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index 1b02b030..10217dc8 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -558,6 +558,147 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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, 'g set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1 set" + by (rule UNIV_witness) + +definition "Sb_T' \ \h1 h2 \1 \2 \3 \4 \5. Abs_T' \ (Sb_T1 h1 (Rep_T' \ \1) Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ Map_T3 h2 id)) \ Rep_T'" +definition "RVrs_1_T' \ \x. Vrs_1_T1 (Rep_T' x)" +definition "RVrs_2_T' \ \x. \ (Vrs_1_T2 ` set_1_T1 (Rep_T' x)) \ \ (set_1_T3 ` set_3_T1 (Rep_T' x))" +definition "Inj_T' \ Abs_T' \ Inj_1_T1" +definition "Vrs_1_T' \ \x. Vrs_2_T1 (Rep_T' x)" +definition "Vrs_2_T' \ \x. \ (Vrs_2_T2 ` set_1_T1 (Rep_T' x))" +definition "Vrs_3_T' \ \x. \ (Vrs_1_T3 ` set_3_T1 (Rep_T' x))" +definition "Vrs_4_T' \ \x. \ (Vrs_2_T3 ` set_3_T1 (Rep_T' x))" +definition "Vrs_5_T' \ \x. \ (Vrs_4_T3 ` set_3_T1 (Rep_T' x))" +definition "Map_T' \ \f. Abs_T' \ Map_T1 id id (Map_T3 id f) \ Rep_T'" +definition "Supp_T' \ \x. \ (set_2_T3 ` set_3_T1 (Rep_T' x))" + +lemmas defs = Sb_T'_def RVrs_1_T'_def RVrs_2_T'_def Inj_T'_def Vrs_1_T'_def Vrs_2_T'_def Vrs_3_T'_def + Vrs_4_T'_def Vrs_5_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_T' Inj_T2 Inj_1_T3 Inj_1_T4 Inj_2_T4 + Vrs: Vrs_1_T' Vrs_2_T' Vrs_3_T' Vrs_4_T' Vrs_5_T' + Maps: Map_T' + Supps: Supp_T' + bd: natLeq + apply (unfold SSupp_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) + 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 (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 (rule type_copy_map_cong0) + apply (rule T.Sb_cong) + apply assumption+ + apply (unfold0 comp_apply)[1] + apply (rule arg_cong[of _ _ Rep_T']) + apply assumption+ + + 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 (rule T.Supp_bd) + + apply (rule type_copy_map_cong0) + apply (rule T.Map_cong) + 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 @@ -567,6 +708,11 @@ let 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 \ diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 8b1f2e44..d3181351 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -17,75 +17,26 @@ Multithreading.parallel_proofs := 0 local_setup \fn lthy => let - val ((mrsbnf, tys), ((bmv_unfolds, (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) + val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; + val Xs = [@{typ 'tv}, @{typ 'v}, @{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}]; + + val ((mrsbnf, (Ds, tys)), ((bmv_unfolds, (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) I [] (map (apfst dest_TFree) [(@{typ 'v}, MRBNF_Def.Free_Var), (@{typ 'btv}, MRBNF_Def.Bound_Var), (@{typ 'bv}, MRBNF_Def.Bound_Var)]) - @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} + (fn xss => inter (op=) (flat xss) (map dest_TFree Xs)) + T (([], (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy); - val unfold_defs = Thm.cterm_of lthy o Raw_Simplifier.rewrite_term (Proof_Context.theory_of lthy) bmv_unfolds [] - val unfold_defs' = Local_Defs.unfold0 lthy (bmv_unfolds @ #map_unfolds mrbnf_unfolds) val mrsbnf = case mrsbnf of MRBNF_Util.Inl x => x | _ => error "impossible" - val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; - - val _ = @{print} (map unfold_defs (BMV_Monad_Def.Sbs_of_bmv_monad bmv)) - val _ = @{print} (map (map unfold_defs' o #set_Vrs) (MRSBNF_Def.axioms_of_mrsbnf mrsbnf)) - - val (_, lthy) = BMV_Monad_Def.note_bmv_monad_thms (K BNF_Def.Note_All) I (SOME @{binding FTerm_pre'}) bmv lthy - - val notes = [ - ("bmv_defs", bmv_unfolds) - ] |> (map (fn (thmN, thms) => - ((Binding.name thmN, []), [(thms, [])]) - )); - - val (noted, lthy) = Local_Theory.notes notes lthy - -in lthy end -\ -print_theorems - - - - - - - - - - - - - - - - - - - + val ((mrsbnf, (tys, info)), lthy) = MRSBNF_Comp.seal_mrsbnf I (bmv_unfolds, mrbnf_unfolds) + @{binding FTerm_pre} Xs Ds mrsbnf NONE lthy + val (_, lthy) = MRSBNF_Def.note_mrsbnf_thms (K BNF_Def.Note_Some) I NONE 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) - -local_setup \fn lthy => - let - val Xs = map dest_TFree [] - val resBs = map dest_TFree [@{typ 'tv}, @{typ 'v}, @{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}] - - fun flatten_tyargs Ass = subtract (op =) Xs (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs) @ Xs; - val qualify = Binding.prefix_name "FTerm_pre_" - val accum = (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds) - - (* Step 1: Create pre-MRBNF *) - val ((mrbnf, tys), (accum, lthy)) = MRBNF_Comp.mrbnf_of_typ true MRBNF_Def.Smart_Inline qualify flatten_tyargs Xs [] - [(dest_TFree @{typ 'tv}, MRBNF_Def.Free_Var), (dest_TFree @{typ 'v}, MRBNF_Def.Free_Var), - (dest_TFree @{typ 'btv}, MRBNF_Def.Bound_Var), (dest_TFree @{typ 'bv}, MRBNF_Def.Bound_Var) - ] @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} (accum, lthy) - - (* Step 2: Seal the pre-MRBNF with a typedef *) - val ((mrbnf, (Ds, info)), lthy) = MRBNF_Comp.seal_mrbnf I (snd accum) (Binding.name "FTerm_pre") true (fst tys) [] mrbnf lthy - - (* Step 3: Register the pre-MRBNF as a BNF in its live variables *) + (* 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 *) @@ -98,246 +49,10 @@ local_setup \fn lthy => pre_mrbnf = mrbnf }] [[([], [0])], [([], [0])]] lthy - (* Step 5: Prove BMV structure of pre-MRBNF by composition *) - val (bmv, (thms, lthy)) = apfst the (MRSBNF_Def.pbmv_monad_of_typ true BNF_Def.Smart_Inline (K BNF_Def.Note_Some) - (map dest_TFree [@{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}]) - I @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"} ([], lthy)) - - (* Register bmv to access theorems later *) - val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Fixpoint.FTerm_pre'" bmv lthy; - - val notes = [ - ("bmv_defs", thms) - ] |> (map (fn (thmN, thms) => - ((Binding.name thmN, []), [(thms, [])]) - )); - - val (noted, lthy) = Local_Theory.notes notes lthy - - val _ = @{print} bmv - in lthy end\ - -ML \ -val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre'") -val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv; -val laxioms = nth axioms (BMV_Monad_Def.leader_of_bmv_monad bmv) +in lthy end \ - -lemma comp_assoc_middle: "(\x. f2 (f1 x) = x) \ f1 \ g1 \ f2 \ (f1 \ g2 \ f2) = f1 \ (g1 \ g2) \ f2" - by auto -lemma typedef_Rep_comp: "type_definition Rep Abs UNIV \ Rep ((Abs \ f \ Rep) x) = f (Rep x)" - unfolding comp_def type_definition.Abs_inverse[OF _ UNIV_I] .. - -definition "Sb_FTerm_pre \ \(f1::'v::var \ 'v) (f2::'tv::var \ 'tv FType). (Abs_FTerm_pre :: _ \ ('tv, 'v, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre) \ (map_sum (id f1) (map_sum id (BMV_Fixpoint.sum2.sum2.sum.Sb_0 f2) \ id) \ id) \ Rep_FTerm_pre" -definition "Vrs1_FTerm_pre \ \x. \x\Basic_BNFs.setl (Rep_FTerm_pre x). {x}" -definition "Vrs2_FTerm_pre \ \x. \y\Basic_BNFs.setr (Rep_FTerm_pre x). \ (sum2.sum2.sum.Vrs_0_0 ` Basic_BNFs.setr y)" - -(* Transfer pbmv structure of pre-datatype to sealed version *) -pbmv_monad "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var" and "'tv::var FType" - Sbs: "Sb_FTerm_pre :: _ \ _ \ _ \ ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "id :: ('v \ 'v) \ 'v \ 'v" and "tvsubst_FType :: ('tv::var \ 'tv FType) \ 'tv FType \ 'tv FType" - Injs: "id :: 'v::var \ 'v" "TyVar :: 'tv::var \ 'tv FType" and "id :: 'v::var \ 'v" and "TyVar :: 'tv::var \ 'tv FType" - SSupps: "supp :: _ \ 'v::var set" "SSupp_FType :: _ \ 'tv::var set" and "supp :: _ \ 'v::var set" and "SSupp_FType :: _ \ 'tv::var set" - Vrs: "Vrs1_FTerm_pre :: ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre \ _", "Vrs2_FTerm_pre :: ('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre \ _" and "\(x::'v). {x}" and "Vrs_FType_1 :: _ \ 'tv::var set" - Map: "\(f1::'c \ 'c') (f2::'d \ 'd'). map_FTerm_pre id id id id f1 f2" - Supps: "set5_FTerm_pre :: _ \ 'c set" "set6_FTerm_pre :: _ \ 'd set" - bd: natLeq - apply (unfold Sb_FTerm_pre_def Vrs1_FTerm_pre_def Vrs2_FTerm_pre_def) - subgoal - apply (tactic \resolve_tac @{context} [BMV_Monad_Def.bd_infinite_regular_card_order_of_bmv_monad bmv] 1\) - done - subgoal - apply (tactic \Local_Defs.unfold0_tac @{context} [#Sb_Inj laxioms]\) - apply (unfold o_id) - apply (rule ext) - apply (rule trans[OF comp_apply]) - apply (rule trans[OF Rep_FTerm_pre_inverse]) - apply (rule id_apply[symmetric]) - done - apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] - apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] - subgoal - apply (rule trans[OF comp_assoc_middle]) - apply (rule Abs_FTerm_pre_inverse[OF UNIV_I]) - apply (rule arg_cong[of _ _ "\x. _ \ x \ _"]) - apply (tactic \resolve_tac @{context} [#Sb_comp laxioms] 1\; assumption) - done - subgoal - apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_bds laxioms)) 1\) - done - subgoal - apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_bds laxioms)) 1\) - done - subgoal - apply (unfold typedef_Rep_comp[OF type_definition_FTerm_pre]) - apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_Sbs laxioms)) 1\) - apply assumption+ - done - subgoal - apply (unfold typedef_Rep_comp[OF type_definition_FTerm_pre]) - apply (tactic \resolve_tac @{context} (maps (map_filter I) (#Vrs_Sbs laxioms)) 1\) - apply assumption+ - done - subgoal - apply (rule trans[OF comp_apply])+ - apply (rule trans[OF _ comp_apply[symmetric]])+ - apply (rule arg_cong[of _ _ Abs_FTerm_pre]) - apply (tactic \resolve_tac @{context} [#Sb_cong laxioms] 1\) - apply assumption+ - done - subgoal - apply (rule FTerm_pre.map_id0) - done - subgoal - apply (rule trans) - apply (rule FTerm_pre.map_comp0[symmetric]) - apply (rule supp_id_bound bij_id)+ - apply (unfold id_o) - apply (rule refl) - done - subgoal - apply (rule FTerm_pre.set_map) - apply (rule supp_id_bound bij_id)+ - done - subgoal - apply (rule FTerm_pre.set_map) - apply (rule supp_id_bound bij_id)+ - done - subgoal - apply (rule FTerm_pre.set_bd) - done - subgoal - apply (rule FTerm_pre.set_bd) - done - subgoal - apply (rule FTerm_pre.map_cong0) - apply (rule bij_id supp_id_bound)+ - apply (rule refl | assumption)+ - done - subgoal - apply (rule ext) - apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms map_FTerm_pre_def bmv_defs - comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply - FType.map_id0 - })\) - apply (rule refl) - done - subgoal - apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms set5_FTerm_pre_def set6_FTerm_pre_def bmv_defs - comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply - FType.map_id0 id_def[symmetric] - })\) - apply (rule refl) - done - subgoal - apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms set5_FTerm_pre_def set6_FTerm_pre_def bmv_defs - comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply - FType.map_id0 id_def[symmetric] - })\) - apply (rule refl) - done - subgoal - apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms map_FTerm_pre_def bmv_defs - comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply - FType.map_id0 sum.set_map prod.set_map image_id UN_simps(10) - })\) - apply (rule refl) - done - subgoal - apply (tactic \Local_Defs.unfold0_tac @{context} (@{thms map_FTerm_pre_def bmv_defs - comp_def Abs_FTerm_pre_inverse[OF UNIV_I] sum.map_comp prod.map_comp id_apply - FType.map_id0 sum.set_map prod.set_map image_id UN_simps(10) - })\) - apply (rule refl) - done - (********************* BMV Structure of minions, no transfer needed *) - apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) - apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) - apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] - apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) - (* also for FType *) - apply (tactic \resolve_tac @{context} (map #Sb_Inj axioms) 1\) - apply (tactic \resolve_tac @{context} (maps #Sb_comp_Injs axioms) 1\; assumption) - apply (tactic \Local_Defs.unfold0_tac @{context} (maps (map snd) (BMV_Monad_Def.SSupps_of_bmv_monad bmv))\, rule refl)[1] - apply (tactic \resolve_tac @{context} (map #Sb_comp axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_bds) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Injs) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (maps (maps (map_filter I) o #Vrs_Sbs) axioms) 1\; assumption) - apply (tactic \resolve_tac @{context} (map #Sb_cong axioms) 1\; assumption) - done -print_theorems -print_pbmv_monads - -mrsbnf "('tv::var, 'v::var, 'btv::var, 'bv::var, 'c, 'd) FTerm_pre" and "'v::var" and "'tv::var FType" - subgoal for f1 f2 - apply (rule ext) - apply (unfold map_FTerm_pre_def comp_def Sb_FTerm_pre_def bmv_defs id_def) - apply (subst FType.map_is_Sb, assumption+)+ - apply (unfold id_def[symmetric] sum.map_id prod.map_id comp_def) - apply (rule refl) - done - subgoal for x - apply (unfold set1_FTerm_pre_def Vrs2_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left - prod.set_map Un_empty_right comp_def bmv_defs - ) - apply (rule refl) - done - subgoal for x - apply (unfold set2_FTerm_pre_def Vrs1_FTerm_pre_def sum.set_map UN_empty2 Un_empty_left - prod.set_map Un_empty_right comp_def bmv_defs - ) - apply (rule refl) - done - subgoal for f3 f4 f5 f6 g1 g2 - apply (rule ext) - apply (unfold map_FTerm_pre_def comp_def Sb_FTerm_pre_def bmv_defs FType.map_id0 Abs_FTerm_pre_inverse[OF UNIV_I]) - apply (unfold id_def) - apply (unfold sum.map_id prod.map_id comp_def sum.map_comp prod.map_comp) - apply (rule refl) - done - subgoal for g1 g2 - apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set3_FTerm_pre_def - prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right - Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) - ) - apply (rule refl) - done - subgoal for g1 g2 - apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set4_FTerm_pre_def - prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right - Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) - ) - apply (rule refl) - done - subgoal for g1 g2 - apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set5_FTerm_pre_def - prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right - Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) - ) - apply (rule refl) - done - subgoal for g1 g2 - apply (unfold Sb_FTerm_pre_def bmv_defs comp_def id_apply set6_FTerm_pre_def - prod.set_map sum.set_map UN_empty2 Un_empty_left Un_empty_right - Abs_FTerm_pre_inverse[OF UNIV_I] UN_simps(10) - ) - apply (rule refl) - done - apply (rule ID.map_is_Sb; assumption) - apply (rule FType.map_is_Sb; assumption) - done print_theorems -ML \ -val bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Fixpoint.FTerm_pre") -val axioms = BMV_Monad_Def.axioms_of_bmv_monad bmv -val laxioms = hd axioms -val param = the (hd (BMV_Monad_Def.params_of_bmv_monad bmv)) -\ - (* Substitution axioms *) abbreviation \ :: "'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre" where "\ a \ Abs_FTerm_pre (Inl a)" @@ -421,12 +136,6 @@ lemma asVVr_VVr: "asVVr (VVr a) = a" apply (erule sym) done -ML \ -val Map_Sb' = Local_Defs.unfold0 @{context} @{thms comp_apply} (#Map_Sb param RS fun_cong) RS sym -val Vrs_Sb = maps (map_filter I) (#Vrs_Sbs laxioms); -val Vrs_Injs = maps (maps (map_filter I) o #Vrs_Injs) axioms; -\ - lemma permute_VVr: fixes f1::"'var::var \ 'var" and f2::"'tyvar::var \ 'tyvar" assumes f_prems: "bij f1" "|supp f1| fn lthy => let - val ((mrbnf, tys), ((_, unfolds), lthy)) = MRBNF_Comp.compose_mrbnf MRBNF_Def.Do_Inline (Binding.prefix_name o string_of_int) (distinct (op=) o flat) + 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 'g}], + [@{typ "'g::var set"}], [@{typ 'e}] - ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g"}] [ + ] [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}] @@ -109,61 +110,67 @@ let 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 \ 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 (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 T3'.map_Sb[THEN fun_cong]) + apply assumption+ apply (rule refl) apply (unfold T1.Map_map[symmetric])[1] @@ -172,22 +179,22 @@ mrsbnf T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3' 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 - ) + 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 - ) + 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 - ) + T3'.set_Vrs(1) Un_Union_image + ) apply (rule refl) done @@ -213,10 +220,10 @@ mrsbnf T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3' 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 (rotate_tac -1) + apply (erule contrapos_pp) + apply (unfold Un_iff de_Morgan_disj)[1] + apply (erule conjE)+ apply ((rule conjI)+, assumption+)+ done @@ -243,42 +250,89 @@ mrsbnf T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and T3' 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 (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 ext) - apply (rule trans[OF comp_apply]) - apply (rule trans) - apply (rule T2.map_Inj) - apply (assumption | rule supp_id_bound bij_id)+ - apply (rule arg_cong[OF id_apply]) + 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 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'.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, _), (_, lthy)) = MRSBNF_Comp.compose_mrsbnfs BNF_Def.Do_Inline (K BNF_Def.Note_Some) + 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}), @@ -286,13 +340,19 @@ let the (MRSBNF_Def.mrsbnf_of lthy "MRSBNF_Composition.T3'") ] [@{typ 'f}] [ [@{typ 'e}], - [@{typ 'g}], + [@{typ "'g::var"}], [@{typ 'e}] - ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g"}] [ + ] [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}] - ] [] (([], (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy) + ] [] (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/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index 8599aee8..a639a1fa 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -389,6 +389,7 @@ lemma id_on_image_same: "id_on A f \ id_on (f ` A) f" lemma rel_refl_eq: "(\x. R x x) \ x = y \ R x y" by auto + lemma rel_set_reflI: "(\a. a \ A \ r a a) \ rel_set r A A" by (auto simp: rel_set_def) @@ -412,6 +413,14 @@ lemma conj_mp: "(P1 \ Q1) \ (P2 \ Q2) \ 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/Support.thy b/thys/Support.thy index 021d7739..0b76c658 100644 --- a/thys/Support.thy +++ b/thys/Support.thy @@ -34,4 +34,7 @@ qed lemma SSupp_comp_bound: "infinite (UNIV::'a set) \ |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) + end \ No newline at end of file From 085b69a52d22eebc18f16c9def2ef9c6158cfe9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 27 Jun 2025 12:04:45 +0100 Subject: [PATCH 41/90] Adjust BMV_Fixpoint operations theory for sealed mrsbnf --- operations/BMV_Fixpoint.thy | 818 ++++++++++++------------------------ 1 file changed, 276 insertions(+), 542 deletions(-) diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index d3181351..1a9d15a9 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -29,6 +29,14 @@ let 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 Ds mrsbnf NONE lthy val (_, lthy) = MRSBNF_Def.note_mrsbnf_thms (K BNF_Def.Note_Some) I NONE mrsbnf lthy @@ -39,15 +47,18 @@ let (* 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 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; in lthy end \ @@ -78,8 +89,6 @@ lemma eta_natural: done (* Construction of substitution *) -type_synonym ('tv, 'v) P = "('v \ ('tv, 'v) FTerm) \ ('tv \ 'tv FType)" - definition VVr :: "'v::var \ ('tv::var, 'v) FTerm" where "VVr \ FTerm_ctor \ \" definition isVVr :: "('tv::var, 'v::var) FTerm \ bool" where @@ -87,37 +96,8 @@ definition isVVr :: "('tv::var, 'v::var) FTerm \ bool" where definition asVVr :: "('tv::var, 'v::var) FTerm \ 'v" where "asVVr x \ (if isVVr x then SOME a. x = VVr a else undefined)" -definition SSupp_FTerm :: "('v \ ('tv::var, 'v::var) FTerm) \ 'v set" where - "SSupp_FTerm f \ { a. f a \ VVr a }" -definition IImsupp_FTerm1 :: "('v \ ('tv::var, 'v::var) FTerm) \ 'tv set" where - "IImsupp_FTerm1 f \ \(FTVars ` f ` SSupp_FTerm f)" -definition IImsupp_FTerm2 :: "('v \ ('tv::var, 'v::var) FTerm) \ 'v set" where - "IImsupp_FTerm2 f \ SSupp_FTerm f \ \(FVars ` f ` SSupp_FTerm f)" - -definition Uctor :: "('tv::var, 'v::var, 'tv, 'v, ('tv, 'v) FTerm \ (('tv, 'v) P \ ('tv, 'v) FTerm), ('tv, 'v) FTerm \ (('tv, 'v) P \ ('tv, 'v) FTerm)) FTerm_pre - \ ('tv, 'v) P \ ('tv, 'v) FTerm" where - "Uctor y p \ case p of (f1, f2) \ 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 ((\R. R (f1, f2)) \ snd) ((\R. R (f1, f2)) \ snd) y))" - -definition PFVars_1 :: "('tv::var, 'v::var) P \ 'tv set" where - "PFVars_1 p \ case p of (f1, f2) \ IImsupp_FTerm1 f1 \ IImsupp_FType f2" -definition PFVars_2 :: "('tv::var, 'v::var) P \ 'v set" where - "PFVars_2 p \ case p of (f1, _) \ IImsupp_FTerm2 f1" - -definition compSS_FType :: "('tv \ 'tv) \ ('tv \ 'tv::var FType) \ 'tv \ 'tv FType" where - "compSS_FType g f \ permute_FType g \ f \ inv g" -definition compSS_FTerm :: "('tv \ 'tv) \ ('v \ 'v) \ ('v \ ('tv::var, 'v::var) FTerm) \ 'v \ ('tv, 'v) FTerm" where - "compSS_FTerm g1 g2 f \ permute_FTerm g1 g2 \ f \ inv g2" -definition Pmap :: "('tv \ 'tv) \ ('v \ 'v) \ ('tv::var, 'v::var) P \ ('tv, 'v) P" where - "Pmap g1 g2 p \ case p of (f1, f2) \ (compSS_FTerm g1 g2 f1, compSS_FType g1 f2)" -lemmas compSS_defs = compSS_FType_def compSS_FTerm_def - -definition valid_P :: "('tv::var, 'v::var) P \ bool" where - "valid_P p \ case p of (f1, f2) \ - |SSupp_FTerm f1| |SSupp_FType f2| 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) @@ -173,31 +153,8 @@ lemma isVVr_permute: apply (rule refl) done -lemma compSS_id0s: - "compSS_FType id = id" - "compSS_FTerm id id = id" - apply (unfold compSS_FType_def compSS_FTerm_def FTerm.permute_id0 FType.permute_id0 id_o o_id inv_id) - apply (unfold id_def) - apply (rule refl)+ - done - -lemma compSS_comp0_FTerm: - fixes f1 g1::"'tyvar::var \ 'tyvar" and f2 g2::"'var::var \ 'var" - assumes g_prems: "bij g1" "|supp g1| compSS_FTerm g1 g2 = compSS_FTerm (f1 \ g1) (f2 \ g2)" - apply (unfold compSS_FTerm_def) - apply (subst o_inv_distrib FTerm.permute_comp0[symmetric], (rule supp_id_bound bij_id assms ordLess_ordLeq_trans cmin2 cmin1 card_of_Card_order)+)+ - apply (rule ext) - apply (rule trans[OF comp_apply]) - apply (unfold comp_assoc) - apply (rule refl) - done -lemmas compSS_comp0s = FType.compSS_comp0[unfolded tvcompSS_tvsubst_FType_def compSS_FType_def[symmetric]] compSS_comp0_FTerm - lemma IImsupp_VVrs: "f2 a \ a \ imsupp f2 \ IImsupp_FTerm2 y = {} \ y a = VVr a" - apply (unfold imsupp_def supp_def IImsupp_FTerm2_def SSupp_FTerm_def) + apply (unfold imsupp_def supp_def SSupp_def) apply (drule iffD1[OF disjoint_iff]) apply (erule allE) apply (erule impE) @@ -238,12 +195,11 @@ lemma IImsupp_permute_commute: apply (erule id_onD[rotated]) apply (rule imsupp_id_on) apply (erule Int_subset_empty2) - apply (unfold IImsupp_FTerm1_def SSupp_FTerm_def)[1] + apply (unfold SSupp_def IImsupp_def)[1] apply (rule subsetI) apply (rule UnI2)? apply (rule UN_I[rotated]) apply assumption - apply (rule imageI) apply (rule CollectI) apply assumption (* repeated *) @@ -251,12 +207,11 @@ lemma IImsupp_permute_commute: apply (erule id_onD[rotated]) apply (rule imsupp_id_on) apply (erule Int_subset_empty2) - apply (unfold IImsupp_FTerm2_def SSupp_FTerm_def)[1] + apply (unfold SSupp_def IImsupp_def)[1] apply (rule subsetI) apply (rule UnI2)? apply (rule UN_I[rotated]) apply assumption - apply (rule imageI) apply (rule CollectI) apply assumption (* END REPEAT_DETERM *) @@ -281,38 +236,7 @@ lemma IImsupp_permute_commute: done done -lemma compSS_cong_id_FTerm: - fixes f1 g1::"'tyvar::var \ 'tyvar" and f2 g2::"'var::var \ 'var" - assumes g_prems: "bij g1" "|supp g1| a. a \ IImsupp_FTerm1 h \ f1 a = a) \ (\a. a \ IImsupp_FTerm2 h \ f2 a = a) \ compSS_FTerm f1 f2 h = h" - apply (unfold compSS_FTerm_def) - subgoal premises prems - apply (subst IImsupp_permute_commute) - apply (rule assms cmin1 cmin2 card_of_Card_order ordLess_ordLeq_trans)+ - (* REPEAT_DETERM *) - apply (rule trans[OF Int_commute]) - apply (rule disjointI) - apply (drule prems) - apply (erule bij_id_imsupp[rotated]) - apply (rule assms) - (* repeated *) - apply (rule trans[OF Int_commute]) - apply (rule disjointI) - apply (drule prems) - apply (erule bij_id_imsupp[rotated]) - apply (rule assms) - (* END REPEAT_DETERM *) - apply (unfold comp_assoc) - apply (subst inv_o_simp2) - apply (rule assms) - apply (rule o_id) - done - done -lemmas compSS_cong_ids = FType.compSS_cong_id[unfolded tvcompSS_tvsubst_FType_def compSS_FType_def[symmetric]] compSS_cong_id_FTerm - -lemma SSupp_natural_FTerm: +(*lemma SSupp_natural_FTerm: fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" assumes f_prems: "bij f1" "|supp f1| 'tyvar" and f2 g2::"'var::var \ 'var" - assumes g_prems: "bij g1" "|supp g1| Pmap g1 g2 = Pmap (f1 \ g1) (f2 \ g2)" - apply (rule ext) - apply (unfold Pmap_def case_prod_beta) - apply (rule trans[OF comp_apply]) - apply (unfold prod.inject fst_conv snd_conv) - apply (rule conjI bij_id supp_id_bound assms ordLess_ordLeq_trans cmin1 card_of_Card_order - trans[OF comp_apply[symmetric] fun_cong[OF compSS_comp0s(1)]] - trans[OF comp_apply[symmetric] fun_cong[OF compSS_comp0s(2)]] - )+ - done - -lemma valid_Pmap: - fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" - assumes f_prems: "bij f1" "|supp f1| valid_P (Pmap f1 f2 p)" - apply (unfold valid_P_def Pmap_def case_prod_beta compSS_defs fst_conv snd_conv) - apply (erule conj_forward)+ - apply (subst SSupp_naturals; (assumption | rule assms cmin1 cmin2 card_of_Card_order ordLeq_ordLess_trans[OF card_of_image] ordLess_ordLeq_trans)+)+ - done - -lemma PFVars_Pmaps: - fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" - assumes f_prems: "bij f1" "|supp f1| 'tyvar" and f2::"'var::var \ 'var" - assumes f_prems: "bij f1" "|supp f1| a. a \ PFVars_1 p \ f1 a = a) \ (\a. a \ PFVars_2 p \ f2 a = a) \ Pmap f1 f2 p = p" - apply (unfold PFVars_1_def PFVars_2_def Pmap_def case_prod_beta) - subgoal premises prems - apply (subst compSS_cong_ids, (rule f_prems prems cmin1 cmin2 card_of_Card_order ordLess_ordLeq_trans | erule UnI2 UnI1 | rule UnI1)+)+ - apply assumption - apply (unfold prod.collapse) - apply (rule refl) - done - done - -lemmas Cinfinite_UNIV = conjI[OF FTerm_pre.UNIV_cinfinite card_of_Card_order] -lemmas Cinfinite_card = cmin_Cinfinite[OF Cinfinite_UNIV Cinfinite_UNIV] -lemmas regularCard_card = cmin_regularCard[OF FTerm_pre.var_regular FTerm_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 small_PFVarss: - "valid_P p \ |PFVars_1 (p::('tyvar::var, 'var::var) P)| |PFVars_2 p| set3_FTerm_pre y \ PFVars_1 p = {} \ - (\t pu p. valid_P p \ (t, pu) \ set5_FTerm_pre y \ set6_FTerm_pre y \ FTVars (pu p) \ FTVars t \ PFVars_1 p) \ - FTVars (Uctor y p) \ FTVars (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) \ PFVars_1 p" - apply (frule iffD1[OF meta_eq_to_obj_eq[OF valid_P_def]]) - apply (unfold case_prod_beta) - apply (erule conjE)+ - subgoal premises prems - apply (unfold Uctor_def case_prod_beta) - 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 PFVars_1_def case_prod_beta IImsupp_FTerm1_def SSupp_FTerm_def image_comp[unfolded 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 (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) - apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ - - apply (unfold FTerm.FVars_ctor prod.collapse) - apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ - apply (unfold image_id image_comp comp_def prod.collapse) - apply (rule Un_mono')+ - apply (unfold FTerm_pre.set_Sb FTerm_pre.set_Vrs) - apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) - apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ - apply (unfold PFVars_1_def case_prod_beta IImsupp_FType_def SSupp_FType_def - tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric] comp_def - )[1] - apply (rule subsetI) - apply (erule UN_E) - apply (rule case_split[of "_ = _", rotated]) - apply (rule UnI2)+ - apply (rule UN_I) - apply (rule CollectI) - apply assumption - apply assumption - apply (rule UnI1) - apply (rotate_tac -2) - apply (drule iffD1[OF arg_cong2[OF refl, of _ _ "(\)"], rotated]) - apply (erule arg_cong) - apply (tactic \Local_Defs.unfold0_tac @{context} Vrs_Injs\) - apply (drule singletonD) - apply hypsubst - apply assumption - - apply (subst FTerm_pre.set_Sb) - apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ - 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 (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* repeated *) - apply (rule subset_If) - apply (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* END REPEAT_DETERM *) - done - done - -lemma FVars_subset: "valid_P p \ set4_FTerm_pre y \ PFVars_2 p = {} \ - (\t pu p. valid_P p \ (t, pu) \ set5_FTerm_pre y \ set6_FTerm_pre y \ FVars (pu p) \ FVars t \ PFVars_2 p) \ - FVars (Uctor y p) \ FVars (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) \ PFVars_2 p" - apply (frule iffD1[OF meta_eq_to_obj_eq[OF valid_P_def]]) - apply (unfold case_prod_beta) - apply (erule conjE)+ - subgoal premises prems - apply (unfold Uctor_def case_prod_beta) - 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 PFVars_2_def case_prod_beta IImsupp_FTerm2_def SSupp_FTerm_def image_comp[unfolded comp_def])[1] - apply (rule UnI2) - apply (rule UN_I) - apply (rule CollectI) - apply assumption - apply assumption - apply (unfold if_not_P) - apply (erule thin_rl) - - apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) - apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ - apply (unfold FTerm.FVars_ctor prod.collapse) - apply (subst FTerm_pre.set_map, (rule bij_id supp_id_bound)+)+ - apply (unfold image_id image_comp comp_def prod.collapse) - apply (rule Un_mono')+ - apply (unfold FTerm_pre.set_Vrs) - apply (tactic \EqSubst.eqsubst_tac @{context} [0] Vrs_Sb 1\) - apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ - apply (unfold PFVars_2_def case_prod_beta IImsupp_FTerm2_def SSupp_FType_def - tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric] comp_def - )[1] - apply (rule subsetI) - apply (erule UN_E) - apply (rule UnI1) - apply (tactic \Local_Defs.unfold0_tac @{context} Vrs_Injs\) - apply (drule singletonD) - apply hypsubst - apply assumption - - apply (subst FTerm_pre.set_Sb) - apply (rule FTerm_pre.SSupp_Inj_bound prems(4,5)[THEN ordLess_ordLeq_trans] cmin1 cmin2 card_of_Card_order)+ - 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 (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* repeated *) - apply (rule subset_If) - apply (tactic \Local_Defs.unfold0_tac @{context} (#Supp_Sb param)\) - apply (unfold UN_empty')[1] - apply (rule empty_subsetI) - apply (rule UN_mono[OF subset_refl]) - apply (rule prems) - apply (rule prems) - apply (unfold prod.collapse) - apply (erule UnI2 UnI1) - (* END REPEAT_DETERM *) - done - done - -lemma permute_Uctor: - fixes f1::"'tv::var \ 'tv" and f2::"'v::var \ 'v" - shows "valid_P p \ bij f1 \ |supp f1| bij f2 \ |supp f2| permute_FTerm f1 f2 (Uctor y p) = Uctor (map_FTerm_pre f1 f2 f1 f2 - (\(t, pu). (permute_FTerm f1 f2 t, \p. if valid_P p then permute_FTerm f1 f2 (pu (Pmap (inv f1) (inv f2) p)) else undefined)) - (\(t, pu). (permute_FTerm f1 f2 t, \p. if valid_P p then permute_FTerm f1 f2 (pu (Pmap (inv f1) (inv f2) p)) else undefined)) - y) (Pmap f1 f2 p)" - apply (frule iffD1[OF meta_eq_to_obj_eq[OF valid_P_def]]) - apply (subst (asm) case_prod_beta) - apply (erule conjE)+ - apply (unfold Uctor_def) - apply (subst FTerm_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] fst_o_f comp_assoc comp_def[of snd] snd_conv case_prod_beta prod.collapse) - apply (subst FTerm_pre.map_comp[symmetric], (assumption | rule supp_id_bound bij_id ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ - apply (subst FTerm.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 (erule subst[OF sym]) - apply (subst permute_VVr) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - apply (unfold Pmap_def case_prod_beta fst_conv snd_conv asVVr_VVr compSS_FTerm_def comp_def)[1] - apply (subst inv_simp1) - apply assumption - apply (rule refl) - - apply (rule trans) - apply (rule FTerm.permute_ctor) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - - apply (tactic \EqSubst.eqsubst_tac @{context} [0] [Map_Sb'] 1\) - apply (rule FTerm_pre.SSupp_Inj_bound cmin1 cmin2 card_of_Card_order - | erule ordLess_ordLeq_trans)+ - - apply (subst FTerm_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 (subst if_P inv_o_simp1 trans[OF comp_apply[symmetric] Pmap_comp0[THEN fun_cong]], (rule valid_Pmap bij_imp_bij_inv supp_inv_bound | assumption)+)+ - apply (unfold trans[OF Pmap_id0[THEN fun_cong] id_apply]) - apply (unfold Pmap_def case_prod_beta snd_conv compSS_FType_def) - - apply (subst trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]]) - apply (assumption | rule cmin1 cmin2 card_of_Card_order FTerm_pre.SSupp_Inj_bound | erule ordLess_ordLeq_trans)+ - apply (unfold id_o o_id inv_o_simp2) - apply (subst FType.vvsubst_permute, (assumption | rule cmin1 cmin2 card_of_Card_order FTerm_pre.SSupp_Inj_bound | erule ordLess_ordLeq_trans)+) - apply (unfold comp_def BNF_Composition.id_bnf_def inv_simp2 id_def) - apply (rule refl) - done - -ML \ -val nvars: int = 2 - -val parameters = { - P = @{typ "('tv::var, 'v::var) P"}, - Pmap = @{term "Pmap :: _ \ _ \ _ \ ('tv::var, 'v::var) P"}, - PFVarss = [ - @{term "PFVars_1 :: ('tv::var, 'v::var) P \ _"}, - @{term "PFVars_2 :: ('tv::var, 'v::var) P \ _"} - ], - avoiding_sets = [@{term "{} :: 'tv::var set"}, @{term "{} :: 'v::var set"}], - min_bound = true, - validity = SOME { - pred = @{term "valid_P :: ('tv::var, 'v::var) P \ _"}, - valid_Pmap = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms valid_Pmap} THEN_ALL_NEW assume_tac ctxt) - }, - axioms = { - Pmap_id0 = fn ctxt => EVERY1 [ - resolve_tac ctxt [trans], - resolve_tac ctxt @{thms fun_cong[OF Pmap_id0]}, - resolve_tac ctxt @{thms id_apply} - ], - Pmap_comp0 = fn ctxt => resolve_tac ctxt @{thms fun_cong[OF Pmap_comp0[symmetric]]} 1 THEN REPEAT_DETERM (assume_tac ctxt 1), - Pmap_cong_id = fn ctxt => resolve_tac ctxt @{thms Pmap_cong_id} 1 THEN REPEAT_DETERM (assume_tac ctxt 1 ORELSE Goal.assume_rule_tac ctxt 1), - PFVars_Pmaps = replicate nvars (fn ctxt => resolve_tac ctxt @{thms PFVars_Pmaps} 1 THEN REPEAT_DETERM (assume_tac ctxt 1)), - small_PFVarss = replicate nvars (fn ctxt => resolve_tac ctxt @{thms small_PFVarss} 1 THEN assume_tac ctxt 1), - small_avoiding_sets = replicate nvars (fn ctxt => HEADGOAL (resolve_tac ctxt @{thms cmin_greater} - THEN_ALL_NEW resolve_tac ctxt @{thms card_of_Card_order emp_bound})) - } -} : (Proof.context -> tactic) MRBNF_Recursor.parameter; -\ - -ML \ -val fp_res = the (MRBNF_FP_Def_Sugar.fp_result_of @{context} "BMV_Fixpoint.FTerm") -val quot = hd (#quotient_fps fp_res); -val vars = map TVar (rev (Term.add_tvarsT (#T quot) [])); -\ - -ML \ -val model = MRBNF_Recursor.mk_quotient_model quot (vars ~~ [@{typ "'tv::var"}, @{typ "'v::var"}]) [] { - binding = @{binding "tvsubst_FTerm"}, - Uctor = @{term "Uctor :: _ \ ('tv::var, 'v::var) P \ _"}, - validity = NONE, - axioms = { - FVars_subsets = [ - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Un_empty_right}), - resolve_tac ctxt @{thms FTVars_subset}, - REPEAT_DETERM o assume_tac ctxt, - Goal.assume_rule_tac ctxt - ], - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Un_empty_right}), - resolve_tac ctxt @{thms FVars_subset}, - REPEAT_DETERM o assume_tac ctxt, - Goal.assume_rule_tac ctxt - ] - ], - permute_Uctor = fn ctxt => HEADGOAL (resolve_tac ctxt @{thms permute_Uctor} THEN_ALL_NEW assume_tac ctxt) - } -} -\ - -local_setup \fn lthy => -let - val qualify = I - val (ress, lthy) = MRBNF_Recursor.create_binding_recursor qualify fp_res parameters [model] lthy - - val notes = - [ ("rec_Uctor", map (Local_Defs.unfold0 lthy @{thms Un_empty_right} o #rec_Uctor) ress) - ] |> (map (fn (thmN, thms) => - ((Binding.qualify true "FTerm" (Binding.name thmN), []), [(thms, [])]) - )); - val (_, lthy) = Local_Theory.notes notes lthy - val _ = @{print} ress -in lthy end -\ -print_theorems - -definition tvsubst_FTerm :: "('v \ ('tv::var, 'v::var) FTerm) \ ('tv \ 'tv FType) \ ('tv, 'v) FTerm \ ('tv, 'v) FTerm" where - "tvsubst_FTerm f1 f2 t \ ff0_tvsubst_FTerm t (f1, f2)" +*) type_synonym ('tv, 'v) U1_pre = "('tv, 'v, 'tv, 'v, ('tv, 'v) FTerm, ('tv, 'v) FTerm) FTerm_pre" @@ -929,55 +456,262 @@ lemma eta_set_empties: done done -lemma tvsubst_VVr: - assumes - "|SSupp_FTerm f1| ('tyvar::var, 'var) FTerm" and f2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr f1| (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2)" + "IImsupp_FTerm2 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 (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound f_prems card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs cmin_greater + var_class.UN_bound f_prems[THEN ordLess_ordLeq_trans] cmin1 cmin2 + )+)+ + + subgoal for g1 g2 y + apply (subst 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 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 | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] | rule card_of_Card_order supp_id_bound bij_id)+)+ + apply (subst FTerm.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) + 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) + apply (rule subsetI) + apply (assumption | erule UnI1 UnI2 | rule UnI1)+ + + apply (rule trans) + apply (rule FTerm.permute_ctor) + apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + + apply (subst trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]]) + apply (assumption | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] + | rule card_of_Card_order supp_id_bound bij_id f_prems[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2])+ + 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 | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] + | rule supp_id_bound card_of_Card_order supp_inv_bound SSupp_comp_bound infinite_UNIV FType.SSupp_map_bound + f_prems[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] + | (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 (unfold IImsupp_FType_def comp_def SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def + IImsupp_def SSupp_def VVr_def TyVar_def + )[1] + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+) + apply (rule subsetI) + apply (erule UN_E) + apply (rule case_split[of "_ = _", rotated]) + apply (unfold IImsupp_def SSupp_def)[1] + apply (rule UnI2)+ + apply (rule UN_I) + apply (rule CollectI) + apply assumption + apply assumption + 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 UnI2) + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+) + 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 FTerm.rec_Uctor) - apply (unfold valid_P_def prod.case) - apply (rule conjI assms)+ - apply (unfold eta_set_empties noclash_FTerm_def Uctor_def Un_empty prod.case) + 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) - apply (rule trans) - apply (rule if_P) - apply (unfold isVVr_def VVr_def comp_def ) + 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 (unfold meta_eq_to_obj_eq[OF VVr_def, THEN fun_cong, unfolded comp_def, symmetric] asVVr_VVr) apply (rule refl) done -lemma tvsubst_FTerm_no_is_VVr: - fixes x::"('tv::var, 'v::var) U1_pre" - assumes f_prems: "|SSupp_FTerm f1| (IImsupp_FTerm1 f1 \ IImsupp_FType f2) = {}" "set4_FTerm_pre x \ IImsupp_FTerm2 f1 = {}" - and noclash: "noclash_FTerm x" - and VVr_prems: "\isVVr (FTerm_ctor x)" - shows - "tvsubst_FTerm f1 f2 (FTerm_ctor x) = FTerm_ctor (Sb_FTerm_pre id f2 (map_FTerm_pre id id id id (tvsubst_FTerm f1 f2) (tvsubst_FTerm f1 f2) x))" +lemma tvsubst_FTerm_not_is_VVr: + assumes empty_prems: "set3_FTerm_pre x \ (IImsupp_FTerm1 f1 \ (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2)) = {}" "set4_FTerm_pre x \ IImsupp_FTerm2 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 (subgoal_tac "valid_P (f1, f2)") - prefer 2 - apply (unfold valid_P_def prod.case)[1] - apply (rule conjI f_prems)+ apply (rule trans) - apply (rule FTerm.rec_Uctor) - apply assumption - apply (unfold PFVars_1_def PFVars_2_def prod.case) - apply (rule empty_prems noclash)+ - apply (unfold Uctor_def prod.case) + 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] fst_conv id_def[symmetric] FTerm_pre.map_id) - apply (subst if_not_P, rule VVr_prems)+ - apply (unfold comp_def snd_conv if_P) - apply (rule refl) + 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 + (* Sugar theorems for substitution *) definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl a))" @@ -992,20 +726,20 @@ definition TyLam :: "'tv \ ('tv, 'v) FTerm \ ('tv::var, lemma FTerm_subst: fixes f1::"'v \ ('tv::var, 'v::var) FTerm" and f2::"'tv \ 'tv FType" - assumes "|SSupp_FTerm 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 \ IImsupp_FType f2 \ tvsubst_FTerm f1 f2 (TyLam a t) = TyLam a (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_FTerm_no_is_VVr) + apply (rule tvsubst_FTerm_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 @@ -1026,7 +760,7 @@ lemma FTerm_subst: apply (rule refl) apply (rule trans) - apply (rule tvsubst_FTerm_no_is_VVr) + apply (rule tvsubst_FTerm_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 @@ -1048,7 +782,7 @@ lemma FTerm_subst: apply (rule refl) apply (rule trans) - apply (rule tvsubst_FTerm_no_is_VVr) + apply (rule tvsubst_FTerm_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 @@ -1070,7 +804,7 @@ lemma FTerm_subst: apply (rule refl) apply (rule trans) - apply (rule tvsubst_FTerm_no_is_VVr) + apply (rule tvsubst_FTerm_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 From bdfe1b60aad1bb3930e7278e6c4b30c498dc665d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 1 Jul 2025 21:22:35 +0100 Subject: [PATCH 42/90] Adjust bmv composition operations theory for minimum UNIV bound --- Tools/bmv_monad_def.ML | 194 ++++++++------ Tools/mrbnf_fp.ML | 3 +- Tools/mrbnf_fp_def_sugar.ML | 5 +- operations/BMV_Composition.thy | 150 ++++++----- operations/BMV_Fixpoint.thy | 142 ++++------ operations/BMV_Monad.thy | 469 --------------------------------- 6 files changed, 263 insertions(+), 700 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index ace39f89..1d25dde0 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -25,11 +25,13 @@ signature BMV_MONAD_DEF = sig SSupp_Map_subsets: thm list option, SSupp_Map_bounds: thm list option, SSupp_Sb_subsets: thm list, - SSupp_Sb_bounds: thm list + SSupp_Sb_bounds: thm list, + SSupp_Inj_bound: thm }; - type bmv_monad_consts = { + type 'a bmv_monad_consts = { bd: term, + UNIV_bds: 'a list, Sbs: term list, RVrs: term list list, Injs: term list list, @@ -45,7 +47,7 @@ signature BMV_MONAD_DEF = sig Map_Injs: 'a list }; - type 'a bmv_monad_model = { + type ('a, 'b) bmv_monad_model = { ops: typ list, var_class: class, bmv_ops: bmv_monad list, @@ -54,7 +56,7 @@ signature BMV_MONAD_DEF = sig leader: int, lives: typ list list, lives': typ list list, - consts: bmv_monad_consts, + consts: 'b bmv_monad_consts, params: 'a bmv_monad_param option list, bd_infinite_regular_card_order: 'a, tacs: 'a bmv_monad_axioms list @@ -70,6 +72,7 @@ signature BMV_MONAD_DEF = sig 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 UNIV_bds_of_bmv_monad: bmv_monad -> term 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; @@ -95,7 +98,7 @@ signature BMV_MONAD_DEF = sig 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 -> local_theory -> (bmv_monad * thm list) * local_theory + -> (binding -> binding) -> binding option -> (Proof.context -> tactic, term option) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory datatype var_type = Dead_Var | Free_Var | Live_Var; @@ -173,16 +176,18 @@ type bmv_monad_facts = { SSupp_Map_subsets: thm list option, SSupp_Map_bounds: thm list option, SSupp_Sb_subsets: thm list, - SSupp_Sb_bounds: thm list + SSupp_Sb_bounds: thm list, + SSupp_Inj_bound: thm }; -fun morph_bmv_monad_facts phi { Inj_inj, Supp_Injss, SSupp_Map_subsets, SSupp_Map_bounds, SSupp_Sb_subsets, SSupp_Sb_bounds } = { +fun morph_bmv_monad_facts phi { Inj_inj, Supp_Injss, SSupp_Map_subsets, SSupp_Map_bounds, SSupp_Sb_subsets, SSupp_Sb_bounds, SSupp_Inj_bound } = { 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, SSupp_Sb_subsets = map (Morphism.thm phi) SSupp_Sb_subsets, - SSupp_Sb_bounds = map (Morphism.thm phi) SSupp_Sb_bounds + SSupp_Sb_bounds = map (Morphism.thm phi) SSupp_Sb_bounds, + SSupp_Inj_bound = Morphism.thm phi SSupp_Inj_bound }: bmv_monad_facts; type 'a supported_functor_axioms = { @@ -218,8 +223,9 @@ fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Vrs_Map, Map_Injs }: 'a bm }: 'b bmv_monad_param; -type bmv_monad_consts = { +type 'a bmv_monad_consts = { bd: term, + UNIV_bds: 'a list, Sbs: term list, RVrs: term list list, Injs: term list list, @@ -227,8 +233,9 @@ type bmv_monad_consts = { params: { Map: term, Supps: term list} option list }; -fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs } = { +fun morph_bmv_monad_consts f phi { bd, params, Injs, Sbs, Vrs, RVrs, UNIV_bds } = { bd = Morphism.term phi bd, + UNIV_bds = map f UNIV_bds, RVrs = map (map (Morphism.term phi)) RVrs, params = map (Option.map (fn { Map, Supps } => { Map = Morphism.term phi Map, @@ -237,7 +244,7 @@ fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs } = { Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (Morphism.term phi)) Vrs -}: bmv_monad_consts; +}: 'a bmv_monad_consts; datatype bmv_monad = BMV of { ops: typ list, @@ -247,7 +254,7 @@ datatype bmv_monad = BMV of { lives: typ list list, lives': typ list list, deads: typ list list, - consts: bmv_monad_consts, + consts: term bmv_monad_consts, params: thm bmv_monad_param option list, bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list, @@ -266,7 +273,7 @@ fun morph_bmv_monad phi (BMV { 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, + consts = morph_bmv_monad_consts (Morphism.term phi) 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, @@ -285,6 +292,7 @@ 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 UNIV_bds_of_bmv_monad = #UNIV_bds 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 @@ -299,14 +307,14 @@ val unfolds_of_bmv_monad = #unfolds o Rep_bmv fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) -type 'a bmv_monad_model = { +type ('a, 'b) 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, + consts: 'b bmv_monad_consts, params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, leader: int, @@ -314,7 +322,7 @@ type 'a bmv_monad_model = { tacs: 'a bmv_monad_axioms list } -fun morph_bmv_monad_model phi f ({ ops, var_class, frees, lives, lives', consts, bmv_ops, leader, +fun morph_bmv_monad_model phi f g ({ ops, var_class, frees, lives, lives', consts, bmv_ops, leader, params, tacs, bd_infinite_regular_card_order, deads } ) = { ops = map (Morphism.typ phi) ops, @@ -323,15 +331,15 @@ fun morph_bmv_monad_model phi f ({ ops, var_class, frees, lives, lives', consts, 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, + consts = morph_bmv_monad_consts g 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 -} : 'b bmv_monad_model; +} : ('a, 'b) bmv_monad_model; -fun update_consts consts (model: 'a bmv_monad_model) = { +fun update_consts (consts: term bmv_monad_consts) (model: ('a, 'b) bmv_monad_model) = { ops = #ops model, var_class = #var_class model, frees = #frees model, @@ -344,7 +352,7 @@ fun update_consts consts (model: 'a bmv_monad_model) = { leader = #leader model, tacs = #tacs model, bd_infinite_regular_card_order = #bd_infinite_regular_card_order model -}: 'a bmv_monad_model; +}: ('a, term) bmv_monad_model; structure Data = Generic_Data ( type T = bmv_monad Symtab.table; @@ -362,11 +370,12 @@ fun pbmv_monad_of_generic context = val pbmv_monad_of = pbmv_monad_of_generic o Context.Proof; -fun mk_small_prems fs rhos Injs = map (HOLogic.mk_Trueprop o mk_supp_bound) fs - @ map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (MRBNF_Util.mk_SSupp Inj $ rho)) - (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of rho)))) -)) rhos Injs; +fun mk_small_prems fs rhos Injs UNIV_bd = + map (HOLogic.mk_Trueprop o mk_supp_bound) fs + @ map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (MRBNF_Util.mk_SSupp Inj $ rho)) + UNIV_bd + )) rhos Injs; fun mk_bmv_monad_axioms ops consts bmv_ops lthy = let @@ -376,7 +385,7 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = val RVrss = #RVrs consts @ maps RVrs_of_bmv_monad bmv_ops; val Vrss = #Vrs consts @ maps Vrs_of_bmv_monad bmv_ops; - val axioms = @{map 5} (fn T => fn Injs => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => + val axioms = @{map 6} (fn T => fn Injs => fn UNIV_bds => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => 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; @@ -396,8 +405,8 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, f_ids @ Injs), HOLogic.id_const T); - val small_prems = mk_small_prems fs rhos Injs; - val small_prems' = mk_small_prems gs rhos' Injs; + val small_prems = mk_small_prems fs rhos Injs UNIV_bds; + val small_prems' = mk_small_prems gs rhos' Injs UNIV_bds; 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 ( @@ -499,10 +508,10 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong } : term bmv_monad_axioms end - ) ops (#Injs consts) (#Sbs consts) (#Vrs consts) (#RVrs consts); + ) ops (#Injs consts) (#UNIV_bds consts) (#Sbs consts) (#Vrs consts) (#RVrs consts); in axioms end; -fun mk_param_axiom Map Supps Sb Injs RVrs Vrs bd params lthy = +fun mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd params lthy = let val (f_Ts, T) = split_last (binder_types (fastype_of Map)); val (lives, lives') = split_list (map dest_funT f_Ts); @@ -558,7 +567,7 @@ fun mk_param_axiom Map Supps Sb Injs RVrs Vrs bd params lthy = ))); val Map_Sb = fold_rev Logic.all (fs @ hs @ rhos) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs) (mk_Trueprop_eq ( + fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs UNIV_bds) (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 => @@ -584,7 +593,7 @@ fun mk_param_axiom Map Supps Sb Injs RVrs Vrs bd params lthy = ) (RVrs @ Vrs); val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ hs @ [x]) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs) (mk_Trueprop_eq ( + fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs UNIV_bds) (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, ... } => @@ -644,7 +653,7 @@ fun maybe_define const_policy fact_policy b rhs lthy = 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 const_policy fact_policy qualify leader ops lives' (consts: bmv_monad_consts) lthy = +fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees lives' (consts: term option bmv_monad_consts) lthy = let val maybe_define' = maybe_define const_policy fact_policy o qualify; @@ -697,14 +706,19 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops lives' ( val ((bd, bd_def), lthy) = maybe_define' (Binding.name "bd") (#bd consts) lthy; + val UNIV_bds = map2 (fn SOME t => K t | NONE => + foldl1 mk_cmin o map (mk_card_of o HOLogic.mk_UNIV) + ) (#UNIV_bds consts) frees; + val consts' = { bd = bd, params = params, Injs = Injs, Sbs = Sbs, + UNIV_bds = UNIV_bds, RVrs = RVrs, Vrs = Vrs - } : bmv_monad_consts; + } : term bmv_monad_consts; val (lthy, old_lthy) = `Local_Theory.end_nested lthy; val phi = Proof_Context.export_morphism old_lthy lthy; @@ -713,7 +727,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops 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 consts' = morph_bmv_monad_consts (Morphism.term phi') phi' consts'; val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ RVrs_defs @ [bd_def] @ flat param_defs); in (consts', map (Morphism.thm phi) defs, lthy) end; @@ -756,7 +770,8 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("SSupp_Map_subset", maps (the_default [] o #SSupp_Map_subsets) facts, []), ("SSupp_Map_bound", maps (the_default [] o #SSupp_Map_bounds) facts, []), ("SSupp_Sb_subset", maps #SSupp_Sb_subsets facts, []), - ("SSupp_Sb_bound", maps #SSupp_Sb_bounds facts, []) + ("SSupp_Sb_bound", maps #SSupp_Sb_bounds facts, []), + ("SSupp_Inj_bound", map #SSupp_Inj_bound facts, []) ] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((Binding.qualify true (bmv_name ()) (Binding.name thmN), attrs), [ @@ -768,16 +783,17 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv 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 lthy = +fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: (thm, term) bmv_monad_model) unfolds 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), + UNIV_bds = #UNIV_bds (#consts model) @ maps (#UNIV_bds 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) - }: bmv_monad_consts; + }: term bmv_monad_consts; val axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model); val names = map (fst o dest_Free); @@ -797,8 +813,10 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona )) (#Injs (#consts model)) (#Vrs (#consts model)); val Un_bound = MRBNF_Def.get_class_assumption [#var_class model] "Un_bound" lthy; + val UNIV_cinfinite = MRBNF_Def.get_class_assumption [#var_class model] "UNIV_cinfinite" lthy; val Injss = #Injs (#consts model); + val UNIV_bds = #UNIV_bds (#consts model); val (((rhoss, hss), fss), names_lthy) = lthy |> mk_Freess "\" (map (map fastype_of) Injss) @@ -836,14 +854,9 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona ])) end else NONE ) Injs) Supps)) (#lives model) (#lives' model) (#params model) Injss (#params (#consts model)) - val SSupp_premss = @{map 3} (fn Injs => fn rhos => fn hs => - map (HOLogic.mk_Trueprop o mk_supp_bound) hs @ - map2 (fn Inj => fn rho => HOLogic.mk_Trueprop ( - mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj)))) - )) Injs rhos - ) Injss rhoss hss; + val SSupp_premss = @{map 4} mk_small_prems hss rhoss Injss UNIV_bds; - val SSupp_thms = @{map 12} (fn params => fn param_consts => fn axioms => fn T => fn SSupp_prems => fn lives => fn lives' => fn fs => fn Injs => fn rhos => fn hs => fn Sb => + val SSupp_thms = @{map 14} (fn params => fn param_consts => fn axioms => fn T => fn SSupp_prems => fn lives => fn lives' => fn frees => fn fs => fn Injs => fn UNIV_bd => fn rhos => fn hs => fn Sb => let 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 @@ -894,28 +907,38 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona let val (rho, _) = names_lthy |> apfst hd o mk_Frees "\'" [fastype_of Inj]; - val card = mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of Inj))); - val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (mk_SSupp Inj $ rho)) card - ); + val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) UNIV_bd); val goal = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ HOLogic.mk_comp ( Term.list_comb (Sb, hs @ rhos), rho - ))) card + ))) UNIV_bd ); 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 (Un_bound :: prems) + REPEAT_DETERM o resolve_tac ctxt ([UNIV_cinfinite] @ + @{thms Un_Cinfinite_ordLess cmin_Cinfinite card_of_Card_order} @ prems @ @{thms conjI} + ) ])) end ) Injs; + + val SSupp_Inj_bound = + let + val Inj = Free ("Inj", @{typ "'a \ 'b"}); + val goal = HOLogic.mk_Trueprop (mk_ordLess + (mk_card_of (mk_SSupp Inj $ Inj)) + UNIV_bd + ) in Goal.prove_sorry lthy (names [Inj]) [] goal (fn {context=ctxt, ...} => EVERY1 [ + REPEAT_DETERM o resolve_tac ctxt @{thms cmin_Card_order card_of_Card_order SSupp_Inj_bound cmin_greater} + ]) end; in { SSupp_Map_subsets = SSupp_Map_subsets, SSupp_Map_bounds = SSupp_Map_bounds, SSupp_Sb_subsets = SSupp_Sb_subsets, - SSupp_Sb_bounds = SSupp_Sb_bounds + SSupp_Sb_bounds = SSupp_Sb_bounds, + SSupp_Inj_bound = SSupp_Inj_bound } end - ) (#params model) (#params (#consts model)) (#tacs model) (#ops model) SSupp_premss (#lives model) (#lives' model) fss Injss rhoss hss (#Sbs (#consts model)); + ) (#params model) (#params (#consts model)) (#tacs model) (#ops model) SSupp_premss (#lives model) (#lives' model) (#frees model) fss Injss UNIV_bds rhoss hss (#Sbs (#consts model)); val facts = @{map 3} (fn Inj_inj => fn SSupp_thms => fn Supp_Injss => { Inj_inj = Inj_inj, @@ -923,7 +946,8 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona SSupp_Map_subsets = #SSupp_Map_subsets SSupp_thms, SSupp_Map_bounds = #SSupp_Map_bounds SSupp_thms, SSupp_Sb_subsets = #SSupp_Sb_subsets SSupp_thms, - SSupp_Sb_bounds = #SSupp_Sb_bounds SSupp_thms + SSupp_Sb_bounds = #SSupp_Sb_bounds SSupp_thms, + SSupp_Inj_bound = #SSupp_Inj_bound SSupp_thms }: bmv_monad_facts) Inj_injs SSupp_thms Supp_Injss; val bmv = BMV { @@ -945,7 +969,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 = +fun prove_axioms (model: (Proof.context -> tactic, term) 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); @@ -955,11 +979,11 @@ fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = ) end; -fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = +fun prove_params (model: (Proof.context -> tactic, term) bmv_monad_model) defs lthy = let - val goals = @{map 5} (fn Sb => fn RVrs => fn Vrs => fn Injs => Option.map (fn param => - mk_param_axiom (#Map param) (#Supps param) Sb Injs RVrs Vrs (#bd (#consts 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)) (#Injs (#consts model)) (#params (#consts model)) + val goals = @{map 6} (fn Sb => fn RVrs => fn Vrs => fn Injs => fn UNIV_bds => Option.map (fn param => + mk_param_axiom (#Map param) (#Supps param) Sb Injs UNIV_bds RVrs Vrs (#bd (#consts 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)) (#Injs (#consts model)) (#UNIV_bds (#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 @@ -981,7 +1005,7 @@ fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = } } : thm bmv_monad_param)) tacs' goals end; -fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { +fun mk_thm_model (model: ('a, term) bmv_monad_model) params axioms bd_irco = { ops = #ops model, var_class = #var_class model, leader = #leader model, @@ -994,17 +1018,18 @@ fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { params = params, bd_infinite_regular_card_order = bd_irco, tacs = axioms -} : thm bmv_monad_model; +} : (thm, term) bmv_monad_model; -fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.context -> tactic) bmv_monad_model) lthy = +fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.context -> tactic, term option) bmv_monad_model) 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 model = morph_bmv_monad_model (MRBNF_Util.subst_typ_morphism (nth (#frees model) (#leader model) ~~ frees)) I model; + val phi = MRBNF_Util.subst_typ_morphism (nth (#frees model) (#leader model) ~~ frees); + val model = morph_bmv_monad_model phi I (Option.map (Morphism.term phi)) model; val (consts, unfold_set, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify - (#leader model) (#ops model) (#lives' model) (#consts model) lthy; + (#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; @@ -1062,6 +1087,7 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = consts = { bd = MRBNF_Def.bd_of_mrbnf mrbnf, Injs = [[]], + UNIV_bds = [NONE], Sbs = [Sb], Vrs = [[]], RVrs = [fsets], @@ -1170,6 +1196,7 @@ fun slice_bmv_monad n bmv = Map = Map, Supps = Supps }) (f (Maps_of_bmv_monad bmv)) (f (Supps_of_bmv_monad bmv))], Injs = [f (Injs_of_bmv_monad bmv)], + UNIV_bds = [f (UNIV_bds_of_bmv_monad bmv)], Sbs = [Sb], RVrs = [f (RVrs_of_bmv_monad bmv)], Vrs = [f (Vrs_of_bmv_monad bmv)] @@ -1182,7 +1209,7 @@ fun slice_bmv_monad n bmv = } end; fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives, frees=dfrees } lthy = - let + (*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)) @@ -1440,11 +1467,12 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives (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 +*) error "demote" 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 + (*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) @@ -1980,7 +2008,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 lthy - in (res, lthy) end; + in (res, lthy) end;*) in error "compose" end fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = let @@ -2055,8 +2083,9 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = Sbs = [fst Sb], Vrs = [map fst Vrs], RVrs = [map fst RVrs], + UNIV_bds = [SOME (leader UNIV_bds_of_bmv_monad bmv)], params = [Option.map (fn Map => { Map = fst Map, Supps = map fst (the Supps_opt) }) Map_opt] - }: bmv_monad_consts; + }: term option bmv_monad_consts; val axioms = leader axioms_of_bmv_monad bmv; val params = leader params_of_bmv_monad bmv; @@ -2217,14 +2246,14 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ] ] }] - } : (Proof.context -> tactic) bmv_monad_model; + } : (Proof.context -> tactic, term option) bmv_monad_model; val ((bmv, _), lthy) = bmv_monad_def BNF_Def.Hardly_Inline (K BNF_Def.Note_Some) qualify NONE model lthy; val new_unfolds = map (Local_Defs.unfold0 lthy unfolds) defs; in ((bmv, new_unfolds, defs, (T_name, info)), lthy) end -fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = +fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV_bds) lthy = let val b = fst (hd b_ops); val (opss, bmv_ops) = split_list (map_index (fn (i, (b, s)) => @@ -2388,20 +2417,30 @@ fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = Supps = map (Term.subst_atomic_types subst) Supps })) param_consts; + val UNIV_bds = @{map 3} (fn deads => fn frees => fn s => if s = "_" then NONE else + let + val t = Syntax.read_term lthy s; + val t = Term.map_types (Term.map_atyps (fn T as TFree (x, _) => + the_default T (List.find (curry (op=) x o fst o dest_TFree) (frees @ deads)) + | _ => raise Same.SAME)) t; + in SOME t end + ) deadss frees (UNIV_bds @ replicate (length ops - length UNIV_bds) "_"); + val consts = { bd = bd, Injs = Injs, Sbs = Sbs, Vrs = Vrs, + UNIV_bds = UNIV_bds, RVrs = RVrs, params = param_consts - }: bmv_monad_consts; + }: term option bmv_monad_consts; val (consts, bmv_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 - ops lives' consts lthy; + ops frees lives' consts lthy; - val param_goals = @{map 5} (fn Sb => fn Injs => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => - mk_param_axiom Map Supps Sb Injs RVrs Vrs bd (map_filter I (#params consts @ maps (#params o consts_of_bmv_monad) bmv_ops)) lthy - )) (#Sbs consts) (#Injs consts) (#RVrs consts) (#Vrs consts) (#params consts); + val param_goals = @{map 6} (fn Sb => fn Injs => fn UNIV_bds => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => + mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd (map_filter I (#params consts @ maps (#params o consts_of_bmv_monad) bmv_ops)) lthy + )) (#Sbs consts) (#Injs consts) (#UNIV_bds consts) (#RVrs consts) (#Vrs consts) (#params consts); val goals = mk_bmv_monad_axioms ops consts bmv_ops lthy; @@ -2468,7 +2507,7 @@ fun pbmv_monad_cmd ((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd) lthy = params = params, bd_infinite_regular_card_order = bd_irco, tacs = axioms - } : thm bmv_monad_model; + } : (thm, term) 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 lthy; @@ -2542,7 +2581,8 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term) )) ) -- - ((Parse.reserved "bd" -- @{keyword ":"}) |-- Parse.term)) + ((Parse.reserved "bd" -- @{keyword ":"}) |-- Parse.term)) -- + (Scan.optional ((Parse.reserved "UNIV_bd" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.underscore || Parse.term)) []) >> pbmv_monad_cmd) end \ No newline at end of file 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/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index 10217dc8..c12fa4fe 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -4,8 +4,6 @@ theory BMV_Composition "pbmv_monad" :: thy_goal begin -ML_file \../Tools/bmv_monad_def.ML\ - (* live, free, free, live, live, dead, free *) typedecl ('a, 'b, 'c, 'd, 'e, 'f, 'g) T1 (* dead, free, dead, free *) @@ -48,6 +46,8 @@ 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" +ML_file \../Tools/bmv_monad_def.ML\ + ML \ Multithreading.parallel_proofs := 0 \ @@ -101,6 +101,28 @@ 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}); \ +lemma cminE: + assumes "A A R" + shows R +proof (cases "r1 r f1 \1 \2 \4. Sb_T3 \1 \2 Inj_2_T3 \4 \ Map_T3 f1 id" and Sb_T4 @@ -110,27 +132,31 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" Maps: "Map_T3 id" Supps: set_2_T3 bd: natLeq + UNIV_bd: "cmin (cmin (cmin |UNIV::'a set| |UNIV::'b set| ) |UNIV::'c set| ) |UNIV::'d set|" + 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; (assumption | rule SSupp_Inj_bound))+ + + apply (rule T3.Sb_comp_Inj) + apply (erule cmin_smaller_T3' | rule T3.SSupp_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)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_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 SSupp_Inj_bound)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Map_bound T3.SSupp_Inj_bound)+ apply (rule T3.Map_comp) apply (unfold id_o T3.Map_Inj) - apply (subst T3.Sb_comp_Inj, (assumption | rule SSupp_Inj_bound)+)+ + apply (subst T3.Sb_comp_Inj, (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+)+ apply (rule refl) apply (rule T3.Supp_bd T3.Vrs_bd T3.Vrs_Inj T3.Supp_Inj)+ @@ -138,7 +164,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" subgoal for f \1 \2 \3 x apply (unfold comp_def) apply (subst T3.Supp_Sb) - apply (assumption | rule SSupp_Inj_bound)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Supp_Map T3.Supp_Inj UN_empty2 Un_empty_left Un_empty_right) apply (rule refl) done @@ -146,7 +172,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (assumption | rule SSupp_Inj_bound)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) apply (rule refl) done @@ -155,7 +181,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (assumption | rule SSupp_Inj_bound)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) apply (rule refl) done @@ -164,7 +190,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (assumption | rule SSupp_Inj_bound)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) apply (rule refl) done @@ -175,7 +201,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (assumption | rule refl)+ apply (rule T3.Sb_cong) apply (unfold T3.Vrs_Map) - apply (assumption | rule SSupp_Inj_bound refl)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound refl | assumption)+ done apply (rule refl) apply (rule trans) @@ -193,7 +219,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" 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)+ + apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Map_Inj comp_assoc) apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule trans) @@ -206,7 +232,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" done apply (unfold comp_def)[1] - apply (subst T3.Supp_Sb, (assumption | rule SSupp_Inj_bound)+) + apply (subst T3.Supp_Sb, (erule cmin_smaller_T3' | rule T3.SSupp_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)+ @@ -236,6 +262,24 @@ 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)" +lemma cmin_smaller_T: + "r r r r h1 h2 \1 \2 \3 \4 \5. Sb_T1 h1 \1 Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ Map_T3 h2 id)" @@ -245,6 +289,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and Maps: "\f. Map_T1 id id (Map_T3 id f)" Supps: "\x. \ (set_2_T3 ` set_3_T1 x)" bd: natLeq + UNIV_bd: "cmin (cmin (cmin (cmin |UNIV::'b set| |UNIV::'d set| ) |UNIV::'c set| ) |UNIV::'g set| ) |UNIV::'a set|" 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) @@ -256,7 +301,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule T1.Map_Inj) apply (rule T1.Sb_comp_Inj) - apply (assumption | rule T1.SSupp_Map_bound SSupp_Inj_bound)+ + apply (assumption | rule T1.SSupp_Map_bound T1.SSupp_Inj_bound | erule cmin_smaller_T)+ done subgoal for g1 g2 \'1 \'2 \'3 \'4 \'5 f1 f2 \1 \2 \3 \4 \5 @@ -268,45 +313,27 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule trans) apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) apply (rule T1.Map_Sb) - apply (assumption | rule SSupp_Inj_bound)+ + apply (assumption | rule T1.SSupp_Map_bound T1.SSupp_Inj_bound | erule cmin_smaller_T)+ 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 SSupp_Inj_bound)+ + apply (assumption | rule T1.SSupp_Map_bound T1.SSupp_Inj_bound | erule cmin_smaller_T)+ apply (rule arg_cong2[of _ _ _ _ "(\)"]) apply (rule ext) apply (rule T1.Sb_cong) - apply (unfold comp_assoc T1.Map_Inj id_o o_id) + 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] + T1.Sb_comp_Inj[THEN fun_cong] T1.SSupp_Inj_bound | erule cmin_smaller_T )+ apply (rule ext) apply (rule T1.Map_cong) (* REPEAT for inner *) - apply (rule T2.Sb_comp[THEN fun_cong], assumption+) + apply (rule T2.Sb_comp[THEN fun_cong], (assumption | erule cmin_smaller_T)+) apply (rule refl) - (* repeated *) - apply (rule trans) - apply (rule arg_cong2[OF refl, of _ _ "(\)", THEN fun_cong]) - 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)+ - apply (unfold T3.Map_Inj) - apply (rule trans[OF comp_assoc]) - apply (rule arg_cong2[OF refl, of _ _ "(\)"]) - apply (rule T3.Map_comp) - apply (unfold id_o o_id comp_assoc[symmetric]) - apply (rule arg_cong2[OF _ refl, of _ _ "(\)", THEN fun_cong]) - apply (rule trans) - apply (rule T3.Sb_comp) - apply (assumption | rule T3.SSupp_Map_bound SSupp_Inj_bound)+ - apply (subst T3.Sb_comp_Inj, (assumption | rule SSupp_Inj_bound)+)+ - apply (unfold comp_assoc[symmetric]) - apply (rule refl) + apply (rule T3'.Sb_comp[THEN fun_cong], (assumption | erule cmin_smaller_T)+) done apply (unfold T1.Supp_Inj UN_empty) @@ -315,17 +342,17 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (unfold0 comp_apply)[1] apply (rule trans) apply (rule T1.Vrs_Sb) - apply (assumption | rule SSupp_Inj_bound)+ + apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ 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)+)+ + apply (subst T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ 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)+)+ + apply (subst T3'.Vrs_Sb T2.Vrs_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ apply (unfold Un_assoc[symmetric] Un_Union_image)[1] apply (rule set_eqI) apply (rule iffI) @@ -347,18 +374,18 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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)+ + apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ 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)+)+ + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ 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 (subst T2.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (subst T2.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ apply (unfold UN_UN_flatten UN_Un)[1] apply (rule set_eqI) apply (unfold Un_iff)[1] @@ -379,12 +406,12 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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)+)+ + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ 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'.Vrs_Sb T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ apply (rule set_eqI) apply (unfold Un_iff)[1] apply (rule iffI) @@ -404,12 +431,12 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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)+)+ + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ 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)+)+ + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ apply (unfold UN_Un_distrib)[1] apply (rule set_eqI) apply (unfold Un_iff)[1] @@ -430,12 +457,12 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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)+)+ + apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ 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)+)+ + apply (subst T3'.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ apply (unfold UN_Un_distrib)[1] apply (rule set_eqI) apply (unfold Un_iff)[1] @@ -459,7 +486,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule cong'[OF _ T1.Map_cong, rotated]) (* REPEAT for inners *) apply (rule T2.Sb_cong) - apply (rule prems)+ + apply (rule prems cmin_smaller_T)+ (* REPEAT_DETERM *) apply (drule UN_I) apply assumption @@ -474,7 +501,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule refl) (* third inner *) apply (rule T3'.Sb_cong) - apply (rule prems)+ + apply (rule prems cmin_smaller_T)+ (* REPEAT_DETERM *) apply (drule UN_I) apply assumption @@ -496,8 +523,8 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (assumption | erule UnI1 UnI2 | rule UnI2)+ (* END REPEAT_DETERM *) apply (rule T1.Sb_cong) - apply (unfold T1.Vrs_Map) - apply (rule prems SSupp_Inj_bound refl | assumption| erule UnI1 UnI2 | rule UnI2)+ + apply (unfold T1.Vrs_Map) + apply (rule refl prems SSupp_Inj_bound T1.SSupp_Inj_bound cmin_smaller_T | assumption | erule UnI1 UnI2 | rule UnI2)+ done apply (unfold T3'.Map_id T1.Map_id)[1] @@ -524,18 +551,22 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (unfold comp_assoc[symmetric]) apply (rule trans) apply (rule arg_cong2[OF T1.Map_Sb refl]) - apply (assumption | rule SSupp_Inj_bound)+ - apply (unfold T1.Map_Inj comp_assoc T1.Map_comp id_o o_id T3'.Map_Sb) + apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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 (subst T3'.Map_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+) apply (rule refl) done apply (unfold0 comp_apply)[1] - apply (subst T1.Supp_Sb, (assumption | rule SSupp_Inj_bound)+)+ + apply (subst T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ 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)+)+ + apply (subst T3'.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ apply (unfold UN_Un_distrib)[1] apply (rule set_eqI) apply (unfold Un_iff)[1] @@ -586,6 +617,7 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T Maps: Map_T' Supps: Supp_T' bd: natLeq + UNIV_bd: "cmin (cmin (cmin (cmin |UNIV::'b set| |UNIV::'d set| ) |UNIV::'c set| ) |UNIV::'g set| ) |UNIV::'a set|" apply (unfold SSupp_type_copy[OF type_definition_T'] defs) apply (rule infinite_regular_card_order_natLeq) diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 1a9d15a9..6c4d8829 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -60,6 +60,10 @@ let (* 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 @@ -236,93 +240,6 @@ lemma IImsupp_permute_commute: done done -(*lemma SSupp_natural_FTerm: - fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" - assumes f_prems: "bij f1" "|supp f1| y \ inv f2) = f2 ` SSupp_FTerm y" - apply (unfold SSupp_FTerm_def) - apply (rule set_eqI) - apply (rule iffI) - apply (unfold mem_Collect_eq comp_def VVr_def image_Collect) - apply (erule contrapos_np) - apply (drule Meson.not_exD) - apply (erule allE) - apply (drule iffD1[OF de_Morgan_conj]) - apply (erule disjE) - apply (subst (asm) inv_simp2[of f2]) - apply (rule assms) - apply (erule notE) - apply (rule refl) - apply (drule notnotD) - apply (drule sym) - apply (erule subst) - apply (rule trans) - apply (rule FTerm.permute_ctor) - apply (rule assms)+ - apply (subst fun_cong[OF eta_natural, unfolded comp_def]) - apply (rule assms)+ - apply (subst inv_simp2[of f2]) - apply (rule f_prems) - apply (rule refl) - apply (erule exE) - apply (erule conjE) - apply hypsubst - apply (subst inv_simp1) - apply (rule f_prems) - apply (erule contrapos_nn) - apply (drule arg_cong[of _ _ "permute_FTerm (inv f1) (inv f2)"]) - apply (subst (asm) FTerm.permute_comp) - apply (rule assms supp_inv_bound bij_imp_bij_inv)+ - apply (subst (asm) inv_o_simp1, rule assms)+ - apply (unfold FTerm.permute_id) - apply (erule trans) - apply (rule trans) - apply (rule FTerm.permute_ctor) - apply (rule assms supp_inv_bound bij_imp_bij_inv)+ - apply (subst fun_cong[OF eta_natural, unfolded comp_def]) - apply (rule assms supp_inv_bound bij_imp_bij_inv)+ - apply (subst inv_simp1) - apply (rule assms) - apply (rule refl) - done -lemmas SSupp_naturals = FType.SSupp_natural SSupp_natural_FTerm - -lemma IImsupp_natural_FTerm: - fixes f1::"'tyvar::var \ 'tyvar" and f2::"'var::var \ 'var" - assumes f_prems: "bij f1" "|supp f1| y \ inv f2) = f1 ` IImsupp_FTerm1 y" - "IImsupp_FTerm2 (permute_FTerm f1 f2 \ y \ inv f2) = f2 ` IImsupp_FTerm2 y" - apply (unfold IImsupp_FTerm1_def IImsupp_FTerm2_def image_UN image_Un) - apply (rule arg_cong2[of _ _ _ _ "(\)"])? - apply (subst SSupp_naturals) - apply (rule assms)+ - apply (unfold image_comp comp_assoc)[1] - apply (subst inv_o_simp1, rule assms) - apply (unfold o_id) - apply (unfold comp_def)[1] - apply (subst FTerm.FVars_permute, (rule assms)+) - apply (rule refl) - (* repeated *) - apply (rule arg_cong2[of _ _ _ _ "(\)"])? - apply (subst SSupp_naturals) - apply (rule assms)+ - apply (rule refl) - (* repeated *) - apply (rule arg_cong2[of _ _ _ _ "(\)"])? - apply (subst SSupp_naturals) - apply (rule assms)+ - apply (unfold image_comp comp_assoc)[1] - apply (subst inv_o_simp1, rule assms) - apply (unfold o_id) - apply (unfold comp_def)[1] - apply (subst FTerm.FVars_permute, (rule assms)+) - apply (rule refl) - done -lemmas IImsupp_naturals = FType.IImsupp_natural IImsupp_natural_FTerm -*) - 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] @@ -695,7 +612,7 @@ lemma tvsubst_VVr: "tvsubst_FTerm (VVr a) = f1 a" apply (rule refl) done -lemma tvsubst_FTerm_not_is_VVr: +lemma tvsubst_not_is_VVr: assumes empty_prems: "set3_FTerm_pre x \ (IImsupp_FTerm1 f1 \ (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2)) = {}" "set4_FTerm_pre x \ IImsupp_FTerm2 f1 = {}" and noclash: "noclash_FTerm x" and VVr_prems: "\isVVr (FTerm_ctor x)" @@ -709,9 +626,48 @@ lemma tvsubst_FTerm_not_is_VVr: apply (rule if_not_P) apply (rule assms) done - end +pbmv_monad "('tv, 'v) FTerm" and "'tv FType" + Sbs: tvsubst_FTerm + Injs: VVr TyVar + Vrs: FVars FTVars + bd: natLeq + apply (rule infinite_regular_card_order_natLeq) + + apply (rule ext) + apply (rule trans[rotated]) + apply (rule id_apply[symmetric]) + subgoal for x + apply (rule FTerm.TT_fresh_induct[OF emp_bound emp_bound, of _ x]) + subgoal for x + apply (rule case_split[of "isVVr (FTerm_ctor x)"]) + apply (unfold isVVr_def)[1] + apply (erule exE) + apply (rotate_tac -1) + apply (erule subst[OF sym]) + apply (rule tvsubst_VVr) + apply (rule SSupp_Inj_bound cmin_greater card_of_Card_order)+ + apply (rule trans) + apply (rule tvsubst_not_is_VVr) + apply (rule SSupp_Inj_bound cmin_greater card_of_Card_order)+ + apply (unfold IImsupp_def SSupp_Inj UN_empty Un_empty_left Un_empty_right noclash_FTerm_def)[3] + apply (rule Int_empty_right)+ + apply assumption+ + apply (subst FTerm_pre.map_cong0) + apply (assumption | rule supp_id_bound bij_id refl)+ + apply (unfold id_def[symmetric] FTerm_pre.map_id FTerm_pre.Sb_Inj) + apply (unfold id_def) + apply (rule refl) + done + done + + apply (rule ext) + apply (rule trans[OF comp_apply]) + apply (rule tvsubst_VVr) + apply (assumption | rule cmin_greater card_of_Card_order)+ + oops + (* Sugar theorems for substitution *) definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl a))" @@ -739,7 +695,7 @@ lemma FTerm_subst: apply (rule assms)+ apply (rule trans) - apply (rule tvsubst_FTerm_not_is_VVr) + 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 @@ -760,7 +716,7 @@ lemma FTerm_subst: apply (rule refl) apply (rule trans) - apply (rule tvsubst_FTerm_not_is_VVr) + 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 @@ -782,7 +738,7 @@ lemma FTerm_subst: apply (rule refl) apply (rule trans) - apply (rule tvsubst_FTerm_not_is_VVr) + 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 @@ -804,7 +760,7 @@ lemma FTerm_subst: apply (rule refl) apply (rule trans) - apply (rule tvsubst_FTerm_not_is_VVr) + 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 diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 3274c6ad..6728c66e 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -385,473 +385,4 @@ mrsbnf "'b::var LM" done print_theorems -typedef ('a1, 'a2, 'c1, 'c2) L' = "UNIV :: ('a1 * 'a1 * ('c1 + 'c2)) set" - by (rule UNIV_witness) - -pbmv_monad "('a1::var, 'a2, 'c1, 'c2) L'" - Sbs: "\f x. Abs_L' (map_prod f (map_prod f id) (Rep_L' x))" - RVrs: "\x. case Rep_L' x of (x1, x2, _) \ {x1, x2}" - Maps: "\f1 f2 x. Abs_L' (map_prod id (map_prod id (map_sum f1 f2)) (Rep_L' x))" - Supps: "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setl y" "\x. case Rep_L' x of (_, _, y) \ Basic_BNFs.setr y" - bd: natLeq - apply (rule infinite_regular_card_order_natLeq) - apply (auto simp: Abs_L'_inject Abs_L'_inverse Rep_L'_inverse prod.map_comp comp_def - id_def case_prod_beta insert_bound[OF natLeq_Cinfinite] - Cinfinite_gt_empty[OF natLeq_Cinfinite] - )[4] - apply (unfold Abs_L'_inject[OF UNIV_I UNIV_I] case_prod_beta)[1] - apply (metis (no_types, lifting) fst_map_prod insertCI prod.collapse snd_map_prod) - apply (auto simp: insert_bound[OF natLeq_Cinfinite] Cinfinite_gt_empty[OF natLeq_Cinfinite] - sum.map_id0 Rep_L'_inverse Abs_L'_inverse Abs_L'_inject prod.map_comp sum.map_comp comp_def - id_def[symmetric] case_prod_beta sum.set_map sum.set_bd - ) - apply (rule prod.map_cong0[OF refl])+ - apply (rule sum.map_cong0) - apply (auto elim!: snds.cases) - done -print_theorems - -(* *) -type_synonym ('a1, 'a2, 'c1, 'c2) L = "'a1 * 'a1 * ('c1 + 'c2)" (* PBMV *) - type_synonym ('a1, 'a2, 'c1, 'c2) L_M1 = "'a1" (* PBMV *) - -type_synonym ('a1, 'a2) L1 = "'a1 * 'a2" - type_synonym ('a1, 'a2) L1_M1 = "'a1" - type_synonym ('a1, 'a2) L1_M2 = "'a2" - -type_synonym ('a1, 'a2) L2 = "'a1 * 'a2 * 'a2 * 'a2 FType" - type_synonym ('a1, 'a2) L2_M1 = "'a1" - type_synonym ('a1, 'a2) L2_M2 = "'a2" - type_synonym ('a1, 'a2) L2_M3 = "'a2 FType" - -(* Dispatcher *) - (* from L_M1 *) -definition Sb_L :: "('a1 \ 'a1) \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1, 'c2) L" where - "Sb_L \ \f. map_prod f (map_prod f id)" -definition Vrs_L_1 :: "('a1, 'a2, 'c1, 'c2) L \ 'a1 set" where - "Vrs_L_1 \ \(a1, a1', p). {a1, a1'}" (* corresponds to L_M1 and Inj_L_M1_1 *) -definition Vrs_L_2 :: "('a1, 'a2, 'c1, 'c2) L \ 'a2 set" where - "Vrs_L_2 \ \x. {}" (* corresponds to nothing *) -definition Map_L :: "('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" where - "Map_L \ \f1 f2 (a1, a2, p). (a1, a2, map_sum f1 f2 p)" -definition Supp_L_1 :: "('a1, 'a2, 'c1, 'c2) L \ 'c1 set" where - "Supp_L_1 \ \(a1, a1', p). Basic_BNFs.setl p" -definition Supp_L_2 :: "('a1, 'a2, 'c1, 'c2) L \ 'c2 set" where - "Supp_L_2 \ \(a1, a1', p). Basic_BNFs.setr p" - -(* and its minion *) -definition Inj_L_M1_1 :: "'a1 \ 'a1" where "Inj_L_M1_1 \ id" -definition Sb_L_M1 :: "('a1 \ 'a1) \ ('a1, 'a2, 'c1, 'c2) L_M1 \ ('a1, 'a2, 'c1, 'c2) L_M1" where - "Sb_L_M1 \ \f. f" -definition Vrs_L_M1_1 :: "'a1 \ 'a1 set" where "Vrs_L_M1_1 \ \x. {x}" -definition Vrs_L_M1_2 :: "'a2 \ 'a2 set" where "Vrs_L_M1_2 \ \x. {}" -definition Map_L_M1 :: "('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L_M1 \ ('a1, 'a2, 'c1', 'c2') L_M1" where - "Map_L_M1 \ \f1 f2 x. x" - -(* L1 *) -definition Sb_L1 :: "('a1 \ 'a1) \ ('a2 \ 'a2) \ ('a1, 'a2) L1 \ ('a1, 'a2) L1" where - "Sb_L1 \ \f1 f2. map_prod f1 f2" -definition Vrs_L1_1 :: "('a1, 'a2) L1 \ 'a1 set" where - "Vrs_L1_1 \ \(a1, a2). {a1}" (* corresponds to L1_M1 and Inj_L1_M1_1 *) -definition Vrs_L1_2 :: "('a1, 'a2) L1 \ 'a2 set" where - "Vrs_L1_2 \ \(a1, a2). {a2}" (* corresponds to L1_M2 and Inj_L1_M2_2 *) -(* and its minions M1 *) -definition Sb_L1_M1 :: "('a1 \ 'a1) \ ('a1, 'a2) L1_M1 \ ('a1, 'a2) L1_M1" where - "Sb_L1_M1 \ \f. f" -definition Vrs_L1_M1_1 :: "('a1, 'a2) L1_M1 \ 'a1 set" where - "Vrs_L1_M1_1 \ \a. {a}" (* corresponds to L1_M1 and Inj_L1_M1_1 *) -definition Vrs_L1_M1_2 :: "('a1, 'a2) L1_M1 \ 'a2 set" where - "Vrs_L1_M1_2 \ \a. {}" (* corresponds to L1_M2 and Inj_L1_M2_2 *) -(* and its minions M2 *) -definition Sb_L1_M2 :: "('a2 \ 'a2) \ ('a1, 'a2) L1_M2 \ ('a1, 'a2) L1_M2" where - "Sb_L1_M2 \ \f. f" -definition Vrs_L1_M2_1 :: "('a1, 'a2) L1_M2 \ 'a1 set" where - "Vrs_L1_M2_1 \ \a. {}" (* corresponds to L1_M1 and Inj_L1_M1_1 *) -definition Vrs_L1_M2_2 :: "('a1, 'a2) L1_M2 \ 'a2 set" where - "Vrs_L1_M2_2 \ \a. {a}" (* corresponds to L1_M2 and Inj_L1_M2_2 *) - -(* L2 *) -(* its minions M1, shared with L1_M1 *) -(*definition Sb_L2_M1 :: "('a1 \ 'a1) \ ('a1, 'a2) L2_M1 \ ('a1, 'a2) L2_M1" where - "Sb_L2_M1 \ \f. f" -definition Vrs_L2_M1_1 :: "('a1, 'a2) L2_M1 \ 'a1 set" where - "Vrs_L2_M1_1 \ \a. {a}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) -definition Vrs_L2_M1_2 :: "('a1, 'a2) L2_M1 \ 'a2 set" where - "Vrs_L2_M1_2 \ \a. {}" (* corresponds to L2_M2 and Inj_L2_M2_2 *) *) -(* and its minions M2 *) -definition Sb_L2_M2 :: "('a2::var \ 'a2 FType) \ ('a1, 'a2) L2_M3 \ ('a1, 'a2) L2_M3" where - "Sb_L2_M2 \ tvsubst_FType" -definition Vrs_L2_M2_1 :: "('a1, 'a2) L2_M2 \ 'a1 set" where - "Vrs_L2_M2_1 \ \a. {}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) -definition Vrs_L2_M2_2 :: "('a1, 'a2::var) L2_M3 \ 'a2 set" where - "Vrs_L2_M2_2 \ FVars_FType" (* corresponds to L2_M2 and Inj_L2_M2_2 *) -(* and then the leader L2 itself *) -definition Sb_L2 :: "('a1 \ 'a1) \ ('a2 \ 'a2) \ ('a2::var \ 'a2 FType) \ ('a1, 'a2) L2 \ ('a1, 'a2) L2" where - "Sb_L2 \ \f1 f2 f3. map_prod (id f1) (map_prod (id f2) (map_prod (id f2) (tvsubst_FType f3)))" -definition Vrs_L2_1 :: "('a1, 'a2) L2 \ 'a1 set" where - "Vrs_L2_1 \ \(x,x2,x3,x4). {x}" (* corresponds to L2_M1 and Inj_L2_M1_1 *) -definition Vrs_L2_2 :: "('a1, 'a2::var) L2 \ 'a2 set" where - "Vrs_L2_2 \ \(x,x2,x3,x4). {x2,x3}" (* corresponds to L2_M2 and Inj_L2_M2_2 *) -definition Vrs_L2_3 :: "('a1, 'a2::var) L2 \ 'a2 set" where - "Vrs_L2_3 \ \(x,x2,x3,x4). FVars_FType x4" (* corresponds to L2_M2 and Inj_L2_M2_2 *) - -(* Composition *) -type_synonym ('a1, 'a2) LC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L" -typ "('a1, 'a2, 'c1, 'c2) L" -typ "('a1, 'a2) L1" -typ "('a1, 'a2) LC" -type_synonym ('a1, 'a2) L_MC = "('a1, 'a2, ('a1, 'a2) L1, ('a1, 'a2) L2) L_M1" -typ "('a1, 'a2) L_MC" (* is the same as LC_M1, so do not add *) - -typ "('a1, 'a2) L1_M1" -typ "('a1, 'a2) L1_M2" -typ "('a1, 'a2) L2_M2" - -ML \ -val FType_bmv = the (BMV_Monad_Def.pbmv_monad_of @{context} "BMV_Monad.FType") -\ - -ML \ -val model_L = { - ops = [@{typ "'a1 * 'a1 * ('c1 + 'c2)"}], - var_class = @{class var}, - leader = 0, - frees = [[@{typ "'a1"}]], - lives = [[@{typ "'c1"}, @{typ "'c2"}]], - lives' = [[@{typ "'c1'"}, @{typ "'c2'"}]], - deads = [[]], - bmv_ops = [], - consts = { - bd = @{term natLeq}, - Sbs = [@{term "Sb_L :: _ \ _ \ ('a1, 'a2, 'c1, 'c2) L"}], - RVrs = [[@{term "Vrs_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}]], - Injs = [[]], - Vrs = [[]], - params = [SOME { - Map = @{term "Map_L :: ('c1 \ 'c1') \ ('c2 \ 'c2') \ ('a1, 'a2, 'c1, 'c2) L \ ('a1, 'a2, 'c1', 'c2') L" }, - Supps = [ - @{term "Supp_L_1 :: ('a1, 'a2, 'c1, 'c2) L \ _"}, - @{term "Supp_L_2 :: ('a1, 'a2, 'c1, 'c2) L \ _"} - ] - }] - }, - params = [SOME { - axioms = { - Map_id = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def sum.map_id0 id_apply}), - resolve_tac ctxt [ext], - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta prod.collapse}), - resolve_tac ctxt @{thms id_apply[symmetric]} - ], - Map_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), - resolve_tac ctxt [ext], - resolve_tac ctxt @{thms trans[OF comp_apply]}, - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta fst_conv snd_conv sum.map_comp}), - resolve_tac ctxt [refl] - ], - Supp_Map = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv sum_set_simps sum.set_map}), - resolve_tac ctxt [refl] - ]), - Supp_bd = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Supp_L_1_def Supp_L_2_def}), - resolve_tac ctxt @{thms sum.set_bd} - ]), - Map_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def Supp_L_1_def Supp_L_2_def case_prod_beta fst_conv snd_conv}), - K (Local_Defs.unfold0_tac ctxt @{thms prod.inject}), - REPEAT_DETERM o resolve_tac ctxt @{thms conjI[OF refl]}, - resolve_tac ctxt @{thms sum.map_cong0}, - REPEAT_DETERM o Goal.assume_rule_tac ctxt - ] - }, - Map_Sb = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Map_L_def}), - resolve_tac ctxt [ext], - K (Local_Defs.unfold0_tac ctxt @{thms comp_def Sb_L_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta id_apply map_prod_simp}), - resolve_tac ctxt [refl] - ], - Map_Injs = [], - Supp_Sb = replicate 2 (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_map_prod id_apply Sb_L_def Supp_L_1_def Supp_L_2_def}), - resolve_tac ctxt [refl] - ]), - Vrs_Map = [fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Map_L_def case_prod_beta fst_conv snd_conv}), - resolve_tac ctxt [refl] - ]] - }], - bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, - tacs = [{ - Sb_Inj = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L_def prod.map_id0}), - resolve_tac ctxt [refl] - ], - Sb_comp_Injs = [], - Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ( - (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) - :: @{thms Sb_L_def id_o id_apply} - )), - resolve_tac ctxt [refl] - ], - Vrs_bds = [fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def case_prod_beta}), - resolve_tac ctxt @{thms insert_bound}, - resolve_tac ctxt @{thms natLeq_Cinfinite}, - resolve_tac ctxt @{thms ID.set_bd} - ]], - Vrs_Injss = [[]], - Vrs_Sbs = [fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta - Product_Type.fst_map_prod Product_Type.snd_map_prod image_insert image_empty - UN_insert UN_empty Un_empty_right insert_is_Un[symmetric] - }), - resolve_tac ctxt [refl] - ]], - Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L_1_def Sb_L_def case_prod_beta}), - resolve_tac ctxt @{thms prod.map_cong0}, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms insertI1}, - eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, - hyp_subst_tac ctxt, - assume_tac ctxt, - resolve_tac ctxt @{thms prod.map_cong0}, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms insertI2}, - resolve_tac ctxt @{thms singletonI}, - eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, - eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, - hyp_subst_tac ctxt, - assume_tac ctxt, - resolve_tac ctxt [refl] - ] - } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; -\ - -ML \ -val model_L1 = { - ops = [@{typ "'a1 * 'a2"}], - var_class = @{class var}, - leader = 0, - frees = [[@{typ "'a1"}, @{typ "'a2"}]], - lives = [[]], - lives' = [[]], - deads = [[]], - bmv_ops = [], - consts = { - bd = @{term natLeq}, - Injs = [[]], - Sbs = [@{term "Sb_L1 :: _ \ _ \ _ \ ('a1, 'a2) L1"}], - Vrs = [[]], - RVrs = [[ - @{term "Vrs_L1_1 :: ('a1, 'a2) L1 \ _"}, - @{term "Vrs_L1_2 :: ('a1, 'a2) L1 \ _"} - ]], - params = [NONE] - }, - params = [NONE], - bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, - tacs = [{ - Sb_Inj = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L1_def prod.map_id0}), - resolve_tac ctxt [refl] - ], - Sb_comp_Injs = [], - Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ( - (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) - :: @{thms Sb_L1_def id_apply} - )), - resolve_tac ctxt [refl] - ], - Vrs_bds = [ - fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1, - fn ctxt => Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def case_prod_beta} THEN resolve_tac ctxt @{thms ID.set_bd} 1 - ], - Vrs_Injss = [[], []], - Vrs_Sbs = [ - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Sb_L1_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single image_insert image_empty}), - resolve_tac ctxt [refl] - ], - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_2_def Sb_L1_def case_prod_map_prod}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single image_insert image_empty}), - resolve_tac ctxt [refl] - ] - ], - Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Vrs_L1_1_def Vrs_L1_2_def Sb_L1_def case_prod_beta}), - resolve_tac ctxt @{thms prod.map_cong0}, - eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms singletonI}, - hyp_subst_tac ctxt, - assume_tac ctxt, - eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, - rotate_tac ~1, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms singletonI}, - hyp_subst_tac ctxt, - assume_tac ctxt - ] - } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; -\ - -ML \ -val model_L2 = { - ops = [@{typ "('a1, 'a2) L2"}], - var_class = @{class var}, - leader = 0, - frees = [[@{typ 'a1}, @{typ "'a2"}]], - lives = [[]], - lives' = [[]], - deads = [[]], - bmv_ops = [ - BMV_Monad_Def.morph_bmv_monad ( - MRBNF_Util.subst_typ_morphism ( - hd (BMV_Monad_Def.frees_of_bmv_monad FType_bmv) ~~ [@{typ "'a2::var"}] - )) FType_bmv - ], - consts = { - bd = @{term natLeq}, - RVrs = [[ - @{term "Vrs_L2_1 :: ('a1, 'a2::var) L2 \ _"}, - @{term "Vrs_L2_2 :: ('a1, 'a2::var) L2 \ _"} - ]], - Injs = [[@{term "TyVar :: 'a2::var \ 'a2 FType"}]], - Sbs = [@{term "Sb_L2 :: _ \ _ \ _ \ _ \ ('a1, 'a2::var) L2"}], - Vrs = [[ - @{term "Vrs_L2_3 :: ('a1, 'a2::var) L2 \ _"} - ]], - params = [NONE] - }, - params = [NONE], - bd_infinite_regular_card_order = fn ctxt => resolve_tac ctxt @{thms infinite_regular_card_order_natLeq} 1, - tacs = [{ - Sb_Inj = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Sb_Inj_FType id_apply prod.map_id0}), - resolve_tac ctxt [refl] - ], - Sb_comp_Injs = [], - Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ( - (BNF_Def.map_comp0_of_bnf (the (BNF_Def.bnf_of @{context} "Product_Type.prod")) RS sym) - :: @{thms Sb_L2_def id_apply Sb_comp_FType SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]} - )), - resolve_tac ctxt [refl] - ], - Vrs_bds = [ - fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_1_def} THEN resolve_tac ctxt @{thms ID.set_bd} 1, - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_2_def}), - resolve_tac ctxt @{thms insert_bound}, - resolve_tac ctxt @{thms natLeq_Cinfinite}, - resolve_tac ctxt @{thms ID.set_bd} - ], - fn ctxt => Local_Defs.unfold0_tac ctxt @{thms case_prod_beta Vrs_L2_3_def} THEN resolve_tac ctxt @{thms FType.set_bd} 1 - ], - Vrs_Injss = [[], [], []], - Vrs_Sbs = [ - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply image_insert image_empty}), - resolve_tac ctxt [refl] - ], - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_2_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta insert_is_Un[symmetric] UN_insert UN_empty Un_empty_right id_apply image_insert image_empty}), - resolve_tac ctxt [refl] - ], - fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_3_def case_prod_map_prod SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), - K (Local_Defs.unfold0_tac ctxt @{thms case_prod_beta UN_single id_apply}), - resolve_tac ctxt @{thms Vrs_Sb_FType}, - K (Local_Defs.unfold0_tac ctxt @{thms SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]}), - assume_tac ctxt - ] - ], - Sb_cong = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms Sb_L2_def Vrs_L2_1_def Vrs_L2_2_def Vrs_L2_3_def case_prod_beta id_apply SSupp_def[of TyVar, unfolded SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric], symmetric]]}), - resolve_tac ctxt @{thms prod.map_cong0}, - eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms singletonI}, - hyp_subst_tac ctxt, - assume_tac ctxt, - eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, - resolve_tac ctxt @{thms prod.map_cong0}, - eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, - hyp_subst_tac ctxt, - rotate_tac ~2, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms insertI1}, - assume_tac ctxt, - hyp_subst_tac ctxt, - eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, - resolve_tac ctxt @{thms prod.map_cong0}, - eresolve_tac ctxt @{thms Basic_BNFs.fsts.cases}, - hyp_subst_tac ctxt, - rotate_tac ~2, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - resolve_tac ctxt @{thms insertI2}, - resolve_tac ctxt @{thms singletonI}, - assume_tac ctxt, - eresolve_tac ctxt @{thms Basic_BNFs.snds.cases}, - hyp_subst_tac ctxt, - resolve_tac ctxt @{thms Sb_cong_FType}, - REPEAT_DETERM o assume_tac ctxt, - rotate_tac ~2, - dresolve_tac ctxt @{thms meta_spec}, - dresolve_tac ctxt @{thms meta_mp}, - assume_tac ctxt, - assume_tac ctxt - ] - } : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_axioms] -} : (Proof.context -> tactic) BMV_Monad_Def.bmv_monad_model; -\ - -local_setup \fn lthy => -let - val ((L_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (Binding.prefix_name "L_") (SOME (Binding.name "L")) model_L lthy; - val ((L1_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (Binding.prefix_name "L1_") (SOME (Binding.name "L1")) model_L1 lthy; - val ((L2_bmv, _), lthy) = BMV_Monad_Def.bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Note_Some) (Binding.prefix_name "L2_") (SOME (Binding.name "L2")) model_L2 lthy; - - val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Monad.L" L_bmv lthy - val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Monad.L1" L1_bmv lthy - val lthy = BMV_Monad_Def.register_pbmv_monad "BMV_Monad.L2" L2_bmv lthy -in lthy end -\ - -local_setup \fn lthy => - let - val L_bmv = the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.L"); - val L1_bmv = the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.L1"); - val L2_bmv = the (BMV_Monad_Def.pbmv_monad_of lthy "BMV_Monad.L2"); - - val ((comp_bmv, unfold_set), lthy) = BMV_Monad_Def.compose_bmv_monad I L_bmv [MRBNF_Util.Inl L1_bmv, MRBNF_Util.Inl L2_bmv] - { deads = [], frees = [@{typ "'a1"}] } - [ SOME { deads = [], lives = [], frees = [@{typ "'a1"}, @{typ "'a2"}] }, - SOME { deads = [], lives = [], frees = [@{typ 'a1}, @{typ "'a2"}] } - ] - lthy - val _ = @{print} comp_bmv - in lthy end -\ -print_theorems - end From f664777661ef42b19f33e283c68cd6f6d8038055 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 3 Jul 2025 13:57:37 +0100 Subject: [PATCH 43/90] Fix types with no frees --- Tools/bmv_monad_def.ML | 278 ++++++++++++++++++++++----------- operations/BMV_Composition.thy | 57 +++---- thys/Prelim/Prelim.thy | 16 ++ 3 files changed, 218 insertions(+), 133 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 1d25dde0..1b6528bf 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -29,9 +29,9 @@ signature BMV_MONAD_DEF = sig SSupp_Inj_bound: thm }; - type 'a bmv_monad_consts = { + type bmv_monad_consts = { bd: term, - UNIV_bds: 'a list, + UNIV_bds: term option list, Sbs: term list, RVrs: term list list, Injs: term list list, @@ -47,7 +47,7 @@ signature BMV_MONAD_DEF = sig Map_Injs: 'a list }; - type ('a, 'b) bmv_monad_model = { + type 'a bmv_monad_model = { ops: typ list, var_class: class, bmv_ops: bmv_monad list, @@ -56,7 +56,7 @@ signature BMV_MONAD_DEF = sig leader: int, lives: typ list list, lives': typ list list, - consts: 'b bmv_monad_consts, + consts: bmv_monad_consts, params: 'a bmv_monad_param option list, bd_infinite_regular_card_order: 'a, tacs: 'a bmv_monad_axioms list @@ -72,7 +72,7 @@ signature BMV_MONAD_DEF = sig 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 UNIV_bds_of_bmv_monad: bmv_monad -> term list; + val UNIV_bds_of_bmv_monad: bmv_monad -> term option 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; @@ -98,7 +98,7 @@ signature BMV_MONAD_DEF = sig 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, term option) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory + -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model -> local_theory -> (bmv_monad * thm list) * local_theory datatype var_type = Dead_Var | Free_Var | Live_Var; @@ -223,9 +223,9 @@ fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Vrs_Map, Map_Injs }: 'a bm }: 'b bmv_monad_param; -type 'a bmv_monad_consts = { +type bmv_monad_consts = { bd: term, - UNIV_bds: 'a list, + UNIV_bds: term option list, Sbs: term list, RVrs: term list list, Injs: term list list, @@ -233,9 +233,9 @@ type 'a bmv_monad_consts = { params: { Map: term, Supps: term list} option list }; -fun morph_bmv_monad_consts f phi { bd, params, Injs, Sbs, Vrs, RVrs, UNIV_bds } = { +fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs, UNIV_bds } = { bd = Morphism.term phi bd, - UNIV_bds = map f UNIV_bds, + UNIV_bds = map (Option.map (Morphism.term phi)) UNIV_bds, RVrs = map (map (Morphism.term phi)) RVrs, params = map (Option.map (fn { Map, Supps } => { Map = Morphism.term phi Map, @@ -244,7 +244,7 @@ fun morph_bmv_monad_consts f phi { bd, params, Injs, Sbs, Vrs, RVrs, UNIV_bds } Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, Vrs = map (map (Morphism.term phi)) Vrs -}: 'a bmv_monad_consts; +}: bmv_monad_consts; datatype bmv_monad = BMV of { ops: typ list, @@ -254,7 +254,7 @@ datatype bmv_monad = BMV of { lives: typ list list, lives': typ list list, deads: typ list list, - consts: term bmv_monad_consts, + consts: bmv_monad_consts, params: thm bmv_monad_param option list, bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list, @@ -273,7 +273,7 @@ fun morph_bmv_monad phi (BMV { 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 (Morphism.term phi) phi consts, + 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, @@ -307,14 +307,14 @@ val unfolds_of_bmv_monad = #unfolds o Rep_bmv fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) -type ('a, 'b) bmv_monad_model = { +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: 'b bmv_monad_consts, + consts: bmv_monad_consts, params: 'a bmv_monad_param option list, bmv_ops: bmv_monad list, leader: int, @@ -322,7 +322,7 @@ type ('a, 'b) bmv_monad_model = { tacs: 'a bmv_monad_axioms list } -fun morph_bmv_monad_model phi f g ({ ops, var_class, frees, lives, lives', consts, bmv_ops, leader, +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, @@ -331,15 +331,15 @@ fun morph_bmv_monad_model phi f g ({ ops, var_class, frees, lives, lives', const 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 g phi consts, + 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, 'b) bmv_monad_model; +} : 'a bmv_monad_model; -fun update_consts (consts: term bmv_monad_consts) (model: ('a, 'b) 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, @@ -352,7 +352,7 @@ fun update_consts (consts: term bmv_monad_consts) (model: ('a, 'b) bmv_monad_mod leader = #leader model, tacs = #tacs model, bd_infinite_regular_card_order = #bd_infinite_regular_card_order model -}: ('a, term) bmv_monad_model; +}: 'a bmv_monad_model; structure Data = Generic_Data ( type T = bmv_monad Symtab.table; @@ -374,7 +374,7 @@ fun mk_small_prems fs rhos Injs UNIV_bd = map (HOLogic.mk_Trueprop o mk_supp_bound) fs @ map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (MRBNF_Util.mk_SSupp Inj $ rho)) - UNIV_bd + (the UNIV_bd) )) rhos Injs; fun mk_bmv_monad_axioms ops consts bmv_ops lthy = @@ -653,7 +653,7 @@ fun maybe_define const_policy fact_policy b rhs lthy = 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 const_policy fact_policy qualify leader ops frees lives' (consts: term option bmv_monad_consts) lthy = +fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees lives' (consts: bmv_monad_consts) lthy = let val maybe_define' = maybe_define const_policy fact_policy o qualify; @@ -706,9 +706,12 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees li val ((bd, bd_def), lthy) = maybe_define' (Binding.name "bd") (#bd consts) lthy; - val UNIV_bds = map2 (fn SOME t => K t | NONE => - foldl1 mk_cmin o map (mk_card_of o HOLogic.mk_UNIV) - ) (#UNIV_bds consts) frees; + val UNIV_bds = @{map 4} (fn SOME t => K (K (K (SOME t))) | NONE => fn frees => fn Injs => fn T => + let + val frees' = inter (op=) (map TFree (fold Term.add_tfrees Injs [])) frees; + val frees' = inter (op=) frees' (rev (map TFree (Term.add_tfreesT T []))); (* reorder frees *) + in try (foldl1 mk_cmin) (map (mk_card_of o HOLogic.mk_UNIV) frees') end + ) (#UNIV_bds consts) frees Injs ops; val consts' = { bd = bd, @@ -718,7 +721,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees li UNIV_bds = UNIV_bds, RVrs = RVrs, Vrs = Vrs - } : term bmv_monad_consts; + } : bmv_monad_consts; val (lthy, old_lthy) = `Local_Theory.end_nested lthy; val phi = Proof_Context.export_morphism old_lthy lthy; @@ -727,7 +730,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees li 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 (Morphism.term phi') phi' consts'; + val consts' = morph_bmv_monad_consts phi' consts'; val defs = map_filter I (Sb_defs @ flat Inj_defs @ Vrs_defs @ RVrs_defs @ [bd_def] @ flat param_defs); in (consts', map (Morphism.thm phi) defs, lthy) end; @@ -783,7 +786,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv 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, term) bmv_monad_model) unfolds lthy = +fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_monad_model) unfolds lthy = let val consts = { bd = #bd (#consts model), @@ -793,7 +796,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: (thm, term) 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) - }: term bmv_monad_consts; + }: bmv_monad_consts; val axioms = #tacs model @ maps (#axioms o Rep_bmv) (#bmv_ops model); val names = map (fst o dest_Free); @@ -907,11 +910,11 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: (thm, term) let val (rho, _) = names_lthy |> apfst hd o mk_Frees "\'" [fastype_of Inj]; - val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) UNIV_bd); + val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) (the UNIV_bd)); val goal = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ HOLogic.mk_comp ( Term.list_comb (Sb, hs @ rhos), rho - ))) UNIV_bd + ))) (the UNIV_bd) ); 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}, @@ -922,7 +925,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: (thm, term) ])) end ) Injs; - val SSupp_Inj_bound = + val SSupp_Inj_bound = the_default @{thm SSupp_Inj_bound} (Option.map (fn UNIV_bd => let val Inj = Free ("Inj", @{typ "'a \ 'b"}); val goal = HOLogic.mk_Trueprop (mk_ordLess @@ -930,7 +933,8 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: (thm, term) UNIV_bd ) in Goal.prove_sorry lthy (names [Inj]) [] goal (fn {context=ctxt, ...} => EVERY1 [ REPEAT_DETERM o resolve_tac ctxt @{thms cmin_Card_order card_of_Card_order SSupp_Inj_bound cmin_greater} - ]) end; + ]) end + ) UNIV_bd); in { SSupp_Map_subsets = SSupp_Map_subsets, SSupp_Map_bounds = SSupp_Map_bounds, @@ -969,7 +973,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: (thm, term) 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, term) bmv_monad_model) defs lthy = +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); @@ -979,7 +983,7 @@ fun prove_axioms (model: (Proof.context -> tactic, term) bmv_monad_model) defs l ) end; -fun prove_params (model: (Proof.context -> tactic, term) bmv_monad_model) defs lthy = +fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let val goals = @{map 6} (fn Sb => fn RVrs => fn Vrs => fn Injs => fn UNIV_bds => Option.map (fn param => mk_param_axiom (#Map param) (#Supps param) Sb Injs UNIV_bds RVrs Vrs (#bd (#consts model)) (map_filter I (#params (#consts model) @ maps (#params o consts_of_bmv_monad) (#bmv_ops model))) lthy @@ -1005,7 +1009,7 @@ fun prove_params (model: (Proof.context -> tactic, term) bmv_monad_model) defs l } } : thm bmv_monad_param)) tacs' goals end; -fun mk_thm_model (model: ('a, term) bmv_monad_model) params axioms bd_irco = { +fun mk_thm_model (model: 'a bmv_monad_model) params axioms bd_irco = { ops = #ops model, var_class = #var_class model, leader = #leader model, @@ -1018,15 +1022,15 @@ fun mk_thm_model (model: ('a, term) bmv_monad_model) params axioms bd_irco = { params = params, bd_infinite_regular_card_order = bd_irco, tacs = axioms -} : (thm, term) bmv_monad_model; +} : thm bmv_monad_model; -fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.context -> tactic, term option) bmv_monad_model) lthy = +fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.context -> tactic) bmv_monad_model) 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 (Option.map (Morphism.term phi)) model; + val model = morph_bmv_monad_model phi I model; val (consts, unfold_set, lthy) = define_bmv_monad_consts const_policy (fact_policy lthy) qualify (#leader model) (#ops model) (#frees model) (#lives' model) (#consts model) lthy; @@ -1209,7 +1213,7 @@ fun slice_bmv_monad n bmv = } end; fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives, frees=dfrees } lthy = - (*let + 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)) @@ -1308,6 +1312,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives RVrs = new_RVrss, Sbs = new_Sbs, Vrs = new_Vrss, + UNIV_bds = map (leader UNIV_bds_of_bmv_monad) demoted_bmvs, params = new_params, bd = bd_of_bmv_monad bmv }: bmv_monad_consts; @@ -1363,7 +1368,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} ], rtac ctxt (#Map_Sb (the params)), - REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)), K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} @ #Map_Injs (the params) @ [#Map_comp (#axioms (the params))] @@ -1374,7 +1379,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)) ], K (Local_Defs.unfold0_tac ctxt (@{thms image_id UN_empty2 Un_empty_left Un_empty_right} @ #Supp_Map (#axioms (the params)) @@ -1399,7 +1404,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)) ]) ) Injs, Sb_comp = fn ctxt => EVERY1 [ @@ -1411,7 +1416,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt @{thm SSupp_Inj_bound}), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)), 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)), @@ -1421,13 +1426,13 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives rtac ctxt trans, rtac ctxt (#Sb_comp axioms) ], - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thm SSupp_Inj_bound} + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt ((#SSupp_Inj_bound facts) :: maps (the_default [] o #SSupp_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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)) ], rtac ctxt refl ], @@ -1438,7 +1443,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)) ], K (Local_Defs.unfold0_tac ctxt (@{thms UN_empty2 Un_empty_left Un_empty_right} @ flat (#Vrs_Injss axioms) @@ -1459,7 +1464,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt @{thm SSupp_Inj_bound}), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)), 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) ] @@ -1467,12 +1472,11 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives (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 -*) error "demote" 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 + 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) @@ -1652,15 +1656,6 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) inners (the (leader Supps_of_bmv_monad outer))))) lives; in SOME { Map = Map, Supps = Supps } end; - 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] - }: bmv_monad_consts; - val new_minions = maps (fn bmv => map_index (fn (i, T) => (T, 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') @@ -1671,12 +1666,47 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit val T = leader ops_of_bmv_monad outer; + val UNIV_bd = + let + val ts = map_filter (leader UNIV_bds_of_bmv_monad) (outer :: new_minions) + val frees' = map TFree (rev (fold Term.add_tfrees ts [])); + val frees' = inter (op=) frees' (rev (map TFree (Term.add_tfreesT T []))); (* reorder frees *) + in try (foldl1 mk_cmin) (map (mk_card_of o HOLogic.mk_UNIV) frees') end; + + 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], + UNIV_bds = [UNIV_bd] + }: 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 cmin_smaller = the_default [] (Option.map (fn UNIV_bd => map_filter (Option.map (fn inner_bd => + let + val (rT, _) = lthy + |> fold Variable.declare_typ (map TFree (Term.add_tfrees UNIV_bd [])) + |> apfst hd o mk_TFrees 1; + val r = Free ("r", mk_relT (rT, rT)); + val goal = Logic.mk_implies ( + HOLogic.mk_Trueprop (mk_ordLess r UNIV_bd), + HOLogic.mk_Trueprop (mk_ordLess r inner_bd) + ); + in Goal.prove_sorry lthy ["r"] [] goal (fn {context=ctxt, ...} => EVERY1 [ + REPEAT_DETERM o (resolve_tac ctxt @{thms card_of_Card_order cmin_Card_order} ORELSE' etac ctxt @{thm cminE}), + REPEAT_DETERM o (resolve_tac ctxt @{thms card_of_Card_order cmin_Card_order cmin_greater} ORELSE' assume_tac ctxt) + ]) end + )) (map (leader UNIV_bds_of_bmv_monad) (outer :: inners'))) UNIV_bd); + val model = { - ops = [leader ops_of_bmv_monad outer], + 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, @@ -1743,6 +1773,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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}, @@ -1760,27 +1791,48 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], K (Local_Defs.unfold0_tac ctxt (@{thms comp_assoc id_o o_id} - @ #Map_Injs param @ [#Map_comp (#axioms param)] + @ #Map_Injs param )), + REPEAT_DETERM_N 2 o EVERY' [ + rtac ctxt trans, + rtac ctxt (#Map_comp (#axioms param)), + rtac ctxt sym + ], TRY o rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, rtac ctxt ext, rtac ctxt (#Map_cong (#axioms param)), - EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' 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, - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - rtac ctxt refl + 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 FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ], + 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], SUBGOAL (fn (goal, _) => let @@ -1799,7 +1851,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ), 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], K (Local_Defs.unfold0_tac ctxt ( @{thms image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap @@ -1808,7 +1864,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit )), 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], 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' [ @@ -1849,7 +1909,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ]) ) new_Injs, Sb_comp = fn ctxt => EVERY1 [ @@ -1862,7 +1926,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Map_Sb param), - REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm SSupp_Inj_bound}), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ], rtac ctxt @{thm trans[OF comp_assoc]}, rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]} ], @@ -1870,19 +1938,26 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit TRY o EVERY' [ rtac ctxt @{thm comp_assoc[symmetric]}, EqSubst.eqsubst_tac ctxt [0] [#Sb_comp axioms], - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt (@{thms SSupp_Inj_bound} - @ the (#SSupp_Map_bounds facts) - )), + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt ((#SSupp_Inj_bound facts) :: the (#SSupp_Map_bounds facts)), + eresolve_tac ctxt cmin_smaller + ], 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 (assume_tac ctxt ORELSE' resolve_tac ctxt ( - @{thms refl supp_comp_bound infinite_class.infinite_UNIV SSupp_Inj_bound} - @ #SSupp_Sb_bounds facts @ the (#SSupp_Map_bounds facts) - @ maps (map (fn thm => thm RS fun_cong) o #Sb_comp_Injs o leader axioms_of_bmv_monad) (outer :: inners') - )) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + resolve_tac ctxt ( + @{thms refl supp_comp_bound infinite_class.infinite_UNIV} + @ [#SSupp_Inj_bound facts] + @ #SSupp_Sb_bounds facts @ the (#SSupp_Map_bounds facts) + @ maps (map (fn thm => thm RS fun_cong) o #Sb_comp_Injs o leader axioms_of_bmv_monad) (outer :: inners') + ), + eresolve_tac ctxt cmin_smaller + ] ]) ], K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), @@ -1890,7 +1965,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt (#Map_cong (#axioms param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => rtac ctxt refl ORELSE' EVERY' [ rtac ctxt (#Sb_comp (leader axioms_of_bmv_monad inner) RS fun_cong), - REPEAT_DETERM o assume_tac ctxt + REPEAT_DETERM o (assume_tac ctxt ORELSE' eresolve_tac ctxt cmin_smaller) ]) inners) ], Vrs_bds = map (K (fn ctxt => EVERY1 [ @@ -1913,7 +1988,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], SUBGOAL (fn (goal, _) => let @@ -1934,7 +2013,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], K (Local_Defs.unfold0_tac ctxt ( @{thms image_Un image_UN image_comp[unfolded comp_def] UN_empty2 Union_UN_swap Un_assoc[symmetric] @@ -1948,7 +2031,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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' rtac ctxt @{thm SSupp_Inj_bound}) + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + rtac ctxt (#SSupp_Inj_bound facts), + eresolve_tac ctxt cmin_smaller + ] ], 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]}), rtac ctxt refl ORELSE' EVERY' [ @@ -1971,14 +2058,17 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 resolve_tac ctxt ( + let val thms = filter (null o fst o Logic.strip_horn o Thm.prop_of) prems + in thms @ maps (fn cmin_thm => map_filter (fn thm => try (fn () => thm RS cmin_thm) ()) thms) cmin_smaller end + ), 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 [UnI1, UnI2], + eresolve_tac ctxt ([UnI1, UnI2] @ cmin_smaller), rtac ctxt UnI1 ] ] @@ -1988,7 +2078,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit K (Local_Defs.unfold0_tac ctxt (#Vrs_Map param)), REPEAT_DETERM o FIRST' [ assume_tac ctxt, - resolve_tac ctxt (@{thms SSupp_Inj_bound refl} @ prems), + resolve_tac ctxt ((#SSupp_Inj_bound facts) :: refl :: prems @ cmin_smaller), eresolve_tac ctxt [UnI1, UnI2], rtac ctxt UnI1 ] @@ -2008,7 +2098,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 lthy - in (res, lthy) end;*) in error "compose" end + in (res, lthy) end; fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = let @@ -2083,9 +2173,9 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = Sbs = [fst Sb], Vrs = [map fst Vrs], RVrs = [map fst RVrs], - UNIV_bds = [SOME (leader UNIV_bds_of_bmv_monad bmv)], + UNIV_bds = [leader UNIV_bds_of_bmv_monad bmv], params = [Option.map (fn Map => { Map = fst Map, Supps = map fst (the Supps_opt) }) Map_opt] - }: term option bmv_monad_consts; + }: bmv_monad_consts; val axioms = leader axioms_of_bmv_monad bmv; val params = leader params_of_bmv_monad bmv; @@ -2246,7 +2336,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ] ] }] - } : (Proof.context -> tactic, term option) bmv_monad_model; + } : (Proof.context -> tactic) bmv_monad_model; val ((bmv, _), lthy) = bmv_monad_def BNF_Def.Hardly_Inline (K BNF_Def.Note_Some) qualify NONE model lthy; val new_unfolds = map (Local_Defs.unfold0 lthy unfolds) defs; @@ -2434,7 +2524,7 @@ fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV UNIV_bds = UNIV_bds, RVrs = RVrs, params = param_consts - }: term option bmv_monad_consts; + }: bmv_monad_consts; val (consts, bmv_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 ops frees lives' consts lthy; @@ -2507,7 +2597,7 @@ fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV params = params, bd_infinite_regular_card_order = bd_irco, tacs = axioms - } : (thm, term) bmv_monad_model; + } : 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 lthy; diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index c12fa4fe..c3a57c32 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -101,28 +101,6 @@ 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}); \ -lemma cminE: - assumes "A A R" - shows R -proof (cases "r1 r f1 \1 \2 \4. Sb_T3 \1 \2 Inj_2_T3 \4 \ Map_T3 f1 id" and Sb_T4 @@ -132,7 +110,8 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" Maps: "Map_T3 id" Supps: set_2_T3 bd: natLeq - UNIV_bd: "cmin (cmin (cmin |UNIV::'a set| |UNIV::'b set| ) |UNIV::'c set| ) |UNIV::'d set|" + (* use same bound as original type, even though one of the positions is dead now *) + UNIV_bd: "cmin (cmin |UNIV::'a set| |UNIV::'b set| ) |UNIV::'c set|" apply (rule infinite_regular_card_order_natLeq) apply (unfold T3.Sb_Inj T3.Map_id id_o) @@ -140,23 +119,23 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_assoc T3.Map_Inj) apply (rule T3.Sb_comp_Inj) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_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 (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_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 (erule cmin_smaller_T3' | rule T3.SSupp_Map_bound T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_Map_bound T3.SSupp_Inj_bound)+ apply (rule T3.Map_comp) apply (unfold id_o T3.Map_Inj) - apply (subst T3.Sb_comp_Inj, (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+)+ + apply (subst T3.Sb_comp_Inj, (assumption | rule T3.SSupp_Inj_bound)+)+ apply (rule refl) apply (rule T3.Supp_bd T3.Vrs_bd T3.Vrs_Inj T3.Supp_Inj)+ @@ -164,7 +143,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" subgoal for f \1 \2 \3 x apply (unfold comp_def) apply (subst T3.Supp_Sb) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Supp_Map T3.Supp_Inj UN_empty2 Un_empty_left Un_empty_right) apply (rule refl) done @@ -172,7 +151,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) apply (rule refl) done @@ -181,7 +160,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) apply (rule refl) done @@ -190,7 +169,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Vrs_Map T3.Vrs_Inj UN_empty2 Un_empty_right Un_empty_left) apply (rule refl) done @@ -201,7 +180,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (assumption | rule refl)+ apply (rule T3.Sb_cong) apply (unfold T3.Vrs_Map) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound refl | assumption)+ + apply (assumption | rule T3.SSupp_Inj_bound refl | assumption)+ done apply (rule refl) apply (rule trans) @@ -219,7 +198,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (rule trans[OF comp_assoc[symmetric]]) apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) apply (rule T3.Map_Sb) - apply (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+ + apply (assumption | rule T3.SSupp_Inj_bound)+ apply (unfold T3.Map_Inj comp_assoc) apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule trans) @@ -232,7 +211,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" done apply (unfold comp_def)[1] - apply (subst T3.Supp_Sb, (erule cmin_smaller_T3' | rule T3.SSupp_Inj_bound)+) + apply (subst T3.Supp_Sb, (assumption | rule T3.SSupp_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)+ @@ -264,8 +243,8 @@ abbreviation "Vrs_3_T \ \x. \ (Vrs_1_T3 ` set_3_T1 x)" lemma cmin_smaller_T: "r r r r r r h1 h2 \1 \2 \3 \4 \5. Sb_T1 h1 \1 Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ Map_T3 h2 id)" RVrs: Vrs_1_T1 "\x. \ (Vrs_1_T2 ` set_1_T1 x) \ \ (set_1_T3 ` set_3_T1 x)" @@ -301,7 +279,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule T1.Map_Inj) apply (rule T1.Sb_comp_Inj) - apply (assumption | rule T1.SSupp_Map_bound T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ done subgoal for g1 g2 \'1 \'2 \'3 \'4 \'5 f1 f2 \1 \2 \3 \4 \5 @@ -501,7 +479,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule refl) (* third inner *) apply (rule T3'.Sb_cong) - apply (rule prems cmin_smaller_T)+ + apply (rule prems prems(3-7,10-14)[THEN cmin_smaller_T(3)])+ (* REPEAT_DETERM *) apply (drule UN_I) apply assumption @@ -593,6 +571,7 @@ print_theorems typedef ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T' = "UNIV :: (('a, 'b, 'e, 'd) T2, 'b, 'c, 'g 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. Abs_T' \ (Sb_T1 h1 (Rep_T' \ \1) Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ Map_T3 h2 id)) \ Rep_T'" definition "RVrs_1_T' \ \x. Vrs_1_T1 (Rep_T' x)" diff --git a/thys/Prelim/Prelim.thy b/thys/Prelim/Prelim.thy index bafe214a..9af652cd 100644 --- a/thys/Prelim/Prelim.thy +++ b/thys/Prelim/Prelim.thy @@ -879,6 +879,22 @@ next then show "regularCard (czero +c s2)" using regularCard_ordIso ordIso_symmetric assms by blast qed +lemma cminE: + assumes "A A R" + shows R +proof (cases "r1 nat" where From 7e3ac6da1ee2df9e429fcd9ae2ecb838f6cfc884 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 7 Jul 2025 14:27:42 +0100 Subject: [PATCH 44/90] Use IImsupp everywhere --- Tools/bmv_monad_def.ML | 563 +++++++++++++-------- Tools/mrsbnf_comp.ML | 68 ++- Tools/mrsbnf_def.ML | 383 +++++++++++---- operations/BMV_Composition.thy | 269 ++++++---- operations/BMV_Fixpoint.thy | 793 +++++++++++++++++++++++++++++- operations/MRSBNF_Composition.thy | 13 +- thys/MRBNF_FP.thy | 4 +- thys/Support.thy | 144 +++++- 8 files changed, 1785 insertions(+), 452 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 1b6528bf..d7f439a3 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -24,18 +24,21 @@ signature BMV_MONAD_DEF = sig 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, - SSupp_Inj_bound: thm + IImsupp_Sb_subsetss: thm list list, + IImsupp_Sb_boundss: thm list list }; type bmv_monad_consts = { bd: term, - UNIV_bds: term option list, 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 }; @@ -72,7 +75,6 @@ signature BMV_MONAD_DEF = sig 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 UNIV_bds_of_bmv_monad: bmv_monad -> term option 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; @@ -83,6 +85,8 @@ signature BMV_MONAD_DEF = sig val params_of_bmv_monad: bmv_monad -> thm bmv_monad_param option list; val unfolds_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; @@ -175,19 +179,28 @@ type bmv_monad_facts = { 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, - SSupp_Inj_bound: thm + 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, SSupp_Inj_bound } = { +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, - SSupp_Inj_bound = Morphism.thm phi SSupp_Inj_bound + 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 = { @@ -225,17 +238,16 @@ fun map_bmv_monad_param f ({ axioms, Map_Sb, Supp_Sb, Vrs_Map, Map_Injs }: 'a bm type bmv_monad_consts = { bd: term, - UNIV_bds: term option list, 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, UNIV_bds } = { +fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs, extra_Vrs } = { bd = Morphism.term phi bd, - UNIV_bds = map (Option.map (Morphism.term phi)) UNIV_bds, RVrs = map (map (Morphism.term phi)) RVrs, params = map (Option.map (fn { Map, Supps } => { Map = Morphism.term phi Map, @@ -243,7 +255,8 @@ fun morph_bmv_monad_consts phi { bd, params, Injs, Sbs, Vrs, RVrs, UNIV_bds } = })) params, Injs = map (map (Morphism.term phi)) Injs, Sbs = map (Morphism.term phi) Sbs, - Vrs = map (map (Morphism.term phi)) Vrs + Vrs = map (map (Morphism.term phi)) Vrs, + extra_Vrs = map (map (Morphism.term phi)) extra_Vrs }: bmv_monad_consts; datatype bmv_monad = BMV of { @@ -292,11 +305,11 @@ 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 UNIV_bds_of_bmv_monad = #UNIV_bds 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 @@ -370,12 +383,34 @@ fun pbmv_monad_of_generic context = val pbmv_monad_of = pbmv_monad_of_generic o Context.Proof; -fun mk_small_prems fs rhos Injs UNIV_bd = - map (HOLogic.mk_Trueprop o mk_supp_bound) fs - @ map2 (fn rho => fn Inj => HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (MRBNF_Util.mk_SSupp Inj $ rho)) - (the UNIV_bd) - )) rhos Injs; +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 @@ -384,8 +419,9 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = 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 UNIV_bds => fn Sb => fn (Vrs: term list) => fn (RVrs: term list) => + 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; @@ -405,8 +441,9 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = val Sb_Inj = mk_Trueprop_eq (Term.list_comb (Sb, f_ids @ Injs), HOLogic.id_const T); - val small_prems = mk_small_prems fs rhos Injs UNIV_bds; - val small_prems' = mk_small_prems gs rhos' Injs UNIV_bds; + 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 ( @@ -447,7 +484,7 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = 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) (RVrs @ Vrs); + ) 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 => @@ -508,10 +545,10 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = Vrs_Sbs = Vrs_Sbs, Sb_cong = Sb_cong } : term bmv_monad_axioms end - ) ops (#Injs consts) (#UNIV_bds consts) (#Sbs consts) (#Vrs consts) (#RVrs consts); + ) ops (#Injs consts) (#Sbs consts) (#Vrs consts) (#RVrs consts) (#extra_Vrs consts); in axioms end; -fun mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd params lthy = +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); @@ -526,7 +563,9 @@ fun mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd params lthy = ||>> 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];; + ||>> 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 ( @@ -567,7 +606,7 @@ fun mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd params lthy = ))); val Map_Sb = fold_rev Logic.all (fs @ hs @ rhos) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs UNIV_bds) (mk_Trueprop_eq ( + 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 => @@ -593,7 +632,7 @@ fun mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd params lthy = ) (RVrs @ Vrs); val Supp_Sb = map (fn Supp => fold_rev Logic.all (rhos @ hs @ [x]) ( - fold_rev (curry Logic.mk_implies) (mk_small_prems hs rhos Injs UNIV_bds) (mk_Trueprop_eq ( + 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, ... } => @@ -653,11 +692,13 @@ fun maybe_define const_policy fact_policy b rhs lthy = 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 const_policy fact_policy qualify leader ops frees lives' (consts: bmv_monad_consts) lthy = +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 fact_policy o qualify; + val maybe_define' = maybe_define (*const_policy*) BNF_Def.Hardly_Inline fact_policy o qualify; - val suffixes = map_index (fn (i, T) => Binding.suffix_name ("_" ^ (case T of + 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 ^ "_") (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; @@ -683,12 +724,19 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees li 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; @@ -706,21 +754,14 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees li val ((bd, bd_def), lthy) = maybe_define' (Binding.name "bd") (#bd consts) lthy; - val UNIV_bds = @{map 4} (fn SOME t => K (K (K (SOME t))) | NONE => fn frees => fn Injs => fn T => - let - val frees' = inter (op=) (map TFree (fold Term.add_tfrees Injs [])) frees; - val frees' = inter (op=) frees' (rev (map TFree (Term.add_tfreesT T []))); (* reorder frees *) - in try (foldl1 mk_cmin) (map (mk_card_of o HOLogic.mk_UNIV) frees') end - ) (#UNIV_bds consts) frees Injs ops; - val consts' = { bd = bd, params = params, Injs = Injs, Sbs = Sbs, - UNIV_bds = UNIV_bds, RVrs = RVrs, - Vrs = Vrs + Vrs = Vrs, + extra_Vrs = extra_Vrs } : bmv_monad_consts; val (lthy, old_lthy) = `Local_Theory.end_nested lthy; @@ -732,7 +773,7 @@ fun define_bmv_monad_consts const_policy fact_policy qualify leader ops frees li 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 @ [bd_def] @ flat param_defs); + 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 = @@ -772,9 +813,12 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = ("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, []), - ("SSupp_Inj_bound", map #SSupp_Inj_bound 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), [ @@ -792,12 +836,12 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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), - UNIV_bds = #UNIV_bds (#consts model) @ maps (#UNIV_bds 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) + 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 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 @@ -807,7 +851,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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))), + K (Local_Defs.unfold0_tac ctxt (flat (maps #Vrs_Injss axioms'))), etac ctxt @{thm singleton_inject}, hyp_subst_tac ctxt, rtac ctxt refl @@ -816,10 +860,10 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona )) (#Injs (#consts model)) (#Vrs (#consts model)); val Un_bound = MRBNF_Def.get_class_assumption [#var_class model] "Un_bound" lthy; + val UN_bound = MRBNF_Def.get_class_assumption [#var_class model] "UN_bound" lthy; val UNIV_cinfinite = MRBNF_Def.get_class_assumption [#var_class model] "UNIV_cinfinite" lthy; val Injss = #Injs (#consts model); - val UNIV_bds = #UNIV_bds (#consts model); val (((rhoss, hss), fss), names_lthy) = lthy |> mk_Freess "\" (map (map fastype_of) Injss) @@ -857,10 +901,19 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona ])) end else NONE ) Injs) Supps)) (#lives model) (#lives' model) (#params model) Injss (#params (#consts model)) - val SSupp_premss = @{map 4} mk_small_prems hss rhoss Injss UNIV_bds; + 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 14} (fn params => fn param_consts => fn axioms => fn T => fn SSupp_prems => fn lives => fn lives' => fn frees => fn fs => fn Injs => fn UNIV_bd => fn rhos => fn hs => fn Sb => + 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 ( @@ -881,6 +934,23 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 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 = @{map_filter 2} (fn Inj => fn rho => if body_type (fastype_of Inj) <> T then NONE else let val (rho', _) = names_lthy @@ -910,11 +980,11 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona let val (rho, _) = names_lthy |> apfst hd o mk_Frees "\'" [fastype_of Inj]; - val SSupp_prem = HOLogic.mk_Trueprop (mk_ordLess (mk_card_of (mk_SSupp Inj $ rho)) (the UNIV_bd)); + 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 - ))) (the UNIV_bd) + ))) (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}, @@ -925,33 +995,141 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona ])) end ) Injs; - val SSupp_Inj_bound = the_default @{thm SSupp_Inj_bound} (Option.map (fn UNIV_bd => + val IImsupp_Sb_subsetss = map_filter (fn Inj => + if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vrs => + let + val (rho', _) = names_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 (#RVrs consts) idx @ nth (#Vrs consts) 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 axioms), + 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 + ) (RVrs @ Vrs))) Injs; + + val IImsupp_Sb_boundss = map_filter (fn Inj => + if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vr => let - val Inj = Free ("Inj", @{typ "'a \ 'b"}); + val (rho', _) = names_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')) + ) (RVrs @ Vrs) + ); val goal = HOLogic.mk_Trueprop (mk_ordLess - (mk_card_of (mk_SSupp Inj $ Inj)) - UNIV_bd - ) in Goal.prove_sorry lthy (names [Inj]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - REPEAT_DETERM o resolve_tac ctxt @{thms cmin_Card_order card_of_Card_order SSupp_Inj_bound cmin_greater} + (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}) (maps #Vrs_bds axioms') @ + @{thms var_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV var_class.large'} + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ] ]) end - ) UNIV_bd); + ) (RVrs @ Vrs))) Injs; 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, - SSupp_Inj_bound = SSupp_Inj_bound + 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 UNIV_bds rhoss hss (#Sbs (#consts model)); + ) (#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, - SSupp_Inj_bound = #SSupp_Inj_bound 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 { @@ -964,7 +1142,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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, + 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 @@ -985,9 +1163,13 @@ fun prove_axioms (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = fun prove_params (model: (Proof.context -> tactic) bmv_monad_model) defs lthy = let - val goals = @{map 6} (fn Sb => fn RVrs => fn Vrs => fn Injs => fn UNIV_bds => Option.map (fn param => - mk_param_axiom (#Map param) (#Supps param) Sb Injs UNIV_bds RVrs Vrs (#bd (#consts 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)) (#Injs (#consts model)) (#UNIV_bds (#consts model)) (#params (#consts model)) + 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 @@ -1032,7 +1214,7 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont 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 const_policy (fact_policy lthy) qualify + 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; @@ -1079,7 +1261,9 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = MRBNF_Def.interlace gs (map HOLogic.id_const bounds) (map HOLogic.id_const frees) (MRBNF_Def.var_types_of_mrbnf mrbnf) )) ); - in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I NONE { + val name = MRBNF_Def.name_of_mrbnf mrbnf; + val _ = @{print} ("MRBNF name" , name) + in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I (SOME name) { ops = [T], var_class = var_class, leader = 0, @@ -1091,10 +1275,10 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = consts = { bd = MRBNF_Def.bd_of_mrbnf mrbnf, Injs = [[]], - UNIV_bds = [NONE], Sbs = [Sb], Vrs = [[]], RVrs = [fsets], + extra_Vrs = [[]], params = [Option.map (fn Map => { Map = Map, Supps = lsets @@ -1200,10 +1384,10 @@ fun slice_bmv_monad n bmv = Map = Map, Supps = Supps }) (f (Maps_of_bmv_monad bmv)) (f (Supps_of_bmv_monad bmv))], Injs = [f (Injs_of_bmv_monad bmv)], - UNIV_bds = [f (UNIV_bds_of_bmv_monad bmv)], Sbs = [Sb], RVrs = [f (RVrs_of_bmv_monad bmv)], - Vrs = [f (Vrs_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, @@ -1307,14 +1491,18 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives )) 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, - UNIV_bds = map (leader UNIV_bds_of_bmv_monad) demoted_bmvs, params = new_params, - bd = bd_of_bmv_monad bmv + 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, ... } => @@ -1368,7 +1556,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]} ], rtac ctxt (#Map_Sb (the params)), - REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt (#SSupp_Inj_bound facts)), + 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))] @@ -1379,7 +1567,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt (#SSupp_Inj_bound facts)) + 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)) @@ -1396,7 +1584,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives ])) (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 6} (fn T => fn Injs => fn RVrs => fn axioms => fn params => fn facts => { + 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, @@ -1404,7 +1592,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt (#SSupp_Inj_bound facts)) + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) ]) ) Injs, Sb_comp = fn ctxt => EVERY1 [ @@ -1416,7 +1604,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt (#SSupp_Inj_bound facts)), + 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)), @@ -1426,26 +1614,27 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives rtac ctxt trans, rtac ctxt (#Sb_comp axioms) ], - REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt ((#SSupp_Inj_bound facts) - :: maps (the_default [] o #SSupp_Map_bounds) (facts_of_bmv_monad bmv) + 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' rtac ctxt (#SSupp_Inj_bound facts)) + 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), + ) 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' rtac ctxt (#SSupp_Inj_bound facts)) + 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} + 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 => @@ -1464,11 +1653,11 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives 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' rtac ctxt (#SSupp_Inj_bound facts)), + 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 (map (hd o axioms_of_bmv_monad) demoted_bmvs) + }) 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 @@ -1589,9 +1778,12 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 Option.map (Term.absfree (dest_Free x)) ( - try (foldl1 mk_Un) (outer_RVrs @ inner_RVrs) - ) end + 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 => @@ -1603,7 +1795,10 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 Term.absfree (dest_Free x) (foldl1 mk_Un (outer_Vrs @ inner_Vrs)) end + 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 @@ -1664,15 +1859,6 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 T = leader ops_of_bmv_monad outer; - - val UNIV_bd = - let - val ts = map_filter (leader UNIV_bds_of_bmv_monad) (outer :: new_minions) - val frees' = map TFree (rev (fold Term.add_tfrees ts [])); - val frees' = inter (op=) frees' (rev (map TFree (Term.add_tfreesT T []))); (* reorder frees *) - in try (foldl1 mk_cmin) (map (mk_card_of o HOLogic.mk_UNIV) frees') end; - val consts = { bd = bd_of_bmv_monad outer, (* TODO: compose bounds *) Injs = [new_Injs], @@ -1680,7 +1866,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit Vrs = [new_Vrs], RVrs = [new_RVrs], params = [param], - UNIV_bds = [UNIV_bd] + 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; @@ -1689,22 +1875,6 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit lhs = rhs ) (try (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm))); - val cmin_smaller = the_default [] (Option.map (fn UNIV_bd => map_filter (Option.map (fn inner_bd => - let - val (rT, _) = lthy - |> fold Variable.declare_typ (map TFree (Term.add_tfrees UNIV_bd [])) - |> apfst hd o mk_TFrees 1; - val r = Free ("r", mk_relT (rT, rT)); - val goal = Logic.mk_implies ( - HOLogic.mk_Trueprop (mk_ordLess r UNIV_bd), - HOLogic.mk_Trueprop (mk_ordLess r inner_bd) - ); - in Goal.prove_sorry lthy ["r"] [] goal (fn {context=ctxt, ...} => EVERY1 [ - REPEAT_DETERM o (resolve_tac ctxt @{thms card_of_Card_order cmin_Card_order} ORELSE' etac ctxt @{thm cminE}), - REPEAT_DETERM o (resolve_tac ctxt @{thms card_of_Card_order cmin_Card_order cmin_greater} ORELSE' assume_tac ctxt) - ]) end - )) (map (leader UNIV_bds_of_bmv_monad) (outer :: inners'))) UNIV_bd); - val model = { ops = [T], bmv_ops = new_minions, @@ -1791,21 +1961,17 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt @{thm trans[OF comp_assoc[symmetric]]}, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Map_Sb param), - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + 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 ], - TRY o rtac ctxt @{thm arg_cong2[OF refl, of _ _ "(\)"]}, rtac ctxt ext, rtac ctxt (#Map_cong (#axioms param)), EVERY' (map (fn Inr _ => rtac ctxt refl | Inl inner => FIRST' [ @@ -1814,11 +1980,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ], + 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 ] @@ -1828,11 +1990,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), TRY o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (#Supp_Sb param), - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) ], SUBGOAL (fn (goal, _) => let @@ -1851,11 +2009,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ), 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + 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 @@ -1864,11 +2018,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit )), 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + 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' [ @@ -1897,7 +2047,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) new_Injs } end) param], leader = 0, - tacs = @{map 8} (fn axioms => fn param => fn facts => fn T => fn Map => fn Injs => fn RVrs => fn Vrs => { + 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)) @@ -1909,11 +2059,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) ]) ) new_Injs, Sb_comp = fn ctxt => EVERY1 [ @@ -1926,11 +2072,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "(\)"]}, rtac ctxt (#Map_Sb param), - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ], + 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 _ _ "(\)"]} ], @@ -1940,8 +2082,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit EqSubst.eqsubst_tac ctxt [0] [#Sb_comp axioms], REPEAT_DETERM o FIRST' [ assume_tac ctxt, - resolve_tac ctxt ((#SSupp_Inj_bound facts) :: the (#SSupp_Map_bounds facts)), - eresolve_tac ctxt cmin_smaller + 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, @@ -1951,12 +2094,11 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit REPEAT_DETERM o FIRST' [ assume_tac ctxt, resolve_tac ctxt ( - @{thms refl supp_comp_bound infinite_class.infinite_UNIV} - @ [#SSupp_Inj_bound facts] + @{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') - ), - eresolve_tac ctxt cmin_smaller + ) ] ]) ], @@ -1964,8 +2106,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 ctxt (#Sb_comp (leader axioms_of_bmv_monad inner) RS fun_cong), - REPEAT_DETERM o (assume_tac ctxt ORELSE' eresolve_tac ctxt cmin_smaller) + 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 [ @@ -1983,16 +2125,12 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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), + ) 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms SSupp_Inj_bound IImsupp_Inj_bound}) ], SUBGOAL (fn (goal, _) => let @@ -2013,11 +2151,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + 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] @@ -2031,11 +2165,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 FIRST' [ - assume_tac ctxt, - rtac ctxt (#SSupp_Inj_bound facts), - eresolve_tac ctxt cmin_smaller - ] + 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]}), rtac ctxt refl ORELSE' EVERY' [ @@ -2059,8 +2189,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 ( - let val thms = filter (null o fst o Logic.strip_horn o Thm.prop_of) prems - in thms @ maps (fn cmin_thm => map_filter (fn thm => try (fn () => thm RS cmin_thm) ()) thms) cmin_smaller end + filter (null o fst o Logic.strip_horn o Thm.prop_of) prems ), REPEAT_DETERM o EVERY' [ resolve_tac ctxt prems, @@ -2068,7 +2197,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit assume_tac ctxt, REPEAT_DETERM o FIRST' [ assume_tac ctxt, - eresolve_tac ctxt ([UnI1, UnI2] @ cmin_smaller), + eresolve_tac ctxt [UnI1, UnI2], rtac ctxt UnI1 ] ] @@ -2078,7 +2207,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit K (Local_Defs.unfold0_tac ctxt (#Vrs_Map param)), REPEAT_DETERM o FIRST' [ assume_tac ctxt, - resolve_tac ctxt ((#SSupp_Inj_bound facts) :: refl :: prems @ cmin_smaller), + resolve_tac ctxt (refl :: @{thms SSupp_Inj_bound IImsupp_Inj_bound} @ prems), eresolve_tac ctxt [UnI1, UnI2], rtac ctxt UnI1 ] @@ -2091,7 +2220,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit [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] + [new_Injs] [new_RVrs] [new_Vrs] (#extra_Vrs consts) } : (Proof.context -> tactic) bmv_monad_model; val name = qualify (Binding.conglomerate (map_filter ( @@ -2123,7 +2252,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = fun mk_name s = s ^ "_" ^ short_type_name T_name val (_, lthy) = Local_Theory.begin_nested lthy; - val ((((Sb, RVrs), Injs), Vrs), lthy) = 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, fs @ map (fn rho => if body_type (fastype_of rho) = T then HOLogic.mk_comp (rep, rho) else rho) rhos @@ -2132,7 +2261,8 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ||>> 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 "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 @@ -2144,7 +2274,6 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = )) ||>> apfst SOME o mk_defs_t (mk_name "Supp") 0 (map (fn Supp => HOLogic.mk_comp (Supp, rep)) (the (leader Supps_of_bmv_monad bmv))) - val (lthy, old_lthy) = `Local_Theory.end_nested lthy; val phi = Proof_Context.export_morphism old_lthy lthy; @@ -2157,6 +2286,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = 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; @@ -2165,7 +2295,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = (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 @ the_default [] (Option.map (fn Map => snd Map :: map snd (the Supps_opt)) Map_opt); + 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, @@ -2173,7 +2303,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = Sbs = [fst Sb], Vrs = [map fst Vrs], RVrs = [map fst RVrs], - UNIV_bds = [leader UNIV_bds_of_bmv_monad bmv], + 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; @@ -2228,7 +2358,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ] }, Map_Sb = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ([snd (the Map_opt), snd Sb, @{thm SSupp_type_copy} OF [copy]] @ Inj_defs)), + 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, @@ -2242,10 +2372,11 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ], Supp_Sb = map (fn _ => fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt ([ - snd Sb, @{thm SSupp_type_copy} OF [copy], #Abs_inverse (snd info) OF @{thms UNIV_I}, + 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} - ] @ Inj_defs @ map snd Supps @ map snd Vrs @ map snd RVrs)), + ] @ 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}), @@ -2283,7 +2414,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ], 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]] @ Inj_defs)), + 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]}, @@ -2295,7 +2426,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ]) ) Injs, Sb_comp = fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ([snd Sb, @{thm SSupp_type_copy} OF [copy]] @ Inj_defs)), + 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, @@ -2309,23 +2440,24 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ])) (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} @ map snd Vrs @ map snd RVrs @ Inj_defs @ [#Abs_inverse (snd info) OF @{thms UNIV_I}])), + 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), + ) Injs)) (RVrs @ Vrs @ extra_Vrs), Vrs_Sbs = map (K (fn ctxt => EVERY1 [ K (Local_Defs.unfold0_tac ctxt ([ - snd Sb, @{thm SSupp_type_copy} OF [copy], #Abs_inverse (snd info) OF @{thms UNIV_I}, + 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} - ] @ Inj_defs @ map snd Vrs @ map snd RVrs)), + ] @ defs)), 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]] @ Inj_defs @ map snd Vrs @ map snd RVrs)), + 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, @@ -2343,7 +2475,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = in ((bmv, new_unfolds, defs, (T_name, info)), lthy) end -fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV_bds) lthy = +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)) => @@ -2497,40 +2629,45 @@ fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV )) (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 UNIV_bds = @{map 3} (fn deads => fn frees => fn s => if s = "_" then NONE else - let - val t = Syntax.read_term lthy s; - val t = Term.map_types (Term.map_atyps (fn T as TFree (x, _) => - the_default T (List.find (curry (op=) x o fst o dest_TFree) (frees @ deads)) - | _ => raise Same.SAME)) t; - in SOME t end - ) deadss frees (UNIV_bds @ replicate (length ops - length UNIV_bds) "_"); - val consts = { bd = bd, Injs = Injs, Sbs = Sbs, Vrs = Vrs, - UNIV_bds = UNIV_bds, RVrs = RVrs, + extra_Vrs = extra_Vrs, params = param_consts }: bmv_monad_consts; - val (consts, bmv_defs, lthy) = define_bmv_monad_consts BNF_Def.Smart_Inline BNF_Def.Dont_Note I 0 + 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 UNIV_bds => fn RVrs => fn Vrs => Option.map (fn { Map, Supps } => - mk_param_axiom Map Supps Sb Injs UNIV_bds RVrs Vrs bd (map_filter I (#params consts @ maps (#params o consts_of_bmv_monad) bmv_ops)) lthy - )) (#Sbs consts) (#Injs consts) (#UNIV_bds consts) (#RVrs consts) (#Vrs consts) (#params consts); + 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; @@ -2599,7 +2736,7 @@ fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV 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 lthy; + 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; @@ -2614,7 +2751,7 @@ fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), UNIV ) param) ) goals param_goals) )) lthy - |> Proof.unfolding ([[(bmv_defs, [])]]) + |> 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; @@ -2672,7 +2809,9 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} )) ) -- ((Parse.reserved "bd" -- @{keyword ":"}) |-- Parse.term)) -- - (Scan.optional ((Parse.reserved "UNIV_bd" -- @{keyword ":"}) |-- Parse.and_list1 (Parse.underscore || Parse.term)) []) + (Scan.optional ((Parse.reserved "extra_Vrs" -- @{keyword ":"}) |-- + Parse.and_list1 (Scan.repeat (Parse.underscore || Parse.term)) + ) []) >> pbmv_monad_cmd) end \ No newline at end of file diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 9e3a5bf0..87000eca 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -10,9 +10,9 @@ signature MRSBNF_COMP = sig 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 -> ((thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) + -> 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)) - * ((thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)) * local_theory) + * (((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 -> typ list -> typ list -> MRSBNF_Def.mrsbnf -> (string * Typedef.info) option -> local_theory @@ -205,12 +205,15 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 _ = @{print} ("Ts", map MRBNF_Def.T_of_mrbnf inner_mrbnfs) + 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 _ = @{print} (MRBNF_Def.T_of_mrbnf mrbnf, T) 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 @@ -246,7 +249,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A NONE => false | SOME (lhs, rhs) => lhs = rhs ); - val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def fact_policy (qualify 0) NONE mrbnfs bmv + 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), @@ -323,7 +326,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 (bmv_unfolds @ #map_unfolds (snd mrbnf_unfolds)) + 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 @@ -469,7 +472,7 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A }) axioms') lthy; in ((mrsbnf, tys), ((old_bmv_unfold @ bmv_unfolds, mrbnf_unfolds), lthy)) end -fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:(thm list * (MRBNF_Comp.comp_cache * MRBNF_Comp.unfold_set)), lthy:local_theory) = +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)) @@ -483,8 +486,8 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:(thm list * ) ) | 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)) ((bmv_unfolds:thm list, accum), lthy) = (case mrsbnf_of lthy n of - NONE => ((Inr MRBNF_Comp.DEADID_mrbnf, ([T], [])), ((bmv_unfolds, accum), lthy)) + | 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 @@ -511,7 +514,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:(thm list * else case outer of Inl mrsbnf => error "TODO: Demote MRSBNF" | 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')), accum) end + 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; @@ -539,29 +542,54 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:(thm list * ) oAs) val Ts' = map (nth Ts) (subtract (op =) (oDs_pos @ ofree_bound_pos) (0 upto length Ts - 1)); - val ((inners, (Dss, Ass)), ((bmv_unfolds:thm list, accum), lthy)) = + val ((inners, (Dss, Ass)), (((mrsbnf_cache, bmv_unfolds:thm list), 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) - (if length Ts' = 1 then [0] else 1 upto length Ts') Ts' ((bmv_unfolds, accum), lthy)); + (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 - val (outer', lthy) = case outer of - Inl mrsbnf => (mrsbnf, lthy) - | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf lthy - val (inners', lthy) = fold_map (fn Inl mrsbnf => pair mrsbnf - | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf - ) inners lthy; - val ((mrsbnf, tys), accum) = compose_mrsbnfs BNF_Def.Smart_Inline const_policy qualify outer' inners' + 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 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 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 ((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), accum) end + in ((Inl mrsbnf, tys), (((mrsbnf_cache, unfolds), accum), lthy)) end else - apsnd (apfst (pair bmv_unfolds)) (apfst (apfst Inr) (MRBNF_Comp.compose_mrbnf MRBNF_Def.Smart_Inline qualify (distinct (op=) o flat) + (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 ); diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 63f0dd04..09b87d8c 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -13,7 +13,6 @@ signature MRSBNF_DEF = sig SSupp_map_subset: thm option list, SSupp_map_bound: thm option list, map_Inj: thm option list, - Sb_comp_right: thm, map_Sb_strong: thm, Map_map: thm option, set_Injs: thm list list @@ -86,19 +85,17 @@ type mrsbnf_facts = { SSupp_map_subset: thm option list, SSupp_map_bound: thm option list, map_Inj: thm option list, - Sb_comp_right: thm, 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, Sb_comp_right, map_Sb_strong, Map_map, set_Injs + SSupp_map_subset, SSupp_map_bound, map_Inj, map_Sb_strong, Map_map, set_Injs }: 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, map_Inj = map (Option.map (Morphism.thm phi)) map_Inj, - Sb_comp_right = Morphism.thm phi Sb_comp_right, 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 @@ -163,7 +160,6 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("SSupp_map_bound", maps (map_filter I o #SSupp_map_bound) facts, []), ("map_Inj_raw", maps (the_default [] o #map_Injs) axioms, []), ("map_Inj", maps (map_filter I o #map_Inj) facts, []), - ("Sb_comp_right", map #Sb_comp_right facts, []), ("map_Sb_strong", map #map_Sb_strong facts, []), ("Map_map", map_filter #Map_map facts, []), ("set_Inj", flat (maps #set_Injs facts), []) @@ -186,7 +182,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ); val names = map (fst o dest_Free); - val facts' = @{map 11} (fn lives => fn lives' => fn axioms => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn Injs => fn RVrs => fn Map_opt => + 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; @@ -221,39 +217,6 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 Sb_comp_right = - let - val fs' = map (the o find_f o domain_type o fastype_of) gs; - val f'_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) fs'; - val goal = Term.subst_atomic_types (As' ~~ As) (mk_Trueprop_eq ( - Term.list_comb (Sb, map2 (curry HOLogic.mk_comp) (hs @ gs) (h_fs @ fs')), - HOLogic.mk_comp ( - Term.list_comb (Sb, hs @ gs), - Term.list_comb (mapx, map (fn T => case List.find (fn f => (domain_type T) = domain_type (fastype_of f)) (h_fs @ fs') of - SOME f => f | NONE => HOLogic.id_const (domain_type T) - ) (fst (split_last (binder_types (fastype_of mapx))))) - ) - )); - in Goal.prove_sorry lthy (names (distinct (op=) (h_fs @ fs' @ hs @ gs))) (distinct (op=) (h_fs_prems @ f'_prems @ h_prems @ g_prems)) goal (fn {context=ctxt, prems} => EVERY1 [ - EqSubst.eqsubst_tac ctxt [0] [#map_is_Sb axioms], - REPEAT_DETERM o resolve_tac ctxt prems, - K (Local_Defs.unfold0_tac ctxt (@{thms o_id} - @ the_default [] (Option.map (single o #Map_id o #axioms) bmv_params) - )), - TRY o EVERY' [ - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt (#Sb_comp bmv_axioms), - REPEAT_DETERM o resolve_tac ctxt (@{thms SSupp_comp_bound SSupp_Inj_bound infinite_class.infinite_UNIV} @ prems), - K (Local_Defs.unfold0_tac ctxt @{thms comp_assoc[symmetric]}), - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps #Sb_comp_Injs (BMV_Monad_Def.axioms_of_bmv_monad bmv)), - REPEAT_DETERM o resolve_tac ctxt prems - ] - ], - rtac ctxt refl - ]) end; - 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); @@ -294,7 +257,10 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ], 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} @ prems), + 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; @@ -358,6 +324,171 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ]) 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 var_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, + 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; @@ -407,17 +538,18 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b in { SSupp_map_subset = SSupp_map_subset, SSupp_map_bound = SSupp_map_bound, + IImsupp_map_bound = IImsupp_map_bound, + IImsupp_map_bound' = IImsupp_map_bound', map_Inj = map_Inj, - Sb_comp_right = Sb_comp_right, 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.Maps_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 9} (fn axioms => fn facts => fn mrbnf => fn bmv_axioms => fn bmv_params => fn bmv_facts => fn Sb => fn RVrs => fn Injs => + 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; @@ -437,12 +569,13 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 ( + (*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; + )) 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_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 = @@ -474,7 +607,15 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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'); - in Goal.prove_sorry lthy (names (fs @ hs @ gs)) (f_prems @ h_prems @ g_prems) goal (fn {context=ctxt, prems} => EVERY1 [ + + 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 [ @@ -520,26 +661,39 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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)), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} - @ prems + 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), - REPEAT_DETERM o EVERY' [ - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - resolve_tac ctxt ( - @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} - @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) - @ maps (map_filter I o #SSupp_map_bound) facts' - ) - ], + 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' [ @@ -551,24 +705,55 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ] ], rtac ctxt (#Sb_comp bmv_axioms), - REPEAT_DETERM o EVERY' [ - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - resolve_tac ctxt ( - @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} - @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) - @ maps (map_filter I o #SSupp_map_bound) facts' - ) + 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 var_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 resolve_tac ctxt ( - @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} - @ prems @ maps (the_default [] o #SSupp_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) - ), + 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 var_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}), @@ -583,13 +768,27 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 EVERY' [ - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_assoc}), - resolve_tac ctxt ( - @{thms supp_id_bound supp_comp_bound supp_inv_bound infinite_class.infinite_UNIV SSupp_comp_bound SSupp_Inj_bound} - @ prems @ maps (the_default [] o #SSupp_Map_bounds) (BMV_Monad_Def.facts_of_bmv_monad bmv) - @ maps (map_filter I o #SSupp_map_bound) facts' - ) + 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 var_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, @@ -623,12 +822,11 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b SSupp_map_subset = #SSupp_map_subset facts, SSupp_map_bound = #SSupp_map_bound facts, map_Inj = #map_Inj facts, - Sb_comp_right = #Sb_comp_right facts, map_Sb_strong = map_Sb_strong, Map_map = #Map_map facts, set_Injs = #set_Injs facts }: mrsbnf_facts end - ) 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) + ) (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); @@ -687,9 +885,12 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val free = length frees; val free_fs = take free free_fs'; - val free_prems = map (fn f => HOLogic.mk_Trueprop (mk_supp_bound f)) free_fs; - val live_fs' = filter (member (op=) lives o domain_type o fastype_of) live_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 _ = @{print} (MRBNF_Def.frees_of_mrbnf mrbnf, MRBNF_Def.bounds_of_mrbnf mrbnf, MRBNF_Def.lives_of_mrbnf mrbnf) + val _ = @{print} (Fs, Bs, As) 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 @@ -712,6 +913,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ) Injs) ) end ))); + val _ = @{print} (Thm.cterm_of lthy map_is_Sb) val RVrs_aTs = map (HOLogic.dest_setT o body_type o fastype_of) RVrs; @@ -806,7 +1008,8 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = map_Sb = map_Sb, set_Sb = set_Sbs }: term mrsbnf_axioms end - ) mrbnfs (BMV_Monad_Def.Sbs_of_bmv_monad bmv) (BMV_Monad_Def.Injs_of_bmv_monad bmv) + ) 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 @@ -844,7 +1047,7 @@ fun mrsbnf_of_mrbnf mrbnf lthy = in BMV_Monad_Def.morph_bmv_monad phi bmv end; in mrsbnf_def (K BNF_Def.Dont_Note) I NONE [mrbnf] bmv [{ map_Sb = SOME (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms id_o o_id}), + 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}), @@ -856,6 +1059,7 @@ fun mrsbnf_of_mrbnf mrbnf lthy = ] ]), 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, @@ -867,7 +1071,7 @@ fun mrsbnf_of_mrbnf mrbnf lthy = ], 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}), + 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), @@ -875,7 +1079,10 @@ fun mrsbnf_of_mrbnf mrbnf lthy = rtac ctxt @{thm image_id} ] ]), - set_Vrs = replicate (MRBNF_Def.free_of_mrbnf mrbnf) (fn ctxt => rtac ctxt refl 1) + 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 = diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index c3a57c32..90baf104 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -32,7 +32,8 @@ 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 \ 'f 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" @@ -53,6 +54,9 @@ Multithreading.parallel_proofs := 0 \ 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 @@ -79,7 +83,7 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) 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_2_T3 + Supps: set_1_T3 set_3_T3 bd: natLeq apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ done @@ -87,7 +91,7 @@ print_theorems print_pbmv_monads type_synonym ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T = - "(('a, 'b, 'e, 'd) T2, 'b, 'c, 'g set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1" + "(('a, 'b, 'e, 'd) T2, 'b, 'c, 'f set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1" (* deads: 'a, 'e, 'f, 'g @@ -103,39 +107,37 @@ 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 \4. Sb_T3 \1 \2 Inj_2_T3 \4 \ Map_T3 f1 id" and Sb_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_T4 and Inj_1_T4 Inj_2_T4 - Vrs: Vrs_1_T3 Vrs_2_T3 Vrs_4_T3 and Vrs_1_T4 Vrs_2_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 id" - Supps: set_2_T3 + Supps: set_3_T3 bd: natLeq - (* use same bound as original type, even though one of the positions is dead now *) - UNIV_bd: "cmin (cmin |UNIV::'a set| |UNIV::'b set| ) |UNIV::'c set|" - 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 T3.SSupp_Inj_bound)+ + 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 T3.SSupp_Inj_bound)+ + 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.SSupp_Inj_bound)+ + 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 (subst T3.Sb_comp_Inj, (assumption | rule T3.SSupp_Inj_bound)+)+ apply (rule refl) apply (rule T3.Supp_bd T3.Vrs_bd T3.Vrs_Inj T3.Supp_Inj)+ @@ -143,15 +145,24 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" subgoal for f \1 \2 \3 x apply (unfold comp_def) apply (subst T3.Supp_Sb) - apply (assumption | rule T3.SSupp_Inj_bound)+ - apply (unfold T3.Vrs_Map T3.Supp_Map T3.Supp_Inj UN_empty2 Un_empty_left Un_empty_right) + 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 T3.SSupp_Inj_bound)+ + 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 @@ -160,7 +171,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (assumption | rule T3.SSupp_Inj_bound)+ + 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 @@ -169,7 +180,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (unfold comp_def) apply (rule trans) apply (rule T3.Vrs_Sb) - apply (assumption | rule T3.SSupp_Inj_bound)+ + 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 @@ -180,7 +191,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (assumption | rule refl)+ apply (rule T3.Sb_cong) apply (unfold T3.Vrs_Map) - apply (assumption | rule T3.SSupp_Inj_bound refl | assumption)+ + apply (assumption | rule SSupp_Inj_bound IImsupp_Inj_bound refl)+ done apply (rule refl) apply (rule trans) @@ -198,7 +209,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" apply (rule trans[OF comp_assoc[symmetric]]) apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) apply (rule T3.Map_Sb) - apply (assumption | rule T3.SSupp_Inj_bound)+ + 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) @@ -211,7 +222,7 @@ pbmv_monad T3': "('a, 'b, 'c, 'd, 'e, 'f) T3" and "('a, 'c) T4" done apply (unfold comp_def)[1] - apply (subst T3.Supp_Sb, (assumption | rule T3.SSupp_Inj_bound)+) + 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)+ @@ -230,7 +241,7 @@ let 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, true, false], lives = [Free_Var, Live_Var] } + { frees = [false, false, false], lives = [Free_Var, Live_Var] } lthy val lthy = register_pbmv_monad "BMV_Composition.T3''" bmv lthy in lthy end @@ -241,33 +252,14 @@ 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)" -lemma cmin_smaller_T: - "r r r r h1 h2 \1 \2 \3 \4 \5. Sb_T1 h1 \1 Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ Map_T3 h2 id)" + 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_T2 Inj_1_T3 Inj_1_T4 Inj_2_T4 - Vrs: Vrs_2_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_4_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_2_T3 ` set_3_T1 x)" + Supps: "\x. \ (set_3_T3 ` set_3_T1 x)" bd: natLeq - UNIV_bd: "cmin (cmin (cmin (cmin |UNIV::'b set| |UNIV::'d set| ) |UNIV::'c set| ) |UNIV::'g set| ) |UNIV::'a set|" 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) @@ -279,7 +271,16 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule arg_cong2[OF refl, of _ _ "(\)"]) apply (rule T1.Map_Inj) apply (rule T1.Sb_comp_Inj) - apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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 @@ -291,27 +292,29 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule trans) apply (rule arg_cong2[OF _ refl, of _ _ "(\)"]) apply (rule T1.Map_Sb) - apply (assumption | rule T1.SSupp_Map_bound T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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] T1.SSupp_Inj_bound | erule cmin_smaller_T + 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 | erule cmin_smaller_T)+) + apply (rule T2.Sb_comp[THEN fun_cong], assumption+) apply (rule refl) - apply (rule T3'.Sb_comp[THEN fun_cong], (assumption | erule cmin_smaller_T)+) + apply (rule T3'.Sb_comp[THEN fun_cong], assumption+) done apply (unfold T1.Supp_Inj UN_empty) @@ -320,17 +323,17 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (unfold0 comp_apply)[1] apply (rule trans) apply (rule T1.Vrs_Sb) - apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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) @@ -352,19 +355,36 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and subgoal for f1 f2 \1 \2 \3 \4 \5 x apply (unfold0 comp_apply) apply (subst T1.Vrs_Sb) - apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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 (subst T2.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ - apply (unfold UN_UN_flatten UN_Un)[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+ + 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) @@ -384,12 +404,13 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and subgoal for f1 f2 \1 \2 \3 \4 \5 x apply (unfold0 comp_apply) - apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ - apply (unfold T1.Supp_Map T1.Vrs_Map T1.Vrs_Inj T1.Supp_Inj + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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) @@ -409,12 +430,12 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and subgoal for f1 f2 \1 \2 \3 \4 \5 x apply (unfold0 comp_apply) - apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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] @@ -435,12 +456,38 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and subgoal for f1 f2 \1 \2 \3 \4 \5 x apply (unfold0 comp_apply) - apply (subst T1.Vrs_Sb T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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] @@ -464,7 +511,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule cong'[OF _ T1.Map_cong, rotated]) (* REPEAT for inners *) apply (rule T2.Sb_cong) - apply (rule prems cmin_smaller_T)+ + apply (rule prems)+ (* REPEAT_DETERM *) apply (drule UN_I) apply assumption @@ -479,7 +526,7 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (rule refl) (* third inner *) apply (rule T3'.Sb_cong) - apply (rule prems prems(3-7,10-14)[THEN cmin_smaller_T(3)])+ + apply (rule prems)+ (* REPEAT_DETERM *) apply (drule UN_I) apply assumption @@ -499,10 +546,15 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and 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 T1.SSupp_Inj_bound cmin_smaller_T | assumption | erule UnI1 UnI2 | rule UnI2)+ + 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] @@ -529,22 +581,21 @@ pbmv_monad T: "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T" and "('a, 'b, 'e, 'd) T2" and apply (unfold comp_assoc[symmetric]) apply (rule trans) apply (rule arg_cong2[OF T1.Map_Sb refl]) - apply (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+ + 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 (subst T3'.Map_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+) apply (rule refl) done apply (unfold0 comp_apply)[1] - apply (subst T1.Supp_Sb, (assumption | rule T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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 T1.SSupp_Inj_bound | erule cmin_smaller_T)+)+ + 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] @@ -569,35 +620,37 @@ print_theorems (* Sealing of composed bmv *) typedef ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T' = - "UNIV :: (('a, 'b, 'e, 'd) T2, 'b, 'c, 'g set, ('b, 'a, 'c, 'd, 'e, 'h) T3, 'f, 'g) T1 set" + "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. Abs_T' \ (Sb_T1 h1 (Rep_T' \ \1) Inj_2_T1 \ Map_T1 (Sb_T2 h2 \2) id (Sb_T3 \3 \4 Inj_2_T3 \5 \ Map_T3 h2 id)) \ Rep_T'" -definition "RVrs_1_T' \ \x. Vrs_1_T1 (Rep_T' x)" -definition "RVrs_2_T' \ \x. \ (Vrs_1_T2 ` set_1_T1 (Rep_T' x)) \ \ (set_1_T3 ` set_3_T1 (Rep_T' x))" -definition "Inj_T' \ Abs_T' \ Inj_1_T1" -definition "Vrs_1_T' \ \x. Vrs_2_T1 (Rep_T' x)" -definition "Vrs_2_T' \ \x. \ (Vrs_2_T2 ` set_1_T1 (Rep_T' x))" -definition "Vrs_3_T' \ \x. \ (Vrs_1_T3 ` set_3_T1 (Rep_T' x))" -definition "Vrs_4_T' \ \x. \ (Vrs_2_T3 ` set_3_T1 (Rep_T' x))" -definition "Vrs_5_T' \ \x. \ (Vrs_4_T3 ` set_3_T1 (Rep_T' x))" +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_2_T3 ` set_3_T1 (Rep_T' x))" +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_T'_def Vrs_1_T'_def Vrs_2_T'_def Vrs_3_T'_def - Vrs_4_T'_def Vrs_5_T'_def Map_T'_def Supp_T'_def +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_T' Inj_T2 Inj_1_T3 Inj_1_T4 Inj_2_T4 - Vrs: Vrs_1_T' Vrs_2_T' Vrs_3_T' Vrs_4_T' Vrs_5_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 - UNIV_bd: "cmin (cmin (cmin (cmin |UNIV::'b set| |UNIV::'d set| ) |UNIV::'c set| ) |UNIV::'g set| ) |UNIV::'a set|" - apply (unfold SSupp_type_copy[OF type_definition_T'] defs) + apply (unfold SSupp_type_copy[OF type_definition_T'] IImsupp_type_copy[OF type_definition_T'] defs) apply (rule infinite_regular_card_order_natLeq) @@ -615,14 +668,24 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T 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 (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 (rule T.Vrs_bd)+ + apply ((unfold comp_apply)[1], rule T.Vrs_bd)+ apply ((unfold comp_def Abs_T'_inverse[OF UNIV_I])[1], rule T.Vrs_Inj)+ @@ -656,6 +719,18 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T 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) @@ -669,10 +744,7 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T apply (rule refl) apply (rule type_copy_map_cong0) apply (rule T.Sb_cong) - apply assumption+ - apply (unfold0 comp_apply)[1] - apply (rule arg_cong[of _ _ Rep_T']) - apply assumption+ + 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) @@ -685,10 +757,11 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T 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 (rule T.Supp_bd) + 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) @@ -705,7 +778,7 @@ pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) T'" and "('a, 'b, 'e, 'd) T2" and T 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) + apply (rule refl)+ done print_theorems diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 6c4d8829..325041e9 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -3,9 +3,10 @@ theory BMV_Fixpoint begin type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = - "'v \\Var 'v\ - + 'd * 'd \\App \('tv, 'v) FTerm\ \('tv, 'v) FTerm\\ - + 'd * 'tv FType \\TyApp \('tv, 'v) FTerm\ \'tv FType\\ + "('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\" @@ -15,17 +16,18 @@ ML \ Multithreading.parallel_proofs := 0 \ +declare [[mrbnf_internals=false]] local_setup \fn lthy => let val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; val Xs = [@{typ 'tv}, @{typ 'v}, @{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}]; - val ((mrsbnf, (Ds, tys)), ((bmv_unfolds, (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) + val ((mrsbnf, (Ds, tys)), (((_, bmv_unfolds), (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) I [] (map (apfst dest_TFree) [(@{typ 'v}, MRBNF_Def.Free_Var), (@{typ 'btv}, MRBNF_Def.Bound_Var), (@{typ 'bv}, MRBNF_Def.Bound_Var)]) (fn xss => inter (op=) (flat xss) (map dest_TFree Xs)) T - (([], (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy); + (((Symtab.empty, []), (MRBNF_Comp.empty_comp_cache, MRBNF_Comp.empty_unfolds)), lthy); val mrsbnf = case mrsbnf of MRBNF_Util.Inl x => x | _ => error "impossible" @@ -60,24 +62,42 @@ let (* 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}] + 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 +thm bmv_defs + (* Substitution axioms *) abbreviation \ :: "'v::var \ ('tv::var, 'v::var, 'a::var, 'b::var, 'c, 'd) FTerm_pre" where - "\ a \ Abs_FTerm_pre (Inl a)" + "\ a \ Abs_FTerm_pre (Inl (Inl a))" -lemma eta_free: "set2_FTerm_pre (\ a) = {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 + 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 @@ -92,6 +112,20 @@ lemma eta_natural: 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 + (* Construction of substitution *) definition VVr :: "'v::var \ ('tv::var, 'v) FTerm" where "VVr \ FTerm_ctor \ \" @@ -373,20 +407,48 @@ lemma eta_set_empties: 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 + lemmas Cinfinite_UNIV = conjI[OF FTerm_pre.UNIV_cinfinite card_of_Card_order] lemmas Cinfinite_card = cmin_Cinfinite[OF Cinfinite_UNIV Cinfinite_UNIV] lemmas regularCard_card = cmin_regularCard[OF FTerm_pre.var_regular FTerm_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] +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| (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2)" - "IImsupp_FTerm2 f1" "\y. if isVVr (FTerm_ctor (map_FTerm_pre id id id id fst fst y)) then +interpretation tvsubst: QREC_cmin_fixed_FTerm "avoiding_set1 f1 f2" + "avoiding_set2 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 @@ -415,8 +477,9 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "IImsupp_FTerm1 f1 \ (SSupp 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) - apply (rule subsetI) - apply (assumption | erule UnI1 UnI2 | rule UnI1)+ + apply (rule Un_upper1) + apply (erule Int_subset_empty2) + apply (rule Un_upper1 Un_upper2) apply (rule trans) apply (rule FTerm.permute_ctor) @@ -431,6 +494,7 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "IImsupp_FTerm1 f1 \ (SSupp apply (assumption | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] | rule supp_id_bound card_of_Card_order supp_inv_bound SSupp_comp_bound infinite_UNIV FType.SSupp_map_bound f_prems[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] + card_of_Card_order conjI cinfinite_iff_infinite[THEN iffD2] | (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)+) @@ -545,9 +609,8 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "IImsupp_FTerm1 f1 \ (SSupp apply assumption apply (rule Un_upper1) apply (rule subsetI) - apply (rule UnI2) + apply (rule UnI2)+ apply (unfold IImsupp_def SSupp_def)[1] - apply (rule UnI2) apply (rule UN_I) apply (rule CollectI) apply assumption @@ -613,7 +676,7 @@ lemma tvsubst_VVr: "tvsubst_FTerm (VVr a) = f1 a" done lemma tvsubst_not_is_VVr: - assumes empty_prems: "set3_FTerm_pre x \ (IImsupp_FTerm1 f1 \ (SSupp TyVar f2 \ IImsupp TyVar FVars_FType f2)) = {}" "set4_FTerm_pre x \ IImsupp_FTerm2 f1 = {}" + 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))" @@ -628,6 +691,365 @@ lemma tvsubst_not_is_VVr: done end +lemma eta_ctor_inj: "FTerm_ctor (\ a) = FTerm_ctor x \ x = \ a" + apply (unfold FTerm.TT_inject0) + apply (erule exE conjE)+ + apply (subst (asm) eta_natural') + apply (rule supp_id_bound bij_id | assumption)+ + apply (unfold id_apply) + apply (erule sym) + done + +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 (unfold IImsupp_def)[2] + apply (rule var_class.Un_bound var_class.UN_bound cmin1 cmin2 card_of_Card_order FTerm.FVars_bd_UNIVs assms[THEN ordLess_ordLeq_trans] + FType.set_bd_UNIV + )+ + 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_forward: "a \ A \ B \ (a \ A \ a \ C) \ (a \ B \ a \ D) \ a \ C \ D" + by blast + +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| 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 (unfold IImsupp_def)[2] + apply (rule var_class.Un_bound var_class.UN_bound cmin1 cmin2 card_of_Card_order FTerm.FVars_bd_UNIVs assms[THEN ordLess_ordLeq_trans] + FType.set_bd_UNIV + )+ + + 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) + (* This is only because FType does not use BMVs yet, not part of the tactic *) + apply (unfold IImsupp_FType_def SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def + TyVar_def[symmetric] SSupp_def[of TyVar, symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong] + comp_def IImsupp_def[of TyVar FVars_FType, symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong] + )[1] + 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| 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_Sb_subset: + fixes \2::"'tyvar::var \ 'tyvar FType" + assumes f_prems: + "|SSupp TyVar \2| 2 \ \1') \ SSupp TyVar \2 \ SSupp TyVar \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 FType.Sb_comp_Inj[THEN fun_cong, unfolded comp_def]) + apply (rule ordLess_ordLeq_trans) + apply (rule assms) + apply (rule cmin1 card_of_Card_order)+ + 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| 2| 1'| 1 \2 \ \1')| 2::"'tyvar::var \ 'tyvar FType" + assumes f_prems: + "|SSupp TyVar \2| 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 (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs + SSupp_Sb_bound SSupp_tvsubst_bound[THEN ordLess_ordLeq_trans] SSupp_Sb_bound[THEN ordLess_ordLeq_trans] ordLeq_refl cmin_Card_order + var_class.UN_bound var_class.Un_bound cmin1 cmin2 | erule ordLess_ordLeq_trans + )+)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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 cmin1 cmin2 card_of_Card_order cmin1 SSupp_Sb_bound | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + apply (unfold id_o o_id) + apply (rule arg_cong[of _ _ "Sb_FTerm_pre _ _"]) + apply (unfold FTerm_pre.Map_map) + apply (rule 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 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(5,6)) + 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-4))[2] +apply (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs cmin_greater + var_class.UN_bound var_class.Un_bound cmin1 cmin2 | erule ordLess_ordLeq_trans + )+)+ + apply (unfold atomize_all[symmetric] atomize_imp[symmetric]) + subgoal premises inner_prems for x + apply (insert prems(1-4) 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 cong'[of _ "map_FTerm_pre id id id id _ _ _" _ "map_FTerm_pre id id id id _ _ _"]) + apply (rule FTerm_pre.Sb_cong) + apply (rule supp_id_bound cmin1 cmin2 card_of_Card_order refl | erule ordLess_ordLeq_trans)+ + apply (unfold FTerm_pre.Map_map[symmetric] FTerm_pre.Vrs_Map)[1] + apply (unfold FTerm_pre.set_Vrs(1-2)[symmetric])[1] + apply (rule inner_prems) + apply (erule FTerm.FVars_intros) + + apply (rule 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 ((subst IImsupp_Inj_comp SSupp_Inj_comp IImsupp_def FVars_VVr UN_empty2 Un_empty_left Un_empty_right comp_apply imsupp_absorb, + ((rule injI FTerm.Vrs_Inj | erule FTerm.Inj_inj[THEN iffD1] | assumption + )+)?)+)[4] + apply (rule sym) + apply (rule trans) + apply (rule FTerm.vvsubst_cctor) + apply (rule cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + apply (rule sym) + apply (rule FTerm_pre.map_cong0) + apply (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 (subst SSupp_Inj_comp, rule injI, erule FTerm.Inj_inj[THEN iffD1], assumption+)+ + apply (subst VVr_def comp_apply)+ + apply (rule sym) + apply (rule trans) + apply (rule FTerm.vvsubst_cctor) + apply (rule cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + done + apply (rule FType.map_is_Sb; assumption) + done (* Sugar theorems for substitution *) definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where - "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl a))" + "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl (Inl a)))" definition App :: "('tv, 'v) FTerm \ ('tv, 'v) FTerm \ ('tv::var, 'v::var) FTerm" where - "App t1 t2 \ FTerm_ctor (Abs_FTerm_pre (Inr (Inl (t1, t2))))" + "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 (Inr (Inl (t, T)))))" + "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 (Inr (Inl (x, T, t))))))" + "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 (Inr (a, t))))))" + "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" @@ -705,13 +1446,13 @@ lemma FTerm_subst: 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] + 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 + Abs_FTerm_pre_inject[OF UNIV_I UNIV_I] Sb_FTerm_pre_def id_def map_prod_simp bmv_defs )[1] apply (rule refl) diff --git a/operations/MRSBNF_Composition.thy b/operations/MRSBNF_Composition.thy index 6f90c0dd..6c9c8ff3 100644 --- a/operations/MRSBNF_Composition.thy +++ b/operations/MRSBNF_Composition.thy @@ -9,7 +9,7 @@ consts rel_T1 :: "('a \ 'a' \ bool) \ ('d \< 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') \ ('f \ 'f') \ ('a, 'b, 'c, 'd, 'e, 'f) T3 \ ('a, 'b, 'c, 'd', 'e, 'f') T3" +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" @@ -47,7 +47,8 @@ mrbnf "('a, 'b, 'c, 'd, 'e, 'f) T3" free: Vrs_3_T3 free: Vrs_4_T3 live: set_1_T3 - live: set_2_T3 + bound: set_2_T3 + live: set_3_T3 bd: natLeq rel: rel_T3 apply (tactic \Skip_Proof.cheat_tac @{context} 1\)+ @@ -57,7 +58,7 @@ local_setup \fn lthy => let open MRBNF_Def val (mrbnf, (_, lthy)) = MRBNF_Comp.demote_mrbnf I - [Free_Var, Bound_Var, Free_Var, Free_Var, Live_Var] + [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 @@ -97,9 +98,9 @@ let the (MRBNF_Def.mrbnf_of lthy "MRSBNF_Composition.T3'") ] [@{typ 'f}] [ [@{typ 'e}], - [@{typ "'g::var set"}], + [@{typ "'f set"}], [@{typ 'e}] - ] [NONE, SOME @{typ "'b"}, SOME @{typ "'c"}, NONE, NONE, SOME @{typ "'g::var"}] [ + ] [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}] @@ -119,6 +120,8 @@ let 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) diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index a639a1fa..cdcf7b01 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -389,7 +389,6 @@ lemma id_on_image_same: "id_on A f \ id_on (f ` A) f" lemma rel_refl_eq: "(\x. R x x) \ x = y \ R x y" by auto - lemma rel_set_reflI: "(\a. a \ A \ r a a) \ rel_set r A A" by (auto simp: rel_set_def) @@ -413,6 +412,9 @@ 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" diff --git a/thys/Support.thy b/thys/Support.thy index 0b76c658..26577004 100644 --- a/thys/Support.thy +++ b/thys/Support.thy @@ -5,6 +5,9 @@ begin lemma notin_supp: "x \ supp f \ f x = x" unfolding supp_def by blast +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 }" @@ -14,11 +17,25 @@ definition IImsupp :: "('a \ 't) \ ('t \ 'b 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 SSupp_Inj_bound[simp]: "|SSupp Inj Inj| |SSupp Inj Inj| 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) @@ -31,10 +48,133 @@ proof (rule subsetI, unfold SSupp_def mem_Collect_eq Un_iff comp_apply) qed blast qed -lemma SSupp_comp_bound: "infinite (UNIV::'a set) \ |SSupp Inj g| |supp f| |SSupp Inj (g \ f)| |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 + +lemma IImsupp_Inj_comp_bound1: "inj Inj \ |supp (f::'a::var \ 'a)| + (\a. Vrs (Inj a) = {a}) \ |IImsupp Inj Vrs (Inj \ f)| a. Vrs (Inj a) = {}) \ |IImsupp Inj Vrs (Inj \ f)| Date: Thu, 10 Jul 2025 11:37:54 +0200 Subject: [PATCH 45/90] more --- Tools/mrsbnf_def.ML | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 09b87d8c..b949ef16 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -473,9 +473,11 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), rtac ctxt @{thm var_class.UN_bound}, resolve_tac ctxt prems, - rtac ctxt @{thm ordLess_ordLeq_trans}, - resolve_tac ctxt (#Vrs_bds bmv_axioms), - rtac ctxt @{thm var_class.large'} + 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 From 8832417e5481a2a3ce7689807f002e6cd230ee03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 10 Jul 2025 11:24:12 +0100 Subject: [PATCH 46/90] Fix remaining fixpoint proofs --- Tools/mrsbnf_comp.ML | 4 +- operations/BMV_Fixpoint.thy | 254 +++++++++++++++++++++--------------- 2 files changed, 149 insertions(+), 109 deletions(-) diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 87000eca..d39552ab 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -583,9 +583,11 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_De | 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), accum), lthy)) end + 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) diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 325041e9..b7f0b50c 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -16,7 +16,6 @@ ML \ Multithreading.parallel_proofs := 0 \ -declare [[mrbnf_internals=false]] local_setup \fn lthy => let val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; @@ -443,25 +442,26 @@ abbreviation (input) "avoiding_set2 f1 \ SSupp VVr f1 \ IImsupp_FT 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 (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound f_prems card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs cmin_greater - var_class.UN_bound f_prems[THEN ordLess_ordLeq_trans] cmin1 cmin2 - )+)+ + apply ((rule var_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 | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] | rule card_of_Card_order supp_id_bound bij_id)+)+ + 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 | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] | rule card_of_Card_order supp_id_bound bij_id)+)+ - apply (subst FTerm.permute_ctor[symmetric] isVVr_permute, (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+)+ + 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) @@ -472,10 +472,10 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "avoiding_set1 f1 f2" 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 assumption+ apply (unfold asVVr_VVr) apply (rule IImsupp_permute_commute[THEN fun_cong, unfolded comp_def]) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ + apply assumption+ apply (erule Int_subset_empty2) apply (rule Un_upper1) apply (erule Int_subset_empty2) @@ -486,15 +486,12 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "avoiding_set1 f1 f2" apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ apply (subst trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]]) - apply (assumption | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] - | rule card_of_Card_order supp_id_bound bij_id f_prems[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2])+ + 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 | erule ordLess_ordLeq_trans[OF _ cmin1] ordLess_ordLeq_trans[OF _ cmin2] - | rule supp_id_bound card_of_Card_order supp_inv_bound SSupp_comp_bound infinite_UNIV FType.SSupp_map_bound - f_prems[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] - card_of_Card_order conjI cinfinite_iff_infinite[THEN iffD2] + 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)+) @@ -542,15 +539,15 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "avoiding_set1 f1 f2" 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+) + 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]) @@ -618,15 +615,15 @@ interpretation tvsubst: QREC_cmin_fixed_FTerm "avoiding_set1 f1 f2" 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+)+ + 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[THEN ordLess_ordLeq_trans, OF cmin1] f_prems[THEN ordLess_ordLeq_trans, OF cmin2] card_of_Card_order)+) + apply (subst FTerm_pre.Vrs_Sb, (rule supp_id_bound bij_id f_prems)+) apply (unfold image_id) apply (rule Un_upper1) @@ -835,14 +832,16 @@ lemma IImsupp_Diff: 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 (unfold IImsupp_def)[2] - apply (rule var_class.Un_bound var_class.UN_bound cmin1 cmin2 card_of_Card_order FTerm.FVars_bd_UNIVs assms[THEN ordLess_ordLeq_trans] - FType.set_bd_UNIV - )+ + + apply ((rule var_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 @@ -930,14 +929,14 @@ lemma Un_cong_FTVars: "A = A1 \ A2 \ B = B1 \ B2 \ lemma FVars_tvsubst2: fixes \1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" - assumes f_prems: "|SSupp VVr \1| 2| 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 (unfold IImsupp_def)[2] - apply (rule var_class.Un_bound var_class.UN_bound cmin1 cmin2 card_of_Card_order FTerm.FVars_bd_UNIVs assms[THEN ordLess_ordLeq_trans] - FType.set_bd_UNIV - )+ + apply ((rule var_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]) @@ -995,8 +994,9 @@ 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| 2| 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]) @@ -1009,45 +1009,69 @@ lemma SSupp_tvsubst_subset: apply (rule tvsubst_VVr[OF assms]) apply assumption done -lemma SSupp_Sb_subset: - fixes \2::"'tyvar::var \ 'tyvar FType" - assumes f_prems: - "|SSupp TyVar \2| 2 \ \1') \ SSupp TyVar \2 \ SSupp TyVar \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 FType.Sb_comp_Inj[THEN fun_cong, unfolded comp_def]) - apply (rule ordLess_ordLeq_trans) - apply (rule assms) - apply (rule cmin1 card_of_Card_order)+ - 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| 2| 1'| 1 \2 \ \1')| 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 SSupp_Sb_bound: - fixes \2::"'tyvar::var \ 'tyvar FType" - assumes f_prems: - "|SSupp TyVar \2| 1'| 2 \ \1')| 1::"'var::var \ ('tyvar::var, 'var) FTerm" and \2::"'tyvar \ 'tyvar FType" + assumes f_prems: "|SSupp VVr \1| 1| 2| 1'| 1 \2 \ \1')| 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 (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs - SSupp_Sb_bound SSupp_tvsubst_bound[THEN ordLess_ordLeq_trans] SSupp_Sb_bound[THEN ordLess_ordLeq_trans] ordLeq_refl cmin_Card_order - var_class.UN_bound var_class.Un_bound cmin1 cmin2 | erule ordLess_ordLeq_trans - )+)+ + + apply ((assumption | rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs + FType.SSupp_Sb_bound var_class.UN_bound var_class.Un_bound IImsupp_tvsubst_bound + FType.IImsupp_Sb_bound SSupp_tvsubst_bound | (unfold IImsupp_def)[1])+)[2] + apply (rule impI) apply hypsubst @@ -1138,7 +1163,7 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" apply (rule UnI2) apply (rule UnI2) apply assumption - apply (subst FTerm_pre.set_Sb FTerm_pre.set_map, (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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) @@ -1146,7 +1171,7 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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) @@ -1169,7 +1194,7 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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)+ @@ -1195,24 +1220,24 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+)+ + 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 cmin1 cmin2 card_of_Card_order cmin1 SSupp_Sb_bound | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + apply (rule supp_id_bound | assumption)+ apply (unfold id_o o_id) apply (rule arg_cong[of _ _ "Sb_FTerm_pre _ _"]) apply (unfold FTerm_pre.Map_map) @@ -1242,7 +1267,7 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" apply (erule subst[OF sym]) apply (unfold tvsubst_VVr) apply (subst tvsubst_VVr) - apply (rule SSupp_tvsubst_bound SSupp_Sb_bound | assumption)+ + apply (rule SSupp_tvsubst_bound IImsupp_tvsubst_bound FType.SSupp_Sb_bound | assumption)+ apply (unfold comp_def) apply (rule refl) done @@ -1252,16 +1277,18 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" apply (rule FVars_tvsubst; assumption)+ subgoal premises prems for \1 \2 \1' \2' t - apply (insert prems(5,6)) + 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-4))[2] -apply (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs cmin_greater - var_class.UN_bound var_class.Un_bound cmin1 cmin2 | erule ordLess_ordLeq_trans - )+)+ + apply (insert prems(1-6))[2] + + apply ((assumption | rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs + FType.SSupp_Sb_bound var_class.UN_bound var_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-4) inner_prems(3-5)) + apply (insert prems(1-6) inner_prems(3-5)) apply (rule case_split[rotated]) apply (subst tvsubst_not_is_VVr[rotated -1]) apply assumption+ @@ -1274,9 +1301,9 @@ apply (((unfold IImsupp_def)[1]), (rule Un_bound UN_bound card_of_Card_order FTe apply (rule arg_cong[of _ _ FTerm_ctor]) apply (rule cong'[of _ "map_FTerm_pre id id id id _ _ _" _ "map_FTerm_pre id id id id _ _ _"]) apply (rule FTerm_pre.Sb_cong) - apply (rule supp_id_bound cmin1 cmin2 card_of_Card_order refl | erule ordLess_ordLeq_trans)+ + apply (rule supp_id_bound refl | assumption)+ apply (unfold FTerm_pre.Map_map[symmetric] FTerm_pre.Vrs_Map)[1] - apply (unfold FTerm_pre.set_Vrs(1-2)[symmetric])[1] + apply (unfold FTerm_pre.set_Vrs(1-2)[symmetric])[1] apply (rule inner_prems) apply (erule FTerm.FVars_intros) @@ -1350,30 +1377,33 @@ 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 ((subst IImsupp_Inj_comp SSupp_Inj_comp IImsupp_def FVars_VVr UN_empty2 Un_empty_left Un_empty_right comp_apply imsupp_absorb, - ((rule injI FTerm.Vrs_Inj | erule FTerm.Inj_inj[THEN iffD1] | assumption - )+)?)+)[4] + 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 (rule cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ - apply assumption+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + apply (rule supp_id_bound | assumption)+ apply (rule sym) apply (rule FTerm_pre.map_cong0) - apply (rule supp_id_bound bij_id cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + apply (rule supp_id_bound bij_id | assumption)+ apply (rule refl) apply (unfold FTerm_pre.set_Vrs)[1] apply (subst (asm) eta_compl_free) @@ -1395,19 +1425,26 @@ mrsbnf "('tv, 'v) FTerm" and "'tv FType" apply (rule sym) apply (rule trans) apply (rule tvsubst_VVr) - apply (subst SSupp_Inj_comp, rule injI, erule FTerm.Inj_inj[THEN iffD1], 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 + )+)[3] + apply (subst VVr_def comp_apply)+ apply (rule sym) apply (rule trans) apply (rule FTerm.vvsubst_cctor) - apply (rule cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + 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 cmin1 cmin2 card_of_Card_order | erule ordLess_ordLeq_trans)+ + apply (rule supp_id_bound bij_id | assumption)+ done apply (rule FType.map_is_Sb; assumption) done +print_theorems (* Sugar theorems for substitution *) definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where @@ -1423,12 +1460,12 @@ definition TyLam :: "'tv \ ('tv, 'v) FTerm \ ('tv::var, 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)" + "x \ 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]) @@ -1485,7 +1522,8 @@ lemma FTerm_subst: Abs_FTerm_pre_inverse[OF UNIV_I] sum_set_simps UN_single UN_empty set4_FTerm_pre_def noclash_FTerm_def prod_set_simps ) 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 (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 From 414b5a1ac48bf1eef1b8b30c2bc22ec3e4bb01cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 10 Jul 2025 11:29:58 +0100 Subject: [PATCH 47/90] Fix duplicate simp rule assumption --- operations/BMV_Fixpoint.thy | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index b7f0b50c..19af5d67 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -1465,7 +1465,7 @@ lemma FTerm_subst: "tvsubst_FTerm f1 f2 (Var x) = f1 x" "tvsubst_FTerm f1 f2 (App t1 t2) = App (tvsubst_FTerm f1 f2 t1) (tvsubst_FTerm f1 f2 t2)" "tvsubst_FTerm f1 f2 (TyApp t T) = TyApp (tvsubst_FTerm f1 f2 t) (tvsubst_FType f2 T)" - "x \ 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)" + "x \ 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]) @@ -1520,6 +1520,7 @@ lemma FTerm_subst: 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] @@ -1543,7 +1544,7 @@ lemma FTerm_subst: 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 + 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] From d068809e9f1b91ee4a3c353f733bace489206c13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 10 Jul 2025 20:05:40 +0100 Subject: [PATCH 48/90] Automate obtaining new substitutions --- Tools/mrbnf_sugar.ML | 22 +- Tools/mrbnf_tvsubst.ML | 22 +- Tools/tvsubst.ML | 1384 +++++++++++++++++++++++++++++++++++ operations/BMV_Fixpoint.thy | 52 +- 4 files changed, 1452 insertions(+), 28 deletions(-) create mode 100644 Tools/tvsubst.ML diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 5f18f41a..7c601ad7 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -19,6 +19,7 @@ type binder_sugar = { permute_simps: thm list, map_permute: thm option, subst_simps: thm list option, + IImsupp_permute_commutes: thm list option, bsetss: term option list list, bset_bounds: thm list, mrbnf: MRBNF_Def.mrbnf, @@ -73,6 +74,7 @@ type binder_sugar = { permute_simps: thm list, map_permute: thm option, subst_simps: thm list option, + IImsupp_permute_commutes: thm list option, bsetss: term option list list, bset_bounds: thm list, mrbnf: MRBNF_Def.mrbnf, @@ -83,12 +85,13 @@ type binder_sugar = { }; fun morph_binder_sugar phi { map_simps, permute_simps, map_permute, set_simpss, subst_simps, mrbnf, - strong_induct, distinct, inject, ctors, bsetss, bset_bounds } = { + strong_induct, distinct, inject, ctors, bsetss, bset_bounds, IImsupp_permute_commutes } = { 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, bsetss = map (map (Option.map (Morphism.term phi))) bsetss, bset_bounds = map (Morphism.thm phi) bset_bounds, mrbnf = MRBNF_Def.morph_mrbnf phi mrbnf, @@ -1122,13 +1125,13 @@ fun create_binder_datatype co (spec : spec) lthy = 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)); + ) (map fst (#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)) + ) (map fst (flat (#IImsuppss tvsubst_res))) )) fs)); fun tac ctxt prems = EVERY1 [ K (Local_Defs.unfold0_tac ctxt (map (Thm.symmetric o snd) (#VVrs tvsubst_res))), @@ -1177,6 +1180,17 @@ 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 IImsupp_permute_commutes = Option.map (fn (res, _) => map_filter (Option.map ( + Local_Defs.unfold lthy ( + @{thms SSupp_def[symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong]} + @ map snd (flat (#IImsuppss res)) @ map snd (#SSupps res) + @ #eta_defs res @ map snd (#VVrs res) + @ map (Thm.symmetric o snd) ctors + @ [@{lemma "\((Vrs \ \) ` SSupp Inj \) = IImsupp Inj Vrs \" + by (auto simp: IImsupp_def)}] + ) + )) (#IImsupp_permute_commutes res)) tvsubst_opt; + val (sugar, lthy) = if co then let val (locale_name, lthy) = MRBNF_Corecursor.create_binding_corecursor I res lthy; @@ -1187,6 +1201,7 @@ fun create_binder_datatype co (spec : spec) lthy = map_permute = NONE, strong_induct = NONE, subst_simps = NONE, + IImsupp_permute_commutes = IImsupp_permute_commutes, bsetss = [], bset_bounds = [], mrbnf = mrbnf, @@ -1204,6 +1219,7 @@ 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, bsetss = bset_optss, bset_bounds = [], mrbnf = mrbnf, diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML index e656279e..d69abf9f 100644 --- a/Tools/mrbnf_tvsubst.ML +++ b/Tools/mrbnf_tvsubst.ML @@ -13,10 +13,12 @@ sig type tvsubst_result = { tvsubst: term, - SSupps: term list, - IImsuppss: term list list, + SSupps: (term * thm) list, + IImsuppss: (term * thm) list list, VVrs: (term * thm) list, + eta_defs: thm list, isVVrs: thm list, + IImsupp_permute_commutes: thm option list, tvsubst_VVrs: thm list, tvsubst_cctor_not_isVVr: thm, tvsubst_permute: thm @@ -48,10 +50,12 @@ type 'a tvsubst_model = { type tvsubst_result = { tvsubst: term, - SSupps: term list, - IImsuppss: term list list, + SSupps: (term * thm) list, + IImsuppss: (term * thm) list list, VVrs: (term * thm) list, + eta_defs: thm list, isVVrs: thm list, + IImsupp_permute_commutes: thm option list, tvsubst_VVrs: thm list, tvsubst_cctor_not_isVVr: thm, tvsubst_permute: thm @@ -1392,16 +1396,18 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l @{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 => { + val results = @{map 7} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => fn VVrs' => fn tvsubst_permute => fn IImsupp_commutes => { tvsubst = fst tvsubst, - SSupps = map_filter (Option.map (fst o #SSupp)) defs, - IImsuppss = map_filter (Option.map (map fst o #IImsupps)) defs, + SSupps = map_filter (Option.map #SSupp) defs, + IImsuppss = map_filter (Option.map #IImsupps) defs, VVrs = VVrs', + eta_defs = eta_defs, isVVrs = map_filter (Option.map (snd o #isVVr)) defs, + IImsupp_permute_commutes = IImsupp_commutes, 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; + }: tvsubst_result) tvsubsts defss tvsubst_VVrss tvsubst_not_isVVrs VVrss' tvsubst_permutes IImsupp_imsupp_permute_commutess; (* TODO: Remove *) val notes = diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML new file mode 100644 index 00000000..339b18c8 --- /dev/null +++ b/Tools/tvsubst.ML @@ -0,0 +1,1384 @@ +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, + 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_mrsbnf: (binding -> binding) -> MRBNF_FP_Def_Sugar.fp_result + -> MRSBNF_Def.mrsbnf -> binding + -> (Proof.context -> tactic) eta_model option list -> string -> local_theory + -> tvsubst_result list * 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, + 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 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 2} (fn Vrs => 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)] + + 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.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 [x] 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 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 (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 fs 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 eta_Sb_goal = fold_rev (curry Logic.mk_implies) 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)) + $ the_default I (Option.map (fn Map => fn t => Term.list_comb (Map, live_fs) $ t) + (BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv) + ) 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 (gs @ rhos @ live_fs @ [x, a]) 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 + )) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_of_bmv_monad bmv) 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 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 = MRBNF_Def.frees_of_mrbnf (hd (#pre_mrbnfs fp_res)); + 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; + + 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, some_rhos), _) = lthy + |> mk_Frees "f" (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 rhos = map (fn a => List.find (curry (op=) a o domain_type o fastype_of) some_rhos) frees; + + 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 (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 + )) (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 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 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 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 + )) (#FVarss quot) + | 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 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 UnI1, + rtac ctxt 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 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 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 subsetI, + TRY o rtac ctxt 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 nvars - 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 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 args = (snd o dest_Type o body_type o fastype_of o #eta) (hd (map_filter I defs)); + 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 eta_set_emptiess = map (Option.map (fn def => + let + 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 + )) 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 ((((fs, rhos), 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 "h" (replicate 2 (#T quot --> #T quot)) + ||>> 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 goal = Logic.mk_implies (apply2 ( + fn x => HOLogic.mk_Trueprop (HOLogic.mk_not (fst (#isInj def) $ (#ctor quot $ x))) + ) (x, Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, fs @ rhos) $ ( + Term.list_comb (the (BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv), hs) $ x + ))); + in Goal.prove_sorry lthy (names (fs @ rhos @ hs @ [x])) 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 (BMV_Monad_Def.leader BMV_Monad_Def.deads_of_bmv_monad bmv)) + (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 mk_inv fs) (map HOLogic.id_const frees) 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 (_, lthy) = Local_Theory.begin_nested lthy; + + val lthy = snd (Proof_Context.add_fixes (map (fn Free (x, T) => (Binding.name x, SOME T, NoSyn)) (map_filter I rhos)) lthy); + + val rho_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 = map (foldl1 mk_Un o map_filter I) (transpose IImsuppss); + + val Uctor = + let + val ctor = #ctor quot; + val (name, (args, rec_args)) = dest_Type (fst (dest_funT (fastype_of ctor))) + |> apsnd (chop (nvars * 2 + 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; + val bound_ids = map HOLogic.id_const frees; + + val deads = MRBNF_Def.deads_of_mrbnf mrbnf; + val map_id_fst = ctor $ (MRBNF_Def.mk_map_comb_of_mrbnf deads + (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 (HOLogic.id_const o HOLogic.dest_setT o body_type o fastype_of) (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 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 ( + avoiding_sets @ [Uctor] + )), [])) + )], []) lthy; + + val sugars = map_filter (fn mrbnf => MRBNF_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 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 [ + 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 var_class.Un_bound var_class.UN_bound} @ 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}) + ], + 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}) + ], + 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' [ + 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)), + 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 supp_inv_bound SSupp_comp_bound infinite_UNIV conjI card_of_Card_order} + @ [MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf] @ maps (map_filter I o #SSupp_map_bound) (MRSBNF_Def.facts_of_mrsbnf mrsbnf) + @ rho_prems + )), + REPEAT_DETERM o rtac ctxt refl, + REPEAT_DETERM o EVERY' [ + 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 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 #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 2} (fn rho => Option.map (fn def => EVERY' (map (fn tac => DETERM o tac) [ + 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, + 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 IImsupp_def SSupp_def Un_assoc[symmetric]}), + REPEAT_DETERM o FIRST' [ + EVERY' [ + TRY o rtac ctxt @{thm UnI2}, + rtac ctxt @{thm UN_I}, + etac ctxt @{thm CollectI}, + assume_tac ctxt + ], + rtac ctxt @{thm UnI1} + ] + ]))) rhos 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} + ], + 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))), + EqSubst.eqsubst_tac ctxt [0] (#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}), + rtac ctxt @{thm Un_upper1} ORELSE' 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} + ] + ]) 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) + )) bound_sets 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) + (flat (map2 replicate (#rec_vars fp_res) [fst tvsubst])) + (ids frees) (ids frees) mrbnf; + val Sb = Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, + map (HOLogic.id_const o HOLogic.dest_setT o body_type o fastype_of) (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} + ], + 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} + ], + 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}), + 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 (#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) rhos eta_set_emptiess asInj_Injs 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_not_isInj = Morphism.thm phi tvsubst_not_isInj; + val tvsubst_Injs = map (Option.map (Morphism.thm phi)) tvsubst_Injs; + + val _ = @{print} tvsubst_not_isInj + val _ = @{print} tvsubst_Injs + + (*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 (#Inj 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 (#Inj 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 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 (#Inj 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 bexI, + assume_tac ctxt, + rtac ctxt 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 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 (#isInj 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 (#isInj def) $ (#ctor quotient $ Thm.term_of (snd (hd params)))))] @{thm case_split}) 1 + ) ctxt, + SELECT_GOAL (unfold_thms_tac ctxt [snd (#isInj 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_old", 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), + ("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; +*) in error "tvsubst" end +end diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 19af5d67..6717f13e 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -42,6 +42,8 @@ let @{binding FTerm_pre} Xs Ds 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) @@ -69,8 +71,6 @@ in lthy end \ print_theorems -thm bmv_defs - (* 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))" @@ -96,11 +96,11 @@ lemma eta_compl_free: "\a. x \ \ a \ RVrs_FT 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| ('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 \ \" @@ -431,12 +434,6 @@ lemma not_is_VVr_Sb: done done -lemmas Cinfinite_UNIV = conjI[OF FTerm_pre.UNIV_cinfinite card_of_Card_order] -lemmas Cinfinite_card = cmin_Cinfinite[OF Cinfinite_UNIV Cinfinite_UNIV] -lemmas regularCard_card = cmin_regularCard[OF FTerm_pre.var_regular FTerm_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] - 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" @@ -553,10 +550,8 @@ interpretation tvsubst: QREC_fixed_FTerm "avoiding_set1 f1 f2" apply (rule case_split[of "_ = _", rotated]) apply (unfold IImsupp_def SSupp_def)[1] apply (rule UnI2)+ - apply (rule UN_I) - apply (rule CollectI) - apply assumption - apply assumption + 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]) @@ -1123,7 +1118,7 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" ]) apply ((assumption | rule Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs - FType.SSupp_Sb_bound var_class.UN_bound var_class.Un_bound IImsupp_tvsubst_bound + FType.SSupp_Sb_bound infinite_UNIV var_class.UN_bound var_class.Un_bound IImsupp_tvsubst_bound FType.IImsupp_Sb_bound SSupp_tvsubst_bound | (unfold IImsupp_def)[1])+)[2] apply (rule impI) @@ -1282,7 +1277,7 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" 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 Un_bound UN_bound card_of_Card_order FTerm.FVars_bd_UNIVs FType.FVars_bd_UNIVs + 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 var_class.Un_bound IImsupp_tvsubst_bound FType.IImsupp_Sb_bound SSupp_tvsubst_bound | (unfold IImsupp_def)[1])+)[2] @@ -1447,8 +1442,6 @@ mrsbnf "('tv, 'v) FTerm" and "'tv FType" print_theorems (* Sugar theorems for substitution *) -definition Var :: "'v \ ('tv::var, 'v::var) FTerm" where - "Var a \ FTerm_ctor (Abs_FTerm_pre (Inl (Inl a)))" 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 @@ -1562,4 +1555,29 @@ lemma FTerm_subst: apply (rule refl) done +ML_file \../Tools/tvsubst.ML\ + +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}) + +open BNF_Util + +val x = TVSubst.create_tvsubst_of_mrsbnf + I fp_res mrsbnf @{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[rotated -1]} THEN_ALL_NEW assume_tac ctxt) + } + }] "BMV_Fixpoint.QREC_fixed_FTerm" lthy + +in lthy end\ + end \ No newline at end of file From 91877379d721ad3c768c6f1f269f74c066051f65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 01:37:57 +0100 Subject: [PATCH 49/90] Prove most of the bmv axioms --- Tools/bmv_monad_def.ML | 173 ++--------- Tools/bmv_monad_tacs.ML | 167 ++++++++++ Tools/mrbnf_sugar.ML | 13 +- Tools/mrbnf_tvsubst.ML | 8 +- Tools/tvsubst.ML | 604 ++++++++++++++++++------------------ operations/BMV_Fixpoint.thy | 12 - operations/BMV_Monad.thy | 1 + thys/MRBNF_FP.thy | 2 + 8 files changed, 505 insertions(+), 475 deletions(-) create mode 100644 Tools/bmv_monad_tacs.ML diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index d7f439a3..b727f656 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -104,6 +104,8 @@ signature BMV_MONAD_DEF = sig val bmv_monad_def: BNF_Def.inline_policy -> (Proof.context -> BNF_Def.fact_policy) -> (binding -> binding) -> binding option -> (Proof.context -> tactic) bmv_monad_model -> 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) @@ -951,160 +953,21 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona val IImsupp_Map_bounds = Option.map (map (map (fn thm => @{thm card_of_subset_bound} OF [thm]))) IImsupp_Map_subsets; - val SSupp_Sb_subsets = @{map_filter 2} (fn Inj => fn rho => if body_type (fastype_of Inj) <> T then NONE else - let - val (rho', _) = names_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 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 (map (fn thm => thm RS fun_cong RS @{thm trans[OF comp_apply[symmetric]]}) (#Sb_comp_Injs axioms)), - REPEAT_DETERM o resolve_tac ctxt prems, - assume_tac ctxt - ])) end - ) Injs rhos; + 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 = map_filter (fn Inj => if body_type (fastype_of Inj) <> T then NONE else - let - val (rho, _) = names_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; + 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 = map_filter (fn Inj => - if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vrs => - let - val (rho', _) = names_lthy - |> apfst hd o mk_Frees "\'" [fastype_of Inj]; + 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 (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 (#RVrs consts) idx @ nth (#Vrs consts) 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 axioms), - 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 - ) (RVrs @ Vrs))) Injs; - - val IImsupp_Sb_boundss = map_filter (fn Inj => - if body_type (fastype_of Inj) <> T then NONE else SOME (map (fn Vr => - let - val (rho', _) = names_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')) - ) (RVrs @ 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}) (maps #Vrs_bds axioms') @ - @{thms var_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV var_class.large'} - ), - CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) - ] - ]) end - ) (RVrs @ Vrs))) Injs; + val IImsupp_Sb_boundss = BMV_Monad_Tactics.mk_IImsupp_Sb_boundss 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, @@ -1366,7 +1229,7 @@ fun register_mrbnf_as_pbmv_monad name lthy = val lthy = register_pbmv_monad name bmv lthy; in lthy end -fun slice_bmv_monad n bmv = +fun unsafe_slice_bmv_monad n bmv = let fun f xs = nth xs n; val Sb = f (Sbs_of_bmv_monad bmv); @@ -1431,7 +1294,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives )) bmv; val n = length (ops_of_bmv_monad bmv); - val slices = map (fn i => slice_bmv_monad i bmv) (0 upto n - 1); + 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)) @@ -1851,7 +1714,7 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit ) 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, slice_bmv_monad i bmv)) (ops_of_bmv_monad bmv)) ( + 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') ) @@ -2313,7 +2176,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = val model = { ops = [T], - bmv_ops = map_filter (fn i => if i = leader_of_bmv_monad bmv then NONE else SOME (slice_bmv_monad i bmv)) (0 upto length (ops_of_bmv_monad bmv) - 1), + 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 = [leader frees_of_bmv_monad bmv], diff --git a/Tools/bmv_monad_tacs.ML b/Tools/bmv_monad_tacs.ML new file mode 100644 index 00000000..dec098b4 --- /dev/null +++ b/Tools/bmv_monad_tacs.ML @@ -0,0 +1,167 @@ +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 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 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 @ + @{thms var_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV var_class.large'} + ), + CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) + ] + ]) end + ) Vrs)) Injs + +end \ No newline at end of file diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 7c601ad7..dd93a880 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -20,6 +20,7 @@ type binder_sugar = { map_permute: thm option, subst_simps: thm list option, IImsupp_permute_commutes: thm list option, + IImsupp_Diffs: thm list option, bsetss: term option list list, bset_bounds: thm list, mrbnf: MRBNF_Def.mrbnf, @@ -75,6 +76,7 @@ type binder_sugar = { map_permute: thm option, subst_simps: thm list option, IImsupp_permute_commutes: thm list option, + IImsupp_Diffs: thm list option, bsetss: term option list list, bset_bounds: thm list, mrbnf: MRBNF_Def.mrbnf, @@ -85,13 +87,14 @@ type binder_sugar = { }; 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 } = { + strong_induct, distinct, inject, ctors, bsetss, bset_bounds, IImsupp_permute_commutes, IImsupp_Diffs } = { 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, bsetss = map (map (Option.map (Morphism.term phi))) bsetss, bset_bounds = map (Morphism.thm phi) bset_bounds, mrbnf = MRBNF_Def.morph_mrbnf phi mrbnf, @@ -1180,7 +1183,7 @@ 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 IImsupp_permute_commutes = Option.map (fn (res, _) => map_filter (Option.map ( + fun unfold_tvsubst res = map_filter (Option.map ( Local_Defs.unfold lthy ( @{thms SSupp_def[symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong]} @ map snd (flat (#IImsuppss res)) @ map snd (#SSupps res) @@ -1189,7 +1192,9 @@ fun create_binder_datatype co (spec : spec) lthy = @ [@{lemma "\((Vrs \ \) ` SSupp Inj \) = IImsupp Inj Vrs \" by (auto simp: IImsupp_def)}] ) - )) (#IImsupp_permute_commutes res)) tvsubst_opt; + )); + val IImsupp_permute_commutes = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_permute_commutes res)) tvsubst_opt; + val IImsupp_Diffs = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_Diffs res)) tvsubst_opt; val (sugar, lthy) = if co then let @@ -1202,6 +1207,7 @@ fun create_binder_datatype co (spec : spec) lthy = strong_induct = NONE, subst_simps = NONE, IImsupp_permute_commutes = IImsupp_permute_commutes, + IImsupp_Diffs = IImsupp_Diffs, bsetss = [], bset_bounds = [], mrbnf = mrbnf, @@ -1220,6 +1226,7 @@ fun create_binder_datatype co (spec : spec) lthy = strong_induct = strong_induct_opt, subst_simps = Option.map snd tvsubst_opt, IImsupp_permute_commutes = IImsupp_permute_commutes, + IImsupp_Diffs = IImsupp_Diffs, bsetss = bset_optss, bset_bounds = [], mrbnf = mrbnf, diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML index d69abf9f..334c291f 100644 --- a/Tools/mrbnf_tvsubst.ML +++ b/Tools/mrbnf_tvsubst.ML @@ -19,6 +19,7 @@ sig eta_defs: thm list, isVVrs: thm list, IImsupp_permute_commutes: thm option list, + IImsupp_Diffs: thm option list, tvsubst_VVrs: thm list, tvsubst_cctor_not_isVVr: thm, tvsubst_permute: thm @@ -56,6 +57,7 @@ type tvsubst_result = { eta_defs: thm list, isVVrs: thm list, IImsupp_permute_commutes: thm option list, + IImsupp_Diffs: thm option list, tvsubst_VVrs: thm list, tvsubst_cctor_not_isVVr: thm, tvsubst_permute: thm @@ -1396,7 +1398,8 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l @{thm meta_eq_to_obj_eq} OF [Local_Defs.unfold0 lthy (@{thms comp_def} @ eta_defs) VVr_def] )])) o #VVr))) defss; - val results = @{map 7} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => fn VVrs' => fn tvsubst_permute => fn IImsupp_commutes => { + val results = @{map 8} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => + fn VVrs' => fn tvsubst_permute => fn IImsupp_commutes => fn IImsupp_Diffs => { tvsubst = fst tvsubst, SSupps = map_filter (Option.map #SSupp) defs, IImsuppss = map_filter (Option.map #IImsupps) defs, @@ -1404,10 +1407,11 @@ fun create_tvsubst_of_mrbnf qualify fp_res models QREC_cmin_fixed_name no_defs_l eta_defs = eta_defs, isVVrs = map_filter (Option.map (snd o #isVVr)) defs, IImsupp_permute_commutes = IImsupp_commutes, + IImsupp_Diffs = IImsupp_Diffs, 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 IImsupp_imsupp_permute_commutess; + }: tvsubst_result) tvsubsts defss tvsubst_VVrss tvsubst_not_isVVrs VVrss' tvsubst_permutes IImsupp_imsupp_permute_commutess IImsupp_Diffss; (* TODO: Remove *) val notes = diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 339b18c8..09f26496 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -713,6 +713,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n ) (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 [ @@ -995,354 +996,351 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n 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 _ = @{print} tvsubst_not_isInj - val _ = @{print} tvsubst_Injs - - (*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 (#Inj 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 (#Inj 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 in_IImsuppsss = map2 (fn quotient => map (Option.map (fn def => map2 (fn FVars => fn IImsupp => + val in_IImsuppss = map (Option.map (fn def => map (fn FVars => 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 f = Free ("f", #aT def --> #T quot); val goal = Logic.mk_implies ( HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq ( f $ a, fst (#Inj 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)) + HOLogic.mk_Trueprop (HOLogic.mk_mem (z, mk_IImsupp (fst (#Inj def)) FVars $ 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 bexI, - assume_tac ctxt, - rtac ctxt CollectI, + K (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def SSupp_def}), + rtac ctxt @{thm UN_I}, + etac ctxt @{thm CollectI}, assume_tac ctxt ]) end - ) (#FVarss quotient) (#IImsupps def)))) (#quotient_fps fp_res) defss; + ) (#FVarss quot))) defs; - 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)), + 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 @ [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 + ) (#FVarss quot))) defs; + + val IImsupp_Diffs = @{map 3} (fn rho => fn avoiding_set => 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 SOME [HOLogic.mk_Trueprop ( + mk_int_empty (B2, the (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, + HOLogic.mk_binop @{const_name minus} (mk_UNION A inner, B2) + )); + 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, + 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 (maps (the_default []) 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, - 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 UnI1, - rtac ctxt @{thm iffD2[OF mem_Collect_eq]}, + ], + DETERM o forward_tac ctxt (map (Drule.rotate_prems 1) (maps (the_default []) in_IImsuppss)), 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) + 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}, + SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ])) + ] else etac ctxt @{thm disjoint_iff[THEN iffD1, THEN spec, THEN mp, OF trans[OF Int_commute]]} + ] in EVERY' [ + helper_tac false, + helper_tac true + ] end, + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms SSupp_def IImsupp_def}), + rtac ctxt @{thm UnI1}, + rtac ctxt @{thm CollectI}, + assume_tac ctxt, + assume_tac ctxt ]) end - ) fs (#IImsupps def))) fs) (#quotient_fps fp_res) SSupp_naturalss defss; + ) (#FVarss quot))) rhos avoiding_sets defs; - val fp_thms = Option.map (fn Inl x => x | Inr _ => error "wrong fp kind") (#fp_thms fp_res); + val netas = length (map_filter I defs); - 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 = + fun mk_Un_cong i j = 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 (#isInj 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 (Ass, _) = lthy + |> mk_Freess "A" (replicate i (replicate (j + 1) (HOLogic.mk_setT (Term.aT @{sort type})))) - 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 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 UnE, + EVERY' (map (fn i' => EVERY' [ + REPEAT_DETERM_N (j - 1) o etac ctxt 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 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 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 => + val fresh_induct = case #fp_thms fp_res of + SOME (Inl x) => #fresh_induct x + | _ => error "only works for datatypes" + val FVars_tvsubsts = map (fn FVars => let - val t = Free ("t", #T quotient); + 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 #FVarss quot 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))) (#FVarss quot); + 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')) + FVars $ (Term.list_comb (fst tvsubst, map_filter I rhos) $ t), + foldl1 mk_Un rhss ); - 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))), + in Goal.prove_sorry lthy (names (map_filter I rhos @ [t])) rho_prems' goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) avoiding_sets) fresh_induct), + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + resolve_tac ctxt (@{thms var_class.Un_bound var_class.UN_bound} @ 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_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)), 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} - ) + 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) ], - 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 (#isInj def) $ (#ctor quotient $ Thm.term_of (snd (hd params)))))] @{thm case_split}) 1 - ) ctxt, - SELECT_GOAL (unfold_thms_tac ctxt [snd (#isInj def)]), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thms image_id image_comp[unfolded comp_def]} + @ no_reflexive (#set_Vrs mrsbnf_axioms) @ [the (#Map_map mrsbnf_facts) RS sym] + )), + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs bmv_axioms), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} @ prems) + ], + K (Local_Defs.unfold0_tac ctxt (@{thms image_id UN_Un} @ #Vrs_Map (the (BMV_Monad_Def.leader BMV_Monad_Def.params_of_bmv_monad bmv)))), + rtac ctxt (mk_Un_cong (nrecs + 1) (length rhss)), + 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, - 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}), + hyp_subst_tac ctxt, + rtac ctxt exI, rtac ctxt refl - ])) defs), - (* goal 2: not (isVVr (ctor x)) *) + ], + K (Local_Defs.unfold0_tac ctxt @{thms UN_empty Un_empty_left Un_empty_right}), + rtac ctxt refl, rtac ctxt trans, - rtac ctxt (mk_arg_cong ctxt FVars), - rtac ctxt tvsubst_not_isVVr, - REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + rtac ctxt @{thm UN_cong}, + Goal.assume_rule_tac ctxt, 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 + EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs @ maps (the_default [] o #IImsupp_Diffs) sugars), + REPEAT_DETERM o (assume_tac ctxt ORELSE' EVERY' [ + etac ctxt @{thm Int_subset_empty2}, + rtac ctxt @{thm subsetI}, + SELECT_GOAL (EVERY1 [ + REPEAT_DETERM o etac ctxt UnE, + REPEAT_DETERM o FIRST' [ + assume_tac ctxt, + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} + ] + ]) + ]) ], - 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' [ + K (Local_Defs.unfold0_tac ctxt @{thms Un_Diff[symmetric]}), + rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib[symmetric]}), + rtac ctxt refl, + 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 Un_empty_left Un_empty_right} + @ maps (the_default []) FVars_Injs + )), + rtac ctxt refl + ])) (rev defs)) + ]) end + ) (#FVarss quot); + + 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 some_rhos = map_filter I rhos; + val SSupp_tvsubst_subsets = BMV_Monad_Tactics.mk_SSupp_Sb_subsets (#T quot) + Injs rho_prems' (fst tvsubst) + [] some_rhos (map_filter I tvsubst_Injs) lthy; + + val SSupp_tvsubst_bounds = BMV_Monad_Tactics.mk_SSupp_Sb_bounds (#T quot) + Injs (fst tvsubst) [] some_rhos rho_prems' SSupp_tvsubst_subsets + (MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf) lthy; + + 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 IImsupp_Sb_subsetss = BMV_Monad_Tactics.mk_IImsupp_Sb_subsetss (#T quot) ops + (fst tvsubst) rho_prems' ([] :: tl (BMV_Monad_Def.RVrs_of_bmv_monad bmv)) + (#FVarss quot :: tl (BMV_Monad_Def.Vrs_of_bmv_monad bmv)) + (#FVarss quot) Injs [] some_rhos SSupp_tvsubst_subsets + FVars_tvsubsts Vrs_Injs' lthy; + + val IImsupp_Sb_boundss = BMV_Monad_Tactics.mk_IImsupp_Sb_boundss (#T quot) + (fst tvsubst) Injs (#FVarss quot) [] some_rhos rho_prems' IImsupp_Sb_subsetss + (#card_of_FVars_bounds quot @ maps #Vrs_bds (BMV_Monad_Def.axioms_of_bmv_monad bmv)) lthy; + + 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], + lives = [[]], + lives' = [[]], + deads = [[]], + 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 = [[]], + Vrs = [#FVarss quot], + extra_Vrs = [[]], + params = [NONE] + }, + params = [NONE], + 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, 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 _ _ "(-)"]} + 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}, + K (Local_Defs.unfold0_tac ctxt (@{thms SSupp_Inj IImsupp_def UN_empty UN_empty2 Un_empty_left Un_empty_right} @ [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} + ])) defs) ], - 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;*) + Sb_comp_Injs = map_filter (Option.map (fn def => 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 [ + K (print_tac ctxt "Sb_comp") + ], + Vrs_bds = replicate nvars (fn ctxt => resolve_tac ctxt (#card_of_FVars_bounds quot) 1), + Vrs_Injss = replicate nvars (map_filter (Option.map (fn def => fn ctxt => + resolve_tac ctxt (maps (the_default []) FVars_Injs) 1 + )) defs), + Vrs_Sbs = replicate nvars (fn ctxt => EVERY1 [ + resolve_tac ctxt FVars_tvsubsts, + REPEAT_DETERM o assume_tac ctxt + ]), + Sb_cong = fn ctxt => EVERY1 [ + K (print_tac ctxt "Sb_cong") + ] + }] + } lthy; - 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 _ = @{print} FVars_tvsubsts + val _ = @{print} IImsupp_Sb_boundss + (* 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, diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 6717f13e..615f5549 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -683,15 +683,6 @@ lemma tvsubst_not_is_VVr: done end -lemma eta_ctor_inj: "FTerm_ctor (\ a) = FTerm_ctor x \ x = \ a" - apply (unfold FTerm.TT_inject0) - apply (erule exE conjE)+ - apply (subst (asm) eta_natural') - apply (rule supp_id_bound bij_id | assumption)+ - apply (unfold id_apply) - apply (erule sym) - done - 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" @@ -887,9 +878,6 @@ lemma FVars_tvsubst1: apply (rule refl) done -lemma Un_forward: "a \ A \ B \ (a \ A \ a \ C) \ (a \ B \ a \ D) \ a \ C \ D" - by blast - 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) diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 6728c66e..a5280867 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -119,6 +119,7 @@ lemma map_is_Sb_FType: declare [[ML_print_depth=1000]] +ML_file \../Tools/bmv_monad_tacs.ML\ ML_file \../Tools/bmv_monad_def.ML\ local_setup \fold BMV_Monad_Def.register_mrbnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ diff --git a/thys/MRBNF_FP.thy b/thys/MRBNF_FP.thy index cdcf7b01..b1390704 100644 --- a/thys/MRBNF_FP.thy +++ b/thys/MRBNF_FP.thy @@ -173,6 +173,8 @@ lemma id_on_comp2: "b z = z \ 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: From 1fc5062a868883089ab916500556a8b54d8c5361 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 09:59:59 +0100 Subject: [PATCH 50/90] Automate proofs of recursive BMV --- Tools/tvsubst.ML | 275 ++++++++++++++++++++++++++++++++++-- operations/BMV_Fixpoint.thy | 18 +-- 2 files changed, 276 insertions(+), 17 deletions(-) diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 09f26496..fedee8b3 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -1134,9 +1134,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n ]) (1 upto j)) ]) end; - val fresh_induct = case #fp_thms fp_res of - SOME (Inl x) => #fresh_induct x + 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; + val FVars_tvsubsts = map (fn FVars => let val t = Free ("t", domain_type (fastype_of FVars)); @@ -1262,6 +1264,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n (fst tvsubst) Injs (#FVarss quot) [] some_rhos rho_prems' IImsupp_Sb_subsetss (#card_of_FVars_bounds quot @ 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 = map (Term.subst_atomic (some_rhos ~~ rhos)) avoiding_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], @@ -1321,7 +1326,178 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n REPEAT_DETERM o assume_tac ctxt ])) defs, Sb_comp = fn ctxt => EVERY1 [ - K (print_tac ctxt "Sb_comp") + rtac ctxt ext, + rtac ctxt @{thm trans[OF comp_apply]}, + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, concl, ...} => + let + val ((rhos', rhos), x) = map (Thm.term_of o snd) params + |> chop (length some_rhos) + ||>> 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, rhos) $ Bound 0), + s1, s2, s3 + ])) (#FVarss quot) (mk_avoiding_sets rhos) (mk_avoiding_sets rhos') (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) rhos')) + (fst (split_last (binder_types (fastype_of Sb)))); + in HOLogic.mk_comp (Term.list_comb (Sb, rhos'), rho) end + ) rhos + )) + ) @ [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 rtac ctxt (thm RS @{thm mp[OF _ refl]}) 1 end + ) ctxt, + REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + assume_tac ctxt, + resolve_tac ctxt (@{thms var_class.Un_bound var_class.UN_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 ~1 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 ~1 tvsubst_not_isInj), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt [the (#Map_map mrsbnf_facts) RS sym]), + eresolve_tac ctxt (map_filter (Option.map (Drule.rotate_prems ~1)) not_isInj_Sb), + REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm 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} + ])) + ], + assume_tac ctxt, + 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 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 (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} + ], + assume_tac ctxt, + 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 (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 + ])) defs) ], Vrs_bds = replicate nvars (fn ctxt => resolve_tac ctxt (#card_of_FVars_bounds quot) 1), Vrs_Injss = replicate nvars (map_filter (Option.map (fn def => fn ctxt => @@ -1331,14 +1507,97 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n resolve_tac ctxt FVars_tvsubsts, REPEAT_DETERM o assume_tac ctxt ]), - Sb_cong = fn ctxt => EVERY1 [ - K (print_tac ctxt "Sb_cong") - ] + Sb_cong = fn ctxt => Subgoal.FOCUS (fn {context=ctxt, params, prems, ...} => + let + val ((rhos, rhos'), t) = map (Thm.term_of o snd) params + |> chop (length some_rhos) + ||>> 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}), + rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) + (map2 (curry mk_Un) (mk_avoiding_sets rhos) (mk_avoiding_sets rhos')) + @ [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 var_class.Un_bound var_class.UN_bound} + @ #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} + ], + 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)) + ], + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id refl}), + rtac ctxt (arg_cong 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 nvars 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, + etac ctxt @{thm notin_SSupp}, + rtac ctxt sym, + etac ctxt @{thm notin_SSupp} + ] ORELSE' EVERY' [ + resolve_tac ctxt inner_prems, + eresolve_tac ctxt (flat (#FVars_intross quot)), + assume_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 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 }] } lthy; - val _ = @{print} FVars_tvsubsts - val _ = @{print} IImsupp_Sb_boundss + val _ = @{print} bmv (* val results = @{map 6} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => fn VVrs' => fn tvsubst_permute => { diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 615f5549..3c91708f 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -1222,9 +1222,9 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" 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 (rule arg_cong[of _ _ "Sb_FTerm_pre _ _"]) apply (unfold FTerm_pre.Map_map) - apply (rule FTerm_pre.map_cong0) + + 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) @@ -1281,16 +1281,16 @@ pbmv_monad "('tv, 'v) FTerm" and "'tv FType" apply assumption+ apply (erule Int_subset_empty2, rule Un_upper2)+ apply assumption - apply (rule arg_cong[of _ _ FTerm_ctor]) - apply (rule cong'[of _ "map_FTerm_pre id id id id _ _ _" _ "map_FTerm_pre id id id id _ _ _"]) - apply (rule FTerm_pre.Sb_cong) - apply (rule supp_id_bound refl | 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 (rule inner_prems) - apply (erule FTerm.FVars_intros) + apply (erule FTerm.FVars_intros) + apply (rule supp_id_bound refl | assumption)+ - apply (rule FTerm_pre.map_cong0) + 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]) From f7c188cdd3511821c81b5ef83d4ba0bbf808ffcb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 11:03:04 +0100 Subject: [PATCH 51/90] Automate recursive mrsbnf --- Tools/mrsbnf_def.ML | 6 +- Tools/tvsubst.ML | 129 +++++++++++++++++++++++++++++++++++- operations/BMV_Fixpoint.thy | 3 +- 3 files changed, 129 insertions(+), 9 deletions(-) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index b949ef16..25f52a75 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -889,10 +889,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val free_fs = take free 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 _ = @{print} (MRBNF_Def.frees_of_mrbnf mrbnf, MRBNF_Def.bounds_of_mrbnf mrbnf, MRBNF_Def.lives_of_mrbnf mrbnf) - val _ = @{print} (Fs, Bs, As) + 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 @@ -915,7 +912,6 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ) Injs) ) end ))); - val _ = @{print} (Thm.cterm_of lthy map_is_Sb) val RVrs_aTs = map (HOLogic.dest_setT o body_type o fastype_of) RVrs; diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index fedee8b3..96a1e2c6 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -26,7 +26,7 @@ sig }; val create_tvsubst_of_mrsbnf: (binding -> binding) -> MRBNF_FP_Def_Sugar.fp_result - -> MRSBNF_Def.mrsbnf -> binding + -> MRSBNF_Def.mrsbnf -> MRBNF_Def.mrbnf -> thm -> binding -> (Proof.context -> tactic) eta_model option list -> string -> local_theory -> tvsubst_result list * local_theory end @@ -279,7 +279,7 @@ fun define_tvsubst_consts qualify (fp_res : MRBNF_FP_Def_Sugar.fp_result) (etas in (defs, lthy) end; -fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_name no_defs_lthy = +fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor 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; @@ -1597,7 +1597,130 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf tvsubst_b models QREC_fixed_n }] } lthy; - val _ = @{print} bmv + 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 rec_bmv_facts = BMV_Monad_Def.leader BMV_Monad_Def.facts_of_bmv_monad bmv; + + val (rec_mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Dont_Note) qualify NONE + (rec_mrbnf :: tl (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf)) 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 = NONE, + map_Sb = NONE, + map_is_Sb = fn ctxt => EVERY1 [ + rtac ctxt ext, + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + let val (fs, t) = split_last (map (Thm.term_of o snd) params); + in rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt o mk_imsupp) 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, + rtac ctxt trans, + rtac ctxt (Drule.rotate_prems (~netas) tvsubst_not_isInj), + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM_N (length rho_prems' + nvars + 1) 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) + ) + ])), + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt vvsubst_ctor, + REPEAT_DETERM o assume_tac ctxt, + 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, + 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 sym, + rtac ctxt trans, + 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) + ) + ])), + REPEAT_DETERM o EqSubst.eqsubst_tac ctxt [0] (@{thms comp_apply} @ [snd (#Inj def)]), + rtac ctxt sym, + rtac ctxt trans, + rtac ctxt vvsubst_ctor, + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o EVERY' [ + SELECT_GOAL (Local_Defs.unfold0_tac ctxt (snd (#noclash quot) :: maps (the_default []) eta_set_emptiess)), + REPEAT_DETERM1 o resolve_tac ctxt @{thms Int_empty_left conjI} + ], + rtac ctxt (arg_cong OF [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}) + ])) defs) + ], + set_Sb = [], + set_Vrs = replicate nvars (fn ctxt => rtac ctxt refl 1) + }) (0 upto length ops - 1)) lthy; + + val _ = @{print} rec_mrsbnf (* val results = @{map 6} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => fn VVrs' => fn tvsubst_permute => { diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 3c91708f..82d8b27c 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -1550,11 +1550,12 @@ 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 @{binding tvsubst_FTerm'} [SOME { + I fp_res mrsbnf mrbnf @{thm FTerm.vvsubst_cctor} @{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 = { From 219af3129b3c31adf3d83fc48887dbe010439fee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 11:08:20 +0100 Subject: [PATCH 52/90] Package resulting theorems in tvsubst_result --- Tools/tvsubst.ML | 72 ++++++++++++------------------------------------ 1 file changed, 17 insertions(+), 55 deletions(-) diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 96a1e2c6..050bb472 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -16,19 +16,16 @@ sig 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 + isInjs: (term * thm) list, + tvsubst_Injs: thm list, + tvsubst_not_isInj: 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 -> binding -> (Proof.context -> tactic) eta_model option list -> string -> local_theory - -> tvsubst_result list * local_theory + -> tvsubst_result * local_theory end structure TVSubst : TVSUBST = @@ -54,13 +51,10 @@ type 'a eta_model = { 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 + isInjs: (term * thm) list, + tvsubst_Injs: thm list, + tvsubst_not_isInj: thm, + mrsbnf: MRSBNF_Def.mrsbnf }; val names = map (fst o dest_Free); @@ -1720,45 +1714,13 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs set_Vrs = replicate nvars (fn ctxt => rtac ctxt refl 1) }) (0 upto length ops - 1)) lthy; - val _ = @{print} rec_mrsbnf - - (* - val results = @{map 6} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => fn VVrs' => fn tvsubst_permute => { + val result = { 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_old", 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), - ("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; -*) in error "tvsubst" end + isInjs = map_filter (Option.map #isInj) defs, + tvsubst_Injs = map_filter I tvsubst_Injs, + tvsubst_not_isInj = tvsubst_not_isInj, + mrsbnf = rec_mrsbnf + }: tvsubst_result; + + in (result, lthy) end; end From d3c43ec70d149a2b1e3320dcd8b2207067299cb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 11:09:59 +0100 Subject: [PATCH 53/90] Add theories to ROOT file --- ROOT | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ROOT b/ROOT index 76426046..4cfa560c 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 From 23f6c7f5193a44c56e54b19994246dd494aa7ff3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 11:43:52 +0100 Subject: [PATCH 54/90] Fix Pi_Calculus theories --- Tools/mrbnf_comp_tactics.ML | 2 +- case_studies/Pi_Calculus/Commitment.thy | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Tools/mrbnf_comp_tactics.ML b/Tools/mrbnf_comp_tactics.ML index 53818bb4..324815b1 100644 --- a/Tools/mrbnf_comp_tactics.ML +++ b/Tools/mrbnf_comp_tactics.ML @@ -399,7 +399,7 @@ fun mr_mk_comp_wit_tac ctxt set'_eq_sets outer inners = unfold_thms_tac ctxt set'_eq_sets THEN unfold_thms_tac ctxt @{thms collect_def UN_insert Union_image_empty} THEN unfold_thms_tac ctxt set_maps THEN - unfold_thms_tac ctxt @{thms Union_Un_distrib} THEN + unfold_thms_tac ctxt @{thms Union_Un_distrib id_def} THEN REPEAT_DETERM ( EVERY (map (etac ctxt @{thm UnE}) (1 upto num_olive - 1)) THEN EVERY (replicate num_olive (HEADGOAL (EVERY' [ diff --git a/case_studies/Pi_Calculus/Commitment.thy b/case_studies/Pi_Calculus/Commitment.thy index 81742353..d4720cc7 100644 --- a/case_studies/Pi_Calculus/Commitment.thy +++ b/case_studies/Pi_Calculus/Commitment.thy @@ -112,7 +112,9 @@ local_setup \MRBNF_Sugar.register_binder_sugar "Commitment.commit" { 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 }\ abbreviation "swapa act x y \ map_action (id(x:=y,y:=x)) act" From e550b9ad347240a5380ec9deaf807796ece8bdb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 11:57:58 +0100 Subject: [PATCH 55/90] Fix POPLmark theories --- case_studies/POPLmark/POPLmark_2B.thy | 4 ++-- case_studies/POPLmark/SystemFSub.thy | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index c8b7b25d..efc44a5b 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -421,7 +421,7 @@ interpretation tvsubst: QREC_cmin_fixed_trm "IImsupp_1_trm \1 \ IIms 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]) + intro!: tvsubst_pat_cong typ.SSupp_comp_bound_old[unfolded comp_def]) apply (unfold typ.vvsubst_permute) apply (auto intro!: typ.IImsupp_permute_commute[THEN fun_cong, unfolded comp_def]) done @@ -1179,7 +1179,7 @@ proof- subgoal by (metis SSupp_typ_TyVar SSupp_typ_fun_upd_le card_of_subset_bound finite.simps finite_ordLess_infinite2 infinite_UNIV) subgoal apply(rule tvsubst_typ_cong) subgoal by (metis SSupp_typ_TyVar SSupp_typ_fun_upd_le card_of_subset_bound finite.simps finite_ordLess_infinite2 infinite_UNIV) - subgoal by (simp add: SSupp_typ_tvsubst_typ_bound \|SSupp_typ (TyVar(f X := T2))| f(2) typ.SSupp_comp_bound) + subgoal by (simp add: SSupp_typ_tvsubst_typ_bound \|SSupp_typ (TyVar(f X := T2))| f(2) typ.SSupp_comp_bound_old) subgoal apply simp subgoal using \|SSupp_typ (TyVar(f X := T2))| bij_implies_inject f(1,3) id_onD by fastforce . . . . diff --git a/case_studies/POPLmark/SystemFSub.thy b/case_studies/POPLmark/SystemFSub.thy index f2f63e64..120b6c54 100644 --- a/case_studies/POPLmark/SystemFSub.thy +++ b/case_studies/POPLmark/SystemFSub.thy @@ -314,7 +314,7 @@ proof 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) + by (auto simp: IImsupp_typ_def infinite_UNIV intro!: typ.Un_bound typ.UN_bound typ.SSupp_comp_bound_old) next case (Forall X T1 T2) then show ?case From 3b41e3ab318dd59ca7d9218a43bfd885c9000f71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 12:10:25 +0100 Subject: [PATCH 56/90] Fix Composition operations theory --- operations/Composition.thy | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/operations/Composition.thy b/operations/Composition.thy index f5e68b14..29b0630e 100644 --- a/operations/Composition.thy +++ b/operations/Composition.thy @@ -71,9 +71,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 *) From 965058720764c7534172f28d6828347e43c721c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 12:31:31 +0100 Subject: [PATCH 57/90] Fix map simp rules --- Tools/mrbnf_sugar.ML | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index dd93a880..df462ada 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -994,7 +994,7 @@ 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 - | _ => let val T = body_type (fastype_of g) + | _ => 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; From 4e486edf297a7ed366538a7038c7fe53d03dd162 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 12:35:15 +0100 Subject: [PATCH 58/90] Fix duplicate IImsupp and SSupp constants in LC --- case_studies/Untyped_Lambda_Calculus/LC.thy | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/case_studies/Untyped_Lambda_Calculus/LC.thy b/case_studies/Untyped_Lambda_Calculus/LC.thy index 2ee81f13..21793c70 100644 --- a/case_studies/Untyped_Lambda_Calculus/LC.thy +++ b/case_studies/Untyped_Lambda_Calculus/LC.thy @@ -9,7 +9,7 @@ begin (* DATATYPE DECLARTION *) -(*declare [[mrbnf_internals]]*) +declare [[mrbnf_internals]] binder_datatype 'a "term" = Var 'a | App "'a term" "'a term" @@ -30,6 +30,8 @@ apply standard type_synonym trm = "var term" +hide_const IImsupp SSupp + (* Some lighter notations: *) abbreviation "VVr \ tvVVr_tvsubst" lemmas VVr_def = tvVVr_tvsubst_def @@ -435,9 +437,9 @@ lemma tvsubst_inv: shows "tvsubst (rrename \ \ (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 \)| " x e2 e1 rule: term.strong_induct) case Bound From bfa06be3dd85ea10aab18acb7b38d162ff2ddd35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 12:51:28 +0100 Subject: [PATCH 59/90] Fix ILC theories --- case_studies/Infinitary_Lambda_Calculus/ILC.thy | 2 ++ case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy | 2 +- .../Infinitary_Lambda_Calculus/ILC_affine.thy | 10 +++++----- case_studies/Infinitary_Lambda_Calculus/ILC_good.thy | 12 ++++++------ .../Infinitary_Lambda_Calculus/ILC_uniform.thy | 10 +++++----- 5 files changed, 19 insertions(+), 17 deletions(-) diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC.thy b/case_studies/Infinitary_Lambda_Calculus/ILC.thy index a420ecff..e00e899b 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC.thy @@ -139,6 +139,8 @@ by (meson injD iVariable_inj) type_synonym itrm = "ivar iterm" +hide_const IImsupp SSupp + (* Some lighter notations: *) abbreviation "VVr \ tvVVr_itvsubst" lemmas VVr_def = tvVVr_itvsubst_def diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy index a3ae91b1..b6ad63f3 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy @@ -97,7 +97,7 @@ 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" diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy index acceb43a..6243dcdd 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy @@ -67,11 +67,11 @@ 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 @@ -89,7 +89,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 +116,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..ce244ed8 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,10 +296,10 @@ 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..af3a3df2 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 +253,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) From 9e48baac80044989eeb8076d9fc443d72793a89e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 12:52:16 +0100 Subject: [PATCH 60/90] Fix Greatest_Fixpoint operations theory --- operations/Greatest_Fixpoint.thy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/operations/Greatest_Fixpoint.thy b/operations/Greatest_Fixpoint.thy index cead3068..77cfe51e 100644 --- a/operations/Greatest_Fixpoint.thy +++ b/operations/Greatest_Fixpoint.thy @@ -44,7 +44,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 *) From fbbac94300c7f45475ae3141604f384acc0fdfa3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 13:19:14 +0100 Subject: [PATCH 61/90] Fix Least_Fixpoint2 theory --- operations/Least_Fixpoint2.thy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/operations/Least_Fixpoint2.thy b/operations/Least_Fixpoint2.thy index 69b8be95..f90efbcf 100644 --- a/operations/Least_Fixpoint2.thy +++ b/operations/Least_Fixpoint2.thy @@ -45,7 +45,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 *) From a9bbc63dc68c5721915b76af7dd7fbf07733a0fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 13:48:25 +0100 Subject: [PATCH 62/90] Fix Least_Fixpoint theory --- operations/Least_Fixpoint.thy | 1 + 1 file changed, 1 insertion(+) 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"}, From b33068c1d8bc5d198e3a6bd585504bb2b38ae589 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 14:47:37 +0100 Subject: [PATCH 63/90] Fix Sugar operations theory --- operations/Sugar.thy | 3 --- 1 file changed, 3 deletions(-) diff --git a/operations/Sugar.thy b/operations/Sugar.thy index c3b88e9e..e382ca0e 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 From 8bd40631753d74a042787bb3b2e9f16b29550344 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 16:01:09 +0100 Subject: [PATCH 64/90] Do not generate a substitution if there are extra free vars --- Tools/mrbnf_sugar.ML | 6 +++- operations/BMV_Monad.thy | 78 +++++++++++++++++----------------------- 2 files changed, 38 insertions(+), 46 deletions(-) diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index df462ada..70948e01 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -867,7 +867,11 @@ fun create_binder_datatype co (spec : spec) lthy = 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 + if length tys = 1 andalso member (op=) frees (hd tys) andalso + not (member (op=) (@{print}(map TFree ( + fold Term.add_tfreesT (maps snd (take i (#ctors spec) @ drop (i + 1) (#ctors spec))) [] + ))) (@{print}(hd tys))) + then SOME (Term.abs ("a", Term.typ_subst_atomic replace' (hd tys)) (mk_ctor (i + 1) [Bound 0] abs')) else NONE ) (#ctors spec)); diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index a5280867..ee3f6026 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -160,6 +160,9 @@ binder_datatype 'a LM = | 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" @@ -181,14 +184,6 @@ ML \ Multithreading.parallel_proofs := 0 \ -lemma VVr_eq_Var_LM[simp]: "tvVVr_tvsubst_LM = Var" - apply (unfold tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def comp_def Var_def) - apply (rule refl) - done -lemma IImsupp_SSupp_bound[simp]: "( |IImsupp_LM (f::'a::var \ _)| ( |SSupp_LM f| Vrs_2 t" apply (induction t rule: LM.induct) apply auto @@ -201,13 +196,13 @@ lemma IImsupp_Diff_Vrs_1: "B \ IImsupp_LM h = {} \ (\ IImsupp_LM h = {} \ (\ 'a" assumes "|supp f1| (\x\Vrs_2 t. Vrs_1 (f2 x))" -proof (binder_induction t avoiding: "imsupp f1" "IImsupp_LM f2" rule: LM.strong_induct) +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 simp - apply (unfold Un_Diff) - apply (rule arg_cong2[of _ _ _ _ "(\)"]) - apply (simp add: imsupp_def supp_def) - apply fastforce - apply (rule sym) - apply (rule IImsupp_Diff_Vrs_1) - apply blast - done + 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 infinite_UNIV) 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" "IImsupp_LM f2" rule: LM.strong_induct) - case (Lst x) - then show ?case by auto -next - case (App x1 x2) - then show ?case by simp +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) + 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 - fixes g::"'a LM \ 'a LM" and f ::"'a \ 'a LM" - shows "IImsupp_LM (g o f) \ IImsupp_LM g \ IImsupp_LM f" - unfolding IImsupp_LM_def -*) - -(* AtoJ: Proved this first (which is anyway generally useful) *) lemma FVars_LM_Sb_LM: fixes \::"'a::var \ 'a" and \::"'a::var \ 'a LM" assumes "|supp \| | 'a" assumes "|supp g| '| | ' \ \) \ imsupp g \ IImsupp_LM \' \ IImsupp_LM \" -unfolding IImsupp_LM_def SSupp_LM_def imsupp_def supp_def using assms apply safe +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 @@ -318,9 +305,11 @@ lemma Sb_LM_cong: 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" "IImsupp_LM \'" "imsupp f" "IImsupp_LM \" rule: LM.strong_induct) - apply (auto simp: imsupp_supp_bound infinite_UNIV assms LM.permute_id) - by (metis (mono_tags, lifting) IImsupp_LM_def SSupp_LM_def Un_iff imsupp_def mem_Collect_eq supp_def) + 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 @@ -329,21 +318,20 @@ pbmv_monad "'b::var LM" Vrs: Vrs_2 bd: natLeq apply (rule infinite_regular_card_order_natLeq) - apply (unfold SSupp_def[of Var, unfolded SSupp_LM_def[unfolded tvVVr_tvsubst_LM_def comp_def tv\_LM_tvsubst_LM_def Var_def[symmetric], symmetric]]) 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_LM_def SSupp_LM_def tvVVr_tvsubst_LM_def tv\_LM_tvsubst_LM_def Var_def) + 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" "IImsupp_LM \" "IImsupp_LM \'" rule: LM.strong_induct) - apply (auto simp: imsupp_supp_bound infinite_UNIV prems IImsupp_LM_def LM.set_bd_UNIV intro!: var_class.Un_bound var_class.UN_bound)[7] + 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!: var_class.Un_bound var_class.UN_bound)[7] apply (auto simp: prems) apply (subst Sb_LM_simp4) apply (rule contra_subsetD[OF imsupp_o]) @@ -374,7 +362,7 @@ lemma vvsubst_Sb: apply (auto simp: imsupp_supp_bound assms infinite_UNIV) apply (subst Sb_LM_simp4) apply assumption - apply (unfold IImsupp_LM_def SSupp_LM_def VVr_eq_Var_LM comp_def LM.Inj_inj LM.set UN_singleton imsupp_def supp_def)[1] + 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 From 1e247a4ac4f05b710e3b428962b551923543bda8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 11 Jul 2025 17:49:54 +0100 Subject: [PATCH 65/90] Use mrsbnf composition for binder_datatypes --- Tools/bmv_monad_def.ML | 1 - Tools/mrbnf_sugar.ML | 37 ++++++++++++++++++++----------------- Tools/mrsbnf_comp.ML | 37 +++++++++++++++++++++---------------- operations/BMV_Fixpoint.thy | 13 +++++++------ operations/BMV_Monad.thy | 12 +----------- thys/MRBNF_Recursor.thy | 12 ++++++++++-- 6 files changed, 59 insertions(+), 53 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index b727f656..ac0bc6bd 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -1125,7 +1125,6 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = )) ); val name = MRBNF_Def.name_of_mrbnf mrbnf; - val _ = @{print} ("MRBNF name" , name) in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I (SOME name) { ops = [T], var_class = var_class, diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 70948e01..5a5e08a9 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -42,9 +42,9 @@ 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 * local_theory end structure MRBNF_Sugar : MRBNF_SUGAR = @@ -136,20 +136,22 @@ 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 NONE 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 mrbnf lthy + + val ((mrsbnf, (Ds, absinfo)), lthy) = MRSBNF_Comp.seal_mrsbnf I (bmv_unfolds, 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, @@ -158,7 +160,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 @@ -257,7 +259,8 @@ fun build_set_for _ aT x (TFree (s, _)) = if s = fst (dest_TFree aT) then SOME ( 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 ((res, fp_pre_T, mrsbnf, absinfo), lthy) = create_binder_type fp_kind spec lthy; + val mrbnf = hd (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf); val (vvsubst_res_opt, lthy) = if co then (NONE, lthy) else (* TODO: Automate renaming for codatatypes *) let @@ -868,9 +871,9 @@ fun create_binder_datatype co (spec : spec) lthy = val etas = map_filter I (map_index (fn (i, (_, tys)) => if length tys = 1 andalso member (op=) frees (hd tys) andalso - not (member (op=) (@{print}(map TFree ( + not (member (op=) (map TFree ( fold Term.add_tfreesT (maps snd (take i (#ctors spec) @ drop (i + 1) (#ctors spec))) [] - ))) (@{print}(hd tys))) + )) (hd tys)) then SOME (Term.abs ("a", Term.typ_subst_atomic replace' (hd tys)) (mk_ctor (i + 1) [Bound 0] abs')) else NONE diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index d39552ab..22b4b5eb 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -15,7 +15,7 @@ signature MRSBNF_COMP = sig * (((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 - -> typ list -> typ list -> MRSBNF_Def.mrsbnf -> (string * Typedef.info) option -> local_theory + -> ((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 @@ -44,23 +44,30 @@ fun morph_info phi ({rep_type, abs_type, Rep_name: string, Abs_name: string, axi axiom_name = axiom_name }, x) -fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name vars Ds mrsbnf info_opt lthy = +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 var_types = MRBNF_Def.var_types_of_mrbnf mrbnf; - val (lives, bounds, frees) = MRBNF_Def.deinterlace vars var_types; + val mrbnf' = nth (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) (BMV_Monad_Def.leader_of_bmv_monad bmv); + + val (_, _, (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_types = MRBNF_Def.var_types_of_mrbnf mrbnf'; + val (lives, bounds, frees) = MRBNF_Def.deinterlace (snd tys) var_types; val bounds = map (resort_tfree_or_tvar @{sort var}) bounds; val frees = map (resort_tfree_or_tvar @{sort var}) frees; - val rep_T = MRBNF_Def.mk_T_of_mrbnf Ds lives bounds frees mrbnf; - - val ((mrbnf, info, (Ds, absT_info)), lthy) = MRBNF_Comp.seal_mrbnf qualify mrbnf_unfolds name true Ds Ds mrbnf info_opt lthy; + 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 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; @@ -83,8 +90,8 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name vars Ds mrsbnf info_op 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 defs = bmv_defs @ [MRBNF_Def.map_def_of_mrbnf mrbnf] @ MRBNF_Def.set_defs_of_mrbnf mrbnf; 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) ( @@ -104,7 +111,7 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name vars Ds mrsbnf info_op ) (BMV_Monad_Def.ops_of_bmv_monad bmv) mrbnfs; val subst = Term.subst_atomic_types (lives ~~ lives'); - val unfold_defs = Local_Defs.unfold0 lthy mrbnf_defs; + 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}, @@ -145,16 +152,17 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name vars Ds mrsbnf info_op 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)) THEN_ALL_NEW assume_tac ctxt ], - set_Sb = map (fn thm => fn ctxt => EVERY1 [ + 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, - rtac ctxt (unfold_defs thm) THEN_ALL_NEW assume_tac ctxt, + 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 ]) (#set_Sb axioms), set_Vrs = map (fn thm => fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), + K (Local_Defs.unfold_tac ctxt (defs @ [@{thm SSupp_type_copy} OF [copy]])), rtac ctxt @{thm trans[OF comp_apply]}, rtac ctxt trans, rtac ctxt (unfold_defs thm), @@ -205,15 +213,12 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 _ = @{print} ("Ts", map MRBNF_Def.T_of_mrbnf inner_mrbnfs) - 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 _ = @{print} (MRBNF_Def.T_of_mrbnf mrbnf, T) 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 diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 82d8b27c..3d4d10fa 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -19,12 +19,13 @@ Multithreading.parallel_proofs := 0 local_setup \fn lthy => let val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; - val Xs = [@{typ 'tv}, @{typ 'v}, @{typ 'btv}, @{typ 'bv}, @{typ 'c}, @{typ 'd}]; + 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, (Ds, tys)), (((_, bmv_unfolds), (_, mrbnf_unfolds)), lthy)) = MRSBNF_Comp.mrsbnf_of_typ true (K BNF_Def.Dont_Note) - I [] (map (apfst dest_TFree) [(@{typ 'v}, MRBNF_Def.Free_Var), - (@{typ 'btv}, MRBNF_Def.Bound_Var), (@{typ 'bv}, MRBNF_Def.Bound_Var)]) - (fn xss => inter (op=) (flat xss) (map dest_TFree Xs)) + 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); @@ -39,7 +40,7 @@ let 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 Ds mrsbnf NONE lthy + @{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; diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index ee3f6026..1234462c 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -6,6 +6,7 @@ theory BMV_Monad begin declare [[mrbnf_internals]] +declare [[ML_print_depth=1000]] binder_datatype 'a FType = TyVar 'a | TyApp "'a FType" "'a FType" @@ -119,19 +120,8 @@ lemma map_is_Sb_FType: declare [[ML_print_depth=1000]] -ML_file \../Tools/bmv_monad_tacs.ML\ -ML_file \../Tools/bmv_monad_def.ML\ - local_setup \fold BMV_Monad_Def.register_mrbnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ -ML_file \../Tools/mrsbnf_def.ML\ - -local_setup \fn lthy => -let - val (mrsbnf, _) = MRSBNF_Def.mrsbnf_of_mrbnf (the (MRBNF_Def.mrbnf_of lthy @{type_name FType_pre})) lthy; - val _ = @{print} mrsbnf -in lthy end\ - pbmv_monad "'tv::var FType" Sbs: tvsubst_FType Injs: TyVar diff --git a/thys/MRBNF_Recursor.thy b/thys/MRBNF_Recursor.thy index 84df7336..df47f997 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 @@ -36,8 +39,13 @@ lemma notin_Un_forward: "x \ A \ B \ (x \ A 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/mrbnf_sugar.ML\ context begin From 9aa2a89d9969116cfe7694576940e240fcf9060c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 5 Aug 2025 11:17:02 +0100 Subject: [PATCH 66/90] Use class registry also for BMV monads --- Tools/bmv_monad_def.ML | 9 +++------ Tools/bmv_monad_tacs.ML | 2 +- Tools/mrsbnf_comp.ML | 5 +++-- Tools/mrsbnf_def.ML | 10 +++++----- Tools/tvsubst.ML | 8 ++++---- thys/Classes.thy | 16 +++++++++++++--- thys/Support.thy | 11 ----------- 7 files changed, 29 insertions(+), 32 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index ac0bc6bd..87bf57a6 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -861,9 +861,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona else NONE )) (#Injs (#consts model)) (#Vrs (#consts model)); - val Un_bound = MRBNF_Def.get_class_assumption [#var_class model] "Un_bound" lthy; - val UN_bound = MRBNF_Def.get_class_assumption [#var_class model] "UN_bound" lthy; - val UNIV_cinfinite = MRBNF_Def.get_class_assumption [#var_class model] "UNIV_cinfinite" lthy; + val UNIV_cinfinite = @{thm var_class.UNIV_cinfinite}; val Injss = #Injs (#consts model); @@ -1105,9 +1103,8 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = ||>> 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 = case MRBNF_Def.bd_of_mrbnf mrbnf of - @{term natLeq} => @{class var} - | _ => error "TODO: other var classes" + 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 diff --git a/Tools/bmv_monad_tacs.ML b/Tools/bmv_monad_tacs.ML index dec098b4..dd000658 100644 --- a/Tools/bmv_monad_tacs.ML +++ b/Tools/bmv_monad_tacs.ML @@ -157,7 +157,7 @@ fun mk_IImsupp_Sb_boundss T Sb Injs Vrs hs rhos SSupp_prems IImsupp_Sb_subsetss 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 @ - @{thms var_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV var_class.large'} + @{thms infinite_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV var_class.large'} ), CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) ] diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 22b4b5eb..b7e5fa5c 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -56,10 +56,11 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt 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 (snd tys) var_types; - val bounds = map (resort_tfree_or_tvar @{sort var}) bounds; - val frees = map (resort_tfree_or_tvar @{sort var}) frees; + val bounds = map (resort_tfree_or_tvar var_class) bounds; + val frees = map (resort_tfree_or_tvar var_class) frees; val rep_T = MRBNF_Def.mk_T_of_mrbnf Ds lives bounds frees mrbnf'; val (lives', _) = lthy diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index 25f52a75..c785b0bc 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -294,7 +294,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b end ) Injs gs g_prems; - val Un_bound = MRBNF_Def.get_class_assumption [BMV_Monad_Def.var_class_of_bmv_monad bmv] "Un_bound" lthy; + 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 ( @@ -468,7 +468,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 var_class.Un_bound}, + 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}, @@ -719,7 +719,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 var_class.Un_bound + 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) @@ -744,7 +744,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b ])), 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 var_class.Un_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) @@ -782,7 +782,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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 var_class.Un_bound + 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) diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 050bb472..c39f56f9 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -713,7 +713,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs 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_fixed_name))), REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ - resolve_tac ctxt (@{thms var_class.Un_bound var_class.UN_bound} @ rho_prems + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound} @ rho_prems @ maps (MRBNF_Def.set_bd_UNIV_of_mrbnf) (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) @ #card_of_FVars_bound_UNIVs quot ), @@ -1152,7 +1152,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs in Goal.prove_sorry lthy (names (map_filter I rhos @ [t])) rho_prems' goal (fn {context=ctxt, prems} => EVERY1 [ rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) avoiding_sets) fresh_induct), REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ - resolve_tac ctxt (@{thms var_class.Un_bound var_class.UN_bound} @ prems + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound} @ prems @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) @ #card_of_FVars_bound_UNIVs quot ), @@ -1357,7 +1357,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs ) ctxt, REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ assume_tac ctxt, - resolve_tac ctxt (@{thms var_class.Un_bound var_class.UN_bound} + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_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 @@ -1515,7 +1515,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs ) fresh_induct), REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ assume_tac ctxt, - resolve_tac ctxt (@{thms var_class.Un_bound var_class.UN_bound} + resolve_tac ctxt (@{thms infinite_class.Un_bound var_class.UN_bound} @ #card_of_FVars_bound_UNIVs quot @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) @ prems ), diff --git a/thys/Classes.thy b/thys/Classes.thy index b686cc87..0235e49d 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\ @@ -97,10 +97,20 @@ local_setup \ \ (* Theorems *) - lemma supp_comp_bound_var: assumes bound: "|supp f| f)| |supp (f::'a::var \ 'a)| + (\a. Vrs (Inj a) = {a}) \ |IImsupp Inj Vrs (Inj \ f)| a. Vrs (Inj a) = {}) \ |IImsupp Inj Vrs (Inj \ f)| |supp (f::'a::var \ 'a)| - (\a. Vrs (Inj a) = {a}) \ |IImsupp Inj Vrs (Inj \ f)| a. Vrs (Inj a) = {}) \ |IImsupp Inj Vrs (Inj \ f)| Date: Tue, 5 Aug 2025 13:16:08 +0100 Subject: [PATCH 67/90] Fix handling of deads in seal_mrsbnf --- Tools/mrbnf_comp.ML | 2 +- Tools/mrsbnf_comp.ML | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Tools/mrbnf_comp.ML b/Tools/mrbnf_comp.ML index 8dfae91c..44d77193 100644 --- a/Tools/mrbnf_comp.ML +++ b/Tools/mrbnf_comp.ML @@ -1426,7 +1426,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'', the info_opt, (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/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index b7e5fa5c..c28315c8 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -67,7 +67,7 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt |> fold Variable.declare_typ (vars @ map TFree (fold Term.add_tfreesT Ds [])) |> mk_TFrees (length lives); - val T = MRBNF_Def.mk_T_of_mrbnf Ds lives bounds frees mrbnf; + 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)) From 0c4412700388f3ff0de3bea6d876ece1245c8f98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 5 Aug 2025 13:42:49 +0100 Subject: [PATCH 68/90] Fix map_is_Sb for simple sealing --- Tools/mrsbnf_comp.ML | 8 +++++--- operations/BMV_Fixpoint.thy | 14 +++++++------- operations/BMV_Monad.thy | 4 ++-- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index c28315c8..574bcb18 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -148,9 +148,11 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt ])) (#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}, - rtac ctxt copy, - K (Local_Defs.unfold0_tac ctxt (comp_assocs @ [@{thm type_copy_Rep_o_Abs_o} 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)) THEN_ALL_NEW assume_tac ctxt ], set_Sb = map (fn _ => fn ctxt => EVERY1 [ diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 3d4d10fa..a52b85ed 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -451,7 +451,7 @@ interpretation tvsubst: QREC_fixed_FTerm "avoiding_set1 f1 f2" else FTerm_ctor (Sb_FTerm_pre id f2 (map_FTerm_pre id id id id snd snd y))" apply unfold_locales - apply ((rule var_class.Un_bound var_class.UN_bound f_prems FType.set_bd_UNIV + 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] @@ -825,7 +825,7 @@ lemma FVars_tvsubst1: shows "FVars (tvsubst_FTerm f1 f2 t) = (\a\FVars t. FVars (f1 a))" apply (rule FTerm.TT_fresh_induct[of "avoiding_set1 f1 f2" "avoiding_set2 f1" _ t]) - apply ((rule var_class.Un_bound var_class.UN_bound f_prems FType.set_bd_UNIV + 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] @@ -918,7 +918,7 @@ lemma FVars_tvsubst2: "|SSupp TyVar \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 var_class.Un_bound var_class.UN_bound f_prems FType.set_bd_UNIV + 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] @@ -1002,7 +1002,7 @@ lemma SSupp_tvsubst_bound: shows "|SSupp VVr (tvsubst_FTerm \1 \2 \ \1')| \'::"'tyvar::var \ 'tyvar FType" assumes "|SSupp_FType \| '| \ \')| ' 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!: var_class.Un_bound var_class.UN_bound)[7] + 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]) From 6e310eb0ef849801d27ac885b3ba02ccb6ff0e20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 8 Aug 2025 16:34:32 +0100 Subject: [PATCH 69/90] Fix lingering issues of mrsbnf composition --- Tools/mrbnf_sugar.ML | 20 +++++++++-- Tools/mrsbnf_comp.ML | 29 +++++++++------ Tools/mrsbnf_def.ML | 51 ++++++++++++++++----------- case_studies/POPLmark/POPLmark_2B.thy | 1 + operations/BMV_Composition.thy | 7 +--- operations/BMV_Fixpoint.thy | 6 +--- operations/BMV_Monad.thy | 4 --- tests/Regression_Tests.thy | 1 + 8 files changed, 70 insertions(+), 49 deletions(-) diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 5a5e08a9..8f882260 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -611,6 +611,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 *) @@ -689,6 +697,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 @@ -1066,7 +1075,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))) @@ -1100,7 +1110,8 @@ 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} ])), @@ -1154,6 +1165,7 @@ fun create_binder_datatype co (spec : spec) lthy = REPEAT_DETERM o resolve_tac ctxt prems, 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 @ #isVVrs tvsubst_res @ map snd (#VVrs tvsubst_res) @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, snd (#noclash quotient)] )), @@ -1177,7 +1189,9 @@ fun create_binder_datatype co (spec : spec) lthy = ])), eresolve_tac ctxt @{thms sum.distinct[THEN notE]} ], - K (Local_Defs.unfold0_tac ctxt (map MRBNF_Def.map_id0_of_mrbnf fp_nesting_mrbnfs)), + K (Local_Defs.unfold0_tac ctxt (map MRBNF_Def.map_id0_of_mrbnf fp_nesting_mrbnfs + @ map (BNF_Def.map_id_of_bnf o snd) bnfs + )), K (Local_Defs.unfold0_tac ctxt @{thms id_def}), rtac ctxt refl ] diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 574bcb18..442469f6 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -51,16 +51,17 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt 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 (_, _, (mrbnfs', (_, lthy))) = MRBNF_Comp.normalize_mrbnfs (K I) [] [map dest_TFree (snd tys)] + 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 (snd tys) var_types; + 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 rep_T = MRBNF_Def.mk_T_of_mrbnf Ds lives bounds frees mrbnf'; val (lives', _) = lthy @@ -137,7 +138,8 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt 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) THEN_ALL_NEW assume_tac ctxt + 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), @@ -153,7 +155,8 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt 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)) THEN_ALL_NEW assume_tac ctxt + 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]])), @@ -163,15 +166,17 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt REPEAT_DETERM o assume_tac ctxt, K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), rtac ctxt refl - ]) (#set_Sb axioms), - set_Vrs = map (fn thm => fn ctxt => EVERY1 [ + ]) (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 trans, - rtac ctxt (unfold_defs thm), - K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), - rtac ctxt refl - ]) (#set_Vrs axioms) + 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 + ] + ])) (#set_Vrs axioms) } ) (MRSBNF_Def.axioms_of_mrsbnf mrsbnf)) lthy; in ((mrsbnf, (snd (dest_Type T), absT_info)), lthy) end @@ -216,8 +221,10 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 _ = @{print} "wat" 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 _ = @{print} (tys, MRBNF_Def.T_of_mrbnf mrbnf) val mrbnf = let diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index c785b0bc..b5a8199f 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -860,18 +860,27 @@ fun mk_mrsbnf_axioms mrbnfs bmv 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 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 phi = MRBNF_Util.subst_typ_morphism subst; + 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 mrbnfs = map (MRBNF_Def.morph_mrbnf phi) mrbnfs; - val bmv = BMV_Monad_Def.morph_bmv_monad phi bmv; - end; + val bmv = BMV_Monad_Def.morph_bmv_monad (the_default subst_phi phi) bmv; + end val axioms = @{map 7} (fn mrbnf => fn Sb => fn Injs => fn RVrs => fn Vrs => fn Map_opt => fn lives => let @@ -888,14 +897,15 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = 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 ( + 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 @ map HOLogic.id_const (drop (length frees) Fs)) + )) As) (map HOLogic.id_const Bs) free_fs' (MRBNF_Def.var_types_of_mrbnf mrbnf) ), let val add_Map = case Map_opt of @@ -905,9 +915,11 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = 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 => the (List.find (fn f => - HOLogic.dest_setT (body_type (fastype_of RVr)) = domain_type (fastype_of f) - ) fs)) RVrs @ map (fn Inj => + 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 @@ -921,14 +933,13 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = ||>> apfst hd o mk_Frees "x" [body_type (fastype_of Sb)]; val live = MRBNF_Def.live_of_mrbnf mrbnf; - val pfree_fs = drop free free_fs'; 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 free [] @ map (fn f => [HOLogic.mk_Trueprop (mk_supp_bound f)]) pfree_fs) + (replicate (length free_fs') []) var_types ); val other_fs = flat (MRBNF_Def.interlace (map single live_fs) (map single bound_fs) - (replicate free [] @ map single pfree_fs) var_types); + (replicate (length free_fs') []) var_types); val g_prems = map2 (fn Inj => fn g => HOLogic.mk_Trueprop (uncurry mk_ordLess ( mk_card_of (mk_SSupp Inj $ g), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) @@ -938,7 +949,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val count = live + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; val map_Sb = if count - free = 0 then NONE else let - val map_t = Term.list_comb (mapx, MRBNF_Def.interlace live_fs bound_fs (map HOLogic.id_const frees @ pfree_fs) var_types); + 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 @ h_prems @ g_prems) (mk_Trueprop_eq ( HOLogic.mk_comp (map_t, Sb_t), @@ -966,7 +977,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val set_Sbs = let val sets' = flat (MRBNF_Def.interlace (map single live_sets) (map single bound_sets) - (replicate free [] @ map single (drop free free_sets)) var_types); + (replicate (length free_fs') []) var_types); in map (fn set => fold_rev Logic.all (hs @ gs @ [x]) (fold_rev (curry Logic.mk_implies) (h_prems @ 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 => diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index efc44a5b..bea4ef4a 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -2,6 +2,7 @@ theory POPLmark_2B imports Pattern "HOL-Library.List_Lexorder" "HOL-Library.Char_ord" begin +declare [[ML_print_depth=1000]] binder_datatype (FTVars: 'tv, FVars: 'v) trm = Var 'v | Abs x::'v "'tv typ" t::"('tv, 'v) trm" binds x in t diff --git a/operations/BMV_Composition.thy b/operations/BMV_Composition.thy index 90baf104..91c06447 100644 --- a/operations/BMV_Composition.thy +++ b/operations/BMV_Composition.thy @@ -49,12 +49,7 @@ consts Inj_2_T4 :: "'b \ ('a::var, 'b::var) T4" ML_file \../Tools/bmv_monad_def.ML\ -ML \ -Multithreading.parallel_proofs := 0 -\ - declare [[goals_limit=1000]] - declare [[ML_print_depth=1000]] pbmv_monad "('a, 'b, 'c, 'd, 'e, 'f, 'g) T1" @@ -800,4 +795,4 @@ let in lthy end \ -end \ No newline at end of file +end diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index a52b85ed..4b7aa3f6 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -12,10 +12,6 @@ type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = ML_file \../Tools/mrsbnf_comp.ML\ -ML \ -Multithreading.parallel_proofs := 0 -\ - local_setup \fn lthy => let val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; @@ -1570,4 +1566,4 @@ val x = TVSubst.create_tvsubst_of_mrsbnf in lthy end\ -end \ No newline at end of file +end diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index fcdfb306..f27812d4 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -170,10 +170,6 @@ axiomatization Sb_LM :: "('a::var \ 'a) \ ('a \ imsupp f1 \ x \ IImsupp_LM f2 \ Sb_LM f1 f2 (Lam x t) = Lam x (Sb_LM f1 f2 t)" -ML \ -Multithreading.parallel_proofs := 0 -\ - lemma Vrs_Un: "FVars_LM t = Vrs_1 t \ Vrs_2 t" apply (induction t rule: LM.induct) apply auto diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index 5886d146..0fbc93cf 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -14,6 +14,7 @@ binder_datatype 'a LLC = | Abs x::'a t::"'a LLC" binds x in t | Let "(x::'a, t::'a LLC) alist" u::"'a LLC" binds x in t u +declare [[ML_print_depth=1000]] (* #70 *) datatype ('tv, 'ev, 'rv) type = Type 'tv 'ev 'rv binder_datatype ('tv, 'ev, 'rv) type_scheme = From 45370dea7acf5c5a5a8ed636cf45d9c88953a607 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 8 Aug 2025 17:12:41 +0100 Subject: [PATCH 70/90] Clamp var types in fast compose path --- Tools/mrsbnf_comp.ML | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 442469f6..f68b0c3b 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -521,7 +521,9 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_De 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 the_default var_type req + 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 From 5d4139c06048c3d9f5448a3cf376c32e6f77c66e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 10 Aug 2025 13:00:21 +0100 Subject: [PATCH 71/90] First working integration of bmv-based substitution --- Tools/binder_inductive.ML | 5 +- Tools/binder_sugar.ML | 81 ++ Tools/bmv_monad_def.ML | 12 +- Tools/mrbnf_sugar.ML | 162 ++- Tools/mrbnf_tvsubst.ML | 1443 ------------------- Tools/mrsbnf_comp.ML | 6 +- Tools/tvsubst.ML | 34 +- case_studies/Untyped_Lambda_Calculus/LC.thy | 18 +- thys/MRBNF_Recursor.thy | 3 +- 9 files changed, 241 insertions(+), 1523 deletions(-) create mode 100644 Tools/binder_sugar.ML delete mode 100644 Tools/mrbnf_tvsubst.ML diff --git a/Tools/binder_inductive.ML b/Tools/binder_inductive.ML index 8b1d9d3f..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 @@ -540,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; diff --git a/Tools/binder_sugar.ML b/Tools/binder_sugar.ML new file mode 100644 index 00000000..9fe84a19 --- /dev/null +++ b/Tools/binder_sugar.ML @@ -0,0 +1,81 @@ +signature BINDER_SUGAR = sig + +type binder_sugar = { + map_simps: thm list, + set_simpss: thm list list, + permute_simps: thm list, + map_permute: thm, + subst_simps: thm list option, + IImsupp_permute_commutes: thm list option, + IImsupp_Diffs: 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; + + +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, + subst_simps: thm list option, + IImsupp_permute_commutes: thm list option, + IImsupp_Diffs: 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, IImsupp_permute_commutes, IImsupp_Diffs } = { + map_simps = map (Morphism.thm phi) map_simps, + permute_simps = map (Morphism.thm phi) permute_simps, + map_permute = 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, + 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 (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 index 87bf57a6..435f94ef 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -2329,8 +2329,18 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = }] } : (Proof.context -> tactic) bmv_monad_model; + fun set_unfolds thms (BMV { + ops, var_class, leader: int, frees, lives, lives', deads, consts, params, bd_infinite_regular_card_order, + axioms, facts, ... + }) = BMV { + ops = ops, var_class = var_class, leader = leader, frees = frees, lives = lives, lives' = lives', + deads = deads, consts = consts, params = params, bd_infinite_regular_card_order = bd_infinite_regular_card_order, + axioms = axioms, facts = facts, unfolds = thms + } + val ((bmv, _), lthy) = bmv_monad_def BNF_Def.Hardly_Inline (K BNF_Def.Note_Some) qualify NONE model lthy; - val new_unfolds = map (Local_Defs.unfold0 lthy unfolds) defs; + val new_unfolds = map (Local_Defs.unfold lthy unfolds) defs; + val bmv = set_unfolds new_unfolds bmv; in ((bmv, new_unfolds, defs, (T_name, info)), lthy) end diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 8f882260..aa55e701 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -38,9 +38,6 @@ 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 * MRSBNF_Def.mrsbnf * MRBNF_Comp.absT_info) * local_theory @@ -147,7 +144,8 @@ fun create_binder_type (fp : MRBNF_Util.fp_kind) (spec : spec) lthy = val (mrsbnf, lthy) = case mrsbnf_opt of Inl mrsbnf => (mrsbnf, lthy) | Inr mrbnf => MRSBNF_Def.mrsbnf_of_mrbnf mrbnf lthy - val ((mrsbnf, (Ds, absinfo)), lthy) = MRSBNF_Comp.seal_mrsbnf I (bmv_unfolds, snd accum) + 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); @@ -261,6 +259,7 @@ fun create_binder_datatype co (spec : spec) lthy = val fp_kind = if co then MRBNF_Util.Greatest_FP else MRBNF_Util.Least_FP; 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 @@ -878,21 +877,25 @@ 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)) => + 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 (Term.abs ("a", Term.typ_subst_atomic replace' (hd tys)) (mk_ctor (i + 1) [Bound 0] abs')) + 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 + @ BMV_Monad_Def.unfolds_of_bmv_monad bmv @ [#Abs_inverse (snd info) OF @{thms UNIV_I}] )), rtac ctxt refl @@ -901,24 +904,63 @@ fun create_binder_datatype co (spec : spec) lthy = K (Local_Defs.unfold0_tac ctxt (@{thms sum.inject} @ [#Abs_inject (snd info) OF @{thms UNIV_I UNIV_I}])), assume_tac ctxt ]; + 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 + @ BMV_Monad_Def.unfolds_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 + ) ctxt, + hyp_subst_tac ctxt, + 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, + REPEAT_DETERM o etac ctxt @{thm UN_E}, + REPEAT_DETERM o eresolve_tac ctxt @{thms setl.cases setr.cases}, + hyp_subst_tac ctxt, + rtac ctxt exI, + rtac ctxt refl + ]; fun eta_natural_tac ctxt = EVERY1 [ K (Local_Defs.unfold0_tac ctxt (@{thms comp_def map_sum.simps} @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, MRBNF_Def.map_def_of_mrbnf pre_mrbnf] )), 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 + @ BMV_Monad_Def.unfolds_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, eta_natural = eta_natural_tac }; - 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 - )) vars - } + val eta_models = map (fn a => Option.map (fn { eta, Inj } => { eta = eta, Inj = Inj, tacs = tvsubst_axioms }) ( + List.find (fn { eta, ...} => domain_type (fastype_of eta) = 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 @@ -1022,14 +1064,14 @@ fun create_binder_datatype co (spec : spec) lthy = 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 + | SOME ts => HOLogic.dest_setT (fastype_of (hd ts)) = T ) 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) + maps (fn f => map (HOLogic.mk_Trueprop o HOLogic.mk_not o HOLogic.mk_mem o pair 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 + in maps (fn f => map (HOLogic.mk_Trueprop o mk_int_empty o pair t) (the (mk_imsupp_opt f T))) (get_fs T) end )) bound_sets; val free_rec_vars = subtract (op=) (map (nth rec_vars) (flat (map snd (#binding_rel spec)))) rec_vars; @@ -1096,9 +1138,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 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; @@ -1134,39 +1176,61 @@ fun create_binder_datatype co (spec : spec) lthy = REPEAT_DETERM o resolve_tac ctxt (MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf :: @{thms cmin_Cinfinite conjI card_of_Card_order}) ]); +<<<<<<< HEAD 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 (tvsubst_res, lthy) = TVSubst.create_tvsubst_of_mrsbnf (Binding.prefix_name "tv") res mrsbnf + rec_mrbnf (#vvsubst_ctor vvsubst_res) (#tvsubst_b spec) eta_models (#QREC_fixed recursor_result) 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) - ) (map fst (#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 - ) (map fst (flat (#IImsuppss tvsubst_res))) - )) fs)); + val fs = map_filter I (map2 (fn f => Option.map (fn _ => f)) fs (map (Option.map #eta) eta_models)); + + 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); + + fun mk_supp_bound f = if Term.is_TFree (body_type (fastype_of f)) then SOME (MRBNF_Util.mk_supp_bound f) else + Option.map (fn Inj => mk_ordLess + (mk_card_of (mk_SSupp Inj $ f)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of f)))) + ) (List.find (fn Inj => fastype_of Inj = fastype_of f) Injs); + fun mk_imsupp h _ = + let + val Inj = the (List.find (fn Inj => fastype_of Inj = fastype_of h) Injs); + val Vrs = nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) ( + find_index (curry (op=) (body_type (fastype_of Inj))) (BMV_Monad_Def.ops_of_bmv_monad bmv) + ); + in SOME ((mk_SSupp Inj $ h) :: map (fn Vrs => mk_IImsupp Inj Vrs $ h) Vrs) end + 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) eta_models))), 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 @ map (BNF_Def.map_id_of_bnf o snd) bnfs - @ #isVVrs tvsubst_res @ map snd (#VVrs tvsubst_res) + @ map snd (#isInjs tvsubst_res) @ [#Abs_inverse (snd info) OF @{thms UNIV_I}, snd (#noclash quotient)] )), K (TRYALL (REPEAT_DETERM o EVERY' [ @@ -1181,17 +1245,18 @@ 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_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} + @ [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 @{thms id_def}), rtac ctxt refl ] @@ -1204,16 +1269,15 @@ 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]} - fun unfold_tvsubst res = map_filter (Option.map ( + (*fun unfold_tvsubst res = map_filter (Option.map ( Local_Defs.unfold lthy ( @{thms SSupp_def[symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong]} - @ map snd (flat (#IImsuppss res)) @ map snd (#SSupps res) - @ #eta_defs res @ map snd (#VVrs res) @ 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 res (#IImsupp_permute_commutes res)) tvsubst_opt; val IImsupp_Diffs = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_Diffs res)) tvsubst_opt; @@ -1257,7 +1321,7 @@ fun create_binder_datatype co (spec : spec) lthy = } : 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], []), diff --git a/Tools/mrbnf_tvsubst.ML b/Tools/mrbnf_tvsubst.ML deleted file mode 100644 index 334c291f..00000000 --- a/Tools/mrbnf_tvsubst.ML +++ /dev/null @@ -1,1443 +0,0 @@ -signature MRBNF_TVSUBST = -sig - type 'a eta_axioms = { - eta_free: 'a, - eta_inj: 'a, - eta_natural: 'a - }; - - type 'a tvsubst_model = { - binding: binding, - etas: (term * 'a eta_axioms) option list - }; - - type tvsubst_result = { - tvsubst: term, - SSupps: (term * thm) list, - IImsuppss: (term * thm) list list, - VVrs: (term * thm) list, - eta_defs: thm list, - isVVrs: thm list, - IImsupp_permute_commutes: thm option list, - IImsupp_Diffs: thm option 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_natural: 'a -}; - -type 'a tvsubst_model = { - binding: binding, - etas: (term * 'a eta_axioms) option list -}; - -type tvsubst_result = { - tvsubst: term, - SSupps: (term * thm) list, - IImsuppss: (term * thm) list list, - VVrs: (term * thm) list, - eta_defs: thm list, - isVVrs: thm list, - IImsupp_permute_commutes: thm option list, - IImsupp_Diffs: thm option 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 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_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 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 8} (fn tvsubst => fn defs => fn tvsubst_VVrs => fn tvsubst_not_isVVr => - fn VVrs' => fn tvsubst_permute => fn IImsupp_commutes => fn IImsupp_Diffs => { - tvsubst = fst tvsubst, - SSupps = map_filter (Option.map #SSupp) defs, - IImsuppss = map_filter (Option.map #IImsupps) defs, - VVrs = VVrs', - eta_defs = eta_defs, - isVVrs = map_filter (Option.map (snd o #isVVr)) defs, - IImsupp_permute_commutes = IImsupp_commutes, - IImsupp_Diffs = IImsupp_Diffs, - 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 IImsupp_imsupp_permute_commutess IImsupp_Diffss; - - (* 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_old", 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), - ("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 diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index f68b0c3b..0d412a6f 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -87,7 +87,9 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt (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 ((bmv, _, bmv_defs, _), lthy) = BMV_Monad_Def.seal_bmv_monad qualify bmv_unfolds name [] bmv (SOME info) lthy; + val ((bmv, _, bmv_defs, _), lthy) = BMV_Monad_Def.seal_bmv_monad qualify ( + bmv_unfolds @ #map_unfolds mrbnf_unfolds @ flat (#set_unfoldss mrbnf_unfolds) + ) name [] 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); @@ -559,7 +561,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_De ) 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:thm list), accum), lthy)) = + 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)); diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index c39f56f9..a2ac30cf 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -19,6 +19,8 @@ sig isInjs: (term * thm) list, tvsubst_Injs: thm list, tvsubst_not_isInj: thm, + IImsupp_Diffs: thm list, + IImsupp_permute_commutes: thm list, mrsbnf: MRSBNF_Def.mrsbnf }; @@ -54,6 +56,8 @@ type tvsubst_result = { isInjs: (term * thm) list, tvsubst_Injs: thm list, tvsubst_not_isInj: thm, + IImsupp_Diffs: thm list, + IImsupp_permute_commutes: thm list, mrsbnf: MRSBNF_Def.mrsbnf }; @@ -122,13 +126,13 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m 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.mk_implies ( + 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 [x] eta_compl_free_goal (#eta_compl_free tacs); + )); + 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) @@ -143,11 +147,11 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m val subst = MRBNF_Def.lives_of_mrbnf mrbnf ~~ MRBNF_Def.lives'_of_mrbnf mrbnf; - val eta_natural_goal = fold_rev (curry Logic.mk_implies) f_prems (mk_Trueprop_eq ( + 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 fs eta_natural_goal (#eta_natural tacs); + )))); + 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 @@ -156,7 +160,7 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m BMV_Monad_Def.leader BMV_Monad_Def.lives_of_bmv_monad bmv ); - val eta_Sb_goal = fold_rev (curry Logic.mk_implies) g_prems (Logic.mk_implies ( + val eta_Sb_goal = fold_rev Logic.all (gs @ rhos @ live_fs @ [a, x]) (fold_rev (curry Logic.mk_implies) 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)) $ the_default I (Option.map (fn Map => fn t => Term.list_comb (Map, live_fs) $ t) @@ -165,8 +169,8 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m 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 (gs @ rhos @ live_fs @ [x, a]) eta_Sb_goal (#eta_Sb tacs); + ))); + val eta_Sb = prove [] eta_Sb_goal (#eta_Sb tacs); in ({ eta = eta, Inj = Inj, @@ -282,7 +286,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs val quot = hd (#quotient_fps fp_res); val bmv = MRSBNF_Def.bmv_monad_of_mrsbnf mrsbnf; - val frees = MRBNF_Def.frees_of_mrbnf (hd (#pre_mrbnfs fp_res)); + val frees = map (HOLogic.dest_setT o body_type o fastype_of) (#FVarss (hd (#quotient_fps fp_res))); val defs = map (fn a => Option.map (fn (eta, def) => { aT = #aT def, eta = #eta eta, @@ -702,7 +706,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs )), [])) )], []) lthy; - val sugars = map_filter (fn mrbnf => MRBNF_Sugar.binder_sugar_of 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); @@ -785,9 +789,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs rtac ctxt @{thm trans[OF comp_apply]}, EqSubst.eqsubst_tac ctxt [0] (map #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)) + (*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}, @@ -1194,7 +1198,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs rtac ctxt @{thm UN_cong}, Goal.assume_rule_tac ctxt, REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs @ maps (the_default [] o #IImsupp_Diffs) sugars), + EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs (* @ maps (the_default [] o #IImsupp_Diffs) sugars *)), REPEAT_DETERM o (assume_tac ctxt ORELSE' EVERY' [ etac ctxt @{thm Int_subset_empty2}, rtac ctxt @{thm subsetI}, @@ -1719,6 +1723,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs 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, mrsbnf = rec_mrsbnf }: tvsubst_result; diff --git a/case_studies/Untyped_Lambda_Calculus/LC.thy b/case_studies/Untyped_Lambda_Calculus/LC.thy index 21793c70..9f088509 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 @@ -30,18 +30,14 @@ apply standard type_synonym trm = "var term" +(* Some lighter notations: *) +abbreviation "IImsupp' \ IImsupp" +abbreviation "SSupp' \ SSupp" hide_const IImsupp SSupp -(* 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 "SSupp \ SSupp' Var" +abbreviation "IImsupp f \ SSupp f \ IImsupp' Var FFVars f" +lemmas IImsupp_def = SSupp_def IImsupp_def abbreviation "rrename \ permute_term" (* *) diff --git a/thys/MRBNF_Recursor.thy b/thys/MRBNF_Recursor.thy index df47f997..8f743fa0 100644 --- a/thys/MRBNF_Recursor.thy +++ b/thys/MRBNF_Recursor.thy @@ -39,13 +39,14 @@ lemma notin_Un_forward: "x \ A \ B \ (x \ A 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 From 67f7c8d7d872da15d06eb303ec1b9dd9d1bd7eeb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 10 Aug 2025 18:46:26 +0100 Subject: [PATCH 72/90] Prove SSupp_natural, IImsupp_natural and tvsubst_permute again --- Tools/binder_induction.ML | 8 +- Tools/binder_sugar.ML | 7 +- Tools/mrbnf_sugar.ML | 11 +- Tools/mrsbnf_def.ML | 15 +- Tools/tvsubst.ML | 143 +++++++++++++++- case_studies/Untyped_Lambda_Calculus/LC.thy | 173 ++++---------------- 6 files changed, 201 insertions(+), 156 deletions(-) diff --git a/Tools/binder_induction.ML b/Tools/binder_induction.ML index f9ec380d..f275a456 100644 --- a/Tools/binder_induction.ML +++ b/Tools/binder_induction.ML @@ -455,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 @@ -463,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}, diff --git a/Tools/binder_sugar.ML b/Tools/binder_sugar.ML index 9fe84a19..81a9d4de 100644 --- a/Tools/binder_sugar.ML +++ b/Tools/binder_sugar.ML @@ -8,6 +8,7 @@ type binder_sugar = { 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, mrbnf: MRBNF_Def.mrbnf, @@ -35,6 +36,7 @@ type binder_sugar = { 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, mrbnf: MRBNF_Def.mrbnf, @@ -45,7 +47,9 @@ type binder_sugar = { }; 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 } = { + strong_induct, distinct, inject, ctors, bsetss, bset_bounds, IImsupp_permute_commutes, IImsupp_Diffs, + tvsubst_permute +} = { map_simps = map (Morphism.thm phi) map_simps, permute_simps = map (Morphism.thm phi) permute_simps, map_permute = Morphism.thm phi map_permute, @@ -53,6 +57,7 @@ fun morph_binder_sugar phi { map_simps, permute_simps, map_permute, 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, mrbnf = MRBNF_Def.morph_mrbnf phi mrbnf, diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index aa55e701..717ac467 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -1180,7 +1180,7 @@ fun create_binder_datatype co (spec : spec) lthy = val (lthy, tvsubst_opt) = if not (null (map_filter I (#etas tvsubst_model))) andalso not co then val recursor_result = #recursor_result (the vvsubst_res_opt); val (tvsubst_res, lthy) = TVSubst.create_tvsubst_of_mrsbnf (Binding.prefix_name "tv") res mrsbnf - rec_mrbnf (#vvsubst_ctor vvsubst_res) (#tvsubst_b spec) eta_models (#QREC_fixed recursor_result) lthy; + rec_mrbnf (#vvsubst_ctor vvsubst_res) (#vvsubst_permute vvsubst_res) (#tvsubst_b spec) eta_models (#QREC_fixed recursor_result) 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) @@ -1277,6 +1277,7 @@ fun create_binder_datatype co (spec : spec) lthy = by (auto simp: IImsupp_def)}] ) ));*) +<<<<<<< HEAD val IImsupp_permute_commutes = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_permute_commutes res)) tvsubst_opt; val IImsupp_Diffs = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_Diffs res)) tvsubst_opt; @@ -1293,6 +1294,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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 = [], mrbnf = mrbnf, @@ -1312,6 +1314,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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 = [], mrbnf = mrbnf, @@ -1335,8 +1338,10 @@ 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), + ("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/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index b5a8199f..d1f0eb49 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -12,6 +12,8 @@ signature MRSBNF_DEF = sig type mrsbnf_facts = { SSupp_map_subset: thm option list, SSupp_map_bound: thm option list, + SSupp_naturals: thm list, + IImsupp_naturals: thm list list, map_Inj: thm option list, map_Sb_strong: thm, Map_map: thm option, @@ -84,6 +86,8 @@ in { type mrsbnf_facts = { SSupp_map_subset: thm option list, SSupp_map_bound: thm option list, + SSupp_naturals: thm list, + IImsupp_naturals: thm list list, map_Inj: thm option list, map_Sb_strong: thm, Map_map: thm option, @@ -91,10 +95,13 @@ type mrsbnf_facts = { } fun morph_mrsbnf_facts phi ({ - SSupp_map_subset, SSupp_map_bound, map_Inj, map_Sb_strong, Map_map, set_Injs + SSupp_map_subset, SSupp_map_bound, map_Inj, map_Sb_strong, Map_map, set_Injs, SSupp_naturals, + IImsupp_naturals }: 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, 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, @@ -158,6 +165,8 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("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), []), ("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, []), @@ -540,6 +549,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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, @@ -823,6 +834,8 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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, map_Inj = #map_Inj facts, map_Sb_strong = map_Sb_strong, Map_map = #Map_map facts, diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index a2ac30cf..28bf72a2 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -21,11 +21,12 @@ sig 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 -> binding + -> MRSBNF_Def.mrsbnf -> MRBNF_Def.mrbnf -> thm -> thm -> binding -> (Proof.context -> tactic) eta_model option list -> string -> local_theory -> tvsubst_result * local_theory end @@ -58,6 +59,7 @@ type tvsubst_result = { tvsubst_not_isInj: thm, IImsupp_Diffs: thm list, IImsupp_permute_commutes: thm list, + tvsubst_permute: thm, mrsbnf: MRSBNF_Def.mrsbnf }; @@ -277,7 +279,7 @@ fun define_tvsubst_consts qualify (fp_res : MRBNF_FP_Def_Sugar.fp_result) (etas in (defs, lthy) end; -fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubst_b models QREC_fixed_name no_defs_lthy = +fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_permute 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; @@ -789,9 +791,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs rtac ctxt @{thm trans[OF comp_apply]}, EqSubst.eqsubst_tac ctxt [0] (map #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)) + 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}, @@ -1718,6 +1720,138 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs set_Vrs = replicate nvars (fn ctxt => rtac ctxt refl 1) }) (0 upto length ops - 1)) lthy; + 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 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, fs), Term.list_comb (fst tvsubst, map_filter I rhos)), + HOLogic.mk_comp ( + Term.list_comb (fst tvsubst, map_filter (Option.map (fn rho => + HOLogic.mk_comp (HOLogic.mk_comp ( + let val permute = the (List.find (fn perm => body_type (fastype_of perm) = body_type (fastype_of rho)) permutes); + in Term.list_comb (permute, map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of permute))))) end, + rho + ), mk_inv (the (List.find (fn f => domain_type (fastype_of rho) = domain_type (fastype_of f)) fs))) + )) rhos), + Term.list_comb (#permute quot, fs) + ) + ); + + (*val As = map2 (fn f => curry mk_Un (mk_imsupp f)) fs avoiding_sets;*) + in Goal.prove_sorry lthy (names (fs @ map_filter I rhos)) (f_prems @ rho_prems') goal (fn {context=ctxt, prems} => EVERY1 [ + rtac ctxt ext, + K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), + Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => + DETERM (rtac ctxt (infer_instantiate' ctxt ( + map (SOME o Thm.cterm_of ctxt) avoiding_sets @ replicate 1 NONE @ map (SOME o snd) params + ) fresh_induct) 1) + ) ctxt, + SELECT_GOALS (length avoiding_sets) (EVERY1 [ + K (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), + REPEAT_DETERM o resolve_tac ctxt ( + @{thms infinite_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] + infinite_UNIV + } @ prems @ maps #card_of_FVars_bound_UNIVs (#quotient_fps fp_res) + ) + ]), + 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 quot], + REPEAT_DETERM o resolve_tac ctxt prems, + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~1 - n) tvsubst_not_isInj], + resolve_tac ctxt IHs, + REPEAT_DETERM o assume_tac ctxt, + REPEAT_DETERM o resolve_tac ctxt prems, + REPEAT_DETERM o resolve_tac ctxt IHs, + EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~1 - n) tvsubst_not_isInj], + rtac ctxt (iffD2 OF [#noclash_permute (#inner quot)]), + REPEAT_DETERM o resolve_tac ctxt prems, + resolve_tac ctxt IHs, + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] [#permute_ctor quot RS sym], + REPEAT_DETERM o resolve_tac ctxt prems, + EqSubst.eqsubst_tac ctxt [0] (map_filter I isInj_permutes), + REPEAT_DETERM o resolve_tac ctxt prems, + assume_tac ctxt + ], + REPEAT_DETERM o FIRST' [ + resolve_tac ctxt (prems @ @{thms ordLeq_ordLess_trans[OF card_of_image]}), + EqSubst.eqsubst_tac ctxt [0] ( + map (fn thm => thm RS sym) (map_permute :: map #map_permute sugars) + @ maps #SSupp_naturals (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf) + ) + ], + REPEAT_DETERM o EVERY' [ + REPEAT_DETERM1 o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf + @ maps #SSupp_naturals (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf) + @ flat (maps #IImsupp_naturals (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 image_Un[symmetric]}), + rtac ctxt @{thm trans[OF image_Int[OF bij_is_inj, symmetric]]}, + resolve_tac ctxt prems, + rtac ctxt @{thm iffD2[OF image_is_empty]}, + resolve_tac ctxt IHs + ], + K (Local_Defs.unfold0_tac ctxt (@{thms id_apply} @ map #Sb_Inj (BMV_Monad_Def.axioms_of_bmv_monad bmv))), + rtac ctxt (trans OF [#permute_ctor quot]), + REPEAT_DETERM o resolve_tac ctxt prems, + rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), + rtac ctxt (trans OF [MRBNF_Def.map_comp_of_mrbnf mrbnf]), + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ 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} @ 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} @ 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 (#isInj def)]), + etac ctxt exE, + etac ctxt @{thm subst[OF sym]}, + EqSubst.eqsubst_tac ctxt [0] (map_filter I permute_Injs), + REPEAT_DETERM o resolve_tac ctxt prems, + EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), + REPEAT_DETERM o resolve_tac ctxt prems, + EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), + REPEAT_DETERM o FIRST' [ + resolve_tac ctxt (prems @ @{thms ordLeq_ordLess_trans[OF card_of_image]}), + EqSubst.eqsubst_tac ctxt [0] ( + map (fn thm => thm RS sym) (map_permute :: map #map_permute sugars) + @ maps #SSupp_naturals (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf) + ) + ], + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + EqSubst.eqsubst_tac ctxt [0] @{thms inv_simp1}, + resolve_tac ctxt prems, + rtac ctxt refl + ])) (rev defs)) + ]) ctxt end + ]) end + val result = { tvsubst = fst tvsubst, isInjs = map_filter (Option.map #isInj) defs, @@ -1725,6 +1859,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor tvsubs 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; diff --git a/case_studies/Untyped_Lambda_Calculus/LC.thy b/case_studies/Untyped_Lambda_Calculus/LC.thy index 9f088509..42640be2 100644 --- a/case_studies/Untyped_Lambda_Calculus/LC.thy +++ b/case_studies/Untyped_Lambda_Calculus/LC.thy @@ -46,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]) @@ -222,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)) @@ -236,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))" using IImsupp_Var by auto @@ -308,8 +242,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: @@ -337,7 +270,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" @@ -417,7 +340,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 @@ -432,10 +355,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 @@ -443,12 +366,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] @@ -460,11 +383,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 @@ -609,46 +532,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) *) @@ -1175,7 +1058,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 From 954de77cc91563ced7f62a3c52df4c3878d92487 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 10 Aug 2025 18:50:07 +0100 Subject: [PATCH 73/90] Remove tvsubst simps from sugar operations --- operations/Sugar.thy | 350 +------------------------------------------ 1 file changed, 1 insertion(+), 349 deletions(-) diff --git a/operations/Sugar.thy b/operations/Sugar.thy index e382ca0e..3b3708cf 100644 --- a/operations/Sugar.thy +++ b/operations/Sugar.thy @@ -834,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 @@ -1111,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 From 7018929af6ec00d2646970ed3529bae0ef66c6e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 10 Aug 2025 19:41:09 +0100 Subject: [PATCH 74/90] Fix errors in Mazza case study --- Tools/bmv_monad_def.ML | 2 +- Tools/bmv_monad_tacs.ML | 7 +- Tools/mrbnf_sugar.ML | 1 + Tools/tvsubst.ML | 2 +- .../Infinitary_Lambda_Calculus/ILC.thy | 116 ++++-------------- .../Infinitary_Lambda_Calculus/ILC_Beta.thy | 6 +- .../ILC_Head_Reduction.thy | 2 +- .../Infinitary_Lambda_Calculus/ILC_affine.thy | 1 + .../Infinitary_Lambda_Calculus/ILC_good.thy | 1 + .../ILC_uniform.thy | 2 + .../Infinitary_Lambda_Calculus/Iso_LC_ILC.thy | 24 +++- case_studies/Untyped_Lambda_Calculus/LC.thy | 3 +- 12 files changed, 64 insertions(+), 103 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 435f94ef..df16828a 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -964,7 +964,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 T Sb Injs (RVrs @ Vrs) + 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, diff --git a/Tools/bmv_monad_tacs.ML b/Tools/bmv_monad_tacs.ML index dd000658..392f2ade 100644 --- a/Tools/bmv_monad_tacs.ML +++ b/Tools/bmv_monad_tacs.ML @@ -131,7 +131,7 @@ fun mk_IImsupp_Sb_subsetss T ops Sb SSupp_prems RVrss Vrss Vrs Injs hs rhos SSup ]) end ) Vrs)) Injs; -fun mk_IImsupp_Sb_boundss T Sb Injs Vrs hs rhos SSupp_prems IImsupp_Sb_subsetss Vrs_bds lthy = +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 @@ -156,8 +156,9 @@ fun mk_IImsupp_Sb_boundss T Sb Injs Vrs hs rhos SSupp_prems IImsupp_Sb_subsetss 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 @ - @{thms infinite_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] infinite_class.infinite_UNIV var_class.large'} + 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}) ] diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 717ac467..f920e564 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -1254,6 +1254,7 @@ fun create_binder_datatype co (spec : spec) lthy = @ 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 @ [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} ])), diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 28bf72a2..51f9402c 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -1260,7 +1260,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe (#FVarss quot) Injs [] some_rhos SSupp_tvsubst_subsets FVars_tvsubsts Vrs_Injs' lthy; - val IImsupp_Sb_boundss = BMV_Monad_Tactics.mk_IImsupp_Sb_boundss (#T quot) + val IImsupp_Sb_boundss = BMV_Monad_Tactics.mk_IImsupp_Sb_boundss (hd (MRBNF_Def.class_of_mrbnf mrbnf)) (#T quot) (fst tvsubst) Injs (#FVarss quot) [] some_rhos rho_prems' IImsupp_Sb_subsetss (#card_of_FVars_bounds quot @ maps #Vrs_bds (BMV_Monad_Def.axioms_of_bmv_monad bmv)) lthy; diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC.thy b/case_studies/Infinitary_Lambda_Calculus/ILC.thy index e00e899b..b52ac28a 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 @@ -139,37 +139,21 @@ by (meson injD iVariable_inj) type_synonym itrm = "ivar iterm" -hide_const IImsupp SSupp - (* 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] @@ -183,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'" @@ -350,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: @@ -472,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 @@ -487,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 @@ -533,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 @@ -550,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 diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_Beta.thy index b6ad63f3..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 @@ -98,9 +98,9 @@ thm istep.equiv lemma SSupp_If_small[simp]: "|A :: ivar set| |ILC.SSupp (\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 6243dcdd..d972eccb 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_affine.thy @@ -76,6 +76,7 @@ using r proof (binder_induction e avoiding: "ILC.IImsupp f" rule: affine.strong_ 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) diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy index ce244ed8..1567c101 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_good.thy @@ -304,6 +304,7 @@ using r proof (binder_induction e avoiding: "ILC.IImsupp f" rule: strong_induct_ show ?case using iLam apply(subst iterm.subst) subgoal using s by blast subgoal using s by auto + subgoal using s by auto subgoal apply(rule good.iLam) by auto . next case (iApp e1 es2) diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy b/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy index af3a3df2..924146b1 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC_uniform.thy @@ -161,11 +161,13 @@ next next case (iLam ea e'a xs) then show ?case using iLam apply(subst iterm.subst) + subgoal using s by auto subgoal using s by auto subgoal using s by auto apply(subst iterm.subst) subgoal using s by auto subgoal using s by auto + subgoal using s by auto subgoal apply(rule reneqv.iLam) by auto . next case (iApp e1 e1' es2 es2') 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/Untyped_Lambda_Calculus/LC.thy b/case_studies/Untyped_Lambda_Calculus/LC.thy index 42640be2..b44915ae 100644 --- a/case_studies/Untyped_Lambda_Calculus/LC.thy +++ b/case_studies/Untyped_Lambda_Calculus/LC.thy @@ -220,7 +220,8 @@ using SSupp_tvsubst_bound[OF assms] unfolding o_def . lemma IImsupp_Var: "IImsupp (Var(x := e)) \ FFVars e \ {x}" 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: From b16a0f93ea8b06b3573540a1340d036e4ccacfd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sun, 10 Aug 2025 22:11:15 +0100 Subject: [PATCH 75/90] Fix Pi calculus and POPLmark 1B --- Tools/binder_induction.ML | 4 +- Tools/bmv_monad_def.ML | 2 +- case_studies/POPLmark/SystemFSub.thy | 132 ++---------------------- case_studies/Pi_Calculus/Commitment.thy | 5 +- thys/Classes.thy | 3 + thys/Support.thy | 8 ++ 6 files changed, 23 insertions(+), 131 deletions(-) diff --git a/Tools/binder_induction.ML b/Tools/binder_induction.ML index f275a456..e59827b8 100644 --- a/Tools/binder_induction.ML +++ b/Tools/binder_induction.ML @@ -475,12 +475,12 @@ fun gen_binder_context_tactic mod_cases simp def_insts arbitrary avoiding taking REPEAT_DETERM o rtac ctxt @{thm induct_forallI}, rtac ctxt inner_prem ORELSE' EVERY' [ - Method.insert_tac ctxt inner_prems, + Method.insert_tac ctxt [inner_prem], let 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/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index df16828a..7ca13c37 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -2178,7 +2178,7 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = frees = [leader frees_of_bmv_monad bmv], lives = [leader lives_of_bmv_monad bmv], lives' = [leader lives'_of_bmv_monad bmv], - deads = [leader deads_of_bmv_monad bmv], + deads = [map TFree (rev (fold Term.add_tfreesT (leader deads_of_bmv_monad bmv) []))], consts = consts, leader = 0, params = [Option.map (fn Supps => { diff --git a/case_studies/POPLmark/SystemFSub.thy b/case_studies/POPLmark/SystemFSub.thy index 120b6c54..69b44100 100644 --- a/case_studies/POPLmark/SystemFSub.thy +++ b/case_studies/POPLmark/SystemFSub.thy @@ -266,136 +266,16 @@ binder_inductive ty @{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 - -lemma SSupp_typ_TyVar[simp]: "SSupp_typ TyVar = {}" - unfolding SSupp_typ_def by simp +lemmas FVars_tvsubst_typ = typ.Vrs_Sb -lemma IImsupp_typ_TyVar[simp]: "IImsupp_typ TyVar = {}" - unfolding IImsupp_typ_def by simp +lemmas [simp] = typ.Vrs_Inj -lemma SSupp_typ_fun_upd_le: "SSupp_typ (f(X := T)) \ insert X (SSupp_typ f)" - unfolding SSupp_typ_def by auto +lemma inj_TyVar[simp, intro!]: "inj TyVar" + by (meson injI typ.inject(1)) -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_old) - 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 d4720cc7..207e2171 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}), @@ -114,7 +114,8 @@ local_setup \MRBNF_Sugar.register_binder_sugar "Commitment.commit" { set_simpss = [], subst_simps = NONE, IImsupp_Diffs = NONE, - IImsupp_permute_commutes = NONE + IImsupp_permute_commutes = NONE, + tvsubst_permute = NONE }\ abbreviation "swapa act x y \ map_action (id(x:=y,y:=x)) act" diff --git a/thys/Classes.thy b/thys/Classes.thy index 0235e49d..b3e2a33f 100644 --- a/thys/Classes.thy +++ b/thys/Classes.thy @@ -113,4 +113,7 @@ lemma IImsupp_Inj_comp_bound2: "(\a. Vrs (Inj a) = {}) \ |I by (auto simp: IImsupp_def) lemmas IImsupp_Inj_comp_bound = IImsupp_Inj_comp_bound1 IImsupp_Inj_comp_bound2 +lemma SSupp_fun_upd_bound_UNIV[simp]: "|SSupp Inj (f(x := t))| |SSupp Inj f| |SSupp Inj Inj| insert x (SSupp Inj f)" + by (simp add: SSupp_def subset_eq) + +lemma SSupp_fun_upd_bound[simp]: "Cinfinite r \ |SSupp Inj (f(x := t))| |SSupp Inj f| Date: Wed, 13 Aug 2025 21:42:11 +0100 Subject: [PATCH 76/90] Fix POPLmark 2B --- Tools/bmv_monad_def.ML | 17 +- Tools/mrbnf_comp.ML | 21 +- Tools/mrbnf_def.ML | 10 +- Tools/mrbnf_sugar.ML | 91 +- Tools/mrsbnf_comp.ML | 17 +- Tools/mrsbnf_def.ML | 8 +- Tools/tvsubst.ML | 123 +-- case_studies/POPLmark/POPLmark_2B.thy | 1463 ++++--------------------- case_studies/POPLmark/Pattern.thy | 51 +- thys/Classes.thy | 7 + thys/Support.thy | 7 + 11 files changed, 370 insertions(+), 1445 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 7ca13c37..d13d8d61 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -97,7 +97,7 @@ signature BMV_MONAD_DEF = sig 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: MRBNF_Def.mrbnf -> local_theory -> bmv_monad * local_theory + 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 @@ -699,7 +699,7 @@ fun define_bmv_monad_consts bmv_b_opt const_policy fact_policy qualify leader op 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 ^ "_") (the bmv_b_opt) + 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 @@ -1089,7 +1089,7 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont 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 lthy) end -fun pbmv_monad_of_mrbnf mrbnf lthy = +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) @@ -1122,7 +1122,7 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = )) ); val name = MRBNF_Def.name_of_mrbnf mrbnf; - in apfst fst (bmv_monad_def BNF_Def.Smart_Inline (K BNF_Def.Dont_Note) I (SOME name) { + 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, @@ -1221,7 +1221,7 @@ fun pbmv_monad_of_mrbnf mrbnf lthy = 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 mrbnf lthy; + val (bmv, lthy) = pbmv_monad_of_mrbnf I mrbnf lthy; val lthy = register_pbmv_monad name bmv lthy; in lthy end @@ -1529,7 +1529,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit fun leader f bmv = nth (f bmv) (leader_of_bmv_monad bmv) - val eq_name = (op=) o apply2 (fst o dest_TFree) + 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 [])) @@ -2027,6 +2029,9 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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}), diff --git a/Tools/mrbnf_comp.ML b/Tools/mrbnf_comp.ML index 44d77193..95513bb8 100644 --- a/Tools/mrbnf_comp.ML +++ b/Tools/mrbnf_comp.ML @@ -215,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; @@ -508,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; @@ -910,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 diff --git a/Tools/mrbnf_def.ML b/Tools/mrbnf_def.ML index 450fc026..d7a6ae4b 100644 --- a/Tools/mrbnf_def.ML +++ b/Tools/mrbnf_def.ML @@ -1709,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; @@ -1889,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_sugar.ML b/Tools/mrbnf_sugar.ML index f920e564..b7e385b7 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -142,7 +142,7 @@ fun create_binder_type (fp : MRBNF_Util.fp_kind) (spec : spec) lthy = (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 mrbnf lthy + 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) @@ -893,8 +893,9 @@ fun create_binder_datatype co (spec : spec) lthy = 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 @ [#Abs_inverse (snd info) OF @{thms UNIV_I}] )), @@ -906,8 +907,9 @@ 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 )), Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => @@ -967,14 +969,14 @@ fun create_binder_datatype co (spec : spec) lthy = 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); @@ -990,6 +992,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) @@ -1062,16 +1076,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 ts => HOLogic.dest_setT (fastype_of (hd ts)) = 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)) $ _) => - maps (fn f => map (HOLogic.mk_Trueprop o HOLogic.mk_not o HOLogic.mk_mem o pair t) (the (mk_imsupp_opt f T))) (get_fs T) - | t => - let val T = HOLogic.dest_setT (fastype_of t); - in maps (fn f => map (HOLogic.mk_Trueprop o mk_int_empty o pair 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; @@ -1138,7 +1152,7 @@ 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_Util.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.binder_sugar_of lthy (fst (dest_Type (MRBNF_Def.T_of_mrbnf mrbnf))) @@ -1165,7 +1179,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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; @@ -1182,6 +1196,8 @@ fun create_binder_datatype co (spec : spec) lthy = 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) (#tvsubst_b spec) eta_models (#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; @@ -1192,10 +1208,6 @@ fun create_binder_datatype co (spec : spec) 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 (map (Option.map #eta) eta_models)); - val T = range_type (fastype_of quotient_ctor); val bmv = let @@ -1206,17 +1218,31 @@ fun create_binder_datatype co (spec : spec) lthy = in BMV_Monad_Def.morph_bmv_monad phi bmv end val Injs = hd (BMV_Monad_Def.Injs_of_bmv_monad bmv); - fun mk_supp_bound f = if Term.is_TFree (body_type (fastype_of f)) then SOME (MRBNF_Util.mk_supp_bound f) else - Option.map (fn Inj => mk_ordLess - (mk_card_of (mk_SSupp Inj $ f)) (mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of f)))) - ) (List.find (fn Inj => fastype_of Inj = fastype_of f) Injs); + val (fs, _) = lthy + |> mk_Frees "f" (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 + ); + + 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 _ = let val Inj = the (List.find (fn Inj => fastype_of Inj = fastype_of h) Injs); val Vrs = nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) ( find_index (curry (op=) (body_type (fastype_of Inj))) (BMV_Monad_Def.ops_of_bmv_monad bmv) ); - in SOME ((mk_SSupp Inj $ h) :: map (fn Vrs => mk_IImsupp Inj Vrs $ h) Vrs) end + 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) (map_filter (Option.map #Inj) eta_models))), @@ -1255,14 +1281,19 @@ fun create_binder_datatype co (spec : spec) lthy = )), 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 + @ BMV_Monad_Def.unfolds_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 @{thms id_def}), + 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 mk_supp_bound mk_imsupp (K []) [] (#tvsubst tvsubst_res) tac + ) end; in (lthy, SOME (tvsubst_res, tvsubst_simps)) end else (lthy, NONE); diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 0d412a6f..b60a2122 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -223,10 +223,8 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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 _ = @{print} "wat" 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 _ = @{print} (tys, MRBNF_Def.T_of_mrbnf mrbnf) val mrbnf = let @@ -484,6 +482,17 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A 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; @@ -580,7 +589,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_De 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 mrbnf lthy; + 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 @@ -589,7 +598,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_De SOME mrsbnf => (mrsbnf, (mrsbnf_cache, lthy)) | NONE => let - val (mrsbnf, lthy) = MRSBNF_Def.mrsbnf_of_mrbnf mrbnf lthy; + 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 ) diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index d1f0eb49..b86d9e76 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -31,7 +31,7 @@ signature MRSBNF_DEF = sig -> MRBNF_Def.mrbnf list -> BMV_Monad_Def.bmv_monad -> (Proof.context -> tactic) mrsbnf_axioms list -> local_theory -> mrsbnf * local_theory; - val mrsbnf_of_mrbnf: MRBNF_Def.mrbnf -> 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 @@ -1049,9 +1049,9 @@ fun mrsbnf_def fact_policy qualify name_opt mrbnfs bmv tacs lthy = 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 mrbnf lthy = +fun mrsbnf_of_mrbnf qualify mrbnf lthy = let - val (bmv, lthy) = BMV_Monad_Def.pbmv_monad_of_mrbnf mrbnf lthy; + 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; @@ -1067,7 +1067,7 @@ fun mrsbnf_of_mrbnf mrbnf lthy = )) 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) I NONE [mrbnf] bmv [{ + 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' [ diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 51f9402c..864e3b06 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -85,6 +85,7 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m 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; @@ -105,7 +106,7 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m val mrbnfs = #pre_mrbnfs fp_res; val mrbnf = hd mrbnfs; - val (etas, lthy) = @{fold_map 2} (fn Vrs => fold_map_option (fn { eta, Inj, tacs } => fn lthy => + val (etas, lthy) = fold_map (fold_map_option (fn { eta, Inj, tacs } => fn lthy => let fun mk_endo a = a --> a @@ -123,6 +124,9 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m ||>> 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); @@ -184,7 +188,7 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m eta_Sb = eta_Sb } }: thm eta_model, lthy) end - )) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_of_bmv_monad bmv) models lthy; + )) models lthy; val (fp_res, mrsbnf) = let @@ -546,7 +550,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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]}), + 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), @@ -1156,7 +1160,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe foldl1 mk_Un rhss ); in Goal.prove_sorry lthy (names (map_filter I rhos @ [t])) rho_prems' goal (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) avoiding_sets) fresh_induct), + DETERM o rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) 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} @ prems @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) @@ -1200,7 +1204,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt @{thm UN_cong}, Goal.assume_rule_tac ctxt, REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs (* @ maps (the_default [] o #IImsupp_Diffs) sugars *)), + EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs @ maps (the_default [] o #IImsupp_Diffs) sugars), REPEAT_DETERM o (assume_tac ctxt ORELSE' EVERY' [ etac ctxt @{thm Int_subset_empty2}, rtac ctxt @{thm subsetI}, @@ -1720,10 +1724,6 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe set_Vrs = replicate nvars (fn ctxt => rtac ctxt refl 1) }) (0 upto length ops - 1)) lthy; - 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 quot = hd (#quotient_fps fp_res); @@ -1750,106 +1750,13 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe Term.list_comb (#permute quot, fs) ) ); - - (*val As = map2 (fn f => curry mk_Un (mk_imsupp f)) fs avoiding_sets;*) in Goal.prove_sorry lthy (names (fs @ map_filter I rhos)) (f_prems @ rho_prems') goal (fn {context=ctxt, prems} => EVERY1 [ - rtac ctxt ext, - K (Local_Defs.unfold0_tac ctxt @{thms comp_apply}), - Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => - DETERM (rtac ctxt (infer_instantiate' ctxt ( - map (SOME o Thm.cterm_of ctxt) avoiding_sets @ replicate 1 NONE @ map (SOME o snd) params - ) fresh_induct) 1) - ) ctxt, - SELECT_GOALS (length avoiding_sets) (EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}), - REPEAT_DETERM o resolve_tac ctxt ( - @{thms infinite_class.Un_bound var_class.UN_bound imsupp_supp_bound[THEN iffD2] - infinite_UNIV - } @ prems @ maps #card_of_FVars_bound_UNIVs (#quotient_fps fp_res) - ) - ]), - 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 quot], - REPEAT_DETERM o resolve_tac ctxt prems, - EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~1 - n) tvsubst_not_isInj], - resolve_tac ctxt IHs, - REPEAT_DETERM o assume_tac ctxt, - REPEAT_DETERM o resolve_tac ctxt prems, - REPEAT_DETERM o resolve_tac ctxt IHs, - EqSubst.eqsubst_tac ctxt [0] [Drule.rotate_prems (~1 - n) tvsubst_not_isInj], - rtac ctxt (iffD2 OF [#noclash_permute (#inner quot)]), - REPEAT_DETERM o resolve_tac ctxt prems, - resolve_tac ctxt IHs, - REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] [#permute_ctor quot RS sym], - REPEAT_DETERM o resolve_tac ctxt prems, - EqSubst.eqsubst_tac ctxt [0] (map_filter I isInj_permutes), - REPEAT_DETERM o resolve_tac ctxt prems, - assume_tac ctxt - ], - REPEAT_DETERM o FIRST' [ - resolve_tac ctxt (prems @ @{thms ordLeq_ordLess_trans[OF card_of_image]}), - EqSubst.eqsubst_tac ctxt [0] ( - map (fn thm => thm RS sym) (map_permute :: map #map_permute sugars) - @ maps #SSupp_naturals (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf) - ) - ], - REPEAT_DETERM o EVERY' [ - REPEAT_DETERM1 o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (MRBNF_Def.set_map_of_mrbnf mrbnf - @ maps #SSupp_naturals (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf) - @ flat (maps #IImsupp_naturals (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 image_Un[symmetric]}), - rtac ctxt @{thm trans[OF image_Int[OF bij_is_inj, symmetric]]}, - resolve_tac ctxt prems, - rtac ctxt @{thm iffD2[OF image_is_empty]}, - resolve_tac ctxt IHs - ], - K (Local_Defs.unfold0_tac ctxt (@{thms id_apply} @ map #Sb_Inj (BMV_Monad_Def.axioms_of_bmv_monad bmv))), - rtac ctxt (trans OF [#permute_ctor quot]), - REPEAT_DETERM o resolve_tac ctxt prems, - rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), - rtac ctxt (trans OF [MRBNF_Def.map_comp_of_mrbnf mrbnf]), - REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ 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} @ 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} @ 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 (#isInj def)]), - etac ctxt exE, - etac ctxt @{thm subst[OF sym]}, - EqSubst.eqsubst_tac ctxt [0] (map_filter I permute_Injs), - REPEAT_DETERM o resolve_tac ctxt prems, - EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), - REPEAT_DETERM o resolve_tac ctxt prems, - EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), - REPEAT_DETERM o FIRST' [ - resolve_tac ctxt (prems @ @{thms ordLeq_ordLess_trans[OF card_of_image]}), - EqSubst.eqsubst_tac ctxt [0] ( - map (fn thm => thm RS sym) (map_permute :: map #map_permute sugars) - @ maps #SSupp_naturals (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf) - ) - ], - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), - EqSubst.eqsubst_tac ctxt [0] @{thms inv_simp1}, - resolve_tac ctxt prems, - rtac ctxt refl - ])) (rev defs)) - ]) ctxt end + REPEAT_DETERM o EVERY' [ + EqSubst.eqsubst_tac ctxt [0] (map (fn thm => thm RS sym) (map_permute :: map #map_permute sugars)), + REPEAT_DETERM o resolve_tac ctxt prems + ], + rtac ctxt (#map_Sb_strong (hd (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf))), + REPEAT_DETERM o resolve_tac ctxt prems ]) end val result = { diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index bea4ef4a..6e6e5452 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -1,8 +1,7 @@ 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 -declare [[ML_print_depth=1000]] binder_datatype (FTVars: 'tv, FVars: 'v) trm = Var 'v | Abs x::'v "'tv typ" t::"('tv, 'v) trm" binds x in t @@ -14,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 - -(* 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 +thm trm.subst -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_old[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)" @@ -793,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)" @@ -875,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_UNIV apply fastforce - using infinite_UNIV insert_bound_UNIV 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_UNIV apply fastforce - using infinite_UNIV insert_bound_UNIV 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" @@ -1155,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_old) - 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]: @@ -1306,7 +378,7 @@ binder_inductive typing 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_UNIV sup.orderE) + apply simp apply auto [] apply (rule exI[of _ "T11"]) apply (rule exI[of _ "permute_typ (X \ Y) T12"]) @@ -1635,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) @@ -1647,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 @@ -1660,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 @@ -1680,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)" @@ -1829,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 +lemmas tvsubst_pat_id[simp] = pat.Sb_Inj -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 - -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': @@ -2076,37 +923,63 @@ 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 infinite_UNIV 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 infinite_UNIV 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 infinite_UNIV 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)| FTVars x2 \ FTVars x3"]) + apply blast + using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson + subgoal for x1 x2 x3 + apply (rule card_of_subset_bound[of _ "FVars x2 \ FVars x3"]) + apply blast + using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson + apply (rule trm.Sb_cong) + apply (auto simp: IImsupp_def SSupp_def restrict_def pat.set_bd_UNIV) + apply (metis (no_types, lifting) card_of_subset_bound mem_Collect_eq subsetI trm.set_bd_UNIV(1)) + apply (metis (no_types, lifting) card_of_subset_bound mem_Collect_eq subsetI trm.set_bd_UNIV(2)) + subgoal for x1 x2 x3 + apply (rule card_of_subset_bound[of _ "PTVars x1 \ FTVars x2 \ FTVars x3"]) + apply blast + using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson + subgoal for x1 x2 x3 + apply (rule card_of_subset_bound[of _ "FVars x2 \ FVars x3"]) + apply blast + using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson + by (meson disjoint_iff_not_equal not_in_supp_alt) +qed -lemma SSupp_trm_restrict: "SSupp_trm (restrict \ 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})" @@ -2229,6 +1100,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 @@ -2238,40 +1137,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 @@ -2284,8 +1188,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"]) @@ -2299,13 +1204,14 @@ 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 (auto simp: ordLeq_ordLess_trans[OF card_of_image] pat.set_bd_UNIV) + apply (rule trm.Sb_cong) + apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def intro!: trm.SSupp_Sb_bound trm.IImsupp_Sb_bound) + apply (subst trm.subst) + apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def) + apply (subst trm.subst) + apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def) done apply (auto simp: infinite_UNIV intro!: trm.Un_bound trm.set_bd_UNIV) done @@ -2393,7 +1299,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) @@ -2402,7 +1308,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 @@ -2413,7 +1319,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 @@ -2447,13 +1353,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 \ @@ -2469,12 +1377,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>, \)" @@ -2486,11 +1400,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 @@ -2511,7 +1425,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) @@ -2529,7 +1443,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 @@ -2626,19 +1540,18 @@ 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 (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2)) + apply auto + apply (metis PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2)) 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 PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2))+ + 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)) @@ -2649,20 +1562,22 @@ 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) [2] + apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) + apply (metis IImsupp_restrict_bound PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6) + trm.set_bd_UNIV(1)) 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) [2] + apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) + apply (metis IImsupp_restrict_bound PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6) + trm.set_bd_UNIV(1)) 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/thys/Classes.thy b/thys/Classes.thy index b3e2a33f..df4e0cc2 100644 --- a/thys/Classes.thy +++ b/thys/Classes.thy @@ -102,6 +102,8 @@ lemma supp_comp_bound_var: shows "|supp (g \ f)| |supp (f::'a::var \ 'a)| (\a. Vrs (Inj a) = {a}) \ |IImsupp Inj Vrs (Inj \ f)| |SSupp Inj f| x. |Vrs x| |IImsupp Inj Vrs (Inj(x := t))| 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| Date: Wed, 13 Aug 2025 21:57:10 +0100 Subject: [PATCH 77/90] Fix STLC and add it to ROOT --- ROOT | 4 ++ case_studies/STLC/STLC.thy | 89 ++++++++------------------------------ thys/Classes.thy | 4 ++ 3 files changed, 26 insertions(+), 71 deletions(-) diff --git a/ROOT b/ROOT index 4cfa560c..3ef9ecfe 100644 --- a/ROOT +++ b/ROOT @@ -120,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/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/thys/Classes.thy b/thys/Classes.thy index df4e0cc2..a6efc810 100644 --- a/thys/Classes.thy +++ b/thys/Classes.thy @@ -96,12 +96,16 @@ local_setup \ #> Var_Classes.register_class_for_bound @{class covar} @{term "card_suc natLeq"} \ + (* Theorems *) lemma supp_comp_bound_var: assumes bound: "|supp f| f)| |A| |supp (f::'a::var \ 'a)| From ba8c5804fb5c37eea12572b60b5512aa1acfbdec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 2 Oct 2025 20:56:47 +0100 Subject: [PATCH 78/90] Fix classes proofs --- thys/Classes.thy | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/thys/Classes.thy b/thys/Classes.thy index a6efc810..3b253f13 100644 --- a/thys/Classes.thy +++ b/thys/Classes.thy @@ -104,16 +104,13 @@ lemma supp_comp_bound_var: using supp_comp_bound[OF assms] infinite_UNIV by blast lemma insert_bound[simp]: "|insert x A| |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)| Date: Thu, 2 Oct 2025 21:22:34 +0100 Subject: [PATCH 79/90] Simplify POPLmark proofs --- case_studies/POPLmark/POPLmark_2B.thy | 46 ++++----------------------- 1 file changed, 7 insertions(+), 39 deletions(-) diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index 6e6e5452..fce1b86e 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -953,28 +953,8 @@ proof - apply (auto simp: pat.Sb_cong restrict_def) apply (rule trm.Sb_cong) apply (auto simp: IImsupp_def SSupp_def restrict_def pat.set_bd_UNIV) - apply (metis (no_types, lifting) card_of_subset_bound mem_Collect_eq subsetI trm.set_bd_UNIV(1)) - apply (metis (no_types, lifting) card_of_subset_bound mem_Collect_eq subsetI trm.set_bd_UNIV(2)) - subgoal for x1 x2 x3 - apply (rule card_of_subset_bound[of _ "PTVars x1 \ FTVars x2 \ FTVars x3"]) - apply blast - using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson - subgoal for x1 x2 x3 - apply (rule card_of_subset_bound[of _ "FVars x2 \ FVars x3"]) - apply blast - using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson apply (rule trm.Sb_cong) apply (auto simp: IImsupp_def SSupp_def restrict_def pat.set_bd_UNIV) - apply (metis (no_types, lifting) card_of_subset_bound mem_Collect_eq subsetI trm.set_bd_UNIV(1)) - apply (metis (no_types, lifting) card_of_subset_bound mem_Collect_eq subsetI trm.set_bd_UNIV(2)) - subgoal for x1 x2 x3 - apply (rule card_of_subset_bound[of _ "PTVars x1 \ FTVars x2 \ FTVars x3"]) - apply blast - using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson - subgoal for x1 x2 x3 - apply (rule card_of_subset_bound[of _ "FVars x2 \ FVars x3"]) - apply blast - using pat.set_bd_UNIV trm.set_bd_UNIV infinite_class.Un_bound by meson by (meson disjoint_iff_not_equal not_in_supp_alt) qed @@ -1205,15 +1185,14 @@ binder_inductive step apply (auto) apply (subst tvsubst_comp) apply (auto simp: supp_def[symmetric] intro!: var_class.UN_bound) - apply (auto simp: ordLeq_ordLess_trans[OF card_of_image] pat.set_bd_UNIV) apply (rule trm.Sb_cong) - apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def intro!: trm.SSupp_Sb_bound trm.IImsupp_Sb_bound) + apply (auto simp: SSupp_trm_restrict restrict_def intro!: trm.SSupp_Sb_bound trm.IImsupp_Sb_bound) apply (subst trm.subst) - apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def) + apply (auto simp: SSupp_trm_restrict restrict_def) apply (subst trm.subst) - apply (auto simp: infinite_UNIV SSupp_trm_restrict restrict_def) + 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 @@ -1540,21 +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 - apply (metis PVars_PRec 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 trm.Sb_cong) apply (auto 0 0 intro!: trm.SSupp_Sb_bound trm.IImsupp_Sb_bound pat.set_bd_UNIV) [5] - apply (metis PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2))+ 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 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] @@ -1563,10 +1537,7 @@ next done subgoal for x P' l' apply (subst trm.subst) - apply (auto 0 0) [2] - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) - apply (metis IImsupp_restrict_bound PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6) - trm.set_bd_UNIV(1)) + apply (auto 0 0) [3] apply (auto simp: restrict_def) apply (cases "l = l'") apply (metis lfin_label_inject) @@ -1574,10 +1545,7 @@ next done subgoal for x apply (subst trm.subst) - apply (auto 0 0) [2] - apply (metis Int_bound2 PVars_PRec SSupp_trm_restrict nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6)) - apply (metis IImsupp_restrict_bound PVars_PRec nonrep_PRec_lfdelete pat.set_bd_UNIV(2) prems(6) - trm.set_bd_UNIV(1)) + apply (auto 0 0) [3] apply (auto simp: restrict_def) apply (metis lfin_lfdelete values_lfin_iff) done From 2ec8d3f1ae607cd25f978beb40df77efd3f40c29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 2 Oct 2025 21:24:38 +0100 Subject: [PATCH 80/90] Use antiquotations for proofs --- Tools/bmv_monad_def.ML | 6 +++--- Tools/bmv_monad_tacs.ML | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index d13d8d61..4dd6a161 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -905,7 +905,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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] @@ -921,7 +921,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 subsetI, + 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]}, @@ -2688,4 +2688,4 @@ val _ = Outer_Syntax.local_theory_to_proof @{command_keyword pbmv_monad} ) []) >> pbmv_monad_cmd) -end \ No newline at end of file +end diff --git a/Tools/bmv_monad_tacs.ML b/Tools/bmv_monad_tacs.ML index 392f2ade..7a6bb67c 100644 --- a/Tools/bmv_monad_tacs.ML +++ b/Tools/bmv_monad_tacs.ML @@ -17,7 +17,7 @@ fun mk_SSupp_Sb_subsets T Injs SSupp_prems Sb hs rhos Sb_Injs lthy = (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 subsetI, + 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, @@ -165,4 +165,4 @@ fun mk_IImsupp_Sb_boundss var_class T Sb Injs Vrs hs rhos SSupp_prems IImsupp_Sb ]) end ) Vrs)) Injs -end \ No newline at end of file +end From 615e8fbbb9a6e8489395b9a91718f3adc3082f9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 2 Oct 2025 22:58:07 +0100 Subject: [PATCH 81/90] Fix ILC proof --- Tools/bmv_monad_def.ML | 10 +++++----- case_studies/Infinitary_Lambda_Calculus/ILC.thy | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 4dd6a161..bb9fdb3b 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -945,7 +945,7 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 subset_refl + rtac ctxt @{thm subset_refl} ]) end ) (RVrs @ Vrs))) Injs rhos) (Option.map #Map param_consts); @@ -2061,8 +2061,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit assume_tac ctxt, REPEAT_DETERM o FIRST' [ assume_tac ctxt, - eresolve_tac ctxt [UnI1, UnI2], - rtac ctxt UnI1 + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} ] ] ]) inners), @@ -2072,8 +2072,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit REPEAT_DETERM o FIRST' [ assume_tac ctxt, resolve_tac ctxt (refl :: @{thms SSupp_Inj_bound IImsupp_Inj_bound} @ prems), - eresolve_tac ctxt [UnI1, UnI2], - rtac ctxt UnI1 + eresolve_tac ctxt @{thms UnI1 UnI2}, + rtac ctxt @{thm UnI1} ] ] ]) ctxt diff --git a/case_studies/Infinitary_Lambda_Calculus/ILC.thy b/case_studies/Infinitary_Lambda_Calculus/ILC.thy index b52ac28a..ff7d6585 100644 --- a/case_studies/Infinitary_Lambda_Calculus/ILC.thy +++ b/case_studies/Infinitary_Lambda_Calculus/ILC.thy @@ -652,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) . From 67771cdde919a5c1491f99cceab801ca131070f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Thu, 2 Oct 2025 23:21:57 +0100 Subject: [PATCH 82/90] Fix operations theories --- Tools/mrbnf_sugar.ML | 2 + Tools/tvsubst.ML | 20 +++--- operations/BMV_Fixpoint.thy | 14 +--- operations/BMV_Monad.thy | 123 ------------------------------------ 4 files changed, 15 insertions(+), 144 deletions(-) diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index b7e385b7..41f0e429 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -1372,6 +1372,8 @@ fun create_binder_datatype co (spec : spec) lthy = ("inject", injects, simp) ] @ 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) diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 864e3b06..d17d308f 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -431,8 +431,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe dtac ctxt @{thm iffD1[OF disjoint_iff]}, etac ctxt allE, etac ctxt impE, - rtac ctxt UnI1, - rtac ctxt CollectI, + 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, @@ -483,8 +483,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 subsetI, - TRY o rtac ctxt UnI2, + rtac ctxt @{thm subsetI}, + TRY o rtac ctxt @{thm UnI2}, rtac ctxt @{thm UN_I[rotated]}, assume_tac ctxt, rtac ctxt @{thm CollectI}, @@ -788,7 +788,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 imageE, + etac ctxt @{thm imageE}, hyp_subst_tac ctxt, rtac ctxt @{thm trans[OF comp_apply]}, K (Local_Defs.unfold0_tac ctxt @{thms inv_simp1}), @@ -1123,15 +1123,15 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe hyp_subst_tac_thin true ctxt, rtac ctxt @{thm set_eqI}, rtac ctxt iffI, - REPEAT_DETERM_N (i - 1) o etac ctxt UnE, + REPEAT_DETERM_N (i - 1) o etac ctxt @{thm UnE}, EVERY' (map (fn i' => EVERY' [ - REPEAT_DETERM_N (j - 1) o etac ctxt UnE, + 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 UnE, + 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') @@ -1209,7 +1209,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe etac ctxt @{thm Int_subset_empty2}, rtac ctxt @{thm subsetI}, SELECT_GOAL (EVERY1 [ - REPEAT_DETERM o etac ctxt UnE, + REPEAT_DETERM o etac ctxt @{thm UnE}, REPEAT_DETERM o FIRST' [ assume_tac ctxt, eresolve_tac ctxt @{thms UnI1 UnI2}, @@ -1440,7 +1440,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ], K (Local_Defs.unfold0_tac ctxt @{thms image_id}), SELECT_GOAL (EVERY1 [ - REPEAT_DETERM o etac ctxt UnE, + REPEAT_DETERM o etac ctxt @{thm UnE}, REPEAT_DETERM o FIRST' [ assume_tac ctxt, eresolve_tac ctxt @{thms UnI1 UnI2}, diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 4b7aa3f6..1967a0da 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -477,8 +477,8 @@ interpretation tvsubst: QREC_fixed_FTerm "avoiding_set1 f1 f2" apply (rule trans) apply (rule FTerm.permute_ctor) - apply (assumption | rule ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order)+ - + apply (assumption)+ + thm trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]] 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) @@ -502,9 +502,6 @@ interpretation tvsubst: QREC_fixed_FTerm "avoiding_set1 f1 f2" apply (erule Int_subset_empty2) apply (rule subsetI) apply (rule UnI2) - apply (unfold IImsupp_FType_def comp_def SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def - IImsupp_def SSupp_def VVr_def TyVar_def - )[1] apply assumption done @@ -947,11 +944,6 @@ lemma FVars_tvsubst2: apply (subst IImsupp_Diff, assumption+) apply (subst FType.IImsupp_Diff) apply (erule Int_subset_empty2) - (* This is only because FType does not use BMVs yet, not part of the tactic *) - apply (unfold IImsupp_FType_def SSupp_FType_def tvVVr_tvsubst_FType_def tv\_FType_tvsubst_FType_def - TyVar_def[symmetric] SSupp_def[of TyVar, symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong] - comp_def IImsupp_def[of TyVar FVars_FType, symmetric, THEN meta_eq_to_obj_eq, THEN fun_cong] - )[1] apply (rule Un_upper2) apply (unfold Un_Diff[symmetric]) apply (rule arg_cong2[OF _ refl, of _ _ "minus"]) @@ -1552,7 +1544,7 @@ 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} @{binding tvsubst_FTerm'} [SOME { + 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 = { diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index f27812d4..8118ad0a 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -21,129 +21,6 @@ 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 VVr_eq_Var_FType: "tvVVr_tvsubst_FType = TyVar" - unfolding tvVVr_tvsubst_FType_def TyVar_def comp_def tv\_FType_tvsubst_FType_def by (rule refl) - -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]) - apply (rule subsetI) - apply (unfold mem_Collect_eq) - apply simp - using assms(1) by force -lemma SSupp_comp_bound_FType[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) - done -thm Sb_comp_FType[unfolded SSupp_FType_def tvVVr_tvsubst_FType_def[unfolded comp_def] tv\_FType_tvsubst_FType_def TyVar_def[symmetric]] -lemma Vrs_Inj_FType: "Vrs_FType_1 (Inj_FType_1 a) = {a}" - by simp - -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 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 simp: FType.permute_id) - by (metis (mono_tags, lifting) CollectI IImsupp_FType_def SSupp_FType_def Un_iff) -qed (auto simp: assms(1-2)) - -lemma map_is_Sb_FType: - fixes f::"'tyvar::var \ 'tyvar" - assumes "|supp f| f)" - apply (rule ext) - subgoal for x - proof (binder_induction x avoiding: "imsupp f" rule: FType.strong_induct) - case Bound - then show ?case using imsupp_supp_bound infinite_UNIV assms by blast - next - case (TyAll x1 x2) - then have 1: "x1 \ SSupp_FType (Inj_FType_1 \ f)" - by (simp add: SSupp_FType_def VVr_eq_Var_FType not_in_imsupp_same) - then have "x1 \ IImsupp_FType (Inj_FType_1 \ f)" - unfolding IImsupp_FType_def Un_iff de_Morgan_disj - apply (rule conjI) - apply (insert 1) - apply (erule contrapos_nn) - apply (erule UN_E) - by (metis FType.set(1) TyAll.fresh comp_apply in_imsupp not_in_imsupp_same singletonD) - then show ?case using assms TyAll by (auto simp: FType.SSupp_comp_bound_old) - qed (auto simp: FType.SSupp_comp_bound_old assms) - done - -declare [[ML_print_depth=1000]] - -local_setup \fold BMV_Monad_Def.register_mrbnf_as_pbmv_monad [@{type_name sum}, @{type_name prod}]\ - -pbmv_monad "'tv::var FType" - Sbs: tvsubst_FType - Injs: TyVar - Vrs: FVars_FType - bd: natLeq - apply (rule infinite_regular_card_order_natLeq) - apply (rule Sb_Inj_FType) - apply (unfold SSupp_def SSupp_FType_def[unfolded tvVVr_tvsubst_FType_def[unfolded comp_def tv\_FType_tvsubst_FType_def TyVar_def[symmetric]], symmetric]) - apply (rule Sb_comp_Inj_FType; assumption) - apply (rule Sb_comp_FType; assumption) - apply (rule FType.set_bd) - apply (rule Vrs_Inj_FType) - apply (rule Vrs_Sb_FType; assumption) - apply (rule Sb_cong_FType; assumption) - done -print_theorems - -mrsbnf "'a::var FType" - apply (rule map_is_Sb_FType; assumption) - done -print_theorems - binder_datatype 'a LM = Var 'a | Lst "'a list" From b7a774a277925e1b0986f6dfe0747959ee420395 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Fri, 3 Oct 2025 23:54:58 +0100 Subject: [PATCH 83/90] Split internal definitions from user-facing ones --- Tools/bmv_monad_def.ML | 50 ++++++++++++++++++------------------- Tools/mrbnf_sugar.ML | 16 +++++------- Tools/tvsubst.ML | 2 +- operations/BMV_Fixpoint.thy | 1 - 4 files changed, 31 insertions(+), 38 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index bb9fdb3b..559f115d 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -84,6 +84,7 @@ signature BMV_MONAD_DEF = sig 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; @@ -102,7 +103,8 @@ signature BMV_MONAD_DEF = sig 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 -> local_theory -> (bmv_monad * thm list) * local_theory + -> (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; @@ -274,12 +276,13 @@ datatype bmv_monad = BMV of { bd_infinite_regular_card_order: thm, axioms: thm bmv_monad_axioms list, facts: bmv_monad_facts list, - unfolds: thm 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 + facts, unfolds, defs }) = BMV { ops = map (Morphism.typ phi) ops, leader = leader, @@ -293,7 +296,8 @@ fun morph_bmv_monad phi (BMV { 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 + unfolds = map (Morphism.thm phi) unfolds, + defs = map (Morphism.thm phi) defs } fun Rep_bmv (BMV x) = x @@ -319,6 +323,7 @@ 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) @@ -832,7 +837,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv 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 lthy = +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), @@ -1006,7 +1011,8 @@ fun mk_bmv_monad const_policy fact_policy qualify bmv_b_opt (model: thm bmv_mona 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 + unfolds = unfolds, + defs = defs } : bmv_monad; val (_, lthy) = note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy; @@ -1067,7 +1073,7 @@ fun mk_thm_model (model: 'a bmv_monad_model) params axioms 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) lthy = +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) @@ -1087,7 +1093,7 @@ fun bmv_monad_def const_policy fact_policy qualify bmv_b_opt (model: (Proof.cont )) (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 lthy) end + 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 @@ -1216,7 +1222,7 @@ fun pbmv_monad_of_mrbnf qualify mrbnf lthy = REPEAT_DETERM o (rtac ctxt refl ORELSE' Goal.assume_rule_tac ctxt) ] }] - } lthy) end; + } [] lthy) end; fun register_mrbnf_as_pbmv_monad name lthy = let @@ -1252,7 +1258,8 @@ fun unsafe_slice_bmv_monad n 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 + 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 = @@ -1519,7 +1526,7 @@ fun demote_bmv_monad inline_policy const_policy qualify b_opt bmv { lives=dlives }) 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 + 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 = @@ -2090,7 +2097,8 @@ fun compose_bmv_monad qualify (outer : bmv_monad) (inners : (bmv_monad, typ) eit 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 lthy + 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 = @@ -2334,20 +2342,10 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = }] } : (Proof.context -> tactic) bmv_monad_model; - fun set_unfolds thms (BMV { - ops, var_class, leader: int, frees, lives, lives', deads, consts, params, bd_infinite_regular_card_order, - axioms, facts, ... - }) = BMV { - ops = ops, var_class = var_class, leader = leader, frees = frees, lives = lives, lives' = lives', - deads = deads, consts = consts, params = params, bd_infinite_regular_card_order = bd_infinite_regular_card_order, - axioms = axioms, facts = facts, unfolds = thms - } + 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; - val ((bmv, _), lthy) = bmv_monad_def BNF_Def.Hardly_Inline (K BNF_Def.Note_Some) qualify NONE model lthy; - val new_unfolds = map (Local_Defs.unfold lthy unfolds) defs; - val bmv = set_unfolds new_unfolds bmv; - - in ((bmv, new_unfolds, defs, (T_name, info)), lthy) end + 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 @@ -2610,7 +2608,7 @@ fun pbmv_monad_cmd (((((((b_ops, Sbs), RVrs), Injs), Vrs), param_opt), bd), extr 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 (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; diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 41f0e429..d6d76134 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -897,6 +897,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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 @@ -911,6 +912,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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 @@ -945,6 +947,7 @@ fun create_binder_datatype co (spec : spec) lthy = @{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 @ 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' [ @@ -1183,15 +1186,8 @@ fun create_binder_datatype co (spec : spec) lthy = (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}) - ]); - -<<<<<<< HEAD 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_res, lthy) = TVSubst.create_tvsubst_of_mrsbnf (Binding.prefix_name "tv") res mrsbnf rec_mrbnf (#vvsubst_ctor vvsubst_res) (#vvsubst_permute vvsubst_res) (#tvsubst_b spec) eta_models (#QREC_fixed recursor_result) lthy; @@ -1243,7 +1239,6 @@ fun create_binder_datatype co (spec : spec) lthy = 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) (map_filter (Option.map #Inj) eta_models))), EVERY' [ @@ -1261,7 +1256,7 @@ fun create_binder_datatype co (spec : spec) lthy = )), 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 ( @@ -1282,6 +1277,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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 @ 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} diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index d17d308f..65aeac23 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -1599,7 +1599,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ] end ) ctxt 1 }] - } lthy; + } [] (*TODO: Put definitions here *) lthy; val rec_mrbnf = let diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 1967a0da..6001ddbc 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -478,7 +478,6 @@ interpretation tvsubst: QREC_fixed_FTerm "avoiding_set1 f1 f2" apply (rule trans) apply (rule FTerm.permute_ctor) apply (assumption)+ - thm trans[OF comp_apply[symmetric] FTerm_pre.map_Sb_strong(1)[THEN fun_cong]] 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) From 6bcd55dbd5b0170452d62199bef699a7aa0a5a51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Mon, 20 Oct 2025 15:57:58 +0100 Subject: [PATCH 84/90] Fix errors from rebase --- Tools/binder_sugar.ML | 7 +- Tools/bmv_monad_def.ML | 1 + Tools/mrbnf_sugar.ML | 104 +++++--------------------- Tools/tvsubst.ML | 57 ++++++++++---- case_studies/POPLmark/POPLmark_2B.thy | 8 +- operations/BMV_Monad.thy | 6 +- tests/Regression_Tests.thy | 12 ++- 7 files changed, 82 insertions(+), 113 deletions(-) diff --git a/Tools/binder_sugar.ML b/Tools/binder_sugar.ML index 81a9d4de..0a900c2e 100644 --- a/Tools/binder_sugar.ML +++ b/Tools/binder_sugar.ML @@ -4,7 +4,7 @@ type binder_sugar = { map_simps: thm list, set_simpss: thm list list, permute_simps: thm list, - map_permute: thm, + map_permute: thm option, subst_simps: thm list option, IImsupp_permute_commutes: thm list option, IImsupp_Diffs: thm list option, @@ -20,7 +20,6 @@ type binder_sugar = { 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 @@ -32,7 +31,7 @@ type binder_sugar = { map_simps: thm list, set_simpss: thm list list, permute_simps: thm list, - map_permute: thm, + map_permute: thm option, subst_simps: thm list option, IImsupp_permute_commutes: thm list option, IImsupp_Diffs: thm list option, @@ -52,7 +51,7 @@ fun morph_binder_sugar phi { map_simps, permute_simps, map_permute, set_simpss, } = { map_simps = map (Morphism.thm phi) map_simps, permute_simps = map (Morphism.thm phi) permute_simps, - map_permute = Morphism.thm phi map_permute, + 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, diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 559f115d..ed118ef1 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -796,6 +796,7 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = val facts = facts_of_bmv_monad bmv; val params = params_of_bmv_monad bmv; val unfolds = unfolds_of_bmv_monad bmv; + val _ = @{print} unfolds fun note_unless_dont_note (noted, lthy) = let val notes = diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index d6d76134..6437cf20 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -13,25 +13,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, - IImsupp_permute_commutes: thm list option, - IImsupp_Diffs: 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; @@ -41,7 +22,7 @@ val build_permute_for: Proof.context -> term list -> typ list -> typ -> (string val create_binder_type : MRBNF_Util.fp_kind -> spec -> 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 * local_theory +val create_binder_datatype : bool -> spec -> local_theory -> Binder_Sugar.binder_sugar * local_theory end structure MRBNF_Sugar : MRBNF_SUGAR = @@ -66,57 +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, - IImsupp_permute_commutes: thm list option, - IImsupp_Diffs: 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, IImsupp_permute_commutes, IImsupp_Diffs } = { - 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, - 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 = @@ -963,9 +893,12 @@ fun create_binder_datatype co (spec : spec) lthy = eta_compl_free = eta_compl_free_tac, eta_natural = eta_natural_tac }; - val eta_models = map (fn a => Option.map (fn { eta, Inj } => { eta = eta, Inj = Inj, tacs = tvsubst_axioms }) ( - List.find (fn { eta, ...} => domain_type (fastype_of eta) = a) etas - )) vars; + val tvsubst_model = { + binding = #tvsubst_b spec, + 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 @@ -1177,7 +1110,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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 @@ -1189,8 +1122,12 @@ fun create_binder_datatype co (spec : spec) lthy = 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 rec_mrbnf = #rec_mrbnf (the vvsubst_res_opt); + val vvsubst_res = #vvsubst_res (the vvsubst_res_opt); + 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) (#tvsubst_b spec) eta_models (#QREC_fixed recursor_result) lthy; + rec_mrbnf (#vvsubst_ctor vvsubst_res) (#vvsubst_permute vvsubst_res) (#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; @@ -1240,7 +1177,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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) (map_filter (Option.map #Inj) eta_models))), + K (Local_Defs.unfold0_tac ctxt (map (Thm.symmetric o snd) (map_filter (Option.map #Inj) (#etas tvsubst_model)))), EVERY' [ resolve_tac ctxt (#tvsubst_Injs tvsubst_res), REPEAT_DETERM o resolve_tac ctxt prems @@ -1297,18 +1234,17 @@ 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]} - (*fun unfold_tvsubst res = map_filter (Option.map ( + 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)}] ) - ));*) -<<<<<<< HEAD + ); - val IImsupp_permute_commutes = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_permute_commutes res)) tvsubst_opt; - val IImsupp_Diffs = Option.map (fn (res, _) => unfold_tvsubst res (#IImsupp_Diffs res)) tvsubst_opt; + 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 @@ -1329,7 +1265,7 @@ fun create_binder_datatype co (spec : spec) lthy = distinct = [], inject = [], ctors = [] - } : binder_sugar; + } : Binder_Sugar.binder_sugar; in (sugar, lthy) end else let @@ -1349,7 +1285,7 @@ fun create_binder_datatype co (spec : spec) lthy = distinct = distinct, inject = injects, ctors = ctors - } : binder_sugar; + } : Binder_Sugar.binder_sugar; in (sugar, lthy) end val lthy = Binder_Sugar.register_binder_sugar (fst (dest_Type qT)) sugar lthy; diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index 65aeac23..eae4007a 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -603,7 +603,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val ((((fs, rhos), 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 "h" (replicate 2 (#T quot --> #T quot)) + ||>> mk_Frees "h" (replicate nrecs (#T quot --> #T quot)) ||>> 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 @@ -671,8 +671,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val rho_prems = Proof_Context.get_thms lthy "f_prems"; - val avoiding_sets = map (foldl1 mk_Un o map_filter I) (transpose IImsuppss); + val avoiding_sets = map2 (fn free => + the_default (mk_bot free) o try (foldl1 mk_Un) o map_filter I + ) frees (transpose (filter_out null IImsuppss)); + val _ = @{print} "3" val Uctor = let val ctor = #ctor quot; @@ -793,7 +796,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 #map_permute sugars), + 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) @@ -855,9 +858,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ], REPEAT_DETERM o rtac ctxt @{thm Un_mono'}, SELECT_GOAL (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), - EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs bmv_axioms), + 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}), + K (Local_Defs.unfold0_tac ctxt @{thms image_id id_apply}), rtac ctxt @{thm Un_upper1} ORELSE' EVERY' [ rtac ctxt @{thm subsetI}, etac ctxt @{thm UN_E}, @@ -893,7 +896,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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} + eresolve_tac ctxt @{thms UnI1 UnI2} ORELSE' assume_tac ctxt ] ]) ctxt ])), Position.no_range), NONE) state; @@ -901,6 +904,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 _ = @{print} "4" val tvsubst_not_isInj = let val x = Free ("x", domain_type (fastype_of (#ctor quot))); @@ -1143,6 +1147,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe | _ => error "only works for datatypes" val fresh_induct = #fresh_induct fp_thms; + (* needs to account for vars that are not injections on RHS *) val FVars_tvsubsts = map (fn FVars => let val t = Free ("t", domain_type (fastype_of FVars)); @@ -1159,6 +1164,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe FVars $ (Term.list_comb (fst tvsubst, map_filter I rhos) $ t), foldl1 mk_Un rhss ); + val _ = @{print} (Thm.cterm_of lthy goal) in Goal.prove_sorry lthy (names (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) avoiding_sets) fresh_induct), REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ @@ -1184,25 +1190,42 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe EqSubst.eqsubst_tac ctxt [0] (#Vrs_Sbs bmv_axioms), REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound} @ prems) ], - K (Local_Defs.unfold0_tac ctxt (@{thms image_id UN_Un} @ #Vrs_Map (the (BMV_Monad_Def.leader BMV_Monad_Def.params_of_bmv_monad bmv)))), + 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] + )), + K (print_tac ctxt "1"), rtac ctxt (mk_Un_cong (nrecs + 1) (length rhss)), REPEAT_DETERM o EVERY' [ - EqSubst.eqsubst_tac ctxt [0] (map_filter (Option.map (#eta_compl_free o #axioms)) defs), + EqSubst.eqsubst_tac ctxt [0] (@{print}(map_filter (Option.map (#eta_compl_free o #axioms)) defs)), + K (print_tac ctxt "1.1"), SELECT_GOAL (Local_Defs.unfold0_tac ctxt (map_filter (Option.map (snd o #isInj)) defs)), rotate_tac ~1, etac ctxt @{thm contrapos_np}, + K (print_tac ctxt "1.2"), 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, + K (print_tac ctxt "1.3"), rtac ctxt exI, - rtac ctxt refl + rtac ctxt refl, + K (print_tac ctxt "1.35") + ], + 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} ], - K (Local_Defs.unfold0_tac ctxt @{thms UN_empty Un_empty_left Un_empty_right}), + K (Local_Defs.unfold0_tac ctxt (@{thms image_id})), + K (print_tac ctxt "1.4"), rtac ctxt refl, rtac ctxt trans, rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, rtac ctxt @{thm UN_cong}, Goal.assume_rule_tac ctxt, + K (print_tac ctxt "2"), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs @ maps (the_default [] o #IImsupp_Diffs) sugars), REPEAT_DETERM o (assume_tac ctxt ORELSE' EVERY' [ @@ -1218,12 +1241,16 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ]) ]) ], + K (print_tac ctxt "3"), K (Local_Defs.unfold0_tac ctxt @{thms Un_Diff[symmetric]}), rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib[symmetric]}), rtac ctxt refl, - rtac ctxt @{thm UN_cong}, - Goal.assume_rule_tac ctxt, + TRY o EVERY' [ + rtac ctxt @{thm UN_cong}, + Goal.assume_rule_tac ctxt + ], + K (print_tac ctxt "4"), EVERY' (map_filter (Option.map (fn def => EVERY' [ K (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), etac ctxt exE, @@ -1234,8 +1261,10 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe K (Local_Defs.unfold0_tac ctxt (@{thms UN_single UN_empty Un_empty_left Un_empty_right} @ maps (the_default []) FVars_Injs )), + K (print_tac ctxt "5"), rtac ctxt refl - ])) (rev defs)) + ])) (rev defs)), + K (print_tac ctxt "end") ]) end ) (#FVarss quot); @@ -1752,7 +1781,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ); in Goal.prove_sorry lthy (names (fs @ map_filter I rhos)) (f_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 #map_permute sugars)), + 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 (#map_Sb_strong (hd (MRSBNF_Def.facts_of_mrsbnf rec_mrsbnf))), diff --git a/case_studies/POPLmark/POPLmark_2B.thy b/case_studies/POPLmark/POPLmark_2B.thy index fce1b86e..745c4fe9 100644 --- a/case_studies/POPLmark/POPLmark_2B.thy +++ b/case_studies/POPLmark/POPLmark_2B.thy @@ -925,7 +925,7 @@ lemma permute_trm_eq_tvsubst': proof - have [simp]: "|SSupp Var (restrict (Var o \) (FVars t) Var)| ) (FTVars t) TyVar)| " "supp \" t rule: trm.strong_induct) apply (auto simp: lfset.set_map intro!: lfset.map_cong0) @@ -934,13 +934,13 @@ proof - 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 infinite_UNIV bij_implies_inject supp_def[symmetric] split: if_splits intro!: trm.Sb_cong lfset.map_cong) + 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 infinite_UNIV bij_implies_inject supp_def[symmetric] split: if_splits intro!: trm.Sb_cong lfset.map_cong) + 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 infinite_UNIV bij_implies_inject supp_def[symmetric] split: if_splits intro!: trm.Sb_cong lfset.map_cong) + 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) diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 8118ad0a..01375c57 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -112,7 +112,7 @@ next 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 infinite_UNIV) +qed (auto simp: assms imsupp_supp_bound) lemma Vrs_2_Sb_LM: fixes f1::"'a::var \ 'a" @@ -161,7 +161,7 @@ lemma Vrs_1_bd: "|Vrs_1 t::'a::var set| 'a" @@ -222,7 +222,7 @@ lemma vvsubst_Sb: apply (rule ext) subgoal for x apply (binder_induction x avoiding: "imsupp f" rule: LM.strong_induct) - apply (auto simp: imsupp_supp_bound assms infinite_UNIV) + 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] diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index 0fbc93cf..5cddf926 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -1,7 +1,7 @@ theory Regression_Tests imports "Binders.MRBNF_Recursor" "../thys/LetRec/DAList_MRBNF" "HOL-Library.FSet" begin - +(* (* #68 *) binder_datatype 'a trm = Var 'a @@ -14,7 +14,6 @@ binder_datatype 'a LLC = | Abs x::'a t::"'a LLC" binds x in t | Let "(x::'a, t::'a LLC) alist" u::"'a LLC" binds x in t u -declare [[ML_print_depth=1000]] (* #70 *) datatype ('tv, 'ev, 'rv) type = Type 'tv 'ev 'rv binder_datatype ('tv, 'ev, 'rv) type_scheme = @@ -25,14 +24,19 @@ binder_datatype ('tv, 'ev, 'rv) type_scheme = binder_datatype ('tv, 'ev, 'rv) type_scheme2 = TAll "(X::'tv) list" \::"('tv, 'ev, 'rv) type_scheme2" binds X in \ | ERAll "(\::'ev) list" "(\::'rv) list" T::"('tv, 'ev, 'rv) type" binds \ \ in T +*) +ML \ +Multithreading.parallel_proofs := 0 +\ (* #75 *) binder_datatype ('a, 'b, 'c, 'd) trm3 = Var 'a + (* | Test "'b list" *) | App "('a, 'b, 'c, 'd) trm3" "('a, 'b, 'c, 'd) trm3" | Lam a::'a b::'b c::'c d::'d e::"('a, 'b, 'c, 'd) trm3" binds a b c d in e -(* #74 *) +(*(* #74 *) binder_datatype 'a trm4 = V 'a | Lm x::'a t::"'a trm4" binds x in t binder_datatype 'a foo = Foo 'a | Bind "(x::'a) trm4" t::"'a foo" binds x in t @@ -92,5 +96,5 @@ lemma fixes x y::"'a::var" and e::"'a term" shows "e = e" by (binder_induction e avoiding: "{x} \ {y}" rule: term.strong_induct) auto - +*) end From 97f6a2bc112fb1143e712aeaa63999f9868e2828 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Sat, 15 Nov 2025 11:05:17 +0000 Subject: [PATCH 85/90] Add support for passive free variables --- Tools/binder_sugar.ML | 5 +- Tools/bmv_monad_def.ML | 1 - Tools/mrbnf_sugar.ML | 7 +- Tools/tvsubst.ML | 268 ++++++++++++++---------- case_studies/Pi_Calculus/Commitment.thy | 1 + operations/BMV_Fixpoint.thy | 2 +- 6 files changed, 172 insertions(+), 112 deletions(-) diff --git a/Tools/binder_sugar.ML b/Tools/binder_sugar.ML index 0a900c2e..4fa40839 100644 --- a/Tools/binder_sugar.ML +++ b/Tools/binder_sugar.ML @@ -11,6 +11,7 @@ type binder_sugar = { 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, @@ -38,6 +39,7 @@ type binder_sugar = { 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, @@ -47,7 +49,7 @@ type binder_sugar = { 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 + tvsubst_permute, pset_ctors } = { map_simps = map (Morphism.thm phi) map_simps, permute_simps = map (Morphism.thm phi) permute_simps, @@ -59,6 +61,7 @@ fun morph_binder_sugar phi { map_simps, permute_simps, map_permute, set_simpss, 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, diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index ed118ef1..559f115d 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -796,7 +796,6 @@ fun note_bmv_monad_thms fact_policy qualify bmv_b_opt bmv lthy = val facts = facts_of_bmv_monad bmv; val params = params_of_bmv_monad bmv; val unfolds = unfolds_of_bmv_monad bmv; - val _ = @{print} unfolds fun note_unless_dont_note (noted, lthy) = let val notes = diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 6437cf20..957d5d0e 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -1121,14 +1121,17 @@ fun create_binder_datatype co (spec : spec) lthy = val (lthy, tvsubst_opt) = if not (null (map_filter I (#etas tvsubst_model))) andalso not co then let + val _ = @{print} "before tvsubst" val recursor_result = #recursor_result (the vvsubst_res_opt); val rec_mrbnf = #rec_mrbnf (the vvsubst_res_opt); val vvsubst_res = #vvsubst_res (the vvsubst_res_opt); 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) (#tvsubst_b spec) + 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 _ = @{print} "after tvsubst" + 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; @@ -1261,6 +1264,7 @@ fun create_binder_datatype co (spec : spec) lthy = tvsubst_permute = Option.map (#tvsubst_permute o fst) tvsubst_opt, bsetss = [], bset_bounds = [], + pset_ctors = [], mrbnf = mrbnf, distinct = [], inject = [], @@ -1281,6 +1285,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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, diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index eae4007a..c802aba2 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -26,7 +26,7 @@ sig }; val create_tvsubst_of_mrsbnf: (binding -> binding) -> MRBNF_FP_Def_Sugar.fp_result - -> MRSBNF_Def.mrsbnf -> MRBNF_Def.mrbnf -> thm -> thm -> binding + -> 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 @@ -283,7 +283,7 @@ fun define_tvsubst_consts qualify (fp_res : MRBNF_FP_Def_Sugar.fp_result) (etas in (defs, lthy) end; -fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_permute tvsubst_b models QREC_fixed_name no_defs_lthy = +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; @@ -293,6 +293,27 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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, @@ -300,7 +321,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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; + }) (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 @@ -346,7 +367,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ||>> 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 rhos = map (fn a => List.find (curry (op=) a o domain_type o fastype_of) some_rhos) frees; + 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 @@ -360,10 +381,10 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 (prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}), + 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 (prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}) + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems) ]) end )) (0 upto length defs - 1) defs; @@ -374,14 +395,14 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 [ + 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))), + 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 supp_inv_bound bij_imp_bij_inv} @ prems @ @{thms ordLess_ordLeq_trans cmin1 cmin2 card_of_Card_order}) + 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, @@ -398,12 +419,19 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 + 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 - )) (#FVarss quot) + )) 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); @@ -411,7 +439,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 end + ) (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 => @@ -438,13 +466,13 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe etac ctxt conjE, assume_tac ctxt ]) end - )) fs rhos IImsuppss defs; + )) (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 IImsupps; + ) 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) @@ -508,33 +536,20 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe resolve_tac ctxt prems, resolve_tac ctxt prems ]) end - )) (0 upto nvars - 1) permute_Injs IImsupp_Injs IImsuppss rhos defs; + )) (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 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 args = (snd o dest_Type o body_type o fastype_of o #eta) (hd (map_filter I defs)); - 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 eta_set_emptiess = map (Option.map (fn def => let - val var_types = replicate nvars MRBNF_Def.Free_Var @ replicate nvars MRBNF_Def.Bound_Var + 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 (foldr1 (op+) (#rec_vars fp_res)) MRBNF_Def.Live_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); @@ -624,12 +639,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe let val fs = map (Thm.term_of o snd) (tl params); val map_t = MRBNF_Def.mk_map_comb_of_mrbnf (subtract (op=) frees (BMV_Monad_Def.leader BMV_Monad_Def.deads_of_bmv_monad bmv)) - (map (fn xs => if null xs then HOLogic.id_const (#T quot) else + (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 mk_inv fs) (map HOLogic.id_const frees) mrbnf; + (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], @@ -673,23 +688,23 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val avoiding_sets = map2 (fn free => the_default (mk_bot free) o try (foldl1 mk_Un) o map_filter I - ) frees (transpose (filter_out null IImsuppss)); + ) (frees @ pfrees) (transpose (filter_out null IImsuppss)); + val passive = length plives + length pfrees + length pbounds; - val _ = @{print} "3" val Uctor = let val ctor = #ctor quot; val (name, (args, rec_args)) = dest_Type (fst (dest_funT (fastype_of ctor))) - |> apsnd (chop (nvars * 2 + length (#bfree_vars fp_res))); + |> 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; - val bound_ids = map HOLogic.id_const frees; + 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 fst_const rec_args') + (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, @@ -702,7 +717,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 snd_const rec_args') bound_ids free_ids mrbnf $ Bound 0))) + (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) => @@ -711,7 +726,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val state = Interpretation.interpretation ([ (QREC_fixed_name, (("tvsubst", true), (Expression.Positional (map SOME ( - avoiding_sets @ [Uctor] + take nvars avoiding_sets @ [Uctor] )), [])) )], []) lthy; @@ -724,7 +739,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 [ - rtac ctxt (the (fst (Locale.intros_of (Proof_Context.theory_of lthy) QREC_fixed_name))), + 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} @ rho_prems @ maps (MRBNF_Def.set_bd_UNIV_of_mrbnf) (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) @@ -780,10 +795,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), 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 supp_inv_bound SSupp_comp_bound infinite_UNIV conjI card_of_Card_order} + @{thms supp_id_bound bij_id supp_inv_bound SSupp_comp_bound infinite_UNIV conjI card_of_Card_order} @ [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, REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_asm_tac ctxt [0] [MRBNF_Def.map_comp_of_mrbnf mrbnf], @@ -814,7 +830,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ], (* FVars goals *) REPEAT_DETERM o Subgoal.FOCUS_PREMS (fn {context=ctxt, prems, ...} => EVERY1 [ - EVERY' (@{map_filter 2} (fn rho => Option.map (fn def => EVERY' (map (fn tac => DETERM o tac) [ + EVERY' (map_filter (Option.map (fn def => EVERY' (map (fn tac => DETERM o tac) [ rtac ctxt @{thm case_split}, EqSubst.eqsubst_tac ctxt [0] @{thms if_P}, assume_tac ctxt, @@ -840,7 +856,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ], rtac ctxt @{thm UnI1} ] - ]))) rhos defs), + ]))) 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 @@ -904,7 +920,6 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 _ = @{print} "4" val tvsubst_not_isInj = let val x = Free ("x", domain_type (fastype_of (#ctor quot))); @@ -913,15 +928,15 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ); val int_empty_prems = map2 (fn bset => fn avoiding_set => HOLogic.mk_Trueprop ( mk_int_empty (bset $ x, avoiding_set) - )) bound_sets avoiding_sets; + )) 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) - (flat (map2 replicate (#rec_vars fp_res) [fst tvsubst])) - (ids frees) (ids frees) 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 (HOLogic.id_const o HOLogic.dest_setT o body_type o fastype_of) (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) @@ -989,7 +1004,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt refl, rtac ctxt refl ]) end - )) (0 upto nvars - 1) (take nvars sets) rhos eta_set_emptiess asInj_Injs defs; + )) (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; @@ -1009,6 +1024,13 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val tvsubst_not_isInj = Morphism.thm phi tvsubst_not_isInj; val tvsubst_Injs = map (Option.map (Morphism.thm phi)) tvsubst_Injs; + 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 in_IImsuppss = map (Option.map (fn def => map (fn FVars => let val a = Free ("a", #aT def); @@ -1029,7 +1051,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe etac ctxt @{thm CollectI}, assume_tac ctxt ]) end - ) (#FVarss quot))) defs; + ) Vrs)) defs; val FVars_Injs = map (Option.map (fn def => map (fn FVars => let @@ -1038,12 +1060,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 @ [snd (#Inj def)] @ maps (the_default []) eta_set_emptiess + @ #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 - ) (#FVarss quot))) defs; + ) Vrs)) defs; val IImsupp_Diffs = @{map 3} (fn rho => fn avoiding_set => Option.map (fn def => map (fn FVars => let @@ -1109,7 +1131,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe assume_tac ctxt, assume_tac ctxt ]) end - ) (#FVarss quot))) rhos avoiding_sets defs; + ) Vrs)) rhos avoiding_sets defs; val netas = length (map_filter I defs); @@ -1150,23 +1172,23 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe (* needs to account for vars that are not injections on RHS *) val FVars_tvsubsts = map (fn FVars => let + val Vrs_orig = Vrs; 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 #FVarss quot else nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) idx; + val Vrs = if idx = ~1 then Vrs_orig 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))) (#FVarss quot); + ) (List.find (curry (op=) (HOLogic.dest_setT (body_type (fastype_of FVars'))) o domain_type o fastype_of) (map_filter I rhos))) Vrs; val goal = mk_Trueprop_eq ( FVars $ (Term.list_comb (fst tvsubst, map_filter I rhos) $ t), foldl1 mk_Un rhss ); - val _ = @{print} (Thm.cterm_of lthy goal) in Goal.prove_sorry lthy (names (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) avoiding_sets) fresh_induct), + 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} @ prems @ maps MRBNF_Def.set_bd_UNIV_of_mrbnf (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf) @@ -1178,7 +1200,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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)), + 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) @@ -1196,6 +1218,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe )), K (print_tac ctxt "1"), rtac ctxt (mk_Un_cong (nrecs + 1) (length rhss)), + K (print_tac ctxt "1.0"), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (@{print}(map_filter (Option.map (#eta_compl_free o #axioms)) defs)), K (print_tac ctxt "1.1"), @@ -1222,30 +1245,40 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe K (print_tac ctxt "1.4"), rtac ctxt refl, rtac ctxt trans, - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + K (print_tac ctxt "1.5"), + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + K (print_tac ctxt "1.6"), rtac ctxt @{thm UN_cong}, Goal.assume_rule_tac ctxt, K (print_tac ctxt "2"), REPEAT_DETERM o EVERY' [ EqSubst.eqsubst_tac ctxt [0] (maps (the_default []) IImsupp_Diffs @ maps (the_default [] o #IImsupp_Diffs) sugars), - REPEAT_DETERM o (assume_tac ctxt ORELSE' 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} - ] - ]) - ]) + 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 (print_tac ctxt "3"), - K (Local_Defs.unfold0_tac ctxt @{thms Un_Diff[symmetric]}), - rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + K (Local_Defs.unfold0_tac ctxt @{thms Un_Diff[symmetric] Diff_empty}), + K (print_tac ctxt "3.1"), + TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, + K (print_tac ctxt "3.2"), K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib[symmetric]}), + K (print_tac ctxt "3.3"), rtac ctxt refl, + K (print_tac ctxt "3.4"), TRY o EVERY' [ rtac ctxt @{thm UN_cong}, Goal.assume_rule_tac ctxt @@ -1266,13 +1299,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ])) (rev defs)), K (print_tac ctxt "end") ]) end - ) (#FVarss quot); + ) Vrs; - 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 _ = @{print} ("FVars_tvsubsts", FVars_tvsubsts) val some_rhos = map_filter I rhos; val SSupp_tvsubst_subsets = BMV_Monad_Tactics.mk_SSupp_Sb_subsets (#T quot) @@ -1289,12 +1318,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val IImsupp_Sb_subsetss = BMV_Monad_Tactics.mk_IImsupp_Sb_subsetss (#T quot) ops (fst tvsubst) rho_prems' ([] :: tl (BMV_Monad_Def.RVrs_of_bmv_monad bmv)) - (#FVarss quot :: tl (BMV_Monad_Def.Vrs_of_bmv_monad bmv)) - (#FVarss quot) Injs [] some_rhos SSupp_tvsubst_subsets + (Vrs :: tl (BMV_Monad_Def.Vrs_of_bmv_monad bmv)) + Vrs Injs [] 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 (#FVarss quot) [] some_rhos rho_prems' IImsupp_Sb_subsetss + (fst tvsubst) Injs Vrs [] some_rhos rho_prems' IImsupp_Sb_subsetss (#card_of_FVars_bounds quot @ 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); @@ -1305,7 +1334,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ops = [#T quot], var_class = hd (MRBNF_Def.class_of_mrbnf mrbnf), leader = 0, - frees = [frees], + frees = [frees @ pfrees], lives = [[]], lives' = [[]], deads = [[]], @@ -1317,7 +1346,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe Injs = [Injs], Sbs = [fst tvsubst], RVrs = [[]], - Vrs = [#FVarss quot], + Vrs = [Vrs], extra_Vrs = [[]], params = [NONE] }, @@ -1372,7 +1401,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe @ @{map 4} (fn FVars => fn s1 => fn s2 => fn s3 => Term.abs ("t", #T quot) (foldl1 mk_Un [ FVars $ (Term.list_comb (fst tvsubst, rhos) $ Bound 0), s1, s2, s3 - ])) (#FVarss quot) (mk_avoiding_sets rhos) (mk_avoiding_sets rhos') (mk_avoiding_sets ( + ])) (#FVarss quot) (take nvars (mk_avoiding_sets rhos)) (take nvars (mk_avoiding_sets rhos')) (take nvars (mk_avoiding_sets ( map (fn rho => let val idx = find_index (curry (op=) (body_type (fastype_of rho))) ops; @@ -1381,7 +1410,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe (fst (split_last (binder_types (fastype_of Sb)))); in HOLogic.mk_comp (Term.list_comb (Sb, rhos'), rho) end ) rhos - )) + ))) ) @ [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))); @@ -1532,11 +1561,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt refl ])) defs) ], - Vrs_bds = replicate nvars (fn ctxt => resolve_tac ctxt (#card_of_FVars_bounds quot) 1), - Vrs_Injss = replicate nvars (map_filter (Option.map (fn def => fn ctxt => + Vrs_bds = replicate (length Vrs) (fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf rec_mrbnf) 1), + Vrs_Injss = replicate (length Vrs) (map_filter (Option.map (fn def => fn ctxt => resolve_tac ctxt (maps (the_default []) FVars_Injs) 1 )) defs), - Vrs_Sbs = replicate nvars (fn ctxt => EVERY1 [ + Vrs_Sbs = replicate (length Vrs) (fn ctxt => EVERY1 [ resolve_tac ctxt FVars_tvsubsts, REPEAT_DETERM o assume_tac ctxt ]), @@ -1548,8 +1577,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe in EVERY1 [ Method.insert_tac ctxt (drop (2 * length rho_prems') prems), K (Local_Defs.unfold0_tac ctxt @{thms atomize_all atomize_imp}), - rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) - (map2 (curry mk_Un) (mk_avoiding_sets rhos) (mk_avoiding_sets rhos')) + DETERM o rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt) + (take nvars (map2 (curry mk_Un) (mk_avoiding_sets rhos) (mk_avoiding_sets rhos'))) @ [NONE, SOME (Thm.cterm_of ctxt t)] ) fresh_induct), REPEAT_DETERM_N nvars o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ @@ -1580,7 +1609,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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)) + 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}), rtac ctxt (arg_cong OF [MRBNF_Def.map_cong0_of_mrbnf mrbnf]), @@ -1589,7 +1622,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rotate_tac ~1, etac ctxt @{thm distinct_prems_rl[rotated]}, eresolve_tac ctxt inner_prems, - REPEAT_DETERM_N nvars o (EVERY' [ + REPEAT_DETERM_N (length Vrs) o (EVERY' [ rtac ctxt @{thm case_split[of "_ \ _", rotated]}, resolve_tac ctxt inner_prems, eresolve_tac ctxt (flat (#FVars_intross quot)), @@ -1606,8 +1639,19 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe etac ctxt @{thm notin_SSupp} ] ORELSE' EVERY' [ resolve_tac ctxt inner_prems, - eresolve_tac ctxt (flat (#FVars_intross quot)), - assume_tac ctxt + 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} + ] + ] ]) ], EVERY' (map_filter (Option.map (fn def => EVERY' [ @@ -1638,8 +1682,6 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe map (fn (n, (s, T)) => (TVar (n, s), T)) (Vartab.dest tyenv) )) rec_mrbnf end; - val rec_bmv_facts = BMV_Monad_Def.leader BMV_Monad_Def.facts_of_bmv_monad bmv; - val (rec_mrsbnf, lthy) = MRSBNF_Def.mrsbnf_def (K BNF_Def.Dont_Note) qualify NONE (rec_mrbnf :: tl (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf)) rec_bmv (map (fn i => if i <> 0 then @@ -1660,7 +1702,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt ext, Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, ...} => let val (fs, t) = split_last (map (Thm.term_of o snd) params); - in rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt o mk_imsupp) fs @ + in 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, @@ -1750,7 +1792,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ])) defs) ], set_Sb = [], - set_Vrs = replicate nvars (fn ctxt => rtac ctxt refl 1) + set_Vrs = replicate (length Vrs) (fn ctxt => rtac ctxt refl 1) }) (0 upto length ops - 1)) lthy; val tvsubst_permutes = @@ -1770,11 +1812,18 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe HOLogic.mk_comp (Term.list_comb (#permute quot, fs), Term.list_comb (fst tvsubst, map_filter I rhos)), HOLogic.mk_comp ( Term.list_comb (fst tvsubst, map_filter (Option.map (fn rho => - HOLogic.mk_comp (HOLogic.mk_comp ( - let val permute = the (List.find (fn perm => body_type (fastype_of perm) = body_type (fastype_of rho)) permutes); - in Term.list_comb (permute, map (fn T => the (List.find (curry (op=) T o fastype_of) fs)) (fst (split_last (binder_types (fastype_of permute))))) end, - rho - ), mk_inv (the (List.find (fn f => domain_type (fastype_of rho) = domain_type (fastype_of f)) fs))) + 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) fs) + ) (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 f => domain_type (fastype_of rho) = domain_type (fastype_of f)) fs of + SOME f => HOLogic.mk_comp (inner, mk_inv f) + | _ => inner + end )) rhos), Term.list_comb (#permute quot, fs) ) @@ -1784,8 +1833,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 prems + 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 = { diff --git a/case_studies/Pi_Calculus/Commitment.thy b/case_studies/Pi_Calculus/Commitment.thy index 207e2171..530166e8 100644 --- a/case_studies/Pi_Calculus/Commitment.thy +++ b/case_studies/Pi_Calculus/Commitment.thy @@ -108,6 +108,7 @@ local_setup \Binder_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"), diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 6001ddbc..97e20bb1 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -1543,7 +1543,7 @@ 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 { + 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 = { From 2269cde7563d967d5705fd49fbb3cf5dc02dc9b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 18 Nov 2025 18:01:35 +0000 Subject: [PATCH 86/90] Fully support passive position (incl bound and live) --- Tools/bmv_monad_def.ML | 63 +- Tools/mrbnf_sugar.ML | 21 +- Tools/mrsbnf_comp.ML | 10 +- Tools/mrsbnf_def.ML | 58 +- Tools/tvsubst.ML | 1223 +++++++++++++++++++++++++++--------- tests/Regression_Tests.thy | 16 +- thys/MRBNF_Recursor.thy | 3 + thys/Support.thy | 11 + 8 files changed, 1052 insertions(+), 353 deletions(-) diff --git a/Tools/bmv_monad_def.ML b/Tools/bmv_monad_def.ML index 559f115d..0933b38f 100644 --- a/Tools/bmv_monad_def.ML +++ b/Tools/bmv_monad_def.ML @@ -120,7 +120,7 @@ signature BMV_MONAD_DEF = sig -> { 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 -> typ list -> bmv_monad + 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 @@ -505,7 +505,7 @@ fun mk_bmv_monad_axioms ops consts bmv_ops lthy = ) (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), foldr1 mk_Un ((mk_image f $ (RVr $ x)) :: UNs) + 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 => @@ -2106,17 +2106,30 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = 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 tys, NoSyn) + | 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) o HOLogic.dest_setT o body_type o fastype_of) (leader RVrs_of_bmv_monad bmv)) + |> 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" (the_default [] (Option.map (fst o split_last o binder_types o fastype_of) (leader Maps_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 @@ -2127,9 +2140,12 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt 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, - fs @ map (fn rho => if body_type (fastype_of rho) = T then HOLogic.mk_comp (rep, rho) else rho) rhos + 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 RVrs => HOLogic.mk_comp (RVrs, rep)) (leader RVrs_of_bmv_monad bmv)) + ||>> 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)) @@ -2142,9 +2158,13 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt 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, gs)), rep) + 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 Supp => HOLogic.mk_comp (Supp, rep)) (the (leader Supps_of_bmv_monad bmv))) + ||>> 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; @@ -2188,10 +2208,10 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = 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 = [leader frees_of_bmv_monad bmv], - lives = [leader lives_of_bmv_monad bmv], - lives' = [leader lives'_of_bmv_monad bmv], - deads = [map TFree (rev (fold Term.add_tfreesT (leader deads_of_bmv_monad bmv) []))], + frees = [frees], + lives = [lives], + lives' = [lives'], + deads = [deads], consts = consts, leader = 0, params = [Option.map (fn Supps => { @@ -2255,13 +2275,13 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = rtac ctxt refl ]) Supps, Vrs_Map = map (fn _ => fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ([ + 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 (#Vrs_Map (the params)) + 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 [ @@ -2308,7 +2328,8 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ], 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 (#Vrs_bds axioms) + 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 [ @@ -2317,15 +2338,17 @@ fun seal_bmv_monad qualify unfolds name tys bmv info_opt lthy = ]) ) Injs)) (RVrs @ Vrs @ extra_Vrs), Vrs_Sbs = map (K (fn ctxt => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt ([ + 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)), - rtac ctxt trans, - resolve_tac ctxt (#Vrs_Sbs axioms) THEN_ALL_NEW assume_tac ctxt, - K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + 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 [ diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index 957d5d0e..e3755ab6 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -876,6 +876,7 @@ fun create_binder_datatype co (spec : spec) lthy = 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}] @@ -1121,7 +1122,6 @@ fun create_binder_datatype co (spec : spec) lthy = val (lthy, tvsubst_opt) = if not (null (map_filter I (#etas tvsubst_model))) andalso not co then let - val _ = @{print} "before tvsubst" val recursor_result = #recursor_result (the vvsubst_res_opt); val rec_mrbnf = #rec_mrbnf (the vvsubst_res_opt); val vvsubst_res = #vvsubst_res (the vvsubst_res_opt); @@ -1130,8 +1130,6 @@ fun create_binder_datatype co (spec : spec) lthy = 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 _ = @{print} "after tvsubst" - 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; @@ -1153,24 +1151,25 @@ fun create_binder_datatype co (spec : spec) lthy = 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, _) = lthy - |> mk_Frees "f" (map fastype_of Injs); + 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 + 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 _ = + 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 Vrs = nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) ( - find_index (curry (op=) (body_type (fastype_of Inj))) (BMV_Monad_Def.ops_of_bmv_monad bmv) - ); + 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 @@ -1228,7 +1227,7 @@ fun create_binder_datatype co (spec : spec) lthy = ] ]; in map (Local_Defs.unfold0 lthy bmv_unfolds) ( - mk_map_simps lthy false true Sbs plives fs mk_supp_bound mk_imsupp (K []) [] (#tvsubst tvsubst_res) tac + 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); diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index b60a2122..577f9db2 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -61,6 +61,7 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt 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'; @@ -87,9 +88,14 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt (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 [] bmv (SOME info) lthy; + ) 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); @@ -178,7 +184,7 @@ fun seal_mrsbnf qualify (bmv_unfolds, mrbnf_unfolds) name Xs tys mrsbnf info_opt K (Local_Defs.unfold0_tac ctxt @{thms comp_def}), rtac ctxt refl ] - ])) (#set_Vrs axioms) + ])) frees } ) (MRSBNF_Def.axioms_of_mrsbnf mrsbnf)) lthy; in ((mrsbnf, (snd (dest_Type T), absT_info)), lthy) end diff --git a/Tools/mrsbnf_def.ML b/Tools/mrsbnf_def.ML index b86d9e76..02ef16c2 100644 --- a/Tools/mrsbnf_def.ML +++ b/Tools/mrsbnf_def.ML @@ -14,6 +14,7 @@ signature MRSBNF_DEF = sig 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, @@ -88,6 +89,7 @@ type mrsbnf_facts = { 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, @@ -96,12 +98,13 @@ type mrsbnf_facts = { 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_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, @@ -167,6 +170,7 @@ fun note_mrsbnf_thms fact_policy qualify name_opt mrsbnf lthy = ("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, []), @@ -238,7 +242,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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) (live_fs @ map mk_id live_fs)) ( + 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) @@ -252,8 +256,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b in EVERY' [ rtac ctxt (trans OF [thm]), REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ prems), - rtac ctxt trans, - resolve_tac ctxt map_Injs, + EqSubst.eqsubst_tac ctxt [0] map_Injs, REPEAT_DETERM o resolve_tac ctxt prems ] end, rtac ctxt (#map_is_Sb axioms RS fun_cong), @@ -616,7 +619,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b (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 + MRBNF_Def.free_of_mrbnf mrbnf - free; + 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'); @@ -836,6 +839,7 @@ fun mk_mrsbnf fact_policy qualify (deads, As, As', Bs, Fs, fs) name_opt mrbnfs b 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, @@ -863,12 +867,23 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val lmrbnf = nth mrbnfs l; val ldeads = distinct (op=) (filter_out Term.is_Type (MRBNF_Def.deads_of_mrbnf lmrbnf)); - val (((((Fs, Bs), As), As'), deads), names_lthy) = 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 (MRBNF_Def.live_of_mrbnf lmrbnf) - ||>> mk_TFrees' (map Type.sort_of_atyp ldeads); + 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)); @@ -895,7 +910,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val bmv = BMV_Monad_Def.morph_bmv_monad (the_default subst_phi phi) bmv; end - val axioms = @{map 7} (fn mrbnf => fn Sb => fn Injs => fn RVrs => fn Vrs => fn Map_opt => fn lives => + 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; @@ -954,17 +969,14 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = val other_fs = flat (MRBNF_Def.interlace (map single live_fs) (map single bound_fs) (replicate (length free_fs') []) var_types); - val g_prems = map2 (fn Inj => fn g => HOLogic.mk_Trueprop (uncurry mk_ordLess ( - mk_card_of (mk_SSupp Inj $ g), mk_card_of (HOLogic.mk_UNIV (domain_type (fastype_of g))) - ))) Injs gs; - val h_prems = map (HOLogic.mk_Trueprop o mk_supp_bound) hs; + val g_prems = flat (BMV_Monad_Def.mk_small_prems_of_bmv_monad bmv i hs gs); - val count = live + MRBNF_Def.free_of_mrbnf mrbnf + MRBNF_Def.bound_of_mrbnf mrbnf; - val map_Sb = if count - free = 0 then NONE else + 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 @ h_prems @ g_prems) (mk_Trueprop_eq ( + 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 @@ -991,7 +1003,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = 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) (h_prems @ g_prems) ( + 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))) ( @@ -1011,7 +1023,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = [] => mk_bot aT | _ => foldl1 mk_Un Vrs' )) end - ) (take free free_sets); + ) 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 @@ -1030,7 +1042,7 @@ fun mk_mrsbnf_axioms mrbnfs bmv lthy = map_Sb = map_Sb, set_Sb = set_Sbs }: term mrsbnf_axioms end - ) mrbnfs + ) (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); @@ -1199,4 +1211,4 @@ 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 \ No newline at end of file +end diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index c802aba2..e6678599 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -145,6 +145,8 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m ); 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] @@ -165,12 +167,20 @@ fun prove_model_axioms fp_res' mrsbnf' (models : (Proof.context -> tactic) eta_m 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 @ [a, x]) (fold_rev (curry Logic.mk_implies) g_prems (Logic.mk_implies ( + 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)) - $ the_default I (Option.map (fn Map => fn t => Term.list_comb (Map, live_fs) $ t) - (BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv) + $ (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 ), @@ -362,10 +372,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe )) Inj_injs defs; val nvars = length frees; - val ((fs, some_rhos), _) = lthy + 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); @@ -615,21 +627,29 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val not_isInj_Sb = map (Option.map (fn def => let - val ((((fs, rhos), hs), x), _) = lthy + 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 "h" (replicate nrecs (#T quot --> #T quot)) + ||>> 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 goal = Logic.mk_implies (apply2 ( - fn x => HOLogic.mk_Trueprop (HOLogic.mk_not (fst (#isInj def) $ (#ctor quot $ x))) - ) (x, Term.list_comb (BMV_Monad_Def.leader BMV_Monad_Def.Sbs_of_bmv_monad bmv, fs @ rhos) $ ( - Term.list_comb (the (BMV_Monad_Def.leader BMV_Monad_Def.Maps_of_bmv_monad bmv), hs) $ x + 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 @ hs @ [x])) prems goal (fn {context=ctxt, prems} => EVERY1 [ + 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, @@ -638,12 +658,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 (BMV_Monad_Def.leader BMV_Monad_Def.deads_of_bmv_monad bmv)) - (map HOLogic.id_const plives @ map (fn xs => if null xs then HOLogic.id_const (#T quot) else + 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) + ) 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, @@ -664,11 +684,21 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ]) 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)) (map_filter I rhos)) 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' = maps (map_filter (Option.map (fn IImsupp => + val rho_prems' = rf_prems @ maps (map_filter (Option.map (fn IImsupp => let val A = case IImsupp of Const (@{const_name sup}, _) $ t $ _ => t @@ -686,8 +716,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val rho_prems = Proof_Context.get_thms lthy "f_prems"; - val avoiding_sets = map2 (fn free => - the_default (mk_bot free) o try (foldl1 mk_Un) o map_filter I + 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; @@ -708,7 +741,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 (HOLogic.id_const o HOLogic.dest_setT o body_type o fastype_of) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_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) ); @@ -741,7 +779,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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} @ rho_prems + 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 ), @@ -749,7 +788,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ])), 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}) + 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} @@ -761,7 +800,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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}) + 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}, @@ -778,6 +817,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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}, @@ -793,51 +833,71 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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)), - 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} - @ [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, REPEAT_DETERM o EVERY' [ - 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' [ + 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 subsetI}, - REPEAT_DETERM o FIRST' [ - assume_tac ctxt, - eresolve_tac ctxt @{thms UnI1 UnI2}, - rtac ctxt @{thm UnI1} + 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' (map (fn tac => DETERM o tac) [ + 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, - etac ctxt @{thm subst[OF sym]}, + 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 _ _ "(\)"]]}, @@ -846,17 +906,16 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt @{thm Un_upper1}, rtac ctxt @{thm subsetI}, rtac ctxt @{thm UnI2}, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def SSupp_def Un_assoc[symmetric]}), + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_assoc[symmetric]}), REPEAT_DETERM o FIRST' [ EVERY' [ TRY o rtac ctxt @{thm UnI2}, - rtac ctxt @{thm UN_I}, - etac ctxt @{thm CollectI}, + etac ctxt @{thm in_IImsupp[rotated]}, assume_tac ctxt ], rtac ctxt @{thm UnI1} ] - ]))) defs), + ])) 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 @@ -865,7 +924,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 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' [ @@ -874,29 +933,43 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ], REPEAT_DETERM o rtac ctxt @{thm Un_mono'}, SELECT_GOAL (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), - 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), + 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}), - rtac ctxt @{thm Un_upper1} ORELSE' 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} + 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} ], - 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 + 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' [ @@ -928,17 +1001,23 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ); val int_empty_prems = map2 (fn bset => fn avoiding_set => HOLogic.mk_Trueprop ( mk_int_empty (bset $ x, avoiding_set) - )) bound_sets (take nvars avoiding_sets); + )) (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 (HOLogic.id_const o HOLogic.dest_setT o body_type o fastype_of) (BMV_Monad_Def.leader BMV_Monad_Def.RVrs_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))); @@ -949,7 +1028,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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} + 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]} @@ -972,7 +1051,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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} + 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]} @@ -988,10 +1067,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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}), + 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 (#eta_free (#axioms def) :: maps (the_default []) eta_set_emptiess)), + 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} @@ -1024,35 +1105,6 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe val tvsubst_not_isInj = Morphism.thm phi tvsubst_not_isInj; val tvsubst_Injs = map (Option.map (Morphism.thm phi)) tvsubst_Injs; - 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 in_IImsuppss = map (Option.map (fn def => map (fn FVars => - 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 quot); - val goal = Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq ( - f $ a, fst (#Inj def) $ a - ))), - Logic.mk_implies ( - HOLogic.mk_Trueprop (HOLogic.mk_mem (z, FVars $ (f $ a))), - HOLogic.mk_Trueprop (HOLogic.mk_mem (z, mk_IImsupp (fst (#Inj def)) FVars $ f)) - ) - ); - in Goal.prove_sorry lthy (names [f, a, z]) [] goal (fn {context=ctxt, ...} => EVERY1 [ - K (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def SSupp_def}), - rtac ctxt @{thm UN_I}, - etac ctxt @{thm CollectI}, - assume_tac ctxt - ]) end - ) Vrs)) defs; - val FVars_Injs = map (Option.map (fn def => map (fn FVars => let val a = Free ("a", #aT def); @@ -1065,9 +1117,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe K (Local_Defs.unfold0_tac ctxt (no_reflexive (#set_Vrs mrsbnf_axioms))), resolve_tac ctxt [refl, #eta_free (#axioms def)] ]) end - ) Vrs)) defs; + ) rec_sets)) defs; - val IImsupp_Diffs = @{map 3} (fn rho => fn avoiding_set => Option.map (fn def => map (fn FVars => + 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)); @@ -1077,12 +1129,13 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 SOME [HOLogic.mk_Trueprop ( - mk_int_empty (B2, the (List.find (curry (op=) (fastype_of B2) o fastype_of) avoiding_sets)) - )]) + :: 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, - HOLogic.mk_binop @{const_name minus} (mk_UNION A inner, B2) + 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 [ @@ -1093,45 +1146,44 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 (maps (the_default []) 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, + 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, - assume_tac ctxt - ], - DETERM o forward_tac ctxt (map (Drule.rotate_prems 1) (maps (the_default []) in_IImsuppss)), - 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}, - SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + 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, - eresolve_tac ctxt @{thms UnI1 UnI2}, + 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} - ])) - ] else etac ctxt @{thm disjoint_iff[THEN iffD1, THEN spec, THEN mp, OF trans[OF Int_commute]]} + ] + ] ] in EVERY' [ helper_tac false, helper_tac true - ] end, - SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms SSupp_def IImsupp_def}), - rtac ctxt @{thm UnI1}, - rtac ctxt @{thm CollectI}, - assume_tac ctxt, - assume_tac ctxt + ] end ]) end - ) Vrs)) rhos avoiding_sets defs; + ) rec_sets)) rhos avoiding_sets FVars_Injs defs; val netas = length (map_filter I defs); @@ -1169,30 +1221,39 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe | _ => error "only works for datatypes" val fresh_induct = #fresh_induct fp_thms; - (* needs to account for vars that are not injections on RHS *) + 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 Vrs_orig = Vrs; 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 Vrs_orig else nth (BMV_Monad_Def.Vrs_of_bmv_monad bmv) idx; + 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))) Vrs; + ) (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, map_filter I rhos) $ t), - foldl1 mk_Un rhss + FVars $ (Term.list_comb (fst tvsubst, rfs @ map_filter I rhos) $ t), + foldl1 mk_Un (rhs' @ rhss) ); - in Goal.prove_sorry lthy (names (map_filter I rhos @ [t])) rho_prems' goal (fn {context=ctxt, prems} => EVERY1 [ + 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} @ prems + 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 + @ #card_of_FVars_bound_UNIVs quot @ rho_prems ), CHANGED o SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms IImsupp_def}) ])), @@ -1206,51 +1267,54 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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) @ [the (#Map_map mrsbnf_facts) RS sym] + @ 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] )), - K (print_tac ctxt "1"), - rtac ctxt (mk_Un_cong (nrecs + 1) (length rhss)), - K (print_tac ctxt "1.0"), + 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] (@{print}(map_filter (Option.map (#eta_compl_free o #axioms)) defs)), - K (print_tac ctxt "1.1"), + 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}, - K (print_tac ctxt "1.2"), 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, - K (print_tac ctxt "1.3"), rtac ctxt exI, - rtac ctxt refl, - K (print_tac ctxt "1.35") + 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} + REPEAT_DETERM o resolve_tac ctxt (@{thms supp_id_bound bij_id} @ rho_prems) ], K (Local_Defs.unfold0_tac ctxt (@{thms image_id})), - K (print_tac ctxt "1.4"), rtac ctxt refl, rtac ctxt trans, - K (print_tac ctxt "1.5"), TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, - K (print_tac ctxt "1.6"), rtac ctxt @{thm UN_cong}, Goal.assume_rule_tac ctxt, - K (print_tac ctxt "2"), + 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' [ @@ -1270,20 +1334,15 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt @{thm Int_empty_left} ] ], - K (print_tac ctxt "3"), K (Local_Defs.unfold0_tac ctxt @{thms Un_Diff[symmetric] Diff_empty}), - K (print_tac ctxt "3.1"), TRY o rtac ctxt @{thm arg_cong2[OF _ refl, of _ _ "minus"]}, - K (print_tac ctxt "3.2"), - K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib[symmetric]}), - K (print_tac ctxt "3.3"), + K (Local_Defs.unfold0_tac ctxt @{thms UN_UN_flatten UN_Un_distrib Union_UN_swap}), rtac ctxt refl, - K (print_tac ctxt "3.4"), + 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 ], - K (print_tac ctxt "4"), EVERY' (map_filter (Option.map (fn def => EVERY' [ K (Local_Defs.unfold0_tac ctxt [snd (#isInj def)]), etac ctxt exE, @@ -1291,43 +1350,462 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 Un_empty_left Un_empty_right} + 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 )), - K (print_tac ctxt "5"), rtac ctxt refl - ])) (rev defs)), - K (print_tac ctxt "end") + ])) (rev defs)) ]) end - ) Vrs; + ) free_sets; - val _ = @{print} ("FVars_tvsubsts", FVars_tvsubsts) - - val some_rhos = map_filter I rhos; val SSupp_tvsubst_subsets = BMV_Monad_Tactics.mk_SSupp_Sb_subsets (#T quot) Injs rho_prems' (fst tvsubst) - [] some_rhos (map_filter I tvsubst_Injs) lthy; + 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) [] some_rhos rho_prems' SSupp_tvsubst_subsets + Injs (fst tvsubst) rfs some_rhos rho_prems' SSupp_tvsubst_subsets (MRBNF_Def.UNIV_cinfinite_of_mrbnf mrbnf) lthy; - 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 IImsupp_Sb_subsetss = BMV_Monad_Tactics.mk_IImsupp_Sb_subsetss (#T quot) ops - (fst tvsubst) rho_prems' ([] :: tl (BMV_Monad_Def.RVrs_of_bmv_monad bmv)) + (fst tvsubst) rho_prems' (RVrs :: tl (BMV_Monad_Def.RVrs_of_bmv_monad bmv)) (Vrs :: tl (BMV_Monad_Def.Vrs_of_bmv_monad bmv)) - Vrs Injs [] some_rhos SSupp_tvsubst_subsets + (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 Vrs [] some_rhos rho_prems' IImsupp_Sb_subsetss - (#card_of_FVars_bounds quot @ maps #Vrs_bds (BMV_Monad_Def.axioms_of_bmv_monad bmv)) lthy; + (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 = map (Term.subst_atomic (some_rhos ~~ rhos)) avoiding_sets; + 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 { @@ -1335,9 +1813,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe var_class = hd (MRBNF_Def.class_of_mrbnf mrbnf), leader = 0, frees = [frees @ pfrees], - lives = [[]], - lives' = [[]], - deads = [[]], + 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), @@ -1345,16 +1823,66 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe bd = MRBNF_Def.bd_of_mrbnf mrbnf, Injs = [Injs], Sbs = [fst tvsubst], - RVrs = [[]], + RVrs = [RVrs], Vrs = [Vrs], extra_Vrs = [[]], - params = [NONE] + 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 = [NONE], + 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})), @@ -1363,8 +1891,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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}, - K (Local_Defs.unfold0_tac ctxt (@{thms SSupp_Inj IImsupp_def UN_empty UN_empty2 Un_empty_left Un_empty_right} @ [snd (#noclash quot)])), + 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 ]), @@ -1378,10 +1906,10 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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} - ])) defs) + 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 def => fn ctxt => EVERY1 [ + 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), @@ -1392,25 +1920,27 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt @{thm trans[OF comp_apply]}, Subgoal.FOCUS_PARAMS (fn {context=ctxt, params, concl, ...} => let - val ((rhos', rhos), x) = map (Thm.term_of o snd) params - |> chop (length some_rhos) + 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, rhos) $ Bound 0), + FVars $ (Term.list_comb (fst tvsubst, rfs @ rhos) $ Bound 0), s1, s2, s3 - ])) (#FVarss quot) (take nvars (mk_avoiding_sets rhos)) (take nvars (mk_avoiding_sets rhos')) (take nvars (mk_avoiding_sets ( + ])) (#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) rhos')) + 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))); @@ -1421,11 +1951,12 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe Term.subst_atomic [(hd x, Bound 1)] concl ))) ))] (Local_Defs.unfold0 ctxt @{thms ball_UNIV} thm RS spec); - in rtac ctxt (thm RS @{thm mp[OF _ refl]}) 1 end + 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} + 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 @@ -1435,7 +1966,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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 ~1 tvsubst_not_isInj], + 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}, @@ -1448,10 +1979,11 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ], assume_tac ctxt, rtac ctxt trans, - rtac ctxt (Drule.rotate_prems ~1 tvsubst_not_isInj), - SELECT_GOAL (Local_Defs.unfold0_tac ctxt [the (#Map_map mrsbnf_facts) RS sym]), - eresolve_tac ctxt (map_filter (Option.map (Drule.rotate_prems ~1)) not_isInj_Sb), - REPEAT_DETERM o (assume_tac ctxt ORELSE' rtac ctxt @{thm supp_id_bound}), + 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}), @@ -1489,8 +2021,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe rtac ctxt @{thm UnI1} ])) ], - assume_tac ctxt, - assume_tac ctxt, + 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), @@ -1509,7 +2040,8 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe EqSubst.eqsubst_tac ctxt [0] [tvsubst_not_isInj], REPEAT_DETERM o FIRST' [ assume_tac ctxt, - resolve_tac ctxt (SSupp_tvsubst_bounds @ flat IImsupp_Sb_boundss + 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) ) ], @@ -1517,8 +2049,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe etac ctxt @{thm Int_subset_empty2}, rtac ctxt @{thm Un_upper2} ], - assume_tac ctxt, - assume_tac ctxt, + 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)], @@ -1553,37 +2084,40 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe EqSubst.eqsubst_tac ctxt [0] (map_filter I tvsubst_Injs), REPEAT_DETERM o FIRST' [ assume_tac ctxt, - resolve_tac ctxt (SSupp_tvsubst_bounds @ flat IImsupp_Sb_boundss + 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 - ])) defs) + ])) (rev defs)) ], - Vrs_bds = replicate (length Vrs) (fn ctxt => resolve_tac ctxt (MRBNF_Def.set_bd_of_mrbnf rec_mrbnf) 1), - Vrs_Injss = replicate (length Vrs) (map_filter (Option.map (fn def => fn ctxt => + 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 Vrs) (fn ctxt => EVERY1 [ + 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 ((rhos, rhos'), t) = map (Thm.term_of o snd) params - |> chop (length some_rhos) - ||>> apsnd hd o chop (length some_rhos) + 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) (mk_avoiding_sets rhos'))) + (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} + 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 ), @@ -1600,7 +2134,7 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe etac ctxt @{thm Int_subset_empty2}, resolve_tac ctxt @{thms Un_upper1 Un_upper2} ], - assume_tac ctxt + REPEAT_DETERM1 o assume_tac ctxt ], rtac ctxt (mk_arg_cong lthy 1 (#ctor quot)), rtac ctxt trans, @@ -1616,13 +2150,13 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ] ], REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id refl}), - rtac ctxt (arg_cong OF [MRBNF_Def.map_cong0_of_mrbnf mrbnf]), + 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) o (EVERY' [ + 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)), @@ -1634,9 +2168,9 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms Un_iff de_Morgan_disj}), REPEAT_DETERM o etac ctxt conjE, rtac ctxt trans, - etac ctxt @{thm notin_SSupp}, + eresolve_tac ctxt @{thms notin_SSupp notin_imsupp}, rtac ctxt sym, - etac ctxt @{thm notin_SSupp} + eresolve_tac ctxt @{thms notin_SSupp notin_imsupp} ] ORELSE' EVERY' [ resolve_tac ctxt inner_prems, EVERY' [ @@ -1654,6 +2188,20 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe ] ]) ], + 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, @@ -1674,16 +2222,59 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe }] } [] (*TODO: Put definitions here *) lthy; - val rec_mrbnf = + val _ = @{print} rec_bmv + + val isInj_Map = if null plives then [] else map (Option.map (fn def => 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 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 - (rec_mrbnf :: tl (MRSBNF_Def.mrbnfs_of_mrsbnf mrsbnf)) rec_bmv + 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 { @@ -1696,36 +2287,78 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe set_Vrs = map (fn thm => fn ctxt => rtac ctxt thm 1) (#set_Vrs axioms) } end else { - map_Injs = NONE, - map_Sb = NONE, + 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 rtac ctxt (infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt o mk_imsupp) (take nvars fs) @ + 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 + ) 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' + nvars + 1) o SELECT_GOAL (REPEAT_DETERM (FIRST1 [ + 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} @ maps (the_default []) FVars_Injs + 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 IImsupp_def comp_apply UN_empty2 Un_empty_left Un_empty_right} + 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, + REPEAT_DETERM o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms supp_id_bound bij_id}), rtac ctxt sym, SUBGOAL (fn (t, i) => let @@ -1751,10 +2384,16 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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))), + 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} @@ -1765,8 +2404,17 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe 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, @@ -1778,21 +2426,15 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe @ maps (flat o #Vrs_Injss) (BMV_Monad_Def.axioms_of_bmv_monad rec_bmv) ) ])), - REPEAT_DETERM o EqSubst.eqsubst_tac ctxt [0] (@{thms comp_apply} @ [snd (#Inj def)]), - rtac ctxt sym, - rtac ctxt trans, - rtac ctxt vvsubst_ctor, - REPEAT_DETERM o assume_tac ctxt, - REPEAT_DETERM o EVERY' [ - SELECT_GOAL (Local_Defs.unfold0_tac ctxt (snd (#noclash quot) :: maps (the_default []) eta_set_emptiess)), - REPEAT_DETERM1 o resolve_tac ctxt @{thms Int_empty_left conjI} - ], - rtac ctxt (arg_cong OF [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}) - ])) defs) + SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms comp_def}), + rtac ctxt refl + ])) (rev defs)) ], - set_Sb = [], - set_Vrs = replicate (length Vrs) (fn ctxt => rtac ctxt refl 1) + 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 = @@ -1809,26 +2451,29 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe )) rhos; val goal = mk_Trueprop_eq ( - HOLogic.mk_comp (Term.list_comb (#permute quot, fs), Term.list_comb (fst tvsubst, map_filter I rhos)), + 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_filter (Option.map (fn rho => + 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) fs) + (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 f => domain_type (fastype_of rho) = domain_type (fastype_of f)) fs of - SOME f => HOLogic.mk_comp (inner, mk_inv f) + 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, fs) + Term.list_comb (#permute quot, gs) ) ); - in Goal.prove_sorry lthy (names (fs @ map_filter I rhos)) (f_prems @ rho_prems') goal (fn {context=ctxt, prems} => EVERY1 [ + 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 diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index 5cddf926..fff75d01 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -1,7 +1,7 @@ theory Regression_Tests imports "Binders.MRBNF_Recursor" "../thys/LetRec/DAList_MRBNF" "HOL-Library.FSet" begin -(* + (* #68 *) binder_datatype 'a trm = Var 'a @@ -24,21 +24,19 @@ binder_datatype ('tv, 'ev, 'rv) type_scheme = binder_datatype ('tv, 'ev, 'rv) type_scheme2 = TAll "(X::'tv) list" \::"('tv, 'ev, 'rv) type_scheme2" binds X in \ | ERAll "(\::'ev) list" "(\::'rv) list" T::"('tv, 'ev, 'rv) type" binds \ \ in T -*) -ML \ -Multithreading.parallel_proofs := 0 -\ +declare [[ML_print_depth=1000]] (* #75 *) binder_datatype ('a, 'b, 'c, 'd) trm3 = Var 'a - (* | Test "'b list" *) | App "('a, 'b, 'c, 'd) trm3" "('a, 'b, 'c, 'd) trm3" | Lam a::'a b::'b c::'c d::'d e::"('a, 'b, 'c, 'd) trm3" binds a b c d in e -(*(* #74 *) +(* #74 *) +(* binder_datatype 'a trm4 = V 'a | Lm x::'a t::"'a trm4" binds x in t binder_datatype 'a foo = Foo 'a | Bind "(x::'a) trm4" t::"'a foo" binds x in t +*) (* #82 *) datatype ('ev, 'rv) aeff = Eff 'ev | Reg 'rv @@ -56,6 +54,7 @@ binder_datatype ('tv, 'ev, 'rv) type_scheme3 = TAll "(X::'tv) list" \::"('tv, 'ev, 'rv) type_scheme3" binds X in \ | ERAll "(\::'ev) list" "(\::'rv) list" T::"('tv, 'ev, 'rv) type2" binds \ \ in T +(* binder_datatype ('v, 'tv, 'ev, 'rv) expr = Var 'v | Int int @@ -66,6 +65,7 @@ binder_datatype ('v, 'tv, 'ev, 'rv) expr = | Assert "('ev, 'rv) constraint" "('v, 'tv, 'ev, 'rv) expr" | Let x::'v "('v, 'tv, 'ev, 'rv) expr" e::"('v, 'tv, 'ev, 'rv) expr" binds x in e | RApp "('v, 'tv, 'ev, 'rv) expr" "'rv list" "('v, 'tv, 'ev, 'rv) expr" +*) (* #86 *) binder_datatype 'a "term" = @@ -96,5 +96,5 @@ lemma fixes x y::"'a::var" and e::"'a term" shows "e = e" by (binder_induction e avoiding: "{x} \ {y}" rule: term.strong_induct) auto -*) + end diff --git a/thys/MRBNF_Recursor.thy b/thys/MRBNF_Recursor.thy index 8f743fa0..31145584 100644 --- a/thys/MRBNF_Recursor.thy +++ b/thys/MRBNF_Recursor.thy @@ -37,6 +37,9 @@ 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\ diff --git a/thys/Support.thy b/thys/Support.thy index f4af1d56..3605e9a7 100644 --- a/thys/Support.thy +++ b/thys/Support.thy @@ -4,6 +4,9 @@ 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 @@ -14,6 +17,11 @@ definition SSupp :: "('a \ 't) \ ('a \ 't) \ 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 @@ -26,6 +34,9 @@ lemma IImsupp_Inj_comp[simp]: "inj Inj \ (\a. FVars (Inj a) 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| Date: Tue, 18 Nov 2025 21:49:56 +0000 Subject: [PATCH 87/90] Fix simp rules for tvsubst --- Tools/mrbnf_sugar.ML | 18 +++++++++++++++++- Tools/tvsubst.ML | 2 -- tests/Regression_Tests.thy | 2 -- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/Tools/mrbnf_sugar.ML b/Tools/mrbnf_sugar.ML index e3755ab6..50c8d996 100644 --- a/Tools/mrbnf_sugar.ML +++ b/Tools/mrbnf_sugar.ML @@ -184,17 +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 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 { @@ -220,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; @@ -1126,6 +1140,8 @@ fun create_binder_datatype co (spec : spec) lthy = 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; @@ -1139,7 +1155,6 @@ fun create_binder_datatype co (spec : spec) lthy = MRSBNF_Def.bmv_monad_of_mrsbnf (#mrsbnf tvsubst_res) ) lthy; - val tvsubst_simps = let val T = range_type (fastype_of quotient_ctor); @@ -1215,6 +1230,7 @@ fun create_binder_datatype co (spec : spec) lthy = )), 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 diff --git a/Tools/tvsubst.ML b/Tools/tvsubst.ML index e6678599..6b7d2c73 100644 --- a/Tools/tvsubst.ML +++ b/Tools/tvsubst.ML @@ -2222,8 +2222,6 @@ fun create_tvsubst_of_mrsbnf qualify fp_res mrsbnf rec_mrbnf vvsubst_ctor map_pe }] } [] (*TODO: Put definitions here *) lthy; - val _ = @{print} rec_bmv - val isInj_Map = if null plives then [] else map (Option.map (fn def => let val t = Free ("t", #T quot); diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index fff75d01..ba06d350 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -54,7 +54,6 @@ binder_datatype ('tv, 'ev, 'rv) type_scheme3 = TAll "(X::'tv) list" \::"('tv, 'ev, 'rv) type_scheme3" binds X in \ | ERAll "(\::'ev) list" "(\::'rv) list" T::"('tv, 'ev, 'rv) type2" binds \ \ in T -(* binder_datatype ('v, 'tv, 'ev, 'rv) expr = Var 'v | Int int @@ -65,7 +64,6 @@ binder_datatype ('v, 'tv, 'ev, 'rv) expr = | Assert "('ev, 'rv) constraint" "('v, 'tv, 'ev, 'rv) expr" | Let x::'v "('v, 'tv, 'ev, 'rv) expr" e::"('v, 'tv, 'ev, 'rv) expr" binds x in e | RApp "('v, 'tv, 'ev, 'rv) expr" "'rv list" "('v, 'tv, 'ev, 'rv) expr" -*) (* #86 *) binder_datatype 'a "term" = From 34e2740d4dfaa242d779594b41580923337d17be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 18 Nov 2025 22:38:24 +0000 Subject: [PATCH 88/90] Implement a basic mrsbnf demotion --- Tools/mrsbnf_comp.ML | 77 +++++++++++++++++++++++++++++++++++++- tests/Regression_Tests.thy | 3 -- 2 files changed, 76 insertions(+), 4 deletions(-) diff --git a/Tools/mrsbnf_comp.ML b/Tools/mrsbnf_comp.ML index 577f9db2..c57e8598 100644 --- a/Tools/mrsbnf_comp.ML +++ b/Tools/mrsbnf_comp.ML @@ -504,6 +504,81 @@ fun compose_mrsbnfs inline_policy fact_policy qualify outer inners oDs Dss oAs A }) 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 @@ -546,7 +621,7 @@ fun mrsbnf_of_typ _ _ qualify Ds0 var_types _ (T as TFree T') (accum:((MRSBNF_De 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 => error "TODO: Demote MRSBNF" + 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 diff --git a/tests/Regression_Tests.thy b/tests/Regression_Tests.thy index ba06d350..5886d146 100644 --- a/tests/Regression_Tests.thy +++ b/tests/Regression_Tests.thy @@ -25,7 +25,6 @@ binder_datatype ('tv, 'ev, 'rv) type_scheme2 = TAll "(X::'tv) list" \::"('tv, 'ev, 'rv) type_scheme2" binds X in \ | ERAll "(\::'ev) list" "(\::'rv) list" T::"('tv, 'ev, 'rv) type" binds \ \ in T -declare [[ML_print_depth=1000]] (* #75 *) binder_datatype ('a, 'b, 'c, 'd) trm3 = Var 'a @@ -33,10 +32,8 @@ binder_datatype ('a, 'b, 'c, 'd) trm3 = | Lam a::'a b::'b c::'c d::'d e::"('a, 'b, 'c, 'd) trm3" binds a b c d in e (* #74 *) -(* binder_datatype 'a trm4 = V 'a | Lm x::'a t::"'a trm4" binds x in t binder_datatype 'a foo = Foo 'a | Bind "(x::'a) trm4" t::"'a foo" binds x in t -*) (* #82 *) datatype ('ev, 'rv) aeff = Eff 'ev | Reg 'rv From ca41e2ee6a8440034e84d32fa5895cf2ff3cd02c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 18 Nov 2025 22:41:45 +0000 Subject: [PATCH 89/90] Adapt operations theory --- operations/BMV_Fixpoint.thy | 6 +----- operations/BMV_Monad.thy | 3 --- 2 files changed, 1 insertion(+), 8 deletions(-) diff --git a/operations/BMV_Fixpoint.thy b/operations/BMV_Fixpoint.thy index 97e20bb1..35aefa6a 100644 --- a/operations/BMV_Fixpoint.thy +++ b/operations/BMV_Fixpoint.thy @@ -10,8 +10,6 @@ type_synonym ('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre' = + '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\" -ML_file \../Tools/mrsbnf_comp.ML\ - local_setup \fn lthy => let val T = @{typ "('tv, 'v, 'btv, 'bv, 'c, 'd) FTerm_pre'"}; @@ -1531,8 +1529,6 @@ lemma FTerm_subst: apply (rule refl) done -ML_file \../Tools/tvsubst.ML\ - local_setup \fn lthy => let @@ -1551,7 +1547,7 @@ val x = TVSubst.create_tvsubst_of_mrsbnf 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[rotated -1]} 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 diff --git a/operations/BMV_Monad.thy b/operations/BMV_Monad.thy index 01375c57..418cd1ab 100644 --- a/operations/BMV_Monad.thy +++ b/operations/BMV_Monad.thy @@ -1,8 +1,5 @@ theory BMV_Monad imports "Binders.MRBNF_Recursor" - keywords "print_pbmv_monads" :: diag and - "pbmv_monad" :: thy_goal and - "mrsbnf" :: thy_goal begin declare [[mrbnf_internals]] From 13b4335ff1c1c9fbdce8a8f5a63b4598ba826016 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20van=20Br=C3=BCgge?= Date: Tue, 18 Nov 2025 22:57:19 +0000 Subject: [PATCH 90/90] Remove quick_and_dirty from operations --- operations/Composition.thy | 3 --- operations/Greatest_Fixpoint.thy | 5 +---- operations/Least_Fixpoint2.thy | 5 +---- 3 files changed, 2 insertions(+), 11 deletions(-) diff --git a/operations/Composition.thy b/operations/Composition.thy index 29b0630e..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 => @@ -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 77cfe51e..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 => @@ -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_Fixpoint2.thy b/operations/Least_Fixpoint2.thy index f90efbcf..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 => @@ -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