renamed "Codatatype" directory "BNF" (and corresponding session) -- this opens the door to no-nonsense session names like "HOL-BNF-LFP"
1.1 --- a/Admin/lib/Tools/update_keywords Fri Sep 21 16:34:40 2012 +0200
1.2 +++ b/Admin/lib/Tools/update_keywords Fri Sep 21 16:45:06 2012 +0200
1.3 @@ -9,7 +9,7 @@
1.4 cd "$ISABELLE_HOME/etc"
1.5
1.6 "$ISABELLE_TOOL" keywords \
1.7 - "$LOG/HOLCF.gz" "$LOG/HOL-Boogie.gz" "$LOG/HOL-Codatatype.gz" "$LOG/HOL-Library.gz" "$LOG/HOL-Nominal.gz" \
1.8 + "$LOG/HOLCF.gz" "$LOG/HOL-BNF.gz" "$LOG/HOL-Boogie.gz" "$LOG/HOL-Library.gz" "$LOG/HOL-Nominal.gz" \
1.9 "$LOG/HOL-Statespace.gz" "$LOG/HOL-SPARK.gz" "$LOG/HOL-TPTP.gz" "$LOG/HOL-Import.gz"
1.10
1.11 "$ISABELLE_TOOL" keywords -k ZF "$LOG/ZF.gz"
2.1 --- a/CONTRIBUTORS Fri Sep 21 16:34:40 2012 +0200
2.2 +++ b/CONTRIBUTORS Fri Sep 21 16:45:06 2012 +0200
2.3 @@ -14,7 +14,7 @@
2.4 Sublist_Order) w.r.t. prefixes, suffixes, and embedding on lists.
2.5
2.6 * August 2012: Dmitriy Traytel, Andrei Popescu, Jasmin Blanchette, TUM
2.7 - New (co)datatype package.
2.8 + New BNF-based (co)datatype package.
2.9
2.10 * August 2012: Andrei Popescu and Dmitriy Traytel, TUM
2.11 Theories of ordinals and cardinals.
3.1 --- a/NEWS Fri Sep 21 16:34:40 2012 +0200
3.2 +++ b/NEWS Fri Sep 21 16:45:06 2012 +0200
3.3 @@ -100,8 +100,9 @@
3.4
3.5 INCOMPATIBILITY.
3.6
3.7 -* HOL/Codatatype: New (co)datatype package with support for mixed,
3.8 -nested recursion and interesting non-free datatypes.
3.9 +* HOL/BNF: New (co)datatype package based on bounded natural
3.10 +functors with support for mixed, nested recursion and interesting
3.11 +non-free datatypes.
3.12
3.13 * HOL/Cardinals: Theories of ordinals and cardinals
3.14 (supersedes the AFP entry "Ordinals_and_Cardinals").
4.1 --- a/etc/isar-keywords.el Fri Sep 21 16:34:40 2012 +0200
4.2 +++ b/etc/isar-keywords.el Fri Sep 21 16:45:06 2012 +0200
4.3 @@ -1,6 +1,6 @@
4.4 ;;
4.5 ;; Keyword classification tables for Isabelle/Isar.
4.6 -;; Generated from HOLCF + HOL-Boogie + HOL-Codatatype + HOL-Library + HOL-Nominal + HOL-Statespace + HOL-SPARK + HOL-TPTP + HOL-Import.
4.7 +;; Generated from HOLCF + HOL-BNF + HOL-Boogie + HOL-Library + HOL-Nominal + HOL-Statespace + HOL-SPARK + HOL-TPTP + HOL-Import.
4.8 ;; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***
4.9 ;;
4.10
5.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2 +++ b/src/HOL/BNF/BNF.thy Fri Sep 21 16:45:06 2012 +0200
5.3 @@ -0,0 +1,16 @@
5.4 +(* Title: HOL/BNF/BNF.thy
5.5 + Author: Dmitriy Traytel, TU Muenchen
5.6 + Author: Andrei Popescu, TU Muenchen
5.7 + Author: Jasmin Blanchette, TU Muenchen
5.8 + Copyright 2012
5.9 +
5.10 +Bounded natural functors for (co)datatypes.
5.11 +*)
5.12 +
5.13 +header {* Bounded Natural Functors for (Co)datatypes *}
5.14 +
5.15 +theory BNF
5.16 +imports More_BNFs
5.17 +begin
5.18 +
5.19 +end
6.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2 +++ b/src/HOL/BNF/BNF_Comp.thy Fri Sep 21 16:45:06 2012 +0200
6.3 @@ -0,0 +1,91 @@
6.4 +(* Title: HOL/BNF/BNF_Comp.thy
6.5 + Author: Dmitriy Traytel, TU Muenchen
6.6 + Copyright 2012
6.7 +
6.8 +Composition of bounded natural functors.
6.9 +*)
6.10 +
6.11 +header {* Composition of Bounded Natural Functors *}
6.12 +
6.13 +theory BNF_Comp
6.14 +imports Basic_BNFs
6.15 +begin
6.16 +
6.17 +lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
6.18 +by (rule ext) simp
6.19 +
6.20 +lemma Union_natural: "Union o image (image f) = image f o Union"
6.21 +by (rule ext) (auto simp only: o_apply)
6.22 +
6.23 +lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
6.24 +by (unfold o_assoc)
6.25 +
6.26 +lemma comp_single_set_bd:
6.27 + assumes fbd_Card_order: "Card_order fbd" and
6.28 + fset_bd: "\<And>x. |fset x| \<le>o fbd" and
6.29 + gset_bd: "\<And>x. |gset x| \<le>o gbd"
6.30 + shows "|\<Union>fset ` gset x| \<le>o gbd *c fbd"
6.31 +apply (subst sym[OF SUP_def])
6.32 +apply (rule ordLeq_transitive)
6.33 +apply (rule card_of_UNION_Sigma)
6.34 +apply (subst SIGMA_CSUM)
6.35 +apply (rule ordLeq_transitive)
6.36 +apply (rule card_of_Csum_Times')
6.37 +apply (rule fbd_Card_order)
6.38 +apply (rule ballI)
6.39 +apply (rule fset_bd)
6.40 +apply (rule ordLeq_transitive)
6.41 +apply (rule cprod_mono1)
6.42 +apply (rule gset_bd)
6.43 +apply (rule ordIso_imp_ordLeq)
6.44 +apply (rule ordIso_refl)
6.45 +apply (rule Card_order_cprod)
6.46 +done
6.47 +
6.48 +lemma Union_image_insert: "\<Union>f ` insert a B = f a \<union> \<Union>f ` B"
6.49 +by simp
6.50 +
6.51 +lemma Union_image_empty: "A \<union> \<Union>f ` {} = A"
6.52 +by simp
6.53 +
6.54 +lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
6.55 +by (rule ext) (auto simp add: collect_def)
6.56 +
6.57 +lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
6.58 +by blast
6.59 +
6.60 +lemma UN_image_subset: "\<Union>f ` g x \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
6.61 +by blast
6.62 +
6.63 +lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>(\<lambda>f. f x) ` X| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
6.64 +by (unfold o_apply collect_def SUP_def)
6.65 +
6.66 +lemma wpull_cong:
6.67 +"\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
6.68 +by simp
6.69 +
6.70 +lemma Id_def': "Id = {(a,b). a = b}"
6.71 +by auto
6.72 +
6.73 +lemma Gr_fst_snd: "(Gr R fst)^-1 O Gr R snd = R"
6.74 +unfolding Gr_def by auto
6.75 +
6.76 +lemma subst_rel_def: "A = B \<Longrightarrow> (Gr A f)^-1 O Gr A g = (Gr B f)^-1 O Gr B g"
6.77 +by simp
6.78 +
6.79 +lemma abs_pred_def: "\<lbrakk>\<And>x y. (x, y) \<in> rel = pred x y\<rbrakk> \<Longrightarrow> rel = Collect (split pred)"
6.80 +by auto
6.81 +
6.82 +lemma Collect_split_cong: "Collect (split pred) = Collect (split pred') \<Longrightarrow> pred = pred'"
6.83 +by blast
6.84 +
6.85 +lemma pred_def_abs: "rel = Collect (split pred) \<Longrightarrow> pred = (\<lambda>x y. (x, y) \<in> rel)"
6.86 +by auto
6.87 +
6.88 +lemma mem_Id_eq_eq: "(\<lambda>x y. (x, y) \<in> Id) = (op =)"
6.89 +by simp
6.90 +
6.91 +ML_file "Tools/bnf_comp_tactics.ML"
6.92 +ML_file "Tools/bnf_comp.ML"
6.93 +
6.94 +end
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/src/HOL/BNF/BNF_Def.thy Fri Sep 21 16:45:06 2012 +0200
7.3 @@ -0,0 +1,151 @@
7.4 +(* Title: HOL/BNF/BNF_Def.thy
7.5 + Author: Dmitriy Traytel, TU Muenchen
7.6 + Copyright 2012
7.7 +
7.8 +Definition of bounded natural functors.
7.9 +*)
7.10 +
7.11 +header {* Definition of Bounded Natural Functors *}
7.12 +
7.13 +theory BNF_Def
7.14 +imports BNF_Util
7.15 +keywords
7.16 + "print_bnfs" :: diag and
7.17 + "bnf_def" :: thy_goal
7.18 +begin
7.19 +
7.20 +lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
7.21 +by (rule ext) (auto simp only: o_apply collect_def)
7.22 +
7.23 +lemma converse_mono:
7.24 +"R1 ^-1 \<subseteq> R2 ^-1 \<longleftrightarrow> R1 \<subseteq> R2"
7.25 +unfolding converse_def by auto
7.26 +
7.27 +lemma converse_shift:
7.28 +"R1 \<subseteq> R2 ^-1 \<Longrightarrow> R1 ^-1 \<subseteq> R2"
7.29 +unfolding converse_def by auto
7.30 +
7.31 +definition convol ("<_ , _>") where
7.32 +"<f , g> \<equiv> %a. (f a, g a)"
7.33 +
7.34 +lemma fst_convol:
7.35 +"fst o <f , g> = f"
7.36 +apply(rule ext)
7.37 +unfolding convol_def by simp
7.38 +
7.39 +lemma snd_convol:
7.40 +"snd o <f , g> = g"
7.41 +apply(rule ext)
7.42 +unfolding convol_def by simp
7.43 +
7.44 +lemma convol_memI:
7.45 +"\<lbrakk>f x = f' x; g x = g' x; P x\<rbrakk> \<Longrightarrow> <f , g> x \<in> {(f' a, g' a) |a. P a}"
7.46 +unfolding convol_def by auto
7.47 +
7.48 +definition csquare where
7.49 +"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
7.50 +
7.51 +(* The pullback of sets *)
7.52 +definition thePull where
7.53 +"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
7.54 +
7.55 +lemma wpull_thePull:
7.56 +"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
7.57 +unfolding wpull_def thePull_def by auto
7.58 +
7.59 +lemma wppull_thePull:
7.60 +assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
7.61 +shows
7.62 +"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
7.63 + j a' \<in> A \<and>
7.64 + e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
7.65 +(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
7.66 +proof(rule bchoice[of ?A' ?phi], default)
7.67 + fix a' assume a': "a' \<in> ?A'"
7.68 + hence "fst a' \<in> B1" unfolding thePull_def by auto
7.69 + moreover
7.70 + from a' have "snd a' \<in> B2" unfolding thePull_def by auto
7.71 + moreover have "f1 (fst a') = f2 (snd a')"
7.72 + using a' unfolding csquare_def thePull_def by auto
7.73 + ultimately show "\<exists> ja'. ?phi a' ja'"
7.74 + using assms unfolding wppull_def by blast
7.75 +qed
7.76 +
7.77 +lemma wpull_wppull:
7.78 +assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
7.79 +1: "\<forall> a' \<in> A'. j a' \<in> A \<and> e1 (p1 (j a')) = e1 (p1' a') \<and> e2 (p2 (j a')) = e2 (p2' a')"
7.80 +shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
7.81 +unfolding wppull_def proof safe
7.82 + fix b1 b2
7.83 + assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
7.84 + then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
7.85 + using wp unfolding wpull_def by blast
7.86 + show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
7.87 + apply (rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
7.88 +qed
7.89 +
7.90 +lemma wppull_id: "\<lbrakk>wpull UNIV UNIV UNIV f1 f2 p1 p2; e1 = id; e2 = id\<rbrakk> \<Longrightarrow>
7.91 + wppull UNIV UNIV UNIV f1 f2 e1 e2 p1 p2"
7.92 +by (erule wpull_wppull) auto
7.93 +
7.94 +lemma Id_alt: "Id = Gr UNIV id"
7.95 +unfolding Gr_def by auto
7.96 +
7.97 +lemma Gr_UNIV_id: "f = id \<Longrightarrow> (Gr UNIV f)^-1 O Gr UNIV f = Gr UNIV f"
7.98 +unfolding Gr_def by auto
7.99 +
7.100 +lemma Gr_mono: "A \<subseteq> B \<Longrightarrow> Gr A f \<subseteq> Gr B f"
7.101 +unfolding Gr_def by auto
7.102 +
7.103 +lemma wpull_Gr:
7.104 +"wpull (Gr A f) A (f ` A) f id fst snd"
7.105 +unfolding wpull_def Gr_def by auto
7.106 +
7.107 +definition "pick_middle P Q a c = (SOME b. (a,b) \<in> P \<and> (b,c) \<in> Q)"
7.108 +
7.109 +lemma pick_middle:
7.110 +"(a,c) \<in> P O Q \<Longrightarrow> (a, pick_middle P Q a c) \<in> P \<and> (pick_middle P Q a c, c) \<in> Q"
7.111 +unfolding pick_middle_def apply(rule someI_ex)
7.112 +using assms unfolding relcomp_def by auto
7.113 +
7.114 +definition fstO where "fstO P Q ac = (fst ac, pick_middle P Q (fst ac) (snd ac))"
7.115 +definition sndO where "sndO P Q ac = (pick_middle P Q (fst ac) (snd ac), snd ac)"
7.116 +
7.117 +lemma fstO_in: "ac \<in> P O Q \<Longrightarrow> fstO P Q ac \<in> P"
7.118 +unfolding fstO_def
7.119 +by (subst (asm) surjective_pairing) (rule pick_middle[THEN conjunct1])
7.120 +
7.121 +lemma fst_fstO: "fst bc = (fst \<circ> fstO P Q) bc"
7.122 +unfolding comp_def fstO_def by simp
7.123 +
7.124 +lemma snd_sndO: "snd bc = (snd \<circ> sndO P Q) bc"
7.125 +unfolding comp_def sndO_def by simp
7.126 +
7.127 +lemma sndO_in: "ac \<in> P O Q \<Longrightarrow> sndO P Q ac \<in> Q"
7.128 +unfolding sndO_def
7.129 +by (subst (asm) surjective_pairing) (rule pick_middle[THEN conjunct2])
7.130 +
7.131 +lemma csquare_fstO_sndO:
7.132 +"csquare (P O Q) snd fst (fstO P Q) (sndO P Q)"
7.133 +unfolding csquare_def fstO_def sndO_def using pick_middle by simp
7.134 +
7.135 +lemma wppull_fstO_sndO:
7.136 +shows "wppull (P O Q) P Q snd fst fst snd (fstO P Q) (sndO P Q)"
7.137 +using pick_middle unfolding wppull_def fstO_def sndO_def relcomp_def by auto
7.138 +
7.139 +lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
7.140 +by (simp split: prod.split)
7.141 +
7.142 +lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
7.143 +by (simp split: prod.split)
7.144 +
7.145 +lemma flip_rel: "A \<subseteq> (R ^-1) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> R"
7.146 +by auto
7.147 +
7.148 +lemma pointfreeE: "f o g = f' o g' \<Longrightarrow> f (g x) = f' (g' x)"
7.149 +unfolding o_def fun_eq_iff by simp
7.150 +
7.151 +ML_file "Tools/bnf_def_tactics.ML"
7.152 +ML_file"Tools/bnf_def.ML"
7.153 +
7.154 +end
8.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2 +++ b/src/HOL/BNF/BNF_FP.thy Fri Sep 21 16:45:06 2012 +0200
8.3 @@ -0,0 +1,113 @@
8.4 +(* Title: HOL/BNF/BNF_FP.thy
8.5 + Author: Dmitriy Traytel, TU Muenchen
8.6 + Author: Jasmin Blanchette, TU Muenchen
8.7 + Copyright 2012
8.8 +
8.9 +Composition of bounded natural functors.
8.10 +*)
8.11 +
8.12 +header {* Composition of Bounded Natural Functors *}
8.13 +
8.14 +theory BNF_FP
8.15 +imports BNF_Comp BNF_Wrap
8.16 +keywords
8.17 + "defaults"
8.18 +begin
8.19 +
8.20 +lemma case_unit: "(case u of () => f) = f"
8.21 +by (cases u) (hypsubst, rule unit.cases)
8.22 +
8.23 +lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
8.24 +by simp
8.25 +
8.26 +lemma prod_all_impI: "(\<And>x y. P (x, y) \<Longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
8.27 +by clarify
8.28 +
8.29 +lemma prod_all_impI_step: "(\<And>x. \<forall>y. P (x, y) \<longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
8.30 +by auto
8.31 +
8.32 +lemma all_unit_eq: "(\<And>x. PROP P x) \<equiv> PROP P ()"
8.33 +by simp
8.34 +
8.35 +lemma all_prod_eq: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))"
8.36 +by clarsimp
8.37 +
8.38 +lemma rev_bspec: "a \<in> A \<Longrightarrow> \<forall>z \<in> A. P z \<Longrightarrow> P a"
8.39 +by simp
8.40 +
8.41 +lemma Un_cong: "\<lbrakk>A = B; C = D\<rbrakk> \<Longrightarrow> A \<union> C = B \<union> D"
8.42 +by simp
8.43 +
8.44 +lemma pointfree_idE: "f o g = id \<Longrightarrow> f (g x) = x"
8.45 +unfolding o_def fun_eq_iff by simp
8.46 +
8.47 +lemma o_bij:
8.48 + assumes gf: "g o f = id" and fg: "f o g = id"
8.49 + shows "bij f"
8.50 +unfolding bij_def inj_on_def surj_def proof safe
8.51 + fix a1 a2 assume "f a1 = f a2"
8.52 + hence "g ( f a1) = g (f a2)" by simp
8.53 + thus "a1 = a2" using gf unfolding fun_eq_iff by simp
8.54 +next
8.55 + fix b
8.56 + have "b = f (g b)"
8.57 + using fg unfolding fun_eq_iff by simp
8.58 + thus "EX a. b = f a" by blast
8.59 +qed
8.60 +
8.61 +lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
8.62 +
8.63 +lemma sum_case_step:
8.64 + "sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
8.65 + "sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
8.66 +by auto
8.67 +
8.68 +lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
8.69 +by simp
8.70 +
8.71 +lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
8.72 +by blast
8.73 +
8.74 +lemma obj_sumE_f':
8.75 +"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> s = f x \<longrightarrow> P"
8.76 +by (cases x) blast+
8.77 +
8.78 +lemma obj_sumE_f:
8.79 +"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f x \<longrightarrow> P"
8.80 +by (rule allI) (rule obj_sumE_f')
8.81 +
8.82 +lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
8.83 +by (cases s) auto
8.84 +
8.85 +lemma obj_sum_step':
8.86 +"\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> s = f (Inr x) \<longrightarrow> P"
8.87 +by (cases x) blast+
8.88 +
8.89 +lemma obj_sum_step:
8.90 +"\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f (Inr x) \<longrightarrow> P"
8.91 +by (rule allI) (rule obj_sum_step')
8.92 +
8.93 +lemma sum_case_if:
8.94 +"sum_case f g (if p then Inl x else Inr y) = (if p then f x else g y)"
8.95 +by simp
8.96 +
8.97 +lemma mem_UN_compreh_eq: "(z : \<Union>{y. \<exists>x\<in>A. y = F x}) = (\<exists>x\<in>A. z : F x)"
8.98 +by blast
8.99 +
8.100 +lemma prod_set_simps:
8.101 +"fsts (x, y) = {x}"
8.102 +"snds (x, y) = {y}"
8.103 +unfolding fsts_def snds_def by simp+
8.104 +
8.105 +lemma sum_set_simps:
8.106 +"setl (Inl x) = {x}"
8.107 +"setl (Inr x) = {}"
8.108 +"setr (Inl x) = {}"
8.109 +"setr (Inr x) = {x}"
8.110 +unfolding sum_set_defs by simp+
8.111 +
8.112 +ML_file "Tools/bnf_fp.ML"
8.113 +ML_file "Tools/bnf_fp_sugar_tactics.ML"
8.114 +ML_file "Tools/bnf_fp_sugar.ML"
8.115 +
8.116 +end
9.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2 +++ b/src/HOL/BNF/BNF_GFP.thy Fri Sep 21 16:45:06 2012 +0200
9.3 @@ -0,0 +1,331 @@
9.4 +(* Title: HOL/BNF/BNF_GFP.thy
9.5 + Author: Dmitriy Traytel, TU Muenchen
9.6 + Copyright 2012
9.7 +
9.8 +Greatest fixed point operation on bounded natural functors.
9.9 +*)
9.10 +
9.11 +header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
9.12 +
9.13 +theory BNF_GFP
9.14 +imports BNF_FP Equiv_Relations_More "~~/src/HOL/Library/Prefix_Order"
9.15 +keywords
9.16 + "codata_raw" :: thy_decl and
9.17 + "codata" :: thy_decl
9.18 +begin
9.19 +
9.20 +lemma sum_case_comp_Inl:
9.21 +"sum_case f g \<circ> Inl = f"
9.22 +unfolding comp_def by simp
9.23 +
9.24 +lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
9.25 +by (auto split: sum.splits)
9.26 +
9.27 +lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
9.28 +by auto
9.29 +
9.30 +lemma equiv_triv1:
9.31 +assumes "equiv A R" and "(a, b) \<in> R" and "(a, c) \<in> R"
9.32 +shows "(b, c) \<in> R"
9.33 +using assms unfolding equiv_def sym_def trans_def by blast
9.34 +
9.35 +lemma equiv_triv2:
9.36 +assumes "equiv A R" and "(a, b) \<in> R" and "(b, c) \<in> R"
9.37 +shows "(a, c) \<in> R"
9.38 +using assms unfolding equiv_def trans_def by blast
9.39 +
9.40 +lemma equiv_proj:
9.41 + assumes e: "equiv A R" and "z \<in> R"
9.42 + shows "(proj R o fst) z = (proj R o snd) z"
9.43 +proof -
9.44 + from assms(2) have z: "(fst z, snd z) \<in> R" by auto
9.45 + have P: "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" by (erule equiv_triv1[OF e z])
9.46 + have "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R" by (erule equiv_triv2[OF e z])
9.47 + with P show ?thesis unfolding proj_def[abs_def] by auto
9.48 +qed
9.49 +
9.50 +(* Operators: *)
9.51 +definition diag where "diag A \<equiv> {(a,a) | a. a \<in> A}"
9.52 +definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
9.53 +
9.54 +lemma diagI: "x \<in> A \<Longrightarrow> (x, x) \<in> diag A"
9.55 +unfolding diag_def by simp
9.56 +
9.57 +lemma diagE: "(a, b) \<in> diag A \<Longrightarrow> a = b"
9.58 +unfolding diag_def by simp
9.59 +
9.60 +lemma diagE': "x \<in> diag A \<Longrightarrow> fst x = snd x"
9.61 +unfolding diag_def by auto
9.62 +
9.63 +lemma diag_fst: "x \<in> diag A \<Longrightarrow> fst x \<in> A"
9.64 +unfolding diag_def by auto
9.65 +
9.66 +lemma diag_UNIV: "diag UNIV = Id"
9.67 +unfolding diag_def by auto
9.68 +
9.69 +lemma diag_converse: "diag A = (diag A) ^-1"
9.70 +unfolding diag_def by auto
9.71 +
9.72 +lemma diag_Comp: "diag A = diag A O diag A"
9.73 +unfolding diag_def by auto
9.74 +
9.75 +lemma diag_Gr: "diag A = Gr A id"
9.76 +unfolding diag_def Gr_def by simp
9.77 +
9.78 +lemma diag_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> diag UNIV"
9.79 +unfolding diag_def by auto
9.80 +
9.81 +lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
9.82 +unfolding image2_def by auto
9.83 +
9.84 +lemma Id_subset: "Id \<subseteq> {(a, b). P a b \<or> a = b}"
9.85 +by auto
9.86 +
9.87 +lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
9.88 +by auto
9.89 +
9.90 +lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
9.91 +unfolding image2_def Gr_def by auto
9.92 +
9.93 +lemma GrI: "\<lbrakk>x \<in> A; f x = fx\<rbrakk> \<Longrightarrow> (x, fx) \<in> Gr A f"
9.94 +unfolding Gr_def by simp
9.95 +
9.96 +lemma GrE: "(x, fx) \<in> Gr A f \<Longrightarrow> (x \<in> A \<Longrightarrow> f x = fx \<Longrightarrow> P) \<Longrightarrow> P"
9.97 +unfolding Gr_def by simp
9.98 +
9.99 +lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
9.100 +unfolding Gr_def by simp
9.101 +
9.102 +lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
9.103 +unfolding Gr_def by simp
9.104 +
9.105 +lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
9.106 +unfolding Gr_def by auto
9.107 +
9.108 +definition relImage where
9.109 +"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
9.110 +
9.111 +definition relInvImage where
9.112 +"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
9.113 +
9.114 +lemma relImage_Gr:
9.115 +"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
9.116 +unfolding relImage_def Gr_def relcomp_def by auto
9.117 +
9.118 +lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
9.119 +unfolding Gr_def relcomp_def image_def relInvImage_def by auto
9.120 +
9.121 +lemma relImage_mono:
9.122 +"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
9.123 +unfolding relImage_def by auto
9.124 +
9.125 +lemma relInvImage_mono:
9.126 +"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
9.127 +unfolding relInvImage_def by auto
9.128 +
9.129 +lemma relInvImage_diag:
9.130 +"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (diag B) f \<subseteq> Id"
9.131 +unfolding relInvImage_def diag_def by auto
9.132 +
9.133 +lemma relInvImage_UNIV_relImage:
9.134 +"R \<subseteq> relInvImage UNIV (relImage R f) f"
9.135 +unfolding relInvImage_def relImage_def by auto
9.136 +
9.137 +lemma equiv_Image: "equiv A R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> a \<in> A \<and> b \<in> A \<and> R `` {a} = R `` {b})"
9.138 +unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
9.139 +
9.140 +lemma relImage_proj:
9.141 +assumes "equiv A R"
9.142 +shows "relImage R (proj R) \<subseteq> diag (A//R)"
9.143 +unfolding relImage_def diag_def apply safe
9.144 +using proj_iff[OF assms]
9.145 +by (metis assms equiv_Image proj_def proj_preserves)
9.146 +
9.147 +lemma relImage_relInvImage:
9.148 +assumes "R \<subseteq> f ` A <*> f ` A"
9.149 +shows "relImage (relInvImage A R f) f = R"
9.150 +using assms unfolding relImage_def relInvImage_def by fastforce
9.151 +
9.152 +lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
9.153 +by simp
9.154 +
9.155 +lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
9.156 +by simp
9.157 +
9.158 +lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
9.159 +by simp
9.160 +
9.161 +lemma Collect_restrict': "{(x, y) | x y. phi x y \<and> P x y} \<subseteq> {(x, y) | x y. phi x y}"
9.162 +by auto
9.163 +
9.164 +lemma image_convolD: "\<lbrakk>(a, b) \<in> <f, g> ` X\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> X \<and> a = f x \<and> b = g x"
9.165 +unfolding convol_def by auto
9.166 +
9.167 +(*Extended Sublist*)
9.168 +
9.169 +definition prefCl where
9.170 + "prefCl Kl = (\<forall> kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
9.171 +definition PrefCl where
9.172 + "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> kl' \<le> kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
9.173 +
9.174 +lemma prefCl_UN:
9.175 + "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
9.176 +unfolding prefCl_def PrefCl_def by fastforce
9.177 +
9.178 +definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
9.179 +definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
9.180 +definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
9.181 +
9.182 +lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
9.183 +unfolding Shift_def Succ_def by simp
9.184 +
9.185 +lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
9.186 +unfolding Shift_def clists_def Field_card_of by auto
9.187 +
9.188 +lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
9.189 +unfolding prefCl_def Shift_def
9.190 +proof safe
9.191 + fix kl1 kl2
9.192 + assume "\<forall>kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
9.193 + "kl1 \<le> kl2" "k # kl2 \<in> Kl"
9.194 + thus "k # kl1 \<in> Kl" using Cons_prefix_Cons[of k kl1 k kl2] by blast
9.195 +qed
9.196 +
9.197 +lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
9.198 +unfolding Shift_def by simp
9.199 +
9.200 +lemma prefCl_Succ: "\<lbrakk>prefCl Kl; k # kl \<in> Kl\<rbrakk> \<Longrightarrow> k \<in> Succ Kl []"
9.201 +unfolding Succ_def proof
9.202 + assume "prefCl Kl" "k # kl \<in> Kl"
9.203 + moreover have "k # [] \<le> k # kl" by auto
9.204 + ultimately have "k # [] \<in> Kl" unfolding prefCl_def by blast
9.205 + thus "[] @ [k] \<in> Kl" by simp
9.206 +qed
9.207 +
9.208 +lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
9.209 +unfolding Succ_def by simp
9.210 +
9.211 +lemmas SuccE = SuccD[elim_format]
9.212 +
9.213 +lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
9.214 +unfolding Succ_def by simp
9.215 +
9.216 +lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
9.217 +unfolding Shift_def by simp
9.218 +
9.219 +lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
9.220 +unfolding Succ_def Shift_def by auto
9.221 +
9.222 +lemma ShiftI: "k # kl \<in> Kl \<Longrightarrow> kl \<in> Shift Kl k"
9.223 +unfolding Shift_def by simp
9.224 +
9.225 +lemma Func_cexp: "|Func A B| =o |B| ^c |A|"
9.226 +unfolding cexp_def Field_card_of by (simp only: card_of_refl)
9.227 +
9.228 +lemma clists_bound: "A \<in> Field (cpow (clists r)) - {{}} \<Longrightarrow> |A| \<le>o clists r"
9.229 +unfolding cpow_def clists_def Field_card_of by (auto simp: card_of_mono1)
9.230 +
9.231 +lemma cpow_clists_czero: "\<lbrakk>A \<in> Field (cpow (clists r)) - {{}}; |A| =o czero\<rbrakk> \<Longrightarrow> False"
9.232 +unfolding cpow_def clists_def
9.233 +by (auto simp add: card_of_ordIso_czero_iff_empty[symmetric])
9.234 + (erule notE, erule ordIso_transitive, rule czero_ordIso)
9.235 +
9.236 +lemma incl_UNION_I:
9.237 +assumes "i \<in> I" and "A \<subseteq> F i"
9.238 +shows "A \<subseteq> UNION I F"
9.239 +using assms by auto
9.240 +
9.241 +lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
9.242 +unfolding clists_def Field_card_of by auto
9.243 +
9.244 +lemma Cons_clists:
9.245 + "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
9.246 +unfolding clists_def Field_card_of by auto
9.247 +
9.248 +lemma length_Cons: "length (x # xs) = Suc (length xs)"
9.249 +by simp
9.250 +
9.251 +lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
9.252 +by simp
9.253 +
9.254 +(*injection into the field of a cardinal*)
9.255 +definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
9.256 +definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
9.257 +
9.258 +lemma ex_toCard_pred:
9.259 +"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
9.260 +unfolding toCard_pred_def
9.261 +using card_of_ordLeq[of A "Field r"]
9.262 + ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
9.263 +by blast
9.264 +
9.265 +lemma toCard_pred_toCard:
9.266 + "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
9.267 +unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
9.268 +
9.269 +lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
9.270 + toCard A r x = toCard A r y \<longleftrightarrow> x = y"
9.271 +using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
9.272 +
9.273 +lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
9.274 +using toCard_pred_toCard unfolding toCard_pred_def by blast
9.275 +
9.276 +definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
9.277 +
9.278 +lemma fromCard_toCard:
9.279 +"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
9.280 +unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
9.281 +
9.282 +(* pick according to the weak pullback *)
9.283 +definition pickWP_pred where
9.284 +"pickWP_pred A p1 p2 b1 b2 a \<equiv> a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
9.285 +
9.286 +definition pickWP where
9.287 +"pickWP A p1 p2 b1 b2 \<equiv> SOME a. pickWP_pred A p1 p2 b1 b2 a"
9.288 +
9.289 +lemma pickWP_pred:
9.290 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
9.291 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
9.292 +shows "\<exists> a. pickWP_pred A p1 p2 b1 b2 a"
9.293 +using assms unfolding wpull_def pickWP_pred_def by blast
9.294 +
9.295 +lemma pickWP_pred_pickWP:
9.296 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
9.297 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
9.298 +shows "pickWP_pred A p1 p2 b1 b2 (pickWP A p1 p2 b1 b2)"
9.299 +unfolding pickWP_def using assms by(rule someI_ex[OF pickWP_pred])
9.300 +
9.301 +lemma pickWP:
9.302 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
9.303 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
9.304 +shows "pickWP A p1 p2 b1 b2 \<in> A"
9.305 + "p1 (pickWP A p1 p2 b1 b2) = b1"
9.306 + "p2 (pickWP A p1 p2 b1 b2) = b2"
9.307 +using assms pickWP_pred_pickWP unfolding pickWP_pred_def by fastforce+
9.308 +
9.309 +lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
9.310 +unfolding Field_card_of csum_def by auto
9.311 +
9.312 +lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
9.313 +unfolding Field_card_of csum_def by auto
9.314 +
9.315 +lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
9.316 +by auto
9.317 +
9.318 +lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
9.319 +by auto
9.320 +
9.321 +lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
9.322 +by auto
9.323 +
9.324 +lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
9.325 +by auto
9.326 +
9.327 +lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
9.328 +by simp
9.329 +
9.330 +ML_file "Tools/bnf_gfp_util.ML"
9.331 +ML_file "Tools/bnf_gfp_tactics.ML"
9.332 +ML_file "Tools/bnf_gfp.ML"
9.333 +
9.334 +end
10.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2 +++ b/src/HOL/BNF/BNF_LFP.thy Fri Sep 21 16:45:06 2012 +0200
10.3 @@ -0,0 +1,228 @@
10.4 +(* Title: HOL/BNF/BNF_LFP.thy
10.5 + Author: Dmitriy Traytel, TU Muenchen
10.6 + Copyright 2012
10.7 +
10.8 +Least fixed point operation on bounded natural functors.
10.9 +*)
10.10 +
10.11 +header {* Least Fixed Point Operation on Bounded Natural Functors *}
10.12 +
10.13 +theory BNF_LFP
10.14 +imports BNF_FP
10.15 +keywords
10.16 + "data_raw" :: thy_decl and
10.17 + "data" :: thy_decl
10.18 +begin
10.19 +
10.20 +lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
10.21 +by blast
10.22 +
10.23 +lemma image_Collect_subsetI:
10.24 + "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
10.25 +by blast
10.26 +
10.27 +lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
10.28 +by auto
10.29 +
10.30 +lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
10.31 +by auto
10.32 +
10.33 +lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> rel.underS R j"
10.34 +unfolding rel.underS_def by simp
10.35 +
10.36 +lemma underS_E: "i \<in> rel.underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
10.37 +unfolding rel.underS_def by simp
10.38 +
10.39 +lemma underS_Field: "i \<in> rel.underS R j \<Longrightarrow> i \<in> Field R"
10.40 +unfolding rel.underS_def Field_def by auto
10.41 +
10.42 +lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
10.43 +unfolding Field_def by auto
10.44 +
10.45 +lemma fst_convol': "fst (<f, g> x) = f x"
10.46 +using fst_convol unfolding convol_def by simp
10.47 +
10.48 +lemma snd_convol': "snd (<f, g> x) = g x"
10.49 +using snd_convol unfolding convol_def by simp
10.50 +
10.51 +lemma convol_expand_snd: "fst o f = g \<Longrightarrow> <g, snd o f> = f"
10.52 +unfolding convol_def by auto
10.53 +
10.54 +definition inver where
10.55 + "inver g f A = (ALL a : A. g (f a) = a)"
10.56 +
10.57 +lemma bij_betw_iff_ex:
10.58 + "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
10.59 +proof (rule iffI)
10.60 + assume ?L
10.61 + hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
10.62 + let ?phi = "% b a. a : A \<and> f a = b"
10.63 + have "ALL b : B. EX a. ?phi b a" using f by blast
10.64 + then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
10.65 + using bchoice[of B ?phi] by blast
10.66 + hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
10.67 + have gf: "inver g f A" unfolding inver_def
10.68 + by (metis (no_types) gg imageI[of _ A f] the_inv_into_f_f[OF inj_f])
10.69 + moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
10.70 + moreover have "A \<le> g ` B"
10.71 + proof safe
10.72 + fix a assume a: "a : A"
10.73 + hence "f a : B" using f by auto
10.74 + moreover have "a = g (f a)" using a gf unfolding inver_def by auto
10.75 + ultimately show "a : g ` B" by blast
10.76 + qed
10.77 + ultimately show ?R by blast
10.78 +next
10.79 + assume ?R
10.80 + then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
10.81 + show ?L unfolding bij_betw_def
10.82 + proof safe
10.83 + show "inj_on f A" unfolding inj_on_def
10.84 + proof safe
10.85 + fix a1 a2 assume a: "a1 : A" "a2 : A" and "f a1 = f a2"
10.86 + hence "g (f a1) = g (f a2)" by simp
10.87 + thus "a1 = a2" using a g unfolding inver_def by simp
10.88 + qed
10.89 + next
10.90 + fix a assume "a : A"
10.91 + then obtain b where b: "b : B" and a: "a = g b" using g by blast
10.92 + hence "b = f (g b)" using g unfolding inver_def by auto
10.93 + thus "f a : B" unfolding a using b by simp
10.94 + next
10.95 + fix b assume "b : B"
10.96 + hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
10.97 + thus "b : f ` A" by auto
10.98 + qed
10.99 +qed
10.100 +
10.101 +lemma bij_betw_ex_weakE:
10.102 + "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
10.103 +by (auto simp only: bij_betw_iff_ex)
10.104 +
10.105 +lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
10.106 +unfolding inver_def by auto (rule rev_image_eqI, auto)
10.107 +
10.108 +lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
10.109 +unfolding inver_def by auto
10.110 +
10.111 +lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
10.112 +unfolding inver_def by simp
10.113 +
10.114 +lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
10.115 +unfolding bij_betw_def by auto
10.116 +
10.117 +lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
10.118 +unfolding bij_betw_def by auto
10.119 +
10.120 +lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
10.121 +unfolding inver_def by auto
10.122 +
10.123 +lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
10.124 +unfolding bij_betw_def inver_def by auto
10.125 +
10.126 +lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
10.127 +unfolding bij_betw_def inver_def by auto
10.128 +
10.129 +lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
10.130 +by (drule bij_betw_imageE, unfold bij_betw_iff_ex) blast
10.131 +
10.132 +lemma bij_betwI':
10.133 + "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
10.134 + \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
10.135 + \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
10.136 +unfolding bij_betw_def inj_on_def
10.137 +apply (rule conjI)
10.138 + apply blast
10.139 +by (erule thin_rl) blast
10.140 +
10.141 +lemma surj_fun_eq:
10.142 + assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
10.143 + shows "g1 = g2"
10.144 +proof (rule ext)
10.145 + fix y
10.146 + from surj_on obtain x where "x \<in> X" and "y = f x" by blast
10.147 + thus "g1 y = g2 y" using eq_on by simp
10.148 +qed
10.149 +
10.150 +lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
10.151 +unfolding wo_rel_def card_order_on_def by blast
10.152 +
10.153 +lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
10.154 + \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
10.155 +unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
10.156 +
10.157 +lemma Card_order_trans:
10.158 + "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
10.159 +unfolding card_order_on_def well_order_on_def linear_order_on_def
10.160 + partial_order_on_def preorder_on_def trans_def antisym_def by blast
10.161 +
10.162 +lemma Cinfinite_limit2:
10.163 + assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
10.164 + shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
10.165 +proof -
10.166 + from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
10.167 + unfolding card_order_on_def well_order_on_def linear_order_on_def
10.168 + partial_order_on_def preorder_on_def by auto
10.169 + obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
10.170 + using Cinfinite_limit[OF x1 r] by blast
10.171 + obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
10.172 + using Cinfinite_limit[OF x2 r] by blast
10.173 + show ?thesis
10.174 + proof (cases "y1 = y2")
10.175 + case True with y1 y2 show ?thesis by blast
10.176 + next
10.177 + case False
10.178 + with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
10.179 + unfolding total_on_def by auto
10.180 + thus ?thesis
10.181 + proof
10.182 + assume *: "(y1, y2) \<in> r"
10.183 + with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
10.184 + with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
10.185 + next
10.186 + assume *: "(y2, y1) \<in> r"
10.187 + with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
10.188 + with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
10.189 + qed
10.190 + qed
10.191 +qed
10.192 +
10.193 +lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
10.194 + \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
10.195 +proof (induct X rule: finite_induct)
10.196 + case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
10.197 +next
10.198 + case (insert x X)
10.199 + then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
10.200 + then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
10.201 + using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
10.202 + show ?case
10.203 + apply (intro bexI ballI)
10.204 + apply (erule insertE)
10.205 + apply hypsubst
10.206 + apply (rule z(2))
10.207 + using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
10.208 + apply blast
10.209 + apply (rule z(1))
10.210 + done
10.211 +qed
10.212 +
10.213 +lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
10.214 +by auto
10.215 +
10.216 +(*helps resolution*)
10.217 +lemma well_order_induct_imp:
10.218 + "wo_rel r \<Longrightarrow> (\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> y \<in> Field r \<longrightarrow> P y \<Longrightarrow> x \<in> Field r \<longrightarrow> P x) \<Longrightarrow>
10.219 + x \<in> Field r \<longrightarrow> P x"
10.220 +by (erule wo_rel.well_order_induct)
10.221 +
10.222 +lemma meta_spec2:
10.223 + assumes "(\<And>x y. PROP P x y)"
10.224 + shows "PROP P x y"
10.225 +by (rule `(\<And>x y. PROP P x y)`)
10.226 +
10.227 +ML_file "Tools/bnf_lfp_util.ML"
10.228 +ML_file "Tools/bnf_lfp_tactics.ML"
10.229 +ML_file "Tools/bnf_lfp.ML"
10.230 +
10.231 +end
11.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2 +++ b/src/HOL/BNF/BNF_Util.thy Fri Sep 21 16:45:06 2012 +0200
11.3 @@ -0,0 +1,66 @@
11.4 +(* Title: HOL/BNF/BNF_Util.thy
11.5 + Author: Dmitriy Traytel, TU Muenchen
11.6 + Author: Jasmin Blanchette, TU Muenchen
11.7 + Copyright 2012
11.8 +
11.9 +Library for bounded natural functors.
11.10 +*)
11.11 +
11.12 +header {* Library for Bounded Natural Functors *}
11.13 +
11.14 +theory BNF_Util
11.15 +imports "../Cardinals/Cardinal_Arithmetic"
11.16 +begin
11.17 +
11.18 +lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
11.19 +by blast
11.20 +
11.21 +lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
11.22 +by blast
11.23 +
11.24 +definition collect where
11.25 +"collect F x = (\<Union>f \<in> F. f x)"
11.26 +
11.27 +(* Weak pullbacks: *)
11.28 +definition wpull where
11.29 +"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
11.30 + (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow> (\<exists> a \<in> A. p1 a = b1 \<and> p2 a = b2))"
11.31 +
11.32 +(* Weak pseudo-pullbacks *)
11.33 +definition wppull where
11.34 +"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
11.35 + (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
11.36 + (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
11.37 +
11.38 +lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
11.39 +by simp
11.40 +
11.41 +lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
11.42 +by simp
11.43 +
11.44 +lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
11.45 +by simp
11.46 +
11.47 +lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
11.48 +by simp
11.49 +
11.50 +lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
11.51 +unfolding bij_def inj_on_def by auto blast
11.52 +
11.53 +lemma pair_mem_Collect_split:
11.54 +"(\<lambda>x y. (x, y) \<in> {(x, y). P x y}) = P"
11.55 +by simp
11.56 +
11.57 +lemma Collect_pair_mem_eq: "{(x, y). (x, y) \<in> R} = R"
11.58 +by simp
11.59 +
11.60 +lemma Collect_fst_snd_mem_eq: "{p. (fst p, snd p) \<in> A} = A"
11.61 +by simp
11.62 +
11.63 +(* Operator: *)
11.64 +definition "Gr A f = {(a, f a) | a. a \<in> A}"
11.65 +
11.66 +ML_file "Tools/bnf_util.ML"
11.67 +ML_file "Tools/bnf_tactics.ML"
11.68 +
11.69 +end
12.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2 +++ b/src/HOL/BNF/BNF_Wrap.thy Fri Sep 21 16:45:06 2012 +0200
12.3 @@ -0,0 +1,28 @@
12.4 +(* Title: HOL/BNF/BNF_Wrap.thy
12.5 + Author: Jasmin Blanchette, TU Muenchen
12.6 + Copyright 2012
12.7 +
12.8 +Wrapping datatypes.
12.9 +*)
12.10 +
12.11 +header {* Wrapping Datatypes *}
12.12 +
12.13 +theory BNF_Wrap
12.14 +imports BNF_Util
12.15 +keywords
12.16 + "wrap_data" :: thy_goal and
12.17 + "no_dests"
12.18 +begin
12.19 +
12.20 +lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
12.21 +by (erule iffI) (erule contrapos_pn)
12.22 +
12.23 +lemma iff_contradict:
12.24 +"\<not> P \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> Q \<Longrightarrow> R"
12.25 +"\<not> Q \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> P \<Longrightarrow> R"
12.26 +by blast+
12.27 +
12.28 +ML_file "Tools/bnf_wrap_tactics.ML"
12.29 +ML_file "Tools/bnf_wrap.ML"
12.30 +
12.31 +end
13.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2 +++ b/src/HOL/BNF/Basic_BNFs.thy Fri Sep 21 16:45:06 2012 +0200
13.3 @@ -0,0 +1,417 @@
13.4 +(* Title: HOL/BNF/Basic_BNFs.thy
13.5 + Author: Dmitriy Traytel, TU Muenchen
13.6 + Author: Andrei Popescu, TU Muenchen
13.7 + Author: Jasmin Blanchette, TU Muenchen
13.8 + Copyright 2012
13.9 +
13.10 +Registration of basic types as bounded natural functors.
13.11 +*)
13.12 +
13.13 +header {* Registration of Basic Types as Bounded Natural Functors *}
13.14 +
13.15 +theory Basic_BNFs
13.16 +imports BNF_Def
13.17 +begin
13.18 +
13.19 +lemma wpull_id: "wpull UNIV B1 B2 id id id id"
13.20 +unfolding wpull_def by simp
13.21 +
13.22 +lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
13.23 +
13.24 +lemma ctwo_card_order: "card_order ctwo"
13.25 +using Card_order_ctwo by (unfold ctwo_def Field_card_of)
13.26 +
13.27 +lemma natLeq_cinfinite: "cinfinite natLeq"
13.28 +unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
13.29 +
13.30 +bnf_def ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
13.31 + "\<lambda>x :: 'a \<Rightarrow> 'b \<Rightarrow> bool. x"
13.32 +apply auto
13.33 +apply (rule natLeq_card_order)
13.34 +apply (rule natLeq_cinfinite)
13.35 +apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
13.36 +apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
13.37 +apply (rule ordLeq_transitive)
13.38 +apply (rule ordLeq_cexp1[of natLeq])
13.39 +apply (rule Cinfinite_Cnotzero)
13.40 +apply (rule conjI)
13.41 +apply (rule natLeq_cinfinite)
13.42 +apply (rule natLeq_Card_order)
13.43 +apply (rule card_of_Card_order)
13.44 +apply (rule cexp_mono1)
13.45 +apply (rule ordLeq_csum1)
13.46 +apply (rule card_of_Card_order)
13.47 +apply (rule disjI2)
13.48 +apply (rule cone_ordLeq_cexp)
13.49 +apply (rule ordLeq_transitive)
13.50 +apply (rule cone_ordLeq_ctwo)
13.51 +apply (rule ordLeq_csum2)
13.52 +apply (rule Card_order_ctwo)
13.53 +apply (rule natLeq_Card_order)
13.54 +apply (auto simp: Gr_def fun_eq_iff)
13.55 +done
13.56 +
13.57 +bnf_def DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
13.58 + "op =::'a \<Rightarrow> 'a \<Rightarrow> bool"
13.59 +apply (auto simp add: wpull_id)
13.60 +apply (rule card_order_csum)
13.61 +apply (rule natLeq_card_order)
13.62 +apply (rule card_of_card_order_on)
13.63 +apply (rule cinfinite_csum)
13.64 +apply (rule disjI1)
13.65 +apply (rule natLeq_cinfinite)
13.66 +apply (rule ordLess_imp_ordLeq)
13.67 +apply (rule ordLess_ordLeq_trans)
13.68 +apply (rule ordLess_ctwo_cexp)
13.69 +apply (rule card_of_Card_order)
13.70 +apply (rule cexp_mono2'')
13.71 +apply (rule ordLeq_csum2)
13.72 +apply (rule card_of_Card_order)
13.73 +apply (rule ctwo_Cnotzero)
13.74 +apply (rule card_of_Card_order)
13.75 +apply (auto simp: Id_def Gr_def fun_eq_iff)
13.76 +done
13.77 +
13.78 +definition setl :: "'a + 'b \<Rightarrow> 'a set" where
13.79 +"setl x = (case x of Inl z => {z} | _ => {})"
13.80 +
13.81 +definition setr :: "'a + 'b \<Rightarrow> 'b set" where
13.82 +"setr x = (case x of Inr z => {z} | _ => {})"
13.83 +
13.84 +lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
13.85 +
13.86 +definition sum_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a + 'c \<Rightarrow> 'b + 'd \<Rightarrow> bool" where
13.87 +"sum_rel \<phi> \<psi> x y =
13.88 + (case x of Inl a1 \<Rightarrow> (case y of Inl a2 \<Rightarrow> \<phi> a1 a2 | Inr _ \<Rightarrow> False)
13.89 + | Inr b1 \<Rightarrow> (case y of Inl _ \<Rightarrow> False | Inr b2 \<Rightarrow> \<psi> b1 b2))"
13.90 +
13.91 +bnf_def sum_map [setl, setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr] sum_rel
13.92 +proof -
13.93 + show "sum_map id id = id" by (rule sum_map.id)
13.94 +next
13.95 + fix f1 f2 g1 g2
13.96 + show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
13.97 + by (rule sum_map.comp[symmetric])
13.98 +next
13.99 + fix x f1 f2 g1 g2
13.100 + assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
13.101 + a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
13.102 + thus "sum_map f1 f2 x = sum_map g1 g2 x"
13.103 + proof (cases x)
13.104 + case Inl thus ?thesis using a1 by (clarsimp simp: setl_def)
13.105 + next
13.106 + case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
13.107 + qed
13.108 +next
13.109 + fix f1 f2
13.110 + show "setl o sum_map f1 f2 = image f1 o setl"
13.111 + by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
13.112 +next
13.113 + fix f1 f2
13.114 + show "setr o sum_map f1 f2 = image f2 o setr"
13.115 + by (rule ext, unfold o_apply) (simp add: setr_def split: sum.split)
13.116 +next
13.117 + show "card_order natLeq" by (rule natLeq_card_order)
13.118 +next
13.119 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
13.120 +next
13.121 + fix x
13.122 + show "|setl x| \<le>o natLeq"
13.123 + apply (rule ordLess_imp_ordLeq)
13.124 + apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
13.125 + by (simp add: setl_def split: sum.split)
13.126 +next
13.127 + fix x
13.128 + show "|setr x| \<le>o natLeq"
13.129 + apply (rule ordLess_imp_ordLeq)
13.130 + apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
13.131 + by (simp add: setr_def split: sum.split)
13.132 +next
13.133 + fix A1 :: "'a set" and A2 :: "'b set"
13.134 + have in_alt: "{x. (case x of Inl z => {z} | _ => {}) \<subseteq> A1 \<and>
13.135 + (case x of Inr z => {z} | _ => {}) \<subseteq> A2} = A1 <+> A2" (is "?L = ?R")
13.136 + proof safe
13.137 + fix x :: "'a + 'b"
13.138 + assume "(case x of Inl z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A1" "(case x of Inr z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A2"
13.139 + hence "x \<in> Inl ` A1 \<or> x \<in> Inr ` A2" by (cases x) simp+
13.140 + thus "x \<in> A1 <+> A2" by blast
13.141 + qed (auto split: sum.split)
13.142 + show "|{x. setl x \<subseteq> A1 \<and> setr x \<subseteq> A2}| \<le>o
13.143 + (( |A1| +c |A2| ) +c ctwo) ^c natLeq"
13.144 + apply (rule ordIso_ordLeq_trans)
13.145 + apply (rule card_of_ordIso_subst)
13.146 + apply (unfold sum_set_defs)
13.147 + apply (rule in_alt)
13.148 + apply (rule ordIso_ordLeq_trans)
13.149 + apply (rule Plus_csum)
13.150 + apply (rule ordLeq_transitive)
13.151 + apply (rule ordLeq_csum1)
13.152 + apply (rule Card_order_csum)
13.153 + apply (rule ordLeq_cexp1)
13.154 + apply (rule conjI)
13.155 + using Field_natLeq UNIV_not_empty czeroE apply fast
13.156 + apply (rule natLeq_Card_order)
13.157 + by (rule Card_order_csum)
13.158 +next
13.159 + fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
13.160 + assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
13.161 + hence
13.162 + pull1: "\<And>b1 b2. \<lbrakk>b1 \<in> B11; b2 \<in> B21; f11 b1 = f21 b2\<rbrakk> \<Longrightarrow> \<exists>a \<in> A1. p11 a = b1 \<and> p21 a = b2"
13.163 + and pull2: "\<And>b1 b2. \<lbrakk>b1 \<in> B12; b2 \<in> B22; f12 b1 = f22 b2\<rbrakk> \<Longrightarrow> \<exists>a \<in> A2. p12 a = b1 \<and> p22 a = b2"
13.164 + unfolding wpull_def by blast+
13.165 + show "wpull {x. setl x \<subseteq> A1 \<and> setr x \<subseteq> A2}
13.166 + {x. setl x \<subseteq> B11 \<and> setr x \<subseteq> B12} {x. setl x \<subseteq> B21 \<and> setr x \<subseteq> B22}
13.167 + (sum_map f11 f12) (sum_map f21 f22) (sum_map p11 p12) (sum_map p21 p22)"
13.168 + (is "wpull ?in ?in1 ?in2 ?mapf1 ?mapf2 ?mapp1 ?mapp2")
13.169 + proof (unfold wpull_def)
13.170 + { fix B1 B2
13.171 + assume *: "B1 \<in> ?in1" "B2 \<in> ?in2" "?mapf1 B1 = ?mapf2 B2"
13.172 + have "\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2"
13.173 + proof (cases B1)
13.174 + case (Inl b1)
13.175 + { fix b2 assume "B2 = Inr b2"
13.176 + with Inl *(3) have False by simp
13.177 + } then obtain b2 where Inl': "B2 = Inl b2" by (cases B2) (simp, blast)
13.178 + with Inl * have "b1 \<in> B11" "b2 \<in> B21" "f11 b1 = f21 b2"
13.179 + by (simp add: setl_def)+
13.180 + with pull1 obtain a where "a \<in> A1" "p11 a = b1" "p21 a = b2" by blast+
13.181 + with Inl Inl' have "Inl a \<in> ?in" "?mapp1 (Inl a) = B1 \<and> ?mapp2 (Inl a) = B2"
13.182 + by (simp add: sum_set_defs)+
13.183 + thus ?thesis by blast
13.184 + next
13.185 + case (Inr b1)
13.186 + { fix b2 assume "B2 = Inl b2"
13.187 + with Inr *(3) have False by simp
13.188 + } then obtain b2 where Inr': "B2 = Inr b2" by (cases B2) (simp, blast)
13.189 + with Inr * have "b1 \<in> B12" "b2 \<in> B22" "f12 b1 = f22 b2"
13.190 + by (simp add: sum_set_defs)+
13.191 + with pull2 obtain a where "a \<in> A2" "p12 a = b1" "p22 a = b2" by blast+
13.192 + with Inr Inr' have "Inr a \<in> ?in" "?mapp1 (Inr a) = B1 \<and> ?mapp2 (Inr a) = B2"
13.193 + by (simp add: sum_set_defs)+
13.194 + thus ?thesis by blast
13.195 + qed
13.196 + }
13.197 + thus "\<forall>B1 B2. B1 \<in> ?in1 \<and> B2 \<in> ?in2 \<and> ?mapf1 B1 = ?mapf2 B2 \<longrightarrow>
13.198 + (\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2)" by fastforce
13.199 + qed
13.200 +next
13.201 + fix R S
13.202 + show "{p. sum_rel (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) (fst p) (snd p)} =
13.203 + (Gr {x. setl x \<subseteq> R \<and> setr x \<subseteq> S} (sum_map fst fst))\<inverse> O
13.204 + Gr {x. setl x \<subseteq> R \<and> setr x \<subseteq> S} (sum_map snd snd)"
13.205 + unfolding setl_def setr_def sum_rel_def Gr_def relcomp_unfold converse_unfold
13.206 + by (fastforce split: sum.splits)
13.207 +qed (auto simp: sum_set_defs)
13.208 +
13.209 +lemma singleton_ordLeq_ctwo_natLeq: "|{x}| \<le>o ctwo *c natLeq"
13.210 + apply (rule ordLeq_transitive)
13.211 + apply (rule ordLeq_cprod2)
13.212 + apply (rule ctwo_Cnotzero)
13.213 + apply (auto simp: Field_card_of intro: card_of_card_order_on)
13.214 + apply (rule cprod_mono2)
13.215 + apply (rule ordLess_imp_ordLeq)
13.216 + apply (unfold finite_iff_ordLess_natLeq[symmetric])
13.217 + by simp
13.218 +
13.219 +definition fsts :: "'a \<times> 'b \<Rightarrow> 'a set" where
13.220 +"fsts x = {fst x}"
13.221 +
13.222 +definition snds :: "'a \<times> 'b \<Rightarrow> 'b set" where
13.223 +"snds x = {snd x}"
13.224 +
13.225 +lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
13.226 +
13.227 +definition prod_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b \<times> 'd \<Rightarrow> bool" where
13.228 +"prod_rel \<phi> \<psi> p1 p2 = (case p1 of (a1, b1) \<Rightarrow> case p2 of (a2, b2) \<Rightarrow> \<phi> a1 a2 \<and> \<psi> b1 b2)"
13.229 +
13.230 +bnf_def map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. ctwo *c natLeq" [Pair] prod_rel
13.231 +proof (unfold prod_set_defs)
13.232 + show "map_pair id id = id" by (rule map_pair.id)
13.233 +next
13.234 + fix f1 f2 g1 g2
13.235 + show "map_pair (g1 o f1) (g2 o f2) = map_pair g1 g2 o map_pair f1 f2"
13.236 + by (rule map_pair.comp[symmetric])
13.237 +next
13.238 + fix x f1 f2 g1 g2
13.239 + assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
13.240 + thus "map_pair f1 f2 x = map_pair g1 g2 x" by (cases x) simp
13.241 +next
13.242 + fix f1 f2
13.243 + show "(\<lambda>x. {fst x}) o map_pair f1 f2 = image f1 o (\<lambda>x. {fst x})"
13.244 + by (rule ext, unfold o_apply) simp
13.245 +next
13.246 + fix f1 f2
13.247 + show "(\<lambda>x. {snd x}) o map_pair f1 f2 = image f2 o (\<lambda>x. {snd x})"
13.248 + by (rule ext, unfold o_apply) simp
13.249 +next
13.250 + show "card_order (ctwo *c natLeq)"
13.251 + apply (rule card_order_cprod)
13.252 + apply (rule ctwo_card_order)
13.253 + by (rule natLeq_card_order)
13.254 +next
13.255 + show "cinfinite (ctwo *c natLeq)"
13.256 + apply (rule cinfinite_cprod2)
13.257 + apply (rule ctwo_Cnotzero)
13.258 + apply (rule conjI[OF _ natLeq_Card_order])
13.259 + by (rule natLeq_cinfinite)
13.260 +next
13.261 + fix x
13.262 + show "|{fst x}| \<le>o ctwo *c natLeq"
13.263 + by (rule singleton_ordLeq_ctwo_natLeq)
13.264 +next
13.265 + fix x
13.266 + show "|{snd x}| \<le>o ctwo *c natLeq"
13.267 + by (rule singleton_ordLeq_ctwo_natLeq)
13.268 +next
13.269 + fix A1 :: "'a set" and A2 :: "'b set"
13.270 + have in_alt: "{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2} = A1 \<times> A2" by auto
13.271 + show "|{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}| \<le>o
13.272 + ( ( |A1| +c |A2| ) +c ctwo) ^c (ctwo *c natLeq)"
13.273 + apply (rule ordIso_ordLeq_trans)
13.274 + apply (rule card_of_ordIso_subst)
13.275 + apply (rule in_alt)
13.276 + apply (rule ordIso_ordLeq_trans)
13.277 + apply (rule Times_cprod)
13.278 + apply (rule ordLeq_transitive)
13.279 + apply (rule cprod_csum_cexp)
13.280 + apply (rule cexp_mono)
13.281 + apply (rule ordLeq_csum1)
13.282 + apply (rule Card_order_csum)
13.283 + apply (rule ordLeq_cprod1)
13.284 + apply (rule Card_order_ctwo)
13.285 + apply (rule Cinfinite_Cnotzero)
13.286 + apply (rule conjI[OF _ natLeq_Card_order])
13.287 + apply (rule natLeq_cinfinite)
13.288 + apply (rule disjI2)
13.289 + apply (rule cone_ordLeq_cexp)
13.290 + apply (rule ordLeq_transitive)
13.291 + apply (rule cone_ordLeq_ctwo)
13.292 + apply (rule ordLeq_csum2)
13.293 + apply (rule Card_order_ctwo)
13.294 + apply (rule notE)
13.295 + apply (rule ctwo_not_czero)
13.296 + apply assumption
13.297 + by (rule Card_order_ctwo)
13.298 +next
13.299 + fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
13.300 + assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
13.301 + thus "wpull {x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}
13.302 + {x. {fst x} \<subseteq> B11 \<and> {snd x} \<subseteq> B12} {x. {fst x} \<subseteq> B21 \<and> {snd x} \<subseteq> B22}
13.303 + (map_pair f11 f12) (map_pair f21 f22) (map_pair p11 p12) (map_pair p21 p22)"
13.304 + unfolding wpull_def by simp fast
13.305 +next
13.306 + fix R S
13.307 + show "{p. prod_rel (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) (fst p) (snd p)} =
13.308 + (Gr {x. {fst x} \<subseteq> R \<and> {snd x} \<subseteq> S} (map_pair fst fst))\<inverse> O
13.309 + Gr {x. {fst x} \<subseteq> R \<and> {snd x} \<subseteq> S} (map_pair snd snd)"
13.310 + unfolding prod_set_defs prod_rel_def Gr_def relcomp_unfold converse_unfold
13.311 + by auto
13.312 +qed simp+
13.313 +
13.314 +(* Categorical version of pullback: *)
13.315 +lemma wpull_cat:
13.316 +assumes p: "wpull A B1 B2 f1 f2 p1 p2"
13.317 +and c: "f1 o q1 = f2 o q2"
13.318 +and r: "range q1 \<subseteq> B1" "range q2 \<subseteq> B2"
13.319 +obtains h where "range h \<subseteq> A \<and> q1 = p1 o h \<and> q2 = p2 o h"
13.320 +proof-
13.321 + have *: "\<forall>d. \<exists>a \<in> A. p1 a = q1 d & p2 a = q2 d"
13.322 + proof safe
13.323 + fix d
13.324 + have "f1 (q1 d) = f2 (q2 d)" using c unfolding comp_def[abs_def] by (rule fun_cong)
13.325 + moreover
13.326 + have "q1 d : B1" "q2 d : B2" using r unfolding image_def by auto
13.327 + ultimately show "\<exists>a \<in> A. p1 a = q1 d \<and> p2 a = q2 d"
13.328 + using p unfolding wpull_def by auto
13.329 + qed
13.330 + then obtain h where "!! d. h d \<in> A & p1 (h d) = q1 d & p2 (h d) = q2 d" by metis
13.331 + thus ?thesis using that by fastforce
13.332 +qed
13.333 +
13.334 +lemma card_of_bounded_range:
13.335 + "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
13.336 +proof -
13.337 + let ?f = "\<lambda>f. %x. if f x \<in> B then Some (f x) else None"
13.338 + have "inj_on ?f ?LHS" unfolding inj_on_def
13.339 + proof (unfold fun_eq_iff, safe)
13.340 + fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
13.341 + assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
13.342 + hence "f x \<in> B" "g x \<in> B" by auto
13.343 + with eq have "Some (f x) = Some (g x)" by metis
13.344 + thus "f x = g x" by simp
13.345 + qed
13.346 + moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
13.347 + ultimately show ?thesis using card_of_ordLeq by fast
13.348 +qed
13.349 +
13.350 +definition fun_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b) \<Rightarrow> bool" where
13.351 +"fun_rel \<phi> f g = (\<forall>x. \<phi> (f x) (g x))"
13.352 +
13.353 +bnf_def "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|" ["%c x::'b::type. c::'a::type"]
13.354 + fun_rel
13.355 +proof
13.356 + fix f show "id \<circ> f = id f" by simp
13.357 +next
13.358 + fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
13.359 + unfolding comp_def[abs_def] ..
13.360 +next
13.361 + fix x f g
13.362 + assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
13.363 + thus "f \<circ> x = g \<circ> x" by auto
13.364 +next
13.365 + fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
13.366 + unfolding image_def comp_def[abs_def] by auto
13.367 +next
13.368 + show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
13.369 + apply (rule card_order_csum)
13.370 + apply (rule natLeq_card_order)
13.371 + by (rule card_of_card_order_on)
13.372 +(* *)
13.373 + show "cinfinite (natLeq +c ?U)"
13.374 + apply (rule cinfinite_csum)
13.375 + apply (rule disjI1)
13.376 + by (rule natLeq_cinfinite)
13.377 +next
13.378 + fix f :: "'d => 'a"
13.379 + have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
13.380 + also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
13.381 + finally show "|range f| \<le>o natLeq +c ?U" .
13.382 +next
13.383 + fix B :: "'a set"
13.384 + have "|{f::'d => 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" by (rule card_of_bounded_range)
13.385 + also have "|Func (UNIV :: 'd set) B| =o |B| ^c |UNIV :: 'd set|"
13.386 + unfolding cexp_def Field_card_of by (rule card_of_refl)
13.387 + also have "|B| ^c |UNIV :: 'd set| \<le>o
13.388 + ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )"
13.389 + apply (rule cexp_mono)
13.390 + apply (rule ordLeq_csum1) apply (rule card_of_Card_order)
13.391 + apply (rule ordLeq_csum2) apply (rule card_of_Card_order)
13.392 + apply (rule disjI2) apply (rule cone_ordLeq_cexp)
13.393 + apply (rule ordLeq_transitive) apply (rule cone_ordLeq_ctwo) apply (rule ordLeq_csum2)
13.394 + apply (rule Card_order_ctwo)
13.395 + apply (rule notE) apply (rule conjunct1) apply (rule Cnotzero_UNIV) apply blast
13.396 + apply (rule card_of_Card_order)
13.397 + done
13.398 + finally
13.399 + show "|{f::'d => 'a. range f \<subseteq> B}| \<le>o
13.400 + ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )" .
13.401 +next
13.402 + fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
13.403 + show "wpull {h. range h \<subseteq> A} {g1. range g1 \<subseteq> B1} {g2. range g2 \<subseteq> B2}
13.404 + (op \<circ> f1) (op \<circ> f2) (op \<circ> p1) (op \<circ> p2)"
13.405 + unfolding wpull_def
13.406 + proof safe
13.407 + fix g1 g2 assume r: "range g1 \<subseteq> B1" "range g2 \<subseteq> B2"
13.408 + and c: "f1 \<circ> g1 = f2 \<circ> g2"
13.409 + show "\<exists>h \<in> {h. range h \<subseteq> A}. p1 \<circ> h = g1 \<and> p2 \<circ> h = g2"
13.410 + using wpull_cat[OF p c r] by simp metis
13.411 + qed
13.412 +next
13.413 + fix R
13.414 + show "{p. fun_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
13.415 + (Gr {x. range x \<subseteq> R} (op \<circ> fst))\<inverse> O Gr {x. range x \<subseteq> R} (op \<circ> snd)"
13.416 + unfolding fun_rel_def Gr_def relcomp_unfold converse_unfold
13.417 + by (auto intro!: exI dest!: in_mono)
13.418 +qed auto
13.419 +
13.420 +end
14.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2 +++ b/src/HOL/BNF/Countable_Set.thy Fri Sep 21 16:45:06 2012 +0200
14.3 @@ -0,0 +1,366 @@
14.4 +(* Title: HOL/BNF/Countable_Set.thy
14.5 + Author: Andrei Popescu, TU Muenchen
14.6 + Copyright 2012
14.7 +
14.8 +(At most) countable sets.
14.9 +*)
14.10 +
14.11 +header {* (At Most) Countable Sets *}
14.12 +
14.13 +theory Countable_Set
14.14 +imports "../Cardinals/Cardinals" "~~/src/HOL/Library/Countable"
14.15 +begin
14.16 +
14.17 +
14.18 +subsection{* Basics *}
14.19 +
14.20 +definition "countable A \<equiv> |A| \<le>o natLeq"
14.21 +
14.22 +lemma countable_card_of_nat:
14.23 +"countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
14.24 +unfolding countable_def using card_of_nat
14.25 +using ordLeq_ordIso_trans ordIso_symmetric by blast
14.26 +
14.27 +lemma countable_ex_to_nat:
14.28 +fixes A :: "'a set"
14.29 +shows "countable A \<longleftrightarrow> (\<exists> f::'a\<Rightarrow>nat. inj_on f A)"
14.30 +unfolding countable_card_of_nat card_of_ordLeq[symmetric] by auto
14.31 +
14.32 +lemma countable_or_card_of:
14.33 +assumes "countable A"
14.34 +shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
14.35 + (infinite A \<and> |A| =o |UNIV::nat set| )"
14.36 +apply (cases "finite A")
14.37 + apply(metis finite_iff_cardOf_nat)
14.38 + by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
14.39 +
14.40 +lemma countable_or:
14.41 +assumes "countable A"
14.42 +shows "(\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or>
14.43 + (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
14.44 +using countable_or_card_of[OF assms]
14.45 +by (metis assms card_of_ordIso countable_ex_to_nat)
14.46 +
14.47 +lemma countable_cases_card_of[elim, consumes 1, case_names Fin Inf]:
14.48 +assumes "countable A"
14.49 +and "\<lbrakk>finite A; |A| <o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
14.50 +and "\<lbrakk>infinite A; |A| =o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
14.51 +shows phi
14.52 +using assms countable_or_card_of by blast
14.53 +
14.54 +lemma countable_cases[elim, consumes 1, case_names Fin Inf]:
14.55 +assumes "countable A"
14.56 +and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>finite A; inj_on f A\<rbrakk> \<Longrightarrow> phi"
14.57 +and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>infinite A; bij_betw f A UNIV\<rbrakk> \<Longrightarrow> phi"
14.58 +shows phi
14.59 +using assms countable_or by metis
14.60 +
14.61 +definition toNat_pred :: "'a set \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> bool"
14.62 +where
14.63 +"toNat_pred (A::'a set) f \<equiv>
14.64 + (finite A \<and> inj_on f A) \<or> (infinite A \<and> bij_betw f A UNIV)"
14.65 +definition toNat where "toNat A \<equiv> SOME f. toNat_pred A f"
14.66 +
14.67 +lemma toNat_pred:
14.68 +assumes "countable A"
14.69 +shows "\<exists> f. toNat_pred A f"
14.70 +using assms countable_ex_to_nat toNat_pred_def by (cases rule: countable_cases) auto
14.71 +
14.72 +lemma toNat_pred_toNat:
14.73 +assumes "countable A"
14.74 +shows "toNat_pred A (toNat A)"
14.75 +unfolding toNat_def apply(rule someI_ex[of "toNat_pred A"])
14.76 +using toNat_pred[OF assms] .
14.77 +
14.78 +lemma bij_betw_toNat:
14.79 +assumes c: "countable A" and i: "infinite A"
14.80 +shows "bij_betw (toNat A) A (UNIV::nat set)"
14.81 +using toNat_pred_toNat[OF c] unfolding toNat_pred_def using i by auto
14.82 +
14.83 +lemma inj_on_toNat:
14.84 +assumes c: "countable A"
14.85 +shows "inj_on (toNat A) A"
14.86 +using c apply(cases rule: countable_cases)
14.87 +using bij_betw_toNat[OF c] toNat_pred_toNat[OF c]
14.88 +unfolding toNat_pred_def unfolding bij_betw_def by auto
14.89 +
14.90 +lemma toNat_inj[simp]:
14.91 +assumes c: "countable A" and a: "a \<in> A" and b: "b \<in> A"
14.92 +shows "toNat A a = toNat A b \<longleftrightarrow> a = b"
14.93 +using inj_on_toNat[OF c] using a b unfolding inj_on_def by auto
14.94 +
14.95 +lemma image_toNat:
14.96 +assumes c: "countable A" and i: "infinite A"
14.97 +shows "toNat A ` A = UNIV"
14.98 +using bij_betw_toNat[OF assms] unfolding bij_betw_def by simp
14.99 +
14.100 +lemma toNat_surj:
14.101 +assumes "countable A" and i: "infinite A"
14.102 +shows "\<exists> a. a \<in> A \<and> toNat A a = n"
14.103 +using image_toNat[OF assms]
14.104 +by (metis (no_types) image_iff iso_tuple_UNIV_I)
14.105 +
14.106 +definition
14.107 +"fromNat A n \<equiv>
14.108 + if n \<in> toNat A ` A then inv_into A (toNat A) n
14.109 + else (SOME a. a \<in> A)"
14.110 +
14.111 +lemma fromNat:
14.112 +assumes "A \<noteq> {}"
14.113 +shows "fromNat A n \<in> A"
14.114 +unfolding fromNat_def by (metis assms equals0I inv_into_into someI_ex)
14.115 +
14.116 +lemma toNat_fromNat[simp]:
14.117 +assumes "n \<in> toNat A ` A"
14.118 +shows "toNat A (fromNat A n) = n"
14.119 +by (metis assms f_inv_into_f fromNat_def)
14.120 +
14.121 +lemma infinite_toNat_fromNat[simp]:
14.122 +assumes c: "countable A" and i: "infinite A"
14.123 +shows "toNat A (fromNat A n) = n"
14.124 +apply(rule toNat_fromNat) using toNat_surj[OF assms]
14.125 +by (metis image_iff)
14.126 +
14.127 +lemma fromNat_toNat[simp]:
14.128 +assumes c: "countable A" and a: "a \<in> A"
14.129 +shows "fromNat A (toNat A a) = a"
14.130 +by (metis a c equals0D fromNat imageI toNat_fromNat toNat_inj)
14.131 +
14.132 +lemma fromNat_inj:
14.133 +assumes c: "countable A" and i: "infinite A"
14.134 +shows "fromNat A m = fromNat A n \<longleftrightarrow> m = n" (is "?L = ?R \<longleftrightarrow> ?K")
14.135 +proof-
14.136 + have "?L = ?R \<longleftrightarrow> toNat A ?L = toNat A ?R"
14.137 + unfolding toNat_inj[OF c fromNat[OF infinite_imp_nonempty[OF i]]
14.138 + fromNat[OF infinite_imp_nonempty[OF i]]] ..
14.139 + also have "... \<longleftrightarrow> ?K" using c i by simp
14.140 + finally show ?thesis .
14.141 +qed
14.142 +
14.143 +lemma fromNat_surj:
14.144 +assumes c: "countable A" and a: "a \<in> A"
14.145 +shows "\<exists> n. fromNat A n = a"
14.146 +apply(rule exI[of _ "toNat A a"]) using assms by simp
14.147 +
14.148 +lemma fromNat_image_incl:
14.149 +assumes "A \<noteq> {}"
14.150 +shows "fromNat A ` UNIV \<subseteq> A"
14.151 +using fromNat[OF assms] by auto
14.152 +
14.153 +lemma incl_fromNat_image:
14.154 +assumes "countable A"
14.155 +shows "A \<subseteq> fromNat A ` UNIV"
14.156 +unfolding image_def using fromNat_surj[OF assms] by auto
14.157 +
14.158 +lemma fromNat_image[simp]:
14.159 +assumes "A \<noteq> {}" and "countable A"
14.160 +shows "fromNat A ` UNIV = A"
14.161 +by (metis assms equalityI fromNat_image_incl incl_fromNat_image)
14.162 +
14.163 +lemma fromNat_inject[simp]:
14.164 +assumes A: "A \<noteq> {}" "countable A" and B: "B \<noteq> {}" "countable B"
14.165 +shows "fromNat A = fromNat B \<longleftrightarrow> A = B"
14.166 +by (metis assms fromNat_image)
14.167 +
14.168 +lemma inj_on_fromNat:
14.169 +"inj_on fromNat ({A. A \<noteq> {} \<and> countable A})"
14.170 +unfolding inj_on_def by auto
14.171 +
14.172 +
14.173 +subsection {* Preservation under the set theoretic operations *}
14.174 +
14.175 +lemma contable_empty[simp,intro]:
14.176 +"countable {}"
14.177 +by (metis countable_ex_to_nat inj_on_empty)
14.178 +
14.179 +lemma incl_countable:
14.180 +assumes "A \<subseteq> B" and "countable B"
14.181 +shows "countable A"
14.182 +by (metis assms countable_ex_to_nat subset_inj_on)
14.183 +
14.184 +lemma countable_diff:
14.185 +assumes "countable A"
14.186 +shows "countable (A - B)"
14.187 +by (metis Diff_subset assms incl_countable)
14.188 +
14.189 +lemma finite_countable[simp]:
14.190 +assumes "finite A"
14.191 +shows "countable A"
14.192 +by (metis assms countable_ex_to_nat finite_imp_inj_to_nat_seg)
14.193 +
14.194 +lemma countable_singl[simp]:
14.195 +"countable {a}"
14.196 +by simp
14.197 +
14.198 +lemma countable_insert[simp]:
14.199 +"countable (insert a A) \<longleftrightarrow> countable A"
14.200 +proof
14.201 + assume c: "countable A"
14.202 + thus "countable (insert a A)"
14.203 + apply (cases rule: countable_cases_card_of)
14.204 + apply (metis finite_countable finite_insert)
14.205 + unfolding countable_card_of_nat
14.206 + by (metis infinite_card_of_insert ordIso_imp_ordLeq ordIso_transitive)
14.207 +qed(insert incl_countable, metis incl_countable subset_insertI)
14.208 +
14.209 +lemma contable_IntL[simp]:
14.210 +assumes "countable A"
14.211 +shows "countable (A \<inter> B)"
14.212 +by (metis Int_lower1 assms incl_countable)
14.213 +
14.214 +lemma contable_IntR[simp]:
14.215 +assumes "countable B"
14.216 +shows "countable (A \<inter> B)"
14.217 +by (metis assms contable_IntL inf.commute)
14.218 +
14.219 +lemma countable_UN[simp]:
14.220 +assumes cI: "countable I" and cA: "\<And> i. i \<in> I \<Longrightarrow> countable (A i)"
14.221 +shows "countable (\<Union> i \<in> I. A i)"
14.222 +using assms unfolding countable_card_of_nat
14.223 +apply(intro card_of_UNION_ordLeq_infinite) by auto
14.224 +
14.225 +lemma contable_Un[simp]:
14.226 +"countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
14.227 +proof safe
14.228 + assume cA: "countable A" and cB: "countable B"
14.229 + let ?I = "{0,Suc 0}" let ?As = "\<lambda> i. case i of 0 \<Rightarrow> A|Suc 0 \<Rightarrow> B"
14.230 + have AB: "A \<union> B = (\<Union> i \<in> ?I. ?As i)" by simp
14.231 + show "countable (A \<union> B)" unfolding AB apply(rule countable_UN)
14.232 + using cA cB by auto
14.233 +qed (metis Un_upper1 incl_countable, metis Un_upper2 incl_countable)
14.234 +
14.235 +lemma countable_INT[simp]:
14.236 +assumes "i \<in> I" and "countable (A i)"
14.237 +shows "countable (\<Inter> i \<in> I. A i)"
14.238 +by (metis INF_insert assms contable_IntL insert_absorb)
14.239 +
14.240 +lemma countable_class[simp]:
14.241 +fixes A :: "('a::countable) set"
14.242 +shows "countable A"
14.243 +proof-
14.244 + have "inj_on to_nat A" by (metis inj_on_to_nat)
14.245 + thus ?thesis by (metis countable_ex_to_nat)
14.246 +qed
14.247 +
14.248 +lemma countable_image[simp]:
14.249 +assumes "countable A"
14.250 +shows "countable (f ` A)"
14.251 +using assms unfolding countable_card_of_nat
14.252 +by (metis card_of_image ordLeq_transitive)
14.253 +
14.254 +lemma countable_ordLeq:
14.255 +assumes "|A| \<le>o |B|" and "countable B"
14.256 +shows "countable A"
14.257 +using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
14.258 +
14.259 +lemma countable_ordLess:
14.260 +assumes AB: "|A| <o |B|" and B: "countable B"
14.261 +shows "countable A"
14.262 +using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
14.263 +
14.264 +lemma countable_vimage:
14.265 +assumes "B \<subseteq> range f" and "countable (f -` B)"
14.266 +shows "countable B"
14.267 +by (metis Int_absorb2 assms countable_image image_vimage_eq)
14.268 +
14.269 +lemma surj_countable_vimage:
14.270 +assumes s: "surj f" and c: "countable (f -` B)"
14.271 +shows "countable B"
14.272 +apply(rule countable_vimage[OF _ c]) using s by auto
14.273 +
14.274 +lemma countable_Collect[simp]:
14.275 +assumes "countable A"
14.276 +shows "countable {a \<in> A. \<phi> a}"
14.277 +by (metis Collect_conj_eq Int_absorb Int_commute Int_def assms contable_IntR)
14.278 +
14.279 +lemma countable_Plus[simp]:
14.280 +assumes A: "countable A" and B: "countable B"
14.281 +shows "countable (A <+> B)"
14.282 +proof-
14.283 + let ?U = "UNIV::nat set"
14.284 + have "|A| \<le>o |?U|" and "|B| \<le>o |?U|" using A B
14.285 + using card_of_nat[THEN ordIso_symmetric] ordLeq_ordIso_trans
14.286 + unfolding countable_def by blast+
14.287 + hence "|A <+> B| \<le>o |?U|" by (intro card_of_Plus_ordLeq_infinite) auto
14.288 + thus ?thesis using card_of_nat unfolding countable_def by(rule ordLeq_ordIso_trans)
14.289 +qed
14.290 +
14.291 +lemma countable_Times[simp]:
14.292 +assumes A: "countable A" and B: "countable B"
14.293 +shows "countable (A \<times> B)"
14.294 +proof-
14.295 + let ?U = "UNIV::nat set"
14.296 + have "|A| \<le>o |?U|" and "|B| \<le>o |?U|" using A B
14.297 + using card_of_nat[THEN ordIso_symmetric] ordLeq_ordIso_trans
14.298 + unfolding countable_def by blast+
14.299 + hence "|A \<times> B| \<le>o |?U|" by (intro card_of_Times_ordLeq_infinite) auto
14.300 + thus ?thesis using card_of_nat unfolding countable_def by(rule ordLeq_ordIso_trans)
14.301 +qed
14.302 +
14.303 +lemma ordLeq_countable:
14.304 +assumes "|A| \<le>o |B|" and "countable B"
14.305 +shows "countable A"
14.306 +using assms unfolding countable_def by(rule ordLeq_transitive)
14.307 +
14.308 +lemma ordLess_countable:
14.309 +assumes A: "|A| <o |B|" and B: "countable B"
14.310 +shows "countable A"
14.311 +by (rule ordLeq_countable[OF ordLess_imp_ordLeq[OF A] B])
14.312 +
14.313 +lemma countable_def2: "countable A \<longleftrightarrow> |A| \<le>o |UNIV :: nat set|"
14.314 +unfolding countable_def using card_of_nat[THEN ordIso_symmetric]
14.315 +by (metis (lifting) Field_card_of Field_natLeq card_of_mono2 card_of_nat
14.316 + countable_def ordIso_imp_ordLeq ordLeq_countable)
14.317 +
14.318 +
14.319 +subsection{* The type of countable sets *}
14.320 +
14.321 +typedef (open) 'a cset = "{A :: 'a set. countable A}"
14.322 +apply(rule exI[of _ "{}"]) by simp
14.323 +
14.324 +abbreviation rcset where "rcset \<equiv> Rep_cset"
14.325 +abbreviation acset where "acset \<equiv> Abs_cset"
14.326 +
14.327 +lemmas acset_rcset = Rep_cset_inverse
14.328 +declare acset_rcset[simp]
14.329 +
14.330 +lemma acset_surj:
14.331 +"\<exists> A. countable A \<and> acset A = C"
14.332 +apply(cases rule: Abs_cset_cases[of C]) by auto
14.333 +
14.334 +lemma rcset_acset[simp]:
14.335 +assumes "countable A"
14.336 +shows "rcset (acset A) = A"
14.337 +using Abs_cset_inverse assms by auto
14.338 +
14.339 +lemma acset_inj[simp]:
14.340 +assumes "countable A" and "countable B"
14.341 +shows "acset A = acset B \<longleftrightarrow> A = B"
14.342 +using assms Abs_cset_inject by auto
14.343 +
14.344 +lemma rcset[simp]:
14.345 +"countable (rcset C)"
14.346 +using Rep_cset by simp
14.347 +
14.348 +lemma rcset_inj[simp]:
14.349 +"rcset C = rcset D \<longleftrightarrow> C = D"
14.350 +by (metis acset_rcset)
14.351 +
14.352 +lemma rcset_surj:
14.353 +assumes "countable A"
14.354 +shows "\<exists> C. rcset C = A"
14.355 +apply(cases rule: Rep_cset_cases[of A])
14.356 +using assms by auto
14.357 +
14.358 +definition "cIn a C \<equiv> (a \<in> rcset C)"
14.359 +definition "cEmp \<equiv> acset {}"
14.360 +definition "cIns a C \<equiv> acset (insert a (rcset C))"
14.361 +abbreviation cSingl where "cSingl a \<equiv> cIns a cEmp"
14.362 +definition "cUn C D \<equiv> acset (rcset C \<union> rcset D)"
14.363 +definition "cInt C D \<equiv> acset (rcset C \<inter> rcset D)"
14.364 +definition "cDif C D \<equiv> acset (rcset C - rcset D)"
14.365 +definition "cIm f C \<equiv> acset (f ` rcset C)"
14.366 +definition "cVim f D \<equiv> acset (f -` rcset D)"
14.367 +(* TODO eventually: nice setup for these operations, copied from the set setup *)
14.368 +
14.369 +end
15.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2 +++ b/src/HOL/BNF/Equiv_Relations_More.thy Fri Sep 21 16:45:06 2012 +0200
15.3 @@ -0,0 +1,161 @@
15.4 +(* Title: HOL/BNF/Equiv_Relations_More.thy
15.5 + Author: Andrei Popescu, TU Muenchen
15.6 + Copyright 2012
15.7 +
15.8 +Some preliminaries on equivalence relations and quotients.
15.9 +*)
15.10 +
15.11 +header {* Some Preliminaries on Equivalence Relations and Quotients *}
15.12 +
15.13 +theory Equiv_Relations_More
15.14 +imports Equiv_Relations Hilbert_Choice
15.15 +begin
15.16 +
15.17 +
15.18 +(* Recall the following constants and lemmas:
15.19 +
15.20 +term Eps
15.21 +term "A//r"
15.22 +lemmas equiv_def
15.23 +lemmas refl_on_def
15.24 + -- note that "reflexivity on" also assumes inclusion of the relation's field into r
15.25 +
15.26 +*)
15.27 +
15.28 +definition proj where "proj r x = r `` {x}"
15.29 +
15.30 +definition univ where "univ f X == f (Eps (%x. x \<in> X))"
15.31 +
15.32 +lemma proj_preserves:
15.33 +"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
15.34 +unfolding proj_def by (rule quotientI)
15.35 +
15.36 +lemma proj_in_iff:
15.37 +assumes "equiv A r"
15.38 +shows "(proj r x \<in> A//r) = (x \<in> A)"
15.39 +apply(rule iffI, auto simp add: proj_preserves)
15.40 +unfolding proj_def quotient_def proof clarsimp
15.41 + fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
15.42 + moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by blast
15.43 + ultimately have "(x,y) \<in> r" by blast
15.44 + thus "x \<in> A" using assms unfolding equiv_def refl_on_def by blast
15.45 +qed
15.46 +
15.47 +lemma proj_iff:
15.48 +"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
15.49 +by (simp add: proj_def eq_equiv_class_iff)
15.50 +
15.51 +(*
15.52 +lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
15.53 +unfolding proj_def equiv_def refl_on_def by blast
15.54 +*)
15.55 +
15.56 +lemma proj_image: "(proj r) ` A = A//r"
15.57 +unfolding proj_def[abs_def] quotient_def by blast
15.58 +
15.59 +lemma in_quotient_imp_non_empty:
15.60 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<noteq> {}"
15.61 +unfolding quotient_def using equiv_class_self by fast
15.62 +
15.63 +lemma in_quotient_imp_in_rel:
15.64 +"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
15.65 +using quotient_eq_iff by fastforce
15.66 +
15.67 +lemma in_quotient_imp_closed:
15.68 +"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
15.69 +unfolding quotient_def equiv_def trans_def by blast
15.70 +
15.71 +lemma in_quotient_imp_subset:
15.72 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
15.73 +using assms in_quotient_imp_in_rel equiv_type by fastforce
15.74 +
15.75 +lemma equiv_Eps_in:
15.76 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
15.77 +apply (rule someI2_ex)
15.78 +using in_quotient_imp_non_empty by blast
15.79 +
15.80 +lemma equiv_Eps_preserves:
15.81 +assumes ECH: "equiv A r" and X: "X \<in> A//r"
15.82 +shows "Eps (%x. x \<in> X) \<in> A"
15.83 +apply (rule in_mono[rule_format])
15.84 + using assms apply (rule in_quotient_imp_subset)
15.85 +by (rule equiv_Eps_in) (rule assms)+
15.86 +
15.87 +lemma proj_Eps:
15.88 +assumes "equiv A r" and "X \<in> A//r"
15.89 +shows "proj r (Eps (%x. x \<in> X)) = X"
15.90 +unfolding proj_def proof auto
15.91 + fix x assume x: "x \<in> X"
15.92 + thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
15.93 +next
15.94 + fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
15.95 + thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
15.96 +qed
15.97 +
15.98 +(*
15.99 +lemma Eps_proj:
15.100 +assumes "equiv A r" and "x \<in> A"
15.101 +shows "(Eps (%y. y \<in> proj r x), x) \<in> r"
15.102 +proof-
15.103 + have 1: "proj r x \<in> A//r" using assms proj_preserves by fastforce
15.104 + hence "Eps(%y. y \<in> proj r x) \<in> proj r x" using assms equiv_Eps_in by auto
15.105 + moreover have "x \<in> proj r x" using assms in_proj by fastforce
15.106 + ultimately show ?thesis using assms 1 in_quotient_imp_in_rel by fastforce
15.107 +qed
15.108 +
15.109 +lemma equiv_Eps_iff:
15.110 +assumes "equiv A r" and "{X,Y} \<subseteq> A//r"
15.111 +shows "((Eps (%x. x \<in> X),Eps (%y. y \<in> Y)) \<in> r) = (X = Y)"
15.112 +proof-
15.113 + have "Eps (%x. x \<in> X) \<in> X \<and> Eps (%y. y \<in> Y) \<in> Y" using assms equiv_Eps_in by auto
15.114 + thus ?thesis using assms quotient_eq_iff by fastforce
15.115 +qed
15.116 +
15.117 +lemma equiv_Eps_inj_on:
15.118 +assumes "equiv A r"
15.119 +shows "inj_on (%X. Eps (%x. x \<in> X)) (A//r)"
15.120 +unfolding inj_on_def proof clarify
15.121 + fix X Y assume X: "X \<in> A//r" and Y: "Y \<in> A//r" and Eps: "Eps (%x. x \<in> X) = Eps (%y. y \<in> Y)"
15.122 + hence "Eps (%x. x \<in> X) \<in> A" using assms equiv_Eps_preserves by auto
15.123 + hence "(Eps (%x. x \<in> X), Eps (%y. y \<in> Y)) \<in> r"
15.124 + using assms Eps unfolding quotient_def equiv_def refl_on_def by auto
15.125 + thus "X= Y" using X Y assms equiv_Eps_iff by auto
15.126 +qed
15.127 +*)
15.128 +
15.129 +lemma univ_commute:
15.130 +assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
15.131 +shows "(univ f) (proj r x) = f x"
15.132 +unfolding univ_def proof -
15.133 + have prj: "proj r x \<in> A//r" using x proj_preserves by fast
15.134 + hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
15.135 + moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
15.136 + ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
15.137 + thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
15.138 +qed
15.139 +
15.140 +(*
15.141 +lemma univ_unique:
15.142 +assumes ECH: "equiv A r" and
15.143 + RES: "f respects r" and COM: "\<forall> x \<in> A. G (proj r x) = f x"
15.144 +shows "\<forall> X \<in> A//r. G X = univ f X"
15.145 +proof
15.146 + fix X assume "X \<in> A//r"
15.147 + then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
15.148 + have "G X = f x" unfolding X using x COM by simp
15.149 + thus "G X = univ f X" unfolding X using ECH RES x univ_commute by fastforce
15.150 +qed
15.151 +*)
15.152 +
15.153 +lemma univ_preserves:
15.154 +assumes ECH: "equiv A r" and RES: "f respects r" and
15.155 + PRES: "\<forall> x \<in> A. f x \<in> B"
15.156 +shows "\<forall> X \<in> A//r. univ f X \<in> B"
15.157 +proof
15.158 + fix X assume "X \<in> A//r"
15.159 + then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
15.160 + hence "univ f X = f x" using assms univ_commute by fastforce
15.161 + thus "univ f X \<in> B" using x PRES by simp
15.162 +qed
15.163 +
15.164 +end
16.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2 +++ b/src/HOL/BNF/Examples/HFset.thy Fri Sep 21 16:45:06 2012 +0200
16.3 @@ -0,0 +1,60 @@
16.4 +(* Title: HOL/BNF/Examples/HFset.thy
16.5 + Author: Andrei Popescu, TU Muenchen
16.6 + Copyright 2012
16.7 +
16.8 +Hereditary sets.
16.9 +*)
16.10 +
16.11 +header {* Hereditary Sets *}
16.12 +
16.13 +theory HFset
16.14 +imports "../BNF"
16.15 +begin
16.16 +
16.17 +
16.18 +section {* Datatype definition *}
16.19 +
16.20 +data_raw hfset: 'hfset = "'hfset fset"
16.21 +
16.22 +
16.23 +section {* Customization of terms *}
16.24 +
16.25 +subsection{* Constructors *}
16.26 +
16.27 +definition "Fold hs \<equiv> hfset_ctor hs"
16.28 +
16.29 +lemma hfset_simps[simp]:
16.30 +"\<And>hs1 hs2. Fold hs1 = Fold hs2 \<longrightarrow> hs1 = hs2"
16.31 +unfolding Fold_def hfset.ctor_inject by auto
16.32 +
16.33 +theorem hfset_cases[elim, case_names Fold]:
16.34 +assumes Fold: "\<And> hs. h = Fold hs \<Longrightarrow> phi"
16.35 +shows phi
16.36 +using Fold unfolding Fold_def
16.37 +by (cases rule: hfset.ctor_exhaust[of h]) simp
16.38 +
16.39 +lemma hfset_induct[case_names Fold, induct type: hfset]:
16.40 +assumes Fold: "\<And> hs. (\<And> h. h |\<in>| hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
16.41 +shows "phi t"
16.42 +apply (induct rule: hfset.ctor_induct)
16.43 +using Fold unfolding Fold_def fset_fset_member mem_Collect_eq ..
16.44 +
16.45 +(* alternative induction principle, using fset: *)
16.46 +lemma hfset_induct_fset[case_names Fold, induct type: hfset]:
16.47 +assumes Fold: "\<And> hs. (\<And> h. h \<in> fset hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
16.48 +shows "phi t"
16.49 +apply (induct rule: hfset_induct)
16.50 +using Fold by (metis notin_fset)
16.51 +
16.52 +subsection{* Recursion and iteration (fold) *}
16.53 +
16.54 +lemma hfset_ctor_rec:
16.55 +"hfset_ctor_rec R (Fold hs) = R (map_fset <id, hfset_ctor_rec R> hs)"
16.56 +using hfset.ctor_recs unfolding Fold_def .
16.57 +
16.58 +(* The iterator has a simpler form: *)
16.59 +lemma hfset_ctor_fold:
16.60 +"hfset_ctor_fold R (Fold hs) = R (map_fset (hfset_ctor_fold R) hs)"
16.61 +using hfset.ctor_folds unfolding Fold_def .
16.62 +
16.63 +end
17.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Gram_Lang.thy Fri Sep 21 16:45:06 2012 +0200
17.3 @@ -0,0 +1,1366 @@
17.4 +(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Gram_Lang.thy
17.5 + Author: Andrei Popescu, TU Muenchen
17.6 + Copyright 2012
17.7 +
17.8 +Language of a grammar.
17.9 +*)
17.10 +
17.11 +header {* Language of a Grammar *}
17.12 +
17.13 +theory Gram_Lang
17.14 +imports Tree
17.15 +begin
17.16 +
17.17 +
17.18 +consts P :: "(N \<times> (T + N) set) set"
17.19 +axiomatization where
17.20 + finite_N: "finite (UNIV::N set)"
17.21 +and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
17.22 +and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
17.23 +
17.24 +
17.25 +subsection{* Tree basics: frontier, interior, etc. *}
17.26 +
17.27 +lemma Tree_cong:
17.28 +assumes "root tr = root tr'" and "cont tr = cont tr'"
17.29 +shows "tr = tr'"
17.30 +by (metis Node_root_cont assms)
17.31 +
17.32 +inductive finiteT where
17.33 +Node: "\<lbrakk>finite as; (finiteT^#) as\<rbrakk> \<Longrightarrow> finiteT (Node a as)"
17.34 +monos lift_mono
17.35 +
17.36 +lemma finiteT_induct[consumes 1, case_names Node, induct pred: finiteT]:
17.37 +assumes 1: "finiteT tr"
17.38 +and IH: "\<And>as n. \<lbrakk>finite as; (\<phi>^#) as\<rbrakk> \<Longrightarrow> \<phi> (Node n as)"
17.39 +shows "\<phi> tr"
17.40 +using 1 apply(induct rule: finiteT.induct)
17.41 +apply(rule IH) apply assumption apply(elim mono_lift) by simp
17.42 +
17.43 +
17.44 +(* Frontier *)
17.45 +
17.46 +inductive inFr :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where
17.47 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
17.48 +|
17.49 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
17.50 +
17.51 +definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
17.52 +
17.53 +lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
17.54 +by (metis inFr.simps)
17.55 +
17.56 +lemma inFr_mono:
17.57 +assumes "inFr ns tr t" and "ns \<subseteq> ns'"
17.58 +shows "inFr ns' tr t"
17.59 +using assms apply(induct arbitrary: ns' rule: inFr.induct)
17.60 +using Base Ind by (metis inFr.simps set_mp)+
17.61 +
17.62 +lemma inFr_Ind_minus:
17.63 +assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
17.64 +shows "inFr (insert (root tr) ns1) tr t"
17.65 +using assms apply(induct rule: inFr.induct)
17.66 + apply (metis inFr.simps insert_iff)
17.67 + by (metis inFr.simps inFr_mono insertI1 subset_insertI)
17.68 +
17.69 +(* alternative definition *)
17.70 +inductive inFr2 :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where
17.71 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
17.72 +|
17.73 +Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
17.74 + \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
17.75 +
17.76 +lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
17.77 +apply(induct rule: inFr2.induct) by auto
17.78 +
17.79 +lemma inFr2_mono:
17.80 +assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
17.81 +shows "inFr2 ns' tr t"
17.82 +using assms apply(induct arbitrary: ns' rule: inFr2.induct)
17.83 +using Base Ind
17.84 +apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
17.85 +
17.86 +lemma inFr2_Ind:
17.87 +assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
17.88 +shows "inFr2 ns tr t"
17.89 +using assms apply(induct rule: inFr2.induct)
17.90 + apply (metis inFr2.simps insert_absorb)
17.91 + by (metis inFr2.simps insert_absorb)
17.92 +
17.93 +lemma inFr_inFr2:
17.94 +"inFr = inFr2"
17.95 +apply (rule ext)+ apply(safe)
17.96 + apply(erule inFr.induct)
17.97 + apply (metis (lifting) inFr2.Base)
17.98 + apply (metis (lifting) inFr2_Ind)
17.99 + apply(erule inFr2.induct)
17.100 + apply (metis (lifting) inFr.Base)
17.101 + apply (metis (lifting) inFr_Ind_minus)
17.102 +done
17.103 +
17.104 +lemma not_root_inFr:
17.105 +assumes "root tr \<notin> ns"
17.106 +shows "\<not> inFr ns tr t"
17.107 +by (metis assms inFr_root_in)
17.108 +
17.109 +theorem not_root_Fr:
17.110 +assumes "root tr \<notin> ns"
17.111 +shows "Fr ns tr = {}"
17.112 +using not_root_inFr[OF assms] unfolding Fr_def by auto
17.113 +
17.114 +
17.115 +(* Interior *)
17.116 +
17.117 +inductive inItr :: "N set \<Rightarrow> Tree \<Rightarrow> N \<Rightarrow> bool" where
17.118 +Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
17.119 +|
17.120 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
17.121 +
17.122 +definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
17.123 +
17.124 +lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
17.125 +by (metis inItr.simps)
17.126 +
17.127 +lemma inItr_mono:
17.128 +assumes "inItr ns tr n" and "ns \<subseteq> ns'"
17.129 +shows "inItr ns' tr n"
17.130 +using assms apply(induct arbitrary: ns' rule: inItr.induct)
17.131 +using Base Ind by (metis inItr.simps set_mp)+
17.132 +
17.133 +
17.134 +(* The subtree relation *)
17.135 +
17.136 +inductive subtr where
17.137 +Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
17.138 +|
17.139 +Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
17.140 +
17.141 +lemma subtr_rootL_in:
17.142 +assumes "subtr ns tr1 tr2"
17.143 +shows "root tr1 \<in> ns"
17.144 +using assms apply(induct rule: subtr.induct) by auto
17.145 +
17.146 +lemma subtr_rootR_in:
17.147 +assumes "subtr ns tr1 tr2"
17.148 +shows "root tr2 \<in> ns"
17.149 +using assms apply(induct rule: subtr.induct) by auto
17.150 +
17.151 +lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
17.152 +
17.153 +lemma subtr_mono:
17.154 +assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
17.155 +shows "subtr ns' tr1 tr2"
17.156 +using assms apply(induct arbitrary: ns' rule: subtr.induct)
17.157 +using Refl Step by (metis subtr.simps set_mp)+
17.158 +
17.159 +lemma subtr_trans_Un:
17.160 +assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
17.161 +shows "subtr (ns12 \<union> ns23) tr1 tr3"
17.162 +proof-
17.163 + have "subtr ns23 tr2 tr3 \<Longrightarrow>
17.164 + (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
17.165 + apply(induct rule: subtr.induct, safe)
17.166 + apply (metis subtr_mono sup_commute sup_ge2)
17.167 + by (metis (lifting) Step UnI2)
17.168 + thus ?thesis using assms by auto
17.169 +qed
17.170 +
17.171 +lemma subtr_trans:
17.172 +assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
17.173 +shows "subtr ns tr1 tr3"
17.174 +using subtr_trans_Un[OF assms] by simp
17.175 +
17.176 +lemma subtr_StepL:
17.177 +assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
17.178 +shows "subtr ns tr1 tr3"
17.179 +apply(rule subtr_trans[OF _ s]) apply(rule Step[of tr2 ns tr1 tr1])
17.180 +by (metis assms subtr_rootL_in Refl)+
17.181 +
17.182 +(* alternative definition: *)
17.183 +inductive subtr2 where
17.184 +Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
17.185 +|
17.186 +Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
17.187 +
17.188 +lemma subtr2_rootL_in:
17.189 +assumes "subtr2 ns tr1 tr2"
17.190 +shows "root tr1 \<in> ns"
17.191 +using assms apply(induct rule: subtr2.induct) by auto
17.192 +
17.193 +lemma subtr2_rootR_in:
17.194 +assumes "subtr2 ns tr1 tr2"
17.195 +shows "root tr2 \<in> ns"
17.196 +using assms apply(induct rule: subtr2.induct) by auto
17.197 +
17.198 +lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
17.199 +
17.200 +lemma subtr2_mono:
17.201 +assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
17.202 +shows "subtr2 ns' tr1 tr2"
17.203 +using assms apply(induct arbitrary: ns' rule: subtr2.induct)
17.204 +using Refl Step by (metis subtr2.simps set_mp)+
17.205 +
17.206 +lemma subtr2_trans_Un:
17.207 +assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
17.208 +shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
17.209 +proof-
17.210 + have "subtr2 ns12 tr1 tr2 \<Longrightarrow>
17.211 + (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
17.212 + apply(induct rule: subtr2.induct, safe)
17.213 + apply (metis subtr2_mono sup_commute sup_ge2)
17.214 + by (metis Un_iff subtr2.simps)
17.215 + thus ?thesis using assms by auto
17.216 +qed
17.217 +
17.218 +lemma subtr2_trans:
17.219 +assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
17.220 +shows "subtr2 ns tr1 tr3"
17.221 +using subtr2_trans_Un[OF assms] by simp
17.222 +
17.223 +lemma subtr2_StepR:
17.224 +assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
17.225 +shows "subtr2 ns tr1 tr3"
17.226 +apply(rule subtr2_trans[OF s]) apply(rule Step[of _ _ tr3])
17.227 +by (metis assms subtr2_rootR_in Refl)+
17.228 +
17.229 +lemma subtr_subtr2:
17.230 +"subtr = subtr2"
17.231 +apply (rule ext)+ apply(safe)
17.232 + apply(erule subtr.induct)
17.233 + apply (metis (lifting) subtr2.Refl)
17.234 + apply (metis (lifting) subtr2_StepR)
17.235 + apply(erule subtr2.induct)
17.236 + apply (metis (lifting) subtr.Refl)
17.237 + apply (metis (lifting) subtr_StepL)
17.238 +done
17.239 +
17.240 +lemma subtr_inductL[consumes 1, case_names Refl Step]:
17.241 +assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
17.242 +and Step:
17.243 +"\<And>ns tr1 tr2 tr3.
17.244 + \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
17.245 +shows "\<phi> ns tr1 tr2"
17.246 +using s unfolding subtr_subtr2 apply(rule subtr2.induct)
17.247 +using Refl Step unfolding subtr_subtr2 by auto
17.248 +
17.249 +lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
17.250 +assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
17.251 +and Step:
17.252 +"\<And>tr1 tr2 tr3.
17.253 + \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
17.254 +shows "\<phi> tr1 tr2"
17.255 +using s apply(induct rule: subtr_inductL)
17.256 +apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
17.257 +
17.258 +(* Subtree versus frontier: *)
17.259 +lemma subtr_inFr:
17.260 +assumes "inFr ns tr t" and "subtr ns tr tr1"
17.261 +shows "inFr ns tr1 t"
17.262 +proof-
17.263 + have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
17.264 + apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
17.265 + thus ?thesis using assms by auto
17.266 +qed
17.267 +
17.268 +corollary Fr_subtr:
17.269 +"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
17.270 +unfolding Fr_def proof safe
17.271 + fix t assume t: "inFr ns tr t" hence "root tr \<in> ns" by (rule inFr_root_in)
17.272 + thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
17.273 + apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
17.274 +qed(metis subtr_inFr)
17.275 +
17.276 +lemma inFr_subtr:
17.277 +assumes "inFr ns tr t"
17.278 +shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
17.279 +using assms apply(induct rule: inFr.induct) apply safe
17.280 + apply (metis subtr.Refl)
17.281 + by (metis (lifting) subtr.Step)
17.282 +
17.283 +corollary Fr_subtr_cont:
17.284 +"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
17.285 +unfolding Fr_def
17.286 +apply safe
17.287 +apply (frule inFr_subtr)
17.288 +apply auto
17.289 +by (metis inFr.Base subtr_inFr subtr_rootL_in)
17.290 +
17.291 +(* Subtree versus interior: *)
17.292 +lemma subtr_inItr:
17.293 +assumes "inItr ns tr n" and "subtr ns tr tr1"
17.294 +shows "inItr ns tr1 n"
17.295 +proof-
17.296 + have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
17.297 + apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
17.298 + thus ?thesis using assms by auto
17.299 +qed
17.300 +
17.301 +corollary Itr_subtr:
17.302 +"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
17.303 +unfolding Itr_def apply safe
17.304 +apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
17.305 +by (metis subtr_inItr)
17.306 +
17.307 +lemma inItr_subtr:
17.308 +assumes "inItr ns tr n"
17.309 +shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
17.310 +using assms apply(induct rule: inItr.induct) apply safe
17.311 + apply (metis subtr.Refl)
17.312 + by (metis (lifting) subtr.Step)
17.313 +
17.314 +corollary Itr_subtr_cont:
17.315 +"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
17.316 +unfolding Itr_def apply safe
17.317 + apply (metis (lifting, mono_tags) UnionI inItr_subtr mem_Collect_eq vimageI2)
17.318 + by (metis inItr.Base subtr_inItr subtr_rootL_in)
17.319 +
17.320 +
17.321 +subsection{* The immediate subtree function *}
17.322 +
17.323 +(* production of: *)
17.324 +abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
17.325 +(* subtree of: *)
17.326 +definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
17.327 +
17.328 +lemma subtrOf:
17.329 +assumes n: "Inr n \<in> prodOf tr"
17.330 +shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
17.331 +proof-
17.332 + obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
17.333 + using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
17.334 + thus ?thesis unfolding subtrOf_def by(rule someI)
17.335 +qed
17.336 +
17.337 +lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
17.338 +lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
17.339 +
17.340 +lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
17.341 +proof safe
17.342 + fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
17.343 + thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
17.344 +next
17.345 + fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
17.346 + by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
17.347 +qed
17.348 +
17.349 +lemma root_prodOf:
17.350 +assumes "Inr tr' \<in> cont tr"
17.351 +shows "Inr (root tr') \<in> prodOf tr"
17.352 +by (metis (lifting) assms image_iff sum_map.simps(2))
17.353 +
17.354 +
17.355 +subsection{* Derivation trees *}
17.356 +
17.357 +coinductive dtree where
17.358 +Tree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
17.359 + lift dtree (cont tr)\<rbrakk> \<Longrightarrow> dtree tr"
17.360 +monos lift_mono
17.361 +
17.362 +(* destruction rules: *)
17.363 +lemma dtree_P:
17.364 +assumes "dtree tr"
17.365 +shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
17.366 +using assms unfolding dtree.simps by auto
17.367 +
17.368 +lemma dtree_inj_on:
17.369 +assumes "dtree tr"
17.370 +shows "inj_on root (Inr -` cont tr)"
17.371 +using assms unfolding dtree.simps by auto
17.372 +
17.373 +lemma dtree_inj[simp]:
17.374 +assumes "dtree tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
17.375 +shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
17.376 +using assms dtree_inj_on unfolding inj_on_def by auto
17.377 +
17.378 +lemma dtree_lift:
17.379 +assumes "dtree tr"
17.380 +shows "lift dtree (cont tr)"
17.381 +using assms unfolding dtree.simps by auto
17.382 +
17.383 +
17.384 +(* coinduction:*)
17.385 +lemma dtree_coind[elim, consumes 1, case_names Hyp]:
17.386 +assumes phi: "\<phi> tr"
17.387 +and Hyp:
17.388 +"\<And> tr. \<phi> tr \<Longrightarrow>
17.389 + (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
17.390 + inj_on root (Inr -` cont tr) \<and>
17.391 + lift (\<lambda> tr. \<phi> tr \<or> dtree tr) (cont tr)"
17.392 +shows "dtree tr"
17.393 +apply(rule dtree.coinduct[of \<phi> tr, OF phi])
17.394 +using Hyp by blast
17.395 +
17.396 +lemma dtree_raw_coind[elim, consumes 1, case_names Hyp]:
17.397 +assumes phi: "\<phi> tr"
17.398 +and Hyp:
17.399 +"\<And> tr. \<phi> tr \<Longrightarrow>
17.400 + (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
17.401 + inj_on root (Inr -` cont tr) \<and>
17.402 + lift \<phi> (cont tr)"
17.403 +shows "dtree tr"
17.404 +using phi apply(induct rule: dtree_coind)
17.405 +using Hyp mono_lift
17.406 +by (metis (mono_tags) mono_lift)
17.407 +
17.408 +lemma dtree_subtr_inj_on:
17.409 +assumes d: "dtree tr1" and s: "subtr ns tr tr1"
17.410 +shows "inj_on root (Inr -` cont tr)"
17.411 +using s d apply(induct rule: subtr.induct)
17.412 +apply (metis (lifting) dtree_inj_on) by (metis dtree_lift lift_def)
17.413 +
17.414 +lemma dtree_subtr_P:
17.415 +assumes d: "dtree tr1" and s: "subtr ns tr tr1"
17.416 +shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
17.417 +using s d apply(induct rule: subtr.induct)
17.418 +apply (metis (lifting) dtree_P) by (metis dtree_lift lift_def)
17.419 +
17.420 +lemma subtrOf_root[simp]:
17.421 +assumes tr: "dtree tr" and cont: "Inr tr' \<in> cont tr"
17.422 +shows "subtrOf tr (root tr') = tr'"
17.423 +proof-
17.424 + have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
17.425 + by (metis (lifting) cont root_prodOf)
17.426 + have "root (subtrOf tr (root tr')) = root tr'"
17.427 + using root_subtrOf by (metis (lifting) cont root_prodOf)
17.428 + thus ?thesis unfolding dtree_inj[OF tr 0 cont] .
17.429 +qed
17.430 +
17.431 +lemma surj_subtrOf:
17.432 +assumes "dtree tr" and 0: "Inr tr' \<in> cont tr"
17.433 +shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
17.434 +apply(rule exI[of _ "root tr'"])
17.435 +using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
17.436 +
17.437 +lemma dtree_subtr:
17.438 +assumes "dtree tr1" and "subtr ns tr tr1"
17.439 +shows "dtree tr"
17.440 +proof-
17.441 + have "(\<exists> ns tr1. dtree tr1 \<and> subtr ns tr tr1) \<Longrightarrow> dtree tr"
17.442 + proof (induct rule: dtree_raw_coind)
17.443 + case (Hyp tr)
17.444 + then obtain ns tr1 where tr1: "dtree tr1" and tr_tr1: "subtr ns tr tr1" by auto
17.445 + show ?case unfolding lift_def proof safe
17.446 + show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using dtree_subtr_P[OF tr1 tr_tr1] .
17.447 + next
17.448 + show "inj_on root (Inr -` cont tr)" using dtree_subtr_inj_on[OF tr1 tr_tr1] .
17.449 + next
17.450 + fix tr' assume tr': "Inr tr' \<in> cont tr"
17.451 + have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
17.452 + have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
17.453 + thus "\<exists>ns' tr1. dtree tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
17.454 + qed
17.455 + qed
17.456 + thus ?thesis using assms by auto
17.457 +qed
17.458 +
17.459 +
17.460 +subsection{* Default trees *}
17.461 +
17.462 +(* Pick a left-hand side of a production for each nonterminal *)
17.463 +definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
17.464 +
17.465 +lemma S_P: "(n, S n) \<in> P"
17.466 +using used unfolding S_def by(rule someI_ex)
17.467 +
17.468 +lemma finite_S: "finite (S n)"
17.469 +using S_P finite_in_P by auto
17.470 +
17.471 +
17.472 +(* The default tree of a nonterminal *)
17.473 +definition deftr :: "N \<Rightarrow> Tree" where
17.474 +"deftr \<equiv> unfold id S"
17.475 +
17.476 +lemma deftr_simps[simp]:
17.477 +"root (deftr n) = n"
17.478 +"cont (deftr n) = image (id \<oplus> deftr) (S n)"
17.479 +using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
17.480 +unfolding deftr_def by simp_all
17.481 +
17.482 +lemmas root_deftr = deftr_simps(1)
17.483 +lemmas cont_deftr = deftr_simps(2)
17.484 +
17.485 +lemma root_o_deftr[simp]: "root o deftr = id"
17.486 +by (rule ext, auto)
17.487 +
17.488 +lemma dtree_deftr: "dtree (deftr n)"
17.489 +proof-
17.490 + {fix tr assume "\<exists> n. tr = deftr n" hence "dtree tr"
17.491 + apply(induct rule: dtree_raw_coind) apply safe
17.492 + unfolding deftr_simps image_compose[symmetric] sum_map.comp id_o
17.493 + root_o_deftr sum_map.id image_id id_apply apply(rule S_P)
17.494 + unfolding inj_on_def lift_def by auto
17.495 + }
17.496 + thus ?thesis by auto
17.497 +qed
17.498 +
17.499 +
17.500 +subsection{* Hereditary substitution *}
17.501 +
17.502 +(* Auxiliary concept: The root-ommiting frontier: *)
17.503 +definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
17.504 +definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
17.505 +
17.506 +context
17.507 +fixes tr0 :: Tree
17.508 +begin
17.509 +
17.510 +definition "hsubst_r tr \<equiv> root tr"
17.511 +definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
17.512 +
17.513 +(* Hereditary substitution: *)
17.514 +definition hsubst :: "Tree \<Rightarrow> Tree" where
17.515 +"hsubst \<equiv> unfold hsubst_r hsubst_c"
17.516 +
17.517 +lemma finite_hsubst_c: "finite (hsubst_c n)"
17.518 +unfolding hsubst_c_def by (metis finite_cont)
17.519 +
17.520 +lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
17.521 +using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
17.522 +
17.523 +lemma root_o_subst[simp]: "root o hsubst = root"
17.524 +unfolding comp_def root_hsubst ..
17.525 +
17.526 +lemma cont_hsubst_eq[simp]:
17.527 +assumes "root tr = root tr0"
17.528 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
17.529 +apply(subst id_o[symmetric, of id]) unfolding id_o
17.530 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
17.531 +unfolding hsubst_def hsubst_c_def using assms by simp
17.532 +
17.533 +lemma hsubst_eq:
17.534 +assumes "root tr = root tr0"
17.535 +shows "hsubst tr = hsubst tr0"
17.536 +apply(rule Tree_cong) using assms cont_hsubst_eq by auto
17.537 +
17.538 +lemma cont_hsubst_neq[simp]:
17.539 +assumes "root tr \<noteq> root tr0"
17.540 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
17.541 +apply(subst id_o[symmetric, of id]) unfolding id_o
17.542 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
17.543 +unfolding hsubst_def hsubst_c_def using assms by simp
17.544 +
17.545 +lemma Inl_cont_hsubst_eq[simp]:
17.546 +assumes "root tr = root tr0"
17.547 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
17.548 +unfolding cont_hsubst_eq[OF assms] by simp
17.549 +
17.550 +lemma Inr_cont_hsubst_eq[simp]:
17.551 +assumes "root tr = root tr0"
17.552 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
17.553 +unfolding cont_hsubst_eq[OF assms] by simp
17.554 +
17.555 +lemma Inl_cont_hsubst_neq[simp]:
17.556 +assumes "root tr \<noteq> root tr0"
17.557 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
17.558 +unfolding cont_hsubst_neq[OF assms] by simp
17.559 +
17.560 +lemma Inr_cont_hsubst_neq[simp]:
17.561 +assumes "root tr \<noteq> root tr0"
17.562 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
17.563 +unfolding cont_hsubst_neq[OF assms] by simp
17.564 +
17.565 +lemma dtree_hsubst:
17.566 +assumes tr0: "dtree tr0" and tr: "dtree tr"
17.567 +shows "dtree (hsubst tr)"
17.568 +proof-
17.569 + {fix tr1 have "(\<exists> tr. dtree tr \<and> tr1 = hsubst tr) \<Longrightarrow> dtree tr1"
17.570 + proof (induct rule: dtree_raw_coind)
17.571 + case (Hyp tr1) then obtain tr
17.572 + where dtr: "dtree tr" and tr1: "tr1 = hsubst tr" by auto
17.573 + show ?case unfolding lift_def tr1 proof safe
17.574 + show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
17.575 + unfolding tr1 apply(cases "root tr = root tr0")
17.576 + using dtree_P[OF dtr] dtree_P[OF tr0]
17.577 + by (auto simp add: image_compose[symmetric] sum_map.comp)
17.578 + show "inj_on root (Inr -` cont (hsubst tr))"
17.579 + apply(cases "root tr = root tr0") using dtree_inj_on[OF dtr] dtree_inj_on[OF tr0]
17.580 + unfolding inj_on_def by (auto, blast)
17.581 + fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
17.582 + thus "\<exists>tra. dtree tra \<and> tr' = hsubst tra"
17.583 + apply(cases "root tr = root tr0", simp_all)
17.584 + apply (metis dtree_lift lift_def tr0)
17.585 + by (metis dtr dtree_lift lift_def)
17.586 + qed
17.587 + qed
17.588 + }
17.589 + thus ?thesis using assms by blast
17.590 +qed
17.591 +
17.592 +lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
17.593 +unfolding inFrr_def Frr_def Fr_def by auto
17.594 +
17.595 +lemma inFr_hsubst_imp:
17.596 +assumes "inFr ns (hsubst tr) t"
17.597 +shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
17.598 + inFr (ns - {root tr0}) tr t"
17.599 +proof-
17.600 + {fix tr1
17.601 + have "inFr ns tr1 t \<Longrightarrow>
17.602 + (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
17.603 + inFr (ns - {root tr0}) tr t))"
17.604 + proof(induct rule: inFr.induct)
17.605 + case (Base tr1 ns t tr)
17.606 + hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
17.607 + by auto
17.608 + show ?case
17.609 + proof(cases "root tr1 = root tr0")
17.610 + case True
17.611 + hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
17.612 + thus ?thesis by simp
17.613 + next
17.614 + case False
17.615 + hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
17.616 + by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
17.617 + thus ?thesis by simp
17.618 + qed
17.619 + next
17.620 + case (Ind tr1 ns tr1' t) note IH = Ind(4)
17.621 + have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
17.622 + and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
17.623 + have rtr1: "root tr1 = root tr" unfolding tr1 by simp
17.624 + show ?case
17.625 + proof(cases "root tr1 = root tr0")
17.626 + case True
17.627 + then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
17.628 + using tr1'_tr1 unfolding tr1 by auto
17.629 + show ?thesis using IH[OF tr1'] proof (elim disjE)
17.630 + assume "inFr (ns - {root tr0}) tr' t"
17.631 + thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
17.632 + qed auto
17.633 + next
17.634 + case False
17.635 + then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
17.636 + using tr1'_tr1 unfolding tr1 by auto
17.637 + show ?thesis using IH[OF tr1'] proof (elim disjE)
17.638 + assume "inFr (ns - {root tr0}) tr' t"
17.639 + thus ?thesis using tr'_tr unfolding inFrr_def
17.640 + by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
17.641 + qed auto
17.642 + qed
17.643 + qed
17.644 + }
17.645 + thus ?thesis using assms by auto
17.646 +qed
17.647 +
17.648 +lemma inFr_hsubst_notin:
17.649 +assumes "inFr ns tr t" and "root tr0 \<notin> ns"
17.650 +shows "inFr ns (hsubst tr) t"
17.651 +using assms apply(induct rule: inFr.induct)
17.652 +apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
17.653 +by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
17.654 +
17.655 +lemma inFr_hsubst_minus:
17.656 +assumes "inFr (ns - {root tr0}) tr t"
17.657 +shows "inFr ns (hsubst tr) t"
17.658 +proof-
17.659 + have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
17.660 + using inFr_hsubst_notin[OF assms] by simp
17.661 + show ?thesis using inFr_mono[OF 1] by auto
17.662 +qed
17.663 +
17.664 +lemma inFr_self_hsubst:
17.665 +assumes "root tr0 \<in> ns"
17.666 +shows
17.667 +"inFr ns (hsubst tr0) t \<longleftrightarrow>
17.668 + t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
17.669 +(is "?A \<longleftrightarrow> ?B \<or> ?C")
17.670 +apply(intro iffI)
17.671 +apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
17.672 + assume ?B thus ?A apply(intro inFr.Base) using assms by auto
17.673 +next
17.674 + assume ?C then obtain tr where
17.675 + tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
17.676 + unfolding inFrr_def by auto
17.677 + def tr1 \<equiv> "hsubst tr"
17.678 + have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
17.679 + have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
17.680 + thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
17.681 +qed
17.682 +
17.683 +theorem Fr_self_hsubst:
17.684 +assumes "root tr0 \<in> ns"
17.685 +shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
17.686 +using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
17.687 +
17.688 +end (* context *)
17.689 +
17.690 +
17.691 +subsection{* Regular trees *}
17.692 +
17.693 +hide_const regular
17.694 +
17.695 +definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
17.696 +definition "regular tr \<equiv> \<exists> f. reg f tr"
17.697 +
17.698 +lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
17.699 +unfolding reg_def using subtr_mono by (metis subset_UNIV)
17.700 +
17.701 +lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
17.702 +unfolding regular_def proof safe
17.703 + fix f assume f: "reg f tr"
17.704 + def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
17.705 + show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
17.706 + apply(rule exI[of _ g])
17.707 + using f deftr_simps(1) unfolding g_def reg_def apply safe
17.708 + apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
17.709 + by (metis (full_types) inItr_subtr subtr_subtr2)
17.710 +qed auto
17.711 +
17.712 +lemma reg_root:
17.713 +assumes "reg f tr"
17.714 +shows "f (root tr) = tr"
17.715 +using assms unfolding reg_def
17.716 +by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
17.717 +
17.718 +
17.719 +lemma reg_Inr_cont:
17.720 +assumes "reg f tr" and "Inr tr' \<in> cont tr"
17.721 +shows "reg f tr'"
17.722 +by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
17.723 +
17.724 +lemma reg_subtr:
17.725 +assumes "reg f tr" and "subtr ns tr' tr"
17.726 +shows "reg f tr'"
17.727 +using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
17.728 +by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
17.729 +
17.730 +lemma regular_subtr:
17.731 +assumes r: "regular tr" and s: "subtr ns tr' tr"
17.732 +shows "regular tr'"
17.733 +using r reg_subtr[OF _ s] unfolding regular_def by auto
17.734 +
17.735 +lemma subtr_deftr:
17.736 +assumes "subtr ns tr' (deftr n)"
17.737 +shows "tr' = deftr (root tr')"
17.738 +proof-
17.739 + {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
17.740 + apply (induct rule: subtr.induct)
17.741 + proof(metis (lifting) deftr_simps(1), safe)
17.742 + fix tr3 ns tr1 tr2 n
17.743 + assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
17.744 + and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
17.745 + and 3: "Inr tr2 \<in> cont (deftr n)"
17.746 + have "tr2 \<in> deftr ` UNIV"
17.747 + using 3 unfolding deftr_simps image_def
17.748 + by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
17.749 + iso_tuple_UNIV_I)
17.750 + then obtain n where "tr2 = deftr n" by auto
17.751 + thus "tr1 = deftr (root tr1)" using IH by auto
17.752 + qed
17.753 + }
17.754 + thus ?thesis using assms by auto
17.755 +qed
17.756 +
17.757 +lemma reg_deftr: "reg deftr (deftr n)"
17.758 +unfolding reg_def using subtr_deftr by auto
17.759 +
17.760 +lemma dtree_subtrOf_Union:
17.761 +assumes "dtree tr"
17.762 +shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
17.763 + \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
17.764 +unfolding Union_eq Bex_def mem_Collect_eq proof safe
17.765 + fix x xa tr'
17.766 + assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
17.767 + show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
17.768 + apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
17.769 + apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
17.770 + by (metis (lifting) assms subtrOf_root tr'_tr x)
17.771 +next
17.772 + fix x X n ttr
17.773 + assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
17.774 + show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
17.775 + apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
17.776 + apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
17.777 + using x .
17.778 +qed
17.779 +
17.780 +
17.781 +
17.782 +
17.783 +subsection {* Paths in a regular tree *}
17.784 +
17.785 +inductive path :: "(N \<Rightarrow> Tree) \<Rightarrow> N list \<Rightarrow> bool" for f where
17.786 +Base: "path f [n]"
17.787 +|
17.788 +Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
17.789 + \<Longrightarrow> path f (n # n1 # nl)"
17.790 +
17.791 +lemma path_NE:
17.792 +assumes "path f nl"
17.793 +shows "nl \<noteq> Nil"
17.794 +using assms apply(induct rule: path.induct) by auto
17.795 +
17.796 +lemma path_post:
17.797 +assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
17.798 +shows "path f nl"
17.799 +proof-
17.800 + obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
17.801 + show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
17.802 +qed
17.803 +
17.804 +lemma path_post_concat:
17.805 +assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
17.806 +shows "path f nl2"
17.807 +using assms apply (induct nl1)
17.808 +apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
17.809 +
17.810 +lemma path_concat:
17.811 +assumes "path f nl1" and "path f ((last nl1) # nl2)"
17.812 +shows "path f (nl1 @ nl2)"
17.813 +using assms apply(induct rule: path.induct) apply simp
17.814 +by (metis append_Cons last.simps list.simps(3) path.Ind)
17.815 +
17.816 +lemma path_distinct:
17.817 +assumes "path f nl"
17.818 +shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
17.819 + set nl' \<subseteq> set nl \<and> distinct nl'"
17.820 +using assms proof(induct rule: length_induct)
17.821 + case (1 nl) hence p_nl: "path f nl" by simp
17.822 + then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
17.823 + show ?case
17.824 + proof(cases nl1)
17.825 + case Nil
17.826 + show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
17.827 + next
17.828 + case (Cons n1 nl2)
17.829 + hence p1: "path f nl1" by (metis list.simps nl p_nl path_post)
17.830 + show ?thesis
17.831 + proof(cases "n \<in> set nl1")
17.832 + case False
17.833 + obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
17.834 + l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
17.835 + and s_nl1': "set nl1' \<subseteq> set nl1"
17.836 + using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
17.837 + obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
17.838 + unfolding Cons by(cases nl1', auto)
17.839 + show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
17.840 + show "path f (n # nl1')" unfolding nl1'
17.841 + apply(rule path.Ind, metis nl1' p1')
17.842 + by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
17.843 + qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
17.844 + next
17.845 + case True
17.846 + then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
17.847 + by (metis split_list)
17.848 + have p12: "path f (n # nl12)"
17.849 + apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
17.850 + obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
17.851 + l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
17.852 + and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
17.853 + using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
17.854 + thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
17.855 + qed
17.856 + qed
17.857 +qed
17.858 +
17.859 +lemma path_subtr:
17.860 +assumes f: "\<And> n. root (f n) = n"
17.861 +and p: "path f nl"
17.862 +shows "subtr (set nl) (f (last nl)) (f (hd nl))"
17.863 +using p proof (induct rule: path.induct)
17.864 + case (Ind n1 nl n) let ?ns1 = "insert n1 (set nl)"
17.865 + have "path f (n1 # nl)"
17.866 + and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
17.867 + and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
17.868 + hence fn1_flast: "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
17.869 + by (metis subset_insertI subtr_mono)
17.870 + have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
17.871 + have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
17.872 + using f subtr.Step[OF _ fn1_flast fn1] by auto
17.873 + thus ?case unfolding 1 by simp
17.874 +qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
17.875 +
17.876 +lemma reg_subtr_path_aux:
17.877 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
17.878 +shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
17.879 +using n f proof(induct rule: subtr.induct)
17.880 + case (Refl tr ns)
17.881 + thus ?case
17.882 + apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
17.883 +next
17.884 + case (Step tr ns tr2 tr1)
17.885 + hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
17.886 + and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
17.887 + have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
17.888 + by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
17.889 + obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
17.890 + and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
17.891 + have 0: "path f (root tr # nl)" apply (subst path.simps)
17.892 + using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv)
17.893 + show ?case apply(rule exI[of _ "(root tr) # nl"])
17.894 + using 0 reg_root tr last_nl nl path_NE rtr set by auto
17.895 +qed
17.896 +
17.897 +lemma reg_subtr_path:
17.898 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
17.899 +shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
17.900 +using reg_subtr_path_aux[OF assms] path_distinct[of f]
17.901 +by (metis (lifting) order_trans)
17.902 +
17.903 +lemma subtr_iff_path:
17.904 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
17.905 +shows "subtr ns tr1 tr \<longleftrightarrow>
17.906 + (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
17.907 +proof safe
17.908 + fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
17.909 + have "subtr (set nl) (f (last nl)) (f (hd nl))"
17.910 + apply(rule path_subtr) using p f by simp_all
17.911 + thus "subtr ns (f (last nl)) (f (hd nl))"
17.912 + using subtr_mono nl by auto
17.913 +qed(insert reg_subtr_path[OF r], auto)
17.914 +
17.915 +lemma inFr_iff_path:
17.916 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
17.917 +shows
17.918 +"inFr ns tr t \<longleftrightarrow>
17.919 + (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
17.920 + set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
17.921 +apply safe
17.922 +apply (metis (no_types) inFr_subtr r reg_subtr_path)
17.923 +by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
17.924 +
17.925 +
17.926 +
17.927 +subsection{* The regular cut of a tree *}
17.928 +
17.929 +context fixes tr0 :: Tree
17.930 +begin
17.931 +
17.932 +(* Picking a subtree of a certain root: *)
17.933 +definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
17.934 +
17.935 +lemma pick:
17.936 +assumes "inItr UNIV tr0 n"
17.937 +shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
17.938 +proof-
17.939 + have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
17.940 + using assms by (metis (lifting) inItr_subtr)
17.941 + thus ?thesis unfolding pick_def by(rule someI_ex)
17.942 +qed
17.943 +
17.944 +lemmas subtr_pick = pick[THEN conjunct1]
17.945 +lemmas root_pick = pick[THEN conjunct2]
17.946 +
17.947 +lemma dtree_pick:
17.948 +assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n"
17.949 +shows "dtree (pick n)"
17.950 +using dtree_subtr[OF tr0 subtr_pick[OF n]] .
17.951 +
17.952 +definition "regOf_r n \<equiv> root (pick n)"
17.953 +definition "regOf_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
17.954 +
17.955 +(* The regular tree of a function: *)
17.956 +definition regOf :: "N \<Rightarrow> Tree" where
17.957 +"regOf \<equiv> unfold regOf_r regOf_c"
17.958 +
17.959 +lemma finite_regOf_c: "finite (regOf_c n)"
17.960 +unfolding regOf_c_def by (metis finite_cont finite_imageI)
17.961 +
17.962 +lemma root_regOf_pick: "root (regOf n) = root (pick n)"
17.963 +using unfold(1)[of regOf_r regOf_c n] unfolding regOf_def regOf_r_def by simp
17.964 +
17.965 +lemma root_regOf[simp]:
17.966 +assumes "inItr UNIV tr0 n"
17.967 +shows "root (regOf n) = n"
17.968 +unfolding root_regOf_pick root_pick[OF assms] ..
17.969 +
17.970 +lemma cont_regOf[simp]:
17.971 +"cont (regOf n) = (id \<oplus> (regOf o root)) ` cont (pick n)"
17.972 +apply(subst id_o[symmetric, of id]) unfolding sum_map.comp[symmetric]
17.973 +unfolding image_compose unfolding regOf_c_def[symmetric]
17.974 +using unfold(2)[of regOf_c n regOf_r, OF finite_regOf_c]
17.975 +unfolding regOf_def ..
17.976 +
17.977 +lemma Inl_cont_regOf[simp]:
17.978 +"Inl -` (cont (regOf n)) = Inl -` (cont (pick n))"
17.979 +unfolding cont_regOf by simp
17.980 +
17.981 +lemma Inr_cont_regOf:
17.982 +"Inr -` (cont (regOf n)) = (regOf \<circ> root) ` (Inr -` cont (pick n))"
17.983 +unfolding cont_regOf by simp
17.984 +
17.985 +lemma subtr_regOf:
17.986 +assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (regOf n)"
17.987 +shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1"
17.988 +proof-
17.989 + {fix tr ns assume "subtr UNIV tr1 tr"
17.990 + hence "tr = regOf n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1)"
17.991 + proof (induct rule: subtr_UNIV_inductL)
17.992 + case (Step tr2 tr1 tr)
17.993 + show ?case proof
17.994 + assume "tr = regOf n"
17.995 + then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
17.996 + and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = regOf n1"
17.997 + using Step by auto
17.998 + obtain tr2' where tr2: "tr2 = regOf (root tr2')"
17.999 + and tr2': "Inr tr2' \<in> cont (pick n1)"
17.1000 + using tr2 Inr_cont_regOf[of n1]
17.1001 + unfolding tr1 image_def o_def using vimage_eq by auto
17.1002 + have "inItr UNIV tr0 (root tr2')"
17.1003 + using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
17.1004 + thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = regOf n2" using tr2 by blast
17.1005 + qed
17.1006 + qed(insert n, auto)
17.1007 + }
17.1008 + thus ?thesis using assms by auto
17.1009 +qed
17.1010 +
17.1011 +lemma root_regOf_root:
17.1012 +assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
17.1013 +shows "(id \<oplus> (root \<circ> regOf \<circ> root)) t_tr = (id \<oplus> root) t_tr"
17.1014 +using assms apply(cases t_tr)
17.1015 + apply (metis (lifting) sum_map.simps(1))
17.1016 + using pick regOf_def regOf_r_def unfold(1)
17.1017 + inItr.Base o_apply subtr_StepL subtr_inItr sum_map.simps(2)
17.1018 + by (metis UNIV_I)
17.1019 +
17.1020 +lemma regOf_P:
17.1021 +assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n"
17.1022 +shows "(n, (id \<oplus> root) ` cont (regOf n)) \<in> P" (is "?L \<in> P")
17.1023 +proof-
17.1024 + have "?L = (n, (id \<oplus> root) ` cont (pick n))"
17.1025 + unfolding cont_regOf image_compose[symmetric] sum_map.comp id_o o_assoc
17.1026 + unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
17.1027 + by(rule root_regOf_root[OF n])
17.1028 + moreover have "... \<in> P" by (metis (lifting) dtree_pick root_pick dtree_P n tr0)
17.1029 + ultimately show ?thesis by simp
17.1030 +qed
17.1031 +
17.1032 +lemma dtree_regOf:
17.1033 +assumes tr0: "dtree tr0" and "inItr UNIV tr0 n"
17.1034 +shows "dtree (regOf n)"
17.1035 +proof-
17.1036 + {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = regOf n \<Longrightarrow> dtree tr"
17.1037 + proof (induct rule: dtree_raw_coind)
17.1038 + case (Hyp tr)
17.1039 + then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" by auto
17.1040 + show ?case unfolding lift_def apply safe
17.1041 + apply (metis (lifting) regOf_P root_regOf n tr tr0)
17.1042 + unfolding tr Inr_cont_regOf unfolding inj_on_def apply clarsimp using root_regOf
17.1043 + apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
17.1044 + by (metis n subtr.Refl subtr_StepL subtr_regOf tr UNIV_I)
17.1045 + qed
17.1046 + }
17.1047 + thus ?thesis using assms by blast
17.1048 +qed
17.1049 +
17.1050 +(* The regular cut of a tree: *)
17.1051 +definition "rcut \<equiv> regOf (root tr0)"
17.1052 +
17.1053 +theorem reg_rcut: "reg regOf rcut"
17.1054 +unfolding reg_def rcut_def
17.1055 +by (metis inItr.Base root_regOf subtr_regOf UNIV_I)
17.1056 +
17.1057 +lemma rcut_reg:
17.1058 +assumes "reg regOf tr0"
17.1059 +shows "rcut = tr0"
17.1060 +using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
17.1061 +
17.1062 +theorem rcut_eq: "rcut = tr0 \<longleftrightarrow> reg regOf tr0"
17.1063 +using reg_rcut rcut_reg by metis
17.1064 +
17.1065 +theorem regular_rcut: "regular rcut"
17.1066 +using reg_rcut unfolding regular_def by blast
17.1067 +
17.1068 +theorem Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
17.1069 +proof safe
17.1070 + fix t assume "t \<in> Fr UNIV rcut"
17.1071 + then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (regOf (root tr0))"
17.1072 + using Fr_subtr[of UNIV "regOf (root tr0)"] unfolding rcut_def
17.1073 + by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
17.1074 + obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" using tr
17.1075 + by (metis (lifting) inItr.Base subtr_regOf UNIV_I)
17.1076 + have "Inl t \<in> cont (pick n)" using t using Inl_cont_regOf[of n] unfolding tr
17.1077 + by (metis (lifting) vimageD vimageI2)
17.1078 + moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
17.1079 + ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
17.1080 +qed
17.1081 +
17.1082 +theorem dtree_rcut:
17.1083 +assumes "dtree tr0"
17.1084 +shows "dtree rcut"
17.1085 +unfolding rcut_def using dtree_regOf[OF assms inItr.Base] by simp
17.1086 +
17.1087 +theorem root_rcut[simp]: "root rcut = root tr0"
17.1088 +unfolding rcut_def
17.1089 +by (metis (lifting) root_regOf inItr.Base reg_def reg_root subtr_rootR_in)
17.1090 +
17.1091 +end (* context *)
17.1092 +
17.1093 +
17.1094 +subsection{* Recursive description of the regular tree frontiers *}
17.1095 +
17.1096 +lemma regular_inFr:
17.1097 +assumes r: "regular tr" and In: "root tr \<in> ns"
17.1098 +and t: "inFr ns tr t"
17.1099 +shows "t \<in> Inl -` (cont tr) \<or>
17.1100 + (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
17.1101 +(is "?L \<or> ?R")
17.1102 +proof-
17.1103 + obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
17.1104 + using r unfolding regular_def2 by auto
17.1105 + obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
17.1106 + and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
17.1107 + using t unfolding inFr_iff_path[OF r f] by auto
17.1108 + obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
17.1109 + hence f_n: "f n = tr" using hd_nl by simp
17.1110 + have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
17.1111 + show ?thesis
17.1112 + proof(cases nl1)
17.1113 + case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
17.1114 + hence ?L using t_tr1 by simp thus ?thesis by simp
17.1115 + next
17.1116 + case (Cons n1 nl2) note nl1 = Cons
17.1117 + have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
17.1118 + have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
17.1119 + using path.simps[of f nl] p f_n unfolding nl nl1 by auto
17.1120 + have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
17.1121 + have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
17.1122 + apply(intro exI[of _ nl1], intro exI[of _ tr1])
17.1123 + using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
17.1124 + have root_tr: "root tr = n" by (metis f f_n)
17.1125 + have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
17.1126 + using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
17.1127 + thus ?thesis using n1_tr by auto
17.1128 + qed
17.1129 +qed
17.1130 +
17.1131 +theorem regular_Fr:
17.1132 +assumes r: "regular tr" and In: "root tr \<in> ns"
17.1133 +shows "Fr ns tr =
17.1134 + Inl -` (cont tr) \<union>
17.1135 + \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
17.1136 +unfolding Fr_def
17.1137 +using In inFr.Base regular_inFr[OF assms] apply safe
17.1138 +apply (simp, metis (full_types) UnionI mem_Collect_eq)
17.1139 +apply simp
17.1140 +by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
17.1141 +
17.1142 +
17.1143 +subsection{* The generated languages *}
17.1144 +
17.1145 +(* The (possibly inifinite tree) generated language *)
17.1146 +definition "L ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n}"
17.1147 +
17.1148 +(* The regular-tree generated language *)
17.1149 +definition "Lr ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n \<and> regular tr}"
17.1150 +
17.1151 +theorem L_rec_notin:
17.1152 +assumes "n \<notin> ns"
17.1153 +shows "L ns n = {{}}"
17.1154 +using assms unfolding L_def apply safe
17.1155 + using not_root_Fr apply force
17.1156 + apply(rule exI[of _ "deftr n"])
17.1157 + by (metis (no_types) dtree_deftr not_root_Fr root_deftr)
17.1158 +
17.1159 +theorem Lr_rec_notin:
17.1160 +assumes "n \<notin> ns"
17.1161 +shows "Lr ns n = {{}}"
17.1162 +using assms unfolding Lr_def apply safe
17.1163 + using not_root_Fr apply force
17.1164 + apply(rule exI[of _ "deftr n"])
17.1165 + by (metis (no_types) regular_def dtree_deftr not_root_Fr reg_deftr root_deftr)
17.1166 +
17.1167 +lemma dtree_subtrOf:
17.1168 +assumes "dtree tr" and "Inr n \<in> prodOf tr"
17.1169 +shows "dtree (subtrOf tr n)"
17.1170 +by (metis assms dtree_lift lift_def subtrOf)
17.1171 +
17.1172 +theorem Lr_rec_in:
17.1173 +assumes n: "n \<in> ns"
17.1174 +shows "Lr ns n \<subseteq>
17.1175 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
17.1176 + (n,tns) \<in> P \<and>
17.1177 + (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
17.1178 +(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
17.1179 +proof safe
17.1180 + fix ts assume "ts \<in> Lr ns n"
17.1181 + then obtain tr where dtr: "dtree tr" and r: "root tr = n" and tr: "regular tr"
17.1182 + and ts: "ts = Fr ns tr" unfolding Lr_def by auto
17.1183 + def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
17.1184 + def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
17.1185 + show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
17.1186 + apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
17.1187 + show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
17.1188 + unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
17.1189 + unfolding tns_def K_def r[symmetric]
17.1190 + unfolding Inl_prodOf dtree_subtrOf_Union[OF dtr] ..
17.1191 + show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using dtree_P[OF dtr] .
17.1192 + fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
17.1193 + unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
17.1194 + using dtr tr apply(intro conjI refl) unfolding tns_def
17.1195 + apply(erule dtree_subtrOf[OF dtr])
17.1196 + apply (metis subtrOf)
17.1197 + by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
17.1198 + qed
17.1199 +qed
17.1200 +
17.1201 +lemma hsubst_aux:
17.1202 +fixes n ftr tns
17.1203 +assumes n: "n \<in> ns" and tns: "finite tns" and
17.1204 +1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> dtree (ftr n')"
17.1205 +defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)" defines "tr' \<equiv> hsubst tr tr"
17.1206 +shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
17.1207 +(is "_ = ?B") proof-
17.1208 + have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
17.1209 + unfolding tr_def using tns by auto
17.1210 + have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
17.1211 + unfolding Frr_def ctr by auto
17.1212 + have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
17.1213 + using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
17.1214 + also have "... = ?B" unfolding ctr Frr by simp
17.1215 + finally show ?thesis .
17.1216 +qed
17.1217 +
17.1218 +theorem L_rec_in:
17.1219 +assumes n: "n \<in> ns"
17.1220 +shows "
17.1221 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
17.1222 + (n,tns) \<in> P \<and>
17.1223 + (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
17.1224 + \<subseteq> L ns n"
17.1225 +proof safe
17.1226 + fix tns K
17.1227 + assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
17.1228 + {fix n' assume "Inr n' \<in> tns"
17.1229 + hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
17.1230 + hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> dtree tr' \<and> root tr' = n'"
17.1231 + unfolding L_def mem_Collect_eq by auto
17.1232 + }
17.1233 + then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
17.1234 + K n' = Fr (ns - {n}) (ftr n') \<and> dtree (ftr n') \<and> root (ftr n') = n'"
17.1235 + by metis
17.1236 + def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)" def tr' \<equiv> "hsubst tr tr"
17.1237 + have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
17.1238 + unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
17.1239 + have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
17.1240 + unfolding ctr apply simp apply simp apply safe
17.1241 + using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
17.1242 + have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
17.1243 + using 0 by auto
17.1244 + have dtr: "dtree tr" apply(rule dtree.Tree)
17.1245 + apply (metis (lifting) P prtr rtr)
17.1246 + unfolding inj_on_def ctr lift_def using 0 by auto
17.1247 + hence dtr': "dtree tr'" unfolding tr'_def by (metis dtree_hsubst)
17.1248 + have tns: "finite tns" using finite_in_P P by simp
17.1249 + have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
17.1250 + unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
17.1251 + using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
17.1252 + thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
17.1253 +qed
17.1254 +
17.1255 +lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
17.1256 +by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
17.1257 +
17.1258 +function LL where
17.1259 +"LL ns n =
17.1260 + (if n \<notin> ns then {{}} else
17.1261 + {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
17.1262 + (n,tns) \<in> P \<and>
17.1263 + (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
17.1264 +by(pat_completeness, auto)
17.1265 +termination apply(relation "inv_image (measure card) fst")
17.1266 +using card_N by auto
17.1267 +
17.1268 +declare LL.simps[code] (* TODO: Does code generation for LL work? *)
17.1269 +declare LL.simps[simp del]
17.1270 +
17.1271 +theorem Lr_LL: "Lr ns n \<subseteq> LL ns n"
17.1272 +proof (induct ns arbitrary: n rule: measure_induct[of card])
17.1273 + case (1 ns n) show ?case proof(cases "n \<in> ns")
17.1274 + case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
17.1275 + next
17.1276 + case True show ?thesis apply(rule subset_trans)
17.1277 + using Lr_rec_in[OF True] apply assumption
17.1278 + unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
17.1279 + fix tns K
17.1280 + assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
17.1281 + assume "(n, tns) \<in> P"
17.1282 + and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
17.1283 + thus "\<exists>tnsa Ka.
17.1284 + Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
17.1285 + Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
17.1286 + (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
17.1287 + apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
17.1288 + qed
17.1289 + qed
17.1290 +qed
17.1291 +
17.1292 +theorem LL_L: "LL ns n \<subseteq> L ns n"
17.1293 +proof (induct ns arbitrary: n rule: measure_induct[of card])
17.1294 + case (1 ns n) show ?case proof(cases "n \<in> ns")
17.1295 + case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
17.1296 + next
17.1297 + case True show ?thesis apply(rule subset_trans)
17.1298 + prefer 2 using L_rec_in[OF True] apply assumption
17.1299 + unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
17.1300 + fix tns K
17.1301 + assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
17.1302 + assume "(n, tns) \<in> P"
17.1303 + and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
17.1304 + thus "\<exists>tnsa Ka.
17.1305 + Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
17.1306 + Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
17.1307 + (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
17.1308 + apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
17.1309 + qed
17.1310 + qed
17.1311 +qed
17.1312 +
17.1313 +(* The subsumpsion relation between languages *)
17.1314 +definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
17.1315 +
17.1316 +lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
17.1317 +unfolding subs_def by auto
17.1318 +
17.1319 +lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
17.1320 +
17.1321 +lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
17.1322 +unfolding subs_def by (metis subset_trans)
17.1323 +
17.1324 +(* Language equivalence *)
17.1325 +definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
17.1326 +
17.1327 +lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
17.1328 +unfolding leqv_def by auto
17.1329 +
17.1330 +lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
17.1331 +unfolding leqv_def by auto
17.1332 +
17.1333 +lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
17.1334 +
17.1335 +lemma leqv_trans:
17.1336 +assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
17.1337 +shows "leqv L1 L3"
17.1338 +using assms unfolding leqv_def by (metis (lifting) subs_trans)
17.1339 +
17.1340 +lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
17.1341 +unfolding leqv_def by auto
17.1342 +
17.1343 +lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
17.1344 +unfolding leqv_def by auto
17.1345 +
17.1346 +lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
17.1347 +unfolding Lr_def L_def by auto
17.1348 +
17.1349 +lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
17.1350 +unfolding subs_def proof safe
17.1351 + fix ts2 assume "ts2 \<in> L UNIV ts"
17.1352 + then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "dtree tr" and rtr: "root tr = ts"
17.1353 + unfolding L_def by auto
17.1354 + thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
17.1355 + apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
17.1356 + unfolding Lr_def L_def using Fr_rcut dtree_rcut root_rcut regular_rcut by auto
17.1357 +qed
17.1358 +
17.1359 +theorem Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
17.1360 +using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
17.1361 +
17.1362 +theorem LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
17.1363 +by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
17.1364 +
17.1365 +theorem LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
17.1366 +using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
17.1367 +
17.1368 +
17.1369 +end
18.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Parallel.thy Fri Sep 21 16:45:06 2012 +0200
18.3 @@ -0,0 +1,152 @@
18.4 +(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Parallel.thy
18.5 + Author: Andrei Popescu, TU Muenchen
18.6 + Copyright 2012
18.7 +
18.8 +Parallel composition.
18.9 +*)
18.10 +
18.11 +header {* Parallel Composition *}
18.12 +
18.13 +theory Parallel
18.14 +imports Tree
18.15 +begin
18.16 +
18.17 +
18.18 +consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
18.19 +
18.20 +axiomatization where
18.21 + Nplus_comm: "(a::N) + b = b + (a::N)"
18.22 +and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
18.23 +
18.24 +
18.25 +
18.26 +section{* Parallel composition *}
18.27 +
18.28 +fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
18.29 +fun par_c where
18.30 +"par_c (tr1,tr2) =
18.31 + Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
18.32 + Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
18.33 +
18.34 +declare par_r.simps[simp del] declare par_c.simps[simp del]
18.35 +
18.36 +definition par :: "Tree \<times> Tree \<Rightarrow> Tree" where
18.37 +"par \<equiv> unfold par_r par_c"
18.38 +
18.39 +abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
18.40 +
18.41 +lemma finite_par_c: "finite (par_c (tr1, tr2))"
18.42 +unfolding par_c.simps apply(rule finite_UnI)
18.43 + apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
18.44 + apply(intro finite_imageI finite_cartesian_product finite_vimageI)
18.45 + using finite_cont by auto
18.46 +
18.47 +lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
18.48 +using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
18.49 +
18.50 +lemma cont_par:
18.51 +"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
18.52 +using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
18.53 +unfolding par_def ..
18.54 +
18.55 +lemma Inl_cont_par[simp]:
18.56 +"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
18.57 +unfolding cont_par par_c.simps by auto
18.58 +
18.59 +lemma Inr_cont_par[simp]:
18.60 +"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
18.61 +unfolding cont_par par_c.simps by auto
18.62 +
18.63 +lemma Inl_in_cont_par:
18.64 +"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
18.65 +using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
18.66 +
18.67 +lemma Inr_in_cont_par:
18.68 +"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
18.69 +using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
18.70 +
18.71 +
18.72 +section{* =-coinductive proofs *}
18.73 +
18.74 +(* Detailed proofs of commutativity and associativity: *)
18.75 +theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
18.76 +proof-
18.77 + let ?\<phi> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
18.78 + {fix trA trB
18.79 + assume "?\<phi> trA trB" hence "trA = trB"
18.80 + proof (induct rule: Tree_coind, safe)
18.81 + fix tr1 tr2
18.82 + show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
18.83 + unfolding root_par by (rule Nplus_comm)
18.84 + next
18.85 + fix tr1 tr2 :: Tree
18.86 + let ?trA = "tr1 \<parallel> tr2" let ?trB = "tr2 \<parallel> tr1"
18.87 + show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
18.88 + unfolding lift2_def proof(intro conjI allI impI)
18.89 + fix n show "Inl n \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> Inl n \<in> cont (tr2 \<parallel> tr1)"
18.90 + unfolding Inl_in_cont_par by auto
18.91 + next
18.92 + fix trA' assume "Inr trA' \<in> cont ?trA"
18.93 + then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
18.94 + and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
18.95 + unfolding Inr_in_cont_par by auto
18.96 + thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
18.97 + apply(intro exI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
18.98 + next
18.99 + fix trB' assume "Inr trB' \<in> cont ?trB"
18.100 + then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
18.101 + and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
18.102 + unfolding Inr_in_cont_par by auto
18.103 + thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
18.104 + apply(intro exI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
18.105 + qed
18.106 + qed
18.107 + }
18.108 + thus ?thesis by blast
18.109 +qed
18.110 +
18.111 +theorem par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
18.112 +proof-
18.113 + let ?\<phi> =
18.114 + "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and>
18.115 + trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
18.116 + {fix trA trB
18.117 + assume "?\<phi> trA trB" hence "trA = trB"
18.118 + proof (induct rule: Tree_coind, safe)
18.119 + fix tr1 tr2 tr3
18.120 + show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
18.121 + unfolding root_par by (rule Nplus_assoc)
18.122 + next
18.123 + fix tr1 tr2 tr3
18.124 + let ?trA = "(tr1 \<parallel> tr2) \<parallel> tr3" let ?trB = "tr1 \<parallel> (tr2 \<parallel> tr3)"
18.125 + show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
18.126 + unfolding lift2_def proof(intro conjI allI impI)
18.127 + fix n show "Inl n \<in> (cont ?trA) \<longleftrightarrow> Inl n \<in> (cont ?trB)"
18.128 + unfolding Inl_in_cont_par by simp
18.129 + next
18.130 + fix trA' assume "Inr trA' \<in> cont ?trA"
18.131 + then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
18.132 + and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
18.133 + and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
18.134 + thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
18.135 + apply(intro exI[of _ "tr1' \<parallel> (tr2' \<parallel> tr3')"])
18.136 + unfolding Inr_in_cont_par by auto
18.137 + next
18.138 + fix trB' assume "Inr trB' \<in> cont ?trB"
18.139 + then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
18.140 + and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
18.141 + and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
18.142 + thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
18.143 + apply(intro exI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
18.144 + unfolding Inr_in_cont_par by auto
18.145 + qed
18.146 + qed
18.147 + }
18.148 + thus ?thesis by blast
18.149 +qed
18.150 +
18.151 +
18.152 +
18.153 +
18.154 +
18.155 +end
18.156 \ No newline at end of file
19.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
19.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Prelim.thy Fri Sep 21 16:45:06 2012 +0200
19.3 @@ -0,0 +1,67 @@
19.4 +(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Prelim.thy
19.5 + Author: Andrei Popescu, TU Muenchen
19.6 + Copyright 2012
19.7 +
19.8 +Preliminaries.
19.9 +*)
19.10 +
19.11 +header {* Preliminaries *}
19.12 +
19.13 +theory Prelim
19.14 +imports "../../BNF"
19.15 +begin
19.16 +
19.17 +declare fset_to_fset[simp]
19.18 +
19.19 +lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
19.20 +apply(rule ext) by (simp add: convol_def)
19.21 +
19.22 +abbreviation sm_abbrev (infix "\<oplus>" 60)
19.23 +where "f \<oplus> g \<equiv> Sum_Type.sum_map f g"
19.24 +
19.25 +lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
19.26 +by (cases z) auto
19.27 +
19.28 +lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
19.29 +by (cases z) auto
19.30 +
19.31 +abbreviation sum_case_abbrev ("[[_,_]]" 800)
19.32 +where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
19.33 +
19.34 +lemma inj_Inl[simp]: "inj Inl" unfolding inj_on_def by auto
19.35 +lemma inj_Inr[simp]: "inj Inr" unfolding inj_on_def by auto
19.36 +
19.37 +lemma Inl_oplus_elim:
19.38 +assumes "Inl tr \<in> (id \<oplus> f) ` tns"
19.39 +shows "Inl tr \<in> tns"
19.40 +using assms apply clarify by (case_tac x, auto)
19.41 +
19.42 +lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
19.43 +using Inl_oplus_elim
19.44 +by (metis id_def image_iff sum_map.simps(1))
19.45 +
19.46 +lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
19.47 +using Inl_oplus_iff unfolding vimage_def by auto
19.48 +
19.49 +lemma Inr_oplus_elim:
19.50 +assumes "Inr tr \<in> (id \<oplus> f) ` tns"
19.51 +shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
19.52 +using assms apply clarify by (case_tac x, auto)
19.53 +
19.54 +lemma Inr_oplus_iff[simp]:
19.55 +"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
19.56 +apply (rule iffI)
19.57 + apply (metis Inr_oplus_elim)
19.58 +by (metis image_iff sum_map.simps(2))
19.59 +
19.60 +lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
19.61 +using Inr_oplus_iff unfolding vimage_def by auto
19.62 +
19.63 +lemma Inl_Inr_image_cong:
19.64 +assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
19.65 +shows "A = B"
19.66 +apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
19.67 +
19.68 +
19.69 +
19.70 +end
19.71 \ No newline at end of file
20.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
20.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Tree.thy Fri Sep 21 16:45:06 2012 +0200
20.3 @@ -0,0 +1,326 @@
20.4 +(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Tree.thy
20.5 + Author: Andrei Popescu, TU Muenchen
20.6 + Copyright 2012
20.7 +
20.8 +Trees with nonterminal internal nodes and terminal leaves.
20.9 +*)
20.10 +
20.11 +header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
20.12 +
20.13 +theory Tree
20.14 +imports Prelim
20.15 +begin
20.16 +
20.17 +hide_fact (open) Quotient_Product.prod_rel_def
20.18 +
20.19 +typedecl N typedecl T
20.20 +
20.21 +codata_raw Tree: 'Tree = "N \<times> (T + 'Tree) fset"
20.22 +
20.23 +
20.24 +section {* Sugar notations for Tree *}
20.25 +
20.26 +subsection{* Setup for map, set, rel *}
20.27 +
20.28 +(* These should be eventually inferred from compositionality *)
20.29 +
20.30 +lemma pre_Tree_map:
20.31 +"pre_Tree_map f (n, as) = (n, map_fset (id \<oplus> f) as)"
20.32 +unfolding pre_Tree_map_def id_apply
20.33 +sum_map_def by simp
20.34 +
20.35 +lemma pre_Tree_map':
20.36 +"pre_Tree_map f n_as = (fst n_as, map_fset (id \<oplus> f) (snd n_as))"
20.37 +using pre_Tree_map by(cases n_as, simp)
20.38 +
20.39 +
20.40 +definition
20.41 +"llift2 \<phi> as1 as2 \<longleftrightarrow>
20.42 + (\<forall> n. Inl n \<in> fset as1 \<longleftrightarrow> Inl n \<in> fset as2) \<and>
20.43 + (\<forall> tr1. Inr tr1 \<in> fset as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> fset as2 \<and> \<phi> tr1 tr2)) \<and>
20.44 + (\<forall> tr2. Inr tr2 \<in> fset as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> fset as1 \<and> \<phi> tr1 tr2))"
20.45 +
20.46 +lemma pre_Tree_rel: "pre_Tree_rel \<phi> (n1,as1) (n2,as2) \<longleftrightarrow> n1 = n2 \<and> llift2 \<phi> as1 as2"
20.47 +unfolding llift2_def pre_Tree_rel_def sum_rel_def[abs_def] prod_rel_def fset_rel_def split_conv
20.48 +apply (auto split: sum.splits)
20.49 +apply (metis sumE)
20.50 +apply (metis sumE)
20.51 +apply (metis sumE)
20.52 +apply (metis sumE)
20.53 +apply (metis sumE sum.simps(1,2,4))
20.54 +apply (metis sumE sum.simps(1,2,4))
20.55 +done
20.56 +
20.57 +
20.58 +subsection{* Constructors *}
20.59 +
20.60 +definition NNode :: "N \<Rightarrow> (T + Tree)fset \<Rightarrow> Tree"
20.61 +where "NNode n as \<equiv> Tree_ctor (n,as)"
20.62 +
20.63 +lemmas ctor_defs = NNode_def
20.64 +
20.65 +
20.66 +subsection {* Pre-selectors *}
20.67 +
20.68 +(* These are mere auxiliaries *)
20.69 +
20.70 +definition "asNNode tr \<equiv> SOME n_as. NNode (fst n_as) (snd n_as) = tr"
20.71 +lemmas pre_sel_defs = asNNode_def
20.72 +
20.73 +
20.74 +subsection {* Selectors *}
20.75 +
20.76 +(* One for each pair (constructor, constructor argument) *)
20.77 +
20.78 +(* For NNode: *)
20.79 +definition root :: "Tree \<Rightarrow> N" where "root tr = fst (asNNode tr)"
20.80 +definition ccont :: "Tree \<Rightarrow> (T + Tree)fset" where "ccont tr = snd (asNNode tr)"
20.81 +
20.82 +lemmas sel_defs = root_def ccont_def
20.83 +
20.84 +
20.85 +subsection {* Basic properties *}
20.86 +
20.87 +(* Constructors versus selectors *)
20.88 +lemma NNode_surj: "\<exists> n as. NNode n as = tr"
20.89 +unfolding NNode_def
20.90 +by (metis Tree.ctor_dtor pair_collapse)
20.91 +
20.92 +lemma NNode_asNNode:
20.93 +"NNode (fst (asNNode tr)) (snd (asNNode tr)) = tr"
20.94 +proof-
20.95 + obtain n as where "NNode n as = tr" using NNode_surj[of tr] by blast
20.96 + hence "NNode (fst (n,as)) (snd (n,as)) = tr" by simp
20.97 + thus ?thesis unfolding asNNode_def by(rule someI)
20.98 +qed
20.99 +
20.100 +theorem NNode_root_ccont[simp]:
20.101 +"NNode (root tr) (ccont tr) = tr"
20.102 +using NNode_asNNode unfolding root_def ccont_def .
20.103 +
20.104 +(* Constructors *)
20.105 +theorem TTree_simps[simp]:
20.106 +"NNode n as = NNode n' as' \<longleftrightarrow> n = n' \<and> as = as'"
20.107 +unfolding ctor_defs Tree.ctor_inject by auto
20.108 +
20.109 +theorem TTree_cases[elim, case_names NNode Choice]:
20.110 +assumes NNode: "\<And> n as. tr = NNode n as \<Longrightarrow> phi"
20.111 +shows phi
20.112 +proof(cases rule: Tree.ctor_exhaust[of tr])
20.113 + fix x assume "tr = Tree_ctor x"
20.114 + thus ?thesis
20.115 + apply(cases x)
20.116 + using NNode unfolding ctor_defs apply blast
20.117 + done
20.118 +qed
20.119 +
20.120 +(* Constructors versus selectors *)
20.121 +theorem TTree_sel_ctor[simp]:
20.122 +"root (NNode n as) = n"
20.123 +"ccont (NNode n as) = as"
20.124 +unfolding root_def ccont_def
20.125 +by (metis (no_types) NNode_asNNode TTree_simps)+
20.126 +
20.127 +
20.128 +subsection{* Coinduction *}
20.129 +
20.130 +theorem TTree_coind_Node[elim, consumes 1, case_names NNode, induct pred: "HOL.eq"]:
20.131 +assumes phi: "\<phi> tr1 tr2" and
20.132 +NNode: "\<And> n1 n2 as1 as2.
20.133 + \<lbrakk>\<phi> (NNode n1 as1) (NNode n2 as2)\<rbrakk> \<Longrightarrow>
20.134 + n1 = n2 \<and> llift2 \<phi> as1 as2"
20.135 +shows "tr1 = tr2"
20.136 +apply(rule mp[OF Tree.rel_coinduct[of \<phi> tr1 tr2] phi]) proof clarify
20.137 + fix tr1 tr2 assume \<phi>: "\<phi> tr1 tr2"
20.138 + show "pre_Tree_rel \<phi> (Tree_dtor tr1) (Tree_dtor tr2)"
20.139 + apply(cases rule: Tree.ctor_exhaust[of tr1], cases rule: Tree.ctor_exhaust[of tr2])
20.140 + apply (simp add: Tree.dtor_ctor)
20.141 + apply(case_tac x, case_tac xa, simp)
20.142 + unfolding pre_Tree_rel apply(rule NNode) using \<phi> unfolding NNode_def by simp
20.143 +qed
20.144 +
20.145 +theorem TTree_coind[elim, consumes 1, case_names LLift]:
20.146 +assumes phi: "\<phi> tr1 tr2" and
20.147 +LLift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
20.148 + root tr1 = root tr2 \<and> llift2 \<phi> (ccont tr1) (ccont tr2)"
20.149 +shows "tr1 = tr2"
20.150 +using phi apply(induct rule: TTree_coind_Node)
20.151 +using LLift by (metis TTree_sel_ctor)
20.152 +
20.153 +
20.154 +
20.155 +subsection {* Coiteration *}
20.156 +
20.157 +(* Preliminaries: *)
20.158 +declare Tree.dtor_ctor[simp]
20.159 +declare Tree.ctor_dtor[simp]
20.160 +
20.161 +lemma Tree_dtor_NNode[simp]:
20.162 +"Tree_dtor (NNode n as) = (n,as)"
20.163 +unfolding NNode_def Tree.dtor_ctor ..
20.164 +
20.165 +lemma Tree_dtor_root_ccont:
20.166 +"Tree_dtor tr = (root tr, ccont tr)"
20.167 +unfolding root_def ccont_def
20.168 +by (metis (lifting) NNode_asNNode Tree_dtor_NNode)
20.169 +
20.170 +(* Coiteration *)
20.171 +definition TTree_unfold ::
20.172 +"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + 'b) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
20.173 +where "TTree_unfold rt ct \<equiv> Tree_dtor_unfold <rt,ct>"
20.174 +
20.175 +lemma Tree_unfold_unfold:
20.176 +"Tree_dtor_unfold s = TTree_unfold (fst o s) (snd o s)"
20.177 +apply(rule ext)
20.178 +unfolding TTree_unfold_def by simp
20.179 +
20.180 +theorem TTree_unfold:
20.181 +"root (TTree_unfold rt ct b) = rt b"
20.182 +"ccont (TTree_unfold rt ct b) = map_fset (id \<oplus> TTree_unfold rt ct) (ct b)"
20.183 +using Tree.dtor_unfolds[of "<rt,ct>" b] unfolding Tree_unfold_unfold fst_convol snd_convol
20.184 +unfolding pre_Tree_map' fst_convol' snd_convol'
20.185 +unfolding Tree_dtor_root_ccont by simp_all
20.186 +
20.187 +(* Corecursion, stronger than coiteration (unfold) *)
20.188 +definition TTree_corec ::
20.189 +"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + (Tree + 'b)) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
20.190 +where "TTree_corec rt ct \<equiv> Tree_dtor_corec <rt,ct>"
20.191 +
20.192 +lemma Tree_dtor_corec_corec:
20.193 +"Tree_dtor_corec s = TTree_corec (fst o s) (snd o s)"
20.194 +apply(rule ext)
20.195 +unfolding TTree_corec_def by simp
20.196 +
20.197 +theorem TTree_corec:
20.198 +"root (TTree_corec rt ct b) = rt b"
20.199 +"ccont (TTree_corec rt ct b) = map_fset (id \<oplus> ([[id, TTree_corec rt ct]]) ) (ct b)"
20.200 +using Tree.dtor_corecs[of "<rt,ct>" b] unfolding Tree_dtor_corec_corec fst_convol snd_convol
20.201 +unfolding pre_Tree_map' fst_convol' snd_convol'
20.202 +unfolding Tree_dtor_root_ccont by simp_all
20.203 +
20.204 +
20.205 +subsection{* The characteristic theorems transported from fset to set *}
20.206 +
20.207 +definition "Node n as \<equiv> NNode n (the_inv fset as)"
20.208 +definition "cont \<equiv> fset o ccont"
20.209 +definition "unfold rt ct \<equiv> TTree_unfold rt (the_inv fset o ct)"
20.210 +definition "corec rt ct \<equiv> TTree_corec rt (the_inv fset o ct)"
20.211 +
20.212 +definition lift ("_ ^#" 200) where
20.213 +"lift \<phi> as \<longleftrightarrow> (\<forall> tr. Inr tr \<in> as \<longrightarrow> \<phi> tr)"
20.214 +
20.215 +definition lift2 ("_ ^#2" 200) where
20.216 +"lift2 \<phi> as1 as2 \<longleftrightarrow>
20.217 + (\<forall> n. Inl n \<in> as1 \<longleftrightarrow> Inl n \<in> as2) \<and>
20.218 + (\<forall> tr1. Inr tr1 \<in> as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> as2 \<and> \<phi> tr1 tr2)) \<and>
20.219 + (\<forall> tr2. Inr tr2 \<in> as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> as1 \<and> \<phi> tr1 tr2))"
20.220 +
20.221 +definition liftS ("_ ^#s" 200) where
20.222 +"liftS trs = {as. Inr -` as \<subseteq> trs}"
20.223 +
20.224 +lemma lift2_llift2:
20.225 +"\<lbrakk>finite as1; finite as2\<rbrakk> \<Longrightarrow>
20.226 + lift2 \<phi> as1 as2 \<longleftrightarrow> llift2 \<phi> (the_inv fset as1) (the_inv fset as2)"
20.227 +unfolding lift2_def llift2_def by auto
20.228 +
20.229 +lemma llift2_lift2:
20.230 +"llift2 \<phi> as1 as2 \<longleftrightarrow> lift2 \<phi> (fset as1) (fset as2)"
20.231 +using lift2_llift2 by (metis finite_fset fset_cong fset_to_fset)
20.232 +
20.233 +lemma mono_lift:
20.234 +assumes "(\<phi>^#) as"
20.235 +and "\<And> tr. \<phi> tr \<Longrightarrow> \<phi>' tr"
20.236 +shows "(\<phi>'^#) as"
20.237 +using assms unfolding lift_def[abs_def] by blast
20.238 +
20.239 +lemma mono_liftS:
20.240 +assumes "trs1 \<subseteq> trs2 "
20.241 +shows "(trs1 ^#s) \<subseteq> (trs2 ^#s)"
20.242 +using assms unfolding liftS_def[abs_def] by blast
20.243 +
20.244 +lemma lift_mono:
20.245 +assumes "\<phi> \<le> \<phi>'"
20.246 +shows "(\<phi>^#) \<le> (\<phi>'^#)"
20.247 +using assms unfolding lift_def[abs_def] by blast
20.248 +
20.249 +lemma mono_lift2:
20.250 +assumes "(\<phi>^#2) as1 as2"
20.251 +and "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> \<phi>' tr1 tr2"
20.252 +shows "(\<phi>'^#2) as1 as2"
20.253 +using assms unfolding lift2_def[abs_def] by blast
20.254 +
20.255 +lemma lift2_mono:
20.256 +assumes "\<phi> \<le> \<phi>'"
20.257 +shows "(\<phi>^#2) \<le> (\<phi>'^#2)"
20.258 +using assms unfolding lift2_def[abs_def] by blast
20.259 +
20.260 +lemma finite_cont[simp]: "finite (cont tr)"
20.261 +unfolding cont_def by auto
20.262 +
20.263 +theorem Node_root_cont[simp]:
20.264 +"Node (root tr) (cont tr) = tr"
20.265 +using NNode_root_ccont unfolding Node_def cont_def
20.266 +by (metis cont_def finite_cont fset_cong fset_to_fset o_def)
20.267 +
20.268 +theorem Tree_simps[simp]:
20.269 +assumes "finite as" and "finite as'"
20.270 +shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
20.271 +using assms TTree_simps unfolding Node_def
20.272 +by (metis fset_to_fset)
20.273 +
20.274 +theorem Tree_cases[elim, case_names Node Choice]:
20.275 +assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
20.276 +shows phi
20.277 +apply(cases rule: TTree_cases[of tr])
20.278 +using Node unfolding Node_def
20.279 +by (metis Node Node_root_cont finite_cont)
20.280 +
20.281 +theorem Tree_sel_ctor[simp]:
20.282 +"root (Node n as) = n"
20.283 +"finite as \<Longrightarrow> cont (Node n as) = as"
20.284 +unfolding Node_def cont_def by auto
20.285 +
20.286 +theorems root_Node = Tree_sel_ctor(1)
20.287 +theorems cont_Node = Tree_sel_ctor(2)
20.288 +
20.289 +theorem Tree_coind_Node[elim, consumes 1, case_names Node]:
20.290 +assumes phi: "\<phi> tr1 tr2" and
20.291 +Node:
20.292 +"\<And> n1 n2 as1 as2.
20.293 + \<lbrakk>finite as1; finite as2; \<phi> (Node n1 as1) (Node n2 as2)\<rbrakk>
20.294 + \<Longrightarrow> n1 = n2 \<and> (\<phi>^#2) as1 as2"
20.295 +shows "tr1 = tr2"
20.296 +using phi apply(induct rule: TTree_coind_Node)
20.297 +unfolding llift2_lift2 apply(rule Node)
20.298 +unfolding Node_def
20.299 +apply (metis finite_fset)
20.300 +apply (metis finite_fset)
20.301 +by (metis finite_fset fset_cong fset_to_fset)
20.302 +
20.303 +theorem Tree_coind[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
20.304 +assumes phi: "\<phi> tr1 tr2" and
20.305 +Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
20.306 + root tr1 = root tr2 \<and> (\<phi>^#2) (cont tr1) (cont tr2)"
20.307 +shows "tr1 = tr2"
20.308 +using phi apply(induct rule: TTree_coind)
20.309 +unfolding llift2_lift2 apply(rule Lift[unfolded cont_def comp_def]) .
20.310 +
20.311 +theorem unfold:
20.312 +"root (unfold rt ct b) = rt b"
20.313 +"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
20.314 +using TTree_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
20.315 +apply - apply metis
20.316 +unfolding cont_def comp_def
20.317 +by (metis (no_types) fset_to_fset map_fset_image)
20.318 +
20.319 +
20.320 +theorem corec:
20.321 +"root (corec rt ct b) = rt b"
20.322 +"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
20.323 +using TTree_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
20.324 +apply - apply metis
20.325 +unfolding cont_def comp_def
20.326 +by (metis (no_types) fset_to_fset map_fset_image)
20.327 +
20.328 +
20.329 +end
21.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
21.2 +++ b/src/HOL/BNF/Examples/Lambda_Term.thy Fri Sep 21 16:45:06 2012 +0200
21.3 @@ -0,0 +1,259 @@
21.4 +(* Title: HOL/BNF/Examples/Lambda_Term.thy
21.5 + Author: Dmitriy Traytel, TU Muenchen
21.6 + Author: Andrei Popescu, TU Muenchen
21.7 + Copyright 2012
21.8 +
21.9 +Lambda-terms.
21.10 +*)
21.11 +
21.12 +header {* Lambda-Terms *}
21.13 +
21.14 +theory Lambda_Term
21.15 +imports "../BNF"
21.16 +begin
21.17 +
21.18 +
21.19 +section {* Datatype definition *}
21.20 +
21.21 +data_raw trm: 'trm = "'a + 'trm \<times> 'trm + 'a \<times> 'trm + ('a \<times> 'trm) fset \<times> 'trm"
21.22 +
21.23 +
21.24 +section {* Customization of terms *}
21.25 +
21.26 +subsection{* Set and map *}
21.27 +
21.28 +lemma pre_trm_set2_Lt: "pre_trm_set2 (Inr (Inr (Inr (xts, t)))) = snd ` (fset xts) \<union> {t}"
21.29 +unfolding pre_trm_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
21.30 +by auto
21.31 +
21.32 +lemma pre_trm_set2_Var: "\<And>x. pre_trm_set2 (Inl x) = {}"
21.33 +and pre_trm_set2_App:
21.34 +"\<And>t1 t2. pre_trm_set2 (Inr (Inl t1t2)) = {fst t1t2, snd t1t2}"
21.35 +and pre_trm_set2_Lam:
21.36 +"\<And>x t. pre_trm_set2 (Inr (Inr (Inl (x, t)))) = {t}"
21.37 +unfolding pre_trm_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
21.38 +by auto
21.39 +
21.40 +lemma pre_trm_map:
21.41 +"\<And> a1. pre_trm_map f1 f2 (Inl a1) = Inl (f1 a1)"
21.42 +"\<And> a2 b2. pre_trm_map f1 f2 (Inr (Inl (a2,b2))) = Inr (Inl (f2 a2, f2 b2))"
21.43 +"\<And> a1 a2. pre_trm_map f1 f2 (Inr (Inr (Inl (a1,a2)))) = Inr (Inr (Inl (f1 a1, f2 a2)))"
21.44 +"\<And> a1a2s a2.
21.45 + pre_trm_map f1 f2 (Inr (Inr (Inr (a1a2s, a2)))) =
21.46 + Inr (Inr (Inr (map_fset (\<lambda> (a1', a2'). (f1 a1', f2 a2')) a1a2s, f2 a2)))"
21.47 +unfolding pre_trm_map_def collect_def[abs_def] map_pair_def by auto
21.48 +
21.49 +
21.50 +subsection{* Constructors *}
21.51 +
21.52 +definition "Var x \<equiv> trm_ctor (Inl x)"
21.53 +definition "App t1 t2 \<equiv> trm_ctor (Inr (Inl (t1,t2)))"
21.54 +definition "Lam x t \<equiv> trm_ctor (Inr (Inr (Inl (x,t))))"
21.55 +definition "Lt xts t \<equiv> trm_ctor (Inr (Inr (Inr (xts,t))))"
21.56 +
21.57 +lemmas ctor_defs = Var_def App_def Lam_def Lt_def
21.58 +
21.59 +theorem trm_simps[simp]:
21.60 +"\<And>x y. Var x = Var y \<longleftrightarrow> x = y"
21.61 +"\<And>t1 t2 t1' t2'. App t1 t2 = App t1' t2' \<longleftrightarrow> t1 = t1' \<and> t2 = t2'"
21.62 +"\<And>x x' t t'. Lam x t = Lam x' t' \<longleftrightarrow> x = x' \<and> t = t'"
21.63 +"\<And> xts xts' t t'. Lt xts t = Lt xts' t' \<longleftrightarrow> xts = xts' \<and> t = t'"
21.64 +(* *)
21.65 +"\<And> x t1 t2. Var x \<noteq> App t1 t2" "\<And>x y t. Var x \<noteq> Lam y t" "\<And> x xts t. Var x \<noteq> Lt xts t"
21.66 +"\<And> t1 t2 x t. App t1 t2 \<noteq> Lam x t" "\<And> t1 t2 xts t. App t1 t2 \<noteq> Lt xts t"
21.67 +"\<And>x t xts t1. Lam x t \<noteq> Lt xts t1"
21.68 +unfolding ctor_defs trm.ctor_inject by auto
21.69 +
21.70 +theorem trm_cases[elim, case_names Var App Lam Lt]:
21.71 +assumes Var: "\<And> x. t = Var x \<Longrightarrow> phi"
21.72 +and App: "\<And> t1 t2. t = App t1 t2 \<Longrightarrow> phi"
21.73 +and Lam: "\<And> x t1. t = Lam x t1 \<Longrightarrow> phi"
21.74 +and Lt: "\<And> xts t1. t = Lt xts t1 \<Longrightarrow> phi"
21.75 +shows phi
21.76 +proof(cases rule: trm.ctor_exhaust[of t])
21.77 + fix x assume "t = trm_ctor x"
21.78 + thus ?thesis
21.79 + apply(cases x) using Var unfolding ctor_defs apply blast
21.80 + apply(case_tac b) using App unfolding ctor_defs apply(case_tac a, blast)
21.81 + apply(case_tac ba) using Lam unfolding ctor_defs apply(case_tac a, blast)
21.82 + apply(case_tac bb) using Lt unfolding ctor_defs by blast
21.83 +qed
21.84 +
21.85 +lemma trm_induct[case_names Var App Lam Lt, induct type: trm]:
21.86 +assumes Var: "\<And> (x::'a). phi (Var x)"
21.87 +and App: "\<And> t1 t2. \<lbrakk>phi t1; phi t2\<rbrakk> \<Longrightarrow> phi (App t1 t2)"
21.88 +and Lam: "\<And> x t. phi t \<Longrightarrow> phi (Lam x t)"
21.89 +and Lt: "\<And> xts t. \<lbrakk>\<And> x1 t1. (x1,t1) |\<in>| xts \<Longrightarrow> phi t1; phi t\<rbrakk> \<Longrightarrow> phi (Lt xts t)"
21.90 +shows "phi t"
21.91 +proof(induct rule: trm.ctor_induct)
21.92 + fix u :: "'a + 'a trm \<times> 'a trm + 'a \<times> 'a trm + ('a \<times> 'a trm) fset \<times> 'a trm"
21.93 + assume IH: "\<And>t. t \<in> pre_trm_set2 u \<Longrightarrow> phi t"
21.94 + show "phi (trm_ctor u)"
21.95 + proof(cases u)
21.96 + case (Inl x)
21.97 + show ?thesis using Var unfolding Var_def Inl .
21.98 + next
21.99 + case (Inr uu) note Inr1 = Inr
21.100 + show ?thesis
21.101 + proof(cases uu)
21.102 + case (Inl t1t2)
21.103 + obtain t1 t2 where t1t2: "t1t2 = (t1,t2)" by (cases t1t2, blast)
21.104 + show ?thesis unfolding Inr1 Inl t1t2 App_def[symmetric] apply(rule App)
21.105 + using IH unfolding Inr1 Inl pre_trm_set2_App t1t2 fst_conv snd_conv by blast+
21.106 + next
21.107 + case (Inr uuu) note Inr2 = Inr
21.108 + show ?thesis
21.109 + proof(cases uuu)
21.110 + case (Inl xt)
21.111 + obtain x t where xt: "xt = (x,t)" by (cases xt, blast)
21.112 + show ?thesis unfolding Inr1 Inr2 Inl xt Lam_def[symmetric] apply(rule Lam)
21.113 + using IH unfolding Inr1 Inr2 Inl pre_trm_set2_Lam xt by blast
21.114 + next
21.115 + case (Inr xts_t)
21.116 + obtain xts t where xts_t: "xts_t = (xts,t)" by (cases xts_t, blast)
21.117 + show ?thesis unfolding Inr1 Inr2 Inr xts_t Lt_def[symmetric] apply(rule Lt) using IH
21.118 + unfolding Inr1 Inr2 Inr pre_trm_set2_Lt xts_t fset_fset_member image_def by auto
21.119 + qed
21.120 + qed
21.121 + qed
21.122 +qed
21.123 +
21.124 +
21.125 +subsection{* Recursion and iteration (fold) *}
21.126 +
21.127 +definition
21.128 +"sumJoin4 f1 f2 f3 f4 \<equiv>
21.129 +\<lambda> k. (case k of
21.130 + Inl x1 \<Rightarrow> f1 x1
21.131 +|Inr k1 \<Rightarrow> (case k1 of
21.132 + Inl ((s2,a2),(t2,b2)) \<Rightarrow> f2 s2 a2 t2 b2
21.133 +|Inr k2 \<Rightarrow> (case k2 of Inl (x3,(t3,b3)) \<Rightarrow> f3 x3 t3 b3
21.134 +|Inr (xts,(t4,b4)) \<Rightarrow> f4 xts t4 b4)))"
21.135 +
21.136 +lemma sumJoin4_simps[simp]:
21.137 +"\<And>x. sumJoin4 var app lam lt (Inl x) = var x"
21.138 +"\<And> t1 a1 t2 a2. sumJoin4 var app lam lt (Inr (Inl ((t1,a1),(t2,a2)))) = app t1 a1 t2 a2"
21.139 +"\<And> x t a. sumJoin4 var app lam lt (Inr (Inr (Inl (x,(t,a))))) = lam x t a"
21.140 +"\<And> xtas t a. sumJoin4 var app lam lt (Inr (Inr (Inr (xtas,(t,a))))) = lt xtas t a"
21.141 +unfolding sumJoin4_def by auto
21.142 +
21.143 +definition "trmrec var app lam lt \<equiv> trm_ctor_rec (sumJoin4 var app lam lt)"
21.144 +
21.145 +lemma trmrec_Var[simp]:
21.146 +"trmrec var app lam lt (Var x) = var x"
21.147 +unfolding trmrec_def Var_def trm.ctor_recs pre_trm_map(1) by simp
21.148 +
21.149 +lemma trmrec_App[simp]:
21.150 +"trmrec var app lam lt (App t1 t2) =
21.151 + app t1 (trmrec var app lam lt t1) t2 (trmrec var app lam lt t2)"
21.152 +unfolding trmrec_def App_def trm.ctor_recs pre_trm_map(2) convol_def by simp
21.153 +
21.154 +lemma trmrec_Lam[simp]:
21.155 +"trmrec var app lam lt (Lam x t) = lam x t (trmrec var app lam lt t)"
21.156 +unfolding trmrec_def Lam_def trm.ctor_recs pre_trm_map(3) convol_def by simp
21.157 +
21.158 +lemma trmrec_Lt[simp]:
21.159 +"trmrec var app lam lt (Lt xts t) =
21.160 + lt (map_fset (\<lambda> (x,t). (x,t,trmrec var app lam lt t)) xts) t (trmrec var app lam lt t)"
21.161 +unfolding trmrec_def Lt_def trm.ctor_recs pre_trm_map(4) convol_def by simp
21.162 +
21.163 +definition
21.164 +"sumJoinI4 f1 f2 f3 f4 \<equiv>
21.165 +\<lambda> k. (case k of
21.166 + Inl x1 \<Rightarrow> f1 x1
21.167 +|Inr k1 \<Rightarrow> (case k1 of
21.168 + Inl (a2,b2) \<Rightarrow> f2 a2 b2
21.169 +|Inr k2 \<Rightarrow> (case k2 of Inl (x3,b3) \<Rightarrow> f3 x3 b3
21.170 +|Inr (xts,b4) \<Rightarrow> f4 xts b4)))"
21.171 +
21.172 +lemma sumJoinI4_simps[simp]:
21.173 +"\<And>x. sumJoinI4 var app lam lt (Inl x) = var x"
21.174 +"\<And> a1 a2. sumJoinI4 var app lam lt (Inr (Inl (a1,a2))) = app a1 a2"
21.175 +"\<And> x a. sumJoinI4 var app lam lt (Inr (Inr (Inl (x,a)))) = lam x a"
21.176 +"\<And> xtas a. sumJoinI4 var app lam lt (Inr (Inr (Inr (xtas,a)))) = lt xtas a"
21.177 +unfolding sumJoinI4_def by auto
21.178 +
21.179 +(* The iterator has a simpler, hence more manageable type. *)
21.180 +definition "trmfold var app lam lt \<equiv> trm_ctor_fold (sumJoinI4 var app lam lt)"
21.181 +
21.182 +lemma trmfold_Var[simp]:
21.183 +"trmfold var app lam lt (Var x) = var x"
21.184 +unfolding trmfold_def Var_def trm.ctor_folds pre_trm_map(1) by simp
21.185 +
21.186 +lemma trmfold_App[simp]:
21.187 +"trmfold var app lam lt (App t1 t2) =
21.188 + app (trmfold var app lam lt t1) (trmfold var app lam lt t2)"
21.189 +unfolding trmfold_def App_def trm.ctor_folds pre_trm_map(2) by simp
21.190 +
21.191 +lemma trmfold_Lam[simp]:
21.192 +"trmfold var app lam lt (Lam x t) = lam x (trmfold var app lam lt t)"
21.193 +unfolding trmfold_def Lam_def trm.ctor_folds pre_trm_map(3) by simp
21.194 +
21.195 +lemma trmfold_Lt[simp]:
21.196 +"trmfold var app lam lt (Lt xts t) =
21.197 + lt (map_fset (\<lambda> (x,t). (x,trmfold var app lam lt t)) xts) (trmfold var app lam lt t)"
21.198 +unfolding trmfold_def Lt_def trm.ctor_folds pre_trm_map(4) by simp
21.199 +
21.200 +
21.201 +subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
21.202 +
21.203 +definition "varsOf = trmfold
21.204 +(\<lambda> x. {x})
21.205 +(\<lambda> X1 X2. X1 \<union> X2)
21.206 +(\<lambda> x X. X \<union> {x})
21.207 +(\<lambda> xXs Y. Y \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| xXs}))"
21.208 +
21.209 +lemma varsOf_simps[simp]:
21.210 +"varsOf (Var x) = {x}"
21.211 +"varsOf (App t1 t2) = varsOf t1 \<union> varsOf t2"
21.212 +"varsOf (Lam x t) = varsOf t \<union> {x}"
21.213 +"varsOf (Lt xts t) =
21.214 + varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,varsOf t1)) xts})"
21.215 +unfolding varsOf_def by simp_all
21.216 +
21.217 +definition "fvarsOf = trmfold
21.218 +(\<lambda> x. {x})
21.219 +(\<lambda> X1 X2. X1 \<union> X2)
21.220 +(\<lambda> x X. X - {x})
21.221 +(\<lambda> xtXs Y. Y - {x | x X. (x,X) |\<in>| xtXs} \<union> (\<Union> {X | x X. (x,X) |\<in>| xtXs}))"
21.222 +
21.223 +lemma fvarsOf_simps[simp]:
21.224 +"fvarsOf (Var x) = {x}"
21.225 +"fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
21.226 +"fvarsOf (Lam x t) = fvarsOf t - {x}"
21.227 +"fvarsOf (Lt xts t) =
21.228 + fvarsOf t
21.229 + - {x | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts}
21.230 + \<union> (\<Union> {X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts})"
21.231 +unfolding fvarsOf_def by simp_all
21.232 +
21.233 +lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
21.234 +
21.235 +lemma in_map_fset_iff:
21.236 +"(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, f t1)) xts \<longleftrightarrow>
21.237 + (\<exists> t1. (x,t1) |\<in>| xts \<and> X = f t1)"
21.238 +unfolding map_fset_def2_raw in_fset fset_afset unfolding fset_def2_raw by auto
21.239 +
21.240 +lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
21.241 +proof induct
21.242 + case (Lt xts t)
21.243 + thus ?case unfolding fvarsOf_simps varsOf_simps
21.244 + proof (elim diff_Un_incl_triv)
21.245 + show
21.246 + "\<Union>{X | x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts}
21.247 + \<subseteq> \<Union>{{x} \<union> X |x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts}"
21.248 + (is "_ \<subseteq> \<Union> ?L")
21.249 + proof(rule Sup_mono, safe)
21.250 + fix a x X
21.251 + assume "(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts"
21.252 + then obtain t1 where x_t1: "(x,t1) |\<in>| xts" and X: "X = fvarsOf t1"
21.253 + unfolding in_map_fset_iff by auto
21.254 + let ?Y = "varsOf t1"
21.255 + have x_Y: "(x,?Y) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts"
21.256 + using x_t1 unfolding in_map_fset_iff by auto
21.257 + show "\<exists> Y \<in> ?L. X \<subseteq> Y" unfolding X using Lt(1) x_Y x_t1 by auto
21.258 + qed
21.259 + qed
21.260 +qed auto
21.261 +
21.262 +end
22.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
22.2 +++ b/src/HOL/BNF/Examples/ListF.thy Fri Sep 21 16:45:06 2012 +0200
22.3 @@ -0,0 +1,171 @@
22.4 +(* Title: HOL/BNF/Examples/ListF.thy
22.5 + Author: Dmitriy Traytel, TU Muenchen
22.6 + Author: Andrei Popescu, TU Muenchen
22.7 + Copyright 2012
22.8 +
22.9 +Finite lists.
22.10 +*)
22.11 +
22.12 +header {* Finite Lists *}
22.13 +
22.14 +theory ListF
22.15 +imports "../BNF"
22.16 +begin
22.17 +
22.18 +data_raw listF: 'list = "unit + 'a \<times> 'list"
22.19 +
22.20 +definition "NilF = listF_ctor (Inl ())"
22.21 +definition "Conss a as \<equiv> listF_ctor (Inr (a, as))"
22.22 +
22.23 +lemma listF_map_NilF[simp]: "listF_map f NilF = NilF"
22.24 +unfolding listF_map_def pre_listF_map_def NilF_def listF.ctor_folds by simp
22.25 +
22.26 +lemma listF_map_Conss[simp]:
22.27 + "listF_map f (Conss x xs) = Conss (f x) (listF_map f xs)"
22.28 +unfolding listF_map_def pre_listF_map_def Conss_def listF.ctor_folds by simp
22.29 +
22.30 +lemma listF_set_NilF[simp]: "listF_set NilF = {}"
22.31 +unfolding listF_set_def NilF_def listF.ctor_folds pre_listF_set1_def pre_listF_set2_def
22.32 + sum_set_defs pre_listF_map_def collect_def[abs_def] by simp
22.33 +
22.34 +lemma listF_set_Conss[simp]: "listF_set (Conss x xs) = {x} \<union> listF_set xs"
22.35 +unfolding listF_set_def Conss_def listF.ctor_folds pre_listF_set1_def pre_listF_set2_def
22.36 + sum_set_defs prod_set_defs pre_listF_map_def collect_def[abs_def] by simp
22.37 +
22.38 +lemma fold_sum_case_NilF: "listF_ctor_fold (sum_case f g) NilF = f ()"
22.39 +unfolding NilF_def listF.ctor_folds pre_listF_map_def by simp
22.40 +
22.41 +
22.42 +lemma fold_sum_case_Conss:
22.43 + "listF_ctor_fold (sum_case f g) (Conss y ys) = g (y, listF_ctor_fold (sum_case f g) ys)"
22.44 +unfolding Conss_def listF.ctor_folds pre_listF_map_def by simp
22.45 +
22.46 +(* familiar induction principle *)
22.47 +lemma listF_induct:
22.48 + fixes xs :: "'a listF"
22.49 + assumes IB: "P NilF" and IH: "\<And>x xs. P xs \<Longrightarrow> P (Conss x xs)"
22.50 + shows "P xs"
22.51 +proof (rule listF.ctor_induct)
22.52 + fix xs :: "unit + 'a \<times> 'a listF"
22.53 + assume raw_IH: "\<And>a. a \<in> pre_listF_set2 xs \<Longrightarrow> P a"
22.54 + show "P (listF_ctor xs)"
22.55 + proof (cases xs)
22.56 + case (Inl a) with IB show ?thesis unfolding NilF_def by simp
22.57 + next
22.58 + case (Inr b)
22.59 + then obtain y ys where yys: "listF_ctor xs = Conss y ys"
22.60 + unfolding Conss_def listF.ctor_inject by (blast intro: prod.exhaust)
22.61 + hence "ys \<in> pre_listF_set2 xs"
22.62 + unfolding pre_listF_set2_def Conss_def listF.ctor_inject sum_set_defs prod_set_defs
22.63 + collect_def[abs_def] by simp
22.64 + with raw_IH have "P ys" by blast
22.65 + with IH have "P (Conss y ys)" by blast
22.66 + with yys show ?thesis by simp
22.67 + qed
22.68 +qed
22.69 +
22.70 +rep_datatype NilF Conss
22.71 +by (blast intro: listF_induct) (auto simp add: NilF_def Conss_def listF.ctor_inject)
22.72 +
22.73 +definition Singll ("[[_]]") where
22.74 + [simp]: "Singll a \<equiv> Conss a NilF"
22.75 +
22.76 +definition appendd (infixr "@@" 65) where
22.77 + "appendd \<equiv> listF_ctor_fold (sum_case (\<lambda> _. id) (\<lambda> (a,f) bs. Conss a (f bs)))"
22.78 +
22.79 +definition "lrev \<equiv> listF_ctor_fold (sum_case (\<lambda> _. NilF) (\<lambda> (b,bs). bs @@ [[b]]))"
22.80 +
22.81 +lemma lrev_NilF[simp]: "lrev NilF = NilF"
22.82 +unfolding lrev_def by (simp add: fold_sum_case_NilF)
22.83 +
22.84 +lemma lrev_Conss[simp]: "lrev (Conss y ys) = lrev ys @@ [[y]]"
22.85 +unfolding lrev_def by (simp add: fold_sum_case_Conss)
22.86 +
22.87 +lemma NilF_appendd[simp]: "NilF @@ ys = ys"
22.88 +unfolding appendd_def by (simp add: fold_sum_case_NilF)
22.89 +
22.90 +lemma Conss_append[simp]: "Conss x xs @@ ys = Conss x (xs @@ ys)"
22.91 +unfolding appendd_def by (simp add: fold_sum_case_Conss)
22.92 +
22.93 +lemma appendd_NilF[simp]: "xs @@ NilF = xs"
22.94 +by (rule listF_induct) auto
22.95 +
22.96 +lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
22.97 +by (rule listF_induct) auto
22.98 +
22.99 +lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
22.100 +by (rule listF_induct[of _ xs]) auto
22.101 +
22.102 +lemma listF_map_appendd[simp]:
22.103 + "listF_map f (xs @@ ys) = listF_map f xs @@ listF_map f ys"
22.104 +by (rule listF_induct[of _ xs]) auto
22.105 +
22.106 +lemma lrev_listF_map[simp]: "lrev (listF_map f xs) = listF_map f (lrev xs)"
22.107 +by (rule listF_induct[of _ xs]) auto
22.108 +
22.109 +lemma lrev_lrev[simp]: "lrev (lrev as) = as"
22.110 +by (rule listF_induct) auto
22.111 +
22.112 +fun lengthh where
22.113 + "lengthh NilF = 0"
22.114 +| "lengthh (Conss x xs) = Suc (lengthh xs)"
22.115 +
22.116 +fun nthh where
22.117 + "nthh (Conss x xs) 0 = x"
22.118 +| "nthh (Conss x xs) (Suc n) = nthh xs n"
22.119 +| "nthh xs i = undefined"
22.120 +
22.121 +lemma lengthh_listF_map[simp]: "lengthh (listF_map f xs) = lengthh xs"
22.122 +by (rule listF_induct[of _ xs]) auto
22.123 +
22.124 +lemma nthh_listF_map[simp]:
22.125 + "i < lengthh xs \<Longrightarrow> nthh (listF_map f xs) i = f (nthh xs i)"
22.126 +by (induct rule: nthh.induct) auto
22.127 +
22.128 +lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
22.129 +by (induct rule: nthh.induct) auto
22.130 +
22.131 +lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
22.132 +by (induct xs) auto
22.133 +
22.134 +lemma Conss_iff[iff]:
22.135 + "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
22.136 +by (induct xs) auto
22.137 +
22.138 +lemma Conss_iff'[iff]:
22.139 + "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
22.140 +by (induct xs) (simp, simp, blast)
22.141 +
22.142 +lemma listF_induct2: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
22.143 + \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
22.144 +by (induct xs arbitrary: ys rule: listF_induct) auto
22.145 +
22.146 +fun zipp where
22.147 + "zipp NilF NilF = NilF"
22.148 +| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
22.149 +| "zipp xs ys = undefined"
22.150 +
22.151 +lemma listF_map_fst_zip[simp]:
22.152 + "lengthh xs = lengthh ys \<Longrightarrow> listF_map fst (zipp xs ys) = xs"
22.153 +by (erule listF_induct2) auto
22.154 +
22.155 +lemma listF_map_snd_zip[simp]:
22.156 + "lengthh xs = lengthh ys \<Longrightarrow> listF_map snd (zipp xs ys) = ys"
22.157 +by (erule listF_induct2) auto
22.158 +
22.159 +lemma lengthh_zip[simp]:
22.160 + "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
22.161 +by (erule listF_induct2) auto
22.162 +
22.163 +lemma nthh_zip[simp]:
22.164 + assumes *: "lengthh xs = lengthh ys"
22.165 + shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
22.166 +proof (induct arbitrary: i rule: listF_induct2[OF *])
22.167 + case (2 x xs y ys) thus ?case by (induct i) auto
22.168 +qed simp
22.169 +
22.170 +lemma list_set_nthh[simp]:
22.171 + "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
22.172 +by (induct xs) (auto, induct rule: nthh.induct, auto)
22.173 +
22.174 +end
23.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
23.2 +++ b/src/HOL/BNF/Examples/Misc_Codata.thy Fri Sep 21 16:45:06 2012 +0200
23.3 @@ -0,0 +1,110 @@
23.4 +(* Title: HOL/BNF/Examples/Misc_Data.thy
23.5 + Author: Dmitriy Traytel, TU Muenchen
23.6 + Author: Andrei Popescu, TU Muenchen
23.7 + Copyright 2012
23.8 +
23.9 +Miscellaneous codatatype declarations.
23.10 +*)
23.11 +
23.12 +header {* Miscellaneous Codatatype Declarations *}
23.13 +
23.14 +theory Misc_Codata
23.15 +imports "../BNF"
23.16 +begin
23.17 +
23.18 +codata simple = X1 | X2 | X3 | X4
23.19 +
23.20 +codata simple' = X1' unit | X2' unit | X3' unit | X4' unit
23.21 +
23.22 +codata 'a stream = Stream 'a "'a stream"
23.23 +
23.24 +codata 'a mylist = MyNil | MyCons 'a "'a mylist"
23.25 +
23.26 +codata ('b, 'c, 'd, 'e) some_passive =
23.27 + SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
23.28 +
23.29 +codata lambda =
23.30 + Var string |
23.31 + App lambda lambda |
23.32 + Abs string lambda |
23.33 + Let "(string \<times> lambda) fset" lambda
23.34 +
23.35 +codata 'a par_lambda =
23.36 + PVar 'a |
23.37 + PApp "'a par_lambda" "'a par_lambda" |
23.38 + PAbs 'a "'a par_lambda" |
23.39 + PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
23.40 +
23.41 +(*
23.42 + ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
23.43 + ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
23.44 +*)
23.45 +
23.46 +codata 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
23.47 + and 'a J2 = J21 | J22 "'a J1" "'a J2"
23.48 +
23.49 +codata 'a tree = TEmpty | TNode 'a "'a forest"
23.50 + and 'a forest = FNil | FCons "'a tree" "'a forest"
23.51 +
23.52 +codata 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
23.53 + and 'a branch = Branch 'a "'a tree'"
23.54 +
23.55 +codata ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
23.56 + and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
23.57 + and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
23.58 +
23.59 +codata ('a, 'b, 'c) some_killing =
23.60 + SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
23.61 + and ('a, 'b, 'c) in_here =
23.62 + IH1 'b 'a | IH2 'c
23.63 +
23.64 +codata_raw some_killing': 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
23.65 +and in_here': 'c = "'d + 'e"
23.66 +
23.67 +codata_raw some_killing'': 'a = "'b \<Rightarrow> 'c"
23.68 +and in_here'': 'c = "'d \<times> 'b + 'e"
23.69 +
23.70 +codata ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
23.71 +
23.72 +codata 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
23.73 +
23.74 +codata ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
23.75 + FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
23.76 + ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
23.77 +
23.78 +codata ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
23.79 + 'b18, 'b19, 'b20) fun_rhs' =
23.80 + FR' "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'b10 \<Rightarrow> 'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow>
23.81 + 'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
23.82 + ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
23.83 + 'b18, 'b19, 'b20) fun_rhs'"
23.84 +
23.85 +codata ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
23.86 + and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
23.87 + and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
23.88 +
23.89 +codata ('c, 'e, 'g) coind_wit1 =
23.90 + CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
23.91 + and ('c, 'e, 'g) coind_wit2 =
23.92 + CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
23.93 + and ('c, 'e, 'g) ind_wit =
23.94 + IW1 | IW2 'c
23.95 +
23.96 +codata ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
23.97 +codata ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
23.98 +
23.99 +codata 'a dead_foo = A
23.100 +codata ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
23.101 +
23.102 +(* SLOW, MEMORY-HUNGRY
23.103 +codata ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
23.104 + and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
23.105 + and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
23.106 + and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
23.107 + and ('a, 'c) D5 = A5 "('a, 'c) D6"
23.108 + and ('a, 'c) D6 = A6 "('a, 'c) D7"
23.109 + and ('a, 'c) D7 = A7 "('a, 'c) D8"
23.110 + and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
23.111 +*)
23.112 +
23.113 +end
24.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
24.2 +++ b/src/HOL/BNF/Examples/Misc_Data.thy Fri Sep 21 16:45:06 2012 +0200
24.3 @@ -0,0 +1,154 @@
24.4 +(* Title: HOL/BNF/Examples/Misc_Data.thy
24.5 + Author: Dmitriy Traytel, TU Muenchen
24.6 + Author: Andrei Popescu, TU Muenchen
24.7 + Copyright 2012
24.8 +
24.9 +Miscellaneous datatype declarations.
24.10 +*)
24.11 +
24.12 +header {* Miscellaneous Datatype Declarations *}
24.13 +
24.14 +theory Misc_Data
24.15 +imports "../BNF"
24.16 +begin
24.17 +
24.18 +data simple = X1 | X2 | X3 | X4
24.19 +
24.20 +data simple' = X1' unit | X2' unit | X3' unit | X4' unit
24.21 +
24.22 +data 'a mylist = MyNil | MyCons 'a "'a mylist"
24.23 +
24.24 +data ('b, 'c, 'd, 'e) some_passive =
24.25 + SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
24.26 +
24.27 +data lambda =
24.28 + Var string |
24.29 + App lambda lambda |
24.30 + Abs string lambda |
24.31 + Let "(string \<times> lambda) fset" lambda
24.32 +
24.33 +data 'a par_lambda =
24.34 + PVar 'a |
24.35 + PApp "'a par_lambda" "'a par_lambda" |
24.36 + PAbs 'a "'a par_lambda" |
24.37 + PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
24.38 +
24.39 +(*
24.40 + ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
24.41 + ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
24.42 +*)
24.43 +
24.44 +data 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
24.45 + and 'a I2 = I21 | I22 "'a I1" "'a I2"
24.46 +
24.47 +data 'a tree = TEmpty | TNode 'a "'a forest"
24.48 + and 'a forest = FNil | FCons "'a tree" "'a forest"
24.49 +
24.50 +data 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
24.51 + and 'a branch = Branch 'a "'a tree'"
24.52 +
24.53 +data ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
24.54 + and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
24.55 + and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
24.56 +
24.57 +data ('a, 'b, 'c) some_killing =
24.58 + SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
24.59 + and ('a, 'b, 'c) in_here =
24.60 + IH1 'b 'a | IH2 'c
24.61 +
24.62 +data 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
24.63 +data 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
24.64 +data 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
24.65 +data 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
24.66 +
24.67 +(*
24.68 +data 'b fail = F "'b fail" 'b "'b fail" "'b list"
24.69 +data 'b fail = F "'b fail" 'b "'b fail" 'b
24.70 +data 'b fail = F1 "'b fail" 'b | F2 "'b fail"
24.71 +data 'b fail = F "'b fail" 'b
24.72 +*)
24.73 +
24.74 +data l1 = L1 "l2 list"
24.75 + and l2 = L21 "l1 fset" | L22 l2
24.76 +
24.77 +data kk1 = KK1 kk2
24.78 + and kk2 = KK2 kk3
24.79 + and kk3 = KK3 "kk1 list"
24.80 +
24.81 +data t1 = T11 t3 | T12 t2
24.82 + and t2 = T2 t1
24.83 + and t3 = T3
24.84 +
24.85 +data t1' = T11' t2' | T12' t3'
24.86 + and t2' = T2' t1'
24.87 + and t3' = T3'
24.88 +
24.89 +(*
24.90 +data fail1 = F1 fail2
24.91 + and fail2 = F2 fail3
24.92 + and fail3 = F3 fail1
24.93 +
24.94 +data fail1 = F1 "fail2 list" fail2
24.95 + and fail2 = F2 "fail2 fset" fail3
24.96 + and fail3 = F3 fail1
24.97 +
24.98 +data fail1 = F1 "fail2 list" fail2
24.99 + and fail2 = F2 "fail1 fset" fail1
24.100 +*)
24.101 +
24.102 +(* SLOW
24.103 +data ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
24.104 + and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
24.105 + and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
24.106 + and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
24.107 + and ('a, 'c) D5 = A5 "('a, 'c) D6"
24.108 + and ('a, 'c) D6 = A6 "('a, 'c) D7"
24.109 + and ('a, 'c) D7 = A7 "('a, 'c) D8"
24.110 + and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
24.111 +
24.112 +(*time comparison*)
24.113 +datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
24.114 + and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
24.115 + and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
24.116 + and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
24.117 + and ('a, 'c) D5' = A5' "('a, 'c) D6'"
24.118 + and ('a, 'c) D6' = A6' "('a, 'c) D7'"
24.119 + and ('a, 'c) D7' = A7' "('a, 'c) D8'"
24.120 + and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
24.121 +*)
24.122 +
24.123 +(* fail:
24.124 +data tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
24.125 + and tt2 = TT2
24.126 + and tt3 = TT3 tt4
24.127 + and tt4 = TT4 tt1
24.128 +*)
24.129 +
24.130 +data k1 = K11 k2 k3 | K12 k2 k4
24.131 + and k2 = K2
24.132 + and k3 = K3 k4
24.133 + and k4 = K4
24.134 +
24.135 +data tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
24.136 + and tt2 = TT2
24.137 + and tt3 = TT3 tt1
24.138 + and tt4 = TT4
24.139 +
24.140 +(* SLOW
24.141 +data s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
24.142 + and s2 = S21 s7 s5 | S22 s5 s4 s6
24.143 + and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
24.144 + and s4 = S4 s5
24.145 + and s5 = S5
24.146 + and s6 = S61 s6 | S62 s1 s2 | S63 s6
24.147 + and s7 = S71 s8 | S72 s5
24.148 + and s8 = S8 nat
24.149 +*)
24.150 +
24.151 +data ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
24.152 +data ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
24.153 +
24.154 +data 'a dead_foo = A
24.155 +data ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
24.156 +
24.157 +end
25.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
25.2 +++ b/src/HOL/BNF/Examples/Process.thy Fri Sep 21 16:45:06 2012 +0200
25.3 @@ -0,0 +1,367 @@
25.4 +(* Title: HOL/BNF/Examples/Process.thy
25.5 + Author: Andrei Popescu, TU Muenchen
25.6 + Copyright 2012
25.7 +
25.8 +Processes.
25.9 +*)
25.10 +
25.11 +header {* Processes *}
25.12 +
25.13 +theory Process
25.14 +imports "../BNF"
25.15 +begin
25.16 +
25.17 +hide_fact (open) Quotient_Product.prod_rel_def
25.18 +
25.19 +codata 'a process =
25.20 + isAction: Action (prefOf: 'a) (contOf: "'a process") |
25.21 + isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
25.22 +
25.23 +(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
25.24 +
25.25 +section {* Customization *}
25.26 +
25.27 +subsection {* Basic properties *}
25.28 +
25.29 +declare
25.30 + pre_process_rel_def[simp]
25.31 + sum_rel_def[simp]
25.32 + prod_rel_def[simp]
25.33 +
25.34 +(* Constructors versus discriminators *)
25.35 +theorem isAction_isChoice:
25.36 +"isAction p \<or> isChoice p"
25.37 +by (rule process.disc_exhaust) auto
25.38 +
25.39 +theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
25.40 +by (cases rule: process.exhaust[of p]) auto
25.41 +
25.42 +
25.43 +subsection{* Coinduction *}
25.44 +
25.45 +theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
25.46 +assumes phi: "\<phi> p p'" and
25.47 +iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
25.48 +Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
25.49 +Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
25.50 +shows "p = p'"
25.51 +proof(intro mp[OF process.rel_coinduct, of \<phi>, OF _ phi], clarify)
25.52 + fix p p' assume \<phi>: "\<phi> p p'"
25.53 + show "pre_process_rel (op =) \<phi> (process_dtor p) (process_dtor p')"
25.54 + proof(cases rule: process.exhaust[of p])
25.55 + case (Action a q) note p = Action
25.56 + hence "isAction p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
25.57 + then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process.exhaust[of p'], auto)
25.58 + have 0: "a = a' \<and> \<phi> q q'" using Act[OF \<phi>[unfolded p p']] .
25.59 + have dtor: "process_dtor p = Inl (a,q)" "process_dtor p' = Inl (a',q')"
25.60 + unfolding p p' Action_def process.dtor_ctor by simp_all
25.61 + show ?thesis using 0 unfolding dtor by simp
25.62 + next
25.63 + case (Choice p1 p2) note p = Choice
25.64 + hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
25.65 + then obtain p1' p2' where p': "p' = Choice p1' p2'"
25.66 + by (cases rule: process.exhaust[of p'], auto)
25.67 + have 0: "\<phi> p1 p1' \<and> \<phi> p2 p2'" using Ch[OF \<phi>[unfolded p p']] .
25.68 + have dtor: "process_dtor p = Inr (p1,p2)" "process_dtor p' = Inr (p1',p2')"
25.69 + unfolding p p' Choice_def process.dtor_ctor by simp_all
25.70 + show ?thesis using 0 unfolding dtor by simp
25.71 + qed
25.72 +qed
25.73 +
25.74 +(* Stronger coinduction, up to equality: *)
25.75 +theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
25.76 +assumes phi: "\<phi> p p'" and
25.77 +iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
25.78 +Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
25.79 +Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
25.80 +shows "p = p'"
25.81 +proof(intro mp[OF process.rel_strong_coinduct, of \<phi>, OF _ phi], clarify)
25.82 + fix p p' assume \<phi>: "\<phi> p p'"
25.83 + show "pre_process_rel (op =) (\<lambda>a b. \<phi> a b \<or> a = b) (process_dtor p) (process_dtor p')"
25.84 + proof(cases rule: process.exhaust[of p])
25.85 + case (Action a q) note p = Action
25.86 + hence "isAction p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
25.87 + then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process.exhaust[of p'], auto)
25.88 + have 0: "a = a' \<and> (\<phi> q q' \<or> q = q')" using Act[OF \<phi>[unfolded p p']] .
25.89 + have dtor: "process_dtor p = Inl (a,q)" "process_dtor p' = Inl (a',q')"
25.90 + unfolding p p' Action_def process.dtor_ctor by simp_all
25.91 + show ?thesis using 0 unfolding dtor by simp
25.92 + next
25.93 + case (Choice p1 p2) note p = Choice
25.94 + hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
25.95 + then obtain p1' p2' where p': "p' = Choice p1' p2'"
25.96 + by (cases rule: process.exhaust[of p'], auto)
25.97 + have 0: "(\<phi> p1 p1' \<or> p1 = p1') \<and> (\<phi> p2 p2' \<or> p2 = p2')" using Ch[OF \<phi>[unfolded p p']] .
25.98 + have dtor: "process_dtor p = Inr (p1,p2)" "process_dtor p' = Inr (p1',p2')"
25.99 + unfolding p p' Choice_def process.dtor_ctor by simp_all
25.100 + show ?thesis using 0 unfolding dtor by simp
25.101 + qed
25.102 +qed
25.103 +
25.104 +
25.105 +subsection {* Coiteration (unfold) *}
25.106 +
25.107 +
25.108 +section{* Coinductive definition of the notion of trace *}
25.109 +
25.110 +(* Say we have a type of streams: *)
25.111 +
25.112 +typedecl 'a stream
25.113 +
25.114 +consts Ccons :: "'a \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
25.115 +
25.116 +(* Use the existing coinductive package (distinct from our
25.117 +new codatatype package, but highly compatible with it): *)
25.118 +
25.119 +coinductive trace where
25.120 +"trace p as \<Longrightarrow> trace (Action a p) (Ccons a as)"
25.121 +|
25.122 +"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
25.123 +
25.124 +
25.125 +section{* Examples of corecursive definitions: *}
25.126 +
25.127 +subsection{* Single-guard fixpoint definition *}
25.128 +
25.129 +definition
25.130 +"BX \<equiv>
25.131 + process_unfold
25.132 + (\<lambda> P. True)
25.133 + (\<lambda> P. ''a'')
25.134 + (\<lambda> P. P)
25.135 + undefined
25.136 + undefined
25.137 + ()"
25.138 +
25.139 +lemma BX: "BX = Action ''a'' BX"
25.140 +unfolding BX_def
25.141 +using process.unfolds(1)[of "\<lambda> P. True" "()" "\<lambda> P. ''a''" "\<lambda> P. P"] by simp
25.142 +
25.143 +
25.144 +subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
25.145 +
25.146 +datatype x_y_ax = x | y | ax
25.147 +
25.148 +definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False |y \<Rightarrow> True |ax \<Rightarrow> True"
25.149 +definition "pr \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
25.150 +definition "co \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x |ax \<Rightarrow> x"
25.151 +lemmas Action_defs = isA_def pr_def co_def
25.152 +
25.153 +definition "c1 \<equiv> \<lambda> K. case K of x \<Rightarrow> ax |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
25.154 +definition "c2 \<equiv> \<lambda> K. case K of x \<Rightarrow> y |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
25.155 +lemmas Choice_defs = c1_def c2_def
25.156 +
25.157 +definition "F \<equiv> process_unfold isA pr co c1 c2"
25.158 +definition "X = F x" definition "Y = F y" definition "AX = F ax"
25.159 +
25.160 +lemma X_Y_AX: "X = Choice AX Y" "Y = Action ''b'' X" "AX = Action ''a'' X"
25.161 +unfolding X_def Y_def AX_def F_def
25.162 +using process.unfolds(2)[of isA x "pr" co c1 c2]
25.163 + process.unfolds(1)[of isA y "pr" co c1 c2]
25.164 + process.unfolds(1)[of isA ax "pr" co c1 c2]
25.165 +unfolding Action_defs Choice_defs by simp_all
25.166 +
25.167 +(* end product: *)
25.168 +lemma X_AX:
25.169 +"X = Choice AX (Action ''b'' X)"
25.170 +"AX = Action ''a'' X"
25.171 +using X_Y_AX by simp_all
25.172 +
25.173 +
25.174 +
25.175 +section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
25.176 +
25.177 +hide_const x y ax X Y AX
25.178 +
25.179 +(* Process terms *)
25.180 +datatype ('a,'pvar) process_term =
25.181 + VAR 'pvar |
25.182 + PROC "'a process" |
25.183 + ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
25.184 +
25.185 +(* below, sys represents a system of equations *)
25.186 +fun isACT where
25.187 +"isACT sys (VAR X) =
25.188 + (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
25.189 +|
25.190 +"isACT sys (PROC p) = isAction p"
25.191 +|
25.192 +"isACT sys (ACT a T) = True"
25.193 +|
25.194 +"isACT sys (CH T1 T2) = False"
25.195 +
25.196 +fun PREF where
25.197 +"PREF sys (VAR X) =
25.198 + (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
25.199 +|
25.200 +"PREF sys (PROC p) = prefOf p"
25.201 +|
25.202 +"PREF sys (ACT a T) = a"
25.203 +
25.204 +fun CONT where
25.205 +"CONT sys (VAR X) =
25.206 + (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
25.207 +|
25.208 +"CONT sys (PROC p) = PROC (contOf p)"
25.209 +|
25.210 +"CONT sys (ACT a T) = T"
25.211 +
25.212 +fun CH1 where
25.213 +"CH1 sys (VAR X) =
25.214 + (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
25.215 +|
25.216 +"CH1 sys (PROC p) = PROC (ch1Of p)"
25.217 +|
25.218 +"CH1 sys (CH T1 T2) = T1"
25.219 +
25.220 +fun CH2 where
25.221 +"CH2 sys (VAR X) =
25.222 + (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
25.223 +|
25.224 +"CH2 sys (PROC p) = PROC (ch2Of p)"
25.225 +|
25.226 +"CH2 sys (CH T1 T2) = T2"
25.227 +
25.228 +definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
25.229 +
25.230 +definition
25.231 +"solution sys \<equiv>
25.232 + process_unfold
25.233 + (isACT sys)
25.234 + (PREF sys)
25.235 + (CONT sys)
25.236 + (CH1 sys)
25.237 + (CH2 sys)"
25.238 +
25.239 +lemma solution_Action:
25.240 +assumes "isACT sys T"
25.241 +shows "solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
25.242 +unfolding solution_def
25.243 +using process.unfolds(1)[of "isACT sys" T "PREF sys" "CONT sys" "CH1 sys" "CH2 sys"]
25.244 + assms by simp
25.245 +
25.246 +lemma solution_Choice:
25.247 +assumes "\<not> isACT sys T"
25.248 +shows "solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
25.249 +unfolding solution_def
25.250 +using process.unfolds(2)[of "isACT sys" T "PREF sys" "CONT sys" "CH1 sys" "CH2 sys"]
25.251 + assms by simp
25.252 +
25.253 +lemma isACT_VAR:
25.254 +assumes g: "guarded sys"
25.255 +shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
25.256 +using g unfolding guarded_def by (cases "sys X") auto
25.257 +
25.258 +lemma solution_VAR:
25.259 +assumes g: "guarded sys"
25.260 +shows "solution sys (VAR X) = solution sys (sys X)"
25.261 +proof(cases "isACT sys (VAR X)")
25.262 + case True
25.263 + hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
25.264 + show ?thesis
25.265 + unfolding solution_Action[OF T] using solution_Action[of sys "VAR X"] True g
25.266 + unfolding guarded_def by (cases "sys X", auto)
25.267 +next
25.268 + case False note FFalse = False
25.269 + hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
25.270 + show ?thesis
25.271 + unfolding solution_Choice[OF TT] using solution_Choice[of sys "VAR X"] FFalse g
25.272 + unfolding guarded_def by (cases "sys X", auto)
25.273 +qed
25.274 +
25.275 +lemma solution_PROC[simp]:
25.276 +"solution sys (PROC p) = p"
25.277 +proof-
25.278 + {fix q assume "q = solution sys (PROC p)"
25.279 + hence "p = q"
25.280 + proof(induct rule: process_coind)
25.281 + case (iss p p')
25.282 + from isAction_isChoice[of p] show ?case
25.283 + proof
25.284 + assume p: "isAction p"
25.285 + hence 0: "isACT sys (PROC p)" by simp
25.286 + thus ?thesis using iss not_isAction_isChoice
25.287 + unfolding solution_Action[OF 0] by auto
25.288 + next
25.289 + assume "isChoice p"
25.290 + hence 0: "\<not> isACT sys (PROC p)"
25.291 + using not_isAction_isChoice by auto
25.292 + thus ?thesis using iss isAction_isChoice
25.293 + unfolding solution_Choice[OF 0] by auto
25.294 + qed
25.295 + next
25.296 + case (Action a a' p p')
25.297 + hence 0: "isACT sys (PROC (Action a p))" by simp
25.298 + show ?case using Action unfolding solution_Action[OF 0] by simp
25.299 + next
25.300 + case (Choice p q p' q')
25.301 + hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
25.302 + show ?case using Choice unfolding solution_Choice[OF 0] by simp
25.303 + qed
25.304 + }
25.305 + thus ?thesis by metis
25.306 +qed
25.307 +
25.308 +lemma solution_ACT[simp]:
25.309 +"solution sys (ACT a T) = Action a (solution sys T)"
25.310 +by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution_Action)
25.311 +
25.312 +lemma solution_CH[simp]:
25.313 +"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
25.314 +by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution_Choice)
25.315 +
25.316 +
25.317 +(* Example: *)
25.318 +
25.319 +fun sys where
25.320 +"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
25.321 +|
25.322 +"sys (Suc 0) = ACT ''a'' (VAR 0)"
25.323 +| (* dummy guarded term for variables outside the system: *)
25.324 +"sys X = ACT ''a'' (VAR 0)"
25.325 +
25.326 +lemma guarded_sys:
25.327 +"guarded sys"
25.328 +unfolding guarded_def proof (intro allI)
25.329 + fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
25.330 +qed
25.331 +
25.332 +(* the actual processes: *)
25.333 +definition "x \<equiv> solution sys (VAR 0)"
25.334 +definition "ax \<equiv> solution sys (VAR (Suc 0))"
25.335 +
25.336 +(* end product: *)
25.337 +lemma x_ax:
25.338 +"x = Choice ax (Action ''b'' x)"
25.339 +"ax = Action ''a'' x"
25.340 +unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
25.341 +
25.342 +
25.343 +(* Thanks to the inclusion of processes as process terms, one can
25.344 +also consider parametrized systems of equations---here, x is a (semantic)
25.345 +process parameter: *)
25.346 +
25.347 +fun sys' where
25.348 +"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
25.349 +|
25.350 +"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
25.351 +| (* dummy guarded term : *)
25.352 +"sys' X = ACT ''a'' (VAR 0)"
25.353 +
25.354 +lemma guarded_sys':
25.355 +"guarded sys'"
25.356 +unfolding guarded_def proof (intro allI)
25.357 + fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
25.358 +qed
25.359 +
25.360 +(* the actual processes: *)
25.361 +definition "y \<equiv> solution sys' (VAR 0)"
25.362 +definition "ay \<equiv> solution sys' (VAR (Suc 0))"
25.363 +
25.364 +(* end product: *)
25.365 +lemma y_ay:
25.366 +"y = Choice x (Action ''b'' y)"
25.367 +"ay = Choice (Action ''a'' y) x"
25.368 +unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
25.369 +
25.370 +end
26.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
26.2 +++ b/src/HOL/BNF/Examples/Stream.thy Fri Sep 21 16:45:06 2012 +0200
26.3 @@ -0,0 +1,157 @@
26.4 +(* Title: HOL/BNF/Examples/Stream.thy
26.5 + Author: Dmitriy Traytel, TU Muenchen
26.6 + Author: Andrei Popescu, TU Muenchen
26.7 + Copyright 2012
26.8 +
26.9 +Infinite streams.
26.10 +*)
26.11 +
26.12 +header {* Infinite Streams *}
26.13 +
26.14 +theory Stream
26.15 +imports TreeFI
26.16 +begin
26.17 +
26.18 +hide_const (open) Quotient_Product.prod_rel
26.19 +hide_fact (open) Quotient_Product.prod_rel_def
26.20 +
26.21 +codata_raw stream: 's = "'a \<times> 's"
26.22 +
26.23 +(* selectors for streams *)
26.24 +definition "hdd as \<equiv> fst (stream_dtor as)"
26.25 +definition "tll as \<equiv> snd (stream_dtor as)"
26.26 +
26.27 +lemma unfold_pair_fun_hdd[simp]: "hdd (stream_dtor_unfold (f \<odot> g) t) = f t"
26.28 +unfolding hdd_def pair_fun_def stream.dtor_unfolds by simp
26.29 +
26.30 +lemma unfold_pair_fun_tll[simp]: "tll (stream_dtor_unfold (f \<odot> g) t) =
26.31 + stream_dtor_unfold (f \<odot> g) (g t)"
26.32 +unfolding tll_def pair_fun_def stream.dtor_unfolds by simp
26.33 +
26.34 +(* infinite trees: *)
26.35 +coinductive infiniteTr where
26.36 +"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
26.37 +
26.38 +lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
26.39 +assumes *: "phi tr" and
26.40 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
26.41 +shows "infiniteTr tr"
26.42 +using assms by (elim infiniteTr.coinduct) blast
26.43 +
26.44 +lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
26.45 +assumes *: "phi tr" and
26.46 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
26.47 +shows "infiniteTr tr"
26.48 +using assms by (elim infiniteTr.coinduct) blast
26.49 +
26.50 +lemma infiniteTr_sub[simp]:
26.51 +"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
26.52 +by (erule infiniteTr.cases) blast
26.53 +
26.54 +definition "konigPath \<equiv> stream_dtor_unfold
26.55 + (lab \<odot> (\<lambda>tr. SOME tr'. tr' \<in> listF_set (sub tr) \<and> infiniteTr tr'))"
26.56 +
26.57 +lemma hdd_simps1[simp]: "hdd (konigPath t) = lab t"
26.58 +unfolding konigPath_def by simp
26.59 +
26.60 +lemma tll_simps2[simp]: "tll (konigPath t) =
26.61 + konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
26.62 +unfolding konigPath_def by simp
26.63 +
26.64 +(* proper paths in trees: *)
26.65 +coinductive properPath where
26.66 +"\<lbrakk>hdd as = lab tr; tr' \<in> listF_set (sub tr); properPath (tll as) tr'\<rbrakk> \<Longrightarrow>
26.67 + properPath as tr"
26.68 +
26.69 +lemma properPath_strong_coind[consumes 1, case_names hdd_lab sub]:
26.70 +assumes *: "phi as tr" and
26.71 +**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
26.72 +***: "\<And> as tr.
26.73 + phi as tr \<Longrightarrow>
26.74 + \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
26.75 +shows "properPath as tr"
26.76 +using assms by (elim properPath.coinduct) blast
26.77 +
26.78 +lemma properPath_coind[consumes 1, case_names hdd_lab sub, induct pred: properPath]:
26.79 +assumes *: "phi as tr" and
26.80 +**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
26.81 +***: "\<And> as tr.
26.82 + phi as tr \<Longrightarrow>
26.83 + \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr'"
26.84 +shows "properPath as tr"
26.85 +using properPath_strong_coind[of phi, OF * **] *** by blast
26.86 +
26.87 +lemma properPath_hdd_lab:
26.88 +"properPath as tr \<Longrightarrow> hdd as = lab tr"
26.89 +by (erule properPath.cases) blast
26.90 +
26.91 +lemma properPath_sub:
26.92 +"properPath as tr \<Longrightarrow>
26.93 + \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
26.94 +by (erule properPath.cases) blast
26.95 +
26.96 +(* prove the following by coinduction *)
26.97 +theorem Konig:
26.98 + assumes "infiniteTr tr"
26.99 + shows "properPath (konigPath tr) tr"
26.100 +proof-
26.101 + {fix as
26.102 + assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
26.103 + proof (induct rule: properPath_coind, safe)
26.104 + fix t
26.105 + let ?t = "SOME t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'"
26.106 + assume "infiniteTr t"
26.107 + hence "\<exists>t' \<in> listF_set (sub t). infiniteTr t'" by simp
26.108 + hence "\<exists>t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'" by blast
26.109 + hence "?t \<in> listF_set (sub t) \<and> infiniteTr ?t" by (elim someI_ex)
26.110 + moreover have "tll (konigPath t) = konigPath ?t" by simp
26.111 + ultimately show "\<exists>t' \<in> listF_set (sub t).
26.112 + infiniteTr t' \<and> tll (konigPath t) = konigPath t'" by blast
26.113 + qed simp
26.114 + }
26.115 + thus ?thesis using assms by blast
26.116 +qed
26.117 +
26.118 +(* some more stream theorems *)
26.119 +
26.120 +lemma stream_map[simp]: "stream_map f = stream_dtor_unfold (f o hdd \<odot> tll)"
26.121 +unfolding stream_map_def pair_fun_def hdd_def[abs_def] tll_def[abs_def]
26.122 + map_pair_def o_def prod_case_beta by simp
26.123 +
26.124 +lemma prod_rel[simp]: "prod_rel \<phi>1 \<phi>2 a b = (\<phi>1 (fst a) (fst b) \<and> \<phi>2 (snd a) (snd b))"
26.125 +unfolding prod_rel_def by auto
26.126 +
26.127 +lemmas stream_coind =
26.128 + mp[OF stream.rel_coinduct, unfolded prod_rel[abs_def], folded hdd_def tll_def]
26.129 +
26.130 +definition plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
26.131 + [simp]: "plus xs ys =
26.132 + stream_dtor_unfold ((%(xs, ys). hdd xs + hdd ys) \<odot> (%(xs, ys). (tll xs, tll ys))) (xs, ys)"
26.133 +
26.134 +definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
26.135 + [simp]: "scalar n = stream_map (\<lambda>x. n * x)"
26.136 +
26.137 +definition ones :: "nat stream" where [simp]: "ones = stream_dtor_unfold ((%x. 1) \<odot> id) ()"
26.138 +definition twos :: "nat stream" where [simp]: "twos = stream_dtor_unfold ((%x. 2) \<odot> id) ()"
26.139 +definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
26.140 +
26.141 +lemma "ones \<oplus> ones = twos"
26.142 +by (intro stream_coind[where P="%x1 x2. \<exists>x. x1 = ones \<oplus> ones \<and> x2 = twos"]) auto
26.143 +
26.144 +lemma "n \<cdot> twos = ns (2 * n)"
26.145 +by (intro stream_coind[where P="%x1 x2. \<exists>n. x1 = n \<cdot> twos \<and> x2 = ns (2 * n)"]) force+
26.146 +
26.147 +lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
26.148 +by (intro stream_coind[where P="%x1 x2. \<exists>n m xs. x1 = (n * m) \<cdot> xs \<and> x2 = n \<cdot> m \<cdot> xs"]) force+
26.149 +
26.150 +lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
26.151 +by (intro stream_coind[where P="%x1 x2. \<exists>n xs ys. x1 = n \<cdot> (xs \<oplus> ys) \<and> x2 = n \<cdot> xs \<oplus> n \<cdot> ys"])
26.152 + (force simp: add_mult_distrib2)+
26.153 +
26.154 +lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
26.155 +by (intro stream_coind[where P="%x1 x2. \<exists>xs ys. x1 = xs \<oplus> ys \<and> x2 = ys \<oplus> xs"]) force+
26.156 +
26.157 +lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
26.158 +by (intro stream_coind[where P="%x1 x2. \<exists>xs ys zs. x1 = (xs \<oplus> ys) \<oplus> zs \<and> x2 = xs \<oplus> ys \<oplus> zs"]) force+
26.159 +
26.160 +end
27.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
27.2 +++ b/src/HOL/BNF/Examples/TreeFI.thy Fri Sep 21 16:45:06 2012 +0200
27.3 @@ -0,0 +1,83 @@
27.4 +(* Title: HOL/BNF/Examples/TreeFI.thy
27.5 + Author: Dmitriy Traytel, TU Muenchen
27.6 + Author: Andrei Popescu, TU Muenchen
27.7 + Copyright 2012
27.8 +
27.9 +Finitely branching possibly infinite trees.
27.10 +*)
27.11 +
27.12 +header {* Finitely Branching Possibly Infinite Trees *}
27.13 +
27.14 +theory TreeFI
27.15 +imports ListF
27.16 +begin
27.17 +
27.18 +hide_const (open) Sublist.sub
27.19 +
27.20 +codata_raw treeFI: 'tree = "'a \<times> 'tree listF"
27.21 +
27.22 +lemma pre_treeFI_listF_set[simp]: "pre_treeFI_set2 (i, xs) = listF_set xs"
27.23 +unfolding pre_treeFI_set2_def collect_def[abs_def] prod_set_defs
27.24 +by (auto simp add: listF.set_natural')
27.25 +
27.26 +(* selectors for trees *)
27.27 +definition "lab tr \<equiv> fst (treeFI_dtor tr)"
27.28 +definition "sub tr \<equiv> snd (treeFI_dtor tr)"
27.29 +
27.30 +lemma dtor[simp]: "treeFI_dtor tr = (lab tr, sub tr)"
27.31 +unfolding lab_def sub_def by simp
27.32 +
27.33 +definition pair_fun (infixr "\<odot>" 50) where
27.34 + "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
27.35 +
27.36 +lemma unfold_pair_fun_lab: "lab (treeFI_dtor_unfold (f \<odot> g) t) = f t"
27.37 +unfolding lab_def pair_fun_def treeFI.dtor_unfolds pre_treeFI_map_def by simp
27.38 +
27.39 +lemma unfold_pair_fun_sub: "sub (treeFI_dtor_unfold (f \<odot> g) t) = listF_map (treeFI_dtor_unfold (f \<odot> g)) (g t)"
27.40 +unfolding sub_def pair_fun_def treeFI.dtor_unfolds pre_treeFI_map_def by simp
27.41 +
27.42 +(* Tree reverse:*)
27.43 +definition "trev \<equiv> treeFI_dtor_unfold (lab \<odot> lrev o sub)"
27.44 +
27.45 +lemma trev_simps1[simp]: "lab (trev t) = lab t"
27.46 +unfolding trev_def by (simp add: unfold_pair_fun_lab)
27.47 +
27.48 +lemma trev_simps2[simp]: "sub (trev t) = listF_map trev (lrev (sub t))"
27.49 +unfolding trev_def by (simp add: unfold_pair_fun_sub)
27.50 +
27.51 +lemma treeFI_coinduct:
27.52 +assumes *: "phi x y"
27.53 +and step: "\<And>a b. phi a b \<Longrightarrow>
27.54 + lab a = lab b \<and>
27.55 + lengthh (sub a) = lengthh (sub b) \<and>
27.56 + (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
27.57 +shows "x = y"
27.58 +proof (rule mp[OF treeFI.dtor_coinduct, of phi, OF _ *])
27.59 + fix a b :: "'a treeFI"
27.60 + let ?zs = "zipp (sub a) (sub b)"
27.61 + let ?z = "(lab a, ?zs)"
27.62 + assume "phi a b"
27.63 + with step have step': "lab a = lab b" "lengthh (sub a) = lengthh (sub b)"
27.64 + "\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i)" by auto
27.65 + hence "pre_treeFI_map id fst ?z = treeFI_dtor a" "pre_treeFI_map id snd ?z = treeFI_dtor b"
27.66 + unfolding pre_treeFI_map_def by auto
27.67 + moreover have "\<forall>(x, y) \<in> pre_treeFI_set2 ?z. phi x y"
27.68 + proof safe
27.69 + fix z1 z2
27.70 + assume "(z1, z2) \<in> pre_treeFI_set2 ?z"
27.71 + hence "(z1, z2) \<in> listF_set ?zs" by auto
27.72 + hence "\<exists>i < lengthh ?zs. nthh ?zs i = (z1, z2)" by auto
27.73 + with step'(2) obtain i where "i < lengthh (sub a)"
27.74 + "nthh (sub a) i = z1" "nthh (sub b) i = z2" by auto
27.75 + with step'(3) show "phi z1 z2" by auto
27.76 + qed
27.77 + ultimately show "\<exists>z.
27.78 + (pre_treeFI_map id fst z = treeFI_dtor a \<and>
27.79 + pre_treeFI_map id snd z = treeFI_dtor b) \<and>
27.80 + (\<forall>x y. (x, y) \<in> pre_treeFI_set2 z \<longrightarrow> phi x y)" by blast
27.81 +qed
27.82 +
27.83 +lemma trev_trev: "trev (trev tr) = tr"
27.84 +by (rule treeFI_coinduct[of "%a b. trev (trev b) = a"]) auto
27.85 +
27.86 +end
28.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
28.2 +++ b/src/HOL/BNF/Examples/TreeFsetI.thy Fri Sep 21 16:45:06 2012 +0200
28.3 @@ -0,0 +1,59 @@
28.4 +(* Title: HOL/BNF/Examples/TreeFsetI.thy
28.5 + Author: Dmitriy Traytel, TU Muenchen
28.6 + Author: Andrei Popescu, TU Muenchen
28.7 + Copyright 2012
28.8 +
28.9 +Finitely branching possibly infinite trees, with sets of children.
28.10 +*)
28.11 +
28.12 +header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
28.13 +
28.14 +theory TreeFsetI
28.15 +imports "../BNF"
28.16 +begin
28.17 +
28.18 +hide_const (open) Sublist.sub
28.19 +hide_fact (open) Quotient_Product.prod_rel_def
28.20 +
28.21 +definition pair_fun (infixr "\<odot>" 50) where
28.22 + "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
28.23 +
28.24 +codata_raw treeFsetI: 't = "'a \<times> 't fset"
28.25 +
28.26 +(* selectors for trees *)
28.27 +definition "lab t \<equiv> fst (treeFsetI_dtor t)"
28.28 +definition "sub t \<equiv> snd (treeFsetI_dtor t)"
28.29 +
28.30 +lemma dtor[simp]: "treeFsetI_dtor t = (lab t, sub t)"
28.31 +unfolding lab_def sub_def by simp
28.32 +
28.33 +lemma unfold_pair_fun_lab: "lab (treeFsetI_dtor_unfold (f \<odot> g) t) = f t"
28.34 +unfolding lab_def pair_fun_def treeFsetI.dtor_unfolds pre_treeFsetI_map_def by simp
28.35 +
28.36 +lemma unfold_pair_fun_sub: "sub (treeFsetI_dtor_unfold (f \<odot> g) t) = map_fset (treeFsetI_dtor_unfold (f \<odot> g)) (g t)"
28.37 +unfolding sub_def pair_fun_def treeFsetI.dtor_unfolds pre_treeFsetI_map_def by simp
28.38 +
28.39 +(* tree map (contrived example): *)
28.40 +definition "tmap f \<equiv> treeFsetI_dtor_unfold (f o lab \<odot> sub)"
28.41 +
28.42 +lemma tmap_simps1[simp]: "lab (tmap f t) = f (lab t)"
28.43 +unfolding tmap_def by (simp add: unfold_pair_fun_lab)
28.44 +
28.45 +lemma trev_simps2[simp]: "sub (tmap f t) = map_fset (tmap f) (sub t)"
28.46 +unfolding tmap_def by (simp add: unfold_pair_fun_sub)
28.47 +
28.48 +lemma pre_treeFsetI_rel[simp]: "pre_treeFsetI_rel R1 R2 a b = (R1 (fst a) (fst b) \<and>
28.49 + (\<forall>t \<in> fset (snd a). (\<exists>u \<in> fset (snd b). R2 t u)) \<and>
28.50 + (\<forall>t \<in> fset (snd b). (\<exists>u \<in> fset (snd a). R2 u t)))"
28.51 +apply (cases a)
28.52 +apply (cases b)
28.53 +apply (simp add: pre_treeFsetI_rel_def prod_rel_def fset_rel_def)
28.54 +done
28.55 +
28.56 +lemmas treeFsetI_coind = mp[OF treeFsetI.rel_coinduct]
28.57 +
28.58 +lemma "tmap (f o g) x = tmap f (tmap g x)"
28.59 +by (intro treeFsetI_coind[where P="%x1 x2. \<exists>x. x1 = tmap (f o g) x \<and> x2 = tmap f (tmap g x)"])
28.60 + force+
28.61 +
28.62 +end
29.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
29.2 +++ b/src/HOL/BNF/More_BNFs.thy Fri Sep 21 16:45:06 2012 +0200
29.3 @@ -0,0 +1,1511 @@
29.4 +(* Title: HOL/BNF/More_BNFs.thy
29.5 + Author: Dmitriy Traytel, TU Muenchen
29.6 + Author: Andrei Popescu, TU Muenchen
29.7 + Author: Andreas Lochbihler, Karlsruhe Institute of Technology
29.8 + Author: Jasmin Blanchette, TU Muenchen
29.9 + Copyright 2012
29.10 +
29.11 +Registration of various types as bounded natural functors.
29.12 +*)
29.13 +
29.14 +header {* Registration of Various Types as Bounded Natural Functors *}
29.15 +
29.16 +theory More_BNFs
29.17 +imports
29.18 + BNF_LFP
29.19 + BNF_GFP
29.20 + "~~/src/HOL/Quotient_Examples/FSet"
29.21 + "~~/src/HOL/Library/Multiset"
29.22 + Countable_Set
29.23 +begin
29.24 +
29.25 +lemma option_rec_conv_option_case: "option_rec = option_case"
29.26 +by (simp add: fun_eq_iff split: option.split)
29.27 +
29.28 +definition option_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> bool" where
29.29 +"option_rel R x_opt y_opt =
29.30 + (case (x_opt, y_opt) of
29.31 + (None, None) \<Rightarrow> True
29.32 + | (Some x, Some y) \<Rightarrow> R x y
29.33 + | _ \<Rightarrow> False)"
29.34 +
29.35 +bnf_def Option.map [Option.set] "\<lambda>_::'a option. natLeq" ["None"] option_rel
29.36 +proof -
29.37 + show "Option.map id = id" by (simp add: fun_eq_iff Option.map_def split: option.split)
29.38 +next
29.39 + fix f g
29.40 + show "Option.map (g \<circ> f) = Option.map g \<circ> Option.map f"
29.41 + by (auto simp add: fun_eq_iff Option.map_def split: option.split)
29.42 +next
29.43 + fix f g x
29.44 + assume "\<And>z. z \<in> Option.set x \<Longrightarrow> f z = g z"
29.45 + thus "Option.map f x = Option.map g x"
29.46 + by (simp cong: Option.map_cong)
29.47 +next
29.48 + fix f
29.49 + show "Option.set \<circ> Option.map f = op ` f \<circ> Option.set"
29.50 + by fastforce
29.51 +next
29.52 + show "card_order natLeq" by (rule natLeq_card_order)
29.53 +next
29.54 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
29.55 +next
29.56 + fix x
29.57 + show "|Option.set x| \<le>o natLeq"
29.58 + by (cases x) (simp_all add: ordLess_imp_ordLeq finite_iff_ordLess_natLeq[symmetric])
29.59 +next
29.60 + fix A
29.61 + have unfold: "{x. Option.set x \<subseteq> A} = Some ` A \<union> {None}"
29.62 + by (auto simp add: option_rec_conv_option_case Option.set_def split: option.split_asm)
29.63 + show "|{x. Option.set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
29.64 + apply (rule ordIso_ordLeq_trans)
29.65 + apply (rule card_of_ordIso_subst[OF unfold])
29.66 + apply (rule ordLeq_transitive)
29.67 + apply (rule Un_csum)
29.68 + apply (rule ordLeq_transitive)
29.69 + apply (rule csum_mono)
29.70 + apply (rule card_of_image)
29.71 + apply (rule ordIso_ordLeq_trans)
29.72 + apply (rule single_cone)
29.73 + apply (rule cone_ordLeq_ctwo)
29.74 + apply (rule ordLeq_cexp1)
29.75 + apply (simp_all add: natLeq_cinfinite natLeq_Card_order cinfinite_not_czero Card_order_csum)
29.76 + done
29.77 +next
29.78 + fix A B1 B2 f1 f2 p1 p2
29.79 + assume wpull: "wpull A B1 B2 f1 f2 p1 p2"
29.80 + show "wpull {x. Option.set x \<subseteq> A} {x. Option.set x \<subseteq> B1} {x. Option.set x \<subseteq> B2}
29.81 + (Option.map f1) (Option.map f2) (Option.map p1) (Option.map p2)"
29.82 + (is "wpull ?A ?B1 ?B2 ?f1 ?f2 ?p1 ?p2")
29.83 + unfolding wpull_def
29.84 + proof (intro strip, elim conjE)
29.85 + fix b1 b2
29.86 + assume "b1 \<in> ?B1" "b2 \<in> ?B2" "?f1 b1 = ?f2 b2"
29.87 + thus "\<exists>a \<in> ?A. ?p1 a = b1 \<and> ?p2 a = b2" using wpull
29.88 + unfolding wpull_def by (cases b2) (auto 4 5)
29.89 + qed
29.90 +next
29.91 + fix z
29.92 + assume "z \<in> Option.set None"
29.93 + thus False by simp
29.94 +next
29.95 + fix R
29.96 + show "{p. option_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
29.97 + (Gr {x. Option.set x \<subseteq> R} (Option.map fst))\<inverse> O Gr {x. Option.set x \<subseteq> R} (Option.map snd)"
29.98 + unfolding option_rel_def Gr_def relcomp_unfold converse_unfold
29.99 + by (auto simp: trans[OF eq_commute option_map_is_None] trans[OF eq_commute option_map_eq_Some]
29.100 + split: option.splits) blast
29.101 +qed
29.102 +
29.103 +lemma card_of_list_in:
29.104 + "|{xs. set xs \<subseteq> A}| \<le>o |Pfunc (UNIV :: nat set) A|" (is "|?LHS| \<le>o |?RHS|")
29.105 +proof -
29.106 + let ?f = "%xs. %i. if i < length xs \<and> set xs \<subseteq> A then Some (nth xs i) else None"
29.107 + have "inj_on ?f ?LHS" unfolding inj_on_def fun_eq_iff
29.108 + proof safe
29.109 + fix xs :: "'a list" and ys :: "'a list"
29.110 + assume su: "set xs \<subseteq> A" "set ys \<subseteq> A" and eq: "\<forall>i. ?f xs i = ?f ys i"
29.111 + hence *: "length xs = length ys"
29.112 + by (metis linorder_cases option.simps(2) order_less_irrefl)
29.113 + thus "xs = ys" by (rule nth_equalityI) (metis * eq su option.inject)
29.114 + qed
29.115 + moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Pfunc_def by fastforce
29.116 + ultimately show ?thesis using card_of_ordLeq by blast
29.117 +qed
29.118 +
29.119 +lemma list_in_empty: "A = {} \<Longrightarrow> {x. set x \<subseteq> A} = {[]}"
29.120 +by simp
29.121 +
29.122 +lemma card_of_Func: "|Func A B| =o |B| ^c |A|"
29.123 +unfolding cexp_def Field_card_of by (rule card_of_refl)
29.124 +
29.125 +lemma not_emp_czero_notIn_ordIso_Card_order:
29.126 +"A \<noteq> {} \<Longrightarrow> ( |A|, czero) \<notin> ordIso \<and> Card_order |A|"
29.127 + apply (rule conjI)
29.128 + apply (metis Field_card_of czeroE)
29.129 + by (rule card_of_Card_order)
29.130 +
29.131 +lemma list_in_bd: "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
29.132 +proof -
29.133 + fix A :: "'a set"
29.134 + show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
29.135 + proof (cases "A = {}")
29.136 + case False thus ?thesis
29.137 + apply -
29.138 + apply (rule ordLeq_transitive)
29.139 + apply (rule card_of_list_in)
29.140 + apply (rule ordLeq_transitive)
29.141 + apply (erule card_of_Pfunc_Pow_Func)
29.142 + apply (rule ordIso_ordLeq_trans)
29.143 + apply (rule Times_cprod)
29.144 + apply (rule cprod_cinfinite_bound)
29.145 + apply (rule ordIso_ordLeq_trans)
29.146 + apply (rule Pow_cexp_ctwo)
29.147 + apply (rule ordIso_ordLeq_trans)
29.148 + apply (rule cexp_cong2)
29.149 + apply (rule card_of_nat)
29.150 + apply (rule Card_order_ctwo)
29.151 + apply (rule card_of_Card_order)
29.152 + apply (rule natLeq_Card_order)
29.153 + apply (rule disjI1)
29.154 + apply (rule ctwo_Cnotzero)
29.155 + apply (rule cexp_mono1)
29.156 + apply (rule ordLeq_csum2)
29.157 + apply (rule Card_order_ctwo)
29.158 + apply (rule disjI1)
29.159 + apply (rule ctwo_Cnotzero)
29.160 + apply (rule natLeq_Card_order)
29.161 + apply (rule ordIso_ordLeq_trans)
29.162 + apply (rule card_of_Func)
29.163 + apply (rule ordIso_ordLeq_trans)
29.164 + apply (rule cexp_cong2)
29.165 + apply (rule card_of_nat)
29.166 + apply (rule card_of_Card_order)
29.167 + apply (rule card_of_Card_order)
29.168 + apply (rule natLeq_Card_order)
29.169 + apply (rule disjI1)
29.170 + apply (erule not_emp_czero_notIn_ordIso_Card_order)
29.171 + apply (rule cexp_mono1)
29.172 + apply (rule ordLeq_csum1)
29.173 + apply (rule card_of_Card_order)
29.174 + apply (rule disjI1)
29.175 + apply (erule not_emp_czero_notIn_ordIso_Card_order)
29.176 + apply (rule natLeq_Card_order)
29.177 + apply (rule card_of_Card_order)
29.178 + apply (rule card_of_Card_order)
29.179 + apply (rule Cinfinite_cexp)
29.180 + apply (rule ordLeq_csum2)
29.181 + apply (rule Card_order_ctwo)
29.182 + apply (rule conjI)
29.183 + apply (rule natLeq_cinfinite)
29.184 + by (rule natLeq_Card_order)
29.185 + next
29.186 + case True thus ?thesis
29.187 + apply -
29.188 + apply (rule ordIso_ordLeq_trans)
29.189 + apply (rule card_of_ordIso_subst)
29.190 + apply (erule list_in_empty)
29.191 + apply (rule ordIso_ordLeq_trans)
29.192 + apply (rule single_cone)
29.193 + apply (rule cone_ordLeq_cexp)
29.194 + apply (rule ordLeq_transitive)
29.195 + apply (rule cone_ordLeq_ctwo)
29.196 + apply (rule ordLeq_csum2)
29.197 + by (rule Card_order_ctwo)
29.198 + qed
29.199 +qed
29.200 +
29.201 +bnf_def map [set] "\<lambda>_::'a list. natLeq" ["[]"]
29.202 +proof -
29.203 + show "map id = id" by (rule List.map.id)
29.204 +next
29.205 + fix f g
29.206 + show "map (g o f) = map g o map f" by (rule List.map.comp[symmetric])
29.207 +next
29.208 + fix x f g
29.209 + assume "\<And>z. z \<in> set x \<Longrightarrow> f z = g z"
29.210 + thus "map f x = map g x" by simp
29.211 +next
29.212 + fix f
29.213 + show "set o map f = image f o set" by (rule ext, unfold o_apply, rule set_map)
29.214 +next
29.215 + show "card_order natLeq" by (rule natLeq_card_order)
29.216 +next
29.217 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
29.218 +next
29.219 + fix x
29.220 + show "|set x| \<le>o natLeq"
29.221 + apply (rule ordLess_imp_ordLeq)
29.222 + apply (rule finite_ordLess_infinite[OF _ natLeq_Well_order])
29.223 + unfolding Field_natLeq Field_card_of by (auto simp: card_of_well_order_on)
29.224 +next
29.225 + fix A :: "'a set"
29.226 + show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
29.227 +next
29.228 + fix A B1 B2 f1 f2 p1 p2
29.229 + assume "wpull A B1 B2 f1 f2 p1 p2"
29.230 + hence pull: "\<And>b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<Longrightarrow> \<exists>a \<in> A. p1 a = b1 \<and> p2 a = b2"
29.231 + unfolding wpull_def by auto
29.232 + show "wpull {x. set x \<subseteq> A} {x. set x \<subseteq> B1} {x. set x \<subseteq> B2} (map f1) (map f2) (map p1) (map p2)"
29.233 + (is "wpull ?A ?B1 ?B2 _ _ _ _")
29.234 + proof (unfold wpull_def)
29.235 + { fix as bs assume *: "as \<in> ?B1" "bs \<in> ?B2" "map f1 as = map f2 bs"
29.236 + hence "length as = length bs" by (metis length_map)
29.237 + hence "\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs" using *
29.238 + proof (induct as bs rule: list_induct2)
29.239 + case (Cons a as b bs)
29.240 + hence "a \<in> B1" "b \<in> B2" "f1 a = f2 b" by auto
29.241 + with pull obtain z where "z \<in> A" "p1 z = a" "p2 z = b" by blast
29.242 + moreover
29.243 + from Cons obtain zs where "zs \<in> ?A" "map p1 zs = as" "map p2 zs = bs" by auto
29.244 + ultimately have "z # zs \<in> ?A" "map p1 (z # zs) = a # as \<and> map p2 (z # zs) = b # bs" by auto
29.245 + thus ?case by (rule_tac x = "z # zs" in bexI)
29.246 + qed simp
29.247 + }
29.248 + thus "\<forall>as bs. as \<in> ?B1 \<and> bs \<in> ?B2 \<and> map f1 as = map f2 bs \<longrightarrow>
29.249 + (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
29.250 + qed
29.251 +qed simp+
29.252 +
29.253 +(* Finite sets *)
29.254 +abbreviation afset where "afset \<equiv> abs_fset"
29.255 +abbreviation rfset where "rfset \<equiv> rep_fset"
29.256 +
29.257 +lemma fset_fset_member:
29.258 +"fset A = {a. a |\<in>| A}"
29.259 +unfolding fset_def fset_member_def by auto
29.260 +
29.261 +lemma afset_rfset:
29.262 +"afset (rfset x) = x"
29.263 +by (rule Quotient_fset[unfolded Quotient_def, THEN conjunct1, rule_format])
29.264 +
29.265 +lemma afset_rfset_id:
29.266 +"afset o rfset = id"
29.267 +unfolding comp_def afset_rfset id_def ..
29.268 +
29.269 +lemma rfset:
29.270 +"rfset A = rfset B \<longleftrightarrow> A = B"
29.271 +by (metis afset_rfset)
29.272 +
29.273 +lemma afset_set:
29.274 +"afset as = afset bs \<longleftrightarrow> set as = set bs"
29.275 +using Quotient_fset unfolding Quotient_def list_eq_def by auto
29.276 +
29.277 +lemma surj_afset:
29.278 +"\<exists> as. A = afset as"
29.279 +by (metis afset_rfset)
29.280 +
29.281 +lemma fset_def2:
29.282 +"fset = set o rfset"
29.283 +unfolding fset_def map_fun_def[abs_def] by simp
29.284 +
29.285 +lemma fset_def2_raw:
29.286 +"fset A = set (rfset A)"
29.287 +unfolding fset_def2 by simp
29.288 +
29.289 +lemma fset_comp_afset:
29.290 +"fset o afset = set"
29.291 +unfolding fset_def2 comp_def apply(rule ext)
29.292 +unfolding afset_set[symmetric] afset_rfset ..
29.293 +
29.294 +lemma fset_afset:
29.295 +"fset (afset as) = set as"
29.296 +unfolding fset_comp_afset[symmetric] by simp
29.297 +
29.298 +lemma set_rfset_afset:
29.299 +"set (rfset (afset as)) = set as"
29.300 +unfolding afset_set[symmetric] afset_rfset ..
29.301 +
29.302 +lemma map_fset_comp_afset:
29.303 +"(map_fset f) o afset = afset o (map f)"
29.304 +unfolding map_fset_def map_fun_def[abs_def] comp_def apply(rule ext)
29.305 +unfolding afset_set set_map set_rfset_afset id_apply ..
29.306 +
29.307 +lemma map_fset_afset:
29.308 +"(map_fset f) (afset as) = afset (map f as)"
29.309 +using map_fset_comp_afset unfolding comp_def fun_eq_iff by auto
29.310 +
29.311 +lemma fset_map_fset:
29.312 +"fset (map_fset f A) = (image f) (fset A)"
29.313 +apply(subst afset_rfset[symmetric, of A])
29.314 +unfolding map_fset_afset fset_afset set_map
29.315 +unfolding fset_def2_raw ..
29.316 +
29.317 +lemma map_fset_def2:
29.318 +"map_fset f = afset o (map f) o rfset"
29.319 +unfolding map_fset_def map_fun_def[abs_def] by simp
29.320 +
29.321 +lemma map_fset_def2_raw:
29.322 +"map_fset f A = afset (map f (rfset A))"
29.323 +unfolding map_fset_def2 by simp
29.324 +
29.325 +lemma finite_ex_fset:
29.326 +assumes "finite A"
29.327 +shows "\<exists> B. fset B = A"
29.328 +by (metis assms finite_list fset_afset)
29.329 +
29.330 +lemma wpull_image:
29.331 +assumes "wpull A B1 B2 f1 f2 p1 p2"
29.332 +shows "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
29.333 +unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
29.334 + fix Y1 Y2 assume Y1: "Y1 \<subseteq> B1" and Y2: "Y2 \<subseteq> B2" and EQ: "f1 ` Y1 = f2 ` Y2"
29.335 + def X \<equiv> "{a \<in> A. p1 a \<in> Y1 \<and> p2 a \<in> Y2}"
29.336 + show "\<exists>X\<subseteq>A. p1 ` X = Y1 \<and> p2 ` X = Y2"
29.337 + proof (rule exI[of _ X], intro conjI)
29.338 + show "p1 ` X = Y1"
29.339 + proof
29.340 + show "Y1 \<subseteq> p1 ` X"
29.341 + proof safe
29.342 + fix y1 assume y1: "y1 \<in> Y1"
29.343 + then obtain y2 where y2: "y2 \<in> Y2" and eq: "f1 y1 = f2 y2" using EQ by auto
29.344 + then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
29.345 + using assms y1 Y1 Y2 unfolding wpull_def by blast
29.346 + thus "y1 \<in> p1 ` X" unfolding X_def using y1 y2 by auto
29.347 + qed
29.348 + qed(unfold X_def, auto)
29.349 + show "p2 ` X = Y2"
29.350 + proof
29.351 + show "Y2 \<subseteq> p2 ` X"
29.352 + proof safe
29.353 + fix y2 assume y2: "y2 \<in> Y2"
29.354 + then obtain y1 where y1: "y1 \<in> Y1" and eq: "f1 y1 = f2 y2" using EQ by force
29.355 + then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
29.356 + using assms y2 Y1 Y2 unfolding wpull_def by blast
29.357 + thus "y2 \<in> p2 ` X" unfolding X_def using y1 y2 by auto
29.358 + qed
29.359 + qed(unfold X_def, auto)
29.360 + qed(unfold X_def, auto)
29.361 +qed
29.362 +
29.363 +lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
29.364 +by (rule f_the_inv_into_f) (auto simp: inj_on_def fset_cong dest!: finite_ex_fset)
29.365 +
29.366 +definition fset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> bool" where
29.367 +"fset_rel R a b \<longleftrightarrow>
29.368 + (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and>
29.369 + (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
29.370 +
29.371 +lemma fset_rel_aux:
29.372 +"(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
29.373 + (a, b) \<in> (Gr {a. fset a \<subseteq> {(a, b). R a b}} (map_fset fst))\<inverse> O
29.374 + Gr {a. fset a \<subseteq> {(a, b). R a b}} (map_fset snd)" (is "?L = ?R")
29.375 +proof
29.376 + assume ?L
29.377 + def R' \<equiv> "the_inv fset (Collect (split R) \<inter> (fset a \<times> fset b))" (is "the_inv fset ?L'")
29.378 + have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) auto
29.379 + hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
29.380 + show ?R unfolding Gr_def relcomp_unfold converse_unfold
29.381 + proof (intro CollectI prod_caseI exI conjI)
29.382 + from * show "(R', a) = (R', map_fset fst R')" using conjunct1[OF `?L`]
29.383 + by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
29.384 + from * show "(R', b) = (R', map_fset snd R')" using conjunct2[OF `?L`]
29.385 + by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
29.386 + qed (auto simp add: *)
29.387 +next
29.388 + assume ?R thus ?L unfolding Gr_def relcomp_unfold converse_unfold
29.389 + apply (simp add: subset_eq Ball_def)
29.390 + apply (rule conjI)
29.391 + apply (clarsimp, metis snd_conv)
29.392 + by (clarsimp, metis fst_conv)
29.393 +qed
29.394 +
29.395 +bnf_def map_fset [fset] "\<lambda>_::'a fset. natLeq" ["{||}"] fset_rel
29.396 +proof -
29.397 + show "map_fset id = id"
29.398 + unfolding map_fset_def2 map_id o_id afset_rfset_id ..
29.399 +next
29.400 + fix f g
29.401 + show "map_fset (g o f) = map_fset g o map_fset f"
29.402 + unfolding map_fset_def2 map.comp[symmetric] comp_def apply(rule ext)
29.403 + unfolding afset_set set_map fset_def2_raw[symmetric] image_image[symmetric]
29.404 + unfolding map_fset_afset[symmetric] map_fset_image afset_rfset
29.405 + by (rule refl)
29.406 +next
29.407 + fix x f g
29.408 + assume "\<And>z. z \<in> fset x \<Longrightarrow> f z = g z"
29.409 + hence "map f (rfset x) = map g (rfset x)"
29.410 + apply(intro map_cong) unfolding fset_def2_raw by auto
29.411 + thus "map_fset f x = map_fset g x" unfolding map_fset_def2_raw
29.412 + by (rule arg_cong)
29.413 +next
29.414 + fix f
29.415 + show "fset o map_fset f = image f o fset"
29.416 + unfolding comp_def fset_map_fset ..
29.417 +next
29.418 + show "card_order natLeq" by (rule natLeq_card_order)
29.419 +next
29.420 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
29.421 +next
29.422 + fix x
29.423 + show "|fset x| \<le>o natLeq"
29.424 + unfolding fset_def2_raw
29.425 + apply (rule ordLess_imp_ordLeq)
29.426 + apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
29.427 + by (rule finite_set)
29.428 +next
29.429 + fix A :: "'a set"
29.430 + have "|{x. fset x \<subseteq> A}| \<le>o |afset ` {as. set as \<subseteq> A}|"
29.431 + apply(rule card_of_mono1) unfolding fset_def2_raw apply auto
29.432 + apply (rule image_eqI)
29.433 + by (auto simp: afset_rfset)
29.434 + also have "|afset ` {as. set as \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_image .
29.435 + also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
29.436 + finally show "|{x. fset x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
29.437 +next
29.438 + fix A B1 B2 f1 f2 p1 p2
29.439 + assume wp: "wpull A B1 B2 f1 f2 p1 p2"
29.440 + hence "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
29.441 + by (rule wpull_image)
29.442 + show "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
29.443 + (map_fset f1) (map_fset f2) (map_fset p1) (map_fset p2)"
29.444 + unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
29.445 + fix y1 y2
29.446 + assume Y1: "fset y1 \<subseteq> B1" and Y2: "fset y2 \<subseteq> B2"
29.447 + assume "map_fset f1 y1 = map_fset f2 y2"
29.448 + hence EQ: "f1 ` (fset y1) = f2 ` (fset y2)" unfolding map_fset_def2_raw
29.449 + unfolding afset_set set_map fset_def2_raw .
29.450 + with Y1 Y2 obtain X where X: "X \<subseteq> A"
29.451 + and Y1: "p1 ` X = fset y1" and Y2: "p2 ` X = fset y2"
29.452 + using wpull_image[OF wp] unfolding wpull_def Pow_def
29.453 + unfolding Bex_def mem_Collect_eq apply -
29.454 + apply(erule allE[of _ "fset y1"], erule allE[of _ "fset y2"]) by auto
29.455 + have "\<forall> y1' \<in> fset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
29.456 + then obtain q1 where q1: "\<forall> y1' \<in> fset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
29.457 + have "\<forall> y2' \<in> fset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
29.458 + then obtain q2 where q2: "\<forall> y2' \<in> fset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
29.459 + def X' \<equiv> "q1 ` (fset y1) \<union> q2 ` (fset y2)"
29.460 + have X': "X' \<subseteq> A" and Y1: "p1 ` X' = fset y1" and Y2: "p2 ` X' = fset y2"
29.461 + using X Y1 Y2 q1 q2 unfolding X'_def by auto
29.462 + have fX': "finite X'" unfolding X'_def by simp
29.463 + then obtain x where X'eq: "X' = fset x" by (auto dest: finite_ex_fset)
29.464 + show "\<exists>x. fset x \<subseteq> A \<and> map_fset p1 x = y1 \<and> map_fset p2 x = y2"
29.465 + apply(intro exI[of _ "x"]) using X' Y1 Y2
29.466 + unfolding X'eq map_fset_def2_raw fset_def2_raw set_map[symmetric]
29.467 + afset_set[symmetric] afset_rfset by simp
29.468 + qed
29.469 +next
29.470 + fix R
29.471 + show "{p. fset_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
29.472 + (Gr {x. fset x \<subseteq> R} (map_fset fst))\<inverse> O Gr {x. fset x \<subseteq> R} (map_fset snd)"
29.473 + unfolding fset_rel_def fset_rel_aux by simp
29.474 +qed auto
29.475 +
29.476 +(* Countable sets *)
29.477 +
29.478 +lemma card_of_countable_sets_range:
29.479 +fixes A :: "'a set"
29.480 +shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
29.481 +apply(rule card_of_ordLeqI[of fromNat]) using inj_on_fromNat
29.482 +unfolding inj_on_def by auto
29.483 +
29.484 +lemma card_of_countable_sets_Func:
29.485 +"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
29.486 +using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
29.487 +unfolding cexp_def Field_natLeq Field_card_of
29.488 +by (rule ordLeq_ordIso_trans)
29.489 +
29.490 +lemma ordLeq_countable_subsets:
29.491 +"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
29.492 +apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
29.493 +
29.494 +lemma finite_countable_subset:
29.495 +"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
29.496 +apply default
29.497 + apply (erule contrapos_pp)
29.498 + apply (rule card_of_ordLeq_infinite)
29.499 + apply (rule ordLeq_countable_subsets)
29.500 + apply assumption
29.501 +apply (rule finite_Collect_conjI)
29.502 +apply (rule disjI1)
29.503 +by (erule finite_Collect_subsets)
29.504 +
29.505 +lemma card_of_countable_sets:
29.506 +"|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
29.507 +(is "|?L| \<le>o _")
29.508 +proof(cases "finite A")
29.509 + let ?R = "Func (UNIV::nat set) (A <+> (UNIV::bool set))"
29.510 + case True hence "finite ?L" by simp
29.511 + moreover have "infinite ?R"
29.512 + apply(rule infinite_Func[of _ "Inr True" "Inr False"]) by auto
29.513 + ultimately show ?thesis unfolding cexp_def csum_def ctwo_def Field_natLeq Field_card_of
29.514 + apply(intro ordLess_imp_ordLeq) by (rule finite_ordLess_infinite2)
29.515 +next
29.516 + case False
29.517 + hence "|{X. X \<subseteq> A \<and> countable X}| =o |{X. X \<subseteq> A \<and> countable X} - {{}}|"
29.518 + by (intro card_of_infinite_diff_finitte finite.emptyI finite.insertI ordIso_symmetric)
29.519 + (unfold finite_countable_subset)
29.520 + also have "|{X. X \<subseteq> A \<and> countable X} - {{}}| \<le>o |A| ^c natLeq"
29.521 + using card_of_countable_sets_Func[of A] unfolding set_diff_eq by auto
29.522 + also have "|A| ^c natLeq \<le>o ( |A| +c ctwo) ^c natLeq"
29.523 + apply(rule cexp_mono1_cone_ordLeq)
29.524 + apply(rule ordLeq_csum1, rule card_of_Card_order)
29.525 + apply (rule cone_ordLeq_cexp)
29.526 + apply (rule cone_ordLeq_Cnotzero)
29.527 + using csum_Cnotzero2 ctwo_Cnotzero apply blast
29.528 + by (rule natLeq_Card_order)
29.529 + finally show ?thesis .
29.530 +qed
29.531 +
29.532 +lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
29.533 +apply (rule f_the_inv_into_f)
29.534 +unfolding inj_on_def rcset_inj using rcset_surj by auto
29.535 +
29.536 +lemma Collect_Int_Times:
29.537 +"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
29.538 +by auto
29.539 +
29.540 +lemma rcset_natural': "rcset (cIm f x) = f ` rcset x"
29.541 +unfolding cIm_def[abs_def] by simp
29.542 +
29.543 +definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
29.544 +"cset_rel R a b \<longleftrightarrow>
29.545 + (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
29.546 + (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
29.547 +
29.548 +lemma cset_rel_aux:
29.549 +"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
29.550 + (a, b) \<in> (Gr {x. rcset x \<subseteq> {(a, b). R a b}} (cIm fst))\<inverse> O
29.551 + Gr {x. rcset x \<subseteq> {(a, b). R a b}} (cIm snd)" (is "?L = ?R")
29.552 +proof
29.553 + assume ?L
29.554 + def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
29.555 + (is "the_inv rcset ?L'")
29.556 + have "countable ?L'" by auto
29.557 + hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
29.558 + show ?R unfolding Gr_def relcomp_unfold converse_unfold
29.559 + proof (intro CollectI prod_caseI exI conjI)
29.560 + have "rcset a = fst ` ({(x, y). R x y} \<inter> rcset a \<times> rcset b)" (is "_ = ?A")
29.561 + using conjunct1[OF `?L`] unfolding image_def by (auto simp add: Collect_Int_Times)
29.562 + hence "a = acset ?A" by (metis acset_rcset)
29.563 + thus "(R', a) = (R', cIm fst R')" unfolding cIm_def * by auto
29.564 + have "rcset b = snd ` ({(x, y). R x y} \<inter> rcset a \<times> rcset b)" (is "_ = ?B")
29.565 + using conjunct2[OF `?L`] unfolding image_def by (auto simp add: Collect_Int_Times)
29.566 + hence "b = acset ?B" by (metis acset_rcset)
29.567 + thus "(R', b) = (R', cIm snd R')" unfolding cIm_def * by auto
29.568 + qed (auto simp add: *)
29.569 +next
29.570 + assume ?R thus ?L unfolding Gr_def relcomp_unfold converse_unfold
29.571 + apply (simp add: subset_eq Ball_def)
29.572 + apply (rule conjI)
29.573 + apply (clarsimp, metis (lifting, no_types) rcset_natural' image_iff surjective_pairing)
29.574 + apply (clarsimp)
29.575 + by (metis Domain.intros Range.simps rcset_natural' fst_eq_Domain snd_eq_Range)
29.576 +qed
29.577 +
29.578 +bnf_def cIm [rcset] "\<lambda>_::'a cset. natLeq" ["cEmp"] cset_rel
29.579 +proof -
29.580 + show "cIm id = id" unfolding cIm_def[abs_def] id_def by auto
29.581 +next
29.582 + fix f g show "cIm (g \<circ> f) = cIm g \<circ> cIm f"
29.583 + unfolding cIm_def[abs_def] apply(rule ext) unfolding comp_def by auto
29.584 +next
29.585 + fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
29.586 + thus "cIm f C = cIm g C"
29.587 + unfolding cIm_def[abs_def] unfolding image_def by auto
29.588 +next
29.589 + fix f show "rcset \<circ> cIm f = op ` f \<circ> rcset" unfolding cIm_def[abs_def] by auto
29.590 +next
29.591 + show "card_order natLeq" by (rule natLeq_card_order)
29.592 +next
29.593 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
29.594 +next
29.595 + fix C show "|rcset C| \<le>o natLeq" using rcset unfolding countable_def .
29.596 +next
29.597 + fix A :: "'a set"
29.598 + have "|{Z. rcset Z \<subseteq> A}| \<le>o |acset ` {X. X \<subseteq> A \<and> countable X}|"
29.599 + apply(rule card_of_mono1) unfolding Pow_def image_def
29.600 + proof (rule Collect_mono, clarsimp)
29.601 + fix x
29.602 + assume "rcset x \<subseteq> A"
29.603 + hence "rcset x \<subseteq> A \<and> countable (rcset x) \<and> x = acset (rcset x)"
29.604 + using acset_rcset[of x] rcset[of x] by force
29.605 + thus "\<exists>y \<subseteq> A. countable y \<and> x = acset y" by blast
29.606 + qed
29.607 + also have "|acset ` {X. X \<subseteq> A \<and> countable X}| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
29.608 + using card_of_image .
29.609 + also have "|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
29.610 + using card_of_countable_sets .
29.611 + finally show "|{Z. rcset Z \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
29.612 +next
29.613 + fix A B1 B2 f1 f2 p1 p2
29.614 + assume wp: "wpull A B1 B2 f1 f2 p1 p2"
29.615 + show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
29.616 + (cIm f1) (cIm f2) (cIm p1) (cIm p2)"
29.617 + unfolding wpull_def proof safe
29.618 + fix y1 y2
29.619 + assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
29.620 + assume "cIm f1 y1 = cIm f2 y2"
29.621 + hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)"
29.622 + unfolding cIm_def by auto
29.623 + with Y1 Y2 obtain X where X: "X \<subseteq> A"
29.624 + and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
29.625 + using wpull_image[OF wp] unfolding wpull_def Pow_def
29.626 + unfolding Bex_def mem_Collect_eq apply -
29.627 + apply(erule allE[of _ "rcset y1"], erule allE[of _ "rcset y2"]) by auto
29.628 + have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
29.629 + then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
29.630 + have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
29.631 + then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
29.632 + def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
29.633 + have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
29.634 + using X Y1 Y2 q1 q2 unfolding X'_def by fast+
29.635 + have fX': "countable X'" unfolding X'_def by simp
29.636 + then obtain x where X'eq: "X' = rcset x" by (metis rcset_acset)
29.637 + show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cIm p1 x = y1 \<and> cIm p2 x = y2"
29.638 + apply(intro bexI[of _ "x"]) using X' Y1 Y2 unfolding X'eq cIm_def by auto
29.639 + qed
29.640 +next
29.641 + fix R
29.642 + show "{p. cset_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
29.643 + (Gr {x. rcset x \<subseteq> R} (cIm fst))\<inverse> O Gr {x. rcset x \<subseteq> R} (cIm snd)"
29.644 + unfolding cset_rel_def cset_rel_aux by simp
29.645 +qed (unfold cEmp_def, auto)
29.646 +
29.647 +
29.648 +(* Multisets *)
29.649 +
29.650 +(* The cardinal of a mutiset: this, and the following basic lemmas about it,
29.651 +should eventually go into Multiset.thy *)
29.652 +definition "mcard M \<equiv> setsum (count M) {a. count M a > 0}"
29.653 +
29.654 +lemma mcard_emp[simp]: "mcard {#} = 0"
29.655 +unfolding mcard_def by auto
29.656 +
29.657 +lemma mcard_emp_iff[simp]: "mcard M = 0 \<longleftrightarrow> M = {#}"
29.658 +unfolding mcard_def apply safe
29.659 + apply simp_all
29.660 + by (metis multi_count_eq zero_multiset.rep_eq)
29.661 +
29.662 +lemma mcard_singl[simp]: "mcard {#a#} = Suc 0"
29.663 +unfolding mcard_def by auto
29.664 +
29.665 +lemma mcard_Plus[simp]: "mcard (M + N) = mcard M + mcard N"
29.666 +proof-
29.667 + have "setsum (count M) {a. 0 < count M a + count N a} =
29.668 + setsum (count M) {a. a \<in># M}"
29.669 + apply(rule setsum_mono_zero_cong_right) by auto
29.670 + moreover
29.671 + have "setsum (count N) {a. 0 < count M a + count N a} =
29.672 + setsum (count N) {a. a \<in># N}"
29.673 + apply(rule setsum_mono_zero_cong_right) by auto
29.674 + ultimately show ?thesis
29.675 + unfolding mcard_def count_union[THEN ext] comm_monoid_add_class.setsum.F_fun_f by simp
29.676 +qed
29.677 +
29.678 +lemma setsum_gt_0_iff:
29.679 +fixes f :: "'a \<Rightarrow> nat" assumes "finite A"
29.680 +shows "setsum f A > 0 \<longleftrightarrow> (\<exists> a \<in> A. f a > 0)"
29.681 +(is "?L \<longleftrightarrow> ?R")
29.682 +proof-
29.683 + have "?L \<longleftrightarrow> \<not> setsum f A = 0" by fast
29.684 + also have "... \<longleftrightarrow> (\<exists> a \<in> A. f a \<noteq> 0)" using assms by simp
29.685 + also have "... \<longleftrightarrow> ?R" by simp
29.686 + finally show ?thesis .
29.687 +qed
29.688 +
29.689 +(* *)
29.690 +definition mmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> nat" where
29.691 +"mmap h f b = setsum f {a. h a = b \<and> f a > 0}"
29.692 +
29.693 +lemma mmap_id: "mmap id = id"
29.694 +proof (rule ext)+
29.695 + fix f a show "mmap id f a = id f a"
29.696 + proof(cases "f a = 0")
29.697 + case False
29.698 + hence 1: "{aa. aa = a \<and> 0 < f aa} = {a}" by auto
29.699 + show ?thesis by (simp add: mmap_def id_apply 1)
29.700 + qed(unfold mmap_def, auto)
29.701 +qed
29.702 +
29.703 +lemma inj_on_setsum_inv:
29.704 +assumes f: "f \<in> multiset"
29.705 +and 1: "(0::nat) < setsum f {a. h a = b' \<and> 0 < f a}" (is "0 < setsum f ?A'")
29.706 +and 2: "{a. h a = b \<and> 0 < f a} = {a. h a = b' \<and> 0 < f a}" (is "?A = ?A'")
29.707 +shows "b = b'"
29.708 +proof-
29.709 + have "finite ?A'" using f unfolding multiset_def by auto
29.710 + hence "?A' \<noteq> {}" using 1 setsum_gt_0_iff by auto
29.711 + thus ?thesis using 2 by auto
29.712 +qed
29.713 +
29.714 +lemma mmap_comp:
29.715 +fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
29.716 +assumes f: "f \<in> multiset"
29.717 +shows "mmap (h2 o h1) f = (mmap h2 o mmap h1) f"
29.718 +unfolding mmap_def[abs_def] comp_def proof(rule ext)+
29.719 + fix c :: 'c
29.720 + let ?A = "{a. h2 (h1 a) = c \<and> 0 < f a}"
29.721 + let ?As = "\<lambda> b. {a. h1 a = b \<and> 0 < f a}"
29.722 + let ?B = "{b. h2 b = c \<and> 0 < setsum f (?As b)}"
29.723 + have 0: "{?As b | b. b \<in> ?B} = ?As ` ?B" by auto
29.724 + have "\<And> b. finite (?As b)" using f unfolding multiset_def by simp
29.725 + hence "?B = {b. h2 b = c \<and> ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
29.726 + hence A: "?A = \<Union> {?As b | b. b \<in> ?B}" by auto
29.727 + have "setsum f ?A = setsum (setsum f) {?As b | b. b \<in> ?B}"
29.728 + unfolding A apply(rule setsum_Union_disjoint)
29.729 + using f unfolding multiset_def by auto
29.730 + also have "... = setsum (setsum f) (?As ` ?B)" unfolding 0 ..
29.731 + also have "... = setsum (setsum f o ?As) ?B" apply(rule setsum_reindex)
29.732 + unfolding inj_on_def apply auto using inj_on_setsum_inv[OF f, of h1] by blast
29.733 + also have "... = setsum (\<lambda> b. setsum f (?As b)) ?B" unfolding comp_def ..
29.734 + finally show "setsum f ?A = setsum (\<lambda> b. setsum f (?As b)) ?B" .
29.735 +qed
29.736 +
29.737 +lemma mmap_comp1:
29.738 +fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
29.739 +assumes "f \<in> multiset"
29.740 +shows "mmap (\<lambda> a. h2 (h1 a)) f = mmap h2 (mmap h1 f)"
29.741 +using mmap_comp[OF assms] unfolding comp_def by auto
29.742 +
29.743 +lemma mmap:
29.744 +assumes "f \<in> multiset"
29.745 +shows "mmap h f \<in> multiset"
29.746 +using assms unfolding mmap_def[abs_def] multiset_def proof safe
29.747 + assume fin: "finite {a. 0 < f a}" (is "finite ?A")
29.748 + show "finite {b. 0 < setsum f {a. h a = b \<and> 0 < f a}}"
29.749 + (is "finite {b. 0 < setsum f (?As b)}")
29.750 + proof- let ?B = "{b. 0 < setsum f (?As b)}"
29.751 + have "\<And> b. finite (?As b)" using assms unfolding multiset_def by simp
29.752 + hence B: "?B = {b. ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
29.753 + hence "?B \<subseteq> h ` ?A" by auto
29.754 + thus ?thesis using finite_surj[OF fin] by auto
29.755 + qed
29.756 +qed
29.757 +
29.758 +lemma mmap_cong:
29.759 +assumes "\<And>a. a \<in># M \<Longrightarrow> f a = g a"
29.760 +shows "mmap f (count M) = mmap g (count M)"
29.761 +using assms unfolding mmap_def[abs_def] by (intro ext, intro setsum_cong) auto
29.762 +
29.763 +abbreviation supp where "supp f \<equiv> {a. f a > 0}"
29.764 +
29.765 +lemma mmap_image_comp:
29.766 +assumes f: "f \<in> multiset"
29.767 +shows "(supp o mmap h) f = (image h o supp) f"
29.768 +unfolding mmap_def[abs_def] comp_def proof-
29.769 + have "\<And> b. finite {a. h a = b \<and> 0 < f a}" (is "\<And> b. finite (?As b)")
29.770 + using f unfolding multiset_def by auto
29.771 + thus "{b. 0 < setsum f (?As b)} = h ` {a. 0 < f a}"
29.772 + using setsum_gt_0_iff by auto
29.773 +qed
29.774 +
29.775 +lemma mmap_image:
29.776 +assumes f: "f \<in> multiset"
29.777 +shows "supp (mmap h f) = h ` (supp f)"
29.778 +using mmap_image_comp[OF assms] unfolding comp_def .
29.779 +
29.780 +lemma set_of_Abs_multiset:
29.781 +assumes f: "f \<in> multiset"
29.782 +shows "set_of (Abs_multiset f) = supp f"
29.783 +using assms unfolding set_of_def by (auto simp: Abs_multiset_inverse)
29.784 +
29.785 +lemma supp_count:
29.786 +"supp (count M) = set_of M"
29.787 +using assms unfolding set_of_def by auto
29.788 +
29.789 +lemma multiset_of_surj:
29.790 +"multiset_of ` {as. set as \<subseteq> A} = {M. set_of M \<subseteq> A}"
29.791 +proof safe
29.792 + fix M assume M: "set_of M \<subseteq> A"
29.793 + obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto
29.794 + hence "set as \<subseteq> A" using M by auto
29.795 + thus "M \<in> multiset_of ` {as. set as \<subseteq> A}" using eq by auto
29.796 +next
29.797 + show "\<And>x xa xb. \<lbrakk>set xa \<subseteq> A; xb \<in> set_of (multiset_of xa)\<rbrakk> \<Longrightarrow> xb \<in> A"
29.798 + by (erule set_mp) (unfold set_of_multiset_of)
29.799 +qed
29.800 +
29.801 +lemma card_of_set_of:
29.802 +"|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|"
29.803 +apply(rule card_of_ordLeqI2[of _ multiset_of]) using multiset_of_surj by auto
29.804 +
29.805 +lemma nat_sum_induct:
29.806 +assumes "\<And>n1 n2. (\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow> phi m1 m2) \<Longrightarrow> phi n1 n2"
29.807 +shows "phi (n1::nat) (n2::nat)"
29.808 +proof-
29.809 + let ?chi = "\<lambda> n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)"
29.810 + have "?chi (n1,n2)"
29.811 + apply(induct rule: measure_induct[of "\<lambda> n1n2. fst n1n2 + snd n1n2" ?chi])
29.812 + using assms by (metis fstI sndI)
29.813 + thus ?thesis by simp
29.814 +qed
29.815 +
29.816 +lemma matrix_count:
29.817 +fixes ct1 ct2 :: "nat \<Rightarrow> nat"
29.818 +assumes "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
29.819 +shows
29.820 +"\<exists> ct. (\<forall> i1 \<le> n1. setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ct1 i1) \<and>
29.821 + (\<forall> i2 \<le> n2. setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ct2 i2)"
29.822 +(is "?phi ct1 ct2 n1 n2")
29.823 +proof-
29.824 + have "\<forall> ct1 ct2 :: nat \<Rightarrow> nat.
29.825 + setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"
29.826 + proof(induct rule: nat_sum_induct[of
29.827 +"\<lambda> n1 n2. \<forall> ct1 ct2 :: nat \<Rightarrow> nat.
29.828 + setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"],
29.829 + clarify)
29.830 + fix n1 n2 :: nat and ct1 ct2 :: "nat \<Rightarrow> nat"
29.831 + assume IH: "\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow>
29.832 + \<forall> dt1 dt2 :: nat \<Rightarrow> nat.
29.833 + setsum dt1 {..<Suc m1} = setsum dt2 {..<Suc m2} \<longrightarrow> ?phi dt1 dt2 m1 m2"
29.834 + and ss: "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
29.835 + show "?phi ct1 ct2 n1 n2"
29.836 + proof(cases n1)
29.837 + case 0 note n1 = 0
29.838 + show ?thesis
29.839 + proof(cases n2)
29.840 + case 0 note n2 = 0
29.841 + let ?ct = "\<lambda> i1 i2. ct2 0"
29.842 + show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by simp
29.843 + next
29.844 + case (Suc m2) note n2 = Suc
29.845 + let ?ct = "\<lambda> i1 i2. ct2 i2"
29.846 + show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
29.847 + qed
29.848 + next
29.849 + case (Suc m1) note n1 = Suc
29.850 + show ?thesis
29.851 + proof(cases n2)
29.852 + case 0 note n2 = 0
29.853 + let ?ct = "\<lambda> i1 i2. ct1 i1"
29.854 + show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
29.855 + next
29.856 + case (Suc m2) note n2 = Suc
29.857 + show ?thesis
29.858 + proof(cases "ct1 n1 \<le> ct2 n2")
29.859 + case True
29.860 + def dt2 \<equiv> "\<lambda> i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2"
29.861 + have "setsum ct1 {..<Suc m1} = setsum dt2 {..<Suc n2}"
29.862 + unfolding dt2_def using ss n1 True by auto
29.863 + hence "?phi ct1 dt2 m1 n2" using IH[of m1 n2] n1 by simp
29.864 + then obtain dt where
29.865 + 1: "\<And> i1. i1 \<le> m1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc n2} = ct1 i1" and
29.866 + 2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc m1} = dt2 i2" by auto
29.867 + let ?ct = "\<lambda> i1 i2. if i1 = n1 then (if i2 = n2 then ct1 n1 else 0)
29.868 + else dt i1 i2"
29.869 + show ?thesis apply(rule exI[of _ ?ct])
29.870 + using n1 n2 1 2 True unfolding dt2_def by simp
29.871 + next
29.872 + case False
29.873 + hence False: "ct2 n2 < ct1 n1" by simp
29.874 + def dt1 \<equiv> "\<lambda> i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1"
29.875 + have "setsum dt1 {..<Suc n1} = setsum ct2 {..<Suc m2}"
29.876 + unfolding dt1_def using ss n2 False by auto
29.877 + hence "?phi dt1 ct2 n1 m2" using IH[of n1 m2] n2 by simp
29.878 + then obtain dt where
29.879 + 1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc m2} = dt1 i1" and
29.880 + 2: "\<And> i2. i2 \<le> m2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc n1} = ct2 i2" by force
29.881 + let ?ct = "\<lambda> i1 i2. if i2 = n2 then (if i1 = n1 then ct2 n2 else 0)
29.882 + else dt i1 i2"
29.883 + show ?thesis apply(rule exI[of _ ?ct])
29.884 + using n1 n2 1 2 False unfolding dt1_def by simp
29.885 + qed
29.886 + qed
29.887 + qed
29.888 + qed
29.889 + thus ?thesis using assms by auto
29.890 +qed
29.891 +
29.892 +definition
29.893 +"inj2 u B1 B2 \<equiv>
29.894 + \<forall> b1 b1' b2 b2'. {b1,b1'} \<subseteq> B1 \<and> {b2,b2'} \<subseteq> B2 \<and> u b1 b2 = u b1' b2'
29.895 + \<longrightarrow> b1 = b1' \<and> b2 = b2'"
29.896 +
29.897 +lemma matrix_setsum_finite:
29.898 +assumes B1: "B1 \<noteq> {}" "finite B1" and B2: "B2 \<noteq> {}" "finite B2" and u: "inj2 u B1 B2"
29.899 +and ss: "setsum N1 B1 = setsum N2 B2"
29.900 +shows "\<exists> M :: 'a \<Rightarrow> nat.
29.901 + (\<forall> b1 \<in> B1. setsum (\<lambda> b2. M (u b1 b2)) B2 = N1 b1) \<and>
29.902 + (\<forall> b2 \<in> B2. setsum (\<lambda> b1. M (u b1 b2)) B1 = N2 b2)"
29.903 +proof-
29.904 + obtain n1 where "card B1 = Suc n1" using B1 by (metis card_insert finite.simps)
29.905 + then obtain e1 where e1: "bij_betw e1 {..<Suc n1} B1"
29.906 + using ex_bij_betw_finite_nat[OF B1(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
29.907 + hence e1_inj: "inj_on e1 {..<Suc n1}" and e1_surj: "e1 ` {..<Suc n1} = B1"
29.908 + unfolding bij_betw_def by auto
29.909 + def f1 \<equiv> "inv_into {..<Suc n1} e1"
29.910 + have f1: "bij_betw f1 B1 {..<Suc n1}"
29.911 + and f1e1[simp]: "\<And> i1. i1 < Suc n1 \<Longrightarrow> f1 (e1 i1) = i1"
29.912 + and e1f1[simp]: "\<And> b1. b1 \<in> B1 \<Longrightarrow> e1 (f1 b1) = b1" unfolding f1_def
29.913 + apply (metis bij_betw_inv_into e1, metis bij_betw_inv_into_left e1 lessThan_iff)
29.914 + by (metis e1_surj f_inv_into_f)
29.915 + (* *)
29.916 + obtain n2 where "card B2 = Suc n2" using B2 by (metis card_insert finite.simps)
29.917 + then obtain e2 where e2: "bij_betw e2 {..<Suc n2} B2"
29.918 + using ex_bij_betw_finite_nat[OF B2(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
29.919 + hence e2_inj: "inj_on e2 {..<Suc n2}" and e2_surj: "e2 ` {..<Suc n2} = B2"
29.920 + unfolding bij_betw_def by auto
29.921 + def f2 \<equiv> "inv_into {..<Suc n2} e2"
29.922 + have f2: "bij_betw f2 B2 {..<Suc n2}"
29.923 + and f2e2[simp]: "\<And> i2. i2 < Suc n2 \<Longrightarrow> f2 (e2 i2) = i2"
29.924 + and e2f2[simp]: "\<And> b2. b2 \<in> B2 \<Longrightarrow> e2 (f2 b2) = b2" unfolding f2_def
29.925 + apply (metis bij_betw_inv_into e2, metis bij_betw_inv_into_left e2 lessThan_iff)
29.926 + by (metis e2_surj f_inv_into_f)
29.927 + (* *)
29.928 + let ?ct1 = "N1 o e1" let ?ct2 = "N2 o e2"
29.929 + have ss: "setsum ?ct1 {..<Suc n1} = setsum ?ct2 {..<Suc n2}"
29.930 + unfolding setsum_reindex[OF e1_inj, symmetric] setsum_reindex[OF e2_inj, symmetric]
29.931 + e1_surj e2_surj using ss .
29.932 + obtain ct where
29.933 + ct1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ?ct1 i1" and
29.934 + ct2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ?ct2 i2"
29.935 + using matrix_count[OF ss] by blast
29.936 + (* *)
29.937 + def A \<equiv> "{u b1 b2 | b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"
29.938 + have "\<forall> a \<in> A. \<exists> b1b2 \<in> B1 <*> B2. u (fst b1b2) (snd b1b2) = a"
29.939 + unfolding A_def Ball_def mem_Collect_eq by auto
29.940 + then obtain h1h2 where h12:
29.941 + "\<And>a. a \<in> A \<Longrightarrow> u (fst (h1h2 a)) (snd (h1h2 a)) = a \<and> h1h2 a \<in> B1 <*> B2" by metis
29.942 + def h1 \<equiv> "fst o h1h2" def h2 \<equiv> "snd o h1h2"
29.943 + have h12[simp]: "\<And>a. a \<in> A \<Longrightarrow> u (h1 a) (h2 a) = a"
29.944 + "\<And> a. a \<in> A \<Longrightarrow> h1 a \<in> B1" "\<And> a. a \<in> A \<Longrightarrow> h2 a \<in> B2"
29.945 + using h12 unfolding h1_def h2_def by force+
29.946 + {fix b1 b2 assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2"
29.947 + hence inA: "u b1 b2 \<in> A" unfolding A_def by auto
29.948 + hence "u b1 b2 = u (h1 (u b1 b2)) (h2 (u b1 b2))" by auto
29.949 + moreover have "h1 (u b1 b2) \<in> B1" "h2 (u b1 b2) \<in> B2" using inA by auto
29.950 + ultimately have "h1 (u b1 b2) = b1 \<and> h2 (u b1 b2) = b2"
29.951 + using u b1 b2 unfolding inj2_def by fastforce
29.952 + }
29.953 + hence h1[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h1 (u b1 b2) = b1" and
29.954 + h2[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h2 (u b1 b2) = b2" by auto
29.955 + def M \<equiv> "\<lambda> a. ct (f1 (h1 a)) (f2 (h2 a))"
29.956 + show ?thesis
29.957 + apply(rule exI[of _ M]) proof safe
29.958 + fix b1 assume b1: "b1 \<in> B1"
29.959 + hence f1b1: "f1 b1 \<le> n1" using f1 unfolding bij_betw_def
29.960 + by (metis bij_betwE f1 lessThan_iff less_Suc_eq_le)
29.961 + have "(\<Sum>b2\<in>B2. M (u b1 b2)) = (\<Sum>i2<Suc n2. ct (f1 b1) (f2 (e2 i2)))"
29.962 + unfolding e2_surj[symmetric] setsum_reindex[OF e2_inj]
29.963 + unfolding M_def comp_def apply(intro setsum_cong) apply force
29.964 + by (metis e2_surj b1 h1 h2 imageI)
29.965 + also have "... = N1 b1" using b1 ct1[OF f1b1] by simp
29.966 + finally show "(\<Sum>b2\<in>B2. M (u b1 b2)) = N1 b1" .
29.967 + next
29.968 + fix b2 assume b2: "b2 \<in> B2"
29.969 + hence f2b2: "f2 b2 \<le> n2" using f2 unfolding bij_betw_def
29.970 + by (metis bij_betwE f2 lessThan_iff less_Suc_eq_le)
29.971 + have "(\<Sum>b1\<in>B1. M (u b1 b2)) = (\<Sum>i1<Suc n1. ct (f1 (e1 i1)) (f2 b2))"
29.972 + unfolding e1_surj[symmetric] setsum_reindex[OF e1_inj]
29.973 + unfolding M_def comp_def apply(intro setsum_cong) apply force
29.974 + by (metis e1_surj b2 h1 h2 imageI)
29.975 + also have "... = N2 b2" using b2 ct2[OF f2b2] by simp
29.976 + finally show "(\<Sum>b1\<in>B1. M (u b1 b2)) = N2 b2" .
29.977 + qed
29.978 +qed
29.979 +
29.980 +lemma supp_vimage_mmap:
29.981 +assumes "M \<in> multiset"
29.982 +shows "supp M \<subseteq> f -` (supp (mmap f M))"
29.983 +using assms by (auto simp: mmap_image)
29.984 +
29.985 +lemma mmap_ge_0:
29.986 +assumes "M \<in> multiset"
29.987 +shows "0 < mmap f M b \<longleftrightarrow> (\<exists>a. 0 < M a \<and> f a = b)"
29.988 +proof-
29.989 + have f: "finite {a. f a = b \<and> 0 < M a}" using assms unfolding multiset_def by auto
29.990 + show ?thesis unfolding mmap_def setsum_gt_0_iff[OF f] by auto
29.991 +qed
29.992 +
29.993 +lemma finite_twosets:
29.994 +assumes "finite B1" and "finite B2"
29.995 +shows "finite {u b1 b2 |b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}" (is "finite ?A")
29.996 +proof-
29.997 + have A: "?A = (\<lambda> b1b2. u (fst b1b2) (snd b1b2)) ` (B1 <*> B2)" by force
29.998 + show ?thesis unfolding A using finite_cartesian_product[OF assms] by auto
29.999 +qed
29.1000 +
29.1001 +lemma wp_mmap:
29.1002 +fixes A :: "'a set" and B1 :: "'b1 set" and B2 :: "'b2 set"
29.1003 +assumes wp: "wpull A B1 B2 f1 f2 p1 p2"
29.1004 +shows
29.1005 +"wpull {M. M \<in> multiset \<and> supp M \<subseteq> A}
29.1006 + {N1. N1 \<in> multiset \<and> supp N1 \<subseteq> B1} {N2. N2 \<in> multiset \<and> supp N2 \<subseteq> B2}
29.1007 + (mmap f1) (mmap f2) (mmap p1) (mmap p2)"
29.1008 +unfolding wpull_def proof (safe, unfold Bex_def mem_Collect_eq)
29.1009 + fix N1 :: "'b1 \<Rightarrow> nat" and N2 :: "'b2 \<Rightarrow> nat"
29.1010 + assume mmap': "mmap f1 N1 = mmap f2 N2"
29.1011 + and N1[simp]: "N1 \<in> multiset" "supp N1 \<subseteq> B1"
29.1012 + and N2[simp]: "N2 \<in> multiset" "supp N2 \<subseteq> B2"
29.1013 + have mN1[simp]: "mmap f1 N1 \<in> multiset" using N1 by (auto simp: mmap)
29.1014 + have mN2[simp]: "mmap f2 N2 \<in> multiset" using N2 by (auto simp: mmap)
29.1015 + def P \<equiv> "mmap f1 N1"
29.1016 + have P1: "P = mmap f1 N1" and P2: "P = mmap f2 N2" unfolding P_def using mmap' by auto
29.1017 + note P = P1 P2
29.1018 + have P_mult[simp]: "P \<in> multiset" unfolding P_def using N1 by auto
29.1019 + have fin_N1[simp]: "finite (supp N1)" using N1(1) unfolding multiset_def by auto
29.1020 + have fin_N2[simp]: "finite (supp N2)" using N2(1) unfolding multiset_def by auto
29.1021 + have fin_P[simp]: "finite (supp P)" using P_mult unfolding multiset_def by auto
29.1022 + (* *)
29.1023 + def set1 \<equiv> "\<lambda> c. {b1 \<in> supp N1. f1 b1 = c}"
29.1024 + have set1[simp]: "\<And> c b1. b1 \<in> set1 c \<Longrightarrow> f1 b1 = c" unfolding set1_def by auto
29.1025 + have fin_set1: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set1 c)"
29.1026 + using N1(1) unfolding set1_def multiset_def by auto
29.1027 + have set1_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<noteq> {}"
29.1028 + unfolding set1_def P1 mmap_ge_0[OF N1(1)] by auto
29.1029 + have supp_N1_set1: "supp N1 = (\<Union> c \<in> supp P. set1 c)"
29.1030 + using supp_vimage_mmap[OF N1(1), of f1] unfolding set1_def P1 by auto
29.1031 + hence set1_inclN1: "\<And>c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> supp N1" by auto
29.1032 + hence set1_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> B1" using N1(2) by blast
29.1033 + have set1_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set1 c \<inter> set1 c' = {}"
29.1034 + unfolding set1_def by auto
29.1035 + have setsum_set1: "\<And> c. setsum N1 (set1 c) = P c"
29.1036 + unfolding P1 set1_def mmap_def apply(rule setsum_cong) by auto
29.1037 + (* *)
29.1038 + def set2 \<equiv> "\<lambda> c. {b2 \<in> supp N2. f2 b2 = c}"
29.1039 + have set2[simp]: "\<And> c b2. b2 \<in> set2 c \<Longrightarrow> f2 b2 = c" unfolding set2_def by auto
29.1040 + have fin_set2: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set2 c)"
29.1041 + using N2(1) unfolding set2_def multiset_def by auto
29.1042 + have set2_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<noteq> {}"
29.1043 + unfolding set2_def P2 mmap_ge_0[OF N2(1)] by auto
29.1044 + have supp_N2_set2: "supp N2 = (\<Union> c \<in> supp P. set2 c)"
29.1045 + using supp_vimage_mmap[OF N2(1), of f2] unfolding set2_def P2 by auto
29.1046 + hence set2_inclN2: "\<And>c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> supp N2" by auto
29.1047 + hence set2_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> B2" using N2(2) by blast
29.1048 + have set2_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set2 c \<inter> set2 c' = {}"
29.1049 + unfolding set2_def by auto
29.1050 + have setsum_set2: "\<And> c. setsum N2 (set2 c) = P c"
29.1051 + unfolding P2 set2_def mmap_def apply(rule setsum_cong) by auto
29.1052 + (* *)
29.1053 + have ss: "\<And> c. c \<in> supp P \<Longrightarrow> setsum N1 (set1 c) = setsum N2 (set2 c)"
29.1054 + unfolding setsum_set1 setsum_set2 ..
29.1055 + have "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
29.1056 + \<exists> a \<in> A. p1 a = fst b1b2 \<and> p2 a = snd b1b2"
29.1057 + using wp set1_incl set2_incl unfolding wpull_def Ball_def mem_Collect_eq
29.1058 + by simp (metis set1 set2 set_rev_mp)
29.1059 + then obtain uu where uu:
29.1060 + "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
29.1061 + uu c b1b2 \<in> A \<and> p1 (uu c b1b2) = fst b1b2 \<and> p2 (uu c b1b2) = snd b1b2" by metis
29.1062 + def u \<equiv> "\<lambda> c b1 b2. uu c (b1,b2)"
29.1063 + have u[simp]:
29.1064 + "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> A"
29.1065 + "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p1 (u c b1 b2) = b1"
29.1066 + "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p2 (u c b1 b2) = b2"
29.1067 + using uu unfolding u_def by auto
29.1068 + {fix c assume c: "c \<in> supp P"
29.1069 + have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify
29.1070 + fix b1 b1' b2 b2'
29.1071 + assume "{b1, b1'} \<subseteq> set1 c" "{b2, b2'} \<subseteq> set2 c" and 0: "u c b1 b2 = u c b1' b2'"
29.1072 + hence "p1 (u c b1 b2) = b1 \<and> p2 (u c b1 b2) = b2 \<and>
29.1073 + p1 (u c b1' b2') = b1' \<and> p2 (u c b1' b2') = b2'"
29.1074 + using u(2)[OF c] u(3)[OF c] by simp metis
29.1075 + thus "b1 = b1' \<and> b2 = b2'" using 0 by auto
29.1076 + qed
29.1077 + } note inj = this
29.1078 + def sset \<equiv> "\<lambda> c. {u c b1 b2 | b1 b2. b1 \<in> set1 c \<and> b2 \<in> set2 c}"
29.1079 + have fin_sset[simp]: "\<And> c. c \<in> supp P \<Longrightarrow> finite (sset c)" unfolding sset_def
29.1080 + using fin_set1 fin_set2 finite_twosets by blast
29.1081 + have sset_A: "\<And> c. c \<in> supp P \<Longrightarrow> sset c \<subseteq> A" unfolding sset_def by auto
29.1082 + {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
29.1083 + then obtain b1 b2 where b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
29.1084 + and a: "a = u c b1 b2" unfolding sset_def by auto
29.1085 + have "p1 a \<in> set1 c" and p2a: "p2 a \<in> set2 c"
29.1086 + using ac a b1 b2 c u(2) u(3) by simp+
29.1087 + hence "u c (p1 a) (p2 a) = a" unfolding a using b1 b2 inj[OF c]
29.1088 + unfolding inj2_def by (metis c u(2) u(3))
29.1089 + } note u_p12[simp] = this
29.1090 + {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
29.1091 + hence "p1 a \<in> set1 c" unfolding sset_def by auto
29.1092 + }note p1[simp] = this
29.1093 + {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
29.1094 + hence "p2 a \<in> set2 c" unfolding sset_def by auto
29.1095 + }note p2[simp] = this
29.1096 + (* *)
29.1097 + {fix c assume c: "c \<in> supp P"
29.1098 + hence "\<exists> M. (\<forall> b1 \<in> set1 c. setsum (\<lambda> b2. M (u c b1 b2)) (set2 c) = N1 b1) \<and>
29.1099 + (\<forall> b2 \<in> set2 c. setsum (\<lambda> b1. M (u c b1 b2)) (set1 c) = N2 b2)"
29.1100 + unfolding sset_def
29.1101 + using matrix_setsum_finite[OF set1_NE[OF c] fin_set1[OF c]
29.1102 + set2_NE[OF c] fin_set2[OF c] inj[OF c] ss[OF c]] by auto
29.1103 + }
29.1104 + then obtain Ms where
29.1105 + ss1: "\<And> c b1. \<lbrakk>c \<in> supp P; b1 \<in> set1 c\<rbrakk> \<Longrightarrow>
29.1106 + setsum (\<lambda> b2. Ms c (u c b1 b2)) (set2 c) = N1 b1" and
29.1107 + ss2: "\<And> c b2. \<lbrakk>c \<in> supp P; b2 \<in> set2 c\<rbrakk> \<Longrightarrow>
29.1108 + setsum (\<lambda> b1. Ms c (u c b1 b2)) (set1 c) = N2 b2"
29.1109 + by metis
29.1110 + def SET \<equiv> "\<Union> c \<in> supp P. sset c"
29.1111 + have fin_SET[simp]: "finite SET" unfolding SET_def apply(rule finite_UN_I) by auto
29.1112 + have SET_A: "SET \<subseteq> A" unfolding SET_def using sset_A by auto
29.1113 + have u_SET[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> SET"
29.1114 + unfolding SET_def sset_def by blast
29.1115 + {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p1a: "p1 a \<in> set1 c"
29.1116 + then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
29.1117 + unfolding SET_def by auto
29.1118 + hence "p1 a \<in> set1 c'" unfolding sset_def by auto
29.1119 + hence eq: "c = c'" using p1a c c' set1_disj by auto
29.1120 + hence "a \<in> sset c" using ac' by simp
29.1121 + } note p1_rev = this
29.1122 + {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p2a: "p2 a \<in> set2 c"
29.1123 + then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
29.1124 + unfolding SET_def by auto
29.1125 + hence "p2 a \<in> set2 c'" unfolding sset_def by auto
29.1126 + hence eq: "c = c'" using p2a c c' set2_disj by auto
29.1127 + hence "a \<in> sset c" using ac' by simp
29.1128 + } note p2_rev = this
29.1129 + (* *)
29.1130 + have "\<forall> a \<in> SET. \<exists> c \<in> supp P. a \<in> sset c" unfolding SET_def by auto
29.1131 + then obtain h where h: "\<forall> a \<in> SET. h a \<in> supp P \<and> a \<in> sset (h a)" by metis
29.1132 + have h_u[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
29.1133 + \<Longrightarrow> h (u c b1 b2) = c"
29.1134 + by (metis h p2 set2 u(3) u_SET)
29.1135 + have h_u1: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
29.1136 + \<Longrightarrow> h (u c b1 b2) = f1 b1"
29.1137 + using h unfolding sset_def by auto
29.1138 + have h_u2: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
29.1139 + \<Longrightarrow> h (u c b1 b2) = f2 b2"
29.1140 + using h unfolding sset_def by auto
29.1141 + def M \<equiv> "\<lambda> a. if a \<in> SET \<and> p1 a \<in> supp N1 \<and> p2 a \<in> supp N2 then Ms (h a) a else 0"
29.1142 + have sM: "supp M \<subseteq> SET" "supp M \<subseteq> p1 -` (supp N1)" "supp M \<subseteq> p2 -` (supp N2)"
29.1143 + unfolding M_def by auto
29.1144 + show "\<exists>M. (M \<in> multiset \<and> supp M \<subseteq> A) \<and> mmap p1 M = N1 \<and> mmap p2 M = N2"
29.1145 + proof(rule exI[of _ M], safe)
29.1146 + show "M \<in> multiset"
29.1147 + unfolding multiset_def using finite_subset[OF sM(1) fin_SET] by simp
29.1148 + next
29.1149 + fix a assume "0 < M a"
29.1150 + thus "a \<in> A" unfolding M_def using SET_A by (cases "a \<in> SET") auto
29.1151 + next
29.1152 + show "mmap p1 M = N1"
29.1153 + unfolding mmap_def[abs_def] proof(rule ext)
29.1154 + fix b1
29.1155 + let ?K = "{a. p1 a = b1 \<and> 0 < M a}"
29.1156 + show "setsum M ?K = N1 b1"
29.1157 + proof(cases "b1 \<in> supp N1")
29.1158 + case False
29.1159 + hence "?K = {}" using sM(2) by auto
29.1160 + thus ?thesis using False by auto
29.1161 + next
29.1162 + case True
29.1163 + def c \<equiv> "f1 b1"
29.1164 + have c: "c \<in> supp P" and b1: "b1 \<in> set1 c"
29.1165 + unfolding set1_def c_def P1 using True by (auto simp: mmap_image)
29.1166 + have "setsum M ?K = setsum M {a. p1 a = b1 \<and> a \<in> SET}"
29.1167 + apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
29.1168 + also have "... = setsum M ((\<lambda> b2. u c b1 b2) ` (set2 c))"
29.1169 + apply(rule setsum_cong) using c b1 proof safe
29.1170 + fix a assume p1a: "p1 a \<in> set1 c" and "0 < P c" and "a \<in> SET"
29.1171 + hence ac: "a \<in> sset c" using p1_rev by auto
29.1172 + hence "a = u c (p1 a) (p2 a)" using c by auto
29.1173 + moreover have "p2 a \<in> set2 c" using ac c by auto
29.1174 + ultimately show "a \<in> u c (p1 a) ` set2 c" by auto
29.1175 + next
29.1176 + fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
29.1177 + hence "u c b1 b2 \<in> SET" using c by auto
29.1178 + qed auto
29.1179 + also have "... = setsum (\<lambda> b2. M (u c b1 b2)) (set2 c)"
29.1180 + unfolding comp_def[symmetric] apply(rule setsum_reindex)
29.1181 + using inj unfolding inj_on_def inj2_def using b1 c u(3) by blast
29.1182 + also have "... = N1 b1" unfolding ss1[OF c b1, symmetric]
29.1183 + apply(rule setsum_cong[OF refl]) unfolding M_def
29.1184 + using True h_u[OF c b1] set2_def u(2,3)[OF c b1] u_SET[OF c b1] by fastforce
29.1185 + finally show ?thesis .
29.1186 + qed
29.1187 + qed
29.1188 + next
29.1189 + show "mmap p2 M = N2"
29.1190 + unfolding mmap_def[abs_def] proof(rule ext)
29.1191 + fix b2
29.1192 + let ?K = "{a. p2 a = b2 \<and> 0 < M a}"
29.1193 + show "setsum M ?K = N2 b2"
29.1194 + proof(cases "b2 \<in> supp N2")
29.1195 + case False
29.1196 + hence "?K = {}" using sM(3) by auto
29.1197 + thus ?thesis using False by auto
29.1198 + next
29.1199 + case True
29.1200 + def c \<equiv> "f2 b2"
29.1201 + have c: "c \<in> supp P" and b2: "b2 \<in> set2 c"
29.1202 + unfolding set2_def c_def P2 using True by (auto simp: mmap_image)
29.1203 + have "setsum M ?K = setsum M {a. p2 a = b2 \<and> a \<in> SET}"
29.1204 + apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
29.1205 + also have "... = setsum M ((\<lambda> b1. u c b1 b2) ` (set1 c))"
29.1206 + apply(rule setsum_cong) using c b2 proof safe
29.1207 + fix a assume p2a: "p2 a \<in> set2 c" and "0 < P c" and "a \<in> SET"
29.1208 + hence ac: "a \<in> sset c" using p2_rev by auto
29.1209 + hence "a = u c (p1 a) (p2 a)" using c by auto
29.1210 + moreover have "p1 a \<in> set1 c" using ac c by auto
29.1211 + ultimately show "a \<in> (\<lambda>b1. u c b1 (p2 a)) ` set1 c" by auto
29.1212 + next
29.1213 + fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
29.1214 + hence "u c b1 b2 \<in> SET" using c by auto
29.1215 + qed auto
29.1216 + also have "... = setsum (M o (\<lambda> b1. u c b1 b2)) (set1 c)"
29.1217 + apply(rule setsum_reindex)
29.1218 + using inj unfolding inj_on_def inj2_def using b2 c u(2) by blast
29.1219 + also have "... = setsum (\<lambda> b1. M (u c b1 b2)) (set1 c)"
29.1220 + unfolding comp_def[symmetric] by simp
29.1221 + also have "... = N2 b2" unfolding ss2[OF c b2, symmetric]
29.1222 + apply(rule setsum_cong[OF refl]) unfolding M_def set2_def
29.1223 + using True h_u1[OF c _ b2] u(2,3)[OF c _ b2] u_SET[OF c _ b2]
29.1224 + unfolding set1_def by fastforce
29.1225 + finally show ?thesis .
29.1226 + qed
29.1227 + qed
29.1228 + qed
29.1229 +qed
29.1230 +
29.1231 +definition multiset_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
29.1232 +"multiset_map h = Abs_multiset \<circ> mmap h \<circ> count"
29.1233 +
29.1234 +bnf_def multiset_map [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
29.1235 +unfolding multiset_map_def
29.1236 +proof -
29.1237 + show "Abs_multiset \<circ> mmap id \<circ> count = id" unfolding mmap_id by (auto simp: count_inverse)
29.1238 +next
29.1239 + fix f g
29.1240 + show "Abs_multiset \<circ> mmap (g \<circ> f) \<circ> count =
29.1241 + Abs_multiset \<circ> mmap g \<circ> count \<circ> (Abs_multiset \<circ> mmap f \<circ> count)"
29.1242 + unfolding comp_def apply(rule ext)
29.1243 + by (auto simp: Abs_multiset_inverse count mmap_comp1 mmap)
29.1244 +next
29.1245 + fix M f g assume eq: "\<And>a. a \<in> set_of M \<Longrightarrow> f a = g a"
29.1246 + thus "(Abs_multiset \<circ> mmap f \<circ> count) M = (Abs_multiset \<circ> mmap g \<circ> count) M" apply auto
29.1247 + unfolding cIm_def[abs_def] image_def
29.1248 + by (auto intro!: mmap_cong simp: Abs_multiset_inject count mmap)
29.1249 +next
29.1250 + fix f show "set_of \<circ> (Abs_multiset \<circ> mmap f \<circ> count) = op ` f \<circ> set_of"
29.1251 + by (auto simp: count mmap mmap_image set_of_Abs_multiset supp_count)
29.1252 +next
29.1253 + show "card_order natLeq" by (rule natLeq_card_order)
29.1254 +next
29.1255 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
29.1256 +next
29.1257 + fix M show "|set_of M| \<le>o natLeq"
29.1258 + apply(rule ordLess_imp_ordLeq)
29.1259 + unfolding finite_iff_ordLess_natLeq[symmetric] using finite_set_of .
29.1260 +next
29.1261 + fix A :: "'a set"
29.1262 + have "|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_set_of .
29.1263 + also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
29.1264 + by (rule list_in_bd)
29.1265 + finally show "|{M. set_of M \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
29.1266 +next
29.1267 + fix A B1 B2 f1 f2 p1 p2
29.1268 + let ?map = "\<lambda> f. Abs_multiset \<circ> mmap f \<circ> count"
29.1269 + assume wp: "wpull A B1 B2 f1 f2 p1 p2"
29.1270 + show "wpull {x. set_of x \<subseteq> A} {x. set_of x \<subseteq> B1} {x. set_of x \<subseteq> B2}
29.1271 + (?map f1) (?map f2) (?map p1) (?map p2)"
29.1272 + unfolding wpull_def proof safe
29.1273 + fix y1 y2
29.1274 + assume y1: "set_of y1 \<subseteq> B1" and y2: "set_of y2 \<subseteq> B2"
29.1275 + and m: "?map f1 y1 = ?map f2 y2"
29.1276 + def N1 \<equiv> "count y1" def N2 \<equiv> "count y2"
29.1277 + have "N1 \<in> multiset \<and> supp N1 \<subseteq> B1" and "N2 \<in> multiset \<and> supp N2 \<subseteq> B2"
29.1278 + and "mmap f1 N1 = mmap f2 N2"
29.1279 + using y1 y2 m unfolding N1_def N2_def
29.1280 + by (auto simp: Abs_multiset_inject count mmap)
29.1281 + then obtain M where M: "M \<in> multiset \<and> supp M \<subseteq> A"
29.1282 + and N1: "mmap p1 M = N1" and N2: "mmap p2 M = N2"
29.1283 + using wp_mmap[OF wp] unfolding wpull_def by auto
29.1284 + def x \<equiv> "Abs_multiset M"
29.1285 + show "\<exists>x\<in>{x. set_of x \<subseteq> A}. ?map p1 x = y1 \<and> ?map p2 x = y2"
29.1286 + apply(intro bexI[of _ x]) using M N1 N2 unfolding N1_def N2_def x_def
29.1287 + by (auto simp: count_inverse Abs_multiset_inverse)
29.1288 + qed
29.1289 +qed (unfold set_of_empty, auto)
29.1290 +
29.1291 +inductive multiset_rel' where
29.1292 +Zero: "multiset_rel' R {#} {#}"
29.1293 +|
29.1294 +Plus: "\<lbrakk>R a b; multiset_rel' R M N\<rbrakk> \<Longrightarrow> multiset_rel' R (M + {#a#}) (N + {#b#})"
29.1295 +
29.1296 +lemma multiset_map_Zero_iff[simp]: "multiset_map f M = {#} \<longleftrightarrow> M = {#}"
29.1297 +by (metis image_is_empty multiset.set_natural' set_of_eq_empty_iff)
29.1298 +
29.1299 +lemma multiset_map_Zero[simp]: "multiset_map f {#} = {#}" by simp
29.1300 +
29.1301 +lemma multiset_rel_Zero: "multiset_rel R {#} {#}"
29.1302 +unfolding multiset_rel_def Gr_def relcomp_unfold by auto
29.1303 +
29.1304 +declare multiset.count[simp]
29.1305 +declare mmap[simp]
29.1306 +declare Abs_multiset_inverse[simp]
29.1307 +declare multiset.count_inverse[simp]
29.1308 +declare union_preserves_multiset[simp]
29.1309 +
29.1310 +lemma mmap_Plus[simp]:
29.1311 +assumes "K \<in> multiset" and "L \<in> multiset"
29.1312 +shows "mmap f (\<lambda>a. K a + L a) a = mmap f K a + mmap f L a"
29.1313 +proof-
29.1314 + have "{aa. f aa = a \<and> (0 < K aa \<or> 0 < L aa)} \<subseteq>
29.1315 + {aa. 0 < K aa} \<union> {aa. 0 < L aa}" (is "?C \<subseteq> ?A \<union> ?B") by auto
29.1316 + moreover have "finite (?A \<union> ?B)" apply(rule finite_UnI)
29.1317 + using assms unfolding multiset_def by auto
29.1318 + ultimately have C: "finite ?C" using finite_subset by blast
29.1319 + have "setsum K {aa. f aa = a \<and> 0 < K aa} = setsum K {aa. f aa = a \<and> 0 < K aa + L aa}"
29.1320 + apply(rule setsum_mono_zero_cong_left) using C by auto
29.1321 + moreover
29.1322 + have "setsum L {aa. f aa = a \<and> 0 < L aa} = setsum L {aa. f aa = a \<and> 0 < K aa + L aa}"
29.1323 + apply(rule setsum_mono_zero_cong_left) using C by auto
29.1324 + ultimately show ?thesis
29.1325 + unfolding mmap_def unfolding comm_monoid_add_class.setsum.F_fun_f by auto
29.1326 +qed
29.1327 +
29.1328 +lemma multiset_map_Plus[simp]:
29.1329 +"multiset_map f (M1 + M2) = multiset_map f M1 + multiset_map f M2"
29.1330 +unfolding multiset_map_def
29.1331 +apply(subst multiset.count_inject[symmetric])
29.1332 +unfolding plus_multiset.rep_eq comp_def by auto
29.1333 +
29.1334 +lemma multiset_map_singl[simp]: "multiset_map f {#a#} = {#f a#}"
29.1335 +proof-
29.1336 + have 0: "\<And> b. card {aa. a = aa \<and> (a = aa \<longrightarrow> f aa = b)} =
29.1337 + (if b = f a then 1 else 0)" by auto
29.1338 + thus ?thesis
29.1339 + unfolding multiset_map_def comp_def mmap_def[abs_def] map_fun_def
29.1340 + by (simp, simp add: single_def)
29.1341 +qed
29.1342 +
29.1343 +lemma multiset_rel_Plus:
29.1344 +assumes ab: "R a b" and MN: "multiset_rel R M N"
29.1345 +shows "multiset_rel R (M + {#a#}) (N + {#b#})"
29.1346 +proof-
29.1347 + {fix y assume "R a b" and "set_of y \<subseteq> {(x, y). R x y}"
29.1348 + hence "\<exists>ya. multiset_map fst y + {#a#} = multiset_map fst ya \<and>
29.1349 + multiset_map snd y + {#b#} = multiset_map snd ya \<and>
29.1350 + set_of ya \<subseteq> {(x, y). R x y}"
29.1351 + apply(intro exI[of _ "y + {#(a,b)#}"]) by auto
29.1352 + }
29.1353 + thus ?thesis
29.1354 + using assms
29.1355 + unfolding multiset_rel_def Gr_def relcomp_unfold by force
29.1356 +qed
29.1357 +
29.1358 +lemma multiset_rel'_imp_multiset_rel:
29.1359 +"multiset_rel' R M N \<Longrightarrow> multiset_rel R M N"
29.1360 +apply(induct rule: multiset_rel'.induct)
29.1361 +using multiset_rel_Zero multiset_rel_Plus by auto
29.1362 +
29.1363 +lemma mcard_multiset_map[simp]: "mcard (multiset_map f M) = mcard M"
29.1364 +proof-
29.1365 + def A \<equiv> "\<lambda> b. {a. f a = b \<and> a \<in># M}"
29.1366 + let ?B = "{b. 0 < setsum (count M) (A b)}"
29.1367 + have "{b. \<exists>a. f a = b \<and> a \<in># M} \<subseteq> f ` {a. a \<in># M}" by auto
29.1368 + moreover have "finite (f ` {a. a \<in># M})" apply(rule finite_imageI)
29.1369 + using finite_Collect_mem .
29.1370 + ultimately have fin: "finite {b. \<exists>a. f a = b \<and> a \<in># M}" by(rule finite_subset)
29.1371 + have i: "inj_on A ?B" unfolding inj_on_def A_def apply clarsimp
29.1372 + by (metis (lifting, mono_tags) mem_Collect_eq rel_simps(54)
29.1373 + setsum_gt_0_iff setsum_infinite)
29.1374 + have 0: "\<And> b. 0 < setsum (count M) (A b) \<longleftrightarrow> (\<exists> a \<in> A b. count M a > 0)"
29.1375 + apply safe
29.1376 + apply (metis less_not_refl setsum_gt_0_iff setsum_infinite)
29.1377 + by (metis A_def finite_Collect_conjI finite_Collect_mem setsum_gt_0_iff)
29.1378 + hence AB: "A ` ?B = {A b | b. \<exists> a \<in> A b. count M a > 0}" by auto
29.1379 +
29.1380 + have "setsum (\<lambda> x. setsum (count M) (A x)) ?B = setsum (setsum (count M) o A) ?B"
29.1381 + unfolding comp_def ..
29.1382 + also have "... = (\<Sum>x\<in> A ` ?B. setsum (count M) x)"
29.1383 + unfolding comm_monoid_add_class.setsum_reindex[OF i, symmetric] ..
29.1384 + also have "... = setsum (count M) (\<Union>x\<in>A ` {b. 0 < setsum (count M) (A b)}. x)"
29.1385 + (is "_ = setsum (count M) ?J")
29.1386 + apply(rule comm_monoid_add_class.setsum_UN_disjoint[symmetric])
29.1387 + using 0 fin unfolding A_def by (auto intro!: finite_imageI)
29.1388 + also have "?J = {a. a \<in># M}" unfolding AB unfolding A_def by auto
29.1389 + finally have "setsum (\<lambda> x. setsum (count M) (A x)) ?B =
29.1390 + setsum (count M) {a. a \<in># M}" .
29.1391 + thus ?thesis unfolding A_def mcard_def multiset_map_def by (simp add: mmap_def)
29.1392 +qed
29.1393 +
29.1394 +lemma multiset_rel_mcard:
29.1395 +assumes "multiset_rel R M N"
29.1396 +shows "mcard M = mcard N"
29.1397 +using assms unfolding multiset_rel_def relcomp_unfold Gr_def by auto
29.1398 +
29.1399 +lemma multiset_induct2[case_names empty addL addR]:
29.1400 +assumes empty: "P {#} {#}"
29.1401 +and addL: "\<And>M N a. P M N \<Longrightarrow> P (M + {#a#}) N"
29.1402 +and addR: "\<And>M N a. P M N \<Longrightarrow> P M (N + {#a#})"
29.1403 +shows "P M N"
29.1404 +apply(induct N rule: multiset_induct)
29.1405 + apply(induct M rule: multiset_induct, rule empty, erule addL)
29.1406 + apply(induct M rule: multiset_induct, erule addR, erule addR)
29.1407 +done
29.1408 +
29.1409 +lemma multiset_induct2_mcard[consumes 1, case_names empty add]:
29.1410 +assumes c: "mcard M = mcard N"
29.1411 +and empty: "P {#} {#}"
29.1412 +and add: "\<And>M N a b. P M N \<Longrightarrow> P (M + {#a#}) (N + {#b#})"
29.1413 +shows "P M N"
29.1414 +using c proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
29.1415 + case (less M) show ?case
29.1416 + proof(cases "M = {#}")
29.1417 + case True hence "N = {#}" using less.prems by auto
29.1418 + thus ?thesis using True empty by auto
29.1419 + next
29.1420 + case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
29.1421 + have "N \<noteq> {#}" using False less.prems by auto
29.1422 + then obtain N1 b where N: "N = N1 + {#b#}" by (metis multi_nonempty_split)
29.1423 + have "mcard M1 = mcard N1" using less.prems unfolding M N by auto
29.1424 + thus ?thesis using M N less.hyps add by auto
29.1425 + qed
29.1426 +qed
29.1427 +
29.1428 +lemma msed_map_invL:
29.1429 +assumes "multiset_map f (M + {#a#}) = N"
29.1430 +shows "\<exists> N1. N = N1 + {#f a#} \<and> multiset_map f M = N1"
29.1431 +proof-
29.1432 + have "f a \<in># N"
29.1433 + using assms multiset.set_natural'[of f "M + {#a#}"] by auto
29.1434 + then obtain N1 where N: "N = N1 + {#f a#}" using multi_member_split by metis
29.1435 + have "multiset_map f M = N1" using assms unfolding N by simp
29.1436 + thus ?thesis using N by blast
29.1437 +qed
29.1438 +
29.1439 +lemma msed_map_invR:
29.1440 +assumes "multiset_map f M = N + {#b#}"
29.1441 +shows "\<exists> M1 a. M = M1 + {#a#} \<and> f a = b \<and> multiset_map f M1 = N"
29.1442 +proof-
29.1443 + obtain a where a: "a \<in># M" and fa: "f a = b"
29.1444 + using multiset.set_natural'[of f M] unfolding assms
29.1445 + by (metis image_iff mem_set_of_iff union_single_eq_member)
29.1446 + then obtain M1 where M: "M = M1 + {#a#}" using multi_member_split by metis
29.1447 + have "multiset_map f M1 = N" using assms unfolding M fa[symmetric] by simp
29.1448 + thus ?thesis using M fa by blast
29.1449 +qed
29.1450 +
29.1451 +lemma msed_rel_invL:
29.1452 +assumes "multiset_rel R (M + {#a#}) N"
29.1453 +shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> multiset_rel R M N1"
29.1454 +proof-
29.1455 + obtain K where KM: "multiset_map fst K = M + {#a#}"
29.1456 + and KN: "multiset_map snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
29.1457 + using assms
29.1458 + unfolding multiset_rel_def Gr_def relcomp_unfold by auto
29.1459 + obtain K1 ab where K: "K = K1 + {#ab#}" and a: "fst ab = a"
29.1460 + and K1M: "multiset_map fst K1 = M" using msed_map_invR[OF KM] by auto
29.1461 + obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "multiset_map snd K1 = N1"
29.1462 + using msed_map_invL[OF KN[unfolded K]] by auto
29.1463 + have Rab: "R a (snd ab)" using sK a unfolding K by auto
29.1464 + have "multiset_rel R M N1" using sK K1M K1N1
29.1465 + unfolding K multiset_rel_def Gr_def relcomp_unfold by auto
29.1466 + thus ?thesis using N Rab by auto
29.1467 +qed
29.1468 +
29.1469 +lemma msed_rel_invR:
29.1470 +assumes "multiset_rel R M (N + {#b#})"
29.1471 +shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> multiset_rel R M1 N"
29.1472 +proof-
29.1473 + obtain K where KN: "multiset_map snd K = N + {#b#}"
29.1474 + and KM: "multiset_map fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
29.1475 + using assms
29.1476 + unfolding multiset_rel_def Gr_def relcomp_unfold by auto
29.1477 + obtain K1 ab where K: "K = K1 + {#ab#}" and b: "snd ab = b"
29.1478 + and K1N: "multiset_map snd K1 = N" using msed_map_invR[OF KN] by auto
29.1479 + obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "multiset_map fst K1 = M1"
29.1480 + using msed_map_invL[OF KM[unfolded K]] by auto
29.1481 + have Rab: "R (fst ab) b" using sK b unfolding K by auto
29.1482 + have "multiset_rel R M1 N" using sK K1N K1M1
29.1483 + unfolding K multiset_rel_def Gr_def relcomp_unfold by auto
29.1484 + thus ?thesis using M Rab by auto
29.1485 +qed
29.1486 +
29.1487 +lemma multiset_rel_imp_multiset_rel':
29.1488 +assumes "multiset_rel R M N"
29.1489 +shows "multiset_rel' R M N"
29.1490 +using assms proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
29.1491 + case (less M)
29.1492 + have c: "mcard M = mcard N" using multiset_rel_mcard[OF less.prems] .
29.1493 + show ?case
29.1494 + proof(cases "M = {#}")
29.1495 + case True hence "N = {#}" using c by simp
29.1496 + thus ?thesis using True multiset_rel'.Zero by auto
29.1497 + next
29.1498 + case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
29.1499 + obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "multiset_rel R M1 N1"
29.1500 + using msed_rel_invL[OF less.prems[unfolded M]] by auto
29.1501 + have "multiset_rel' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
29.1502 + thus ?thesis using multiset_rel'.Plus[of R a b, OF R] unfolding M N by simp
29.1503 + qed
29.1504 +qed
29.1505 +
29.1506 +lemma multiset_rel_multiset_rel':
29.1507 +"multiset_rel R M N = multiset_rel' R M N"
29.1508 +using multiset_rel_imp_multiset_rel' multiset_rel'_imp_multiset_rel by auto
29.1509 +
29.1510 +(* The main end product for multiset_rel: inductive characterization *)
29.1511 +theorems multiset_rel_induct[case_names empty add, induct pred: multiset_rel] =
29.1512 + multiset_rel'.induct[unfolded multiset_rel_multiset_rel'[symmetric]]
29.1513 +
29.1514 +end
30.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
30.2 +++ b/src/HOL/BNF/README.html Fri Sep 21 16:45:06 2012 +0200
30.3 @@ -0,0 +1,54 @@
30.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
30.5 +
30.6 +<html>
30.7 +
30.8 +<head>
30.9 + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
30.10 + <title>BNF Package</title>
30.11 +</head>
30.12 +
30.13 +<body>
30.14 +
30.15 +<h3><i>BNF</i>: A (co)datatype package based on bounded natural functors
30.16 +(BNFs)</h3>
30.17 +
30.18 +<p>
30.19 +The <i>BNF</i> package provides a fully modular framework for constructing
30.20 +inductive and coinductive datatypes in HOL, with support for mixed mutual and
30.21 +nested (co)recursion. Mixed (co)recursion enables type definitions involving
30.22 +both datatypes and codatatypes, such as the type of finitely branching trees of
30.23 +possibly infinite depth. The framework draws heavily from category theory.
30.24 +
30.25 +<p>
30.26 +The package is described in the following paper:
30.27 +
30.28 +<ul>
30.29 + <li><a href="http://www21.in.tum.de/~traytel/papers/codatatypes/index.html">Foundational, Compositional (Co)datatypes for Higher-Order Logic—Category Theory Applied to Theorem Proving</a>, <br>
30.30 + Dmitriy Traytel, Andrei Popescu, and Jasmin Christian Blanchette.<br>
30.31 + <i>Logic in Computer Science (LICS 2012)</i>, 2012.
30.32 +</ul>
30.33 +
30.34 +<p>
30.35 +The main entry point for applications is <tt>BNF.thy</tt>. The <tt>Examples</tt>
30.36 +directory contains various examples of (co)datatypes, including the examples
30.37 +from the paper.
30.38 +
30.39 +<p>
30.40 +The key notion underlying the package is that of a <i>bounded natural functor</i>
30.41 +(<i>BNF</i>)—an enriched type constructor satisfying specific properties
30.42 +preserved by interesting categorical operations (composition, least fixed point,
30.43 +and greatest fixed point). The <tt>Basic_BNFs.thy</tt> and <tt>More_BNFs.thy</tt>
30.44 +files register various basic types, notably for sums, products, function spaces,
30.45 +finite sets, multisets, and countable sets. Custom BNFs can be registered as well.
30.46 +
30.47 +<p>
30.48 +<b>Warning:</b> The package is under development. Please contact any nonempty
30.49 +subset of
30.50 +<a href="mailto:traytel@in.tum.de">the</a>
30.51 +<a href="mailto:popescua@in.tum.de">above</a>
30.52 +<a href="mailto:blanchette@in.tum.de">authors</a>
30.53 +if you have questions or comments.
30.54 +
30.55 +</body>
30.56 +
30.57 +</html>
31.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
31.2 +++ b/src/HOL/BNF/Tools/bnf_comp.ML Fri Sep 21 16:45:06 2012 +0200
31.3 @@ -0,0 +1,726 @@
31.4 +(* Title: HOL/BNF/Tools/bnf_comp.ML
31.5 + Author: Dmitriy Traytel, TU Muenchen
31.6 + Author: Jasmin Blanchette, TU Muenchen
31.7 + Copyright 2012
31.8 +
31.9 +Composition of bounded natural functors.
31.10 +*)
31.11 +
31.12 +signature BNF_COMP =
31.13 +sig
31.14 + type unfold_set
31.15 + val empty_unfolds: unfold_set
31.16 + val map_unfolds_of: unfold_set -> thm list
31.17 + val rel_unfolds_of: unfold_set -> thm list
31.18 + val set_unfoldss_of: unfold_set -> thm list list
31.19 + val srel_unfolds_of: unfold_set -> thm list
31.20 +
31.21 + val bnf_of_typ: BNF_Def.const_policy -> (binding -> binding) ->
31.22 + ((string * sort) list list -> (string * sort) list) -> typ -> unfold_set * Proof.context ->
31.23 + (BNF_Def.BNF * (typ list * typ list)) * (unfold_set * Proof.context)
31.24 + val default_comp_sort: (string * sort) list list -> (string * sort) list
31.25 + val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
31.26 + (''a list list -> ''a list) -> BNF_Def.BNF list -> unfold_set -> Proof.context ->
31.27 + (int list list * ''a list) * (BNF_Def.BNF list * (unfold_set * Proof.context))
31.28 + val seal_bnf: unfold_set -> binding -> typ list -> BNF_Def.BNF -> Proof.context ->
31.29 + (BNF_Def.BNF * typ list) * local_theory
31.30 +end;
31.31 +
31.32 +structure BNF_Comp : BNF_COMP =
31.33 +struct
31.34 +
31.35 +open BNF_Def
31.36 +open BNF_Util
31.37 +open BNF_Tactics
31.38 +open BNF_Comp_Tactics
31.39 +
31.40 +type unfold_set = {
31.41 + map_unfolds: thm list,
31.42 + set_unfoldss: thm list list,
31.43 + rel_unfolds: thm list,
31.44 + srel_unfolds: thm list
31.45 +};
31.46 +
31.47 +val empty_unfolds = {map_unfolds = [], set_unfoldss = [], rel_unfolds = [], srel_unfolds = []};
31.48 +
31.49 +fun add_to_thms thms new = thms |> not (Thm.is_reflexive new) ? insert Thm.eq_thm new;
31.50 +fun adds_to_thms thms news = insert (eq_set Thm.eq_thm) (no_reflexive news) thms;
31.51 +
31.52 +fun add_to_unfolds map sets rel srel
31.53 + {map_unfolds, set_unfoldss, rel_unfolds, srel_unfolds} =
31.54 + {map_unfolds = add_to_thms map_unfolds map,
31.55 + set_unfoldss = adds_to_thms set_unfoldss sets,
31.56 + rel_unfolds = add_to_thms rel_unfolds rel,
31.57 + srel_unfolds = add_to_thms srel_unfolds srel};
31.58 +
31.59 +fun add_bnf_to_unfolds bnf =
31.60 + add_to_unfolds (map_def_of_bnf bnf) (set_defs_of_bnf bnf) (rel_def_of_bnf bnf)
31.61 + (srel_def_of_bnf bnf);
31.62 +
31.63 +val map_unfolds_of = #map_unfolds;
31.64 +val set_unfoldss_of = #set_unfoldss;
31.65 +val rel_unfolds_of = #rel_unfolds;
31.66 +val srel_unfolds_of = #srel_unfolds;
31.67 +
31.68 +val bdTN = "bdT";
31.69 +
31.70 +fun mk_killN n = "_kill" ^ string_of_int n;
31.71 +fun mk_liftN n = "_lift" ^ string_of_int n;
31.72 +fun mk_permuteN src dest =
31.73 + "_permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest);
31.74 +
31.75 +(*copied from Envir.expand_term_free*)
31.76 +fun expand_term_const defs =
31.77 + let
31.78 + val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
31.79 + val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
31.80 + in Envir.expand_term get end;
31.81 +
31.82 +fun clean_compose_bnf const_policy qualify b outer inners (unfold_set, lthy) =
31.83 + let
31.84 + val olive = live_of_bnf outer;
31.85 + val onwits = nwits_of_bnf outer;
31.86 + val odead = dead_of_bnf outer;
31.87 + val inner = hd inners;
31.88 + val ilive = live_of_bnf inner;
31.89 + val ideads = map dead_of_bnf inners;
31.90 + val inwitss = map nwits_of_bnf inners;
31.91 +
31.92 + (* TODO: check olive = length inners > 0,
31.93 + forall inner from inners. ilive = live,
31.94 + forall inner from inners. idead = dead *)
31.95 +
31.96 + val (oDs, lthy1) = apfst (map TFree)
31.97 + (Variable.invent_types (replicate odead HOLogic.typeS) lthy);
31.98 + val (Dss, lthy2) = apfst (map (map TFree))
31.99 + (fold_map Variable.invent_types (map (fn n => replicate n HOLogic.typeS) ideads) lthy1);
31.100 + val (Ass, lthy3) = apfst (replicate ilive o map TFree)
31.101 + (Variable.invent_types (replicate ilive HOLogic.typeS) lthy2);
31.102 + val As = if ilive > 0 then hd Ass else [];
31.103 + val Ass_repl = replicate olive As;
31.104 + val (Bs, _(*lthy4*)) = apfst (map TFree)
31.105 + (Variable.invent_types (replicate ilive HOLogic.typeS) lthy3);
31.106 + val Bss_repl = replicate olive Bs;
31.107 +
31.108 + val ((((fs', Qs'), Asets), xs), _(*names_lthy*)) = lthy
31.109 + |> apfst snd o mk_Frees' "f" (map2 (curry (op -->)) As Bs)
31.110 + ||>> apfst snd o mk_Frees' "Q" (map2 mk_pred2T As Bs)
31.111 + ||>> mk_Frees "A" (map HOLogic.mk_setT As)
31.112 + ||>> mk_Frees "x" As;
31.113 +
31.114 + val CAs = map3 mk_T_of_bnf Dss Ass_repl inners;
31.115 + val CCA = mk_T_of_bnf oDs CAs outer;
31.116 + val CBs = map3 mk_T_of_bnf Dss Bss_repl inners;
31.117 + val outer_sets = mk_sets_of_bnf (replicate olive oDs) (replicate olive CAs) outer;
31.118 + val inner_setss = map3 mk_sets_of_bnf (map (replicate ilive) Dss) (replicate olive Ass) inners;
31.119 + val inner_bds = map3 mk_bd_of_bnf Dss Ass_repl inners;
31.120 + val outer_bd = mk_bd_of_bnf oDs CAs outer;
31.121 +
31.122 + (*%f1 ... fn. outer.map (inner_1.map f1 ... fn) ... (inner_m.map f1 ... fn)*)
31.123 + val mapx = fold_rev Term.abs fs'
31.124 + (Term.list_comb (mk_map_of_bnf oDs CAs CBs outer,
31.125 + map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
31.126 + mk_map_of_bnf Ds As Bs) Dss inners));
31.127 + (*%Q1 ... Qn. outer.rel (inner_1.rel Q1 ... Qn) ... (inner_m.rel Q1 ... Qn)*)
31.128 + val rel = fold_rev Term.abs Qs'
31.129 + (Term.list_comb (mk_rel_of_bnf oDs CAs CBs outer,
31.130 + map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
31.131 + mk_rel_of_bnf Ds As Bs) Dss inners));
31.132 +
31.133 + (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
31.134 + (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
31.135 + fun mk_set i =
31.136 + let
31.137 + val (setTs, T) = `(replicate olive o HOLogic.mk_setT) (nth As i);
31.138 + val outer_set = mk_collect
31.139 + (mk_sets_of_bnf (replicate olive oDs) (replicate olive setTs) outer)
31.140 + (mk_T_of_bnf oDs setTs outer --> HOLogic.mk_setT T);
31.141 + val inner_sets = map (fn sets => nth sets i) inner_setss;
31.142 + val outer_map = mk_map_of_bnf oDs CAs setTs outer;
31.143 + val map_inner_sets = Term.list_comb (outer_map, inner_sets);
31.144 + val collect_image = mk_collect
31.145 + (map2 (fn f => fn set => HOLogic.mk_comp (mk_image f, set)) inner_sets outer_sets)
31.146 + (CCA --> HOLogic.mk_setT T);
31.147 + in
31.148 + (Library.foldl1 HOLogic.mk_comp [mk_Union T, outer_set, map_inner_sets],
31.149 + HOLogic.mk_comp (mk_Union T, collect_image))
31.150 + end;
31.151 +
31.152 + val (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
31.153 +
31.154 + (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
31.155 + val bd = Term.absdummy CCA (mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd);
31.156 +
31.157 + fun map_id_tac {context = ctxt, ...} =
31.158 + let
31.159 + (*order the theorems by reverse size to prevent bad interaction with nonconfluent rewrite
31.160 + rules*)
31.161 + val thms = (map map_id_of_bnf inners
31.162 + |> map (`(Term.size_of_term o Thm.prop_of))
31.163 + |> sort (rev_order o int_ord o pairself fst)
31.164 + |> map snd) @ [map_id_of_bnf outer];
31.165 + in
31.166 + (EVERY' (map (fn thm => subst_tac ctxt [thm]) thms) THEN' rtac refl) 1
31.167 + end;
31.168 +
31.169 + fun map_comp_tac _ =
31.170 + mk_comp_map_comp_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
31.171 + (map map_comp_of_bnf inners);
31.172 +
31.173 + fun mk_single_set_natural_tac i _ =
31.174 + mk_comp_set_natural_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
31.175 + (collect_set_natural_of_bnf outer)
31.176 + (map ((fn thms => nth thms i) o set_natural_of_bnf) inners);
31.177 +
31.178 + val set_natural_tacs = map mk_single_set_natural_tac (0 upto ilive - 1);
31.179 +
31.180 + fun bd_card_order_tac _ =
31.181 + mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
31.182 +
31.183 + fun bd_cinfinite_tac _ =
31.184 + mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
31.185 +
31.186 + val set_alt_thms =
31.187 + if ! quick_and_dirty then
31.188 + []
31.189 + else
31.190 + map (fn goal =>
31.191 + Skip_Proof.prove lthy [] [] goal
31.192 + (fn {context, ...} => (mk_comp_set_alt_tac context (collect_set_natural_of_bnf outer)))
31.193 + |> Thm.close_derivation)
31.194 + (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) sets sets_alt);
31.195 +
31.196 + fun map_cong_tac _ =
31.197 + mk_comp_map_cong_tac set_alt_thms (map_cong_of_bnf outer) (map map_cong_of_bnf inners);
31.198 +
31.199 + val set_bd_tacs =
31.200 + if ! quick_and_dirty then
31.201 + replicate (length set_alt_thms) (K all_tac)
31.202 + else
31.203 + let
31.204 + val outer_set_bds = set_bd_of_bnf outer;
31.205 + val inner_set_bdss = map set_bd_of_bnf inners;
31.206 + val inner_bd_Card_orders = map bd_Card_order_of_bnf inners;
31.207 + fun single_set_bd_thm i j =
31.208 + @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
31.209 + nth outer_set_bds j]
31.210 + val single_set_bd_thmss =
31.211 + map ((fn f => map f (0 upto olive - 1)) o single_set_bd_thm) (0 upto ilive - 1);
31.212 + in
31.213 + map2 (fn set_alt => fn single_set_bds => fn {context, ...} =>
31.214 + mk_comp_set_bd_tac context set_alt single_set_bds)
31.215 + set_alt_thms single_set_bd_thmss
31.216 + end;
31.217 +
31.218 + val in_alt_thm =
31.219 + let
31.220 + val inx = mk_in Asets sets CCA;
31.221 + val in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
31.222 + val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
31.223 + in
31.224 + Skip_Proof.prove lthy [] [] goal
31.225 + (fn {context, ...} => mk_comp_in_alt_tac context set_alt_thms)
31.226 + |> Thm.close_derivation
31.227 + end;
31.228 +
31.229 + fun in_bd_tac _ =
31.230 + mk_comp_in_bd_tac in_alt_thm (map in_bd_of_bnf inners) (in_bd_of_bnf outer)
31.231 + (map bd_Cinfinite_of_bnf inners) (bd_Card_order_of_bnf outer);
31.232 +
31.233 + fun map_wpull_tac _ =
31.234 + mk_map_wpull_tac in_alt_thm (map map_wpull_of_bnf inners) (map_wpull_of_bnf outer);
31.235 +
31.236 + fun srel_O_Gr_tac _ =
31.237 + let
31.238 + val basic_thms = @{thms mem_Collect_eq fst_conv snd_conv}; (*TODO: tune*)
31.239 + val outer_srel_Gr = srel_Gr_of_bnf outer RS sym;
31.240 + val outer_srel_cong = srel_cong_of_bnf outer;
31.241 + val thm =
31.242 + (trans OF [in_alt_thm RS @{thm subst_rel_def},
31.243 + trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
31.244 + [trans OF [outer_srel_Gr RS @{thm arg_cong[of _ _ converse]},
31.245 + srel_converse_of_bnf outer RS sym], outer_srel_Gr],
31.246 + trans OF [srel_O_of_bnf outer RS sym, outer_srel_cong OF
31.247 + (map (fn bnf => srel_O_Gr_of_bnf bnf RS sym) inners)]]] RS sym)
31.248 + |> unfold_thms lthy (basic_thms @ srel_def_of_bnf outer :: map srel_def_of_bnf inners);
31.249 + in
31.250 + unfold_thms_tac lthy basic_thms THEN rtac thm 1
31.251 + end;
31.252 +
31.253 + val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
31.254 + bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
31.255 +
31.256 + val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
31.257 +
31.258 + val inner_witss = map (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)))
31.259 + (map3 (fn Ds => fn n => mk_wits_of_bnf (replicate n Ds) (replicate n As))
31.260 + Dss inwitss inners);
31.261 +
31.262 + val inner_witsss = map (map (nth inner_witss) o fst) outer_wits;
31.263 +
31.264 + val wits = (inner_witsss, (map (single o snd) outer_wits))
31.265 + |-> map2 (fold (map_product (fn iwit => fn owit => owit $ iwit)))
31.266 + |> flat
31.267 + |> map (`(fn t => Term.add_frees t []))
31.268 + |> minimize_wits
31.269 + |> map (fn (frees, t) => fold absfree frees t);
31.270 +
31.271 + fun wit_tac {context = ctxt, ...} =
31.272 + mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_natural_of_bnf outer)
31.273 + (maps wit_thms_of_bnf inners);
31.274 +
31.275 + val (bnf', lthy') =
31.276 + bnf_def const_policy (K Derive_Few_Facts) qualify tacs wit_tac (SOME (oDs @ flat Dss))
31.277 + (((((b, mapx), sets), bd), wits), SOME rel) lthy;
31.278 + in
31.279 + (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
31.280 + end;
31.281 +
31.282 +(* Killing live variables *)
31.283 +
31.284 +fun kill_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
31.285 + let
31.286 + val b = Binding.suffix_name (mk_killN n) (name_of_bnf bnf);
31.287 + val live = live_of_bnf bnf;
31.288 + val dead = dead_of_bnf bnf;
31.289 + val nwits = nwits_of_bnf bnf;
31.290 +
31.291 + (* TODO: check 0 < n <= live *)
31.292 +
31.293 + val (Ds, lthy1) = apfst (map TFree)
31.294 + (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
31.295 + val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
31.296 + (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
31.297 + val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
31.298 + (Variable.invent_types (replicate (live - n) HOLogic.typeS) lthy2);
31.299 +
31.300 + val ((Asets, lives), _(*names_lthy*)) = lthy
31.301 + |> mk_Frees "A" (map HOLogic.mk_setT (drop n As))
31.302 + ||>> mk_Frees "x" (drop n As);
31.303 + val xs = map (fn T => HOLogic.choice_const T $ absdummy T @{term True}) killedAs @ lives;
31.304 +
31.305 + val T = mk_T_of_bnf Ds As bnf;
31.306 +
31.307 + (*bnf.map id ... id*)
31.308 + val mapx = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
31.309 + (*bnf.rel (op =) ... (op =)*)
31.310 + val rel = Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, map HOLogic.eq_const killedAs);
31.311 +
31.312 + val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
31.313 + val sets = drop n bnf_sets;
31.314 +
31.315 + (*(|UNIV :: A1 set| +c ... +c |UNIV :: An set|) *c bnf.bd*)
31.316 + val bnf_bd = mk_bd_of_bnf Ds As bnf;
31.317 + val bd = mk_cprod
31.318 + (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
31.319 +
31.320 + fun map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
31.321 + fun map_comp_tac {context, ...} =
31.322 + unfold_thms_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
31.323 + rtac refl 1;
31.324 + fun map_cong_tac {context, ...} =
31.325 + mk_kill_map_cong_tac context n (live - n) (map_cong_of_bnf bnf);
31.326 + val set_natural_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_natural_of_bnf bnf));
31.327 + fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
31.328 + fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
31.329 + val set_bd_tacs =
31.330 + map (fn thm => fn _ => mk_kill_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
31.331 + (drop n (set_bd_of_bnf bnf));
31.332 +
31.333 + val in_alt_thm =
31.334 + let
31.335 + val inx = mk_in Asets sets T;
31.336 + val in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
31.337 + val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
31.338 + in
31.339 + Skip_Proof.prove lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
31.340 + end;
31.341 +
31.342 + fun in_bd_tac _ =
31.343 + mk_kill_in_bd_tac n (live > n) in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf)
31.344 + (bd_Cinfinite_of_bnf bnf) (bd_Cnotzero_of_bnf bnf);
31.345 + fun map_wpull_tac _ = mk_map_wpull_tac in_alt_thm [] (map_wpull_of_bnf bnf);
31.346 +
31.347 + fun srel_O_Gr_tac _ =
31.348 + let
31.349 + val srel_Gr = srel_Gr_of_bnf bnf RS sym
31.350 + val thm =
31.351 + (trans OF [in_alt_thm RS @{thm subst_rel_def},
31.352 + trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
31.353 + [trans OF [srel_Gr RS @{thm arg_cong[of _ _ converse]},
31.354 + srel_converse_of_bnf bnf RS sym], srel_Gr],
31.355 + trans OF [srel_O_of_bnf bnf RS sym, srel_cong_of_bnf bnf OF
31.356 + (replicate n @{thm trans[OF Gr_UNIV_id[OF refl] Id_alt[symmetric]]} @
31.357 + replicate (live - n) @{thm Gr_fst_snd})]]] RS sym)
31.358 + |> unfold_thms lthy (srel_def_of_bnf bnf :: @{thms Id_def' mem_Collect_eq split_conv});
31.359 + in
31.360 + rtac thm 1
31.361 + end;
31.362 +
31.363 + val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
31.364 + bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
31.365 +
31.366 + val bnf_wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
31.367 +
31.368 + val wits = map (fn t => fold absfree (Term.add_frees t []) t)
31.369 + (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) bnf_wits);
31.370 +
31.371 + fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
31.372 +
31.373 + val (bnf', lthy') =
31.374 + bnf_def Smart_Inline (K Derive_Few_Facts) qualify tacs wit_tac (SOME (killedAs @ Ds))
31.375 + (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
31.376 + in
31.377 + (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
31.378 + end;
31.379 +
31.380 +(* Adding dummy live variables *)
31.381 +
31.382 +fun lift_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
31.383 + let
31.384 + val b = Binding.suffix_name (mk_liftN n) (name_of_bnf bnf);
31.385 + val live = live_of_bnf bnf;
31.386 + val dead = dead_of_bnf bnf;
31.387 + val nwits = nwits_of_bnf bnf;
31.388 +
31.389 + (* TODO: check 0 < n *)
31.390 +
31.391 + val (Ds, lthy1) = apfst (map TFree)
31.392 + (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
31.393 + val ((newAs, As), lthy2) = apfst (chop n o map TFree)
31.394 + (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy1);
31.395 + val ((newBs, Bs), _(*lthy3*)) = apfst (chop n o map TFree)
31.396 + (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy2);
31.397 +
31.398 + val (Asets, _(*names_lthy*)) = lthy
31.399 + |> mk_Frees "A" (map HOLogic.mk_setT (newAs @ As));
31.400 +
31.401 + val T = mk_T_of_bnf Ds As bnf;
31.402 +
31.403 + (*%f1 ... fn. bnf.map*)
31.404 + val mapx =
31.405 + fold_rev Term.absdummy (map2 (curry (op -->)) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
31.406 + (*%Q1 ... Qn. bnf.rel*)
31.407 + val rel = fold_rev Term.absdummy (map2 mk_pred2T newAs newBs) (mk_rel_of_bnf Ds As Bs bnf);
31.408 +
31.409 + val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
31.410 + val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
31.411 +
31.412 + val bd = mk_bd_of_bnf Ds As bnf;
31.413 +
31.414 + fun map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
31.415 + fun map_comp_tac {context, ...} =
31.416 + unfold_thms_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
31.417 + rtac refl 1;
31.418 + fun map_cong_tac {context, ...} =
31.419 + rtac (map_cong_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac context 1);
31.420 + val set_natural_tacs =
31.421 + if ! quick_and_dirty then
31.422 + replicate (n + live) (K all_tac)
31.423 + else
31.424 + replicate n (K empty_natural_tac) @
31.425 + map (fn thm => fn _ => rtac thm 1) (set_natural_of_bnf bnf);
31.426 + fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
31.427 + fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
31.428 + val set_bd_tacs =
31.429 + if ! quick_and_dirty then
31.430 + replicate (n + live) (K all_tac)
31.431 + else
31.432 + replicate n (K (mk_lift_set_bd_tac (bd_Card_order_of_bnf bnf))) @
31.433 + (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
31.434 +
31.435 + val in_alt_thm =
31.436 + let
31.437 + val inx = mk_in Asets sets T;
31.438 + val in_alt = mk_in (drop n Asets) bnf_sets T;
31.439 + val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
31.440 + in
31.441 + Skip_Proof.prove lthy [] [] goal (K lift_in_alt_tac) |> Thm.close_derivation
31.442 + end;
31.443 +
31.444 + fun in_bd_tac _ = mk_lift_in_bd_tac n in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf);
31.445 + fun map_wpull_tac _ = mk_map_wpull_tac in_alt_thm [] (map_wpull_of_bnf bnf);
31.446 +
31.447 + fun srel_O_Gr_tac _ =
31.448 + mk_simple_srel_O_Gr_tac lthy (srel_def_of_bnf bnf) (srel_O_Gr_of_bnf bnf) in_alt_thm;
31.449 +
31.450 + val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
31.451 + bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
31.452 +
31.453 + val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
31.454 +
31.455 + fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
31.456 +
31.457 + val (bnf', lthy') =
31.458 + bnf_def Smart_Inline (K Derive_Few_Facts) qualify tacs wit_tac (SOME Ds)
31.459 + (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
31.460 +
31.461 + in
31.462 + (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
31.463 + end;
31.464 +
31.465 +(* Changing the order of live variables *)
31.466 +
31.467 +fun permute_bnf qualify src dest bnf (unfold_set, lthy) =
31.468 + if src = dest then (bnf, (unfold_set, lthy)) else
31.469 + let
31.470 + val b = Binding.suffix_name (mk_permuteN src dest) (name_of_bnf bnf);
31.471 + val live = live_of_bnf bnf;
31.472 + val dead = dead_of_bnf bnf;
31.473 + val nwits = nwits_of_bnf bnf;
31.474 + fun permute xs = mk_permute src dest xs;
31.475 + fun permute_rev xs = mk_permute dest src xs;
31.476 +
31.477 + val (Ds, lthy1) = apfst (map TFree)
31.478 + (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
31.479 + val (As, lthy2) = apfst (map TFree)
31.480 + (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
31.481 + val (Bs, _(*lthy3*)) = apfst (map TFree)
31.482 + (Variable.invent_types (replicate live HOLogic.typeS) lthy2);
31.483 +
31.484 + val (Asets, _(*names_lthy*)) = lthy
31.485 + |> mk_Frees "A" (map HOLogic.mk_setT (permute As));
31.486 +
31.487 + val T = mk_T_of_bnf Ds As bnf;
31.488 +
31.489 + (*%f(1) ... f(n). bnf.map f\<sigma>(1) ... f\<sigma>(n)*)
31.490 + val mapx = fold_rev Term.absdummy (permute (map2 (curry op -->) As Bs))
31.491 + (Term.list_comb (mk_map_of_bnf Ds As Bs bnf, permute_rev (map Bound (live - 1 downto 0))));
31.492 + (*%Q(1) ... Q(n). bnf.rel Q\<sigma>(1) ... Q\<sigma>(n)*)
31.493 + val rel = fold_rev Term.absdummy (permute (map2 mk_pred2T As Bs))
31.494 + (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, permute_rev (map Bound (live - 1 downto 0))));
31.495 +
31.496 + val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
31.497 + val sets = permute bnf_sets;
31.498 +
31.499 + val bd = mk_bd_of_bnf Ds As bnf;
31.500 +
31.501 + fun map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
31.502 + fun map_comp_tac _ = rtac (map_comp_of_bnf bnf) 1;
31.503 + fun map_cong_tac {context, ...} =
31.504 + rtac (map_cong_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac context 1);
31.505 + val set_natural_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_natural_of_bnf bnf));
31.506 + fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
31.507 + fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
31.508 + val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
31.509 +
31.510 + val in_alt_thm =
31.511 + let
31.512 + val inx = mk_in Asets sets T;
31.513 + val in_alt = mk_in (permute_rev Asets) bnf_sets T;
31.514 + val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
31.515 + in
31.516 + Skip_Proof.prove lthy [] [] goal (K (mk_permute_in_alt_tac src dest))
31.517 + |> Thm.close_derivation
31.518 + end;
31.519 +
31.520 + fun in_bd_tac _ =
31.521 + mk_permute_in_bd_tac src dest in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf);
31.522 + fun map_wpull_tac _ = mk_map_wpull_tac in_alt_thm [] (map_wpull_of_bnf bnf);
31.523 +
31.524 + fun srel_O_Gr_tac _ =
31.525 + mk_simple_srel_O_Gr_tac lthy (srel_def_of_bnf bnf) (srel_O_Gr_of_bnf bnf) in_alt_thm;
31.526 +
31.527 + val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
31.528 + bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
31.529 +
31.530 + val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
31.531 +
31.532 + fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
31.533 +
31.534 + val (bnf', lthy') =
31.535 + bnf_def Smart_Inline (K Derive_Few_Facts) qualify tacs wit_tac (SOME Ds)
31.536 + (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
31.537 + in
31.538 + (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
31.539 + end;
31.540 +
31.541 +(* Composition pipeline *)
31.542 +
31.543 +fun permute_and_kill qualify n src dest bnf =
31.544 + bnf
31.545 + |> permute_bnf qualify src dest
31.546 + #> uncurry (kill_bnf qualify n);
31.547 +
31.548 +fun lift_and_permute qualify n src dest bnf =
31.549 + bnf
31.550 + |> lift_bnf qualify n
31.551 + #> uncurry (permute_bnf qualify src dest);
31.552 +
31.553 +fun normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy =
31.554 + let
31.555 + val before_kill_src = map (fn As => 0 upto (length As - 1)) Ass;
31.556 + val kill_poss = map (find_indices Ds) Ass;
31.557 + val live_poss = map2 (subtract (op =)) kill_poss before_kill_src;
31.558 + val before_kill_dest = map2 append kill_poss live_poss;
31.559 + val kill_ns = map length kill_poss;
31.560 + val (inners', (unfold_set', lthy')) =
31.561 + fold_map5 (fn i => permute_and_kill (qualify i))
31.562 + (if length bnfs = 1 then [0] else (1 upto length bnfs))
31.563 + kill_ns before_kill_src before_kill_dest bnfs (unfold_set, lthy);
31.564 +
31.565 + val Ass' = map2 (map o nth) Ass live_poss;
31.566 + val As = sort Ass';
31.567 + val after_lift_dest = replicate (length Ass') (0 upto (length As - 1));
31.568 + val old_poss = map (map (fn x => find_index (fn y => x = y) As)) Ass';
31.569 + val new_poss = map2 (subtract (op =)) old_poss after_lift_dest;
31.570 + val after_lift_src = map2 append new_poss old_poss;
31.571 + val lift_ns = map (fn xs => length As - length xs) Ass';
31.572 + in
31.573 + ((kill_poss, As), fold_map5 (fn i => lift_and_permute (qualify i))
31.574 + (if length bnfs = 1 then [0] else (1 upto length bnfs))
31.575 + lift_ns after_lift_src after_lift_dest inners' (unfold_set', lthy'))
31.576 + end;
31.577 +
31.578 +fun default_comp_sort Ass =
31.579 + Library.sort (Term_Ord.typ_ord o pairself TFree) (fold (fold (insert (op =))) Ass []);
31.580 +
31.581 +fun compose_bnf const_policy qualify sort outer inners oDs Dss tfreess (unfold_set, lthy) =
31.582 + let
31.583 + val b = name_of_bnf outer;
31.584 +
31.585 + val Ass = map (map Term.dest_TFree) tfreess;
31.586 + val Ds = fold (fold Term.add_tfreesT) (oDs :: Dss) [];
31.587 +
31.588 + val ((kill_poss, As), (inners', (unfold_set', lthy'))) =
31.589 + normalize_bnfs qualify Ass Ds sort inners unfold_set lthy;
31.590 +
31.591 + val Ds = oDs @ flat (map3 (append oo map o nth) tfreess kill_poss Dss);
31.592 + val As = map TFree As;
31.593 + in
31.594 + apfst (rpair (Ds, As))
31.595 + (clean_compose_bnf const_policy (qualify 0) b outer inners' (unfold_set', lthy'))
31.596 + end;
31.597 +
31.598 +(* Hide the type of the bound (optimization) and unfold the definitions (nicer to the user) *)
31.599 +
31.600 +fun seal_bnf unfold_set b Ds bnf lthy =
31.601 + let
31.602 + val live = live_of_bnf bnf;
31.603 + val nwits = nwits_of_bnf bnf;
31.604 +
31.605 + val (As, lthy1) = apfst (map TFree)
31.606 + (Variable.invent_types (replicate live HOLogic.typeS) (fold Variable.declare_typ Ds lthy));
31.607 + val (Bs, _) = apfst (map TFree)
31.608 + (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
31.609 +
31.610 + val map_unfolds = map_unfolds_of unfold_set;
31.611 + val set_unfoldss = set_unfoldss_of unfold_set;
31.612 + val rel_unfolds = rel_unfolds_of unfold_set;
31.613 + val srel_unfolds = srel_unfolds_of unfold_set;
31.614 +
31.615 + val expand_maps =
31.616 + fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) map_unfolds);
31.617 + val expand_sets =
31.618 + fold expand_term_const (map (map (Logic.dest_equals o Thm.prop_of)) set_unfoldss);
31.619 + val expand_rels =
31.620 + fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) rel_unfolds);
31.621 + val unfold_maps = fold (unfold_thms lthy o single) map_unfolds;
31.622 + val unfold_sets = fold (unfold_thms lthy) set_unfoldss;
31.623 + val unfold_rels = unfold_thms lthy rel_unfolds;
31.624 + val unfold_srels = unfold_thms lthy srel_unfolds;
31.625 + val unfold_all = unfold_sets o unfold_maps o unfold_rels o unfold_srels;
31.626 + val bnf_map = expand_maps (mk_map_of_bnf Ds As Bs bnf);
31.627 + val bnf_sets = map (expand_maps o expand_sets)
31.628 + (mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf);
31.629 + val bnf_bd = mk_bd_of_bnf Ds As bnf;
31.630 + val bnf_rel = expand_rels (mk_rel_of_bnf Ds As Bs bnf);
31.631 + val T = mk_T_of_bnf Ds As bnf;
31.632 +
31.633 + (*bd should only depend on dead type variables!*)
31.634 + val bd_repT = fst (dest_relT (fastype_of bnf_bd));
31.635 + val bdT_bind = Binding.suffix_name ("_" ^ bdTN) b;
31.636 + val params = fold Term.add_tfreesT Ds [];
31.637 + val deads = map TFree params;
31.638 +
31.639 + val ((bdT_name, (bdT_glob_info, bdT_loc_info)), lthy) =
31.640 + typedef false NONE (bdT_bind, params, NoSyn)
31.641 + (HOLogic.mk_UNIV bd_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
31.642 +
31.643 + val bnf_bd' = mk_dir_image bnf_bd
31.644 + (Const (#Abs_name bdT_glob_info, bd_repT --> Type (bdT_name, deads)))
31.645 +
31.646 + val Abs_bdT_inj = mk_Abs_inj_thm (#Abs_inject bdT_loc_info);
31.647 + val Abs_bdT_bij = mk_Abs_bij_thm lthy Abs_bdT_inj (#Abs_cases bdT_loc_info);
31.648 +
31.649 + val bd_ordIso = @{thm dir_image} OF [Abs_bdT_inj, bd_Card_order_of_bnf bnf];
31.650 + val bd_card_order =
31.651 + @{thm card_order_dir_image} OF [Abs_bdT_bij, bd_card_order_of_bnf bnf];
31.652 + val bd_cinfinite =
31.653 + (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
31.654 +
31.655 + val set_bds =
31.656 + map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
31.657 + val in_bd =
31.658 + @{thm ordLeq_ordIso_trans} OF [in_bd_of_bnf bnf,
31.659 + @{thm cexp_cong2_Cnotzero} OF [bd_ordIso, if live = 0 then
31.660 + @{thm ctwo_Cnotzero} else @{thm ctwo_Cnotzero} RS @{thm csum_Cnotzero2},
31.661 + bd_Card_order_of_bnf bnf]];
31.662 +
31.663 + fun mk_tac thm {context = ctxt, prems = _} =
31.664 + (rtac (unfold_all thm) THEN'
31.665 + SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
31.666 +
31.667 + val tacs = zip_axioms (mk_tac (map_id_of_bnf bnf)) (mk_tac (map_comp_of_bnf bnf))
31.668 + (mk_tac (map_cong_of_bnf bnf)) (map mk_tac (set_natural_of_bnf bnf))
31.669 + (K (rtac bd_card_order 1)) (K (rtac bd_cinfinite 1)) (map mk_tac set_bds) (mk_tac in_bd)
31.670 + (mk_tac (map_wpull_of_bnf bnf))
31.671 + (mk_tac (unfold_thms lthy [srel_def_of_bnf bnf] (srel_O_Gr_of_bnf bnf)));
31.672 +
31.673 + val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
31.674 +
31.675 + fun wit_tac _ = mk_simple_wit_tac (map unfold_all (wit_thms_of_bnf bnf));
31.676 +
31.677 + val policy = user_policy Derive_All_Facts;
31.678 +
31.679 + val (bnf', lthy') = bnf_def Hardly_Inline policy I tacs wit_tac (SOME deads)
31.680 + (((((b, bnf_map), bnf_sets), Term.absdummy T bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
31.681 + in
31.682 + ((bnf', deads), lthy')
31.683 + end;
31.684 +
31.685 +val ID_bnf = the (bnf_of @{context} "Basic_BNFs.ID");
31.686 +val DEADID_bnf = the (bnf_of @{context} "Basic_BNFs.DEADID");
31.687 +
31.688 +fun bnf_of_typ _ _ _ (T as TFree _) accum = ((ID_bnf, ([], [T])), accum)
31.689 + | bnf_of_typ _ _ _ (TVar _) _ = error "Unexpected schematic variable"
31.690 + | bnf_of_typ const_policy qualify' sort (T as Type (C, Ts)) (unfold_set, lthy) =
31.691 + let
31.692 + val tfrees = Term.add_tfreesT T [];
31.693 + val bnf_opt = if null tfrees then NONE else bnf_of lthy C;
31.694 + in
31.695 + (case bnf_opt of
31.696 + NONE => ((DEADID_bnf, ([T], [])), (unfold_set, lthy))
31.697 + | SOME bnf =>
31.698 + if forall (can Term.dest_TFree) Ts andalso length Ts = length tfrees then
31.699 + let
31.700 + val T' = T_of_bnf bnf;
31.701 + val deads = deads_of_bnf bnf;
31.702 + val lives = lives_of_bnf bnf;
31.703 + val tvars' = Term.add_tvarsT T' [];
31.704 + val deads_lives =
31.705 + pairself (map (Term.typ_subst_TVars (map fst tvars' ~~ map TFree tfrees)))
31.706 + (deads, lives);
31.707 + in ((bnf, deads_lives), (unfold_set, lthy)) end
31.708 + else
31.709 + let
31.710 + val name = Long_Name.base_name C;
31.711 + fun qualify i =
31.712 + let val namei = name ^ nonzero_string_of_int i;
31.713 + in qualify' o Binding.qualify true namei end;
31.714 + val odead = dead_of_bnf bnf;
31.715 + val olive = live_of_bnf bnf;
31.716 + val oDs_pos = find_indices [TFree ("dead", [])] (snd (Term.dest_Type
31.717 + (mk_T_of_bnf (replicate odead (TFree ("dead", []))) (replicate olive dummyT) bnf)));
31.718 + val oDs = map (nth Ts) oDs_pos;
31.719 + val Ts' = map (nth Ts) (subtract (op =) oDs_pos (0 upto length Ts - 1));
31.720 + val ((inners, (Dss, Ass)), (unfold_set', lthy')) =
31.721 + apfst (apsnd split_list o split_list)
31.722 + (fold_map2 (fn i => bnf_of_typ Smart_Inline (qualify i) sort)
31.723 + (if length Ts' = 1 then [0] else (1 upto length Ts')) Ts' (unfold_set, lthy));
31.724 + in
31.725 + compose_bnf const_policy qualify sort bnf inners oDs Dss Ass (unfold_set', lthy')
31.726 + end)
31.727 + end;
31.728 +
31.729 +end;
32.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
32.2 +++ b/src/HOL/BNF/Tools/bnf_comp_tactics.ML Fri Sep 21 16:45:06 2012 +0200
32.3 @@ -0,0 +1,416 @@
32.4 +(* Title: HOL/BNF/Tools/bnf_comp_tactics.ML
32.5 + Author: Dmitriy Traytel, TU Muenchen
32.6 + Author: Jasmin Blanchette, TU Muenchen
32.7 + Copyright 2012
32.8 +
32.9 +Tactics for composition of bounded natural functors.
32.10 +*)
32.11 +
32.12 +signature BNF_COMP_TACTICS =
32.13 +sig
32.14 + val mk_comp_bd_card_order_tac: thm list -> thm -> tactic
32.15 + val mk_comp_bd_cinfinite_tac: thm -> thm -> tactic
32.16 + val mk_comp_in_alt_tac: Proof.context -> thm list -> tactic
32.17 + val mk_comp_in_bd_tac: thm -> thm list -> thm -> thm list -> thm -> tactic
32.18 + val mk_comp_map_comp_tac: thm -> thm -> thm list -> tactic
32.19 + val mk_comp_map_cong_tac: thm list -> thm -> thm list -> tactic
32.20 + val mk_comp_set_alt_tac: Proof.context -> thm -> tactic
32.21 + val mk_comp_set_bd_tac: Proof.context -> thm -> thm list -> tactic
32.22 + val mk_comp_set_natural_tac: thm -> thm -> thm -> thm list -> tactic
32.23 + val mk_comp_wit_tac: Proof.context -> thm list -> thm -> thm list -> tactic
32.24 +
32.25 + val mk_kill_bd_card_order_tac: int -> thm -> tactic
32.26 + val mk_kill_bd_cinfinite_tac: thm -> tactic
32.27 + val kill_in_alt_tac: tactic
32.28 + val mk_kill_in_bd_tac: int -> bool -> thm -> thm -> thm -> thm -> thm -> tactic
32.29 + val mk_kill_map_cong_tac: Proof.context -> int -> int -> thm -> tactic
32.30 + val mk_kill_set_bd_tac: thm -> thm -> tactic
32.31 +
32.32 + val empty_natural_tac: tactic
32.33 + val lift_in_alt_tac: tactic
32.34 + val mk_lift_in_bd_tac: int -> thm -> thm -> thm -> tactic
32.35 + val mk_lift_set_bd_tac: thm -> tactic
32.36 +
32.37 + val mk_permute_in_alt_tac: ''a list -> ''a list -> tactic
32.38 + val mk_permute_in_bd_tac: ''a list -> ''a list -> thm -> thm -> thm -> tactic
32.39 +
32.40 + val mk_map_wpull_tac: thm -> thm list -> thm -> tactic
32.41 + val mk_simple_srel_O_Gr_tac: Proof.context -> thm -> thm -> thm -> tactic
32.42 + val mk_simple_wit_tac: thm list -> tactic
32.43 +end;
32.44 +
32.45 +structure BNF_Comp_Tactics : BNF_COMP_TACTICS =
32.46 +struct
32.47 +
32.48 +open BNF_Util
32.49 +open BNF_Tactics
32.50 +
32.51 +val Card_order_csum = @{thm Card_order_csum};
32.52 +val Card_order_ctwo = @{thm Card_order_ctwo};
32.53 +val Cnotzero_UNIV = @{thm Cnotzero_UNIV};
32.54 +val arg_cong_Union = @{thm arg_cong[of _ _ Union]};
32.55 +val card_of_Card_order = @{thm card_of_Card_order};
32.56 +val csum_Cnotzero1 = @{thm csum_Cnotzero1};
32.57 +val csum_Cnotzero2 = @{thm csum_Cnotzero2};
32.58 +val ctwo_Cnotzero = @{thm ctwo_Cnotzero};
32.59 +val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
32.60 +val ordIso_transitive = @{thm ordIso_transitive};
32.61 +val ordLeq_csum2 = @{thm ordLeq_csum2};
32.62 +val trans_image_cong_o_apply = @{thm trans[OF image_cong[OF o_apply refl]]};
32.63 +val trans_o_apply = @{thm trans[OF o_apply]};
32.64 +
32.65 +
32.66 +
32.67 +(* Composition *)
32.68 +
32.69 +fun mk_comp_set_alt_tac ctxt collect_set_natural =
32.70 + unfold_thms_tac ctxt @{thms sym[OF o_assoc]} THEN
32.71 + unfold_thms_tac ctxt [collect_set_natural RS sym] THEN
32.72 + rtac refl 1;
32.73 +
32.74 +fun mk_comp_map_comp_tac Gmap_comp Gmap_cong map_comps =
32.75 + EVERY' ([rtac ext, rtac sym, rtac trans_o_apply,
32.76 + rtac (Gmap_comp RS sym RS o_eq_dest_lhs RS trans), rtac Gmap_cong] @
32.77 + map (fn thm => rtac (thm RS sym RS fun_cong)) map_comps) 1;
32.78 +
32.79 +fun mk_comp_set_natural_tac Gmap_comp Gmap_cong Gset_natural set_naturals =
32.80 + EVERY' ([rtac ext] @
32.81 + replicate 3 (rtac trans_o_apply) @
32.82 + [rtac (arg_cong_Union RS trans),
32.83 + rtac (@{thm arg_cong2[of _ _ _ _ collect, OF refl]} RS trans),
32.84 + rtac (Gmap_comp RS sym RS o_eq_dest_lhs RS trans),
32.85 + rtac Gmap_cong] @
32.86 + map (fn thm => rtac (thm RS fun_cong)) set_naturals @
32.87 + [rtac (Gset_natural RS o_eq_dest_lhs), rtac sym, rtac trans_o_apply,
32.88 + rtac trans_image_cong_o_apply, rtac trans_image_cong_o_apply,
32.89 + rtac (@{thm image_cong} OF [Gset_natural RS o_eq_dest_lhs RS arg_cong_Union, refl] RS trans),
32.90 + rtac @{thm trans[OF pointfreeE[OF Union_natural[symmetric]]]}, rtac arg_cong_Union,
32.91 + rtac @{thm trans[OF o_eq_dest_lhs[OF image_o_collect[symmetric]]]},
32.92 + rtac @{thm fun_cong[OF arg_cong[of _ _ collect]]}] @
32.93 + [REPEAT_DETERM_N (length set_naturals) o EVERY' [rtac @{thm trans[OF image_insert]},
32.94 + rtac @{thm arg_cong2[of _ _ _ _ insert]}, rtac ext, rtac trans_o_apply,
32.95 + rtac trans_image_cong_o_apply, rtac @{thm trans[OF image_image]},
32.96 + rtac @{thm sym[OF trans[OF o_apply]]}, rtac @{thm image_cong[OF refl o_apply]}],
32.97 + rtac @{thm image_empty}]) 1;
32.98 +
32.99 +fun mk_comp_map_cong_tac comp_set_alts map_cong map_congs =
32.100 + let
32.101 + val n = length comp_set_alts;
32.102 + in
32.103 + (if n = 0 then rtac refl 1
32.104 + else rtac map_cong 1 THEN
32.105 + EVERY' (map_index (fn (i, map_cong) =>
32.106 + rtac map_cong THEN' EVERY' (map_index (fn (k, set_alt) =>
32.107 + EVERY' [select_prem_tac n (dtac @{thm meta_spec}) (k + 1), etac @{thm meta_mp},
32.108 + rtac (equalityD2 RS set_mp), rtac (set_alt RS fun_cong RS trans),
32.109 + rtac trans_o_apply, rtac (@{thm collect_def} RS arg_cong_Union),
32.110 + rtac @{thm UnionI}, rtac @{thm UN_I}, REPEAT_DETERM_N i o rtac @{thm insertI2},
32.111 + rtac @{thm insertI1}, rtac (o_apply RS equalityD2 RS set_mp),
32.112 + etac @{thm imageI}, atac])
32.113 + comp_set_alts))
32.114 + map_congs) 1)
32.115 + end;
32.116 +
32.117 +fun mk_comp_bd_card_order_tac Fbd_card_orders Gbd_card_order =
32.118 + let
32.119 + val (card_orders, last_card_order) = split_last Fbd_card_orders;
32.120 + fun gen_before thm = rtac @{thm card_order_csum} THEN' rtac thm;
32.121 + in
32.122 + (rtac @{thm card_order_cprod} THEN'
32.123 + WRAP' gen_before (K (K all_tac)) card_orders (rtac last_card_order) THEN'
32.124 + rtac Gbd_card_order) 1
32.125 + end;
32.126 +
32.127 +fun mk_comp_bd_cinfinite_tac Fbd_cinfinite Gbd_cinfinite =
32.128 + (rtac @{thm cinfinite_cprod} THEN'
32.129 + ((K (TRY ((rtac @{thm cinfinite_csum} THEN' rtac disjI1) 1)) THEN'
32.130 + ((rtac @{thm cinfinite_csum} THEN' rtac disjI1 THEN' rtac Fbd_cinfinite) ORELSE'
32.131 + rtac Fbd_cinfinite)) ORELSE'
32.132 + rtac Fbd_cinfinite) THEN'
32.133 + rtac Gbd_cinfinite) 1;
32.134 +
32.135 +fun mk_comp_set_bd_tac ctxt comp_set_alt Gset_Fset_bds =
32.136 + let
32.137 + val (bds, last_bd) = split_last Gset_Fset_bds;
32.138 + fun gen_before bd =
32.139 + rtac ctrans THEN' rtac @{thm Un_csum} THEN'
32.140 + rtac ctrans THEN' rtac @{thm csum_mono} THEN'
32.141 + rtac bd;
32.142 + fun gen_after _ = rtac @{thm ordIso_imp_ordLeq} THEN' rtac @{thm cprod_csum_distrib1};
32.143 + in
32.144 + unfold_thms_tac ctxt [comp_set_alt] THEN
32.145 + rtac @{thm comp_set_bd_Union_o_collect} 1 THEN
32.146 + unfold_thms_tac ctxt @{thms Union_image_insert Union_image_empty Union_Un_distrib o_apply} THEN
32.147 + (rtac ctrans THEN'
32.148 + WRAP' gen_before gen_after bds (rtac last_bd) THEN'
32.149 + rtac @{thm ordIso_imp_ordLeq} THEN'
32.150 + rtac @{thm cprod_com}) 1
32.151 + end;
32.152 +
32.153 +val comp_in_alt_thms = @{thms o_apply collect_def SUP_def image_insert image_empty Union_insert
32.154 + Union_empty Un_empty_right Union_Un_distrib Un_subset_iff conj_subset_def UN_image_subset
32.155 + conj_assoc};
32.156 +
32.157 +fun mk_comp_in_alt_tac ctxt comp_set_alts =
32.158 + unfold_thms_tac ctxt (comp_set_alts @ comp_in_alt_thms) THEN
32.159 + unfold_thms_tac ctxt @{thms set_eq_subset} THEN
32.160 + rtac conjI 1 THEN
32.161 + REPEAT_DETERM (
32.162 + rtac @{thm subsetI} 1 THEN
32.163 + unfold_thms_tac ctxt @{thms mem_Collect_eq Ball_def} THEN
32.164 + (REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
32.165 + REPEAT_DETERM (CHANGED ((
32.166 + (rtac conjI THEN' (atac ORELSE' rtac subset_UNIV)) ORELSE'
32.167 + atac ORELSE'
32.168 + (rtac subset_UNIV)) 1)) ORELSE rtac subset_UNIV 1));
32.169 +
32.170 +fun mk_comp_in_bd_tac comp_in_alt Fin_bds Gin_bd Fbd_Cinfs Gbd_Card_order =
32.171 + let
32.172 + val (bds, last_bd) = split_last Fin_bds;
32.173 + val (Cinfs, _) = split_last Fbd_Cinfs;
32.174 + fun gen_before (bd, _) = rtac ctrans THEN' rtac @{thm csum_mono} THEN' rtac bd;
32.175 + fun gen_after (_, (bd_Cinf, next_bd_Cinf)) =
32.176 + TRY o (rtac @{thm csum_cexp} THEN'
32.177 + rtac bd_Cinf THEN'
32.178 + (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac next_bd_Cinf ORELSE'
32.179 + rtac next_bd_Cinf) THEN'
32.180 + ((rtac Card_order_csum THEN' rtac ordLeq_csum2) ORELSE'
32.181 + (rtac Card_order_ctwo THEN' rtac @{thm ordLeq_refl})) THEN'
32.182 + rtac Card_order_ctwo);
32.183 + in
32.184 + (rtac @{thm ordIso_ordLeq_trans} THEN'
32.185 + rtac @{thm card_of_ordIso_subst} THEN'
32.186 + rtac comp_in_alt THEN'
32.187 + rtac ctrans THEN'
32.188 + rtac Gin_bd THEN'
32.189 + rtac @{thm ordLeq_ordIso_trans} THEN'
32.190 + rtac @{thm cexp_mono1} THEN'
32.191 + rtac @{thm ordLeq_ordIso_trans} THEN'
32.192 + rtac @{thm csum_mono1} THEN'
32.193 + WRAP' gen_before gen_after (bds ~~ (Cinfs ~~ tl Fbd_Cinfs)) (rtac last_bd) THEN'
32.194 + rtac @{thm csum_absorb1} THEN'
32.195 + rtac @{thm Cinfinite_cexp} THEN'
32.196 + (rtac ordLeq_csum2 ORELSE' rtac @{thm ordLeq_refl}) THEN'
32.197 + rtac Card_order_ctwo THEN'
32.198 + (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac (hd Fbd_Cinfs) ORELSE'
32.199 + rtac (hd Fbd_Cinfs)) THEN'
32.200 + rtac @{thm ctwo_ordLeq_Cinfinite} THEN'
32.201 + rtac @{thm Cinfinite_cexp} THEN'
32.202 + (rtac ordLeq_csum2 ORELSE' rtac @{thm ordLeq_refl}) THEN'
32.203 + rtac Card_order_ctwo THEN'
32.204 + (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac (hd Fbd_Cinfs) ORELSE'
32.205 + rtac (hd Fbd_Cinfs)) THEN'
32.206 + rtac disjI1 THEN'
32.207 + TRY o rtac csum_Cnotzero2 THEN'
32.208 + rtac ctwo_Cnotzero THEN'
32.209 + rtac Gbd_Card_order THEN'
32.210 + rtac @{thm cexp_cprod} THEN'
32.211 + TRY o rtac csum_Cnotzero2 THEN'
32.212 + rtac ctwo_Cnotzero) 1
32.213 + end;
32.214 +
32.215 +val comp_wit_thms = @{thms Union_empty_conv o_apply collect_def SUP_def
32.216 + Union_image_insert Union_image_empty};
32.217 +
32.218 +fun mk_comp_wit_tac ctxt Gwit_thms collect_set_natural Fwit_thms =
32.219 + ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
32.220 + unfold_thms_tac ctxt (collect_set_natural :: comp_wit_thms) THEN
32.221 + REPEAT_DETERM (
32.222 + atac 1 ORELSE
32.223 + REPEAT_DETERM (eresolve_tac @{thms UnionE UnE imageE} 1) THEN
32.224 + (TRY o dresolve_tac Gwit_thms THEN'
32.225 + (etac FalseE ORELSE'
32.226 + hyp_subst_tac THEN'
32.227 + dresolve_tac Fwit_thms THEN'
32.228 + (etac FalseE ORELSE' atac))) 1);
32.229 +
32.230 +
32.231 +
32.232 +(* Kill operation *)
32.233 +
32.234 +fun mk_kill_map_cong_tac ctxt n m map_cong =
32.235 + (rtac map_cong THEN' EVERY' (replicate n (rtac refl)) THEN'
32.236 + EVERY' (replicate m (Goal.assume_rule_tac ctxt))) 1;
32.237 +
32.238 +fun mk_kill_bd_card_order_tac n bd_card_order =
32.239 + (rtac @{thm card_order_cprod} THEN'
32.240 + K (REPEAT_DETERM_N (n - 1)
32.241 + ((rtac @{thm card_order_csum} THEN'
32.242 + rtac @{thm card_of_card_order_on}) 1)) THEN'
32.243 + rtac @{thm card_of_card_order_on} THEN'
32.244 + rtac bd_card_order) 1;
32.245 +
32.246 +fun mk_kill_bd_cinfinite_tac bd_Cinfinite =
32.247 + (rtac @{thm cinfinite_cprod2} THEN'
32.248 + TRY o rtac csum_Cnotzero1 THEN'
32.249 + rtac Cnotzero_UNIV THEN'
32.250 + rtac bd_Cinfinite) 1;
32.251 +
32.252 +fun mk_kill_set_bd_tac bd_Card_order set_bd =
32.253 + (rtac ctrans THEN'
32.254 + rtac set_bd THEN'
32.255 + rtac @{thm ordLeq_cprod2} THEN'
32.256 + TRY o rtac csum_Cnotzero1 THEN'
32.257 + rtac Cnotzero_UNIV THEN'
32.258 + rtac bd_Card_order) 1
32.259 +
32.260 +val kill_in_alt_tac =
32.261 + ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
32.262 + REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
32.263 + REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
32.264 + rtac conjI THEN' rtac subset_UNIV) 1)) THEN
32.265 + (rtac subset_UNIV ORELSE' atac) 1 THEN
32.266 + REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
32.267 + REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1))) ORELSE
32.268 + ((rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
32.269 + REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac subset_UNIV 1));
32.270 +
32.271 +fun mk_kill_in_bd_tac n nontrivial_kill_in in_alt in_bd bd_Card_order bd_Cinfinite bd_Cnotzero =
32.272 + (rtac @{thm ordIso_ordLeq_trans} THEN'
32.273 + rtac @{thm card_of_ordIso_subst} THEN'
32.274 + rtac in_alt THEN'
32.275 + rtac ctrans THEN'
32.276 + rtac in_bd THEN'
32.277 + rtac @{thm ordIso_ordLeq_trans} THEN'
32.278 + rtac @{thm cexp_cong1}) 1 THEN
32.279 + (if nontrivial_kill_in then
32.280 + rtac ordIso_transitive 1 THEN
32.281 + REPEAT_DETERM_N (n - 1)
32.282 + ((rtac @{thm csum_cong1} THEN'
32.283 + rtac @{thm ordIso_symmetric} THEN'
32.284 + rtac @{thm csum_assoc} THEN'
32.285 + rtac ordIso_transitive) 1) THEN
32.286 + (rtac @{thm ordIso_refl} THEN'
32.287 + rtac Card_order_csum THEN'
32.288 + rtac ordIso_transitive THEN'
32.289 + rtac @{thm csum_assoc} THEN'
32.290 + rtac ordIso_transitive THEN'
32.291 + rtac @{thm csum_cong1} THEN'
32.292 + K (mk_flatten_assoc_tac
32.293 + (rtac @{thm ordIso_refl} THEN'
32.294 + FIRST' [rtac card_of_Card_order, rtac Card_order_csum])
32.295 + ordIso_transitive @{thm csum_assoc} @{thm csum_cong}) THEN'
32.296 + rtac @{thm ordIso_refl} THEN'
32.297 + (rtac card_of_Card_order ORELSE' rtac Card_order_csum)) 1
32.298 + else all_tac) THEN
32.299 + (rtac @{thm csum_com} THEN'
32.300 + rtac bd_Card_order THEN'
32.301 + rtac disjI1 THEN'
32.302 + rtac csum_Cnotzero2 THEN'
32.303 + rtac ctwo_Cnotzero THEN'
32.304 + rtac disjI1 THEN'
32.305 + rtac csum_Cnotzero2 THEN'
32.306 + TRY o rtac csum_Cnotzero1 THEN'
32.307 + rtac Cnotzero_UNIV THEN'
32.308 + rtac @{thm ordLeq_ordIso_trans} THEN'
32.309 + rtac @{thm cexp_mono1} THEN'
32.310 + rtac ctrans THEN'
32.311 + rtac @{thm csum_mono2} THEN'
32.312 + rtac @{thm ordLeq_cprod1} THEN'
32.313 + (rtac card_of_Card_order ORELSE' rtac Card_order_csum) THEN'
32.314 + rtac bd_Cnotzero THEN'
32.315 + rtac @{thm csum_cexp'} THEN'
32.316 + rtac @{thm Cinfinite_cprod2} THEN'
32.317 + TRY o rtac csum_Cnotzero1 THEN'
32.318 + rtac Cnotzero_UNIV THEN'
32.319 + rtac bd_Cinfinite THEN'
32.320 + ((rtac Card_order_ctwo THEN' rtac @{thm ordLeq_refl}) ORELSE'
32.321 + (rtac Card_order_csum THEN' rtac ordLeq_csum2)) THEN'
32.322 + rtac Card_order_ctwo THEN'
32.323 + rtac disjI1 THEN'
32.324 + rtac csum_Cnotzero2 THEN'
32.325 + TRY o rtac csum_Cnotzero1 THEN'
32.326 + rtac Cnotzero_UNIV THEN'
32.327 + rtac bd_Card_order THEN'
32.328 + rtac @{thm cexp_cprod_ordLeq} THEN'
32.329 + TRY o rtac csum_Cnotzero2 THEN'
32.330 + rtac ctwo_Cnotzero THEN'
32.331 + rtac @{thm Cinfinite_cprod2} THEN'
32.332 + TRY o rtac csum_Cnotzero1 THEN'
32.333 + rtac Cnotzero_UNIV THEN'
32.334 + rtac bd_Cinfinite THEN'
32.335 + rtac bd_Cnotzero THEN'
32.336 + rtac @{thm ordLeq_cprod2} THEN'
32.337 + TRY o rtac csum_Cnotzero1 THEN'
32.338 + rtac Cnotzero_UNIV THEN'
32.339 + rtac bd_Card_order) 1;
32.340 +
32.341 +
32.342 +
32.343 +(* Lift operation *)
32.344 +
32.345 +val empty_natural_tac = rtac @{thm empty_natural} 1;
32.346 +
32.347 +fun mk_lift_set_bd_tac bd_Card_order = (rtac @{thm Card_order_empty} THEN' rtac bd_Card_order) 1;
32.348 +
32.349 +val lift_in_alt_tac =
32.350 + ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
32.351 + REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
32.352 + REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1)) THEN
32.353 + REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
32.354 + REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
32.355 + rtac conjI THEN' rtac @{thm empty_subsetI}) 1)) THEN
32.356 + (rtac @{thm empty_subsetI} ORELSE' atac) 1) ORELSE
32.357 + ((rtac sym THEN' rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
32.358 + REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac @{thm empty_subsetI} 1));
32.359 +
32.360 +fun mk_lift_in_bd_tac n in_alt in_bd bd_Card_order =
32.361 + (rtac @{thm ordIso_ordLeq_trans} THEN'
32.362 + rtac @{thm card_of_ordIso_subst} THEN'
32.363 + rtac in_alt THEN'
32.364 + rtac ctrans THEN'
32.365 + rtac in_bd THEN'
32.366 + rtac @{thm cexp_mono1}) 1 THEN
32.367 + ((rtac @{thm csum_mono1} 1 THEN
32.368 + REPEAT_DETERM_N (n - 1)
32.369 + ((rtac ctrans THEN'
32.370 + rtac ordLeq_csum2 THEN'
32.371 + (rtac Card_order_csum ORELSE' rtac card_of_Card_order)) 1) THEN
32.372 + (rtac ordLeq_csum2 THEN'
32.373 + (rtac Card_order_csum ORELSE' rtac card_of_Card_order)) 1) ORELSE
32.374 + (rtac ordLeq_csum2 THEN' rtac Card_order_ctwo) 1) THEN
32.375 + (rtac disjI1 THEN' TRY o rtac csum_Cnotzero2 THEN' rtac ctwo_Cnotzero
32.376 + THEN' rtac bd_Card_order) 1;
32.377 +
32.378 +
32.379 +
32.380 +(* Permute operation *)
32.381 +
32.382 +fun mk_permute_in_alt_tac src dest =
32.383 + (rtac @{thm Collect_cong} THEN'
32.384 + mk_rotate_eq_tac (rtac refl) trans @{thm conj_assoc} @{thm conj_commute} @{thm conj_cong}
32.385 + dest src) 1;
32.386 +
32.387 +fun mk_permute_in_bd_tac src dest in_alt in_bd bd_Card_order =
32.388 + (rtac @{thm ordIso_ordLeq_trans} THEN'
32.389 + rtac @{thm card_of_ordIso_subst} THEN'
32.390 + rtac in_alt THEN'
32.391 + rtac @{thm ordLeq_ordIso_trans} THEN'
32.392 + rtac in_bd THEN'
32.393 + rtac @{thm cexp_cong1} THEN'
32.394 + rtac @{thm csum_cong1} THEN'
32.395 + mk_rotate_eq_tac
32.396 + (rtac @{thm ordIso_refl} THEN'
32.397 + FIRST' [rtac card_of_Card_order, rtac Card_order_csum])
32.398 + ordIso_transitive @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
32.399 + src dest THEN'
32.400 + rtac bd_Card_order THEN'
32.401 + rtac disjI1 THEN'
32.402 + TRY o rtac csum_Cnotzero2 THEN'
32.403 + rtac ctwo_Cnotzero THEN'
32.404 + rtac disjI1 THEN'
32.405 + TRY o rtac csum_Cnotzero2 THEN'
32.406 + rtac ctwo_Cnotzero) 1;
32.407 +
32.408 +fun mk_map_wpull_tac comp_in_alt inner_map_wpulls outer_map_wpull =
32.409 + (rtac (@{thm wpull_cong} OF (replicate 3 comp_in_alt)) THEN' rtac outer_map_wpull) 1 THEN
32.410 + WRAP (fn thm => rtac thm 1 THEN REPEAT_DETERM (atac 1)) (K all_tac) inner_map_wpulls all_tac THEN
32.411 + TRY (REPEAT_DETERM (atac 1 ORELSE rtac @{thm wpull_id} 1));
32.412 +
32.413 +fun mk_simple_srel_O_Gr_tac ctxt srel_def srel_O_Gr in_alt_thm =
32.414 + rtac (unfold_thms ctxt [srel_def]
32.415 + (trans OF [srel_O_Gr, in_alt_thm RS @{thm subst_rel_def} RS sym])) 1;
32.416 +
32.417 +fun mk_simple_wit_tac wit_thms = ALLGOALS (atac ORELSE' eresolve_tac (@{thm emptyE} :: wit_thms));
32.418 +
32.419 +end;
33.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
33.2 +++ b/src/HOL/BNF/Tools/bnf_def.ML Fri Sep 21 16:45:06 2012 +0200
33.3 @@ -0,0 +1,1238 @@
33.4 +(* Title: HOL/BNF/Tools/bnf_def.ML
33.5 + Author: Dmitriy Traytel, TU Muenchen
33.6 + Author: Jasmin Blanchette, TU Muenchen
33.7 + Copyright 2012
33.8 +
33.9 +Definition of bounded natural functors.
33.10 +*)
33.11 +
33.12 +signature BNF_DEF =
33.13 +sig
33.14 + type BNF
33.15 + type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
33.16 +
33.17 + val bnf_of: Proof.context -> string -> BNF option
33.18 + val register_bnf: string -> (BNF * local_theory) -> (BNF * local_theory)
33.19 +
33.20 + val name_of_bnf: BNF -> binding
33.21 + val T_of_bnf: BNF -> typ
33.22 + val live_of_bnf: BNF -> int
33.23 + val lives_of_bnf: BNF -> typ list
33.24 + val dead_of_bnf: BNF -> int
33.25 + val deads_of_bnf: BNF -> typ list
33.26 + val nwits_of_bnf: BNF -> int
33.27 +
33.28 + val mapN: string
33.29 + val relN: string
33.30 + val setN: string
33.31 + val mk_setN: int -> string
33.32 + val srelN: string
33.33 +
33.34 + val map_of_bnf: BNF -> term
33.35 +
33.36 + val mk_T_of_bnf: typ list -> typ list -> BNF -> typ
33.37 + val mk_bd_of_bnf: typ list -> typ list -> BNF -> term
33.38 + val mk_map_of_bnf: typ list -> typ list -> typ list -> BNF -> term
33.39 + val mk_rel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
33.40 + val mk_sets_of_bnf: typ list list -> typ list list -> BNF -> term list
33.41 + val mk_srel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
33.42 + val mk_wits_of_bnf: typ list list -> typ list list -> BNF -> (int list * term) list
33.43 +
33.44 + val bd_Card_order_of_bnf: BNF -> thm
33.45 + val bd_Cinfinite_of_bnf: BNF -> thm
33.46 + val bd_Cnotzero_of_bnf: BNF -> thm
33.47 + val bd_card_order_of_bnf: BNF -> thm
33.48 + val bd_cinfinite_of_bnf: BNF -> thm
33.49 + val collect_set_natural_of_bnf: BNF -> thm
33.50 + val in_bd_of_bnf: BNF -> thm
33.51 + val in_cong_of_bnf: BNF -> thm
33.52 + val in_mono_of_bnf: BNF -> thm
33.53 + val in_srel_of_bnf: BNF -> thm
33.54 + val map_comp'_of_bnf: BNF -> thm
33.55 + val map_comp_of_bnf: BNF -> thm
33.56 + val map_cong_of_bnf: BNF -> thm
33.57 + val map_def_of_bnf: BNF -> thm
33.58 + val map_id'_of_bnf: BNF -> thm
33.59 + val map_id_of_bnf: BNF -> thm
33.60 + val map_wppull_of_bnf: BNF -> thm
33.61 + val map_wpull_of_bnf: BNF -> thm
33.62 + val rel_def_of_bnf: BNF -> thm
33.63 + val set_bd_of_bnf: BNF -> thm list
33.64 + val set_defs_of_bnf: BNF -> thm list
33.65 + val set_natural'_of_bnf: BNF -> thm list
33.66 + val set_natural_of_bnf: BNF -> thm list
33.67 + val sets_of_bnf: BNF -> term list
33.68 + val srel_def_of_bnf: BNF -> thm
33.69 + val srel_Gr_of_bnf: BNF -> thm
33.70 + val srel_Id_of_bnf: BNF -> thm
33.71 + val srel_O_of_bnf: BNF -> thm
33.72 + val srel_O_Gr_of_bnf: BNF -> thm
33.73 + val srel_cong_of_bnf: BNF -> thm
33.74 + val srel_converse_of_bnf: BNF -> thm
33.75 + val srel_mono_of_bnf: BNF -> thm
33.76 + val wit_thms_of_bnf: BNF -> thm list
33.77 + val wit_thmss_of_bnf: BNF -> thm list list
33.78 +
33.79 + val mk_witness: int list * term -> thm list -> nonemptiness_witness
33.80 + val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
33.81 + val wits_of_bnf: BNF -> nonemptiness_witness list
33.82 +
33.83 + val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list
33.84 +
33.85 + datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
33.86 + datatype fact_policy =
33.87 + Derive_Few_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms
33.88 + val bnf_note_all: bool Config.T
33.89 + val user_policy: fact_policy -> Proof.context -> fact_policy
33.90 +
33.91 + val print_bnfs: Proof.context -> unit
33.92 + val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
33.93 + ({prems: thm list, context: Proof.context} -> tactic) list ->
33.94 + ({prems: thm list, context: Proof.context} -> tactic) -> typ list option ->
33.95 + ((((binding * term) * term list) * term) * term list) * term option -> local_theory ->
33.96 + BNF * local_theory
33.97 +end;
33.98 +
33.99 +structure BNF_Def : BNF_DEF =
33.100 +struct
33.101 +
33.102 +open BNF_Util
33.103 +open BNF_Tactics
33.104 +open BNF_Def_Tactics
33.105 +
33.106 +type axioms = {
33.107 + map_id: thm,
33.108 + map_comp: thm,
33.109 + map_cong: thm,
33.110 + set_natural: thm list,
33.111 + bd_card_order: thm,
33.112 + bd_cinfinite: thm,
33.113 + set_bd: thm list,
33.114 + in_bd: thm,
33.115 + map_wpull: thm,
33.116 + srel_O_Gr: thm
33.117 +};
33.118 +
33.119 +fun mk_axioms' (((((((((id, comp), cong), nat), c_o), cinf), set_bd), in_bd), wpull), srel) =
33.120 + {map_id = id, map_comp = comp, map_cong = cong, set_natural = nat, bd_card_order = c_o,
33.121 + bd_cinfinite = cinf, set_bd = set_bd, in_bd = in_bd, map_wpull = wpull, srel_O_Gr = srel};
33.122 +
33.123 +fun dest_cons [] = raise Empty
33.124 + | dest_cons (x :: xs) = (x, xs);
33.125 +
33.126 +fun mk_axioms n thms = thms
33.127 + |> map the_single
33.128 + |> dest_cons
33.129 + ||>> dest_cons
33.130 + ||>> dest_cons
33.131 + ||>> chop n
33.132 + ||>> dest_cons
33.133 + ||>> dest_cons
33.134 + ||>> chop n
33.135 + ||>> dest_cons
33.136 + ||>> dest_cons
33.137 + ||> the_single
33.138 + |> mk_axioms';
33.139 +
33.140 +fun zip_axioms mid mcomp mcong snat bdco bdinf sbd inbd wpull srel =
33.141 + [mid, mcomp, mcong] @ snat @ [bdco, bdinf] @ sbd @ [inbd, wpull, srel];
33.142 +
33.143 +fun dest_axioms {map_id, map_comp, map_cong, set_natural, bd_card_order, bd_cinfinite, set_bd,
33.144 + in_bd, map_wpull, srel_O_Gr} =
33.145 + zip_axioms map_id map_comp map_cong set_natural bd_card_order bd_cinfinite set_bd in_bd map_wpull
33.146 + srel_O_Gr;
33.147 +
33.148 +fun map_axioms f {map_id, map_comp, map_cong, set_natural, bd_card_order, bd_cinfinite, set_bd,
33.149 + in_bd, map_wpull, srel_O_Gr} =
33.150 + {map_id = f map_id,
33.151 + map_comp = f map_comp,
33.152 + map_cong = f map_cong,
33.153 + set_natural = map f set_natural,
33.154 + bd_card_order = f bd_card_order,
33.155 + bd_cinfinite = f bd_cinfinite,
33.156 + set_bd = map f set_bd,
33.157 + in_bd = f in_bd,
33.158 + map_wpull = f map_wpull,
33.159 + srel_O_Gr = f srel_O_Gr};
33.160 +
33.161 +val morph_axioms = map_axioms o Morphism.thm;
33.162 +
33.163 +type defs = {
33.164 + map_def: thm,
33.165 + set_defs: thm list,
33.166 + rel_def: thm,
33.167 + srel_def: thm
33.168 +}
33.169 +
33.170 +fun mk_defs map sets rel srel = {map_def = map, set_defs = sets, rel_def = rel, srel_def = srel};
33.171 +
33.172 +fun map_defs f {map_def, set_defs, rel_def, srel_def} =
33.173 + {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def, srel_def = f srel_def};
33.174 +
33.175 +val morph_defs = map_defs o Morphism.thm;
33.176 +
33.177 +type facts = {
33.178 + bd_Card_order: thm,
33.179 + bd_Cinfinite: thm,
33.180 + bd_Cnotzero: thm,
33.181 + collect_set_natural: thm lazy,
33.182 + in_cong: thm lazy,
33.183 + in_mono: thm lazy,
33.184 + in_srel: thm lazy,
33.185 + map_comp': thm lazy,
33.186 + map_id': thm lazy,
33.187 + map_wppull: thm lazy,
33.188 + set_natural': thm lazy list,
33.189 + srel_cong: thm lazy,
33.190 + srel_mono: thm lazy,
33.191 + srel_Id: thm lazy,
33.192 + srel_Gr: thm lazy,
33.193 + srel_converse: thm lazy,
33.194 + srel_O: thm lazy
33.195 +};
33.196 +
33.197 +fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_natural in_cong in_mono in_srel
33.198 + map_comp' map_id' map_wppull set_natural' srel_cong srel_mono srel_Id srel_Gr srel_converse
33.199 + srel_O = {
33.200 + bd_Card_order = bd_Card_order,
33.201 + bd_Cinfinite = bd_Cinfinite,
33.202 + bd_Cnotzero = bd_Cnotzero,
33.203 + collect_set_natural = collect_set_natural,
33.204 + in_cong = in_cong,
33.205 + in_mono = in_mono,
33.206 + in_srel = in_srel,
33.207 + map_comp' = map_comp',
33.208 + map_id' = map_id',
33.209 + map_wppull = map_wppull,
33.210 + set_natural' = set_natural',
33.211 + srel_cong = srel_cong,
33.212 + srel_mono = srel_mono,
33.213 + srel_Id = srel_Id,
33.214 + srel_Gr = srel_Gr,
33.215 + srel_converse = srel_converse,
33.216 + srel_O = srel_O};
33.217 +
33.218 +fun map_facts f {
33.219 + bd_Card_order,
33.220 + bd_Cinfinite,
33.221 + bd_Cnotzero,
33.222 + collect_set_natural,
33.223 + in_cong,
33.224 + in_mono,
33.225 + in_srel,
33.226 + map_comp',
33.227 + map_id',
33.228 + map_wppull,
33.229 + set_natural',
33.230 + srel_cong,
33.231 + srel_mono,
33.232 + srel_Id,
33.233 + srel_Gr,
33.234 + srel_converse,
33.235 + srel_O} =
33.236 + {bd_Card_order = f bd_Card_order,
33.237 + bd_Cinfinite = f bd_Cinfinite,
33.238 + bd_Cnotzero = f bd_Cnotzero,
33.239 + collect_set_natural = Lazy.map f collect_set_natural,
33.240 + in_cong = Lazy.map f in_cong,
33.241 + in_mono = Lazy.map f in_mono,
33.242 + in_srel = Lazy.map f in_srel,
33.243 + map_comp' = Lazy.map f map_comp',
33.244 + map_id' = Lazy.map f map_id',
33.245 + map_wppull = Lazy.map f map_wppull,
33.246 + set_natural' = map (Lazy.map f) set_natural',
33.247 + srel_cong = Lazy.map f srel_cong,
33.248 + srel_mono = Lazy.map f srel_mono,
33.249 + srel_Id = Lazy.map f srel_Id,
33.250 + srel_Gr = Lazy.map f srel_Gr,
33.251 + srel_converse = Lazy.map f srel_converse,
33.252 + srel_O = Lazy.map f srel_O};
33.253 +
33.254 +val morph_facts = map_facts o Morphism.thm;
33.255 +
33.256 +type nonemptiness_witness = {
33.257 + I: int list,
33.258 + wit: term,
33.259 + prop: thm list
33.260 +};
33.261 +
33.262 +fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
33.263 +fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
33.264 +fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
33.265 +
33.266 +datatype BNF = BNF of {
33.267 + name: binding,
33.268 + T: typ,
33.269 + live: int,
33.270 + lives: typ list, (*source type variables of map, only for composition*)
33.271 + lives': typ list, (*target type variables of map, only for composition*)
33.272 + dead: int,
33.273 + deads: typ list, (*only for composition*)
33.274 + map: term,
33.275 + sets: term list,
33.276 + bd: term,
33.277 + axioms: axioms,
33.278 + defs: defs,
33.279 + facts: facts,
33.280 + nwits: int,
33.281 + wits: nonemptiness_witness list,
33.282 + rel: term,
33.283 + srel: term
33.284 +};
33.285 +
33.286 +(* getters *)
33.287 +
33.288 +fun rep_bnf (BNF bnf) = bnf;
33.289 +val name_of_bnf = #name o rep_bnf;
33.290 +val T_of_bnf = #T o rep_bnf;
33.291 +fun mk_T_of_bnf Ds Ts bnf =
33.292 + let val bnf_rep = rep_bnf bnf
33.293 + in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
33.294 +val live_of_bnf = #live o rep_bnf;
33.295 +val lives_of_bnf = #lives o rep_bnf;
33.296 +val dead_of_bnf = #dead o rep_bnf;
33.297 +val deads_of_bnf = #deads o rep_bnf;
33.298 +val axioms_of_bnf = #axioms o rep_bnf;
33.299 +val facts_of_bnf = #facts o rep_bnf;
33.300 +val nwits_of_bnf = #nwits o rep_bnf;
33.301 +val wits_of_bnf = #wits o rep_bnf;
33.302 +
33.303 +(*terms*)
33.304 +val map_of_bnf = #map o rep_bnf;
33.305 +val sets_of_bnf = #sets o rep_bnf;
33.306 +fun mk_map_of_bnf Ds Ts Us bnf =
33.307 + let val bnf_rep = rep_bnf bnf;
33.308 + in
33.309 + Term.subst_atomic_types
33.310 + ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
33.311 + end;
33.312 +fun mk_sets_of_bnf Dss Tss bnf =
33.313 + let val bnf_rep = rep_bnf bnf;
33.314 + in
33.315 + map2 (fn (Ds, Ts) => Term.subst_atomic_types
33.316 + ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
33.317 + end;
33.318 +val bd_of_bnf = #bd o rep_bnf;
33.319 +fun mk_bd_of_bnf Ds Ts bnf =
33.320 + let val bnf_rep = rep_bnf bnf;
33.321 + in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
33.322 +fun mk_wits_of_bnf Dss Tss bnf =
33.323 + let
33.324 + val bnf_rep = rep_bnf bnf;
33.325 + val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
33.326 + in
33.327 + map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
33.328 + ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
33.329 + end;
33.330 +val rel_of_bnf = #rel o rep_bnf;
33.331 +fun mk_rel_of_bnf Ds Ts Us bnf =
33.332 + let val bnf_rep = rep_bnf bnf;
33.333 + in
33.334 + Term.subst_atomic_types
33.335 + ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
33.336 + end;
33.337 +val srel_of_bnf = #srel o rep_bnf;
33.338 +fun mk_srel_of_bnf Ds Ts Us bnf =
33.339 + let val bnf_rep = rep_bnf bnf;
33.340 + in
33.341 + Term.subst_atomic_types
33.342 + ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#srel bnf_rep)
33.343 + end;
33.344 +
33.345 +(*thms*)
33.346 +val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
33.347 +val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
33.348 +val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
33.349 +val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
33.350 +val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
33.351 +val collect_set_natural_of_bnf = Lazy.force o #collect_set_natural o #facts o rep_bnf;
33.352 +val in_bd_of_bnf = #in_bd o #axioms o rep_bnf;
33.353 +val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
33.354 +val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
33.355 +val in_srel_of_bnf = Lazy.force o #in_srel o #facts o rep_bnf;
33.356 +val map_def_of_bnf = #map_def o #defs o rep_bnf;
33.357 +val map_id_of_bnf = #map_id o #axioms o rep_bnf;
33.358 +val map_id'_of_bnf = Lazy.force o #map_id' o #facts o rep_bnf;
33.359 +val map_comp_of_bnf = #map_comp o #axioms o rep_bnf;
33.360 +val map_comp'_of_bnf = Lazy.force o #map_comp' o #facts o rep_bnf;
33.361 +val map_cong_of_bnf = #map_cong o #axioms o rep_bnf;
33.362 +val map_wppull_of_bnf = Lazy.force o #map_wppull o #facts o rep_bnf;
33.363 +val map_wpull_of_bnf = #map_wpull o #axioms o rep_bnf;
33.364 +val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
33.365 +val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
33.366 +val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
33.367 +val set_natural_of_bnf = #set_natural o #axioms o rep_bnf;
33.368 +val set_natural'_of_bnf = map Lazy.force o #set_natural' o #facts o rep_bnf;
33.369 +val srel_cong_of_bnf = Lazy.force o #srel_cong o #facts o rep_bnf;
33.370 +val srel_mono_of_bnf = Lazy.force o #srel_mono o #facts o rep_bnf;
33.371 +val srel_def_of_bnf = #srel_def o #defs o rep_bnf;
33.372 +val srel_Id_of_bnf = Lazy.force o #srel_Id o #facts o rep_bnf;
33.373 +val srel_Gr_of_bnf = Lazy.force o #srel_Gr o #facts o rep_bnf;
33.374 +val srel_converse_of_bnf = Lazy.force o #srel_converse o #facts o rep_bnf;
33.375 +val srel_O_of_bnf = Lazy.force o #srel_O o #facts o rep_bnf;
33.376 +val srel_O_Gr_of_bnf = #srel_O_Gr o #axioms o rep_bnf;
33.377 +val wit_thms_of_bnf = maps #prop o wits_of_bnf;
33.378 +val wit_thmss_of_bnf = map #prop o wits_of_bnf;
33.379 +
33.380 +fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel srel =
33.381 + BNF {name = name, T = T,
33.382 + live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
33.383 + map = map, sets = sets, bd = bd,
33.384 + axioms = axioms, defs = defs, facts = facts,
33.385 + nwits = length wits, wits = wits, rel = rel, srel = srel};
33.386 +
33.387 +fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
33.388 + dead = dead, deads = deads, map = map, sets = sets, bd = bd,
33.389 + axioms = axioms, defs = defs, facts = facts,
33.390 + nwits = nwits, wits = wits, rel = rel, srel = srel}) =
33.391 + BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
33.392 + live = live, lives = List.map (Morphism.typ phi) lives,
33.393 + lives' = List.map (Morphism.typ phi) lives',
33.394 + dead = dead, deads = List.map (Morphism.typ phi) deads,
33.395 + map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
33.396 + bd = Morphism.term phi bd,
33.397 + axioms = morph_axioms phi axioms,
33.398 + defs = morph_defs phi defs,
33.399 + facts = morph_facts phi facts,
33.400 + nwits = nwits,
33.401 + wits = List.map (morph_witness phi) wits,
33.402 + rel = Morphism.term phi rel, srel = Morphism.term phi srel};
33.403 +
33.404 +fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
33.405 + BNF {T = T2, live = live2, dead = dead2, ...}) =
33.406 + Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
33.407 +
33.408 +structure Data = Generic_Data
33.409 +(
33.410 + type T = BNF Symtab.table;
33.411 + val empty = Symtab.empty;
33.412 + val extend = I;
33.413 + val merge = Symtab.merge eq_bnf;
33.414 +);
33.415 +
33.416 +val bnf_of = Symtab.lookup o Data.get o Context.Proof;
33.417 +
33.418 +
33.419 +
33.420 +(* Utilities *)
33.421 +
33.422 +fun normalize_set insts instA set =
33.423 + let
33.424 + val (T, T') = dest_funT (fastype_of set);
33.425 + val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
33.426 + val params = Term.add_tvar_namesT T [];
33.427 + in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
33.428 +
33.429 +fun normalize_rel ctxt instTs instA instB rel =
33.430 + let
33.431 + val thy = Proof_Context.theory_of ctxt;
33.432 + val tyenv =
33.433 + Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
33.434 + Vartab.empty;
33.435 + in Envir.subst_term (tyenv, Vartab.empty) rel end
33.436 + handle Type.TYPE_MATCH => error "Bad predicator";
33.437 +
33.438 +fun normalize_srel ctxt instTs instA instB srel =
33.439 + let
33.440 + val thy = Proof_Context.theory_of ctxt;
33.441 + val tyenv =
33.442 + Sign.typ_match thy (fastype_of srel, Library.foldr (op -->) (instTs, mk_relT (instA, instB)))
33.443 + Vartab.empty;
33.444 + in Envir.subst_term (tyenv, Vartab.empty) srel end
33.445 + handle Type.TYPE_MATCH => error "Bad relator";
33.446 +
33.447 +fun normalize_wit insts CA As wit =
33.448 + let
33.449 + fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
33.450 + if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
33.451 + | strip_param x = x;
33.452 + val (Ts, T) = strip_param ([], fastype_of wit);
33.453 + val subst = Term.add_tvar_namesT T [] ~~ insts;
33.454 + fun find y = find_index (fn x => x = y) As;
33.455 + in
33.456 + (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
33.457 + end;
33.458 +
33.459 +fun minimize_wits wits =
33.460 + let
33.461 + fun minimize done [] = done
33.462 + | minimize done ((I, wit) :: todo) =
33.463 + if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
33.464 + then minimize done todo
33.465 + else minimize ((I, wit) :: done) todo;
33.466 + in minimize [] wits end;
33.467 +
33.468 +
33.469 +
33.470 +(* Names *)
33.471 +
33.472 +val mapN = "map";
33.473 +val setN = "set";
33.474 +fun mk_setN i = setN ^ nonzero_string_of_int i;
33.475 +val bdN = "bd";
33.476 +val witN = "wit";
33.477 +fun mk_witN i = witN ^ nonzero_string_of_int i;
33.478 +val relN = "rel";
33.479 +val srelN = "srel";
33.480 +
33.481 +val bd_card_orderN = "bd_card_order";
33.482 +val bd_cinfiniteN = "bd_cinfinite";
33.483 +val bd_Card_orderN = "bd_Card_order";
33.484 +val bd_CinfiniteN = "bd_Cinfinite";
33.485 +val bd_CnotzeroN = "bd_Cnotzero";
33.486 +val collect_set_naturalN = "collect_set_natural";
33.487 +val in_bdN = "in_bd";
33.488 +val in_monoN = "in_mono";
33.489 +val in_srelN = "in_srel";
33.490 +val map_idN = "map_id";
33.491 +val map_id'N = "map_id'";
33.492 +val map_compN = "map_comp";
33.493 +val map_comp'N = "map_comp'";
33.494 +val map_congN = "map_cong";
33.495 +val map_wpullN = "map_wpull";
33.496 +val srel_IdN = "srel_Id";
33.497 +val srel_GrN = "srel_Gr";
33.498 +val srel_converseN = "srel_converse";
33.499 +val srel_monoN = "srel_mono"
33.500 +val srel_ON = "srel_comp";
33.501 +val srel_O_GrN = "srel_comp_Gr";
33.502 +val set_naturalN = "set_natural";
33.503 +val set_natural'N = "set_natural'";
33.504 +val set_bdN = "set_bd";
33.505 +
33.506 +datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
33.507 +
33.508 +datatype fact_policy =
33.509 + Derive_Few_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms;
33.510 +
33.511 +val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
33.512 +
33.513 +fun user_policy policy ctxt =
33.514 + if Config.get ctxt bnf_note_all then Note_All_Facts_and_Axioms else policy;
33.515 +
33.516 +val smart_max_inline_size = 25; (*FUDGE*)
33.517 +
33.518 +
33.519 +(* Define new BNFs *)
33.520 +
33.521 +fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt
33.522 + (((((raw_b, raw_map), raw_sets), raw_bd_Abs), raw_wits), raw_rel_opt) no_defs_lthy =
33.523 + let
33.524 + val fact_policy = mk_fact_policy no_defs_lthy;
33.525 + val b = qualify raw_b;
33.526 + val live = length raw_sets;
33.527 + val nwits = length raw_wits;
33.528 +
33.529 + val map_rhs = prep_term no_defs_lthy raw_map;
33.530 + val set_rhss = map (prep_term no_defs_lthy) raw_sets;
33.531 + val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
33.532 + Abs (_, T, t) => (T, t)
33.533 + | _ => error "Bad bound constant");
33.534 + val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
33.535 +
33.536 + fun err T =
33.537 + error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
33.538 + " as unnamed BNF");
33.539 +
33.540 + val (b, key) =
33.541 + if Binding.eq_name (b, Binding.empty) then
33.542 + (case bd_rhsT of
33.543 + Type (C, Ts) => if forall (is_some o try dest_TFree) Ts
33.544 + then (Binding.qualified_name C, C) else err bd_rhsT
33.545 + | T => err T)
33.546 + else (b, Local_Theory.full_name no_defs_lthy b);
33.547 +
33.548 + fun maybe_define user_specified (b, rhs) lthy =
33.549 + let
33.550 + val inline =
33.551 + (user_specified orelse fact_policy = Derive_Few_Facts) andalso
33.552 + (case const_policy of
33.553 + Dont_Inline => false
33.554 + | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
33.555 + | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
33.556 + | Do_Inline => true)
33.557 + in
33.558 + if inline then
33.559 + ((rhs, Drule.reflexive_thm), lthy)
33.560 + else
33.561 + let val b = b () in
33.562 + apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
33.563 + lthy)
33.564 + end
33.565 + end;
33.566 +
33.567 + fun maybe_restore lthy_old lthy =
33.568 + lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
33.569 +
33.570 + val map_bind_def = (fn () => Binding.suffix_name ("_" ^ mapN) b, map_rhs);
33.571 + val set_binds_defs =
33.572 + let
33.573 + val bs = if live = 1 then [fn () => Binding.suffix_name ("_" ^ setN) b]
33.574 + else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_setN i) b) (1 upto live)
33.575 + in map2 pair bs set_rhss end;
33.576 + val bd_bind_def = (fn () => Binding.suffix_name ("_" ^ bdN) b, bd_rhs);
33.577 + val wit_binds_defs =
33.578 + let
33.579 + val bs = if nwits = 1 then [fn () => Binding.suffix_name ("_" ^ witN) b]
33.580 + else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_witN i) b) (1 upto nwits);
33.581 + in map2 pair bs wit_rhss end;
33.582 +
33.583 + val (((((bnf_map_term, raw_map_def),
33.584 + (bnf_set_terms, raw_set_defs)),
33.585 + (bnf_bd_term, raw_bd_def)),
33.586 + (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
33.587 + no_defs_lthy
33.588 + |> maybe_define true map_bind_def
33.589 + ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
33.590 + ||>> maybe_define true bd_bind_def
33.591 + ||>> apfst split_list o fold_map (maybe_define true) wit_binds_defs
33.592 + ||> `(maybe_restore no_defs_lthy);
33.593 +
33.594 + val phi = Proof_Context.export_morphism lthy_old lthy;
33.595 +
33.596 + val bnf_map_def = Morphism.thm phi raw_map_def;
33.597 + val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
33.598 + val bnf_bd_def = Morphism.thm phi raw_bd_def;
33.599 + val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
33.600 +
33.601 + val bnf_map = Morphism.term phi bnf_map_term;
33.602 +
33.603 + (*TODO: handle errors*)
33.604 + (*simple shape analysis of a map function*)
33.605 + val ((alphas, betas), (CA, _)) =
33.606 + fastype_of bnf_map
33.607 + |> strip_typeN live
33.608 + |>> map_split dest_funT
33.609 + ||> dest_funT
33.610 + handle TYPE _ => error "Bad map function";
33.611 +
33.612 + val CA_params = map TVar (Term.add_tvarsT CA []);
33.613 +
33.614 + val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
33.615 + val bdT = Morphism.typ phi bd_rhsT;
33.616 + val bnf_bd =
33.617 + Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
33.618 + val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
33.619 +
33.620 + (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
33.621 + val deads = (case Ds_opt of
33.622 + NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
33.623 + | SOME Ds => map (Morphism.typ phi) Ds);
33.624 + val dead = length deads;
33.625 +
33.626 + (*TODO: further checks of type of bnf_map*)
33.627 + (*TODO: check types of bnf_sets*)
33.628 + (*TODO: check type of bnf_bd*)
33.629 + (*TODO: check type of bnf_rel*)
33.630 +
33.631 + val ((((((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), domTs), ranTs), ranTs'), ranTs''),
33.632 + (Ts, T)) = lthy
33.633 + |> mk_TFrees live
33.634 + ||>> mk_TFrees live
33.635 + ||>> mk_TFrees live
33.636 + ||>> mk_TFrees dead
33.637 + ||>> mk_TFrees live
33.638 + ||>> mk_TFrees live
33.639 + ||>> mk_TFrees live
33.640 + ||>> mk_TFrees live
33.641 + ||>> mk_TFrees live
33.642 + ||>> mk_TFrees live
33.643 + ||> fst o mk_TFrees 1
33.644 + ||> the_single
33.645 + ||> `(replicate live);
33.646 +
33.647 + fun mk_bnf_map As' Bs' =
33.648 + Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
33.649 + fun mk_bnf_t As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
33.650 + fun mk_bnf_T As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
33.651 +
33.652 + val (setRTs, RTs) = map_split (`HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Bs');
33.653 + val setRTsAsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Cs);
33.654 + val setRTsBsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ Cs);
33.655 + val setRT's = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ As');
33.656 + val self_setRTs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ As');
33.657 + val QTs = map2 mk_pred2T As' Bs';
33.658 +
33.659 + val CA' = mk_bnf_T As' CA;
33.660 + val CB' = mk_bnf_T Bs' CA;
33.661 + val CC' = mk_bnf_T Cs CA;
33.662 + val CRs' = mk_bnf_T RTs CA;
33.663 + val CA'CB' = HOLogic.mk_prodT (CA', CB');
33.664 +
33.665 + val bnf_map_AsAs = mk_bnf_map As' As';
33.666 + val bnf_map_AsBs = mk_bnf_map As' Bs';
33.667 + val bnf_map_AsCs = mk_bnf_map As' Cs;
33.668 + val bnf_map_BsCs = mk_bnf_map Bs' Cs;
33.669 + val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
33.670 + val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
33.671 + val bnf_bd_As = mk_bnf_t As' bnf_bd;
33.672 + val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
33.673 +
33.674 + val (((((((((((((((((((((((((fs, fs_copy), gs), hs), p), (x, x')), (y, y')), (z, z')), zs), As),
33.675 + As_copy), Xs), B1s), B2s), f1s), f2s), e1s), e2s), p1s), p2s), bs), (Rs, Rs')), Rs_copy), Ss),
33.676 + (Qs, Qs')), _) = lthy
33.677 + |> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
33.678 + ||>> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
33.679 + ||>> mk_Frees "g" (map2 (curry (op -->)) Bs' Cs)
33.680 + ||>> mk_Frees "h" (map2 (curry (op -->)) As' Ts)
33.681 + ||>> yield_singleton (mk_Frees "p") CA'CB'
33.682 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "x") CA'
33.683 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "y") CB'
33.684 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "z") CRs'
33.685 + ||>> mk_Frees "z" As'
33.686 + ||>> mk_Frees "A" (map HOLogic.mk_setT As')
33.687 + ||>> mk_Frees "A" (map HOLogic.mk_setT As')
33.688 + ||>> mk_Frees "A" (map HOLogic.mk_setT domTs)
33.689 + ||>> mk_Frees "B1" (map HOLogic.mk_setT B1Ts)
33.690 + ||>> mk_Frees "B2" (map HOLogic.mk_setT B2Ts)
33.691 + ||>> mk_Frees "f1" (map2 (curry (op -->)) B1Ts ranTs)
33.692 + ||>> mk_Frees "f2" (map2 (curry (op -->)) B2Ts ranTs)
33.693 + ||>> mk_Frees "e1" (map2 (curry (op -->)) B1Ts ranTs')
33.694 + ||>> mk_Frees "e2" (map2 (curry (op -->)) B2Ts ranTs'')
33.695 + ||>> mk_Frees "p1" (map2 (curry (op -->)) domTs B1Ts)
33.696 + ||>> mk_Frees "p2" (map2 (curry (op -->)) domTs B2Ts)
33.697 + ||>> mk_Frees "b" As'
33.698 + ||>> mk_Frees' "R" setRTs
33.699 + ||>> mk_Frees "R" setRTs
33.700 + ||>> mk_Frees "S" setRTsBsCs
33.701 + ||>> mk_Frees' "Q" QTs;
33.702 +
33.703 + (*Gr (in R1 .. Rn) (map fst .. fst)^-1 O Gr (in R1 .. Rn) (map snd .. snd)*)
33.704 + val O_Gr =
33.705 + let
33.706 + val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
33.707 + val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
33.708 + val bnf_in = mk_in (map Free Rs') (map (mk_bnf_t RTs) bnf_sets) CRs';
33.709 + in
33.710 + mk_rel_comp (mk_converse (mk_Gr bnf_in map1), mk_Gr bnf_in map2)
33.711 + end;
33.712 +
33.713 + fun mk_predicate_of_set x_name y_name t =
33.714 + let
33.715 + val (T, U) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of t));
33.716 + val x = Free (x_name, T);
33.717 + val y = Free (y_name, U);
33.718 + in fold_rev Term.lambda [x, y] (HOLogic.mk_mem (HOLogic.mk_prod (x, y), t)) end;
33.719 +
33.720 + val rel_rhs = (case raw_rel_opt of
33.721 + NONE =>
33.722 + fold_rev absfree Qs' (mk_predicate_of_set (fst x') (fst y')
33.723 + (Term.list_comb (fold_rev Term.absfree Rs' O_Gr, map3 (fn Q => fn T => fn U =>
33.724 + HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split Q) Qs As' Bs')))
33.725 + | SOME raw_rel => prep_term no_defs_lthy raw_rel);
33.726 +
33.727 + val rel_bind_def = (fn () => Binding.suffix_name ("_" ^ relN) b, rel_rhs);
33.728 +
33.729 + val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
33.730 + lthy
33.731 + |> maybe_define (is_some raw_rel_opt) rel_bind_def
33.732 + ||> `(maybe_restore lthy);
33.733 +
33.734 + val phi = Proof_Context.export_morphism lthy_old lthy;
33.735 + val bnf_rel_def = Morphism.thm phi raw_rel_def;
33.736 + val bnf_rel = Morphism.term phi bnf_rel_term;
33.737 +
33.738 + fun mk_bnf_rel QTs CA' CB' = normalize_rel lthy QTs CA' CB' bnf_rel;
33.739 +
33.740 + val rel = mk_bnf_rel QTs CA' CB';
33.741 +
33.742 + val srel_rhs =
33.743 + fold_rev Term.absfree Rs' (HOLogic.Collect_const CA'CB' $
33.744 + Term.lambda p (Term.list_comb (rel, map (mk_predicate_of_set (fst x') (fst y')) Rs) $
33.745 + HOLogic.mk_fst p $ HOLogic.mk_snd p));
33.746 +
33.747 + val srel_bind_def = (fn () => Binding.suffix_name ("_" ^ srelN) b, srel_rhs);
33.748 +
33.749 + val ((bnf_srel_term, raw_srel_def), (lthy, lthy_old)) =
33.750 + lthy
33.751 + |> maybe_define false srel_bind_def
33.752 + ||> `(maybe_restore lthy);
33.753 +
33.754 + val phi = Proof_Context.export_morphism lthy_old lthy;
33.755 + val bnf_srel_def = Morphism.thm phi raw_srel_def;
33.756 + val bnf_srel = Morphism.term phi bnf_srel_term;
33.757 +
33.758 + fun mk_bnf_srel setRTs CA' CB' = normalize_srel lthy setRTs CA' CB' bnf_srel;
33.759 +
33.760 + val srel = mk_bnf_srel setRTs CA' CB';
33.761 +
33.762 + val _ = case no_reflexive (raw_map_def :: raw_set_defs @ [raw_bd_def] @
33.763 + raw_wit_defs @ [raw_rel_def, raw_srel_def]) of
33.764 + [] => ()
33.765 + | defs => Proof_Display.print_consts true lthy_old (K false)
33.766 + (map (dest_Free o fst o Logic.dest_equals o prop_of) defs);
33.767 +
33.768 + val map_id_goal =
33.769 + let
33.770 + val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As');
33.771 + in
33.772 + HOLogic.mk_Trueprop
33.773 + (HOLogic.mk_eq (bnf_map_app_id, HOLogic.id_const CA'))
33.774 + end;
33.775 +
33.776 + val map_comp_goal =
33.777 + let
33.778 + val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
33.779 + val comp_bnf_map_app = HOLogic.mk_comp
33.780 + (Term.list_comb (bnf_map_BsCs, gs),
33.781 + Term.list_comb (bnf_map_AsBs, fs));
33.782 + in
33.783 + fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
33.784 + end;
33.785 +
33.786 + val map_cong_goal =
33.787 + let
33.788 + fun mk_prem z set f f_copy =
33.789 + Logic.all z (Logic.mk_implies
33.790 + (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
33.791 + mk_Trueprop_eq (f $ z, f_copy $ z)));
33.792 + val prems = map4 mk_prem zs bnf_sets_As fs fs_copy;
33.793 + val eq = HOLogic.mk_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
33.794 + Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
33.795 + in
33.796 + fold_rev Logic.all (x :: fs @ fs_copy)
33.797 + (Logic.list_implies (prems, HOLogic.mk_Trueprop eq))
33.798 + end;
33.799 +
33.800 + val set_naturals_goal =
33.801 + let
33.802 + fun mk_goal setA setB f =
33.803 + let
33.804 + val set_comp_map =
33.805 + HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
33.806 + val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
33.807 + in
33.808 + fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
33.809 + end;
33.810 + in
33.811 + map3 mk_goal bnf_sets_As bnf_sets_Bs fs
33.812 + end;
33.813 +
33.814 + val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
33.815 +
33.816 + val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
33.817 +
33.818 + val set_bds_goal =
33.819 + let
33.820 + fun mk_goal set =
33.821 + Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
33.822 + in
33.823 + map mk_goal bnf_sets_As
33.824 + end;
33.825 +
33.826 + val in_bd_goal =
33.827 + let
33.828 + val bd = mk_cexp
33.829 + (if live = 0 then ctwo
33.830 + else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
33.831 + bnf_bd_As;
33.832 + in
33.833 + fold_rev Logic.all As
33.834 + (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd))
33.835 + end;
33.836 +
33.837 + val map_wpull_goal =
33.838 + let
33.839 + val prems = map HOLogic.mk_Trueprop
33.840 + (map8 mk_wpull Xs B1s B2s f1s f2s (replicate live NONE) p1s p2s);
33.841 + val CX = mk_bnf_T domTs CA;
33.842 + val CB1 = mk_bnf_T B1Ts CA;
33.843 + val CB2 = mk_bnf_T B2Ts CA;
33.844 + val bnf_sets_CX = map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
33.845 + val bnf_sets_CB1 = map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
33.846 + val bnf_sets_CB2 = map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
33.847 + val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
33.848 + val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
33.849 + val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
33.850 + val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
33.851 +
33.852 + val map_wpull = mk_wpull (mk_in Xs bnf_sets_CX CX)
33.853 + (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
33.854 + bnf_map_app_f1 bnf_map_app_f2 NONE bnf_map_app_p1 bnf_map_app_p2;
33.855 + in
33.856 + fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
33.857 + (Logic.list_implies (prems, HOLogic.mk_Trueprop map_wpull))
33.858 + end;
33.859 +
33.860 + val srel_O_Gr_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (srel, Rs), O_Gr));
33.861 +
33.862 + val goals = zip_axioms map_id_goal map_comp_goal map_cong_goal set_naturals_goal
33.863 + card_order_bd_goal cinfinite_bd_goal set_bds_goal in_bd_goal map_wpull_goal srel_O_Gr_goal;
33.864 +
33.865 + fun mk_wit_goals (I, wit) =
33.866 + let
33.867 + val xs = map (nth bs) I;
33.868 + fun wit_goal i =
33.869 + let
33.870 + val z = nth zs i;
33.871 + val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
33.872 + val concl = HOLogic.mk_Trueprop
33.873 + (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
33.874 + else @{term False});
33.875 + in
33.876 + fold_rev Logic.all (z :: xs)
33.877 + (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
33.878 + end;
33.879 + in
33.880 + map wit_goal (0 upto live - 1)
33.881 + end;
33.882 +
33.883 + val wit_goalss = map mk_wit_goals bnf_wit_As;
33.884 +
33.885 + fun after_qed thms lthy =
33.886 + let
33.887 + val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
33.888 +
33.889 + val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
33.890 + val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
33.891 + val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
33.892 +
33.893 + fun mk_lazy f = if fact_policy <> Derive_Few_Facts then Lazy.value (f ()) else Lazy.lazy f;
33.894 +
33.895 + fun mk_collect_set_natural () =
33.896 + let
33.897 + val defT = mk_bnf_T Ts CA --> HOLogic.mk_setT T;
33.898 + val collect_map = HOLogic.mk_comp
33.899 + (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
33.900 + Term.list_comb (mk_bnf_map As' Ts, hs));
33.901 + val image_collect = mk_collect
33.902 + (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
33.903 + defT;
33.904 + (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
33.905 + val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
33.906 + in
33.907 + Skip_Proof.prove lthy [] [] goal
33.908 + (fn {context = ctxt, ...} => mk_collect_set_natural_tac ctxt (#set_natural axioms))
33.909 + |> Thm.close_derivation
33.910 + end;
33.911 +
33.912 + val collect_set_natural = mk_lazy mk_collect_set_natural;
33.913 +
33.914 + fun mk_in_mono () =
33.915 + let
33.916 + val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_subset) As As_copy;
33.917 + val in_mono_goal =
33.918 + fold_rev Logic.all (As @ As_copy)
33.919 + (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
33.920 + (mk_subset (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
33.921 + in
33.922 + Skip_Proof.prove lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
33.923 + |> Thm.close_derivation
33.924 + end;
33.925 +
33.926 + val in_mono = mk_lazy mk_in_mono;
33.927 +
33.928 + fun mk_in_cong () =
33.929 + let
33.930 + val prems_cong = map2 (HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) As As_copy;
33.931 + val in_cong_goal =
33.932 + fold_rev Logic.all (As @ As_copy)
33.933 + (Logic.list_implies (prems_cong, HOLogic.mk_Trueprop
33.934 + (HOLogic.mk_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA'))));
33.935 + in
33.936 + Skip_Proof.prove lthy [] [] in_cong_goal (K ((TRY o hyp_subst_tac THEN' rtac refl) 1))
33.937 + |> Thm.close_derivation
33.938 + end;
33.939 +
33.940 + val in_cong = mk_lazy mk_in_cong;
33.941 +
33.942 + val map_id' = mk_lazy (fn () => mk_id' (#map_id axioms));
33.943 + val map_comp' = mk_lazy (fn () => mk_comp' (#map_comp axioms));
33.944 +
33.945 + val set_natural' =
33.946 + map (fn thm => mk_lazy (fn () => mk_set_natural' thm)) (#set_natural axioms);
33.947 +
33.948 + fun mk_map_wppull () =
33.949 + let
33.950 + val prems = if live = 0 then [] else
33.951 + [HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
33.952 + (map8 mk_wpull Xs B1s B2s f1s f2s (map SOME (e1s ~~ e2s)) p1s p2s))];
33.953 + val CX = mk_bnf_T domTs CA;
33.954 + val CB1 = mk_bnf_T B1Ts CA;
33.955 + val CB2 = mk_bnf_T B2Ts CA;
33.956 + val bnf_sets_CX =
33.957 + map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
33.958 + val bnf_sets_CB1 =
33.959 + map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
33.960 + val bnf_sets_CB2 =
33.961 + map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
33.962 + val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
33.963 + val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
33.964 + val bnf_map_app_e1 = Term.list_comb (mk_bnf_map B1Ts ranTs', e1s);
33.965 + val bnf_map_app_e2 = Term.list_comb (mk_bnf_map B2Ts ranTs'', e2s);
33.966 + val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
33.967 + val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
33.968 +
33.969 + val concl = mk_wpull (mk_in Xs bnf_sets_CX CX)
33.970 + (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
33.971 + bnf_map_app_f1 bnf_map_app_f2 (SOME (bnf_map_app_e1, bnf_map_app_e2))
33.972 + bnf_map_app_p1 bnf_map_app_p2;
33.973 +
33.974 + val goal =
33.975 + fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ e1s @ e2s @ p1s @ p2s)
33.976 + (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))
33.977 + in
33.978 + Skip_Proof.prove lthy [] [] goal
33.979 + (fn _ => mk_map_wppull_tac (#map_id axioms) (#map_cong axioms)
33.980 + (#map_wpull axioms) (Lazy.force map_comp') (map Lazy.force set_natural'))
33.981 + |> Thm.close_derivation
33.982 + end;
33.983 +
33.984 + val srel_O_Grs = no_refl [#srel_O_Gr axioms];
33.985 +
33.986 + val map_wppull = mk_lazy mk_map_wppull;
33.987 +
33.988 + fun mk_srel_Gr () =
33.989 + let
33.990 + val lhs = Term.list_comb (srel, map2 mk_Gr As fs);
33.991 + val rhs = mk_Gr (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
33.992 + val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
33.993 + in
33.994 + Skip_Proof.prove lthy [] [] goal
33.995 + (mk_srel_Gr_tac srel_O_Grs (#map_id axioms) (#map_cong axioms) (Lazy.force map_id')
33.996 + (Lazy.force map_comp') (map Lazy.force set_natural'))
33.997 + |> Thm.close_derivation
33.998 + end;
33.999 +
33.1000 + val srel_Gr = mk_lazy mk_srel_Gr;
33.1001 +
33.1002 + fun mk_srel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
33.1003 + fun mk_srel_concl f = HOLogic.mk_Trueprop
33.1004 + (f (Term.list_comb (srel, Rs), Term.list_comb (srel, Rs_copy)));
33.1005 +
33.1006 + fun mk_srel_mono () =
33.1007 + let
33.1008 + val mono_prems = mk_srel_prems mk_subset;
33.1009 + val mono_concl = mk_srel_concl (uncurry mk_subset);
33.1010 + in
33.1011 + Skip_Proof.prove lthy [] []
33.1012 + (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
33.1013 + (mk_srel_mono_tac srel_O_Grs (Lazy.force in_mono))
33.1014 + |> Thm.close_derivation
33.1015 + end;
33.1016 +
33.1017 + fun mk_srel_cong () =
33.1018 + let
33.1019 + val cong_prems = mk_srel_prems (curry HOLogic.mk_eq);
33.1020 + val cong_concl = mk_srel_concl HOLogic.mk_eq;
33.1021 + in
33.1022 + Skip_Proof.prove lthy [] []
33.1023 + (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
33.1024 + (fn _ => (TRY o hyp_subst_tac THEN' rtac refl) 1)
33.1025 + |> Thm.close_derivation
33.1026 + end;
33.1027 +
33.1028 + val srel_mono = mk_lazy mk_srel_mono;
33.1029 + val srel_cong = mk_lazy mk_srel_cong;
33.1030 +
33.1031 + fun mk_srel_Id () =
33.1032 + let val relAsAs = mk_bnf_srel self_setRTs CA' CA' in
33.1033 + Skip_Proof.prove lthy [] []
33.1034 + (HOLogic.mk_Trueprop
33.1035 + (HOLogic.mk_eq (Term.list_comb (relAsAs, map Id_const As'), Id_const CA')))
33.1036 + (mk_srel_Id_tac live (Lazy.force srel_Gr) (#map_id axioms))
33.1037 + |> Thm.close_derivation
33.1038 + end;
33.1039 +
33.1040 + val srel_Id = mk_lazy mk_srel_Id;
33.1041 +
33.1042 + fun mk_srel_converse () =
33.1043 + let
33.1044 + val relBsAs = mk_bnf_srel setRT's CB' CA';
33.1045 + val lhs = Term.list_comb (relBsAs, map mk_converse Rs);
33.1046 + val rhs = mk_converse (Term.list_comb (srel, Rs));
33.1047 + val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_subset lhs rhs));
33.1048 + val le_thm = Skip_Proof.prove lthy [] [] le_goal
33.1049 + (mk_srel_converse_le_tac srel_O_Grs (Lazy.force srel_Id) (#map_cong axioms)
33.1050 + (Lazy.force map_comp') (map Lazy.force set_natural'))
33.1051 + |> Thm.close_derivation
33.1052 + val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
33.1053 + in
33.1054 + Skip_Proof.prove lthy [] [] goal (fn _ => mk_srel_converse_tac le_thm)
33.1055 + |> Thm.close_derivation
33.1056 + end;
33.1057 +
33.1058 + val srel_converse = mk_lazy mk_srel_converse;
33.1059 +
33.1060 + fun mk_srel_O () =
33.1061 + let
33.1062 + val relAsCs = mk_bnf_srel setRTsAsCs CA' CC';
33.1063 + val relBsCs = mk_bnf_srel setRTsBsCs CB' CC';
33.1064 + val lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_comp) Rs Ss);
33.1065 + val rhs = mk_rel_comp (Term.list_comb (srel, Rs), Term.list_comb (relBsCs, Ss));
33.1066 + val goal = fold_rev Logic.all (Rs @ Ss) (mk_Trueprop_eq (lhs, rhs));
33.1067 + in
33.1068 + Skip_Proof.prove lthy [] [] goal
33.1069 + (mk_srel_O_tac srel_O_Grs (Lazy.force srel_Id) (#map_cong axioms)
33.1070 + (Lazy.force map_wppull) (Lazy.force map_comp') (map Lazy.force set_natural'))
33.1071 + |> Thm.close_derivation
33.1072 + end;
33.1073 +
33.1074 + val srel_O = mk_lazy mk_srel_O;
33.1075 +
33.1076 + fun mk_in_srel () =
33.1077 + let
33.1078 + val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
33.1079 + val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
33.1080 + val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
33.1081 + val map_fst_eq = HOLogic.mk_eq (map1 $ z, x);
33.1082 + val map_snd_eq = HOLogic.mk_eq (map2 $ z, y);
33.1083 + val lhs = HOLogic.mk_mem (HOLogic.mk_prod (x, y), Term.list_comb (srel, Rs));
33.1084 + val rhs =
33.1085 + HOLogic.mk_exists (fst z', snd z', HOLogic.mk_conj (HOLogic.mk_mem (z, bnf_in),
33.1086 + HOLogic.mk_conj (map_fst_eq, map_snd_eq)));
33.1087 + val goal =
33.1088 + fold_rev Logic.all (x :: y :: Rs) (mk_Trueprop_eq (lhs, rhs));
33.1089 + in
33.1090 + Skip_Proof.prove lthy [] [] goal (mk_in_srel_tac srel_O_Grs (length bnf_sets))
33.1091 + |> Thm.close_derivation
33.1092 + end;
33.1093 +
33.1094 + val in_srel = mk_lazy mk_in_srel;
33.1095 +
33.1096 + val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_srel_def;
33.1097 +
33.1098 + val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_natural in_cong
33.1099 + in_mono in_srel map_comp' map_id' map_wppull set_natural' srel_cong srel_mono srel_Id
33.1100 + srel_Gr srel_converse srel_O;
33.1101 +
33.1102 + val wits = map2 mk_witness bnf_wits wit_thms;
33.1103 +
33.1104 + val bnf_rel =
33.1105 + Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
33.1106 + val bnf_srel =
33.1107 + Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) srel;
33.1108 +
33.1109 + val bnf = mk_bnf b CA live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms defs facts
33.1110 + wits bnf_rel bnf_srel;
33.1111 + in
33.1112 + (bnf, lthy
33.1113 + |> (if fact_policy = Note_All_Facts_and_Axioms then
33.1114 + let
33.1115 + val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
33.1116 + val notes =
33.1117 + [(bd_card_orderN, [#bd_card_order axioms]),
33.1118 + (bd_cinfiniteN, [#bd_cinfinite axioms]),
33.1119 + (bd_Card_orderN, [#bd_Card_order facts]),
33.1120 + (bd_CinfiniteN, [#bd_Cinfinite facts]),
33.1121 + (bd_CnotzeroN, [#bd_Cnotzero facts]),
33.1122 + (collect_set_naturalN, [Lazy.force (#collect_set_natural facts)]),
33.1123 + (in_bdN, [#in_bd axioms]),
33.1124 + (in_monoN, [Lazy.force (#in_mono facts)]),
33.1125 + (in_srelN, [Lazy.force (#in_srel facts)]),
33.1126 + (map_compN, [#map_comp axioms]),
33.1127 + (map_idN, [#map_id axioms]),
33.1128 + (map_wpullN, [#map_wpull axioms]),
33.1129 + (set_naturalN, #set_natural axioms),
33.1130 + (set_bdN, #set_bd axioms)] @
33.1131 + map2 pair witNs wit_thms
33.1132 + |> map (fn (thmN, thms) =>
33.1133 + ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
33.1134 + [(thms, [])]));
33.1135 + in
33.1136 + Local_Theory.notes notes #> snd
33.1137 + end
33.1138 + else
33.1139 + I)
33.1140 + |> (if fact_policy = Note_All_Facts_and_Axioms orelse
33.1141 + fact_policy = Derive_All_Facts_Note_Most then
33.1142 + let
33.1143 + val notes =
33.1144 + [(map_comp'N, [Lazy.force (#map_comp' facts)]),
33.1145 + (map_congN, [#map_cong axioms]),
33.1146 + (map_id'N, [Lazy.force (#map_id' facts)]),
33.1147 + (set_natural'N, map Lazy.force (#set_natural' facts)),
33.1148 + (srel_O_GrN, srel_O_Grs),
33.1149 + (srel_IdN, [Lazy.force (#srel_Id facts)]),
33.1150 + (srel_GrN, [Lazy.force (#srel_Gr facts)]),
33.1151 + (srel_converseN, [Lazy.force (#srel_converse facts)]),
33.1152 + (srel_monoN, [Lazy.force (#srel_mono facts)]),
33.1153 + (srel_ON, [Lazy.force (#srel_O facts)])]
33.1154 + |> filter_out (null o #2)
33.1155 + |> map (fn (thmN, thms) =>
33.1156 + ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
33.1157 + [(thms, [])]));
33.1158 + in
33.1159 + Local_Theory.notes notes #> snd
33.1160 + end
33.1161 + else
33.1162 + I))
33.1163 + end;
33.1164 +
33.1165 + val one_step_defs =
33.1166 + no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def,
33.1167 + bnf_srel_def]);
33.1168 + in
33.1169 + (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
33.1170 + end;
33.1171 +
33.1172 +fun register_bnf key (bnf, lthy) =
33.1173 + (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
33.1174 + (fn phi => Data.map (Symtab.update_new (key, morph_bnf phi bnf))) lthy);
33.1175 +
33.1176 +(* TODO: Once the invariant "nwits > 0" holds, remove "mk_conjunction_balanced'" and "rtac TrueI"
33.1177 + below *)
33.1178 +fun mk_conjunction_balanced' [] = @{prop True}
33.1179 + | mk_conjunction_balanced' ts = Logic.mk_conjunction_balanced ts;
33.1180 +
33.1181 +fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds =
33.1182 + (fn (_, goals, wit_goalss, after_qed, lthy, one_step_defs) =>
33.1183 + let
33.1184 + val wits_tac =
33.1185 + K (TRYALL Goal.conjunction_tac) THEN' K (TRYALL (rtac TrueI)) THEN'
33.1186 + mk_unfold_thms_then_tac lthy one_step_defs wit_tac;
33.1187 + val wit_goals = map mk_conjunction_balanced' wit_goalss;
33.1188 + val wit_thms =
33.1189 + Skip_Proof.prove lthy [] [] (mk_conjunction_balanced' wit_goals) wits_tac
33.1190 + |> Conjunction.elim_balanced (length wit_goals)
33.1191 + |> map2 (Conjunction.elim_balanced o length) wit_goalss
33.1192 + |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
33.1193 + in
33.1194 + map2 (Thm.close_derivation oo Skip_Proof.prove lthy [] [])
33.1195 + goals (map (mk_unfold_thms_then_tac lthy one_step_defs) tacs)
33.1196 + |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
33.1197 + end) oo prepare_def const_policy fact_policy qualify (K I) Ds;
33.1198 +
33.1199 +val bnf_def_cmd = (fn (key, goals, wit_goals, after_qed, lthy, defs) =>
33.1200 + Proof.unfolding ([[(defs, [])]])
33.1201 + (Proof.theorem NONE (snd o register_bnf key oo after_qed)
33.1202 + (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
33.1203 + prepare_def Do_Inline (user_policy Derive_All_Facts_Note_Most) I Syntax.read_term NONE;
33.1204 +
33.1205 +fun print_bnfs ctxt =
33.1206 + let
33.1207 + fun pretty_set sets i = Pretty.block
33.1208 + [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
33.1209 + Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
33.1210 +
33.1211 + fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
33.1212 + live = live, lives = lives, dead = dead, deads = deads, ...}) =
33.1213 + Pretty.big_list
33.1214 + (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
33.1215 + Pretty.quote (Syntax.pretty_typ ctxt T)]))
33.1216 + ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
33.1217 + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
33.1218 + Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
33.1219 + Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
33.1220 + Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
33.1221 + Pretty.quote (Syntax.pretty_term ctxt map)]] @
33.1222 + List.map (pretty_set sets) (0 upto length sets - 1) @
33.1223 + [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
33.1224 + Pretty.quote (Syntax.pretty_term ctxt bd)]]);
33.1225 + in
33.1226 + Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
33.1227 + |> Pretty.writeln
33.1228 + end;
33.1229 +
33.1230 +val _ =
33.1231 + Outer_Syntax.improper_command @{command_spec "print_bnfs"} "print all BNFs"
33.1232 + (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
33.1233 +
33.1234 +val _ =
33.1235 + Outer_Syntax.local_theory_to_proof @{command_spec "bnf_def"} "define a BNF for an existing type"
33.1236 + ((parse_opt_binding_colon -- Parse.term --
33.1237 + (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Parse.term --
33.1238 + (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Scan.option Parse.term)
33.1239 + >> bnf_def_cmd);
33.1240 +
33.1241 +end;
34.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
34.2 +++ b/src/HOL/BNF/Tools/bnf_def_tactics.ML Fri Sep 21 16:45:06 2012 +0200
34.3 @@ -0,0 +1,209 @@
34.4 +(* Title: HOL/BNF/Tools/bnf_def_tactics.ML
34.5 + Author: Dmitriy Traytel, TU Muenchen
34.6 + Author: Jasmin Blanchette, TU Muenchen
34.7 + Copyright 2012
34.8 +
34.9 +Tactics for definition of bounded natural functors.
34.10 +*)
34.11 +
34.12 +signature BNF_DEF_TACTICS =
34.13 +sig
34.14 + val mk_collect_set_natural_tac: Proof.context -> thm list -> tactic
34.15 + val mk_id': thm -> thm
34.16 + val mk_comp': thm -> thm
34.17 + val mk_in_mono_tac: int -> tactic
34.18 + val mk_map_wppull_tac: thm -> thm -> thm -> thm -> thm list -> tactic
34.19 + val mk_set_natural': thm -> thm
34.20 +
34.21 + val mk_srel_Gr_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
34.22 + {prems: thm list, context: Proof.context} -> tactic
34.23 + val mk_srel_Id_tac: int -> thm -> thm -> {prems: 'a, context: Proof.context} -> tactic
34.24 + val mk_srel_O_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
34.25 + {prems: thm list, context: Proof.context} -> tactic
34.26 + val mk_in_srel_tac: thm list -> int -> {prems: 'b, context: Proof.context} -> tactic
34.27 + val mk_srel_converse_tac: thm -> tactic
34.28 + val mk_srel_converse_le_tac: thm list -> thm -> thm -> thm -> thm list ->
34.29 + {prems: thm list, context: Proof.context} -> tactic
34.30 + val mk_srel_mono_tac: thm list -> thm -> {prems: 'a, context: Proof.context} -> tactic
34.31 +end;
34.32 +
34.33 +structure BNF_Def_Tactics : BNF_DEF_TACTICS =
34.34 +struct
34.35 +
34.36 +open BNF_Util
34.37 +open BNF_Tactics
34.38 +
34.39 +fun mk_id' id = mk_trans (fun_cong OF [id]) @{thm id_apply};
34.40 +fun mk_comp' comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
34.41 +fun mk_set_natural' set_natural = set_natural RS @{thm pointfreeE};
34.42 +fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
34.43 + else (rtac subsetI THEN'
34.44 + rtac CollectI) 1 THEN
34.45 + REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
34.46 + REPEAT_DETERM_N (n - 1)
34.47 + ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
34.48 + (etac subset_trans THEN' atac) 1;
34.49 +
34.50 +fun mk_collect_set_natural_tac ctxt set_naturals =
34.51 + substs_tac ctxt (@{thms collect_o image_insert image_empty} @ set_naturals) 1 THEN rtac refl 1;
34.52 +
34.53 +fun mk_map_wppull_tac map_id map_cong map_wpull map_comp set_naturals =
34.54 + if null set_naturals then
34.55 + EVERY' [rtac @{thm wppull_id}, rtac map_wpull, rtac map_id, rtac map_id] 1
34.56 + else EVERY' [REPEAT_DETERM o etac conjE, REPEAT_DETERM o dtac @{thm wppull_thePull},
34.57 + REPEAT_DETERM o etac exE, rtac @{thm wpull_wppull}, rtac map_wpull,
34.58 + REPEAT_DETERM o rtac @{thm wpull_thePull}, rtac ballI,
34.59 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac CollectI,
34.60 + CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
34.61 + rtac @{thm image_subsetI}, rtac conjunct1, etac bspec, etac set_mp, atac])
34.62 + set_naturals,
34.63 + CONJ_WRAP' (fn thm => EVERY' [rtac (map_comp RS trans), rtac (map_comp RS trans),
34.64 + rtac (map_comp RS trans RS sym), rtac map_cong,
34.65 + REPEAT_DETERM_N (length set_naturals) o EVERY' [rtac (o_apply RS trans),
34.66 + rtac (o_apply RS trans RS sym), rtac (o_apply RS trans), rtac thm,
34.67 + rtac conjunct2, etac bspec, etac set_mp, atac]]) [conjunct1, conjunct2]] 1;
34.68 +
34.69 +fun mk_srel_Gr_tac srel_O_Grs map_id map_cong map_id' map_comp set_naturals
34.70 + {context = ctxt, prems = _} =
34.71 + let
34.72 + val n = length set_naturals;
34.73 + in
34.74 + if null set_naturals then
34.75 + unfold_thms_tac ctxt srel_O_Grs THEN EVERY' [rtac @{thm Gr_UNIV_id}, rtac map_id] 1
34.76 + else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
34.77 + EVERY' [rtac equalityI, rtac subsetI,
34.78 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
34.79 + REPEAT_DETERM o dtac Pair_eqD,
34.80 + REPEAT_DETERM o etac conjE, hyp_subst_tac,
34.81 + rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
34.82 + rtac sym, rtac trans, rtac map_comp, rtac map_cong,
34.83 + REPEAT_DETERM_N n o EVERY' [dtac @{thm set_rev_mp}, atac,
34.84 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
34.85 + rtac (o_apply RS trans), rtac (@{thm fst_conv} RS arg_cong RS trans),
34.86 + rtac (@{thm snd_conv} RS sym)],
34.87 + rtac CollectI,
34.88 + CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
34.89 + rtac @{thm image_subsetI}, dtac @{thm set_rev_mp}, atac,
34.90 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
34.91 + stac @{thm fst_conv}, atac]) set_naturals,
34.92 + rtac @{thm subrelI}, etac CollectE, REPEAT_DETERM o eresolve_tac [exE, conjE],
34.93 + REPEAT_DETERM o dtac Pair_eqD,
34.94 + REPEAT_DETERM o etac conjE, hyp_subst_tac,
34.95 + rtac @{thm relcompI}, rtac @{thm converseI},
34.96 + EVERY' (map2 (fn convol => fn map_id =>
34.97 + EVERY' [rtac CollectI, rtac exI, rtac conjI,
34.98 + rtac Pair_eqI, rtac conjI, rtac refl, rtac sym,
34.99 + rtac (box_equals OF [map_cong, map_comp RS sym, map_id]),
34.100 + REPEAT_DETERM_N n o rtac (convol RS fun_cong),
34.101 + REPEAT_DETERM o eresolve_tac [CollectE, conjE],
34.102 + rtac CollectI,
34.103 + CONJ_WRAP' (fn thm =>
34.104 + EVERY' [rtac @{thm ord_eq_le_trans}, rtac thm, rtac @{thm image_subsetI},
34.105 + rtac @{thm convol_memI[of id _ "%x. x", OF id_apply refl]}, etac set_mp, atac])
34.106 + set_naturals])
34.107 + @{thms fst_convol snd_convol} [map_id', refl])] 1
34.108 + end;
34.109 +
34.110 +fun mk_srel_Id_tac n srel_Gr map_id {context = ctxt, prems = _} =
34.111 + unfold_thms_tac ctxt [srel_Gr, @{thm Id_alt}] THEN
34.112 + subst_tac ctxt [map_id] 1 THEN
34.113 + (if n = 0 then rtac refl 1
34.114 + else EVERY' [rtac @{thm arg_cong2[of _ _ _ _ Gr]},
34.115 + rtac equalityI, rtac subset_UNIV, rtac subsetI, rtac CollectI,
34.116 + CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto n), rtac refl] 1);
34.117 +
34.118 +fun mk_srel_mono_tac srel_O_Grs in_mono {context = ctxt, prems = _} =
34.119 + unfold_thms_tac ctxt srel_O_Grs THEN
34.120 + EVERY' [rtac @{thm relcomp_mono}, rtac @{thm iffD2[OF converse_mono]},
34.121 + rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac,
34.122 + rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac] 1;
34.123 +
34.124 +fun mk_srel_converse_le_tac srel_O_Grs srel_Id map_cong map_comp set_naturals
34.125 + {context = ctxt, prems = _} =
34.126 + let
34.127 + val n = length set_naturals;
34.128 + in
34.129 + if null set_naturals then
34.130 + unfold_thms_tac ctxt [srel_Id] THEN rtac equalityD2 1 THEN rtac @{thm converse_Id} 1
34.131 + else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
34.132 + EVERY' [rtac @{thm subrelI},
34.133 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
34.134 + REPEAT_DETERM o dtac Pair_eqD,
34.135 + REPEAT_DETERM o etac conjE, hyp_subst_tac, rtac @{thm converseI},
34.136 + rtac @{thm relcompI}, rtac @{thm converseI},
34.137 + EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
34.138 + rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac trans,
34.139 + rtac map_cong, REPEAT_DETERM_N n o rtac thm,
34.140 + rtac (map_comp RS sym), rtac CollectI,
34.141 + CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
34.142 + etac @{thm flip_rel}]) set_naturals]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
34.143 + end;
34.144 +
34.145 +fun mk_srel_converse_tac le_converse =
34.146 + EVERY' [rtac equalityI, rtac le_converse, rtac @{thm xt1(6)}, rtac @{thm converse_shift},
34.147 + rtac le_converse, REPEAT_DETERM o stac @{thm converse_converse}, rtac subset_refl] 1;
34.148 +
34.149 +fun mk_srel_O_tac srel_O_Grs srel_Id map_cong map_wppull map_comp set_naturals
34.150 + {context = ctxt, prems = _} =
34.151 + let
34.152 + val n = length set_naturals;
34.153 + fun in_tac nthO_in = rtac CollectI THEN'
34.154 + CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
34.155 + rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_naturals;
34.156 + in
34.157 + if null set_naturals then unfold_thms_tac ctxt [srel_Id] THEN rtac (@{thm Id_O_R} RS sym) 1
34.158 + else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
34.159 + EVERY' [rtac equalityI, rtac @{thm subrelI},
34.160 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
34.161 + REPEAT_DETERM o dtac Pair_eqD,
34.162 + REPEAT_DETERM o etac conjE, hyp_subst_tac,
34.163 + rtac @{thm relcompI}, rtac @{thm relcompI}, rtac @{thm converseI},
34.164 + rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
34.165 + rtac sym, rtac trans, rtac map_comp, rtac sym, rtac map_cong,
34.166 + REPEAT_DETERM_N n o rtac @{thm fst_fstO},
34.167 + in_tac @{thm fstO_in},
34.168 + rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
34.169 + rtac sym, rtac trans, rtac map_comp, rtac map_cong,
34.170 + REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, rtac ballE, rtac subst,
34.171 + rtac @{thm csquare_def}, rtac @{thm csquare_fstO_sndO}, atac, etac notE,
34.172 + etac set_mp, atac],
34.173 + in_tac @{thm fstO_in},
34.174 + rtac @{thm relcompI}, rtac @{thm converseI},
34.175 + rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
34.176 + rtac sym, rtac trans, rtac map_comp, rtac map_cong,
34.177 + REPEAT_DETERM_N n o rtac o_apply,
34.178 + in_tac @{thm sndO_in},
34.179 + rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
34.180 + rtac sym, rtac trans, rtac map_comp, rtac sym, rtac map_cong,
34.181 + REPEAT_DETERM_N n o rtac @{thm snd_sndO},
34.182 + in_tac @{thm sndO_in},
34.183 + rtac @{thm subrelI},
34.184 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm relcompE}, @{thm converseE}],
34.185 + REPEAT_DETERM o eresolve_tac [exE, conjE],
34.186 + REPEAT_DETERM o dtac Pair_eqD,
34.187 + REPEAT_DETERM o etac conjE, hyp_subst_tac,
34.188 + rtac allE, rtac subst, rtac @{thm wppull_def}, rtac map_wppull,
34.189 + CONJ_WRAP' (K (rtac @{thm wppull_fstO_sndO})) set_naturals,
34.190 + etac allE, etac impE, etac conjI, etac conjI, atac,
34.191 + REPEAT_DETERM o eresolve_tac [bexE, conjE],
34.192 + rtac @{thm relcompI}, rtac @{thm converseI},
34.193 + EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
34.194 + rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac sym, rtac trans,
34.195 + rtac trans, rtac map_cong, REPEAT_DETERM_N n o rtac thm,
34.196 + rtac (map_comp RS sym), atac, atac]) [@{thm fst_fstO}, @{thm snd_sndO}])] 1
34.197 + end;
34.198 +
34.199 +fun mk_in_srel_tac srel_O_Grs m {context = ctxt, prems = _} =
34.200 + let
34.201 + val ls' = replicate (Int.max (1, m)) ();
34.202 + in
34.203 + unfold_thms_tac ctxt (srel_O_Grs @
34.204 + @{thms Gr_def converse_unfold relcomp_unfold mem_Collect_eq prod.cases Pair_eq}) THEN
34.205 + EVERY' [rtac iffI, REPEAT_DETERM o eresolve_tac [exE, conjE], hyp_subst_tac, rtac exI,
34.206 + rtac conjI, CONJ_WRAP' (K atac) ls', rtac conjI, rtac refl, rtac refl,
34.207 + REPEAT_DETERM o eresolve_tac [exE, conjE], rtac exI, rtac conjI,
34.208 + REPEAT_DETERM_N 2 o EVERY' [rtac exI, rtac conjI, etac @{thm conjI[OF refl sym]},
34.209 + CONJ_WRAP' (K atac) ls']] 1
34.210 + end;
34.211 +
34.212 +end;
35.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
35.2 +++ b/src/HOL/BNF/Tools/bnf_fp.ML Fri Sep 21 16:45:06 2012 +0200
35.3 @@ -0,0 +1,442 @@
35.4 +(* Title: HOL/BNF/Tools/bnf_fp.ML
35.5 + Author: Dmitriy Traytel, TU Muenchen
35.6 + Copyright 2012
35.7 +
35.8 +Shared library for the datatype and codatatype constructions.
35.9 +*)
35.10 +
35.11 +signature BNF_FP =
35.12 +sig
35.13 + val time: Timer.real_timer -> string -> Timer.real_timer
35.14 +
35.15 + val IITN: string
35.16 + val LevN: string
35.17 + val algN: string
35.18 + val behN: string
35.19 + val bisN: string
35.20 + val carTN: string
35.21 + val caseN: string
35.22 + val coN: string
35.23 + val coinductN: string
35.24 + val corecN: string
35.25 + val corecsN: string
35.26 + val ctorN: string
35.27 + val ctor_dtorN: string
35.28 + val ctor_dtor_unfoldsN: string
35.29 + val ctor_dtor_corecsN: string
35.30 + val ctor_exhaustN: string
35.31 + val ctor_induct2N: string
35.32 + val ctor_inductN: string
35.33 + val ctor_injectN: string
35.34 + val ctor_foldN: string
35.35 + val ctor_fold_uniqueN: string
35.36 + val ctor_foldsN: string
35.37 + val ctor_recN: string
35.38 + val ctor_recsN: string
35.39 + val disc_unfold_iffN: string
35.40 + val disc_unfoldsN: string
35.41 + val disc_corec_iffN: string
35.42 + val disc_corecsN: string
35.43 + val dtorN: string
35.44 + val dtor_coinductN: string
35.45 + val dtor_unfoldN: string
35.46 + val dtor_unfold_uniqueN: string
35.47 + val dtor_unfoldsN: string
35.48 + val dtor_corecN: string
35.49 + val dtor_corecsN: string
35.50 + val dtor_exhaustN: string
35.51 + val dtor_ctorN: string
35.52 + val dtor_injectN: string
35.53 + val dtor_strong_coinductN: string
35.54 + val exhaustN: string
35.55 + val foldN: string
35.56 + val foldsN: string
35.57 + val hsetN: string
35.58 + val hset_recN: string
35.59 + val inductN: string
35.60 + val injectN: string
35.61 + val isNodeN: string
35.62 + val lsbisN: string
35.63 + val map_simpsN: string
35.64 + val map_uniqueN: string
35.65 + val min_algN: string
35.66 + val morN: string
35.67 + val nchotomyN: string
35.68 + val recN: string
35.69 + val recsN: string
35.70 + val rel_coinductN: string
35.71 + val rel_simpN: string
35.72 + val rel_strong_coinductN: string
35.73 + val rvN: string
35.74 + val sel_unfoldsN: string
35.75 + val sel_corecsN: string
35.76 + val set_inclN: string
35.77 + val set_set_inclN: string
35.78 + val simpsN: string
35.79 + val srel_coinductN: string
35.80 + val srel_simpN: string
35.81 + val srel_strong_coinductN: string
35.82 + val strTN: string
35.83 + val str_initN: string
35.84 + val strongN: string
35.85 + val sum_bdN: string
35.86 + val sum_bdTN: string
35.87 + val unfoldN: string
35.88 + val unfoldsN: string
35.89 + val uniqueN: string
35.90 +
35.91 + val mk_exhaustN: string -> string
35.92 + val mk_injectN: string -> string
35.93 + val mk_nchotomyN: string -> string
35.94 + val mk_set_simpsN: int -> string
35.95 + val mk_set_minimalN: int -> string
35.96 + val mk_set_inductN: int -> string
35.97 +
35.98 + val mk_common_name: string list -> string
35.99 +
35.100 + val split_conj_thm: thm -> thm list
35.101 + val split_conj_prems: int -> thm -> thm
35.102 +
35.103 + val retype_free: typ -> term -> term
35.104 +
35.105 + val mk_sumTN: typ list -> typ
35.106 + val mk_sumTN_balanced: typ list -> typ
35.107 +
35.108 + val id_const: typ -> term
35.109 + val id_abs: typ -> term
35.110 +
35.111 + val Inl_const: typ -> typ -> term
35.112 + val Inr_const: typ -> typ -> term
35.113 +
35.114 + val mk_Inl: typ -> term -> term
35.115 + val mk_Inr: typ -> term -> term
35.116 + val mk_InN: typ list -> term -> int -> term
35.117 + val mk_InN_balanced: typ -> int -> term -> int -> term
35.118 + val mk_sum_case: term * term -> term
35.119 + val mk_sum_caseN: term list -> term
35.120 + val mk_sum_caseN_balanced: term list -> term
35.121 +
35.122 + val dest_sumT: typ -> typ * typ
35.123 + val dest_sumTN: int -> typ -> typ list
35.124 + val dest_sumTN_balanced: int -> typ -> typ list
35.125 + val dest_tupleT: int -> typ -> typ list
35.126 +
35.127 + val mk_Field: term -> term
35.128 + val mk_If: term -> term -> term -> term
35.129 + val mk_union: term * term -> term
35.130 +
35.131 + val mk_sumEN: int -> thm
35.132 + val mk_sumEN_balanced: int -> thm
35.133 + val mk_sumEN_tupled_balanced: int list -> thm
35.134 + val mk_sum_casesN: int -> int -> thm
35.135 + val mk_sum_casesN_balanced: int -> int -> thm
35.136 +
35.137 + val fixpoint: ('a * 'a -> bool) -> ('a list -> 'a list) -> 'a list -> 'a list
35.138 +
35.139 + val fp_bnf: (mixfix list -> (string * sort) list option -> binding list ->
35.140 + typ list * typ list list -> BNF_Def.BNF list -> local_theory -> 'a) ->
35.141 + binding list -> mixfix list -> (string * sort) list -> ((string * sort) * typ) list ->
35.142 + local_theory -> BNF_Def.BNF list * 'a
35.143 + val fp_bnf_cmd: (mixfix list -> (string * sort) list option -> binding list ->
35.144 + typ list * typ list list -> BNF_Def.BNF list -> local_theory -> 'a) ->
35.145 + binding list * (string list * string list) -> local_theory -> 'a
35.146 +end;
35.147 +
35.148 +structure BNF_FP : BNF_FP =
35.149 +struct
35.150 +
35.151 +open BNF_Comp
35.152 +open BNF_Def
35.153 +open BNF_Util
35.154 +
35.155 +val timing = true;
35.156 +fun time timer msg = (if timing
35.157 + then warning (msg ^ ": " ^ ATP_Util.string_from_time (Timer.checkRealTimer timer))
35.158 + else (); Timer.startRealTimer ());
35.159 +
35.160 +val preN = "pre_"
35.161 +val rawN = "raw_"
35.162 +
35.163 +val coN = "co"
35.164 +val unN = "un"
35.165 +val algN = "alg"
35.166 +val IITN = "IITN"
35.167 +val foldN = "fold"
35.168 +val foldsN = foldN ^ "s"
35.169 +val unfoldN = unN ^ foldN
35.170 +val unfoldsN = unfoldN ^ "s"
35.171 +val uniqueN = "_unique"
35.172 +val simpsN = "simps"
35.173 +val ctorN = "ctor"
35.174 +val dtorN = "dtor"
35.175 +val ctor_foldN = ctorN ^ "_" ^ foldN
35.176 +val ctor_foldsN = ctor_foldN ^ "s"
35.177 +val dtor_unfoldN = dtorN ^ "_" ^ unfoldN
35.178 +val dtor_unfoldsN = dtor_unfoldN ^ "s"
35.179 +val ctor_fold_uniqueN = ctor_foldN ^ uniqueN
35.180 +val dtor_unfold_uniqueN = dtor_unfoldN ^ uniqueN
35.181 +val ctor_dtor_unfoldsN = ctorN ^ "_" ^ dtor_unfoldN ^ "s"
35.182 +val map_simpsN = mapN ^ "_" ^ simpsN
35.183 +val map_uniqueN = mapN ^ uniqueN
35.184 +val min_algN = "min_alg"
35.185 +val morN = "mor"
35.186 +val bisN = "bis"
35.187 +val lsbisN = "lsbis"
35.188 +val sum_bdTN = "sbdT"
35.189 +val sum_bdN = "sbd"
35.190 +val carTN = "carT"
35.191 +val strTN = "strT"
35.192 +val isNodeN = "isNode"
35.193 +val LevN = "Lev"
35.194 +val rvN = "recover"
35.195 +val behN = "beh"
35.196 +fun mk_set_simpsN i = mk_setN i ^ "_" ^ simpsN
35.197 +fun mk_set_minimalN i = mk_setN i ^ "_minimal"
35.198 +fun mk_set_inductN i = mk_setN i ^ "_induct"
35.199 +
35.200 +val str_initN = "str_init"
35.201 +val recN = "rec"
35.202 +val recsN = recN ^ "s"
35.203 +val corecN = coN ^ recN
35.204 +val corecsN = corecN ^ "s"
35.205 +val ctor_recN = ctorN ^ "_" ^ recN
35.206 +val ctor_recsN = ctor_recN ^ "s"
35.207 +val dtor_corecN = dtorN ^ "_" ^ corecN
35.208 +val dtor_corecsN = dtor_corecN ^ "s"
35.209 +val ctor_dtor_corecsN = ctorN ^ "_" ^ dtor_corecN ^ "s"
35.210 +
35.211 +val ctor_dtorN = ctorN ^ "_" ^ dtorN
35.212 +val dtor_ctorN = dtorN ^ "_" ^ ctorN
35.213 +val nchotomyN = "nchotomy"
35.214 +fun mk_nchotomyN s = s ^ "_" ^ nchotomyN
35.215 +val injectN = "inject"
35.216 +fun mk_injectN s = s ^ "_" ^ injectN
35.217 +val exhaustN = "exhaust"
35.218 +fun mk_exhaustN s = s ^ "_" ^ exhaustN
35.219 +val ctor_injectN = mk_injectN ctorN
35.220 +val ctor_exhaustN = mk_exhaustN ctorN
35.221 +val dtor_injectN = mk_injectN dtorN
35.222 +val dtor_exhaustN = mk_exhaustN dtorN
35.223 +val inductN = "induct"
35.224 +val coinductN = coN ^ inductN
35.225 +val ctor_inductN = ctorN ^ "_" ^ inductN
35.226 +val ctor_induct2N = ctor_inductN ^ "2"
35.227 +val dtor_coinductN = dtorN ^ "_" ^ coinductN
35.228 +val rel_coinductN = relN ^ "_" ^ coinductN
35.229 +val srel_coinductN = srelN ^ "_" ^ coinductN
35.230 +val simpN = "_simp";
35.231 +val srel_simpN = srelN ^ simpN;
35.232 +val rel_simpN = relN ^ simpN;
35.233 +val strongN = "strong_"
35.234 +val dtor_strong_coinductN = dtorN ^ "_" ^ strongN ^ coinductN
35.235 +val rel_strong_coinductN = relN ^ "_" ^ strongN ^ coinductN
35.236 +val srel_strong_coinductN = srelN ^ "_" ^ strongN ^ coinductN
35.237 +val hsetN = "Hset"
35.238 +val hset_recN = hsetN ^ "_rec"
35.239 +val set_inclN = "set_incl"
35.240 +val set_set_inclN = "set_set_incl"
35.241 +
35.242 +val caseN = "case"
35.243 +val discN = "disc"
35.244 +val disc_unfoldsN = discN ^ "_" ^ unfoldsN
35.245 +val disc_corecsN = discN ^ "_" ^ corecsN
35.246 +val iffN = "_iff"
35.247 +val disc_unfold_iffN = discN ^ "_" ^ unfoldN ^ iffN
35.248 +val disc_corec_iffN = discN ^ "_" ^ corecN ^ iffN
35.249 +val selN = "sel"
35.250 +val sel_unfoldsN = selN ^ "_" ^ unfoldsN
35.251 +val sel_corecsN = selN ^ "_" ^ corecsN
35.252 +
35.253 +val mk_common_name = space_implode "_";
35.254 +
35.255 +fun retype_free T (Free (s, _)) = Free (s, T);
35.256 +
35.257 +fun dest_sumT (Type (@{type_name sum}, [T, T'])) = (T, T');
35.258 +
35.259 +fun dest_sumTN 1 T = [T]
35.260 + | dest_sumTN n (Type (@{type_name sum}, [T, T'])) = T :: dest_sumTN (n - 1) T';
35.261 +
35.262 +val dest_sumTN_balanced = Balanced_Tree.dest dest_sumT;
35.263 +
35.264 +(* TODO: move something like this to "HOLogic"? *)
35.265 +fun dest_tupleT 0 @{typ unit} = []
35.266 + | dest_tupleT 1 T = [T]
35.267 + | dest_tupleT n (Type (@{type_name prod}, [T, T'])) = T :: dest_tupleT (n - 1) T';
35.268 +
35.269 +val mk_sumTN = Library.foldr1 mk_sumT;
35.270 +val mk_sumTN_balanced = Balanced_Tree.make mk_sumT;
35.271 +
35.272 +fun id_const T = Const (@{const_name id}, T --> T);
35.273 +fun id_abs T = Abs (Name.uu, T, Bound 0);
35.274 +
35.275 +fun Inl_const LT RT = Const (@{const_name Inl}, LT --> mk_sumT (LT, RT));
35.276 +fun mk_Inl RT t = Inl_const (fastype_of t) RT $ t;
35.277 +
35.278 +fun Inr_const LT RT = Const (@{const_name Inr}, RT --> mk_sumT (LT, RT));
35.279 +fun mk_Inr LT t = Inr_const LT (fastype_of t) $ t;
35.280 +
35.281 +fun mk_InN [_] t 1 = t
35.282 + | mk_InN (_ :: Ts) t 1 = mk_Inl (mk_sumTN Ts) t
35.283 + | mk_InN (LT :: Ts) t m = mk_Inr LT (mk_InN Ts t (m - 1))
35.284 + | mk_InN Ts t _ = raise (TYPE ("mk_InN", Ts, [t]));
35.285 +
35.286 +fun mk_InN_balanced sum_T n t k =
35.287 + let
35.288 + fun repair_types T (Const (s as @{const_name Inl}, _) $ t) = repair_inj_types T s fst t
35.289 + | repair_types T (Const (s as @{const_name Inr}, _) $ t) = repair_inj_types T s snd t
35.290 + | repair_types _ t = t
35.291 + and repair_inj_types T s get t =
35.292 + let val T' = get (dest_sumT T) in
35.293 + Const (s, T' --> T) $ repair_types T' t
35.294 + end;
35.295 + in
35.296 + Balanced_Tree.access {left = mk_Inl dummyT, right = mk_Inr dummyT, init = t} n k
35.297 + |> repair_types sum_T
35.298 + end;
35.299 +
35.300 +fun mk_sum_case (f, g) =
35.301 + let
35.302 + val fT = fastype_of f;
35.303 + val gT = fastype_of g;
35.304 + in
35.305 + Const (@{const_name sum_case},
35.306 + fT --> gT --> mk_sumT (domain_type fT, domain_type gT) --> range_type fT) $ f $ g
35.307 + end;
35.308 +
35.309 +val mk_sum_caseN = Library.foldr1 mk_sum_case;
35.310 +val mk_sum_caseN_balanced = Balanced_Tree.make mk_sum_case;
35.311 +
35.312 +fun mk_If p t f =
35.313 + let val T = fastype_of t;
35.314 + in Const (@{const_name If}, HOLogic.boolT --> T --> T --> T) $ p $ t $ f end;
35.315 +
35.316 +fun mk_Field r =
35.317 + let val T = fst (dest_relT (fastype_of r));
35.318 + in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
35.319 +
35.320 +val mk_union = HOLogic.mk_binop @{const_name sup};
35.321 +
35.322 +(*dangerous; use with monotonic, converging functions only!*)
35.323 +fun fixpoint eq f X = if subset eq (f X, X) then X else fixpoint eq f (f X);
35.324 +
35.325 +(* stolen from "~~/src/HOL/Tools/Datatype/datatype_aux.ML" *)
35.326 +fun split_conj_thm th =
35.327 + ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
35.328 +
35.329 +fun split_conj_prems limit th =
35.330 + let
35.331 + fun split n i th =
35.332 + if i = n then th else split n (i + 1) (conjI RSN (i, th)) handle THM _ => th;
35.333 + in split limit 1 th end;
35.334 +
35.335 +fun mk_sumEN 1 = @{thm one_pointE}
35.336 + | mk_sumEN 2 = @{thm sumE}
35.337 + | mk_sumEN n =
35.338 + (fold (fn i => fn thm => @{thm obj_sum_step} RSN (i, thm)) (2 upto n - 1) @{thm obj_sumE}) OF
35.339 + replicate n (impI RS allI);
35.340 +
35.341 +fun mk_obj_sumEN_balanced n =
35.342 + Balanced_Tree.make (fn (thm1, thm2) => thm1 RSN (1, thm2 RSN (2, @{thm obj_sumE_f})))
35.343 + (replicate n asm_rl);
35.344 +
35.345 +fun mk_sumEN_balanced' n all_impIs = mk_obj_sumEN_balanced n OF all_impIs RS @{thm obj_one_pointE};
35.346 +
35.347 +fun mk_sumEN_balanced 1 = @{thm one_pointE} (*optimization*)
35.348 + | mk_sumEN_balanced 2 = @{thm sumE} (*optimization*)
35.349 + | mk_sumEN_balanced n = mk_sumEN_balanced' n (replicate n (impI RS allI));
35.350 +
35.351 +fun mk_tupled_allIN 0 = @{thm unit_all_impI}
35.352 + | mk_tupled_allIN 1 = @{thm impI[THEN allI]}
35.353 + | mk_tupled_allIN 2 = @{thm prod_all_impI} (*optimization*)
35.354 + | mk_tupled_allIN n = mk_tupled_allIN (n - 1) RS @{thm prod_all_impI_step};
35.355 +
35.356 +fun mk_sumEN_tupled_balanced ms =
35.357 + let val n = length ms in
35.358 + if forall (curry (op =) 1) ms then mk_sumEN_balanced n
35.359 + else mk_sumEN_balanced' n (map mk_tupled_allIN ms)
35.360 + end;
35.361 +
35.362 +fun mk_sum_casesN 1 1 = refl
35.363 + | mk_sum_casesN _ 1 = @{thm sum.cases(1)}
35.364 + | mk_sum_casesN 2 2 = @{thm sum.cases(2)}
35.365 + | mk_sum_casesN n k = trans OF [@{thm sum_case_step(2)}, mk_sum_casesN (n - 1) (k - 1)];
35.366 +
35.367 +fun mk_sum_step base step thm =
35.368 + if Thm.eq_thm_prop (thm, refl) then base else trans OF [step, thm];
35.369 +
35.370 +fun mk_sum_casesN_balanced 1 1 = refl
35.371 + | mk_sum_casesN_balanced n k =
35.372 + Balanced_Tree.access {left = mk_sum_step @{thm sum.cases(1)} @{thm sum_case_step(1)},
35.373 + right = mk_sum_step @{thm sum.cases(2)} @{thm sum_case_step(2)}, init = refl} n k;
35.374 +
35.375 +(* FIXME: because of "@ lhss", the output could contain type variables that are not in the input;
35.376 + also, "fp_sort" should put the "resBs" first and in the order in which they appear *)
35.377 +fun fp_sort lhss NONE Ass = Library.sort (Term_Ord.typ_ord o pairself TFree)
35.378 + (subtract (op =) lhss (fold (fold (insert (op =))) Ass [])) @ lhss
35.379 + | fp_sort lhss (SOME resBs) Ass =
35.380 + (subtract (op =) lhss (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs)) @ lhss;
35.381 +
35.382 +fun mk_fp_bnf timer construct resBs bs sort lhss bnfs deadss livess unfold_set lthy =
35.383 + let
35.384 + val name = mk_common_name (map Binding.name_of bs);
35.385 + fun qualify i =
35.386 + let val namei = name ^ nonzero_string_of_int i;
35.387 + in Binding.qualify true namei end;
35.388 +
35.389 + val Ass = map (map dest_TFree) livess;
35.390 + val resDs = (case resBs of NONE => [] | SOME Ts => fold (subtract (op =)) Ass Ts);
35.391 + val Ds = fold (fold Term.add_tfreesT) deadss [];
35.392 +
35.393 + val _ = (case Library.inter (op =) Ds lhss of [] => ()
35.394 + | A :: _ => error ("Nonadmissible type recursion (cannot take fixed point of dead type \
35.395 + \variable " ^ quote (Syntax.string_of_typ lthy (TFree A)) ^ ")"));
35.396 +
35.397 + val timer = time (timer "Construction of BNFs");
35.398 +
35.399 + val ((kill_poss, _), (bnfs', (unfold_set', lthy'))) =
35.400 + normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy;
35.401 +
35.402 + val Dss = map3 (append oo map o nth) livess kill_poss deadss;
35.403 +
35.404 + val ((bnfs'', deadss), lthy'') =
35.405 + fold_map3 (seal_bnf unfold_set') (map (Binding.prefix_name preN) bs) Dss bnfs' lthy'
35.406 + |>> split_list;
35.407 +
35.408 + val timer = time (timer "Normalization & sealing of BNFs");
35.409 +
35.410 + val res = construct resBs bs (map TFree resDs, deadss) bnfs'' lthy'';
35.411 +
35.412 + val timer = time (timer "FP construction in total");
35.413 + in
35.414 + timer; (bnfs'', res)
35.415 + end;
35.416 +
35.417 +fun fp_bnf construct bs mixfixes resBs eqs lthy =
35.418 + let
35.419 + val timer = time (Timer.startRealTimer ());
35.420 + val (lhss, rhss) = split_list eqs;
35.421 + val sort = fp_sort lhss (SOME resBs);
35.422 + fun qualify b = Binding.qualify true (Binding.name_of (Binding.prefix_name rawN b));
35.423 + val ((bnfs, (Dss, Ass)), (unfold_set, lthy')) = apfst (apsnd split_list o split_list)
35.424 + (fold_map2 (fn b => bnf_of_typ Smart_Inline (qualify b) sort) bs rhss
35.425 + (empty_unfolds, lthy));
35.426 + in
35.427 + mk_fp_bnf timer (construct mixfixes) (SOME resBs) bs sort lhss bnfs Dss Ass unfold_set lthy'
35.428 + end;
35.429 +
35.430 +fun fp_bnf_cmd construct (bs, (raw_lhss, raw_bnfs)) lthy =
35.431 + let
35.432 + val timer = time (Timer.startRealTimer ());
35.433 + val lhss = map (dest_TFree o Syntax.read_typ lthy) raw_lhss;
35.434 + val sort = fp_sort lhss NONE;
35.435 + fun qualify b = Binding.qualify true (Binding.name_of (Binding.prefix_name rawN b));
35.436 + val ((bnfs, (Dss, Ass)), (unfold_set, lthy')) = apfst (apsnd split_list o split_list)
35.437 + (fold_map2 (fn b => fn rawT =>
35.438 + (bnf_of_typ Smart_Inline (qualify b) sort (Syntax.read_typ lthy rawT)))
35.439 + bs raw_bnfs (empty_unfolds, lthy));
35.440 + in
35.441 + snd (mk_fp_bnf timer
35.442 + (construct (map (K NoSyn) bs)) NONE bs sort lhss bnfs Dss Ass unfold_set lthy')
35.443 + end;
35.444 +
35.445 +end;
36.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
36.2 +++ b/src/HOL/BNF/Tools/bnf_fp_sugar.ML Fri Sep 21 16:45:06 2012 +0200
36.3 @@ -0,0 +1,911 @@
36.4 +(* Title: HOL/BNF/Tools/bnf_fp_sugar.ML
36.5 + Author: Jasmin Blanchette, TU Muenchen
36.6 + Copyright 2012
36.7 +
36.8 +Sugared datatype and codatatype constructions.
36.9 +*)
36.10 +
36.11 +signature BNF_FP_SUGAR =
36.12 +sig
36.13 + val datatyp: bool ->
36.14 + (mixfix list -> (string * sort) list option -> binding list -> typ list * typ list list ->
36.15 + BNF_Def.BNF list -> local_theory ->
36.16 + (term list * term list * term list * term list * thm * thm list * thm list * thm list *
36.17 + thm list * thm list) * local_theory) ->
36.18 + bool * ((((typ * sort) list * binding) * mixfix) * ((((binding * binding) *
36.19 + (binding * typ) list) * (binding * term) list) * mixfix) list) list ->
36.20 + local_theory -> local_theory
36.21 + val parse_datatype_cmd: bool ->
36.22 + (mixfix list -> (string * sort) list option -> binding list -> typ list * typ list list ->
36.23 + BNF_Def.BNF list -> local_theory ->
36.24 + (term list * term list * term list * term list * thm * thm list * thm list * thm list *
36.25 + thm list * thm list) * local_theory) ->
36.26 + (local_theory -> local_theory) parser
36.27 +end;
36.28 +
36.29 +structure BNF_FP_Sugar : BNF_FP_SUGAR =
36.30 +struct
36.31 +
36.32 +open BNF_Util
36.33 +open BNF_Wrap
36.34 +open BNF_Def
36.35 +open BNF_FP
36.36 +open BNF_FP_Sugar_Tactics
36.37 +
36.38 +val simp_attrs = @{attributes [simp]};
36.39 +
36.40 +fun split_list8 xs =
36.41 + (map #1 xs, map #2 xs, map #3 xs, map #4 xs, map #5 xs, map #6 xs, map #7 xs, map #8 xs);
36.42 +
36.43 +fun resort_tfree S (TFree (s, _)) = TFree (s, S);
36.44 +
36.45 +fun typ_subst inst (T as Type (s, Ts)) =
36.46 + (case AList.lookup (op =) inst T of
36.47 + NONE => Type (s, map (typ_subst inst) Ts)
36.48 + | SOME T' => T')
36.49 + | typ_subst inst T = the_default T (AList.lookup (op =) inst T);
36.50 +
36.51 +val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs));
36.52 +
36.53 +fun mk_tupled_fun x f xs = HOLogic.tupled_lambda x (Term.list_comb (f, xs));
36.54 +fun mk_uncurried_fun f xs = mk_tupled_fun (HOLogic.mk_tuple xs) f xs;
36.55 +fun mk_uncurried2_fun f xss =
36.56 + mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat xss);
36.57 +
36.58 +fun tick u f = Term.lambda u (HOLogic.mk_prod (u, f $ u));
36.59 +
36.60 +fun tack z_name (c, u) f =
36.61 + let val z = Free (z_name, mk_sumT (fastype_of u, fastype_of c)) in
36.62 + Term.lambda z (mk_sum_case (Term.lambda u u, Term.lambda c (f $ c)) $ z)
36.63 + end;
36.64 +
36.65 +fun cannot_merge_types () = error "Mutually recursive types must have the same type parameters";
36.66 +
36.67 +fun merge_type_arg T T' = if T = T' then T else cannot_merge_types ();
36.68 +
36.69 +fun merge_type_args (As, As') =
36.70 + if length As = length As' then map2 merge_type_arg As As' else cannot_merge_types ();
36.71 +
36.72 +fun is_triv_implies thm =
36.73 + op aconv (Logic.dest_implies (Thm.prop_of thm))
36.74 + handle TERM _ => false;
36.75 +
36.76 +fun type_args_constrained_of (((cAs, _), _), _) = cAs;
36.77 +fun type_binding_of (((_, b), _), _) = b;
36.78 +fun mixfix_of ((_, mx), _) = mx;
36.79 +fun ctr_specs_of (_, ctr_specs) = ctr_specs;
36.80 +
36.81 +fun disc_of ((((disc, _), _), _), _) = disc;
36.82 +fun ctr_of ((((_, ctr), _), _), _) = ctr;
36.83 +fun args_of (((_, args), _), _) = args;
36.84 +fun defaults_of ((_, ds), _) = ds;
36.85 +fun ctr_mixfix_of (_, mx) = mx;
36.86 +
36.87 +fun define_datatype prepare_constraint prepare_typ prepare_term lfp construct (no_dests, specs)
36.88 + no_defs_lthy0 =
36.89 + let
36.90 + (* TODO: sanity checks on arguments *)
36.91 + (* TODO: integration with function package ("size") *)
36.92 +
36.93 + val _ = if not lfp andalso no_dests then error "Cannot define destructor-less codatatypes"
36.94 + else ();
36.95 +
36.96 + val nn = length specs;
36.97 + val fp_bs = map type_binding_of specs;
36.98 + val fp_b_names = map Binding.name_of fp_bs;
36.99 + val fp_common_name = mk_common_name fp_b_names;
36.100 +
36.101 + fun prepare_type_arg (ty, c) =
36.102 + let val TFree (s, _) = prepare_typ no_defs_lthy0 ty in
36.103 + TFree (s, prepare_constraint no_defs_lthy0 c)
36.104 + end;
36.105 +
36.106 + val Ass0 = map (map prepare_type_arg o type_args_constrained_of) specs;
36.107 + val unsorted_Ass0 = map (map (resort_tfree HOLogic.typeS)) Ass0;
36.108 + val unsorted_As = Library.foldr1 merge_type_args unsorted_Ass0;
36.109 +
36.110 + val ((Bs, Cs), no_defs_lthy) =
36.111 + no_defs_lthy0
36.112 + |> fold (Variable.declare_typ o resort_tfree dummyS) unsorted_As
36.113 + |> mk_TFrees nn
36.114 + ||>> mk_TFrees nn;
36.115 +
36.116 + (* TODO: cleaner handling of fake contexts, without "background_theory" *)
36.117 + (*the "perhaps o try" below helps gracefully handles the case where the new type is defined in a
36.118 + locale and shadows an existing global type*)
36.119 + val fake_thy =
36.120 + Theory.copy #> fold (fn spec => perhaps (try (Sign.add_type no_defs_lthy
36.121 + (type_binding_of spec, length (type_args_constrained_of spec), mixfix_of spec)))) specs;
36.122 + val fake_lthy = Proof_Context.background_theory fake_thy no_defs_lthy;
36.123 +
36.124 + fun mk_fake_T b =
36.125 + Type (fst (Term.dest_Type (Proof_Context.read_type_name fake_lthy true (Binding.name_of b))),
36.126 + unsorted_As);
36.127 +
36.128 + val fake_Ts = map mk_fake_T fp_bs;
36.129 +
36.130 + val mixfixes = map mixfix_of specs;
36.131 +
36.132 + val _ = (case duplicates Binding.eq_name fp_bs of [] => ()
36.133 + | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
36.134 +
36.135 + val ctr_specss = map ctr_specs_of specs;
36.136 +
36.137 + val disc_bindingss = map (map disc_of) ctr_specss;
36.138 + val ctr_bindingss =
36.139 + map2 (fn fp_b_name => map (Binding.qualify false fp_b_name o ctr_of)) fp_b_names ctr_specss;
36.140 + val ctr_argsss = map (map args_of) ctr_specss;
36.141 + val ctr_mixfixess = map (map ctr_mixfix_of) ctr_specss;
36.142 +
36.143 + val sel_bindingsss = map (map (map fst)) ctr_argsss;
36.144 + val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss;
36.145 + val raw_sel_defaultsss = map (map defaults_of) ctr_specss;
36.146 +
36.147 + val (As :: _) :: fake_ctr_Tsss =
36.148 + burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0);
36.149 +
36.150 + val _ = (case duplicates (op =) unsorted_As of [] => ()
36.151 + | A :: _ => error ("Duplicate type parameter " ^
36.152 + quote (Syntax.string_of_typ no_defs_lthy A)));
36.153 +
36.154 + val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss [];
36.155 + val _ = (case subtract (op =) (map dest_TFree As) rhs_As' of
36.156 + [] => ()
36.157 + | A' :: _ => error ("Extra type variable on right-hand side: " ^
36.158 + quote (Syntax.string_of_typ no_defs_lthy (TFree A'))));
36.159 +
36.160 + fun eq_fpT (T as Type (s, Us)) (Type (s', Us')) =
36.161 + s = s' andalso (Us = Us' orelse error ("Illegal occurrence of recursive type " ^
36.162 + quote (Syntax.string_of_typ fake_lthy T)))
36.163 + | eq_fpT _ _ = false;
36.164 +
36.165 + fun freeze_fp (T as Type (s, Us)) =
36.166 + (case find_index (eq_fpT T) fake_Ts of ~1 => Type (s, map freeze_fp Us) | j => nth Bs j)
36.167 + | freeze_fp T = T;
36.168 +
36.169 + val ctr_TsssBs = map (map (map freeze_fp)) fake_ctr_Tsss;
36.170 + val ctr_sum_prod_TsBs = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctr_TsssBs;
36.171 +
36.172 + val fp_eqs =
36.173 + map dest_TFree Bs ~~ map (Term.typ_subst_atomic (As ~~ unsorted_As)) ctr_sum_prod_TsBs;
36.174 +
36.175 + val (pre_bnfs, ((dtors0, ctors0, fp_folds0, fp_recs0, fp_induct, dtor_ctors, ctor_dtors,
36.176 + ctor_injects, fp_fold_thms, fp_rec_thms), lthy)) =
36.177 + fp_bnf construct fp_bs mixfixes (map dest_TFree unsorted_As) fp_eqs no_defs_lthy0;
36.178 +
36.179 + fun add_nesty_bnf_names Us =
36.180 + let
36.181 + fun add (Type (s, Ts)) ss =
36.182 + let val (needs, ss') = fold_map add Ts ss in
36.183 + if exists I needs then (true, insert (op =) s ss') else (false, ss')
36.184 + end
36.185 + | add T ss = (member (op =) Us T, ss);
36.186 + in snd oo add end;
36.187 +
36.188 + fun nesty_bnfs Us =
36.189 + map_filter (bnf_of lthy) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_TsssBs []);
36.190 +
36.191 + val nesting_bnfs = nesty_bnfs As;
36.192 + val nested_bnfs = nesty_bnfs Bs;
36.193 +
36.194 + val timer = time (Timer.startRealTimer ());
36.195 +
36.196 + fun mk_ctor_or_dtor get_T Ts t =
36.197 + let val Type (_, Ts0) = get_T (fastype_of t) in
36.198 + Term.subst_atomic_types (Ts0 ~~ Ts) t
36.199 + end;
36.200 +
36.201 + val mk_ctor = mk_ctor_or_dtor range_type;
36.202 + val mk_dtor = mk_ctor_or_dtor domain_type;
36.203 +
36.204 + val ctors = map (mk_ctor As) ctors0;
36.205 + val dtors = map (mk_dtor As) dtors0;
36.206 +
36.207 + val fpTs = map (domain_type o fastype_of) dtors;
36.208 +
36.209 + val exists_fp_subtype = exists_subtype (member (op =) fpTs);
36.210 +
36.211 + val ctr_Tsss = map (map (map (Term.typ_subst_atomic (Bs ~~ fpTs)))) ctr_TsssBs;
36.212 + val ns = map length ctr_Tsss;
36.213 + val kss = map (fn n => 1 upto n) ns;
36.214 + val mss = map (map length) ctr_Tsss;
36.215 + val Css = map2 replicate ns Cs;
36.216 +
36.217 + fun mk_rec_like Ts Us t =
36.218 + let
36.219 + val (bindings, body) = strip_type (fastype_of t);
36.220 + val (f_Us, prebody) = split_last bindings;
36.221 + val Type (_, Ts0) = if lfp then prebody else body;
36.222 + val Us0 = distinct (op =) (map (if lfp then body_type else domain_type) f_Us);
36.223 + in
36.224 + Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
36.225 + end;
36.226 +
36.227 + val fp_folds as fp_fold1 :: _ = map (mk_rec_like As Cs) fp_folds0;
36.228 + val fp_recs as fp_rec1 :: _ = map (mk_rec_like As Cs) fp_recs0;
36.229 +
36.230 + val fp_fold_fun_Ts = fst (split_last (binder_types (fastype_of fp_fold1)));
36.231 + val fp_rec_fun_Ts = fst (split_last (binder_types (fastype_of fp_rec1)));
36.232 +
36.233 + val (((fold_only as (gss, _, _), rec_only as (hss, _, _)),
36.234 + (zs, cs, cpss, unfold_only as ((pgss, crgsss), _), corec_only as ((phss, cshsss), _))),
36.235 + names_lthy) =
36.236 + if lfp then
36.237 + let
36.238 + val y_Tsss =
36.239 + map3 (fn n => fn ms => map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type)
36.240 + ns mss fp_fold_fun_Ts;
36.241 + val g_Tss = map2 (map2 (curry (op --->))) y_Tsss Css;
36.242 +
36.243 + val ((gss, ysss), lthy) =
36.244 + lthy
36.245 + |> mk_Freess "f" g_Tss
36.246 + ||>> mk_Freesss "x" y_Tsss;
36.247 + val yssss = map (map (map single)) ysss;
36.248 +
36.249 + fun dest_rec_prodT (T as Type (@{type_name prod}, Us as [_, U])) =
36.250 + if member (op =) Cs U then Us else [T]
36.251 + | dest_rec_prodT T = [T];
36.252 +
36.253 + val z_Tssss =
36.254 + map3 (fn n => fn ms => map2 (map dest_rec_prodT oo dest_tupleT) ms o
36.255 + dest_sumTN_balanced n o domain_type) ns mss fp_rec_fun_Ts;
36.256 + val h_Tss = map2 (map2 (fold_rev (curry (op --->)))) z_Tssss Css;
36.257 +
36.258 + val hss = map2 (map2 retype_free) h_Tss gss;
36.259 + val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
36.260 + val (zssss_tl, lthy) =
36.261 + lthy
36.262 + |> mk_Freessss "y" (map (map (map tl)) z_Tssss);
36.263 + val zssss = map2 (map2 (map2 cons)) zssss_hd zssss_tl;
36.264 + in
36.265 + ((((gss, g_Tss, yssss), (hss, h_Tss, zssss)),
36.266 + ([], [], [], (([], []), ([], [])), (([], []), ([], [])))), lthy)
36.267 + end
36.268 + else
36.269 + let
36.270 + (*avoid "'a itself" arguments in coiterators and corecursors*)
36.271 + val mss' = map (fn [0] => [1] | ms => ms) mss;
36.272 +
36.273 + val p_Tss = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs;
36.274 +
36.275 + fun zip_predss_getterss qss fss = maps (op @) (qss ~~ fss);
36.276 +
36.277 + fun zip_preds_predsss_gettersss [] [qss] [fss] = zip_predss_getterss qss fss
36.278 + | zip_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
36.279 + p :: zip_predss_getterss qss fss @ zip_preds_predsss_gettersss ps qsss fsss;
36.280 +
36.281 + fun mk_types maybe_dest_sumT fun_Ts =
36.282 + let
36.283 + val f_sum_prod_Ts = map range_type fun_Ts;
36.284 + val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
36.285 + val f_Tssss =
36.286 + map3 (fn C => map2 (map (map (curry (op -->) C) o maybe_dest_sumT) oo dest_tupleT))
36.287 + Cs mss' f_prod_Tss;
36.288 + val q_Tssss =
36.289 + map (map (map (fn [_] => [] | [_, C] => [mk_pred1T (domain_type C)]))) f_Tssss;
36.290 + val pf_Tss = map3 zip_preds_predsss_gettersss p_Tss q_Tssss f_Tssss;
36.291 + in (q_Tssss, f_sum_prod_Ts, f_Tssss, pf_Tss) end;
36.292 +
36.293 + val (r_Tssss, g_sum_prod_Ts, g_Tssss, pg_Tss) = mk_types single fp_fold_fun_Ts;
36.294 +
36.295 + val ((((Free (z, _), cs), pss), gssss), lthy) =
36.296 + lthy
36.297 + |> yield_singleton (mk_Frees "z") dummyT
36.298 + ||>> mk_Frees "a" Cs
36.299 + ||>> mk_Freess "p" p_Tss
36.300 + ||>> mk_Freessss "g" g_Tssss;
36.301 + val rssss = map (map (map (fn [] => []))) r_Tssss;
36.302 +
36.303 + fun dest_corec_sumT (T as Type (@{type_name sum}, Us as [_, U])) =
36.304 + if member (op =) Cs U then Us else [T]
36.305 + | dest_corec_sumT T = [T];
36.306 +
36.307 + val (s_Tssss, h_sum_prod_Ts, h_Tssss, ph_Tss) = mk_types dest_corec_sumT fp_rec_fun_Ts;
36.308 +
36.309 + val hssss_hd = map2 (map2 (map2 (fn T :: _ => fn [g] => retype_free T g))) h_Tssss gssss;
36.310 + val ((sssss, hssss_tl), lthy) =
36.311 + lthy
36.312 + |> mk_Freessss "q" s_Tssss
36.313 + ||>> mk_Freessss "h" (map (map (map tl)) h_Tssss);
36.314 + val hssss = map2 (map2 (map2 cons)) hssss_hd hssss_tl;
36.315 +
36.316 + val cpss = map2 (fn c => map (fn p => p $ c)) cs pss;
36.317 +
36.318 + fun mk_preds_getters_join [] [cf] = cf
36.319 + | mk_preds_getters_join [cq] [cf, cf'] =
36.320 + mk_If cq (mk_Inl (fastype_of cf') cf) (mk_Inr (fastype_of cf) cf');
36.321 +
36.322 + fun mk_terms qssss fssss =
36.323 + let
36.324 + val pfss = map3 zip_preds_predsss_gettersss pss qssss fssss;
36.325 + val cqssss = map2 (fn c => map (map (map (fn f => f $ c)))) cs qssss;
36.326 + val cfssss = map2 (fn c => map (map (map (fn f => f $ c)))) cs fssss;
36.327 + val cqfsss = map2 (map2 (map2 mk_preds_getters_join)) cqssss cfssss;
36.328 + in (pfss, cqfsss) end;
36.329 + in
36.330 + (((([], [], []), ([], [], [])),
36.331 + ([z], cs, cpss, (mk_terms rssss gssss, (g_sum_prod_Ts, pg_Tss)),
36.332 + (mk_terms sssss hssss, (h_sum_prod_Ts, ph_Tss)))), lthy)
36.333 + end;
36.334 +
36.335 + fun define_ctrs_case_for_type ((((((((((((((((((fp_b, fpT), C), ctor), dtor), fp_fold), fp_rec),
36.336 + ctor_dtor), dtor_ctor), ctor_inject), n), ks), ms), ctr_bindings), ctr_mixfixes), ctr_Tss),
36.337 + disc_bindings), sel_bindingss), raw_sel_defaultss) no_defs_lthy =
36.338 + let
36.339 + val fp_b_name = Binding.name_of fp_b;
36.340 +
36.341 + val dtorT = domain_type (fastype_of ctor);
36.342 + val ctr_prod_Ts = map HOLogic.mk_tupleT ctr_Tss;
36.343 + val ctr_sum_prod_T = mk_sumTN_balanced ctr_prod_Ts;
36.344 + val case_Ts = map (fn Ts => Ts ---> C) ctr_Tss;
36.345 +
36.346 + val ((((w, fs), xss), u'), _) =
36.347 + no_defs_lthy
36.348 + |> yield_singleton (mk_Frees "w") dtorT
36.349 + ||>> mk_Frees "f" case_Ts
36.350 + ||>> mk_Freess "x" ctr_Tss
36.351 + ||>> yield_singleton Variable.variant_fixes fp_b_name;
36.352 +
36.353 + val u = Free (u', fpT);
36.354 +
36.355 + val ctr_rhss =
36.356 + map2 (fn k => fn xs => fold_rev Term.lambda xs (ctor $
36.357 + mk_InN_balanced ctr_sum_prod_T n (HOLogic.mk_tuple xs) k)) ks xss;
36.358 +
36.359 + val case_binding = Binding.suffix_name ("_" ^ caseN) fp_b;
36.360 +
36.361 + val case_rhs =
36.362 + fold_rev Term.lambda (fs @ [u])
36.363 + (mk_sum_caseN_balanced (map2 mk_uncurried_fun fs xss) $ (dtor $ u));
36.364 +
36.365 + val ((raw_case :: raw_ctrs, raw_case_def :: raw_ctr_defs), (lthy', lthy)) = no_defs_lthy
36.366 + |> apfst split_list o fold_map3 (fn b => fn mx => fn rhs =>
36.367 + Local_Theory.define ((b, mx), ((Thm.def_binding b, []), rhs)) #>> apsnd snd)
36.368 + (case_binding :: ctr_bindings) (NoSyn :: ctr_mixfixes) (case_rhs :: ctr_rhss)
36.369 + ||> `Local_Theory.restore;
36.370 +
36.371 + val phi = Proof_Context.export_morphism lthy lthy';
36.372 +
36.373 + val ctr_defs = map (Morphism.thm phi) raw_ctr_defs;
36.374 + val case_def = Morphism.thm phi raw_case_def;
36.375 +
36.376 + val ctrs0 = map (Morphism.term phi) raw_ctrs;
36.377 + val casex0 = Morphism.term phi raw_case;
36.378 +
36.379 + val ctrs = map (mk_ctr As) ctrs0;
36.380 +
36.381 + fun exhaust_tac {context = ctxt, ...} =
36.382 + let
36.383 + val ctor_iff_dtor_thm =
36.384 + let
36.385 + val goal =
36.386 + fold_rev Logic.all [w, u]
36.387 + (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w)));
36.388 + in
36.389 + Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
36.390 + mk_ctor_iff_dtor_tac ctxt (map (SOME o certifyT lthy) [dtorT, fpT])
36.391 + (certify lthy ctor) (certify lthy dtor) ctor_dtor dtor_ctor)
36.392 + |> Thm.close_derivation
36.393 + |> Morphism.thm phi
36.394 + end;
36.395 +
36.396 + val sumEN_thm' =
36.397 + unfold_thms lthy @{thms all_unit_eq}
36.398 + (Drule.instantiate' (map (SOME o certifyT lthy) ctr_prod_Ts) []
36.399 + (mk_sumEN_balanced n))
36.400 + |> Morphism.thm phi;
36.401 + in
36.402 + mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'
36.403 + end;
36.404 +
36.405 + val inject_tacss =
36.406 + map2 (fn 0 => K [] | _ => fn ctr_def => [fn {context = ctxt, ...} =>
36.407 + mk_inject_tac ctxt ctr_def ctor_inject]) ms ctr_defs;
36.408 +
36.409 + val half_distinct_tacss =
36.410 + map (map (fn (def, def') => fn {context = ctxt, ...} =>
36.411 + mk_half_distinct_tac ctxt ctor_inject [def, def'])) (mk_half_pairss ctr_defs);
36.412 +
36.413 + val case_tacs =
36.414 + map3 (fn k => fn m => fn ctr_def => fn {context = ctxt, ...} =>
36.415 + mk_case_tac ctxt n k m case_def ctr_def dtor_ctor) ks ms ctr_defs;
36.416 +
36.417 + val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss @ [case_tacs];
36.418 +
36.419 + fun define_fold_rec (wrap_res, no_defs_lthy) =
36.420 + let
36.421 + val fpT_to_C = fpT --> C;
36.422 +
36.423 + fun generate_rec_like (suf, fp_rec_like, (fss, f_Tss, xssss)) =
36.424 + let
36.425 + val res_T = fold_rev (curry (op --->)) f_Tss fpT_to_C;
36.426 + val binding = Binding.suffix_name ("_" ^ suf) fp_b;
36.427 + val spec =
36.428 + mk_Trueprop_eq (lists_bmoc fss (Free (Binding.name_of binding, res_T)),
36.429 + Term.list_comb (fp_rec_like,
36.430 + map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss));
36.431 + in (binding, spec) end;
36.432 +
36.433 + val rec_like_infos =
36.434 + [(foldN, fp_fold, fold_only),
36.435 + (recN, fp_rec, rec_only)];
36.436 +
36.437 + val (bindings, specs) = map generate_rec_like rec_like_infos |> split_list;
36.438 +
36.439 + val ((csts, defs), (lthy', lthy)) = no_defs_lthy
36.440 + |> apfst split_list o fold_map2 (fn b => fn spec =>
36.441 + Specification.definition (SOME (b, NONE, NoSyn), ((Thm.def_binding b, []), spec))
36.442 + #>> apsnd snd) bindings specs
36.443 + ||> `Local_Theory.restore;
36.444 +
36.445 + val phi = Proof_Context.export_morphism lthy lthy';
36.446 +
36.447 + val [fold_def, rec_def] = map (Morphism.thm phi) defs;
36.448 +
36.449 + val [foldx, recx] = map (mk_rec_like As Cs o Morphism.term phi) csts;
36.450 + in
36.451 + ((wrap_res, ctrs, foldx, recx, xss, ctr_defs, fold_def, rec_def), lthy)
36.452 + end;
36.453 +
36.454 + fun define_unfold_corec (wrap_res, no_defs_lthy) =
36.455 + let
36.456 + val B_to_fpT = C --> fpT;
36.457 +
36.458 + fun mk_preds_getterss_join c n cps sum_prod_T cqfss =
36.459 + Term.lambda c (mk_IfN sum_prod_T cps
36.460 + (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)));
36.461 +
36.462 + fun generate_corec_like (suf, fp_rec_like, ((pfss, cqfsss), (f_sum_prod_Ts,
36.463 + pf_Tss))) =
36.464 + let
36.465 + val res_T = fold_rev (curry (op --->)) pf_Tss B_to_fpT;
36.466 + val binding = Binding.suffix_name ("_" ^ suf) fp_b;
36.467 + val spec =
36.468 + mk_Trueprop_eq (lists_bmoc pfss (Free (Binding.name_of binding, res_T)),
36.469 + Term.list_comb (fp_rec_like,
36.470 + map5 mk_preds_getterss_join cs ns cpss f_sum_prod_Ts cqfsss));
36.471 + in (binding, spec) end;
36.472 +
36.473 + val corec_like_infos =
36.474 + [(unfoldN, fp_fold, unfold_only),
36.475 + (corecN, fp_rec, corec_only)];
36.476 +
36.477 + val (bindings, specs) = map generate_corec_like corec_like_infos |> split_list;
36.478 +
36.479 + val ((csts, defs), (lthy', lthy)) = no_defs_lthy
36.480 + |> apfst split_list o fold_map2 (fn b => fn spec =>
36.481 + Specification.definition (SOME (b, NONE, NoSyn), ((Thm.def_binding b, []), spec))
36.482 + #>> apsnd snd) bindings specs
36.483 + ||> `Local_Theory.restore;
36.484 +
36.485 + val phi = Proof_Context.export_morphism lthy lthy';
36.486 +
36.487 + val [unfold_def, corec_def] = map (Morphism.thm phi) defs;
36.488 +
36.489 + val [unfold, corec] = map (mk_rec_like As Cs o Morphism.term phi) csts;
36.490 + in
36.491 + ((wrap_res, ctrs, unfold, corec, xss, ctr_defs, unfold_def, corec_def), lthy)
36.492 + end;
36.493 +
36.494 + fun wrap lthy =
36.495 + let val sel_defaultss = map (map (apsnd (prepare_term lthy))) raw_sel_defaultss in
36.496 + wrap_datatype tacss (((no_dests, ctrs0), casex0), (disc_bindings, (sel_bindingss,
36.497 + sel_defaultss))) lthy
36.498 + end;
36.499 +
36.500 + val define_rec_likes = if lfp then define_fold_rec else define_unfold_corec;
36.501 + in
36.502 + ((wrap, define_rec_likes), lthy')
36.503 + end;
36.504 +
36.505 + val pre_map_defs = map map_def_of_bnf pre_bnfs;
36.506 + val pre_set_defss = map set_defs_of_bnf pre_bnfs;
36.507 + val nested_set_natural's = maps set_natural'_of_bnf nested_bnfs;
36.508 + val nesting_map_ids = map map_id_of_bnf nesting_bnfs;
36.509 +
36.510 + fun mk_map live Ts Us t =
36.511 + let
36.512 + val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last
36.513 + in
36.514 + Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
36.515 + end;
36.516 +
36.517 + fun build_map build_arg (Type (s, Ts)) (Type (_, Us)) =
36.518 + let
36.519 + val bnf = the (bnf_of lthy s);
36.520 + val live = live_of_bnf bnf;
36.521 + val mapx = mk_map live Ts Us (map_of_bnf bnf);
36.522 + val TUs = map dest_funT (fst (strip_typeN live (fastype_of mapx)));
36.523 + val args = map build_arg TUs;
36.524 + in Term.list_comb (mapx, args) end;
36.525 +
36.526 + val mk_simp_thmss =
36.527 + map3 (fn (_, _, injects, distincts, cases, _, _, _) => fn rec_likes => fn fold_likes =>
36.528 + injects @ distincts @ cases @ rec_likes @ fold_likes);
36.529 +
36.530 + fun derive_induct_fold_rec_thms_for_types ((wrap_ress, ctrss, folds, recs, xsss, ctr_defss,
36.531 + fold_defs, rec_defs), lthy) =
36.532 + let
36.533 + val (((phis, phis'), us'), names_lthy) =
36.534 + lthy
36.535 + |> mk_Frees' "P" (map mk_pred1T fpTs)
36.536 + ||>> Variable.variant_fixes fp_b_names;
36.537 +
36.538 + val us = map2 (curry Free) us' fpTs;
36.539 +
36.540 + fun mk_sets_nested bnf =
36.541 + let
36.542 + val Type (T_name, Us) = T_of_bnf bnf;
36.543 + val lives = lives_of_bnf bnf;
36.544 + val sets = sets_of_bnf bnf;
36.545 + fun mk_set U =
36.546 + (case find_index (curry (op =) U) lives of
36.547 + ~1 => Term.dummy
36.548 + | i => nth sets i);
36.549 + in
36.550 + (T_name, map mk_set Us)
36.551 + end;
36.552 +
36.553 + val setss_nested = map mk_sets_nested nested_bnfs;
36.554 +
36.555 + val (induct_thms, induct_thm) =
36.556 + let
36.557 + fun mk_set Ts t =
36.558 + let val Type (_, Ts0) = domain_type (fastype_of t) in
36.559 + Term.subst_atomic_types (Ts0 ~~ Ts) t
36.560 + end;
36.561 +
36.562 + fun mk_raw_prem_prems names_lthy (x as Free (s, T as Type (T_name, Ts0))) =
36.563 + (case find_index (curry (op =) T) fpTs of
36.564 + ~1 =>
36.565 + (case AList.lookup (op =) setss_nested T_name of
36.566 + NONE => []
36.567 + | SOME raw_sets0 =>
36.568 + let
36.569 + val (Ts, raw_sets) =
36.570 + split_list (filter (exists_fp_subtype o fst) (Ts0 ~~ raw_sets0));
36.571 + val sets = map (mk_set Ts0) raw_sets;
36.572 + val (ys, names_lthy') = names_lthy |> mk_Frees s Ts;
36.573 + val xysets = map (pair x) (ys ~~ sets);
36.574 + val ppremss = map (mk_raw_prem_prems names_lthy') ys;
36.575 + in
36.576 + flat (map2 (map o apfst o cons) xysets ppremss)
36.577 + end)
36.578 + | i => [([], (i + 1, x))])
36.579 + | mk_raw_prem_prems _ _ = [];
36.580 +
36.581 + fun close_prem_prem xs t =
36.582 + fold_rev Logic.all (map Free (drop (nn + length xs)
36.583 + (rev (Term.add_frees t (map dest_Free xs @ phis'))))) t;
36.584 +
36.585 + fun mk_prem_prem xs (xysets, (j, x)) =
36.586 + close_prem_prem xs (Logic.list_implies (map (fn (x', (y, set)) =>
36.587 + HOLogic.mk_Trueprop (HOLogic.mk_mem (y, set $ x'))) xysets,
36.588 + HOLogic.mk_Trueprop (nth phis (j - 1) $ x)));
36.589 +
36.590 + fun mk_raw_prem phi ctr ctr_Ts =
36.591 + let
36.592 + val (xs, names_lthy') = names_lthy |> mk_Frees "x" ctr_Ts;
36.593 + val pprems = maps (mk_raw_prem_prems names_lthy') xs;
36.594 + in (xs, pprems, HOLogic.mk_Trueprop (phi $ Term.list_comb (ctr, xs))) end;
36.595 +
36.596 + fun mk_prem (xs, raw_pprems, concl) =
36.597 + fold_rev Logic.all xs (Logic.list_implies (map (mk_prem_prem xs) raw_pprems, concl));
36.598 +
36.599 + val raw_premss = map3 (map2 o mk_raw_prem) phis ctrss ctr_Tsss;
36.600 +
36.601 + val goal =
36.602 + Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
36.603 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) phis us)));
36.604 +
36.605 + val kksss = map (map (map (fst o snd) o #2)) raw_premss;
36.606 +
36.607 + val ctor_induct' = fp_induct OF (map mk_sumEN_tupled_balanced mss);
36.608 +
36.609 + val induct_thm =
36.610 + Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
36.611 + mk_induct_tac ctxt ns mss kksss (flat ctr_defss) ctor_induct'
36.612 + nested_set_natural's pre_set_defss)
36.613 + |> singleton (Proof_Context.export names_lthy lthy)
36.614 + in
36.615 + `(conj_dests nn) induct_thm
36.616 + end;
36.617 +
36.618 + (* TODO: Generate nicer names in case of clashes *)
36.619 + val induct_cases = Datatype_Prop.indexify_names (maps (map base_name_of_ctr) ctrss);
36.620 +
36.621 + val (fold_thmss, rec_thmss) =
36.622 + let
36.623 + val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss;
36.624 + val gfolds = map (lists_bmoc gss) folds;
36.625 + val hrecs = map (lists_bmoc hss) recs;
36.626 +
36.627 + fun mk_goal fss frec_like xctr f xs fxs =
36.628 + fold_rev (fold_rev Logic.all) (xs :: fss)
36.629 + (mk_Trueprop_eq (frec_like $ xctr, Term.list_comb (f, fxs)));
36.630 +
36.631 + fun build_call frec_likes maybe_tick (T, U) =
36.632 + if T = U then
36.633 + id_const T
36.634 + else
36.635 + (case find_index (curry (op =) T) fpTs of
36.636 + ~1 => build_map (build_call frec_likes maybe_tick) T U
36.637 + | j => maybe_tick (nth us j) (nth frec_likes j));
36.638 +
36.639 + fun mk_U maybe_mk_prodT =
36.640 + typ_subst (map2 (fn fpT => fn C => (fpT, maybe_mk_prodT fpT C)) fpTs Cs);
36.641 +
36.642 + fun intr_calls frec_likes maybe_cons maybe_tick maybe_mk_prodT (x as Free (_, T)) =
36.643 + if member (op =) fpTs T then
36.644 + maybe_cons x [build_call frec_likes (K I) (T, mk_U (K I) T) $ x]
36.645 + else if exists_fp_subtype T then
36.646 + [build_call frec_likes maybe_tick (T, mk_U maybe_mk_prodT T) $ x]
36.647 + else
36.648 + [x];
36.649 +
36.650 + val gxsss = map (map (maps (intr_calls gfolds (K I) (K I) (K I)))) xsss;
36.651 + val hxsss = map (map (maps (intr_calls hrecs cons tick (curry HOLogic.mk_prodT)))) xsss;
36.652 +
36.653 + val fold_goalss = map5 (map4 o mk_goal gss) gfolds xctrss gss xsss gxsss;
36.654 + val rec_goalss = map5 (map4 o mk_goal hss) hrecs xctrss hss xsss hxsss;
36.655 +
36.656 + val fold_tacss =
36.657 + map2 (map o mk_rec_like_tac pre_map_defs nesting_map_ids fold_defs) fp_fold_thms
36.658 + ctr_defss;
36.659 + val rec_tacss =
36.660 + map2 (map o mk_rec_like_tac pre_map_defs nesting_map_ids rec_defs) fp_rec_thms
36.661 + ctr_defss;
36.662 +
36.663 + fun prove goal tac = Skip_Proof.prove lthy [] [] goal (tac o #context);
36.664 + in
36.665 + (map2 (map2 prove) fold_goalss fold_tacss,
36.666 + map2 (map2 prove) rec_goalss rec_tacss)
36.667 + end;
36.668 +
36.669 + val simp_thmss = mk_simp_thmss wrap_ress rec_thmss fold_thmss;
36.670 +
36.671 + val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases));
36.672 + fun induct_type_attr T_name = Attrib.internal (K (Induct.induct_type T_name));
36.673 +
36.674 + (* TODO: Also note "recs", "simps", and "splits" if "nn > 1" (for compatibility with the
36.675 + old package)? And for codatatypes as well? *)
36.676 + val common_notes =
36.677 + (if nn > 1 then [(inductN, [induct_thm], [induct_case_names_attr])] else [])
36.678 + |> map (fn (thmN, thms, attrs) =>
36.679 + ((Binding.qualify true fp_common_name (Binding.name thmN), attrs), [(thms, [])]));
36.680 +
36.681 + val notes =
36.682 + [(inductN, map single induct_thms,
36.683 + fn T_name => [induct_case_names_attr, induct_type_attr T_name]),
36.684 + (foldsN, fold_thmss, K (Code.add_default_eqn_attrib :: simp_attrs)),
36.685 + (recsN, rec_thmss, K (Code.add_default_eqn_attrib :: simp_attrs)),
36.686 + (simpsN, simp_thmss, K [])]
36.687 + |> maps (fn (thmN, thmss, attrs) =>
36.688 + map3 (fn b => fn Type (T_name, _) => fn thms =>
36.689 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), attrs T_name),
36.690 + [(thms, [])])) fp_bs fpTs thmss);
36.691 + in
36.692 + lthy |> Local_Theory.notes (common_notes @ notes) |> snd
36.693 + end;
36.694 +
36.695 + fun derive_coinduct_unfold_corec_thms_for_types ((wrap_ress, ctrss, unfolds, corecs, _,
36.696 + ctr_defss, unfold_defs, corec_defs), lthy) =
36.697 + let
36.698 + val discss = map (map (mk_disc_or_sel As) o #1) wrap_ress;
36.699 + val selsss = map #2 wrap_ress;
36.700 + val disc_thmsss = map #6 wrap_ress;
36.701 + val discIss = map #7 wrap_ress;
36.702 + val sel_thmsss = map #8 wrap_ress;
36.703 +
36.704 + val (us', _) =
36.705 + lthy
36.706 + |> Variable.variant_fixes fp_b_names;
36.707 +
36.708 + val us = map2 (curry Free) us' fpTs;
36.709 +
36.710 + val (coinduct_thms, coinduct_thm) =
36.711 + let
36.712 + val coinduct_thm = fp_induct;
36.713 + in
36.714 + `(conj_dests nn) coinduct_thm
36.715 + end;
36.716 +
36.717 + fun mk_maybe_not pos = not pos ? HOLogic.mk_not;
36.718 +
36.719 + val z = the_single zs;
36.720 + val gunfolds = map (lists_bmoc pgss) unfolds;
36.721 + val hcorecs = map (lists_bmoc phss) corecs;
36.722 +
36.723 + val (unfold_thmss, corec_thmss, safe_unfold_thmss, safe_corec_thmss) =
36.724 + let
36.725 + fun mk_goal pfss c cps fcorec_like n k ctr m cfs' =
36.726 + fold_rev (fold_rev Logic.all) ([c] :: pfss)
36.727 + (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps,
36.728 + mk_Trueprop_eq (fcorec_like $ c, Term.list_comb (ctr, take m cfs'))));
36.729 +
36.730 + fun build_call frec_likes maybe_tack (T, U) =
36.731 + if T = U then
36.732 + id_const T
36.733 + else
36.734 + (case find_index (curry (op =) U) fpTs of
36.735 + ~1 => build_map (build_call frec_likes maybe_tack) T U
36.736 + | j => maybe_tack (nth cs j, nth us j) (nth frec_likes j));
36.737 +
36.738 + fun mk_U maybe_mk_sumT =
36.739 + typ_subst (map2 (fn C => fn fpT => (maybe_mk_sumT fpT C, fpT)) Cs fpTs);
36.740 +
36.741 + fun intr_calls frec_likes maybe_mk_sumT maybe_tack cqf =
36.742 + let val T = fastype_of cqf in
36.743 + if exists_subtype (member (op =) Cs) T then
36.744 + build_call frec_likes maybe_tack (T, mk_U maybe_mk_sumT T) $ cqf
36.745 + else
36.746 + cqf
36.747 + end;
36.748 +
36.749 + val crgsss' = map (map (map (intr_calls gunfolds (K I) (K I)))) crgsss;
36.750 + val cshsss' = map (map (map (intr_calls hcorecs (curry mk_sumT) (tack z)))) cshsss;
36.751 +
36.752 + val unfold_goalss =
36.753 + map8 (map4 oooo mk_goal pgss) cs cpss gunfolds ns kss ctrss mss crgsss';
36.754 + val corec_goalss =
36.755 + map8 (map4 oooo mk_goal phss) cs cpss hcorecs ns kss ctrss mss cshsss';
36.756 +
36.757 + val unfold_tacss =
36.758 + map3 (map oo mk_corec_like_tac unfold_defs nesting_map_ids) fp_fold_thms pre_map_defs
36.759 + ctr_defss;
36.760 + val corec_tacss =
36.761 + map3 (map oo mk_corec_like_tac corec_defs nesting_map_ids) fp_rec_thms pre_map_defs
36.762 + ctr_defss;
36.763 +
36.764 + fun prove goal tac =
36.765 + Skip_Proof.prove lthy [] [] goal (tac o #context) |> Thm.close_derivation;
36.766 +
36.767 + val unfold_thmss = map2 (map2 prove) unfold_goalss unfold_tacss;
36.768 + val corec_thmss =
36.769 + map2 (map2 prove) corec_goalss corec_tacss
36.770 + |> map (map (unfold_thms lthy @{thms sum_case_if}));
36.771 +
36.772 + val unfold_safesss = map2 (map2 (map2 (curry (op =)))) crgsss' crgsss;
36.773 + val corec_safesss = map2 (map2 (map2 (curry (op =)))) cshsss' cshsss;
36.774 +
36.775 + val filter_safesss =
36.776 + map2 (map_filter (fn (safes, thm) => if forall I safes then SOME thm else NONE) oo
36.777 + curry (op ~~));
36.778 +
36.779 + val safe_unfold_thmss = filter_safesss unfold_safesss unfold_thmss;
36.780 + val safe_corec_thmss = filter_safesss corec_safesss corec_thmss;
36.781 + in
36.782 + (unfold_thmss, corec_thmss, safe_unfold_thmss, safe_corec_thmss)
36.783 + end;
36.784 +
36.785 + val (disc_unfold_iff_thmss, disc_corec_iff_thmss) =
36.786 + let
36.787 + fun mk_goal c cps fcorec_like n k disc =
36.788 + mk_Trueprop_eq (disc $ (fcorec_like $ c),
36.789 + if n = 1 then @{const True}
36.790 + else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps));
36.791 +
36.792 + val unfold_goalss = map6 (map2 oooo mk_goal) cs cpss gunfolds ns kss discss;
36.793 + val corec_goalss = map6 (map2 oooo mk_goal) cs cpss hcorecs ns kss discss;
36.794 +
36.795 + fun mk_case_split' cp =
36.796 + Drule.instantiate' [] [SOME (certify lthy cp)] @{thm case_split};
36.797 +
36.798 + val case_splitss' = map (map mk_case_split') cpss;
36.799 +
36.800 + val unfold_tacss =
36.801 + map3 (map oo mk_disc_corec_like_iff_tac) case_splitss' unfold_thmss disc_thmsss;
36.802 + val corec_tacss =
36.803 + map3 (map oo mk_disc_corec_like_iff_tac) case_splitss' corec_thmss disc_thmsss;
36.804 +
36.805 + fun prove goal tac =
36.806 + Skip_Proof.prove lthy [] [] goal (tac o #context)
36.807 + |> Thm.close_derivation
36.808 + |> singleton (Proof_Context.export names_lthy no_defs_lthy);
36.809 +
36.810 + fun proves [_] [_] = []
36.811 + | proves goals tacs = map2 prove goals tacs;
36.812 + in
36.813 + (map2 proves unfold_goalss unfold_tacss,
36.814 + map2 proves corec_goalss corec_tacss)
36.815 + end;
36.816 +
36.817 + fun mk_disc_corec_like_thms corec_likes discIs =
36.818 + map (op RS) (filter_out (is_triv_implies o snd) (corec_likes ~~ discIs));
36.819 +
36.820 + val disc_unfold_thmss = map2 mk_disc_corec_like_thms unfold_thmss discIss;
36.821 + val disc_corec_thmss = map2 mk_disc_corec_like_thms corec_thmss discIss;
36.822 +
36.823 + fun mk_sel_corec_like_thm corec_like_thm sel sel_thm =
36.824 + let
36.825 + val (domT, ranT) = dest_funT (fastype_of sel);
36.826 + val arg_cong' =
36.827 + Drule.instantiate' (map (SOME o certifyT lthy) [domT, ranT])
36.828 + [NONE, NONE, SOME (certify lthy sel)] arg_cong
36.829 + |> Thm.varifyT_global;
36.830 + val sel_thm' = sel_thm RSN (2, trans);
36.831 + in
36.832 + corec_like_thm RS arg_cong' RS sel_thm'
36.833 + end;
36.834 +
36.835 + fun mk_sel_corec_like_thms corec_likess =
36.836 + map3 (map3 (map2 o mk_sel_corec_like_thm)) corec_likess selsss sel_thmsss |> map flat;
36.837 +
36.838 + val sel_unfold_thmss = mk_sel_corec_like_thms unfold_thmss;
36.839 + val sel_corec_thmss = mk_sel_corec_like_thms corec_thmss;
36.840 +
36.841 + fun zip_corec_like_thms corec_likes disc_corec_likes sel_corec_likes =
36.842 + corec_likes @ disc_corec_likes @ sel_corec_likes;
36.843 +
36.844 + val simp_thmss =
36.845 + mk_simp_thmss wrap_ress
36.846 + (map3 zip_corec_like_thms safe_corec_thmss disc_corec_thmss sel_corec_thmss)
36.847 + (map3 zip_corec_like_thms safe_unfold_thmss disc_unfold_thmss sel_unfold_thmss);
36.848 +
36.849 + val anonymous_notes =
36.850 + [(flat safe_unfold_thmss @ flat safe_corec_thmss, simp_attrs)]
36.851 + |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
36.852 +
36.853 + val common_notes =
36.854 + (if nn > 1 then [(coinductN, [coinduct_thm], [])] (* FIXME: attribs *) else [])
36.855 + |> map (fn (thmN, thms, attrs) =>
36.856 + ((Binding.qualify true fp_common_name (Binding.name thmN), attrs), [(thms, [])]));
36.857 +
36.858 + val notes =
36.859 + [(coinductN, map single coinduct_thms, []), (* FIXME: attribs *)
36.860 + (unfoldsN, unfold_thmss, []),
36.861 + (corecsN, corec_thmss, []),
36.862 + (disc_unfold_iffN, disc_unfold_iff_thmss, simp_attrs),
36.863 + (disc_unfoldsN, disc_unfold_thmss, simp_attrs),
36.864 + (disc_corec_iffN, disc_corec_iff_thmss, simp_attrs),
36.865 + (disc_corecsN, disc_corec_thmss, simp_attrs),
36.866 + (sel_unfoldsN, sel_unfold_thmss, simp_attrs),
36.867 + (sel_corecsN, sel_corec_thmss, simp_attrs),
36.868 + (simpsN, simp_thmss, [])]
36.869 + |> maps (fn (thmN, thmss, attrs) =>
36.870 + map_filter (fn (_, []) => NONE | (b, thms) =>
36.871 + SOME ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), attrs),
36.872 + [(thms, [])])) (fp_bs ~~ thmss));
36.873 + in
36.874 + lthy |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |> snd
36.875 + end;
36.876 +
36.877 + fun wrap_types_and_define_rec_likes ((wraps, define_rec_likess), lthy) =
36.878 + fold_map2 (curry (op o)) define_rec_likess wraps lthy |>> split_list8
36.879 +
36.880 + val lthy' = lthy
36.881 + |> fold_map define_ctrs_case_for_type (fp_bs ~~ fpTs ~~ Cs ~~ ctors ~~ dtors ~~ fp_folds ~~
36.882 + fp_recs ~~ ctor_dtors ~~ dtor_ctors ~~ ctor_injects ~~ ns ~~ kss ~~ mss ~~ ctr_bindingss ~~
36.883 + ctr_mixfixess ~~ ctr_Tsss ~~ disc_bindingss ~~ sel_bindingsss ~~ raw_sel_defaultsss)
36.884 + |>> split_list |> wrap_types_and_define_rec_likes
36.885 + |> (if lfp then derive_induct_fold_rec_thms_for_types
36.886 + else derive_coinduct_unfold_corec_thms_for_types);
36.887 +
36.888 + val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^
36.889 + (if lfp then "" else "co") ^ "datatype"));
36.890 + in
36.891 + timer; lthy'
36.892 + end;
36.893 +
36.894 +val datatyp = define_datatype (K I) (K I) (K I);
36.895 +
36.896 +val datatype_cmd = define_datatype Typedecl.read_constraint Syntax.parse_typ Syntax.read_term;
36.897 +
36.898 +val parse_ctr_arg =
36.899 + @{keyword "("} |-- parse_binding_colon -- Parse.typ --| @{keyword ")"} ||
36.900 + (Parse.typ >> pair Binding.empty);
36.901 +
36.902 +val parse_defaults =
36.903 + @{keyword "("} |-- @{keyword "defaults"} |-- Scan.repeat parse_bound_term --| @{keyword ")"};
36.904 +
36.905 +val parse_single_spec =
36.906 + Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix --
36.907 + (@{keyword "="} |-- Parse.enum1 "|" (parse_opt_binding_colon -- Parse.binding --
36.908 + Scan.repeat parse_ctr_arg -- Scan.optional parse_defaults [] -- Parse.opt_mixfix));
36.909 +
36.910 +val parse_datatype = parse_wrap_options -- Parse.and_list1 parse_single_spec;
36.911 +
36.912 +fun parse_datatype_cmd lfp construct = parse_datatype >> datatype_cmd lfp construct;
36.913 +
36.914 +end;
37.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
37.2 +++ b/src/HOL/BNF/Tools/bnf_fp_sugar_tactics.ML Fri Sep 21 16:45:06 2012 +0200
37.3 @@ -0,0 +1,133 @@
37.4 +(* Title: HOL/BNF/Tools/bnf_fp_sugar_tactics.ML
37.5 + Author: Jasmin Blanchette, TU Muenchen
37.6 + Copyright 2012
37.7 +
37.8 +Tactics for datatype and codatatype sugar.
37.9 +*)
37.10 +
37.11 +signature BNF_FP_SUGAR_TACTICS =
37.12 +sig
37.13 + val mk_case_tac: Proof.context -> int -> int -> int -> thm -> thm -> thm -> tactic
37.14 + val mk_corec_like_tac: thm list -> thm list -> thm -> thm -> thm -> Proof.context -> tactic
37.15 + val mk_ctor_iff_dtor_tac: Proof.context -> ctyp option list -> cterm -> cterm -> thm -> thm ->
37.16 + tactic
37.17 + val mk_disc_corec_like_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic
37.18 + val mk_exhaust_tac: Proof.context -> int -> thm list -> thm -> thm -> tactic
37.19 + val mk_half_distinct_tac: Proof.context -> thm -> thm list -> tactic
37.20 + val mk_induct_tac: Proof.context -> int list -> int list list -> int list list list -> thm list ->
37.21 + thm -> thm list -> thm list list -> tactic
37.22 + val mk_inject_tac: Proof.context -> thm -> thm -> tactic
37.23 + val mk_rec_like_tac: thm list -> thm list -> thm list -> thm -> thm -> Proof.context -> tactic
37.24 +end;
37.25 +
37.26 +structure BNF_FP_Sugar_Tactics : BNF_FP_SUGAR_TACTICS =
37.27 +struct
37.28 +
37.29 +open BNF_Tactics
37.30 +open BNF_Util
37.31 +open BNF_FP
37.32 +
37.33 +val meta_mp = @{thm meta_mp};
37.34 +val meta_spec = @{thm meta_spec};
37.35 +
37.36 +fun inst_spurious_fs lthy thm =
37.37 + let
37.38 + val fs =
37.39 + Term.add_vars (prop_of thm) []
37.40 + |> filter (fn (_, Type (@{type_name fun}, [_, T'])) => T' <> HOLogic.boolT | _ => false);
37.41 + val cfs =
37.42 + map (fn f as (_, T) => (certify lthy (Var f), certify lthy (id_abs (domain_type T)))) fs;
37.43 + in
37.44 + Drule.cterm_instantiate cfs thm
37.45 + end;
37.46 +
37.47 +val inst_spurious_fs_tac = PRIMITIVE o inst_spurious_fs;
37.48 +
37.49 +fun mk_case_tac ctxt n k m case_def ctr_def dtor_ctor =
37.50 + unfold_thms_tac ctxt [case_def, ctr_def, dtor_ctor] THEN
37.51 + (rtac (mk_sum_casesN_balanced n k RS ssubst) THEN'
37.52 + REPEAT_DETERM_N (Int.max (0, m - 1)) o rtac (@{thm split} RS ssubst) THEN'
37.53 + rtac refl) 1;
37.54 +
37.55 +fun mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor sumEN' =
37.56 + unfold_thms_tac ctxt (ctor_iff_dtor :: ctr_defs) THEN rtac sumEN' 1 THEN
37.57 + unfold_thms_tac ctxt @{thms all_prod_eq} THEN
37.58 + EVERY' (maps (fn k => [select_prem_tac n (rotate_tac 1) k, REPEAT_DETERM o dtac meta_spec,
37.59 + etac meta_mp, atac]) (1 upto n)) 1;
37.60 +
37.61 +fun mk_ctor_iff_dtor_tac ctxt cTs cctor cdtor ctor_dtor dtor_ctor =
37.62 + (rtac iffI THEN'
37.63 + EVERY' (map3 (fn cTs => fn cx => fn th =>
37.64 + dtac (Drule.instantiate' cTs [NONE, NONE, SOME cx] arg_cong) THEN'
37.65 + SELECT_GOAL (unfold_thms_tac ctxt [th]) THEN'
37.66 + atac) [rev cTs, cTs] [cdtor, cctor] [dtor_ctor, ctor_dtor])) 1;
37.67 +
37.68 +fun mk_half_distinct_tac ctxt ctor_inject ctr_defs =
37.69 + unfold_thms_tac ctxt (ctor_inject :: @{thms sum.inject} @ ctr_defs) THEN
37.70 + rtac @{thm sum.distinct(1)} 1;
37.71 +
37.72 +fun mk_inject_tac ctxt ctr_def ctor_inject =
37.73 + unfold_thms_tac ctxt [ctr_def] THEN rtac (ctor_inject RS ssubst) 1 THEN
37.74 + unfold_thms_tac ctxt @{thms sum.inject Pair_eq conj_assoc} THEN rtac refl 1;
37.75 +
37.76 +val rec_like_unfold_thms =
37.77 + @{thms case_unit comp_def convol_def id_apply map_pair_def sum.simps(5,6) sum_map.simps
37.78 + split_conv};
37.79 +
37.80 +fun mk_rec_like_tac pre_map_defs map_ids rec_like_defs ctor_rec_like ctr_def ctxt =
37.81 + unfold_thms_tac ctxt (ctr_def :: ctor_rec_like :: rec_like_defs @ pre_map_defs @ map_ids @
37.82 + rec_like_unfold_thms) THEN unfold_thms_tac ctxt @{thms id_def} THEN rtac refl 1;
37.83 +
37.84 +val corec_like_ss = ss_only @{thms if_True if_False};
37.85 +val corec_like_unfold_thms = @{thms id_apply map_pair_def sum_map.simps prod.cases};
37.86 +
37.87 +fun mk_corec_like_tac corec_like_defs map_ids ctor_dtor_corec_like pre_map_def ctr_def ctxt =
37.88 + unfold_thms_tac ctxt (ctr_def :: corec_like_defs) THEN
37.89 + subst_tac ctxt [ctor_dtor_corec_like] 1 THEN asm_simp_tac corec_like_ss 1 THEN
37.90 + unfold_thms_tac ctxt (pre_map_def :: corec_like_unfold_thms @ map_ids) THEN
37.91 + unfold_thms_tac ctxt @{thms id_def} THEN
37.92 + TRY ((rtac refl ORELSE' subst_tac ctxt @{thms unit_eq} THEN' rtac refl) 1);
37.93 +
37.94 +fun mk_disc_corec_like_iff_tac case_splits' corec_likes discs ctxt =
37.95 + EVERY (map3 (fn case_split_tac => fn corec_like_thm => fn disc =>
37.96 + case_split_tac 1 THEN unfold_thms_tac ctxt [corec_like_thm] THEN
37.97 + asm_simp_tac (ss_only @{thms simp_thms(7,8,12,14,22,24)}) 1 THEN
37.98 + (if is_refl disc then all_tac else rtac disc 1))
37.99 + (map rtac case_splits' @ [K all_tac]) corec_likes discs);
37.100 +
37.101 +val solve_prem_prem_tac =
37.102 + REPEAT o (eresolve_tac @{thms bexE rev_bexI} ORELSE' rtac @{thm rev_bexI[OF UNIV_I]} ORELSE'
37.103 + hyp_subst_tac ORELSE' resolve_tac @{thms disjI1 disjI2}) THEN'
37.104 + (rtac refl ORELSE' atac ORELSE' rtac @{thm singletonI});
37.105 +
37.106 +val induct_prem_prem_thms =
37.107 + @{thms SUP_empty Sup_empty Sup_insert UN_insert Un_empty_left Un_empty_right Un_iff
37.108 + Union_Un_distrib collect_def[abs_def] image_def o_apply map_pair_simp
37.109 + mem_Collect_eq mem_UN_compreh_eq prod_set_simps sum_map.simps sum_set_simps};
37.110 +
37.111 +fun mk_induct_leverage_prem_prems_tac ctxt nn kks set_natural's pre_set_defs =
37.112 + EVERY' (maps (fn kk => [select_prem_tac nn (dtac meta_spec) kk, etac meta_mp,
37.113 + SELECT_GOAL (unfold_thms_tac ctxt (pre_set_defs @ set_natural's @ induct_prem_prem_thms)),
37.114 + solve_prem_prem_tac]) (rev kks)) 1;
37.115 +
37.116 +fun mk_induct_discharge_prem_tac ctxt nn n set_natural's pre_set_defs m k kks =
37.117 + let val r = length kks in
37.118 + EVERY' [select_prem_tac n (rotate_tac 1) k, rotate_tac ~1, hyp_subst_tac,
37.119 + REPEAT_DETERM_N m o (dtac meta_spec THEN' rotate_tac ~1)] 1 THEN
37.120 + EVERY [REPEAT_DETERM_N r
37.121 + (rotate_tac ~1 1 THEN dtac meta_mp 1 THEN rotate_tac 1 1 THEN prefer_tac 2),
37.122 + if r > 0 then PRIMITIVE Raw_Simplifier.norm_hhf else all_tac, atac 1,
37.123 + mk_induct_leverage_prem_prems_tac ctxt nn kks set_natural's pre_set_defs]
37.124 + end;
37.125 +
37.126 +fun mk_induct_tac ctxt ns mss kkss ctr_defs ctor_induct' set_natural's pre_set_defss =
37.127 + let
37.128 + val nn = length ns;
37.129 + val n = Integer.sum ns;
37.130 + in
37.131 + unfold_thms_tac ctxt ctr_defs THEN rtac ctor_induct' 1 THEN inst_spurious_fs_tac ctxt THEN
37.132 + EVERY (map4 (EVERY oooo map3 o mk_induct_discharge_prem_tac ctxt nn n set_natural's)
37.133 + pre_set_defss mss (unflat mss (1 upto n)) kkss)
37.134 + end;
37.135 +
37.136 +end;
38.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
38.2 +++ b/src/HOL/BNF/Tools/bnf_gfp.ML Fri Sep 21 16:45:06 2012 +0200
38.3 @@ -0,0 +1,3002 @@
38.4 +(* Title: HOL/BNF/Tools/bnf_gfp.ML
38.5 + Author: Dmitriy Traytel, TU Muenchen
38.6 + Author: Andrei Popescu, TU Muenchen
38.7 + Author: Jasmin Blanchette, TU Muenchen
38.8 + Copyright 2012
38.9 +
38.10 +Codatatype construction.
38.11 +*)
38.12 +
38.13 +signature BNF_GFP =
38.14 +sig
38.15 + val bnf_gfp: mixfix list -> (string * sort) list option -> binding list ->
38.16 + typ list * typ list list -> BNF_Def.BNF list -> local_theory ->
38.17 + (term list * term list * term list * term list * thm * thm list * thm list * thm list *
38.18 + thm list * thm list) * local_theory
38.19 +end;
38.20 +
38.21 +structure BNF_GFP : BNF_GFP =
38.22 +struct
38.23 +
38.24 +open BNF_Def
38.25 +open BNF_Util
38.26 +open BNF_Tactics
38.27 +open BNF_FP
38.28 +open BNF_FP_Sugar
38.29 +open BNF_GFP_Util
38.30 +open BNF_GFP_Tactics
38.31 +
38.32 +datatype wit_tree = Wit_Leaf of int | Wit_Node of (int * int * int list) * wit_tree list;
38.33 +
38.34 +fun mk_tree_args (I, T) (I', Ts) = (sort_distinct int_ord (I @ I'), T :: Ts);
38.35 +
38.36 +fun finish Iss m seen i (nwit, I) =
38.37 + let
38.38 + val treess = map (fn j =>
38.39 + if j < m orelse member (op =) seen j then [([j], Wit_Leaf j)]
38.40 + else
38.41 + map_index (finish Iss m (insert (op =) j seen) j) (nth Iss (j - m))
38.42 + |> flat
38.43 + |> minimize_wits)
38.44 + I;
38.45 + in
38.46 + map (fn (I, t) => (I, Wit_Node ((i - m, nwit, filter (fn i => i < m) I), t)))
38.47 + (fold_rev (map_product mk_tree_args) treess [([], [])])
38.48 + |> minimize_wits
38.49 + end;
38.50 +
38.51 +fun tree_to_ctor_wit vars _ _ (Wit_Leaf j) = ([j], nth vars j)
38.52 + | tree_to_ctor_wit vars ctors witss (Wit_Node ((i, nwit, I), subtrees)) =
38.53 + (I, nth ctors i $ (Term.list_comb (snd (nth (nth witss i) nwit),
38.54 + map (snd o tree_to_ctor_wit vars ctors witss) subtrees)));
38.55 +
38.56 +fun tree_to_coind_wits _ (Wit_Leaf _) = []
38.57 + | tree_to_coind_wits lwitss (Wit_Node ((i, nwit, I), subtrees)) =
38.58 + ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
38.59 +
38.60 +(*all BNFs have the same lives*)
38.61 +fun bnf_gfp mixfixes resBs bs (resDs, Dss) bnfs lthy =
38.62 + let
38.63 + val timer = time (Timer.startRealTimer ());
38.64 +
38.65 + val live = live_of_bnf (hd bnfs);
38.66 + val n = length bnfs; (*active*)
38.67 + val ks = 1 upto n;
38.68 + val m = live - n (*passive, if 0 don't generate a new BNF*);
38.69 + val ls = 1 upto m;
38.70 + val b = Binding.name (mk_common_name (map Binding.name_of bs));
38.71 +
38.72 + (* TODO: check if m, n, etc., are sane *)
38.73 +
38.74 + val deads = fold (union (op =)) Dss resDs;
38.75 + val names_lthy = fold Variable.declare_typ deads lthy;
38.76 +
38.77 + (* tvars *)
38.78 + val ((((((((passiveAs, activeAs), allAs)), (passiveBs, activeBs)),
38.79 + (passiveCs, activeCs)), passiveXs), passiveYs), idxT) = names_lthy
38.80 + |> mk_TFrees live
38.81 + |> apfst (`(chop m))
38.82 + ||> mk_TFrees live
38.83 + ||>> apfst (chop m)
38.84 + ||> mk_TFrees live
38.85 + ||>> apfst (chop m)
38.86 + ||>> mk_TFrees m
38.87 + ||>> mk_TFrees m
38.88 + ||> fst o mk_TFrees 1
38.89 + ||> the_single;
38.90 +
38.91 + val Ass = replicate n allAs;
38.92 + val allBs = passiveAs @ activeBs;
38.93 + val Bss = replicate n allBs;
38.94 + val allCs = passiveAs @ activeCs;
38.95 + val allCs' = passiveBs @ activeCs;
38.96 + val Css' = replicate n allCs';
38.97 +
38.98 + (* typs *)
38.99 + val dead_poss =
38.100 + (case resBs of
38.101 + NONE => map SOME deads @ replicate m NONE
38.102 + | SOME Ts => map (fn T => if member (op =) deads (TFree T) then SOME (TFree T) else NONE) Ts);
38.103 + fun mk_param NONE passive = (hd passive, tl passive)
38.104 + | mk_param (SOME a) passive = (a, passive);
38.105 + val mk_params = fold_map mk_param dead_poss #> fst;
38.106 +
38.107 + fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
38.108 + val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
38.109 + val FTsAs = mk_FTs allAs;
38.110 + val FTsBs = mk_FTs allBs;
38.111 + val FTsCs = mk_FTs allCs;
38.112 + val ATs = map HOLogic.mk_setT passiveAs;
38.113 + val BTs = map HOLogic.mk_setT activeAs;
38.114 + val B'Ts = map HOLogic.mk_setT activeBs;
38.115 + val B''Ts = map HOLogic.mk_setT activeCs;
38.116 + val sTs = map2 (fn T => fn U => T --> U) activeAs FTsAs;
38.117 + val s'Ts = map2 (fn T => fn U => T --> U) activeBs FTsBs;
38.118 + val s''Ts = map2 (fn T => fn U => T --> U) activeCs FTsCs;
38.119 + val fTs = map2 (fn T => fn U => T --> U) activeAs activeBs;
38.120 + val all_fTs = map2 (fn T => fn U => T --> U) allAs allBs;
38.121 + val self_fTs = map (fn T => T --> T) activeAs;
38.122 + val gTs = map2 (fn T => fn U => T --> U) activeBs activeCs;
38.123 + val all_gTs = map2 (fn T => fn U => T --> U) allBs allCs';
38.124 + val RTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeBs;
38.125 + val sRTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeAs;
38.126 + val R'Ts = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeBs activeCs;
38.127 + val setsRTs = map HOLogic.mk_setT sRTs;
38.128 + val setRTs = map HOLogic.mk_setT RTs;
38.129 + val all_sbisT = HOLogic.mk_tupleT setsRTs;
38.130 + val setR'Ts = map HOLogic.mk_setT R'Ts;
38.131 + val FRTs = mk_FTs (passiveAs @ RTs);
38.132 + val sumBsAs = map2 (curry mk_sumT) activeBs activeAs;
38.133 + val sumFTs = mk_FTs (passiveAs @ sumBsAs);
38.134 + val sum_sTs = map2 (fn T => fn U => T --> U) activeAs sumFTs;
38.135 +
38.136 + (* terms *)
38.137 + val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
38.138 + val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
38.139 + val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
38.140 + val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
38.141 + val map_Inls = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ sumBsAs)) bnfs;
38.142 + val map_Inls_rev = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ sumBsAs)) Bss bnfs;
38.143 + val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Ass bnfs;
38.144 + val map_snds = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Bss bnfs;
38.145 + fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
38.146 + (map (replicate live) (replicate n Ts)) bnfs;
38.147 + val setssAs = mk_setss allAs;
38.148 + val setssAs' = transpose setssAs;
38.149 + val bis_setss = mk_setss (passiveAs @ RTs);
38.150 + val relsAsBs = map4 mk_srel_of_bnf Dss Ass Bss bnfs;
38.151 + val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
38.152 + val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
38.153 + val sum_bdT = fst (dest_relT (fastype_of sum_bd));
38.154 +
38.155 + val emptys = map (fn T => HOLogic.mk_set T []) passiveAs;
38.156 + val Zeros = map (fn empty =>
38.157 + HOLogic.mk_tuple (map (fn U => absdummy U empty) activeAs)) emptys;
38.158 + val hrecTs = map fastype_of Zeros;
38.159 + val hsetTs = map (fn hrecT => Library.foldr (op -->) (sTs, HOLogic.natT --> hrecT)) hrecTs;
38.160 +
38.161 + val (((((((((((((((((((((((((((((((((((zs, zs'), zs_copy), zs_copy2),
38.162 + z's), As), As_copy), Bs), Bs_copy), B's), B''s), ss), sum_ss), s's), s''s), fs), fs_copy),
38.163 + self_fs), all_fs), gs), all_gs), xFs), xFs_copy), RFs), (Rtuple, Rtuple')), (hrecs, hrecs')),
38.164 + (nat, nat')), Rs), Rs_copy), R's), sRs), (idx, idx')), Idx), Ris), Kss),
38.165 + names_lthy) = lthy
38.166 + |> mk_Frees' "b" activeAs
38.167 + ||>> mk_Frees "b" activeAs
38.168 + ||>> mk_Frees "b" activeAs
38.169 + ||>> mk_Frees "b" activeBs
38.170 + ||>> mk_Frees "A" ATs
38.171 + ||>> mk_Frees "A" ATs
38.172 + ||>> mk_Frees "B" BTs
38.173 + ||>> mk_Frees "B" BTs
38.174 + ||>> mk_Frees "B'" B'Ts
38.175 + ||>> mk_Frees "B''" B''Ts
38.176 + ||>> mk_Frees "s" sTs
38.177 + ||>> mk_Frees "sums" sum_sTs
38.178 + ||>> mk_Frees "s'" s'Ts
38.179 + ||>> mk_Frees "s''" s''Ts
38.180 + ||>> mk_Frees "f" fTs
38.181 + ||>> mk_Frees "f" fTs
38.182 + ||>> mk_Frees "f" self_fTs
38.183 + ||>> mk_Frees "f" all_fTs
38.184 + ||>> mk_Frees "g" gTs
38.185 + ||>> mk_Frees "g" all_gTs
38.186 + ||>> mk_Frees "x" FTsAs
38.187 + ||>> mk_Frees "x" FTsAs
38.188 + ||>> mk_Frees "x" FRTs
38.189 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Rtuple") all_sbisT
38.190 + ||>> mk_Frees' "rec" hrecTs
38.191 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "n") HOLogic.natT
38.192 + ||>> mk_Frees "R" setRTs
38.193 + ||>> mk_Frees "R" setRTs
38.194 + ||>> mk_Frees "R'" setR'Ts
38.195 + ||>> mk_Frees "R" setsRTs
38.196 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "i") idxT
38.197 + ||>> yield_singleton (mk_Frees "I") (HOLogic.mk_setT idxT)
38.198 + ||>> mk_Frees "Ri" (map (fn T => idxT --> T) setRTs)
38.199 + ||>> mk_Freess "K" (map (fn AT => map (fn T => T --> AT) activeAs) ATs);
38.200 +
38.201 + val passive_UNIVs = map HOLogic.mk_UNIV passiveAs;
38.202 + val passive_diags = map mk_diag As;
38.203 + val active_UNIVs = map HOLogic.mk_UNIV activeAs;
38.204 + val sum_UNIVs = map HOLogic.mk_UNIV sumBsAs;
38.205 + val passive_ids = map HOLogic.id_const passiveAs;
38.206 + val active_ids = map HOLogic.id_const activeAs;
38.207 + val Inls = map2 Inl_const activeBs activeAs;
38.208 + val fsts = map fst_const RTs;
38.209 + val snds = map snd_const RTs;
38.210 +
38.211 + (* thms *)
38.212 + val bd_card_orders = map bd_card_order_of_bnf bnfs;
38.213 + val bd_card_order = hd bd_card_orders
38.214 + val bd_Card_orders = map bd_Card_order_of_bnf bnfs;
38.215 + val bd_Card_order = hd bd_Card_orders;
38.216 + val bd_Cinfinites = map bd_Cinfinite_of_bnf bnfs;
38.217 + val bd_Cinfinite = hd bd_Cinfinites;
38.218 + val bd_Cnotzeros = map bd_Cnotzero_of_bnf bnfs;
38.219 + val bd_Cnotzero = hd bd_Cnotzeros;
38.220 + val in_bds = map in_bd_of_bnf bnfs;
38.221 + val in_monos = map in_mono_of_bnf bnfs;
38.222 + val map_comps = map map_comp_of_bnf bnfs;
38.223 + val map_comp's = map map_comp'_of_bnf bnfs;
38.224 + val map_congs = map map_cong_of_bnf bnfs;
38.225 + val map_id's = map map_id'_of_bnf bnfs;
38.226 + val map_wpulls = map map_wpull_of_bnf bnfs;
38.227 + val set_bdss = map set_bd_of_bnf bnfs;
38.228 + val set_natural'ss = map set_natural'_of_bnf bnfs;
38.229 + val srel_congs = map srel_cong_of_bnf bnfs;
38.230 + val srel_converses = map srel_converse_of_bnf bnfs;
38.231 + val srel_defs = map srel_def_of_bnf bnfs;
38.232 + val srel_Grs = map srel_Gr_of_bnf bnfs;
38.233 + val srel_Ids = map srel_Id_of_bnf bnfs;
38.234 + val srel_monos = map srel_mono_of_bnf bnfs;
38.235 + val srel_Os = map srel_O_of_bnf bnfs;
38.236 + val srel_O_Grs = map srel_O_Gr_of_bnf bnfs;
38.237 +
38.238 + val timer = time (timer "Extracted terms & thms");
38.239 +
38.240 + (* derived thms *)
38.241 +
38.242 + (*map g1 ... gm g(m+1) ... g(m+n) (map id ... id f(m+1) ... f(m+n) x)=
38.243 + map g1 ... gm (g(m+1) o f(m+1)) ... (g(m+n) o f(m+n)) x*)
38.244 + fun mk_map_comp_id x mapAsBs mapBsCs mapAsCs map_comp =
38.245 + let
38.246 + val lhs = Term.list_comb (mapBsCs, all_gs) $
38.247 + (Term.list_comb (mapAsBs, passive_ids @ fs) $ x);
38.248 + val rhs =
38.249 + Term.list_comb (mapAsCs, take m all_gs @ map HOLogic.mk_comp (drop m all_gs ~~ fs)) $ x;
38.250 + in
38.251 + Skip_Proof.prove lthy [] []
38.252 + (fold_rev Logic.all (x :: fs @ all_gs) (mk_Trueprop_eq (lhs, rhs)))
38.253 + (K (mk_map_comp_id_tac map_comp))
38.254 + |> Thm.close_derivation
38.255 + end;
38.256 +
38.257 + val map_comp_id_thms = map5 mk_map_comp_id xFs mapsAsBs mapsBsCs' mapsAsCs' map_comp's;
38.258 +
38.259 + (*forall a : set(m+1) x. f(m+1) a = a; ...; forall a : set(m+n) x. f(m+n) a = a ==>
38.260 + map id ... id f(m+1) ... f(m+n) x = x*)
38.261 + fun mk_map_congL x mapAsAs sets map_cong map_id' =
38.262 + let
38.263 + fun mk_prem set f z z' =
38.264 + HOLogic.mk_Trueprop
38.265 + (mk_Ball (set $ x) (Term.absfree z' (HOLogic.mk_eq (f $ z, z))));
38.266 + val prems = map4 mk_prem (drop m sets) self_fs zs zs';
38.267 + val goal = mk_Trueprop_eq (Term.list_comb (mapAsAs, passive_ids @ self_fs) $ x, x);
38.268 + in
38.269 + Skip_Proof.prove lthy [] []
38.270 + (fold_rev Logic.all (x :: self_fs) (Logic.list_implies (prems, goal)))
38.271 + (K (mk_map_congL_tac m map_cong map_id'))
38.272 + |> Thm.close_derivation
38.273 + end;
38.274 +
38.275 + val map_congL_thms = map5 mk_map_congL xFs mapsAsAs setssAs map_congs map_id's;
38.276 + val in_mono'_thms = map (fn thm =>
38.277 + (thm OF (replicate m subset_refl)) RS @{thm set_mp}) in_monos;
38.278 +
38.279 + val map_arg_cong_thms =
38.280 + let
38.281 + val prems = map2 (curry mk_Trueprop_eq) xFs xFs_copy;
38.282 + val maps = map (fn mapx => Term.list_comb (mapx, all_fs)) mapsAsBs;
38.283 + val concls =
38.284 + map3 (fn x => fn y => fn mapx => mk_Trueprop_eq (mapx $ x, mapx $ y)) xFs xFs_copy maps;
38.285 + val goals =
38.286 + map4 (fn prem => fn concl => fn x => fn y =>
38.287 + fold_rev Logic.all (x :: y :: all_fs) (Logic.mk_implies (prem, concl)))
38.288 + prems concls xFs xFs_copy;
38.289 + in
38.290 + map (fn goal => Skip_Proof.prove lthy [] [] goal
38.291 + (K ((hyp_subst_tac THEN' rtac refl) 1)) |> Thm.close_derivation) goals
38.292 + end;
38.293 +
38.294 + val timer = time (timer "Derived simple theorems");
38.295 +
38.296 + (* coalgebra *)
38.297 +
38.298 + val coalg_bind = Binding.suffix_name ("_" ^ coN ^ algN) b;
38.299 + val coalg_name = Binding.name_of coalg_bind;
38.300 + val coalg_def_bind = (Thm.def_binding coalg_bind, []);
38.301 +
38.302 + (*forall i = 1 ... n: (\<forall>x \<in> Bi. si \<in> Fi_in A1 .. Am B1 ... Bn)*)
38.303 + val coalg_spec =
38.304 + let
38.305 + val coalgT = Library.foldr (op -->) (ATs @ BTs @ sTs, HOLogic.boolT);
38.306 +
38.307 + val ins = map3 mk_in (replicate n (As @ Bs)) setssAs FTsAs;
38.308 + fun mk_coalg_conjunct B s X z z' =
38.309 + mk_Ball B (Term.absfree z' (HOLogic.mk_mem (s $ z, X)));
38.310 +
38.311 + val lhs = Term.list_comb (Free (coalg_name, coalgT), As @ Bs @ ss);
38.312 + val rhs = Library.foldr1 HOLogic.mk_conj (map5 mk_coalg_conjunct Bs ss ins zs zs')
38.313 + in
38.314 + mk_Trueprop_eq (lhs, rhs)
38.315 + end;
38.316 +
38.317 + val ((coalg_free, (_, coalg_def_free)), (lthy, lthy_old)) =
38.318 + lthy
38.319 + |> Specification.definition (SOME (coalg_bind, NONE, NoSyn), (coalg_def_bind, coalg_spec))
38.320 + ||> `Local_Theory.restore;
38.321 +
38.322 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.323 + val coalg = fst (Term.dest_Const (Morphism.term phi coalg_free));
38.324 + val coalg_def = Morphism.thm phi coalg_def_free;
38.325 +
38.326 + fun mk_coalg As Bs ss =
38.327 + let
38.328 + val args = As @ Bs @ ss;
38.329 + val Ts = map fastype_of args;
38.330 + val coalgT = Library.foldr (op -->) (Ts, HOLogic.boolT);
38.331 + in
38.332 + Term.list_comb (Const (coalg, coalgT), args)
38.333 + end;
38.334 +
38.335 + val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
38.336 +
38.337 + val coalg_in_thms = map (fn i =>
38.338 + coalg_def RS @{thm subst[of _ _ "%x. x"]} RS mk_conjunctN n i RS bspec) ks
38.339 +
38.340 + val coalg_set_thmss =
38.341 + let
38.342 + val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
38.343 + fun mk_prem x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B));
38.344 + fun mk_concl s x B set = HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) B);
38.345 + val prems = map2 mk_prem zs Bs;
38.346 + val conclss = map3 (fn s => fn x => fn sets => map2 (mk_concl s x) (As @ Bs) sets)
38.347 + ss zs setssAs;
38.348 + val goalss = map3 (fn x => fn prem => fn concls => map (fn concl =>
38.349 + fold_rev Logic.all (x :: As @ Bs @ ss)
38.350 + (Logic.list_implies (coalg_prem :: [prem], concl))) concls) zs prems conclss;
38.351 + in
38.352 + map (fn goals => map (fn goal => Skip_Proof.prove lthy [] [] goal
38.353 + (K (mk_coalg_set_tac coalg_def)) |> Thm.close_derivation) goals) goalss
38.354 + end;
38.355 +
38.356 + val coalg_set_thmss' = transpose coalg_set_thmss;
38.357 +
38.358 + fun mk_tcoalg ATs BTs = mk_coalg (map HOLogic.mk_UNIV ATs) (map HOLogic.mk_UNIV BTs);
38.359 +
38.360 + val tcoalg_thm =
38.361 + let
38.362 + val goal = fold_rev Logic.all ss
38.363 + (HOLogic.mk_Trueprop (mk_tcoalg passiveAs activeAs ss))
38.364 + in
38.365 + Skip_Proof.prove lthy [] [] goal
38.366 + (K (stac coalg_def 1 THEN CONJ_WRAP
38.367 + (K (EVERY' [rtac ballI, rtac CollectI,
38.368 + CONJ_WRAP' (K (EVERY' [rtac @{thm subset_UNIV}])) allAs] 1)) ss))
38.369 + |> Thm.close_derivation
38.370 + end;
38.371 +
38.372 + val timer = time (timer "Coalgebra definition & thms");
38.373 +
38.374 + (* morphism *)
38.375 +
38.376 + val mor_bind = Binding.suffix_name ("_" ^ morN) b;
38.377 + val mor_name = Binding.name_of mor_bind;
38.378 + val mor_def_bind = (Thm.def_binding mor_bind, []);
38.379 +
38.380 + (*fbetw) forall i = 1 ... n: (\<forall>x \<in> Bi. fi x \<in> B'i)*)
38.381 + (*mor) forall i = 1 ... n: (\<forall>x \<in> Bi.
38.382 + Fi_map id ... id f1 ... fn (si x) = si' (fi x)*)
38.383 + val mor_spec =
38.384 + let
38.385 + val morT = Library.foldr (op -->) (BTs @ sTs @ B'Ts @ s'Ts @ fTs, HOLogic.boolT);
38.386 +
38.387 + fun mk_fbetw f B1 B2 z z' =
38.388 + mk_Ball B1 (Term.absfree z' (HOLogic.mk_mem (f $ z, B2)));
38.389 + fun mk_mor B mapAsBs f s s' z z' =
38.390 + mk_Ball B (Term.absfree z' (HOLogic.mk_eq
38.391 + (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ z]), s' $ (f $ z))));
38.392 + val lhs = Term.list_comb (Free (mor_name, morT), Bs @ ss @ B's @ s's @ fs);
38.393 + val rhs = HOLogic.mk_conj
38.394 + (Library.foldr1 HOLogic.mk_conj (map5 mk_fbetw fs Bs B's zs zs'),
38.395 + Library.foldr1 HOLogic.mk_conj (map7 mk_mor Bs mapsAsBs fs ss s's zs zs'))
38.396 + in
38.397 + mk_Trueprop_eq (lhs, rhs)
38.398 + end;
38.399 +
38.400 + val ((mor_free, (_, mor_def_free)), (lthy, lthy_old)) =
38.401 + lthy
38.402 + |> Specification.definition (SOME (mor_bind, NONE, NoSyn), (mor_def_bind, mor_spec))
38.403 + ||> `Local_Theory.restore;
38.404 +
38.405 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.406 + val mor = fst (Term.dest_Const (Morphism.term phi mor_free));
38.407 + val mor_def = Morphism.thm phi mor_def_free;
38.408 +
38.409 + fun mk_mor Bs1 ss1 Bs2 ss2 fs =
38.410 + let
38.411 + val args = Bs1 @ ss1 @ Bs2 @ ss2 @ fs;
38.412 + val Ts = map fastype_of (Bs1 @ ss1 @ Bs2 @ ss2 @ fs);
38.413 + val morT = Library.foldr (op -->) (Ts, HOLogic.boolT);
38.414 + in
38.415 + Term.list_comb (Const (mor, morT), args)
38.416 + end;
38.417 +
38.418 + val mor_prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
38.419 +
38.420 + val (mor_image_thms, morE_thms) =
38.421 + let
38.422 + val prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
38.423 + fun mk_image_goal f B1 B2 = fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs)
38.424 + (Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_subset (mk_image f $ B1) B2)));
38.425 + val image_goals = map3 mk_image_goal fs Bs B's;
38.426 + fun mk_elim_goal B mapAsBs f s s' x =
38.427 + fold_rev Logic.all (x :: Bs @ ss @ B's @ s's @ fs)
38.428 + (Logic.list_implies ([prem, HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B))],
38.429 + mk_Trueprop_eq (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ x]), s' $ (f $ x))));
38.430 + val elim_goals = map6 mk_elim_goal Bs mapsAsBs fs ss s's zs;
38.431 + fun prove goal =
38.432 + Skip_Proof.prove lthy [] [] goal (K (mk_mor_elim_tac mor_def))
38.433 + |> Thm.close_derivation;
38.434 + in
38.435 + (map prove image_goals, map prove elim_goals)
38.436 + end;
38.437 +
38.438 + val mor_image'_thms = map (fn thm => @{thm set_mp} OF [thm, imageI]) mor_image_thms;
38.439 +
38.440 + val mor_incl_thm =
38.441 + let
38.442 + val prems = map2 (HOLogic.mk_Trueprop oo mk_subset) Bs Bs_copy;
38.443 + val concl = HOLogic.mk_Trueprop (mk_mor Bs ss Bs_copy ss active_ids);
38.444 + in
38.445 + Skip_Proof.prove lthy [] []
38.446 + (fold_rev Logic.all (Bs @ ss @ Bs_copy) (Logic.list_implies (prems, concl)))
38.447 + (K (mk_mor_incl_tac mor_def map_id's))
38.448 + |> Thm.close_derivation
38.449 + end;
38.450 +
38.451 + val mor_id_thm = mor_incl_thm OF (replicate n subset_refl);
38.452 +
38.453 + val mor_comp_thm =
38.454 + let
38.455 + val prems =
38.456 + [HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs),
38.457 + HOLogic.mk_Trueprop (mk_mor B's s's B''s s''s gs)];
38.458 + val concl =
38.459 + HOLogic.mk_Trueprop (mk_mor Bs ss B''s s''s (map2 (curry HOLogic.mk_comp) gs fs));
38.460 + in
38.461 + Skip_Proof.prove lthy [] []
38.462 + (fold_rev Logic.all (Bs @ ss @ B's @ s's @ B''s @ s''s @ fs @ gs)
38.463 + (Logic.list_implies (prems, concl)))
38.464 + (K (mk_mor_comp_tac mor_def mor_image'_thms morE_thms map_comp_id_thms))
38.465 + |> Thm.close_derivation
38.466 + end;
38.467 +
38.468 + val mor_cong_thm =
38.469 + let
38.470 + val prems = map HOLogic.mk_Trueprop
38.471 + (map2 (curry HOLogic.mk_eq) fs_copy fs @ [mk_mor Bs ss B's s's fs])
38.472 + val concl = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs_copy);
38.473 + in
38.474 + Skip_Proof.prove lthy [] []
38.475 + (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ fs_copy)
38.476 + (Logic.list_implies (prems, concl)))
38.477 + (K ((hyp_subst_tac THEN' atac) 1))
38.478 + |> Thm.close_derivation
38.479 + end;
38.480 +
38.481 + val mor_UNIV_thm =
38.482 + let
38.483 + fun mk_conjunct mapAsBs f s s' = HOLogic.mk_eq
38.484 + (HOLogic.mk_comp (Term.list_comb (mapAsBs, passive_ids @ fs), s),
38.485 + HOLogic.mk_comp (s', f));
38.486 + val lhs = mk_mor active_UNIVs ss (map HOLogic.mk_UNIV activeBs) s's fs;
38.487 + val rhs = Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct mapsAsBs fs ss s's);
38.488 + in
38.489 + Skip_Proof.prove lthy [] [] (fold_rev Logic.all (ss @ s's @ fs) (mk_Trueprop_eq (lhs, rhs)))
38.490 + (K (mk_mor_UNIV_tac morE_thms mor_def))
38.491 + |> Thm.close_derivation
38.492 + end;
38.493 +
38.494 + val mor_str_thm =
38.495 + let
38.496 + val maps = map2 (fn Ds => fn bnf => Term.list_comb
38.497 + (mk_map_of_bnf Ds allAs (passiveAs @ FTsAs) bnf, passive_ids @ ss)) Dss bnfs;
38.498 + in
38.499 + Skip_Proof.prove lthy [] []
38.500 + (fold_rev Logic.all ss (HOLogic.mk_Trueprop
38.501 + (mk_mor active_UNIVs ss (map HOLogic.mk_UNIV FTsAs) maps ss)))
38.502 + (K (mk_mor_str_tac ks mor_UNIV_thm))
38.503 + |> Thm.close_derivation
38.504 + end;
38.505 +
38.506 + val mor_sum_case_thm =
38.507 + let
38.508 + val maps = map3 (fn s => fn sum_s => fn mapx =>
38.509 + mk_sum_case (HOLogic.mk_comp (Term.list_comb (mapx, passive_ids @ Inls), s), sum_s))
38.510 + s's sum_ss map_Inls;
38.511 + in
38.512 + Skip_Proof.prove lthy [] []
38.513 + (fold_rev Logic.all (s's @ sum_ss) (HOLogic.mk_Trueprop
38.514 + (mk_mor (map HOLogic.mk_UNIV activeBs) s's sum_UNIVs maps Inls)))
38.515 + (K (mk_mor_sum_case_tac ks mor_UNIV_thm))
38.516 + |> Thm.close_derivation
38.517 + end;
38.518 +
38.519 + val timer = time (timer "Morphism definition & thms");
38.520 +
38.521 + fun hset_rec_bind j = Binding.suffix_name ("_" ^ hset_recN ^ (if m = 1 then "" else
38.522 + string_of_int j)) b;
38.523 + val hset_rec_name = Binding.name_of o hset_rec_bind;
38.524 + val hset_rec_def_bind = rpair [] o Thm.def_binding o hset_rec_bind;
38.525 +
38.526 + fun hset_rec_spec j Zero hsetT hrec hrec' =
38.527 + let
38.528 + fun mk_Suc s setsAs z z' =
38.529 + let
38.530 + val (set, sets) = apfst (fn xs => nth xs (j - 1)) (chop m setsAs);
38.531 + fun mk_UN set k = mk_UNION (set $ (s $ z)) (mk_nthN n hrec k);
38.532 + in
38.533 + Term.absfree z'
38.534 + (mk_union (set $ (s $ z), Library.foldl1 mk_union (map2 mk_UN sets ks)))
38.535 + end;
38.536 +
38.537 + val Suc = Term.absdummy HOLogic.natT (Term.absfree hrec'
38.538 + (HOLogic.mk_tuple (map4 mk_Suc ss setssAs zs zs')));
38.539 +
38.540 + val lhs = Term.list_comb (Free (hset_rec_name j, hsetT), ss);
38.541 + val rhs = mk_nat_rec Zero Suc;
38.542 + in
38.543 + mk_Trueprop_eq (lhs, rhs)
38.544 + end;
38.545 +
38.546 + val ((hset_rec_frees, (_, hset_rec_def_frees)), (lthy, lthy_old)) =
38.547 + lthy
38.548 + |> fold_map5 (fn j => fn Zero => fn hsetT => fn hrec => fn hrec' => Specification.definition
38.549 + (SOME (hset_rec_bind j, NONE, NoSyn),
38.550 + (hset_rec_def_bind j, hset_rec_spec j Zero hsetT hrec hrec')))
38.551 + ls Zeros hsetTs hrecs hrecs'
38.552 + |>> apsnd split_list o split_list
38.553 + ||> `Local_Theory.restore;
38.554 +
38.555 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.556 +
38.557 + val hset_rec_defs = map (Morphism.thm phi) hset_rec_def_frees;
38.558 + val hset_recs = map (fst o Term.dest_Const o Morphism.term phi) hset_rec_frees;
38.559 +
38.560 + fun mk_hset_rec ss nat i j T =
38.561 + let
38.562 + val args = ss @ [nat];
38.563 + val Ts = map fastype_of ss;
38.564 + val bTs = map domain_type Ts;
38.565 + val hrecT = HOLogic.mk_tupleT (map (fn U => U --> HOLogic.mk_setT T) bTs)
38.566 + val hset_recT = Library.foldr (op -->) (Ts, HOLogic.natT --> hrecT);
38.567 + in
38.568 + mk_nthN n (Term.list_comb (Const (nth hset_recs (j - 1), hset_recT), args)) i
38.569 + end;
38.570 +
38.571 + val hset_rec_0ss = mk_rec_simps n @{thm nat_rec_0} hset_rec_defs;
38.572 + val hset_rec_Sucss = mk_rec_simps n @{thm nat_rec_Suc} hset_rec_defs;
38.573 + val hset_rec_0ss' = transpose hset_rec_0ss;
38.574 + val hset_rec_Sucss' = transpose hset_rec_Sucss;
38.575 +
38.576 + fun hset_bind i j = Binding.suffix_name ("_" ^ hsetN ^
38.577 + (if m = 1 then "" else string_of_int j)) (nth bs (i - 1));
38.578 + val hset_name = Binding.name_of oo hset_bind;
38.579 + val hset_def_bind = rpair [] o Thm.def_binding oo hset_bind;
38.580 +
38.581 + fun hset_spec i j =
38.582 + let
38.583 + val U = nth activeAs (i - 1);
38.584 + val z = nth zs (i - 1);
38.585 + val T = nth passiveAs (j - 1);
38.586 + val setT = HOLogic.mk_setT T;
38.587 + val hsetT = Library.foldr (op -->) (sTs, U --> setT);
38.588 +
38.589 + val lhs = Term.list_comb (Free (hset_name i j, hsetT), ss @ [z]);
38.590 + val rhs = mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
38.591 + (Term.absfree nat' (mk_hset_rec ss nat i j T $ z));
38.592 + in
38.593 + mk_Trueprop_eq (lhs, rhs)
38.594 + end;
38.595 +
38.596 + val ((hset_frees, (_, hset_def_frees)), (lthy, lthy_old)) =
38.597 + lthy
38.598 + |> fold_map (fn i => fold_map (fn j => Specification.definition
38.599 + (SOME (hset_bind i j, NONE, NoSyn), (hset_def_bind i j, hset_spec i j))) ls) ks
38.600 + |>> map (apsnd split_list o split_list)
38.601 + |>> apsnd split_list o split_list
38.602 + ||> `Local_Theory.restore;
38.603 +
38.604 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.605 +
38.606 + val hset_defss = map (map (Morphism.thm phi)) hset_def_frees;
38.607 + val hset_defss' = transpose hset_defss;
38.608 + val hset_namess = map (map (fst o Term.dest_Const o Morphism.term phi)) hset_frees;
38.609 +
38.610 + fun mk_hset ss i j T =
38.611 + let
38.612 + val Ts = map fastype_of ss;
38.613 + val bTs = map domain_type Ts;
38.614 + val hsetT = Library.foldr (op -->) (Ts, nth bTs (i - 1) --> HOLogic.mk_setT T);
38.615 + in
38.616 + Term.list_comb (Const (nth (nth hset_namess (i - 1)) (j - 1), hsetT), ss)
38.617 + end;
38.618 +
38.619 + val hsetssAs = map (fn i => map2 (mk_hset ss i) ls passiveAs) ks;
38.620 +
38.621 + val (set_incl_hset_thmss, set_hset_incl_hset_thmsss) =
38.622 + let
38.623 + fun mk_set_incl_hset s x set hset = fold_rev Logic.all (x :: ss)
38.624 + (HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) (hset $ x)));
38.625 +
38.626 + fun mk_set_hset_incl_hset s x y set hset1 hset2 =
38.627 + fold_rev Logic.all (x :: y :: ss)
38.628 + (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x, set $ (s $ y))),
38.629 + HOLogic.mk_Trueprop (mk_subset (hset1 $ x) (hset2 $ y))));
38.630 +
38.631 + val set_incl_hset_goalss =
38.632 + map4 (fn s => fn x => fn sets => fn hsets =>
38.633 + map2 (mk_set_incl_hset s x) (take m sets) hsets)
38.634 + ss zs setssAs hsetssAs;
38.635 +
38.636 + (*xk : F(i)set(m+k) (si yi) ==> F(k)_hset(j) s1 ... sn xk <= F(i)_hset(j) s1 ... sn yi*)
38.637 + val set_hset_incl_hset_goalsss =
38.638 + map4 (fn si => fn yi => fn sets => fn hsetsi =>
38.639 + map3 (fn xk => fn set => fn hsetsk =>
38.640 + map2 (mk_set_hset_incl_hset si xk yi set) hsetsk hsetsi)
38.641 + zs_copy (drop m sets) hsetssAs)
38.642 + ss zs setssAs hsetssAs;
38.643 + in
38.644 + (map3 (fn goals => fn defs => fn rec_Sucs =>
38.645 + map3 (fn goal => fn def => fn rec_Suc =>
38.646 + Skip_Proof.prove lthy [] [] goal (K (mk_set_incl_hset_tac def rec_Suc))
38.647 + |> Thm.close_derivation)
38.648 + goals defs rec_Sucs)
38.649 + set_incl_hset_goalss hset_defss hset_rec_Sucss,
38.650 + map3 (fn goalss => fn defsi => fn rec_Sucs =>
38.651 + map3 (fn k => fn goals => fn defsk =>
38.652 + map4 (fn goal => fn defk => fn defi => fn rec_Suc =>
38.653 + Skip_Proof.prove lthy [] [] goal
38.654 + (K (mk_set_hset_incl_hset_tac n [defk, defi] rec_Suc k))
38.655 + |> Thm.close_derivation)
38.656 + goals defsk defsi rec_Sucs)
38.657 + ks goalss hset_defss)
38.658 + set_hset_incl_hset_goalsss hset_defss hset_rec_Sucss)
38.659 + end;
38.660 +
38.661 + val set_incl_hset_thmss' = transpose set_incl_hset_thmss;
38.662 + val set_hset_incl_hset_thmsss' = transpose (map transpose set_hset_incl_hset_thmsss);
38.663 + val set_hset_incl_hset_thmsss'' = map transpose set_hset_incl_hset_thmsss';
38.664 + val set_hset_thmss = map (map (fn thm => thm RS @{thm set_mp})) set_incl_hset_thmss;
38.665 + val set_hset_hset_thmsss = map (map (map (fn thm => thm RS @{thm set_mp})))
38.666 + set_hset_incl_hset_thmsss;
38.667 + val set_hset_thmss' = transpose set_hset_thmss;
38.668 + val set_hset_hset_thmsss' = transpose (map transpose set_hset_hset_thmsss);
38.669 +
38.670 + val set_incl_hin_thmss =
38.671 + let
38.672 + fun mk_set_incl_hin s x hsets1 set hsets2 T =
38.673 + fold_rev Logic.all (x :: ss @ As)
38.674 + (Logic.list_implies
38.675 + (map2 (fn hset => fn A => HOLogic.mk_Trueprop (mk_subset (hset $ x) A)) hsets1 As,
38.676 + HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) (mk_in As hsets2 T))));
38.677 +
38.678 + val set_incl_hin_goalss =
38.679 + map4 (fn s => fn x => fn sets => fn hsets =>
38.680 + map3 (mk_set_incl_hin s x hsets) (drop m sets) hsetssAs activeAs)
38.681 + ss zs setssAs hsetssAs;
38.682 + in
38.683 + map2 (map2 (fn goal => fn thms =>
38.684 + Skip_Proof.prove lthy [] [] goal (K (mk_set_incl_hin_tac thms))
38.685 + |> Thm.close_derivation))
38.686 + set_incl_hin_goalss set_hset_incl_hset_thmsss
38.687 + end;
38.688 +
38.689 + val hset_minimal_thms =
38.690 + let
38.691 + fun mk_passive_prem set s x K =
38.692 + Logic.all x (HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) (K $ x)));
38.693 +
38.694 + fun mk_active_prem s x1 K1 set x2 K2 =
38.695 + fold_rev Logic.all [x1, x2]
38.696 + (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x2, set $ (s $ x1))),
38.697 + HOLogic.mk_Trueprop (mk_subset (K2 $ x2) (K1 $ x1))));
38.698 +
38.699 + val premss = map2 (fn j => fn Ks =>
38.700 + map4 mk_passive_prem (map (fn xs => nth xs (j - 1)) setssAs) ss zs Ks @
38.701 + flat (map4 (fn sets => fn s => fn x1 => fn K1 =>
38.702 + map3 (mk_active_prem s x1 K1) (drop m sets) zs_copy Ks) setssAs ss zs Ks))
38.703 + ls Kss;
38.704 +
38.705 + val hset_rec_minimal_thms =
38.706 + let
38.707 + fun mk_conjunct j T i K x = mk_subset (mk_hset_rec ss nat i j T $ x) (K $ x);
38.708 + fun mk_concl j T Ks = list_all_free zs
38.709 + (Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs));
38.710 + val concls = map3 mk_concl ls passiveAs Kss;
38.711 +
38.712 + val goals = map2 (fn prems => fn concl =>
38.713 + Logic.list_implies (prems, HOLogic.mk_Trueprop concl)) premss concls
38.714 +
38.715 + val ctss =
38.716 + map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
38.717 + in
38.718 + map4 (fn goal => fn cts => fn hset_rec_0s => fn hset_rec_Sucs =>
38.719 + singleton (Proof_Context.export names_lthy lthy)
38.720 + (Skip_Proof.prove lthy [] [] goal
38.721 + (mk_hset_rec_minimal_tac m cts hset_rec_0s hset_rec_Sucs))
38.722 + |> Thm.close_derivation)
38.723 + goals ctss hset_rec_0ss' hset_rec_Sucss'
38.724 + end;
38.725 +
38.726 + fun mk_conjunct j T i K x = mk_subset (mk_hset ss i j T $ x) (K $ x);
38.727 + fun mk_concl j T Ks = Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs);
38.728 + val concls = map3 mk_concl ls passiveAs Kss;
38.729 +
38.730 + val goals = map3 (fn Ks => fn prems => fn concl =>
38.731 + fold_rev Logic.all (Ks @ ss @ zs)
38.732 + (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))) Kss premss concls;
38.733 + in
38.734 + map3 (fn goal => fn hset_defs => fn hset_rec_minimal =>
38.735 + Skip_Proof.prove lthy [] [] goal
38.736 + (mk_hset_minimal_tac n hset_defs hset_rec_minimal)
38.737 + |> Thm.close_derivation)
38.738 + goals hset_defss' hset_rec_minimal_thms
38.739 + end;
38.740 +
38.741 + val mor_hset_thmss =
38.742 + let
38.743 + val mor_hset_rec_thms =
38.744 + let
38.745 + fun mk_conjunct j T i f x B =
38.746 + HOLogic.mk_imp (HOLogic.mk_mem (x, B), HOLogic.mk_eq
38.747 + (mk_hset_rec s's nat i j T $ (f $ x), mk_hset_rec ss nat i j T $ x));
38.748 +
38.749 + fun mk_concl j T = list_all_free zs
38.750 + (Library.foldr1 HOLogic.mk_conj (map4 (mk_conjunct j T) ks fs zs Bs));
38.751 + val concls = map2 mk_concl ls passiveAs;
38.752 +
38.753 + val ctss =
38.754 + map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
38.755 +
38.756 + val goals = map (fn concl =>
38.757 + Logic.list_implies ([coalg_prem, mor_prem], HOLogic.mk_Trueprop concl)) concls;
38.758 + in
38.759 + map5 (fn j => fn goal => fn cts => fn hset_rec_0s => fn hset_rec_Sucs =>
38.760 + singleton (Proof_Context.export names_lthy lthy)
38.761 + (Skip_Proof.prove lthy [] [] goal
38.762 + (K (mk_mor_hset_rec_tac m n cts j hset_rec_0s hset_rec_Sucs
38.763 + morE_thms set_natural'ss coalg_set_thmss)))
38.764 + |> Thm.close_derivation)
38.765 + ls goals ctss hset_rec_0ss' hset_rec_Sucss'
38.766 + end;
38.767 +
38.768 + val mor_hset_rec_thmss = map (fn thm => map (fn i =>
38.769 + mk_specN n thm RS mk_conjunctN n i RS mp) ks) mor_hset_rec_thms;
38.770 +
38.771 + fun mk_prem x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B));
38.772 +
38.773 + fun mk_concl j T i f x =
38.774 + mk_Trueprop_eq (mk_hset s's i j T $ (f $ x), mk_hset ss i j T $ x);
38.775 +
38.776 + val goalss = map2 (fn j => fn T => map4 (fn i => fn f => fn x => fn B =>
38.777 + fold_rev Logic.all (x :: As @ Bs @ ss @ B's @ s's @ fs)
38.778 + (Logic.list_implies ([coalg_prem, mor_prem,
38.779 + mk_prem x B], mk_concl j T i f x))) ks fs zs Bs) ls passiveAs;
38.780 + in
38.781 + map3 (map3 (fn goal => fn hset_def => fn mor_hset_rec =>
38.782 + Skip_Proof.prove lthy [] [] goal
38.783 + (K (mk_mor_hset_tac hset_def mor_hset_rec))
38.784 + |> Thm.close_derivation))
38.785 + goalss hset_defss' mor_hset_rec_thmss
38.786 + end;
38.787 +
38.788 + val timer = time (timer "Hereditary sets");
38.789 +
38.790 + (* bisimulation *)
38.791 +
38.792 + val bis_bind = Binding.suffix_name ("_" ^ bisN) b;
38.793 + val bis_name = Binding.name_of bis_bind;
38.794 + val bis_def_bind = (Thm.def_binding bis_bind, []);
38.795 +
38.796 + fun mk_bis_le_conjunct R B1 B2 = mk_subset R (mk_Times (B1, B2));
38.797 + val bis_le = Library.foldr1 HOLogic.mk_conj (map3 mk_bis_le_conjunct Rs Bs B's)
38.798 +
38.799 + val bis_spec =
38.800 + let
38.801 + val bisT = Library.foldr (op -->) (ATs @ BTs @ sTs @ B'Ts @ s'Ts @ setRTs, HOLogic.boolT);
38.802 +
38.803 + val fst_args = passive_ids @ fsts;
38.804 + val snd_args = passive_ids @ snds;
38.805 + fun mk_bis R s s' b1 b2 RF map1 map2 sets =
38.806 + list_all_free [b1, b2] (HOLogic.mk_imp
38.807 + (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
38.808 + mk_Bex (mk_in (As @ Rs) sets (snd (dest_Free RF))) (Term.absfree (dest_Free RF)
38.809 + (HOLogic.mk_conj
38.810 + (HOLogic.mk_eq (Term.list_comb (map1, fst_args) $ RF, s $ b1),
38.811 + HOLogic.mk_eq (Term.list_comb (map2, snd_args) $ RF, s' $ b2))))));
38.812 +
38.813 + val lhs = Term.list_comb (Free (bis_name, bisT), As @ Bs @ ss @ B's @ s's @ Rs);
38.814 + val rhs = HOLogic.mk_conj
38.815 + (bis_le, Library.foldr1 HOLogic.mk_conj
38.816 + (map9 mk_bis Rs ss s's zs z's RFs map_fsts map_snds bis_setss))
38.817 + in
38.818 + mk_Trueprop_eq (lhs, rhs)
38.819 + end;
38.820 +
38.821 + val ((bis_free, (_, bis_def_free)), (lthy, lthy_old)) =
38.822 + lthy
38.823 + |> Specification.definition (SOME (bis_bind, NONE, NoSyn), (bis_def_bind, bis_spec))
38.824 + ||> `Local_Theory.restore;
38.825 +
38.826 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.827 + val bis = fst (Term.dest_Const (Morphism.term phi bis_free));
38.828 + val bis_def = Morphism.thm phi bis_def_free;
38.829 +
38.830 + fun mk_bis As Bs1 ss1 Bs2 ss2 Rs =
38.831 + let
38.832 + val args = As @ Bs1 @ ss1 @ Bs2 @ ss2 @ Rs;
38.833 + val Ts = map fastype_of args;
38.834 + val bisT = Library.foldr (op -->) (Ts, HOLogic.boolT);
38.835 + in
38.836 + Term.list_comb (Const (bis, bisT), args)
38.837 + end;
38.838 +
38.839 + val bis_cong_thm =
38.840 + let
38.841 + val prems = map HOLogic.mk_Trueprop
38.842 + (mk_bis As Bs ss B's s's Rs :: map2 (curry HOLogic.mk_eq) Rs_copy Rs)
38.843 + val concl = HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs_copy);
38.844 + in
38.845 + Skip_Proof.prove lthy [] []
38.846 + (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs @ Rs_copy)
38.847 + (Logic.list_implies (prems, concl)))
38.848 + (K ((hyp_subst_tac THEN' atac) 1))
38.849 + |> Thm.close_derivation
38.850 + end;
38.851 +
38.852 + val bis_srel_thm =
38.853 + let
38.854 + fun mk_conjunct R s s' b1 b2 srel =
38.855 + list_all_free [b1, b2] (HOLogic.mk_imp
38.856 + (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
38.857 + HOLogic.mk_mem (HOLogic.mk_prod (s $ b1, s' $ b2),
38.858 + Term.list_comb (srel, passive_diags @ Rs))));
38.859 +
38.860 + val rhs = HOLogic.mk_conj
38.861 + (bis_le, Library.foldr1 HOLogic.mk_conj
38.862 + (map6 mk_conjunct Rs ss s's zs z's relsAsBs))
38.863 + in
38.864 + Skip_Proof.prove lthy [] []
38.865 + (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
38.866 + (mk_Trueprop_eq (mk_bis As Bs ss B's s's Rs, rhs)))
38.867 + (K (mk_bis_srel_tac m bis_def srel_O_Grs map_comp's map_congs set_natural'ss))
38.868 + |> Thm.close_derivation
38.869 + end;
38.870 +
38.871 + val bis_converse_thm =
38.872 + Skip_Proof.prove lthy [] []
38.873 + (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
38.874 + (Logic.mk_implies
38.875 + (HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
38.876 + HOLogic.mk_Trueprop (mk_bis As B's s's Bs ss (map mk_converse Rs)))))
38.877 + (K (mk_bis_converse_tac m bis_srel_thm srel_congs srel_converses))
38.878 + |> Thm.close_derivation;
38.879 +
38.880 + val bis_O_thm =
38.881 + let
38.882 + val prems =
38.883 + [HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
38.884 + HOLogic.mk_Trueprop (mk_bis As B's s's B''s s''s R's)];
38.885 + val concl =
38.886 + HOLogic.mk_Trueprop (mk_bis As Bs ss B''s s''s (map2 (curry mk_rel_comp) Rs R's));
38.887 + in
38.888 + Skip_Proof.prove lthy [] []
38.889 + (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ B''s @ s''s @ Rs @ R's)
38.890 + (Logic.list_implies (prems, concl)))
38.891 + (K (mk_bis_O_tac m bis_srel_thm srel_congs srel_Os))
38.892 + |> Thm.close_derivation
38.893 + end;
38.894 +
38.895 + val bis_Gr_thm =
38.896 + let
38.897 + val concl =
38.898 + HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map2 mk_Gr Bs fs));
38.899 + in
38.900 + Skip_Proof.prove lthy [] []
38.901 + (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ fs)
38.902 + (Logic.list_implies ([coalg_prem, mor_prem], concl)))
38.903 + (mk_bis_Gr_tac bis_srel_thm srel_Grs mor_image_thms morE_thms coalg_in_thms)
38.904 + |> Thm.close_derivation
38.905 + end;
38.906 +
38.907 + val bis_image2_thm = bis_cong_thm OF
38.908 + ((bis_O_thm OF [bis_Gr_thm RS bis_converse_thm, bis_Gr_thm]) ::
38.909 + replicate n @{thm image2_Gr});
38.910 +
38.911 + val bis_diag_thm = bis_cong_thm OF ((mor_id_thm RSN (2, bis_Gr_thm)) ::
38.912 + replicate n @{thm diag_Gr});
38.913 +
38.914 + val bis_Union_thm =
38.915 + let
38.916 + val prem =
38.917 + HOLogic.mk_Trueprop (mk_Ball Idx
38.918 + (Term.absfree idx' (mk_bis As Bs ss B's s's (map (fn R => R $ idx) Ris))));
38.919 + val concl =
38.920 + HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map (mk_UNION Idx) Ris));
38.921 + in
38.922 + Skip_Proof.prove lthy [] []
38.923 + (fold_rev Logic.all (Idx :: As @ Bs @ ss @ B's @ s's @ Ris)
38.924 + (Logic.mk_implies (prem, concl)))
38.925 + (mk_bis_Union_tac bis_def in_mono'_thms)
38.926 + |> Thm.close_derivation
38.927 + end;
38.928 +
38.929 + (* self-bisimulation *)
38.930 +
38.931 + fun mk_sbis As Bs ss Rs = mk_bis As Bs ss Bs ss Rs;
38.932 +
38.933 + val sbis_prem = HOLogic.mk_Trueprop (mk_sbis As Bs ss sRs);
38.934 +
38.935 + (* largest self-bisimulation *)
38.936 +
38.937 + fun lsbis_bind i = Binding.suffix_name ("_" ^ lsbisN ^ (if n = 1 then "" else
38.938 + string_of_int i)) b;
38.939 + val lsbis_name = Binding.name_of o lsbis_bind;
38.940 + val lsbis_def_bind = rpair [] o Thm.def_binding o lsbis_bind;
38.941 +
38.942 + val all_sbis = HOLogic.mk_Collect (fst Rtuple', snd Rtuple', list_exists_free sRs
38.943 + (HOLogic.mk_conj (HOLogic.mk_eq (Rtuple, HOLogic.mk_tuple sRs), mk_sbis As Bs ss sRs)));
38.944 +
38.945 + fun lsbis_spec i RT =
38.946 + let
38.947 + fun mk_lsbisT RT =
38.948 + Library.foldr (op -->) (map fastype_of (As @ Bs @ ss), RT);
38.949 + val lhs = Term.list_comb (Free (lsbis_name i, mk_lsbisT RT), As @ Bs @ ss);
38.950 + val rhs = mk_UNION all_sbis (Term.absfree Rtuple' (mk_nthN n Rtuple i));
38.951 + in
38.952 + mk_Trueprop_eq (lhs, rhs)
38.953 + end;
38.954 +
38.955 + val ((lsbis_frees, (_, lsbis_def_frees)), (lthy, lthy_old)) =
38.956 + lthy
38.957 + |> fold_map2 (fn i => fn RT => Specification.definition
38.958 + (SOME (lsbis_bind i, NONE, NoSyn), (lsbis_def_bind i, lsbis_spec i RT))) ks setsRTs
38.959 + |>> apsnd split_list o split_list
38.960 + ||> `Local_Theory.restore;
38.961 +
38.962 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.963 +
38.964 + val lsbis_defs = map (Morphism.thm phi) lsbis_def_frees;
38.965 + val lsbiss = map (fst o Term.dest_Const o Morphism.term phi) lsbis_frees;
38.966 +
38.967 + fun mk_lsbis As Bs ss i =
38.968 + let
38.969 + val args = As @ Bs @ ss;
38.970 + val Ts = map fastype_of args;
38.971 + val RT = mk_relT (`I (HOLogic.dest_setT (fastype_of (nth Bs (i - 1)))));
38.972 + val lsbisT = Library.foldr (op -->) (Ts, RT);
38.973 + in
38.974 + Term.list_comb (Const (nth lsbiss (i - 1), lsbisT), args)
38.975 + end;
38.976 +
38.977 + val sbis_lsbis_thm =
38.978 + Skip_Proof.prove lthy [] []
38.979 + (fold_rev Logic.all (As @ Bs @ ss)
38.980 + (HOLogic.mk_Trueprop (mk_sbis As Bs ss (map (mk_lsbis As Bs ss) ks))))
38.981 + (K (mk_sbis_lsbis_tac lsbis_defs bis_Union_thm bis_cong_thm))
38.982 + |> Thm.close_derivation;
38.983 +
38.984 + val lsbis_incl_thms = map (fn i => sbis_lsbis_thm RS
38.985 + (bis_def RS @{thm subst[of _ _ "%x. x"]} RS conjunct1 RS mk_conjunctN n i)) ks;
38.986 + val lsbisE_thms = map (fn i => (mk_specN 2 (sbis_lsbis_thm RS
38.987 + (bis_def RS @{thm subst[of _ _ "%x. x"]} RS conjunct2 RS mk_conjunctN n i))) RS mp) ks;
38.988 +
38.989 + val incl_lsbis_thms =
38.990 + let
38.991 + fun mk_concl i R = HOLogic.mk_Trueprop (mk_subset R (mk_lsbis As Bs ss i));
38.992 + val goals = map2 (fn i => fn R => fold_rev Logic.all (As @ Bs @ ss @ sRs)
38.993 + (Logic.mk_implies (sbis_prem, mk_concl i R))) ks sRs;
38.994 + in
38.995 + map3 (fn goal => fn i => fn def => Skip_Proof.prove lthy [] [] goal
38.996 + (K (mk_incl_lsbis_tac n i def)) |> Thm.close_derivation) goals ks lsbis_defs
38.997 + end;
38.998 +
38.999 + val equiv_lsbis_thms =
38.1000 + let
38.1001 + fun mk_concl i B = HOLogic.mk_Trueprop (mk_equiv B (mk_lsbis As Bs ss i));
38.1002 + val goals = map2 (fn i => fn B => fold_rev Logic.all (As @ Bs @ ss)
38.1003 + (Logic.mk_implies (coalg_prem, mk_concl i B))) ks Bs;
38.1004 + in
38.1005 + map3 (fn goal => fn l_incl => fn incl_l =>
38.1006 + Skip_Proof.prove lthy [] [] goal
38.1007 + (K (mk_equiv_lsbis_tac sbis_lsbis_thm l_incl incl_l
38.1008 + bis_diag_thm bis_converse_thm bis_O_thm))
38.1009 + |> Thm.close_derivation)
38.1010 + goals lsbis_incl_thms incl_lsbis_thms
38.1011 + end;
38.1012 +
38.1013 + val timer = time (timer "Bisimulations");
38.1014 +
38.1015 + (* bounds *)
38.1016 +
38.1017 + val (lthy, sbd, sbdT,
38.1018 + sbd_card_order, sbd_Cinfinite, sbd_Cnotzero, sbd_Card_order, set_sbdss, in_sbds) =
38.1019 + if n = 1
38.1020 + then (lthy, sum_bd, sum_bdT,
38.1021 + bd_card_order, bd_Cinfinite, bd_Cnotzero, bd_Card_order, set_bdss, in_bds)
38.1022 + else
38.1023 + let
38.1024 + val sbdT_bind = Binding.suffix_name ("_" ^ sum_bdTN) b;
38.1025 +
38.1026 + val ((sbdT_name, (sbdT_glob_info, sbdT_loc_info)), lthy) =
38.1027 + typedef false NONE (sbdT_bind, params, NoSyn)
38.1028 + (HOLogic.mk_UNIV sum_bdT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
38.1029 +
38.1030 + val sbdT = Type (sbdT_name, params');
38.1031 + val Abs_sbdT = Const (#Abs_name sbdT_glob_info, sum_bdT --> sbdT);
38.1032 +
38.1033 + val sbd_bind = Binding.suffix_name ("_" ^ sum_bdN) b;
38.1034 + val sbd_name = Binding.name_of sbd_bind;
38.1035 + val sbd_def_bind = (Thm.def_binding sbd_bind, []);
38.1036 +
38.1037 + val sbd_spec = HOLogic.mk_Trueprop
38.1038 + (HOLogic.mk_eq (Free (sbd_name, mk_relT (`I sbdT)), mk_dir_image sum_bd Abs_sbdT));
38.1039 +
38.1040 + val ((sbd_free, (_, sbd_def_free)), (lthy, lthy_old)) =
38.1041 + lthy
38.1042 + |> Specification.definition (SOME (sbd_bind, NONE, NoSyn), (sbd_def_bind, sbd_spec))
38.1043 + ||> `Local_Theory.restore;
38.1044 +
38.1045 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1046 +
38.1047 + val sbd_def = Morphism.thm phi sbd_def_free;
38.1048 + val sbd = Const (fst (Term.dest_Const (Morphism.term phi sbd_free)), mk_relT (`I sbdT));
38.1049 +
38.1050 + val Abs_sbdT_inj = mk_Abs_inj_thm (#Abs_inject sbdT_loc_info);
38.1051 + val Abs_sbdT_bij = mk_Abs_bij_thm lthy Abs_sbdT_inj (#Abs_cases sbdT_loc_info);
38.1052 +
38.1053 + fun mk_sum_Cinfinite [thm] = thm
38.1054 + | mk_sum_Cinfinite (thm :: thms) =
38.1055 + @{thm Cinfinite_csum_strong} OF [thm, mk_sum_Cinfinite thms];
38.1056 +
38.1057 + val sum_Cinfinite = mk_sum_Cinfinite bd_Cinfinites;
38.1058 + val sum_Card_order = sum_Cinfinite RS conjunct2;
38.1059 +
38.1060 + fun mk_sum_card_order [thm] = thm
38.1061 + | mk_sum_card_order (thm :: thms) =
38.1062 + @{thm card_order_csum} OF [thm, mk_sum_card_order thms];
38.1063 +
38.1064 + val sum_card_order = mk_sum_card_order bd_card_orders;
38.1065 +
38.1066 + val sbd_ordIso = fold_thms lthy [sbd_def]
38.1067 + (@{thm dir_image} OF [Abs_sbdT_inj, sum_Card_order]);
38.1068 + val sbd_card_order = fold_thms lthy [sbd_def]
38.1069 + (@{thm card_order_dir_image} OF [Abs_sbdT_bij, sum_card_order]);
38.1070 + val sbd_Cinfinite = @{thm Cinfinite_cong} OF [sbd_ordIso, sum_Cinfinite];
38.1071 + val sbd_Cnotzero = sbd_Cinfinite RS @{thm Cinfinite_Cnotzero};
38.1072 + val sbd_Card_order = sbd_Cinfinite RS conjunct2;
38.1073 +
38.1074 + fun mk_set_sbd i bd_Card_order bds =
38.1075 + map (fn thm => @{thm ordLeq_ordIso_trans} OF
38.1076 + [bd_Card_order RS mk_ordLeq_csum n i thm, sbd_ordIso]) bds;
38.1077 + val set_sbdss = map3 mk_set_sbd ks bd_Card_orders set_bdss;
38.1078 +
38.1079 + fun mk_in_sbd i Co Cnz bd =
38.1080 + Cnz RS ((@{thm ordLeq_ordIso_trans} OF
38.1081 + [(Co RS mk_ordLeq_csum n i (Co RS @{thm ordLeq_refl})), sbd_ordIso]) RS
38.1082 + (bd RS @{thm ordLeq_transitive[OF _
38.1083 + cexp_mono2_Cnotzero[OF _ csum_Cnotzero2[OF ctwo_Cnotzero]]]}));
38.1084 + val in_sbds = map4 mk_in_sbd ks bd_Card_orders bd_Cnotzeros in_bds;
38.1085 + in
38.1086 + (lthy, sbd, sbdT,
38.1087 + sbd_card_order, sbd_Cinfinite, sbd_Cnotzero, sbd_Card_order, set_sbdss, in_sbds)
38.1088 + end;
38.1089 +
38.1090 + fun mk_sbd_sbd 1 = sbd_Card_order RS @{thm ordIso_refl}
38.1091 + | mk_sbd_sbd n = @{thm csum_absorb1} OF
38.1092 + [sbd_Cinfinite, mk_sbd_sbd (n - 1) RS @{thm ordIso_imp_ordLeq}];
38.1093 +
38.1094 + val sbd_sbd_thm = mk_sbd_sbd n;
38.1095 +
38.1096 + val sbdTs = replicate n sbdT;
38.1097 + val sum_sbd = Library.foldr1 (uncurry mk_csum) (replicate n sbd);
38.1098 + val sum_sbdT = mk_sumTN sbdTs;
38.1099 + val sum_sbd_listT = HOLogic.listT sum_sbdT;
38.1100 + val sum_sbd_list_setT = HOLogic.mk_setT sum_sbd_listT;
38.1101 + val bdTs = passiveAs @ replicate n sbdT;
38.1102 + val to_sbd_maps = map4 mk_map_of_bnf Dss Ass (replicate n bdTs) bnfs;
38.1103 + val bdFTs = mk_FTs bdTs;
38.1104 + val sbdFT = mk_sumTN bdFTs;
38.1105 + val treeT = HOLogic.mk_prodT (sum_sbd_list_setT, sum_sbd_listT --> sbdFT);
38.1106 + val treeQT = HOLogic.mk_setT treeT;
38.1107 + val treeTs = passiveAs @ replicate n treeT;
38.1108 + val treeQTs = passiveAs @ replicate n treeQT;
38.1109 + val treeFTs = mk_FTs treeTs;
38.1110 + val tree_maps = map4 mk_map_of_bnf Dss (replicate n bdTs) (replicate n treeTs) bnfs;
38.1111 + val final_maps = map4 mk_map_of_bnf Dss (replicate n treeTs) (replicate n treeQTs) bnfs;
38.1112 + val tree_setss = mk_setss treeTs;
38.1113 + val isNode_setss = mk_setss (passiveAs @ replicate n sbdT);
38.1114 +
38.1115 + val root = HOLogic.mk_set sum_sbd_listT [HOLogic.mk_list sum_sbdT []];
38.1116 + val Zero = HOLogic.mk_tuple (map (fn U => absdummy U root) activeAs);
38.1117 + val Lev_recT = fastype_of Zero;
38.1118 + val LevT = Library.foldr (op -->) (sTs, HOLogic.natT --> Lev_recT);
38.1119 +
38.1120 + val Nil = HOLogic.mk_tuple (map3 (fn i => fn z => fn z'=>
38.1121 + Term.absfree z' (mk_InN activeAs z i)) ks zs zs');
38.1122 + val rv_recT = fastype_of Nil;
38.1123 + val rvT = Library.foldr (op -->) (sTs, sum_sbd_listT --> rv_recT);
38.1124 +
38.1125 + val (((((((((((sumx, sumx'), (kks, kks')), (kl, kl')), (kl_copy, kl'_copy)), (Kl, Kl')),
38.1126 + (lab, lab')), (Kl_lab, Kl_lab')), xs), (Lev_rec, Lev_rec')), (rv_rec, rv_rec')),
38.1127 + names_lthy) = names_lthy
38.1128 + |> yield_singleton (apfst (op ~~) oo mk_Frees' "sumx") sum_sbdT
38.1129 + ||>> mk_Frees' "k" sbdTs
38.1130 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
38.1131 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
38.1132 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl") sum_sbd_list_setT
38.1133 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "lab") (sum_sbd_listT --> sbdFT)
38.1134 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl_lab") treeT
38.1135 + ||>> mk_Frees "x" bdFTs
38.1136 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") Lev_recT
38.1137 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") rv_recT;
38.1138 +
38.1139 + val (k, k') = (hd kks, hd kks')
38.1140 +
38.1141 + val timer = time (timer "Bounds");
38.1142 +
38.1143 + (* tree coalgebra *)
38.1144 +
38.1145 + fun isNode_bind i = Binding.suffix_name ("_" ^ isNodeN ^ (if n = 1 then "" else
38.1146 + string_of_int i)) b;
38.1147 + val isNode_name = Binding.name_of o isNode_bind;
38.1148 + val isNode_def_bind = rpair [] o Thm.def_binding o isNode_bind;
38.1149 +
38.1150 + val isNodeT =
38.1151 + Library.foldr (op -->) (map fastype_of (As @ [Kl, lab, kl]), HOLogic.boolT);
38.1152 +
38.1153 + val Succs = map3 (fn i => fn k => fn k' =>
38.1154 + HOLogic.mk_Collect (fst k', snd k', HOLogic.mk_mem (mk_InN sbdTs k i, mk_Succ Kl kl)))
38.1155 + ks kks kks';
38.1156 +
38.1157 + fun isNode_spec sets x i =
38.1158 + let
38.1159 + val (passive_sets, active_sets) = chop m (map (fn set => set $ x) sets);
38.1160 + val lhs = Term.list_comb (Free (isNode_name i, isNodeT), As @ [Kl, lab, kl]);
38.1161 + val rhs = list_exists_free [x]
38.1162 + (Library.foldr1 HOLogic.mk_conj (HOLogic.mk_eq (lab $ kl, mk_InN bdFTs x i) ::
38.1163 + map2 mk_subset passive_sets As @ map2 (curry HOLogic.mk_eq) active_sets Succs));
38.1164 + in
38.1165 + mk_Trueprop_eq (lhs, rhs)
38.1166 + end;
38.1167 +
38.1168 + val ((isNode_frees, (_, isNode_def_frees)), (lthy, lthy_old)) =
38.1169 + lthy
38.1170 + |> fold_map3 (fn i => fn x => fn sets => Specification.definition
38.1171 + (SOME (isNode_bind i, NONE, NoSyn), (isNode_def_bind i, isNode_spec sets x i)))
38.1172 + ks xs isNode_setss
38.1173 + |>> apsnd split_list o split_list
38.1174 + ||> `Local_Theory.restore;
38.1175 +
38.1176 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1177 +
38.1178 + val isNode_defs = map (Morphism.thm phi) isNode_def_frees;
38.1179 + val isNodes = map (fst o Term.dest_Const o Morphism.term phi) isNode_frees;
38.1180 +
38.1181 + fun mk_isNode As kl i =
38.1182 + Term.list_comb (Const (nth isNodes (i - 1), isNodeT), As @ [Kl, lab, kl]);
38.1183 +
38.1184 + val isTree =
38.1185 + let
38.1186 + val empty = HOLogic.mk_mem (HOLogic.mk_list sum_sbdT [], Kl);
38.1187 + val Field = mk_subset Kl (mk_Field (mk_clists sum_sbd));
38.1188 + val prefCl = mk_prefCl Kl;
38.1189 +
38.1190 + val tree = mk_Ball Kl (Term.absfree kl'
38.1191 + (HOLogic.mk_conj
38.1192 + (Library.foldr1 HOLogic.mk_disj (map (mk_isNode As kl) ks),
38.1193 + Library.foldr1 HOLogic.mk_conj (map4 (fn Succ => fn i => fn k => fn k' =>
38.1194 + mk_Ball Succ (Term.absfree k' (mk_isNode As
38.1195 + (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i])) i)))
38.1196 + Succs ks kks kks'))));
38.1197 +
38.1198 + val undef = list_all_free [kl] (HOLogic.mk_imp
38.1199 + (HOLogic.mk_not (HOLogic.mk_mem (kl, Kl)),
38.1200 + HOLogic.mk_eq (lab $ kl, mk_undefined sbdFT)));
38.1201 + in
38.1202 + Library.foldr1 HOLogic.mk_conj [empty, Field, prefCl, tree, undef]
38.1203 + end;
38.1204 +
38.1205 + fun carT_bind i = Binding.suffix_name ("_" ^ carTN ^ (if n = 1 then "" else
38.1206 + string_of_int i)) b;
38.1207 + val carT_name = Binding.name_of o carT_bind;
38.1208 + val carT_def_bind = rpair [] o Thm.def_binding o carT_bind;
38.1209 +
38.1210 + fun carT_spec i =
38.1211 + let
38.1212 + val carTT = Library.foldr (op -->) (ATs, HOLogic.mk_setT treeT);
38.1213 +
38.1214 + val lhs = Term.list_comb (Free (carT_name i, carTT), As);
38.1215 + val rhs = HOLogic.mk_Collect (fst Kl_lab', snd Kl_lab', list_exists_free [Kl, lab]
38.1216 + (HOLogic.mk_conj (HOLogic.mk_eq (Kl_lab, HOLogic.mk_prod (Kl, lab)),
38.1217 + HOLogic.mk_conj (isTree, mk_isNode As (HOLogic.mk_list sum_sbdT []) i))));
38.1218 + in
38.1219 + mk_Trueprop_eq (lhs, rhs)
38.1220 + end;
38.1221 +
38.1222 + val ((carT_frees, (_, carT_def_frees)), (lthy, lthy_old)) =
38.1223 + lthy
38.1224 + |> fold_map (fn i => Specification.definition
38.1225 + (SOME (carT_bind i, NONE, NoSyn), (carT_def_bind i, carT_spec i))) ks
38.1226 + |>> apsnd split_list o split_list
38.1227 + ||> `Local_Theory.restore;
38.1228 +
38.1229 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1230 +
38.1231 + val carT_defs = map (Morphism.thm phi) carT_def_frees;
38.1232 + val carTs = map (fst o Term.dest_Const o Morphism.term phi) carT_frees;
38.1233 +
38.1234 + fun mk_carT As i = Term.list_comb
38.1235 + (Const (nth carTs (i - 1),
38.1236 + Library.foldr (op -->) (map fastype_of As, HOLogic.mk_setT treeT)), As);
38.1237 +
38.1238 + fun strT_bind i = Binding.suffix_name ("_" ^ strTN ^ (if n = 1 then "" else
38.1239 + string_of_int i)) b;
38.1240 + val strT_name = Binding.name_of o strT_bind;
38.1241 + val strT_def_bind = rpair [] o Thm.def_binding o strT_bind;
38.1242 +
38.1243 + fun strT_spec mapFT FT i =
38.1244 + let
38.1245 + val strTT = treeT --> FT;
38.1246 +
38.1247 + fun mk_f i k k' =
38.1248 + let val in_k = mk_InN sbdTs k i;
38.1249 + in Term.absfree k' (HOLogic.mk_prod (mk_Shift Kl in_k, mk_shift lab in_k)) end;
38.1250 +
38.1251 + val f = Term.list_comb (mapFT, passive_ids @ map3 mk_f ks kks kks');
38.1252 + val (fTs1, fTs2) = apsnd tl (chop (i - 1) (map (fn T => T --> FT) bdFTs));
38.1253 + val fs = map mk_undefined fTs1 @ (f :: map mk_undefined fTs2);
38.1254 + val lhs = Free (strT_name i, strTT);
38.1255 + val rhs = HOLogic.mk_split (Term.absfree Kl' (Term.absfree lab'
38.1256 + (mk_sum_caseN fs $ (lab $ HOLogic.mk_list sum_sbdT []))));
38.1257 + in
38.1258 + mk_Trueprop_eq (lhs, rhs)
38.1259 + end;
38.1260 +
38.1261 + val ((strT_frees, (_, strT_def_frees)), (lthy, lthy_old)) =
38.1262 + lthy
38.1263 + |> fold_map3 (fn i => fn mapFT => fn FT => Specification.definition
38.1264 + (SOME (strT_bind i, NONE, NoSyn), (strT_def_bind i, strT_spec mapFT FT i)))
38.1265 + ks tree_maps treeFTs
38.1266 + |>> apsnd split_list o split_list
38.1267 + ||> `Local_Theory.restore;
38.1268 +
38.1269 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1270 +
38.1271 + val strT_defs = map ((fn def => trans OF [def RS fun_cong, @{thm prod.cases}]) o
38.1272 + Morphism.thm phi) strT_def_frees;
38.1273 + val strTs = map (fst o Term.dest_Const o Morphism.term phi) strT_frees;
38.1274 +
38.1275 + fun mk_strT FT i = Const (nth strTs (i - 1), treeT --> FT);
38.1276 +
38.1277 + val carTAs = map (mk_carT As) ks;
38.1278 + val carTAs_copy = map (mk_carT As_copy) ks;
38.1279 + val strTAs = map2 mk_strT treeFTs ks;
38.1280 + val hset_strTss = map (fn i => map2 (mk_hset strTAs i) ls passiveAs) ks;
38.1281 +
38.1282 + val coalgT_thm =
38.1283 + Skip_Proof.prove lthy [] []
38.1284 + (fold_rev Logic.all As (HOLogic.mk_Trueprop (mk_coalg As carTAs strTAs)))
38.1285 + (mk_coalgT_tac m (coalg_def :: isNode_defs @ carT_defs) strT_defs set_natural'ss)
38.1286 + |> Thm.close_derivation;
38.1287 +
38.1288 + val card_of_carT_thms =
38.1289 + let
38.1290 + val lhs = mk_card_of
38.1291 + (HOLogic.mk_Collect (fst Kl_lab', snd Kl_lab', list_exists_free [Kl, lab]
38.1292 + (HOLogic.mk_conj (HOLogic.mk_eq (Kl_lab, HOLogic.mk_prod (Kl, lab)), isTree))));
38.1293 + val rhs = mk_cexp
38.1294 + (if m = 0 then ctwo else
38.1295 + (mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo))
38.1296 + (mk_cexp sbd sbd);
38.1297 + val card_of_carT =
38.1298 + Skip_Proof.prove lthy [] []
38.1299 + (fold_rev Logic.all As (HOLogic.mk_Trueprop (mk_ordLeq lhs rhs)))
38.1300 + (K (mk_card_of_carT_tac m isNode_defs sbd_sbd_thm
38.1301 + sbd_card_order sbd_Card_order sbd_Cinfinite sbd_Cnotzero in_sbds))
38.1302 + |> Thm.close_derivation
38.1303 + in
38.1304 + map (fn def => @{thm ordLeq_transitive[OF
38.1305 + card_of_mono1[OF ord_eq_le_trans[OF _ Collect_restrict']]]} OF [def, card_of_carT])
38.1306 + carT_defs
38.1307 + end;
38.1308 +
38.1309 + val carT_set_thmss =
38.1310 + let
38.1311 + val Kl_lab = HOLogic.mk_prod (Kl, lab);
38.1312 + fun mk_goal carT strT set k i =
38.1313 + fold_rev Logic.all (sumx :: Kl :: lab :: k :: kl :: As)
38.1314 + (Logic.list_implies (map HOLogic.mk_Trueprop
38.1315 + [HOLogic.mk_mem (Kl_lab, carT), HOLogic.mk_mem (mk_Cons sumx kl, Kl),
38.1316 + HOLogic.mk_eq (sumx, mk_InN sbdTs k i)],
38.1317 + HOLogic.mk_Trueprop (HOLogic.mk_mem
38.1318 + (HOLogic.mk_prod (mk_Shift Kl sumx, mk_shift lab sumx),
38.1319 + set $ (strT $ Kl_lab)))));
38.1320 +
38.1321 + val goalss = map3 (fn carT => fn strT => fn sets =>
38.1322 + map3 (mk_goal carT strT) (drop m sets) kks ks) carTAs strTAs tree_setss;
38.1323 + in
38.1324 + map6 (fn i => fn goals =>
38.1325 + fn carT_def => fn strT_def => fn isNode_def => fn set_naturals =>
38.1326 + map2 (fn goal => fn set_natural =>
38.1327 + Skip_Proof.prove lthy [] [] goal
38.1328 + (mk_carT_set_tac n i carT_def strT_def isNode_def set_natural)
38.1329 + |> Thm.close_derivation)
38.1330 + goals (drop m set_naturals))
38.1331 + ks goalss carT_defs strT_defs isNode_defs set_natural'ss
38.1332 + end;
38.1333 +
38.1334 + val carT_set_thmss' = transpose carT_set_thmss;
38.1335 +
38.1336 + val isNode_hset_thmss =
38.1337 + let
38.1338 + val Kl_lab = HOLogic.mk_prod (Kl, lab);
38.1339 + fun mk_Kl_lab carT = HOLogic.mk_mem (Kl_lab, carT);
38.1340 +
38.1341 + val strT_hset_thmsss =
38.1342 + let
38.1343 + val strT_hset_thms =
38.1344 + let
38.1345 + fun mk_lab_kl i x = HOLogic.mk_eq (lab $ kl, mk_InN bdFTs x i);
38.1346 +
38.1347 + fun mk_inner_conjunct j T i x set i' carT =
38.1348 + HOLogic.mk_imp (HOLogic.mk_conj (mk_Kl_lab carT, mk_lab_kl i x),
38.1349 + mk_subset (set $ x) (mk_hset strTAs i' j T $ Kl_lab));
38.1350 +
38.1351 + fun mk_conjunct j T i x set =
38.1352 + Library.foldr1 HOLogic.mk_conj (map2 (mk_inner_conjunct j T i x set) ks carTAs);
38.1353 +
38.1354 + fun mk_concl j T = list_all_free (Kl :: lab :: xs @ As)
38.1355 + (HOLogic.mk_imp (HOLogic.mk_mem (kl, Kl),
38.1356 + Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T)
38.1357 + ks xs (map (fn xs => nth xs (j - 1)) isNode_setss))));
38.1358 + val concls = map2 mk_concl ls passiveAs;
38.1359 +
38.1360 + val cTs = [SOME (certifyT lthy sum_sbdT)];
38.1361 + val arg_cong_cTs = map (SOME o certifyT lthy) treeFTs;
38.1362 + val ctss =
38.1363 + map (fn phi => map (SOME o certify lthy) [Term.absfree kl' phi, kl]) concls;
38.1364 +
38.1365 + val goals = map HOLogic.mk_Trueprop concls;
38.1366 + in
38.1367 + map5 (fn j => fn goal => fn cts => fn set_incl_hsets => fn set_hset_incl_hsetss =>
38.1368 + singleton (Proof_Context.export names_lthy lthy)
38.1369 + (Skip_Proof.prove lthy [] [] goal
38.1370 + (K (mk_strT_hset_tac n m j arg_cong_cTs cTs cts
38.1371 + carT_defs strT_defs isNode_defs
38.1372 + set_incl_hsets set_hset_incl_hsetss coalg_set_thmss' carT_set_thmss'
38.1373 + coalgT_thm set_natural'ss)))
38.1374 + |> Thm.close_derivation)
38.1375 + ls goals ctss set_incl_hset_thmss' set_hset_incl_hset_thmsss''
38.1376 + end;
38.1377 +
38.1378 + val strT_hset'_thms = map (fn thm => mk_specN (2 + n + m) thm RS mp) strT_hset_thms;
38.1379 + in
38.1380 + map (fn thm => map (fn i => map (fn i' =>
38.1381 + thm RS mk_conjunctN n i RS mk_conjunctN n i' RS mp) ks) ks) strT_hset'_thms
38.1382 + end;
38.1383 +
38.1384 + val carT_prems = map (fn carT =>
38.1385 + HOLogic.mk_Trueprop (HOLogic.mk_mem (Kl_lab, carT))) carTAs_copy;
38.1386 + val prem = HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, Kl));
38.1387 + val in_prems = map (fn hsets =>
38.1388 + HOLogic.mk_Trueprop (HOLogic.mk_mem (Kl_lab, mk_in As hsets treeT))) hset_strTss;
38.1389 + val isNode_premss = replicate n (map (HOLogic.mk_Trueprop o mk_isNode As_copy kl) ks);
38.1390 + val conclss = replicate n (map (HOLogic.mk_Trueprop o mk_isNode As kl) ks);
38.1391 + in
38.1392 + map5 (fn carT_prem => fn isNode_prems => fn in_prem => fn concls => fn strT_hset_thmss =>
38.1393 + map4 (fn isNode_prem => fn concl => fn isNode_def => fn strT_hset_thms =>
38.1394 + Skip_Proof.prove lthy [] []
38.1395 + (fold_rev Logic.all (Kl :: lab :: kl :: As @ As_copy)
38.1396 + (Logic.list_implies ([carT_prem, prem, isNode_prem, in_prem], concl)))
38.1397 + (mk_isNode_hset_tac n isNode_def strT_hset_thms)
38.1398 + |> Thm.close_derivation)
38.1399 + isNode_prems concls isNode_defs
38.1400 + (if m = 0 then replicate n [] else transpose strT_hset_thmss))
38.1401 + carT_prems isNode_premss in_prems conclss
38.1402 + (if m = 0 then replicate n [] else transpose (map transpose strT_hset_thmsss))
38.1403 + end;
38.1404 +
38.1405 + val timer = time (timer "Tree coalgebra");
38.1406 +
38.1407 + fun mk_to_sbd s x i i' =
38.1408 + mk_toCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
38.1409 + fun mk_from_sbd s x i i' =
38.1410 + mk_fromCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
38.1411 +
38.1412 + fun mk_to_sbd_thmss thm = map (map (fn set_sbd =>
38.1413 + thm OF [set_sbd, sbd_Card_order]) o drop m) set_sbdss;
38.1414 +
38.1415 + val to_sbd_inj_thmss = mk_to_sbd_thmss @{thm toCard_inj};
38.1416 + val to_sbd_thmss = mk_to_sbd_thmss @{thm toCard};
38.1417 + val from_to_sbd_thmss = mk_to_sbd_thmss @{thm fromCard_toCard};
38.1418 +
38.1419 + val Lev_bind = Binding.suffix_name ("_" ^ LevN) b;
38.1420 + val Lev_name = Binding.name_of Lev_bind;
38.1421 + val Lev_def_bind = rpair [] (Thm.def_binding Lev_bind);
38.1422 +
38.1423 + val Lev_spec =
38.1424 + let
38.1425 + fun mk_Suc i s setsAs a a' =
38.1426 + let
38.1427 + val sets = drop m setsAs;
38.1428 + fun mk_set i' set b =
38.1429 + let
38.1430 + val Cons = HOLogic.mk_eq (kl_copy,
38.1431 + mk_Cons (mk_InN sbdTs (mk_to_sbd s a i i' $ b) i') kl)
38.1432 + val b_set = HOLogic.mk_mem (b, set $ (s $ a));
38.1433 + val kl_rec = HOLogic.mk_mem (kl, mk_nthN n Lev_rec i' $ b);
38.1434 + in
38.1435 + HOLogic.mk_Collect (fst kl'_copy, snd kl'_copy, list_exists_free [b, kl]
38.1436 + (HOLogic.mk_conj (Cons, HOLogic.mk_conj (b_set, kl_rec))))
38.1437 + end;
38.1438 + in
38.1439 + Term.absfree a' (Library.foldl1 mk_union (map3 mk_set ks sets zs_copy))
38.1440 + end;
38.1441 +
38.1442 + val Suc = Term.absdummy HOLogic.natT (Term.absfree Lev_rec'
38.1443 + (HOLogic.mk_tuple (map5 mk_Suc ks ss setssAs zs zs')));
38.1444 +
38.1445 + val lhs = Term.list_comb (Free (Lev_name, LevT), ss);
38.1446 + val rhs = mk_nat_rec Zero Suc;
38.1447 + in
38.1448 + mk_Trueprop_eq (lhs, rhs)
38.1449 + end;
38.1450 +
38.1451 + val ((Lev_free, (_, Lev_def_free)), (lthy, lthy_old)) =
38.1452 + lthy
38.1453 + |> Specification.definition (SOME (Lev_bind, NONE, NoSyn), (Lev_def_bind, Lev_spec))
38.1454 + ||> `Local_Theory.restore;
38.1455 +
38.1456 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1457 +
38.1458 + val Lev_def = Morphism.thm phi Lev_def_free;
38.1459 + val Lev = fst (Term.dest_Const (Morphism.term phi Lev_free));
38.1460 +
38.1461 + fun mk_Lev ss nat i =
38.1462 + let
38.1463 + val Ts = map fastype_of ss;
38.1464 + val LevT = Library.foldr (op -->) (Ts, HOLogic.natT -->
38.1465 + HOLogic.mk_tupleT (map (fn U => domain_type U --> sum_sbd_list_setT) Ts));
38.1466 + in
38.1467 + mk_nthN n (Term.list_comb (Const (Lev, LevT), ss) $ nat) i
38.1468 + end;
38.1469 +
38.1470 + val Lev_0s = flat (mk_rec_simps n @{thm nat_rec_0} [Lev_def]);
38.1471 + val Lev_Sucs = flat (mk_rec_simps n @{thm nat_rec_Suc} [Lev_def]);
38.1472 +
38.1473 + val rv_bind = Binding.suffix_name ("_" ^ rvN) b;
38.1474 + val rv_name = Binding.name_of rv_bind;
38.1475 + val rv_def_bind = rpair [] (Thm.def_binding rv_bind);
38.1476 +
38.1477 + val rv_spec =
38.1478 + let
38.1479 + fun mk_Cons i s b b' =
38.1480 + let
38.1481 + fun mk_case i' =
38.1482 + Term.absfree k' (mk_nthN n rv_rec i' $ (mk_from_sbd s b i i' $ k));
38.1483 + in
38.1484 + Term.absfree b' (mk_sum_caseN (map mk_case ks) $ sumx)
38.1485 + end;
38.1486 +
38.1487 + val Cons = Term.absfree sumx' (Term.absdummy sum_sbd_listT (Term.absfree rv_rec'
38.1488 + (HOLogic.mk_tuple (map4 mk_Cons ks ss zs zs'))));
38.1489 +
38.1490 + val lhs = Term.list_comb (Free (rv_name, rvT), ss);
38.1491 + val rhs = mk_list_rec Nil Cons;
38.1492 + in
38.1493 + mk_Trueprop_eq (lhs, rhs)
38.1494 + end;
38.1495 +
38.1496 + val ((rv_free, (_, rv_def_free)), (lthy, lthy_old)) =
38.1497 + lthy
38.1498 + |> Specification.definition (SOME (rv_bind, NONE, NoSyn), (rv_def_bind, rv_spec))
38.1499 + ||> `Local_Theory.restore;
38.1500 +
38.1501 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1502 +
38.1503 + val rv_def = Morphism.thm phi rv_def_free;
38.1504 + val rv = fst (Term.dest_Const (Morphism.term phi rv_free));
38.1505 +
38.1506 + fun mk_rv ss kl i =
38.1507 + let
38.1508 + val Ts = map fastype_of ss;
38.1509 + val As = map domain_type Ts;
38.1510 + val rvT = Library.foldr (op -->) (Ts, fastype_of kl -->
38.1511 + HOLogic.mk_tupleT (map (fn U => U --> mk_sumTN As) As));
38.1512 + in
38.1513 + mk_nthN n (Term.list_comb (Const (rv, rvT), ss) $ kl) i
38.1514 + end;
38.1515 +
38.1516 + val rv_Nils = flat (mk_rec_simps n @{thm list_rec_Nil} [rv_def]);
38.1517 + val rv_Conss = flat (mk_rec_simps n @{thm list_rec_Cons} [rv_def]);
38.1518 +
38.1519 + fun beh_bind i = Binding.suffix_name ("_" ^ behN ^ (if n = 1 then "" else
38.1520 + string_of_int i)) b;
38.1521 + val beh_name = Binding.name_of o beh_bind;
38.1522 + val beh_def_bind = rpair [] o Thm.def_binding o beh_bind;
38.1523 +
38.1524 + fun beh_spec i z =
38.1525 + let
38.1526 + val mk_behT = Library.foldr (op -->) (map fastype_of (ss @ [z]), treeT);
38.1527 +
38.1528 + fun mk_case i to_sbd_map s k k' =
38.1529 + Term.absfree k' (mk_InN bdFTs
38.1530 + (Term.list_comb (to_sbd_map, passive_ids @ map (mk_to_sbd s k i) ks) $ (s $ k)) i);
38.1531 +
38.1532 + val Lab = Term.absfree kl' (mk_If
38.1533 + (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))
38.1534 + (mk_sum_caseN (map5 mk_case ks to_sbd_maps ss zs zs') $ (mk_rv ss kl i $ z))
38.1535 + (mk_undefined sbdFT));
38.1536 +
38.1537 + val lhs = Term.list_comb (Free (beh_name i, mk_behT), ss) $ z;
38.1538 + val rhs = HOLogic.mk_prod (mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
38.1539 + (Term.absfree nat' (mk_Lev ss nat i $ z)), Lab);
38.1540 + in
38.1541 + mk_Trueprop_eq (lhs, rhs)
38.1542 + end;
38.1543 +
38.1544 + val ((beh_frees, (_, beh_def_frees)), (lthy, lthy_old)) =
38.1545 + lthy
38.1546 + |> fold_map2 (fn i => fn z => Specification.definition
38.1547 + (SOME (beh_bind i, NONE, NoSyn), (beh_def_bind i, beh_spec i z))) ks zs
38.1548 + |>> apsnd split_list o split_list
38.1549 + ||> `Local_Theory.restore;
38.1550 +
38.1551 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1552 +
38.1553 + val beh_defs = map (Morphism.thm phi) beh_def_frees;
38.1554 + val behs = map (fst o Term.dest_Const o Morphism.term phi) beh_frees;
38.1555 +
38.1556 + fun mk_beh ss i =
38.1557 + let
38.1558 + val Ts = map fastype_of ss;
38.1559 + val behT = Library.foldr (op -->) (Ts, nth activeAs (i - 1) --> treeT);
38.1560 + in
38.1561 + Term.list_comb (Const (nth behs (i - 1), behT), ss)
38.1562 + end;
38.1563 +
38.1564 + val Lev_sbd_thms =
38.1565 + let
38.1566 + fun mk_conjunct i z = mk_subset (mk_Lev ss nat i $ z) (mk_Field (mk_clists sum_sbd));
38.1567 + val goal = list_all_free zs
38.1568 + (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
38.1569 +
38.1570 + val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
38.1571 +
38.1572 + val Lev_sbd = singleton (Proof_Context.export names_lthy lthy)
38.1573 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.1574 + (K (mk_Lev_sbd_tac cts Lev_0s Lev_Sucs to_sbd_thmss))
38.1575 + |> Thm.close_derivation);
38.1576 +
38.1577 + val Lev_sbd' = mk_specN n Lev_sbd;
38.1578 + in
38.1579 + map (fn i => Lev_sbd' RS mk_conjunctN n i) ks
38.1580 + end;
38.1581 +
38.1582 + val (length_Lev_thms, length_Lev'_thms) =
38.1583 + let
38.1584 + fun mk_conjunct i z = HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
38.1585 + HOLogic.mk_eq (mk_size kl, nat));
38.1586 + val goal = list_all_free (kl :: zs)
38.1587 + (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
38.1588 +
38.1589 + val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
38.1590 +
38.1591 + val length_Lev = singleton (Proof_Context.export names_lthy lthy)
38.1592 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.1593 + (K (mk_length_Lev_tac cts Lev_0s Lev_Sucs))
38.1594 + |> Thm.close_derivation);
38.1595 +
38.1596 + val length_Lev' = mk_specN (n + 1) length_Lev;
38.1597 + val length_Levs = map (fn i => length_Lev' RS mk_conjunctN n i RS mp) ks;
38.1598 +
38.1599 + fun mk_goal i z = fold_rev Logic.all (z :: kl :: nat :: ss) (Logic.mk_implies
38.1600 + (HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z)),
38.1601 + HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))));
38.1602 + val goals = map2 mk_goal ks zs;
38.1603 +
38.1604 + val length_Levs' = map2 (fn goal => fn length_Lev =>
38.1605 + Skip_Proof.prove lthy [] [] goal (K (mk_length_Lev'_tac length_Lev))
38.1606 + |> Thm.close_derivation) goals length_Levs;
38.1607 + in
38.1608 + (length_Levs, length_Levs')
38.1609 + end;
38.1610 +
38.1611 + val prefCl_Lev_thms =
38.1612 + let
38.1613 + fun mk_conjunct i z = HOLogic.mk_imp
38.1614 + (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), mk_subset kl_copy kl),
38.1615 + HOLogic.mk_mem (kl_copy, mk_Lev ss (mk_size kl_copy) i $ z));
38.1616 + val goal = list_all_free (kl :: kl_copy :: zs)
38.1617 + (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
38.1618 +
38.1619 + val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
38.1620 +
38.1621 + val prefCl_Lev = singleton (Proof_Context.export names_lthy lthy)
38.1622 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.1623 + (K (mk_prefCl_Lev_tac cts Lev_0s Lev_Sucs)))
38.1624 + |> Thm.close_derivation;
38.1625 +
38.1626 + val prefCl_Lev' = mk_specN (n + 2) prefCl_Lev;
38.1627 + in
38.1628 + map (fn i => prefCl_Lev' RS mk_conjunctN n i RS mp) ks
38.1629 + end;
38.1630 +
38.1631 + val rv_last_thmss =
38.1632 + let
38.1633 + fun mk_conjunct i z i' z_copy = list_exists_free [z_copy]
38.1634 + (HOLogic.mk_eq
38.1635 + (mk_rv ss (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i'])) i $ z,
38.1636 + mk_InN activeAs z_copy i'));
38.1637 + val goal = list_all_free (k :: zs)
38.1638 + (Library.foldr1 HOLogic.mk_conj (map2 (fn i => fn z =>
38.1639 + Library.foldr1 HOLogic.mk_conj
38.1640 + (map2 (mk_conjunct i z) ks zs_copy)) ks zs));
38.1641 +
38.1642 + val cTs = [SOME (certifyT lthy sum_sbdT)];
38.1643 + val cts = map (SOME o certify lthy) [Term.absfree kl' goal, kl];
38.1644 +
38.1645 + val rv_last = singleton (Proof_Context.export names_lthy lthy)
38.1646 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.1647 + (K (mk_rv_last_tac cTs cts rv_Nils rv_Conss)))
38.1648 + |> Thm.close_derivation;
38.1649 +
38.1650 + val rv_last' = mk_specN (n + 1) rv_last;
38.1651 + in
38.1652 + map (fn i => map (fn i' => rv_last' RS mk_conjunctN n i RS mk_conjunctN n i') ks) ks
38.1653 + end;
38.1654 +
38.1655 + val set_rv_Lev_thmsss = if m = 0 then replicate n (replicate n []) else
38.1656 + let
38.1657 + fun mk_case s sets z z_free = Term.absfree z_free (Library.foldr1 HOLogic.mk_conj
38.1658 + (map2 (fn set => fn A => mk_subset (set $ (s $ z)) A) (take m sets) As));
38.1659 +
38.1660 + fun mk_conjunct i z B = HOLogic.mk_imp
38.1661 + (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), HOLogic.mk_mem (z, B)),
38.1662 + mk_sum_caseN (map4 mk_case ss setssAs zs zs') $ (mk_rv ss kl i $ z));
38.1663 +
38.1664 + val goal = list_all_free (kl :: zs)
38.1665 + (Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct ks zs Bs));
38.1666 +
38.1667 + val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
38.1668 +
38.1669 + val set_rv_Lev = singleton (Proof_Context.export names_lthy lthy)
38.1670 + (Skip_Proof.prove lthy [] []
38.1671 + (Logic.mk_implies (coalg_prem, HOLogic.mk_Trueprop goal))
38.1672 + (K (mk_set_rv_Lev_tac m cts Lev_0s Lev_Sucs rv_Nils rv_Conss
38.1673 + coalg_set_thmss from_to_sbd_thmss)))
38.1674 + |> Thm.close_derivation;
38.1675 +
38.1676 + val set_rv_Lev' = mk_specN (n + 1) set_rv_Lev;
38.1677 + in
38.1678 + map (fn i => map (fn i' =>
38.1679 + split_conj_thm (if n = 1 then set_rv_Lev' RS mk_conjunctN n i RS mp
38.1680 + else set_rv_Lev' RS mk_conjunctN n i RS mp RSN
38.1681 + (2, @{thm sum_case_weak_cong} RS @{thm subst[of _ _ "%x. x"]}) RS
38.1682 + (mk_sum_casesN n i' RS @{thm subst[of _ _ "%x. x"]}))) ks) ks
38.1683 + end;
38.1684 +
38.1685 + val set_Lev_thmsss =
38.1686 + let
38.1687 + fun mk_conjunct i z =
38.1688 + let
38.1689 + fun mk_conjunct' i' sets s z' =
38.1690 + let
38.1691 + fun mk_conjunct'' i'' set z'' = HOLogic.mk_imp
38.1692 + (HOLogic.mk_mem (z'', set $ (s $ z')),
38.1693 + HOLogic.mk_mem (mk_append (kl,
38.1694 + HOLogic.mk_list sum_sbdT [mk_InN sbdTs (mk_to_sbd s z' i' i'' $ z'') i'']),
38.1695 + mk_Lev ss (HOLogic.mk_Suc nat) i $ z));
38.1696 + in
38.1697 + HOLogic.mk_imp (HOLogic.mk_eq (mk_rv ss kl i $ z, mk_InN activeAs z' i'),
38.1698 + (Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct'' ks (drop m sets) zs_copy2)))
38.1699 + end;
38.1700 + in
38.1701 + HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
38.1702 + Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct' ks setssAs ss zs_copy))
38.1703 + end;
38.1704 +
38.1705 + val goal = list_all_free (kl :: zs @ zs_copy @ zs_copy2)
38.1706 + (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
38.1707 +
38.1708 + val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
38.1709 +
38.1710 + val set_Lev = singleton (Proof_Context.export names_lthy lthy)
38.1711 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.1712 + (K (mk_set_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbd_thmss)))
38.1713 + |> Thm.close_derivation;
38.1714 +
38.1715 + val set_Lev' = mk_specN (3 * n + 1) set_Lev;
38.1716 + in
38.1717 + map (fn i => map (fn i' => map (fn i'' => set_Lev' RS
38.1718 + mk_conjunctN n i RS mp RS
38.1719 + mk_conjunctN n i' RS mp RS
38.1720 + mk_conjunctN n i'' RS mp) ks) ks) ks
38.1721 + end;
38.1722 +
38.1723 + val set_image_Lev_thmsss =
38.1724 + let
38.1725 + fun mk_conjunct i z =
38.1726 + let
38.1727 + fun mk_conjunct' i' sets =
38.1728 + let
38.1729 + fun mk_conjunct'' i'' set s z'' = HOLogic.mk_imp
38.1730 + (HOLogic.mk_eq (mk_rv ss kl i $ z, mk_InN activeAs z'' i''),
38.1731 + HOLogic.mk_mem (k, mk_image (mk_to_sbd s z'' i'' i') $ (set $ (s $ z''))));
38.1732 + in
38.1733 + HOLogic.mk_imp (HOLogic.mk_mem
38.1734 + (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i']),
38.1735 + mk_Lev ss (HOLogic.mk_Suc nat) i $ z),
38.1736 + (Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct'' ks sets ss zs_copy)))
38.1737 + end;
38.1738 + in
38.1739 + HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
38.1740 + Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct' ks (drop m setssAs')))
38.1741 + end;
38.1742 +
38.1743 + val goal = list_all_free (kl :: k :: zs @ zs_copy)
38.1744 + (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
38.1745 +
38.1746 + val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
38.1747 +
38.1748 + val set_image_Lev = singleton (Proof_Context.export names_lthy lthy)
38.1749 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.1750 + (K (mk_set_image_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss
38.1751 + from_to_sbd_thmss to_sbd_inj_thmss)))
38.1752 + |> Thm.close_derivation;
38.1753 +
38.1754 + val set_image_Lev' = mk_specN (2 * n + 2) set_image_Lev;
38.1755 + in
38.1756 + map (fn i => map (fn i' => map (fn i'' => set_image_Lev' RS
38.1757 + mk_conjunctN n i RS mp RS
38.1758 + mk_conjunctN n i'' RS mp RS
38.1759 + mk_conjunctN n i' RS mp) ks) ks) ks
38.1760 + end;
38.1761 +
38.1762 + val mor_beh_thm =
38.1763 + Skip_Proof.prove lthy [] []
38.1764 + (fold_rev Logic.all (As @ Bs @ ss) (Logic.mk_implies (coalg_prem,
38.1765 + HOLogic.mk_Trueprop (mk_mor Bs ss carTAs strTAs (map (mk_beh ss) ks)))))
38.1766 + (mk_mor_beh_tac m mor_def mor_cong_thm
38.1767 + beh_defs carT_defs strT_defs isNode_defs
38.1768 + to_sbd_inj_thmss from_to_sbd_thmss Lev_0s Lev_Sucs rv_Nils rv_Conss Lev_sbd_thms
38.1769 + length_Lev_thms length_Lev'_thms prefCl_Lev_thms rv_last_thmss
38.1770 + set_rv_Lev_thmsss set_Lev_thmsss set_image_Lev_thmsss
38.1771 + set_natural'ss coalg_set_thmss map_comp_id_thms map_congs map_arg_cong_thms)
38.1772 + |> Thm.close_derivation;
38.1773 +
38.1774 + val timer = time (timer "Behavioral morphism");
38.1775 +
38.1776 + fun mk_LSBIS As i = mk_lsbis As (map (mk_carT As) ks) strTAs i;
38.1777 + fun mk_car_final As i =
38.1778 + mk_quotient (mk_carT As i) (mk_LSBIS As i);
38.1779 + fun mk_str_final As i =
38.1780 + mk_univ (HOLogic.mk_comp (Term.list_comb (nth final_maps (i - 1),
38.1781 + passive_ids @ map (mk_proj o mk_LSBIS As) ks), nth strTAs (i - 1)));
38.1782 +
38.1783 + val car_finalAs = map (mk_car_final As) ks;
38.1784 + val str_finalAs = map (mk_str_final As) ks;
38.1785 + val car_finals = map (mk_car_final passive_UNIVs) ks;
38.1786 + val str_finals = map (mk_str_final passive_UNIVs) ks;
38.1787 +
38.1788 + val coalgT_set_thmss = map (map (fn thm => coalgT_thm RS thm)) coalg_set_thmss;
38.1789 + val equiv_LSBIS_thms = map (fn thm => coalgT_thm RS thm) equiv_lsbis_thms;
38.1790 +
38.1791 + val congruent_str_final_thms =
38.1792 + let
38.1793 + fun mk_goal R final_map strT =
38.1794 + fold_rev Logic.all As (HOLogic.mk_Trueprop
38.1795 + (mk_congruent R (HOLogic.mk_comp
38.1796 + (Term.list_comb (final_map, passive_ids @ map (mk_proj o mk_LSBIS As) ks), strT))));
38.1797 +
38.1798 + val goals = map3 mk_goal (map (mk_LSBIS As) ks) final_maps strTAs;
38.1799 + in
38.1800 + map4 (fn goal => fn lsbisE => fn map_comp_id => fn map_cong =>
38.1801 + Skip_Proof.prove lthy [] [] goal
38.1802 + (K (mk_congruent_str_final_tac m lsbisE map_comp_id map_cong equiv_LSBIS_thms))
38.1803 + |> Thm.close_derivation)
38.1804 + goals lsbisE_thms map_comp_id_thms map_congs
38.1805 + end;
38.1806 +
38.1807 + val coalg_final_thm = Skip_Proof.prove lthy [] [] (fold_rev Logic.all As
38.1808 + (HOLogic.mk_Trueprop (mk_coalg As car_finalAs str_finalAs)))
38.1809 + (K (mk_coalg_final_tac m coalg_def congruent_str_final_thms equiv_LSBIS_thms
38.1810 + set_natural'ss coalgT_set_thmss))
38.1811 + |> Thm.close_derivation;
38.1812 +
38.1813 + val mor_T_final_thm = Skip_Proof.prove lthy [] [] (fold_rev Logic.all As
38.1814 + (HOLogic.mk_Trueprop (mk_mor carTAs strTAs car_finalAs str_finalAs
38.1815 + (map (mk_proj o mk_LSBIS As) ks))))
38.1816 + (K (mk_mor_T_final_tac mor_def congruent_str_final_thms equiv_LSBIS_thms))
38.1817 + |> Thm.close_derivation;
38.1818 +
38.1819 + val mor_final_thm = mor_comp_thm OF [mor_beh_thm, mor_T_final_thm];
38.1820 + val in_car_final_thms = map (fn mor_image' => mor_image' OF
38.1821 + [tcoalg_thm RS mor_final_thm, UNIV_I]) mor_image'_thms;
38.1822 +
38.1823 + val timer = time (timer "Final coalgebra");
38.1824 +
38.1825 + val ((T_names, (T_glob_infos, T_loc_infos)), lthy) =
38.1826 + lthy
38.1827 + |> fold_map4 (fn b => fn mx => fn car_final => fn in_car_final =>
38.1828 + typedef false NONE (b, params, mx) car_final NONE
38.1829 + (EVERY' [rtac exI, rtac in_car_final] 1)) bs mixfixes car_finals in_car_final_thms
38.1830 + |>> apsnd split_list o split_list;
38.1831 +
38.1832 + val Ts = map (fn name => Type (name, params')) T_names;
38.1833 + fun mk_Ts passive = map (Term.typ_subst_atomic (passiveAs ~~ passive)) Ts;
38.1834 + val Ts' = mk_Ts passiveBs;
38.1835 + val Ts'' = mk_Ts passiveCs;
38.1836 + val Rep_Ts = map2 (fn info => fn T => Const (#Rep_name info, T --> treeQT)) T_glob_infos Ts;
38.1837 + val Abs_Ts = map2 (fn info => fn T => Const (#Abs_name info, treeQT --> T)) T_glob_infos Ts;
38.1838 +
38.1839 + val Reps = map #Rep T_loc_infos;
38.1840 + val Rep_injects = map #Rep_inject T_loc_infos;
38.1841 + val Rep_inverses = map #Rep_inverse T_loc_infos;
38.1842 + val Abs_inverses = map #Abs_inverse T_loc_infos;
38.1843 +
38.1844 + val timer = time (timer "THE TYPEDEFs & Rep/Abs thms");
38.1845 +
38.1846 + val UNIVs = map HOLogic.mk_UNIV Ts;
38.1847 + val FTs = mk_FTs (passiveAs @ Ts);
38.1848 + val FTs' = mk_FTs (passiveBs @ Ts);
38.1849 + val prodTs = map (HOLogic.mk_prodT o `I) Ts;
38.1850 + val prodFTs = mk_FTs (passiveAs @ prodTs);
38.1851 + val FTs_setss = mk_setss (passiveAs @ Ts);
38.1852 + val prodFT_setss = mk_setss (passiveAs @ prodTs);
38.1853 + val map_FTs = map2 (fn Ds => mk_map_of_bnf Ds treeQTs (passiveAs @ Ts)) Dss bnfs;
38.1854 + val map_FT_nths = map2 (fn Ds =>
38.1855 + mk_map_of_bnf Ds (passiveAs @ prodTs) (passiveAs @ Ts)) Dss bnfs;
38.1856 + val fstsTs = map fst_const prodTs;
38.1857 + val sndsTs = map snd_const prodTs;
38.1858 + val dtorTs = map2 (curry (op -->)) Ts FTs;
38.1859 + val ctorTs = map2 (curry (op -->)) FTs Ts;
38.1860 + val unfold_fTs = map2 (curry op -->) activeAs Ts;
38.1861 + val corec_sTs = map (Term.typ_subst_atomic (activeBs ~~ Ts)) sum_sTs;
38.1862 + val corec_maps = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_Inls;
38.1863 + val corec_maps_rev = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_Inls_rev;
38.1864 + val corec_Inls = map (Term.subst_atomic_types (activeBs ~~ Ts)) Inls;
38.1865 +
38.1866 + val (((((((((((((Jzs, Jzs'), (Jz's, Jz's')), Jzs_copy), Jzs1), Jzs2), Jpairs),
38.1867 + FJzs), TRs), unfold_fs), unfold_fs_copy), corec_ss), phis), names_lthy) = names_lthy
38.1868 + |> mk_Frees' "z" Ts
38.1869 + ||>> mk_Frees' "z" Ts'
38.1870 + ||>> mk_Frees "z" Ts
38.1871 + ||>> mk_Frees "z1" Ts
38.1872 + ||>> mk_Frees "z2" Ts
38.1873 + ||>> mk_Frees "j" (map2 (curry HOLogic.mk_prodT) Ts Ts')
38.1874 + ||>> mk_Frees "x" prodFTs
38.1875 + ||>> mk_Frees "R" (map (mk_relT o `I) Ts)
38.1876 + ||>> mk_Frees "f" unfold_fTs
38.1877 + ||>> mk_Frees "g" unfold_fTs
38.1878 + ||>> mk_Frees "s" corec_sTs
38.1879 + ||>> mk_Frees "P" (map2 mk_pred2T Ts Ts);
38.1880 +
38.1881 + fun dtor_bind i = Binding.suffix_name ("_" ^ dtorN) (nth bs (i - 1));
38.1882 + val dtor_name = Binding.name_of o dtor_bind;
38.1883 + val dtor_def_bind = rpair [] o Thm.def_binding o dtor_bind;
38.1884 +
38.1885 + fun dtor_spec i rep str map_FT dtorT Jz Jz' =
38.1886 + let
38.1887 + val lhs = Free (dtor_name i, dtorT);
38.1888 + val rhs = Term.absfree Jz'
38.1889 + (Term.list_comb (map_FT, map HOLogic.id_const passiveAs @ Abs_Ts) $
38.1890 + (str $ (rep $ Jz)));
38.1891 + in
38.1892 + mk_Trueprop_eq (lhs, rhs)
38.1893 + end;
38.1894 +
38.1895 + val ((dtor_frees, (_, dtor_def_frees)), (lthy, lthy_old)) =
38.1896 + lthy
38.1897 + |> fold_map7 (fn i => fn rep => fn str => fn mapx => fn dtorT => fn Jz => fn Jz' =>
38.1898 + Specification.definition (SOME (dtor_bind i, NONE, NoSyn),
38.1899 + (dtor_def_bind i, dtor_spec i rep str mapx dtorT Jz Jz')))
38.1900 + ks Rep_Ts str_finals map_FTs dtorTs Jzs Jzs'
38.1901 + |>> apsnd split_list o split_list
38.1902 + ||> `Local_Theory.restore;
38.1903 +
38.1904 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1905 + fun mk_dtors passive =
38.1906 + map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ (mk_params passive)) o
38.1907 + Morphism.term phi) dtor_frees;
38.1908 + val dtors = mk_dtors passiveAs;
38.1909 + val dtor's = mk_dtors passiveBs;
38.1910 + val dtor_defs = map ((fn thm => thm RS fun_cong) o Morphism.thm phi) dtor_def_frees;
38.1911 +
38.1912 + val coalg_final_set_thmss = map (map (fn thm => coalg_final_thm RS thm)) coalg_set_thmss;
38.1913 + val (mor_Rep_thm, mor_Abs_thm) =
38.1914 + let
38.1915 + val mor_Rep =
38.1916 + Skip_Proof.prove lthy [] []
38.1917 + (HOLogic.mk_Trueprop (mk_mor UNIVs dtors car_finals str_finals Rep_Ts))
38.1918 + (mk_mor_Rep_tac m (mor_def :: dtor_defs) Reps Abs_inverses coalg_final_set_thmss
38.1919 + map_comp_id_thms map_congL_thms)
38.1920 + |> Thm.close_derivation;
38.1921 +
38.1922 + val mor_Abs =
38.1923 + Skip_Proof.prove lthy [] []
38.1924 + (HOLogic.mk_Trueprop (mk_mor car_finals str_finals UNIVs dtors Abs_Ts))
38.1925 + (mk_mor_Abs_tac (mor_def :: dtor_defs) Abs_inverses)
38.1926 + |> Thm.close_derivation;
38.1927 + in
38.1928 + (mor_Rep, mor_Abs)
38.1929 + end;
38.1930 +
38.1931 + val timer = time (timer "dtor definitions & thms");
38.1932 +
38.1933 + fun unfold_bind i = Binding.suffix_name ("_" ^ dtor_unfoldN) (nth bs (i - 1));
38.1934 + val unfold_name = Binding.name_of o unfold_bind;
38.1935 + val unfold_def_bind = rpair [] o Thm.def_binding o unfold_bind;
38.1936 +
38.1937 + fun unfold_spec i T AT abs f z z' =
38.1938 + let
38.1939 + val unfoldT = Library.foldr (op -->) (sTs, AT --> T);
38.1940 +
38.1941 + val lhs = Term.list_comb (Free (unfold_name i, unfoldT), ss);
38.1942 + val rhs = Term.absfree z' (abs $ (f $ z));
38.1943 + in
38.1944 + mk_Trueprop_eq (lhs, rhs)
38.1945 + end;
38.1946 +
38.1947 + val ((unfold_frees, (_, unfold_def_frees)), (lthy, lthy_old)) =
38.1948 + lthy
38.1949 + |> fold_map7 (fn i => fn T => fn AT => fn abs => fn f => fn z => fn z' =>
38.1950 + Specification.definition
38.1951 + (SOME (unfold_bind i, NONE, NoSyn), (unfold_def_bind i, unfold_spec i T AT abs f z z')))
38.1952 + ks Ts activeAs Abs_Ts (map (fn i => HOLogic.mk_comp
38.1953 + (mk_proj (mk_LSBIS passive_UNIVs i), mk_beh ss i)) ks) zs zs'
38.1954 + |>> apsnd split_list o split_list
38.1955 + ||> `Local_Theory.restore;
38.1956 +
38.1957 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.1958 + val unfolds = map (Morphism.term phi) unfold_frees;
38.1959 + val unfold_names = map (fst o dest_Const) unfolds;
38.1960 + fun mk_unfold Ts ss i = Term.list_comb (Const (nth unfold_names (i - 1), Library.foldr (op -->)
38.1961 + (map fastype_of ss, domain_type (fastype_of (nth ss (i - 1))) --> nth Ts (i - 1))), ss);
38.1962 + val unfold_defs = map ((fn thm => thm RS fun_cong) o Morphism.thm phi) unfold_def_frees;
38.1963 +
38.1964 + val mor_unfold_thm =
38.1965 + let
38.1966 + val Abs_inverses' = map2 (curry op RS) in_car_final_thms Abs_inverses;
38.1967 + val morEs' = map (fn thm =>
38.1968 + (thm OF [tcoalg_thm RS mor_final_thm, UNIV_I]) RS sym) morE_thms;
38.1969 + in
38.1970 + Skip_Proof.prove lthy [] []
38.1971 + (fold_rev Logic.all ss
38.1972 + (HOLogic.mk_Trueprop (mk_mor active_UNIVs ss UNIVs dtors (map (mk_unfold Ts ss) ks))))
38.1973 + (K (mk_mor_unfold_tac m mor_UNIV_thm dtor_defs unfold_defs Abs_inverses' morEs'
38.1974 + map_comp_id_thms map_congs))
38.1975 + |> Thm.close_derivation
38.1976 + end;
38.1977 + val dtor_unfold_thms = map (fn thm => (thm OF [mor_unfold_thm, UNIV_I]) RS sym) morE_thms;
38.1978 +
38.1979 + val (raw_coind_thms, raw_coind_thm) =
38.1980 + let
38.1981 + val prem = HOLogic.mk_Trueprop (mk_sbis passive_UNIVs UNIVs dtors TRs);
38.1982 + val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.1983 + (map2 (fn R => fn T => mk_subset R (Id_const T)) TRs Ts));
38.1984 + val goal = fold_rev Logic.all TRs (Logic.mk_implies (prem, concl));
38.1985 + in
38.1986 + `split_conj_thm (Skip_Proof.prove lthy [] [] goal
38.1987 + (K (mk_raw_coind_tac bis_def bis_cong_thm bis_O_thm bis_converse_thm bis_Gr_thm
38.1988 + tcoalg_thm coalgT_thm mor_T_final_thm sbis_lsbis_thm
38.1989 + lsbis_incl_thms incl_lsbis_thms equiv_LSBIS_thms mor_Rep_thm Rep_injects))
38.1990 + |> Thm.close_derivation)
38.1991 + end;
38.1992 +
38.1993 + val unique_mor_thms =
38.1994 + let
38.1995 + val prems = [HOLogic.mk_Trueprop (mk_coalg passive_UNIVs Bs ss), HOLogic.mk_Trueprop
38.1996 + (HOLogic.mk_conj (mk_mor Bs ss UNIVs dtors unfold_fs,
38.1997 + mk_mor Bs ss UNIVs dtors unfold_fs_copy))];
38.1998 + fun mk_fun_eq B f g z = HOLogic.mk_imp
38.1999 + (HOLogic.mk_mem (z, B), HOLogic.mk_eq (f $ z, g $ z));
38.2000 + val unique = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2001 + (map4 mk_fun_eq Bs unfold_fs unfold_fs_copy zs));
38.2002 +
38.2003 + val unique_mor = Skip_Proof.prove lthy [] []
38.2004 + (fold_rev Logic.all (Bs @ ss @ unfold_fs @ unfold_fs_copy @ zs)
38.2005 + (Logic.list_implies (prems, unique)))
38.2006 + (K (mk_unique_mor_tac raw_coind_thms bis_image2_thm))
38.2007 + |> Thm.close_derivation;
38.2008 + in
38.2009 + map (fn thm => conjI RSN (2, thm RS mp)) (split_conj_thm unique_mor)
38.2010 + end;
38.2011 +
38.2012 + val (unfold_unique_mor_thms, unfold_unique_mor_thm) =
38.2013 + let
38.2014 + val prem = HOLogic.mk_Trueprop (mk_mor active_UNIVs ss UNIVs dtors unfold_fs);
38.2015 + fun mk_fun_eq f i = HOLogic.mk_eq (f, mk_unfold Ts ss i);
38.2016 + val unique = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2017 + (map2 mk_fun_eq unfold_fs ks));
38.2018 +
38.2019 + val bis_thm = tcoalg_thm RSN (2, tcoalg_thm RS bis_image2_thm);
38.2020 + val mor_thm = mor_comp_thm OF [tcoalg_thm RS mor_final_thm, mor_Abs_thm];
38.2021 +
38.2022 + val unique_mor = Skip_Proof.prove lthy [] []
38.2023 + (fold_rev Logic.all (ss @ unfold_fs) (Logic.mk_implies (prem, unique)))
38.2024 + (K (mk_unfold_unique_mor_tac raw_coind_thms bis_thm mor_thm unfold_defs))
38.2025 + |> Thm.close_derivation;
38.2026 + in
38.2027 + `split_conj_thm unique_mor
38.2028 + end;
38.2029 +
38.2030 + val (dtor_unfold_unique_thms, dtor_unfold_unique_thm) = `split_conj_thm (split_conj_prems n
38.2031 + (mor_UNIV_thm RS @{thm ssubst[of _ _ "%x. x"]} RS unfold_unique_mor_thm));
38.2032 +
38.2033 + val unfold_dtor_thms = map (fn thm => mor_id_thm RS thm RS sym) unfold_unique_mor_thms;
38.2034 +
38.2035 + val unfold_o_dtor_thms =
38.2036 + let
38.2037 + val mor = mor_comp_thm OF [mor_str_thm, mor_unfold_thm];
38.2038 + in
38.2039 + map2 (fn unique => fn unfold_ctor =>
38.2040 + trans OF [mor RS unique, unfold_ctor]) unfold_unique_mor_thms unfold_dtor_thms
38.2041 + end;
38.2042 +
38.2043 + val timer = time (timer "unfold definitions & thms");
38.2044 +
38.2045 + val map_dtors = map2 (fn Ds => fn bnf =>
38.2046 + Term.list_comb (mk_map_of_bnf Ds (passiveAs @ Ts) (passiveAs @ FTs) bnf,
38.2047 + map HOLogic.id_const passiveAs @ dtors)) Dss bnfs;
38.2048 +
38.2049 + fun ctor_bind i = Binding.suffix_name ("_" ^ ctorN) (nth bs (i - 1));
38.2050 + val ctor_name = Binding.name_of o ctor_bind;
38.2051 + val ctor_def_bind = rpair [] o Thm.def_binding o ctor_bind;
38.2052 +
38.2053 + fun ctor_spec i ctorT =
38.2054 + let
38.2055 + val lhs = Free (ctor_name i, ctorT);
38.2056 + val rhs = mk_unfold Ts map_dtors i;
38.2057 + in
38.2058 + mk_Trueprop_eq (lhs, rhs)
38.2059 + end;
38.2060 +
38.2061 + val ((ctor_frees, (_, ctor_def_frees)), (lthy, lthy_old)) =
38.2062 + lthy
38.2063 + |> fold_map2 (fn i => fn ctorT =>
38.2064 + Specification.definition
38.2065 + (SOME (ctor_bind i, NONE, NoSyn), (ctor_def_bind i, ctor_spec i ctorT))) ks ctorTs
38.2066 + |>> apsnd split_list o split_list
38.2067 + ||> `Local_Theory.restore;
38.2068 +
38.2069 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.2070 + fun mk_ctors params =
38.2071 + map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ params) o Morphism.term phi)
38.2072 + ctor_frees;
38.2073 + val ctors = mk_ctors params';
38.2074 + val ctor_defs = map (Morphism.thm phi) ctor_def_frees;
38.2075 +
38.2076 + val ctor_o_dtor_thms = map2 (fold_thms lthy o single) ctor_defs unfold_o_dtor_thms;
38.2077 +
38.2078 + val dtor_o_ctor_thms =
38.2079 + let
38.2080 + fun mk_goal dtor ctor FT =
38.2081 + mk_Trueprop_eq (HOLogic.mk_comp (dtor, ctor), HOLogic.id_const FT);
38.2082 + val goals = map3 mk_goal dtors ctors FTs;
38.2083 + in
38.2084 + map5 (fn goal => fn ctor_def => fn unfold => fn map_comp_id => fn map_congL =>
38.2085 + Skip_Proof.prove lthy [] [] goal
38.2086 + (mk_dtor_o_ctor_tac ctor_def unfold map_comp_id map_congL unfold_o_dtor_thms)
38.2087 + |> Thm.close_derivation)
38.2088 + goals ctor_defs dtor_unfold_thms map_comp_id_thms map_congL_thms
38.2089 + end;
38.2090 +
38.2091 + val dtor_ctor_thms = map (fn thm => thm RS @{thm pointfree_idE}) dtor_o_ctor_thms;
38.2092 + val ctor_dtor_thms = map (fn thm => thm RS @{thm pointfree_idE}) ctor_o_dtor_thms;
38.2093 +
38.2094 + val bij_dtor_thms =
38.2095 + map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) ctor_o_dtor_thms dtor_o_ctor_thms;
38.2096 + val inj_dtor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_dtor_thms;
38.2097 + val surj_dtor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_dtor_thms;
38.2098 + val dtor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_dtor_thms;
38.2099 + val dtor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_dtor_thms;
38.2100 + val dtor_exhaust_thms = map (fn thm => thm RS exE) dtor_nchotomy_thms;
38.2101 +
38.2102 + val bij_ctor_thms =
38.2103 + map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) dtor_o_ctor_thms ctor_o_dtor_thms;
38.2104 + val inj_ctor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_ctor_thms;
38.2105 + val surj_ctor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_ctor_thms;
38.2106 + val ctor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_ctor_thms;
38.2107 + val ctor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_ctor_thms;
38.2108 + val ctor_exhaust_thms = map (fn thm => thm RS exE) ctor_nchotomy_thms;
38.2109 +
38.2110 + fun mk_ctor_dtor_unfold_like_thm dtor_inject dtor_ctor unfold =
38.2111 + iffD1 OF [dtor_inject, trans OF [unfold, dtor_ctor RS sym]];
38.2112 +
38.2113 + val ctor_dtor_unfold_thms =
38.2114 + map3 mk_ctor_dtor_unfold_like_thm dtor_inject_thms dtor_ctor_thms dtor_unfold_thms;
38.2115 +
38.2116 + val timer = time (timer "ctor definitions & thms");
38.2117 +
38.2118 + val corec_Inl_sum_thms =
38.2119 + let
38.2120 + val mor = mor_comp_thm OF [mor_sum_case_thm, mor_unfold_thm];
38.2121 + in
38.2122 + map2 (fn unique => fn unfold_dtor =>
38.2123 + trans OF [mor RS unique, unfold_dtor]) unfold_unique_mor_thms unfold_dtor_thms
38.2124 + end;
38.2125 +
38.2126 + fun corec_bind i = Binding.suffix_name ("_" ^ dtor_corecN) (nth bs (i - 1));
38.2127 + val corec_name = Binding.name_of o corec_bind;
38.2128 + val corec_def_bind = rpair [] o Thm.def_binding o corec_bind;
38.2129 +
38.2130 + fun corec_spec i T AT =
38.2131 + let
38.2132 + val corecT = Library.foldr (op -->) (corec_sTs, AT --> T);
38.2133 + val maps = map3 (fn dtor => fn sum_s => fn mapx => mk_sum_case
38.2134 + (HOLogic.mk_comp (Term.list_comb (mapx, passive_ids @ corec_Inls), dtor), sum_s))
38.2135 + dtors corec_ss corec_maps;
38.2136 +
38.2137 + val lhs = Term.list_comb (Free (corec_name i, corecT), corec_ss);
38.2138 + val rhs = HOLogic.mk_comp (mk_unfold Ts maps i, Inr_const T AT);
38.2139 + in
38.2140 + mk_Trueprop_eq (lhs, rhs)
38.2141 + end;
38.2142 +
38.2143 + val ((corec_frees, (_, corec_def_frees)), (lthy, lthy_old)) =
38.2144 + lthy
38.2145 + |> fold_map3 (fn i => fn T => fn AT =>
38.2146 + Specification.definition
38.2147 + (SOME (corec_bind i, NONE, NoSyn), (corec_def_bind i, corec_spec i T AT)))
38.2148 + ks Ts activeAs
38.2149 + |>> apsnd split_list o split_list
38.2150 + ||> `Local_Theory.restore;
38.2151 +
38.2152 + val phi = Proof_Context.export_morphism lthy_old lthy;
38.2153 + val corecs = map (Morphism.term phi) corec_frees;
38.2154 + val corec_names = map (fst o dest_Const) corecs;
38.2155 + fun mk_corec ss i = Term.list_comb (Const (nth corec_names (i - 1), Library.foldr (op -->)
38.2156 + (map fastype_of ss, domain_type (fastype_of (nth ss (i - 1))) --> nth Ts (i - 1))), ss);
38.2157 + val corec_defs = map (Morphism.thm phi) corec_def_frees;
38.2158 +
38.2159 + val sum_cases =
38.2160 + map2 (fn T => fn i => mk_sum_case (HOLogic.id_const T, mk_corec corec_ss i)) Ts ks;
38.2161 + val dtor_corec_thms =
38.2162 + let
38.2163 + fun mk_goal i corec_s corec_map dtor z =
38.2164 + let
38.2165 + val lhs = dtor $ (mk_corec corec_ss i $ z);
38.2166 + val rhs = Term.list_comb (corec_map, passive_ids @ sum_cases) $ (corec_s $ z);
38.2167 + in
38.2168 + fold_rev Logic.all (z :: corec_ss) (mk_Trueprop_eq (lhs, rhs))
38.2169 + end;
38.2170 + val goals = map5 mk_goal ks corec_ss corec_maps_rev dtors zs;
38.2171 + in
38.2172 + map3 (fn goal => fn unfold => fn map_cong =>
38.2173 + Skip_Proof.prove lthy [] [] goal
38.2174 + (mk_corec_tac m corec_defs unfold map_cong corec_Inl_sum_thms)
38.2175 + |> Thm.close_derivation)
38.2176 + goals dtor_unfold_thms map_congs
38.2177 + end;
38.2178 +
38.2179 + val ctor_dtor_corec_thms =
38.2180 + map3 mk_ctor_dtor_unfold_like_thm dtor_inject_thms dtor_ctor_thms dtor_corec_thms;
38.2181 +
38.2182 + val timer = time (timer "corec definitions & thms");
38.2183 +
38.2184 + val (dtor_coinduct_thm, coinduct_params, srel_coinduct_thm, rel_coinduct_thm,
38.2185 + dtor_strong_coinduct_thm, srel_strong_coinduct_thm, rel_strong_coinduct_thm) =
38.2186 + let
38.2187 + val zs = Jzs1 @ Jzs2;
38.2188 + val frees = phis @ zs;
38.2189 +
38.2190 + fun mk_Ids Id = if Id then map Id_const passiveAs else map mk_diag passive_UNIVs;
38.2191 +
38.2192 + fun mk_phi upto_eq phi z1 z2 = if upto_eq
38.2193 + then Term.absfree (dest_Free z1) (Term.absfree (dest_Free z2)
38.2194 + (HOLogic.mk_disj (phi $ z1 $ z2, HOLogic.mk_eq (z1, z2))))
38.2195 + else phi;
38.2196 +
38.2197 + fun phi_srels upto_eq = map4 (fn phi => fn T => fn z1 => fn z2 =>
38.2198 + HOLogic.Collect_const (HOLogic.mk_prodT (T, T)) $
38.2199 + HOLogic.mk_split (mk_phi upto_eq phi z1 z2)) phis Ts Jzs1 Jzs2;
38.2200 +
38.2201 + val srels = map (Term.subst_atomic_types ((activeAs ~~ Ts) @ (activeBs ~~ Ts))) relsAsBs;
38.2202 +
38.2203 + fun mk_concl phi z1 z2 = HOLogic.mk_imp (phi $ z1 $ z2, HOLogic.mk_eq (z1, z2));
38.2204 + val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2205 + (map3 mk_concl phis Jzs1 Jzs2));
38.2206 +
38.2207 + fun mk_srel_prem upto_eq phi dtor srel Jz Jz_copy =
38.2208 + let
38.2209 + val concl = HOLogic.mk_mem (HOLogic.mk_tuple [dtor $ Jz, dtor $ Jz_copy],
38.2210 + Term.list_comb (srel, mk_Ids upto_eq @ phi_srels upto_eq));
38.2211 + in
38.2212 + HOLogic.mk_Trueprop
38.2213 + (list_all_free [Jz, Jz_copy] (HOLogic.mk_imp (phi $ Jz $ Jz_copy, concl)))
38.2214 + end;
38.2215 +
38.2216 + val srel_prems = map5 (mk_srel_prem false) phis dtors srels Jzs Jzs_copy;
38.2217 + val srel_upto_prems = map5 (mk_srel_prem true) phis dtors srels Jzs Jzs_copy;
38.2218 +
38.2219 + val srel_coinduct_goal = fold_rev Logic.all frees (Logic.list_implies (srel_prems, concl));
38.2220 + val coinduct_params = rev (Term.add_tfrees srel_coinduct_goal []);
38.2221 +
38.2222 + val srel_coinduct = unfold_thms lthy @{thms diag_UNIV}
38.2223 + (Skip_Proof.prove lthy [] [] srel_coinduct_goal
38.2224 + (K (mk_srel_coinduct_tac ks raw_coind_thm bis_srel_thm))
38.2225 + |> Thm.close_derivation);
38.2226 +
38.2227 + fun mk_dtor_prem upto_eq phi dtor map_nth sets Jz Jz_copy FJz =
38.2228 + let
38.2229 + val xs = [Jz, Jz_copy];
38.2230 +
38.2231 + fun mk_map_conjunct nths x =
38.2232 + HOLogic.mk_eq (Term.list_comb (map_nth, passive_ids @ nths) $ FJz, dtor $ x);
38.2233 +
38.2234 + fun mk_set_conjunct set phi z1 z2 =
38.2235 + list_all_free [z1, z2]
38.2236 + (HOLogic.mk_imp (HOLogic.mk_mem (HOLogic.mk_prod (z1, z2), set $ FJz),
38.2237 + mk_phi upto_eq phi z1 z2 $ z1 $ z2));
38.2238 +
38.2239 + val concl = list_exists_free [FJz] (HOLogic.mk_conj
38.2240 + (Library.foldr1 HOLogic.mk_conj (map2 mk_map_conjunct [fstsTs, sndsTs] xs),
38.2241 + Library.foldr1 HOLogic.mk_conj
38.2242 + (map4 mk_set_conjunct (drop m sets) phis Jzs1 Jzs2)));
38.2243 + in
38.2244 + fold_rev Logic.all xs (Logic.mk_implies
38.2245 + (HOLogic.mk_Trueprop (Term.list_comb (phi, xs)), HOLogic.mk_Trueprop concl))
38.2246 + end;
38.2247 +
38.2248 + fun mk_dtor_prems upto_eq =
38.2249 + map7 (mk_dtor_prem upto_eq) phis dtors map_FT_nths prodFT_setss Jzs Jzs_copy FJzs;
38.2250 +
38.2251 + val dtor_prems = mk_dtor_prems false;
38.2252 + val dtor_upto_prems = mk_dtor_prems true;
38.2253 +
38.2254 + val dtor_coinduct_goal = fold_rev Logic.all frees (Logic.list_implies (dtor_prems, concl));
38.2255 + val dtor_coinduct = Skip_Proof.prove lthy [] [] dtor_coinduct_goal
38.2256 + (K (mk_dtor_coinduct_tac m ks raw_coind_thm bis_def))
38.2257 + |> Thm.close_derivation;
38.2258 +
38.2259 + val cTs = map (SOME o certifyT lthy o TFree) coinduct_params;
38.2260 + val cts = map3 (SOME o certify lthy ooo mk_phi true) phis Jzs1 Jzs2;
38.2261 +
38.2262 + val srel_strong_coinduct = singleton (Proof_Context.export names_lthy lthy)
38.2263 + (Skip_Proof.prove lthy [] []
38.2264 + (fold_rev Logic.all zs (Logic.list_implies (srel_upto_prems, concl)))
38.2265 + (K (mk_srel_strong_coinduct_tac m cTs cts srel_coinduct srel_monos srel_Ids)))
38.2266 + |> Thm.close_derivation;
38.2267 +
38.2268 + val dtor_strong_coinduct = singleton (Proof_Context.export names_lthy lthy)
38.2269 + (Skip_Proof.prove lthy [] []
38.2270 + (fold_rev Logic.all zs (Logic.list_implies (dtor_upto_prems, concl)))
38.2271 + (K (mk_dtor_strong_coinduct_tac ks cTs cts dtor_coinduct bis_def
38.2272 + (tcoalg_thm RS bis_diag_thm))))
38.2273 + |> Thm.close_derivation;
38.2274 +
38.2275 + val rel_of_srel_thms =
38.2276 + srel_defs @ @{thms Id_def' mem_Collect_eq fst_conv snd_conv split_conv};
38.2277 +
38.2278 + val rel_coinduct = unfold_thms lthy rel_of_srel_thms srel_coinduct;
38.2279 + val rel_strong_coinduct = unfold_thms lthy rel_of_srel_thms srel_strong_coinduct;
38.2280 + in
38.2281 + (dtor_coinduct, rev (Term.add_tfrees dtor_coinduct_goal []), srel_coinduct, rel_coinduct,
38.2282 + dtor_strong_coinduct, srel_strong_coinduct, rel_strong_coinduct)
38.2283 + end;
38.2284 +
38.2285 + val timer = time (timer "coinduction");
38.2286 +
38.2287 + (*register new codatatypes as BNFs*)
38.2288 + val lthy = if m = 0 then lthy else
38.2289 + let
38.2290 + val fTs = map2 (curry op -->) passiveAs passiveBs;
38.2291 + val gTs = map2 (curry op -->) passiveBs passiveCs;
38.2292 + val f1Ts = map2 (curry op -->) passiveAs passiveYs;
38.2293 + val f2Ts = map2 (curry op -->) passiveBs passiveYs;
38.2294 + val p1Ts = map2 (curry op -->) passiveXs passiveAs;
38.2295 + val p2Ts = map2 (curry op -->) passiveXs passiveBs;
38.2296 + val pTs = map2 (curry op -->) passiveXs passiveCs;
38.2297 + val uTs = map2 (curry op -->) Ts Ts';
38.2298 + val JRTs = map2 (curry mk_relT) passiveAs passiveBs;
38.2299 + val JphiTs = map2 mk_pred2T passiveAs passiveBs;
38.2300 + val prodTs = map2 (curry HOLogic.mk_prodT) Ts Ts';
38.2301 + val B1Ts = map HOLogic.mk_setT passiveAs;
38.2302 + val B2Ts = map HOLogic.mk_setT passiveBs;
38.2303 + val AXTs = map HOLogic.mk_setT passiveXs;
38.2304 + val XTs = mk_Ts passiveXs;
38.2305 + val YTs = mk_Ts passiveYs;
38.2306 +
38.2307 + val ((((((((((((((((((((fs, fs'), fs_copy), gs), us),
38.2308 + (Jys, Jys')), (Jys_copy, Jys'_copy)), set_induct_phiss), JRs), Jphis),
38.2309 + B1s), B2s), AXs), f1s), f2s), p1s), p2s), ps), (ys, ys')), (ys_copy, ys'_copy)),
38.2310 + names_lthy) = names_lthy
38.2311 + |> mk_Frees' "f" fTs
38.2312 + ||>> mk_Frees "f" fTs
38.2313 + ||>> mk_Frees "g" gTs
38.2314 + ||>> mk_Frees "u" uTs
38.2315 + ||>> mk_Frees' "b" Ts'
38.2316 + ||>> mk_Frees' "b" Ts'
38.2317 + ||>> mk_Freess "P" (map (fn A => map (mk_pred2T A) Ts) passiveAs)
38.2318 + ||>> mk_Frees "R" JRTs
38.2319 + ||>> mk_Frees "P" JphiTs
38.2320 + ||>> mk_Frees "B1" B1Ts
38.2321 + ||>> mk_Frees "B2" B2Ts
38.2322 + ||>> mk_Frees "A" AXTs
38.2323 + ||>> mk_Frees "f1" f1Ts
38.2324 + ||>> mk_Frees "f2" f2Ts
38.2325 + ||>> mk_Frees "p1" p1Ts
38.2326 + ||>> mk_Frees "p2" p2Ts
38.2327 + ||>> mk_Frees "p" pTs
38.2328 + ||>> mk_Frees' "y" passiveAs
38.2329 + ||>> mk_Frees' "y" passiveAs;
38.2330 +
38.2331 + val map_FTFT's = map2 (fn Ds =>
38.2332 + mk_map_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
38.2333 +
38.2334 + fun mk_maps ATs BTs Ts mk_T =
38.2335 + map2 (fn Ds => mk_map_of_bnf Ds (ATs @ Ts) (BTs @ map mk_T Ts)) Dss bnfs;
38.2336 + fun mk_Fmap mk_const fs Ts Fmap = Term.list_comb (Fmap, fs @ map mk_const Ts);
38.2337 + fun mk_map mk_const mk_T Ts fs Ts' dtors mk_maps =
38.2338 + mk_unfold Ts' (map2 (fn dtor => fn Fmap =>
38.2339 + HOLogic.mk_comp (mk_Fmap mk_const fs Ts Fmap, dtor)) dtors (mk_maps Ts mk_T));
38.2340 + val mk_map_id = mk_map HOLogic.id_const I;
38.2341 + val mk_mapsAB = mk_maps passiveAs passiveBs;
38.2342 + val mk_mapsBC = mk_maps passiveBs passiveCs;
38.2343 + val mk_mapsAC = mk_maps passiveAs passiveCs;
38.2344 + val mk_mapsAY = mk_maps passiveAs passiveYs;
38.2345 + val mk_mapsBY = mk_maps passiveBs passiveYs;
38.2346 + val mk_mapsXA = mk_maps passiveXs passiveAs;
38.2347 + val mk_mapsXB = mk_maps passiveXs passiveBs;
38.2348 + val mk_mapsXC = mk_maps passiveXs passiveCs;
38.2349 + val fs_maps = map (mk_map_id Ts fs Ts' dtors mk_mapsAB) ks;
38.2350 + val fs_copy_maps = map (mk_map_id Ts fs_copy Ts' dtors mk_mapsAB) ks;
38.2351 + val gs_maps = map (mk_map_id Ts' gs Ts'' dtor's mk_mapsBC) ks;
38.2352 + val fgs_maps =
38.2353 + map (mk_map_id Ts (map2 (curry HOLogic.mk_comp) gs fs) Ts'' dtors mk_mapsAC) ks;
38.2354 + val Xdtors = mk_dtors passiveXs;
38.2355 + val UNIV's = map HOLogic.mk_UNIV Ts';
38.2356 + val CUNIVs = map HOLogic.mk_UNIV passiveCs;
38.2357 + val UNIV''s = map HOLogic.mk_UNIV Ts'';
38.2358 + val fstsTsTs' = map fst_const prodTs;
38.2359 + val sndsTsTs' = map snd_const prodTs;
38.2360 + val dtor''s = mk_dtors passiveCs;
38.2361 + val f1s_maps = map (mk_map_id Ts f1s YTs dtors mk_mapsAY) ks;
38.2362 + val f2s_maps = map (mk_map_id Ts' f2s YTs dtor's mk_mapsBY) ks;
38.2363 + val pid_maps = map (mk_map_id XTs ps Ts'' Xdtors mk_mapsXC) ks;
38.2364 + val pfst_Fmaps =
38.2365 + map (mk_Fmap fst_const p1s prodTs) (mk_mapsXA prodTs (fst o HOLogic.dest_prodT));
38.2366 + val psnd_Fmaps =
38.2367 + map (mk_Fmap snd_const p2s prodTs) (mk_mapsXB prodTs (snd o HOLogic.dest_prodT));
38.2368 + val p1id_Fmaps = map (mk_Fmap HOLogic.id_const p1s prodTs) (mk_mapsXA prodTs I);
38.2369 + val p2id_Fmaps = map (mk_Fmap HOLogic.id_const p2s prodTs) (mk_mapsXB prodTs I);
38.2370 + val pid_Fmaps = map (mk_Fmap HOLogic.id_const ps prodTs) (mk_mapsXC prodTs I);
38.2371 +
38.2372 + val (map_simp_thms, map_thms) =
38.2373 + let
38.2374 + fun mk_goal fs_map map dtor dtor' = fold_rev Logic.all fs
38.2375 + (mk_Trueprop_eq (HOLogic.mk_comp (dtor', fs_map),
38.2376 + HOLogic.mk_comp (Term.list_comb (map, fs @ fs_maps), dtor)));
38.2377 + val goals = map4 mk_goal fs_maps map_FTFT's dtors dtor's;
38.2378 + val cTs = map (SOME o certifyT lthy) FTs';
38.2379 + val maps =
38.2380 + map5 (fn goal => fn cT => fn unfold => fn map_comp' => fn map_cong =>
38.2381 + Skip_Proof.prove lthy [] [] goal
38.2382 + (K (mk_map_tac m n cT unfold map_comp' map_cong))
38.2383 + |> Thm.close_derivation)
38.2384 + goals cTs dtor_unfold_thms map_comp's map_congs;
38.2385 + in
38.2386 + map_split (fn thm => (thm RS @{thm pointfreeE}, thm)) maps
38.2387 + end;
38.2388 +
38.2389 + val map_comp_thms =
38.2390 + let
38.2391 + val goal = fold_rev Logic.all (fs @ gs)
38.2392 + (HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2393 + (map3 (fn fmap => fn gmap => fn fgmap =>
38.2394 + HOLogic.mk_eq (HOLogic.mk_comp (gmap, fmap), fgmap))
38.2395 + fs_maps gs_maps fgs_maps)))
38.2396 + in
38.2397 + split_conj_thm (Skip_Proof.prove lthy [] [] goal
38.2398 + (K (mk_map_comp_tac m n map_thms map_comps map_congs dtor_unfold_unique_thm))
38.2399 + |> Thm.close_derivation)
38.2400 + end;
38.2401 +
38.2402 + val map_unique_thm =
38.2403 + let
38.2404 + fun mk_prem u map dtor dtor' =
38.2405 + mk_Trueprop_eq (HOLogic.mk_comp (dtor', u),
38.2406 + HOLogic.mk_comp (Term.list_comb (map, fs @ us), dtor));
38.2407 + val prems = map4 mk_prem us map_FTFT's dtors dtor's;
38.2408 + val goal =
38.2409 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2410 + (map2 (curry HOLogic.mk_eq) us fs_maps));
38.2411 + in
38.2412 + Skip_Proof.prove lthy [] []
38.2413 + (fold_rev Logic.all (us @ fs) (Logic.list_implies (prems, goal)))
38.2414 + (mk_map_unique_tac dtor_unfold_unique_thm map_comps)
38.2415 + |> Thm.close_derivation
38.2416 + end;
38.2417 +
38.2418 + val timer = time (timer "map functions for the new codatatypes");
38.2419 +
38.2420 + val bd = mk_ccexp sbd sbd;
38.2421 +
38.2422 + val timer = time (timer "bounds for the new codatatypes");
38.2423 +
38.2424 + val setss_by_bnf = map (fn i => map2 (mk_hset dtors i) ls passiveAs) ks;
38.2425 + val setss_by_bnf' = map (fn i => map2 (mk_hset dtor's i) ls passiveBs) ks;
38.2426 + val setss_by_range = transpose setss_by_bnf;
38.2427 +
38.2428 + val set_simp_thmss =
38.2429 + let
38.2430 + fun mk_simp_goal relate pas_set act_sets sets dtor z set =
38.2431 + relate (set $ z, mk_union (pas_set $ (dtor $ z),
38.2432 + Library.foldl1 mk_union
38.2433 + (map2 (fn X => mk_UNION (X $ (dtor $ z))) act_sets sets)));
38.2434 + fun mk_goals eq =
38.2435 + map2 (fn i => fn sets =>
38.2436 + map4 (fn Fsets =>
38.2437 + mk_simp_goal eq (nth Fsets (i - 1)) (drop m Fsets) sets)
38.2438 + FTs_setss dtors Jzs sets)
38.2439 + ls setss_by_range;
38.2440 +
38.2441 + val le_goals = map
38.2442 + (fold_rev Logic.all Jzs o HOLogic.mk_Trueprop o Library.foldr1 HOLogic.mk_conj)
38.2443 + (mk_goals (uncurry mk_subset));
38.2444 + val set_le_thmss = map split_conj_thm
38.2445 + (map4 (fn goal => fn hset_minimal => fn set_hsets => fn set_hset_hsetss =>
38.2446 + Skip_Proof.prove lthy [] [] goal
38.2447 + (K (mk_set_le_tac n hset_minimal set_hsets set_hset_hsetss))
38.2448 + |> Thm.close_derivation)
38.2449 + le_goals hset_minimal_thms set_hset_thmss' set_hset_hset_thmsss');
38.2450 +
38.2451 + val simp_goalss = map (map2 (fn z => fn goal =>
38.2452 + Logic.all z (HOLogic.mk_Trueprop goal)) Jzs)
38.2453 + (mk_goals HOLogic.mk_eq);
38.2454 + in
38.2455 + map4 (map4 (fn goal => fn set_le => fn set_incl_hset => fn set_hset_incl_hsets =>
38.2456 + Skip_Proof.prove lthy [] [] goal
38.2457 + (K (mk_set_simp_tac n set_le set_incl_hset set_hset_incl_hsets))
38.2458 + |> Thm.close_derivation))
38.2459 + simp_goalss set_le_thmss set_incl_hset_thmss' set_hset_incl_hset_thmsss'
38.2460 + end;
38.2461 +
38.2462 + val timer = time (timer "set functions for the new codatatypes");
38.2463 +
38.2464 + val colss = map2 (fn j => fn T =>
38.2465 + map (fn i => mk_hset_rec dtors nat i j T) ks) ls passiveAs;
38.2466 + val colss' = map2 (fn j => fn T =>
38.2467 + map (fn i => mk_hset_rec dtor's nat i j T) ks) ls passiveBs;
38.2468 + val Xcolss = map2 (fn j => fn T =>
38.2469 + map (fn i => mk_hset_rec Xdtors nat i j T) ks) ls passiveXs;
38.2470 +
38.2471 + val col_natural_thmss =
38.2472 + let
38.2473 + fun mk_col_natural f map z col col' =
38.2474 + HOLogic.mk_eq (mk_image f $ (col $ z), col' $ (map $ z));
38.2475 +
38.2476 + fun mk_goal f cols cols' = list_all_free Jzs (Library.foldr1 HOLogic.mk_conj
38.2477 + (map4 (mk_col_natural f) fs_maps Jzs cols cols'));
38.2478 +
38.2479 + val goals = map3 mk_goal fs colss colss';
38.2480 +
38.2481 + val ctss =
38.2482 + map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) goals;
38.2483 +
38.2484 + val thms =
38.2485 + map4 (fn goal => fn cts => fn rec_0s => fn rec_Sucs =>
38.2486 + singleton (Proof_Context.export names_lthy lthy)
38.2487 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.2488 + (mk_col_natural_tac cts rec_0s rec_Sucs map_simp_thms set_natural'ss))
38.2489 + |> Thm.close_derivation)
38.2490 + goals ctss hset_rec_0ss' hset_rec_Sucss';
38.2491 + in
38.2492 + map (split_conj_thm o mk_specN n) thms
38.2493 + end;
38.2494 +
38.2495 + val col_bd_thmss =
38.2496 + let
38.2497 + fun mk_col_bd z col = mk_ordLeq (mk_card_of (col $ z)) sbd;
38.2498 +
38.2499 + fun mk_goal cols = list_all_free Jzs (Library.foldr1 HOLogic.mk_conj
38.2500 + (map2 mk_col_bd Jzs cols));
38.2501 +
38.2502 + val goals = map mk_goal colss;
38.2503 +
38.2504 + val ctss =
38.2505 + map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) goals;
38.2506 +
38.2507 + val thms =
38.2508 + map5 (fn j => fn goal => fn cts => fn rec_0s => fn rec_Sucs =>
38.2509 + singleton (Proof_Context.export names_lthy lthy)
38.2510 + (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
38.2511 + (K (mk_col_bd_tac m j cts rec_0s rec_Sucs
38.2512 + sbd_Card_order sbd_Cinfinite set_sbdss)))
38.2513 + |> Thm.close_derivation)
38.2514 + ls goals ctss hset_rec_0ss' hset_rec_Sucss';
38.2515 + in
38.2516 + map (split_conj_thm o mk_specN n) thms
38.2517 + end;
38.2518 +
38.2519 + val map_cong_thms =
38.2520 + let
38.2521 + val cTs = map (SOME o certifyT lthy o
38.2522 + Term.typ_subst_atomic (passiveAs ~~ passiveBs) o TFree) coinduct_params;
38.2523 +
38.2524 + fun mk_prem z set f g y y' =
38.2525 + mk_Ball (set $ z) (Term.absfree y' (HOLogic.mk_eq (f $ y, g $ y)));
38.2526 +
38.2527 + fun mk_prems sets z =
38.2528 + Library.foldr1 HOLogic.mk_conj (map5 (mk_prem z) sets fs fs_copy ys ys')
38.2529 +
38.2530 + fun mk_map_cong sets z fmap gmap =
38.2531 + HOLogic.mk_imp (mk_prems sets z, HOLogic.mk_eq (fmap $ z, gmap $ z));
38.2532 +
38.2533 + fun mk_coind_body sets (x, T) z fmap gmap y y_copy =
38.2534 + HOLogic.mk_conj
38.2535 + (HOLogic.mk_mem (z, HOLogic.mk_Collect (x, T, mk_prems sets z)),
38.2536 + HOLogic.mk_conj (HOLogic.mk_eq (y, fmap $ z),
38.2537 + HOLogic.mk_eq (y_copy, gmap $ z)))
38.2538 +
38.2539 + fun mk_cphi sets (z' as (x, T)) z fmap gmap y' y y'_copy y_copy =
38.2540 + HOLogic.mk_exists (x, T, mk_coind_body sets z' z fmap gmap y y_copy)
38.2541 + |> Term.absfree y'_copy
38.2542 + |> Term.absfree y'
38.2543 + |> certify lthy;
38.2544 +
38.2545 + val cphis =
38.2546 + map9 mk_cphi setss_by_bnf Jzs' Jzs fs_maps fs_copy_maps Jys' Jys Jys'_copy Jys_copy;
38.2547 +
38.2548 + val coinduct = Drule.instantiate' cTs (map SOME cphis) dtor_coinduct_thm;
38.2549 +
38.2550 + val goal =
38.2551 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2552 + (map4 mk_map_cong setss_by_bnf Jzs fs_maps fs_copy_maps));
38.2553 +
38.2554 + val thm = singleton (Proof_Context.export names_lthy lthy)
38.2555 + (Skip_Proof.prove lthy [] [] goal
38.2556 + (K (mk_mcong_tac m (rtac coinduct) map_comp's map_simp_thms map_congs set_natural'ss
38.2557 + set_hset_thmss set_hset_hset_thmsss)))
38.2558 + |> Thm.close_derivation
38.2559 + in
38.2560 + split_conj_thm thm
38.2561 + end;
38.2562 +
38.2563 + val B1_ins = map2 (mk_in B1s) setss_by_bnf Ts;
38.2564 + val B2_ins = map2 (mk_in B2s) setss_by_bnf' Ts';
38.2565 + val thePulls = map4 mk_thePull B1_ins B2_ins f1s_maps f2s_maps;
38.2566 + val thePullTs = passiveXs @ map2 (curry HOLogic.mk_prodT) Ts Ts';
38.2567 + val thePull_ins = map2 (mk_in (AXs @ thePulls)) (mk_setss thePullTs) (mk_FTs thePullTs);
38.2568 + val pickFs = map5 mk_pickWP thePull_ins pfst_Fmaps psnd_Fmaps
38.2569 + (map2 (curry (op $)) dtors Jzs) (map2 (curry (op $)) dtor's Jz's);
38.2570 + val pickF_ss = map3 (fn pickF => fn z => fn z' =>
38.2571 + HOLogic.mk_split (Term.absfree z (Term.absfree z' pickF))) pickFs Jzs' Jz's';
38.2572 + val picks = map (mk_unfold XTs pickF_ss) ks;
38.2573 +
38.2574 + val wpull_prem = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
38.2575 + (map8 mk_wpull AXs B1s B2s f1s f2s (replicate m NONE) p1s p2s));
38.2576 +
38.2577 + val map_eq_thms = map2 (fn simp => fn diff => box_equals OF [diff RS iffD2, simp, simp])
38.2578 + map_simp_thms dtor_inject_thms;
38.2579 + val map_wpull_thms = map (fn thm => thm OF
38.2580 + (replicate m asm_rl @ replicate n @{thm wpull_thePull})) map_wpulls;
38.2581 + val pickWP_assms_tacs =
38.2582 + map3 mk_pickWP_assms_tac set_incl_hset_thmss set_incl_hin_thmss map_eq_thms;
38.2583 +
38.2584 + val coalg_thePull_thm =
38.2585 + let
38.2586 + val coalg = HOLogic.mk_Trueprop
38.2587 + (mk_coalg CUNIVs thePulls (map2 (curry HOLogic.mk_comp) pid_Fmaps pickF_ss));
38.2588 + val goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s @ ps)
38.2589 + (Logic.mk_implies (wpull_prem, coalg));
38.2590 + in
38.2591 + Skip_Proof.prove lthy [] [] goal (mk_coalg_thePull_tac m coalg_def map_wpull_thms
38.2592 + set_natural'ss pickWP_assms_tacs)
38.2593 + |> Thm.close_derivation
38.2594 + end;
38.2595 +
38.2596 + val (mor_thePull_fst_thm, mor_thePull_snd_thm, mor_thePull_pick_thm) =
38.2597 + let
38.2598 + val mor_fst = HOLogic.mk_Trueprop
38.2599 + (mk_mor thePulls (map2 (curry HOLogic.mk_comp) p1id_Fmaps pickF_ss)
38.2600 + UNIVs dtors fstsTsTs');
38.2601 + val mor_snd = HOLogic.mk_Trueprop
38.2602 + (mk_mor thePulls (map2 (curry HOLogic.mk_comp) p2id_Fmaps pickF_ss)
38.2603 + UNIV's dtor's sndsTsTs');
38.2604 + val mor_pick = HOLogic.mk_Trueprop
38.2605 + (mk_mor thePulls (map2 (curry HOLogic.mk_comp) pid_Fmaps pickF_ss)
38.2606 + UNIV''s dtor''s (map2 (curry HOLogic.mk_comp) pid_maps picks));
38.2607 +
38.2608 + val fst_goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
38.2609 + (Logic.mk_implies (wpull_prem, mor_fst));
38.2610 + val snd_goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
38.2611 + (Logic.mk_implies (wpull_prem, mor_snd));
38.2612 + val pick_goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s @ ps)
38.2613 + (Logic.mk_implies (wpull_prem, mor_pick));
38.2614 + in
38.2615 + (Skip_Proof.prove lthy [] [] fst_goal (mk_mor_thePull_fst_tac m mor_def map_wpull_thms
38.2616 + map_comp's pickWP_assms_tacs) |> Thm.close_derivation,
38.2617 + Skip_Proof.prove lthy [] [] snd_goal (mk_mor_thePull_snd_tac m mor_def map_wpull_thms
38.2618 + map_comp's pickWP_assms_tacs) |> Thm.close_derivation,
38.2619 + Skip_Proof.prove lthy [] [] pick_goal (mk_mor_thePull_pick_tac mor_def dtor_unfold_thms
38.2620 + map_comp's) |> Thm.close_derivation)
38.2621 + end;
38.2622 +
38.2623 + val pick_col_thmss =
38.2624 + let
38.2625 + fun mk_conjunct AX Jpair pick thePull col =
38.2626 + HOLogic.mk_imp (HOLogic.mk_mem (Jpair, thePull), mk_subset (col $ (pick $ Jpair)) AX);
38.2627 +
38.2628 + fun mk_concl AX cols =
38.2629 + list_all_free Jpairs (Library.foldr1 HOLogic.mk_conj
38.2630 + (map4 (mk_conjunct AX) Jpairs picks thePulls cols));
38.2631 +
38.2632 + val concls = map2 mk_concl AXs Xcolss;
38.2633 +
38.2634 + val ctss =
38.2635 + map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
38.2636 +
38.2637 + val goals =
38.2638 + map (fn concl => Logic.mk_implies (wpull_prem, HOLogic.mk_Trueprop concl)) concls;
38.2639 +
38.2640 + val thms =
38.2641 + map5 (fn j => fn goal => fn cts => fn rec_0s => fn rec_Sucs =>
38.2642 + singleton (Proof_Context.export names_lthy lthy) (Skip_Proof.prove lthy [] [] goal
38.2643 + (mk_pick_col_tac m j cts rec_0s rec_Sucs dtor_unfold_thms set_natural'ss
38.2644 + map_wpull_thms pickWP_assms_tacs))
38.2645 + |> Thm.close_derivation)
38.2646 + ls goals ctss hset_rec_0ss' hset_rec_Sucss';
38.2647 + in
38.2648 + map (map (fn thm => thm RS mp) o split_conj_thm o mk_specN n) thms
38.2649 + end;
38.2650 +
38.2651 + val timer = time (timer "helpers for BNF properties");
38.2652 +
38.2653 + val map_id_tacs =
38.2654 + map2 (K oo mk_map_id_tac map_thms) dtor_unfold_unique_thms unfold_dtor_thms;
38.2655 + val map_comp_tacs = map (fn thm => K (rtac (thm RS sym) 1)) map_comp_thms;
38.2656 + val map_cong_tacs = map (mk_map_cong_tac m) map_cong_thms;
38.2657 + val set_nat_tacss =
38.2658 + map2 (map2 (K oo mk_set_natural_tac)) hset_defss (transpose col_natural_thmss);
38.2659 +
38.2660 + val bd_co_tacs = replicate n (K (mk_bd_card_order_tac sbd_card_order));
38.2661 + val bd_cinf_tacs = replicate n (K (mk_bd_cinfinite_tac sbd_Cinfinite));
38.2662 +
38.2663 + val set_bd_tacss =
38.2664 + map2 (map2 (K oo mk_set_bd_tac sbd_Cinfinite)) hset_defss (transpose col_bd_thmss);
38.2665 +
38.2666 + val in_bd_tacs = map7 (fn i => fn isNode_hsets => fn carT_def =>
38.2667 + fn card_of_carT => fn mor_image => fn Rep_inverse => fn mor_hsets =>
38.2668 + K (mk_in_bd_tac (nth isNode_hsets (i - 1)) isNode_hsets carT_def
38.2669 + card_of_carT mor_image Rep_inverse mor_hsets
38.2670 + sbd_Cnotzero sbd_Card_order mor_Rep_thm coalgT_thm mor_T_final_thm tcoalg_thm))
38.2671 + ks isNode_hset_thmss carT_defs card_of_carT_thms
38.2672 + mor_image'_thms Rep_inverses (transpose mor_hset_thmss);
38.2673 +
38.2674 + val map_wpull_tacs =
38.2675 + map3 (K ooo mk_wpull_tac m coalg_thePull_thm mor_thePull_fst_thm mor_thePull_snd_thm
38.2676 + mor_thePull_pick_thm) unique_mor_thms (transpose pick_col_thmss) hset_defss;
38.2677 +
38.2678 + val srel_O_Gr_tacs = replicate n (simple_srel_O_Gr_tac o #context);
38.2679 +
38.2680 + val tacss = map10 zip_axioms map_id_tacs map_comp_tacs map_cong_tacs set_nat_tacss
38.2681 + bd_co_tacs bd_cinf_tacs set_bd_tacss in_bd_tacs map_wpull_tacs srel_O_Gr_tacs;
38.2682 +
38.2683 + val (hset_dtor_incl_thmss, hset_hset_dtor_incl_thmsss, hset_induct_thms) =
38.2684 + let
38.2685 + fun tinst_of dtor =
38.2686 + map (SOME o certify lthy) (dtor :: remove (op =) dtor dtors);
38.2687 + fun tinst_of' dtor = case tinst_of dtor of t :: ts => t :: NONE :: ts;
38.2688 + val Tinst = map (pairself (certifyT lthy))
38.2689 + (map Logic.varifyT_global (deads @ allAs) ~~ (deads @ passiveAs @ Ts));
38.2690 + val set_incl_thmss =
38.2691 + map2 (fn dtor => map (singleton (Proof_Context.export names_lthy lthy) o
38.2692 + Drule.instantiate' [] (tinst_of' dtor) o
38.2693 + Thm.instantiate (Tinst, []) o Drule.zero_var_indexes))
38.2694 + dtors set_incl_hset_thmss;
38.2695 +
38.2696 + val tinst = interleave (map (SOME o certify lthy) dtors) (replicate n NONE)
38.2697 + val set_minimal_thms =
38.2698 + map (Drule.instantiate' [] tinst o Thm.instantiate (Tinst, []) o
38.2699 + Drule.zero_var_indexes)
38.2700 + hset_minimal_thms;
38.2701 +
38.2702 + val set_set_incl_thmsss =
38.2703 + map2 (fn dtor => map (map (singleton (Proof_Context.export names_lthy lthy) o
38.2704 + Drule.instantiate' [] (NONE :: tinst_of' dtor) o
38.2705 + Thm.instantiate (Tinst, []) o Drule.zero_var_indexes)))
38.2706 + dtors set_hset_incl_hset_thmsss;
38.2707 +
38.2708 + val set_set_incl_thmsss' = transpose (map transpose set_set_incl_thmsss);
38.2709 +
38.2710 + val incls =
38.2711 + maps (map (fn thm => thm RS @{thm subset_Collect_iff})) set_incl_thmss @
38.2712 + @{thms subset_Collect_iff[OF subset_refl]};
38.2713 +
38.2714 + fun mk_induct_tinst phis jsets y y' =
38.2715 + map4 (fn phi => fn jset => fn Jz => fn Jz' =>
38.2716 + SOME (certify lthy (Term.absfree Jz' (HOLogic.mk_Collect (fst y', snd y',
38.2717 + HOLogic.mk_conj (HOLogic.mk_mem (y, jset $ Jz), phi $ y $ Jz))))))
38.2718 + phis jsets Jzs Jzs';
38.2719 + val set_induct_thms =
38.2720 + map6 (fn set_minimal => fn set_set_inclss => fn jsets => fn y => fn y' => fn phis =>
38.2721 + ((set_minimal
38.2722 + |> Drule.instantiate' [] (mk_induct_tinst phis jsets y y')
38.2723 + |> unfold_thms lthy incls) OF
38.2724 + (replicate n ballI @
38.2725 + maps (map (fn thm => thm RS @{thm subset_CollectI})) set_set_inclss))
38.2726 + |> singleton (Proof_Context.export names_lthy lthy)
38.2727 + |> rule_by_tactic lthy (ALLGOALS (TRY o etac asm_rl)))
38.2728 + set_minimal_thms set_set_incl_thmsss' setss_by_range ys ys' set_induct_phiss
38.2729 + in
38.2730 + (set_incl_thmss, set_set_incl_thmsss, set_induct_thms)
38.2731 + end;
38.2732 +
38.2733 + fun close_wit I wit = (I, fold_rev Term.absfree (map (nth ys') I) wit);
38.2734 +
38.2735 + val all_unitTs = replicate live HOLogic.unitT;
38.2736 + val unitTs = replicate n HOLogic.unitT;
38.2737 + val unit_funs = replicate n (Term.absdummy HOLogic.unitT HOLogic.unit);
38.2738 + fun mk_map_args I =
38.2739 + map (fn i =>
38.2740 + if member (op =) I i then Term.absdummy HOLogic.unitT (nth ys i)
38.2741 + else mk_undefined (HOLogic.unitT --> nth passiveAs i))
38.2742 + (0 upto (m - 1));
38.2743 +
38.2744 + fun mk_nat_wit Ds bnf (I, wit) () =
38.2745 + let
38.2746 + val passiveI = filter (fn i => i < m) I;
38.2747 + val map_args = mk_map_args passiveI;
38.2748 + in
38.2749 + Term.absdummy HOLogic.unitT (Term.list_comb
38.2750 + (mk_map_of_bnf Ds all_unitTs (passiveAs @ unitTs) bnf, map_args @ unit_funs) $ wit)
38.2751 + end;
38.2752 +
38.2753 + fun mk_dummy_wit Ds bnf I =
38.2754 + let
38.2755 + val map_args = mk_map_args I;
38.2756 + in
38.2757 + Term.absdummy HOLogic.unitT (Term.list_comb
38.2758 + (mk_map_of_bnf Ds all_unitTs (passiveAs @ unitTs) bnf, map_args @ unit_funs) $
38.2759 + mk_undefined (mk_T_of_bnf Ds all_unitTs bnf))
38.2760 + end;
38.2761 +
38.2762 + val nat_witss =
38.2763 + map2 (fn Ds => fn bnf => mk_wits_of_bnf (replicate (nwits_of_bnf bnf) Ds)
38.2764 + (replicate (nwits_of_bnf bnf) (replicate live HOLogic.unitT)) bnf
38.2765 + |> map (fn (I, wit) =>
38.2766 + (I, Lazy.lazy (mk_nat_wit Ds bnf (I, Term.list_comb (wit, map (K HOLogic.unit) I))))))
38.2767 + Dss bnfs;
38.2768 +
38.2769 + val nat_wit_thmss = map2 (curry op ~~) nat_witss (map wit_thmss_of_bnf bnfs)
38.2770 +
38.2771 + val Iss = map (map fst) nat_witss;
38.2772 +
38.2773 + fun filter_wits (I, wit) =
38.2774 + let val J = filter (fn i => i < m) I;
38.2775 + in (J, (length J < length I, wit)) end;
38.2776 +
38.2777 + val wit_treess = map_index (fn (i, Is) =>
38.2778 + map_index (finish Iss m [i+m] (i+m)) Is) Iss
38.2779 + |> map (minimize_wits o map filter_wits o minimize_wits o flat);
38.2780 +
38.2781 + val coind_wit_argsss =
38.2782 + map (map (tree_to_coind_wits nat_wit_thmss o snd o snd) o filter (fst o snd)) wit_treess;
38.2783 +
38.2784 + val nonredundant_coind_wit_argsss =
38.2785 + fold (fn i => fn argsss =>
38.2786 + nth_map (i - 1) (filter_out (fn xs =>
38.2787 + exists (fn ys =>
38.2788 + let
38.2789 + val xs' = (map (fst o fst) xs, snd (fst (hd xs)));
38.2790 + val ys' = (map (fst o fst) ys, snd (fst (hd ys)));
38.2791 + in
38.2792 + eq_pair (subset (op =)) (eq_set (op =)) (xs', ys') andalso not (fst xs' = fst ys')
38.2793 + end)
38.2794 + (flat argsss)))
38.2795 + argsss)
38.2796 + ks coind_wit_argsss;
38.2797 +
38.2798 + fun prepare_args args =
38.2799 + let
38.2800 + val I = snd (fst (hd args));
38.2801 + val (dummys, args') =
38.2802 + map_split (fn i =>
38.2803 + (case find_first (fn arg => fst (fst arg) = i - 1) args of
38.2804 + SOME (_, ((_, wit), thms)) => (NONE, (Lazy.force wit, thms))
38.2805 + | NONE =>
38.2806 + (SOME (i - 1), (mk_dummy_wit (nth Dss (i - 1)) (nth bnfs (i - 1)) I, []))))
38.2807 + ks;
38.2808 + in
38.2809 + ((I, dummys), apsnd flat (split_list args'))
38.2810 + end;
38.2811 +
38.2812 + fun mk_coind_wits ((I, dummys), (args, thms)) =
38.2813 + ((I, dummys), (map (fn i => mk_unfold Ts args i $ HOLogic.unit) ks, thms));
38.2814 +
38.2815 + val coind_witss =
38.2816 + maps (map (mk_coind_wits o prepare_args)) nonredundant_coind_wit_argsss;
38.2817 +
38.2818 + fun mk_coind_wit_thms ((I, dummys), (wits, wit_thms)) =
38.2819 + let
38.2820 + fun mk_goal sets y y_copy y'_copy j =
38.2821 + let
38.2822 + fun mk_conjunct set z dummy wit =
38.2823 + mk_Ball (set $ z) (Term.absfree y'_copy
38.2824 + (if dummy = NONE orelse member (op =) I (j - 1) then
38.2825 + HOLogic.mk_imp (HOLogic.mk_eq (z, wit),
38.2826 + if member (op =) I (j - 1) then HOLogic.mk_eq (y_copy, y)
38.2827 + else @{term False})
38.2828 + else @{term True}));
38.2829 + in
38.2830 + fold_rev Logic.all (map (nth ys) I @ Jzs) (HOLogic.mk_Trueprop
38.2831 + (Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct sets Jzs dummys wits)))
38.2832 + end;
38.2833 + val goals = map5 mk_goal setss_by_range ys ys_copy ys'_copy ls;
38.2834 + in
38.2835 + map2 (fn goal => fn induct =>
38.2836 + Skip_Proof.prove lthy [] [] goal
38.2837 + (mk_coind_wit_tac induct dtor_unfold_thms (flat set_natural'ss) wit_thms)
38.2838 + |> Thm.close_derivation)
38.2839 + goals hset_induct_thms
38.2840 + |> map split_conj_thm
38.2841 + |> transpose
38.2842 + |> map (map_filter (try (fn thm => thm RS bspec RS mp)))
38.2843 + |> curry op ~~ (map_index Library.I (map (close_wit I) wits))
38.2844 + |> filter (fn (_, thms) => length thms = m)
38.2845 + end;
38.2846 +
38.2847 + val coind_wit_thms = maps mk_coind_wit_thms coind_witss;
38.2848 +
38.2849 + val witss = map2 (fn Ds => fn bnf => mk_wits_of_bnf
38.2850 + (replicate (nwits_of_bnf bnf) Ds)
38.2851 + (replicate (nwits_of_bnf bnf) (passiveAs @ Ts)) bnf) Dss bnfs;
38.2852 +
38.2853 + val ctor_witss =
38.2854 + map (map (uncurry close_wit o tree_to_ctor_wit ys ctors witss o snd o snd) o
38.2855 + filter_out (fst o snd)) wit_treess;
38.2856 +
38.2857 + val all_witss =
38.2858 + fold (fn ((i, wit), thms) => fn witss =>
38.2859 + nth_map i (fn (thms', wits) => (thms @ thms', wit :: wits)) witss)
38.2860 + coind_wit_thms (map (pair []) ctor_witss)
38.2861 + |> map (apsnd (map snd o minimize_wits));
38.2862 +
38.2863 + val wit_tac = mk_wit_tac n dtor_ctor_thms (flat set_simp_thmss) (maps wit_thms_of_bnf bnfs);
38.2864 +
38.2865 + val policy = user_policy Derive_All_Facts_Note_Most;
38.2866 +
38.2867 + val (Jbnfs, lthy) =
38.2868 + fold_map6 (fn tacs => fn b => fn mapx => fn sets => fn T => fn (thms, wits) => fn lthy =>
38.2869 + bnf_def Dont_Inline policy I tacs (wit_tac thms) (SOME deads)
38.2870 + (((((b, fold_rev Term.absfree fs' mapx), sets), absdummy T bd), wits), NONE) lthy
38.2871 + |> register_bnf (Local_Theory.full_name lthy b))
38.2872 + tacss bs fs_maps setss_by_bnf Ts all_witss lthy;
38.2873 +
38.2874 + val fold_maps = fold_thms lthy (map (fn bnf =>
38.2875 + mk_unabs_def m (map_def_of_bnf bnf RS @{thm meta_eq_to_obj_eq})) Jbnfs);
38.2876 +
38.2877 + val fold_sets = fold_thms lthy (maps (fn bnf =>
38.2878 + map (fn thm => thm RS @{thm meta_eq_to_obj_eq}) (set_defs_of_bnf bnf)) Jbnfs);
38.2879 +
38.2880 + val timer = time (timer "registered new codatatypes as BNFs");
38.2881 +
38.2882 + val set_incl_thmss = map (map fold_sets) hset_dtor_incl_thmss;
38.2883 + val set_set_incl_thmsss = map (map (map fold_sets)) hset_hset_dtor_incl_thmsss;
38.2884 + val set_induct_thms = map fold_sets hset_induct_thms;
38.2885 +
38.2886 + val srels = map2 (fn Ds => mk_srel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
38.2887 + val Jsrels = map (mk_srel_of_bnf deads passiveAs passiveBs) Jbnfs;
38.2888 + val rels = map2 (fn Ds => mk_rel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
38.2889 + val Jrels = map (mk_rel_of_bnf deads passiveAs passiveBs) Jbnfs;
38.2890 +
38.2891 + val JrelRs = map (fn Jsrel => Term.list_comb (Jsrel, JRs)) Jsrels;
38.2892 + val relRs = map (fn srel => Term.list_comb (srel, JRs @ JrelRs)) srels;
38.2893 + val Jpredphis = map (fn Jsrel => Term.list_comb (Jsrel, Jphis)) Jrels;
38.2894 + val predphis = map (fn srel => Term.list_comb (srel, Jphis @ Jpredphis)) rels;
38.2895 +
38.2896 + val in_srels = map in_srel_of_bnf bnfs;
38.2897 + val in_Jsrels = map in_srel_of_bnf Jbnfs;
38.2898 + val Jsrel_defs = map srel_def_of_bnf Jbnfs;
38.2899 + val Jrel_defs = map rel_def_of_bnf Jbnfs;
38.2900 +
38.2901 + val folded_map_simp_thms = map fold_maps map_simp_thms;
38.2902 + val folded_set_simp_thmss = map (map fold_sets) set_simp_thmss;
38.2903 + val folded_set_simp_thmss' = transpose folded_set_simp_thmss;
38.2904 +
38.2905 + val Jsrel_simp_thms =
38.2906 + let
38.2907 + fun mk_goal Jz Jz' dtor dtor' JrelR relR = fold_rev Logic.all (Jz :: Jz' :: JRs)
38.2908 + (mk_Trueprop_eq (HOLogic.mk_mem (HOLogic.mk_prod (Jz, Jz'), JrelR),
38.2909 + HOLogic.mk_mem (HOLogic.mk_prod (dtor $ Jz, dtor' $ Jz'), relR)));
38.2910 + val goals = map6 mk_goal Jzs Jz's dtors dtor's JrelRs relRs;
38.2911 + in
38.2912 + map12 (fn i => fn goal => fn in_srel => fn map_comp => fn map_cong =>
38.2913 + fn map_simp => fn set_simps => fn dtor_inject => fn dtor_ctor =>
38.2914 + fn set_naturals => fn set_incls => fn set_set_inclss =>
38.2915 + Skip_Proof.prove lthy [] [] goal
38.2916 + (K (mk_srel_simp_tac in_Jsrels i in_srel map_comp map_cong map_simp set_simps
38.2917 + dtor_inject dtor_ctor set_naturals set_incls set_set_inclss))
38.2918 + |> Thm.close_derivation)
38.2919 + ks goals in_srels map_comp's map_congs folded_map_simp_thms folded_set_simp_thmss'
38.2920 + dtor_inject_thms dtor_ctor_thms set_natural'ss set_incl_thmss set_set_incl_thmsss
38.2921 + end;
38.2922 +
38.2923 + val Jrel_simp_thms =
38.2924 + let
38.2925 + fun mk_goal Jz Jz' dtor dtor' Jpredphi predphi = fold_rev Logic.all (Jz :: Jz' :: Jphis)
38.2926 + (mk_Trueprop_eq (Jpredphi $ Jz $ Jz', predphi $ (dtor $ Jz) $ (dtor' $ Jz')));
38.2927 + val goals = map6 mk_goal Jzs Jz's dtors dtor's Jpredphis predphis;
38.2928 + in
38.2929 + map3 (fn goal => fn srel_def => fn Jsrel_simp =>
38.2930 + Skip_Proof.prove lthy [] [] goal
38.2931 + (mk_rel_simp_tac srel_def Jrel_defs Jsrel_defs Jsrel_simp)
38.2932 + |> Thm.close_derivation)
38.2933 + goals srel_defs Jsrel_simp_thms
38.2934 + end;
38.2935 +
38.2936 + val timer = time (timer "additional properties");
38.2937 +
38.2938 + val ls' = if m = 1 then [0] else ls;
38.2939 +
38.2940 + val Jbnf_common_notes =
38.2941 + [(map_uniqueN, [fold_maps map_unique_thm])] @
38.2942 + map2 (fn i => fn thm => (mk_set_inductN i, [thm])) ls' set_induct_thms
38.2943 + |> map (fn (thmN, thms) =>
38.2944 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
38.2945 +
38.2946 + val Jbnf_notes =
38.2947 + [(map_simpsN, map single folded_map_simp_thms),
38.2948 + (rel_simpN, map single Jrel_simp_thms),
38.2949 + (set_inclN, set_incl_thmss),
38.2950 + (set_set_inclN, map flat set_set_incl_thmsss),
38.2951 + (srel_simpN, map single Jsrel_simp_thms)] @
38.2952 + map2 (fn i => fn thms => (mk_set_simpsN i, map single thms)) ls' folded_set_simp_thmss
38.2953 + |> maps (fn (thmN, thmss) =>
38.2954 + map2 (fn b => fn thms =>
38.2955 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
38.2956 + bs thmss)
38.2957 + in
38.2958 + timer; lthy |> Local_Theory.notes (Jbnf_common_notes @ Jbnf_notes) |> snd
38.2959 + end;
38.2960 +
38.2961 + val common_notes =
38.2962 + [(dtor_coinductN, [dtor_coinduct_thm]),
38.2963 + (dtor_strong_coinductN, [dtor_strong_coinduct_thm]),
38.2964 + (rel_coinductN, [rel_coinduct_thm]),
38.2965 + (rel_strong_coinductN, [rel_strong_coinduct_thm]),
38.2966 + (srel_coinductN, [srel_coinduct_thm]),
38.2967 + (srel_strong_coinductN, [srel_strong_coinduct_thm])]
38.2968 + |> map (fn (thmN, thms) =>
38.2969 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
38.2970 +
38.2971 + val notes =
38.2972 + [(ctor_dtorN, ctor_dtor_thms),
38.2973 + (ctor_dtor_unfoldsN, ctor_dtor_unfold_thms),
38.2974 + (ctor_dtor_corecsN, ctor_dtor_corec_thms),
38.2975 + (ctor_exhaustN, ctor_exhaust_thms),
38.2976 + (ctor_injectN, ctor_inject_thms),
38.2977 + (dtor_corecsN, dtor_corec_thms),
38.2978 + (dtor_ctorN, dtor_ctor_thms),
38.2979 + (dtor_exhaustN, dtor_exhaust_thms),
38.2980 + (dtor_injectN, dtor_inject_thms),
38.2981 + (dtor_unfold_uniqueN, dtor_unfold_unique_thms),
38.2982 + (dtor_unfoldsN, dtor_unfold_thms)]
38.2983 + |> map (apsnd (map single))
38.2984 + |> maps (fn (thmN, thmss) =>
38.2985 + map2 (fn b => fn thms =>
38.2986 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
38.2987 + bs thmss)
38.2988 + in
38.2989 + ((dtors, ctors, unfolds, corecs, dtor_coinduct_thm, dtor_ctor_thms, ctor_dtor_thms,
38.2990 + ctor_inject_thms, ctor_dtor_unfold_thms, ctor_dtor_corec_thms),
38.2991 + lthy |> Local_Theory.notes (common_notes @ notes) |> snd)
38.2992 + end;
38.2993 +
38.2994 +val _ =
38.2995 + Outer_Syntax.local_theory @{command_spec "codata_raw"}
38.2996 + "define BNF-based coinductive datatypes (low-level)"
38.2997 + (Parse.and_list1
38.2998 + ((Parse.binding --| @{keyword ":"}) -- (Parse.typ --| @{keyword "="} -- Parse.typ)) >>
38.2999 + (snd oo fp_bnf_cmd bnf_gfp o apsnd split_list o split_list));
38.3000 +
38.3001 +val _ =
38.3002 + Outer_Syntax.local_theory @{command_spec "codata"} "define BNF-based coinductive datatypes"
38.3003 + (parse_datatype_cmd false bnf_gfp);
38.3004 +
38.3005 +end;
39.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
39.2 +++ b/src/HOL/BNF/Tools/bnf_gfp_tactics.ML Fri Sep 21 16:45:06 2012 +0200
39.3 @@ -0,0 +1,1554 @@
39.4 +(* Title: HOL/BNF/Tools/bnf_gfp_tactics.ML
39.5 + Author: Dmitriy Traytel, TU Muenchen
39.6 + Author: Andrei Popescu, TU Muenchen
39.7 + Author: Jasmin Blanchette, TU Muenchen
39.8 + Copyright 2012
39.9 +
39.10 +Tactics for the codatatype construction.
39.11 +*)
39.12 +
39.13 +signature BNF_GFP_TACTICS =
39.14 +sig
39.15 + val mk_Lev_sbd_tac: cterm option list -> thm list -> thm list -> thm list list -> tactic
39.16 + val mk_bd_card_order_tac: thm -> tactic
39.17 + val mk_bd_cinfinite_tac: thm -> tactic
39.18 + val mk_bis_Gr_tac: thm -> thm list -> thm list -> thm list -> thm list ->
39.19 + {prems: 'a, context: Proof.context} -> tactic
39.20 + val mk_bis_O_tac: int -> thm -> thm list -> thm list -> tactic
39.21 + val mk_bis_Union_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
39.22 + val mk_bis_converse_tac: int -> thm -> thm list -> thm list -> tactic
39.23 + val mk_bis_srel_tac: int -> thm -> thm list -> thm list -> thm list -> thm list list -> tactic
39.24 + val mk_carT_set_tac: int -> int -> thm -> thm -> thm -> thm ->
39.25 + {prems: 'a, context: Proof.context} -> tactic
39.26 + val mk_card_of_carT_tac: int -> thm list -> thm -> thm -> thm -> thm -> thm -> thm list -> tactic
39.27 + val mk_coalgT_tac: int -> thm list -> thm list -> thm list list ->
39.28 + {prems: 'a, context: Proof.context} -> tactic
39.29 + val mk_coalg_final_tac: int -> thm -> thm list -> thm list -> thm list list -> thm list list ->
39.30 + tactic
39.31 + val mk_coalg_set_tac: thm -> tactic
39.32 + val mk_coalg_thePull_tac: int -> thm -> thm list -> thm list list -> (int -> tactic) list ->
39.33 + {prems: 'a, context: Proof.context} -> tactic
39.34 + val mk_coind_wit_tac: thm -> thm list -> thm list -> thm list ->
39.35 + {prems: 'a, context: Proof.context} -> tactic
39.36 + val mk_col_bd_tac: int -> int -> cterm option list -> thm list -> thm list -> thm -> thm ->
39.37 + thm list list -> tactic
39.38 + val mk_col_natural_tac: cterm option list -> thm list -> thm list -> thm list -> thm list list ->
39.39 + {prems: 'a, context: Proof.context} -> tactic
39.40 + val mk_congruent_str_final_tac: int -> thm -> thm -> thm -> thm list -> tactic
39.41 + val mk_corec_tac: int -> thm list -> thm -> thm -> thm list ->
39.42 + {prems: 'a, context: Proof.context} -> tactic
39.43 + val mk_dtor_coinduct_tac: int -> int list -> thm -> thm -> tactic
39.44 + val mk_dtor_strong_coinduct_tac: int list -> ctyp option list -> cterm option list -> thm ->
39.45 + thm -> thm -> tactic
39.46 + val mk_dtor_o_ctor_tac: thm -> thm -> thm -> thm -> thm list ->
39.47 + {prems: 'a, context: Proof.context} -> tactic
39.48 + val mk_equiv_lsbis_tac: thm -> thm -> thm -> thm -> thm -> thm -> tactic
39.49 + val mk_hset_minimal_tac: int -> thm list -> thm -> {prems: 'a, context: Proof.context} -> tactic
39.50 + val mk_hset_rec_minimal_tac: int -> cterm option list -> thm list -> thm list ->
39.51 + {prems: 'a, context: Proof.context} -> tactic
39.52 + val mk_in_bd_tac: thm -> thm list -> thm -> thm -> thm -> thm -> thm list -> thm -> thm -> thm ->
39.53 + thm -> thm -> thm -> tactic
39.54 + val mk_incl_lsbis_tac: int -> int -> thm -> tactic
39.55 + val mk_isNode_hset_tac: int -> thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
39.56 + val mk_length_Lev'_tac: thm -> tactic
39.57 + val mk_length_Lev_tac: cterm option list -> thm list -> thm list -> tactic
39.58 + val mk_map_comp_tac: int -> int -> thm list -> thm list -> thm list -> thm -> tactic
39.59 + val mk_mcong_tac: int -> (int -> tactic) -> thm list -> thm list -> thm list -> thm list list ->
39.60 + thm list list -> thm list list list -> tactic
39.61 + val mk_map_id_tac: thm list -> thm -> thm -> tactic
39.62 + val mk_map_tac: int -> int -> ctyp option -> thm -> thm -> thm -> tactic
39.63 + val mk_map_unique_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
39.64 + val mk_mor_Abs_tac: thm list -> thm list -> {prems: 'a, context: Proof.context} -> tactic
39.65 + val mk_mor_Rep_tac: int -> thm list -> thm list -> thm list -> thm list list -> thm list ->
39.66 + thm list -> {prems: 'a, context: Proof.context} -> tactic
39.67 + val mk_mor_T_final_tac: thm -> thm list -> thm list -> tactic
39.68 + val mk_mor_UNIV_tac: thm list -> thm -> tactic
39.69 + val mk_mor_beh_tac: int -> thm -> thm -> thm list -> thm list -> thm list -> thm list ->
39.70 + thm list list -> thm list list -> thm list -> thm list -> thm list -> thm list -> thm list ->
39.71 + thm list -> thm list -> thm list -> thm list list -> thm list list list -> thm list list list ->
39.72 + thm list list list -> thm list list -> thm list list -> thm list -> thm list -> thm list ->
39.73 + {prems: 'a, context: Proof.context} -> tactic
39.74 + val mk_mor_comp_tac: thm -> thm list -> thm list -> thm list -> tactic
39.75 + val mk_mor_elim_tac: thm -> tactic
39.76 + val mk_mor_hset_rec_tac: int -> int -> cterm option list -> int -> thm list -> thm list ->
39.77 + thm list -> thm list list -> thm list list -> tactic
39.78 + val mk_mor_hset_tac: thm -> thm -> tactic
39.79 + val mk_mor_incl_tac: thm -> thm list -> tactic
39.80 + val mk_mor_str_tac: 'a list -> thm -> tactic
39.81 + val mk_mor_sum_case_tac: 'a list -> thm -> tactic
39.82 + val mk_mor_thePull_fst_tac: int -> thm -> thm list -> thm list -> (int -> tactic) list ->
39.83 + {prems: thm list, context: Proof.context} -> tactic
39.84 + val mk_mor_thePull_snd_tac: int -> thm -> thm list -> thm list -> (int -> tactic) list ->
39.85 + {prems: thm list, context: Proof.context} -> tactic
39.86 + val mk_mor_thePull_pick_tac: thm -> thm list -> thm list ->
39.87 + {prems: 'a, context: Proof.context} -> tactic
39.88 + val mk_mor_unfold_tac: int -> thm -> thm list -> thm list -> thm list -> thm list -> thm list ->
39.89 + thm list -> tactic
39.90 + val mk_prefCl_Lev_tac: cterm option list -> thm list -> thm list -> tactic
39.91 + val mk_pickWP_assms_tac: thm list -> thm list -> thm -> (int -> tactic)
39.92 + val mk_pick_col_tac: int -> int -> cterm option list -> thm list -> thm list -> thm list ->
39.93 + thm list list -> thm list -> (int -> tactic) list -> {prems: 'a, context: Proof.context} ->
39.94 + tactic
39.95 + val mk_raw_coind_tac: thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm list ->
39.96 + thm list -> thm list -> thm -> thm list -> tactic
39.97 + val mk_rv_last_tac: ctyp option list -> cterm option list -> thm list -> thm list -> tactic
39.98 + val mk_sbis_lsbis_tac: thm list -> thm -> thm -> tactic
39.99 + val mk_set_Lev_tac: cterm option list -> thm list -> thm list -> thm list -> thm list ->
39.100 + thm list list -> tactic
39.101 + val mk_set_bd_tac: thm -> thm -> thm -> tactic
39.102 + val mk_set_hset_incl_hset_tac: int -> thm list -> thm -> int -> tactic
39.103 + val mk_set_image_Lev_tac: cterm option list -> thm list -> thm list -> thm list -> thm list ->
39.104 + thm list list -> thm list list -> tactic
39.105 + val mk_set_incl_hin_tac: thm list -> tactic
39.106 + val mk_set_incl_hset_tac: thm -> thm -> tactic
39.107 + val mk_set_le_tac: int -> thm -> thm list -> thm list list -> tactic
39.108 + val mk_set_natural_tac: thm -> thm -> tactic
39.109 + val mk_set_rv_Lev_tac: int -> cterm option list -> thm list -> thm list -> thm list -> thm list ->
39.110 + thm list list -> thm list list -> tactic
39.111 + val mk_set_simp_tac: int -> thm -> thm -> thm list -> tactic
39.112 + val mk_srel_coinduct_tac: 'a list -> thm -> thm -> tactic
39.113 + val mk_srel_strong_coinduct_tac: int -> ctyp option list -> cterm option list -> thm ->
39.114 + thm list -> thm list -> tactic
39.115 + val mk_srel_simp_tac: thm list -> int -> thm -> thm -> thm -> thm -> thm list -> thm -> thm ->
39.116 + thm list -> thm list -> thm list list -> tactic
39.117 + val mk_strT_hset_tac: int -> int -> int -> ctyp option list -> ctyp option list ->
39.118 + cterm option list -> thm list -> thm list -> thm list -> thm list -> thm list list ->
39.119 + thm list list -> thm list list -> thm -> thm list list -> tactic
39.120 + val mk_unfold_unique_mor_tac: thm list -> thm -> thm -> thm list -> tactic
39.121 + val mk_unique_mor_tac: thm list -> thm -> tactic
39.122 + val mk_wit_tac: int -> thm list -> thm list -> thm list -> thm list ->
39.123 + {prems: 'a, context: Proof.context} -> tactic
39.124 + val mk_wpull_tac: int -> thm -> thm -> thm -> thm -> thm -> thm list -> thm list -> tactic
39.125 +end;
39.126 +
39.127 +structure BNF_GFP_Tactics : BNF_GFP_TACTICS =
39.128 +struct
39.129 +
39.130 +open BNF_Tactics
39.131 +open BNF_Util
39.132 +open BNF_FP
39.133 +open BNF_GFP_Util
39.134 +
39.135 +val fst_convol_fun_cong_sym = @{thm fst_convol} RS fun_cong RS sym;
39.136 +val list_inject_iffD1 = @{thm list.inject[THEN iffD1]};
39.137 +val nat_induct = @{thm nat_induct};
39.138 +val o_apply_trans_sym = o_apply RS trans RS sym;
39.139 +val ord_eq_le_trans = @{thm ord_eq_le_trans};
39.140 +val ord_eq_le_trans_trans_fun_cong_image_id_id_apply =
39.141 + @{thm ord_eq_le_trans[OF trans[OF fun_cong[OF image_id] id_apply]]};
39.142 +val ordIso_ordLeq_trans = @{thm ordIso_ordLeq_trans};
39.143 +val snd_convol_fun_cong_sym = @{thm snd_convol} RS fun_cong RS sym;
39.144 +val sum_case_weak_cong = @{thm sum_case_weak_cong};
39.145 +val trans_fun_cong_image_id_id_apply = @{thm trans[OF fun_cong[OF image_id] id_apply]};
39.146 +
39.147 +fun mk_coalg_set_tac coalg_def =
39.148 + dtac (coalg_def RS iffD1) 1 THEN
39.149 + REPEAT_DETERM (etac conjE 1) THEN
39.150 + EVERY' [dtac @{thm rev_bspec}, atac] 1 THEN
39.151 + REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN atac 1;
39.152 +
39.153 +fun mk_mor_elim_tac mor_def =
39.154 + (dtac (subst OF [mor_def]) THEN'
39.155 + REPEAT o etac conjE THEN'
39.156 + TRY o rtac @{thm image_subsetI} THEN'
39.157 + etac bspec THEN'
39.158 + atac) 1;
39.159 +
39.160 +fun mk_mor_incl_tac mor_def map_id's =
39.161 + (stac mor_def THEN'
39.162 + rtac conjI THEN'
39.163 + CONJ_WRAP' (K (EVERY' [rtac ballI, etac set_mp, stac @{thm id_apply}, atac]))
39.164 + map_id's THEN'
39.165 + CONJ_WRAP' (fn thm =>
39.166 + (EVERY' [rtac ballI, rtac (thm RS trans), rtac sym, rtac (@{thm id_apply} RS arg_cong)]))
39.167 + map_id's) 1;
39.168 +
39.169 +fun mk_mor_comp_tac mor_def mor_images morEs map_comp_ids =
39.170 + let
39.171 + fun fbetw_tac image = EVERY' [rtac ballI, stac o_apply, etac image, etac image, atac];
39.172 + fun mor_tac ((mor_image, morE), map_comp_id) =
39.173 + EVERY' [rtac ballI, stac o_apply, rtac trans, rtac (map_comp_id RS sym), rtac trans,
39.174 + etac (morE RS arg_cong), atac, etac morE, etac mor_image, atac];
39.175 + in
39.176 + (stac mor_def THEN' rtac conjI THEN'
39.177 + CONJ_WRAP' fbetw_tac mor_images THEN'
39.178 + CONJ_WRAP' mor_tac ((mor_images ~~ morEs) ~~ map_comp_ids)) 1
39.179 + end;
39.180 +
39.181 +fun mk_mor_UNIV_tac morEs mor_def =
39.182 + let
39.183 + val n = length morEs;
39.184 + fun mor_tac morE = EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, etac morE,
39.185 + rtac UNIV_I, rtac sym, rtac o_apply];
39.186 + in
39.187 + EVERY' [rtac iffI, CONJ_WRAP' mor_tac morEs,
39.188 + stac mor_def, rtac conjI, CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) morEs,
39.189 + CONJ_WRAP' (fn i =>
39.190 + EVERY' [dtac (mk_conjunctN n i), rtac ballI, etac @{thm pointfreeE}]) (1 upto n)] 1
39.191 + end;
39.192 +
39.193 +fun mk_mor_str_tac ks mor_UNIV =
39.194 + (stac mor_UNIV THEN' CONJ_WRAP' (K (rtac refl)) ks) 1;
39.195 +
39.196 +fun mk_mor_sum_case_tac ks mor_UNIV =
39.197 + (stac mor_UNIV THEN' CONJ_WRAP' (K (rtac @{thm sum_case_comp_Inl[symmetric]})) ks) 1;
39.198 +
39.199 +fun mk_set_incl_hset_tac def rec_Suc =
39.200 + EVERY' (stac def ::
39.201 + map rtac [@{thm incl_UNION_I}, UNIV_I, @{thm ord_le_eq_trans}, @{thm Un_upper1},
39.202 + sym, rec_Suc]) 1;
39.203 +
39.204 +fun mk_set_hset_incl_hset_tac n defs rec_Suc i =
39.205 + EVERY' (map (TRY oo stac) defs @
39.206 + map rtac [@{thm UN_least}, subsetI, @{thm UN_I}, UNIV_I, set_mp, equalityD2, rec_Suc, UnI2,
39.207 + mk_UnIN n i] @
39.208 + [etac @{thm UN_I}, atac]) 1;
39.209 +
39.210 +fun mk_set_incl_hin_tac incls =
39.211 + if null incls then rtac subset_UNIV 1
39.212 + else EVERY' [rtac subsetI, rtac CollectI,
39.213 + CONJ_WRAP' (fn incl => EVERY' [rtac subset_trans, etac incl, atac]) incls] 1;
39.214 +
39.215 +fun mk_hset_rec_minimal_tac m cts rec_0s rec_Sucs {context = ctxt, prems = _} =
39.216 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.217 + REPEAT_DETERM o rtac allI,
39.218 + CONJ_WRAP' (fn thm => EVERY'
39.219 + [rtac ord_eq_le_trans, rtac thm, rtac @{thm empty_subsetI}]) rec_0s,
39.220 + REPEAT_DETERM o rtac allI,
39.221 + CONJ_WRAP' (fn rec_Suc => EVERY'
39.222 + [rtac ord_eq_le_trans, rtac rec_Suc,
39.223 + if m = 0 then K all_tac
39.224 + else (rtac @{thm Un_least} THEN' Goal.assume_rule_tac ctxt),
39.225 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
39.226 + (K (EVERY' [rtac @{thm UN_least}, REPEAT_DETERM o eresolve_tac [allE, conjE],
39.227 + rtac subset_trans, atac, Goal.assume_rule_tac ctxt])) rec_0s])
39.228 + rec_Sucs] 1;
39.229 +
39.230 +fun mk_hset_minimal_tac n hset_defs hset_rec_minimal {context = ctxt, prems = _} =
39.231 + (CONJ_WRAP' (fn def => (EVERY' [rtac ord_eq_le_trans, rtac def,
39.232 + rtac @{thm UN_least}, rtac rev_mp, rtac hset_rec_minimal,
39.233 + EVERY' (replicate ((n + 1) * n) (Goal.assume_rule_tac ctxt)), rtac impI,
39.234 + REPEAT_DETERM o eresolve_tac [allE, conjE], atac])) hset_defs) 1
39.235 +
39.236 +fun mk_mor_hset_rec_tac m n cts j rec_0s rec_Sucs morEs set_naturalss coalg_setss =
39.237 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.238 + REPEAT_DETERM o rtac allI,
39.239 + CONJ_WRAP' (fn thm => EVERY' (map rtac [impI, thm RS trans, thm RS sym])) rec_0s,
39.240 + REPEAT_DETERM o rtac allI,
39.241 + CONJ_WRAP'
39.242 + (fn (rec_Suc, (morE, ((passive_set_naturals, active_set_naturals), coalg_sets))) =>
39.243 + EVERY' [rtac impI, rtac (rec_Suc RS trans), rtac (rec_Suc RS trans RS sym),
39.244 + if m = 0 then K all_tac
39.245 + else EVERY' [rtac @{thm Un_cong}, rtac box_equals,
39.246 + rtac (nth passive_set_naturals (j - 1) RS sym),
39.247 + rtac trans_fun_cong_image_id_id_apply, etac (morE RS arg_cong), atac],
39.248 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_cong}))
39.249 + (fn (i, (set_natural, coalg_set)) =>
39.250 + EVERY' [rtac sym, rtac trans, rtac (refl RSN (2, @{thm UN_cong})),
39.251 + etac (morE RS sym RS arg_cong RS trans), atac, rtac set_natural,
39.252 + rtac (@{thm UN_simps(10)} RS trans), rtac (refl RS @{thm UN_cong}),
39.253 + ftac coalg_set, atac, dtac set_mp, atac, rtac mp, rtac (mk_conjunctN n i),
39.254 + REPEAT_DETERM o etac allE, atac, atac])
39.255 + (rev ((1 upto n) ~~ (active_set_naturals ~~ coalg_sets)))])
39.256 + (rec_Sucs ~~ (morEs ~~ (map (chop m) set_naturalss ~~ map (drop m) coalg_setss)))] 1;
39.257 +
39.258 +fun mk_mor_hset_tac hset_def mor_hset_rec =
39.259 + EVERY' [rtac (hset_def RS trans), rtac (refl RS @{thm UN_cong} RS trans), etac mor_hset_rec,
39.260 + atac, atac, rtac (hset_def RS sym)] 1
39.261 +
39.262 +fun mk_bis_srel_tac m bis_def srel_O_Grs map_comps map_congs set_naturalss =
39.263 + let
39.264 + val n = length srel_O_Grs;
39.265 + val thms = ((1 upto n) ~~ map_comps ~~ map_congs ~~ set_naturalss ~~ srel_O_Grs);
39.266 +
39.267 + fun mk_if_tac ((((i, map_comp), map_cong), set_naturals), srel_O_Gr) =
39.268 + EVERY' [rtac allI, rtac allI, rtac impI, dtac (mk_conjunctN n i),
39.269 + etac allE, etac allE, etac impE, atac, etac bexE, etac conjE,
39.270 + rtac (srel_O_Gr RS equalityD2 RS set_mp),
39.271 + rtac @{thm relcompI}, rtac @{thm converseI},
39.272 + EVERY' (map (fn thm =>
39.273 + EVERY' [rtac @{thm GrI}, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
39.274 + rtac CollectI,
39.275 + CONJ_WRAP' (fn (i, thm) =>
39.276 + if i <= m
39.277 + then EVERY' [rtac ord_eq_le_trans, rtac thm, rtac subset_trans,
39.278 + etac @{thm image_mono}, rtac @{thm image_subsetI}, etac @{thm diagI}]
39.279 + else EVERY' [rtac ord_eq_le_trans, rtac trans, rtac thm,
39.280 + rtac trans_fun_cong_image_id_id_apply, atac])
39.281 + (1 upto (m + n) ~~ set_naturals),
39.282 + rtac trans, rtac trans, rtac map_comp, rtac map_cong, REPEAT_DETERM_N m o rtac thm,
39.283 + REPEAT_DETERM_N n o rtac (@{thm o_id} RS fun_cong), atac])
39.284 + @{thms fst_diag_id snd_diag_id})];
39.285 +
39.286 + fun mk_only_if_tac ((((i, map_comp), map_cong), set_naturals), srel_O_Gr) =
39.287 + EVERY' [dtac (mk_conjunctN n i), rtac allI, rtac allI, rtac impI,
39.288 + etac allE, etac allE, etac impE, atac,
39.289 + dtac (srel_O_Gr RS equalityD1 RS set_mp),
39.290 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm relcompE}, @{thm converseE}],
39.291 + REPEAT_DETERM o eresolve_tac [@{thm GrE}, exE, conjE],
39.292 + REPEAT_DETERM o dtac Pair_eqD,
39.293 + REPEAT_DETERM o etac conjE,
39.294 + hyp_subst_tac,
39.295 + REPEAT_DETERM o eresolve_tac [CollectE, conjE],
39.296 + rtac bexI, rtac conjI, rtac trans, rtac map_comp,
39.297 + REPEAT_DETERM_N m o stac @{thm id_o},
39.298 + REPEAT_DETERM_N n o stac @{thm o_id},
39.299 + etac sym, rtac trans, rtac map_comp,
39.300 + REPEAT_DETERM_N m o stac @{thm id_o},
39.301 + REPEAT_DETERM_N n o stac @{thm o_id},
39.302 + rtac trans, rtac map_cong,
39.303 + REPEAT_DETERM_N m o EVERY' [rtac @{thm diagE'}, etac set_mp, atac],
39.304 + REPEAT_DETERM_N n o rtac refl,
39.305 + etac sym, rtac CollectI,
39.306 + CONJ_WRAP' (fn (i, thm) =>
39.307 + if i <= m
39.308 + then EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
39.309 + rtac @{thm diag_fst}, etac set_mp, atac]
39.310 + else EVERY' [rtac ord_eq_le_trans, rtac trans, rtac thm,
39.311 + rtac trans_fun_cong_image_id_id_apply, atac])
39.312 + (1 upto (m + n) ~~ set_naturals)];
39.313 + in
39.314 + EVERY' [rtac (bis_def RS trans),
39.315 + rtac iffI, etac conjE, etac conjI, CONJ_WRAP' mk_if_tac thms,
39.316 + etac conjE, etac conjI, CONJ_WRAP' mk_only_if_tac thms] 1
39.317 + end;
39.318 +
39.319 +fun mk_bis_converse_tac m bis_srel srel_congs srel_converses =
39.320 + EVERY' [stac bis_srel, dtac (bis_srel RS iffD1),
39.321 + REPEAT_DETERM o etac conjE, rtac conjI,
39.322 + CONJ_WRAP' (K (EVERY' [rtac @{thm converse_shift}, etac subset_trans,
39.323 + rtac equalityD2, rtac @{thm converse_Times}])) srel_congs,
39.324 + CONJ_WRAP' (fn (srel_cong, srel_converse) =>
39.325 + EVERY' [rtac allI, rtac allI, rtac impI, rtac @{thm set_mp[OF equalityD2]},
39.326 + rtac (srel_cong RS trans),
39.327 + REPEAT_DETERM_N m o rtac @{thm diag_converse},
39.328 + REPEAT_DETERM_N (length srel_congs) o rtac refl,
39.329 + rtac srel_converse,
39.330 + REPEAT_DETERM o etac allE,
39.331 + rtac @{thm converseI}, etac mp, etac @{thm converseD}]) (srel_congs ~~ srel_converses)] 1;
39.332 +
39.333 +fun mk_bis_O_tac m bis_srel srel_congs srel_Os =
39.334 + EVERY' [stac bis_srel, REPEAT_DETERM o dtac (bis_srel RS iffD1),
39.335 + REPEAT_DETERM o etac conjE, rtac conjI,
39.336 + CONJ_WRAP' (K (EVERY' [etac @{thm relcomp_subset_Sigma}, atac])) srel_congs,
39.337 + CONJ_WRAP' (fn (srel_cong, srel_O) =>
39.338 + EVERY' [rtac allI, rtac allI, rtac impI, rtac @{thm set_mp[OF equalityD2]},
39.339 + rtac (srel_cong RS trans),
39.340 + REPEAT_DETERM_N m o rtac @{thm diag_Comp},
39.341 + REPEAT_DETERM_N (length srel_congs) o rtac refl,
39.342 + rtac srel_O,
39.343 + etac @{thm relcompE},
39.344 + REPEAT_DETERM o dtac Pair_eqD,
39.345 + etac conjE, hyp_subst_tac,
39.346 + REPEAT_DETERM o etac allE, rtac @{thm relcompI},
39.347 + etac mp, atac, etac mp, atac]) (srel_congs ~~ srel_Os)] 1;
39.348 +
39.349 +fun mk_bis_Gr_tac bis_srel srel_Grs mor_images morEs coalg_ins
39.350 + {context = ctxt, prems = _} =
39.351 + unfold_thms_tac ctxt (bis_srel :: @{thm diag_Gr} :: srel_Grs) THEN
39.352 + EVERY' [rtac conjI,
39.353 + CONJ_WRAP' (fn thm => rtac (@{thm Gr_incl} RS ssubst) THEN' etac thm) mor_images,
39.354 + CONJ_WRAP' (fn (coalg_in, morE) =>
39.355 + EVERY' [rtac allI, rtac allI, rtac impI, rtac @{thm GrI}, etac coalg_in,
39.356 + etac @{thm GrD1}, etac (morE RS trans), etac @{thm GrD1},
39.357 + etac (@{thm GrD2} RS arg_cong)]) (coalg_ins ~~ morEs)] 1;
39.358 +
39.359 +fun mk_bis_Union_tac bis_def in_monos {context = ctxt, prems = _} =
39.360 + let
39.361 + val n = length in_monos;
39.362 + val ks = 1 upto n;
39.363 + in
39.364 + unfold_thms_tac ctxt [bis_def] THEN
39.365 + EVERY' [rtac conjI,
39.366 + CONJ_WRAP' (fn i =>
39.367 + EVERY' [rtac @{thm UN_least}, dtac bspec, atac,
39.368 + dtac conjunct1, etac (mk_conjunctN n i)]) ks,
39.369 + CONJ_WRAP' (fn (i, in_mono) =>
39.370 + EVERY' [rtac allI, rtac allI, rtac impI, etac @{thm UN_E}, dtac bspec, atac,
39.371 + dtac conjunct2, dtac (mk_conjunctN n i), etac allE, etac allE, dtac mp,
39.372 + atac, etac bexE, rtac bexI, atac, rtac in_mono,
39.373 + REPEAT_DETERM_N n o etac @{thm incl_UNION_I[OF _ subset_refl]},
39.374 + atac]) (ks ~~ in_monos)] 1
39.375 + end;
39.376 +
39.377 +fun mk_sbis_lsbis_tac lsbis_defs bis_Union bis_cong =
39.378 + let
39.379 + val n = length lsbis_defs;
39.380 + in
39.381 + EVERY' [rtac (Thm.permute_prems 0 1 bis_cong), EVERY' (map rtac lsbis_defs),
39.382 + rtac bis_Union, rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE, exE],
39.383 + hyp_subst_tac, etac bis_cong, EVERY' (map (rtac o mk_nth_conv n) (1 upto n))] 1
39.384 + end;
39.385 +
39.386 +fun mk_incl_lsbis_tac n i lsbis_def =
39.387 + EVERY' [rtac @{thm xt1(3)}, rtac lsbis_def, rtac @{thm incl_UNION_I}, rtac CollectI,
39.388 + REPEAT_DETERM_N n o rtac exI, rtac conjI, rtac refl, atac, rtac equalityD2,
39.389 + rtac (mk_nth_conv n i)] 1;
39.390 +
39.391 +fun mk_equiv_lsbis_tac sbis_lsbis lsbis_incl incl_lsbis bis_diag bis_converse bis_O =
39.392 + EVERY' [rtac (@{thm equiv_def} RS iffD2),
39.393 +
39.394 + rtac conjI, rtac (@{thm refl_on_def} RS iffD2),
39.395 + rtac conjI, rtac lsbis_incl, rtac ballI, rtac set_mp,
39.396 + rtac incl_lsbis, rtac bis_diag, atac, etac @{thm diagI},
39.397 +
39.398 + rtac conjI, rtac (@{thm sym_def} RS iffD2),
39.399 + rtac allI, rtac allI, rtac impI, rtac set_mp,
39.400 + rtac incl_lsbis, rtac bis_converse, rtac sbis_lsbis, etac @{thm converseI},
39.401 +
39.402 + rtac (@{thm trans_def} RS iffD2),
39.403 + rtac allI, rtac allI, rtac allI, rtac impI, rtac impI, rtac set_mp,
39.404 + rtac incl_lsbis, rtac bis_O, rtac sbis_lsbis, rtac sbis_lsbis,
39.405 + etac @{thm relcompI}, atac] 1;
39.406 +
39.407 +fun mk_coalgT_tac m defs strT_defs set_naturalss {context = ctxt, prems = _} =
39.408 + let
39.409 + val n = length strT_defs;
39.410 + val ks = 1 upto n;
39.411 + fun coalg_tac (i, ((passive_sets, active_sets), def)) =
39.412 + EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
39.413 + hyp_subst_tac, rtac (def RS trans RS @{thm ssubst_mem}), etac (arg_cong RS trans),
39.414 + rtac (mk_sum_casesN n i), rtac CollectI,
39.415 + EVERY' (map (fn thm => EVERY' [rtac conjI, rtac (thm RS ord_eq_le_trans),
39.416 + etac ((trans OF [@{thm image_id} RS fun_cong, @{thm id_apply}]) RS ord_eq_le_trans)])
39.417 + passive_sets),
39.418 + CONJ_WRAP' (fn (i, thm) => EVERY' [rtac (thm RS ord_eq_le_trans),
39.419 + rtac @{thm image_subsetI}, rtac CollectI, rtac exI, rtac exI, rtac conjI, rtac refl,
39.420 + rtac conjI,
39.421 + rtac conjI, etac @{thm empty_Shift}, dtac set_rev_mp,
39.422 + etac equalityD1, etac CollectD,
39.423 + rtac conjI, etac @{thm Shift_clists},
39.424 + rtac conjI, etac @{thm Shift_prefCl},
39.425 + rtac conjI, rtac ballI,
39.426 + rtac conjI, dtac @{thm iffD1[OF ball_conj_distrib]}, dtac conjunct1,
39.427 + SELECT_GOAL (unfold_thms_tac ctxt @{thms Succ_Shift shift_def}),
39.428 + etac bspec, etac @{thm ShiftD},
39.429 + CONJ_WRAP' (fn i => EVERY' [rtac ballI, etac CollectE, dtac @{thm ShiftD},
39.430 + dtac bspec, etac thin_rl, atac, dtac conjunct2, dtac (mk_conjunctN n i),
39.431 + dtac bspec, rtac CollectI, etac @{thm set_mp[OF equalityD1[OF Succ_Shift]]},
39.432 + REPEAT_DETERM o eresolve_tac [exE, conjE], rtac exI,
39.433 + rtac conjI, rtac (@{thm shift_def} RS fun_cong RS trans),
39.434 + rtac (@{thm append_Cons} RS sym RS arg_cong RS trans), atac,
39.435 + REPEAT_DETERM_N m o (rtac conjI THEN' atac),
39.436 + CONJ_WRAP' (K (EVERY' [etac trans, rtac @{thm Collect_cong},
39.437 + rtac @{thm eqset_imp_iff}, rtac sym, rtac trans, rtac @{thm Succ_Shift},
39.438 + rtac (@{thm append_Cons} RS sym RS arg_cong)])) ks]) ks,
39.439 + rtac allI, rtac impI, REPEAT_DETERM o eresolve_tac [allE, impE],
39.440 + etac @{thm not_in_Shift}, rtac trans, rtac (@{thm shift_def} RS fun_cong), atac,
39.441 + dtac bspec, atac, dtac conjunct2, dtac (mk_conjunctN n i), dtac bspec,
39.442 + etac @{thm set_mp[OF equalityD1]}, atac,
39.443 + REPEAT_DETERM o eresolve_tac [exE, conjE], rtac exI,
39.444 + rtac conjI, rtac (@{thm shift_def} RS fun_cong RS trans),
39.445 + etac (@{thm append_Nil} RS sym RS arg_cong RS trans),
39.446 + REPEAT_DETERM_N m o (rtac conjI THEN' atac),
39.447 + CONJ_WRAP' (K (EVERY' [etac trans, rtac @{thm Collect_cong},
39.448 + rtac @{thm eqset_imp_iff}, rtac sym, rtac trans, rtac @{thm Succ_Shift},
39.449 + rtac (@{thm append_Nil} RS sym RS arg_cong)])) ks]) (ks ~~ active_sets)];
39.450 + in
39.451 + unfold_thms_tac ctxt defs THEN
39.452 + CONJ_WRAP' coalg_tac (ks ~~ (map (chop m) set_naturalss ~~ strT_defs)) 1
39.453 + end;
39.454 +
39.455 +fun mk_card_of_carT_tac m isNode_defs sbd_sbd
39.456 + sbd_card_order sbd_Card_order sbd_Cinfinite sbd_Cnotzero in_sbds =
39.457 + let
39.458 + val n = length isNode_defs;
39.459 + in
39.460 + EVERY' [rtac (Thm.permute_prems 0 1 ctrans),
39.461 + rtac @{thm card_of_Sigma_ordLeq_Cinfinite}, rtac @{thm Cinfinite_cexp},
39.462 + if m = 0 then rtac @{thm ordLeq_refl} else rtac @{thm ordLeq_csum2},
39.463 + rtac @{thm Card_order_ctwo}, rtac @{thm Cinfinite_cexp},
39.464 + rtac @{thm ctwo_ordLeq_Cinfinite}, rtac sbd_Cinfinite, rtac sbd_Cinfinite,
39.465 + rtac ctrans, rtac @{thm card_of_diff},
39.466 + rtac ordIso_ordLeq_trans, rtac @{thm card_of_Field_ordIso},
39.467 + rtac @{thm Card_order_cpow}, rtac ordIso_ordLeq_trans,
39.468 + rtac @{thm cpow_cexp_ctwo}, rtac ctrans, rtac @{thm cexp_mono1_Cnotzero},
39.469 + if m = 0 then rtac @{thm ordLeq_refl} else rtac @{thm ordLeq_csum2},
39.470 + rtac @{thm Card_order_ctwo}, rtac @{thm ctwo_Cnotzero}, rtac @{thm Card_order_clists},
39.471 + rtac @{thm cexp_mono2_Cnotzero}, rtac ordIso_ordLeq_trans,
39.472 + rtac @{thm clists_Cinfinite},
39.473 + if n = 1 then rtac sbd_Cinfinite else rtac (sbd_Cinfinite RS @{thm Cinfinite_csum1}),
39.474 + rtac ordIso_ordLeq_trans, rtac sbd_sbd, rtac @{thm infinite_ordLeq_cexp},
39.475 + rtac sbd_Cinfinite,
39.476 + if m = 0 then rtac @{thm ctwo_Cnotzero} else rtac @{thm csum_Cnotzero2[OF ctwo_Cnotzero]},
39.477 + rtac @{thm Cnotzero_clists},
39.478 + rtac ballI, rtac ordIso_ordLeq_trans, rtac @{thm card_of_Func_Ffunc},
39.479 + rtac ordIso_ordLeq_trans, rtac @{thm Func_cexp},
39.480 + rtac ctrans, rtac @{thm cexp_mono},
39.481 + rtac @{thm ordLeq_ordIso_trans},
39.482 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1
39.483 + (sbd_Cinfinite RS @{thm Cinfinite_cexp[OF ordLeq_csum2[OF Card_order_ctwo]]}
39.484 + RSN (3, @{thm Un_Cinfinite_bound}))))
39.485 + (fn thm => EVERY' [rtac ctrans, rtac @{thm card_of_image}, rtac thm]) (rev in_sbds),
39.486 + rtac @{thm cexp_cong1_Cnotzero}, rtac @{thm csum_cong1},
39.487 + REPEAT_DETERM_N m o rtac @{thm csum_cong2},
39.488 + CONJ_WRAP_GEN' (rtac @{thm csum_cong})
39.489 + (K (rtac (sbd_Card_order RS @{thm card_of_Field_ordIso}))) in_sbds,
39.490 + rtac sbd_Card_order,
39.491 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
39.492 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
39.493 + rtac @{thm ordLeq_ordIso_trans}, etac @{thm clists_bound},
39.494 + rtac @{thm clists_Cinfinite}, TRY o rtac @{thm Cinfinite_csum1}, rtac sbd_Cinfinite,
39.495 + rtac disjI2, rtac @{thm cone_ordLeq_cexp}, rtac @{thm cone_ordLeq_cexp},
39.496 + rtac ctrans, rtac @{thm cone_ordLeq_ctwo}, rtac @{thm ordLeq_csum2},
39.497 + rtac @{thm Card_order_ctwo}, rtac FalseE, etac @{thm cpow_clists_czero}, atac,
39.498 + rtac @{thm card_of_Card_order},
39.499 + rtac ordIso_ordLeq_trans, rtac @{thm cexp_cprod},
39.500 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
39.501 + rtac ordIso_ordLeq_trans, rtac @{thm cexp_cong2_Cnotzero},
39.502 + rtac @{thm ordIso_transitive}, rtac @{thm cprod_cong2}, rtac sbd_sbd,
39.503 + rtac @{thm cprod_infinite}, rtac sbd_Cinfinite,
39.504 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac @{thm Card_order_cprod},
39.505 + rtac ctrans, rtac @{thm cexp_mono1_Cnotzero},
39.506 + rtac ordIso_ordLeq_trans, rtac @{thm ordIso_transitive}, rtac @{thm csum_cong1},
39.507 + rtac @{thm ordIso_transitive},
39.508 + REPEAT_DETERM_N m o rtac @{thm csum_cong2},
39.509 + rtac sbd_sbd,
39.510 + BNF_Tactics.mk_rotate_eq_tac (rtac @{thm ordIso_refl} THEN'
39.511 + FIRST' [rtac @{thm card_of_Card_order},
39.512 + rtac @{thm Card_order_csum}, rtac sbd_Card_order])
39.513 + @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
39.514 + (1 upto m + 1) (m + 1 :: (1 upto m)),
39.515 + if m = 0 then K all_tac else EVERY' [rtac @{thm ordIso_transitive}, rtac @{thm csum_assoc}],
39.516 + rtac @{thm csum_com}, rtac @{thm csum_cexp'}, rtac sbd_Cinfinite,
39.517 + if m = 0 then rtac @{thm Card_order_ctwo} else rtac @{thm Card_order_csum},
39.518 + if m = 0 then rtac @{thm ordLeq_refl} else rtac @{thm ordLeq_csum2},
39.519 + rtac @{thm Card_order_ctwo},
39.520 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac sbd_Card_order,
39.521 + rtac ordIso_ordLeq_trans, rtac @{thm cexp_cprod_ordLeq},
39.522 + if m = 0 then rtac @{thm ctwo_Cnotzero} else rtac @{thm csum_Cnotzero2[OF ctwo_Cnotzero]},
39.523 + rtac sbd_Cinfinite, rtac sbd_Cnotzero, rtac @{thm ordLeq_refl}, rtac sbd_Card_order,
39.524 + rtac @{thm cexp_mono2_Cnotzero}, rtac @{thm infinite_ordLeq_cexp},
39.525 + rtac sbd_Cinfinite,
39.526 + if m = 0 then rtac @{thm ctwo_Cnotzero} else rtac @{thm csum_Cnotzero2[OF ctwo_Cnotzero]},
39.527 + rtac sbd_Cnotzero,
39.528 + rtac @{thm card_of_mono1}, rtac subsetI,
39.529 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm prod_caseE}], hyp_subst_tac,
39.530 + rtac @{thm SigmaI}, rtac @{thm DiffI}, rtac set_mp, rtac equalityD2,
39.531 + rtac (@{thm cpow_def} RS arg_cong RS trans), rtac (@{thm Pow_def} RS arg_cong RS trans),
39.532 + rtac @{thm Field_card_of}, rtac CollectI, atac, rtac notI, etac @{thm singletonE},
39.533 + hyp_subst_tac, etac @{thm emptyE}, rtac (@{thm Ffunc_def} RS equalityD2 RS set_mp),
39.534 + rtac CollectI, rtac conjI, rtac ballI, dtac bspec, etac thin_rl, atac, dtac conjunct1,
39.535 + CONJ_WRAP_GEN' (etac disjE) (fn (i, def) => EVERY'
39.536 + [rtac (mk_UnIN n i), dtac (def RS iffD1),
39.537 + REPEAT_DETERM o eresolve_tac [exE, conjE], rtac @{thm image_eqI}, atac, rtac CollectI,
39.538 + REPEAT_DETERM_N m o (rtac conjI THEN' atac),
39.539 + CONJ_WRAP' (K (EVERY' [etac ord_eq_le_trans, rtac subset_trans,
39.540 + rtac subset_UNIV, rtac equalityD2, rtac @{thm Field_card_order},
39.541 + rtac sbd_card_order])) isNode_defs]) (1 upto n ~~ isNode_defs),
39.542 + atac] 1
39.543 + end;
39.544 +
39.545 +fun mk_carT_set_tac n i carT_def strT_def isNode_def set_natural {context = ctxt, prems = _}=
39.546 + EVERY' [dtac (carT_def RS equalityD1 RS set_mp),
39.547 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
39.548 + dtac Pair_eqD,
39.549 + etac conjE, hyp_subst_tac,
39.550 + dtac (isNode_def RS iffD1),
39.551 + REPEAT_DETERM o eresolve_tac [exE, conjE],
39.552 + rtac (equalityD2 RS set_mp),
39.553 + rtac (strT_def RS arg_cong RS trans),
39.554 + etac (arg_cong RS trans),
39.555 + fo_rtac (mk_sum_casesN n i RS arg_cong RS trans) ctxt,
39.556 + rtac set_natural, rtac imageI, etac (equalityD2 RS set_mp), rtac CollectI,
39.557 + etac @{thm prefCl_Succ}, atac] 1;
39.558 +
39.559 +fun mk_strT_hset_tac n m j arg_cong_cTs cTs cts carT_defs strT_defs isNode_defs
39.560 + set_incl_hsets set_hset_incl_hsetss coalg_setss carT_setss coalgT set_naturalss =
39.561 + let
39.562 + val set_naturals = map (fn xs => nth xs (j - 1)) set_naturalss;
39.563 + val ks = 1 upto n;
39.564 + fun base_tac (i, (cT, (strT_def, (set_incl_hset, set_natural)))) =
39.565 + CONJ_WRAP' (fn (i', (carT_def, isNode_def)) => rtac impI THEN' etac conjE THEN'
39.566 + (if i = i'
39.567 + then EVERY' [rtac @{thm xt1(4)}, rtac set_incl_hset,
39.568 + rtac (strT_def RS arg_cong RS trans), etac (arg_cong RS trans),
39.569 + rtac (Thm.permute_prems 0 1 (set_natural RS box_equals)),
39.570 + rtac (trans OF [@{thm image_id} RS fun_cong, @{thm id_apply}]),
39.571 + rtac (mk_sum_casesN n i RS (Drule.instantiate' [cT] [] arg_cong) RS sym)]
39.572 + else EVERY' [dtac (carT_def RS equalityD1 RS set_mp),
39.573 + REPEAT_DETERM o eresolve_tac [CollectE, exE], etac conjE,
39.574 + dtac conjunct2, dtac Pair_eqD, etac conjE,
39.575 + hyp_subst_tac, dtac (isNode_def RS iffD1),
39.576 + REPEAT_DETERM o eresolve_tac [exE, conjE],
39.577 + rtac (mk_InN_not_InM i i' RS notE), etac (sym RS trans), atac]))
39.578 + (ks ~~ (carT_defs ~~ isNode_defs));
39.579 + fun step_tac (i, (coalg_sets, (carT_sets, set_hset_incl_hsets))) =
39.580 + dtac (mk_conjunctN n i) THEN'
39.581 + CONJ_WRAP' (fn (coalg_set, (carT_set, set_hset_incl_hset)) =>
39.582 + EVERY' [rtac impI, etac conjE, etac impE, rtac conjI,
39.583 + rtac (coalgT RS coalg_set RS set_mp), atac, etac carT_set, atac, atac,
39.584 + etac (@{thm shift_def} RS fun_cong RS trans), etac subset_trans,
39.585 + rtac set_hset_incl_hset, etac carT_set, atac, atac])
39.586 + (coalg_sets ~~ (carT_sets ~~ set_hset_incl_hsets));
39.587 + in
39.588 + EVERY' [rtac (Drule.instantiate' cTs cts @{thm list.induct}),
39.589 + REPEAT_DETERM o rtac allI, rtac impI,
39.590 + CONJ_WRAP' base_tac
39.591 + (ks ~~ (arg_cong_cTs ~~ (strT_defs ~~ (set_incl_hsets ~~ set_naturals)))),
39.592 + REPEAT_DETERM o rtac allI, rtac impI,
39.593 + REPEAT_DETERM o eresolve_tac [allE, impE], etac @{thm ShiftI},
39.594 + CONJ_WRAP' (fn i => dtac (mk_conjunctN n i) THEN' rtac (mk_sumEN n) THEN'
39.595 + CONJ_WRAP_GEN' (K all_tac) step_tac
39.596 + (ks ~~ (drop m coalg_setss ~~ (carT_setss ~~ set_hset_incl_hsetss)))) ks] 1
39.597 + end;
39.598 +
39.599 +fun mk_isNode_hset_tac n isNode_def strT_hsets {context = ctxt, prems = _} =
39.600 + let
39.601 + val m = length strT_hsets;
39.602 + in
39.603 + if m = 0 then atac 1
39.604 + else (unfold_thms_tac ctxt [isNode_def] THEN
39.605 + EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
39.606 + rtac exI, rtac conjI, atac,
39.607 + CONJ_WRAP' (fn (thm, i) => if i > m then atac
39.608 + else EVERY' [rtac (thm RS subset_trans), atac, rtac conjI, atac, atac, atac])
39.609 + (strT_hsets @ (replicate n mp) ~~ (1 upto (m + n)))] 1)
39.610 + end;
39.611 +
39.612 +fun mk_Lev_sbd_tac cts Lev_0s Lev_Sucs to_sbdss =
39.613 + let
39.614 + val n = length Lev_0s;
39.615 + val ks = 1 upto n;
39.616 + in
39.617 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.618 + REPEAT_DETERM o rtac allI,
39.619 + CONJ_WRAP' (fn Lev_0 =>
39.620 + EVERY' (map rtac [ord_eq_le_trans, Lev_0, @{thm Nil_clists}])) Lev_0s,
39.621 + REPEAT_DETERM o rtac allI,
39.622 + CONJ_WRAP' (fn (Lev_Suc, to_sbds) =>
39.623 + EVERY' [rtac ord_eq_le_trans, rtac Lev_Suc,
39.624 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
39.625 + (fn (i, to_sbd) => EVERY' [rtac subsetI,
39.626 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
39.627 + rtac @{thm Cons_clists}, rtac (mk_InN_Field n i), etac to_sbd,
39.628 + etac set_rev_mp, REPEAT_DETERM o etac allE,
39.629 + etac (mk_conjunctN n i)])
39.630 + (rev (ks ~~ to_sbds))])
39.631 + (Lev_Sucs ~~ to_sbdss)] 1
39.632 + end;
39.633 +
39.634 +fun mk_length_Lev_tac cts Lev_0s Lev_Sucs =
39.635 + let
39.636 + val n = length Lev_0s;
39.637 + val ks = n downto 1;
39.638 + in
39.639 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.640 + REPEAT_DETERM o rtac allI,
39.641 + CONJ_WRAP' (fn Lev_0 =>
39.642 + EVERY' [rtac impI, dtac (Lev_0 RS equalityD1 RS set_mp),
39.643 + etac @{thm singletonE}, etac ssubst, rtac @{thm list.size(3)}]) Lev_0s,
39.644 + REPEAT_DETERM o rtac allI,
39.645 + CONJ_WRAP' (fn Lev_Suc =>
39.646 + EVERY' [rtac impI, dtac (Lev_Suc RS equalityD1 RS set_mp),
39.647 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
39.648 + (fn i => EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
39.649 + rtac trans, rtac @{thm length_Cons}, rtac @{thm arg_cong[of _ _ Suc]},
39.650 + REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i), etac mp, atac]) ks])
39.651 + Lev_Sucs] 1
39.652 + end;
39.653 +
39.654 +fun mk_length_Lev'_tac length_Lev =
39.655 + EVERY' [ftac length_Lev, etac ssubst, atac] 1;
39.656 +
39.657 +fun mk_prefCl_Lev_tac cts Lev_0s Lev_Sucs =
39.658 + let
39.659 + val n = length Lev_0s;
39.660 + val ks = n downto 1;
39.661 + in
39.662 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.663 + REPEAT_DETERM o rtac allI,
39.664 + CONJ_WRAP' (fn Lev_0 =>
39.665 + EVERY' [rtac impI, etac conjE, dtac (Lev_0 RS equalityD1 RS set_mp),
39.666 + etac @{thm singletonE}, hyp_subst_tac, dtac @{thm prefix_Nil[THEN subst, of "%x. x"]},
39.667 + hyp_subst_tac, rtac @{thm set_mp[OF equalityD2[OF trans[OF arg_cong[OF list.size(3)]]]]},
39.668 + rtac Lev_0, rtac @{thm singletonI}]) Lev_0s,
39.669 + REPEAT_DETERM o rtac allI,
39.670 + CONJ_WRAP' (fn (Lev_0, Lev_Suc) =>
39.671 + EVERY' [rtac impI, etac conjE, dtac (Lev_Suc RS equalityD1 RS set_mp),
39.672 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
39.673 + (fn i => EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
39.674 + dtac @{thm prefix_Cons[THEN subst, of "%x. x"]}, etac disjE, hyp_subst_tac,
39.675 + rtac @{thm set_mp[OF equalityD2[OF trans[OF arg_cong[OF list.size(3)]]]]},
39.676 + rtac Lev_0, rtac @{thm singletonI},
39.677 + REPEAT_DETERM o eresolve_tac [exE, conjE], hyp_subst_tac,
39.678 + rtac @{thm set_mp[OF equalityD2[OF trans[OF arg_cong[OF length_Cons]]]]},
39.679 + rtac Lev_Suc, rtac (mk_UnIN n i), rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI,
39.680 + rtac refl, etac conjI, REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i),
39.681 + etac mp, etac conjI, atac]) ks])
39.682 + (Lev_0s ~~ Lev_Sucs)] 1
39.683 + end;
39.684 +
39.685 +fun mk_rv_last_tac cTs cts rv_Nils rv_Conss =
39.686 + let
39.687 + val n = length rv_Nils;
39.688 + val ks = 1 upto n;
39.689 + in
39.690 + EVERY' [rtac (Drule.instantiate' cTs cts @{thm list.induct}),
39.691 + REPEAT_DETERM o rtac allI,
39.692 + CONJ_WRAP' (fn rv_Cons =>
39.693 + CONJ_WRAP' (fn (i, rv_Nil) => (EVERY' [rtac exI,
39.694 + rtac (@{thm append_Nil} RS arg_cong RS trans),
39.695 + rtac (rv_Cons RS trans), rtac (mk_sum_casesN n i RS arg_cong RS trans), rtac rv_Nil]))
39.696 + (ks ~~ rv_Nils))
39.697 + rv_Conss,
39.698 + REPEAT_DETERM o rtac allI, rtac (mk_sumEN n),
39.699 + EVERY' (map (fn i =>
39.700 + CONJ_WRAP' (fn rv_Cons => EVERY' [REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i),
39.701 + CONJ_WRAP' (fn i' => EVERY' [dtac (mk_conjunctN n i'), etac exE, rtac exI,
39.702 + rtac (@{thm append_Cons} RS arg_cong RS trans),
39.703 + rtac (rv_Cons RS trans), etac (sum_case_weak_cong RS arg_cong RS trans),
39.704 + rtac (mk_sum_casesN n i RS arg_cong RS trans), atac])
39.705 + ks])
39.706 + rv_Conss)
39.707 + ks)] 1
39.708 + end;
39.709 +
39.710 +fun mk_set_rv_Lev_tac m cts Lev_0s Lev_Sucs rv_Nils rv_Conss coalg_setss from_to_sbdss =
39.711 + let
39.712 + val n = length Lev_0s;
39.713 + val ks = 1 upto n;
39.714 + in
39.715 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.716 + REPEAT_DETERM o rtac allI,
39.717 + CONJ_WRAP' (fn (i, ((Lev_0, rv_Nil), coalg_sets)) =>
39.718 + EVERY' [rtac impI, REPEAT_DETERM o etac conjE,
39.719 + dtac (Lev_0 RS equalityD1 RS set_mp), etac @{thm singletonE}, etac ssubst,
39.720 + rtac (rv_Nil RS arg_cong RS iffD2),
39.721 + rtac (mk_sum_casesN n i RS iffD2),
39.722 + CONJ_WRAP' (fn thm => etac thm THEN' atac) (take m coalg_sets)])
39.723 + (ks ~~ ((Lev_0s ~~ rv_Nils) ~~ coalg_setss)),
39.724 + REPEAT_DETERM o rtac allI,
39.725 + CONJ_WRAP' (fn ((Lev_Suc, rv_Cons), (from_to_sbds, coalg_sets)) =>
39.726 + EVERY' [rtac impI, etac conjE, dtac (Lev_Suc RS equalityD1 RS set_mp),
39.727 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
39.728 + (fn (i, (from_to_sbd, coalg_set)) =>
39.729 + EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
39.730 + rtac (rv_Cons RS arg_cong RS iffD2),
39.731 + rtac (mk_sum_casesN n i RS arg_cong RS trans RS iffD2),
39.732 + etac (from_to_sbd RS arg_cong), REPEAT_DETERM o etac allE,
39.733 + dtac (mk_conjunctN n i), etac mp, etac conjI, etac set_rev_mp,
39.734 + etac coalg_set, atac])
39.735 + (rev (ks ~~ (from_to_sbds ~~ drop m coalg_sets)))])
39.736 + ((Lev_Sucs ~~ rv_Conss) ~~ (from_to_sbdss ~~ coalg_setss))] 1
39.737 + end;
39.738 +
39.739 +fun mk_set_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbdss =
39.740 + let
39.741 + val n = length Lev_0s;
39.742 + val ks = 1 upto n;
39.743 + in
39.744 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.745 + REPEAT_DETERM o rtac allI,
39.746 + CONJ_WRAP' (fn ((i, (Lev_0, Lev_Suc)), rv_Nil) =>
39.747 + EVERY' [rtac impI, dtac (Lev_0 RS equalityD1 RS set_mp),
39.748 + etac @{thm singletonE}, hyp_subst_tac,
39.749 + CONJ_WRAP' (fn i' => rtac impI THEN' dtac (sym RS trans) THEN' rtac rv_Nil THEN'
39.750 + (if i = i'
39.751 + then EVERY' [dtac (mk_InN_inject n i), hyp_subst_tac,
39.752 + CONJ_WRAP' (fn (i'', Lev_0'') =>
39.753 + EVERY' [rtac impI, rtac @{thm ssubst_mem[OF append_Nil]},
39.754 + rtac (Lev_Suc RS equalityD2 RS set_mp), rtac (mk_UnIN n i''),
39.755 + rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI, rtac refl,
39.756 + etac conjI, rtac (Lev_0'' RS equalityD2 RS set_mp),
39.757 + rtac @{thm singletonI}])
39.758 + (ks ~~ Lev_0s)]
39.759 + else etac (mk_InN_not_InM i' i RS notE)))
39.760 + ks])
39.761 + ((ks ~~ (Lev_0s ~~ Lev_Sucs)) ~~ rv_Nils),
39.762 + REPEAT_DETERM o rtac allI,
39.763 + CONJ_WRAP' (fn ((Lev_Suc, rv_Cons), from_to_sbds) =>
39.764 + EVERY' [rtac impI, dtac (Lev_Suc RS equalityD1 RS set_mp),
39.765 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
39.766 + (fn (i, from_to_sbd) =>
39.767 + EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
39.768 + CONJ_WRAP' (fn i' => rtac impI THEN'
39.769 + CONJ_WRAP' (fn i'' =>
39.770 + EVERY' [rtac impI, rtac (Lev_Suc RS equalityD2 RS set_mp),
39.771 + rtac @{thm ssubst_mem[OF append_Cons]}, rtac (mk_UnIN n i),
39.772 + rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI, rtac refl,
39.773 + rtac conjI, atac, dtac (sym RS trans RS sym),
39.774 + rtac (rv_Cons RS trans), rtac (mk_sum_casesN n i RS trans),
39.775 + etac (from_to_sbd RS arg_cong), REPEAT_DETERM o etac allE,
39.776 + dtac (mk_conjunctN n i), dtac mp, atac,
39.777 + dtac (mk_conjunctN n i'), dtac mp, atac,
39.778 + dtac (mk_conjunctN n i''), etac mp, atac])
39.779 + ks)
39.780 + ks])
39.781 + (rev (ks ~~ from_to_sbds))])
39.782 + ((Lev_Sucs ~~ rv_Conss) ~~ from_to_sbdss)] 1
39.783 + end;
39.784 +
39.785 +fun mk_set_image_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbdss to_sbd_injss =
39.786 + let
39.787 + val n = length Lev_0s;
39.788 + val ks = 1 upto n;
39.789 + in
39.790 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.791 + REPEAT_DETERM o rtac allI,
39.792 + CONJ_WRAP' (fn ((i, (Lev_0, Lev_Suc)), rv_Nil) =>
39.793 + EVERY' [rtac impI, dtac (Lev_0 RS equalityD1 RS set_mp),
39.794 + etac @{thm singletonE}, hyp_subst_tac,
39.795 + CONJ_WRAP' (fn i' => rtac impI THEN'
39.796 + CONJ_WRAP' (fn i'' => rtac impI THEN' dtac (sym RS trans) THEN' rtac rv_Nil THEN'
39.797 + (if i = i''
39.798 + then EVERY' [dtac @{thm ssubst_mem[OF sym[OF append_Nil]]},
39.799 + dtac (Lev_Suc RS equalityD1 RS set_mp), dtac (mk_InN_inject n i),
39.800 + hyp_subst_tac,
39.801 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
39.802 + (fn k => REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE] THEN'
39.803 + dtac list_inject_iffD1 THEN' etac conjE THEN'
39.804 + (if k = i'
39.805 + then EVERY' [dtac (mk_InN_inject n k), hyp_subst_tac, etac imageI]
39.806 + else etac (mk_InN_not_InM i' k RS notE)))
39.807 + (rev ks)]
39.808 + else etac (mk_InN_not_InM i'' i RS notE)))
39.809 + ks)
39.810 + ks])
39.811 + ((ks ~~ (Lev_0s ~~ Lev_Sucs)) ~~ rv_Nils),
39.812 + REPEAT_DETERM o rtac allI,
39.813 + CONJ_WRAP' (fn ((Lev_Suc, rv_Cons), (from_to_sbds, to_sbd_injs)) =>
39.814 + EVERY' [rtac impI, dtac (Lev_Suc RS equalityD1 RS set_mp),
39.815 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
39.816 + (fn (i, (from_to_sbd, to_sbd_inj)) =>
39.817 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE] THEN' hyp_subst_tac THEN'
39.818 + CONJ_WRAP' (fn i' => rtac impI THEN'
39.819 + dtac @{thm ssubst_mem[OF sym[OF append_Cons]]} THEN'
39.820 + dtac (Lev_Suc RS equalityD1 RS set_mp) THEN'
39.821 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE)) (fn k =>
39.822 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE] THEN'
39.823 + dtac list_inject_iffD1 THEN' etac conjE THEN'
39.824 + (if k = i
39.825 + then EVERY' [dtac (mk_InN_inject n i),
39.826 + dtac (Thm.permute_prems 0 2 (to_sbd_inj RS iffD1)),
39.827 + atac, atac, hyp_subst_tac] THEN'
39.828 + CONJ_WRAP' (fn i'' =>
39.829 + EVERY' [rtac impI, dtac (sym RS trans),
39.830 + rtac (rv_Cons RS trans), rtac (mk_sum_casesN n i RS arg_cong RS trans),
39.831 + etac (from_to_sbd RS arg_cong),
39.832 + REPEAT_DETERM o etac allE,
39.833 + dtac (mk_conjunctN n i), dtac mp, atac,
39.834 + dtac (mk_conjunctN n i'), dtac mp, atac,
39.835 + dtac (mk_conjunctN n i''), etac mp, etac sym])
39.836 + ks
39.837 + else etac (mk_InN_not_InM i k RS notE)))
39.838 + (rev ks))
39.839 + ks)
39.840 + (rev (ks ~~ (from_to_sbds ~~ to_sbd_injs)))])
39.841 + ((Lev_Sucs ~~ rv_Conss) ~~ (from_to_sbdss ~~ to_sbd_injss))] 1
39.842 + end;
39.843 +
39.844 +fun mk_mor_beh_tac m mor_def mor_cong beh_defs carT_defs strT_defs isNode_defs
39.845 + to_sbd_injss from_to_sbdss Lev_0s Lev_Sucs rv_Nils rv_Conss Lev_sbds length_Levs length_Lev's
39.846 + prefCl_Levs rv_lastss set_rv_Levsss set_Levsss set_image_Levsss set_naturalss coalg_setss
39.847 + map_comp_ids map_congs map_arg_congs {context = ctxt, prems = _} =
39.848 + let
39.849 + val n = length beh_defs;
39.850 + val ks = 1 upto n;
39.851 +
39.852 + fun fbetw_tac (i, (carT_def, (isNode_def, (Lev_0, (rv_Nil, (Lev_sbd,
39.853 + ((length_Lev, length_Lev'), (prefCl_Lev, (rv_lasts, (set_naturals,
39.854 + (coalg_sets, (set_rv_Levss, (set_Levss, set_image_Levss))))))))))))) =
39.855 + EVERY' [rtac ballI, rtac (carT_def RS equalityD2 RS set_mp),
39.856 + rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI, rtac refl, rtac conjI,
39.857 + rtac conjI,
39.858 + rtac @{thm UN_I}, rtac UNIV_I, rtac (Lev_0 RS equalityD2 RS set_mp),
39.859 + rtac @{thm singletonI},
39.860 + rtac conjI,
39.861 + rtac @{thm UN_least}, rtac Lev_sbd,
39.862 + rtac conjI,
39.863 + rtac @{thm prefCl_UN}, rtac ssubst, rtac @{thm PrefCl_def}, REPEAT_DETERM o rtac allI,
39.864 + rtac impI, etac conjE, rtac exI, rtac conjI, rtac @{thm ord_le_eq_trans},
39.865 + etac @{thm prefix_length_le}, etac length_Lev, rtac prefCl_Lev, etac conjI, atac,
39.866 + rtac conjI,
39.867 + rtac ballI, etac @{thm UN_E}, rtac conjI,
39.868 + if n = 1 then K all_tac else rtac (mk_sumEN n),
39.869 + EVERY' (map6 (fn i => fn isNode_def => fn set_naturals =>
39.870 + fn set_rv_Levs => fn set_Levs => fn set_image_Levs =>
39.871 + EVERY' [rtac (mk_disjIN n i), rtac (isNode_def RS ssubst),
39.872 + rtac exI, rtac conjI,
39.873 + (if n = 1 then rtac @{thm if_P} THEN' etac length_Lev'
39.874 + else rtac (@{thm if_P} RS arg_cong RS trans) THEN' etac length_Lev' THEN'
39.875 + etac (sum_case_weak_cong RS trans) THEN' rtac (mk_sum_casesN n i)),
39.876 + EVERY' (map2 (fn set_natural => fn set_rv_Lev =>
39.877 + EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac (set_natural RS trans),
39.878 + rtac trans_fun_cong_image_id_id_apply,
39.879 + etac set_rv_Lev, TRY o atac, etac conjI, atac])
39.880 + (take m set_naturals) set_rv_Levs),
39.881 + CONJ_WRAP' (fn (set_natural, (set_Lev, set_image_Lev)) =>
39.882 + EVERY' [rtac (set_natural RS trans), rtac equalityI, rtac @{thm image_subsetI},
39.883 + rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, etac set_Lev,
39.884 + if n = 1 then rtac refl else atac, atac, rtac subsetI,
39.885 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
39.886 + rtac set_image_Lev, atac, dtac length_Lev, hyp_subst_tac, dtac length_Lev',
39.887 + etac @{thm set_mp[OF equalityD1[OF arg_cong[OF length_append_singleton]]]},
39.888 + if n = 1 then rtac refl else atac])
39.889 + (drop m set_naturals ~~ (set_Levs ~~ set_image_Levs))])
39.890 + ks isNode_defs set_naturalss set_rv_Levss set_Levss set_image_Levss),
39.891 + CONJ_WRAP' (fn (i, (rv_last, (isNode_def, (set_naturals,
39.892 + (set_rv_Levs, (set_Levs, set_image_Levs)))))) =>
39.893 + EVERY' [rtac ballI,
39.894 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
39.895 + rtac (rev_mp OF [rv_last, impI]), etac exE, rtac (isNode_def RS ssubst),
39.896 + rtac exI, rtac conjI,
39.897 + (if n = 1 then rtac @{thm if_P} THEN' etac length_Lev'
39.898 + else rtac (@{thm if_P} RS trans) THEN' etac length_Lev' THEN'
39.899 + etac (sum_case_weak_cong RS trans) THEN' rtac (mk_sum_casesN n i)),
39.900 + EVERY' (map2 (fn set_natural => fn set_rv_Lev =>
39.901 + EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac (set_natural RS trans),
39.902 + rtac trans_fun_cong_image_id_id_apply,
39.903 + etac set_rv_Lev, TRY o atac, etac conjI, atac])
39.904 + (take m set_naturals) set_rv_Levs),
39.905 + CONJ_WRAP' (fn (set_natural, (set_Lev, set_image_Lev)) =>
39.906 + EVERY' [rtac (set_natural RS trans), rtac equalityI, rtac @{thm image_subsetI},
39.907 + rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, etac set_Lev,
39.908 + if n = 1 then rtac refl else atac, atac, rtac subsetI,
39.909 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
39.910 + REPEAT_DETERM_N 4 o etac thin_rl,
39.911 + rtac set_image_Lev,
39.912 + atac, dtac length_Lev, hyp_subst_tac, dtac length_Lev',
39.913 + etac @{thm set_mp[OF equalityD1[OF arg_cong[OF length_append_singleton]]]},
39.914 + if n = 1 then rtac refl else atac])
39.915 + (drop m set_naturals ~~ (set_Levs ~~ set_image_Levs))])
39.916 + (ks ~~ (rv_lasts ~~ (isNode_defs ~~ (set_naturalss ~~
39.917 + (set_rv_Levss ~~ (set_Levss ~~ set_image_Levss)))))),
39.918 + (**)
39.919 + rtac allI, rtac impI, rtac @{thm if_not_P}, rtac notI,
39.920 + etac notE, etac @{thm UN_I[OF UNIV_I]},
39.921 + (*root isNode*)
39.922 + rtac (isNode_def RS ssubst), rtac exI, rtac conjI, rtac (@{thm if_P} RS trans),
39.923 + rtac length_Lev', rtac (Lev_0 RS equalityD2 RS set_mp), rtac @{thm singletonI},
39.924 + CONVERSION (Conv.top_conv
39.925 + (K (Conv.try_conv (Conv.rewr_conv (rv_Nil RS eq_reflection)))) ctxt),
39.926 + if n = 1 then rtac refl else rtac (mk_sum_casesN n i),
39.927 + EVERY' (map2 (fn set_natural => fn coalg_set =>
39.928 + EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac (set_natural RS trans),
39.929 + rtac trans_fun_cong_image_id_id_apply, etac coalg_set, atac])
39.930 + (take m set_naturals) (take m coalg_sets)),
39.931 + CONJ_WRAP' (fn (set_natural, (set_Lev, set_image_Lev)) =>
39.932 + EVERY' [rtac (set_natural RS trans), rtac equalityI, rtac @{thm image_subsetI},
39.933 + rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, rtac set_Lev,
39.934 + rtac (Lev_0 RS equalityD2 RS set_mp), rtac @{thm singletonI}, rtac rv_Nil,
39.935 + atac, rtac subsetI,
39.936 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
39.937 + rtac set_image_Lev, rtac (Lev_0 RS equalityD2 RS set_mp),
39.938 + rtac @{thm singletonI}, dtac length_Lev',
39.939 + etac @{thm set_mp[OF equalityD1[OF arg_cong[OF
39.940 + trans[OF length_append_singleton arg_cong[of _ _ Suc, OF list.size(3)]]]]]},
39.941 + rtac rv_Nil])
39.942 + (drop m set_naturals ~~ (nth set_Levss (i - 1) ~~ nth set_image_Levss (i - 1)))];
39.943 +
39.944 + fun mor_tac (i, (strT_def, (((Lev_0, Lev_Suc), (rv_Nil, rv_Cons)),
39.945 + ((map_comp_id, (map_cong, map_arg_cong)), (length_Lev', (from_to_sbds, to_sbd_injs)))))) =
39.946 + EVERY' [rtac ballI, rtac sym, rtac trans, rtac strT_def,
39.947 + rtac (@{thm if_P} RS
39.948 + (if n = 1 then map_arg_cong else sum_case_weak_cong) RS trans),
39.949 + rtac (@{thm list.size(3)} RS arg_cong RS trans RS equalityD2 RS set_mp),
39.950 + rtac Lev_0, rtac @{thm singletonI},
39.951 + CONVERSION (Conv.top_conv
39.952 + (K (Conv.try_conv (Conv.rewr_conv (rv_Nil RS eq_reflection)))) ctxt),
39.953 + if n = 1 then K all_tac
39.954 + else (rtac (sum_case_weak_cong RS trans) THEN'
39.955 + rtac (mk_sum_casesN n i) THEN' rtac (mk_sum_casesN n i RS trans)),
39.956 + rtac (map_comp_id RS trans), rtac (map_cong OF replicate m refl),
39.957 + EVERY' (map3 (fn i' => fn to_sbd_inj => fn from_to_sbd =>
39.958 + DETERM o EVERY' [rtac trans, rtac o_apply, rtac Pair_eqI, rtac conjI,
39.959 + rtac trans, rtac @{thm Shift_def},
39.960 + rtac equalityI, rtac subsetI, etac thin_rl, etac thin_rl,
39.961 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm UN_E}], dtac length_Lev', dtac asm_rl,
39.962 + etac thin_rl, dtac @{thm set_rev_mp[OF _ equalityD1]},
39.963 + rtac (@{thm length_Cons} RS arg_cong RS trans), rtac Lev_Suc,
39.964 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE)) (fn i'' =>
39.965 + EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
39.966 + dtac list_inject_iffD1, etac conjE,
39.967 + if i' = i'' then EVERY' [dtac (mk_InN_inject n i'),
39.968 + dtac (Thm.permute_prems 0 2 (to_sbd_inj RS iffD1)),
39.969 + atac, atac, hyp_subst_tac, etac @{thm UN_I[OF UNIV_I]}]
39.970 + else etac (mk_InN_not_InM i' i'' RS notE)])
39.971 + (rev ks),
39.972 + rtac @{thm UN_least}, rtac subsetI, rtac CollectI, rtac @{thm UN_I[OF UNIV_I]},
39.973 + rtac (Lev_Suc RS equalityD2 RS set_mp), rtac (mk_UnIN n i'), rtac CollectI,
39.974 + REPEAT_DETERM o rtac exI, rtac conjI, rtac refl, etac conjI, atac,
39.975 + rtac trans, rtac @{thm shift_def}, rtac ssubst, rtac @{thm fun_eq_iff}, rtac allI,
39.976 + rtac @{thm if_cong}, rtac (@{thm length_Cons} RS arg_cong RS trans), rtac iffI,
39.977 + dtac asm_rl, dtac asm_rl, dtac asm_rl,
39.978 + dtac (Lev_Suc RS equalityD1 RS set_mp),
39.979 + CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE)) (fn i'' =>
39.980 + EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
39.981 + dtac list_inject_iffD1, etac conjE,
39.982 + if i' = i'' then EVERY' [dtac (mk_InN_inject n i'),
39.983 + dtac (Thm.permute_prems 0 2 (to_sbd_inj RS iffD1)),
39.984 + atac, atac, hyp_subst_tac, atac]
39.985 + else etac (mk_InN_not_InM i' i'' RS notE)])
39.986 + (rev ks),
39.987 + rtac (Lev_Suc RS equalityD2 RS set_mp), rtac (mk_UnIN n i'), rtac CollectI,
39.988 + REPEAT_DETERM o rtac exI, rtac conjI, rtac refl, etac conjI, atac,
39.989 + CONVERSION (Conv.top_conv
39.990 + (K (Conv.try_conv (Conv.rewr_conv (rv_Cons RS eq_reflection)))) ctxt),
39.991 + if n = 1 then K all_tac
39.992 + else rtac sum_case_weak_cong THEN' rtac (mk_sum_casesN n i' RS trans),
39.993 + SELECT_GOAL (unfold_thms_tac ctxt [from_to_sbd]), rtac refl,
39.994 + rtac refl])
39.995 + ks to_sbd_injs from_to_sbds)];
39.996 + in
39.997 + (rtac mor_cong THEN'
39.998 + EVERY' (map (fn thm => rtac (thm RS ext)) beh_defs) THEN'
39.999 + stac mor_def THEN' rtac conjI THEN'
39.1000 + CONJ_WRAP' fbetw_tac
39.1001 + (ks ~~ (carT_defs ~~ (isNode_defs ~~ (Lev_0s ~~ (rv_Nils ~~ (Lev_sbds ~~
39.1002 + ((length_Levs ~~ length_Lev's) ~~ (prefCl_Levs ~~ (rv_lastss ~~
39.1003 + (set_naturalss ~~ (coalg_setss ~~
39.1004 + (set_rv_Levsss ~~ (set_Levsss ~~ set_image_Levsss))))))))))))) THEN'
39.1005 + CONJ_WRAP' mor_tac
39.1006 + (ks ~~ (strT_defs ~~ (((Lev_0s ~~ Lev_Sucs) ~~ (rv_Nils ~~ rv_Conss)) ~~
39.1007 + ((map_comp_ids ~~ (map_congs ~~ map_arg_congs)) ~~
39.1008 + (length_Lev's ~~ (from_to_sbdss ~~ to_sbd_injss))))))) 1
39.1009 + end;
39.1010 +
39.1011 +fun mk_congruent_str_final_tac m lsbisE map_comp_id map_cong equiv_LSBISs =
39.1012 + EVERY' [rtac @{thm congruentI}, dtac lsbisE,
39.1013 + REPEAT_DETERM o eresolve_tac [CollectE, conjE, bexE], rtac (o_apply RS trans),
39.1014 + etac (sym RS arg_cong RS trans), rtac (map_comp_id RS trans),
39.1015 + rtac (map_cong RS trans), REPEAT_DETERM_N m o rtac refl,
39.1016 + EVERY' (map (fn equiv_LSBIS =>
39.1017 + EVERY' [rtac @{thm equiv_proj}, rtac equiv_LSBIS, etac set_mp, atac])
39.1018 + equiv_LSBISs), rtac sym, rtac (o_apply RS trans),
39.1019 + etac (sym RS arg_cong RS trans), rtac map_comp_id] 1;
39.1020 +
39.1021 +fun mk_coalg_final_tac m coalg_def congruent_str_finals equiv_LSBISs set_naturalss coalgT_setss =
39.1022 + EVERY' [stac coalg_def,
39.1023 + CONJ_WRAP' (fn ((set_naturals, coalgT_sets), (equiv_LSBIS, congruent_str_final)) =>
39.1024 + EVERY' [rtac @{thm univ_preserves}, rtac equiv_LSBIS, rtac congruent_str_final,
39.1025 + rtac ballI, rtac @{thm ssubst_mem}, rtac o_apply, rtac CollectI,
39.1026 + EVERY' (map2 (fn set_natural => fn coalgT_set =>
39.1027 + EVERY' [rtac conjI, rtac (set_natural RS ord_eq_le_trans),
39.1028 + rtac ord_eq_le_trans_trans_fun_cong_image_id_id_apply,
39.1029 + etac coalgT_set])
39.1030 + (take m set_naturals) (take m coalgT_sets)),
39.1031 + CONJ_WRAP' (fn (equiv_LSBIS, (set_natural, coalgT_set)) =>
39.1032 + EVERY' [rtac (set_natural RS ord_eq_le_trans),
39.1033 + rtac @{thm image_subsetI}, rtac ssubst, rtac @{thm proj_in_iff},
39.1034 + rtac equiv_LSBIS, etac set_rev_mp, etac coalgT_set])
39.1035 + (equiv_LSBISs ~~ drop m (set_naturals ~~ coalgT_sets))])
39.1036 + ((set_naturalss ~~ coalgT_setss) ~~ (equiv_LSBISs ~~ congruent_str_finals))] 1;
39.1037 +
39.1038 +fun mk_mor_T_final_tac mor_def congruent_str_finals equiv_LSBISs =
39.1039 + EVERY' [stac mor_def, rtac conjI,
39.1040 + CONJ_WRAP' (fn equiv_LSBIS =>
39.1041 + EVERY' [rtac ballI, rtac ssubst, rtac @{thm proj_in_iff}, rtac equiv_LSBIS, atac])
39.1042 + equiv_LSBISs,
39.1043 + CONJ_WRAP' (fn (equiv_LSBIS, congruent_str_final) =>
39.1044 + EVERY' [rtac ballI, rtac sym, rtac trans, rtac @{thm univ_commute}, rtac equiv_LSBIS,
39.1045 + rtac congruent_str_final, atac, rtac o_apply])
39.1046 + (equiv_LSBISs ~~ congruent_str_finals)] 1;
39.1047 +
39.1048 +fun mk_mor_Rep_tac m defs Reps Abs_inverses coalg_final_setss map_comp_ids map_congLs
39.1049 + {context = ctxt, prems = _} =
39.1050 + unfold_thms_tac ctxt defs THEN
39.1051 + EVERY' [rtac conjI,
39.1052 + CONJ_WRAP' (fn thm => rtac ballI THEN' rtac thm) Reps,
39.1053 + CONJ_WRAP' (fn (Rep, ((map_comp_id, map_congL), coalg_final_sets)) =>
39.1054 + EVERY' [rtac ballI, rtac (map_comp_id RS trans), rtac map_congL,
39.1055 + EVERY' (map2 (fn Abs_inverse => fn coalg_final_set =>
39.1056 + EVERY' [rtac ballI, rtac (o_apply RS trans), rtac Abs_inverse,
39.1057 + etac set_rev_mp, rtac coalg_final_set, rtac Rep])
39.1058 + Abs_inverses (drop m coalg_final_sets))])
39.1059 + (Reps ~~ ((map_comp_ids ~~ map_congLs) ~~ coalg_final_setss))] 1;
39.1060 +
39.1061 +fun mk_mor_Abs_tac defs Abs_inverses {context = ctxt, prems = _} =
39.1062 + unfold_thms_tac ctxt defs THEN
39.1063 + EVERY' [rtac conjI,
39.1064 + CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) Abs_inverses,
39.1065 + CONJ_WRAP' (fn thm => rtac ballI THEN' etac (thm RS arg_cong RS sym)) Abs_inverses] 1;
39.1066 +
39.1067 +fun mk_mor_unfold_tac m mor_UNIV dtor_defs unfold_defs Abs_inverses morEs map_comp_ids map_congs =
39.1068 + EVERY' [rtac iffD2, rtac mor_UNIV,
39.1069 + CONJ_WRAP' (fn ((Abs_inverse, morE), ((dtor_def, unfold_def), (map_comp_id, map_cong))) =>
39.1070 + EVERY' [rtac ext, rtac (o_apply RS trans RS sym), rtac (dtor_def RS trans),
39.1071 + rtac (unfold_def RS arg_cong RS trans), rtac (Abs_inverse RS arg_cong RS trans),
39.1072 + rtac (morE RS arg_cong RS trans), rtac (map_comp_id RS trans),
39.1073 + rtac (o_apply RS trans RS sym), rtac map_cong,
39.1074 + REPEAT_DETERM_N m o rtac refl,
39.1075 + EVERY' (map (fn thm => rtac (thm RS trans) THEN' rtac (o_apply RS sym)) unfold_defs)])
39.1076 + ((Abs_inverses ~~ morEs) ~~ ((dtor_defs ~~ unfold_defs) ~~ (map_comp_ids ~~ map_congs)))] 1;
39.1077 +
39.1078 +fun mk_raw_coind_tac bis_def bis_cong bis_O bis_converse bis_Gr tcoalg coalgT mor_T_final
39.1079 + sbis_lsbis lsbis_incls incl_lsbiss equiv_LSBISs mor_Rep Rep_injects =
39.1080 + let
39.1081 + val n = length Rep_injects;
39.1082 + in
39.1083 + EVERY' [rtac rev_mp, ftac (bis_def RS iffD1),
39.1084 + REPEAT_DETERM o etac conjE, rtac bis_cong, rtac bis_O, rtac bis_converse,
39.1085 + rtac bis_Gr, rtac tcoalg, rtac mor_Rep, rtac bis_O, atac, rtac bis_Gr, rtac tcoalg,
39.1086 + rtac mor_Rep, REPEAT_DETERM_N n o etac @{thm relImage_Gr},
39.1087 + rtac impI, rtac rev_mp, rtac bis_cong, rtac bis_O, rtac bis_Gr, rtac coalgT,
39.1088 + rtac mor_T_final, rtac bis_O, rtac sbis_lsbis, rtac bis_converse, rtac bis_Gr, rtac coalgT,
39.1089 + rtac mor_T_final, EVERY' (map (fn thm => rtac (thm RS @{thm relInvImage_Gr})) lsbis_incls),
39.1090 + rtac impI,
39.1091 + CONJ_WRAP' (fn (Rep_inject, (equiv_LSBIS , (incl_lsbis, lsbis_incl))) =>
39.1092 + EVERY' [rtac subset_trans, rtac @{thm relInvImage_UNIV_relImage}, rtac subset_trans,
39.1093 + rtac @{thm relInvImage_mono}, rtac subset_trans, etac incl_lsbis,
39.1094 + rtac ord_eq_le_trans, rtac @{thm sym[OF relImage_relInvImage]},
39.1095 + rtac @{thm xt1(3)}, rtac @{thm Sigma_cong},
39.1096 + rtac @{thm proj_image}, rtac @{thm proj_image}, rtac lsbis_incl,
39.1097 + rtac subset_trans, rtac @{thm relImage_mono}, rtac incl_lsbis, atac,
39.1098 + rtac @{thm relImage_proj}, rtac equiv_LSBIS, rtac @{thm relInvImage_diag},
39.1099 + rtac Rep_inject])
39.1100 + (Rep_injects ~~ (equiv_LSBISs ~~ (incl_lsbiss ~~ lsbis_incls)))] 1
39.1101 + end;
39.1102 +
39.1103 +fun mk_unique_mor_tac raw_coinds bis =
39.1104 + CONJ_WRAP' (fn raw_coind =>
39.1105 + EVERY' [rtac impI, rtac (bis RS raw_coind RS set_mp RS @{thm IdD}), atac,
39.1106 + etac conjunct1, atac, etac conjunct2, rtac @{thm image2_eqI}, rtac refl, rtac refl, atac])
39.1107 + raw_coinds 1;
39.1108 +
39.1109 +fun mk_unfold_unique_mor_tac raw_coinds bis mor unfold_defs =
39.1110 + CONJ_WRAP' (fn (raw_coind, unfold_def) =>
39.1111 + EVERY' [rtac ext, etac (bis RS raw_coind RS set_mp RS @{thm IdD}), rtac mor,
39.1112 + rtac @{thm image2_eqI}, rtac refl, rtac (unfold_def RS arg_cong RS trans),
39.1113 + rtac (o_apply RS sym), rtac UNIV_I]) (raw_coinds ~~ unfold_defs) 1;
39.1114 +
39.1115 +fun mk_dtor_o_ctor_tac ctor_def unfold map_comp_id map_congL unfold_o_dtors
39.1116 + {context = ctxt, prems = _} =
39.1117 + unfold_thms_tac ctxt [ctor_def] THEN EVERY' [rtac ext, rtac trans, rtac o_apply,
39.1118 + rtac trans, rtac unfold, rtac trans, rtac map_comp_id, rtac trans, rtac map_congL,
39.1119 + EVERY' (map (fn thm =>
39.1120 + rtac ballI THEN' rtac (trans OF [thm RS fun_cong, @{thm id_apply}])) unfold_o_dtors),
39.1121 + rtac sym, rtac @{thm id_apply}] 1;
39.1122 +
39.1123 +fun mk_corec_tac m corec_defs unfold map_cong corec_Inls {context = ctxt, prems = _} =
39.1124 + unfold_thms_tac ctxt corec_defs THEN EVERY' [rtac trans, rtac (o_apply RS arg_cong),
39.1125 + rtac trans, rtac unfold, fo_rtac (@{thm sum.cases(2)} RS arg_cong RS trans) ctxt, rtac map_cong,
39.1126 + REPEAT_DETERM_N m o rtac refl,
39.1127 + EVERY' (map (fn thm => rtac @{thm sum_case_expand_Inr} THEN' rtac thm) corec_Inls)] 1;
39.1128 +
39.1129 +fun mk_srel_coinduct_tac ks raw_coind bis_srel =
39.1130 + EVERY' [rtac rev_mp, rtac raw_coind, rtac ssubst, rtac bis_srel, rtac conjI,
39.1131 + CONJ_WRAP' (K (rtac @{thm ord_le_eq_trans[OF subset_UNIV UNIV_Times_UNIV[THEN sym]]})) ks,
39.1132 + CONJ_WRAP' (K (EVERY' [rtac allI, rtac allI, rtac impI,
39.1133 + REPEAT_DETERM o etac allE, etac mp, etac CollectE, etac @{thm splitD}])) ks,
39.1134 + rtac impI, REPEAT_DETERM o etac conjE,
39.1135 + CONJ_WRAP' (K (EVERY' [rtac impI, rtac @{thm IdD}, etac set_mp,
39.1136 + rtac CollectI, etac @{thm prod_caseI}])) ks] 1;
39.1137 +
39.1138 +fun mk_srel_strong_coinduct_tac m cTs cts srel_coinduct srel_monos srel_Ids =
39.1139 + EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts srel_coinduct),
39.1140 + EVERY' (map2 (fn srel_mono => fn srel_Id =>
39.1141 + EVERY' [REPEAT_DETERM o resolve_tac [allI, impI], REPEAT_DETERM o etac allE,
39.1142 + etac disjE, etac mp, atac, hyp_subst_tac, rtac (srel_mono RS set_mp),
39.1143 + REPEAT_DETERM_N m o rtac @{thm subset_refl},
39.1144 + REPEAT_DETERM_N (length srel_monos) o rtac @{thm Id_subset},
39.1145 + rtac (srel_Id RS equalityD2 RS set_mp), rtac @{thm IdI}])
39.1146 + srel_monos srel_Ids),
39.1147 + rtac impI, REPEAT_DETERM o etac conjE,
39.1148 + CONJ_WRAP' (K (rtac impI THEN' etac mp THEN' etac disjI1)) srel_Ids] 1;
39.1149 +
39.1150 +fun mk_dtor_coinduct_tac m ks raw_coind bis_def =
39.1151 + let
39.1152 + val n = length ks;
39.1153 + in
39.1154 + EVERY' [rtac rev_mp, rtac raw_coind, rtac ssubst, rtac bis_def, rtac conjI,
39.1155 + CONJ_WRAP' (K (rtac @{thm ord_le_eq_trans[OF subset_UNIV UNIV_Times_UNIV[THEN sym]]})) ks,
39.1156 + CONJ_WRAP' (fn i => EVERY' [select_prem_tac n (dtac asm_rl) i, REPEAT_DETERM o rtac allI,
39.1157 + rtac impI, REPEAT_DETERM o dtac @{thm meta_spec}, etac CollectE, etac @{thm meta_impE},
39.1158 + atac, etac exE, etac conjE, etac conjE, rtac bexI, rtac conjI,
39.1159 + etac @{thm fst_conv[THEN subst]}, etac @{thm snd_conv[THEN subst]},
39.1160 + rtac CollectI, REPEAT_DETERM_N m o (rtac conjI THEN' rtac subset_UNIV),
39.1161 + CONJ_WRAP' (fn i' => EVERY' [rtac subsetI, rtac CollectI, dtac (mk_conjunctN n i'),
39.1162 + REPEAT_DETERM o etac allE, etac mp, rtac @{thm ssubst_mem[OF pair_collapse]}, atac])
39.1163 + ks])
39.1164 + ks,
39.1165 + rtac impI,
39.1166 + CONJ_WRAP' (fn i => EVERY' [rtac impI, dtac (mk_conjunctN n i),
39.1167 + rtac @{thm subst[OF pair_in_Id_conv]}, etac set_mp,
39.1168 + rtac CollectI, etac (refl RSN (2, @{thm subst_Pair}))]) ks] 1
39.1169 + end;
39.1170 +
39.1171 +fun mk_dtor_strong_coinduct_tac ks cTs cts dtor_coinduct bis_def bis_diag =
39.1172 + EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts dtor_coinduct),
39.1173 + EVERY' (map (fn i =>
39.1174 + EVERY' [etac disjE, REPEAT_DETERM o dtac @{thm meta_spec}, etac @{thm meta_mp},
39.1175 + atac, rtac rev_mp, rtac subst, rtac bis_def, rtac bis_diag,
39.1176 + rtac impI, dtac conjunct2, dtac (mk_conjunctN (length ks) i), REPEAT_DETERM o etac allE,
39.1177 + etac impE, etac @{thm diag_UNIV_I}, REPEAT_DETERM o eresolve_tac [bexE, conjE, CollectE],
39.1178 + rtac exI, rtac conjI, etac conjI, atac,
39.1179 + CONJ_WRAP' (K (EVERY' [REPEAT_DETERM o resolve_tac [allI, impI],
39.1180 + rtac disjI2, rtac @{thm diagE}, etac set_mp, atac])) ks])
39.1181 + ks),
39.1182 + rtac impI, REPEAT_DETERM o etac conjE,
39.1183 + CONJ_WRAP' (K (rtac impI THEN' etac mp THEN' etac disjI1)) ks] 1;
39.1184 +
39.1185 +fun mk_map_tac m n cT unfold map_comp' map_cong =
39.1186 + EVERY' [rtac ext, rtac (o_apply RS trans RS sym), rtac (o_apply RS trans RS sym),
39.1187 + rtac (unfold RS trans), rtac (Thm.permute_prems 0 1 (map_comp' RS box_equals)), rtac map_cong,
39.1188 + REPEAT_DETERM_N m o rtac (@{thm id_o} RS fun_cong),
39.1189 + REPEAT_DETERM_N n o rtac (@{thm o_id} RS fun_cong),
39.1190 + rtac (o_apply RS (Drule.instantiate' [cT] [] arg_cong) RS sym)] 1;
39.1191 +
39.1192 +fun mk_set_le_tac n hset_minimal set_hsets set_hset_hsetss =
39.1193 + EVERY' [rtac hset_minimal,
39.1194 + REPEAT_DETERM_N n o rtac @{thm Un_upper1},
39.1195 + REPEAT_DETERM_N n o
39.1196 + EVERY' (map3 (fn i => fn set_hset => fn set_hset_hsets =>
39.1197 + EVERY' [rtac subsetI, rtac @{thm UnI2}, rtac (mk_UnIN n i), etac @{thm UN_I},
39.1198 + etac UnE, etac set_hset, REPEAT_DETERM_N (n - 1) o etac UnE,
39.1199 + EVERY' (map (fn thm => EVERY' [etac @{thm UN_E}, etac thm, atac]) set_hset_hsets)])
39.1200 + (1 upto n) set_hsets set_hset_hsetss)] 1;
39.1201 +
39.1202 +fun mk_set_simp_tac n set_le set_incl_hset set_hset_incl_hsets =
39.1203 + EVERY' [rtac equalityI, rtac set_le, rtac @{thm Un_least}, rtac set_incl_hset,
39.1204 + REPEAT_DETERM_N (n - 1) o rtac @{thm Un_least},
39.1205 + EVERY' (map (fn thm => rtac @{thm UN_least} THEN' etac thm) set_hset_incl_hsets)] 1;
39.1206 +
39.1207 +fun mk_map_id_tac maps unfold_unique unfold_dtor =
39.1208 + EVERY' [rtac (unfold_unique RS trans), EVERY' (map (fn thm => rtac (thm RS sym)) maps),
39.1209 + rtac unfold_dtor] 1;
39.1210 +
39.1211 +fun mk_map_comp_tac m n maps map_comps map_congs unfold_unique =
39.1212 + EVERY' [rtac unfold_unique,
39.1213 + EVERY' (map3 (fn map_thm => fn map_comp => fn map_cong =>
39.1214 + EVERY' (map rtac
39.1215 + ([@{thm o_assoc} RS trans,
39.1216 + @{thm arg_cong2[of _ _ _ _ "op o"]} OF [map_comp RS sym, refl] RS trans,
39.1217 + @{thm o_assoc} RS trans RS sym,
39.1218 + @{thm arg_cong2[of _ _ _ _ "op o"]} OF [map_thm, refl] RS trans,
39.1219 + @{thm o_assoc} RS sym RS trans, map_thm RS arg_cong RS trans, @{thm o_assoc} RS trans,
39.1220 + @{thm arg_cong2[of _ _ _ _ "op o"]} OF [map_comp RS sym, refl] RS trans,
39.1221 + ext, o_apply RS trans, o_apply RS trans RS sym, map_cong] @
39.1222 + replicate m (@{thm id_o} RS fun_cong) @
39.1223 + replicate n (@{thm o_id} RS fun_cong))))
39.1224 + maps map_comps map_congs)] 1;
39.1225 +
39.1226 +fun mk_mcong_tac m coinduct_tac map_comp's map_simps map_congs set_naturalss set_hsetss
39.1227 + set_hset_hsetsss =
39.1228 + let
39.1229 + val n = length map_comp's;
39.1230 + val ks = 1 upto n;
39.1231 + in
39.1232 + EVERY' ([rtac rev_mp,
39.1233 + coinduct_tac] @
39.1234 + maps (fn (((((map_comp'_trans, map_simps_trans), map_cong), set_naturals), set_hsets),
39.1235 + set_hset_hsetss) =>
39.1236 + [REPEAT_DETERM o eresolve_tac [exE, conjE], hyp_subst_tac, rtac exI, rtac conjI, rtac conjI,
39.1237 + rtac map_comp'_trans, rtac sym, rtac map_simps_trans, rtac map_cong,
39.1238 + REPEAT_DETERM_N m o (rtac o_apply_trans_sym THEN' rtac @{thm id_apply}),
39.1239 + REPEAT_DETERM_N n o rtac fst_convol_fun_cong_sym,
39.1240 + rtac map_comp'_trans, rtac sym, rtac map_simps_trans, rtac map_cong,
39.1241 + EVERY' (maps (fn set_hset =>
39.1242 + [rtac o_apply_trans_sym, rtac (@{thm id_apply} RS trans), etac CollectE,
39.1243 + REPEAT_DETERM o etac conjE, etac bspec, etac set_hset]) set_hsets),
39.1244 + REPEAT_DETERM_N n o rtac snd_convol_fun_cong_sym,
39.1245 + CONJ_WRAP' (fn (set_natural, set_hset_hsets) =>
39.1246 + EVERY' [REPEAT_DETERM o rtac allI, rtac impI, rtac @{thm image_convolD},
39.1247 + etac set_rev_mp, rtac ord_eq_le_trans, rtac set_natural,
39.1248 + rtac @{thm image_mono}, rtac subsetI, rtac CollectI, etac CollectE,
39.1249 + REPEAT_DETERM o etac conjE,
39.1250 + CONJ_WRAP' (fn set_hset_hset =>
39.1251 + EVERY' [rtac ballI, etac bspec, etac set_hset_hset, atac]) set_hset_hsets])
39.1252 + (drop m set_naturals ~~ set_hset_hsetss)])
39.1253 + (map (fn th => th RS trans) map_comp's ~~ map (fn th => th RS trans) map_simps ~~
39.1254 + map_congs ~~ set_naturalss ~~ set_hsetss ~~ set_hset_hsetsss) @
39.1255 + [rtac impI,
39.1256 + CONJ_WRAP' (fn k =>
39.1257 + EVERY' [rtac impI, dtac (mk_conjunctN n k), etac mp, rtac exI, rtac conjI, etac CollectI,
39.1258 + rtac conjI, rtac refl, rtac refl]) ks]) 1
39.1259 + end
39.1260 +
39.1261 +fun mk_map_unique_tac unfold_unique map_comps {context = ctxt, prems = _} =
39.1262 + rtac unfold_unique 1 THEN
39.1263 + unfold_thms_tac ctxt (map (fn thm => thm RS sym) map_comps @ @{thms o_assoc id_o o_id}) THEN
39.1264 + ALLGOALS (etac sym);
39.1265 +
39.1266 +fun mk_col_natural_tac cts rec_0s rec_Sucs map_simps set_naturalss
39.1267 + {context = ctxt, prems = _} =
39.1268 + let
39.1269 + val n = length map_simps;
39.1270 + in
39.1271 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.1272 + REPEAT_DETERM o rtac allI, SELECT_GOAL (unfold_thms_tac ctxt rec_0s),
39.1273 + CONJ_WRAP' (K (rtac @{thm image_empty})) rec_0s,
39.1274 + REPEAT_DETERM o rtac allI,
39.1275 + CONJ_WRAP' (fn (rec_Suc, (map_simp, set_nats)) => EVERY'
39.1276 + [SELECT_GOAL (unfold_thms_tac ctxt
39.1277 + (rec_Suc :: map_simp :: set_nats @ @{thms image_Un image_UN UN_simps(10)})),
39.1278 + rtac @{thm Un_cong}, rtac refl,
39.1279 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_cong}))
39.1280 + (fn i => EVERY' [rtac @{thm UN_cong[OF refl]},
39.1281 + REPEAT_DETERM o etac allE, etac (mk_conjunctN n i)]) (n downto 1)])
39.1282 + (rec_Sucs ~~ (map_simps ~~ set_naturalss))] 1
39.1283 + end;
39.1284 +
39.1285 +fun mk_set_natural_tac hset_def col_natural =
39.1286 + EVERY' (map rtac [ext, (o_apply RS trans), (hset_def RS trans), sym,
39.1287 + (o_apply RS trans), (@{thm image_cong} OF [hset_def, refl] RS trans),
39.1288 + (@{thm image_UN} RS trans), (refl RS @{thm UN_cong}), col_natural]) 1;
39.1289 +
39.1290 +fun mk_col_bd_tac m j cts rec_0s rec_Sucs sbd_Card_order sbd_Cinfinite set_sbdss =
39.1291 + let
39.1292 + val n = length rec_0s;
39.1293 + in
39.1294 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.1295 + REPEAT_DETERM o rtac allI,
39.1296 + CONJ_WRAP' (fn rec_0 => EVERY' (map rtac [ordIso_ordLeq_trans,
39.1297 + @{thm card_of_ordIso_subst}, rec_0, @{thm Card_order_empty}, sbd_Card_order])) rec_0s,
39.1298 + REPEAT_DETERM o rtac allI,
39.1299 + CONJ_WRAP' (fn (rec_Suc, set_sbds) => EVERY'
39.1300 + [rtac ordIso_ordLeq_trans, rtac @{thm card_of_ordIso_subst}, rtac rec_Suc,
39.1301 + rtac (sbd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})), rtac (nth set_sbds (j - 1)),
39.1302 + REPEAT_DETERM_N (n - 1) o rtac (sbd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})),
39.1303 + EVERY' (map2 (fn i => fn set_sbd => EVERY' [rtac @{thm UNION_Cinfinite_bound},
39.1304 + rtac set_sbd, rtac ballI, REPEAT_DETERM o etac allE,
39.1305 + etac (mk_conjunctN n i), rtac sbd_Cinfinite]) (1 upto n) (drop m set_sbds))])
39.1306 + (rec_Sucs ~~ set_sbdss)] 1
39.1307 + end;
39.1308 +
39.1309 +fun mk_set_bd_tac sbd_Cinfinite hset_def col_bd =
39.1310 + EVERY' (map rtac [ordIso_ordLeq_trans, @{thm card_of_ordIso_subst}, hset_def,
39.1311 + ctrans, @{thm UNION_Cinfinite_bound}, ordIso_ordLeq_trans, @{thm card_of_nat},
39.1312 + @{thm natLeq_ordLeq_cinfinite}, sbd_Cinfinite, ballI, col_bd, sbd_Cinfinite,
39.1313 + ctrans, @{thm infinite_ordLeq_cexp}, sbd_Cinfinite, @{thm cexp_ordLeq_ccexp}]) 1;
39.1314 +
39.1315 +fun mk_in_bd_tac isNode_hset isNode_hsets carT_def card_of_carT mor_image Rep_inverse mor_hsets
39.1316 + sbd_Cnotzero sbd_Card_order mor_Rep coalgT mor_T_final tcoalg =
39.1317 + let
39.1318 + val n = length isNode_hsets;
39.1319 + val in_hin_tac = rtac CollectI THEN'
39.1320 + CONJ_WRAP' (fn mor_hset => EVERY' (map etac
39.1321 + [mor_hset OF [coalgT, mor_T_final] RS sym RS ord_eq_le_trans,
39.1322 + arg_cong RS sym RS ord_eq_le_trans,
39.1323 + mor_hset OF [tcoalg, mor_Rep, UNIV_I] RS ord_eq_le_trans])) mor_hsets;
39.1324 + in
39.1325 + EVERY' [rtac (Thm.permute_prems 0 1 @{thm ordLeq_transitive}), rtac ctrans,
39.1326 + rtac @{thm card_of_image}, rtac ordIso_ordLeq_trans,
39.1327 + rtac @{thm card_of_ordIso_subst}, rtac @{thm sym[OF proj_image]}, rtac ctrans,
39.1328 + rtac @{thm card_of_image}, rtac ctrans, rtac card_of_carT, rtac @{thm cexp_mono2_Cnotzero},
39.1329 + rtac @{thm cexp_ordLeq_ccexp}, rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
39.1330 + rtac @{thm Cnotzero_cexp}, rtac sbd_Cnotzero, rtac sbd_Card_order,
39.1331 + rtac @{thm card_of_mono1}, rtac subsetI, rtac @{thm image_eqI}, rtac sym,
39.1332 + rtac Rep_inverse, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
39.1333 + rtac set_mp, rtac equalityD2, rtac @{thm sym[OF proj_image]}, rtac imageE,
39.1334 + rtac set_rev_mp, rtac mor_image, rtac mor_Rep, rtac UNIV_I, rtac equalityD2,
39.1335 + rtac @{thm proj_image}, rtac @{thm image_eqI}, atac,
39.1336 + ftac (carT_def RS equalityD1 RS set_mp),
39.1337 + REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
39.1338 + rtac (carT_def RS equalityD2 RS set_mp), rtac CollectI, REPEAT_DETERM o rtac exI,
39.1339 + rtac conjI, rtac refl, rtac conjI, etac conjI, etac conjI, etac conjI, rtac conjI,
39.1340 + rtac ballI, dtac bspec, atac, REPEAT_DETERM o etac conjE, rtac conjI,
39.1341 + CONJ_WRAP_GEN' (etac disjE) (fn (i, isNode_hset) =>
39.1342 + EVERY' [rtac (mk_disjIN n i), rtac isNode_hset, atac, atac, atac, in_hin_tac])
39.1343 + (1 upto n ~~ isNode_hsets),
39.1344 + CONJ_WRAP' (fn isNode_hset =>
39.1345 + EVERY' [rtac ballI, rtac isNode_hset, atac, ftac CollectD, etac @{thm SuccD},
39.1346 + etac bspec, atac, in_hin_tac])
39.1347 + isNode_hsets,
39.1348 + atac, rtac isNode_hset, atac, atac, atac, in_hin_tac] 1
39.1349 + end;
39.1350 +
39.1351 +fun mk_bd_card_order_tac sbd_card_order =
39.1352 + EVERY' (map rtac [@{thm card_order_ccexp}, sbd_card_order, sbd_card_order]) 1;
39.1353 +
39.1354 +fun mk_bd_cinfinite_tac sbd_Cinfinite =
39.1355 + EVERY' (map rtac [@{thm cinfinite_ccexp}, @{thm ctwo_ordLeq_Cinfinite},
39.1356 + sbd_Cinfinite, sbd_Cinfinite]) 1;
39.1357 +
39.1358 +fun mk_pickWP_assms_tac set_incl_hsets set_incl_hins map_eq =
39.1359 + let
39.1360 + val m = length set_incl_hsets;
39.1361 + in
39.1362 + EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
39.1363 + EVERY' (map (fn thm => rtac conjI THEN' etac (thm RS @{thm subset_trans})) set_incl_hsets),
39.1364 + CONJ_WRAP' (fn thm => rtac thm THEN' REPEAT_DETERM_N m o atac) set_incl_hins,
39.1365 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
39.1366 + EVERY' (map (fn thm => rtac conjI THEN' etac (thm RS @{thm subset_trans})) set_incl_hsets),
39.1367 + CONJ_WRAP' (fn thm => rtac thm THEN' REPEAT_DETERM_N m o atac) set_incl_hins,
39.1368 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], etac map_eq]
39.1369 + end;
39.1370 +
39.1371 +fun mk_coalg_thePull_tac m coalg_def map_wpulls set_naturalss pickWP_assms_tacs
39.1372 + {context = ctxt, prems = _} =
39.1373 + unfold_thms_tac ctxt [coalg_def] THEN
39.1374 + CONJ_WRAP' (fn (map_wpull, (pickWP_assms_tac, set_naturals)) =>
39.1375 + EVERY' [rtac ballI, dtac @{thm set_mp[OF equalityD1[OF thePull_def]]},
39.1376 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}],
39.1377 + hyp_subst_tac, rtac rev_mp, rtac (map_wpull RS @{thm pickWP(1)}),
39.1378 + EVERY' (map (etac o mk_conjunctN m) (1 upto m)),
39.1379 + pickWP_assms_tac,
39.1380 + SELECT_GOAL (unfold_thms_tac ctxt @{thms o_apply prod.cases}), rtac impI,
39.1381 + REPEAT_DETERM o eresolve_tac [CollectE, conjE],
39.1382 + rtac CollectI,
39.1383 + REPEAT_DETERM_N m o (rtac conjI THEN' rtac subset_UNIV),
39.1384 + CONJ_WRAP' (fn set_natural =>
39.1385 + EVERY' [rtac ord_eq_le_trans, rtac trans, rtac set_natural,
39.1386 + rtac trans_fun_cong_image_id_id_apply, atac])
39.1387 + (drop m set_naturals)])
39.1388 + (map_wpulls ~~ (pickWP_assms_tacs ~~ set_naturalss)) 1;
39.1389 +
39.1390 +fun mk_mor_thePull_nth_tac conv pick m mor_def map_wpulls map_comps pickWP_assms_tacs
39.1391 + {context = ctxt, prems = _} =
39.1392 + let
39.1393 + val n = length map_comps;
39.1394 + in
39.1395 + unfold_thms_tac ctxt [mor_def] THEN
39.1396 + EVERY' [rtac conjI,
39.1397 + CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) (1 upto n),
39.1398 + CONJ_WRAP' (fn (map_wpull, (pickWP_assms_tac, map_comp)) =>
39.1399 + EVERY' [rtac ballI, dtac @{thm set_mp[OF equalityD1[OF thePull_def]]},
39.1400 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}, conjE],
39.1401 + hyp_subst_tac,
39.1402 + SELECT_GOAL (unfold_thms_tac ctxt @{thms o_apply prod.cases}),
39.1403 + rtac (map_comp RS trans),
39.1404 + SELECT_GOAL (unfold_thms_tac ctxt (conv :: @{thms o_id id_o})),
39.1405 + rtac (map_wpull RS pick), REPEAT_DETERM_N m o atac,
39.1406 + pickWP_assms_tac])
39.1407 + (map_wpulls ~~ (pickWP_assms_tacs ~~ map_comps))] 1
39.1408 + end;
39.1409 +
39.1410 +val mk_mor_thePull_fst_tac = mk_mor_thePull_nth_tac @{thm fst_conv} @{thm pickWP(2)};
39.1411 +val mk_mor_thePull_snd_tac = mk_mor_thePull_nth_tac @{thm snd_conv} @{thm pickWP(3)};
39.1412 +
39.1413 +fun mk_mor_thePull_pick_tac mor_def unfolds map_comps {context = ctxt, prems = _} =
39.1414 + unfold_thms_tac ctxt [mor_def, @{thm thePull_def}] THEN rtac conjI 1 THEN
39.1415 + CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) unfolds 1 THEN
39.1416 + CONJ_WRAP' (fn (unfold, map_comp) =>
39.1417 + EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}, conjE],
39.1418 + hyp_subst_tac,
39.1419 + SELECT_GOAL (unfold_thms_tac ctxt (unfold :: map_comp :: @{thms comp_def id_def})),
39.1420 + rtac refl])
39.1421 + (unfolds ~~ map_comps) 1;
39.1422 +
39.1423 +fun mk_pick_col_tac m j cts rec_0s rec_Sucs unfolds set_naturalss map_wpulls pickWP_assms_tacs
39.1424 + {context = ctxt, prems = _} =
39.1425 + let
39.1426 + val n = length rec_0s;
39.1427 + val ks = n downto 1;
39.1428 + in
39.1429 + EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
39.1430 + REPEAT_DETERM o rtac allI,
39.1431 + CONJ_WRAP' (fn thm => EVERY'
39.1432 + [rtac impI, rtac ord_eq_le_trans, rtac thm, rtac @{thm empty_subsetI}]) rec_0s,
39.1433 + REPEAT_DETERM o rtac allI,
39.1434 + CONJ_WRAP' (fn (rec_Suc, ((unfold, set_naturals), (map_wpull, pickWP_assms_tac))) =>
39.1435 + EVERY' [rtac impI, dtac @{thm set_mp[OF equalityD1[OF thePull_def]]},
39.1436 + REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}],
39.1437 + hyp_subst_tac, rtac rev_mp, rtac (map_wpull RS @{thm pickWP(1)}),
39.1438 + EVERY' (map (etac o mk_conjunctN m) (1 upto m)),
39.1439 + pickWP_assms_tac,
39.1440 + rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
39.1441 + rtac ord_eq_le_trans, rtac rec_Suc,
39.1442 + rtac @{thm Un_least},
39.1443 + SELECT_GOAL (unfold_thms_tac ctxt [unfold, nth set_naturals (j - 1),
39.1444 + @{thm prod.cases}]),
39.1445 + etac ord_eq_le_trans_trans_fun_cong_image_id_id_apply,
39.1446 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least})) (fn (i, set_natural) =>
39.1447 + EVERY' [rtac @{thm UN_least},
39.1448 + SELECT_GOAL (unfold_thms_tac ctxt [unfold, set_natural, @{thm prod.cases}]),
39.1449 + etac imageE, hyp_subst_tac, REPEAT_DETERM o etac allE,
39.1450 + dtac (mk_conjunctN n i), etac mp, etac set_mp, atac])
39.1451 + (ks ~~ rev (drop m set_naturals))])
39.1452 + (rec_Sucs ~~ ((unfolds ~~ set_naturalss) ~~ (map_wpulls ~~ pickWP_assms_tacs)))] 1
39.1453 + end;
39.1454 +
39.1455 +fun mk_wpull_tac m coalg_thePull mor_thePull_fst mor_thePull_snd mor_thePull_pick
39.1456 + mor_unique pick_cols hset_defs =
39.1457 + EVERY' [rtac (@{thm wpull_def} RS iffD2), REPEAT_DETERM o rtac allI, rtac impI,
39.1458 + REPEAT_DETERM o etac conjE, rtac bexI, rtac conjI,
39.1459 + rtac box_equals, rtac mor_unique,
39.1460 + rtac coalg_thePull, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1461 + rtac mor_thePull_pick, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1462 + rtac mor_thePull_fst, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1463 + rtac @{thm set_mp[OF equalityD2[OF thePull_def]]}, rtac CollectI,
39.1464 + rtac @{thm prod_caseI}, etac conjI, etac conjI, atac, rtac o_apply, rtac @{thm fst_conv},
39.1465 + rtac box_equals, rtac mor_unique,
39.1466 + rtac coalg_thePull, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1467 + rtac mor_thePull_pick, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1468 + rtac mor_thePull_snd, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1469 + rtac @{thm set_mp[OF equalityD2[OF thePull_def]]}, rtac CollectI,
39.1470 + rtac @{thm prod_caseI}, etac conjI, etac conjI, atac, rtac o_apply, rtac @{thm snd_conv},
39.1471 + rtac CollectI,
39.1472 + CONJ_WRAP' (fn (pick, def) =>
39.1473 + EVERY' [rtac (def RS ord_eq_le_trans), rtac @{thm UN_least},
39.1474 + rtac pick, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
39.1475 + rtac @{thm set_mp[OF equalityD2[OF thePull_def]]}, rtac CollectI,
39.1476 + rtac @{thm prod_caseI}, etac conjI, etac conjI, atac])
39.1477 + (pick_cols ~~ hset_defs)] 1;
39.1478 +
39.1479 +fun mk_wit_tac n dtor_ctors set_simp wit coind_wits {context = ctxt, prems = _} =
39.1480 + ALLGOALS (TRY o (eresolve_tac coind_wits THEN' rtac refl)) THEN
39.1481 + REPEAT_DETERM (atac 1 ORELSE
39.1482 + EVERY' [dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
39.1483 + K (unfold_thms_tac ctxt dtor_ctors),
39.1484 + REPEAT_DETERM_N n o etac UnE,
39.1485 + REPEAT_DETERM o
39.1486 + (TRY o REPEAT_DETERM o etac UnE THEN' TRY o etac @{thm UN_E} THEN'
39.1487 + (eresolve_tac wit ORELSE'
39.1488 + (dresolve_tac wit THEN'
39.1489 + (etac FalseE ORELSE'
39.1490 + EVERY' [hyp_subst_tac, dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
39.1491 + K (unfold_thms_tac ctxt dtor_ctors), REPEAT_DETERM_N n o etac UnE]))))] 1);
39.1492 +
39.1493 +fun mk_coind_wit_tac induct unfolds set_nats wits {context = ctxt, prems = _} =
39.1494 + rtac induct 1 THEN ALLGOALS (TRY o rtac impI THEN' TRY o hyp_subst_tac) THEN
39.1495 + unfold_thms_tac ctxt (unfolds @ set_nats @ @{thms image_id id_apply}) THEN
39.1496 + ALLGOALS (REPEAT_DETERM o etac imageE THEN' TRY o hyp_subst_tac) THEN
39.1497 + ALLGOALS (TRY o
39.1498 + FIRST' [rtac TrueI, rtac refl, etac (refl RSN (2, mp)), dresolve_tac wits THEN' etac FalseE])
39.1499 +
39.1500 +fun mk_srel_simp_tac in_Jsrels i in_srel map_comp map_cong map_simp set_simps dtor_inject dtor_ctor
39.1501 + set_naturals set_incls set_set_inclss =
39.1502 + let
39.1503 + val m = length set_incls;
39.1504 + val n = length set_set_inclss;
39.1505 + val (passive_set_naturals, active_set_naturals) = chop m set_naturals;
39.1506 + val in_Jsrel = nth in_Jsrels (i - 1);
39.1507 + val if_tac =
39.1508 + EVERY' [dtac (in_Jsrel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
39.1509 + rtac (in_srel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
39.1510 + EVERY' (map2 (fn set_natural => fn set_incl =>
39.1511 + EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac set_natural,
39.1512 + rtac ord_eq_le_trans, rtac trans_fun_cong_image_id_id_apply,
39.1513 + etac (set_incl RS @{thm subset_trans})])
39.1514 + passive_set_naturals set_incls),
39.1515 + CONJ_WRAP' (fn (in_Jsrel, (set_natural, set_set_incls)) =>
39.1516 + EVERY' [rtac ord_eq_le_trans, rtac set_natural, rtac @{thm image_subsetI},
39.1517 + rtac (in_Jsrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
39.1518 + CONJ_WRAP' (fn thm => etac (thm RS @{thm subset_trans}) THEN' atac) set_set_incls,
39.1519 + rtac conjI, rtac refl, rtac refl])
39.1520 + (in_Jsrels ~~ (active_set_naturals ~~ set_set_inclss)),
39.1521 + CONJ_WRAP' (fn conv =>
39.1522 + EVERY' [rtac trans, rtac map_comp, rtac trans, rtac map_cong,
39.1523 + REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
39.1524 + REPEAT_DETERM_N n o EVERY' (map rtac [trans, o_apply, conv]),
39.1525 + rtac trans, rtac sym, rtac map_simp, rtac (dtor_inject RS iffD2), atac])
39.1526 + @{thms fst_conv snd_conv}];
39.1527 + val only_if_tac =
39.1528 + EVERY' [dtac (in_srel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
39.1529 + rtac (in_Jsrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
39.1530 + CONJ_WRAP' (fn (set_simp, passive_set_natural) =>
39.1531 + EVERY' [rtac ord_eq_le_trans, rtac set_simp, rtac @{thm Un_least},
39.1532 + rtac ord_eq_le_trans, rtac box_equals, rtac passive_set_natural,
39.1533 + rtac (dtor_ctor RS sym RS arg_cong), rtac trans_fun_cong_image_id_id_apply, atac,
39.1534 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
39.1535 + (fn (active_set_natural, in_Jsrel) => EVERY' [rtac ord_eq_le_trans,
39.1536 + rtac @{thm UN_cong[OF _ refl]}, rtac @{thm box_equals[OF _ _ refl]},
39.1537 + rtac active_set_natural, rtac (dtor_ctor RS sym RS arg_cong), rtac @{thm UN_least},
39.1538 + dtac set_rev_mp, etac @{thm image_mono}, etac imageE,
39.1539 + dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Jsrel RS iffD1),
39.1540 + dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE,
39.1541 + dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac,
39.1542 + hyp_subst_tac, REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac])
39.1543 + (rev (active_set_naturals ~~ in_Jsrels))])
39.1544 + (set_simps ~~ passive_set_naturals),
39.1545 + rtac conjI,
39.1546 + REPEAT_DETERM_N 2 o EVERY'[rtac (dtor_inject RS iffD1), rtac trans, rtac map_simp,
39.1547 + rtac box_equals, rtac map_comp, rtac (dtor_ctor RS sym RS arg_cong), rtac trans,
39.1548 + rtac map_cong, REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
39.1549 + EVERY' (map (fn in_Jsrel => EVERY' [rtac trans, rtac o_apply, dtac set_rev_mp, atac,
39.1550 + dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Jsrel RS iffD1),
39.1551 + dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, atac]) in_Jsrels),
39.1552 + atac]]
39.1553 + in
39.1554 + EVERY' [rtac iffI, if_tac, only_if_tac] 1
39.1555 + end;
39.1556 +
39.1557 +end;
40.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
40.2 +++ b/src/HOL/BNF/Tools/bnf_gfp_util.ML Fri Sep 21 16:45:06 2012 +0200
40.3 @@ -0,0 +1,197 @@
40.4 +(* Title: HOL/BNF/Tools/bnf_gfp_util.ML
40.5 + Author: Dmitriy Traytel, TU Muenchen
40.6 + Copyright 2012
40.7 +
40.8 +Library for the codatatype construction.
40.9 +*)
40.10 +
40.11 +signature BNF_GFP_UTIL =
40.12 +sig
40.13 + val mk_rec_simps: int -> thm -> thm list -> thm list list
40.14 +
40.15 + val dest_listT: typ -> typ
40.16 +
40.17 + val mk_Cons: term -> term -> term
40.18 + val mk_Shift: term -> term -> term
40.19 + val mk_Succ: term -> term -> term
40.20 + val mk_Times: term * term -> term
40.21 + val mk_append: term * term -> term
40.22 + val mk_congruent: term -> term -> term
40.23 + val mk_clists: term -> term
40.24 + val mk_diag: term -> term
40.25 + val mk_equiv: term -> term -> term
40.26 + val mk_fromCard: term -> term -> term
40.27 + val mk_list_rec: term -> term -> term
40.28 + val mk_nat_rec: term -> term -> term
40.29 + val mk_pickWP: term -> term -> term -> term -> term -> term
40.30 + val mk_prefCl: term -> term
40.31 + val mk_proj: term -> term
40.32 + val mk_quotient: term -> term -> term
40.33 + val mk_shift: term -> term -> term
40.34 + val mk_size: term -> term
40.35 + val mk_thePull: term -> term -> term -> term -> term
40.36 + val mk_toCard: term -> term -> term
40.37 + val mk_undefined: typ -> term
40.38 + val mk_univ: term -> term
40.39 +
40.40 + val mk_specN: int -> thm -> thm
40.41 +
40.42 + val mk_InN_Field: int -> int -> thm
40.43 + val mk_InN_inject: int -> int -> thm
40.44 + val mk_InN_not_InM: int -> int -> thm
40.45 +end;
40.46 +
40.47 +structure BNF_GFP_Util : BNF_GFP_UTIL =
40.48 +struct
40.49 +
40.50 +open BNF_Util
40.51 +
40.52 +val mk_append = HOLogic.mk_binop @{const_name append};
40.53 +
40.54 +fun mk_equiv B R =
40.55 + Const (@{const_name equiv}, fastype_of B --> fastype_of R --> HOLogic.boolT) $ B $ R;
40.56 +
40.57 +fun mk_Sigma (A, B) =
40.58 + let
40.59 + val AT = fastype_of A;
40.60 + val BT = fastype_of B;
40.61 + val ABT = mk_relT (HOLogic.dest_setT AT, HOLogic.dest_setT (range_type BT));
40.62 + in Const (@{const_name Sigma}, AT --> BT --> ABT) $ A $ B end;
40.63 +
40.64 +fun mk_diag A =
40.65 + let
40.66 + val AT = fastype_of A;
40.67 + val AAT = mk_relT (HOLogic.dest_setT AT, HOLogic.dest_setT AT);
40.68 + in Const (@{const_name diag}, AT --> AAT) $ A end;
40.69 +
40.70 +fun mk_Times (A, B) =
40.71 + let val AT = HOLogic.dest_setT (fastype_of A);
40.72 + in mk_Sigma (A, Term.absdummy AT B) end;
40.73 +
40.74 +fun dest_listT (Type (@{type_name list}, [T])) = T
40.75 + | dest_listT T = raise TYPE ("dest_setT: set type expected", [T], []);
40.76 +
40.77 +fun mk_Succ Kl kl =
40.78 + let val T = fastype_of kl;
40.79 + in
40.80 + Const (@{const_name Succ},
40.81 + HOLogic.mk_setT T --> T --> HOLogic.mk_setT (dest_listT T)) $ Kl $ kl
40.82 + end;
40.83 +
40.84 +fun mk_Shift Kl k =
40.85 + let val T = fastype_of Kl;
40.86 + in
40.87 + Const (@{const_name Shift}, T --> dest_listT (HOLogic.dest_setT T) --> T) $ Kl $ k
40.88 + end;
40.89 +
40.90 +fun mk_shift lab k =
40.91 + let val T = fastype_of lab;
40.92 + in
40.93 + Const (@{const_name shift}, T --> dest_listT (Term.domain_type T) --> T) $ lab $ k
40.94 + end;
40.95 +
40.96 +fun mk_prefCl A =
40.97 + Const (@{const_name prefCl}, fastype_of A --> HOLogic.boolT) $ A;
40.98 +
40.99 +fun mk_clists r =
40.100 + let val T = fastype_of r;
40.101 + in Const (@{const_name clists}, T --> mk_relT (`I (HOLogic.listT (fst (dest_relT T))))) $ r end;
40.102 +
40.103 +fun mk_toCard A r =
40.104 + let
40.105 + val AT = fastype_of A;
40.106 + val rT = fastype_of r;
40.107 + in
40.108 + Const (@{const_name toCard},
40.109 + AT --> rT --> HOLogic.dest_setT AT --> fst (dest_relT rT)) $ A $ r
40.110 + end;
40.111 +
40.112 +fun mk_fromCard A r =
40.113 + let
40.114 + val AT = fastype_of A;
40.115 + val rT = fastype_of r;
40.116 + in
40.117 + Const (@{const_name fromCard},
40.118 + AT --> rT --> fst (dest_relT rT) --> HOLogic.dest_setT AT) $ A $ r
40.119 + end;
40.120 +
40.121 +fun mk_Cons x xs =
40.122 + let val T = fastype_of xs;
40.123 + in Const (@{const_name Cons}, dest_listT T --> T --> T) $ x $ xs end;
40.124 +
40.125 +fun mk_size t = HOLogic.size_const (fastype_of t) $ t;
40.126 +
40.127 +fun mk_quotient A R =
40.128 + let val T = fastype_of A;
40.129 + in Const (@{const_name quotient}, T --> fastype_of R --> HOLogic.mk_setT T) $ A $ R end;
40.130 +
40.131 +fun mk_proj R =
40.132 + let val ((AT, BT), T) = `dest_relT (fastype_of R);
40.133 + in Const (@{const_name proj}, T --> AT --> HOLogic.mk_setT BT) $ R end;
40.134 +
40.135 +fun mk_univ f =
40.136 + let val ((AT, BT), T) = `dest_funT (fastype_of f);
40.137 + in Const (@{const_name univ}, T --> HOLogic.mk_setT AT --> BT) $ f end;
40.138 +
40.139 +fun mk_congruent R f =
40.140 + Const (@{const_name congruent}, fastype_of R --> fastype_of f --> HOLogic.boolT) $ R $ f;
40.141 +
40.142 +fun mk_undefined T = Const (@{const_name undefined}, T);
40.143 +
40.144 +fun mk_nat_rec Zero Suc =
40.145 + let val T = fastype_of Zero;
40.146 + in Const (@{const_name nat_rec}, T --> fastype_of Suc --> HOLogic.natT --> T) $ Zero $ Suc end;
40.147 +
40.148 +fun mk_list_rec Nil Cons =
40.149 + let
40.150 + val T = fastype_of Nil;
40.151 + val (U, consT) = `(Term.domain_type) (fastype_of Cons);
40.152 + in
40.153 + Const (@{const_name list_rec}, T --> consT --> HOLogic.listT U --> T) $ Nil $ Cons
40.154 + end;
40.155 +
40.156 +fun mk_thePull B1 B2 f1 f2 =
40.157 + let
40.158 + val fT1 = fastype_of f1;
40.159 + val fT2 = fastype_of f2;
40.160 + val BT1 = domain_type fT1;
40.161 + val BT2 = domain_type fT2;
40.162 + in
40.163 + Const (@{const_name thePull}, HOLogic.mk_setT BT1 --> HOLogic.mk_setT BT2 --> fT1 --> fT2 -->
40.164 + mk_relT (BT1, BT2)) $ B1 $ B2 $ f1 $ f2
40.165 + end;
40.166 +
40.167 +fun mk_pickWP A f1 f2 b1 b2 =
40.168 + let
40.169 + val fT1 = fastype_of f1;
40.170 + val fT2 = fastype_of f2;
40.171 + val AT = domain_type fT1;
40.172 + val BT1 = range_type fT1;
40.173 + val BT2 = range_type fT2;
40.174 + in
40.175 + Const (@{const_name pickWP}, HOLogic.mk_setT AT --> fT1 --> fT2 --> BT1 --> BT2 --> AT) $
40.176 + A $ f1 $ f2 $ b1 $ b2
40.177 + end;
40.178 +
40.179 +fun mk_InN_not_InM 1 _ = @{thm Inl_not_Inr}
40.180 + | mk_InN_not_InM n m =
40.181 + if n > m then mk_InN_not_InM m n RS @{thm not_sym}
40.182 + else mk_InN_not_InM (n - 1) (m - 1) RS @{thm not_arg_cong_Inr};
40.183 +
40.184 +fun mk_InN_Field 1 1 = @{thm TrueE[OF TrueI]}
40.185 + | mk_InN_Field _ 1 = @{thm Inl_Field_csum}
40.186 + | mk_InN_Field 2 2 = @{thm Inr_Field_csum}
40.187 + | mk_InN_Field n m = mk_InN_Field (n - 1) (m - 1) RS @{thm Inr_Field_csum};
40.188 +
40.189 +fun mk_InN_inject 1 _ = @{thm TrueE[OF TrueI]}
40.190 + | mk_InN_inject _ 1 = @{thm Inl_inject}
40.191 + | mk_InN_inject 2 2 = @{thm Inr_inject}
40.192 + | mk_InN_inject n m = @{thm Inr_inject} RS mk_InN_inject (n - 1) (m - 1);
40.193 +
40.194 +fun mk_specN 0 thm = thm
40.195 + | mk_specN n thm = mk_specN (n - 1) (thm RS spec);
40.196 +
40.197 +fun mk_rec_simps n rec_thm defs = map (fn i =>
40.198 + map (fn def => def RS rec_thm RS mk_nthI n i RS fun_cong) defs) (1 upto n);
40.199 +
40.200 +end;
41.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
41.2 +++ b/src/HOL/BNF/Tools/bnf_lfp.ML Fri Sep 21 16:45:06 2012 +0200
41.3 @@ -0,0 +1,1838 @@
41.4 +(* Title: HOL/BNF/Tools/bnf_lfp.ML
41.5 + Author: Dmitriy Traytel, TU Muenchen
41.6 + Author: Andrei Popescu, TU Muenchen
41.7 + Copyright 2012
41.8 +
41.9 +Datatype construction.
41.10 +*)
41.11 +
41.12 +signature BNF_LFP =
41.13 +sig
41.14 + val bnf_lfp: mixfix list -> (string * sort) list option -> binding list ->
41.15 + typ list * typ list list -> BNF_Def.BNF list -> local_theory ->
41.16 + (term list * term list * term list * term list * thm * thm list * thm list * thm list *
41.17 + thm list * thm list) * local_theory
41.18 +end;
41.19 +
41.20 +structure BNF_LFP : BNF_LFP =
41.21 +struct
41.22 +
41.23 +open BNF_Def
41.24 +open BNF_Util
41.25 +open BNF_Tactics
41.26 +open BNF_FP
41.27 +open BNF_FP_Sugar
41.28 +open BNF_LFP_Util
41.29 +open BNF_LFP_Tactics
41.30 +
41.31 +(*all BNFs have the same lives*)
41.32 +fun bnf_lfp mixfixes resBs bs (resDs, Dss) bnfs lthy =
41.33 + let
41.34 + val timer = time (Timer.startRealTimer ());
41.35 + val live = live_of_bnf (hd bnfs);
41.36 + val n = length bnfs; (*active*)
41.37 + val ks = 1 upto n;
41.38 + val m = live - n; (*passive, if 0 don't generate a new BNF*)
41.39 + val b = Binding.name (mk_common_name (map Binding.name_of bs));
41.40 +
41.41 + (* TODO: check if m, n, etc., are sane *)
41.42 +
41.43 + val deads = fold (union (op =)) Dss resDs;
41.44 + val names_lthy = fold Variable.declare_typ deads lthy;
41.45 +
41.46 + (* tvars *)
41.47 + val (((((((passiveAs, activeAs), allAs)), (passiveBs, activeBs)),
41.48 + activeCs), passiveXs), passiveYs) = names_lthy
41.49 + |> mk_TFrees live
41.50 + |> apfst (`(chop m))
41.51 + ||> mk_TFrees live
41.52 + ||>> apfst (chop m)
41.53 + ||>> mk_TFrees n
41.54 + ||>> mk_TFrees m
41.55 + ||> fst o mk_TFrees m;
41.56 +
41.57 + val Ass = replicate n allAs;
41.58 + val allBs = passiveAs @ activeBs;
41.59 + val Bss = replicate n allBs;
41.60 + val allCs = passiveAs @ activeCs;
41.61 + val allCs' = passiveBs @ activeCs;
41.62 + val Css' = replicate n allCs';
41.63 +
41.64 + (* typs *)
41.65 + val dead_poss =
41.66 + (case resBs of
41.67 + NONE => map SOME deads @ replicate m NONE
41.68 + | SOME Ts => map (fn T => if member (op =) deads (TFree T) then SOME (TFree T) else NONE) Ts);
41.69 + fun mk_param NONE passive = (hd passive, tl passive)
41.70 + | mk_param (SOME a) passive = (a, passive);
41.71 + val mk_params = fold_map mk_param dead_poss #> fst;
41.72 +
41.73 + fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
41.74 + val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
41.75 + val FTsAs = mk_FTs allAs;
41.76 + val FTsBs = mk_FTs allBs;
41.77 + val FTsCs = mk_FTs allCs;
41.78 + val ATs = map HOLogic.mk_setT passiveAs;
41.79 + val BTs = map HOLogic.mk_setT activeAs;
41.80 + val B'Ts = map HOLogic.mk_setT activeBs;
41.81 + val B''Ts = map HOLogic.mk_setT activeCs;
41.82 + val sTs = map2 (curry (op -->)) FTsAs activeAs;
41.83 + val s'Ts = map2 (curry (op -->)) FTsBs activeBs;
41.84 + val s''Ts = map2 (curry (op -->)) FTsCs activeCs;
41.85 + val fTs = map2 (curry (op -->)) activeAs activeBs;
41.86 + val inv_fTs = map2 (curry (op -->)) activeBs activeAs;
41.87 + val self_fTs = map2 (curry (op -->)) activeAs activeAs;
41.88 + val gTs = map2 (curry (op -->)) activeBs activeCs;
41.89 + val all_gTs = map2 (curry (op -->)) allBs allCs';
41.90 + val prodBsAs = map2 (curry HOLogic.mk_prodT) activeBs activeAs;
41.91 + val prodFTs = mk_FTs (passiveAs @ prodBsAs);
41.92 + val prod_sTs = map2 (curry (op -->)) prodFTs activeAs;
41.93 +
41.94 + (* terms *)
41.95 + val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
41.96 + val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
41.97 + val mapsBsAs = map4 mk_map_of_bnf Dss Bss Ass bnfs;
41.98 + val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
41.99 + val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
41.100 + val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ prodBsAs)) Bss bnfs;
41.101 + val map_fsts_rev = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ prodBsAs)) bnfs;
41.102 + fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
41.103 + (map (replicate live) (replicate n Ts)) bnfs;
41.104 + val setssAs = mk_setss allAs;
41.105 + val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
41.106 + val witss = map wits_of_bnf bnfs;
41.107 +
41.108 + val (((((((((((((((((((zs, zs'), As), Bs), Bs_copy), B's), B''s), ss), prod_ss), s's), s''s),
41.109 + fs), fs_copy), inv_fs), self_fs), gs), all_gs), (xFs, xFs')), (yFs, yFs')),
41.110 + names_lthy) = lthy
41.111 + |> mk_Frees' "z" activeAs
41.112 + ||>> mk_Frees "A" ATs
41.113 + ||>> mk_Frees "B" BTs
41.114 + ||>> mk_Frees "B" BTs
41.115 + ||>> mk_Frees "B'" B'Ts
41.116 + ||>> mk_Frees "B''" B''Ts
41.117 + ||>> mk_Frees "s" sTs
41.118 + ||>> mk_Frees "prods" prod_sTs
41.119 + ||>> mk_Frees "s'" s'Ts
41.120 + ||>> mk_Frees "s''" s''Ts
41.121 + ||>> mk_Frees "f" fTs
41.122 + ||>> mk_Frees "f" fTs
41.123 + ||>> mk_Frees "f" inv_fTs
41.124 + ||>> mk_Frees "f" self_fTs
41.125 + ||>> mk_Frees "g" gTs
41.126 + ||>> mk_Frees "g" all_gTs
41.127 + ||>> mk_Frees' "x" FTsAs
41.128 + ||>> mk_Frees' "y" FTsBs;
41.129 +
41.130 + val passive_UNIVs = map HOLogic.mk_UNIV passiveAs;
41.131 + val active_UNIVs = map HOLogic.mk_UNIV activeAs;
41.132 + val prod_UNIVs = map HOLogic.mk_UNIV prodBsAs;
41.133 + val passive_ids = map HOLogic.id_const passiveAs;
41.134 + val active_ids = map HOLogic.id_const activeAs;
41.135 + val fsts = map fst_const prodBsAs;
41.136 +
41.137 + (* thms *)
41.138 + val bd_card_orders = map bd_card_order_of_bnf bnfs;
41.139 + val bd_Card_orders = map bd_Card_order_of_bnf bnfs;
41.140 + val bd_Card_order = hd bd_Card_orders;
41.141 + val bd_Cinfinite = bd_Cinfinite_of_bnf (hd bnfs);
41.142 + val bd_Cnotzeros = map bd_Cnotzero_of_bnf bnfs;
41.143 + val bd_Cnotzero = hd bd_Cnotzeros;
41.144 + val in_bds = map in_bd_of_bnf bnfs;
41.145 + val map_comp's = map map_comp'_of_bnf bnfs;
41.146 + val map_congs = map map_cong_of_bnf bnfs;
41.147 + val map_ids = map map_id_of_bnf bnfs;
41.148 + val map_id's = map map_id'_of_bnf bnfs;
41.149 + val map_wpulls = map map_wpull_of_bnf bnfs;
41.150 + val set_bdss = map set_bd_of_bnf bnfs;
41.151 + val set_natural'ss = map set_natural'_of_bnf bnfs;
41.152 +
41.153 + val timer = time (timer "Extracted terms & thms");
41.154 +
41.155 + (* nonemptiness check *)
41.156 + fun new_wit X wit = subset (op =) (#I wit, (0 upto m - 1) @ map snd X);
41.157 +
41.158 + val all = m upto m + n - 1;
41.159 +
41.160 + fun enrich X = map_filter (fn i =>
41.161 + (case find_first (fn (_, i') => i = i') X of
41.162 + NONE =>
41.163 + (case find_index (new_wit X) (nth witss (i - m)) of
41.164 + ~1 => NONE
41.165 + | j => SOME (j, i))
41.166 + | SOME ji => SOME ji)) all;
41.167 + val reachable = fixpoint (op =) enrich [];
41.168 + val _ = (case subtract (op =) (map snd reachable) all of
41.169 + [] => ()
41.170 + | i :: _ => error ("Cannot define empty datatype " ^ quote (Binding.name_of (nth bs (i - m)))));
41.171 +
41.172 + val wit_thms = flat (map2 (fn bnf => fn (j, _) => nth (wit_thmss_of_bnf bnf) j) bnfs reachable);
41.173 +
41.174 + val timer = time (timer "Checked nonemptiness");
41.175 +
41.176 + (* derived thms *)
41.177 +
41.178 + (*map g1 ... gm g(m+1) ... g(m+n) (map id ... id f(m+1) ... f(m+n) x)=
41.179 + map g1 ... gm (g(m+1) o f(m+1)) ... (g(m+n) o f(m+n)) x*)
41.180 + fun mk_map_comp_id x mapAsBs mapBsCs mapAsCs map_comp =
41.181 + let
41.182 + val lhs = Term.list_comb (mapBsCs, all_gs) $
41.183 + (Term.list_comb (mapAsBs, passive_ids @ fs) $ x);
41.184 + val rhs = Term.list_comb (mapAsCs,
41.185 + take m all_gs @ map HOLogic.mk_comp (drop m all_gs ~~ fs)) $ x;
41.186 + in
41.187 + Skip_Proof.prove lthy [] []
41.188 + (fold_rev Logic.all (x :: fs @ all_gs) (mk_Trueprop_eq (lhs, rhs)))
41.189 + (K (mk_map_comp_id_tac map_comp))
41.190 + |> Thm.close_derivation
41.191 + end;
41.192 +
41.193 + val map_comp_id_thms = map5 mk_map_comp_id xFs mapsAsBs mapsBsCs' mapsAsCs' map_comp's;
41.194 +
41.195 + (*forall a : set(m+1) x. f(m+1) a = a; ...; forall a : set(m+n) x. f(m+n) a = a ==>
41.196 + map id ... id f(m+1) ... f(m+n) x = x*)
41.197 + fun mk_map_congL x mapAsAs sets map_cong map_id' =
41.198 + let
41.199 + fun mk_prem set f z z' = HOLogic.mk_Trueprop
41.200 + (mk_Ball (set $ x) (Term.absfree z' (HOLogic.mk_eq (f $ z, z))));
41.201 + val prems = map4 mk_prem (drop m sets) self_fs zs zs';
41.202 + val goal = mk_Trueprop_eq (Term.list_comb (mapAsAs, passive_ids @ self_fs) $ x, x);
41.203 + in
41.204 + Skip_Proof.prove lthy [] []
41.205 + (fold_rev Logic.all (x :: self_fs) (Logic.list_implies (prems, goal)))
41.206 + (K (mk_map_congL_tac m map_cong map_id'))
41.207 + |> Thm.close_derivation
41.208 + end;
41.209 +
41.210 + val map_congL_thms = map5 mk_map_congL xFs mapsAsAs setssAs map_congs map_id's;
41.211 + val in_mono'_thms = map (fn bnf => in_mono_of_bnf bnf OF (replicate m subset_refl)) bnfs
41.212 + val in_cong'_thms = map (fn bnf => in_cong_of_bnf bnf OF (replicate m refl)) bnfs
41.213 +
41.214 + val timer = time (timer "Derived simple theorems");
41.215 +
41.216 + (* algebra *)
41.217 +
41.218 + val alg_bind = Binding.suffix_name ("_" ^ algN) b;
41.219 + val alg_name = Binding.name_of alg_bind;
41.220 + val alg_def_bind = (Thm.def_binding alg_bind, []);
41.221 +
41.222 + (*forall i = 1 ... n: (\<forall>x \<in> Fi_in A1 .. Am B1 ... Bn. si x \<in> Bi)*)
41.223 + val alg_spec =
41.224 + let
41.225 + val algT = Library.foldr (op -->) (ATs @ BTs @ sTs, HOLogic.boolT);
41.226 +
41.227 + val ins = map3 mk_in (replicate n (As @ Bs)) setssAs FTsAs;
41.228 + fun mk_alg_conjunct B s X x x' =
41.229 + mk_Ball X (Term.absfree x' (HOLogic.mk_mem (s $ x, B)));
41.230 +
41.231 + val lhs = Term.list_comb (Free (alg_name, algT), As @ Bs @ ss);
41.232 + val rhs = Library.foldr1 HOLogic.mk_conj (map5 mk_alg_conjunct Bs ss ins xFs xFs')
41.233 + in
41.234 + mk_Trueprop_eq (lhs, rhs)
41.235 + end;
41.236 +
41.237 + val ((alg_free, (_, alg_def_free)), (lthy, lthy_old)) =
41.238 + lthy
41.239 + |> Specification.definition (SOME (alg_bind, NONE, NoSyn), (alg_def_bind, alg_spec))
41.240 + ||> `Local_Theory.restore;
41.241 +
41.242 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.243 + val alg = fst (Term.dest_Const (Morphism.term phi alg_free));
41.244 + val alg_def = Morphism.thm phi alg_def_free;
41.245 +
41.246 + fun mk_alg As Bs ss =
41.247 + let
41.248 + val args = As @ Bs @ ss;
41.249 + val Ts = map fastype_of args;
41.250 + val algT = Library.foldr (op -->) (Ts, HOLogic.boolT);
41.251 + in
41.252 + Term.list_comb (Const (alg, algT), args)
41.253 + end;
41.254 +
41.255 + val alg_set_thms =
41.256 + let
41.257 + val alg_prem = HOLogic.mk_Trueprop (mk_alg As Bs ss);
41.258 + fun mk_prem x set B = HOLogic.mk_Trueprop (mk_subset (set $ x) B);
41.259 + fun mk_concl s x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (s $ x, B));
41.260 + val premss = map2 ((fn x => fn sets => map2 (mk_prem x) sets (As @ Bs))) xFs setssAs;
41.261 + val concls = map3 mk_concl ss xFs Bs;
41.262 + val goals = map3 (fn x => fn prems => fn concl =>
41.263 + fold_rev Logic.all (x :: As @ Bs @ ss)
41.264 + (Logic.list_implies (alg_prem :: prems, concl))) xFs premss concls;
41.265 + in
41.266 + map (fn goal =>
41.267 + Skip_Proof.prove lthy [] [] goal (K (mk_alg_set_tac alg_def)) |> Thm.close_derivation)
41.268 + goals
41.269 + end;
41.270 +
41.271 + fun mk_talg ATs BTs = mk_alg (map HOLogic.mk_UNIV ATs) (map HOLogic.mk_UNIV BTs);
41.272 +
41.273 + val talg_thm =
41.274 + let
41.275 + val goal = fold_rev Logic.all ss
41.276 + (HOLogic.mk_Trueprop (mk_talg passiveAs activeAs ss))
41.277 + in
41.278 + Skip_Proof.prove lthy [] [] goal
41.279 + (K (stac alg_def 1 THEN CONJ_WRAP (K (EVERY' [rtac ballI, rtac UNIV_I] 1)) ss))
41.280 + |> Thm.close_derivation
41.281 + end;
41.282 +
41.283 + val timer = time (timer "Algebra definition & thms");
41.284 +
41.285 + val alg_not_empty_thms =
41.286 + let
41.287 + val alg_prem =
41.288 + HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
41.289 + val concls = map (HOLogic.mk_Trueprop o mk_not_empty) Bs;
41.290 + val goals =
41.291 + map (fn concl =>
41.292 + fold_rev Logic.all (Bs @ ss) (Logic.mk_implies (alg_prem, concl))) concls;
41.293 + in
41.294 + map2 (fn goal => fn alg_set =>
41.295 + Skip_Proof.prove lthy [] []
41.296 + goal (K (mk_alg_not_empty_tac alg_set alg_set_thms wit_thms))
41.297 + |> Thm.close_derivation)
41.298 + goals alg_set_thms
41.299 + end;
41.300 +
41.301 + val timer = time (timer "Proved nonemptiness");
41.302 +
41.303 + (* morphism *)
41.304 +
41.305 + val mor_bind = Binding.suffix_name ("_" ^ morN) b;
41.306 + val mor_name = Binding.name_of mor_bind;
41.307 + val mor_def_bind = (Thm.def_binding mor_bind, []);
41.308 +
41.309 + (*fbetw) forall i = 1 ... n: (\<forall>x \<in> Bi. f x \<in> B'i)*)
41.310 + (*mor) forall i = 1 ... n: (\<forall>x \<in> Fi_in UNIV ... UNIV B1 ... Bn.
41.311 + f (s1 x) = s1' (Fi_map id ... id f1 ... fn x))*)
41.312 + val mor_spec =
41.313 + let
41.314 + val morT = Library.foldr (op -->) (BTs @ sTs @ B'Ts @ s'Ts @ fTs, HOLogic.boolT);
41.315 +
41.316 + fun mk_fbetw f B1 B2 z z' =
41.317 + mk_Ball B1 (Term.absfree z' (HOLogic.mk_mem (f $ z, B2)));
41.318 + fun mk_mor sets mapAsBs f s s' T x x' =
41.319 + mk_Ball (mk_in (passive_UNIVs @ Bs) sets T)
41.320 + (Term.absfree x' (HOLogic.mk_eq (f $ (s $ x), s' $
41.321 + (Term.list_comb (mapAsBs, passive_ids @ fs) $ x))));
41.322 + val lhs = Term.list_comb (Free (mor_name, morT), Bs @ ss @ B's @ s's @ fs);
41.323 + val rhs = HOLogic.mk_conj
41.324 + (Library.foldr1 HOLogic.mk_conj (map5 mk_fbetw fs Bs B's zs zs'),
41.325 + Library.foldr1 HOLogic.mk_conj
41.326 + (map8 mk_mor setssAs mapsAsBs fs ss s's FTsAs xFs xFs'))
41.327 + in
41.328 + mk_Trueprop_eq (lhs, rhs)
41.329 + end;
41.330 +
41.331 + val ((mor_free, (_, mor_def_free)), (lthy, lthy_old)) =
41.332 + lthy
41.333 + |> Specification.definition (SOME (mor_bind, NONE, NoSyn), (mor_def_bind, mor_spec))
41.334 + ||> `Local_Theory.restore;
41.335 +
41.336 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.337 + val mor = fst (Term.dest_Const (Morphism.term phi mor_free));
41.338 + val mor_def = Morphism.thm phi mor_def_free;
41.339 +
41.340 + fun mk_mor Bs1 ss1 Bs2 ss2 fs =
41.341 + let
41.342 + val args = Bs1 @ ss1 @ Bs2 @ ss2 @ fs;
41.343 + val Ts = map fastype_of (Bs1 @ ss1 @ Bs2 @ ss2 @ fs);
41.344 + val morT = Library.foldr (op -->) (Ts, HOLogic.boolT);
41.345 + in
41.346 + Term.list_comb (Const (mor, morT), args)
41.347 + end;
41.348 +
41.349 + val (mor_image_thms, morE_thms) =
41.350 + let
41.351 + val prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
41.352 + fun mk_image_goal f B1 B2 = fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs)
41.353 + (Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_subset (mk_image f $ B1) B2)));
41.354 + val image_goals = map3 mk_image_goal fs Bs B's;
41.355 + fun mk_elim_prem sets x T = HOLogic.mk_Trueprop
41.356 + (HOLogic.mk_mem (x, mk_in (passive_UNIVs @ Bs) sets T));
41.357 + fun mk_elim_goal sets mapAsBs f s s' x T =
41.358 + fold_rev Logic.all (x :: Bs @ ss @ B's @ s's @ fs)
41.359 + (Logic.list_implies ([prem, mk_elim_prem sets x T],
41.360 + mk_Trueprop_eq (f $ (s $ x), s' $ Term.list_comb (mapAsBs, passive_ids @ fs @ [x]))));
41.361 + val elim_goals = map7 mk_elim_goal setssAs mapsAsBs fs ss s's xFs FTsAs;
41.362 + fun prove goal =
41.363 + Skip_Proof.prove lthy [] [] goal (K (mk_mor_elim_tac mor_def)) |> Thm.close_derivation;
41.364 + in
41.365 + (map prove image_goals, map prove elim_goals)
41.366 + end;
41.367 +
41.368 + val mor_incl_thm =
41.369 + let
41.370 + val prems = map2 (HOLogic.mk_Trueprop oo mk_subset) Bs Bs_copy;
41.371 + val concl = HOLogic.mk_Trueprop (mk_mor Bs ss Bs_copy ss active_ids);
41.372 + in
41.373 + Skip_Proof.prove lthy [] []
41.374 + (fold_rev Logic.all (Bs @ ss @ Bs_copy) (Logic.list_implies (prems, concl)))
41.375 + (K (mk_mor_incl_tac mor_def map_id's))
41.376 + |> Thm.close_derivation
41.377 + end;
41.378 +
41.379 + val mor_comp_thm =
41.380 + let
41.381 + val prems =
41.382 + [HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs),
41.383 + HOLogic.mk_Trueprop (mk_mor B's s's B''s s''s gs)];
41.384 + val concl =
41.385 + HOLogic.mk_Trueprop (mk_mor Bs ss B''s s''s (map2 (curry HOLogic.mk_comp) gs fs));
41.386 + in
41.387 + Skip_Proof.prove lthy [] []
41.388 + (fold_rev Logic.all (Bs @ ss @ B's @ s's @ B''s @ s''s @ fs @ gs)
41.389 + (Logic.list_implies (prems, concl)))
41.390 + (K (mk_mor_comp_tac mor_def set_natural'ss map_comp_id_thms))
41.391 + |> Thm.close_derivation
41.392 + end;
41.393 +
41.394 + val mor_inv_thm =
41.395 + let
41.396 + fun mk_inv_prem f inv_f B B' = HOLogic.mk_conj (mk_subset (mk_image inv_f $ B') B,
41.397 + HOLogic.mk_conj (mk_inver inv_f f B, mk_inver f inv_f B'));
41.398 + val prems = map HOLogic.mk_Trueprop
41.399 + ([mk_mor Bs ss B's s's fs,
41.400 + mk_alg passive_UNIVs Bs ss,
41.401 + mk_alg passive_UNIVs B's s's] @
41.402 + map4 mk_inv_prem fs inv_fs Bs B's);
41.403 + val concl = HOLogic.mk_Trueprop (mk_mor B's s's Bs ss inv_fs);
41.404 + in
41.405 + Skip_Proof.prove lthy [] []
41.406 + (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ inv_fs)
41.407 + (Logic.list_implies (prems, concl)))
41.408 + (K (mk_mor_inv_tac alg_def mor_def
41.409 + set_natural'ss morE_thms map_comp_id_thms map_congL_thms))
41.410 + |> Thm.close_derivation
41.411 + end;
41.412 +
41.413 + val mor_cong_thm =
41.414 + let
41.415 + val prems = map HOLogic.mk_Trueprop
41.416 + (map2 (curry HOLogic.mk_eq) fs_copy fs @ [mk_mor Bs ss B's s's fs])
41.417 + val concl = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs_copy);
41.418 + in
41.419 + Skip_Proof.prove lthy [] []
41.420 + (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ fs_copy)
41.421 + (Logic.list_implies (prems, concl)))
41.422 + (K ((hyp_subst_tac THEN' atac) 1))
41.423 + |> Thm.close_derivation
41.424 + end;
41.425 +
41.426 + val mor_str_thm =
41.427 + let
41.428 + val maps = map2 (fn Ds => fn bnf => Term.list_comb
41.429 + (mk_map_of_bnf Ds (passiveAs @ FTsAs) allAs bnf, passive_ids @ ss)) Dss bnfs;
41.430 + in
41.431 + Skip_Proof.prove lthy [] []
41.432 + (fold_rev Logic.all ss (HOLogic.mk_Trueprop
41.433 + (mk_mor (map HOLogic.mk_UNIV FTsAs) maps active_UNIVs ss ss)))
41.434 + (K (mk_mor_str_tac ks mor_def))
41.435 + |> Thm.close_derivation
41.436 + end;
41.437 +
41.438 + val mor_convol_thm =
41.439 + let
41.440 + val maps = map3 (fn s => fn prod_s => fn mapx =>
41.441 + mk_convol (HOLogic.mk_comp (s, Term.list_comb (mapx, passive_ids @ fsts)), prod_s))
41.442 + s's prod_ss map_fsts;
41.443 + in
41.444 + Skip_Proof.prove lthy [] []
41.445 + (fold_rev Logic.all (s's @ prod_ss) (HOLogic.mk_Trueprop
41.446 + (mk_mor prod_UNIVs maps (map HOLogic.mk_UNIV activeBs) s's fsts)))
41.447 + (K (mk_mor_convol_tac ks mor_def))
41.448 + |> Thm.close_derivation
41.449 + end;
41.450 +
41.451 + val mor_UNIV_thm =
41.452 + let
41.453 + fun mk_conjunct mapAsBs f s s' = HOLogic.mk_eq
41.454 + (HOLogic.mk_comp (f, s),
41.455 + HOLogic.mk_comp (s', Term.list_comb (mapAsBs, passive_ids @ fs)));
41.456 + val lhs = mk_mor active_UNIVs ss (map HOLogic.mk_UNIV activeBs) s's fs;
41.457 + val rhs = Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct mapsAsBs fs ss s's);
41.458 + in
41.459 + Skip_Proof.prove lthy [] [] (fold_rev Logic.all (ss @ s's @ fs) (mk_Trueprop_eq (lhs, rhs)))
41.460 + (K (mk_mor_UNIV_tac m morE_thms mor_def))
41.461 + |> Thm.close_derivation
41.462 + end;
41.463 +
41.464 + val timer = time (timer "Morphism definition & thms");
41.465 +
41.466 + (* isomorphism *)
41.467 +
41.468 + (*mor Bs1 ss1 Bs2 ss2 fs \<and> (\<exists>gs. mor Bs2 ss2 Bs1 ss1 fs \<and>
41.469 + forall i = 1 ... n. (inver gs[i] fs[i] Bs1[i] \<and> inver fs[i] gs[i] Bs2[i]))*)
41.470 + fun mk_iso Bs1 ss1 Bs2 ss2 fs gs =
41.471 + let
41.472 + val ex_inv_mor = list_exists_free gs
41.473 + (HOLogic.mk_conj (mk_mor Bs2 ss2 Bs1 ss1 gs,
41.474 + Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_conj)
41.475 + (map3 mk_inver gs fs Bs1) (map3 mk_inver fs gs Bs2))));
41.476 + in
41.477 + HOLogic.mk_conj (mk_mor Bs1 ss1 Bs2 ss2 fs, ex_inv_mor)
41.478 + end;
41.479 +
41.480 + val iso_alt_thm =
41.481 + let
41.482 + val prems = map HOLogic.mk_Trueprop
41.483 + [mk_alg passive_UNIVs Bs ss,
41.484 + mk_alg passive_UNIVs B's s's]
41.485 + val concl = mk_Trueprop_eq (mk_iso Bs ss B's s's fs inv_fs,
41.486 + HOLogic.mk_conj (mk_mor Bs ss B's s's fs,
41.487 + Library.foldr1 HOLogic.mk_conj (map3 mk_bij_betw fs Bs B's)));
41.488 + in
41.489 + Skip_Proof.prove lthy [] []
41.490 + (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs) (Logic.list_implies (prems, concl)))
41.491 + (K (mk_iso_alt_tac mor_image_thms mor_inv_thm))
41.492 + |> Thm.close_derivation
41.493 + end;
41.494 +
41.495 + val timer = time (timer "Isomorphism definition & thms");
41.496 +
41.497 + (* algebra copies *)
41.498 +
41.499 + val (copy_alg_thm, ex_copy_alg_thm) =
41.500 + let
41.501 + val prems = map HOLogic.mk_Trueprop
41.502 + (mk_alg passive_UNIVs Bs ss :: map3 mk_bij_betw inv_fs B's Bs);
41.503 + val inver_prems = map HOLogic.mk_Trueprop
41.504 + (map3 mk_inver inv_fs fs Bs @ map3 mk_inver fs inv_fs B's);
41.505 + val all_prems = prems @ inver_prems;
41.506 + fun mk_s f s mapT y y' = Term.absfree y' (f $ (s $
41.507 + (Term.list_comb (mapT, passive_ids @ inv_fs) $ y)));
41.508 +
41.509 + val alg = HOLogic.mk_Trueprop
41.510 + (mk_alg passive_UNIVs B's (map5 mk_s fs ss mapsBsAs yFs yFs'));
41.511 + val copy_str_thm = Skip_Proof.prove lthy [] []
41.512 + (fold_rev Logic.all (Bs @ ss @ B's @ inv_fs @ fs)
41.513 + (Logic.list_implies (all_prems, alg)))
41.514 + (K (mk_copy_str_tac set_natural'ss alg_def alg_set_thms))
41.515 + |> Thm.close_derivation;
41.516 +
41.517 + val iso = HOLogic.mk_Trueprop
41.518 + (mk_iso B's (map5 mk_s fs ss mapsBsAs yFs yFs') Bs ss inv_fs fs_copy);
41.519 + val copy_alg_thm = Skip_Proof.prove lthy [] []
41.520 + (fold_rev Logic.all (Bs @ ss @ B's @ inv_fs @ fs)
41.521 + (Logic.list_implies (all_prems, iso)))
41.522 + (K (mk_copy_alg_tac set_natural'ss alg_set_thms mor_def iso_alt_thm copy_str_thm))
41.523 + |> Thm.close_derivation;
41.524 +
41.525 + val ex = HOLogic.mk_Trueprop
41.526 + (list_exists_free s's
41.527 + (HOLogic.mk_conj (mk_alg passive_UNIVs B's s's,
41.528 + mk_iso B's s's Bs ss inv_fs fs_copy)));
41.529 + val ex_copy_alg_thm = Skip_Proof.prove lthy [] []
41.530 + (fold_rev Logic.all (Bs @ ss @ B's @ inv_fs @ fs)
41.531 + (Logic.list_implies (prems, ex)))
41.532 + (K (mk_ex_copy_alg_tac n copy_str_thm copy_alg_thm))
41.533 + |> Thm.close_derivation;
41.534 + in
41.535 + (copy_alg_thm, ex_copy_alg_thm)
41.536 + end;
41.537 +
41.538 + val timer = time (timer "Copy thms");
41.539 +
41.540 +
41.541 + (* bounds *)
41.542 +
41.543 + val sum_Card_order = if n = 1 then bd_Card_order else @{thm Card_order_csum};
41.544 + val sum_Cnotzero = if n = 1 then bd_Cnotzero else bd_Cnotzero RS @{thm csum_Cnotzero1};
41.545 + val sum_Cinfinite = if n = 1 then bd_Cinfinite else bd_Cinfinite RS @{thm Cinfinite_csum1};
41.546 + fun mk_set_bd_sums i bd_Card_order bds =
41.547 + if n = 1 then bds
41.548 + else map (fn thm => bd_Card_order RS mk_ordLeq_csum n i thm) bds;
41.549 + val set_bd_sumss = map3 mk_set_bd_sums ks bd_Card_orders set_bdss;
41.550 +
41.551 + fun mk_in_bd_sum i Co Cnz bd =
41.552 + if n = 1 then bd
41.553 + else Cnz RS ((Co RS mk_ordLeq_csum n i (Co RS @{thm ordLeq_refl})) RS
41.554 + (bd RS @{thm ordLeq_transitive[OF _
41.555 + cexp_mono2_Cnotzero[OF _ csum_Cnotzero2[OF ctwo_Cnotzero]]]}));
41.556 + val in_bd_sums = map4 mk_in_bd_sum ks bd_Card_orders bd_Cnotzeros in_bds;
41.557 +
41.558 + val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
41.559 + val suc_bd = mk_cardSuc sum_bd;
41.560 + val field_suc_bd = mk_Field suc_bd;
41.561 + val suc_bdT = fst (dest_relT (fastype_of suc_bd));
41.562 + fun mk_Asuc_bd [] = mk_cexp ctwo suc_bd
41.563 + | mk_Asuc_bd As =
41.564 + mk_cexp (mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo) suc_bd;
41.565 +
41.566 + val suc_bd_Card_order = if n = 1 then bd_Card_order RS @{thm cardSuc_Card_order}
41.567 + else @{thm cardSuc_Card_order[OF Card_order_csum]};
41.568 + val suc_bd_Cinfinite = if n = 1 then bd_Cinfinite RS @{thm Cinfinite_cardSuc}
41.569 + else bd_Cinfinite RS @{thm Cinfinite_cardSuc[OF Cinfinite_csum1]};
41.570 + val suc_bd_Cnotzero = suc_bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
41.571 + val suc_bd_worel = suc_bd_Card_order RS @{thm Card_order_wo_rel}
41.572 + val basis_Asuc = if m = 0 then @{thm ordLeq_refl[OF Card_order_ctwo]}
41.573 + else @{thm ordLeq_csum2[OF Card_order_ctwo]};
41.574 + val Asuc_bd_Cinfinite = suc_bd_Cinfinite RS (basis_Asuc RS @{thm Cinfinite_cexp});
41.575 + val Asuc_bd_Cnotzero = Asuc_bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
41.576 +
41.577 + val suc_bd_Asuc_bd = @{thm ordLess_ordLeq_trans[OF
41.578 + ordLess_ctwo_cexp
41.579 + cexp_mono1_Cnotzero[OF _ ctwo_Cnotzero]]} OF
41.580 + [suc_bd_Card_order, basis_Asuc, suc_bd_Card_order];
41.581 +
41.582 + val Asuc_bdT = fst (dest_relT (fastype_of (mk_Asuc_bd As)));
41.583 + val II_BTs = replicate n (HOLogic.mk_setT Asuc_bdT);
41.584 + val II_sTs = map2 (fn Ds => fn bnf =>
41.585 + mk_T_of_bnf Ds (passiveAs @ replicate n Asuc_bdT) bnf --> Asuc_bdT) Dss bnfs;
41.586 +
41.587 + val (((((((idxs, Asi_name), (idx, idx')), (jdx, jdx')), II_Bs), II_ss), Asuc_fs),
41.588 + names_lthy) = names_lthy
41.589 + |> mk_Frees "i" (replicate n suc_bdT)
41.590 + ||>> (fn ctxt => apfst the_single (mk_fresh_names ctxt 1 "Asi"))
41.591 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "i") suc_bdT
41.592 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "j") suc_bdT
41.593 + ||>> mk_Frees "IIB" II_BTs
41.594 + ||>> mk_Frees "IIs" II_sTs
41.595 + ||>> mk_Frees "f" (map (fn T => Asuc_bdT --> T) activeAs);
41.596 +
41.597 + val suc_bd_limit_thm =
41.598 + let
41.599 + val prem = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.600 + (map (fn idx => HOLogic.mk_mem (idx, field_suc_bd)) idxs));
41.601 + fun mk_conjunct idx = HOLogic.mk_conj (mk_not_eq idx jdx,
41.602 + HOLogic.mk_mem (HOLogic.mk_prod (idx, jdx), suc_bd));
41.603 + val concl = HOLogic.mk_Trueprop (mk_Bex field_suc_bd
41.604 + (Term.absfree jdx' (Library.foldr1 HOLogic.mk_conj (map mk_conjunct idxs))));
41.605 + in
41.606 + Skip_Proof.prove lthy [] []
41.607 + (fold_rev Logic.all idxs (Logic.list_implies ([prem], concl)))
41.608 + (K (mk_bd_limit_tac n suc_bd_Cinfinite))
41.609 + |> Thm.close_derivation
41.610 + end;
41.611 +
41.612 + val timer = time (timer "Bounds");
41.613 +
41.614 +
41.615 + (* minimal algebra *)
41.616 +
41.617 + fun mk_minG Asi i k = mk_UNION (mk_underS suc_bd $ i)
41.618 + (Term.absfree jdx' (mk_nthN n (Asi $ jdx) k));
41.619 +
41.620 + fun mk_minH_component As Asi i sets Ts s k =
41.621 + HOLogic.mk_binop @{const_name "sup"}
41.622 + (mk_minG Asi i k, mk_image s $ mk_in (As @ map (mk_minG Asi i) ks) sets Ts);
41.623 +
41.624 + fun mk_min_algs As ss =
41.625 + let
41.626 + val BTs = map (range_type o fastype_of) ss;
41.627 + val Ts = map (HOLogic.dest_setT o fastype_of) As @ BTs;
41.628 + val (Asi, Asi') = `Free (Asi_name, suc_bdT -->
41.629 + Library.foldr1 HOLogic.mk_prodT (map HOLogic.mk_setT BTs));
41.630 + in
41.631 + mk_worec suc_bd (Term.absfree Asi' (Term.absfree idx' (HOLogic.mk_tuple
41.632 + (map4 (mk_minH_component As Asi idx) (mk_setss Ts) (mk_FTs Ts) ss ks))))
41.633 + end;
41.634 +
41.635 + val (min_algs_thms, min_algs_mono_thms, card_of_min_algs_thm, least_min_algs_thm) =
41.636 + let
41.637 + val i_field = HOLogic.mk_mem (idx, field_suc_bd);
41.638 + val min_algs = mk_min_algs As ss;
41.639 + val min_algss = map (fn k => mk_nthN n (min_algs $ idx) k) ks;
41.640 +
41.641 + val concl = HOLogic.mk_Trueprop
41.642 + (HOLogic.mk_eq (min_algs $ idx, HOLogic.mk_tuple
41.643 + (map4 (mk_minH_component As min_algs idx) setssAs FTsAs ss ks)));
41.644 + val goal = fold_rev Logic.all (idx :: As @ ss)
41.645 + (Logic.mk_implies (HOLogic.mk_Trueprop i_field, concl));
41.646 +
41.647 + val min_algs_thm = Skip_Proof.prove lthy [] [] goal
41.648 + (K (mk_min_algs_tac suc_bd_worel in_cong'_thms))
41.649 + |> Thm.close_derivation;
41.650 +
41.651 + val min_algs_thms = map (fn k => min_algs_thm RS mk_nthI n k) ks;
41.652 +
41.653 + fun mk_mono_goal min_alg =
41.654 + fold_rev Logic.all (As @ ss) (HOLogic.mk_Trueprop (mk_relChain suc_bd
41.655 + (Term.absfree idx' min_alg)));
41.656 +
41.657 + val monos =
41.658 + map2 (fn goal => fn min_algs =>
41.659 + Skip_Proof.prove lthy [] [] goal (K (mk_min_algs_mono_tac min_algs))
41.660 + |> Thm.close_derivation)
41.661 + (map mk_mono_goal min_algss) min_algs_thms;
41.662 +
41.663 + val Asuc_bd = mk_Asuc_bd As;
41.664 +
41.665 + fun mk_card_conjunct min_alg = mk_ordLeq (mk_card_of min_alg) Asuc_bd;
41.666 + val card_conjunction = Library.foldr1 HOLogic.mk_conj (map mk_card_conjunct min_algss);
41.667 + val card_cT = certifyT lthy suc_bdT;
41.668 + val card_ct = certify lthy (Term.absfree idx' card_conjunction);
41.669 +
41.670 + val card_of = singleton (Proof_Context.export names_lthy lthy)
41.671 + (Skip_Proof.prove lthy [] []
41.672 + (HOLogic.mk_Trueprop (HOLogic.mk_imp (i_field, card_conjunction)))
41.673 + (K (mk_min_algs_card_of_tac card_cT card_ct
41.674 + m suc_bd_worel min_algs_thms in_bd_sums
41.675 + sum_Card_order sum_Cnotzero suc_bd_Card_order suc_bd_Cinfinite suc_bd_Cnotzero
41.676 + suc_bd_Asuc_bd Asuc_bd_Cinfinite Asuc_bd_Cnotzero)))
41.677 + |> Thm.close_derivation;
41.678 +
41.679 + val least_prem = HOLogic.mk_Trueprop (mk_alg As Bs ss);
41.680 + val least_conjunction = Library.foldr1 HOLogic.mk_conj (map2 mk_subset min_algss Bs);
41.681 + val least_cT = certifyT lthy suc_bdT;
41.682 + val least_ct = certify lthy (Term.absfree idx' least_conjunction);
41.683 +
41.684 + val least = singleton (Proof_Context.export names_lthy lthy)
41.685 + (Skip_Proof.prove lthy [] []
41.686 + (Logic.mk_implies (least_prem,
41.687 + HOLogic.mk_Trueprop (HOLogic.mk_imp (i_field, least_conjunction))))
41.688 + (K (mk_min_algs_least_tac least_cT least_ct
41.689 + suc_bd_worel min_algs_thms alg_set_thms)))
41.690 + |> Thm.close_derivation;
41.691 + in
41.692 + (min_algs_thms, monos, card_of, least)
41.693 + end;
41.694 +
41.695 + val timer = time (timer "min_algs definition & thms");
41.696 +
41.697 + fun min_alg_bind i = Binding.suffix_name
41.698 + ("_" ^ min_algN ^ (if n = 1 then "" else string_of_int i)) b;
41.699 + val min_alg_name = Binding.name_of o min_alg_bind;
41.700 + val min_alg_def_bind = rpair [] o Thm.def_binding o min_alg_bind;
41.701 +
41.702 + fun min_alg_spec i =
41.703 + let
41.704 + val min_algT =
41.705 + Library.foldr (op -->) (ATs @ sTs, HOLogic.mk_setT (nth activeAs (i - 1)));
41.706 +
41.707 + val lhs = Term.list_comb (Free (min_alg_name i, min_algT), As @ ss);
41.708 + val rhs = mk_UNION (field_suc_bd)
41.709 + (Term.absfree idx' (mk_nthN n (mk_min_algs As ss $ idx) i));
41.710 + in
41.711 + mk_Trueprop_eq (lhs, rhs)
41.712 + end;
41.713 +
41.714 + val ((min_alg_frees, (_, min_alg_def_frees)), (lthy, lthy_old)) =
41.715 + lthy
41.716 + |> fold_map (fn i => Specification.definition
41.717 + (SOME (min_alg_bind i, NONE, NoSyn), (min_alg_def_bind i, min_alg_spec i))) ks
41.718 + |>> apsnd split_list o split_list
41.719 + ||> `Local_Theory.restore;
41.720 +
41.721 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.722 + val min_algs = map (fst o Term.dest_Const o Morphism.term phi) min_alg_frees;
41.723 + val min_alg_defs = map (Morphism.thm phi) min_alg_def_frees;
41.724 +
41.725 + fun mk_min_alg As ss i =
41.726 + let
41.727 + val T = HOLogic.mk_setT (range_type (fastype_of (nth ss (i - 1))))
41.728 + val args = As @ ss;
41.729 + val Ts = map fastype_of args;
41.730 + val min_algT = Library.foldr (op -->) (Ts, T);
41.731 + in
41.732 + Term.list_comb (Const (nth min_algs (i - 1), min_algT), args)
41.733 + end;
41.734 +
41.735 + val (alg_min_alg_thm, card_of_min_alg_thms, least_min_alg_thms, mor_incl_min_alg_thm) =
41.736 + let
41.737 + val min_algs = map (mk_min_alg As ss) ks;
41.738 +
41.739 + val goal = fold_rev Logic.all (As @ ss) (HOLogic.mk_Trueprop (mk_alg As min_algs ss));
41.740 + val alg_min_alg = Skip_Proof.prove lthy [] [] goal
41.741 + (K (mk_alg_min_alg_tac m alg_def min_alg_defs suc_bd_limit_thm sum_Cinfinite
41.742 + set_bd_sumss min_algs_thms min_algs_mono_thms))
41.743 + |> Thm.close_derivation;
41.744 +
41.745 + val Asuc_bd = mk_Asuc_bd As;
41.746 + fun mk_card_of_thm min_alg def = Skip_Proof.prove lthy [] []
41.747 + (fold_rev Logic.all (As @ ss)
41.748 + (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of min_alg) Asuc_bd)))
41.749 + (K (mk_card_of_min_alg_tac def card_of_min_algs_thm
41.750 + suc_bd_Card_order suc_bd_Asuc_bd Asuc_bd_Cinfinite))
41.751 + |> Thm.close_derivation;
41.752 +
41.753 + val least_prem = HOLogic.mk_Trueprop (mk_alg As Bs ss);
41.754 + fun mk_least_thm min_alg B def = Skip_Proof.prove lthy [] []
41.755 + (fold_rev Logic.all (As @ Bs @ ss)
41.756 + (Logic.mk_implies (least_prem, HOLogic.mk_Trueprop (mk_subset min_alg B))))
41.757 + (K (mk_least_min_alg_tac def least_min_algs_thm))
41.758 + |> Thm.close_derivation;
41.759 +
41.760 + val leasts = map3 mk_least_thm min_algs Bs min_alg_defs;
41.761 +
41.762 + val incl_prem = HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
41.763 + val incl_min_algs = map (mk_min_alg passive_UNIVs ss) ks;
41.764 + val incl = Skip_Proof.prove lthy [] []
41.765 + (fold_rev Logic.all (Bs @ ss)
41.766 + (Logic.mk_implies (incl_prem,
41.767 + HOLogic.mk_Trueprop (mk_mor incl_min_algs ss Bs ss active_ids))))
41.768 + (K (EVERY' (rtac mor_incl_thm :: map etac leasts) 1))
41.769 + |> Thm.close_derivation;
41.770 + in
41.771 + (alg_min_alg, map2 mk_card_of_thm min_algs min_alg_defs, leasts, incl)
41.772 + end;
41.773 +
41.774 + val timer = time (timer "Minimal algebra definition & thms");
41.775 +
41.776 + val II_repT = HOLogic.mk_prodT (HOLogic.mk_tupleT II_BTs, HOLogic.mk_tupleT II_sTs);
41.777 + val IIT_bind = Binding.suffix_name ("_" ^ IITN) b;
41.778 +
41.779 + val ((IIT_name, (IIT_glob_info, IIT_loc_info)), lthy) =
41.780 + typedef false NONE (IIT_bind, params, NoSyn)
41.781 + (HOLogic.mk_UNIV II_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
41.782 +
41.783 + val IIT = Type (IIT_name, params');
41.784 + val Abs_IIT = Const (#Abs_name IIT_glob_info, II_repT --> IIT);
41.785 + val Rep_IIT = Const (#Rep_name IIT_glob_info, IIT --> II_repT);
41.786 + val Abs_IIT_inverse_thm = UNIV_I RS #Abs_inverse IIT_loc_info;
41.787 +
41.788 + val initT = IIT --> Asuc_bdT;
41.789 + val active_initTs = replicate n initT;
41.790 + val init_FTs = map2 (fn Ds => mk_T_of_bnf Ds (passiveAs @ active_initTs)) Dss bnfs;
41.791 + val init_fTs = map (fn T => initT --> T) activeAs;
41.792 +
41.793 + val (((((((iidx, iidx'), init_xs), (init_xFs, init_xFs')),
41.794 + init_fs), init_fs_copy), init_phis), names_lthy) = names_lthy
41.795 + |> yield_singleton (apfst (op ~~) oo mk_Frees' "i") IIT
41.796 + ||>> mk_Frees "ix" active_initTs
41.797 + ||>> mk_Frees' "x" init_FTs
41.798 + ||>> mk_Frees "f" init_fTs
41.799 + ||>> mk_Frees "f" init_fTs
41.800 + ||>> mk_Frees "P" (replicate n (mk_pred1T initT));
41.801 +
41.802 + val II = HOLogic.mk_Collect (fst iidx', IIT, list_exists_free (II_Bs @ II_ss)
41.803 + (HOLogic.mk_conj (HOLogic.mk_eq (iidx,
41.804 + Abs_IIT $ (HOLogic.mk_prod (HOLogic.mk_tuple II_Bs, HOLogic.mk_tuple II_ss))),
41.805 + mk_alg passive_UNIVs II_Bs II_ss)));
41.806 +
41.807 + val select_Bs = map (mk_nthN n (HOLogic.mk_fst (Rep_IIT $ iidx))) ks;
41.808 + val select_ss = map (mk_nthN n (HOLogic.mk_snd (Rep_IIT $ iidx))) ks;
41.809 +
41.810 + fun str_init_bind i = Binding.suffix_name ("_" ^ str_initN ^ (if n = 1 then "" else
41.811 + string_of_int i)) b;
41.812 + val str_init_name = Binding.name_of o str_init_bind;
41.813 + val str_init_def_bind = rpair [] o Thm.def_binding o str_init_bind;
41.814 +
41.815 + fun str_init_spec i =
41.816 + let
41.817 + val T = nth init_FTs (i - 1);
41.818 + val init_xF = nth init_xFs (i - 1)
41.819 + val select_s = nth select_ss (i - 1);
41.820 + val map = mk_map_of_bnf (nth Dss (i - 1))
41.821 + (passiveAs @ active_initTs) (passiveAs @ replicate n Asuc_bdT)
41.822 + (nth bnfs (i - 1));
41.823 + val map_args = passive_ids @ replicate n (mk_rapp iidx Asuc_bdT);
41.824 + val str_initT = T --> IIT --> Asuc_bdT;
41.825 +
41.826 + val lhs = Term.list_comb (Free (str_init_name i, str_initT), [init_xF, iidx]);
41.827 + val rhs = select_s $ (Term.list_comb (map, map_args) $ init_xF);
41.828 + in
41.829 + mk_Trueprop_eq (lhs, rhs)
41.830 + end;
41.831 +
41.832 + val ((str_init_frees, (_, str_init_def_frees)), (lthy, lthy_old)) =
41.833 + lthy
41.834 + |> fold_map (fn i => Specification.definition
41.835 + (SOME (str_init_bind i, NONE, NoSyn), (str_init_def_bind i, str_init_spec i))) ks
41.836 + |>> apsnd split_list o split_list
41.837 + ||> `Local_Theory.restore;
41.838 +
41.839 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.840 + val str_inits =
41.841 + map (Term.subst_atomic_types (map (`(Morphism.typ phi)) params') o Morphism.term phi)
41.842 + str_init_frees;
41.843 +
41.844 + val str_init_defs = map (Morphism.thm phi) str_init_def_frees;
41.845 +
41.846 + val car_inits = map (mk_min_alg passive_UNIVs str_inits) ks;
41.847 +
41.848 + (*TODO: replace with instantiate? (problem: figure out right type instantiation)*)
41.849 + val alg_init_thm = Skip_Proof.prove lthy [] []
41.850 + (HOLogic.mk_Trueprop (mk_alg passive_UNIVs car_inits str_inits))
41.851 + (K (rtac alg_min_alg_thm 1))
41.852 + |> Thm.close_derivation;
41.853 +
41.854 + val alg_select_thm = Skip_Proof.prove lthy [] []
41.855 + (HOLogic.mk_Trueprop (mk_Ball II
41.856 + (Term.absfree iidx' (mk_alg passive_UNIVs select_Bs select_ss))))
41.857 + (mk_alg_select_tac Abs_IIT_inverse_thm)
41.858 + |> Thm.close_derivation;
41.859 +
41.860 + val mor_select_thm =
41.861 + let
41.862 + val alg_prem = HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
41.863 + val i_prem = HOLogic.mk_Trueprop (HOLogic.mk_mem (iidx, II));
41.864 + val mor_prem = HOLogic.mk_Trueprop (mk_mor select_Bs select_ss Bs ss Asuc_fs);
41.865 + val prems = [alg_prem, i_prem, mor_prem];
41.866 + val concl = HOLogic.mk_Trueprop
41.867 + (mk_mor car_inits str_inits Bs ss
41.868 + (map (fn f => HOLogic.mk_comp (f, mk_rapp iidx Asuc_bdT)) Asuc_fs));
41.869 + in
41.870 + Skip_Proof.prove lthy [] []
41.871 + (fold_rev Logic.all (iidx :: Bs @ ss @ Asuc_fs) (Logic.list_implies (prems, concl)))
41.872 + (K (mk_mor_select_tac mor_def mor_cong_thm mor_comp_thm mor_incl_min_alg_thm alg_def
41.873 + alg_select_thm alg_set_thms set_natural'ss str_init_defs))
41.874 + |> Thm.close_derivation
41.875 + end;
41.876 +
41.877 + val (init_ex_mor_thm, init_unique_mor_thms) =
41.878 + let
41.879 + val prem = HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
41.880 + val concl = HOLogic.mk_Trueprop
41.881 + (list_exists_free init_fs (mk_mor car_inits str_inits Bs ss init_fs));
41.882 + val ex_mor = Skip_Proof.prove lthy [] []
41.883 + (fold_rev Logic.all (Bs @ ss) (Logic.mk_implies (prem, concl)))
41.884 + (mk_init_ex_mor_tac Abs_IIT_inverse_thm ex_copy_alg_thm alg_min_alg_thm
41.885 + card_of_min_alg_thms mor_comp_thm mor_select_thm mor_incl_min_alg_thm)
41.886 + |> Thm.close_derivation;
41.887 +
41.888 + val prems = map2 (HOLogic.mk_Trueprop oo curry HOLogic.mk_mem) init_xs car_inits
41.889 + val mor_prems = map HOLogic.mk_Trueprop
41.890 + [mk_mor car_inits str_inits Bs ss init_fs,
41.891 + mk_mor car_inits str_inits Bs ss init_fs_copy];
41.892 + fun mk_fun_eq f g x = HOLogic.mk_eq (f $ x, g $ x);
41.893 + val unique = HOLogic.mk_Trueprop
41.894 + (Library.foldr1 HOLogic.mk_conj (map3 mk_fun_eq init_fs init_fs_copy init_xs));
41.895 + val unique_mor = Skip_Proof.prove lthy [] []
41.896 + (fold_rev Logic.all (init_xs @ Bs @ ss @ init_fs @ init_fs_copy)
41.897 + (Logic.list_implies (prems @ mor_prems, unique)))
41.898 + (K (mk_init_unique_mor_tac m alg_def alg_init_thm least_min_alg_thms
41.899 + in_mono'_thms alg_set_thms morE_thms map_congs))
41.900 + |> Thm.close_derivation;
41.901 + in
41.902 + (ex_mor, split_conj_thm unique_mor)
41.903 + end;
41.904 +
41.905 + val init_setss = mk_setss (passiveAs @ active_initTs);
41.906 + val active_init_setss = map (drop m) init_setss;
41.907 + val init_ins = map2 (fn sets => mk_in (passive_UNIVs @ car_inits) sets) init_setss init_FTs;
41.908 +
41.909 + fun mk_closed phis =
41.910 + let
41.911 + fun mk_conjunct phi str_init init_sets init_in x x' =
41.912 + let
41.913 + val prem = Library.foldr1 HOLogic.mk_conj
41.914 + (map2 (fn set => mk_Ball (set $ x)) init_sets phis);
41.915 + val concl = phi $ (str_init $ x);
41.916 + in
41.917 + mk_Ball init_in (Term.absfree x' (HOLogic.mk_imp (prem, concl)))
41.918 + end;
41.919 + in
41.920 + Library.foldr1 HOLogic.mk_conj
41.921 + (map6 mk_conjunct phis str_inits active_init_setss init_ins init_xFs init_xFs')
41.922 + end;
41.923 +
41.924 + val init_induct_thm =
41.925 + let
41.926 + val prem = HOLogic.mk_Trueprop (mk_closed init_phis);
41.927 + val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.928 + (map2 mk_Ball car_inits init_phis));
41.929 + in
41.930 + Skip_Proof.prove lthy [] []
41.931 + (fold_rev Logic.all init_phis (Logic.mk_implies (prem, concl)))
41.932 + (K (mk_init_induct_tac m alg_def alg_init_thm least_min_alg_thms alg_set_thms))
41.933 + |> Thm.close_derivation
41.934 + end;
41.935 +
41.936 + val timer = time (timer "Initiality definition & thms");
41.937 +
41.938 + val ((T_names, (T_glob_infos, T_loc_infos)), lthy) =
41.939 + lthy
41.940 + |> fold_map3 (fn b => fn mx => fn car_init => typedef false NONE (b, params, mx) car_init NONE
41.941 + (EVERY' [rtac ssubst, rtac @{thm ex_in_conv}, resolve_tac alg_not_empty_thms,
41.942 + rtac alg_init_thm] 1)) bs mixfixes car_inits
41.943 + |>> apsnd split_list o split_list;
41.944 +
41.945 + val Ts = map (fn name => Type (name, params')) T_names;
41.946 + fun mk_Ts passive = map (Term.typ_subst_atomic (passiveAs ~~ passive)) Ts;
41.947 + val Ts' = mk_Ts passiveBs;
41.948 + val Rep_Ts = map2 (fn info => fn T => Const (#Rep_name info, T --> initT)) T_glob_infos Ts;
41.949 + val Abs_Ts = map2 (fn info => fn T => Const (#Abs_name info, initT --> T)) T_glob_infos Ts;
41.950 +
41.951 + val type_defs = map #type_definition T_loc_infos;
41.952 + val Reps = map #Rep T_loc_infos;
41.953 + val Rep_casess = map #Rep_cases T_loc_infos;
41.954 + val Rep_injects = map #Rep_inject T_loc_infos;
41.955 + val Rep_inverses = map #Rep_inverse T_loc_infos;
41.956 + val Abs_inverses = map #Abs_inverse T_loc_infos;
41.957 +
41.958 + fun mk_inver_thm mk_tac rep abs X thm =
41.959 + Skip_Proof.prove lthy [] []
41.960 + (HOLogic.mk_Trueprop (mk_inver rep abs X))
41.961 + (K (EVERY' [rtac ssubst, rtac @{thm inver_def}, rtac ballI, mk_tac thm] 1))
41.962 + |> Thm.close_derivation;
41.963 +
41.964 + val inver_Reps = map4 (mk_inver_thm rtac) Abs_Ts Rep_Ts (map HOLogic.mk_UNIV Ts) Rep_inverses;
41.965 + val inver_Abss = map4 (mk_inver_thm etac) Rep_Ts Abs_Ts car_inits Abs_inverses;
41.966 +
41.967 + val timer = time (timer "THE TYPEDEFs & Rep/Abs thms");
41.968 +
41.969 + val UNIVs = map HOLogic.mk_UNIV Ts;
41.970 + val FTs = mk_FTs (passiveAs @ Ts);
41.971 + val FTs' = mk_FTs (passiveBs @ Ts');
41.972 + fun mk_set_Ts T = passiveAs @ replicate n (HOLogic.mk_setT T);
41.973 + val setFTss = map (mk_FTs o mk_set_Ts) passiveAs;
41.974 + val FTs_setss = mk_setss (passiveAs @ Ts);
41.975 + val FTs'_setss = mk_setss (passiveBs @ Ts');
41.976 + val map_FT_inits = map2 (fn Ds =>
41.977 + mk_map_of_bnf Ds (passiveAs @ Ts) (passiveAs @ active_initTs)) Dss bnfs;
41.978 + val fTs = map2 (curry op -->) Ts activeAs;
41.979 + val foldT = Library.foldr1 HOLogic.mk_prodT (map2 (curry op -->) Ts activeAs);
41.980 + val rec_sTs = map (Term.typ_subst_atomic (activeBs ~~ Ts)) prod_sTs;
41.981 + val rec_maps = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_fsts;
41.982 + val rec_maps_rev = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_fsts_rev;
41.983 + val rec_fsts = map (Term.subst_atomic_types (activeBs ~~ Ts)) fsts;
41.984 +
41.985 + val (((((((((Izs1, Izs1'), (Izs2, Izs2')), (xFs, xFs')), yFs), (AFss, AFss')),
41.986 + (fold_f, fold_f')), fs), rec_ss), names_lthy) = names_lthy
41.987 + |> mk_Frees' "z1" Ts
41.988 + ||>> mk_Frees' "z2" Ts'
41.989 + ||>> mk_Frees' "x" FTs
41.990 + ||>> mk_Frees "y" FTs'
41.991 + ||>> mk_Freess' "z" setFTss
41.992 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "f") foldT
41.993 + ||>> mk_Frees "f" fTs
41.994 + ||>> mk_Frees "s" rec_sTs;
41.995 +
41.996 + val Izs = map2 retype_free Ts zs;
41.997 + val phis = map2 retype_free (map mk_pred1T Ts) init_phis;
41.998 + val phi2s = map2 retype_free (map2 mk_pred2T Ts Ts') init_phis;
41.999 +
41.1000 + fun ctor_bind i = Binding.suffix_name ("_" ^ ctorN) (nth bs (i - 1));
41.1001 + val ctor_name = Binding.name_of o ctor_bind;
41.1002 + val ctor_def_bind = rpair [] o Thm.def_binding o ctor_bind;
41.1003 +
41.1004 + fun ctor_spec i abs str map_FT_init x x' =
41.1005 + let
41.1006 + val ctorT = nth FTs (i - 1) --> nth Ts (i - 1);
41.1007 +
41.1008 + val lhs = Free (ctor_name i, ctorT);
41.1009 + val rhs = Term.absfree x' (abs $ (str $
41.1010 + (Term.list_comb (map_FT_init, map HOLogic.id_const passiveAs @ Rep_Ts) $ x)));
41.1011 + in
41.1012 + mk_Trueprop_eq (lhs, rhs)
41.1013 + end;
41.1014 +
41.1015 + val ((ctor_frees, (_, ctor_def_frees)), (lthy, lthy_old)) =
41.1016 + lthy
41.1017 + |> fold_map6 (fn i => fn abs => fn str => fn mapx => fn x => fn x' =>
41.1018 + Specification.definition
41.1019 + (SOME (ctor_bind i, NONE, NoSyn), (ctor_def_bind i, ctor_spec i abs str mapx x x')))
41.1020 + ks Abs_Ts str_inits map_FT_inits xFs xFs'
41.1021 + |>> apsnd split_list o split_list
41.1022 + ||> `Local_Theory.restore;
41.1023 +
41.1024 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.1025 + fun mk_ctors passive =
41.1026 + map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ (mk_params passive)) o
41.1027 + Morphism.term phi) ctor_frees;
41.1028 + val ctors = mk_ctors passiveAs;
41.1029 + val ctor's = mk_ctors passiveBs;
41.1030 + val ctor_defs = map (Morphism.thm phi) ctor_def_frees;
41.1031 +
41.1032 + val (mor_Rep_thm, mor_Abs_thm) =
41.1033 + let
41.1034 + val copy = alg_init_thm RS copy_alg_thm;
41.1035 + fun mk_bij inj Rep cases = @{thm bij_betwI'} OF [inj, Rep, cases];
41.1036 + val bijs = map3 mk_bij Rep_injects Reps Rep_casess;
41.1037 + val mor_Rep =
41.1038 + Skip_Proof.prove lthy [] []
41.1039 + (HOLogic.mk_Trueprop (mk_mor UNIVs ctors car_inits str_inits Rep_Ts))
41.1040 + (mk_mor_Rep_tac ctor_defs copy bijs inver_Abss inver_Reps)
41.1041 + |> Thm.close_derivation;
41.1042 +
41.1043 + val inv = mor_inv_thm OF [mor_Rep, talg_thm, alg_init_thm];
41.1044 + val mor_Abs =
41.1045 + Skip_Proof.prove lthy [] []
41.1046 + (HOLogic.mk_Trueprop (mk_mor car_inits str_inits UNIVs ctors Abs_Ts))
41.1047 + (K (mk_mor_Abs_tac inv inver_Abss inver_Reps))
41.1048 + |> Thm.close_derivation;
41.1049 + in
41.1050 + (mor_Rep, mor_Abs)
41.1051 + end;
41.1052 +
41.1053 + val timer = time (timer "ctor definitions & thms");
41.1054 +
41.1055 + val fold_fun = Term.absfree fold_f'
41.1056 + (mk_mor UNIVs ctors active_UNIVs ss (map (mk_nthN n fold_f) ks));
41.1057 + val foldx = HOLogic.choice_const foldT $ fold_fun;
41.1058 +
41.1059 + fun fold_bind i = Binding.suffix_name ("_" ^ ctor_foldN) (nth bs (i - 1));
41.1060 + val fold_name = Binding.name_of o fold_bind;
41.1061 + val fold_def_bind = rpair [] o Thm.def_binding o fold_bind;
41.1062 +
41.1063 + fun fold_spec i T AT =
41.1064 + let
41.1065 + val foldT = Library.foldr (op -->) (sTs, T --> AT);
41.1066 +
41.1067 + val lhs = Term.list_comb (Free (fold_name i, foldT), ss);
41.1068 + val rhs = mk_nthN n foldx i;
41.1069 + in
41.1070 + mk_Trueprop_eq (lhs, rhs)
41.1071 + end;
41.1072 +
41.1073 + val ((fold_frees, (_, fold_def_frees)), (lthy, lthy_old)) =
41.1074 + lthy
41.1075 + |> fold_map3 (fn i => fn T => fn AT =>
41.1076 + Specification.definition
41.1077 + (SOME (fold_bind i, NONE, NoSyn), (fold_def_bind i, fold_spec i T AT)))
41.1078 + ks Ts activeAs
41.1079 + |>> apsnd split_list o split_list
41.1080 + ||> `Local_Theory.restore;
41.1081 +
41.1082 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.1083 + val folds = map (Morphism.term phi) fold_frees;
41.1084 + val fold_names = map (fst o dest_Const) folds;
41.1085 + fun mk_fold Ts ss i = Term.list_comb (Const (nth fold_names (i - 1), Library.foldr (op -->)
41.1086 + (map fastype_of ss, nth Ts (i - 1) --> range_type (fastype_of (nth ss (i - 1))))), ss);
41.1087 + val fold_defs = map (Morphism.thm phi) fold_def_frees;
41.1088 +
41.1089 + val mor_fold_thm =
41.1090 + let
41.1091 + val ex_mor = talg_thm RS init_ex_mor_thm;
41.1092 + val mor_cong = mor_cong_thm OF (map (mk_nth_conv n) ks);
41.1093 + val mor_comp = mor_Rep_thm RS mor_comp_thm;
41.1094 + val cT = certifyT lthy foldT;
41.1095 + val ct = certify lthy fold_fun
41.1096 + in
41.1097 + singleton (Proof_Context.export names_lthy lthy)
41.1098 + (Skip_Proof.prove lthy [] []
41.1099 + (HOLogic.mk_Trueprop (mk_mor UNIVs ctors active_UNIVs ss (map (mk_fold Ts ss) ks)))
41.1100 + (K (mk_mor_fold_tac cT ct fold_defs ex_mor (mor_comp RS mor_cong))))
41.1101 + |> Thm.close_derivation
41.1102 + end;
41.1103 +
41.1104 + val ctor_fold_thms = map (fn morE => rule_by_tactic lthy
41.1105 + ((rtac CollectI THEN' CONJ_WRAP' (K (rtac @{thm subset_UNIV})) (1 upto m + n)) 1)
41.1106 + (mor_fold_thm RS morE)) morE_thms;
41.1107 +
41.1108 + val (fold_unique_mor_thms, fold_unique_mor_thm) =
41.1109 + let
41.1110 + val prem = HOLogic.mk_Trueprop (mk_mor UNIVs ctors active_UNIVs ss fs);
41.1111 + fun mk_fun_eq f i = HOLogic.mk_eq (f, mk_fold Ts ss i);
41.1112 + val unique = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_fun_eq fs ks));
41.1113 + val unique_mor = Skip_Proof.prove lthy [] []
41.1114 + (fold_rev Logic.all (ss @ fs) (Logic.mk_implies (prem, unique)))
41.1115 + (K (mk_fold_unique_mor_tac type_defs init_unique_mor_thms Reps
41.1116 + mor_comp_thm mor_Abs_thm mor_fold_thm))
41.1117 + |> Thm.close_derivation;
41.1118 + in
41.1119 + `split_conj_thm unique_mor
41.1120 + end;
41.1121 +
41.1122 + val ctor_fold_unique_thms =
41.1123 + split_conj_thm (mk_conjIN n RS
41.1124 + (mor_UNIV_thm RS @{thm ssubst[of _ _ "%x. x"]} RS fold_unique_mor_thm))
41.1125 +
41.1126 + val fold_ctor_thms =
41.1127 + map (fn thm => (mor_incl_thm OF replicate n @{thm subset_UNIV}) RS thm RS sym)
41.1128 + fold_unique_mor_thms;
41.1129 +
41.1130 + val ctor_o_fold_thms =
41.1131 + let
41.1132 + val mor = mor_comp_thm OF [mor_fold_thm, mor_str_thm];
41.1133 + in
41.1134 + map2 (fn unique => fn fold_ctor =>
41.1135 + trans OF [mor RS unique, fold_ctor]) fold_unique_mor_thms fold_ctor_thms
41.1136 + end;
41.1137 +
41.1138 + val timer = time (timer "fold definitions & thms");
41.1139 +
41.1140 + val map_ctors = map2 (fn Ds => fn bnf =>
41.1141 + Term.list_comb (mk_map_of_bnf Ds (passiveAs @ FTs) (passiveAs @ Ts) bnf,
41.1142 + map HOLogic.id_const passiveAs @ ctors)) Dss bnfs;
41.1143 +
41.1144 + fun dtor_bind i = Binding.suffix_name ("_" ^ dtorN) (nth bs (i - 1));
41.1145 + val dtor_name = Binding.name_of o dtor_bind;
41.1146 + val dtor_def_bind = rpair [] o Thm.def_binding o dtor_bind;
41.1147 +
41.1148 + fun dtor_spec i FT T =
41.1149 + let
41.1150 + val dtorT = T --> FT;
41.1151 +
41.1152 + val lhs = Free (dtor_name i, dtorT);
41.1153 + val rhs = mk_fold Ts map_ctors i;
41.1154 + in
41.1155 + mk_Trueprop_eq (lhs, rhs)
41.1156 + end;
41.1157 +
41.1158 + val ((dtor_frees, (_, dtor_def_frees)), (lthy, lthy_old)) =
41.1159 + lthy
41.1160 + |> fold_map3 (fn i => fn FT => fn T =>
41.1161 + Specification.definition
41.1162 + (SOME (dtor_bind i, NONE, NoSyn), (dtor_def_bind i, dtor_spec i FT T))) ks FTs Ts
41.1163 + |>> apsnd split_list o split_list
41.1164 + ||> `Local_Theory.restore;
41.1165 +
41.1166 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.1167 + fun mk_dtors params =
41.1168 + map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ params) o Morphism.term phi)
41.1169 + dtor_frees;
41.1170 + val dtors = mk_dtors params';
41.1171 + val dtor_defs = map (Morphism.thm phi) dtor_def_frees;
41.1172 +
41.1173 + val ctor_o_dtor_thms = map2 (fold_thms lthy o single) dtor_defs ctor_o_fold_thms;
41.1174 +
41.1175 + val dtor_o_ctor_thms =
41.1176 + let
41.1177 + fun mk_goal dtor ctor FT =
41.1178 + mk_Trueprop_eq (HOLogic.mk_comp (dtor, ctor), HOLogic.id_const FT);
41.1179 + val goals = map3 mk_goal dtors ctors FTs;
41.1180 + in
41.1181 + map5 (fn goal => fn dtor_def => fn foldx => fn map_comp_id => fn map_congL =>
41.1182 + Skip_Proof.prove lthy [] [] goal
41.1183 + (K (mk_dtor_o_ctor_tac dtor_def foldx map_comp_id map_congL ctor_o_fold_thms))
41.1184 + |> Thm.close_derivation)
41.1185 + goals dtor_defs ctor_fold_thms map_comp_id_thms map_congL_thms
41.1186 + end;
41.1187 +
41.1188 + val dtor_ctor_thms = map (fn thm => thm RS @{thm pointfree_idE}) dtor_o_ctor_thms;
41.1189 + val ctor_dtor_thms = map (fn thm => thm RS @{thm pointfree_idE}) ctor_o_dtor_thms;
41.1190 +
41.1191 + val bij_dtor_thms =
41.1192 + map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) ctor_o_dtor_thms dtor_o_ctor_thms;
41.1193 + val inj_dtor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_dtor_thms;
41.1194 + val surj_dtor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_dtor_thms;
41.1195 + val dtor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_dtor_thms;
41.1196 + val dtor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_dtor_thms;
41.1197 + val dtor_exhaust_thms = map (fn thm => thm RS exE) dtor_nchotomy_thms;
41.1198 +
41.1199 + val bij_ctor_thms =
41.1200 + map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) dtor_o_ctor_thms ctor_o_dtor_thms;
41.1201 + val inj_ctor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_ctor_thms;
41.1202 + val surj_ctor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_ctor_thms;
41.1203 + val ctor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_ctor_thms;
41.1204 + val ctor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_ctor_thms;
41.1205 + val ctor_exhaust_thms = map (fn thm => thm RS exE) ctor_nchotomy_thms;
41.1206 +
41.1207 + val timer = time (timer "dtor definitions & thms");
41.1208 +
41.1209 + val fst_rec_pair_thms =
41.1210 + let
41.1211 + val mor = mor_comp_thm OF [mor_fold_thm, mor_convol_thm];
41.1212 + in
41.1213 + map2 (fn unique => fn fold_ctor =>
41.1214 + trans OF [mor RS unique, fold_ctor]) fold_unique_mor_thms fold_ctor_thms
41.1215 + end;
41.1216 +
41.1217 + fun rec_bind i = Binding.suffix_name ("_" ^ ctor_recN) (nth bs (i - 1));
41.1218 + val rec_name = Binding.name_of o rec_bind;
41.1219 + val rec_def_bind = rpair [] o Thm.def_binding o rec_bind;
41.1220 +
41.1221 + fun rec_spec i T AT =
41.1222 + let
41.1223 + val recT = Library.foldr (op -->) (rec_sTs, T --> AT);
41.1224 + val maps = map3 (fn ctor => fn prod_s => fn mapx =>
41.1225 + mk_convol (HOLogic.mk_comp (ctor, Term.list_comb (mapx, passive_ids @ rec_fsts)), prod_s))
41.1226 + ctors rec_ss rec_maps;
41.1227 +
41.1228 + val lhs = Term.list_comb (Free (rec_name i, recT), rec_ss);
41.1229 + val rhs = HOLogic.mk_comp (snd_const (HOLogic.mk_prodT (T, AT)), mk_fold Ts maps i);
41.1230 + in
41.1231 + mk_Trueprop_eq (lhs, rhs)
41.1232 + end;
41.1233 +
41.1234 + val ((rec_frees, (_, rec_def_frees)), (lthy, lthy_old)) =
41.1235 + lthy
41.1236 + |> fold_map3 (fn i => fn T => fn AT =>
41.1237 + Specification.definition
41.1238 + (SOME (rec_bind i, NONE, NoSyn), (rec_def_bind i, rec_spec i T AT)))
41.1239 + ks Ts activeAs
41.1240 + |>> apsnd split_list o split_list
41.1241 + ||> `Local_Theory.restore;
41.1242 +
41.1243 + val phi = Proof_Context.export_morphism lthy_old lthy;
41.1244 + val recs = map (Morphism.term phi) rec_frees;
41.1245 + val rec_names = map (fst o dest_Const) recs;
41.1246 + fun mk_rec ss i = Term.list_comb (Const (nth rec_names (i - 1), Library.foldr (op -->)
41.1247 + (map fastype_of ss, nth Ts (i - 1) --> range_type (fastype_of (nth ss (i - 1))))), ss);
41.1248 + val rec_defs = map (Morphism.thm phi) rec_def_frees;
41.1249 +
41.1250 + val convols = map2 (fn T => fn i => mk_convol (HOLogic.id_const T, mk_rec rec_ss i)) Ts ks;
41.1251 + val ctor_rec_thms =
41.1252 + let
41.1253 + fun mk_goal i rec_s rec_map ctor x =
41.1254 + let
41.1255 + val lhs = mk_rec rec_ss i $ (ctor $ x);
41.1256 + val rhs = rec_s $ (Term.list_comb (rec_map, passive_ids @ convols) $ x);
41.1257 + in
41.1258 + fold_rev Logic.all (x :: rec_ss) (mk_Trueprop_eq (lhs, rhs))
41.1259 + end;
41.1260 + val goals = map5 mk_goal ks rec_ss rec_maps_rev ctors xFs;
41.1261 + in
41.1262 + map2 (fn goal => fn foldx =>
41.1263 + Skip_Proof.prove lthy [] [] goal (mk_rec_tac rec_defs foldx fst_rec_pair_thms)
41.1264 + |> Thm.close_derivation)
41.1265 + goals ctor_fold_thms
41.1266 + end;
41.1267 +
41.1268 + val timer = time (timer "rec definitions & thms");
41.1269 +
41.1270 + val (ctor_induct_thm, induct_params) =
41.1271 + let
41.1272 + fun mk_prem phi ctor sets x =
41.1273 + let
41.1274 + fun mk_IH phi set z =
41.1275 + let
41.1276 + val prem = HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x));
41.1277 + val concl = HOLogic.mk_Trueprop (phi $ z);
41.1278 + in
41.1279 + Logic.all z (Logic.mk_implies (prem, concl))
41.1280 + end;
41.1281 +
41.1282 + val IHs = map3 mk_IH phis (drop m sets) Izs;
41.1283 + val concl = HOLogic.mk_Trueprop (phi $ (ctor $ x));
41.1284 + in
41.1285 + Logic.all x (Logic.list_implies (IHs, concl))
41.1286 + end;
41.1287 +
41.1288 + val prems = map4 mk_prem phis ctors FTs_setss xFs;
41.1289 +
41.1290 + fun mk_concl phi z = phi $ z;
41.1291 + val concl =
41.1292 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_concl phis Izs));
41.1293 +
41.1294 + val goal = Logic.list_implies (prems, concl);
41.1295 + in
41.1296 + (Skip_Proof.prove lthy [] []
41.1297 + (fold_rev Logic.all (phis @ Izs) goal)
41.1298 + (K (mk_ctor_induct_tac m set_natural'ss init_induct_thm morE_thms mor_Abs_thm
41.1299 + Rep_inverses Abs_inverses Reps))
41.1300 + |> Thm.close_derivation,
41.1301 + rev (Term.add_tfrees goal []))
41.1302 + end;
41.1303 +
41.1304 + val cTs = map (SOME o certifyT lthy o TFree) induct_params;
41.1305 +
41.1306 + val weak_ctor_induct_thms =
41.1307 + let fun insts i = (replicate (i - 1) TrueI) @ (@{thm asm_rl} :: replicate (n - i) TrueI);
41.1308 + in map (fn i => (ctor_induct_thm OF insts i) RS mk_conjunctN n i) ks end;
41.1309 +
41.1310 + val (ctor_induct2_thm, induct2_params) =
41.1311 + let
41.1312 + fun mk_prem phi ctor ctor' sets sets' x y =
41.1313 + let
41.1314 + fun mk_IH phi set set' z1 z2 =
41.1315 + let
41.1316 + val prem1 = HOLogic.mk_Trueprop (HOLogic.mk_mem (z1, (set $ x)));
41.1317 + val prem2 = HOLogic.mk_Trueprop (HOLogic.mk_mem (z2, (set' $ y)));
41.1318 + val concl = HOLogic.mk_Trueprop (phi $ z1 $ z2);
41.1319 + in
41.1320 + fold_rev Logic.all [z1, z2] (Logic.list_implies ([prem1, prem2], concl))
41.1321 + end;
41.1322 +
41.1323 + val IHs = map5 mk_IH phi2s (drop m sets) (drop m sets') Izs1 Izs2;
41.1324 + val concl = HOLogic.mk_Trueprop (phi $ (ctor $ x) $ (ctor' $ y));
41.1325 + in
41.1326 + fold_rev Logic.all [x, y] (Logic.list_implies (IHs, concl))
41.1327 + end;
41.1328 +
41.1329 + val prems = map7 mk_prem phi2s ctors ctor's FTs_setss FTs'_setss xFs yFs;
41.1330 +
41.1331 + fun mk_concl phi z1 z2 = phi $ z1 $ z2;
41.1332 + val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.1333 + (map3 mk_concl phi2s Izs1 Izs2));
41.1334 + fun mk_t phi (z1, z1') (z2, z2') =
41.1335 + Term.absfree z1' (HOLogic.mk_all (fst z2', snd z2', phi $ z1 $ z2));
41.1336 + val cts = map3 (SOME o certify lthy ooo mk_t) phi2s (Izs1 ~~ Izs1') (Izs2 ~~ Izs2');
41.1337 + val goal = Logic.list_implies (prems, concl);
41.1338 + in
41.1339 + (singleton (Proof_Context.export names_lthy lthy)
41.1340 + (Skip_Proof.prove lthy [] [] goal
41.1341 + (mk_ctor_induct2_tac cTs cts ctor_induct_thm weak_ctor_induct_thms))
41.1342 + |> Thm.close_derivation,
41.1343 + rev (Term.add_tfrees goal []))
41.1344 + end;
41.1345 +
41.1346 + val timer = time (timer "induction");
41.1347 +
41.1348 + (*register new datatypes as BNFs*)
41.1349 + val lthy = if m = 0 then lthy else
41.1350 + let
41.1351 + val fTs = map2 (curry op -->) passiveAs passiveBs;
41.1352 + val f1Ts = map2 (curry op -->) passiveAs passiveYs;
41.1353 + val f2Ts = map2 (curry op -->) passiveBs passiveYs;
41.1354 + val p1Ts = map2 (curry op -->) passiveXs passiveAs;
41.1355 + val p2Ts = map2 (curry op -->) passiveXs passiveBs;
41.1356 + val uTs = map2 (curry op -->) Ts Ts';
41.1357 + val B1Ts = map HOLogic.mk_setT passiveAs;
41.1358 + val B2Ts = map HOLogic.mk_setT passiveBs;
41.1359 + val AXTs = map HOLogic.mk_setT passiveXs;
41.1360 + val XTs = mk_Ts passiveXs;
41.1361 + val YTs = mk_Ts passiveYs;
41.1362 + val IRTs = map2 (curry mk_relT) passiveAs passiveBs;
41.1363 + val IphiTs = map2 mk_pred2T passiveAs passiveBs;
41.1364 +
41.1365 + val (((((((((((((((fs, fs'), fs_copy), us),
41.1366 + B1s), B2s), AXs), (xs, xs')), f1s), f2s), p1s), p2s), (ys, ys')), IRs), Iphis),
41.1367 + names_lthy) = names_lthy
41.1368 + |> mk_Frees' "f" fTs
41.1369 + ||>> mk_Frees "f" fTs
41.1370 + ||>> mk_Frees "u" uTs
41.1371 + ||>> mk_Frees "B1" B1Ts
41.1372 + ||>> mk_Frees "B2" B2Ts
41.1373 + ||>> mk_Frees "A" AXTs
41.1374 + ||>> mk_Frees' "x" XTs
41.1375 + ||>> mk_Frees "f1" f1Ts
41.1376 + ||>> mk_Frees "f2" f2Ts
41.1377 + ||>> mk_Frees "p1" p1Ts
41.1378 + ||>> mk_Frees "p2" p2Ts
41.1379 + ||>> mk_Frees' "y" passiveAs
41.1380 + ||>> mk_Frees "R" IRTs
41.1381 + ||>> mk_Frees "P" IphiTs;
41.1382 +
41.1383 + val map_FTFT's = map2 (fn Ds =>
41.1384 + mk_map_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
41.1385 + fun mk_passive_maps ATs BTs Ts =
41.1386 + map2 (fn Ds => mk_map_of_bnf Ds (ATs @ Ts) (BTs @ Ts)) Dss bnfs;
41.1387 + fun mk_map_fold_arg fs Ts ctor fmap =
41.1388 + HOLogic.mk_comp (ctor, Term.list_comb (fmap, fs @ map HOLogic.id_const Ts));
41.1389 + fun mk_map Ts fs Ts' ctors mk_maps =
41.1390 + mk_fold Ts (map2 (mk_map_fold_arg fs Ts') ctors (mk_maps Ts'));
41.1391 + val pmapsABT' = mk_passive_maps passiveAs passiveBs;
41.1392 + val fs_maps = map (mk_map Ts fs Ts' ctor's pmapsABT') ks;
41.1393 + val fs_copy_maps = map (mk_map Ts fs_copy Ts' ctor's pmapsABT') ks;
41.1394 + val Yctors = mk_ctors passiveYs;
41.1395 + val f1s_maps = map (mk_map Ts f1s YTs Yctors (mk_passive_maps passiveAs passiveYs)) ks;
41.1396 + val f2s_maps = map (mk_map Ts' f2s YTs Yctors (mk_passive_maps passiveBs passiveYs)) ks;
41.1397 + val p1s_maps = map (mk_map XTs p1s Ts ctors (mk_passive_maps passiveXs passiveAs)) ks;
41.1398 + val p2s_maps = map (mk_map XTs p2s Ts' ctor's (mk_passive_maps passiveXs passiveBs)) ks;
41.1399 +
41.1400 + val map_simp_thms =
41.1401 + let
41.1402 + fun mk_goal fs_map map ctor ctor' = fold_rev Logic.all fs
41.1403 + (mk_Trueprop_eq (HOLogic.mk_comp (fs_map, ctor),
41.1404 + HOLogic.mk_comp (ctor', Term.list_comb (map, fs @ fs_maps))));
41.1405 + val goals = map4 mk_goal fs_maps map_FTFT's ctors ctor's;
41.1406 + val maps =
41.1407 + map4 (fn goal => fn foldx => fn map_comp_id => fn map_cong =>
41.1408 + Skip_Proof.prove lthy [] [] goal (K (mk_map_tac m n foldx map_comp_id map_cong))
41.1409 + |> Thm.close_derivation)
41.1410 + goals ctor_fold_thms map_comp_id_thms map_congs;
41.1411 + in
41.1412 + map (fn thm => thm RS @{thm pointfreeE}) maps
41.1413 + end;
41.1414 +
41.1415 + val (map_unique_thms, map_unique_thm) =
41.1416 + let
41.1417 + fun mk_prem u map ctor ctor' =
41.1418 + mk_Trueprop_eq (HOLogic.mk_comp (u, ctor),
41.1419 + HOLogic.mk_comp (ctor', Term.list_comb (map, fs @ us)));
41.1420 + val prems = map4 mk_prem us map_FTFT's ctors ctor's;
41.1421 + val goal =
41.1422 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.1423 + (map2 (curry HOLogic.mk_eq) us fs_maps));
41.1424 + val unique = Skip_Proof.prove lthy [] []
41.1425 + (fold_rev Logic.all (us @ fs) (Logic.list_implies (prems, goal)))
41.1426 + (K (mk_map_unique_tac m mor_def fold_unique_mor_thm map_comp_id_thms map_congs))
41.1427 + |> Thm.close_derivation;
41.1428 + in
41.1429 + `split_conj_thm unique
41.1430 + end;
41.1431 +
41.1432 + val timer = time (timer "map functions for the new datatypes");
41.1433 +
41.1434 + val bd = mk_cpow sum_bd;
41.1435 + val bd_Cinfinite = sum_Cinfinite RS @{thm Cinfinite_cpow};
41.1436 + fun mk_cpow_bd thm = @{thm ordLeq_transitive} OF
41.1437 + [thm, sum_Card_order RS @{thm cpow_greater_eq}];
41.1438 + val set_bd_cpowss = map (map mk_cpow_bd) set_bd_sumss;
41.1439 +
41.1440 + val timer = time (timer "bounds for the new datatypes");
41.1441 +
41.1442 + val ls = 1 upto m;
41.1443 + val setsss = map (mk_setss o mk_set_Ts) passiveAs;
41.1444 + val map_setss = map (fn T => map2 (fn Ds =>
41.1445 + mk_map_of_bnf Ds (passiveAs @ Ts) (mk_set_Ts T)) Dss bnfs) passiveAs;
41.1446 +
41.1447 + fun mk_col l T z z' sets =
41.1448 + let
41.1449 + fun mk_UN set = mk_Union T $ (set $ z);
41.1450 + in
41.1451 + Term.absfree z'
41.1452 + (mk_union (nth sets (l - 1) $ z,
41.1453 + Library.foldl1 mk_union (map mk_UN (drop m sets))))
41.1454 + end;
41.1455 +
41.1456 + val colss = map5 (fn l => fn T => map3 (mk_col l T)) ls passiveAs AFss AFss' setsss;
41.1457 + val setss_by_range = map (fn cols => map (mk_fold Ts cols) ks) colss;
41.1458 + val setss_by_bnf = transpose setss_by_range;
41.1459 +
41.1460 + val set_simp_thmss =
41.1461 + let
41.1462 + fun mk_goal sets ctor set col map =
41.1463 + mk_Trueprop_eq (HOLogic.mk_comp (set, ctor),
41.1464 + HOLogic.mk_comp (col, Term.list_comb (map, passive_ids @ sets)));
41.1465 + val goalss =
41.1466 + map3 (fn sets => map4 (mk_goal sets) ctors sets) setss_by_range colss map_setss;
41.1467 + val setss = map (map2 (fn foldx => fn goal =>
41.1468 + Skip_Proof.prove lthy [] [] goal (K (mk_set_tac foldx)) |> Thm.close_derivation)
41.1469 + ctor_fold_thms) goalss;
41.1470 +
41.1471 + fun mk_simp_goal pas_set act_sets sets ctor z set =
41.1472 + Logic.all z (mk_Trueprop_eq (set $ (ctor $ z),
41.1473 + mk_union (pas_set $ z,
41.1474 + Library.foldl1 mk_union (map2 (fn X => mk_UNION (X $ z)) act_sets sets))));
41.1475 + val simp_goalss =
41.1476 + map2 (fn i => fn sets =>
41.1477 + map4 (fn Fsets => mk_simp_goal (nth Fsets (i - 1)) (drop m Fsets) sets)
41.1478 + FTs_setss ctors xFs sets)
41.1479 + ls setss_by_range;
41.1480 +
41.1481 + val set_simpss = map3 (fn i => map3 (fn set_nats => fn goal => fn set =>
41.1482 + Skip_Proof.prove lthy [] [] goal
41.1483 + (K (mk_set_simp_tac set (nth set_nats (i - 1)) (drop m set_nats)))
41.1484 + |> Thm.close_derivation)
41.1485 + set_natural'ss) ls simp_goalss setss;
41.1486 + in
41.1487 + set_simpss
41.1488 + end;
41.1489 +
41.1490 + fun mk_set_thms set_simp = (@{thm xt1(3)} OF [set_simp, @{thm Un_upper1}]) ::
41.1491 + map (fn i => (@{thm xt1(3)} OF [set_simp, @{thm Un_upper2}]) RS
41.1492 + (mk_Un_upper n i RS subset_trans) RSN
41.1493 + (2, @{thm UN_upper} RS subset_trans))
41.1494 + (1 upto n);
41.1495 + val Fset_set_thmsss = transpose (map (map mk_set_thms) set_simp_thmss);
41.1496 +
41.1497 + val timer = time (timer "set functions for the new datatypes");
41.1498 +
41.1499 + val cxs = map (SOME o certify lthy) Izs;
41.1500 + val setss_by_bnf' =
41.1501 + map (map (Term.subst_atomic_types (passiveAs ~~ passiveBs))) setss_by_bnf;
41.1502 + val setss_by_range' = transpose setss_by_bnf';
41.1503 +
41.1504 + val set_natural_thmss =
41.1505 + let
41.1506 + fun mk_set_natural f map z set set' =
41.1507 + HOLogic.mk_eq (mk_image f $ (set $ z), set' $ (map $ z));
41.1508 +
41.1509 + fun mk_cphi f map z set set' = certify lthy
41.1510 + (Term.absfree (dest_Free z) (mk_set_natural f map z set set'));
41.1511 +
41.1512 + val csetss = map (map (certify lthy)) setss_by_range';
41.1513 +
41.1514 + val cphiss = map3 (fn f => fn sets => fn sets' =>
41.1515 + (map4 (mk_cphi f) fs_maps Izs sets sets')) fs setss_by_range setss_by_range';
41.1516 +
41.1517 + val inducts = map (fn cphis =>
41.1518 + Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm) cphiss;
41.1519 +
41.1520 + val goals =
41.1521 + map3 (fn f => fn sets => fn sets' =>
41.1522 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.1523 + (map4 (mk_set_natural f) fs_maps Izs sets sets')))
41.1524 + fs setss_by_range setss_by_range';
41.1525 +
41.1526 + fun mk_tac induct = mk_set_nat_tac m (rtac induct) set_natural'ss map_simp_thms;
41.1527 + val thms =
41.1528 + map5 (fn goal => fn csets => fn set_simps => fn induct => fn i =>
41.1529 + singleton (Proof_Context.export names_lthy lthy)
41.1530 + (Skip_Proof.prove lthy [] [] goal (mk_tac induct csets set_simps i))
41.1531 + |> Thm.close_derivation)
41.1532 + goals csetss set_simp_thmss inducts ls;
41.1533 + in
41.1534 + map split_conj_thm thms
41.1535 + end;
41.1536 +
41.1537 + val set_bd_thmss =
41.1538 + let
41.1539 + fun mk_set_bd z set = mk_ordLeq (mk_card_of (set $ z)) bd;
41.1540 +
41.1541 + fun mk_cphi z set = certify lthy (Term.absfree (dest_Free z) (mk_set_bd z set));
41.1542 +
41.1543 + val cphiss = map (map2 mk_cphi Izs) setss_by_range;
41.1544 +
41.1545 + val inducts = map (fn cphis =>
41.1546 + Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm) cphiss;
41.1547 +
41.1548 + val goals =
41.1549 + map (fn sets =>
41.1550 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.1551 + (map2 mk_set_bd Izs sets))) setss_by_range;
41.1552 +
41.1553 + fun mk_tac induct = mk_set_bd_tac m (rtac induct) bd_Cinfinite set_bd_cpowss;
41.1554 + val thms =
41.1555 + map4 (fn goal => fn set_simps => fn induct => fn i =>
41.1556 + singleton (Proof_Context.export names_lthy lthy)
41.1557 + (Skip_Proof.prove lthy [] [] goal (mk_tac induct set_simps i))
41.1558 + |> Thm.close_derivation)
41.1559 + goals set_simp_thmss inducts ls;
41.1560 + in
41.1561 + map split_conj_thm thms
41.1562 + end;
41.1563 +
41.1564 + val map_cong_thms =
41.1565 + let
41.1566 + fun mk_prem z set f g y y' =
41.1567 + mk_Ball (set $ z) (Term.absfree y' (HOLogic.mk_eq (f $ y, g $ y)));
41.1568 +
41.1569 + fun mk_map_cong sets z fmap gmap =
41.1570 + HOLogic.mk_imp
41.1571 + (Library.foldr1 HOLogic.mk_conj (map5 (mk_prem z) sets fs fs_copy ys ys'),
41.1572 + HOLogic.mk_eq (fmap $ z, gmap $ z));
41.1573 +
41.1574 + fun mk_cphi sets z fmap gmap =
41.1575 + certify lthy (Term.absfree (dest_Free z) (mk_map_cong sets z fmap gmap));
41.1576 +
41.1577 + val cphis = map4 mk_cphi setss_by_bnf Izs fs_maps fs_copy_maps;
41.1578 +
41.1579 + val induct = Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm;
41.1580 +
41.1581 + val goal =
41.1582 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.1583 + (map4 mk_map_cong setss_by_bnf Izs fs_maps fs_copy_maps));
41.1584 +
41.1585 + val thm = singleton (Proof_Context.export names_lthy lthy)
41.1586 + (Skip_Proof.prove lthy [] [] goal
41.1587 + (mk_mcong_tac (rtac induct) Fset_set_thmsss map_congs map_simp_thms))
41.1588 + |> Thm.close_derivation;
41.1589 + in
41.1590 + split_conj_thm thm
41.1591 + end;
41.1592 +
41.1593 + val in_incl_min_alg_thms =
41.1594 + let
41.1595 + fun mk_prem z sets =
41.1596 + HOLogic.mk_mem (z, mk_in As sets (fastype_of z));
41.1597 +
41.1598 + fun mk_incl z sets i =
41.1599 + HOLogic.mk_imp (mk_prem z sets, HOLogic.mk_mem (z, mk_min_alg As ctors i));
41.1600 +
41.1601 + fun mk_cphi z sets i =
41.1602 + certify lthy (Term.absfree (dest_Free z) (mk_incl z sets i));
41.1603 +
41.1604 + val cphis = map3 mk_cphi Izs setss_by_bnf ks;
41.1605 +
41.1606 + val induct = Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm;
41.1607 +
41.1608 + val goal =
41.1609 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
41.1610 + (map3 mk_incl Izs setss_by_bnf ks));
41.1611 +
41.1612 + val thm = singleton (Proof_Context.export names_lthy lthy)
41.1613 + (Skip_Proof.prove lthy [] [] goal
41.1614 + (mk_incl_min_alg_tac (rtac induct) Fset_set_thmsss alg_set_thms alg_min_alg_thm))
41.1615 + |> Thm.close_derivation;
41.1616 + in
41.1617 + split_conj_thm thm
41.1618 + end;
41.1619 +
41.1620 + val Xsetss = map (map (Term.subst_atomic_types (passiveAs ~~ passiveXs))) setss_by_bnf;
41.1621 +
41.1622 + val map_wpull_thms =
41.1623 + let
41.1624 + val cTs = map (SOME o certifyT lthy o TFree) induct2_params;
41.1625 + val cxs = map (SOME o certify lthy) (interleave Izs1 Izs2);
41.1626 +
41.1627 + fun mk_prem z1 z2 sets1 sets2 map1 map2 =
41.1628 + HOLogic.mk_conj
41.1629 + (HOLogic.mk_mem (z1, mk_in B1s sets1 (fastype_of z1)),
41.1630 + HOLogic.mk_conj
41.1631 + (HOLogic.mk_mem (z2, mk_in B2s sets2 (fastype_of z2)),
41.1632 + HOLogic.mk_eq (map1 $ z1, map2 $ z2)));
41.1633 +
41.1634 + val prems = map6 mk_prem Izs1 Izs2 setss_by_bnf setss_by_bnf' f1s_maps f2s_maps;
41.1635 +
41.1636 + fun mk_concl z1 z2 sets map1 map2 T x x' =
41.1637 + mk_Bex (mk_in AXs sets T) (Term.absfree x'
41.1638 + (HOLogic.mk_conj (HOLogic.mk_eq (map1 $ x, z1), HOLogic.mk_eq (map2 $ x, z2))));
41.1639 +
41.1640 + val concls = map8 mk_concl Izs1 Izs2 Xsetss p1s_maps p2s_maps XTs xs xs';
41.1641 +
41.1642 + val goals = map2 (curry HOLogic.mk_imp) prems concls;
41.1643 +
41.1644 + fun mk_cphi z1 z2 goal = certify lthy (Term.absfree z1 (Term.absfree z2 goal));
41.1645 +
41.1646 + val cphis = map3 mk_cphi Izs1' Izs2' goals;
41.1647 +
41.1648 + val induct = Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct2_thm;
41.1649 +
41.1650 + val goal = Logic.list_implies (map HOLogic.mk_Trueprop
41.1651 + (map8 mk_wpull AXs B1s B2s f1s f2s (replicate m NONE) p1s p2s),
41.1652 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj goals));
41.1653 +
41.1654 + val thm = singleton (Proof_Context.export names_lthy lthy)
41.1655 + (Skip_Proof.prove lthy [] [] goal
41.1656 + (K (mk_lfp_map_wpull_tac m (rtac induct) map_wpulls map_simp_thms
41.1657 + (transpose set_simp_thmss) Fset_set_thmsss ctor_inject_thms)))
41.1658 + |> Thm.close_derivation;
41.1659 + in
41.1660 + split_conj_thm thm
41.1661 + end;
41.1662 +
41.1663 + val timer = time (timer "helpers for BNF properties");
41.1664 +
41.1665 + val map_id_tacs = map (K o mk_map_id_tac map_ids) map_unique_thms;
41.1666 + val map_comp_tacs =
41.1667 + map2 (K oo mk_map_comp_tac map_comp's map_simp_thms) map_unique_thms ks;
41.1668 + val map_cong_tacs = map (mk_map_cong_tac m) map_cong_thms;
41.1669 + val set_nat_tacss = map (map (K o mk_set_natural_tac)) (transpose set_natural_thmss);
41.1670 + val bd_co_tacs = replicate n (K (mk_bd_card_order_tac bd_card_orders));
41.1671 + val bd_cinf_tacs = replicate n (K (rtac (bd_Cinfinite RS conjunct1) 1));
41.1672 + val set_bd_tacss = map (map (fn thm => K (rtac thm 1))) (transpose set_bd_thmss);
41.1673 + val in_bd_tacs = map2 (K oo mk_in_bd_tac sum_Card_order suc_bd_Cnotzero)
41.1674 + in_incl_min_alg_thms card_of_min_alg_thms;
41.1675 + val map_wpull_tacs = map (K o mk_wpull_tac) map_wpull_thms;
41.1676 +
41.1677 + val srel_O_Gr_tacs = replicate n (simple_srel_O_Gr_tac o #context);
41.1678 +
41.1679 + val tacss = map10 zip_axioms map_id_tacs map_comp_tacs map_cong_tacs set_nat_tacss
41.1680 + bd_co_tacs bd_cinf_tacs set_bd_tacss in_bd_tacs map_wpull_tacs srel_O_Gr_tacs;
41.1681 +
41.1682 + val ctor_witss =
41.1683 + let
41.1684 + val witss = map2 (fn Ds => fn bnf => mk_wits_of_bnf
41.1685 + (replicate (nwits_of_bnf bnf) Ds)
41.1686 + (replicate (nwits_of_bnf bnf) (passiveAs @ Ts)) bnf) Dss bnfs;
41.1687 + fun close_wit (I, wit) = fold_rev Term.absfree (map (nth ys') I) wit;
41.1688 + fun wit_apply (arg_I, arg_wit) (fun_I, fun_wit) =
41.1689 + (union (op =) arg_I fun_I, fun_wit $ arg_wit);
41.1690 +
41.1691 + fun gen_arg support i =
41.1692 + if i < m then [([i], nth ys i)]
41.1693 + else maps (mk_wit support (nth ctors (i - m)) (i - m)) (nth support (i - m))
41.1694 + and mk_wit support ctor i (I, wit) =
41.1695 + let val args = map (gen_arg (nth_map i (remove (op =) (I, wit)) support)) I;
41.1696 + in
41.1697 + (args, [([], wit)])
41.1698 + |-> fold (map_product wit_apply)
41.1699 + |> map (apsnd (fn t => ctor $ t))
41.1700 + |> minimize_wits
41.1701 + end;
41.1702 + in
41.1703 + map3 (fn ctor => fn i => map close_wit o minimize_wits o maps (mk_wit witss ctor i))
41.1704 + ctors (0 upto n - 1) witss
41.1705 + end;
41.1706 +
41.1707 + fun wit_tac _ = mk_wit_tac n (flat set_simp_thmss) (maps wit_thms_of_bnf bnfs);
41.1708 +
41.1709 + val policy = user_policy Derive_All_Facts_Note_Most;
41.1710 +
41.1711 + val (Ibnfs, lthy) =
41.1712 + fold_map6 (fn tacs => fn b => fn mapx => fn sets => fn T => fn wits => fn lthy =>
41.1713 + bnf_def Dont_Inline policy I tacs wit_tac (SOME deads)
41.1714 + (((((b, fold_rev Term.absfree fs' mapx), sets), absdummy T bd), wits), NONE) lthy
41.1715 + |> register_bnf (Local_Theory.full_name lthy b))
41.1716 + tacss bs fs_maps setss_by_bnf Ts ctor_witss lthy;
41.1717 +
41.1718 + val fold_maps = fold_thms lthy (map (fn bnf =>
41.1719 + mk_unabs_def m (map_def_of_bnf bnf RS @{thm meta_eq_to_obj_eq})) Ibnfs);
41.1720 +
41.1721 + val fold_sets = fold_thms lthy (maps (fn bnf =>
41.1722 + map (fn thm => thm RS @{thm meta_eq_to_obj_eq}) (set_defs_of_bnf bnf)) Ibnfs);
41.1723 +
41.1724 + val timer = time (timer "registered new datatypes as BNFs");
41.1725 +
41.1726 + val srels = map2 (fn Ds => mk_srel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
41.1727 + val Isrels = map (mk_srel_of_bnf deads passiveAs passiveBs) Ibnfs;
41.1728 + val rels = map2 (fn Ds => mk_rel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
41.1729 + val Irels = map (mk_rel_of_bnf deads passiveAs passiveBs) Ibnfs;
41.1730 +
41.1731 + val IrelRs = map (fn Isrel => Term.list_comb (Isrel, IRs)) Isrels;
41.1732 + val relRs = map (fn srel => Term.list_comb (srel, IRs @ IrelRs)) srels;
41.1733 + val Ipredphis = map (fn Isrel => Term.list_comb (Isrel, Iphis)) Irels;
41.1734 + val predphis = map (fn srel => Term.list_comb (srel, Iphis @ Ipredphis)) rels;
41.1735 +
41.1736 + val in_srels = map in_srel_of_bnf bnfs;
41.1737 + val in_Isrels = map in_srel_of_bnf Ibnfs;
41.1738 + val srel_defs = map srel_def_of_bnf bnfs;
41.1739 + val Isrel_defs = map srel_def_of_bnf Ibnfs;
41.1740 + val Irel_defs = map rel_def_of_bnf Ibnfs;
41.1741 +
41.1742 + val set_incl_thmss = map (map (fold_sets o hd)) Fset_set_thmsss;
41.1743 + val set_set_incl_thmsss = map (transpose o map (map fold_sets o tl)) Fset_set_thmsss;
41.1744 + val folded_map_simp_thms = map fold_maps map_simp_thms;
41.1745 + val folded_set_simp_thmss = map (map fold_sets) set_simp_thmss;
41.1746 + val folded_set_simp_thmss' = transpose folded_set_simp_thmss;
41.1747 +
41.1748 + val Isrel_simp_thms =
41.1749 + let
41.1750 + fun mk_goal xF yF ctor ctor' IrelR relR = fold_rev Logic.all (xF :: yF :: IRs)
41.1751 + (mk_Trueprop_eq (HOLogic.mk_mem (HOLogic.mk_prod (ctor $ xF, ctor' $ yF), IrelR),
41.1752 + HOLogic.mk_mem (HOLogic.mk_prod (xF, yF), relR)));
41.1753 + val goals = map6 mk_goal xFs yFs ctors ctor's IrelRs relRs;
41.1754 + in
41.1755 + map12 (fn i => fn goal => fn in_srel => fn map_comp => fn map_cong =>
41.1756 + fn map_simp => fn set_simps => fn ctor_inject => fn ctor_dtor =>
41.1757 + fn set_naturals => fn set_incls => fn set_set_inclss =>
41.1758 + Skip_Proof.prove lthy [] [] goal
41.1759 + (K (mk_srel_simp_tac in_Isrels i in_srel map_comp map_cong map_simp set_simps
41.1760 + ctor_inject ctor_dtor set_naturals set_incls set_set_inclss))
41.1761 + |> Thm.close_derivation)
41.1762 + ks goals in_srels map_comp's map_congs folded_map_simp_thms folded_set_simp_thmss'
41.1763 + ctor_inject_thms ctor_dtor_thms set_natural'ss set_incl_thmss set_set_incl_thmsss
41.1764 + end;
41.1765 +
41.1766 + val Irel_simp_thms =
41.1767 + let
41.1768 + fun mk_goal xF yF ctor ctor' Ipredphi predphi = fold_rev Logic.all (xF :: yF :: Iphis)
41.1769 + (mk_Trueprop_eq (Ipredphi $ (ctor $ xF) $ (ctor' $ yF), predphi $ xF $ yF));
41.1770 + val goals = map6 mk_goal xFs yFs ctors ctor's Ipredphis predphis;
41.1771 + in
41.1772 + map3 (fn goal => fn srel_def => fn Isrel_simp =>
41.1773 + Skip_Proof.prove lthy [] [] goal
41.1774 + (mk_rel_simp_tac srel_def Irel_defs Isrel_defs Isrel_simp)
41.1775 + |> Thm.close_derivation)
41.1776 + goals srel_defs Isrel_simp_thms
41.1777 + end;
41.1778 +
41.1779 + val timer = time (timer "additional properties");
41.1780 +
41.1781 + val ls' = if m = 1 then [0] else ls
41.1782 +
41.1783 + val Ibnf_common_notes =
41.1784 + [(map_uniqueN, [fold_maps map_unique_thm])]
41.1785 + |> map (fn (thmN, thms) =>
41.1786 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
41.1787 +
41.1788 + val Ibnf_notes =
41.1789 + [(map_simpsN, map single folded_map_simp_thms),
41.1790 + (set_inclN, set_incl_thmss),
41.1791 + (set_set_inclN, map flat set_set_incl_thmsss),
41.1792 + (srel_simpN, map single Isrel_simp_thms),
41.1793 + (rel_simpN, map single Irel_simp_thms)] @
41.1794 + map2 (fn i => fn thms => (mk_set_simpsN i, map single thms)) ls' folded_set_simp_thmss
41.1795 + |> maps (fn (thmN, thmss) =>
41.1796 + map2 (fn b => fn thms =>
41.1797 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
41.1798 + bs thmss)
41.1799 + in
41.1800 + timer; lthy |> Local_Theory.notes (Ibnf_common_notes @ Ibnf_notes) |> snd
41.1801 + end;
41.1802 +
41.1803 + val common_notes =
41.1804 + [(ctor_inductN, [ctor_induct_thm]),
41.1805 + (ctor_induct2N, [ctor_induct2_thm])]
41.1806 + |> map (fn (thmN, thms) =>
41.1807 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
41.1808 +
41.1809 + val notes =
41.1810 + [(ctor_dtorN, ctor_dtor_thms),
41.1811 + (ctor_exhaustN, ctor_exhaust_thms),
41.1812 + (ctor_fold_uniqueN, ctor_fold_unique_thms),
41.1813 + (ctor_foldsN, ctor_fold_thms),
41.1814 + (ctor_injectN, ctor_inject_thms),
41.1815 + (ctor_recsN, ctor_rec_thms),
41.1816 + (dtor_ctorN, dtor_ctor_thms),
41.1817 + (dtor_exhaustN, dtor_exhaust_thms),
41.1818 + (dtor_injectN, dtor_inject_thms)]
41.1819 + |> map (apsnd (map single))
41.1820 + |> maps (fn (thmN, thmss) =>
41.1821 + map2 (fn b => fn thms =>
41.1822 + ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
41.1823 + bs thmss)
41.1824 + in
41.1825 + ((dtors, ctors, folds, recs, ctor_induct_thm, dtor_ctor_thms, ctor_dtor_thms, ctor_inject_thms,
41.1826 + ctor_fold_thms, ctor_rec_thms),
41.1827 + lthy |> Local_Theory.notes (common_notes @ notes) |> snd)
41.1828 + end;
41.1829 +
41.1830 +val _ =
41.1831 + Outer_Syntax.local_theory @{command_spec "data_raw"}
41.1832 + "define BNF-based inductive datatypes (low-level)"
41.1833 + (Parse.and_list1
41.1834 + ((Parse.binding --| @{keyword ":"}) -- (Parse.typ --| @{keyword "="} -- Parse.typ)) >>
41.1835 + (snd oo fp_bnf_cmd bnf_lfp o apsnd split_list o split_list));
41.1836 +
41.1837 +val _ =
41.1838 + Outer_Syntax.local_theory @{command_spec "data"} "define BNF-based inductive datatypes"
41.1839 + (parse_datatype_cmd true bnf_lfp);
41.1840 +
41.1841 +end;
42.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
42.2 +++ b/src/HOL/BNF/Tools/bnf_lfp_tactics.ML Fri Sep 21 16:45:06 2012 +0200
42.3 @@ -0,0 +1,835 @@
42.4 +(* Title: HOL/BNF/Tools/bnf_lfp_tactics.ML
42.5 + Author: Dmitriy Traytel, TU Muenchen
42.6 + Author: Andrei Popescu, TU Muenchen
42.7 + Copyright 2012
42.8 +
42.9 +Tactics for the datatype construction.
42.10 +*)
42.11 +
42.12 +signature BNF_LFP_TACTICS =
42.13 +sig
42.14 + val mk_alg_min_alg_tac: int -> thm -> thm list -> thm -> thm -> thm list list -> thm list ->
42.15 + thm list -> tactic
42.16 + val mk_alg_not_empty_tac: thm -> thm list -> thm list -> tactic
42.17 + val mk_alg_select_tac: thm -> {prems: 'a, context: Proof.context} -> tactic
42.18 + val mk_alg_set_tac: thm -> tactic
42.19 + val mk_bd_card_order_tac: thm list -> tactic
42.20 + val mk_bd_limit_tac: int -> thm -> tactic
42.21 + val mk_card_of_min_alg_tac: thm -> thm -> thm -> thm -> thm -> tactic
42.22 + val mk_copy_alg_tac: thm list list -> thm list -> thm -> thm -> thm -> tactic
42.23 + val mk_copy_str_tac: thm list list -> thm -> thm list -> tactic
42.24 + val mk_ctor_induct_tac: int -> thm list list -> thm -> thm list -> thm -> thm list -> thm list ->
42.25 + thm list -> tactic
42.26 + val mk_ctor_induct2_tac: ctyp option list -> cterm option list -> thm -> thm list ->
42.27 + {prems: 'a, context: Proof.context} -> tactic
42.28 + val mk_dtor_o_ctor_tac: thm -> thm -> thm -> thm -> thm list -> tactic
42.29 + val mk_ex_copy_alg_tac: int -> thm -> thm -> tactic
42.30 + val mk_in_bd_tac: thm -> thm -> thm -> thm -> tactic
42.31 + val mk_incl_min_alg_tac: (int -> tactic) -> thm list list list -> thm list -> thm ->
42.32 + {prems: 'a, context: Proof.context} -> tactic
42.33 + val mk_init_ex_mor_tac: thm -> thm -> thm -> thm list -> thm -> thm -> thm ->
42.34 + {prems: 'a, context: Proof.context} -> tactic
42.35 + val mk_init_induct_tac: int -> thm -> thm -> thm list -> thm list -> tactic
42.36 + val mk_init_unique_mor_tac: int -> thm -> thm -> thm list -> thm list -> thm list -> thm list ->
42.37 + thm list -> tactic
42.38 + val mk_iso_alt_tac: thm list -> thm -> tactic
42.39 + val mk_fold_unique_mor_tac: thm list -> thm list -> thm list -> thm -> thm -> thm -> tactic
42.40 + val mk_least_min_alg_tac: thm -> thm -> tactic
42.41 + val mk_lfp_map_wpull_tac: int -> (int -> tactic) -> thm list -> thm list -> thm list list ->
42.42 + thm list list list -> thm list -> tactic
42.43 + val mk_map_comp_tac: thm list -> thm list -> thm -> int -> tactic
42.44 + val mk_map_id_tac: thm list -> thm -> tactic
42.45 + val mk_map_tac: int -> int -> thm -> thm -> thm -> tactic
42.46 + val mk_map_unique_tac: int -> thm -> thm -> thm list -> thm list -> tactic
42.47 + val mk_mcong_tac: (int -> tactic) -> thm list list list -> thm list -> thm list ->
42.48 + {prems: 'a, context: Proof.context} -> tactic
42.49 + val mk_min_algs_card_of_tac: ctyp -> cterm -> int -> thm -> thm list -> thm list -> thm -> thm ->
42.50 + thm -> thm -> thm -> thm -> thm -> thm -> tactic
42.51 + val mk_min_algs_least_tac: ctyp -> cterm -> thm -> thm list -> thm list -> tactic
42.52 + val mk_min_algs_mono_tac: thm -> tactic
42.53 + val mk_min_algs_tac: thm -> thm list -> tactic
42.54 + val mk_mor_Abs_tac: thm -> thm list -> thm list -> tactic
42.55 + val mk_mor_Rep_tac: thm list -> thm -> thm list -> thm list -> thm list ->
42.56 + {prems: 'a, context: Proof.context} -> tactic
42.57 + val mk_mor_UNIV_tac: int -> thm list -> thm -> tactic
42.58 + val mk_mor_comp_tac: thm -> thm list list -> thm list -> tactic
42.59 + val mk_mor_convol_tac: 'a list -> thm -> tactic
42.60 + val mk_mor_elim_tac: thm -> tactic
42.61 + val mk_mor_incl_tac: thm -> thm list -> tactic
42.62 + val mk_mor_inv_tac: thm -> thm -> thm list list -> thm list -> thm list -> thm list -> tactic
42.63 + val mk_mor_fold_tac: ctyp -> cterm -> thm list -> thm -> thm -> tactic
42.64 + val mk_mor_select_tac: thm -> thm -> thm -> thm -> thm -> thm -> thm list -> thm list list ->
42.65 + thm list -> tactic
42.66 + val mk_mor_str_tac: 'a list -> thm -> tactic
42.67 + val mk_rec_tac: thm list -> thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
42.68 + val mk_set_bd_tac: int -> (int -> tactic) -> thm -> thm list list -> thm list -> int ->
42.69 + {prems: 'a, context: Proof.context} -> tactic
42.70 + val mk_set_nat_tac: int -> (int -> tactic) -> thm list list -> thm list -> cterm list ->
42.71 + thm list -> int -> {prems: 'a, context: Proof.context} -> tactic
42.72 + val mk_set_natural_tac: thm -> tactic
42.73 + val mk_set_simp_tac: thm -> thm -> thm list -> tactic
42.74 + val mk_set_tac: thm -> tactic
42.75 + val mk_srel_simp_tac: thm list -> int -> thm -> thm -> thm -> thm -> thm list -> thm ->
42.76 + thm -> thm list -> thm list -> thm list list -> tactic
42.77 + val mk_wit_tac: int -> thm list -> thm list -> tactic
42.78 + val mk_wpull_tac: thm -> tactic
42.79 +end;
42.80 +
42.81 +structure BNF_LFP_Tactics : BNF_LFP_TACTICS =
42.82 +struct
42.83 +
42.84 +open BNF_Tactics
42.85 +open BNF_LFP_Util
42.86 +open BNF_Util
42.87 +
42.88 +val fst_snd_convs = @{thms fst_conv snd_conv};
42.89 +val id_apply = @{thm id_apply};
42.90 +val meta_mp = @{thm meta_mp};
42.91 +val ord_eq_le_trans = @{thm ord_eq_le_trans};
42.92 +val subset_trans = @{thm subset_trans};
42.93 +val trans_fun_cong_image_id_id_apply = @{thm trans[OF fun_cong[OF image_id] id_apply]};
42.94 +
42.95 +fun mk_alg_set_tac alg_def =
42.96 + dtac (alg_def RS iffD1) 1 THEN
42.97 + REPEAT_DETERM (etac conjE 1) THEN
42.98 + EVERY' [etac bspec, rtac CollectI] 1 THEN
42.99 + REPEAT_DETERM (etac conjI 1) THEN atac 1;
42.100 +
42.101 +fun mk_alg_not_empty_tac alg_set alg_sets wits =
42.102 + (EVERY' [rtac notI, hyp_subst_tac, ftac alg_set] THEN'
42.103 + REPEAT_DETERM o FIRST'
42.104 + [rtac subset_UNIV,
42.105 + EVERY' [rtac @{thm subset_emptyI}, eresolve_tac wits],
42.106 + EVERY' [rtac subsetI, rtac FalseE, eresolve_tac wits],
42.107 + EVERY' [rtac subsetI, dresolve_tac wits, hyp_subst_tac,
42.108 + FIRST' (map (fn thm => rtac thm THEN' atac) alg_sets)]] THEN'
42.109 + etac @{thm emptyE}) 1;
42.110 +
42.111 +fun mk_mor_elim_tac mor_def =
42.112 + (dtac (subst OF [mor_def]) THEN'
42.113 + REPEAT o etac conjE THEN'
42.114 + TRY o rtac @{thm image_subsetI} THEN'
42.115 + etac bspec THEN'
42.116 + atac) 1;
42.117 +
42.118 +fun mk_mor_incl_tac mor_def map_id's =
42.119 + (stac mor_def THEN'
42.120 + rtac conjI THEN'
42.121 + CONJ_WRAP' (K (EVERY' [rtac ballI, etac set_mp, stac id_apply, atac])) map_id's THEN'
42.122 + CONJ_WRAP' (fn thm =>
42.123 + (EVERY' [rtac ballI, rtac trans, rtac id_apply, stac thm, rtac refl])) map_id's) 1;
42.124 +
42.125 +fun mk_mor_comp_tac mor_def set_natural's map_comp_ids =
42.126 + let
42.127 + val fbetw_tac = EVERY' [rtac ballI, stac o_apply, etac bspec, etac bspec, atac];
42.128 + fun mor_tac (set_natural', map_comp_id) =
42.129 + EVERY' [rtac ballI, stac o_apply, rtac trans,
42.130 + rtac trans, dtac @{thm rev_bspec}, atac, etac arg_cong,
42.131 + REPEAT o eresolve_tac [CollectE, conjE], etac bspec, rtac CollectI] THEN'
42.132 + CONJ_WRAP' (fn thm =>
42.133 + FIRST' [rtac subset_UNIV,
42.134 + (EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
42.135 + etac bspec, etac set_mp, atac])]) set_natural' THEN'
42.136 + rtac (map_comp_id RS arg_cong);
42.137 + in
42.138 + (dtac (mor_def RS subst) THEN' dtac (mor_def RS subst) THEN' stac mor_def THEN'
42.139 + REPEAT o etac conjE THEN'
42.140 + rtac conjI THEN'
42.141 + CONJ_WRAP' (K fbetw_tac) set_natural's THEN'
42.142 + CONJ_WRAP' mor_tac (set_natural's ~~ map_comp_ids)) 1
42.143 + end;
42.144 +
42.145 +fun mk_mor_inv_tac alg_def mor_def set_natural's morEs map_comp_ids map_congLs =
42.146 + let
42.147 + val fbetw_tac = EVERY' [rtac ballI, etac set_mp, etac imageI];
42.148 + fun Collect_tac set_natural' =
42.149 + CONJ_WRAP' (fn thm =>
42.150 + FIRST' [rtac subset_UNIV,
42.151 + (EVERY' [rtac ord_eq_le_trans, rtac thm, rtac subset_trans,
42.152 + etac @{thm image_mono}, atac])]) set_natural';
42.153 + fun mor_tac (set_natural', ((morE, map_comp_id), map_congL)) =
42.154 + EVERY' [rtac ballI, ftac @{thm rev_bspec}, atac,
42.155 + REPEAT o eresolve_tac [CollectE, conjE], rtac sym, rtac trans, rtac sym,
42.156 + etac @{thm inverE}, etac bspec, rtac CollectI, Collect_tac set_natural',
42.157 + rtac trans, etac (morE RS arg_cong), rtac CollectI, Collect_tac set_natural',
42.158 + rtac trans, rtac (map_comp_id RS arg_cong), rtac (map_congL RS arg_cong),
42.159 + REPEAT_DETERM_N (length morEs) o
42.160 + (EVERY' [rtac subst, rtac @{thm inver_pointfree}, etac @{thm inver_mono}, atac])];
42.161 + in
42.162 + (stac mor_def THEN'
42.163 + dtac (alg_def RS iffD1) THEN'
42.164 + dtac (alg_def RS iffD1) THEN'
42.165 + REPEAT o etac conjE THEN'
42.166 + rtac conjI THEN'
42.167 + CONJ_WRAP' (K fbetw_tac) set_natural's THEN'
42.168 + CONJ_WRAP' mor_tac (set_natural's ~~ (morEs ~~ map_comp_ids ~~ map_congLs))) 1
42.169 + end;
42.170 +
42.171 +fun mk_mor_str_tac ks mor_def =
42.172 + (stac mor_def THEN' rtac conjI THEN'
42.173 + CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) ks THEN'
42.174 + CONJ_WRAP' (K (EVERY' [rtac ballI, rtac refl])) ks) 1;
42.175 +
42.176 +fun mk_mor_convol_tac ks mor_def =
42.177 + (stac mor_def THEN' rtac conjI THEN'
42.178 + CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) ks THEN'
42.179 + CONJ_WRAP' (K (EVERY' [rtac ballI, rtac trans, rtac @{thm fst_convol'}, rtac o_apply])) ks) 1;
42.180 +
42.181 +fun mk_mor_UNIV_tac m morEs mor_def =
42.182 + let
42.183 + val n = length morEs;
42.184 + fun mor_tac morE = EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, etac morE,
42.185 + rtac CollectI, CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto m + n),
42.186 + rtac sym, rtac o_apply];
42.187 + in
42.188 + EVERY' [rtac iffI, CONJ_WRAP' mor_tac morEs,
42.189 + stac mor_def, rtac conjI, CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) morEs,
42.190 + REPEAT_DETERM o etac conjE, REPEAT_DETERM_N n o dtac (@{thm fun_eq_iff} RS subst),
42.191 + CONJ_WRAP' (K (EVERY' [rtac ballI, REPEAT_DETERM o etac allE, rtac trans,
42.192 + etac (o_apply RS subst), rtac o_apply])) morEs] 1
42.193 + end;
42.194 +
42.195 +fun mk_iso_alt_tac mor_images mor_inv =
42.196 + let
42.197 + val n = length mor_images;
42.198 + fun if_wrap_tac thm =
42.199 + EVERY' [rtac ssubst, rtac @{thm bij_betw_iff_ex}, rtac exI, rtac conjI,
42.200 + rtac @{thm inver_surj}, etac thm, etac thm, atac, etac conjI, atac]
42.201 + val if_tac =
42.202 + EVERY' [etac thin_rl, etac thin_rl, REPEAT o eresolve_tac [conjE, exE],
42.203 + rtac conjI, atac, CONJ_WRAP' if_wrap_tac mor_images];
42.204 + val only_if_tac =
42.205 + EVERY' [rtac conjI, etac conjunct1, EVERY' (map (fn thm =>
42.206 + EVERY' [rtac exE, rtac @{thm bij_betw_ex_weakE}, etac (conjunct2 RS thm)])
42.207 + (map (mk_conjunctN n) (1 upto n))), REPEAT o rtac exI, rtac conjI, rtac mor_inv,
42.208 + etac conjunct1, atac, atac, REPEAT_DETERM_N n o atac,
42.209 + CONJ_WRAP' (K (etac conjunct2)) mor_images];
42.210 + in
42.211 + (rtac iffI THEN' if_tac THEN' only_if_tac) 1
42.212 + end;
42.213 +
42.214 +fun mk_copy_str_tac set_natural's alg_def alg_sets =
42.215 + let
42.216 + val n = length alg_sets;
42.217 + val bij_betw_inv_tac =
42.218 + EVERY' [etac thin_rl, REPEAT_DETERM_N n o EVERY' [dtac @{thm bij_betwI}, atac, atac],
42.219 + REPEAT_DETERM_N (2 * n) o etac thin_rl, REPEAT_DETERM_N (n - 1) o etac conjI, atac];
42.220 + fun set_tac thms =
42.221 + EVERY' [rtac ord_eq_le_trans, resolve_tac thms, rtac subset_trans,
42.222 + etac @{thm image_mono}, rtac equalityD1, etac @{thm bij_betw_imageE}];
42.223 + val copy_str_tac =
42.224 + CONJ_WRAP' (fn (thms, thm) =>
42.225 + EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac set_mp,
42.226 + rtac equalityD1, etac @{thm bij_betw_imageE}, rtac imageI, etac thm,
42.227 + REPEAT_DETERM o rtac subset_UNIV, REPEAT_DETERM_N n o (set_tac thms)])
42.228 + (set_natural's ~~ alg_sets);
42.229 + in
42.230 + (rtac rev_mp THEN' DETERM o bij_betw_inv_tac THEN' rtac impI THEN'
42.231 + stac alg_def THEN' copy_str_tac) 1
42.232 + end;
42.233 +
42.234 +fun mk_copy_alg_tac set_natural's alg_sets mor_def iso_alt copy_str =
42.235 + let
42.236 + val n = length alg_sets;
42.237 + val fbetw_tac = CONJ_WRAP' (K (etac @{thm bij_betwE})) alg_sets;
42.238 + fun set_tac thms =
42.239 + EVERY' [rtac ord_eq_le_trans, resolve_tac thms, rtac subset_trans,
42.240 + REPEAT_DETERM o etac conjE, etac @{thm image_mono},
42.241 + rtac equalityD1, etac @{thm bij_betw_imageE}];
42.242 + val mor_tac =
42.243 + CONJ_WRAP' (fn (thms, thm) =>
42.244 + EVERY' [rtac ballI, etac CollectE, etac @{thm inverE}, etac thm,
42.245 + REPEAT_DETERM o rtac subset_UNIV, REPEAT_DETERM_N n o (set_tac thms)])
42.246 + (set_natural's ~~ alg_sets);
42.247 + in
42.248 + (rtac (iso_alt RS @{thm ssubst[of _ _ "%x. x"]}) THEN'
42.249 + etac copy_str THEN' REPEAT_DETERM o atac THEN'
42.250 + rtac conjI THEN' stac mor_def THEN' rtac conjI THEN' fbetw_tac THEN' mor_tac THEN'
42.251 + CONJ_WRAP' (K atac) alg_sets) 1
42.252 + end;
42.253 +
42.254 +fun mk_ex_copy_alg_tac n copy_str copy_alg =
42.255 + EVERY' [REPEAT_DETERM_N n o rtac exI, rtac conjI, etac copy_str,
42.256 + REPEAT_DETERM_N n o atac,
42.257 + REPEAT_DETERM_N n o etac @{thm bij_betw_inver2},
42.258 + REPEAT_DETERM_N n o etac @{thm bij_betw_inver1}, etac copy_alg,
42.259 + REPEAT_DETERM_N n o atac,
42.260 + REPEAT_DETERM_N n o etac @{thm bij_betw_inver2},
42.261 + REPEAT_DETERM_N n o etac @{thm bij_betw_inver1}] 1;
42.262 +
42.263 +fun mk_bd_limit_tac n bd_Cinfinite =
42.264 + EVERY' [REPEAT_DETERM o etac conjE, rtac rev_mp, rtac @{thm Cinfinite_limit_finite},
42.265 + REPEAT_DETERM_N n o rtac @{thm finite.insertI}, rtac @{thm finite.emptyI},
42.266 + REPEAT_DETERM_N n o etac @{thm insert_subsetI}, rtac @{thm empty_subsetI},
42.267 + rtac bd_Cinfinite, rtac impI, etac bexE, rtac bexI,
42.268 + CONJ_WRAP' (fn i =>
42.269 + EVERY' [etac bspec, REPEAT_DETERM_N i o rtac @{thm insertI2}, rtac @{thm insertI1}])
42.270 + (0 upto n - 1),
42.271 + atac] 1;
42.272 +
42.273 +fun mk_min_algs_tac worel in_congs =
42.274 + let
42.275 + val minG_tac = EVERY' [rtac @{thm UN_cong}, rtac refl, dtac bspec, atac, etac arg_cong];
42.276 + fun minH_tac thm =
42.277 + EVERY' [rtac @{thm Un_cong}, minG_tac, rtac @{thm image_cong}, rtac thm,
42.278 + REPEAT_DETERM_N (length in_congs) o minG_tac, rtac refl];
42.279 + in
42.280 + (rtac (worel RS (@{thm wo_rel.worec_fixpoint} RS fun_cong)) THEN' rtac ssubst THEN'
42.281 + rtac meta_eq_to_obj_eq THEN' rtac (worel RS @{thm wo_rel.adm_wo_def}) THEN'
42.282 + REPEAT_DETERM_N 3 o rtac allI THEN' rtac impI THEN'
42.283 + CONJ_WRAP_GEN' (EVERY' [rtac Pair_eqI, rtac conjI]) minH_tac in_congs) 1
42.284 + end;
42.285 +
42.286 +fun mk_min_algs_mono_tac min_algs = EVERY' [stac @{thm relChain_def}, rtac allI, rtac allI,
42.287 + rtac impI, rtac @{thm case_split}, rtac @{thm xt1(3)}, rtac min_algs, etac @{thm FieldI2},
42.288 + rtac subsetI, rtac UnI1, rtac @{thm UN_I}, etac @{thm underS_I}, atac, atac,
42.289 + rtac equalityD1, dtac @{thm notnotD}, hyp_subst_tac, rtac refl] 1;
42.290 +
42.291 +fun mk_min_algs_card_of_tac cT ct m worel min_algs in_bds bd_Card_order bd_Cnotzero
42.292 + suc_Card_order suc_Cinfinite suc_Cnotzero suc_Asuc Asuc_Cinfinite Asuc_Cnotzero =
42.293 + let
42.294 + val induct = worel RS
42.295 + Drule.instantiate' [SOME cT] [NONE, SOME ct] @{thm well_order_induct_imp};
42.296 + val src = 1 upto m + 1;
42.297 + val dest = (m + 1) :: (1 upto m);
42.298 + val absorbAs_tac = if m = 0 then K (all_tac)
42.299 + else EVERY' [rtac @{thm ordIso_transitive}, rtac @{thm csum_cong1},
42.300 + rtac @{thm ordIso_transitive},
42.301 + BNF_Tactics.mk_rotate_eq_tac (rtac @{thm ordIso_refl} THEN'
42.302 + FIRST' [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum},
42.303 + rtac @{thm Card_order_cexp}])
42.304 + @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
42.305 + src dest,
42.306 + rtac @{thm csum_absorb1}, rtac Asuc_Cinfinite, rtac ctrans, rtac @{thm ordLeq_csum1},
42.307 + FIRST' [rtac @{thm Card_order_csum}, rtac @{thm card_of_Card_order}],
42.308 + rtac @{thm ordLeq_cexp1}, rtac suc_Cnotzero, rtac @{thm Card_order_csum}];
42.309 +
42.310 + val minG_tac = EVERY' [rtac @{thm UNION_Cinfinite_bound}, rtac @{thm ordLess_imp_ordLeq},
42.311 + rtac @{thm ordLess_transitive}, rtac @{thm card_of_underS}, rtac suc_Card_order,
42.312 + atac, rtac suc_Asuc, rtac ballI, etac allE, dtac mp, etac @{thm underS_E},
42.313 + dtac mp, etac @{thm underS_Field}, REPEAT o etac conjE, atac, rtac Asuc_Cinfinite]
42.314 +
42.315 + fun mk_minH_tac (min_alg, in_bd) = EVERY' [rtac @{thm ordIso_ordLeq_trans},
42.316 + rtac @{thm card_of_ordIso_subst}, etac min_alg, rtac @{thm Un_Cinfinite_bound},
42.317 + minG_tac, rtac ctrans, rtac @{thm card_of_image}, rtac ctrans, rtac in_bd, rtac ctrans,
42.318 + rtac @{thm cexp_mono1_Cnotzero}, rtac @{thm csum_mono1},
42.319 + REPEAT_DETERM_N m o rtac @{thm csum_mono2},
42.320 + CONJ_WRAP_GEN' (rtac @{thm csum_cinfinite_bound}) (K minG_tac) min_algs,
42.321 + REPEAT_DETERM o FIRST'
42.322 + [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum}, rtac Asuc_Cinfinite],
42.323 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac bd_Card_order,
42.324 + rtac @{thm ordIso_ordLeq_trans}, rtac @{thm cexp_cong1_Cnotzero}, absorbAs_tac,
42.325 + rtac @{thm csum_absorb1}, rtac Asuc_Cinfinite, rtac @{thm ctwo_ordLeq_Cinfinite},
42.326 + rtac Asuc_Cinfinite, rtac bd_Card_order,
42.327 + rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac Asuc_Cnotzero,
42.328 + rtac @{thm ordIso_imp_ordLeq}, rtac @{thm cexp_cprod_ordLeq},
42.329 + TRY o rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac suc_Cinfinite,
42.330 + rtac bd_Cnotzero, rtac @{thm cardSuc_ordLeq}, rtac bd_Card_order, rtac Asuc_Cinfinite];
42.331 + in
42.332 + (rtac induct THEN'
42.333 + rtac impI THEN'
42.334 + CONJ_WRAP' mk_minH_tac (min_algs ~~ in_bds)) 1
42.335 + end;
42.336 +
42.337 +fun mk_min_algs_least_tac cT ct worel min_algs alg_sets =
42.338 + let
42.339 + val induct = worel RS
42.340 + Drule.instantiate' [SOME cT] [NONE, SOME ct] @{thm well_order_induct_imp};
42.341 +
42.342 + val minG_tac = EVERY' [rtac @{thm UN_least}, etac allE, dtac mp, etac @{thm underS_E},
42.343 + dtac mp, etac @{thm underS_Field}, REPEAT_DETERM o etac conjE, atac];
42.344 +
42.345 + fun mk_minH_tac (min_alg, alg_set) = EVERY' [rtac ord_eq_le_trans, etac min_alg,
42.346 + rtac @{thm Un_least}, minG_tac, rtac @{thm image_subsetI},
42.347 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], etac alg_set,
42.348 + REPEAT_DETERM o FIRST' [atac, etac subset_trans THEN' minG_tac]];
42.349 + in
42.350 + (rtac induct THEN'
42.351 + rtac impI THEN'
42.352 + CONJ_WRAP' mk_minH_tac (min_algs ~~ alg_sets)) 1
42.353 + end;
42.354 +
42.355 +fun mk_alg_min_alg_tac m alg_def min_alg_defs bd_limit bd_Cinfinite
42.356 + set_bdss min_algs min_alg_monos =
42.357 + let
42.358 + val n = length min_algs;
42.359 + fun mk_cardSuc_UNION_tac set_bds (mono, def) = EVERY'
42.360 + [rtac bexE, rtac @{thm cardSuc_UNION_Cinfinite}, rtac bd_Cinfinite, rtac mono,
42.361 + etac (def RSN (2, @{thm subset_trans[OF _ equalityD1]})), resolve_tac set_bds];
42.362 + fun mk_conjunct_tac (set_bds, (min_alg, min_alg_def)) =
42.363 + EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
42.364 + EVERY' (map (mk_cardSuc_UNION_tac set_bds) (min_alg_monos ~~ min_alg_defs)), rtac bexE,
42.365 + rtac bd_limit, REPEAT_DETERM_N (n - 1) o etac conjI, atac,
42.366 + rtac (min_alg_def RS @{thm set_mp[OF equalityD2]}),
42.367 + rtac @{thm UN_I}, REPEAT_DETERM_N (m + 3 * n) o etac thin_rl, atac, rtac set_mp,
42.368 + rtac equalityD2, rtac min_alg, atac, rtac UnI2, rtac @{thm image_eqI}, rtac refl,
42.369 + rtac CollectI, REPEAT_DETERM_N m o dtac asm_rl, REPEAT_DETERM_N n o etac thin_rl,
42.370 + REPEAT_DETERM o etac conjE,
42.371 + CONJ_WRAP' (K (FIRST' [atac,
42.372 + EVERY' [etac subset_trans, rtac subsetI, rtac @{thm UN_I},
42.373 + etac @{thm underS_I}, atac, atac]]))
42.374 + set_bds];
42.375 + in
42.376 + (rtac (alg_def RS @{thm ssubst[of _ _ "%x. x"]}) THEN'
42.377 + CONJ_WRAP' mk_conjunct_tac (set_bdss ~~ (min_algs ~~ min_alg_defs))) 1
42.378 + end;
42.379 +
42.380 +fun mk_card_of_min_alg_tac min_alg_def card_of suc_Card_order suc_Asuc Asuc_Cinfinite =
42.381 + EVERY' [stac min_alg_def, rtac @{thm UNION_Cinfinite_bound},
42.382 + rtac @{thm ordIso_ordLeq_trans}, rtac @{thm card_of_Field_ordIso}, rtac suc_Card_order,
42.383 + rtac @{thm ordLess_imp_ordLeq}, rtac suc_Asuc, rtac ballI, dtac rev_mp, rtac card_of,
42.384 + REPEAT_DETERM o etac conjE, atac, rtac Asuc_Cinfinite] 1;
42.385 +
42.386 +fun mk_least_min_alg_tac min_alg_def least =
42.387 + EVERY' [stac min_alg_def, rtac @{thm UN_least}, dtac least, dtac mp, atac,
42.388 + REPEAT_DETERM o etac conjE, atac] 1;
42.389 +
42.390 +fun mk_alg_select_tac Abs_inverse {context = ctxt, prems = _} =
42.391 + EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac] 1 THEN
42.392 + unfold_thms_tac ctxt (Abs_inverse :: fst_snd_convs) THEN atac 1;
42.393 +
42.394 +fun mk_mor_select_tac mor_def mor_cong mor_comp mor_incl_min_alg alg_def alg_select
42.395 + alg_sets set_natural's str_init_defs =
42.396 + let
42.397 + val n = length alg_sets;
42.398 + val fbetw_tac =
42.399 + CONJ_WRAP' (K (EVERY' [rtac ballI, etac @{thm rev_bspec}, etac CollectE, atac])) alg_sets;
42.400 + val mor_tac =
42.401 + CONJ_WRAP' (fn thm => EVERY' [rtac ballI, rtac thm]) str_init_defs;
42.402 + fun alg_epi_tac ((alg_set, str_init_def), set_natural') =
42.403 + EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
42.404 + rtac ballI, ftac (alg_select RS bspec), stac str_init_def, etac alg_set,
42.405 + REPEAT_DETERM o FIRST' [rtac subset_UNIV,
42.406 + EVERY' [rtac ord_eq_le_trans, resolve_tac set_natural', rtac subset_trans,
42.407 + etac @{thm image_mono}, rtac @{thm image_Collect_subsetI}, etac bspec, atac]]];
42.408 + in
42.409 + (rtac mor_cong THEN' REPEAT_DETERM_N n o (rtac sym THEN' rtac @{thm o_id}) THEN'
42.410 + rtac (Thm.permute_prems 0 1 mor_comp) THEN' etac (Thm.permute_prems 0 1 mor_comp) THEN'
42.411 + stac mor_def THEN' rtac conjI THEN' fbetw_tac THEN' mor_tac THEN' rtac mor_incl_min_alg THEN'
42.412 + stac alg_def THEN' CONJ_WRAP' alg_epi_tac ((alg_sets ~~ str_init_defs) ~~ set_natural's)) 1
42.413 + end;
42.414 +
42.415 +fun mk_init_ex_mor_tac Abs_inverse copy_alg_ex alg_min_alg card_of_min_algs
42.416 + mor_comp mor_select mor_incl_min_alg {context = ctxt, prems = _} =
42.417 + let
42.418 + val n = length card_of_min_algs;
42.419 + val card_of_ordIso_tac = EVERY' [rtac ssubst, rtac @{thm card_of_ordIso},
42.420 + rtac @{thm ordIso_symmetric}, rtac conjunct1, rtac conjunct2, atac];
42.421 + fun internalize_tac card_of = EVERY' [rtac subst, rtac @{thm internalize_card_of_ordLeq2},
42.422 + rtac @{thm ordLeq_ordIso_trans}, rtac card_of, rtac subst,
42.423 + rtac @{thm Card_order_iff_ordIso_card_of}, rtac @{thm Card_order_cexp}];
42.424 + in
42.425 + (rtac rev_mp THEN'
42.426 + REPEAT_DETERM_N (2 * n) o (rtac mp THEN' rtac @{thm ex_mono} THEN' rtac impI) THEN'
42.427 + REPEAT_DETERM_N (n + 1) o etac thin_rl THEN' rtac (alg_min_alg RS copy_alg_ex) THEN'
42.428 + REPEAT_DETERM_N n o atac THEN'
42.429 + REPEAT_DETERM_N n o card_of_ordIso_tac THEN'
42.430 + EVERY' (map internalize_tac card_of_min_algs) THEN'
42.431 + rtac impI THEN'
42.432 + REPEAT_DETERM o eresolve_tac [exE, conjE] THEN'
42.433 + REPEAT_DETERM o rtac exI THEN'
42.434 + rtac mor_select THEN' atac THEN' rtac CollectI THEN'
42.435 + REPEAT_DETERM o rtac exI THEN'
42.436 + rtac conjI THEN' rtac refl THEN' atac THEN'
42.437 + K (unfold_thms_tac ctxt (Abs_inverse :: fst_snd_convs)) THEN'
42.438 + etac mor_comp THEN' etac mor_incl_min_alg) 1
42.439 + end;
42.440 +
42.441 +fun mk_init_unique_mor_tac m
42.442 + alg_def alg_min_alg least_min_algs in_monos alg_sets morEs map_congs =
42.443 + let
42.444 + val n = length least_min_algs;
42.445 + val ks = (1 upto n);
42.446 +
42.447 + fun mor_tac morE in_mono = EVERY' [etac morE, rtac set_mp, rtac in_mono,
42.448 + REPEAT_DETERM_N n o rtac @{thm Collect_restrict}, rtac CollectI,
42.449 + REPEAT_DETERM_N (m + n) o (TRY o rtac conjI THEN' atac)];
42.450 + fun cong_tac map_cong = EVERY' [rtac (map_cong RS arg_cong),
42.451 + REPEAT_DETERM_N m o rtac refl,
42.452 + REPEAT_DETERM_N n o (etac @{thm prop_restrict} THEN' atac)];
42.453 +
42.454 + fun mk_alg_tac (alg_set, (in_mono, (morE, map_cong))) = EVERY' [rtac ballI, rtac CollectI,
42.455 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac (alg_min_alg RS alg_set),
42.456 + REPEAT_DETERM_N m o rtac subset_UNIV,
42.457 + REPEAT_DETERM_N n o (etac subset_trans THEN' rtac @{thm Collect_restrict}),
42.458 + rtac trans, mor_tac morE in_mono,
42.459 + rtac trans, cong_tac map_cong,
42.460 + rtac sym, mor_tac morE in_mono];
42.461 +
42.462 + fun mk_unique_tac (k, least_min_alg) =
42.463 + select_prem_tac n (etac @{thm prop_restrict}) k THEN' rtac least_min_alg THEN'
42.464 + stac alg_def THEN'
42.465 + CONJ_WRAP' mk_alg_tac (alg_sets ~~ (in_monos ~~ (morEs ~~ map_congs)));
42.466 + in
42.467 + CONJ_WRAP' mk_unique_tac (ks ~~ least_min_algs) 1
42.468 + end;
42.469 +
42.470 +fun mk_init_induct_tac m alg_def alg_min_alg least_min_algs alg_sets =
42.471 + let
42.472 + val n = length least_min_algs;
42.473 +
42.474 + fun mk_alg_tac alg_set = EVERY' [rtac ballI, rtac CollectI,
42.475 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac (alg_min_alg RS alg_set),
42.476 + REPEAT_DETERM_N m o rtac subset_UNIV,
42.477 + REPEAT_DETERM_N n o (etac subset_trans THEN' rtac @{thm Collect_restrict}),
42.478 + rtac mp, etac bspec, rtac CollectI,
42.479 + REPEAT_DETERM_N m o (rtac conjI THEN' atac),
42.480 + CONJ_WRAP' (K (etac subset_trans THEN' rtac @{thm Collect_restrict})) alg_sets,
42.481 + CONJ_WRAP' (K (rtac ballI THEN' etac @{thm prop_restrict} THEN' atac)) alg_sets];
42.482 +
42.483 + fun mk_induct_tac least_min_alg =
42.484 + rtac ballI THEN' etac @{thm prop_restrict} THEN' rtac least_min_alg THEN'
42.485 + stac alg_def THEN'
42.486 + CONJ_WRAP' mk_alg_tac alg_sets;
42.487 + in
42.488 + CONJ_WRAP' mk_induct_tac least_min_algs 1
42.489 + end;
42.490 +
42.491 +fun mk_mor_Rep_tac ctor_defs copy bijs inver_Abss inver_Reps {context = ctxt, prems = _} =
42.492 + (K (unfold_thms_tac ctxt ctor_defs) THEN' rtac conjunct1 THEN' rtac copy THEN'
42.493 + EVERY' (map (fn bij => EVERY' [rtac bij, atac, etac bexI, rtac UNIV_I]) bijs) THEN'
42.494 + EVERY' (map rtac inver_Abss) THEN'
42.495 + EVERY' (map rtac inver_Reps)) 1;
42.496 +
42.497 +fun mk_mor_Abs_tac inv inver_Abss inver_Reps =
42.498 + (rtac inv THEN'
42.499 + EVERY' (map2 (fn inver_Abs => fn inver_Rep =>
42.500 + EVERY' [rtac conjI, rtac subset_UNIV, rtac conjI, rtac inver_Rep, rtac inver_Abs])
42.501 + inver_Abss inver_Reps)) 1;
42.502 +
42.503 +fun mk_mor_fold_tac cT ct fold_defs ex_mor mor =
42.504 + (EVERY' (map stac fold_defs) THEN' EVERY' [rtac rev_mp, rtac ex_mor, rtac impI] THEN'
42.505 + REPEAT_DETERM_N (length fold_defs) o etac exE THEN'
42.506 + rtac (Drule.instantiate' [SOME cT] [SOME ct] @{thm someI}) THEN' etac mor) 1;
42.507 +
42.508 +fun mk_fold_unique_mor_tac type_defs init_unique_mors Reps mor_comp mor_Abs mor_fold =
42.509 + let
42.510 + fun mk_unique type_def =
42.511 + EVERY' [rtac @{thm surj_fun_eq}, rtac (type_def RS @{thm type_definition.Abs_image}),
42.512 + rtac ballI, resolve_tac init_unique_mors,
42.513 + EVERY' (map (fn thm => atac ORELSE' rtac thm) Reps),
42.514 + rtac mor_comp, rtac mor_Abs, atac,
42.515 + rtac mor_comp, rtac mor_Abs, rtac mor_fold];
42.516 + in
42.517 + CONJ_WRAP' mk_unique type_defs 1
42.518 + end;
42.519 +
42.520 +fun mk_dtor_o_ctor_tac dtor_def foldx map_comp_id map_congL ctor_o_folds =
42.521 + EVERY' [stac dtor_def, rtac ext, rtac trans, rtac o_apply, rtac trans, rtac foldx,
42.522 + rtac trans, rtac map_comp_id, rtac trans, rtac map_congL,
42.523 + EVERY' (map (fn thm => rtac ballI THEN' rtac (trans OF [thm RS fun_cong, id_apply]))
42.524 + ctor_o_folds),
42.525 + rtac sym, rtac id_apply] 1;
42.526 +
42.527 +fun mk_rec_tac rec_defs foldx fst_recs {context = ctxt, prems = _}=
42.528 + unfold_thms_tac ctxt
42.529 + (rec_defs @ map (fn thm => thm RS @{thm convol_expand_snd}) fst_recs) THEN
42.530 + EVERY' [rtac trans, rtac o_apply, rtac trans, rtac (foldx RS @{thm arg_cong[of _ _ snd]}),
42.531 + rtac @{thm snd_convol'}] 1;
42.532 +
42.533 +fun mk_ctor_induct_tac m set_natural'ss init_induct morEs mor_Abs Rep_invs Abs_invs Reps =
42.534 + let
42.535 + val n = length set_natural'ss;
42.536 + val ks = 1 upto n;
42.537 +
42.538 + fun mk_IH_tac Rep_inv Abs_inv set_natural' =
42.539 + DETERM o EVERY' [dtac meta_mp, rtac (Rep_inv RS arg_cong RS subst), etac bspec,
42.540 + dtac set_rev_mp, rtac equalityD1, rtac set_natural', etac imageE,
42.541 + hyp_subst_tac, rtac (Abs_inv RS ssubst), etac set_mp, atac, atac];
42.542 +
42.543 + fun mk_closed_tac (k, (morE, set_natural's)) =
42.544 + EVERY' [select_prem_tac n (dtac asm_rl) k, rtac ballI, rtac impI,
42.545 + rtac (mor_Abs RS morE RS arg_cong RS ssubst), atac,
42.546 + REPEAT_DETERM o eresolve_tac [CollectE, conjE], dtac @{thm meta_spec},
42.547 + EVERY' (map3 mk_IH_tac Rep_invs Abs_invs (drop m set_natural's)), atac];
42.548 +
42.549 + fun mk_induct_tac (Rep, Rep_inv) =
42.550 + EVERY' [rtac (Rep_inv RS arg_cong RS subst), etac (Rep RSN (2, bspec))];
42.551 + in
42.552 + (rtac mp THEN' rtac impI THEN'
42.553 + DETERM o CONJ_WRAP_GEN' (etac conjE THEN' rtac conjI) mk_induct_tac (Reps ~~ Rep_invs) THEN'
42.554 + rtac init_induct THEN'
42.555 + DETERM o CONJ_WRAP' mk_closed_tac (ks ~~ (morEs ~~ set_natural'ss))) 1
42.556 + end;
42.557 +
42.558 +fun mk_ctor_induct2_tac cTs cts ctor_induct weak_ctor_inducts {context = ctxt, prems = _} =
42.559 + let
42.560 + val n = length weak_ctor_inducts;
42.561 + val ks = 1 upto n;
42.562 + fun mk_inner_induct_tac induct i =
42.563 + EVERY' [rtac allI, fo_rtac induct ctxt,
42.564 + select_prem_tac n (dtac @{thm meta_spec2}) i,
42.565 + REPEAT_DETERM_N n o
42.566 + EVERY' [dtac meta_mp THEN_ALL_NEW Goal.norm_hhf_tac,
42.567 + REPEAT_DETERM o dtac @{thm meta_spec}, etac (spec RS meta_mp), atac],
42.568 + atac];
42.569 + in
42.570 + EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts ctor_induct),
42.571 + EVERY' (map2 mk_inner_induct_tac weak_ctor_inducts ks), rtac impI,
42.572 + REPEAT_DETERM o eresolve_tac [conjE, allE],
42.573 + CONJ_WRAP' (K atac) ks] 1
42.574 + end;
42.575 +
42.576 +fun mk_map_tac m n foldx map_comp_id map_cong =
42.577 + EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, rtac foldx, rtac trans, rtac o_apply,
42.578 + rtac trans, rtac (map_comp_id RS arg_cong), rtac trans, rtac (map_cong RS arg_cong),
42.579 + REPEAT_DETERM_N m o rtac refl,
42.580 + REPEAT_DETERM_N n o (EVERY' (map rtac [trans, o_apply, id_apply])),
42.581 + rtac sym, rtac o_apply] 1;
42.582 +
42.583 +fun mk_map_unique_tac m mor_def fold_unique_mor map_comp_ids map_congs =
42.584 + let
42.585 + val n = length map_congs;
42.586 + fun mk_mor (comp_id, cong) = EVERY' [rtac ballI, rtac trans, etac @{thm pointfreeE},
42.587 + rtac sym, rtac trans, rtac o_apply, rtac trans, rtac (comp_id RS arg_cong),
42.588 + rtac (cong RS arg_cong),
42.589 + REPEAT_DETERM_N m o rtac refl,
42.590 + REPEAT_DETERM_N n o (EVERY' (map rtac [trans, o_apply, id_apply]))];
42.591 + in
42.592 + EVERY' [rtac fold_unique_mor, rtac ssubst, rtac mor_def, rtac conjI,
42.593 + CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) map_congs,
42.594 + CONJ_WRAP' mk_mor (map_comp_ids ~~ map_congs)] 1
42.595 + end;
42.596 +
42.597 +fun mk_set_tac foldx = EVERY' [rtac ext, rtac trans, rtac o_apply,
42.598 + rtac trans, rtac foldx, rtac sym, rtac o_apply] 1;
42.599 +
42.600 +fun mk_set_simp_tac set set_natural' set_natural's =
42.601 + let
42.602 + val n = length set_natural's;
42.603 + fun mk_UN thm = rtac (thm RS @{thm arg_cong[of _ _ Union]} RS trans) THEN'
42.604 + rtac @{thm Union_image_eq};
42.605 + in
42.606 + EVERY' [rtac (set RS @{thm pointfreeE} RS trans), rtac @{thm Un_cong},
42.607 + rtac (trans OF [set_natural', trans_fun_cong_image_id_id_apply]),
42.608 + REPEAT_DETERM_N (n - 1) o rtac @{thm Un_cong},
42.609 + EVERY' (map mk_UN set_natural's)] 1
42.610 + end;
42.611 +
42.612 +fun mk_set_nat_tac m induct_tac set_natural'ss
42.613 + map_simps csets set_simps i {context = ctxt, prems = _} =
42.614 + let
42.615 + val n = length map_simps;
42.616 +
42.617 + fun useIH set_nat = EVERY' [rtac trans, rtac @{thm image_UN}, rtac trans, rtac @{thm UN_cong},
42.618 + rtac refl, Goal.assume_rule_tac ctxt, rtac sym, rtac trans, rtac @{thm UN_cong},
42.619 + rtac set_nat, rtac refl, rtac @{thm UN_simps(10)}];
42.620 +
42.621 + fun mk_set_nat cset map_simp set_simp set_nats =
42.622 + EVERY' [rtac trans, rtac @{thm image_cong}, rtac set_simp, rtac refl,
42.623 + rtac sym, rtac (trans OF [map_simp RS HOL_arg_cong cset, set_simp RS trans]),
42.624 + rtac sym, EVERY' (map rtac (trans :: @{thms image_Un Un_cong})),
42.625 + rtac sym, rtac (nth set_nats (i - 1)),
42.626 + REPEAT_DETERM_N (n - 1) o EVERY' (map rtac (trans :: @{thms image_Un Un_cong})),
42.627 + EVERY' (map useIH (drop m set_nats))];
42.628 + in
42.629 + (induct_tac THEN' EVERY' (map4 mk_set_nat csets map_simps set_simps set_natural'ss)) 1
42.630 + end;
42.631 +
42.632 +fun mk_set_bd_tac m induct_tac bd_Cinfinite set_bdss set_simps i {context = ctxt, prems = _} =
42.633 + let
42.634 + val n = length set_simps;
42.635 +
42.636 + fun useIH set_bd = EVERY' [rtac @{thm UNION_Cinfinite_bound}, rtac set_bd, rtac ballI,
42.637 + Goal.assume_rule_tac ctxt, rtac bd_Cinfinite];
42.638 +
42.639 + fun mk_set_nat set_simp set_bds =
42.640 + EVERY' [rtac @{thm ordIso_ordLeq_trans}, rtac @{thm card_of_ordIso_subst}, rtac set_simp,
42.641 + rtac (bd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})), rtac (nth set_bds (i - 1)),
42.642 + REPEAT_DETERM_N (n - 1) o rtac (bd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})),
42.643 + EVERY' (map useIH (drop m set_bds))];
42.644 + in
42.645 + (induct_tac THEN' EVERY' (map2 mk_set_nat set_simps set_bdss)) 1
42.646 + end;
42.647 +
42.648 +fun mk_mcong_tac induct_tac set_setsss map_congs map_simps {context = ctxt, prems = _} =
42.649 + let
42.650 + fun use_asm thm = EVERY' [etac bspec, etac set_rev_mp, rtac thm];
42.651 +
42.652 + fun useIH set_sets = EVERY' [rtac mp, Goal.assume_rule_tac ctxt,
42.653 + CONJ_WRAP' (fn thm =>
42.654 + EVERY' [rtac ballI, etac bspec, etac set_rev_mp, etac thm]) set_sets];
42.655 +
42.656 + fun mk_map_cong map_simp map_cong set_setss =
42.657 + EVERY' [rtac impI, REPEAT_DETERM o etac conjE,
42.658 + rtac trans, rtac map_simp, rtac trans, rtac (map_cong RS arg_cong),
42.659 + EVERY' (map use_asm (map hd set_setss)),
42.660 + EVERY' (map useIH (transpose (map tl set_setss))),
42.661 + rtac sym, rtac map_simp];
42.662 + in
42.663 + (induct_tac THEN' EVERY' (map3 mk_map_cong map_simps map_congs set_setsss)) 1
42.664 + end;
42.665 +
42.666 +fun mk_incl_min_alg_tac induct_tac set_setsss alg_sets alg_min_alg {context = ctxt, prems = _} =
42.667 + let
42.668 + fun use_asm thm = etac (thm RS subset_trans);
42.669 +
42.670 + fun useIH set_sets = EVERY' [rtac subsetI, rtac mp, Goal.assume_rule_tac ctxt,
42.671 + rtac CollectI, CONJ_WRAP' (fn thm => EVERY' [etac (thm RS subset_trans), atac]) set_sets];
42.672 +
42.673 + fun mk_incl alg_set set_setss =
42.674 + EVERY' [rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
42.675 + rtac (alg_min_alg RS alg_set),
42.676 + EVERY' (map use_asm (map hd set_setss)),
42.677 + EVERY' (map useIH (transpose (map tl set_setss)))];
42.678 + in
42.679 + (induct_tac THEN' EVERY' (map2 mk_incl alg_sets set_setsss)) 1
42.680 + end;
42.681 +
42.682 +fun mk_lfp_map_wpull_tac m induct_tac wpulls map_simps set_simpss set_setsss ctor_injects =
42.683 + let
42.684 + val n = length wpulls;
42.685 + val ks = 1 upto n;
42.686 + val ls = 1 upto m;
42.687 +
42.688 + fun use_pass_asm thm = rtac conjI THEN' etac (thm RS subset_trans);
42.689 + fun use_act_asm thm = etac (thm RS subset_trans) THEN' atac;
42.690 +
42.691 + fun useIH set_sets i = EVERY' [rtac ssubst, rtac @{thm wpull_def},
42.692 + REPEAT_DETERM_N m o etac thin_rl, select_prem_tac n (dtac asm_rl) i,
42.693 + rtac allI, rtac allI, rtac impI, REPEAT_DETERM o etac conjE,
42.694 + REPEAT_DETERM o dtac @{thm meta_spec},
42.695 + dtac meta_mp, atac,
42.696 + dtac meta_mp, atac, etac mp,
42.697 + rtac conjI, rtac CollectI, CONJ_WRAP' use_act_asm set_sets,
42.698 + rtac conjI, rtac CollectI, CONJ_WRAP' use_act_asm set_sets,
42.699 + atac];
42.700 +
42.701 + fun mk_subset thm = EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm Un_least}, atac,
42.702 + REPEAT_DETERM_N (n - 1) o rtac @{thm Un_least},
42.703 + REPEAT_DETERM_N n o
42.704 + EVERY' [rtac @{thm UN_least}, rtac CollectE, etac set_rev_mp, atac,
42.705 + REPEAT_DETERM o etac conjE, atac]];
42.706 +
42.707 + fun mk_wpull wpull map_simp set_simps set_setss ctor_inject =
42.708 + EVERY' [rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
42.709 + rtac rev_mp, rtac wpull,
42.710 + EVERY' (map (fn i => REPEAT_DETERM_N (i - 1) o etac thin_rl THEN' atac) ls),
42.711 + EVERY' (map2 useIH (transpose (map tl set_setss)) ks),
42.712 + rtac impI, REPEAT_DETERM_N (m + n) o etac thin_rl,
42.713 + dtac @{thm subst[OF wpull_def, of "%x. x"]}, etac allE, etac allE, etac impE,
42.714 + rtac conjI, rtac CollectI, EVERY' (map (use_pass_asm o hd) set_setss),
42.715 + CONJ_WRAP' (K (rtac subset_refl)) ks,
42.716 + rtac conjI, rtac CollectI, EVERY' (map (use_pass_asm o hd) set_setss),
42.717 + CONJ_WRAP' (K (rtac subset_refl)) ks,
42.718 + rtac subst, rtac ctor_inject, rtac trans, rtac sym, rtac map_simp,
42.719 + rtac trans, atac, rtac map_simp, REPEAT_DETERM o eresolve_tac [CollectE, conjE, bexE],
42.720 + hyp_subst_tac, rtac bexI, rtac conjI, rtac map_simp, rtac map_simp, rtac CollectI,
42.721 + CONJ_WRAP' mk_subset set_simps];
42.722 + in
42.723 + (induct_tac THEN' EVERY' (map5 mk_wpull wpulls map_simps set_simpss set_setsss ctor_injects)) 1
42.724 + end;
42.725 +
42.726 +(* BNF tactics *)
42.727 +
42.728 +fun mk_map_id_tac map_ids unique =
42.729 + (rtac sym THEN' rtac unique THEN'
42.730 + EVERY' (map (fn thm =>
42.731 + EVERY' [rtac trans, rtac @{thm id_o}, rtac trans, rtac sym, rtac @{thm o_id},
42.732 + rtac (thm RS sym RS arg_cong)]) map_ids)) 1;
42.733 +
42.734 +fun mk_map_comp_tac map_comps map_simps unique iplus1 =
42.735 + let
42.736 + val i = iplus1 - 1;
42.737 + val unique' = Thm.permute_prems 0 i unique;
42.738 + val map_comps' = drop i map_comps @ take i map_comps;
42.739 + val map_simps' = drop i map_simps @ take i map_simps;
42.740 + fun mk_comp comp simp =
42.741 + EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, rtac o_apply,
42.742 + rtac trans, rtac (simp RS arg_cong), rtac trans, rtac simp,
42.743 + rtac trans, rtac (comp RS arg_cong), rtac sym, rtac o_apply];
42.744 + in
42.745 + (rtac sym THEN' rtac unique' THEN' EVERY' (map2 mk_comp map_comps' map_simps')) 1
42.746 + end;
42.747 +
42.748 +fun mk_set_natural_tac set_nat =
42.749 + EVERY' (map rtac [ext, trans, o_apply, sym, trans, o_apply, set_nat]) 1;
42.750 +
42.751 +fun mk_in_bd_tac sum_Card_order sucbd_Cnotzero incl card_of_min_alg =
42.752 + EVERY' [rtac ctrans, rtac @{thm card_of_mono1}, rtac subsetI, etac rev_mp,
42.753 + rtac incl, rtac ctrans, rtac card_of_min_alg, rtac @{thm cexp_mono2_Cnotzero},
42.754 + rtac @{thm cardSuc_ordLeq_cpow}, rtac sum_Card_order, rtac @{thm csum_Cnotzero2},
42.755 + rtac @{thm ctwo_Cnotzero}, rtac sucbd_Cnotzero] 1;
42.756 +
42.757 +fun mk_bd_card_order_tac bd_card_orders =
42.758 + (rtac @{thm card_order_cpow} THEN'
42.759 + CONJ_WRAP_GEN' (rtac @{thm card_order_csum}) rtac bd_card_orders) 1;
42.760 +
42.761 +fun mk_wpull_tac wpull =
42.762 + EVERY' [rtac ssubst, rtac @{thm wpull_def}, rtac allI, rtac allI,
42.763 + rtac wpull, REPEAT_DETERM o atac] 1;
42.764 +
42.765 +fun mk_wit_tac n set_simp wit =
42.766 + REPEAT_DETERM (atac 1 ORELSE
42.767 + EVERY' [dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
42.768 + REPEAT_DETERM o
42.769 + (TRY o REPEAT_DETERM o etac UnE THEN' TRY o etac @{thm UN_E} THEN'
42.770 + (eresolve_tac wit ORELSE'
42.771 + (dresolve_tac wit THEN'
42.772 + (etac FalseE ORELSE'
42.773 + EVERY' [hyp_subst_tac, dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
42.774 + REPEAT_DETERM_N n o etac UnE]))))] 1);
42.775 +
42.776 +fun mk_srel_simp_tac in_Isrels i in_srel map_comp map_cong map_simp set_simps ctor_inject
42.777 + ctor_dtor set_naturals set_incls set_set_inclss =
42.778 + let
42.779 + val m = length set_incls;
42.780 + val n = length set_set_inclss;
42.781 +
42.782 + val (passive_set_naturals, active_set_naturals) = chop m set_naturals;
42.783 + val in_Isrel = nth in_Isrels (i - 1);
42.784 + val le_arg_cong_ctor_dtor = ctor_dtor RS arg_cong RS ord_eq_le_trans;
42.785 + val eq_arg_cong_ctor_dtor = ctor_dtor RS arg_cong RS trans;
42.786 + val if_tac =
42.787 + EVERY' [dtac (in_Isrel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
42.788 + rtac (in_srel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
42.789 + EVERY' (map2 (fn set_natural => fn set_incl =>
42.790 + EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac set_natural,
42.791 + rtac ord_eq_le_trans, rtac trans_fun_cong_image_id_id_apply,
42.792 + rtac (set_incl RS subset_trans), etac le_arg_cong_ctor_dtor])
42.793 + passive_set_naturals set_incls),
42.794 + CONJ_WRAP' (fn (in_Isrel, (set_natural, set_set_incls)) =>
42.795 + EVERY' [rtac ord_eq_le_trans, rtac set_natural, rtac @{thm image_subsetI},
42.796 + rtac (in_Isrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
42.797 + CONJ_WRAP' (fn thm =>
42.798 + EVERY' (map etac [thm RS subset_trans, le_arg_cong_ctor_dtor]))
42.799 + set_set_incls,
42.800 + rtac conjI, rtac refl, rtac refl])
42.801 + (in_Isrels ~~ (active_set_naturals ~~ set_set_inclss)),
42.802 + CONJ_WRAP' (fn conv =>
42.803 + EVERY' [rtac trans, rtac map_comp, rtac trans, rtac map_cong,
42.804 + REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
42.805 + REPEAT_DETERM_N n o EVERY' (map rtac [trans, o_apply, conv]),
42.806 + rtac (ctor_inject RS iffD1), rtac trans, rtac sym, rtac map_simp,
42.807 + etac eq_arg_cong_ctor_dtor])
42.808 + fst_snd_convs];
42.809 + val only_if_tac =
42.810 + EVERY' [dtac (in_srel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
42.811 + rtac (in_Isrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
42.812 + CONJ_WRAP' (fn (set_simp, passive_set_natural) =>
42.813 + EVERY' [rtac ord_eq_le_trans, rtac set_simp, rtac @{thm Un_least},
42.814 + rtac ord_eq_le_trans, rtac @{thm box_equals[OF _ refl]},
42.815 + rtac passive_set_natural, rtac trans_fun_cong_image_id_id_apply, atac,
42.816 + CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
42.817 + (fn (active_set_natural, in_Isrel) => EVERY' [rtac ord_eq_le_trans,
42.818 + rtac @{thm UN_cong[OF _ refl]}, rtac active_set_natural, rtac @{thm UN_least},
42.819 + dtac set_rev_mp, etac @{thm image_mono}, etac imageE,
42.820 + dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Isrel RS iffD1),
42.821 + dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE,
42.822 + dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac,
42.823 + hyp_subst_tac, REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac])
42.824 + (rev (active_set_naturals ~~ in_Isrels))])
42.825 + (set_simps ~~ passive_set_naturals),
42.826 + rtac conjI,
42.827 + REPEAT_DETERM_N 2 o EVERY' [rtac trans, rtac map_simp, rtac (ctor_inject RS iffD2),
42.828 + rtac trans, rtac map_comp, rtac trans, rtac map_cong,
42.829 + REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
42.830 + EVERY' (map (fn in_Isrel => EVERY' [rtac trans, rtac o_apply, dtac set_rev_mp, atac,
42.831 + dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Isrel RS iffD1),
42.832 + dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, atac]) in_Isrels),
42.833 + atac]]
42.834 + in
42.835 + EVERY' [rtac iffI, if_tac, only_if_tac] 1
42.836 + end;
42.837 +
42.838 +end;
43.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
43.2 +++ b/src/HOL/BNF/Tools/bnf_lfp_util.ML Fri Sep 21 16:45:06 2012 +0200
43.3 @@ -0,0 +1,76 @@
43.4 +(* Title: HOL/BNF/Tools/bnf_lfp_util.ML
43.5 + Author: Dmitriy Traytel, TU Muenchen
43.6 + Author: Jasmin Blanchette, TU Muenchen
43.7 + Copyright 2012
43.8 +
43.9 +Library for the datatype construction.
43.10 +*)
43.11 +
43.12 +signature BNF_LFP_UTIL =
43.13 +sig
43.14 + val HOL_arg_cong: cterm -> thm
43.15 +
43.16 + val mk_bij_betw: term -> term -> term -> term
43.17 + val mk_cardSuc: term -> term
43.18 + val mk_convol: term * term -> term
43.19 + val mk_cpow: term -> term
43.20 + val mk_inver: term -> term -> term -> term
43.21 + val mk_not_empty: term -> term
43.22 + val mk_not_eq: term -> term -> term
43.23 + val mk_rapp: term -> typ -> term
43.24 + val mk_relChain: term -> term -> term
43.25 + val mk_underS: term -> term
43.26 + val mk_worec: term -> term -> term
43.27 +end;
43.28 +
43.29 +structure BNF_LFP_Util : BNF_LFP_UTIL =
43.30 +struct
43.31 +
43.32 +open BNF_Util
43.33 +
43.34 +fun HOL_arg_cong ct = Drule.instantiate'
43.35 + (map SOME (Thm.dest_ctyp (Thm.ctyp_of_term ct))) [NONE, NONE, SOME ct] arg_cong;
43.36 +
43.37 +(*reverse application*)
43.38 +fun mk_rapp arg T = Term.absdummy (fastype_of arg --> T) (Bound 0 $ arg);
43.39 +
43.40 +fun mk_underS r =
43.41 + let val T = fst (dest_relT (fastype_of r));
43.42 + in Const (@{const_name rel.underS}, mk_relT (T, T) --> T --> HOLogic.mk_setT T) $ r end;
43.43 +
43.44 +fun mk_worec r f =
43.45 + let val (A, AB) = apfst domain_type (dest_funT (fastype_of f));
43.46 + in Const (@{const_name wo_rel.worec}, mk_relT (A, A) --> (AB --> AB) --> AB) $ r $ f end;
43.47 +
43.48 +fun mk_relChain r f =
43.49 + let val (A, AB) = `domain_type (fastype_of f);
43.50 + in Const (@{const_name relChain}, mk_relT (A, A) --> AB --> HOLogic.boolT) $ r $ f end;
43.51 +
43.52 +fun mk_cardSuc r =
43.53 + let val T = fst (dest_relT (fastype_of r));
43.54 + in Const (@{const_name cardSuc}, mk_relT (T, T) --> mk_relT (`I (HOLogic.mk_setT T))) $ r end;
43.55 +
43.56 +fun mk_cpow r =
43.57 + let val T = fst (dest_relT (fastype_of r));
43.58 + in Const (@{const_name cpow}, mk_relT (T, T) --> mk_relT (`I (HOLogic.mk_setT T))) $ r end;
43.59 +
43.60 +fun mk_bij_betw f A B =
43.61 + Const (@{const_name bij_betw},
43.62 + fastype_of f --> fastype_of A --> fastype_of B --> HOLogic.boolT) $ f $ A $ B;
43.63 +
43.64 +fun mk_inver f g A =
43.65 + Const (@{const_name inver}, fastype_of f --> fastype_of g --> fastype_of A --> HOLogic.boolT) $
43.66 + f $ g $ A;
43.67 +
43.68 +fun mk_not_eq x y = HOLogic.mk_not (HOLogic.mk_eq (x, y));
43.69 +
43.70 +fun mk_not_empty B = mk_not_eq B (HOLogic.mk_set (HOLogic.dest_setT (fastype_of B)) []);
43.71 +
43.72 +fun mk_convol (f, g) =
43.73 + let
43.74 + val (fU, fTU) = `range_type (fastype_of f);
43.75 + val ((gT, gU), gTU) = `dest_funT (fastype_of g);
43.76 + val convolT = fTU --> gTU --> gT --> HOLogic.mk_prodT (fU, gU);
43.77 + in Const (@{const_name convol}, convolT) $ f $ g end;
43.78 +
43.79 +end;
44.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
44.2 +++ b/src/HOL/BNF/Tools/bnf_tactics.ML Fri Sep 21 16:45:06 2012 +0200
44.3 @@ -0,0 +1,125 @@
44.4 +(* Title: HOL/BNF/Tools/bnf_tactics.ML
44.5 + Author: Dmitriy Traytel, TU Muenchen
44.6 + Author: Jasmin Blanchette, TU Muenchen
44.7 + Copyright 2012
44.8 +
44.9 +General tactics for bounded natural functors.
44.10 +*)
44.11 +
44.12 +signature BNF_TACTICS =
44.13 +sig
44.14 + val ss_only: thm list -> simpset
44.15 +
44.16 + val prefer_tac: int -> tactic
44.17 + val select_prem_tac: int -> (int -> tactic) -> int -> int -> tactic
44.18 + val fo_rtac: thm -> Proof.context -> int -> tactic
44.19 + val subst_asm_tac: Proof.context -> thm list -> int -> tactic
44.20 + val subst_tac: Proof.context -> thm list -> int -> tactic
44.21 + val substs_tac: Proof.context -> thm list -> int -> tactic
44.22 + val unfold_thms_tac: Proof.context -> thm list -> tactic
44.23 + val mk_unfold_thms_then_tac: Proof.context -> thm list -> ('a -> tactic) -> 'a -> tactic
44.24 +
44.25 + val mk_flatten_assoc_tac: (int -> tactic) -> thm -> thm -> thm -> tactic
44.26 + val mk_rotate_eq_tac: (int -> tactic) -> thm -> thm -> thm -> thm -> ''a list -> ''a list ->
44.27 + int -> tactic
44.28 +
44.29 + val mk_Abs_bij_thm: Proof.context -> thm -> thm -> thm
44.30 + val mk_Abs_inj_thm: thm -> thm
44.31 +
44.32 + val simple_srel_O_Gr_tac: Proof.context -> tactic
44.33 + val mk_rel_simp_tac: thm -> thm list -> thm list -> thm -> {prems: 'a, context: Proof.context} ->
44.34 + tactic
44.35 +
44.36 + val mk_map_comp_id_tac: thm -> tactic
44.37 + val mk_map_cong_tac: int -> thm -> {prems: 'a, context: Proof.context} -> tactic
44.38 + val mk_map_congL_tac: int -> thm -> thm -> tactic
44.39 +end;
44.40 +
44.41 +structure BNF_Tactics : BNF_TACTICS =
44.42 +struct
44.43 +
44.44 +open BNF_Util
44.45 +
44.46 +fun ss_only thms = Simplifier.clear_ss HOL_basic_ss addsimps thms;
44.47 +
44.48 +(* FIXME: why not in "Pure"? *)
44.49 +fun prefer_tac i = defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1);
44.50 +
44.51 +fun select_prem_tac n tac k = DETERM o (EVERY' [REPEAT_DETERM_N (k - 1) o etac thin_rl,
44.52 + tac, REPEAT_DETERM_N (n - k) o etac thin_rl]);
44.53 +
44.54 +(*stolen from Christian Urban's Cookbook*)
44.55 +fun fo_rtac thm = Subgoal.FOCUS (fn {concl, ...} =>
44.56 + let
44.57 + val concl_pat = Drule.strip_imp_concl (cprop_of thm)
44.58 + val insts = Thm.first_order_match (concl_pat, concl)
44.59 + in
44.60 + rtac (Drule.instantiate_normalize insts thm) 1
44.61 + end);
44.62 +
44.63 +fun unfold_thms_tac ctxt thms = Local_Defs.unfold_tac ctxt (distinct Thm.eq_thm_prop thms);
44.64 +
44.65 +fun mk_unfold_thms_then_tac lthy defs tac x = unfold_thms_tac lthy defs THEN tac x;
44.66 +
44.67 +(*unlike "unfold_thms_tac", succeeds when the RHS contains schematic variables not in the LHS*)
44.68 +fun subst_asm_tac ctxt = EqSubst.eqsubst_asm_tac ctxt [0];
44.69 +fun subst_tac ctxt = EqSubst.eqsubst_tac ctxt [0];
44.70 +fun substs_tac ctxt = REPEAT_DETERM oo subst_tac ctxt;
44.71 +
44.72 +
44.73 +(* Theorems for open typedefs with UNIV as representing set *)
44.74 +
44.75 +fun mk_Abs_inj_thm inj = inj OF (replicate 2 UNIV_I);
44.76 +fun mk_Abs_bij_thm ctxt Abs_inj_thm surj = rule_by_tactic ctxt ((rtac surj THEN' etac exI) 1)
44.77 + (Abs_inj_thm RS @{thm bijI});
44.78 +
44.79 +
44.80 +
44.81 +(* General tactic generators *)
44.82 +
44.83 +(*applies assoc rule to the lhs of an equation as long as possible*)
44.84 +fun mk_flatten_assoc_tac refl_tac trans assoc cong = rtac trans 1 THEN
44.85 + REPEAT_DETERM (CHANGED ((FIRST' [rtac trans THEN' rtac assoc, rtac cong THEN' refl_tac]) 1)) THEN
44.86 + refl_tac 1;
44.87 +
44.88 +(*proves two sides of an equation to be equal assuming both are flattened and rhs can be obtained
44.89 +from lhs by the given permutation of monoms*)
44.90 +fun mk_rotate_eq_tac refl_tac trans assoc com cong =
44.91 + let
44.92 + fun gen_tac [] [] = K all_tac
44.93 + | gen_tac [x] [y] = if x = y then refl_tac else error "mk_rotate_eq_tac: different lists"
44.94 + | gen_tac (x :: xs) (y :: ys) = if x = y
44.95 + then rtac cong THEN' refl_tac THEN' gen_tac xs ys
44.96 + else rtac trans THEN' rtac com THEN'
44.97 + K (mk_flatten_assoc_tac refl_tac trans assoc cong) THEN'
44.98 + gen_tac (xs @ [x]) (y :: ys)
44.99 + | gen_tac _ _ = error "mk_rotate_eq_tac: different lists";
44.100 + in
44.101 + gen_tac
44.102 + end;
44.103 +
44.104 +fun simple_srel_O_Gr_tac ctxt =
44.105 + unfold_thms_tac ctxt @{thms Collect_fst_snd_mem_eq Collect_pair_mem_eq} THEN rtac refl 1;
44.106 +
44.107 +fun mk_rel_simp_tac srel_def IJrel_defs IJsrel_defs srel_simp {context = ctxt, prems = _} =
44.108 + unfold_thms_tac ctxt IJrel_defs THEN
44.109 + subst_tac ctxt [unfold_thms ctxt (IJrel_defs @ IJsrel_defs @
44.110 + @{thms Collect_pair_mem_eq mem_Collect_eq fst_conv snd_conv}) srel_simp] 1 THEN
44.111 + unfold_thms_tac ctxt (srel_def ::
44.112 + @{thms Collect_fst_snd_mem_eq mem_Collect_eq pair_mem_Collect_split fst_conv snd_conv
44.113 + split_conv}) THEN
44.114 + rtac refl 1;
44.115 +
44.116 +fun mk_map_comp_id_tac map_comp =
44.117 + (rtac trans THEN' rtac map_comp THEN' REPEAT_DETERM o stac @{thm o_id} THEN' rtac refl) 1;
44.118 +
44.119 +fun mk_map_cong_tac m map_cong {context = ctxt, prems = _} =
44.120 + EVERY' [rtac mp, rtac map_cong,
44.121 + CONJ_WRAP' (K (rtac ballI THEN' Goal.assume_rule_tac ctxt)) (1 upto m)] 1;
44.122 +
44.123 +fun mk_map_congL_tac passive map_cong map_id' =
44.124 + (rtac trans THEN' rtac map_cong THEN' EVERY' (replicate passive (rtac refl))) 1 THEN
44.125 + REPEAT_DETERM (EVERY' [rtac trans, etac bspec, atac, rtac sym, rtac @{thm id_apply}] 1) THEN
44.126 + rtac map_id' 1;
44.127 +
44.128 +end;
45.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
45.2 +++ b/src/HOL/BNF/Tools/bnf_util.ML Fri Sep 21 16:45:06 2012 +0200
45.3 @@ -0,0 +1,619 @@
45.4 +(* Title: HOL/BNF/Tools/bnf_util.ML
45.5 + Author: Dmitriy Traytel, TU Muenchen
45.6 + Copyright 2012
45.7 +
45.8 +Library for bounded natural functors.
45.9 +*)
45.10 +
45.11 +signature BNF_UTIL =
45.12 +sig
45.13 + val map3: ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
45.14 + val map4: ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
45.15 + val map5: ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
45.16 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list
45.17 + val map6: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
45.18 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list
45.19 + val map7: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) ->
45.20 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list
45.21 + val map8: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i) ->
45.22 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list -> 'i list
45.23 + val map9: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j) ->
45.24 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
45.25 + 'i list -> 'j list
45.26 + val map10: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k) ->
45.27 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
45.28 + 'i list -> 'j list -> 'k list
45.29 + val map11: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k -> 'l) ->
45.30 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
45.31 + 'i list -> 'j list -> 'k list -> 'l list
45.32 + val map12: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k -> 'l -> 'm) ->
45.33 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
45.34 + 'i list -> 'j list -> 'k list -> 'l list -> 'm list
45.35 + val fold_map2: ('a -> 'b -> 'c -> 'd * 'c) -> 'a list -> 'b list -> 'c -> 'd list * 'c
45.36 + val fold_map3: ('a -> 'b -> 'c -> 'd -> 'e * 'd) ->
45.37 + 'a list -> 'b list -> 'c list -> 'd -> 'e list * 'd
45.38 + val fold_map4: ('a -> 'b -> 'c -> 'd -> 'e -> 'f * 'e) ->
45.39 + 'a list -> 'b list -> 'c list -> 'd list -> 'e -> 'f list * 'e
45.40 + val fold_map5: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g * 'f) ->
45.41 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f -> 'g list * 'f
45.42 + val fold_map6: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h * 'g) ->
45.43 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g -> 'h list * 'g
45.44 + val fold_map7: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i * 'h) ->
45.45 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h -> 'i list * 'h
45.46 + val interleave: 'a list -> 'a list -> 'a list
45.47 + val transpose: 'a list list -> 'a list list
45.48 + val seq_conds: (bool -> 'a -> 'b) -> int -> int -> 'a list -> 'b list
45.49 +
45.50 + val mk_fresh_names: Proof.context -> int -> string -> string list * Proof.context
45.51 + val mk_TFrees: int -> Proof.context -> typ list * Proof.context
45.52 + val mk_TFreess: int list -> Proof.context -> typ list list * Proof.context
45.53 + val mk_TFrees': sort list -> Proof.context -> typ list * Proof.context
45.54 + val mk_Frees: string -> typ list -> Proof.context -> term list * Proof.context
45.55 + val mk_Freess: string -> typ list list -> Proof.context -> term list list * Proof.context
45.56 + val mk_Freesss: string -> typ list list list -> Proof.context ->
45.57 + term list list list * Proof.context
45.58 + val mk_Freessss: string -> typ list list list list -> Proof.context ->
45.59 + term list list list list * Proof.context
45.60 + val mk_Frees': string -> typ list -> Proof.context ->
45.61 + (term list * (string * typ) list) * Proof.context
45.62 + val mk_Freess': string -> typ list list -> Proof.context ->
45.63 + (term list list * (string * typ) list list) * Proof.context
45.64 + val nonzero_string_of_int: int -> string
45.65 +
45.66 + val strip_typeN: int -> typ -> typ list * typ
45.67 +
45.68 + val mk_predT: typ list -> typ
45.69 + val mk_pred1T: typ -> typ
45.70 + val mk_pred2T: typ -> typ -> typ
45.71 + val mk_optionT: typ -> typ
45.72 + val mk_relT: typ * typ -> typ
45.73 + val dest_relT: typ -> typ * typ
45.74 + val mk_sumT: typ * typ -> typ
45.75 +
45.76 + val ctwo: term
45.77 + val fst_const: typ -> term
45.78 + val snd_const: typ -> term
45.79 + val Id_const: typ -> term
45.80 +
45.81 + val mk_Ball: term -> term -> term
45.82 + val mk_Bex: term -> term -> term
45.83 + val mk_Card_order: term -> term
45.84 + val mk_Field: term -> term
45.85 + val mk_Gr: term -> term -> term
45.86 + val mk_IfN: typ -> term list -> term list -> term
45.87 + val mk_Trueprop_eq: term * term -> term
45.88 + val mk_UNION: term -> term -> term
45.89 + val mk_Union: typ -> term
45.90 + val mk_card_binop: string -> (typ * typ -> typ) -> term -> term -> term
45.91 + val mk_card_of: term -> term
45.92 + val mk_card_order: term -> term
45.93 + val mk_ccexp: term -> term -> term
45.94 + val mk_cexp: term -> term -> term
45.95 + val mk_cinfinite: term -> term
45.96 + val mk_collect: term list -> typ -> term
45.97 + val mk_converse: term -> term
45.98 + val mk_cprod: term -> term -> term
45.99 + val mk_csum: term -> term -> term
45.100 + val mk_dir_image: term -> term -> term
45.101 + val mk_image: term -> term
45.102 + val mk_in: term list -> term list -> typ -> term
45.103 + val mk_ordLeq: term -> term -> term
45.104 + val mk_rel_comp: term * term -> term
45.105 + val mk_subset: term -> term -> term
45.106 + val mk_wpull: term -> term -> term -> term -> term -> (term * term) option -> term -> term -> term
45.107 +
45.108 + val list_all_free: term list -> term -> term
45.109 + val list_exists_free: term list -> term -> term
45.110 +
45.111 + (*parameterized terms*)
45.112 + val mk_nthN: int -> term -> int -> term
45.113 +
45.114 + (*parameterized thms*)
45.115 + val mk_Un_upper: int -> int -> thm
45.116 + val mk_conjIN: int -> thm
45.117 + val mk_conjunctN: int -> int -> thm
45.118 + val conj_dests: int -> thm -> thm list
45.119 + val mk_disjIN: int -> int -> thm
45.120 + val mk_nthI: int -> int -> thm
45.121 + val mk_nth_conv: int -> int -> thm
45.122 + val mk_ordLeq_csum: int -> int -> thm -> thm
45.123 + val mk_UnIN: int -> int -> thm
45.124 +
45.125 + val ctrans: thm
45.126 + val o_apply: thm
45.127 + val set_mp: thm
45.128 + val set_rev_mp: thm
45.129 + val subset_UNIV: thm
45.130 + val Pair_eqD: thm
45.131 + val Pair_eqI: thm
45.132 + val mk_sym: thm -> thm
45.133 + val mk_trans: thm -> thm -> thm
45.134 + val mk_unabs_def: int -> thm -> thm
45.135 +
45.136 + val is_refl: thm -> bool
45.137 + val no_refl: thm list -> thm list
45.138 + val no_reflexive: thm list -> thm list
45.139 +
45.140 + val fold_thms: Proof.context -> thm list -> thm -> thm
45.141 + val unfold_thms: Proof.context -> thm list -> thm -> thm
45.142 +
45.143 + val mk_permute: ''a list -> ''a list -> 'b list -> 'b list
45.144 + val find_indices: ''a list -> ''a list -> int list
45.145 +
45.146 + val certifyT: Proof.context -> typ -> ctyp
45.147 + val certify: Proof.context -> term -> cterm
45.148 +
45.149 + val parse_binding_colon: Token.T list -> binding * Token.T list
45.150 + val parse_opt_binding_colon: Token.T list -> binding * Token.T list
45.151 +
45.152 + val typedef: bool -> binding option -> binding * (string * sort) list * mixfix -> term ->
45.153 + (binding * binding) option -> tactic -> local_theory -> (string * Typedef.info) * local_theory
45.154 +
45.155 + val WRAP: ('a -> tactic) -> ('a -> tactic) -> 'a list -> tactic -> tactic
45.156 + val WRAP': ('a -> int -> tactic) -> ('a -> int -> tactic) -> 'a list -> (int -> tactic) -> int ->
45.157 + tactic
45.158 + val CONJ_WRAP_GEN: tactic -> ('a -> tactic) -> 'a list -> tactic
45.159 + val CONJ_WRAP_GEN': (int -> tactic) -> ('a -> int -> tactic) -> 'a list -> int -> tactic
45.160 + val CONJ_WRAP: ('a -> tactic) -> 'a list -> tactic
45.161 + val CONJ_WRAP': ('a -> int -> tactic) -> 'a list -> int -> tactic
45.162 +end;
45.163 +
45.164 +structure BNF_Util : BNF_UTIL =
45.165 +struct
45.166 +
45.167 +(* Library proper *)
45.168 +
45.169 +fun map3 _ [] [] [] = []
45.170 + | map3 f (x1::x1s) (x2::x2s) (x3::x3s) = f x1 x2 x3 :: map3 f x1s x2s x3s
45.171 + | map3 _ _ _ _ = raise ListPair.UnequalLengths;
45.172 +
45.173 +fun map4 _ [] [] [] [] = []
45.174 + | map4 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) = f x1 x2 x3 x4 :: map4 f x1s x2s x3s x4s
45.175 + | map4 _ _ _ _ _ = raise ListPair.UnequalLengths;
45.176 +
45.177 +fun map5 _ [] [] [] [] [] = []
45.178 + | map5 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) =
45.179 + f x1 x2 x3 x4 x5 :: map5 f x1s x2s x3s x4s x5s
45.180 + | map5 _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.181 +
45.182 +fun map6 _ [] [] [] [] [] [] = []
45.183 + | map6 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) =
45.184 + f x1 x2 x3 x4 x5 x6 :: map6 f x1s x2s x3s x4s x5s x6s
45.185 + | map6 _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.186 +
45.187 +fun map7 _ [] [] [] [] [] [] [] = []
45.188 + | map7 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) (x7::x7s) =
45.189 + f x1 x2 x3 x4 x5 x6 x7 :: map7 f x1s x2s x3s x4s x5s x6s x7s
45.190 + | map7 _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.191 +
45.192 +fun map8 _ [] [] [] [] [] [] [] [] = []
45.193 + | map8 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) (x7::x7s) (x8::x8s) =
45.194 + f x1 x2 x3 x4 x5 x6 x7 x8 :: map8 f x1s x2s x3s x4s x5s x6s x7s x8s
45.195 + | map8 _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.196 +
45.197 +fun map9 _ [] [] [] [] [] [] [] [] [] = []
45.198 + | map9 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
45.199 + (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) =
45.200 + f x1 x2 x3 x4 x5 x6 x7 x8 x9 :: map9 f x1s x2s x3s x4s x5s x6s x7s x8s x9s
45.201 + | map9 _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.202 +
45.203 +fun map10 _ [] [] [] [] [] [] [] [] [] [] = []
45.204 + | map10 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
45.205 + (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) (x10::x10s) =
45.206 + f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 :: map10 f x1s x2s x3s x4s x5s x6s x7s x8s x9s x10s
45.207 + | map10 _ _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.208 +
45.209 +fun map11 _ [] [] [] [] [] [] [] [] [] [] [] = []
45.210 + | map11 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
45.211 + (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) (x10::x10s) (x11::x11s) =
45.212 + f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 :: map11 f x1s x2s x3s x4s x5s x6s x7s x8s x9s x10s x11s
45.213 + | map11 _ _ _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.214 +
45.215 +fun map12 _ [] [] [] [] [] [] [] [] [] [] [] [] = []
45.216 + | map12 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
45.217 + (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) (x10::x10s) (x11::x11s) (x12::x12s) =
45.218 + f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 ::
45.219 + map12 f x1s x2s x3s x4s x5s x6s x7s x8s x9s x10s x11s x12s
45.220 + | map12 _ _ _ _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.221 +
45.222 +fun fold_map2 _ [] [] acc = ([], acc)
45.223 + | fold_map2 f (x1::x1s) (x2::x2s) acc =
45.224 + let
45.225 + val (x, acc') = f x1 x2 acc;
45.226 + val (xs, acc'') = fold_map2 f x1s x2s acc';
45.227 + in (x :: xs, acc'') end
45.228 + | fold_map2 _ _ _ _ = raise ListPair.UnequalLengths;
45.229 +
45.230 +fun fold_map3 _ [] [] [] acc = ([], acc)
45.231 + | fold_map3 f (x1::x1s) (x2::x2s) (x3::x3s) acc =
45.232 + let
45.233 + val (x, acc') = f x1 x2 x3 acc;
45.234 + val (xs, acc'') = fold_map3 f x1s x2s x3s acc';
45.235 + in (x :: xs, acc'') end
45.236 + | fold_map3 _ _ _ _ _ = raise ListPair.UnequalLengths;
45.237 +
45.238 +fun fold_map4 _ [] [] [] [] acc = ([], acc)
45.239 + | fold_map4 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) acc =
45.240 + let
45.241 + val (x, acc') = f x1 x2 x3 x4 acc;
45.242 + val (xs, acc'') = fold_map4 f x1s x2s x3s x4s acc';
45.243 + in (x :: xs, acc'') end
45.244 + | fold_map4 _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.245 +
45.246 +fun fold_map5 _ [] [] [] [] [] acc = ([], acc)
45.247 + | fold_map5 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) acc =
45.248 + let
45.249 + val (x, acc') = f x1 x2 x3 x4 x5 acc;
45.250 + val (xs, acc'') = fold_map5 f x1s x2s x3s x4s x5s acc';
45.251 + in (x :: xs, acc'') end
45.252 + | fold_map5 _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.253 +
45.254 +fun fold_map6 _ [] [] [] [] [] [] acc = ([], acc)
45.255 + | fold_map6 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) acc =
45.256 + let
45.257 + val (x, acc') = f x1 x2 x3 x4 x5 x6 acc;
45.258 + val (xs, acc'') = fold_map6 f x1s x2s x3s x4s x5s x6s acc';
45.259 + in (x :: xs, acc'') end
45.260 + | fold_map6 _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.261 +
45.262 +fun fold_map7 _ [] [] [] [] [] [] [] acc = ([], acc)
45.263 + | fold_map7 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) (x7::x7s) acc =
45.264 + let
45.265 + val (x, acc') = f x1 x2 x3 x4 x5 x6 x7 acc;
45.266 + val (xs, acc'') = fold_map7 f x1s x2s x3s x4s x5s x6s x7s acc';
45.267 + in (x :: xs, acc'') end
45.268 + | fold_map7 _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
45.269 +
45.270 +(*stolen from ~~/src/HOL/Tools/SMT/smt_utils.ML*)
45.271 +fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt);
45.272 +fun certifyT ctxt = Thm.ctyp_of (Proof_Context.theory_of ctxt);
45.273 +
45.274 +val parse_binding_colon = Parse.binding --| @{keyword ":"};
45.275 +val parse_opt_binding_colon = Scan.optional parse_binding_colon Binding.empty;
45.276 +
45.277 +(*TODO: is this really different from Typedef.add_typedef_global?*)
45.278 +fun typedef def opt_name typ set opt_morphs tac lthy =
45.279 + let
45.280 + val ((name, info), (lthy, lthy_old)) =
45.281 + lthy
45.282 + |> Typedef.add_typedef def opt_name typ set opt_morphs tac
45.283 + ||> `Local_Theory.restore;
45.284 + val phi = Proof_Context.export_morphism lthy_old lthy;
45.285 + in
45.286 + ((name, Typedef.transform_info phi info), lthy)
45.287 + end;
45.288 +
45.289 +(*Tactical WRAP surrounds a static given tactic (core) with two deterministic chains of tactics*)
45.290 +fun WRAP gen_before gen_after xs core_tac =
45.291 + fold_rev (fn x => fn tac => gen_before x THEN tac THEN gen_after x) xs core_tac;
45.292 +
45.293 +fun WRAP' gen_before gen_after xs core_tac =
45.294 + fold_rev (fn x => fn tac => gen_before x THEN' tac THEN' gen_after x) xs core_tac;
45.295 +
45.296 +fun CONJ_WRAP_GEN conj_tac gen_tac xs =
45.297 + let val (butlast, last) = split_last xs;
45.298 + in WRAP (fn thm => conj_tac THEN gen_tac thm) (K all_tac) butlast (gen_tac last) end;
45.299 +
45.300 +fun CONJ_WRAP_GEN' conj_tac gen_tac xs =
45.301 + let val (butlast, last) = split_last xs;
45.302 + in WRAP' (fn thm => conj_tac THEN' gen_tac thm) (K (K all_tac)) butlast (gen_tac last) end;
45.303 +
45.304 +(*not eta-converted because of monotype restriction*)
45.305 +fun CONJ_WRAP gen_tac = CONJ_WRAP_GEN (rtac conjI 1) gen_tac;
45.306 +fun CONJ_WRAP' gen_tac = CONJ_WRAP_GEN' (rtac conjI) gen_tac;
45.307 +
45.308 +
45.309 +
45.310 +(* Term construction *)
45.311 +
45.312 +(** Fresh variables **)
45.313 +
45.314 +fun nonzero_string_of_int 0 = ""
45.315 + | nonzero_string_of_int n = string_of_int n;
45.316 +
45.317 +val mk_TFrees' = apfst (map TFree) oo Variable.invent_types;
45.318 +
45.319 +fun mk_TFrees n = mk_TFrees' (replicate n HOLogic.typeS);
45.320 +val mk_TFreess = fold_map mk_TFrees;
45.321 +
45.322 +fun mk_names n x = if n = 1 then [x] else map (fn i => x ^ string_of_int i) (1 upto n);
45.323 +
45.324 +fun mk_fresh_names ctxt = (fn xs => Variable.variant_fixes xs ctxt) oo mk_names;
45.325 +fun mk_Frees x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => map2 (curry Free) xs Ts);
45.326 +fun mk_Freess x Tss = fold_map2 mk_Frees (mk_names (length Tss) x) Tss;
45.327 +fun mk_Freesss x Tsss = fold_map2 mk_Freess (mk_names (length Tsss) x) Tsss;
45.328 +fun mk_Freessss x Tssss = fold_map2 mk_Freesss (mk_names (length Tssss) x) Tssss;
45.329 +fun mk_Frees' x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => `(map Free) (xs ~~ Ts));
45.330 +fun mk_Freess' x Tss = fold_map2 mk_Frees' (mk_names (length Tss) x) Tss #>> split_list;
45.331 +
45.332 +
45.333 +(** Types **)
45.334 +
45.335 +fun strip_typeN 0 T = ([], T)
45.336 + | strip_typeN n (Type (@{type_name fun}, [T, T'])) = strip_typeN (n - 1) T' |>> cons T
45.337 + | strip_typeN _ T = raise TYPE ("strip_typeN", [T], []);
45.338 +
45.339 +fun mk_predT Ts = Ts ---> HOLogic.boolT;
45.340 +fun mk_pred1T T = mk_predT [T];
45.341 +fun mk_pred2T T U = mk_predT [T, U];
45.342 +fun mk_optionT T = Type (@{type_name option}, [T]);
45.343 +val mk_relT = HOLogic.mk_setT o HOLogic.mk_prodT;
45.344 +val dest_relT = HOLogic.dest_prodT o HOLogic.dest_setT;
45.345 +fun mk_sumT (LT, RT) = Type (@{type_name Sum_Type.sum}, [LT, RT]);
45.346 +fun mk_partial_funT (ranT, domT) = domT --> mk_optionT ranT;
45.347 +
45.348 +
45.349 +(** Constants **)
45.350 +
45.351 +fun fst_const T = Const (@{const_name fst}, T --> fst (HOLogic.dest_prodT T));
45.352 +fun snd_const T = Const (@{const_name snd}, T --> snd (HOLogic.dest_prodT T));
45.353 +fun Id_const T = Const (@{const_name Id}, mk_relT (T, T));
45.354 +
45.355 +
45.356 +(** Operators **)
45.357 +
45.358 +val mk_Trueprop_eq = HOLogic.mk_Trueprop o HOLogic.mk_eq;
45.359 +
45.360 +fun mk_IfN _ _ [t] = t
45.361 + | mk_IfN T (c :: cs) (t :: ts) =
45.362 + Const (@{const_name If}, HOLogic.boolT --> T --> T --> T) $ c $ t $ mk_IfN T cs ts;
45.363 +
45.364 +fun mk_converse R =
45.365 + let
45.366 + val RT = dest_relT (fastype_of R);
45.367 + val RST = mk_relT (snd RT, fst RT);
45.368 + in Const (@{const_name converse}, fastype_of R --> RST) $ R end;
45.369 +
45.370 +fun mk_rel_comp (R, S) =
45.371 + let
45.372 + val RT = fastype_of R;
45.373 + val ST = fastype_of S;
45.374 + val RST = mk_relT (fst (dest_relT RT), snd (dest_relT ST));
45.375 + in Const (@{const_name relcomp}, RT --> ST --> RST) $ R $ S end;
45.376 +
45.377 +fun mk_Gr A f =
45.378 + let val ((AT, BT), FT) = `dest_funT (fastype_of f);
45.379 + in Const (@{const_name Gr}, HOLogic.mk_setT AT --> FT --> mk_relT (AT, BT)) $ A $ f end;
45.380 +
45.381 +fun mk_image f =
45.382 + let val (T, U) = dest_funT (fastype_of f);
45.383 + in Const (@{const_name image},
45.384 + (T --> U) --> (HOLogic.mk_setT T) --> (HOLogic.mk_setT U)) $ f end;
45.385 +
45.386 +fun mk_Ball X f =
45.387 + Const (@{const_name Ball}, fastype_of X --> fastype_of f --> HOLogic.boolT) $ X $ f;
45.388 +
45.389 +fun mk_Bex X f =
45.390 + Const (@{const_name Bex}, fastype_of X --> fastype_of f --> HOLogic.boolT) $ X $ f;
45.391 +
45.392 +fun mk_UNION X f =
45.393 + let val (T, U) = dest_funT (fastype_of f);
45.394 + in Const (@{const_name SUPR}, fastype_of X --> (T --> U) --> U) $ X $ f end;
45.395 +
45.396 +fun mk_Union T =
45.397 + Const (@{const_name Sup}, HOLogic.mk_setT (HOLogic.mk_setT T) --> HOLogic.mk_setT T);
45.398 +
45.399 +fun mk_Field r =
45.400 + let val T = fst (dest_relT (fastype_of r));
45.401 + in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
45.402 +
45.403 +fun mk_card_order bd =
45.404 + let
45.405 + val T = fastype_of bd;
45.406 + val AT = fst (dest_relT T);
45.407 + in
45.408 + Const (@{const_name card_order_on}, HOLogic.mk_setT AT --> T --> HOLogic.boolT) $
45.409 + (HOLogic.mk_UNIV AT) $ bd
45.410 + end;
45.411 +
45.412 +fun mk_Card_order bd =
45.413 + let
45.414 + val T = fastype_of bd;
45.415 + val AT = fst (dest_relT T);
45.416 + in
45.417 + Const (@{const_name card_order_on}, HOLogic.mk_setT AT --> T --> HOLogic.boolT) $
45.418 + mk_Field bd $ bd
45.419 + end;
45.420 +
45.421 +fun mk_cinfinite bd =
45.422 + Const (@{const_name cinfinite}, fastype_of bd --> HOLogic.boolT) $ bd;
45.423 +
45.424 +fun mk_ordLeq t1 t2 =
45.425 + HOLogic.mk_mem (HOLogic.mk_prod (t1, t2),
45.426 + Const (@{const_name ordLeq}, mk_relT (fastype_of t1, fastype_of t2)));
45.427 +
45.428 +fun mk_card_of A =
45.429 + let
45.430 + val AT = fastype_of A;
45.431 + val T = HOLogic.dest_setT AT;
45.432 + in
45.433 + Const (@{const_name card_of}, AT --> mk_relT (T, T)) $ A
45.434 + end;
45.435 +
45.436 +fun mk_dir_image r f =
45.437 + let val (T, U) = dest_funT (fastype_of f);
45.438 + in Const (@{const_name dir_image}, mk_relT (T, T) --> (T --> U) --> mk_relT (U, U)) $ r $ f end;
45.439 +
45.440 +(*FIXME: "x"?*)
45.441 +(*(nth sets i) must be of type "T --> 'ai set"*)
45.442 +fun mk_in As sets T =
45.443 + let
45.444 + fun in_single set A =
45.445 + let val AT = fastype_of A;
45.446 + in Const (@{const_name less_eq},
45.447 + AT --> AT --> HOLogic.boolT) $ (set $ Free ("x", T)) $ A end;
45.448 + in
45.449 + if length sets > 0
45.450 + then HOLogic.mk_Collect ("x", T, foldr1 (HOLogic.mk_conj) (map2 in_single sets As))
45.451 + else HOLogic.mk_UNIV T
45.452 + end;
45.453 +
45.454 +fun mk_wpull A B1 B2 f1 f2 pseudo p1 p2 =
45.455 + let
45.456 + val AT = fastype_of A;
45.457 + val BT1 = fastype_of B1;
45.458 + val BT2 = fastype_of B2;
45.459 + val FT1 = fastype_of f1;
45.460 + val FT2 = fastype_of f2;
45.461 + val PT1 = fastype_of p1;
45.462 + val PT2 = fastype_of p2;
45.463 + val T1 = HOLogic.dest_setT BT1;
45.464 + val T2 = HOLogic.dest_setT BT2;
45.465 + val domP = domain_type PT1;
45.466 + val ranF = range_type FT1;
45.467 + val _ = if is_some pseudo orelse
45.468 + (HOLogic.dest_setT AT = domP andalso
45.469 + domain_type FT1 = T1 andalso
45.470 + domain_type FT2 = T2 andalso
45.471 + domain_type PT2 = domP andalso
45.472 + range_type PT1 = T1 andalso
45.473 + range_type PT2 = T2 andalso
45.474 + range_type FT2 = ranF)
45.475 + then () else raise TYPE ("mk_wpull", [BT1, BT2, FT1, FT2, PT1, PT2], []);
45.476 + in
45.477 + (case pseudo of
45.478 + NONE => Const (@{const_name wpull},
45.479 + AT --> BT1 --> BT2 --> FT1 --> FT2 --> PT1 --> PT2 --> HOLogic.boolT) $
45.480 + A $ B1 $ B2 $ f1 $ f2 $ p1 $ p2
45.481 + | SOME (e1, e2) => Const (@{const_name wppull},
45.482 + AT --> BT1 --> BT2 --> FT1 --> FT2 --> fastype_of e1 --> fastype_of e2 -->
45.483 + PT1 --> PT2 --> HOLogic.boolT) $
45.484 + A $ B1 $ B2 $ f1 $ f2 $ e1 $ e2 $ p1 $ p2)
45.485 + end;
45.486 +
45.487 +fun mk_subset t1 t2 =
45.488 + Const (@{const_name less_eq}, (fastype_of t1) --> (fastype_of t2) --> HOLogic.boolT) $ t1 $ t2;
45.489 +
45.490 +fun mk_card_binop binop typop t1 t2 =
45.491 + let
45.492 + val (T1, relT1) = `(fst o dest_relT) (fastype_of t1);
45.493 + val (T2, relT2) = `(fst o dest_relT) (fastype_of t2);
45.494 + in
45.495 + Const (binop, relT1 --> relT2 --> mk_relT (typop (T1, T2), typop (T1, T2))) $ t1 $ t2
45.496 + end;
45.497 +
45.498 +val mk_csum = mk_card_binop @{const_name csum} mk_sumT;
45.499 +val mk_cprod = mk_card_binop @{const_name cprod} HOLogic.mk_prodT;
45.500 +val mk_cexp = mk_card_binop @{const_name cexp} mk_partial_funT;
45.501 +val mk_ccexp = mk_card_binop @{const_name ccexp} mk_partial_funT;
45.502 +val ctwo = @{term ctwo};
45.503 +
45.504 +fun mk_collect xs defT =
45.505 + let val T = (case xs of [] => defT | (x::_) => fastype_of x);
45.506 + in Const (@{const_name collect}, HOLogic.mk_setT T --> T) $ (HOLogic.mk_set T xs) end;
45.507 +
45.508 +fun mk_permute src dest xs = map (nth xs o (fn x => find_index ((curry op =) x) src)) dest;
45.509 +
45.510 +val list_all_free =
45.511 + fold_rev (fn free => fn P =>
45.512 + let val (x, T) = Term.dest_Free free;
45.513 + in HOLogic.all_const T $ Term.absfree (x, T) P end);
45.514 +
45.515 +val list_exists_free =
45.516 + fold_rev (fn free => fn P =>
45.517 + let val (x, T) = Term.dest_Free free;
45.518 + in HOLogic.exists_const T $ Term.absfree (x, T) P end);
45.519 +
45.520 +fun find_indices xs ys = map_filter I
45.521 + (map_index (fn (i, y) => if member (op =) xs y then SOME i else NONE) ys);
45.522 +
45.523 +fun mk_trans thm1 thm2 = trans OF [thm1, thm2];
45.524 +fun mk_sym thm = sym OF [thm];
45.525 +
45.526 +(*TODO: antiquote heavily used theorems once*)
45.527 +val ctrans = @{thm ordLeq_transitive};
45.528 +val o_apply = @{thm o_apply};
45.529 +val set_mp = @{thm set_mp};
45.530 +val set_rev_mp = @{thm set_rev_mp};
45.531 +val subset_UNIV = @{thm subset_UNIV};
45.532 +val Pair_eqD = @{thm iffD1[OF Pair_eq]};
45.533 +val Pair_eqI = @{thm iffD2[OF Pair_eq]};
45.534 +
45.535 +fun mk_nthN 1 t 1 = t
45.536 + | mk_nthN _ t 1 = HOLogic.mk_fst t
45.537 + | mk_nthN 2 t 2 = HOLogic.mk_snd t
45.538 + | mk_nthN n t m = mk_nthN (n - 1) (HOLogic.mk_snd t) (m - 1);
45.539 +
45.540 +fun mk_nth_conv n m =
45.541 + let
45.542 + fun thm b = if b then @{thm fst_snd} else @{thm snd_snd}
45.543 + fun mk_nth_conv _ 1 1 = refl
45.544 + | mk_nth_conv _ _ 1 = @{thm fst_conv}
45.545 + | mk_nth_conv _ 2 2 = @{thm snd_conv}
45.546 + | mk_nth_conv b _ 2 = @{thm snd_conv} RS thm b
45.547 + | mk_nth_conv b n m = mk_nth_conv false (n - 1) (m - 1) RS thm b;
45.548 + in mk_nth_conv (not (m = n)) n m end;
45.549 +
45.550 +fun mk_nthI 1 1 = @{thm TrueE[OF TrueI]}
45.551 + | mk_nthI n m = fold (curry op RS) (replicate (m - 1) @{thm sndI})
45.552 + (if m = n then @{thm TrueE[OF TrueI]} else @{thm fstI});
45.553 +
45.554 +fun mk_conjunctN 1 1 = @{thm TrueE[OF TrueI]}
45.555 + | mk_conjunctN _ 1 = conjunct1
45.556 + | mk_conjunctN 2 2 = conjunct2
45.557 + | mk_conjunctN n m = conjunct2 RS (mk_conjunctN (n - 1) (m - 1));
45.558 +
45.559 +fun conj_dests n thm = map (fn k => thm RS mk_conjunctN n k) (1 upto n);
45.560 +
45.561 +fun mk_conjIN 1 = @{thm TrueE[OF TrueI]}
45.562 + | mk_conjIN n = mk_conjIN (n - 1) RSN (2, conjI);
45.563 +
45.564 +fun mk_disjIN 1 1 = @{thm TrueE[OF TrueI]}
45.565 + | mk_disjIN _ 1 = disjI1
45.566 + | mk_disjIN 2 2 = disjI2
45.567 + | mk_disjIN n m = (mk_disjIN (n - 1) (m - 1)) RS disjI2;
45.568 +
45.569 +fun mk_ordLeq_csum 1 1 thm = thm
45.570 + | mk_ordLeq_csum _ 1 thm = @{thm ordLeq_transitive} OF [thm, @{thm ordLeq_csum1}]
45.571 + | mk_ordLeq_csum 2 2 thm = @{thm ordLeq_transitive} OF [thm, @{thm ordLeq_csum2}]
45.572 + | mk_ordLeq_csum n m thm = @{thm ordLeq_transitive} OF
45.573 + [mk_ordLeq_csum (n - 1) (m - 1) thm, @{thm ordLeq_csum2[OF Card_order_csum]}];
45.574 +
45.575 +local
45.576 + fun mk_Un_upper' 0 = subset_refl
45.577 + | mk_Un_upper' 1 = @{thm Un_upper1}
45.578 + | mk_Un_upper' k = Library.foldr (op RS o swap)
45.579 + (replicate (k - 1) @{thm subset_trans[OF Un_upper1]}, @{thm Un_upper1});
45.580 +in
45.581 + fun mk_Un_upper 1 1 = subset_refl
45.582 + | mk_Un_upper n 1 = mk_Un_upper' (n - 2) RS @{thm subset_trans[OF Un_upper1]}
45.583 + | mk_Un_upper n m = mk_Un_upper' (n - m) RS @{thm subset_trans[OF Un_upper2]};
45.584 +end;
45.585 +
45.586 +local
45.587 + fun mk_UnIN' 0 = @{thm UnI2}
45.588 + | mk_UnIN' m = mk_UnIN' (m - 1) RS @{thm UnI1};
45.589 +in
45.590 + fun mk_UnIN 1 1 = @{thm TrueE[OF TrueI]}
45.591 + | mk_UnIN n 1 = Library.foldr1 (op RS o swap) (replicate (n - 1) @{thm UnI1})
45.592 + | mk_UnIN n m = mk_UnIN' (n - m)
45.593 +end;
45.594 +
45.595 +fun interleave xs ys = flat (map2 (fn x => fn y => [x, y]) xs ys);
45.596 +
45.597 +fun transpose [] = []
45.598 + | transpose ([] :: xss) = transpose xss
45.599 + | transpose xss = map hd xss :: transpose (map tl xss);
45.600 +
45.601 +fun seq_conds f n k xs =
45.602 + if k = n then
45.603 + map (f false) (take (k - 1) xs)
45.604 + else
45.605 + let val (negs, pos) = split_last (take k xs) in
45.606 + map (f false) negs @ [f true pos]
45.607 + end;
45.608 +
45.609 +fun mk_unabs_def 0 thm = thm
45.610 + | mk_unabs_def n thm = mk_unabs_def (n - 1) thm RS @{thm spec[OF iffD1[OF fun_eq_iff]]};
45.611 +
45.612 +fun is_refl thm =
45.613 + op aconv (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of thm)))
45.614 + handle TERM _ => false;
45.615 +
45.616 +val no_refl = filter_out is_refl;
45.617 +val no_reflexive = filter_out Thm.is_reflexive;
45.618 +
45.619 +fun fold_thms ctxt thms = Local_Defs.fold ctxt (distinct Thm.eq_thm_prop thms);
45.620 +fun unfold_thms ctxt thms = Local_Defs.unfold ctxt (distinct Thm.eq_thm_prop thms);
45.621 +
45.622 +end;
46.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
46.2 +++ b/src/HOL/BNF/Tools/bnf_wrap.ML Fri Sep 21 16:45:06 2012 +0200
46.3 @@ -0,0 +1,665 @@
46.4 +(* Title: HOL/BNF/Tools/bnf_wrap.ML
46.5 + Author: Jasmin Blanchette, TU Muenchen
46.6 + Copyright 2012
46.7 +
46.8 +Wrapping existing datatypes.
46.9 +*)
46.10 +
46.11 +signature BNF_WRAP =
46.12 +sig
46.13 + val mk_half_pairss: 'a list -> ('a * 'a) list list
46.14 + val mk_ctr: typ list -> term -> term
46.15 + val mk_disc_or_sel: typ list -> term -> term
46.16 + val base_name_of_ctr: term -> string
46.17 + val wrap_datatype: ({prems: thm list, context: Proof.context} -> tactic) list list ->
46.18 + ((bool * term list) * term) *
46.19 + (binding list * (binding list list * (binding * term) list list)) -> local_theory ->
46.20 + (term list * term list list * thm list * thm list * thm list * thm list list * thm list *
46.21 + thm list list) * local_theory
46.22 + val parse_wrap_options: bool parser
46.23 + val parse_bound_term: (binding * string) parser
46.24 +end;
46.25 +
46.26 +structure BNF_Wrap : BNF_WRAP =
46.27 +struct
46.28 +
46.29 +open BNF_Util
46.30 +open BNF_Wrap_Tactics
46.31 +
46.32 +val isN = "is_";
46.33 +val unN = "un_";
46.34 +fun mk_unN 1 1 suf = unN ^ suf
46.35 + | mk_unN _ l suf = unN ^ suf ^ string_of_int l;
46.36 +
46.37 +val case_congN = "case_cong";
46.38 +val case_eqN = "case_eq";
46.39 +val casesN = "cases";
46.40 +val collapseN = "collapse";
46.41 +val disc_excludeN = "disc_exclude";
46.42 +val disc_exhaustN = "disc_exhaust";
46.43 +val discsN = "discs";
46.44 +val distinctN = "distinct";
46.45 +val exhaustN = "exhaust";
46.46 +val expandN = "expand";
46.47 +val injectN = "inject";
46.48 +val nchotomyN = "nchotomy";
46.49 +val selsN = "sels";
46.50 +val splitN = "split";
46.51 +val split_asmN = "split_asm";
46.52 +val weak_case_cong_thmsN = "weak_case_cong";
46.53 +
46.54 +val std_binding = @{binding _};
46.55 +
46.56 +val induct_simp_attrs = @{attributes [induct_simp]};
46.57 +val cong_attrs = @{attributes [cong]};
46.58 +val iff_attrs = @{attributes [iff]};
46.59 +val safe_elim_attrs = @{attributes [elim!]};
46.60 +val simp_attrs = @{attributes [simp]};
46.61 +
46.62 +fun pad_list x n xs = xs @ replicate (n - length xs) x;
46.63 +
46.64 +fun unflat_lookup eq ys zs = map (map (fn x => nth zs (find_index (curry eq x) ys)));
46.65 +
46.66 +fun mk_half_pairss' _ [] = []
46.67 + | mk_half_pairss' indent (x :: xs) =
46.68 + indent @ fold_rev (cons o single o pair x) xs (mk_half_pairss' ([] :: indent) xs);
46.69 +
46.70 +fun mk_half_pairss xs = mk_half_pairss' [[]] xs;
46.71 +
46.72 +fun join_halves n half_xss other_half_xss =
46.73 + let
46.74 + val xsss =
46.75 + map2 (map2 append) (Library.chop_groups n half_xss)
46.76 + (transpose (Library.chop_groups n other_half_xss))
46.77 + val xs = interleave (flat half_xss) (flat other_half_xss);
46.78 + in (xs, xsss |> `transpose) end;
46.79 +
46.80 +fun mk_undefined T = Const (@{const_name undefined}, T);
46.81 +
46.82 +fun mk_ctr Ts t =
46.83 + let val Type (_, Ts0) = body_type (fastype_of t) in
46.84 + Term.subst_atomic_types (Ts0 ~~ Ts) t
46.85 + end;
46.86 +
46.87 +fun mk_disc_or_sel Ts t =
46.88 + Term.subst_atomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t;
46.89 +
46.90 +fun base_name_of_ctr c =
46.91 + Long_Name.base_name (case head_of c of
46.92 + Const (s, _) => s
46.93 + | Free (s, _) => s
46.94 + | _ => error "Cannot extract name of constructor");
46.95 +
46.96 +fun rapp u t = betapply (t, u);
46.97 +
46.98 +fun eta_expand_arg xs f_xs = fold_rev Term.lambda xs f_xs;
46.99 +
46.100 +fun prepare_wrap_datatype prep_term (((no_dests, raw_ctrs), raw_case),
46.101 + (raw_disc_bindings, (raw_sel_bindingss, raw_sel_defaultss))) no_defs_lthy =
46.102 + let
46.103 + (* TODO: sanity checks on arguments *)
46.104 + (* TODO: case syntax *)
46.105 +
46.106 + val n = length raw_ctrs;
46.107 + val ks = 1 upto n;
46.108 +
46.109 + val _ = if n > 0 then () else error "No constructors specified";
46.110 +
46.111 + val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs;
46.112 + val case0 = prep_term no_defs_lthy raw_case;
46.113 + val sel_defaultss =
46.114 + pad_list [] n (map (map (apsnd (prep_term no_defs_lthy))) raw_sel_defaultss);
46.115 +
46.116 + val Type (dataT_name, As0) = body_type (fastype_of (hd ctrs0));
46.117 + val data_b = Binding.qualified_name dataT_name;
46.118 + val data_b_name = Binding.name_of data_b;
46.119 +
46.120 + val (As, B) =
46.121 + no_defs_lthy
46.122 + |> mk_TFrees' (map Type.sort_of_atyp As0)
46.123 + ||> the_single o fst o mk_TFrees 1;
46.124 +
46.125 + val dataT = Type (dataT_name, As);
46.126 + val ctrs = map (mk_ctr As) ctrs0;
46.127 + val ctr_Tss = map (binder_types o fastype_of) ctrs;
46.128 +
46.129 + val ms = map length ctr_Tss;
46.130 +
46.131 + val raw_disc_bindings' = pad_list Binding.empty n raw_disc_bindings;
46.132 +
46.133 + fun can_really_rely_on_disc k =
46.134 + not (Binding.eq_name (nth raw_disc_bindings' (k - 1), Binding.empty)) orelse
46.135 + nth ms (k - 1) = 0;
46.136 + fun can_rely_on_disc k =
46.137 + can_really_rely_on_disc k orelse (k = 1 andalso not (can_really_rely_on_disc 2));
46.138 + fun can_omit_disc_binding k m =
46.139 + n = 1 orelse m = 0 orelse (n = 2 andalso can_rely_on_disc (3 - k));
46.140 +
46.141 + val std_disc_binding =
46.142 + Binding.qualify false data_b_name o Binding.name o prefix isN o base_name_of_ctr;
46.143 +
46.144 + val disc_bindings =
46.145 + raw_disc_bindings'
46.146 + |> map4 (fn k => fn m => fn ctr => fn disc =>
46.147 + Option.map (Binding.qualify false data_b_name)
46.148 + (if Binding.eq_name (disc, Binding.empty) then
46.149 + if can_omit_disc_binding k m then NONE else SOME (std_disc_binding ctr)
46.150 + else if Binding.eq_name (disc, std_binding) then
46.151 + SOME (std_disc_binding ctr)
46.152 + else
46.153 + SOME disc)) ks ms ctrs0;
46.154 +
46.155 + val no_discs = map is_none disc_bindings;
46.156 + val no_discs_at_all = forall I no_discs;
46.157 +
46.158 + fun std_sel_binding m l = Binding.name o mk_unN m l o base_name_of_ctr;
46.159 +
46.160 + val sel_bindingss =
46.161 + pad_list [] n raw_sel_bindingss
46.162 + |> map3 (fn ctr => fn m => map2 (fn l => fn sel =>
46.163 + Binding.qualify false data_b_name
46.164 + (if Binding.eq_name (sel, Binding.empty) orelse Binding.eq_name (sel, std_binding) then
46.165 + std_sel_binding m l ctr
46.166 + else
46.167 + sel)) (1 upto m) o pad_list Binding.empty m) ctrs0 ms;
46.168 +
46.169 + fun mk_case Ts T =
46.170 + let
46.171 + val (bindings, body) = strip_type (fastype_of case0)
46.172 + val Type (_, Ts0) = List.last bindings
46.173 + in Term.subst_atomic_types ((body, T) :: (Ts0 ~~ Ts)) case0 end;
46.174 +
46.175 + val casex = mk_case As B;
46.176 + val case_Ts = map (fn Ts => Ts ---> B) ctr_Tss;
46.177 +
46.178 + val (((((((xss, xss'), yss), fs), gs), [u', v']), (p, p')), names_lthy) = no_defs_lthy |>
46.179 + mk_Freess' "x" ctr_Tss
46.180 + ||>> mk_Freess "y" ctr_Tss
46.181 + ||>> mk_Frees "f" case_Ts
46.182 + ||>> mk_Frees "g" case_Ts
46.183 + ||>> (apfst (map (rpair dataT)) oo Variable.variant_fixes) [data_b_name, data_b_name ^ "'"]
46.184 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "P") HOLogic.boolT;
46.185 +
46.186 + val u = Free u';
46.187 + val v = Free v';
46.188 + val q = Free (fst p', mk_pred1T B);
46.189 +
46.190 + val xctrs = map2 (curry Term.list_comb) ctrs xss;
46.191 + val yctrs = map2 (curry Term.list_comb) ctrs yss;
46.192 +
46.193 + val xfs = map2 (curry Term.list_comb) fs xss;
46.194 + val xgs = map2 (curry Term.list_comb) gs xss;
46.195 +
46.196 + val eta_fs = map2 eta_expand_arg xss xfs;
46.197 + val eta_gs = map2 eta_expand_arg xss xgs;
46.198 +
46.199 + val fcase = Term.list_comb (casex, eta_fs);
46.200 + val gcase = Term.list_comb (casex, eta_gs);
46.201 +
46.202 + val ufcase = fcase $ u;
46.203 + val vfcase = fcase $ v;
46.204 + val vgcase = gcase $ v;
46.205 +
46.206 + fun mk_u_eq_u () = HOLogic.mk_eq (u, u);
46.207 +
46.208 + val u_eq_v = mk_Trueprop_eq (u, v);
46.209 +
46.210 + val exist_xs_u_eq_ctrs =
46.211 + map2 (fn xctr => fn xs => list_exists_free xs (HOLogic.mk_eq (u, xctr))) xctrs xss;
46.212 +
46.213 + val unique_disc_no_def = TrueI; (*arbitrary marker*)
46.214 + val alternate_disc_no_def = FalseE; (*arbitrary marker*)
46.215 +
46.216 + fun alternate_disc_lhs get_udisc k =
46.217 + HOLogic.mk_not
46.218 + (case nth disc_bindings (k - 1) of
46.219 + NONE => nth exist_xs_u_eq_ctrs (k - 1)
46.220 + | SOME b => get_udisc b (k - 1));
46.221 +
46.222 + val (all_sels_distinct, discs, selss, udiscs, uselss, vdiscs, vselss, disc_defs, sel_defs,
46.223 + sel_defss, lthy') =
46.224 + if no_dests then
46.225 + (true, [], [], [], [], [], [], [], [], [], no_defs_lthy)
46.226 + else
46.227 + let
46.228 + fun disc_free b = Free (Binding.name_of b, mk_pred1T dataT);
46.229 +
46.230 + fun disc_spec b exist_xs_u_eq_ctr = mk_Trueprop_eq (disc_free b $ u, exist_xs_u_eq_ctr);
46.231 +
46.232 + fun alternate_disc k =
46.233 + Term.lambda u (alternate_disc_lhs (K o rapp u o disc_free) (3 - k));
46.234 +
46.235 + fun mk_default T t =
46.236 + let
46.237 + val Ts0 = map TFree (Term.add_tfreesT (fastype_of t) []);
46.238 + val Ts = map TFree (Term.add_tfreesT T []);
46.239 + in Term.subst_atomic_types (Ts0 ~~ Ts) t end;
46.240 +
46.241 + fun mk_sel_case_args b proto_sels T =
46.242 + map2 (fn Ts => fn k =>
46.243 + (case AList.lookup (op =) proto_sels k of
46.244 + NONE =>
46.245 + (case AList.lookup Binding.eq_name (rev (nth sel_defaultss (k - 1))) b of
46.246 + NONE => fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T)
46.247 + | SOME t => mk_default (Ts ---> T) t)
46.248 + | SOME (xs, x) => fold_rev Term.lambda xs x)) ctr_Tss ks;
46.249 +
46.250 + fun sel_spec b proto_sels =
46.251 + let
46.252 + val _ =
46.253 + (case duplicates (op =) (map fst proto_sels) of
46.254 + k :: _ => error ("Duplicate selector name " ^ quote (Binding.name_of b) ^
46.255 + " for constructor " ^
46.256 + quote (Syntax.string_of_term no_defs_lthy (nth ctrs (k - 1))))
46.257 + | [] => ())
46.258 + val T =
46.259 + (case distinct (op =) (map (fastype_of o snd o snd) proto_sels) of
46.260 + [T] => T
46.261 + | T :: T' :: _ => error ("Inconsistent range type for selector " ^
46.262 + quote (Binding.name_of b) ^ ": " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
46.263 + " vs. " ^ quote (Syntax.string_of_typ no_defs_lthy T')));
46.264 + in
46.265 + mk_Trueprop_eq (Free (Binding.name_of b, dataT --> T) $ u,
46.266 + Term.list_comb (mk_case As T, mk_sel_case_args b proto_sels T) $ u)
46.267 + end;
46.268 +
46.269 + val sel_bindings = flat sel_bindingss;
46.270 + val uniq_sel_bindings = distinct Binding.eq_name sel_bindings;
46.271 + val all_sels_distinct = (length uniq_sel_bindings = length sel_bindings);
46.272 +
46.273 + val sel_binding_index =
46.274 + if all_sels_distinct then 1 upto length sel_bindings
46.275 + else map (fn b => find_index (curry Binding.eq_name b) uniq_sel_bindings) sel_bindings;
46.276 +
46.277 + val proto_sels = flat (map3 (fn k => fn xs => map (fn x => (k, (xs, x)))) ks xss xss);
46.278 + val sel_infos =
46.279 + AList.group (op =) (sel_binding_index ~~ proto_sels)
46.280 + |> sort (int_ord o pairself fst)
46.281 + |> map snd |> curry (op ~~) uniq_sel_bindings;
46.282 + val sel_bindings = map fst sel_infos;
46.283 +
46.284 + fun unflat_selss xs = unflat_lookup Binding.eq_name sel_bindings xs sel_bindingss;
46.285 +
46.286 + val (((raw_discs, raw_disc_defs), (raw_sels, raw_sel_defs)), (lthy', lthy)) =
46.287 + no_defs_lthy
46.288 + |> apfst split_list o fold_map4 (fn k => fn m => fn exist_xs_u_eq_ctr =>
46.289 + fn NONE =>
46.290 + if n = 1 then pair (Term.lambda u (mk_u_eq_u ()), unique_disc_no_def)
46.291 + else if m = 0 then pair (Term.lambda u exist_xs_u_eq_ctr, refl)
46.292 + else pair (alternate_disc k, alternate_disc_no_def)
46.293 + | SOME b => Specification.definition (SOME (b, NONE, NoSyn),
46.294 + ((Thm.def_binding b, []), disc_spec b exist_xs_u_eq_ctr)) #>> apsnd snd)
46.295 + ks ms exist_xs_u_eq_ctrs disc_bindings
46.296 + ||>> apfst split_list o fold_map (fn (b, proto_sels) =>
46.297 + Specification.definition (SOME (b, NONE, NoSyn),
46.298 + ((Thm.def_binding b, []), sel_spec b proto_sels)) #>> apsnd snd) sel_infos
46.299 + ||> `Local_Theory.restore;
46.300 +
46.301 + val phi = Proof_Context.export_morphism lthy lthy';
46.302 +
46.303 + val disc_defs = map (Morphism.thm phi) raw_disc_defs;
46.304 + val sel_defs = map (Morphism.thm phi) raw_sel_defs;
46.305 + val sel_defss = unflat_selss sel_defs;
46.306 +
46.307 + val discs0 = map (Morphism.term phi) raw_discs;
46.308 + val selss0 = unflat_selss (map (Morphism.term phi) raw_sels);
46.309 +
46.310 + val discs = map (mk_disc_or_sel As) discs0;
46.311 + val selss = map (map (mk_disc_or_sel As)) selss0;
46.312 +
46.313 + val udiscs = map (rapp u) discs;
46.314 + val uselss = map (map (rapp u)) selss;
46.315 +
46.316 + val vdiscs = map (rapp v) discs;
46.317 + val vselss = map (map (rapp v)) selss;
46.318 + in
46.319 + (all_sels_distinct, discs, selss, udiscs, uselss, vdiscs, vselss, disc_defs, sel_defs,
46.320 + sel_defss, lthy')
46.321 + end;
46.322 +
46.323 + fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p);
46.324 +
46.325 + val exhaust_goal =
46.326 + let fun mk_prem xctr xs = fold_rev Logic.all xs (mk_imp_p [mk_Trueprop_eq (u, xctr)]) in
46.327 + fold_rev Logic.all [p, u] (mk_imp_p (map2 mk_prem xctrs xss))
46.328 + end;
46.329 +
46.330 + val inject_goalss =
46.331 + let
46.332 + fun mk_goal _ _ [] [] = []
46.333 + | mk_goal xctr yctr xs ys =
46.334 + [fold_rev Logic.all (xs @ ys) (mk_Trueprop_eq (HOLogic.mk_eq (xctr, yctr),
46.335 + Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) xs ys)))];
46.336 + in
46.337 + map4 mk_goal xctrs yctrs xss yss
46.338 + end;
46.339 +
46.340 + val half_distinct_goalss =
46.341 + let
46.342 + fun mk_goal ((xs, xc), (xs', xc')) =
46.343 + fold_rev Logic.all (xs @ xs')
46.344 + (HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (xc, xc'))));
46.345 + in
46.346 + map (map mk_goal) (mk_half_pairss (xss ~~ xctrs))
46.347 + end;
46.348 +
46.349 + val cases_goal =
46.350 + map3 (fn xs => fn xctr => fn xf =>
46.351 + fold_rev Logic.all (fs @ xs) (mk_Trueprop_eq (fcase $ xctr, xf))) xss xctrs xfs;
46.352 +
46.353 + val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss @ [cases_goal];
46.354 +
46.355 + fun after_qed thmss lthy =
46.356 + let
46.357 + val ([exhaust_thm], (inject_thmss, (half_distinct_thmss, [case_thms]))) =
46.358 + (hd thmss, apsnd (chop (n * n)) (chop n (tl thmss)));
46.359 +
46.360 + val inject_thms = flat inject_thmss;
46.361 +
46.362 + val Tinst = map (pairself (certifyT lthy)) (map Logic.varifyT_global As ~~ As);
46.363 +
46.364 + fun inst_thm t thm =
46.365 + Drule.instantiate' [] [SOME (certify lthy t)]
46.366 + (Thm.instantiate (Tinst, []) (Drule.zero_var_indexes thm));
46.367 +
46.368 + val uexhaust_thm = inst_thm u exhaust_thm;
46.369 +
46.370 + val exhaust_cases = map base_name_of_ctr ctrs;
46.371 +
46.372 + val other_half_distinct_thmss = map (map (fn thm => thm RS not_sym)) half_distinct_thmss;
46.373 +
46.374 + val (distinct_thms, (distinct_thmsss', distinct_thmsss)) =
46.375 + join_halves n half_distinct_thmss other_half_distinct_thmss;
46.376 +
46.377 + val nchotomy_thm =
46.378 + let
46.379 + val goal =
46.380 + HOLogic.mk_Trueprop (HOLogic.mk_all (fst u', snd u',
46.381 + Library.foldr1 HOLogic.mk_disj exist_xs_u_eq_ctrs));
46.382 + in
46.383 + Skip_Proof.prove lthy [] [] goal (fn _ => mk_nchotomy_tac n exhaust_thm)
46.384 + end;
46.385 +
46.386 + val (all_sel_thms, sel_thmss, disc_thmss, disc_thms, discI_thms, disc_exclude_thms,
46.387 + disc_exhaust_thms, collapse_thms, expand_thms, case_eq_thms) =
46.388 + if no_dests then
46.389 + ([], [], [], [], [], [], [], [], [], [])
46.390 + else
46.391 + let
46.392 + fun make_sel_thm xs' case_thm sel_def =
46.393 + zero_var_indexes (Drule.gen_all (Drule.rename_bvars' (map (SOME o fst) xs')
46.394 + (Drule.forall_intr_vars (case_thm RS (sel_def RS trans)))));
46.395 +
46.396 + fun has_undefined_rhs thm =
46.397 + (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of thm))) of
46.398 + Const (@{const_name undefined}, _) => true
46.399 + | _ => false);
46.400 +
46.401 + val sel_thmss = map3 (map oo make_sel_thm) xss' case_thms sel_defss;
46.402 +
46.403 + val all_sel_thms =
46.404 + (if all_sels_distinct andalso forall null sel_defaultss then
46.405 + flat sel_thmss
46.406 + else
46.407 + map_product (fn s => fn (xs', c) => make_sel_thm xs' c s) sel_defs
46.408 + (xss' ~~ case_thms))
46.409 + |> filter_out has_undefined_rhs;
46.410 +
46.411 + fun mk_unique_disc_def () =
46.412 + let
46.413 + val m = the_single ms;
46.414 + val goal = mk_Trueprop_eq (mk_u_eq_u (), the_single exist_xs_u_eq_ctrs);
46.415 + in
46.416 + Skip_Proof.prove lthy [] [] goal (fn _ => mk_unique_disc_def_tac m uexhaust_thm)
46.417 + |> singleton (Proof_Context.export names_lthy lthy)
46.418 + |> Thm.close_derivation
46.419 + end;
46.420 +
46.421 + fun mk_alternate_disc_def k =
46.422 + let
46.423 + val goal =
46.424 + mk_Trueprop_eq (alternate_disc_lhs (K (nth udiscs)) (3 - k),
46.425 + nth exist_xs_u_eq_ctrs (k - 1));
46.426 + in
46.427 + Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
46.428 + mk_alternate_disc_def_tac ctxt k (nth disc_defs (2 - k))
46.429 + (nth distinct_thms (2 - k)) uexhaust_thm)
46.430 + |> singleton (Proof_Context.export names_lthy lthy)
46.431 + |> Thm.close_derivation
46.432 + end;
46.433 +
46.434 + val has_alternate_disc_def =
46.435 + exists (fn def => Thm.eq_thm_prop (def, alternate_disc_no_def)) disc_defs;
46.436 +
46.437 + val disc_defs' =
46.438 + map2 (fn k => fn def =>
46.439 + if Thm.eq_thm_prop (def, unique_disc_no_def) then mk_unique_disc_def ()
46.440 + else if Thm.eq_thm_prop (def, alternate_disc_no_def) then mk_alternate_disc_def k
46.441 + else def) ks disc_defs;
46.442 +
46.443 + val discD_thms = map (fn def => def RS iffD1) disc_defs';
46.444 + val discI_thms =
46.445 + map2 (fn m => fn def => funpow m (fn thm => exI RS thm) (def RS iffD2)) ms
46.446 + disc_defs';
46.447 + val not_discI_thms =
46.448 + map2 (fn m => fn def => funpow m (fn thm => allI RS thm)
46.449 + (unfold_thms lthy @{thms not_ex} (def RS @{thm ssubst[of _ _ Not]})))
46.450 + ms disc_defs';
46.451 +
46.452 + val (disc_thmss', disc_thmss) =
46.453 + let
46.454 + fun mk_thm discI _ [] = refl RS discI
46.455 + | mk_thm _ not_discI [distinct] = distinct RS not_discI;
46.456 + fun mk_thms discI not_discI distinctss = map (mk_thm discI not_discI) distinctss;
46.457 + in
46.458 + map3 mk_thms discI_thms not_discI_thms distinct_thmsss' |> `transpose
46.459 + end;
46.460 +
46.461 + val disc_thms = flat (map2 (fn true => K [] | false => I) no_discs disc_thmss);
46.462 +
46.463 + val (disc_exclude_thms, (disc_exclude_thmsss', disc_exclude_thmsss)) =
46.464 + let
46.465 + fun mk_goal [] = []
46.466 + | mk_goal [((_, udisc), (_, udisc'))] =
46.467 + [Logic.all u (Logic.mk_implies (HOLogic.mk_Trueprop udisc,
46.468 + HOLogic.mk_Trueprop (HOLogic.mk_not udisc')))];
46.469 +
46.470 + fun prove tac goal = Skip_Proof.prove lthy [] [] goal (K tac);
46.471 +
46.472 + val infos = ms ~~ discD_thms ~~ udiscs;
46.473 + val half_pairss = mk_half_pairss infos;
46.474 +
46.475 + val half_goalss = map mk_goal half_pairss;
46.476 + val half_thmss =
46.477 + map3 (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] =>
46.478 + fn disc_thm => [prove (mk_half_disc_exclude_tac m discD disc_thm) goal])
46.479 + half_goalss half_pairss (flat disc_thmss');
46.480 +
46.481 + val other_half_goalss = map (mk_goal o map swap) half_pairss;
46.482 + val other_half_thmss =
46.483 + map2 (map2 (prove o mk_other_half_disc_exclude_tac)) half_thmss
46.484 + other_half_goalss;
46.485 + in
46.486 + join_halves n half_thmss other_half_thmss
46.487 + |>> has_alternate_disc_def ? K []
46.488 + end;
46.489 +
46.490 + val disc_exhaust_thm =
46.491 + let
46.492 + fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc];
46.493 + val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs));
46.494 + in
46.495 + Skip_Proof.prove lthy [] [] goal (fn _ =>
46.496 + mk_disc_exhaust_tac n exhaust_thm discI_thms)
46.497 + end;
46.498 +
46.499 + val disc_exhaust_thms =
46.500 + if has_alternate_disc_def orelse no_discs_at_all then [] else [disc_exhaust_thm];
46.501 +
46.502 + val (collapse_thms, collapse_thm_opts) =
46.503 + let
46.504 + fun mk_goal ctr udisc usels =
46.505 + let
46.506 + val prem = HOLogic.mk_Trueprop udisc;
46.507 + val concl =
46.508 + mk_Trueprop_eq ((null usels ? swap) (Term.list_comb (ctr, usels), u));
46.509 + in
46.510 + if prem aconv concl then NONE
46.511 + else SOME (Logic.all u (Logic.mk_implies (prem, concl)))
46.512 + end;
46.513 + val goals = map3 mk_goal ctrs udiscs uselss;
46.514 + in
46.515 + map4 (fn m => fn discD => fn sel_thms => Option.map (fn goal =>
46.516 + Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
46.517 + mk_collapse_tac ctxt m discD sel_thms)
46.518 + |> perhaps (try (fn thm => refl RS thm)))) ms discD_thms sel_thmss goals
46.519 + |> `(map_filter I)
46.520 + end;
46.521 +
46.522 + val expand_thms =
46.523 + let
46.524 + fun mk_prems k udisc usels vdisc vsels =
46.525 + (if k = n then [] else [mk_Trueprop_eq (udisc, vdisc)]) @
46.526 + (if null usels then
46.527 + []
46.528 + else
46.529 + [Logic.list_implies
46.530 + (if n = 1 then [] else map HOLogic.mk_Trueprop [udisc, vdisc],
46.531 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
46.532 + (map2 (curry HOLogic.mk_eq) usels vsels)))]);
46.533 +
46.534 + val uncollapse_thms =
46.535 + map (fn NONE => Drule.dummy_thm | SOME thm => thm RS sym) collapse_thm_opts;
46.536 +
46.537 + val goal =
46.538 + Library.foldr Logic.list_implies
46.539 + (map5 mk_prems ks udiscs uselss vdiscs vselss, u_eq_v);
46.540 + in
46.541 + [Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
46.542 + mk_expand_tac ctxt n ms (inst_thm u disc_exhaust_thm)
46.543 + (inst_thm v disc_exhaust_thm) uncollapse_thms disc_exclude_thmsss
46.544 + disc_exclude_thmsss')]
46.545 + |> Proof_Context.export names_lthy lthy
46.546 + end;
46.547 +
46.548 + val case_eq_thms =
46.549 + let
46.550 + fun mk_body f usels = Term.list_comb (f, usels);
46.551 + val goal = mk_Trueprop_eq (ufcase, mk_IfN B udiscs (map2 mk_body fs uselss));
46.552 + in
46.553 + [Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
46.554 + mk_case_eq_tac ctxt n uexhaust_thm case_thms disc_thmss' sel_thmss)]
46.555 + |> Proof_Context.export names_lthy lthy
46.556 + end;
46.557 + in
46.558 + (all_sel_thms, sel_thmss, disc_thmss, disc_thms, discI_thms, disc_exclude_thms,
46.559 + disc_exhaust_thms, collapse_thms, expand_thms, case_eq_thms)
46.560 + end;
46.561 +
46.562 + val (case_cong_thm, weak_case_cong_thm) =
46.563 + let
46.564 + fun mk_prem xctr xs f g =
46.565 + fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr),
46.566 + mk_Trueprop_eq (f, g)));
46.567 +
46.568 + val goal =
46.569 + Logic.list_implies (u_eq_v :: map4 mk_prem xctrs xss fs gs,
46.570 + mk_Trueprop_eq (ufcase, vgcase));
46.571 + val weak_goal = Logic.mk_implies (u_eq_v, mk_Trueprop_eq (ufcase, vfcase));
46.572 + in
46.573 + (Skip_Proof.prove lthy [] [] goal (fn _ => mk_case_cong_tac uexhaust_thm case_thms),
46.574 + Skip_Proof.prove lthy [] [] weak_goal (K (etac arg_cong 1)))
46.575 + |> pairself (singleton (Proof_Context.export names_lthy lthy))
46.576 + end;
46.577 +
46.578 + val (split_thm, split_asm_thm) =
46.579 + let
46.580 + fun mk_conjunct xctr xs f_xs =
46.581 + list_all_free xs (HOLogic.mk_imp (HOLogic.mk_eq (u, xctr), q $ f_xs));
46.582 + fun mk_disjunct xctr xs f_xs =
46.583 + list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr),
46.584 + HOLogic.mk_not (q $ f_xs)));
46.585 +
46.586 + val lhs = q $ ufcase;
46.587 +
46.588 + val goal =
46.589 + mk_Trueprop_eq (lhs, Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct xctrs xss xfs));
46.590 + val asm_goal =
46.591 + mk_Trueprop_eq (lhs, HOLogic.mk_not (Library.foldr1 HOLogic.mk_disj
46.592 + (map3 mk_disjunct xctrs xss xfs)));
46.593 +
46.594 + val split_thm =
46.595 + Skip_Proof.prove lthy [] [] goal
46.596 + (fn _ => mk_split_tac uexhaust_thm case_thms inject_thmss distinct_thmsss)
46.597 + |> singleton (Proof_Context.export names_lthy lthy)
46.598 + val split_asm_thm =
46.599 + Skip_Proof.prove lthy [] [] asm_goal (fn {context = ctxt, ...} =>
46.600 + mk_split_asm_tac ctxt split_thm)
46.601 + |> singleton (Proof_Context.export names_lthy lthy)
46.602 + in
46.603 + (split_thm, split_asm_thm)
46.604 + end;
46.605 +
46.606 + val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
46.607 + val cases_type_attr = Attrib.internal (K (Induct.cases_type dataT_name));
46.608 +
46.609 + val notes =
46.610 + [(case_congN, [case_cong_thm], []),
46.611 + (case_eqN, case_eq_thms, []),
46.612 + (casesN, case_thms, simp_attrs),
46.613 + (collapseN, collapse_thms, simp_attrs),
46.614 + (discsN, disc_thms, simp_attrs),
46.615 + (disc_excludeN, disc_exclude_thms, []),
46.616 + (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
46.617 + (distinctN, distinct_thms, simp_attrs @ induct_simp_attrs),
46.618 + (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
46.619 + (expandN, expand_thms, []),
46.620 + (injectN, inject_thms, iff_attrs @ induct_simp_attrs),
46.621 + (nchotomyN, [nchotomy_thm], []),
46.622 + (selsN, all_sel_thms, simp_attrs),
46.623 + (splitN, [split_thm], []),
46.624 + (split_asmN, [split_asm_thm], []),
46.625 + (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)]
46.626 + |> filter_out (null o #2)
46.627 + |> map (fn (thmN, thms, attrs) =>
46.628 + ((Binding.qualify true data_b_name (Binding.name thmN), attrs), [(thms, [])]));
46.629 +
46.630 + val notes' =
46.631 + [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs)]
46.632 + |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
46.633 + in
46.634 + ((discs, selss, inject_thms, distinct_thms, case_thms, disc_thmss, discI_thms, sel_thmss),
46.635 + lthy |> Local_Theory.notes (notes' @ notes) |> snd)
46.636 + end;
46.637 + in
46.638 + (goalss, after_qed, lthy')
46.639 + end;
46.640 +
46.641 +fun wrap_datatype tacss = (fn (goalss, after_qed, lthy) =>
46.642 + map2 (map2 (Skip_Proof.prove lthy [] [])) goalss tacss
46.643 + |> (fn thms => after_qed thms lthy)) oo prepare_wrap_datatype (K I);
46.644 +
46.645 +val wrap_datatype_cmd = (fn (goalss, after_qed, lthy) =>
46.646 + Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo
46.647 + prepare_wrap_datatype Syntax.read_term;
46.648 +
46.649 +fun parse_bracket_list parser = @{keyword "["} |-- Parse.list parser --| @{keyword "]"};
46.650 +
46.651 +val parse_bindings = parse_bracket_list Parse.binding;
46.652 +val parse_bindingss = parse_bracket_list parse_bindings;
46.653 +
46.654 +val parse_bound_term = (Parse.binding --| @{keyword ":"}) -- Parse.term;
46.655 +val parse_bound_terms = parse_bracket_list parse_bound_term;
46.656 +val parse_bound_termss = parse_bracket_list parse_bound_terms;
46.657 +
46.658 +val parse_wrap_options =
46.659 + Scan.optional (@{keyword "("} |-- (@{keyword "no_dests"} >> K true) --| @{keyword ")"}) false;
46.660 +
46.661 +val _ =
46.662 + Outer_Syntax.local_theory_to_proof @{command_spec "wrap_data"} "wraps an existing datatype"
46.663 + ((parse_wrap_options -- (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) --
46.664 + Parse.term -- Scan.optional (parse_bindings -- Scan.optional (parse_bindingss --
46.665 + Scan.optional parse_bound_termss []) ([], [])) ([], ([], [])))
46.666 + >> wrap_datatype_cmd);
46.667 +
46.668 +end;
47.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
47.2 +++ b/src/HOL/BNF/Tools/bnf_wrap_tactics.ML Fri Sep 21 16:45:06 2012 +0200
47.3 @@ -0,0 +1,122 @@
47.4 +(* Title: HOL/BNF/Tools/bnf_wrap_tactics.ML
47.5 + Author: Jasmin Blanchette, TU Muenchen
47.6 + Copyright 2012
47.7 +
47.8 +Tactics for wrapping datatypes.
47.9 +*)
47.10 +
47.11 +signature BNF_WRAP_TACTICS =
47.12 +sig
47.13 + val mk_alternate_disc_def_tac: Proof.context -> int -> thm -> thm -> thm -> tactic
47.14 + val mk_case_cong_tac: thm -> thm list -> tactic
47.15 + val mk_case_eq_tac: Proof.context -> int -> thm -> thm list -> thm list list -> thm list list ->
47.16 + tactic
47.17 + val mk_collapse_tac: Proof.context -> int -> thm -> thm list -> tactic
47.18 + val mk_disc_exhaust_tac: int -> thm -> thm list -> tactic
47.19 + val mk_expand_tac: Proof.context -> int -> int list -> thm -> thm -> thm list ->
47.20 + thm list list list -> thm list list list -> tactic
47.21 + val mk_half_disc_exclude_tac: int -> thm -> thm -> tactic
47.22 + val mk_nchotomy_tac: int -> thm -> tactic
47.23 + val mk_other_half_disc_exclude_tac: thm -> tactic
47.24 + val mk_split_tac: thm -> thm list -> thm list list -> thm list list list -> tactic
47.25 + val mk_split_asm_tac: Proof.context -> thm -> tactic
47.26 + val mk_unique_disc_def_tac: int -> thm -> tactic
47.27 +end;
47.28 +
47.29 +structure BNF_Wrap_Tactics : BNF_WRAP_TACTICS =
47.30 +struct
47.31 +
47.32 +open BNF_Util
47.33 +open BNF_Tactics
47.34 +
47.35 +val meta_mp = @{thm meta_mp};
47.36 +
47.37 +fun if_P_or_not_P_OF pos thm = thm RS (if pos then @{thm if_P} else @{thm if_not_P});
47.38 +
47.39 +fun mk_nchotomy_tac n exhaust =
47.40 + (rtac allI THEN' rtac exhaust THEN'
47.41 + EVERY' (maps (fn k => [rtac (mk_disjIN n k), REPEAT_DETERM o rtac exI, atac]) (1 upto n))) 1;
47.42 +
47.43 +fun mk_unique_disc_def_tac m uexhaust =
47.44 + EVERY' [rtac iffI, rtac uexhaust, REPEAT_DETERM_N m o rtac exI, atac, rtac refl] 1;
47.45 +
47.46 +fun mk_alternate_disc_def_tac ctxt k other_disc_def distinct uexhaust =
47.47 + EVERY' ([subst_tac ctxt [other_disc_def], rtac @{thm iffI_np}, REPEAT_DETERM o etac exE,
47.48 + hyp_subst_tac, SELECT_GOAL (unfold_thms_tac ctxt [not_ex]), REPEAT_DETERM o rtac allI,
47.49 + rtac distinct, rtac uexhaust] @
47.50 + (([etac notE, REPEAT_DETERM o rtac exI, atac], [REPEAT_DETERM o rtac exI, atac])
47.51 + |> k = 1 ? swap |> op @)) 1;
47.52 +
47.53 +fun mk_half_disc_exclude_tac m discD disc' =
47.54 + (dtac discD THEN' REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac THEN' rtac disc') 1;
47.55 +
47.56 +fun mk_other_half_disc_exclude_tac half = (etac @{thm contrapos_pn} THEN' etac half) 1;
47.57 +
47.58 +fun mk_disc_exhaust_tac n exhaust discIs =
47.59 + (rtac exhaust THEN'
47.60 + EVERY' (map2 (fn k => fn discI =>
47.61 + dtac discI THEN' select_prem_tac n (etac meta_mp) k THEN' atac) (1 upto n) discIs)) 1;
47.62 +
47.63 +fun mk_collapse_tac ctxt m discD sels =
47.64 + (dtac discD THEN'
47.65 + (if m = 0 then
47.66 + atac
47.67 + else
47.68 + REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac THEN'
47.69 + SELECT_GOAL (unfold_thms_tac ctxt sels) THEN' rtac refl)) 1;
47.70 +
47.71 +fun mk_expand_tac ctxt n ms udisc_exhaust vdisc_exhaust uncollapses disc_excludesss
47.72 + disc_excludesss' =
47.73 + if ms = [0] then
47.74 + rtac (@{thm trans_sym} OF (replicate 2 (the_single uncollapses RS sym))) 1
47.75 + else
47.76 + let
47.77 + val ks = 1 upto n;
47.78 + val maybe_atac = if n = 1 then K all_tac else atac;
47.79 + in
47.80 + (rtac udisc_exhaust THEN'
47.81 + EVERY' (map5 (fn k => fn m => fn disc_excludess => fn disc_excludess' => fn uuncollapse =>
47.82 + EVERY' [if m = 0 then K all_tac else subst_tac ctxt [uuncollapse] THEN' maybe_atac,
47.83 + rtac sym, rtac vdisc_exhaust,
47.84 + EVERY' (map4 (fn k' => fn disc_excludes => fn disc_excludes' => fn vuncollapse =>
47.85 + EVERY'
47.86 + (if k' = k then
47.87 + if m = 0 then
47.88 + [hyp_subst_tac, rtac refl]
47.89 + else
47.90 + [subst_tac ctxt [vuncollapse], maybe_atac,
47.91 + if n = 1 then K all_tac else EVERY' [dtac meta_mp, atac, dtac meta_mp, atac],
47.92 + REPEAT_DETERM_N (Int.max (0, m - 1)) o etac conjE, asm_simp_tac (ss_only [])]
47.93 + else
47.94 + [dtac (the_single (if k = n then disc_excludes else disc_excludes')),
47.95 + etac (if k = n then @{thm iff_contradict(1)} else @{thm iff_contradict(2)}),
47.96 + atac, atac]))
47.97 + ks disc_excludess disc_excludess' uncollapses)])
47.98 + ks ms disc_excludesss disc_excludesss' uncollapses)) 1
47.99 + end;
47.100 +
47.101 +fun mk_case_eq_tac ctxt n uexhaust cases discss' selss =
47.102 + (rtac uexhaust THEN'
47.103 + EVERY' (map3 (fn casex => fn if_discs => fn sels =>
47.104 + EVERY' [hyp_subst_tac, SELECT_GOAL (unfold_thms_tac ctxt (if_discs @ sels)), rtac casex])
47.105 + cases (map2 (seq_conds if_P_or_not_P_OF n) (1 upto n) discss') selss)) 1;
47.106 +
47.107 +fun mk_case_cong_tac uexhaust cases =
47.108 + (rtac uexhaust THEN'
47.109 + EVERY' (maps (fn casex => [dtac sym, asm_simp_tac (ss_only [casex])]) cases)) 1;
47.110 +
47.111 +val naked_ctxt = Proof_Context.init_global @{theory HOL};
47.112 +
47.113 +fun mk_split_tac uexhaust cases injectss distinctsss =
47.114 + rtac uexhaust 1 THEN
47.115 + ALLGOALS (fn k => (hyp_subst_tac THEN'
47.116 + simp_tac (ss_only (@{thms simp_thms} @ cases @ nth injectss (k - 1) @
47.117 + flat (nth distinctsss (k - 1))))) k) THEN
47.118 + ALLGOALS (blast_tac naked_ctxt);
47.119 +
47.120 +val split_asm_thms = @{thms imp_conv_disj de_Morgan_conj de_Morgan_disj not_not not_ex};
47.121 +
47.122 +fun mk_split_asm_tac ctxt split =
47.123 + rtac (split RS trans) 1 THEN unfold_thms_tac ctxt split_asm_thms THEN rtac refl 1;
47.124 +
47.125 +end;
48.1 --- a/src/HOL/Codatatype/BNF.thy Fri Sep 21 16:34:40 2012 +0200
48.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
48.3 @@ -1,16 +0,0 @@
48.4 -(* Title: HOL/BNF/BNF.thy
48.5 - Author: Dmitriy Traytel, TU Muenchen
48.6 - Author: Andrei Popescu, TU Muenchen
48.7 - Author: Jasmin Blanchette, TU Muenchen
48.8 - Copyright 2012
48.9 -
48.10 -Bounded natural functors for (co)datatypes.
48.11 -*)
48.12 -
48.13 -header {* Bounded Natural Functors for (Co)datatypes *}
48.14 -
48.15 -theory BNF
48.16 -imports More_BNFs
48.17 -begin
48.18 -
48.19 -end
49.1 --- a/src/HOL/Codatatype/BNF_Comp.thy Fri Sep 21 16:34:40 2012 +0200
49.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
49.3 @@ -1,91 +0,0 @@
49.4 -(* Title: HOL/BNF/BNF_Comp.thy
49.5 - Author: Dmitriy Traytel, TU Muenchen
49.6 - Copyright 2012
49.7 -
49.8 -Composition of bounded natural functors.
49.9 -*)
49.10 -
49.11 -header {* Composition of Bounded Natural Functors *}
49.12 -
49.13 -theory BNF_Comp
49.14 -imports Basic_BNFs
49.15 -begin
49.16 -
49.17 -lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
49.18 -by (rule ext) simp
49.19 -
49.20 -lemma Union_natural: "Union o image (image f) = image f o Union"
49.21 -by (rule ext) (auto simp only: o_apply)
49.22 -
49.23 -lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
49.24 -by (unfold o_assoc)
49.25 -
49.26 -lemma comp_single_set_bd:
49.27 - assumes fbd_Card_order: "Card_order fbd" and
49.28 - fset_bd: "\<And>x. |fset x| \<le>o fbd" and
49.29 - gset_bd: "\<And>x. |gset x| \<le>o gbd"
49.30 - shows "|\<Union>fset ` gset x| \<le>o gbd *c fbd"
49.31 -apply (subst sym[OF SUP_def])
49.32 -apply (rule ordLeq_transitive)
49.33 -apply (rule card_of_UNION_Sigma)
49.34 -apply (subst SIGMA_CSUM)
49.35 -apply (rule ordLeq_transitive)
49.36 -apply (rule card_of_Csum_Times')
49.37 -apply (rule fbd_Card_order)
49.38 -apply (rule ballI)
49.39 -apply (rule fset_bd)
49.40 -apply (rule ordLeq_transitive)
49.41 -apply (rule cprod_mono1)
49.42 -apply (rule gset_bd)
49.43 -apply (rule ordIso_imp_ordLeq)
49.44 -apply (rule ordIso_refl)
49.45 -apply (rule Card_order_cprod)
49.46 -done
49.47 -
49.48 -lemma Union_image_insert: "\<Union>f ` insert a B = f a \<union> \<Union>f ` B"
49.49 -by simp
49.50 -
49.51 -lemma Union_image_empty: "A \<union> \<Union>f ` {} = A"
49.52 -by simp
49.53 -
49.54 -lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
49.55 -by (rule ext) (auto simp add: collect_def)
49.56 -
49.57 -lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
49.58 -by blast
49.59 -
49.60 -lemma UN_image_subset: "\<Union>f ` g x \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
49.61 -by blast
49.62 -
49.63 -lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>(\<lambda>f. f x) ` X| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
49.64 -by (unfold o_apply collect_def SUP_def)
49.65 -
49.66 -lemma wpull_cong:
49.67 -"\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
49.68 -by simp
49.69 -
49.70 -lemma Id_def': "Id = {(a,b). a = b}"
49.71 -by auto
49.72 -
49.73 -lemma Gr_fst_snd: "(Gr R fst)^-1 O Gr R snd = R"
49.74 -unfolding Gr_def by auto
49.75 -
49.76 -lemma subst_rel_def: "A = B \<Longrightarrow> (Gr A f)^-1 O Gr A g = (Gr B f)^-1 O Gr B g"
49.77 -by simp
49.78 -
49.79 -lemma abs_pred_def: "\<lbrakk>\<And>x y. (x, y) \<in> rel = pred x y\<rbrakk> \<Longrightarrow> rel = Collect (split pred)"
49.80 -by auto
49.81 -
49.82 -lemma Collect_split_cong: "Collect (split pred) = Collect (split pred') \<Longrightarrow> pred = pred'"
49.83 -by blast
49.84 -
49.85 -lemma pred_def_abs: "rel = Collect (split pred) \<Longrightarrow> pred = (\<lambda>x y. (x, y) \<in> rel)"
49.86 -by auto
49.87 -
49.88 -lemma mem_Id_eq_eq: "(\<lambda>x y. (x, y) \<in> Id) = (op =)"
49.89 -by simp
49.90 -
49.91 -ML_file "Tools/bnf_comp_tactics.ML"
49.92 -ML_file "Tools/bnf_comp.ML"
49.93 -
49.94 -end
50.1 --- a/src/HOL/Codatatype/BNF_Def.thy Fri Sep 21 16:34:40 2012 +0200
50.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
50.3 @@ -1,151 +0,0 @@
50.4 -(* Title: HOL/BNF/BNF_Def.thy
50.5 - Author: Dmitriy Traytel, TU Muenchen
50.6 - Copyright 2012
50.7 -
50.8 -Definition of bounded natural functors.
50.9 -*)
50.10 -
50.11 -header {* Definition of Bounded Natural Functors *}
50.12 -
50.13 -theory BNF_Def
50.14 -imports BNF_Util
50.15 -keywords
50.16 - "print_bnfs" :: diag and
50.17 - "bnf_def" :: thy_goal
50.18 -begin
50.19 -
50.20 -lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
50.21 -by (rule ext) (auto simp only: o_apply collect_def)
50.22 -
50.23 -lemma converse_mono:
50.24 -"R1 ^-1 \<subseteq> R2 ^-1 \<longleftrightarrow> R1 \<subseteq> R2"
50.25 -unfolding converse_def by auto
50.26 -
50.27 -lemma converse_shift:
50.28 -"R1 \<subseteq> R2 ^-1 \<Longrightarrow> R1 ^-1 \<subseteq> R2"
50.29 -unfolding converse_def by auto
50.30 -
50.31 -definition convol ("<_ , _>") where
50.32 -"<f , g> \<equiv> %a. (f a, g a)"
50.33 -
50.34 -lemma fst_convol:
50.35 -"fst o <f , g> = f"
50.36 -apply(rule ext)
50.37 -unfolding convol_def by simp
50.38 -
50.39 -lemma snd_convol:
50.40 -"snd o <f , g> = g"
50.41 -apply(rule ext)
50.42 -unfolding convol_def by simp
50.43 -
50.44 -lemma convol_memI:
50.45 -"\<lbrakk>f x = f' x; g x = g' x; P x\<rbrakk> \<Longrightarrow> <f , g> x \<in> {(f' a, g' a) |a. P a}"
50.46 -unfolding convol_def by auto
50.47 -
50.48 -definition csquare where
50.49 -"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
50.50 -
50.51 -(* The pullback of sets *)
50.52 -definition thePull where
50.53 -"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
50.54 -
50.55 -lemma wpull_thePull:
50.56 -"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
50.57 -unfolding wpull_def thePull_def by auto
50.58 -
50.59 -lemma wppull_thePull:
50.60 -assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
50.61 -shows
50.62 -"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
50.63 - j a' \<in> A \<and>
50.64 - e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
50.65 -(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
50.66 -proof(rule bchoice[of ?A' ?phi], default)
50.67 - fix a' assume a': "a' \<in> ?A'"
50.68 - hence "fst a' \<in> B1" unfolding thePull_def by auto
50.69 - moreover
50.70 - from a' have "snd a' \<in> B2" unfolding thePull_def by auto
50.71 - moreover have "f1 (fst a') = f2 (snd a')"
50.72 - using a' unfolding csquare_def thePull_def by auto
50.73 - ultimately show "\<exists> ja'. ?phi a' ja'"
50.74 - using assms unfolding wppull_def by blast
50.75 -qed
50.76 -
50.77 -lemma wpull_wppull:
50.78 -assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
50.79 -1: "\<forall> a' \<in> A'. j a' \<in> A \<and> e1 (p1 (j a')) = e1 (p1' a') \<and> e2 (p2 (j a')) = e2 (p2' a')"
50.80 -shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
50.81 -unfolding wppull_def proof safe
50.82 - fix b1 b2
50.83 - assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
50.84 - then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
50.85 - using wp unfolding wpull_def by blast
50.86 - show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
50.87 - apply (rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
50.88 -qed
50.89 -
50.90 -lemma wppull_id: "\<lbrakk>wpull UNIV UNIV UNIV f1 f2 p1 p2; e1 = id; e2 = id\<rbrakk> \<Longrightarrow>
50.91 - wppull UNIV UNIV UNIV f1 f2 e1 e2 p1 p2"
50.92 -by (erule wpull_wppull) auto
50.93 -
50.94 -lemma Id_alt: "Id = Gr UNIV id"
50.95 -unfolding Gr_def by auto
50.96 -
50.97 -lemma Gr_UNIV_id: "f = id \<Longrightarrow> (Gr UNIV f)^-1 O Gr UNIV f = Gr UNIV f"
50.98 -unfolding Gr_def by auto
50.99 -
50.100 -lemma Gr_mono: "A \<subseteq> B \<Longrightarrow> Gr A f \<subseteq> Gr B f"
50.101 -unfolding Gr_def by auto
50.102 -
50.103 -lemma wpull_Gr:
50.104 -"wpull (Gr A f) A (f ` A) f id fst snd"
50.105 -unfolding wpull_def Gr_def by auto
50.106 -
50.107 -definition "pick_middle P Q a c = (SOME b. (a,b) \<in> P \<and> (b,c) \<in> Q)"
50.108 -
50.109 -lemma pick_middle:
50.110 -"(a,c) \<in> P O Q \<Longrightarrow> (a, pick_middle P Q a c) \<in> P \<and> (pick_middle P Q a c, c) \<in> Q"
50.111 -unfolding pick_middle_def apply(rule someI_ex)
50.112 -using assms unfolding relcomp_def by auto
50.113 -
50.114 -definition fstO where "fstO P Q ac = (fst ac, pick_middle P Q (fst ac) (snd ac))"
50.115 -definition sndO where "sndO P Q ac = (pick_middle P Q (fst ac) (snd ac), snd ac)"
50.116 -
50.117 -lemma fstO_in: "ac \<in> P O Q \<Longrightarrow> fstO P Q ac \<in> P"
50.118 -unfolding fstO_def
50.119 -by (subst (asm) surjective_pairing) (rule pick_middle[THEN conjunct1])
50.120 -
50.121 -lemma fst_fstO: "fst bc = (fst \<circ> fstO P Q) bc"
50.122 -unfolding comp_def fstO_def by simp
50.123 -
50.124 -lemma snd_sndO: "snd bc = (snd \<circ> sndO P Q) bc"
50.125 -unfolding comp_def sndO_def by simp
50.126 -
50.127 -lemma sndO_in: "ac \<in> P O Q \<Longrightarrow> sndO P Q ac \<in> Q"
50.128 -unfolding sndO_def
50.129 -by (subst (asm) surjective_pairing) (rule pick_middle[THEN conjunct2])
50.130 -
50.131 -lemma csquare_fstO_sndO:
50.132 -"csquare (P O Q) snd fst (fstO P Q) (sndO P Q)"
50.133 -unfolding csquare_def fstO_def sndO_def using pick_middle by simp
50.134 -
50.135 -lemma wppull_fstO_sndO:
50.136 -shows "wppull (P O Q) P Q snd fst fst snd (fstO P Q) (sndO P Q)"
50.137 -using pick_middle unfolding wppull_def fstO_def sndO_def relcomp_def by auto
50.138 -
50.139 -lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
50.140 -by (simp split: prod.split)
50.141 -
50.142 -lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
50.143 -by (simp split: prod.split)
50.144 -
50.145 -lemma flip_rel: "A \<subseteq> (R ^-1) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> R"
50.146 -by auto
50.147 -
50.148 -lemma pointfreeE: "f o g = f' o g' \<Longrightarrow> f (g x) = f' (g' x)"
50.149 -unfolding o_def fun_eq_iff by simp
50.150 -
50.151 -ML_file "Tools/bnf_def_tactics.ML"
50.152 -ML_file"Tools/bnf_def.ML"
50.153 -
50.154 -end
51.1 --- a/src/HOL/Codatatype/BNF_FP.thy Fri Sep 21 16:34:40 2012 +0200
51.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
51.3 @@ -1,113 +0,0 @@
51.4 -(* Title: HOL/BNF/BNF_FP.thy
51.5 - Author: Dmitriy Traytel, TU Muenchen
51.6 - Author: Jasmin Blanchette, TU Muenchen
51.7 - Copyright 2012
51.8 -
51.9 -Composition of bounded natural functors.
51.10 -*)
51.11 -
51.12 -header {* Composition of Bounded Natural Functors *}
51.13 -
51.14 -theory BNF_FP
51.15 -imports BNF_Comp BNF_Wrap
51.16 -keywords
51.17 - "defaults"
51.18 -begin
51.19 -
51.20 -lemma case_unit: "(case u of () => f) = f"
51.21 -by (cases u) (hypsubst, rule unit.cases)
51.22 -
51.23 -lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
51.24 -by simp
51.25 -
51.26 -lemma prod_all_impI: "(\<And>x y. P (x, y) \<Longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
51.27 -by clarify
51.28 -
51.29 -lemma prod_all_impI_step: "(\<And>x. \<forall>y. P (x, y) \<longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
51.30 -by auto
51.31 -
51.32 -lemma all_unit_eq: "(\<And>x. PROP P x) \<equiv> PROP P ()"
51.33 -by simp
51.34 -
51.35 -lemma all_prod_eq: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))"
51.36 -by clarsimp
51.37 -
51.38 -lemma rev_bspec: "a \<in> A \<Longrightarrow> \<forall>z \<in> A. P z \<Longrightarrow> P a"
51.39 -by simp
51.40 -
51.41 -lemma Un_cong: "\<lbrakk>A = B; C = D\<rbrakk> \<Longrightarrow> A \<union> C = B \<union> D"
51.42 -by simp
51.43 -
51.44 -lemma pointfree_idE: "f o g = id \<Longrightarrow> f (g x) = x"
51.45 -unfolding o_def fun_eq_iff by simp
51.46 -
51.47 -lemma o_bij:
51.48 - assumes gf: "g o f = id" and fg: "f o g = id"
51.49 - shows "bij f"
51.50 -unfolding bij_def inj_on_def surj_def proof safe
51.51 - fix a1 a2 assume "f a1 = f a2"
51.52 - hence "g ( f a1) = g (f a2)" by simp
51.53 - thus "a1 = a2" using gf unfolding fun_eq_iff by simp
51.54 -next
51.55 - fix b
51.56 - have "b = f (g b)"
51.57 - using fg unfolding fun_eq_iff by simp
51.58 - thus "EX a. b = f a" by blast
51.59 -qed
51.60 -
51.61 -lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
51.62 -
51.63 -lemma sum_case_step:
51.64 - "sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
51.65 - "sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
51.66 -by auto
51.67 -
51.68 -lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
51.69 -by simp
51.70 -
51.71 -lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
51.72 -by blast
51.73 -
51.74 -lemma obj_sumE_f':
51.75 -"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> s = f x \<longrightarrow> P"
51.76 -by (cases x) blast+
51.77 -
51.78 -lemma obj_sumE_f:
51.79 -"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f x \<longrightarrow> P"
51.80 -by (rule allI) (rule obj_sumE_f')
51.81 -
51.82 -lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
51.83 -by (cases s) auto
51.84 -
51.85 -lemma obj_sum_step':
51.86 -"\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> s = f (Inr x) \<longrightarrow> P"
51.87 -by (cases x) blast+
51.88 -
51.89 -lemma obj_sum_step:
51.90 -"\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f (Inr x) \<longrightarrow> P"
51.91 -by (rule allI) (rule obj_sum_step')
51.92 -
51.93 -lemma sum_case_if:
51.94 -"sum_case f g (if p then Inl x else Inr y) = (if p then f x else g y)"
51.95 -by simp
51.96 -
51.97 -lemma mem_UN_compreh_eq: "(z : \<Union>{y. \<exists>x\<in>A. y = F x}) = (\<exists>x\<in>A. z : F x)"
51.98 -by blast
51.99 -
51.100 -lemma prod_set_simps:
51.101 -"fsts (x, y) = {x}"
51.102 -"snds (x, y) = {y}"
51.103 -unfolding fsts_def snds_def by simp+
51.104 -
51.105 -lemma sum_set_simps:
51.106 -"setl (Inl x) = {x}"
51.107 -"setl (Inr x) = {}"
51.108 -"setr (Inl x) = {}"
51.109 -"setr (Inr x) = {x}"
51.110 -unfolding sum_set_defs by simp+
51.111 -
51.112 -ML_file "Tools/bnf_fp.ML"
51.113 -ML_file "Tools/bnf_fp_sugar_tactics.ML"
51.114 -ML_file "Tools/bnf_fp_sugar.ML"
51.115 -
51.116 -end
52.1 --- a/src/HOL/Codatatype/BNF_GFP.thy Fri Sep 21 16:34:40 2012 +0200
52.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
52.3 @@ -1,331 +0,0 @@
52.4 -(* Title: HOL/BNF/BNF_GFP.thy
52.5 - Author: Dmitriy Traytel, TU Muenchen
52.6 - Copyright 2012
52.7 -
52.8 -Greatest fixed point operation on bounded natural functors.
52.9 -*)
52.10 -
52.11 -header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
52.12 -
52.13 -theory BNF_GFP
52.14 -imports BNF_FP Equiv_Relations_More "~~/src/HOL/Library/Prefix_Order"
52.15 -keywords
52.16 - "codata_raw" :: thy_decl and
52.17 - "codata" :: thy_decl
52.18 -begin
52.19 -
52.20 -lemma sum_case_comp_Inl:
52.21 -"sum_case f g \<circ> Inl = f"
52.22 -unfolding comp_def by simp
52.23 -
52.24 -lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
52.25 -by (auto split: sum.splits)
52.26 -
52.27 -lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
52.28 -by auto
52.29 -
52.30 -lemma equiv_triv1:
52.31 -assumes "equiv A R" and "(a, b) \<in> R" and "(a, c) \<in> R"
52.32 -shows "(b, c) \<in> R"
52.33 -using assms unfolding equiv_def sym_def trans_def by blast
52.34 -
52.35 -lemma equiv_triv2:
52.36 -assumes "equiv A R" and "(a, b) \<in> R" and "(b, c) \<in> R"
52.37 -shows "(a, c) \<in> R"
52.38 -using assms unfolding equiv_def trans_def by blast
52.39 -
52.40 -lemma equiv_proj:
52.41 - assumes e: "equiv A R" and "z \<in> R"
52.42 - shows "(proj R o fst) z = (proj R o snd) z"
52.43 -proof -
52.44 - from assms(2) have z: "(fst z, snd z) \<in> R" by auto
52.45 - have P: "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" by (erule equiv_triv1[OF e z])
52.46 - have "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R" by (erule equiv_triv2[OF e z])
52.47 - with P show ?thesis unfolding proj_def[abs_def] by auto
52.48 -qed
52.49 -
52.50 -(* Operators: *)
52.51 -definition diag where "diag A \<equiv> {(a,a) | a. a \<in> A}"
52.52 -definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
52.53 -
52.54 -lemma diagI: "x \<in> A \<Longrightarrow> (x, x) \<in> diag A"
52.55 -unfolding diag_def by simp
52.56 -
52.57 -lemma diagE: "(a, b) \<in> diag A \<Longrightarrow> a = b"
52.58 -unfolding diag_def by simp
52.59 -
52.60 -lemma diagE': "x \<in> diag A \<Longrightarrow> fst x = snd x"
52.61 -unfolding diag_def by auto
52.62 -
52.63 -lemma diag_fst: "x \<in> diag A \<Longrightarrow> fst x \<in> A"
52.64 -unfolding diag_def by auto
52.65 -
52.66 -lemma diag_UNIV: "diag UNIV = Id"
52.67 -unfolding diag_def by auto
52.68 -
52.69 -lemma diag_converse: "diag A = (diag A) ^-1"
52.70 -unfolding diag_def by auto
52.71 -
52.72 -lemma diag_Comp: "diag A = diag A O diag A"
52.73 -unfolding diag_def by auto
52.74 -
52.75 -lemma diag_Gr: "diag A = Gr A id"
52.76 -unfolding diag_def Gr_def by simp
52.77 -
52.78 -lemma diag_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> diag UNIV"
52.79 -unfolding diag_def by auto
52.80 -
52.81 -lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
52.82 -unfolding image2_def by auto
52.83 -
52.84 -lemma Id_subset: "Id \<subseteq> {(a, b). P a b \<or> a = b}"
52.85 -by auto
52.86 -
52.87 -lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
52.88 -by auto
52.89 -
52.90 -lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
52.91 -unfolding image2_def Gr_def by auto
52.92 -
52.93 -lemma GrI: "\<lbrakk>x \<in> A; f x = fx\<rbrakk> \<Longrightarrow> (x, fx) \<in> Gr A f"
52.94 -unfolding Gr_def by simp
52.95 -
52.96 -lemma GrE: "(x, fx) \<in> Gr A f \<Longrightarrow> (x \<in> A \<Longrightarrow> f x = fx \<Longrightarrow> P) \<Longrightarrow> P"
52.97 -unfolding Gr_def by simp
52.98 -
52.99 -lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
52.100 -unfolding Gr_def by simp
52.101 -
52.102 -lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
52.103 -unfolding Gr_def by simp
52.104 -
52.105 -lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
52.106 -unfolding Gr_def by auto
52.107 -
52.108 -definition relImage where
52.109 -"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
52.110 -
52.111 -definition relInvImage where
52.112 -"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
52.113 -
52.114 -lemma relImage_Gr:
52.115 -"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
52.116 -unfolding relImage_def Gr_def relcomp_def by auto
52.117 -
52.118 -lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
52.119 -unfolding Gr_def relcomp_def image_def relInvImage_def by auto
52.120 -
52.121 -lemma relImage_mono:
52.122 -"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
52.123 -unfolding relImage_def by auto
52.124 -
52.125 -lemma relInvImage_mono:
52.126 -"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
52.127 -unfolding relInvImage_def by auto
52.128 -
52.129 -lemma relInvImage_diag:
52.130 -"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (diag B) f \<subseteq> Id"
52.131 -unfolding relInvImage_def diag_def by auto
52.132 -
52.133 -lemma relInvImage_UNIV_relImage:
52.134 -"R \<subseteq> relInvImage UNIV (relImage R f) f"
52.135 -unfolding relInvImage_def relImage_def by auto
52.136 -
52.137 -lemma equiv_Image: "equiv A R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> a \<in> A \<and> b \<in> A \<and> R `` {a} = R `` {b})"
52.138 -unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
52.139 -
52.140 -lemma relImage_proj:
52.141 -assumes "equiv A R"
52.142 -shows "relImage R (proj R) \<subseteq> diag (A//R)"
52.143 -unfolding relImage_def diag_def apply safe
52.144 -using proj_iff[OF assms]
52.145 -by (metis assms equiv_Image proj_def proj_preserves)
52.146 -
52.147 -lemma relImage_relInvImage:
52.148 -assumes "R \<subseteq> f ` A <*> f ` A"
52.149 -shows "relImage (relInvImage A R f) f = R"
52.150 -using assms unfolding relImage_def relInvImage_def by fastforce
52.151 -
52.152 -lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
52.153 -by simp
52.154 -
52.155 -lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
52.156 -by simp
52.157 -
52.158 -lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
52.159 -by simp
52.160 -
52.161 -lemma Collect_restrict': "{(x, y) | x y. phi x y \<and> P x y} \<subseteq> {(x, y) | x y. phi x y}"
52.162 -by auto
52.163 -
52.164 -lemma image_convolD: "\<lbrakk>(a, b) \<in> <f, g> ` X\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> X \<and> a = f x \<and> b = g x"
52.165 -unfolding convol_def by auto
52.166 -
52.167 -(*Extended Sublist*)
52.168 -
52.169 -definition prefCl where
52.170 - "prefCl Kl = (\<forall> kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
52.171 -definition PrefCl where
52.172 - "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> kl' \<le> kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
52.173 -
52.174 -lemma prefCl_UN:
52.175 - "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
52.176 -unfolding prefCl_def PrefCl_def by fastforce
52.177 -
52.178 -definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
52.179 -definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
52.180 -definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
52.181 -
52.182 -lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
52.183 -unfolding Shift_def Succ_def by simp
52.184 -
52.185 -lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
52.186 -unfolding Shift_def clists_def Field_card_of by auto
52.187 -
52.188 -lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
52.189 -unfolding prefCl_def Shift_def
52.190 -proof safe
52.191 - fix kl1 kl2
52.192 - assume "\<forall>kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
52.193 - "kl1 \<le> kl2" "k # kl2 \<in> Kl"
52.194 - thus "k # kl1 \<in> Kl" using Cons_prefix_Cons[of k kl1 k kl2] by blast
52.195 -qed
52.196 -
52.197 -lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
52.198 -unfolding Shift_def by simp
52.199 -
52.200 -lemma prefCl_Succ: "\<lbrakk>prefCl Kl; k # kl \<in> Kl\<rbrakk> \<Longrightarrow> k \<in> Succ Kl []"
52.201 -unfolding Succ_def proof
52.202 - assume "prefCl Kl" "k # kl \<in> Kl"
52.203 - moreover have "k # [] \<le> k # kl" by auto
52.204 - ultimately have "k # [] \<in> Kl" unfolding prefCl_def by blast
52.205 - thus "[] @ [k] \<in> Kl" by simp
52.206 -qed
52.207 -
52.208 -lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
52.209 -unfolding Succ_def by simp
52.210 -
52.211 -lemmas SuccE = SuccD[elim_format]
52.212 -
52.213 -lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
52.214 -unfolding Succ_def by simp
52.215 -
52.216 -lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
52.217 -unfolding Shift_def by simp
52.218 -
52.219 -lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
52.220 -unfolding Succ_def Shift_def by auto
52.221 -
52.222 -lemma ShiftI: "k # kl \<in> Kl \<Longrightarrow> kl \<in> Shift Kl k"
52.223 -unfolding Shift_def by simp
52.224 -
52.225 -lemma Func_cexp: "|Func A B| =o |B| ^c |A|"
52.226 -unfolding cexp_def Field_card_of by (simp only: card_of_refl)
52.227 -
52.228 -lemma clists_bound: "A \<in> Field (cpow (clists r)) - {{}} \<Longrightarrow> |A| \<le>o clists r"
52.229 -unfolding cpow_def clists_def Field_card_of by (auto simp: card_of_mono1)
52.230 -
52.231 -lemma cpow_clists_czero: "\<lbrakk>A \<in> Field (cpow (clists r)) - {{}}; |A| =o czero\<rbrakk> \<Longrightarrow> False"
52.232 -unfolding cpow_def clists_def
52.233 -by (auto simp add: card_of_ordIso_czero_iff_empty[symmetric])
52.234 - (erule notE, erule ordIso_transitive, rule czero_ordIso)
52.235 -
52.236 -lemma incl_UNION_I:
52.237 -assumes "i \<in> I" and "A \<subseteq> F i"
52.238 -shows "A \<subseteq> UNION I F"
52.239 -using assms by auto
52.240 -
52.241 -lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
52.242 -unfolding clists_def Field_card_of by auto
52.243 -
52.244 -lemma Cons_clists:
52.245 - "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
52.246 -unfolding clists_def Field_card_of by auto
52.247 -
52.248 -lemma length_Cons: "length (x # xs) = Suc (length xs)"
52.249 -by simp
52.250 -
52.251 -lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
52.252 -by simp
52.253 -
52.254 -(*injection into the field of a cardinal*)
52.255 -definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
52.256 -definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
52.257 -
52.258 -lemma ex_toCard_pred:
52.259 -"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
52.260 -unfolding toCard_pred_def
52.261 -using card_of_ordLeq[of A "Field r"]
52.262 - ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
52.263 -by blast
52.264 -
52.265 -lemma toCard_pred_toCard:
52.266 - "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
52.267 -unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
52.268 -
52.269 -lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
52.270 - toCard A r x = toCard A r y \<longleftrightarrow> x = y"
52.271 -using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
52.272 -
52.273 -lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
52.274 -using toCard_pred_toCard unfolding toCard_pred_def by blast
52.275 -
52.276 -definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
52.277 -
52.278 -lemma fromCard_toCard:
52.279 -"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
52.280 -unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
52.281 -
52.282 -(* pick according to the weak pullback *)
52.283 -definition pickWP_pred where
52.284 -"pickWP_pred A p1 p2 b1 b2 a \<equiv> a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
52.285 -
52.286 -definition pickWP where
52.287 -"pickWP A p1 p2 b1 b2 \<equiv> SOME a. pickWP_pred A p1 p2 b1 b2 a"
52.288 -
52.289 -lemma pickWP_pred:
52.290 -assumes "wpull A B1 B2 f1 f2 p1 p2" and
52.291 -"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
52.292 -shows "\<exists> a. pickWP_pred A p1 p2 b1 b2 a"
52.293 -using assms unfolding wpull_def pickWP_pred_def by blast
52.294 -
52.295 -lemma pickWP_pred_pickWP:
52.296 -assumes "wpull A B1 B2 f1 f2 p1 p2" and
52.297 -"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
52.298 -shows "pickWP_pred A p1 p2 b1 b2 (pickWP A p1 p2 b1 b2)"
52.299 -unfolding pickWP_def using assms by(rule someI_ex[OF pickWP_pred])
52.300 -
52.301 -lemma pickWP:
52.302 -assumes "wpull A B1 B2 f1 f2 p1 p2" and
52.303 -"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
52.304 -shows "pickWP A p1 p2 b1 b2 \<in> A"
52.305 - "p1 (pickWP A p1 p2 b1 b2) = b1"
52.306 - "p2 (pickWP A p1 p2 b1 b2) = b2"
52.307 -using assms pickWP_pred_pickWP unfolding pickWP_pred_def by fastforce+
52.308 -
52.309 -lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
52.310 -unfolding Field_card_of csum_def by auto
52.311 -
52.312 -lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
52.313 -unfolding Field_card_of csum_def by auto
52.314 -
52.315 -lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
52.316 -by auto
52.317 -
52.318 -lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
52.319 -by auto
52.320 -
52.321 -lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
52.322 -by auto
52.323 -
52.324 -lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
52.325 -by auto
52.326 -
52.327 -lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
52.328 -by simp
52.329 -
52.330 -ML_file "Tools/bnf_gfp_util.ML"
52.331 -ML_file "Tools/bnf_gfp_tactics.ML"
52.332 -ML_file "Tools/bnf_gfp.ML"
52.333 -
52.334 -end
53.1 --- a/src/HOL/Codatatype/BNF_LFP.thy Fri Sep 21 16:34:40 2012 +0200
53.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
53.3 @@ -1,228 +0,0 @@
53.4 -(* Title: HOL/BNF/BNF_LFP.thy
53.5 - Author: Dmitriy Traytel, TU Muenchen
53.6 - Copyright 2012
53.7 -
53.8 -Least fixed point operation on bounded natural functors.
53.9 -*)
53.10 -
53.11 -header {* Least Fixed Point Operation on Bounded Natural Functors *}
53.12 -
53.13 -theory BNF_LFP
53.14 -imports BNF_FP
53.15 -keywords
53.16 - "data_raw" :: thy_decl and
53.17 - "data" :: thy_decl
53.18 -begin
53.19 -
53.20 -lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
53.21 -by blast
53.22 -
53.23 -lemma image_Collect_subsetI:
53.24 - "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
53.25 -by blast
53.26 -
53.27 -lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
53.28 -by auto
53.29 -
53.30 -lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
53.31 -by auto
53.32 -
53.33 -lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> rel.underS R j"
53.34 -unfolding rel.underS_def by simp
53.35 -
53.36 -lemma underS_E: "i \<in> rel.underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
53.37 -unfolding rel.underS_def by simp
53.38 -
53.39 -lemma underS_Field: "i \<in> rel.underS R j \<Longrightarrow> i \<in> Field R"
53.40 -unfolding rel.underS_def Field_def by auto
53.41 -
53.42 -lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
53.43 -unfolding Field_def by auto
53.44 -
53.45 -lemma fst_convol': "fst (<f, g> x) = f x"
53.46 -using fst_convol unfolding convol_def by simp
53.47 -
53.48 -lemma snd_convol': "snd (<f, g> x) = g x"
53.49 -using snd_convol unfolding convol_def by simp
53.50 -
53.51 -lemma convol_expand_snd: "fst o f = g \<Longrightarrow> <g, snd o f> = f"
53.52 -unfolding convol_def by auto
53.53 -
53.54 -definition inver where
53.55 - "inver g f A = (ALL a : A. g (f a) = a)"
53.56 -
53.57 -lemma bij_betw_iff_ex:
53.58 - "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
53.59 -proof (rule iffI)
53.60 - assume ?L
53.61 - hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
53.62 - let ?phi = "% b a. a : A \<and> f a = b"
53.63 - have "ALL b : B. EX a. ?phi b a" using f by blast
53.64 - then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
53.65 - using bchoice[of B ?phi] by blast
53.66 - hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
53.67 - have gf: "inver g f A" unfolding inver_def
53.68 - by (metis (no_types) gg imageI[of _ A f] the_inv_into_f_f[OF inj_f])
53.69 - moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
53.70 - moreover have "A \<le> g ` B"
53.71 - proof safe
53.72 - fix a assume a: "a : A"
53.73 - hence "f a : B" using f by auto
53.74 - moreover have "a = g (f a)" using a gf unfolding inver_def by auto
53.75 - ultimately show "a : g ` B" by blast
53.76 - qed
53.77 - ultimately show ?R by blast
53.78 -next
53.79 - assume ?R
53.80 - then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
53.81 - show ?L unfolding bij_betw_def
53.82 - proof safe
53.83 - show "inj_on f A" unfolding inj_on_def
53.84 - proof safe
53.85 - fix a1 a2 assume a: "a1 : A" "a2 : A" and "f a1 = f a2"
53.86 - hence "g (f a1) = g (f a2)" by simp
53.87 - thus "a1 = a2" using a g unfolding inver_def by simp
53.88 - qed
53.89 - next
53.90 - fix a assume "a : A"
53.91 - then obtain b where b: "b : B" and a: "a = g b" using g by blast
53.92 - hence "b = f (g b)" using g unfolding inver_def by auto
53.93 - thus "f a : B" unfolding a using b by simp
53.94 - next
53.95 - fix b assume "b : B"
53.96 - hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
53.97 - thus "b : f ` A" by auto
53.98 - qed
53.99 -qed
53.100 -
53.101 -lemma bij_betw_ex_weakE:
53.102 - "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
53.103 -by (auto simp only: bij_betw_iff_ex)
53.104 -
53.105 -lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
53.106 -unfolding inver_def by auto (rule rev_image_eqI, auto)
53.107 -
53.108 -lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
53.109 -unfolding inver_def by auto
53.110 -
53.111 -lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
53.112 -unfolding inver_def by simp
53.113 -
53.114 -lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
53.115 -unfolding bij_betw_def by auto
53.116 -
53.117 -lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
53.118 -unfolding bij_betw_def by auto
53.119 -
53.120 -lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
53.121 -unfolding inver_def by auto
53.122 -
53.123 -lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
53.124 -unfolding bij_betw_def inver_def by auto
53.125 -
53.126 -lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
53.127 -unfolding bij_betw_def inver_def by auto
53.128 -
53.129 -lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
53.130 -by (drule bij_betw_imageE, unfold bij_betw_iff_ex) blast
53.131 -
53.132 -lemma bij_betwI':
53.133 - "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
53.134 - \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
53.135 - \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
53.136 -unfolding bij_betw_def inj_on_def
53.137 -apply (rule conjI)
53.138 - apply blast
53.139 -by (erule thin_rl) blast
53.140 -
53.141 -lemma surj_fun_eq:
53.142 - assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
53.143 - shows "g1 = g2"
53.144 -proof (rule ext)
53.145 - fix y
53.146 - from surj_on obtain x where "x \<in> X" and "y = f x" by blast
53.147 - thus "g1 y = g2 y" using eq_on by simp
53.148 -qed
53.149 -
53.150 -lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
53.151 -unfolding wo_rel_def card_order_on_def by blast
53.152 -
53.153 -lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
53.154 - \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
53.155 -unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
53.156 -
53.157 -lemma Card_order_trans:
53.158 - "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
53.159 -unfolding card_order_on_def well_order_on_def linear_order_on_def
53.160 - partial_order_on_def preorder_on_def trans_def antisym_def by blast
53.161 -
53.162 -lemma Cinfinite_limit2:
53.163 - assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
53.164 - shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
53.165 -proof -
53.166 - from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
53.167 - unfolding card_order_on_def well_order_on_def linear_order_on_def
53.168 - partial_order_on_def preorder_on_def by auto
53.169 - obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
53.170 - using Cinfinite_limit[OF x1 r] by blast
53.171 - obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
53.172 - using Cinfinite_limit[OF x2 r] by blast
53.173 - show ?thesis
53.174 - proof (cases "y1 = y2")
53.175 - case True with y1 y2 show ?thesis by blast
53.176 - next
53.177 - case False
53.178 - with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
53.179 - unfolding total_on_def by auto
53.180 - thus ?thesis
53.181 - proof
53.182 - assume *: "(y1, y2) \<in> r"
53.183 - with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
53.184 - with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
53.185 - next
53.186 - assume *: "(y2, y1) \<in> r"
53.187 - with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
53.188 - with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
53.189 - qed
53.190 - qed
53.191 -qed
53.192 -
53.193 -lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
53.194 - \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
53.195 -proof (induct X rule: finite_induct)
53.196 - case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
53.197 -next
53.198 - case (insert x X)
53.199 - then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
53.200 - then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
53.201 - using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
53.202 - show ?case
53.203 - apply (intro bexI ballI)
53.204 - apply (erule insertE)
53.205 - apply hypsubst
53.206 - apply (rule z(2))
53.207 - using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
53.208 - apply blast
53.209 - apply (rule z(1))
53.210 - done
53.211 -qed
53.212 -
53.213 -lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
53.214 -by auto
53.215 -
53.216 -(*helps resolution*)
53.217 -lemma well_order_induct_imp:
53.218 - "wo_rel r \<Longrightarrow> (\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> y \<in> Field r \<longrightarrow> P y \<Longrightarrow> x \<in> Field r \<longrightarrow> P x) \<Longrightarrow>
53.219 - x \<in> Field r \<longrightarrow> P x"
53.220 -by (erule wo_rel.well_order_induct)
53.221 -
53.222 -lemma meta_spec2:
53.223 - assumes "(\<And>x y. PROP P x y)"
53.224 - shows "PROP P x y"
53.225 -by (rule `(\<And>x y. PROP P x y)`)
53.226 -
53.227 -ML_file "Tools/bnf_lfp_util.ML"
53.228 -ML_file "Tools/bnf_lfp_tactics.ML"
53.229 -ML_file "Tools/bnf_lfp.ML"
53.230 -
53.231 -end
54.1 --- a/src/HOL/Codatatype/BNF_Util.thy Fri Sep 21 16:34:40 2012 +0200
54.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
54.3 @@ -1,66 +0,0 @@
54.4 -(* Title: HOL/BNF/BNF_Util.thy
54.5 - Author: Dmitriy Traytel, TU Muenchen
54.6 - Author: Jasmin Blanchette, TU Muenchen
54.7 - Copyright 2012
54.8 -
54.9 -Library for bounded natural functors.
54.10 -*)
54.11 -
54.12 -header {* Library for Bounded Natural Functors *}
54.13 -
54.14 -theory BNF_Util
54.15 -imports "../Cardinals/Cardinal_Arithmetic"
54.16 -begin
54.17 -
54.18 -lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
54.19 -by blast
54.20 -
54.21 -lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
54.22 -by blast
54.23 -
54.24 -definition collect where
54.25 -"collect F x = (\<Union>f \<in> F. f x)"
54.26 -
54.27 -(* Weak pullbacks: *)
54.28 -definition wpull where
54.29 -"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
54.30 - (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow> (\<exists> a \<in> A. p1 a = b1 \<and> p2 a = b2))"
54.31 -
54.32 -(* Weak pseudo-pullbacks *)
54.33 -definition wppull where
54.34 -"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
54.35 - (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
54.36 - (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
54.37 -
54.38 -lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
54.39 -by simp
54.40 -
54.41 -lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
54.42 -by simp
54.43 -
54.44 -lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
54.45 -by simp
54.46 -
54.47 -lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
54.48 -by simp
54.49 -
54.50 -lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
54.51 -unfolding bij_def inj_on_def by auto blast
54.52 -
54.53 -lemma pair_mem_Collect_split:
54.54 -"(\<lambda>x y. (x, y) \<in> {(x, y). P x y}) = P"
54.55 -by simp
54.56 -
54.57 -lemma Collect_pair_mem_eq: "{(x, y). (x, y) \<in> R} = R"
54.58 -by simp
54.59 -
54.60 -lemma Collect_fst_snd_mem_eq: "{p. (fst p, snd p) \<in> A} = A"
54.61 -by simp
54.62 -
54.63 -(* Operator: *)
54.64 -definition "Gr A f = {(a, f a) | a. a \<in> A}"
54.65 -
54.66 -ML_file "Tools/bnf_util.ML"
54.67 -ML_file "Tools/bnf_tactics.ML"
54.68 -
54.69 -end
55.1 --- a/src/HOL/Codatatype/BNF_Wrap.thy Fri Sep 21 16:34:40 2012 +0200
55.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
55.3 @@ -1,28 +0,0 @@
55.4 -(* Title: HOL/BNF/BNF_Wrap.thy
55.5 - Author: Jasmin Blanchette, TU Muenchen
55.6 - Copyright 2012
55.7 -
55.8 -Wrapping datatypes.
55.9 -*)
55.10 -
55.11 -header {* Wrapping Datatypes *}
55.12 -
55.13 -theory BNF_Wrap
55.14 -imports BNF_Util
55.15 -keywords
55.16 - "wrap_data" :: thy_goal and
55.17 - "no_dests"
55.18 -begin
55.19 -
55.20 -lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
55.21 -by (erule iffI) (erule contrapos_pn)
55.22 -
55.23 -lemma iff_contradict:
55.24 -"\<not> P \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> Q \<Longrightarrow> R"
55.25 -"\<not> Q \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> P \<Longrightarrow> R"
55.26 -by blast+
55.27 -
55.28 -ML_file "Tools/bnf_wrap_tactics.ML"
55.29 -ML_file "Tools/bnf_wrap.ML"
55.30 -
55.31 -end
56.1 --- a/src/HOL/Codatatype/Basic_BNFs.thy Fri Sep 21 16:34:40 2012 +0200
56.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
56.3 @@ -1,417 +0,0 @@
56.4 -(* Title: HOL/BNF/Basic_BNFs.thy
56.5 - Author: Dmitriy Traytel, TU Muenchen
56.6 - Author: Andrei Popescu, TU Muenchen
56.7 - Author: Jasmin Blanchette, TU Muenchen
56.8 - Copyright 2012
56.9 -
56.10 -Registration of basic types as bounded natural functors.
56.11 -*)
56.12 -
56.13 -header {* Registration of Basic Types as Bounded Natural Functors *}
56.14 -
56.15 -theory Basic_BNFs
56.16 -imports BNF_Def
56.17 -begin
56.18 -
56.19 -lemma wpull_id: "wpull UNIV B1 B2 id id id id"
56.20 -unfolding wpull_def by simp
56.21 -
56.22 -lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
56.23 -
56.24 -lemma ctwo_card_order: "card_order ctwo"
56.25 -using Card_order_ctwo by (unfold ctwo_def Field_card_of)
56.26 -
56.27 -lemma natLeq_cinfinite: "cinfinite natLeq"
56.28 -unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
56.29 -
56.30 -bnf_def ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
56.31 - "\<lambda>x :: 'a \<Rightarrow> 'b \<Rightarrow> bool. x"
56.32 -apply auto
56.33 -apply (rule natLeq_card_order)
56.34 -apply (rule natLeq_cinfinite)
56.35 -apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
56.36 -apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
56.37 -apply (rule ordLeq_transitive)
56.38 -apply (rule ordLeq_cexp1[of natLeq])
56.39 -apply (rule Cinfinite_Cnotzero)
56.40 -apply (rule conjI)
56.41 -apply (rule natLeq_cinfinite)
56.42 -apply (rule natLeq_Card_order)
56.43 -apply (rule card_of_Card_order)
56.44 -apply (rule cexp_mono1)
56.45 -apply (rule ordLeq_csum1)
56.46 -apply (rule card_of_Card_order)
56.47 -apply (rule disjI2)
56.48 -apply (rule cone_ordLeq_cexp)
56.49 -apply (rule ordLeq_transitive)
56.50 -apply (rule cone_ordLeq_ctwo)
56.51 -apply (rule ordLeq_csum2)
56.52 -apply (rule Card_order_ctwo)
56.53 -apply (rule natLeq_Card_order)
56.54 -apply (auto simp: Gr_def fun_eq_iff)
56.55 -done
56.56 -
56.57 -bnf_def DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
56.58 - "op =::'a \<Rightarrow> 'a \<Rightarrow> bool"
56.59 -apply (auto simp add: wpull_id)
56.60 -apply (rule card_order_csum)
56.61 -apply (rule natLeq_card_order)
56.62 -apply (rule card_of_card_order_on)
56.63 -apply (rule cinfinite_csum)
56.64 -apply (rule disjI1)
56.65 -apply (rule natLeq_cinfinite)
56.66 -apply (rule ordLess_imp_ordLeq)
56.67 -apply (rule ordLess_ordLeq_trans)
56.68 -apply (rule ordLess_ctwo_cexp)
56.69 -apply (rule card_of_Card_order)
56.70 -apply (rule cexp_mono2'')
56.71 -apply (rule ordLeq_csum2)
56.72 -apply (rule card_of_Card_order)
56.73 -apply (rule ctwo_Cnotzero)
56.74 -apply (rule card_of_Card_order)
56.75 -apply (auto simp: Id_def Gr_def fun_eq_iff)
56.76 -done
56.77 -
56.78 -definition setl :: "'a + 'b \<Rightarrow> 'a set" where
56.79 -"setl x = (case x of Inl z => {z} | _ => {})"
56.80 -
56.81 -definition setr :: "'a + 'b \<Rightarrow> 'b set" where
56.82 -"setr x = (case x of Inr z => {z} | _ => {})"
56.83 -
56.84 -lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
56.85 -
56.86 -definition sum_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a + 'c \<Rightarrow> 'b + 'd \<Rightarrow> bool" where
56.87 -"sum_rel \<phi> \<psi> x y =
56.88 - (case x of Inl a1 \<Rightarrow> (case y of Inl a2 \<Rightarrow> \<phi> a1 a2 | Inr _ \<Rightarrow> False)
56.89 - | Inr b1 \<Rightarrow> (case y of Inl _ \<Rightarrow> False | Inr b2 \<Rightarrow> \<psi> b1 b2))"
56.90 -
56.91 -bnf_def sum_map [setl, setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr] sum_rel
56.92 -proof -
56.93 - show "sum_map id id = id" by (rule sum_map.id)
56.94 -next
56.95 - fix f1 f2 g1 g2
56.96 - show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
56.97 - by (rule sum_map.comp[symmetric])
56.98 -next
56.99 - fix x f1 f2 g1 g2
56.100 - assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
56.101 - a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
56.102 - thus "sum_map f1 f2 x = sum_map g1 g2 x"
56.103 - proof (cases x)
56.104 - case Inl thus ?thesis using a1 by (clarsimp simp: setl_def)
56.105 - next
56.106 - case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
56.107 - qed
56.108 -next
56.109 - fix f1 f2
56.110 - show "setl o sum_map f1 f2 = image f1 o setl"
56.111 - by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
56.112 -next
56.113 - fix f1 f2
56.114 - show "setr o sum_map f1 f2 = image f2 o setr"
56.115 - by (rule ext, unfold o_apply) (simp add: setr_def split: sum.split)
56.116 -next
56.117 - show "card_order natLeq" by (rule natLeq_card_order)
56.118 -next
56.119 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
56.120 -next
56.121 - fix x
56.122 - show "|setl x| \<le>o natLeq"
56.123 - apply (rule ordLess_imp_ordLeq)
56.124 - apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
56.125 - by (simp add: setl_def split: sum.split)
56.126 -next
56.127 - fix x
56.128 - show "|setr x| \<le>o natLeq"
56.129 - apply (rule ordLess_imp_ordLeq)
56.130 - apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
56.131 - by (simp add: setr_def split: sum.split)
56.132 -next
56.133 - fix A1 :: "'a set" and A2 :: "'b set"
56.134 - have in_alt: "{x. (case x of Inl z => {z} | _ => {}) \<subseteq> A1 \<and>
56.135 - (case x of Inr z => {z} | _ => {}) \<subseteq> A2} = A1 <+> A2" (is "?L = ?R")
56.136 - proof safe
56.137 - fix x :: "'a + 'b"
56.138 - assume "(case x of Inl z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A1" "(case x of Inr z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A2"
56.139 - hence "x \<in> Inl ` A1 \<or> x \<in> Inr ` A2" by (cases x) simp+
56.140 - thus "x \<in> A1 <+> A2" by blast
56.141 - qed (auto split: sum.split)
56.142 - show "|{x. setl x \<subseteq> A1 \<and> setr x \<subseteq> A2}| \<le>o
56.143 - (( |A1| +c |A2| ) +c ctwo) ^c natLeq"
56.144 - apply (rule ordIso_ordLeq_trans)
56.145 - apply (rule card_of_ordIso_subst)
56.146 - apply (unfold sum_set_defs)
56.147 - apply (rule in_alt)
56.148 - apply (rule ordIso_ordLeq_trans)
56.149 - apply (rule Plus_csum)
56.150 - apply (rule ordLeq_transitive)
56.151 - apply (rule ordLeq_csum1)
56.152 - apply (rule Card_order_csum)
56.153 - apply (rule ordLeq_cexp1)
56.154 - apply (rule conjI)
56.155 - using Field_natLeq UNIV_not_empty czeroE apply fast
56.156 - apply (rule natLeq_Card_order)
56.157 - by (rule Card_order_csum)
56.158 -next
56.159 - fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
56.160 - assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
56.161 - hence
56.162 - pull1: "\<And>b1 b2. \<lbrakk>b1 \<in> B11; b2 \<in> B21; f11 b1 = f21 b2\<rbrakk> \<Longrightarrow> \<exists>a \<in> A1. p11 a = b1 \<and> p21 a = b2"
56.163 - and pull2: "\<And>b1 b2. \<lbrakk>b1 \<in> B12; b2 \<in> B22; f12 b1 = f22 b2\<rbrakk> \<Longrightarrow> \<exists>a \<in> A2. p12 a = b1 \<and> p22 a = b2"
56.164 - unfolding wpull_def by blast+
56.165 - show "wpull {x. setl x \<subseteq> A1 \<and> setr x \<subseteq> A2}
56.166 - {x. setl x \<subseteq> B11 \<and> setr x \<subseteq> B12} {x. setl x \<subseteq> B21 \<and> setr x \<subseteq> B22}
56.167 - (sum_map f11 f12) (sum_map f21 f22) (sum_map p11 p12) (sum_map p21 p22)"
56.168 - (is "wpull ?in ?in1 ?in2 ?mapf1 ?mapf2 ?mapp1 ?mapp2")
56.169 - proof (unfold wpull_def)
56.170 - { fix B1 B2
56.171 - assume *: "B1 \<in> ?in1" "B2 \<in> ?in2" "?mapf1 B1 = ?mapf2 B2"
56.172 - have "\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2"
56.173 - proof (cases B1)
56.174 - case (Inl b1)
56.175 - { fix b2 assume "B2 = Inr b2"
56.176 - with Inl *(3) have False by simp
56.177 - } then obtain b2 where Inl': "B2 = Inl b2" by (cases B2) (simp, blast)
56.178 - with Inl * have "b1 \<in> B11" "b2 \<in> B21" "f11 b1 = f21 b2"
56.179 - by (simp add: setl_def)+
56.180 - with pull1 obtain a where "a \<in> A1" "p11 a = b1" "p21 a = b2" by blast+
56.181 - with Inl Inl' have "Inl a \<in> ?in" "?mapp1 (Inl a) = B1 \<and> ?mapp2 (Inl a) = B2"
56.182 - by (simp add: sum_set_defs)+
56.183 - thus ?thesis by blast
56.184 - next
56.185 - case (Inr b1)
56.186 - { fix b2 assume "B2 = Inl b2"
56.187 - with Inr *(3) have False by simp
56.188 - } then obtain b2 where Inr': "B2 = Inr b2" by (cases B2) (simp, blast)
56.189 - with Inr * have "b1 \<in> B12" "b2 \<in> B22" "f12 b1 = f22 b2"
56.190 - by (simp add: sum_set_defs)+
56.191 - with pull2 obtain a where "a \<in> A2" "p12 a = b1" "p22 a = b2" by blast+
56.192 - with Inr Inr' have "Inr a \<in> ?in" "?mapp1 (Inr a) = B1 \<and> ?mapp2 (Inr a) = B2"
56.193 - by (simp add: sum_set_defs)+
56.194 - thus ?thesis by blast
56.195 - qed
56.196 - }
56.197 - thus "\<forall>B1 B2. B1 \<in> ?in1 \<and> B2 \<in> ?in2 \<and> ?mapf1 B1 = ?mapf2 B2 \<longrightarrow>
56.198 - (\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2)" by fastforce
56.199 - qed
56.200 -next
56.201 - fix R S
56.202 - show "{p. sum_rel (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) (fst p) (snd p)} =
56.203 - (Gr {x. setl x \<subseteq> R \<and> setr x \<subseteq> S} (sum_map fst fst))\<inverse> O
56.204 - Gr {x. setl x \<subseteq> R \<and> setr x \<subseteq> S} (sum_map snd snd)"
56.205 - unfolding setl_def setr_def sum_rel_def Gr_def relcomp_unfold converse_unfold
56.206 - by (fastforce split: sum.splits)
56.207 -qed (auto simp: sum_set_defs)
56.208 -
56.209 -lemma singleton_ordLeq_ctwo_natLeq: "|{x}| \<le>o ctwo *c natLeq"
56.210 - apply (rule ordLeq_transitive)
56.211 - apply (rule ordLeq_cprod2)
56.212 - apply (rule ctwo_Cnotzero)
56.213 - apply (auto simp: Field_card_of intro: card_of_card_order_on)
56.214 - apply (rule cprod_mono2)
56.215 - apply (rule ordLess_imp_ordLeq)
56.216 - apply (unfold finite_iff_ordLess_natLeq[symmetric])
56.217 - by simp
56.218 -
56.219 -definition fsts :: "'a \<times> 'b \<Rightarrow> 'a set" where
56.220 -"fsts x = {fst x}"
56.221 -
56.222 -definition snds :: "'a \<times> 'b \<Rightarrow> 'b set" where
56.223 -"snds x = {snd x}"
56.224 -
56.225 -lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
56.226 -
56.227 -definition prod_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b \<times> 'd \<Rightarrow> bool" where
56.228 -"prod_rel \<phi> \<psi> p1 p2 = (case p1 of (a1, b1) \<Rightarrow> case p2 of (a2, b2) \<Rightarrow> \<phi> a1 a2 \<and> \<psi> b1 b2)"
56.229 -
56.230 -bnf_def map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. ctwo *c natLeq" [Pair] prod_rel
56.231 -proof (unfold prod_set_defs)
56.232 - show "map_pair id id = id" by (rule map_pair.id)
56.233 -next
56.234 - fix f1 f2 g1 g2
56.235 - show "map_pair (g1 o f1) (g2 o f2) = map_pair g1 g2 o map_pair f1 f2"
56.236 - by (rule map_pair.comp[symmetric])
56.237 -next
56.238 - fix x f1 f2 g1 g2
56.239 - assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
56.240 - thus "map_pair f1 f2 x = map_pair g1 g2 x" by (cases x) simp
56.241 -next
56.242 - fix f1 f2
56.243 - show "(\<lambda>x. {fst x}) o map_pair f1 f2 = image f1 o (\<lambda>x. {fst x})"
56.244 - by (rule ext, unfold o_apply) simp
56.245 -next
56.246 - fix f1 f2
56.247 - show "(\<lambda>x. {snd x}) o map_pair f1 f2 = image f2 o (\<lambda>x. {snd x})"
56.248 - by (rule ext, unfold o_apply) simp
56.249 -next
56.250 - show "card_order (ctwo *c natLeq)"
56.251 - apply (rule card_order_cprod)
56.252 - apply (rule ctwo_card_order)
56.253 - by (rule natLeq_card_order)
56.254 -next
56.255 - show "cinfinite (ctwo *c natLeq)"
56.256 - apply (rule cinfinite_cprod2)
56.257 - apply (rule ctwo_Cnotzero)
56.258 - apply (rule conjI[OF _ natLeq_Card_order])
56.259 - by (rule natLeq_cinfinite)
56.260 -next
56.261 - fix x
56.262 - show "|{fst x}| \<le>o ctwo *c natLeq"
56.263 - by (rule singleton_ordLeq_ctwo_natLeq)
56.264 -next
56.265 - fix x
56.266 - show "|{snd x}| \<le>o ctwo *c natLeq"
56.267 - by (rule singleton_ordLeq_ctwo_natLeq)
56.268 -next
56.269 - fix A1 :: "'a set" and A2 :: "'b set"
56.270 - have in_alt: "{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2} = A1 \<times> A2" by auto
56.271 - show "|{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}| \<le>o
56.272 - ( ( |A1| +c |A2| ) +c ctwo) ^c (ctwo *c natLeq)"
56.273 - apply (rule ordIso_ordLeq_trans)
56.274 - apply (rule card_of_ordIso_subst)
56.275 - apply (rule in_alt)
56.276 - apply (rule ordIso_ordLeq_trans)
56.277 - apply (rule Times_cprod)
56.278 - apply (rule ordLeq_transitive)
56.279 - apply (rule cprod_csum_cexp)
56.280 - apply (rule cexp_mono)
56.281 - apply (rule ordLeq_csum1)
56.282 - apply (rule Card_order_csum)
56.283 - apply (rule ordLeq_cprod1)
56.284 - apply (rule Card_order_ctwo)
56.285 - apply (rule Cinfinite_Cnotzero)
56.286 - apply (rule conjI[OF _ natLeq_Card_order])
56.287 - apply (rule natLeq_cinfinite)
56.288 - apply (rule disjI2)
56.289 - apply (rule cone_ordLeq_cexp)
56.290 - apply (rule ordLeq_transitive)
56.291 - apply (rule cone_ordLeq_ctwo)
56.292 - apply (rule ordLeq_csum2)
56.293 - apply (rule Card_order_ctwo)
56.294 - apply (rule notE)
56.295 - apply (rule ctwo_not_czero)
56.296 - apply assumption
56.297 - by (rule Card_order_ctwo)
56.298 -next
56.299 - fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
56.300 - assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
56.301 - thus "wpull {x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}
56.302 - {x. {fst x} \<subseteq> B11 \<and> {snd x} \<subseteq> B12} {x. {fst x} \<subseteq> B21 \<and> {snd x} \<subseteq> B22}
56.303 - (map_pair f11 f12) (map_pair f21 f22) (map_pair p11 p12) (map_pair p21 p22)"
56.304 - unfolding wpull_def by simp fast
56.305 -next
56.306 - fix R S
56.307 - show "{p. prod_rel (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) (fst p) (snd p)} =
56.308 - (Gr {x. {fst x} \<subseteq> R \<and> {snd x} \<subseteq> S} (map_pair fst fst))\<inverse> O
56.309 - Gr {x. {fst x} \<subseteq> R \<and> {snd x} \<subseteq> S} (map_pair snd snd)"
56.310 - unfolding prod_set_defs prod_rel_def Gr_def relcomp_unfold converse_unfold
56.311 - by auto
56.312 -qed simp+
56.313 -
56.314 -(* Categorical version of pullback: *)
56.315 -lemma wpull_cat:
56.316 -assumes p: "wpull A B1 B2 f1 f2 p1 p2"
56.317 -and c: "f1 o q1 = f2 o q2"
56.318 -and r: "range q1 \<subseteq> B1" "range q2 \<subseteq> B2"
56.319 -obtains h where "range h \<subseteq> A \<and> q1 = p1 o h \<and> q2 = p2 o h"
56.320 -proof-
56.321 - have *: "\<forall>d. \<exists>a \<in> A. p1 a = q1 d & p2 a = q2 d"
56.322 - proof safe
56.323 - fix d
56.324 - have "f1 (q1 d) = f2 (q2 d)" using c unfolding comp_def[abs_def] by (rule fun_cong)
56.325 - moreover
56.326 - have "q1 d : B1" "q2 d : B2" using r unfolding image_def by auto
56.327 - ultimately show "\<exists>a \<in> A. p1 a = q1 d \<and> p2 a = q2 d"
56.328 - using p unfolding wpull_def by auto
56.329 - qed
56.330 - then obtain h where "!! d. h d \<in> A & p1 (h d) = q1 d & p2 (h d) = q2 d" by metis
56.331 - thus ?thesis using that by fastforce
56.332 -qed
56.333 -
56.334 -lemma card_of_bounded_range:
56.335 - "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
56.336 -proof -
56.337 - let ?f = "\<lambda>f. %x. if f x \<in> B then Some (f x) else None"
56.338 - have "inj_on ?f ?LHS" unfolding inj_on_def
56.339 - proof (unfold fun_eq_iff, safe)
56.340 - fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
56.341 - assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
56.342 - hence "f x \<in> B" "g x \<in> B" by auto
56.343 - with eq have "Some (f x) = Some (g x)" by metis
56.344 - thus "f x = g x" by simp
56.345 - qed
56.346 - moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
56.347 - ultimately show ?thesis using card_of_ordLeq by fast
56.348 -qed
56.349 -
56.350 -definition fun_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b) \<Rightarrow> bool" where
56.351 -"fun_rel \<phi> f g = (\<forall>x. \<phi> (f x) (g x))"
56.352 -
56.353 -bnf_def "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|" ["%c x::'b::type. c::'a::type"]
56.354 - fun_rel
56.355 -proof
56.356 - fix f show "id \<circ> f = id f" by simp
56.357 -next
56.358 - fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
56.359 - unfolding comp_def[abs_def] ..
56.360 -next
56.361 - fix x f g
56.362 - assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
56.363 - thus "f \<circ> x = g \<circ> x" by auto
56.364 -next
56.365 - fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
56.366 - unfolding image_def comp_def[abs_def] by auto
56.367 -next
56.368 - show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
56.369 - apply (rule card_order_csum)
56.370 - apply (rule natLeq_card_order)
56.371 - by (rule card_of_card_order_on)
56.372 -(* *)
56.373 - show "cinfinite (natLeq +c ?U)"
56.374 - apply (rule cinfinite_csum)
56.375 - apply (rule disjI1)
56.376 - by (rule natLeq_cinfinite)
56.377 -next
56.378 - fix f :: "'d => 'a"
56.379 - have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
56.380 - also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
56.381 - finally show "|range f| \<le>o natLeq +c ?U" .
56.382 -next
56.383 - fix B :: "'a set"
56.384 - have "|{f::'d => 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" by (rule card_of_bounded_range)
56.385 - also have "|Func (UNIV :: 'd set) B| =o |B| ^c |UNIV :: 'd set|"
56.386 - unfolding cexp_def Field_card_of by (rule card_of_refl)
56.387 - also have "|B| ^c |UNIV :: 'd set| \<le>o
56.388 - ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )"
56.389 - apply (rule cexp_mono)
56.390 - apply (rule ordLeq_csum1) apply (rule card_of_Card_order)
56.391 - apply (rule ordLeq_csum2) apply (rule card_of_Card_order)
56.392 - apply (rule disjI2) apply (rule cone_ordLeq_cexp)
56.393 - apply (rule ordLeq_transitive) apply (rule cone_ordLeq_ctwo) apply (rule ordLeq_csum2)
56.394 - apply (rule Card_order_ctwo)
56.395 - apply (rule notE) apply (rule conjunct1) apply (rule Cnotzero_UNIV) apply blast
56.396 - apply (rule card_of_Card_order)
56.397 - done
56.398 - finally
56.399 - show "|{f::'d => 'a. range f \<subseteq> B}| \<le>o
56.400 - ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )" .
56.401 -next
56.402 - fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
56.403 - show "wpull {h. range h \<subseteq> A} {g1. range g1 \<subseteq> B1} {g2. range g2 \<subseteq> B2}
56.404 - (op \<circ> f1) (op \<circ> f2) (op \<circ> p1) (op \<circ> p2)"
56.405 - unfolding wpull_def
56.406 - proof safe
56.407 - fix g1 g2 assume r: "range g1 \<subseteq> B1" "range g2 \<subseteq> B2"
56.408 - and c: "f1 \<circ> g1 = f2 \<circ> g2"
56.409 - show "\<exists>h \<in> {h. range h \<subseteq> A}. p1 \<circ> h = g1 \<and> p2 \<circ> h = g2"
56.410 - using wpull_cat[OF p c r] by simp metis
56.411 - qed
56.412 -next
56.413 - fix R
56.414 - show "{p. fun_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
56.415 - (Gr {x. range x \<subseteq> R} (op \<circ> fst))\<inverse> O Gr {x. range x \<subseteq> R} (op \<circ> snd)"
56.416 - unfolding fun_rel_def Gr_def relcomp_unfold converse_unfold
56.417 - by (auto intro!: exI dest!: in_mono)
56.418 -qed auto
56.419 -
56.420 -end
57.1 --- a/src/HOL/Codatatype/Countable_Set.thy Fri Sep 21 16:34:40 2012 +0200
57.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
57.3 @@ -1,366 +0,0 @@
57.4 -(* Title: HOL/BNF/Countable_Set.thy
57.5 - Author: Andrei Popescu, TU Muenchen
57.6 - Copyright 2012
57.7 -
57.8 -(At most) countable sets.
57.9 -*)
57.10 -
57.11 -header {* (At Most) Countable Sets *}
57.12 -
57.13 -theory Countable_Set
57.14 -imports "../Cardinals/Cardinals" "~~/src/HOL/Library/Countable"
57.15 -begin
57.16 -
57.17 -
57.18 -subsection{* Basics *}
57.19 -
57.20 -definition "countable A \<equiv> |A| \<le>o natLeq"
57.21 -
57.22 -lemma countable_card_of_nat:
57.23 -"countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
57.24 -unfolding countable_def using card_of_nat
57.25 -using ordLeq_ordIso_trans ordIso_symmetric by blast
57.26 -
57.27 -lemma countable_ex_to_nat:
57.28 -fixes A :: "'a set"
57.29 -shows "countable A \<longleftrightarrow> (\<exists> f::'a\<Rightarrow>nat. inj_on f A)"
57.30 -unfolding countable_card_of_nat card_of_ordLeq[symmetric] by auto
57.31 -
57.32 -lemma countable_or_card_of:
57.33 -assumes "countable A"
57.34 -shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
57.35 - (infinite A \<and> |A| =o |UNIV::nat set| )"
57.36 -apply (cases "finite A")
57.37 - apply(metis finite_iff_cardOf_nat)
57.38 - by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
57.39 -
57.40 -lemma countable_or:
57.41 -assumes "countable A"
57.42 -shows "(\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or>
57.43 - (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
57.44 -using countable_or_card_of[OF assms]
57.45 -by (metis assms card_of_ordIso countable_ex_to_nat)
57.46 -
57.47 -lemma countable_cases_card_of[elim, consumes 1, case_names Fin Inf]:
57.48 -assumes "countable A"
57.49 -and "\<lbrakk>finite A; |A| <o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
57.50 -and "\<lbrakk>infinite A; |A| =o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
57.51 -shows phi
57.52 -using assms countable_or_card_of by blast
57.53 -
57.54 -lemma countable_cases[elim, consumes 1, case_names Fin Inf]:
57.55 -assumes "countable A"
57.56 -and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>finite A; inj_on f A\<rbrakk> \<Longrightarrow> phi"
57.57 -and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>infinite A; bij_betw f A UNIV\<rbrakk> \<Longrightarrow> phi"
57.58 -shows phi
57.59 -using assms countable_or by metis
57.60 -
57.61 -definition toNat_pred :: "'a set \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> bool"
57.62 -where
57.63 -"toNat_pred (A::'a set) f \<equiv>
57.64 - (finite A \<and> inj_on f A) \<or> (infinite A \<and> bij_betw f A UNIV)"
57.65 -definition toNat where "toNat A \<equiv> SOME f. toNat_pred A f"
57.66 -
57.67 -lemma toNat_pred:
57.68 -assumes "countable A"
57.69 -shows "\<exists> f. toNat_pred A f"
57.70 -using assms countable_ex_to_nat toNat_pred_def by (cases rule: countable_cases) auto
57.71 -
57.72 -lemma toNat_pred_toNat:
57.73 -assumes "countable A"
57.74 -shows "toNat_pred A (toNat A)"
57.75 -unfolding toNat_def apply(rule someI_ex[of "toNat_pred A"])
57.76 -using toNat_pred[OF assms] .
57.77 -
57.78 -lemma bij_betw_toNat:
57.79 -assumes c: "countable A" and i: "infinite A"
57.80 -shows "bij_betw (toNat A) A (UNIV::nat set)"
57.81 -using toNat_pred_toNat[OF c] unfolding toNat_pred_def using i by auto
57.82 -
57.83 -lemma inj_on_toNat:
57.84 -assumes c: "countable A"
57.85 -shows "inj_on (toNat A) A"
57.86 -using c apply(cases rule: countable_cases)
57.87 -using bij_betw_toNat[OF c] toNat_pred_toNat[OF c]
57.88 -unfolding toNat_pred_def unfolding bij_betw_def by auto
57.89 -
57.90 -lemma toNat_inj[simp]:
57.91 -assumes c: "countable A" and a: "a \<in> A" and b: "b \<in> A"
57.92 -shows "toNat A a = toNat A b \<longleftrightarrow> a = b"
57.93 -using inj_on_toNat[OF c] using a b unfolding inj_on_def by auto
57.94 -
57.95 -lemma image_toNat:
57.96 -assumes c: "countable A" and i: "infinite A"
57.97 -shows "toNat A ` A = UNIV"
57.98 -using bij_betw_toNat[OF assms] unfolding bij_betw_def by simp
57.99 -
57.100 -lemma toNat_surj:
57.101 -assumes "countable A" and i: "infinite A"
57.102 -shows "\<exists> a. a \<in> A \<and> toNat A a = n"
57.103 -using image_toNat[OF assms]
57.104 -by (metis (no_types) image_iff iso_tuple_UNIV_I)
57.105 -
57.106 -definition
57.107 -"fromNat A n \<equiv>
57.108 - if n \<in> toNat A ` A then inv_into A (toNat A) n
57.109 - else (SOME a. a \<in> A)"
57.110 -
57.111 -lemma fromNat:
57.112 -assumes "A \<noteq> {}"
57.113 -shows "fromNat A n \<in> A"
57.114 -unfolding fromNat_def by (metis assms equals0I inv_into_into someI_ex)
57.115 -
57.116 -lemma toNat_fromNat[simp]:
57.117 -assumes "n \<in> toNat A ` A"
57.118 -shows "toNat A (fromNat A n) = n"
57.119 -by (metis assms f_inv_into_f fromNat_def)
57.120 -
57.121 -lemma infinite_toNat_fromNat[simp]:
57.122 -assumes c: "countable A" and i: "infinite A"
57.123 -shows "toNat A (fromNat A n) = n"
57.124 -apply(rule toNat_fromNat) using toNat_surj[OF assms]
57.125 -by (metis image_iff)
57.126 -
57.127 -lemma fromNat_toNat[simp]:
57.128 -assumes c: "countable A" and a: "a \<in> A"
57.129 -shows "fromNat A (toNat A a) = a"
57.130 -by (metis a c equals0D fromNat imageI toNat_fromNat toNat_inj)
57.131 -
57.132 -lemma fromNat_inj:
57.133 -assumes c: "countable A" and i: "infinite A"
57.134 -shows "fromNat A m = fromNat A n \<longleftrightarrow> m = n" (is "?L = ?R \<longleftrightarrow> ?K")
57.135 -proof-
57.136 - have "?L = ?R \<longleftrightarrow> toNat A ?L = toNat A ?R"
57.137 - unfolding toNat_inj[OF c fromNat[OF infinite_imp_nonempty[OF i]]
57.138 - fromNat[OF infinite_imp_nonempty[OF i]]] ..
57.139 - also have "... \<longleftrightarrow> ?K" using c i by simp
57.140 - finally show ?thesis .
57.141 -qed
57.142 -
57.143 -lemma fromNat_surj:
57.144 -assumes c: "countable A" and a: "a \<in> A"
57.145 -shows "\<exists> n. fromNat A n = a"
57.146 -apply(rule exI[of _ "toNat A a"]) using assms by simp
57.147 -
57.148 -lemma fromNat_image_incl:
57.149 -assumes "A \<noteq> {}"
57.150 -shows "fromNat A ` UNIV \<subseteq> A"
57.151 -using fromNat[OF assms] by auto
57.152 -
57.153 -lemma incl_fromNat_image:
57.154 -assumes "countable A"
57.155 -shows "A \<subseteq> fromNat A ` UNIV"
57.156 -unfolding image_def using fromNat_surj[OF assms] by auto
57.157 -
57.158 -lemma fromNat_image[simp]:
57.159 -assumes "A \<noteq> {}" and "countable A"
57.160 -shows "fromNat A ` UNIV = A"
57.161 -by (metis assms equalityI fromNat_image_incl incl_fromNat_image)
57.162 -
57.163 -lemma fromNat_inject[simp]:
57.164 -assumes A: "A \<noteq> {}" "countable A" and B: "B \<noteq> {}" "countable B"
57.165 -shows "fromNat A = fromNat B \<longleftrightarrow> A = B"
57.166 -by (metis assms fromNat_image)
57.167 -
57.168 -lemma inj_on_fromNat:
57.169 -"inj_on fromNat ({A. A \<noteq> {} \<and> countable A})"
57.170 -unfolding inj_on_def by auto
57.171 -
57.172 -
57.173 -subsection {* Preservation under the set theoretic operations *}
57.174 -
57.175 -lemma contable_empty[simp,intro]:
57.176 -"countable {}"
57.177 -by (metis countable_ex_to_nat inj_on_empty)
57.178 -
57.179 -lemma incl_countable:
57.180 -assumes "A \<subseteq> B" and "countable B"
57.181 -shows "countable A"
57.182 -by (metis assms countable_ex_to_nat subset_inj_on)
57.183 -
57.184 -lemma countable_diff:
57.185 -assumes "countable A"
57.186 -shows "countable (A - B)"
57.187 -by (metis Diff_subset assms incl_countable)
57.188 -
57.189 -lemma finite_countable[simp]:
57.190 -assumes "finite A"
57.191 -shows "countable A"
57.192 -by (metis assms countable_ex_to_nat finite_imp_inj_to_nat_seg)
57.193 -
57.194 -lemma countable_singl[simp]:
57.195 -"countable {a}"
57.196 -by simp
57.197 -
57.198 -lemma countable_insert[simp]:
57.199 -"countable (insert a A) \<longleftrightarrow> countable A"
57.200 -proof
57.201 - assume c: "countable A"
57.202 - thus "countable (insert a A)"
57.203 - apply (cases rule: countable_cases_card_of)
57.204 - apply (metis finite_countable finite_insert)
57.205 - unfolding countable_card_of_nat
57.206 - by (metis infinite_card_of_insert ordIso_imp_ordLeq ordIso_transitive)
57.207 -qed(insert incl_countable, metis incl_countable subset_insertI)
57.208 -
57.209 -lemma contable_IntL[simp]:
57.210 -assumes "countable A"
57.211 -shows "countable (A \<inter> B)"
57.212 -by (metis Int_lower1 assms incl_countable)
57.213 -
57.214 -lemma contable_IntR[simp]:
57.215 -assumes "countable B"
57.216 -shows "countable (A \<inter> B)"
57.217 -by (metis assms contable_IntL inf.commute)
57.218 -
57.219 -lemma countable_UN[simp]:
57.220 -assumes cI: "countable I" and cA: "\<And> i. i \<in> I \<Longrightarrow> countable (A i)"
57.221 -shows "countable (\<Union> i \<in> I. A i)"
57.222 -using assms unfolding countable_card_of_nat
57.223 -apply(intro card_of_UNION_ordLeq_infinite) by auto
57.224 -
57.225 -lemma contable_Un[simp]:
57.226 -"countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
57.227 -proof safe
57.228 - assume cA: "countable A" and cB: "countable B"
57.229 - let ?I = "{0,Suc 0}" let ?As = "\<lambda> i. case i of 0 \<Rightarrow> A|Suc 0 \<Rightarrow> B"
57.230 - have AB: "A \<union> B = (\<Union> i \<in> ?I. ?As i)" by simp
57.231 - show "countable (A \<union> B)" unfolding AB apply(rule countable_UN)
57.232 - using cA cB by auto
57.233 -qed (metis Un_upper1 incl_countable, metis Un_upper2 incl_countable)
57.234 -
57.235 -lemma countable_INT[simp]:
57.236 -assumes "i \<in> I" and "countable (A i)"
57.237 -shows "countable (\<Inter> i \<in> I. A i)"
57.238 -by (metis INF_insert assms contable_IntL insert_absorb)
57.239 -
57.240 -lemma countable_class[simp]:
57.241 -fixes A :: "('a::countable) set"
57.242 -shows "countable A"
57.243 -proof-
57.244 - have "inj_on to_nat A" by (metis inj_on_to_nat)
57.245 - thus ?thesis by (metis countable_ex_to_nat)
57.246 -qed
57.247 -
57.248 -lemma countable_image[simp]:
57.249 -assumes "countable A"
57.250 -shows "countable (f ` A)"
57.251 -using assms unfolding countable_card_of_nat
57.252 -by (metis card_of_image ordLeq_transitive)
57.253 -
57.254 -lemma countable_ordLeq:
57.255 -assumes "|A| \<le>o |B|" and "countable B"
57.256 -shows "countable A"
57.257 -using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
57.258 -
57.259 -lemma countable_ordLess:
57.260 -assumes AB: "|A| <o |B|" and B: "countable B"
57.261 -shows "countable A"
57.262 -using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
57.263 -
57.264 -lemma countable_vimage:
57.265 -assumes "B \<subseteq> range f" and "countable (f -` B)"
57.266 -shows "countable B"
57.267 -by (metis Int_absorb2 assms countable_image image_vimage_eq)
57.268 -
57.269 -lemma surj_countable_vimage:
57.270 -assumes s: "surj f" and c: "countable (f -` B)"
57.271 -shows "countable B"
57.272 -apply(rule countable_vimage[OF _ c]) using s by auto
57.273 -
57.274 -lemma countable_Collect[simp]:
57.275 -assumes "countable A"
57.276 -shows "countable {a \<in> A. \<phi> a}"
57.277 -by (metis Collect_conj_eq Int_absorb Int_commute Int_def assms contable_IntR)
57.278 -
57.279 -lemma countable_Plus[simp]:
57.280 -assumes A: "countable A" and B: "countable B"
57.281 -shows "countable (A <+> B)"
57.282 -proof-
57.283 - let ?U = "UNIV::nat set"
57.284 - have "|A| \<le>o |?U|" and "|B| \<le>o |?U|" using A B
57.285 - using card_of_nat[THEN ordIso_symmetric] ordLeq_ordIso_trans
57.286 - unfolding countable_def by blast+
57.287 - hence "|A <+> B| \<le>o |?U|" by (intro card_of_Plus_ordLeq_infinite) auto
57.288 - thus ?thesis using card_of_nat unfolding countable_def by(rule ordLeq_ordIso_trans)
57.289 -qed
57.290 -
57.291 -lemma countable_Times[simp]:
57.292 -assumes A: "countable A" and B: "countable B"
57.293 -shows "countable (A \<times> B)"
57.294 -proof-
57.295 - let ?U = "UNIV::nat set"
57.296 - have "|A| \<le>o |?U|" and "|B| \<le>o |?U|" using A B
57.297 - using card_of_nat[THEN ordIso_symmetric] ordLeq_ordIso_trans
57.298 - unfolding countable_def by blast+
57.299 - hence "|A \<times> B| \<le>o |?U|" by (intro card_of_Times_ordLeq_infinite) auto
57.300 - thus ?thesis using card_of_nat unfolding countable_def by(rule ordLeq_ordIso_trans)
57.301 -qed
57.302 -
57.303 -lemma ordLeq_countable:
57.304 -assumes "|A| \<le>o |B|" and "countable B"
57.305 -shows "countable A"
57.306 -using assms unfolding countable_def by(rule ordLeq_transitive)
57.307 -
57.308 -lemma ordLess_countable:
57.309 -assumes A: "|A| <o |B|" and B: "countable B"
57.310 -shows "countable A"
57.311 -by (rule ordLeq_countable[OF ordLess_imp_ordLeq[OF A] B])
57.312 -
57.313 -lemma countable_def2: "countable A \<longleftrightarrow> |A| \<le>o |UNIV :: nat set|"
57.314 -unfolding countable_def using card_of_nat[THEN ordIso_symmetric]
57.315 -by (metis (lifting) Field_card_of Field_natLeq card_of_mono2 card_of_nat
57.316 - countable_def ordIso_imp_ordLeq ordLeq_countable)
57.317 -
57.318 -
57.319 -subsection{* The type of countable sets *}
57.320 -
57.321 -typedef (open) 'a cset = "{A :: 'a set. countable A}"
57.322 -apply(rule exI[of _ "{}"]) by simp
57.323 -
57.324 -abbreviation rcset where "rcset \<equiv> Rep_cset"
57.325 -abbreviation acset where "acset \<equiv> Abs_cset"
57.326 -
57.327 -lemmas acset_rcset = Rep_cset_inverse
57.328 -declare acset_rcset[simp]
57.329 -
57.330 -lemma acset_surj:
57.331 -"\<exists> A. countable A \<and> acset A = C"
57.332 -apply(cases rule: Abs_cset_cases[of C]) by auto
57.333 -
57.334 -lemma rcset_acset[simp]:
57.335 -assumes "countable A"
57.336 -shows "rcset (acset A) = A"
57.337 -using Abs_cset_inverse assms by auto
57.338 -
57.339 -lemma acset_inj[simp]:
57.340 -assumes "countable A" and "countable B"
57.341 -shows "acset A = acset B \<longleftrightarrow> A = B"
57.342 -using assms Abs_cset_inject by auto
57.343 -
57.344 -lemma rcset[simp]:
57.345 -"countable (rcset C)"
57.346 -using Rep_cset by simp
57.347 -
57.348 -lemma rcset_inj[simp]:
57.349 -"rcset C = rcset D \<longleftrightarrow> C = D"
57.350 -by (metis acset_rcset)
57.351 -
57.352 -lemma rcset_surj:
57.353 -assumes "countable A"
57.354 -shows "\<exists> C. rcset C = A"
57.355 -apply(cases rule: Rep_cset_cases[of A])
57.356 -using assms by auto
57.357 -
57.358 -definition "cIn a C \<equiv> (a \<in> rcset C)"
57.359 -definition "cEmp \<equiv> acset {}"
57.360 -definition "cIns a C \<equiv> acset (insert a (rcset C))"
57.361 -abbreviation cSingl where "cSingl a \<equiv> cIns a cEmp"
57.362 -definition "cUn C D \<equiv> acset (rcset C \<union> rcset D)"
57.363 -definition "cInt C D \<equiv> acset (rcset C \<inter> rcset D)"
57.364 -definition "cDif C D \<equiv> acset (rcset C - rcset D)"
57.365 -definition "cIm f C \<equiv> acset (f ` rcset C)"
57.366 -definition "cVim f D \<equiv> acset (f -` rcset D)"
57.367 -(* TODO eventually: nice setup for these operations, copied from the set setup *)
57.368 -
57.369 -end
58.1 --- a/src/HOL/Codatatype/Equiv_Relations_More.thy Fri Sep 21 16:34:40 2012 +0200
58.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
58.3 @@ -1,161 +0,0 @@
58.4 -(* Title: HOL/BNF/Equiv_Relations_More.thy
58.5 - Author: Andrei Popescu, TU Muenchen
58.6 - Copyright 2012
58.7 -
58.8 -Some preliminaries on equivalence relations and quotients.
58.9 -*)
58.10 -
58.11 -header {* Some Preliminaries on Equivalence Relations and Quotients *}
58.12 -
58.13 -theory Equiv_Relations_More
58.14 -imports Equiv_Relations Hilbert_Choice
58.15 -begin
58.16 -
58.17 -
58.18 -(* Recall the following constants and lemmas:
58.19 -
58.20 -term Eps
58.21 -term "A//r"
58.22 -lemmas equiv_def
58.23 -lemmas refl_on_def
58.24 - -- note that "reflexivity on" also assumes inclusion of the relation's field into r
58.25 -
58.26 -*)
58.27 -
58.28 -definition proj where "proj r x = r `` {x}"
58.29 -
58.30 -definition univ where "univ f X == f (Eps (%x. x \<in> X))"
58.31 -
58.32 -lemma proj_preserves:
58.33 -"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
58.34 -unfolding proj_def by (rule quotientI)
58.35 -
58.36 -lemma proj_in_iff:
58.37 -assumes "equiv A r"
58.38 -shows "(proj r x \<in> A//r) = (x \<in> A)"
58.39 -apply(rule iffI, auto simp add: proj_preserves)
58.40 -unfolding proj_def quotient_def proof clarsimp
58.41 - fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
58.42 - moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by blast
58.43 - ultimately have "(x,y) \<in> r" by blast
58.44 - thus "x \<in> A" using assms unfolding equiv_def refl_on_def by blast
58.45 -qed
58.46 -
58.47 -lemma proj_iff:
58.48 -"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
58.49 -by (simp add: proj_def eq_equiv_class_iff)
58.50 -
58.51 -(*
58.52 -lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
58.53 -unfolding proj_def equiv_def refl_on_def by blast
58.54 -*)
58.55 -
58.56 -lemma proj_image: "(proj r) ` A = A//r"
58.57 -unfolding proj_def[abs_def] quotient_def by blast
58.58 -
58.59 -lemma in_quotient_imp_non_empty:
58.60 -"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<noteq> {}"
58.61 -unfolding quotient_def using equiv_class_self by fast
58.62 -
58.63 -lemma in_quotient_imp_in_rel:
58.64 -"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
58.65 -using quotient_eq_iff by fastforce
58.66 -
58.67 -lemma in_quotient_imp_closed:
58.68 -"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
58.69 -unfolding quotient_def equiv_def trans_def by blast
58.70 -
58.71 -lemma in_quotient_imp_subset:
58.72 -"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
58.73 -using assms in_quotient_imp_in_rel equiv_type by fastforce
58.74 -
58.75 -lemma equiv_Eps_in:
58.76 -"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
58.77 -apply (rule someI2_ex)
58.78 -using in_quotient_imp_non_empty by blast
58.79 -
58.80 -lemma equiv_Eps_preserves:
58.81 -assumes ECH: "equiv A r" and X: "X \<in> A//r"
58.82 -shows "Eps (%x. x \<in> X) \<in> A"
58.83 -apply (rule in_mono[rule_format])
58.84 - using assms apply (rule in_quotient_imp_subset)
58.85 -by (rule equiv_Eps_in) (rule assms)+
58.86 -
58.87 -lemma proj_Eps:
58.88 -assumes "equiv A r" and "X \<in> A//r"
58.89 -shows "proj r (Eps (%x. x \<in> X)) = X"
58.90 -unfolding proj_def proof auto
58.91 - fix x assume x: "x \<in> X"
58.92 - thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
58.93 -next
58.94 - fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
58.95 - thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
58.96 -qed
58.97 -
58.98 -(*
58.99 -lemma Eps_proj:
58.100 -assumes "equiv A r" and "x \<in> A"
58.101 -shows "(Eps (%y. y \<in> proj r x), x) \<in> r"
58.102 -proof-
58.103 - have 1: "proj r x \<in> A//r" using assms proj_preserves by fastforce
58.104 - hence "Eps(%y. y \<in> proj r x) \<in> proj r x" using assms equiv_Eps_in by auto
58.105 - moreover have "x \<in> proj r x" using assms in_proj by fastforce
58.106 - ultimately show ?thesis using assms 1 in_quotient_imp_in_rel by fastforce
58.107 -qed
58.108 -
58.109 -lemma equiv_Eps_iff:
58.110 -assumes "equiv A r" and "{X,Y} \<subseteq> A//r"
58.111 -shows "((Eps (%x. x \<in> X),Eps (%y. y \<in> Y)) \<in> r) = (X = Y)"
58.112 -proof-
58.113 - have "Eps (%x. x \<in> X) \<in> X \<and> Eps (%y. y \<in> Y) \<in> Y" using assms equiv_Eps_in by auto
58.114 - thus ?thesis using assms quotient_eq_iff by fastforce
58.115 -qed
58.116 -
58.117 -lemma equiv_Eps_inj_on:
58.118 -assumes "equiv A r"
58.119 -shows "inj_on (%X. Eps (%x. x \<in> X)) (A//r)"
58.120 -unfolding inj_on_def proof clarify
58.121 - fix X Y assume X: "X \<in> A//r" and Y: "Y \<in> A//r" and Eps: "Eps (%x. x \<in> X) = Eps (%y. y \<in> Y)"
58.122 - hence "Eps (%x. x \<in> X) \<in> A" using assms equiv_Eps_preserves by auto
58.123 - hence "(Eps (%x. x \<in> X), Eps (%y. y \<in> Y)) \<in> r"
58.124 - using assms Eps unfolding quotient_def equiv_def refl_on_def by auto
58.125 - thus "X= Y" using X Y assms equiv_Eps_iff by auto
58.126 -qed
58.127 -*)
58.128 -
58.129 -lemma univ_commute:
58.130 -assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
58.131 -shows "(univ f) (proj r x) = f x"
58.132 -unfolding univ_def proof -
58.133 - have prj: "proj r x \<in> A//r" using x proj_preserves by fast
58.134 - hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
58.135 - moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
58.136 - ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
58.137 - thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
58.138 -qed
58.139 -
58.140 -(*
58.141 -lemma univ_unique:
58.142 -assumes ECH: "equiv A r" and
58.143 - RES: "f respects r" and COM: "\<forall> x \<in> A. G (proj r x) = f x"
58.144 -shows "\<forall> X \<in> A//r. G X = univ f X"
58.145 -proof
58.146 - fix X assume "X \<in> A//r"
58.147 - then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
58.148 - have "G X = f x" unfolding X using x COM by simp
58.149 - thus "G X = univ f X" unfolding X using ECH RES x univ_commute by fastforce
58.150 -qed
58.151 -*)
58.152 -
58.153 -lemma univ_preserves:
58.154 -assumes ECH: "equiv A r" and RES: "f respects r" and
58.155 - PRES: "\<forall> x \<in> A. f x \<in> B"
58.156 -shows "\<forall> X \<in> A//r. univ f X \<in> B"
58.157 -proof
58.158 - fix X assume "X \<in> A//r"
58.159 - then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
58.160 - hence "univ f X = f x" using assms univ_commute by fastforce
58.161 - thus "univ f X \<in> B" using x PRES by simp
58.162 -qed
58.163 -
58.164 -end
59.1 --- a/src/HOL/Codatatype/Examples/HFset.thy Fri Sep 21 16:34:40 2012 +0200
59.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
59.3 @@ -1,60 +0,0 @@
59.4 -(* Title: HOL/BNF/Examples/HFset.thy
59.5 - Author: Andrei Popescu, TU Muenchen
59.6 - Copyright 2012
59.7 -
59.8 -Hereditary sets.
59.9 -*)
59.10 -
59.11 -header {* Hereditary Sets *}
59.12 -
59.13 -theory HFset
59.14 -imports "../BNF"
59.15 -begin
59.16 -
59.17 -
59.18 -section {* Datatype definition *}
59.19 -
59.20 -data_raw hfset: 'hfset = "'hfset fset"
59.21 -
59.22 -
59.23 -section {* Customization of terms *}
59.24 -
59.25 -subsection{* Constructors *}
59.26 -
59.27 -definition "Fold hs \<equiv> hfset_ctor hs"
59.28 -
59.29 -lemma hfset_simps[simp]:
59.30 -"\<And>hs1 hs2. Fold hs1 = Fold hs2 \<longrightarrow> hs1 = hs2"
59.31 -unfolding Fold_def hfset.ctor_inject by auto
59.32 -
59.33 -theorem hfset_cases[elim, case_names Fold]:
59.34 -assumes Fold: "\<And> hs. h = Fold hs \<Longrightarrow> phi"
59.35 -shows phi
59.36 -using Fold unfolding Fold_def
59.37 -by (cases rule: hfset.ctor_exhaust[of h]) simp
59.38 -
59.39 -lemma hfset_induct[case_names Fold, induct type: hfset]:
59.40 -assumes Fold: "\<And> hs. (\<And> h. h |\<in>| hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
59.41 -shows "phi t"
59.42 -apply (induct rule: hfset.ctor_induct)
59.43 -using Fold unfolding Fold_def fset_fset_member mem_Collect_eq ..
59.44 -
59.45 -(* alternative induction principle, using fset: *)
59.46 -lemma hfset_induct_fset[case_names Fold, induct type: hfset]:
59.47 -assumes Fold: "\<And> hs. (\<And> h. h \<in> fset hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
59.48 -shows "phi t"
59.49 -apply (induct rule: hfset_induct)
59.50 -using Fold by (metis notin_fset)
59.51 -
59.52 -subsection{* Recursion and iteration (fold) *}
59.53 -
59.54 -lemma hfset_ctor_rec:
59.55 -"hfset_ctor_rec R (Fold hs) = R (map_fset <id, hfset_ctor_rec R> hs)"
59.56 -using hfset.ctor_recs unfolding Fold_def .
59.57 -
59.58 -(* The iterator has a simpler form: *)
59.59 -lemma hfset_ctor_fold:
59.60 -"hfset_ctor_fold R (Fold hs) = R (map_fset (hfset_ctor_fold R) hs)"
59.61 -using hfset.ctor_folds unfolding Fold_def .
59.62 -
59.63 -end
60.1 --- a/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Gram_Lang.thy Fri Sep 21 16:34:40 2012 +0200
60.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
60.3 @@ -1,1366 +0,0 @@
60.4 -(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Gram_Lang.thy
60.5 - Author: Andrei Popescu, TU Muenchen
60.6 - Copyright 2012
60.7 -
60.8 -Language of a grammar.
60.9 -*)
60.10 -
60.11 -header {* Language of a Grammar *}
60.12 -
60.13 -theory Gram_Lang
60.14 -imports Tree
60.15 -begin
60.16 -
60.17 -
60.18 -consts P :: "(N \<times> (T + N) set) set"
60.19 -axiomatization where
60.20 - finite_N: "finite (UNIV::N set)"
60.21 -and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
60.22 -and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
60.23 -
60.24 -
60.25 -subsection{* Tree basics: frontier, interior, etc. *}
60.26 -
60.27 -lemma Tree_cong:
60.28 -assumes "root tr = root tr'" and "cont tr = cont tr'"
60.29 -shows "tr = tr'"
60.30 -by (metis Node_root_cont assms)
60.31 -
60.32 -inductive finiteT where
60.33 -Node: "\<lbrakk>finite as; (finiteT^#) as\<rbrakk> \<Longrightarrow> finiteT (Node a as)"
60.34 -monos lift_mono
60.35 -
60.36 -lemma finiteT_induct[consumes 1, case_names Node, induct pred: finiteT]:
60.37 -assumes 1: "finiteT tr"
60.38 -and IH: "\<And>as n. \<lbrakk>finite as; (\<phi>^#) as\<rbrakk> \<Longrightarrow> \<phi> (Node n as)"
60.39 -shows "\<phi> tr"
60.40 -using 1 apply(induct rule: finiteT.induct)
60.41 -apply(rule IH) apply assumption apply(elim mono_lift) by simp
60.42 -
60.43 -
60.44 -(* Frontier *)
60.45 -
60.46 -inductive inFr :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where
60.47 -Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
60.48 -|
60.49 -Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
60.50 -
60.51 -definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
60.52 -
60.53 -lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
60.54 -by (metis inFr.simps)
60.55 -
60.56 -lemma inFr_mono:
60.57 -assumes "inFr ns tr t" and "ns \<subseteq> ns'"
60.58 -shows "inFr ns' tr t"
60.59 -using assms apply(induct arbitrary: ns' rule: inFr.induct)
60.60 -using Base Ind by (metis inFr.simps set_mp)+
60.61 -
60.62 -lemma inFr_Ind_minus:
60.63 -assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
60.64 -shows "inFr (insert (root tr) ns1) tr t"
60.65 -using assms apply(induct rule: inFr.induct)
60.66 - apply (metis inFr.simps insert_iff)
60.67 - by (metis inFr.simps inFr_mono insertI1 subset_insertI)
60.68 -
60.69 -(* alternative definition *)
60.70 -inductive inFr2 :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where
60.71 -Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
60.72 -|
60.73 -Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
60.74 - \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
60.75 -
60.76 -lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
60.77 -apply(induct rule: inFr2.induct) by auto
60.78 -
60.79 -lemma inFr2_mono:
60.80 -assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
60.81 -shows "inFr2 ns' tr t"
60.82 -using assms apply(induct arbitrary: ns' rule: inFr2.induct)
60.83 -using Base Ind
60.84 -apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
60.85 -
60.86 -lemma inFr2_Ind:
60.87 -assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
60.88 -shows "inFr2 ns tr t"
60.89 -using assms apply(induct rule: inFr2.induct)
60.90 - apply (metis inFr2.simps insert_absorb)
60.91 - by (metis inFr2.simps insert_absorb)
60.92 -
60.93 -lemma inFr_inFr2:
60.94 -"inFr = inFr2"
60.95 -apply (rule ext)+ apply(safe)
60.96 - apply(erule inFr.induct)
60.97 - apply (metis (lifting) inFr2.Base)
60.98 - apply (metis (lifting) inFr2_Ind)
60.99 - apply(erule inFr2.induct)
60.100 - apply (metis (lifting) inFr.Base)
60.101 - apply (metis (lifting) inFr_Ind_minus)
60.102 -done
60.103 -
60.104 -lemma not_root_inFr:
60.105 -assumes "root tr \<notin> ns"
60.106 -shows "\<not> inFr ns tr t"
60.107 -by (metis assms inFr_root_in)
60.108 -
60.109 -theorem not_root_Fr:
60.110 -assumes "root tr \<notin> ns"
60.111 -shows "Fr ns tr = {}"
60.112 -using not_root_inFr[OF assms] unfolding Fr_def by auto
60.113 -
60.114 -
60.115 -(* Interior *)
60.116 -
60.117 -inductive inItr :: "N set \<Rightarrow> Tree \<Rightarrow> N \<Rightarrow> bool" where
60.118 -Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
60.119 -|
60.120 -Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
60.121 -
60.122 -definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
60.123 -
60.124 -lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
60.125 -by (metis inItr.simps)
60.126 -
60.127 -lemma inItr_mono:
60.128 -assumes "inItr ns tr n" and "ns \<subseteq> ns'"
60.129 -shows "inItr ns' tr n"
60.130 -using assms apply(induct arbitrary: ns' rule: inItr.induct)
60.131 -using Base Ind by (metis inItr.simps set_mp)+
60.132 -
60.133 -
60.134 -(* The subtree relation *)
60.135 -
60.136 -inductive subtr where
60.137 -Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
60.138 -|
60.139 -Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
60.140 -
60.141 -lemma subtr_rootL_in:
60.142 -assumes "subtr ns tr1 tr2"
60.143 -shows "root tr1 \<in> ns"
60.144 -using assms apply(induct rule: subtr.induct) by auto
60.145 -
60.146 -lemma subtr_rootR_in:
60.147 -assumes "subtr ns tr1 tr2"
60.148 -shows "root tr2 \<in> ns"
60.149 -using assms apply(induct rule: subtr.induct) by auto
60.150 -
60.151 -lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
60.152 -
60.153 -lemma subtr_mono:
60.154 -assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
60.155 -shows "subtr ns' tr1 tr2"
60.156 -using assms apply(induct arbitrary: ns' rule: subtr.induct)
60.157 -using Refl Step by (metis subtr.simps set_mp)+
60.158 -
60.159 -lemma subtr_trans_Un:
60.160 -assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
60.161 -shows "subtr (ns12 \<union> ns23) tr1 tr3"
60.162 -proof-
60.163 - have "subtr ns23 tr2 tr3 \<Longrightarrow>
60.164 - (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
60.165 - apply(induct rule: subtr.induct, safe)
60.166 - apply (metis subtr_mono sup_commute sup_ge2)
60.167 - by (metis (lifting) Step UnI2)
60.168 - thus ?thesis using assms by auto
60.169 -qed
60.170 -
60.171 -lemma subtr_trans:
60.172 -assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
60.173 -shows "subtr ns tr1 tr3"
60.174 -using subtr_trans_Un[OF assms] by simp
60.175 -
60.176 -lemma subtr_StepL:
60.177 -assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
60.178 -shows "subtr ns tr1 tr3"
60.179 -apply(rule subtr_trans[OF _ s]) apply(rule Step[of tr2 ns tr1 tr1])
60.180 -by (metis assms subtr_rootL_in Refl)+
60.181 -
60.182 -(* alternative definition: *)
60.183 -inductive subtr2 where
60.184 -Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
60.185 -|
60.186 -Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
60.187 -
60.188 -lemma subtr2_rootL_in:
60.189 -assumes "subtr2 ns tr1 tr2"
60.190 -shows "root tr1 \<in> ns"
60.191 -using assms apply(induct rule: subtr2.induct) by auto
60.192 -
60.193 -lemma subtr2_rootR_in:
60.194 -assumes "subtr2 ns tr1 tr2"
60.195 -shows "root tr2 \<in> ns"
60.196 -using assms apply(induct rule: subtr2.induct) by auto
60.197 -
60.198 -lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
60.199 -
60.200 -lemma subtr2_mono:
60.201 -assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
60.202 -shows "subtr2 ns' tr1 tr2"
60.203 -using assms apply(induct arbitrary: ns' rule: subtr2.induct)
60.204 -using Refl Step by (metis subtr2.simps set_mp)+
60.205 -
60.206 -lemma subtr2_trans_Un:
60.207 -assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
60.208 -shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
60.209 -proof-
60.210 - have "subtr2 ns12 tr1 tr2 \<Longrightarrow>
60.211 - (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
60.212 - apply(induct rule: subtr2.induct, safe)
60.213 - apply (metis subtr2_mono sup_commute sup_ge2)
60.214 - by (metis Un_iff subtr2.simps)
60.215 - thus ?thesis using assms by auto
60.216 -qed
60.217 -
60.218 -lemma subtr2_trans:
60.219 -assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
60.220 -shows "subtr2 ns tr1 tr3"
60.221 -using subtr2_trans_Un[OF assms] by simp
60.222 -
60.223 -lemma subtr2_StepR:
60.224 -assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
60.225 -shows "subtr2 ns tr1 tr3"
60.226 -apply(rule subtr2_trans[OF s]) apply(rule Step[of _ _ tr3])
60.227 -by (metis assms subtr2_rootR_in Refl)+
60.228 -
60.229 -lemma subtr_subtr2:
60.230 -"subtr = subtr2"
60.231 -apply (rule ext)+ apply(safe)
60.232 - apply(erule subtr.induct)
60.233 - apply (metis (lifting) subtr2.Refl)
60.234 - apply (metis (lifting) subtr2_StepR)
60.235 - apply(erule subtr2.induct)
60.236 - apply (metis (lifting) subtr.Refl)
60.237 - apply (metis (lifting) subtr_StepL)
60.238 -done
60.239 -
60.240 -lemma subtr_inductL[consumes 1, case_names Refl Step]:
60.241 -assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
60.242 -and Step:
60.243 -"\<And>ns tr1 tr2 tr3.
60.244 - \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
60.245 -shows "\<phi> ns tr1 tr2"
60.246 -using s unfolding subtr_subtr2 apply(rule subtr2.induct)
60.247 -using Refl Step unfolding subtr_subtr2 by auto
60.248 -
60.249 -lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
60.250 -assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
60.251 -and Step:
60.252 -"\<And>tr1 tr2 tr3.
60.253 - \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
60.254 -shows "\<phi> tr1 tr2"
60.255 -using s apply(induct rule: subtr_inductL)
60.256 -apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
60.257 -
60.258 -(* Subtree versus frontier: *)
60.259 -lemma subtr_inFr:
60.260 -assumes "inFr ns tr t" and "subtr ns tr tr1"
60.261 -shows "inFr ns tr1 t"
60.262 -proof-
60.263 - have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
60.264 - apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
60.265 - thus ?thesis using assms by auto
60.266 -qed
60.267 -
60.268 -corollary Fr_subtr:
60.269 -"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
60.270 -unfolding Fr_def proof safe
60.271 - fix t assume t: "inFr ns tr t" hence "root tr \<in> ns" by (rule inFr_root_in)
60.272 - thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
60.273 - apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
60.274 -qed(metis subtr_inFr)
60.275 -
60.276 -lemma inFr_subtr:
60.277 -assumes "inFr ns tr t"
60.278 -shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
60.279 -using assms apply(induct rule: inFr.induct) apply safe
60.280 - apply (metis subtr.Refl)
60.281 - by (metis (lifting) subtr.Step)
60.282 -
60.283 -corollary Fr_subtr_cont:
60.284 -"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
60.285 -unfolding Fr_def
60.286 -apply safe
60.287 -apply (frule inFr_subtr)
60.288 -apply auto
60.289 -by (metis inFr.Base subtr_inFr subtr_rootL_in)
60.290 -
60.291 -(* Subtree versus interior: *)
60.292 -lemma subtr_inItr:
60.293 -assumes "inItr ns tr n" and "subtr ns tr tr1"
60.294 -shows "inItr ns tr1 n"
60.295 -proof-
60.296 - have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
60.297 - apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
60.298 - thus ?thesis using assms by auto
60.299 -qed
60.300 -
60.301 -corollary Itr_subtr:
60.302 -"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
60.303 -unfolding Itr_def apply safe
60.304 -apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
60.305 -by (metis subtr_inItr)
60.306 -
60.307 -lemma inItr_subtr:
60.308 -assumes "inItr ns tr n"
60.309 -shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
60.310 -using assms apply(induct rule: inItr.induct) apply safe
60.311 - apply (metis subtr.Refl)
60.312 - by (metis (lifting) subtr.Step)
60.313 -
60.314 -corollary Itr_subtr_cont:
60.315 -"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
60.316 -unfolding Itr_def apply safe
60.317 - apply (metis (lifting, mono_tags) UnionI inItr_subtr mem_Collect_eq vimageI2)
60.318 - by (metis inItr.Base subtr_inItr subtr_rootL_in)
60.319 -
60.320 -
60.321 -subsection{* The immediate subtree function *}
60.322 -
60.323 -(* production of: *)
60.324 -abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
60.325 -(* subtree of: *)
60.326 -definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
60.327 -
60.328 -lemma subtrOf:
60.329 -assumes n: "Inr n \<in> prodOf tr"
60.330 -shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
60.331 -proof-
60.332 - obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
60.333 - using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
60.334 - thus ?thesis unfolding subtrOf_def by(rule someI)
60.335 -qed
60.336 -
60.337 -lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
60.338 -lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
60.339 -
60.340 -lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
60.341 -proof safe
60.342 - fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
60.343 - thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
60.344 -next
60.345 - fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
60.346 - by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
60.347 -qed
60.348 -
60.349 -lemma root_prodOf:
60.350 -assumes "Inr tr' \<in> cont tr"
60.351 -shows "Inr (root tr') \<in> prodOf tr"
60.352 -by (metis (lifting) assms image_iff sum_map.simps(2))
60.353 -
60.354 -
60.355 -subsection{* Derivation trees *}
60.356 -
60.357 -coinductive dtree where
60.358 -Tree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
60.359 - lift dtree (cont tr)\<rbrakk> \<Longrightarrow> dtree tr"
60.360 -monos lift_mono
60.361 -
60.362 -(* destruction rules: *)
60.363 -lemma dtree_P:
60.364 -assumes "dtree tr"
60.365 -shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
60.366 -using assms unfolding dtree.simps by auto
60.367 -
60.368 -lemma dtree_inj_on:
60.369 -assumes "dtree tr"
60.370 -shows "inj_on root (Inr -` cont tr)"
60.371 -using assms unfolding dtree.simps by auto
60.372 -
60.373 -lemma dtree_inj[simp]:
60.374 -assumes "dtree tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
60.375 -shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
60.376 -using assms dtree_inj_on unfolding inj_on_def by auto
60.377 -
60.378 -lemma dtree_lift:
60.379 -assumes "dtree tr"
60.380 -shows "lift dtree (cont tr)"
60.381 -using assms unfolding dtree.simps by auto
60.382 -
60.383 -
60.384 -(* coinduction:*)
60.385 -lemma dtree_coind[elim, consumes 1, case_names Hyp]:
60.386 -assumes phi: "\<phi> tr"
60.387 -and Hyp:
60.388 -"\<And> tr. \<phi> tr \<Longrightarrow>
60.389 - (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
60.390 - inj_on root (Inr -` cont tr) \<and>
60.391 - lift (\<lambda> tr. \<phi> tr \<or> dtree tr) (cont tr)"
60.392 -shows "dtree tr"
60.393 -apply(rule dtree.coinduct[of \<phi> tr, OF phi])
60.394 -using Hyp by blast
60.395 -
60.396 -lemma dtree_raw_coind[elim, consumes 1, case_names Hyp]:
60.397 -assumes phi: "\<phi> tr"
60.398 -and Hyp:
60.399 -"\<And> tr. \<phi> tr \<Longrightarrow>
60.400 - (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
60.401 - inj_on root (Inr -` cont tr) \<and>
60.402 - lift \<phi> (cont tr)"
60.403 -shows "dtree tr"
60.404 -using phi apply(induct rule: dtree_coind)
60.405 -using Hyp mono_lift
60.406 -by (metis (mono_tags) mono_lift)
60.407 -
60.408 -lemma dtree_subtr_inj_on:
60.409 -assumes d: "dtree tr1" and s: "subtr ns tr tr1"
60.410 -shows "inj_on root (Inr -` cont tr)"
60.411 -using s d apply(induct rule: subtr.induct)
60.412 -apply (metis (lifting) dtree_inj_on) by (metis dtree_lift lift_def)
60.413 -
60.414 -lemma dtree_subtr_P:
60.415 -assumes d: "dtree tr1" and s: "subtr ns tr tr1"
60.416 -shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
60.417 -using s d apply(induct rule: subtr.induct)
60.418 -apply (metis (lifting) dtree_P) by (metis dtree_lift lift_def)
60.419 -
60.420 -lemma subtrOf_root[simp]:
60.421 -assumes tr: "dtree tr" and cont: "Inr tr' \<in> cont tr"
60.422 -shows "subtrOf tr (root tr') = tr'"
60.423 -proof-
60.424 - have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
60.425 - by (metis (lifting) cont root_prodOf)
60.426 - have "root (subtrOf tr (root tr')) = root tr'"
60.427 - using root_subtrOf by (metis (lifting) cont root_prodOf)
60.428 - thus ?thesis unfolding dtree_inj[OF tr 0 cont] .
60.429 -qed
60.430 -
60.431 -lemma surj_subtrOf:
60.432 -assumes "dtree tr" and 0: "Inr tr' \<in> cont tr"
60.433 -shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
60.434 -apply(rule exI[of _ "root tr'"])
60.435 -using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
60.436 -
60.437 -lemma dtree_subtr:
60.438 -assumes "dtree tr1" and "subtr ns tr tr1"
60.439 -shows "dtree tr"
60.440 -proof-
60.441 - have "(\<exists> ns tr1. dtree tr1 \<and> subtr ns tr tr1) \<Longrightarrow> dtree tr"
60.442 - proof (induct rule: dtree_raw_coind)
60.443 - case (Hyp tr)
60.444 - then obtain ns tr1 where tr1: "dtree tr1" and tr_tr1: "subtr ns tr tr1" by auto
60.445 - show ?case unfolding lift_def proof safe
60.446 - show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using dtree_subtr_P[OF tr1 tr_tr1] .
60.447 - next
60.448 - show "inj_on root (Inr -` cont tr)" using dtree_subtr_inj_on[OF tr1 tr_tr1] .
60.449 - next
60.450 - fix tr' assume tr': "Inr tr' \<in> cont tr"
60.451 - have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
60.452 - have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
60.453 - thus "\<exists>ns' tr1. dtree tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
60.454 - qed
60.455 - qed
60.456 - thus ?thesis using assms by auto
60.457 -qed
60.458 -
60.459 -
60.460 -subsection{* Default trees *}
60.461 -
60.462 -(* Pick a left-hand side of a production for each nonterminal *)
60.463 -definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
60.464 -
60.465 -lemma S_P: "(n, S n) \<in> P"
60.466 -using used unfolding S_def by(rule someI_ex)
60.467 -
60.468 -lemma finite_S: "finite (S n)"
60.469 -using S_P finite_in_P by auto
60.470 -
60.471 -
60.472 -(* The default tree of a nonterminal *)
60.473 -definition deftr :: "N \<Rightarrow> Tree" where
60.474 -"deftr \<equiv> unfold id S"
60.475 -
60.476 -lemma deftr_simps[simp]:
60.477 -"root (deftr n) = n"
60.478 -"cont (deftr n) = image (id \<oplus> deftr) (S n)"
60.479 -using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
60.480 -unfolding deftr_def by simp_all
60.481 -
60.482 -lemmas root_deftr = deftr_simps(1)
60.483 -lemmas cont_deftr = deftr_simps(2)
60.484 -
60.485 -lemma root_o_deftr[simp]: "root o deftr = id"
60.486 -by (rule ext, auto)
60.487 -
60.488 -lemma dtree_deftr: "dtree (deftr n)"
60.489 -proof-
60.490 - {fix tr assume "\<exists> n. tr = deftr n" hence "dtree tr"
60.491 - apply(induct rule: dtree_raw_coind) apply safe
60.492 - unfolding deftr_simps image_compose[symmetric] sum_map.comp id_o
60.493 - root_o_deftr sum_map.id image_id id_apply apply(rule S_P)
60.494 - unfolding inj_on_def lift_def by auto
60.495 - }
60.496 - thus ?thesis by auto
60.497 -qed
60.498 -
60.499 -
60.500 -subsection{* Hereditary substitution *}
60.501 -
60.502 -(* Auxiliary concept: The root-ommiting frontier: *)
60.503 -definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
60.504 -definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
60.505 -
60.506 -context
60.507 -fixes tr0 :: Tree
60.508 -begin
60.509 -
60.510 -definition "hsubst_r tr \<equiv> root tr"
60.511 -definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
60.512 -
60.513 -(* Hereditary substitution: *)
60.514 -definition hsubst :: "Tree \<Rightarrow> Tree" where
60.515 -"hsubst \<equiv> unfold hsubst_r hsubst_c"
60.516 -
60.517 -lemma finite_hsubst_c: "finite (hsubst_c n)"
60.518 -unfolding hsubst_c_def by (metis finite_cont)
60.519 -
60.520 -lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
60.521 -using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
60.522 -
60.523 -lemma root_o_subst[simp]: "root o hsubst = root"
60.524 -unfolding comp_def root_hsubst ..
60.525 -
60.526 -lemma cont_hsubst_eq[simp]:
60.527 -assumes "root tr = root tr0"
60.528 -shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
60.529 -apply(subst id_o[symmetric, of id]) unfolding id_o
60.530 -using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
60.531 -unfolding hsubst_def hsubst_c_def using assms by simp
60.532 -
60.533 -lemma hsubst_eq:
60.534 -assumes "root tr = root tr0"
60.535 -shows "hsubst tr = hsubst tr0"
60.536 -apply(rule Tree_cong) using assms cont_hsubst_eq by auto
60.537 -
60.538 -lemma cont_hsubst_neq[simp]:
60.539 -assumes "root tr \<noteq> root tr0"
60.540 -shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
60.541 -apply(subst id_o[symmetric, of id]) unfolding id_o
60.542 -using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
60.543 -unfolding hsubst_def hsubst_c_def using assms by simp
60.544 -
60.545 -lemma Inl_cont_hsubst_eq[simp]:
60.546 -assumes "root tr = root tr0"
60.547 -shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
60.548 -unfolding cont_hsubst_eq[OF assms] by simp
60.549 -
60.550 -lemma Inr_cont_hsubst_eq[simp]:
60.551 -assumes "root tr = root tr0"
60.552 -shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
60.553 -unfolding cont_hsubst_eq[OF assms] by simp
60.554 -
60.555 -lemma Inl_cont_hsubst_neq[simp]:
60.556 -assumes "root tr \<noteq> root tr0"
60.557 -shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
60.558 -unfolding cont_hsubst_neq[OF assms] by simp
60.559 -
60.560 -lemma Inr_cont_hsubst_neq[simp]:
60.561 -assumes "root tr \<noteq> root tr0"
60.562 -shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
60.563 -unfolding cont_hsubst_neq[OF assms] by simp
60.564 -
60.565 -lemma dtree_hsubst:
60.566 -assumes tr0: "dtree tr0" and tr: "dtree tr"
60.567 -shows "dtree (hsubst tr)"
60.568 -proof-
60.569 - {fix tr1 have "(\<exists> tr. dtree tr \<and> tr1 = hsubst tr) \<Longrightarrow> dtree tr1"
60.570 - proof (induct rule: dtree_raw_coind)
60.571 - case (Hyp tr1) then obtain tr
60.572 - where dtr: "dtree tr" and tr1: "tr1 = hsubst tr" by auto
60.573 - show ?case unfolding lift_def tr1 proof safe
60.574 - show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
60.575 - unfolding tr1 apply(cases "root tr = root tr0")
60.576 - using dtree_P[OF dtr] dtree_P[OF tr0]
60.577 - by (auto simp add: image_compose[symmetric] sum_map.comp)
60.578 - show "inj_on root (Inr -` cont (hsubst tr))"
60.579 - apply(cases "root tr = root tr0") using dtree_inj_on[OF dtr] dtree_inj_on[OF tr0]
60.580 - unfolding inj_on_def by (auto, blast)
60.581 - fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
60.582 - thus "\<exists>tra. dtree tra \<and> tr' = hsubst tra"
60.583 - apply(cases "root tr = root tr0", simp_all)
60.584 - apply (metis dtree_lift lift_def tr0)
60.585 - by (metis dtr dtree_lift lift_def)
60.586 - qed
60.587 - qed
60.588 - }
60.589 - thus ?thesis using assms by blast
60.590 -qed
60.591 -
60.592 -lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
60.593 -unfolding inFrr_def Frr_def Fr_def by auto
60.594 -
60.595 -lemma inFr_hsubst_imp:
60.596 -assumes "inFr ns (hsubst tr) t"
60.597 -shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
60.598 - inFr (ns - {root tr0}) tr t"
60.599 -proof-
60.600 - {fix tr1
60.601 - have "inFr ns tr1 t \<Longrightarrow>
60.602 - (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
60.603 - inFr (ns - {root tr0}) tr t))"
60.604 - proof(induct rule: inFr.induct)
60.605 - case (Base tr1 ns t tr)
60.606 - hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
60.607 - by auto
60.608 - show ?case
60.609 - proof(cases "root tr1 = root tr0")
60.610 - case True
60.611 - hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
60.612 - thus ?thesis by simp
60.613 - next
60.614 - case False
60.615 - hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
60.616 - by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
60.617 - thus ?thesis by simp
60.618 - qed
60.619 - next
60.620 - case (Ind tr1 ns tr1' t) note IH = Ind(4)
60.621 - have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
60.622 - and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
60.623 - have rtr1: "root tr1 = root tr" unfolding tr1 by simp
60.624 - show ?case
60.625 - proof(cases "root tr1 = root tr0")
60.626 - case True
60.627 - then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
60.628 - using tr1'_tr1 unfolding tr1 by auto
60.629 - show ?thesis using IH[OF tr1'] proof (elim disjE)
60.630 - assume "inFr (ns - {root tr0}) tr' t"
60.631 - thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
60.632 - qed auto
60.633 - next
60.634 - case False
60.635 - then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
60.636 - using tr1'_tr1 unfolding tr1 by auto
60.637 - show ?thesis using IH[OF tr1'] proof (elim disjE)
60.638 - assume "inFr (ns - {root tr0}) tr' t"
60.639 - thus ?thesis using tr'_tr unfolding inFrr_def
60.640 - by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
60.641 - qed auto
60.642 - qed
60.643 - qed
60.644 - }
60.645 - thus ?thesis using assms by auto
60.646 -qed
60.647 -
60.648 -lemma inFr_hsubst_notin:
60.649 -assumes "inFr ns tr t" and "root tr0 \<notin> ns"
60.650 -shows "inFr ns (hsubst tr) t"
60.651 -using assms apply(induct rule: inFr.induct)
60.652 -apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
60.653 -by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
60.654 -
60.655 -lemma inFr_hsubst_minus:
60.656 -assumes "inFr (ns - {root tr0}) tr t"
60.657 -shows "inFr ns (hsubst tr) t"
60.658 -proof-
60.659 - have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
60.660 - using inFr_hsubst_notin[OF assms] by simp
60.661 - show ?thesis using inFr_mono[OF 1] by auto
60.662 -qed
60.663 -
60.664 -lemma inFr_self_hsubst:
60.665 -assumes "root tr0 \<in> ns"
60.666 -shows
60.667 -"inFr ns (hsubst tr0) t \<longleftrightarrow>
60.668 - t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
60.669 -(is "?A \<longleftrightarrow> ?B \<or> ?C")
60.670 -apply(intro iffI)
60.671 -apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
60.672 - assume ?B thus ?A apply(intro inFr.Base) using assms by auto
60.673 -next
60.674 - assume ?C then obtain tr where
60.675 - tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
60.676 - unfolding inFrr_def by auto
60.677 - def tr1 \<equiv> "hsubst tr"
60.678 - have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
60.679 - have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
60.680 - thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
60.681 -qed
60.682 -
60.683 -theorem Fr_self_hsubst:
60.684 -assumes "root tr0 \<in> ns"
60.685 -shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
60.686 -using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
60.687 -
60.688 -end (* context *)
60.689 -
60.690 -
60.691 -subsection{* Regular trees *}
60.692 -
60.693 -hide_const regular
60.694 -
60.695 -definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
60.696 -definition "regular tr \<equiv> \<exists> f. reg f tr"
60.697 -
60.698 -lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
60.699 -unfolding reg_def using subtr_mono by (metis subset_UNIV)
60.700 -
60.701 -lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
60.702 -unfolding regular_def proof safe
60.703 - fix f assume f: "reg f tr"
60.704 - def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
60.705 - show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
60.706 - apply(rule exI[of _ g])
60.707 - using f deftr_simps(1) unfolding g_def reg_def apply safe
60.708 - apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
60.709 - by (metis (full_types) inItr_subtr subtr_subtr2)
60.710 -qed auto
60.711 -
60.712 -lemma reg_root:
60.713 -assumes "reg f tr"
60.714 -shows "f (root tr) = tr"
60.715 -using assms unfolding reg_def
60.716 -by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
60.717 -
60.718 -
60.719 -lemma reg_Inr_cont:
60.720 -assumes "reg f tr" and "Inr tr' \<in> cont tr"
60.721 -shows "reg f tr'"
60.722 -by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
60.723 -
60.724 -lemma reg_subtr:
60.725 -assumes "reg f tr" and "subtr ns tr' tr"
60.726 -shows "reg f tr'"
60.727 -using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
60.728 -by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
60.729 -
60.730 -lemma regular_subtr:
60.731 -assumes r: "regular tr" and s: "subtr ns tr' tr"
60.732 -shows "regular tr'"
60.733 -using r reg_subtr[OF _ s] unfolding regular_def by auto
60.734 -
60.735 -lemma subtr_deftr:
60.736 -assumes "subtr ns tr' (deftr n)"
60.737 -shows "tr' = deftr (root tr')"
60.738 -proof-
60.739 - {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
60.740 - apply (induct rule: subtr.induct)
60.741 - proof(metis (lifting) deftr_simps(1), safe)
60.742 - fix tr3 ns tr1 tr2 n
60.743 - assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
60.744 - and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
60.745 - and 3: "Inr tr2 \<in> cont (deftr n)"
60.746 - have "tr2 \<in> deftr ` UNIV"
60.747 - using 3 unfolding deftr_simps image_def
60.748 - by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
60.749 - iso_tuple_UNIV_I)
60.750 - then obtain n where "tr2 = deftr n" by auto
60.751 - thus "tr1 = deftr (root tr1)" using IH by auto
60.752 - qed
60.753 - }
60.754 - thus ?thesis using assms by auto
60.755 -qed
60.756 -
60.757 -lemma reg_deftr: "reg deftr (deftr n)"
60.758 -unfolding reg_def using subtr_deftr by auto
60.759 -
60.760 -lemma dtree_subtrOf_Union:
60.761 -assumes "dtree tr"
60.762 -shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
60.763 - \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
60.764 -unfolding Union_eq Bex_def mem_Collect_eq proof safe
60.765 - fix x xa tr'
60.766 - assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
60.767 - show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
60.768 - apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
60.769 - apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
60.770 - by (metis (lifting) assms subtrOf_root tr'_tr x)
60.771 -next
60.772 - fix x X n ttr
60.773 - assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
60.774 - show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
60.775 - apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
60.776 - apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
60.777 - using x .
60.778 -qed
60.779 -
60.780 -
60.781 -
60.782 -
60.783 -subsection {* Paths in a regular tree *}
60.784 -
60.785 -inductive path :: "(N \<Rightarrow> Tree) \<Rightarrow> N list \<Rightarrow> bool" for f where
60.786 -Base: "path f [n]"
60.787 -|
60.788 -Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
60.789 - \<Longrightarrow> path f (n # n1 # nl)"
60.790 -
60.791 -lemma path_NE:
60.792 -assumes "path f nl"
60.793 -shows "nl \<noteq> Nil"
60.794 -using assms apply(induct rule: path.induct) by auto
60.795 -
60.796 -lemma path_post:
60.797 -assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
60.798 -shows "path f nl"
60.799 -proof-
60.800 - obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
60.801 - show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
60.802 -qed
60.803 -
60.804 -lemma path_post_concat:
60.805 -assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
60.806 -shows "path f nl2"
60.807 -using assms apply (induct nl1)
60.808 -apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
60.809 -
60.810 -lemma path_concat:
60.811 -assumes "path f nl1" and "path f ((last nl1) # nl2)"
60.812 -shows "path f (nl1 @ nl2)"
60.813 -using assms apply(induct rule: path.induct) apply simp
60.814 -by (metis append_Cons last.simps list.simps(3) path.Ind)
60.815 -
60.816 -lemma path_distinct:
60.817 -assumes "path f nl"
60.818 -shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
60.819 - set nl' \<subseteq> set nl \<and> distinct nl'"
60.820 -using assms proof(induct rule: length_induct)
60.821 - case (1 nl) hence p_nl: "path f nl" by simp
60.822 - then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
60.823 - show ?case
60.824 - proof(cases nl1)
60.825 - case Nil
60.826 - show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
60.827 - next
60.828 - case (Cons n1 nl2)
60.829 - hence p1: "path f nl1" by (metis list.simps nl p_nl path_post)
60.830 - show ?thesis
60.831 - proof(cases "n \<in> set nl1")
60.832 - case False
60.833 - obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
60.834 - l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
60.835 - and s_nl1': "set nl1' \<subseteq> set nl1"
60.836 - using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
60.837 - obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
60.838 - unfolding Cons by(cases nl1', auto)
60.839 - show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
60.840 - show "path f (n # nl1')" unfolding nl1'
60.841 - apply(rule path.Ind, metis nl1' p1')
60.842 - by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
60.843 - qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
60.844 - next
60.845 - case True
60.846 - then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
60.847 - by (metis split_list)
60.848 - have p12: "path f (n # nl12)"
60.849 - apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
60.850 - obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
60.851 - l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
60.852 - and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
60.853 - using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
60.854 - thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
60.855 - qed
60.856 - qed
60.857 -qed
60.858 -
60.859 -lemma path_subtr:
60.860 -assumes f: "\<And> n. root (f n) = n"
60.861 -and p: "path f nl"
60.862 -shows "subtr (set nl) (f (last nl)) (f (hd nl))"
60.863 -using p proof (induct rule: path.induct)
60.864 - case (Ind n1 nl n) let ?ns1 = "insert n1 (set nl)"
60.865 - have "path f (n1 # nl)"
60.866 - and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
60.867 - and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
60.868 - hence fn1_flast: "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
60.869 - by (metis subset_insertI subtr_mono)
60.870 - have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
60.871 - have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
60.872 - using f subtr.Step[OF _ fn1_flast fn1] by auto
60.873 - thus ?case unfolding 1 by simp
60.874 -qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
60.875 -
60.876 -lemma reg_subtr_path_aux:
60.877 -assumes f: "reg f tr" and n: "subtr ns tr1 tr"
60.878 -shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
60.879 -using n f proof(induct rule: subtr.induct)
60.880 - case (Refl tr ns)
60.881 - thus ?case
60.882 - apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
60.883 -next
60.884 - case (Step tr ns tr2 tr1)
60.885 - hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
60.886 - and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
60.887 - have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
60.888 - by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
60.889 - obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
60.890 - and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
60.891 - have 0: "path f (root tr # nl)" apply (subst path.simps)
60.892 - using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv)
60.893 - show ?case apply(rule exI[of _ "(root tr) # nl"])
60.894 - using 0 reg_root tr last_nl nl path_NE rtr set by auto
60.895 -qed
60.896 -
60.897 -lemma reg_subtr_path:
60.898 -assumes f: "reg f tr" and n: "subtr ns tr1 tr"
60.899 -shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
60.900 -using reg_subtr_path_aux[OF assms] path_distinct[of f]
60.901 -by (metis (lifting) order_trans)
60.902 -
60.903 -lemma subtr_iff_path:
60.904 -assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
60.905 -shows "subtr ns tr1 tr \<longleftrightarrow>
60.906 - (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
60.907 -proof safe
60.908 - fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
60.909 - have "subtr (set nl) (f (last nl)) (f (hd nl))"
60.910 - apply(rule path_subtr) using p f by simp_all
60.911 - thus "subtr ns (f (last nl)) (f (hd nl))"
60.912 - using subtr_mono nl by auto
60.913 -qed(insert reg_subtr_path[OF r], auto)
60.914 -
60.915 -lemma inFr_iff_path:
60.916 -assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
60.917 -shows
60.918 -"inFr ns tr t \<longleftrightarrow>
60.919 - (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
60.920 - set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
60.921 -apply safe
60.922 -apply (metis (no_types) inFr_subtr r reg_subtr_path)
60.923 -by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
60.924 -
60.925 -
60.926 -
60.927 -subsection{* The regular cut of a tree *}
60.928 -
60.929 -context fixes tr0 :: Tree
60.930 -begin
60.931 -
60.932 -(* Picking a subtree of a certain root: *)
60.933 -definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
60.934 -
60.935 -lemma pick:
60.936 -assumes "inItr UNIV tr0 n"
60.937 -shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
60.938 -proof-
60.939 - have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
60.940 - using assms by (metis (lifting) inItr_subtr)
60.941 - thus ?thesis unfolding pick_def by(rule someI_ex)
60.942 -qed
60.943 -
60.944 -lemmas subtr_pick = pick[THEN conjunct1]
60.945 -lemmas root_pick = pick[THEN conjunct2]
60.946 -
60.947 -lemma dtree_pick:
60.948 -assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n"
60.949 -shows "dtree (pick n)"
60.950 -using dtree_subtr[OF tr0 subtr_pick[OF n]] .
60.951 -
60.952 -definition "regOf_r n \<equiv> root (pick n)"
60.953 -definition "regOf_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
60.954 -
60.955 -(* The regular tree of a function: *)
60.956 -definition regOf :: "N \<Rightarrow> Tree" where
60.957 -"regOf \<equiv> unfold regOf_r regOf_c"
60.958 -
60.959 -lemma finite_regOf_c: "finite (regOf_c n)"
60.960 -unfolding regOf_c_def by (metis finite_cont finite_imageI)
60.961 -
60.962 -lemma root_regOf_pick: "root (regOf n) = root (pick n)"
60.963 -using unfold(1)[of regOf_r regOf_c n] unfolding regOf_def regOf_r_def by simp
60.964 -
60.965 -lemma root_regOf[simp]:
60.966 -assumes "inItr UNIV tr0 n"
60.967 -shows "root (regOf n) = n"
60.968 -unfolding root_regOf_pick root_pick[OF assms] ..
60.969 -
60.970 -lemma cont_regOf[simp]:
60.971 -"cont (regOf n) = (id \<oplus> (regOf o root)) ` cont (pick n)"
60.972 -apply(subst id_o[symmetric, of id]) unfolding sum_map.comp[symmetric]
60.973 -unfolding image_compose unfolding regOf_c_def[symmetric]
60.974 -using unfold(2)[of regOf_c n regOf_r, OF finite_regOf_c]
60.975 -unfolding regOf_def ..
60.976 -
60.977 -lemma Inl_cont_regOf[simp]:
60.978 -"Inl -` (cont (regOf n)) = Inl -` (cont (pick n))"
60.979 -unfolding cont_regOf by simp
60.980 -
60.981 -lemma Inr_cont_regOf:
60.982 -"Inr -` (cont (regOf n)) = (regOf \<circ> root) ` (Inr -` cont (pick n))"
60.983 -unfolding cont_regOf by simp
60.984 -
60.985 -lemma subtr_regOf:
60.986 -assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (regOf n)"
60.987 -shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1"
60.988 -proof-
60.989 - {fix tr ns assume "subtr UNIV tr1 tr"
60.990 - hence "tr = regOf n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1)"
60.991 - proof (induct rule: subtr_UNIV_inductL)
60.992 - case (Step tr2 tr1 tr)
60.993 - show ?case proof
60.994 - assume "tr = regOf n"
60.995 - then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
60.996 - and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = regOf n1"
60.997 - using Step by auto
60.998 - obtain tr2' where tr2: "tr2 = regOf (root tr2')"
60.999 - and tr2': "Inr tr2' \<in> cont (pick n1)"
60.1000 - using tr2 Inr_cont_regOf[of n1]
60.1001 - unfolding tr1 image_def o_def using vimage_eq by auto
60.1002 - have "inItr UNIV tr0 (root tr2')"
60.1003 - using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
60.1004 - thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = regOf n2" using tr2 by blast
60.1005 - qed
60.1006 - qed(insert n, auto)
60.1007 - }
60.1008 - thus ?thesis using assms by auto
60.1009 -qed
60.1010 -
60.1011 -lemma root_regOf_root:
60.1012 -assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
60.1013 -shows "(id \<oplus> (root \<circ> regOf \<circ> root)) t_tr = (id \<oplus> root) t_tr"
60.1014 -using assms apply(cases t_tr)
60.1015 - apply (metis (lifting) sum_map.simps(1))
60.1016 - using pick regOf_def regOf_r_def unfold(1)
60.1017 - inItr.Base o_apply subtr_StepL subtr_inItr sum_map.simps(2)
60.1018 - by (metis UNIV_I)
60.1019 -
60.1020 -lemma regOf_P:
60.1021 -assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n"
60.1022 -shows "(n, (id \<oplus> root) ` cont (regOf n)) \<in> P" (is "?L \<in> P")
60.1023 -proof-
60.1024 - have "?L = (n, (id \<oplus> root) ` cont (pick n))"
60.1025 - unfolding cont_regOf image_compose[symmetric] sum_map.comp id_o o_assoc
60.1026 - unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
60.1027 - by(rule root_regOf_root[OF n])
60.1028 - moreover have "... \<in> P" by (metis (lifting) dtree_pick root_pick dtree_P n tr0)
60.1029 - ultimately show ?thesis by simp
60.1030 -qed
60.1031 -
60.1032 -lemma dtree_regOf:
60.1033 -assumes tr0: "dtree tr0" and "inItr UNIV tr0 n"
60.1034 -shows "dtree (regOf n)"
60.1035 -proof-
60.1036 - {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = regOf n \<Longrightarrow> dtree tr"
60.1037 - proof (induct rule: dtree_raw_coind)
60.1038 - case (Hyp tr)
60.1039 - then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" by auto
60.1040 - show ?case unfolding lift_def apply safe
60.1041 - apply (metis (lifting) regOf_P root_regOf n tr tr0)
60.1042 - unfolding tr Inr_cont_regOf unfolding inj_on_def apply clarsimp using root_regOf
60.1043 - apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
60.1044 - by (metis n subtr.Refl subtr_StepL subtr_regOf tr UNIV_I)
60.1045 - qed
60.1046 - }
60.1047 - thus ?thesis using assms by blast
60.1048 -qed
60.1049 -
60.1050 -(* The regular cut of a tree: *)
60.1051 -definition "rcut \<equiv> regOf (root tr0)"
60.1052 -
60.1053 -theorem reg_rcut: "reg regOf rcut"
60.1054 -unfolding reg_def rcut_def
60.1055 -by (metis inItr.Base root_regOf subtr_regOf UNIV_I)
60.1056 -
60.1057 -lemma rcut_reg:
60.1058 -assumes "reg regOf tr0"
60.1059 -shows "rcut = tr0"
60.1060 -using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
60.1061 -
60.1062 -theorem rcut_eq: "rcut = tr0 \<longleftrightarrow> reg regOf tr0"
60.1063 -using reg_rcut rcut_reg by metis
60.1064 -
60.1065 -theorem regular_rcut: "regular rcut"
60.1066 -using reg_rcut unfolding regular_def by blast
60.1067 -
60.1068 -theorem Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
60.1069 -proof safe
60.1070 - fix t assume "t \<in> Fr UNIV rcut"
60.1071 - then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (regOf (root tr0))"
60.1072 - using Fr_subtr[of UNIV "regOf (root tr0)"] unfolding rcut_def
60.1073 - by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
60.1074 - obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" using tr
60.1075 - by (metis (lifting) inItr.Base subtr_regOf UNIV_I)
60.1076 - have "Inl t \<in> cont (pick n)" using t using Inl_cont_regOf[of n] unfolding tr
60.1077 - by (metis (lifting) vimageD vimageI2)
60.1078 - moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
60.1079 - ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
60.1080 -qed
60.1081 -
60.1082 -theorem dtree_rcut:
60.1083 -assumes "dtree tr0"
60.1084 -shows "dtree rcut"
60.1085 -unfolding rcut_def using dtree_regOf[OF assms inItr.Base] by simp
60.1086 -
60.1087 -theorem root_rcut[simp]: "root rcut = root tr0"
60.1088 -unfolding rcut_def
60.1089 -by (metis (lifting) root_regOf inItr.Base reg_def reg_root subtr_rootR_in)
60.1090 -
60.1091 -end (* context *)
60.1092 -
60.1093 -
60.1094 -subsection{* Recursive description of the regular tree frontiers *}
60.1095 -
60.1096 -lemma regular_inFr:
60.1097 -assumes r: "regular tr" and In: "root tr \<in> ns"
60.1098 -and t: "inFr ns tr t"
60.1099 -shows "t \<in> Inl -` (cont tr) \<or>
60.1100 - (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
60.1101 -(is "?L \<or> ?R")
60.1102 -proof-
60.1103 - obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
60.1104 - using r unfolding regular_def2 by auto
60.1105 - obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
60.1106 - and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
60.1107 - using t unfolding inFr_iff_path[OF r f] by auto
60.1108 - obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
60.1109 - hence f_n: "f n = tr" using hd_nl by simp
60.1110 - have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
60.1111 - show ?thesis
60.1112 - proof(cases nl1)
60.1113 - case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
60.1114 - hence ?L using t_tr1 by simp thus ?thesis by simp
60.1115 - next
60.1116 - case (Cons n1 nl2) note nl1 = Cons
60.1117 - have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
60.1118 - have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
60.1119 - using path.simps[of f nl] p f_n unfolding nl nl1 by auto
60.1120 - have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
60.1121 - have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
60.1122 - apply(intro exI[of _ nl1], intro exI[of _ tr1])
60.1123 - using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
60.1124 - have root_tr: "root tr = n" by (metis f f_n)
60.1125 - have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
60.1126 - using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
60.1127 - thus ?thesis using n1_tr by auto
60.1128 - qed
60.1129 -qed
60.1130 -
60.1131 -theorem regular_Fr:
60.1132 -assumes r: "regular tr" and In: "root tr \<in> ns"
60.1133 -shows "Fr ns tr =
60.1134 - Inl -` (cont tr) \<union>
60.1135 - \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
60.1136 -unfolding Fr_def
60.1137 -using In inFr.Base regular_inFr[OF assms] apply safe
60.1138 -apply (simp, metis (full_types) UnionI mem_Collect_eq)
60.1139 -apply simp
60.1140 -by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
60.1141 -
60.1142 -
60.1143 -subsection{* The generated languages *}
60.1144 -
60.1145 -(* The (possibly inifinite tree) generated language *)
60.1146 -definition "L ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n}"
60.1147 -
60.1148 -(* The regular-tree generated language *)
60.1149 -definition "Lr ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n \<and> regular tr}"
60.1150 -
60.1151 -theorem L_rec_notin:
60.1152 -assumes "n \<notin> ns"
60.1153 -shows "L ns n = {{}}"
60.1154 -using assms unfolding L_def apply safe
60.1155 - using not_root_Fr apply force
60.1156 - apply(rule exI[of _ "deftr n"])
60.1157 - by (metis (no_types) dtree_deftr not_root_Fr root_deftr)
60.1158 -
60.1159 -theorem Lr_rec_notin:
60.1160 -assumes "n \<notin> ns"
60.1161 -shows "Lr ns n = {{}}"
60.1162 -using assms unfolding Lr_def apply safe
60.1163 - using not_root_Fr apply force
60.1164 - apply(rule exI[of _ "deftr n"])
60.1165 - by (metis (no_types) regular_def dtree_deftr not_root_Fr reg_deftr root_deftr)
60.1166 -
60.1167 -lemma dtree_subtrOf:
60.1168 -assumes "dtree tr" and "Inr n \<in> prodOf tr"
60.1169 -shows "dtree (subtrOf tr n)"
60.1170 -by (metis assms dtree_lift lift_def subtrOf)
60.1171 -
60.1172 -theorem Lr_rec_in:
60.1173 -assumes n: "n \<in> ns"
60.1174 -shows "Lr ns n \<subseteq>
60.1175 -{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
60.1176 - (n,tns) \<in> P \<and>
60.1177 - (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
60.1178 -(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
60.1179 -proof safe
60.1180 - fix ts assume "ts \<in> Lr ns n"
60.1181 - then obtain tr where dtr: "dtree tr" and r: "root tr = n" and tr: "regular tr"
60.1182 - and ts: "ts = Fr ns tr" unfolding Lr_def by auto
60.1183 - def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
60.1184 - def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
60.1185 - show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
60.1186 - apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
60.1187 - show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
60.1188 - unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
60.1189 - unfolding tns_def K_def r[symmetric]
60.1190 - unfolding Inl_prodOf dtree_subtrOf_Union[OF dtr] ..
60.1191 - show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using dtree_P[OF dtr] .
60.1192 - fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
60.1193 - unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
60.1194 - using dtr tr apply(intro conjI refl) unfolding tns_def
60.1195 - apply(erule dtree_subtrOf[OF dtr])
60.1196 - apply (metis subtrOf)
60.1197 - by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
60.1198 - qed
60.1199 -qed
60.1200 -
60.1201 -lemma hsubst_aux:
60.1202 -fixes n ftr tns
60.1203 -assumes n: "n \<in> ns" and tns: "finite tns" and
60.1204 -1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> dtree (ftr n')"
60.1205 -defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)" defines "tr' \<equiv> hsubst tr tr"
60.1206 -shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
60.1207 -(is "_ = ?B") proof-
60.1208 - have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
60.1209 - unfolding tr_def using tns by auto
60.1210 - have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
60.1211 - unfolding Frr_def ctr by auto
60.1212 - have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
60.1213 - using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
60.1214 - also have "... = ?B" unfolding ctr Frr by simp
60.1215 - finally show ?thesis .
60.1216 -qed
60.1217 -
60.1218 -theorem L_rec_in:
60.1219 -assumes n: "n \<in> ns"
60.1220 -shows "
60.1221 -{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
60.1222 - (n,tns) \<in> P \<and>
60.1223 - (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
60.1224 - \<subseteq> L ns n"
60.1225 -proof safe
60.1226 - fix tns K
60.1227 - assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
60.1228 - {fix n' assume "Inr n' \<in> tns"
60.1229 - hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
60.1230 - hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> dtree tr' \<and> root tr' = n'"
60.1231 - unfolding L_def mem_Collect_eq by auto
60.1232 - }
60.1233 - then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
60.1234 - K n' = Fr (ns - {n}) (ftr n') \<and> dtree (ftr n') \<and> root (ftr n') = n'"
60.1235 - by metis
60.1236 - def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)" def tr' \<equiv> "hsubst tr tr"
60.1237 - have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
60.1238 - unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
60.1239 - have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
60.1240 - unfolding ctr apply simp apply simp apply safe
60.1241 - using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
60.1242 - have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
60.1243 - using 0 by auto
60.1244 - have dtr: "dtree tr" apply(rule dtree.Tree)
60.1245 - apply (metis (lifting) P prtr rtr)
60.1246 - unfolding inj_on_def ctr lift_def using 0 by auto
60.1247 - hence dtr': "dtree tr'" unfolding tr'_def by (metis dtree_hsubst)
60.1248 - have tns: "finite tns" using finite_in_P P by simp
60.1249 - have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
60.1250 - unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
60.1251 - using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
60.1252 - thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
60.1253 -qed
60.1254 -
60.1255 -lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
60.1256 -by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
60.1257 -
60.1258 -function LL where
60.1259 -"LL ns n =
60.1260 - (if n \<notin> ns then {{}} else
60.1261 - {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
60.1262 - (n,tns) \<in> P \<and>
60.1263 - (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
60.1264 -by(pat_completeness, auto)
60.1265 -termination apply(relation "inv_image (measure card) fst")
60.1266 -using card_N by auto
60.1267 -
60.1268 -declare LL.simps[code] (* TODO: Does code generation for LL work? *)
60.1269 -declare LL.simps[simp del]
60.1270 -
60.1271 -theorem Lr_LL: "Lr ns n \<subseteq> LL ns n"
60.1272 -proof (induct ns arbitrary: n rule: measure_induct[of card])
60.1273 - case (1 ns n) show ?case proof(cases "n \<in> ns")
60.1274 - case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
60.1275 - next
60.1276 - case True show ?thesis apply(rule subset_trans)
60.1277 - using Lr_rec_in[OF True] apply assumption
60.1278 - unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
60.1279 - fix tns K
60.1280 - assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
60.1281 - assume "(n, tns) \<in> P"
60.1282 - and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
60.1283 - thus "\<exists>tnsa Ka.
60.1284 - Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
60.1285 - Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
60.1286 - (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
60.1287 - apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
60.1288 - qed
60.1289 - qed
60.1290 -qed
60.1291 -
60.1292 -theorem LL_L: "LL ns n \<subseteq> L ns n"
60.1293 -proof (induct ns arbitrary: n rule: measure_induct[of card])
60.1294 - case (1 ns n) show ?case proof(cases "n \<in> ns")
60.1295 - case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
60.1296 - next
60.1297 - case True show ?thesis apply(rule subset_trans)
60.1298 - prefer 2 using L_rec_in[OF True] apply assumption
60.1299 - unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
60.1300 - fix tns K
60.1301 - assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
60.1302 - assume "(n, tns) \<in> P"
60.1303 - and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
60.1304 - thus "\<exists>tnsa Ka.
60.1305 - Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
60.1306 - Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
60.1307 - (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
60.1308 - apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
60.1309 - qed
60.1310 - qed
60.1311 -qed
60.1312 -
60.1313 -(* The subsumpsion relation between languages *)
60.1314 -definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
60.1315 -
60.1316 -lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
60.1317 -unfolding subs_def by auto
60.1318 -
60.1319 -lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
60.1320 -
60.1321 -lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
60.1322 -unfolding subs_def by (metis subset_trans)
60.1323 -
60.1324 -(* Language equivalence *)
60.1325 -definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
60.1326 -
60.1327 -lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
60.1328 -unfolding leqv_def by auto
60.1329 -
60.1330 -lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
60.1331 -unfolding leqv_def by auto
60.1332 -
60.1333 -lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
60.1334 -
60.1335 -lemma leqv_trans:
60.1336 -assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
60.1337 -shows "leqv L1 L3"
60.1338 -using assms unfolding leqv_def by (metis (lifting) subs_trans)
60.1339 -
60.1340 -lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
60.1341 -unfolding leqv_def by auto
60.1342 -
60.1343 -lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
60.1344 -unfolding leqv_def by auto
60.1345 -
60.1346 -lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
60.1347 -unfolding Lr_def L_def by auto
60.1348 -
60.1349 -lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
60.1350 -unfolding subs_def proof safe
60.1351 - fix ts2 assume "ts2 \<in> L UNIV ts"
60.1352 - then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "dtree tr" and rtr: "root tr = ts"
60.1353 - unfolding L_def by auto
60.1354 - thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
60.1355 - apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
60.1356 - unfolding Lr_def L_def using Fr_rcut dtree_rcut root_rcut regular_rcut by auto
60.1357 -qed
60.1358 -
60.1359 -theorem Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
60.1360 -using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
60.1361 -
60.1362 -theorem LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
60.1363 -by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
60.1364 -
60.1365 -theorem LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
60.1366 -using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
60.1367 -
60.1368 -
60.1369 -end
61.1 --- a/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Parallel.thy Fri Sep 21 16:34:40 2012 +0200
61.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
61.3 @@ -1,152 +0,0 @@
61.4 -(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Parallel.thy
61.5 - Author: Andrei Popescu, TU Muenchen
61.6 - Copyright 2012
61.7 -
61.8 -Parallel composition.
61.9 -*)
61.10 -
61.11 -header {* Parallel Composition *}
61.12 -
61.13 -theory Parallel
61.14 -imports Tree
61.15 -begin
61.16 -
61.17 -
61.18 -consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
61.19 -
61.20 -axiomatization where
61.21 - Nplus_comm: "(a::N) + b = b + (a::N)"
61.22 -and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
61.23 -
61.24 -
61.25 -
61.26 -section{* Parallel composition *}
61.27 -
61.28 -fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
61.29 -fun par_c where
61.30 -"par_c (tr1,tr2) =
61.31 - Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
61.32 - Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
61.33 -
61.34 -declare par_r.simps[simp del] declare par_c.simps[simp del]
61.35 -
61.36 -definition par :: "Tree \<times> Tree \<Rightarrow> Tree" where
61.37 -"par \<equiv> unfold par_r par_c"
61.38 -
61.39 -abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
61.40 -
61.41 -lemma finite_par_c: "finite (par_c (tr1, tr2))"
61.42 -unfolding par_c.simps apply(rule finite_UnI)
61.43 - apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
61.44 - apply(intro finite_imageI finite_cartesian_product finite_vimageI)
61.45 - using finite_cont by auto
61.46 -
61.47 -lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
61.48 -using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
61.49 -
61.50 -lemma cont_par:
61.51 -"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
61.52 -using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
61.53 -unfolding par_def ..
61.54 -
61.55 -lemma Inl_cont_par[simp]:
61.56 -"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
61.57 -unfolding cont_par par_c.simps by auto
61.58 -
61.59 -lemma Inr_cont_par[simp]:
61.60 -"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
61.61 -unfolding cont_par par_c.simps by auto
61.62 -
61.63 -lemma Inl_in_cont_par:
61.64 -"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
61.65 -using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
61.66 -
61.67 -lemma Inr_in_cont_par:
61.68 -"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
61.69 -using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
61.70 -
61.71 -
61.72 -section{* =-coinductive proofs *}
61.73 -
61.74 -(* Detailed proofs of commutativity and associativity: *)
61.75 -theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
61.76 -proof-
61.77 - let ?\<phi> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
61.78 - {fix trA trB
61.79 - assume "?\<phi> trA trB" hence "trA = trB"
61.80 - proof (induct rule: Tree_coind, safe)
61.81 - fix tr1 tr2
61.82 - show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
61.83 - unfolding root_par by (rule Nplus_comm)
61.84 - next
61.85 - fix tr1 tr2 :: Tree
61.86 - let ?trA = "tr1 \<parallel> tr2" let ?trB = "tr2 \<parallel> tr1"
61.87 - show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
61.88 - unfolding lift2_def proof(intro conjI allI impI)
61.89 - fix n show "Inl n \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> Inl n \<in> cont (tr2 \<parallel> tr1)"
61.90 - unfolding Inl_in_cont_par by auto
61.91 - next
61.92 - fix trA' assume "Inr trA' \<in> cont ?trA"
61.93 - then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
61.94 - and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
61.95 - unfolding Inr_in_cont_par by auto
61.96 - thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
61.97 - apply(intro exI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
61.98 - next
61.99 - fix trB' assume "Inr trB' \<in> cont ?trB"
61.100 - then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
61.101 - and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
61.102 - unfolding Inr_in_cont_par by auto
61.103 - thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
61.104 - apply(intro exI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
61.105 - qed
61.106 - qed
61.107 - }
61.108 - thus ?thesis by blast
61.109 -qed
61.110 -
61.111 -theorem par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
61.112 -proof-
61.113 - let ?\<phi> =
61.114 - "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and>
61.115 - trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
61.116 - {fix trA trB
61.117 - assume "?\<phi> trA trB" hence "trA = trB"
61.118 - proof (induct rule: Tree_coind, safe)
61.119 - fix tr1 tr2 tr3
61.120 - show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
61.121 - unfolding root_par by (rule Nplus_assoc)
61.122 - next
61.123 - fix tr1 tr2 tr3
61.124 - let ?trA = "(tr1 \<parallel> tr2) \<parallel> tr3" let ?trB = "tr1 \<parallel> (tr2 \<parallel> tr3)"
61.125 - show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
61.126 - unfolding lift2_def proof(intro conjI allI impI)
61.127 - fix n show "Inl n \<in> (cont ?trA) \<longleftrightarrow> Inl n \<in> (cont ?trB)"
61.128 - unfolding Inl_in_cont_par by simp
61.129 - next
61.130 - fix trA' assume "Inr trA' \<in> cont ?trA"
61.131 - then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
61.132 - and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
61.133 - and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
61.134 - thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
61.135 - apply(intro exI[of _ "tr1' \<parallel> (tr2' \<parallel> tr3')"])
61.136 - unfolding Inr_in_cont_par by auto
61.137 - next
61.138 - fix trB' assume "Inr trB' \<in> cont ?trB"
61.139 - then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
61.140 - and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
61.141 - and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
61.142 - thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
61.143 - apply(intro exI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
61.144 - unfolding Inr_in_cont_par by auto
61.145 - qed
61.146 - qed
61.147 - }
61.148 - thus ?thesis by blast
61.149 -qed
61.150 -
61.151 -
61.152 -
61.153 -
61.154 -
61.155 -end
61.156 \ No newline at end of file
62.1 --- a/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Prelim.thy Fri Sep 21 16:34:40 2012 +0200
62.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
62.3 @@ -1,67 +0,0 @@
62.4 -(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Prelim.thy
62.5 - Author: Andrei Popescu, TU Muenchen
62.6 - Copyright 2012
62.7 -
62.8 -Preliminaries.
62.9 -*)
62.10 -
62.11 -header {* Preliminaries *}
62.12 -
62.13 -theory Prelim
62.14 -imports "../../BNF"
62.15 -begin
62.16 -
62.17 -declare fset_to_fset[simp]
62.18 -
62.19 -lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
62.20 -apply(rule ext) by (simp add: convol_def)
62.21 -
62.22 -abbreviation sm_abbrev (infix "\<oplus>" 60)
62.23 -where "f \<oplus> g \<equiv> Sum_Type.sum_map f g"
62.24 -
62.25 -lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
62.26 -by (cases z) auto
62.27 -
62.28 -lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
62.29 -by (cases z) auto
62.30 -
62.31 -abbreviation sum_case_abbrev ("[[_,_]]" 800)
62.32 -where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
62.33 -
62.34 -lemma inj_Inl[simp]: "inj Inl" unfolding inj_on_def by auto
62.35 -lemma inj_Inr[simp]: "inj Inr" unfolding inj_on_def by auto
62.36 -
62.37 -lemma Inl_oplus_elim:
62.38 -assumes "Inl tr \<in> (id \<oplus> f) ` tns"
62.39 -shows "Inl tr \<in> tns"
62.40 -using assms apply clarify by (case_tac x, auto)
62.41 -
62.42 -lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
62.43 -using Inl_oplus_elim
62.44 -by (metis id_def image_iff sum_map.simps(1))
62.45 -
62.46 -lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
62.47 -using Inl_oplus_iff unfolding vimage_def by auto
62.48 -
62.49 -lemma Inr_oplus_elim:
62.50 -assumes "Inr tr \<in> (id \<oplus> f) ` tns"
62.51 -shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
62.52 -using assms apply clarify by (case_tac x, auto)
62.53 -
62.54 -lemma Inr_oplus_iff[simp]:
62.55 -"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
62.56 -apply (rule iffI)
62.57 - apply (metis Inr_oplus_elim)
62.58 -by (metis image_iff sum_map.simps(2))
62.59 -
62.60 -lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
62.61 -using Inr_oplus_iff unfolding vimage_def by auto
62.62 -
62.63 -lemma Inl_Inr_image_cong:
62.64 -assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
62.65 -shows "A = B"
62.66 -apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
62.67 -
62.68 -
62.69 -
62.70 -end
62.71 \ No newline at end of file
63.1 --- a/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Tree.thy Fri Sep 21 16:34:40 2012 +0200
63.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
63.3 @@ -1,326 +0,0 @@
63.4 -(* Title: HOL/BNF/Examples/Infinite_Derivation_Trees/Tree.thy
63.5 - Author: Andrei Popescu, TU Muenchen
63.6 - Copyright 2012
63.7 -
63.8 -Trees with nonterminal internal nodes and terminal leaves.
63.9 -*)
63.10 -
63.11 -header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
63.12 -
63.13 -theory Tree
63.14 -imports Prelim
63.15 -begin
63.16 -
63.17 -hide_fact (open) Quotient_Product.prod_rel_def
63.18 -
63.19 -typedecl N typedecl T
63.20 -
63.21 -codata_raw Tree: 'Tree = "N \<times> (T + 'Tree) fset"
63.22 -
63.23 -
63.24 -section {* Sugar notations for Tree *}
63.25 -
63.26 -subsection{* Setup for map, set, rel *}
63.27 -
63.28 -(* These should be eventually inferred from compositionality *)
63.29 -
63.30 -lemma pre_Tree_map:
63.31 -"pre_Tree_map f (n, as) = (n, map_fset (id \<oplus> f) as)"
63.32 -unfolding pre_Tree_map_def id_apply
63.33 -sum_map_def by simp
63.34 -
63.35 -lemma pre_Tree_map':
63.36 -"pre_Tree_map f n_as = (fst n_as, map_fset (id \<oplus> f) (snd n_as))"
63.37 -using pre_Tree_map by(cases n_as, simp)
63.38 -
63.39 -
63.40 -definition
63.41 -"llift2 \<phi> as1 as2 \<longleftrightarrow>
63.42 - (\<forall> n. Inl n \<in> fset as1 \<longleftrightarrow> Inl n \<in> fset as2) \<and>
63.43 - (\<forall> tr1. Inr tr1 \<in> fset as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> fset as2 \<and> \<phi> tr1 tr2)) \<and>
63.44 - (\<forall> tr2. Inr tr2 \<in> fset as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> fset as1 \<and> \<phi> tr1 tr2))"
63.45 -
63.46 -lemma pre_Tree_rel: "pre_Tree_rel \<phi> (n1,as1) (n2,as2) \<longleftrightarrow> n1 = n2 \<and> llift2 \<phi> as1 as2"
63.47 -unfolding llift2_def pre_Tree_rel_def sum_rel_def[abs_def] prod_rel_def fset_rel_def split_conv
63.48 -apply (auto split: sum.splits)
63.49 -apply (metis sumE)
63.50 -apply (metis sumE)
63.51 -apply (metis sumE)
63.52 -apply (metis sumE)
63.53 -apply (metis sumE sum.simps(1,2,4))
63.54 -apply (metis sumE sum.simps(1,2,4))
63.55 -done
63.56 -
63.57 -
63.58 -subsection{* Constructors *}
63.59 -
63.60 -definition NNode :: "N \<Rightarrow> (T + Tree)fset \<Rightarrow> Tree"
63.61 -where "NNode n as \<equiv> Tree_ctor (n,as)"
63.62 -
63.63 -lemmas ctor_defs = NNode_def
63.64 -
63.65 -
63.66 -subsection {* Pre-selectors *}
63.67 -
63.68 -(* These are mere auxiliaries *)
63.69 -
63.70 -definition "asNNode tr \<equiv> SOME n_as. NNode (fst n_as) (snd n_as) = tr"
63.71 -lemmas pre_sel_defs = asNNode_def
63.72 -
63.73 -
63.74 -subsection {* Selectors *}
63.75 -
63.76 -(* One for each pair (constructor, constructor argument) *)
63.77 -
63.78 -(* For NNode: *)
63.79 -definition root :: "Tree \<Rightarrow> N" where "root tr = fst (asNNode tr)"
63.80 -definition ccont :: "Tree \<Rightarrow> (T + Tree)fset" where "ccont tr = snd (asNNode tr)"
63.81 -
63.82 -lemmas sel_defs = root_def ccont_def
63.83 -
63.84 -
63.85 -subsection {* Basic properties *}
63.86 -
63.87 -(* Constructors versus selectors *)
63.88 -lemma NNode_surj: "\<exists> n as. NNode n as = tr"
63.89 -unfolding NNode_def
63.90 -by (metis Tree.ctor_dtor pair_collapse)
63.91 -
63.92 -lemma NNode_asNNode:
63.93 -"NNode (fst (asNNode tr)) (snd (asNNode tr)) = tr"
63.94 -proof-
63.95 - obtain n as where "NNode n as = tr" using NNode_surj[of tr] by blast
63.96 - hence "NNode (fst (n,as)) (snd (n,as)) = tr" by simp
63.97 - thus ?thesis unfolding asNNode_def by(rule someI)
63.98 -qed
63.99 -
63.100 -theorem NNode_root_ccont[simp]:
63.101 -"NNode (root tr) (ccont tr) = tr"
63.102 -using NNode_asNNode unfolding root_def ccont_def .
63.103 -
63.104 -(* Constructors *)
63.105 -theorem TTree_simps[simp]:
63.106 -"NNode n as = NNode n' as' \<longleftrightarrow> n = n' \<and> as = as'"
63.107 -unfolding ctor_defs Tree.ctor_inject by auto
63.108 -
63.109 -theorem TTree_cases[elim, case_names NNode Choice]:
63.110 -assumes NNode: "\<And> n as. tr = NNode n as \<Longrightarrow> phi"
63.111 -shows phi
63.112 -proof(cases rule: Tree.ctor_exhaust[of tr])
63.113 - fix x assume "tr = Tree_ctor x"
63.114 - thus ?thesis
63.115 - apply(cases x)
63.116 - using NNode unfolding ctor_defs apply blast
63.117 - done
63.118 -qed
63.119 -
63.120 -(* Constructors versus selectors *)
63.121 -theorem TTree_sel_ctor[simp]:
63.122 -"root (NNode n as) = n"
63.123 -"ccont (NNode n as) = as"
63.124 -unfolding root_def ccont_def
63.125 -by (metis (no_types) NNode_asNNode TTree_simps)+
63.126 -
63.127 -
63.128 -subsection{* Coinduction *}
63.129 -
63.130 -theorem TTree_coind_Node[elim, consumes 1, case_names NNode, induct pred: "HOL.eq"]:
63.131 -assumes phi: "\<phi> tr1 tr2" and
63.132 -NNode: "\<And> n1 n2 as1 as2.
63.133 - \<lbrakk>\<phi> (NNode n1 as1) (NNode n2 as2)\<rbrakk> \<Longrightarrow>
63.134 - n1 = n2 \<and> llift2 \<phi> as1 as2"
63.135 -shows "tr1 = tr2"
63.136 -apply(rule mp[OF Tree.rel_coinduct[of \<phi> tr1 tr2] phi]) proof clarify
63.137 - fix tr1 tr2 assume \<phi>: "\<phi> tr1 tr2"
63.138 - show "pre_Tree_rel \<phi> (Tree_dtor tr1) (Tree_dtor tr2)"
63.139 - apply(cases rule: Tree.ctor_exhaust[of tr1], cases rule: Tree.ctor_exhaust[of tr2])
63.140 - apply (simp add: Tree.dtor_ctor)
63.141 - apply(case_tac x, case_tac xa, simp)
63.142 - unfolding pre_Tree_rel apply(rule NNode) using \<phi> unfolding NNode_def by simp
63.143 -qed
63.144 -
63.145 -theorem TTree_coind[elim, consumes 1, case_names LLift]:
63.146 -assumes phi: "\<phi> tr1 tr2" and
63.147 -LLift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
63.148 - root tr1 = root tr2 \<and> llift2 \<phi> (ccont tr1) (ccont tr2)"
63.149 -shows "tr1 = tr2"
63.150 -using phi apply(induct rule: TTree_coind_Node)
63.151 -using LLift by (metis TTree_sel_ctor)
63.152 -
63.153 -
63.154 -
63.155 -subsection {* Coiteration *}
63.156 -
63.157 -(* Preliminaries: *)
63.158 -declare Tree.dtor_ctor[simp]
63.159 -declare Tree.ctor_dtor[simp]
63.160 -
63.161 -lemma Tree_dtor_NNode[simp]:
63.162 -"Tree_dtor (NNode n as) = (n,as)"
63.163 -unfolding NNode_def Tree.dtor_ctor ..
63.164 -
63.165 -lemma Tree_dtor_root_ccont:
63.166 -"Tree_dtor tr = (root tr, ccont tr)"
63.167 -unfolding root_def ccont_def
63.168 -by (metis (lifting) NNode_asNNode Tree_dtor_NNode)
63.169 -
63.170 -(* Coiteration *)
63.171 -definition TTree_unfold ::
63.172 -"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + 'b) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
63.173 -where "TTree_unfold rt ct \<equiv> Tree_dtor_unfold <rt,ct>"
63.174 -
63.175 -lemma Tree_unfold_unfold:
63.176 -"Tree_dtor_unfold s = TTree_unfold (fst o s) (snd o s)"
63.177 -apply(rule ext)
63.178 -unfolding TTree_unfold_def by simp
63.179 -
63.180 -theorem TTree_unfold:
63.181 -"root (TTree_unfold rt ct b) = rt b"
63.182 -"ccont (TTree_unfold rt ct b) = map_fset (id \<oplus> TTree_unfold rt ct) (ct b)"
63.183 -using Tree.dtor_unfolds[of "<rt,ct>" b] unfolding Tree_unfold_unfold fst_convol snd_convol
63.184 -unfolding pre_Tree_map' fst_convol' snd_convol'
63.185 -unfolding Tree_dtor_root_ccont by simp_all
63.186 -
63.187 -(* Corecursion, stronger than coiteration (unfold) *)
63.188 -definition TTree_corec ::
63.189 -"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + (Tree + 'b)) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
63.190 -where "TTree_corec rt ct \<equiv> Tree_dtor_corec <rt,ct>"
63.191 -
63.192 -lemma Tree_dtor_corec_corec:
63.193 -"Tree_dtor_corec s = TTree_corec (fst o s) (snd o s)"
63.194 -apply(rule ext)
63.195 -unfolding TTree_corec_def by simp
63.196 -
63.197 -theorem TTree_corec:
63.198 -"root (TTree_corec rt ct b) = rt b"
63.199 -"ccont (TTree_corec rt ct b) = map_fset (id \<oplus> ([[id, TTree_corec rt ct]]) ) (ct b)"
63.200 -using Tree.dtor_corecs[of "<rt,ct>" b] unfolding Tree_dtor_corec_corec fst_convol snd_convol
63.201 -unfolding pre_Tree_map' fst_convol' snd_convol'
63.202 -unfolding Tree_dtor_root_ccont by simp_all
63.203 -
63.204 -
63.205 -subsection{* The characteristic theorems transported from fset to set *}
63.206 -
63.207 -definition "Node n as \<equiv> NNode n (the_inv fset as)"
63.208 -definition "cont \<equiv> fset o ccont"
63.209 -definition "unfold rt ct \<equiv> TTree_unfold rt (the_inv fset o ct)"
63.210 -definition "corec rt ct \<equiv> TTree_corec rt (the_inv fset o ct)"
63.211 -
63.212 -definition lift ("_ ^#" 200) where
63.213 -"lift \<phi> as \<longleftrightarrow> (\<forall> tr. Inr tr \<in> as \<longrightarrow> \<phi> tr)"
63.214 -
63.215 -definition lift2 ("_ ^#2" 200) where
63.216 -"lift2 \<phi> as1 as2 \<longleftrightarrow>
63.217 - (\<forall> n. Inl n \<in> as1 \<longleftrightarrow> Inl n \<in> as2) \<and>
63.218 - (\<forall> tr1. Inr tr1 \<in> as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> as2 \<and> \<phi> tr1 tr2)) \<and>
63.219 - (\<forall> tr2. Inr tr2 \<in> as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> as1 \<and> \<phi> tr1 tr2))"
63.220 -
63.221 -definition liftS ("_ ^#s" 200) where
63.222 -"liftS trs = {as. Inr -` as \<subseteq> trs}"
63.223 -
63.224 -lemma lift2_llift2:
63.225 -"\<lbrakk>finite as1; finite as2\<rbrakk> \<Longrightarrow>
63.226 - lift2 \<phi> as1 as2 \<longleftrightarrow> llift2 \<phi> (the_inv fset as1) (the_inv fset as2)"
63.227 -unfolding lift2_def llift2_def by auto
63.228 -
63.229 -lemma llift2_lift2:
63.230 -"llift2 \<phi> as1 as2 \<longleftrightarrow> lift2 \<phi> (fset as1) (fset as2)"
63.231 -using lift2_llift2 by (metis finite_fset fset_cong fset_to_fset)
63.232 -
63.233 -lemma mono_lift:
63.234 -assumes "(\<phi>^#) as"
63.235 -and "\<And> tr. \<phi> tr \<Longrightarrow> \<phi>' tr"
63.236 -shows "(\<phi>'^#) as"
63.237 -using assms unfolding lift_def[abs_def] by blast
63.238 -
63.239 -lemma mono_liftS:
63.240 -assumes "trs1 \<subseteq> trs2 "
63.241 -shows "(trs1 ^#s) \<subseteq> (trs2 ^#s)"
63.242 -using assms unfolding liftS_def[abs_def] by blast
63.243 -
63.244 -lemma lift_mono:
63.245 -assumes "\<phi> \<le> \<phi>'"
63.246 -shows "(\<phi>^#) \<le> (\<phi>'^#)"
63.247 -using assms unfolding lift_def[abs_def] by blast
63.248 -
63.249 -lemma mono_lift2:
63.250 -assumes "(\<phi>^#2) as1 as2"
63.251 -and "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> \<phi>' tr1 tr2"
63.252 -shows "(\<phi>'^#2) as1 as2"
63.253 -using assms unfolding lift2_def[abs_def] by blast
63.254 -
63.255 -lemma lift2_mono:
63.256 -assumes "\<phi> \<le> \<phi>'"
63.257 -shows "(\<phi>^#2) \<le> (\<phi>'^#2)"
63.258 -using assms unfolding lift2_def[abs_def] by blast
63.259 -
63.260 -lemma finite_cont[simp]: "finite (cont tr)"
63.261 -unfolding cont_def by auto
63.262 -
63.263 -theorem Node_root_cont[simp]:
63.264 -"Node (root tr) (cont tr) = tr"
63.265 -using NNode_root_ccont unfolding Node_def cont_def
63.266 -by (metis cont_def finite_cont fset_cong fset_to_fset o_def)
63.267 -
63.268 -theorem Tree_simps[simp]:
63.269 -assumes "finite as" and "finite as'"
63.270 -shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
63.271 -using assms TTree_simps unfolding Node_def
63.272 -by (metis fset_to_fset)
63.273 -
63.274 -theorem Tree_cases[elim, case_names Node Choice]:
63.275 -assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
63.276 -shows phi
63.277 -apply(cases rule: TTree_cases[of tr])
63.278 -using Node unfolding Node_def
63.279 -by (metis Node Node_root_cont finite_cont)
63.280 -
63.281 -theorem Tree_sel_ctor[simp]:
63.282 -"root (Node n as) = n"
63.283 -"finite as \<Longrightarrow> cont (Node n as) = as"
63.284 -unfolding Node_def cont_def by auto
63.285 -
63.286 -theorems root_Node = Tree_sel_ctor(1)
63.287 -theorems cont_Node = Tree_sel_ctor(2)
63.288 -
63.289 -theorem Tree_coind_Node[elim, consumes 1, case_names Node]:
63.290 -assumes phi: "\<phi> tr1 tr2" and
63.291 -Node:
63.292 -"\<And> n1 n2 as1 as2.
63.293 - \<lbrakk>finite as1; finite as2; \<phi> (Node n1 as1) (Node n2 as2)\<rbrakk>
63.294 - \<Longrightarrow> n1 = n2 \<and> (\<phi>^#2) as1 as2"
63.295 -shows "tr1 = tr2"
63.296 -using phi apply(induct rule: TTree_coind_Node)
63.297 -unfolding llift2_lift2 apply(rule Node)
63.298 -unfolding Node_def
63.299 -apply (metis finite_fset)
63.300 -apply (metis finite_fset)
63.301 -by (metis finite_fset fset_cong fset_to_fset)
63.302 -
63.303 -theorem Tree_coind[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
63.304 -assumes phi: "\<phi> tr1 tr2" and
63.305 -Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
63.306 - root tr1 = root tr2 \<and> (\<phi>^#2) (cont tr1) (cont tr2)"
63.307 -shows "tr1 = tr2"
63.308 -using phi apply(induct rule: TTree_coind)
63.309 -unfolding llift2_lift2 apply(rule Lift[unfolded cont_def comp_def]) .
63.310 -
63.311 -theorem unfold:
63.312 -"root (unfold rt ct b) = rt b"
63.313 -"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
63.314 -using TTree_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
63.315 -apply - apply metis
63.316 -unfolding cont_def comp_def
63.317 -by (metis (no_types) fset_to_fset map_fset_image)
63.318 -
63.319 -
63.320 -theorem corec:
63.321 -"root (corec rt ct b) = rt b"
63.322 -"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
63.323 -using TTree_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
63.324 -apply - apply metis
63.325 -unfolding cont_def comp_def
63.326 -by (metis (no_types) fset_to_fset map_fset_image)
63.327 -
63.328 -
63.329 -end
64.1 --- a/src/HOL/Codatatype/Examples/Lambda_Term.thy Fri Sep 21 16:34:40 2012 +0200
64.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
64.3 @@ -1,259 +0,0 @@
64.4 -(* Title: HOL/BNF/Examples/Lambda_Term.thy
64.5 - Author: Dmitriy Traytel, TU Muenchen
64.6 - Author: Andrei Popescu, TU Muenchen
64.7 - Copyright 2012
64.8 -
64.9 -Lambda-terms.
64.10 -*)
64.11 -
64.12 -header {* Lambda-Terms *}
64.13 -
64.14 -theory Lambda_Term
64.15 -imports "../BNF"
64.16 -begin
64.17 -
64.18 -
64.19 -section {* Datatype definition *}
64.20 -
64.21 -data_raw trm: 'trm = "'a + 'trm \<times> 'trm + 'a \<times> 'trm + ('a \<times> 'trm) fset \<times> 'trm"
64.22 -
64.23 -
64.24 -section {* Customization of terms *}
64.25 -
64.26 -subsection{* Set and map *}
64.27 -
64.28 -lemma pre_trm_set2_Lt: "pre_trm_set2 (Inr (Inr (Inr (xts, t)))) = snd ` (fset xts) \<union> {t}"
64.29 -unfolding pre_trm_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
64.30 -by auto
64.31 -
64.32 -lemma pre_trm_set2_Var: "\<And>x. pre_trm_set2 (Inl x) = {}"
64.33 -and pre_trm_set2_App:
64.34 -"\<And>t1 t2. pre_trm_set2 (Inr (Inl t1t2)) = {fst t1t2, snd t1t2}"
64.35 -and pre_trm_set2_Lam:
64.36 -"\<And>x t. pre_trm_set2 (Inr (Inr (Inl (x, t)))) = {t}"
64.37 -unfolding pre_trm_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
64.38 -by auto
64.39 -
64.40 -lemma pre_trm_map:
64.41 -"\<And> a1. pre_trm_map f1 f2 (Inl a1) = Inl (f1 a1)"
64.42 -"\<And> a2 b2. pre_trm_map f1 f2 (Inr (Inl (a2,b2))) = Inr (Inl (f2 a2, f2 b2))"
64.43 -"\<And> a1 a2. pre_trm_map f1 f2 (Inr (Inr (Inl (a1,a2)))) = Inr (Inr (Inl (f1 a1, f2 a2)))"
64.44 -"\<And> a1a2s a2.
64.45 - pre_trm_map f1 f2 (Inr (Inr (Inr (a1a2s, a2)))) =
64.46 - Inr (Inr (Inr (map_fset (\<lambda> (a1', a2'). (f1 a1', f2 a2')) a1a2s, f2 a2)))"
64.47 -unfolding pre_trm_map_def collect_def[abs_def] map_pair_def by auto
64.48 -
64.49 -
64.50 -subsection{* Constructors *}
64.51 -
64.52 -definition "Var x \<equiv> trm_ctor (Inl x)"
64.53 -definition "App t1 t2 \<equiv> trm_ctor (Inr (Inl (t1,t2)))"
64.54 -definition "Lam x t \<equiv> trm_ctor (Inr (Inr (Inl (x,t))))"
64.55 -definition "Lt xts t \<equiv> trm_ctor (Inr (Inr (Inr (xts,t))))"
64.56 -
64.57 -lemmas ctor_defs = Var_def App_def Lam_def Lt_def
64.58 -
64.59 -theorem trm_simps[simp]:
64.60 -"\<And>x y. Var x = Var y \<longleftrightarrow> x = y"
64.61 -"\<And>t1 t2 t1' t2'. App t1 t2 = App t1' t2' \<longleftrightarrow> t1 = t1' \<and> t2 = t2'"
64.62 -"\<And>x x' t t'. Lam x t = Lam x' t' \<longleftrightarrow> x = x' \<and> t = t'"
64.63 -"\<And> xts xts' t t'. Lt xts t = Lt xts' t' \<longleftrightarrow> xts = xts' \<and> t = t'"
64.64 -(* *)
64.65 -"\<And> x t1 t2. Var x \<noteq> App t1 t2" "\<And>x y t. Var x \<noteq> Lam y t" "\<And> x xts t. Var x \<noteq> Lt xts t"
64.66 -"\<And> t1 t2 x t. App t1 t2 \<noteq> Lam x t" "\<And> t1 t2 xts t. App t1 t2 \<noteq> Lt xts t"
64.67 -"\<And>x t xts t1. Lam x t \<noteq> Lt xts t1"
64.68 -unfolding ctor_defs trm.ctor_inject by auto
64.69 -
64.70 -theorem trm_cases[elim, case_names Var App Lam Lt]:
64.71 -assumes Var: "\<And> x. t = Var x \<Longrightarrow> phi"
64.72 -and App: "\<And> t1 t2. t = App t1 t2 \<Longrightarrow> phi"
64.73 -and Lam: "\<And> x t1. t = Lam x t1 \<Longrightarrow> phi"
64.74 -and Lt: "\<And> xts t1. t = Lt xts t1 \<Longrightarrow> phi"
64.75 -shows phi
64.76 -proof(cases rule: trm.ctor_exhaust[of t])
64.77 - fix x assume "t = trm_ctor x"
64.78 - thus ?thesis
64.79 - apply(cases x) using Var unfolding ctor_defs apply blast
64.80 - apply(case_tac b) using App unfolding ctor_defs apply(case_tac a, blast)
64.81 - apply(case_tac ba) using Lam unfolding ctor_defs apply(case_tac a, blast)
64.82 - apply(case_tac bb) using Lt unfolding ctor_defs by blast
64.83 -qed
64.84 -
64.85 -lemma trm_induct[case_names Var App Lam Lt, induct type: trm]:
64.86 -assumes Var: "\<And> (x::'a). phi (Var x)"
64.87 -and App: "\<And> t1 t2. \<lbrakk>phi t1; phi t2\<rbrakk> \<Longrightarrow> phi (App t1 t2)"
64.88 -and Lam: "\<And> x t. phi t \<Longrightarrow> phi (Lam x t)"
64.89 -and Lt: "\<And> xts t. \<lbrakk>\<And> x1 t1. (x1,t1) |\<in>| xts \<Longrightarrow> phi t1; phi t\<rbrakk> \<Longrightarrow> phi (Lt xts t)"
64.90 -shows "phi t"
64.91 -proof(induct rule: trm.ctor_induct)
64.92 - fix u :: "'a + 'a trm \<times> 'a trm + 'a \<times> 'a trm + ('a \<times> 'a trm) fset \<times> 'a trm"
64.93 - assume IH: "\<And>t. t \<in> pre_trm_set2 u \<Longrightarrow> phi t"
64.94 - show "phi (trm_ctor u)"
64.95 - proof(cases u)
64.96 - case (Inl x)
64.97 - show ?thesis using Var unfolding Var_def Inl .
64.98 - next
64.99 - case (Inr uu) note Inr1 = Inr
64.100 - show ?thesis
64.101 - proof(cases uu)
64.102 - case (Inl t1t2)
64.103 - obtain t1 t2 where t1t2: "t1t2 = (t1,t2)" by (cases t1t2, blast)
64.104 - show ?thesis unfolding Inr1 Inl t1t2 App_def[symmetric] apply(rule App)
64.105 - using IH unfolding Inr1 Inl pre_trm_set2_App t1t2 fst_conv snd_conv by blast+
64.106 - next
64.107 - case (Inr uuu) note Inr2 = Inr
64.108 - show ?thesis
64.109 - proof(cases uuu)
64.110 - case (Inl xt)
64.111 - obtain x t where xt: "xt = (x,t)" by (cases xt, blast)
64.112 - show ?thesis unfolding Inr1 Inr2 Inl xt Lam_def[symmetric] apply(rule Lam)
64.113 - using IH unfolding Inr1 Inr2 Inl pre_trm_set2_Lam xt by blast
64.114 - next
64.115 - case (Inr xts_t)
64.116 - obtain xts t where xts_t: "xts_t = (xts,t)" by (cases xts_t, blast)
64.117 - show ?thesis unfolding Inr1 Inr2 Inr xts_t Lt_def[symmetric] apply(rule Lt) using IH
64.118 - unfolding Inr1 Inr2 Inr pre_trm_set2_Lt xts_t fset_fset_member image_def by auto
64.119 - qed
64.120 - qed
64.121 - qed
64.122 -qed
64.123 -
64.124 -
64.125 -subsection{* Recursion and iteration (fold) *}
64.126 -
64.127 -definition
64.128 -"sumJoin4 f1 f2 f3 f4 \<equiv>
64.129 -\<lambda> k. (case k of
64.130 - Inl x1 \<Rightarrow> f1 x1
64.131 -|Inr k1 \<Rightarrow> (case k1 of
64.132 - Inl ((s2,a2),(t2,b2)) \<Rightarrow> f2 s2 a2 t2 b2
64.133 -|Inr k2 \<Rightarrow> (case k2 of Inl (x3,(t3,b3)) \<Rightarrow> f3 x3 t3 b3
64.134 -|Inr (xts,(t4,b4)) \<Rightarrow> f4 xts t4 b4)))"
64.135 -
64.136 -lemma sumJoin4_simps[simp]:
64.137 -"\<And>x. sumJoin4 var app lam lt (Inl x) = var x"
64.138 -"\<And> t1 a1 t2 a2. sumJoin4 var app lam lt (Inr (Inl ((t1,a1),(t2,a2)))) = app t1 a1 t2 a2"
64.139 -"\<And> x t a. sumJoin4 var app lam lt (Inr (Inr (Inl (x,(t,a))))) = lam x t a"
64.140 -"\<And> xtas t a. sumJoin4 var app lam lt (Inr (Inr (Inr (xtas,(t,a))))) = lt xtas t a"
64.141 -unfolding sumJoin4_def by auto
64.142 -
64.143 -definition "trmrec var app lam lt \<equiv> trm_ctor_rec (sumJoin4 var app lam lt)"
64.144 -
64.145 -lemma trmrec_Var[simp]:
64.146 -"trmrec var app lam lt (Var x) = var x"
64.147 -unfolding trmrec_def Var_def trm.ctor_recs pre_trm_map(1) by simp
64.148 -
64.149 -lemma trmrec_App[simp]:
64.150 -"trmrec var app lam lt (App t1 t2) =
64.151 - app t1 (trmrec var app lam lt t1) t2 (trmrec var app lam lt t2)"
64.152 -unfolding trmrec_def App_def trm.ctor_recs pre_trm_map(2) convol_def by simp
64.153 -
64.154 -lemma trmrec_Lam[simp]:
64.155 -"trmrec var app lam lt (Lam x t) = lam x t (trmrec var app lam lt t)"
64.156 -unfolding trmrec_def Lam_def trm.ctor_recs pre_trm_map(3) convol_def by simp
64.157 -
64.158 -lemma trmrec_Lt[simp]:
64.159 -"trmrec var app lam lt (Lt xts t) =
64.160 - lt (map_fset (\<lambda> (x,t). (x,t,trmrec var app lam lt t)) xts) t (trmrec var app lam lt t)"
64.161 -unfolding trmrec_def Lt_def trm.ctor_recs pre_trm_map(4) convol_def by simp
64.162 -
64.163 -definition
64.164 -"sumJoinI4 f1 f2 f3 f4 \<equiv>
64.165 -\<lambda> k. (case k of
64.166 - Inl x1 \<Rightarrow> f1 x1
64.167 -|Inr k1 \<Rightarrow> (case k1 of
64.168 - Inl (a2,b2) \<Rightarrow> f2 a2 b2
64.169 -|Inr k2 \<Rightarrow> (case k2 of Inl (x3,b3) \<Rightarrow> f3 x3 b3
64.170 -|Inr (xts,b4) \<Rightarrow> f4 xts b4)))"
64.171 -
64.172 -lemma sumJoinI4_simps[simp]:
64.173 -"\<And>x. sumJoinI4 var app lam lt (Inl x) = var x"
64.174 -"\<And> a1 a2. sumJoinI4 var app lam lt (Inr (Inl (a1,a2))) = app a1 a2"
64.175 -"\<And> x a. sumJoinI4 var app lam lt (Inr (Inr (Inl (x,a)))) = lam x a"
64.176 -"\<And> xtas a. sumJoinI4 var app lam lt (Inr (Inr (Inr (xtas,a)))) = lt xtas a"
64.177 -unfolding sumJoinI4_def by auto
64.178 -
64.179 -(* The iterator has a simpler, hence more manageable type. *)
64.180 -definition "trmfold var app lam lt \<equiv> trm_ctor_fold (sumJoinI4 var app lam lt)"
64.181 -
64.182 -lemma trmfold_Var[simp]:
64.183 -"trmfold var app lam lt (Var x) = var x"
64.184 -unfolding trmfold_def Var_def trm.ctor_folds pre_trm_map(1) by simp
64.185 -
64.186 -lemma trmfold_App[simp]:
64.187 -"trmfold var app lam lt (App t1 t2) =
64.188 - app (trmfold var app lam lt t1) (trmfold var app lam lt t2)"
64.189 -unfolding trmfold_def App_def trm.ctor_folds pre_trm_map(2) by simp
64.190 -
64.191 -lemma trmfold_Lam[simp]:
64.192 -"trmfold var app lam lt (Lam x t) = lam x (trmfold var app lam lt t)"
64.193 -unfolding trmfold_def Lam_def trm.ctor_folds pre_trm_map(3) by simp
64.194 -
64.195 -lemma trmfold_Lt[simp]:
64.196 -"trmfold var app lam lt (Lt xts t) =
64.197 - lt (map_fset (\<lambda> (x,t). (x,trmfold var app lam lt t)) xts) (trmfold var app lam lt t)"
64.198 -unfolding trmfold_def Lt_def trm.ctor_folds pre_trm_map(4) by simp
64.199 -
64.200 -
64.201 -subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
64.202 -
64.203 -definition "varsOf = trmfold
64.204 -(\<lambda> x. {x})
64.205 -(\<lambda> X1 X2. X1 \<union> X2)
64.206 -(\<lambda> x X. X \<union> {x})
64.207 -(\<lambda> xXs Y. Y \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| xXs}))"
64.208 -
64.209 -lemma varsOf_simps[simp]:
64.210 -"varsOf (Var x) = {x}"
64.211 -"varsOf (App t1 t2) = varsOf t1 \<union> varsOf t2"
64.212 -"varsOf (Lam x t) = varsOf t \<union> {x}"
64.213 -"varsOf (Lt xts t) =
64.214 - varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,varsOf t1)) xts})"
64.215 -unfolding varsOf_def by simp_all
64.216 -
64.217 -definition "fvarsOf = trmfold
64.218 -(\<lambda> x. {x})
64.219 -(\<lambda> X1 X2. X1 \<union> X2)
64.220 -(\<lambda> x X. X - {x})
64.221 -(\<lambda> xtXs Y. Y - {x | x X. (x,X) |\<in>| xtXs} \<union> (\<Union> {X | x X. (x,X) |\<in>| xtXs}))"
64.222 -
64.223 -lemma fvarsOf_simps[simp]:
64.224 -"fvarsOf (Var x) = {x}"
64.225 -"fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
64.226 -"fvarsOf (Lam x t) = fvarsOf t - {x}"
64.227 -"fvarsOf (Lt xts t) =
64.228 - fvarsOf t
64.229 - - {x | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts}
64.230 - \<union> (\<Union> {X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts})"
64.231 -unfolding fvarsOf_def by simp_all
64.232 -
64.233 -lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
64.234 -
64.235 -lemma in_map_fset_iff:
64.236 -"(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, f t1)) xts \<longleftrightarrow>
64.237 - (\<exists> t1. (x,t1) |\<in>| xts \<and> X = f t1)"
64.238 -unfolding map_fset_def2_raw in_fset fset_afset unfolding fset_def2_raw by auto
64.239 -
64.240 -lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
64.241 -proof induct
64.242 - case (Lt xts t)
64.243 - thus ?case unfolding fvarsOf_simps varsOf_simps
64.244 - proof (elim diff_Un_incl_triv)
64.245 - show
64.246 - "\<Union>{X | x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts}
64.247 - \<subseteq> \<Union>{{x} \<union> X |x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts}"
64.248 - (is "_ \<subseteq> \<Union> ?L")
64.249 - proof(rule Sup_mono, safe)
64.250 - fix a x X
64.251 - assume "(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts"
64.252 - then obtain t1 where x_t1: "(x,t1) |\<in>| xts" and X: "X = fvarsOf t1"
64.253 - unfolding in_map_fset_iff by auto
64.254 - let ?Y = "varsOf t1"
64.255 - have x_Y: "(x,?Y) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts"
64.256 - using x_t1 unfolding in_map_fset_iff by auto
64.257 - show "\<exists> Y \<in> ?L. X \<subseteq> Y" unfolding X using Lt(1) x_Y x_t1 by auto
64.258 - qed
64.259 - qed
64.260 -qed auto
64.261 -
64.262 -end
65.1 --- a/src/HOL/Codatatype/Examples/ListF.thy Fri Sep 21 16:34:40 2012 +0200
65.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
65.3 @@ -1,171 +0,0 @@
65.4 -(* Title: HOL/BNF/Examples/ListF.thy
65.5 - Author: Dmitriy Traytel, TU Muenchen
65.6 - Author: Andrei Popescu, TU Muenchen
65.7 - Copyright 2012
65.8 -
65.9 -Finite lists.
65.10 -*)
65.11 -
65.12 -header {* Finite Lists *}
65.13 -
65.14 -theory ListF
65.15 -imports "../BNF"
65.16 -begin
65.17 -
65.18 -data_raw listF: 'list = "unit + 'a \<times> 'list"
65.19 -
65.20 -definition "NilF = listF_ctor (Inl ())"
65.21 -definition "Conss a as \<equiv> listF_ctor (Inr (a, as))"
65.22 -
65.23 -lemma listF_map_NilF[simp]: "listF_map f NilF = NilF"
65.24 -unfolding listF_map_def pre_listF_map_def NilF_def listF.ctor_folds by simp
65.25 -
65.26 -lemma listF_map_Conss[simp]:
65.27 - "listF_map f (Conss x xs) = Conss (f x) (listF_map f xs)"
65.28 -unfolding listF_map_def pre_listF_map_def Conss_def listF.ctor_folds by simp
65.29 -
65.30 -lemma listF_set_NilF[simp]: "listF_set NilF = {}"
65.31 -unfolding listF_set_def NilF_def listF.ctor_folds pre_listF_set1_def pre_listF_set2_def
65.32 - sum_set_defs pre_listF_map_def collect_def[abs_def] by simp
65.33 -
65.34 -lemma listF_set_Conss[simp]: "listF_set (Conss x xs) = {x} \<union> listF_set xs"
65.35 -unfolding listF_set_def Conss_def listF.ctor_folds pre_listF_set1_def pre_listF_set2_def
65.36 - sum_set_defs prod_set_defs pre_listF_map_def collect_def[abs_def] by simp
65.37 -
65.38 -lemma fold_sum_case_NilF: "listF_ctor_fold (sum_case f g) NilF = f ()"
65.39 -unfolding NilF_def listF.ctor_folds pre_listF_map_def by simp
65.40 -
65.41 -
65.42 -lemma fold_sum_case_Conss:
65.43 - "listF_ctor_fold (sum_case f g) (Conss y ys) = g (y, listF_ctor_fold (sum_case f g) ys)"
65.44 -unfolding Conss_def listF.ctor_folds pre_listF_map_def by simp
65.45 -
65.46 -(* familiar induction principle *)
65.47 -lemma listF_induct:
65.48 - fixes xs :: "'a listF"
65.49 - assumes IB: "P NilF" and IH: "\<And>x xs. P xs \<Longrightarrow> P (Conss x xs)"
65.50 - shows "P xs"
65.51 -proof (rule listF.ctor_induct)
65.52 - fix xs :: "unit + 'a \<times> 'a listF"
65.53 - assume raw_IH: "\<And>a. a \<in> pre_listF_set2 xs \<Longrightarrow> P a"
65.54 - show "P (listF_ctor xs)"
65.55 - proof (cases xs)
65.56 - case (Inl a) with IB show ?thesis unfolding NilF_def by simp
65.57 - next
65.58 - case (Inr b)
65.59 - then obtain y ys where yys: "listF_ctor xs = Conss y ys"
65.60 - unfolding Conss_def listF.ctor_inject by (blast intro: prod.exhaust)
65.61 - hence "ys \<in> pre_listF_set2 xs"
65.62 - unfolding pre_listF_set2_def Conss_def listF.ctor_inject sum_set_defs prod_set_defs
65.63 - collect_def[abs_def] by simp
65.64 - with raw_IH have "P ys" by blast
65.65 - with IH have "P (Conss y ys)" by blast
65.66 - with yys show ?thesis by simp
65.67 - qed
65.68 -qed
65.69 -
65.70 -rep_datatype NilF Conss
65.71 -by (blast intro: listF_induct) (auto simp add: NilF_def Conss_def listF.ctor_inject)
65.72 -
65.73 -definition Singll ("[[_]]") where
65.74 - [simp]: "Singll a \<equiv> Conss a NilF"
65.75 -
65.76 -definition appendd (infixr "@@" 65) where
65.77 - "appendd \<equiv> listF_ctor_fold (sum_case (\<lambda> _. id) (\<lambda> (a,f) bs. Conss a (f bs)))"
65.78 -
65.79 -definition "lrev \<equiv> listF_ctor_fold (sum_case (\<lambda> _. NilF) (\<lambda> (b,bs). bs @@ [[b]]))"
65.80 -
65.81 -lemma lrev_NilF[simp]: "lrev NilF = NilF"
65.82 -unfolding lrev_def by (simp add: fold_sum_case_NilF)
65.83 -
65.84 -lemma lrev_Conss[simp]: "lrev (Conss y ys) = lrev ys @@ [[y]]"
65.85 -unfolding lrev_def by (simp add: fold_sum_case_Conss)
65.86 -
65.87 -lemma NilF_appendd[simp]: "NilF @@ ys = ys"
65.88 -unfolding appendd_def by (simp add: fold_sum_case_NilF)
65.89 -
65.90 -lemma Conss_append[simp]: "Conss x xs @@ ys = Conss x (xs @@ ys)"
65.91 -unfolding appendd_def by (simp add: fold_sum_case_Conss)
65.92 -
65.93 -lemma appendd_NilF[simp]: "xs @@ NilF = xs"
65.94 -by (rule listF_induct) auto
65.95 -
65.96 -lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
65.97 -by (rule listF_induct) auto
65.98 -
65.99 -lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
65.100 -by (rule listF_induct[of _ xs]) auto
65.101 -
65.102 -lemma listF_map_appendd[simp]:
65.103 - "listF_map f (xs @@ ys) = listF_map f xs @@ listF_map f ys"
65.104 -by (rule listF_induct[of _ xs]) auto
65.105 -
65.106 -lemma lrev_listF_map[simp]: "lrev (listF_map f xs) = listF_map f (lrev xs)"
65.107 -by (rule listF_induct[of _ xs]) auto
65.108 -
65.109 -lemma lrev_lrev[simp]: "lrev (lrev as) = as"
65.110 -by (rule listF_induct) auto
65.111 -
65.112 -fun lengthh where
65.113 - "lengthh NilF = 0"
65.114 -| "lengthh (Conss x xs) = Suc (lengthh xs)"
65.115 -
65.116 -fun nthh where
65.117 - "nthh (Conss x xs) 0 = x"
65.118 -| "nthh (Conss x xs) (Suc n) = nthh xs n"
65.119 -| "nthh xs i = undefined"
65.120 -
65.121 -lemma lengthh_listF_map[simp]: "lengthh (listF_map f xs) = lengthh xs"
65.122 -by (rule listF_induct[of _ xs]) auto
65.123 -
65.124 -lemma nthh_listF_map[simp]:
65.125 - "i < lengthh xs \<Longrightarrow> nthh (listF_map f xs) i = f (nthh xs i)"
65.126 -by (induct rule: nthh.induct) auto
65.127 -
65.128 -lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
65.129 -by (induct rule: nthh.induct) auto
65.130 -
65.131 -lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
65.132 -by (induct xs) auto
65.133 -
65.134 -lemma Conss_iff[iff]:
65.135 - "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
65.136 -by (induct xs) auto
65.137 -
65.138 -lemma Conss_iff'[iff]:
65.139 - "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
65.140 -by (induct xs) (simp, simp, blast)
65.141 -
65.142 -lemma listF_induct2: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
65.143 - \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
65.144 -by (induct xs arbitrary: ys rule: listF_induct) auto
65.145 -
65.146 -fun zipp where
65.147 - "zipp NilF NilF = NilF"
65.148 -| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
65.149 -| "zipp xs ys = undefined"
65.150 -
65.151 -lemma listF_map_fst_zip[simp]:
65.152 - "lengthh xs = lengthh ys \<Longrightarrow> listF_map fst (zipp xs ys) = xs"
65.153 -by (erule listF_induct2) auto
65.154 -
65.155 -lemma listF_map_snd_zip[simp]:
65.156 - "lengthh xs = lengthh ys \<Longrightarrow> listF_map snd (zipp xs ys) = ys"
65.157 -by (erule listF_induct2) auto
65.158 -
65.159 -lemma lengthh_zip[simp]:
65.160 - "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
65.161 -by (erule listF_induct2) auto
65.162 -
65.163 -lemma nthh_zip[simp]:
65.164 - assumes *: "lengthh xs = lengthh ys"
65.165 - shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
65.166 -proof (induct arbitrary: i rule: listF_induct2[OF *])
65.167 - case (2 x xs y ys) thus ?case by (induct i) auto
65.168 -qed simp
65.169 -
65.170 -lemma list_set_nthh[simp]:
65.171 - "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
65.172 -by (induct xs) (auto, induct rule: nthh.induct, auto)
65.173 -
65.174 -end
66.1 --- a/src/HOL/Codatatype/Examples/Misc_Codata.thy Fri Sep 21 16:34:40 2012 +0200
66.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
66.3 @@ -1,110 +0,0 @@
66.4 -(* Title: HOL/BNF/Examples/Misc_Data.thy
66.5 - Author: Dmitriy Traytel, TU Muenchen
66.6 - Author: Andrei Popescu, TU Muenchen
66.7 - Copyright 2012
66.8 -
66.9 -Miscellaneous codatatype declarations.
66.10 -*)
66.11 -
66.12 -header {* Miscellaneous Codatatype Declarations *}
66.13 -
66.14 -theory Misc_Codata
66.15 -imports "../BNF"
66.16 -begin
66.17 -
66.18 -codata simple = X1 | X2 | X3 | X4
66.19 -
66.20 -codata simple' = X1' unit | X2' unit | X3' unit | X4' unit
66.21 -
66.22 -codata 'a stream = Stream 'a "'a stream"
66.23 -
66.24 -codata 'a mylist = MyNil | MyCons 'a "'a mylist"
66.25 -
66.26 -codata ('b, 'c, 'd, 'e) some_passive =
66.27 - SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
66.28 -
66.29 -codata lambda =
66.30 - Var string |
66.31 - App lambda lambda |
66.32 - Abs string lambda |
66.33 - Let "(string \<times> lambda) fset" lambda
66.34 -
66.35 -codata 'a par_lambda =
66.36 - PVar 'a |
66.37 - PApp "'a par_lambda" "'a par_lambda" |
66.38 - PAbs 'a "'a par_lambda" |
66.39 - PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
66.40 -
66.41 -(*
66.42 - ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
66.43 - ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
66.44 -*)
66.45 -
66.46 -codata 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
66.47 - and 'a J2 = J21 | J22 "'a J1" "'a J2"
66.48 -
66.49 -codata 'a tree = TEmpty | TNode 'a "'a forest"
66.50 - and 'a forest = FNil | FCons "'a tree" "'a forest"
66.51 -
66.52 -codata 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
66.53 - and 'a branch = Branch 'a "'a tree'"
66.54 -
66.55 -codata ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
66.56 - and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
66.57 - and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
66.58 -
66.59 -codata ('a, 'b, 'c) some_killing =
66.60 - SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
66.61 - and ('a, 'b, 'c) in_here =
66.62 - IH1 'b 'a | IH2 'c
66.63 -
66.64 -codata_raw some_killing': 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
66.65 -and in_here': 'c = "'d + 'e"
66.66 -
66.67 -codata_raw some_killing'': 'a = "'b \<Rightarrow> 'c"
66.68 -and in_here'': 'c = "'d \<times> 'b + 'e"
66.69 -
66.70 -codata ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
66.71 -
66.72 -codata 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
66.73 -
66.74 -codata ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
66.75 - FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
66.76 - ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
66.77 -
66.78 -codata ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
66.79 - 'b18, 'b19, 'b20) fun_rhs' =
66.80 - FR' "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'b10 \<Rightarrow> 'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow>
66.81 - 'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
66.82 - ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
66.83 - 'b18, 'b19, 'b20) fun_rhs'"
66.84 -
66.85 -codata ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
66.86 - and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
66.87 - and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
66.88 -
66.89 -codata ('c, 'e, 'g) coind_wit1 =
66.90 - CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
66.91 - and ('c, 'e, 'g) coind_wit2 =
66.92 - CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
66.93 - and ('c, 'e, 'g) ind_wit =
66.94 - IW1 | IW2 'c
66.95 -
66.96 -codata ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
66.97 -codata ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
66.98 -
66.99 -codata 'a dead_foo = A
66.100 -codata ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
66.101 -
66.102 -(* SLOW, MEMORY-HUNGRY
66.103 -codata ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
66.104 - and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
66.105 - and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
66.106 - and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
66.107 - and ('a, 'c) D5 = A5 "('a, 'c) D6"
66.108 - and ('a, 'c) D6 = A6 "('a, 'c) D7"
66.109 - and ('a, 'c) D7 = A7 "('a, 'c) D8"
66.110 - and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
66.111 -*)
66.112 -
66.113 -end
67.1 --- a/src/HOL/Codatatype/Examples/Misc_Data.thy Fri Sep 21 16:34:40 2012 +0200
67.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
67.3 @@ -1,154 +0,0 @@
67.4 -(* Title: HOL/BNF/Examples/Misc_Data.thy
67.5 - Author: Dmitriy Traytel, TU Muenchen
67.6 - Author: Andrei Popescu, TU Muenchen
67.7 - Copyright 2012
67.8 -
67.9 -Miscellaneous datatype declarations.
67.10 -*)
67.11 -
67.12 -header {* Miscellaneous Datatype Declarations *}
67.13 -
67.14 -theory Misc_Data
67.15 -imports "../BNF"
67.16 -begin
67.17 -
67.18 -data simple = X1 | X2 | X3 | X4
67.19 -
67.20 -data simple' = X1' unit | X2' unit | X3' unit | X4' unit
67.21 -
67.22 -data 'a mylist = MyNil | MyCons 'a "'a mylist"
67.23 -
67.24 -data ('b, 'c, 'd, 'e) some_passive =
67.25 - SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
67.26 -
67.27 -data lambda =
67.28 - Var string |
67.29 - App lambda lambda |
67.30 - Abs string lambda |
67.31 - Let "(string \<times> lambda) fset" lambda
67.32 -
67.33 -data 'a par_lambda =
67.34 - PVar 'a |
67.35 - PApp "'a par_lambda" "'a par_lambda" |
67.36 - PAbs 'a "'a par_lambda" |
67.37 - PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
67.38 -
67.39 -(*
67.40 - ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
67.41 - ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
67.42 -*)
67.43 -
67.44 -data 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
67.45 - and 'a I2 = I21 | I22 "'a I1" "'a I2"
67.46 -
67.47 -data 'a tree = TEmpty | TNode 'a "'a forest"
67.48 - and 'a forest = FNil | FCons "'a tree" "'a forest"
67.49 -
67.50 -data 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
67.51 - and 'a branch = Branch 'a "'a tree'"
67.52 -
67.53 -data ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
67.54 - and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
67.55 - and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
67.56 -
67.57 -data ('a, 'b, 'c) some_killing =
67.58 - SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
67.59 - and ('a, 'b, 'c) in_here =
67.60 - IH1 'b 'a | IH2 'c
67.61 -
67.62 -data 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
67.63 -data 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
67.64 -data 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
67.65 -data 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
67.66 -
67.67 -(*
67.68 -data 'b fail = F "'b fail" 'b "'b fail" "'b list"
67.69 -data 'b fail = F "'b fail" 'b "'b fail" 'b
67.70 -data 'b fail = F1 "'b fail" 'b | F2 "'b fail"
67.71 -data 'b fail = F "'b fail" 'b
67.72 -*)
67.73 -
67.74 -data l1 = L1 "l2 list"
67.75 - and l2 = L21 "l1 fset" | L22 l2
67.76 -
67.77 -data kk1 = KK1 kk2
67.78 - and kk2 = KK2 kk3
67.79 - and kk3 = KK3 "kk1 list"
67.80 -
67.81 -data t1 = T11 t3 | T12 t2
67.82 - and t2 = T2 t1
67.83 - and t3 = T3
67.84 -
67.85 -data t1' = T11' t2' | T12' t3'
67.86 - and t2' = T2' t1'
67.87 - and t3' = T3'
67.88 -
67.89 -(*
67.90 -data fail1 = F1 fail2
67.91 - and fail2 = F2 fail3
67.92 - and fail3 = F3 fail1
67.93 -
67.94 -data fail1 = F1 "fail2 list" fail2
67.95 - and fail2 = F2 "fail2 fset" fail3
67.96 - and fail3 = F3 fail1
67.97 -
67.98 -data fail1 = F1 "fail2 list" fail2
67.99 - and fail2 = F2 "fail1 fset" fail1
67.100 -*)
67.101 -
67.102 -(* SLOW
67.103 -data ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
67.104 - and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
67.105 - and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
67.106 - and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
67.107 - and ('a, 'c) D5 = A5 "('a, 'c) D6"
67.108 - and ('a, 'c) D6 = A6 "('a, 'c) D7"
67.109 - and ('a, 'c) D7 = A7 "('a, 'c) D8"
67.110 - and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
67.111 -
67.112 -(*time comparison*)
67.113 -datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
67.114 - and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
67.115 - and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
67.116 - and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
67.117 - and ('a, 'c) D5' = A5' "('a, 'c) D6'"
67.118 - and ('a, 'c) D6' = A6' "('a, 'c) D7'"
67.119 - and ('a, 'c) D7' = A7' "('a, 'c) D8'"
67.120 - and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
67.121 -*)
67.122 -
67.123 -(* fail:
67.124 -data tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
67.125 - and tt2 = TT2
67.126 - and tt3 = TT3 tt4
67.127 - and tt4 = TT4 tt1
67.128 -*)
67.129 -
67.130 -data k1 = K11 k2 k3 | K12 k2 k4
67.131 - and k2 = K2
67.132 - and k3 = K3 k4
67.133 - and k4 = K4
67.134 -
67.135 -data tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
67.136 - and tt2 = TT2
67.137 - and tt3 = TT3 tt1
67.138 - and tt4 = TT4
67.139 -
67.140 -(* SLOW
67.141 -data s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
67.142 - and s2 = S21 s7 s5 | S22 s5 s4 s6
67.143 - and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
67.144 - and s4 = S4 s5
67.145 - and s5 = S5
67.146 - and s6 = S61 s6 | S62 s1 s2 | S63 s6
67.147 - and s7 = S71 s8 | S72 s5
67.148 - and s8 = S8 nat
67.149 -*)
67.150 -
67.151 -data ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
67.152 -data ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
67.153 -
67.154 -data 'a dead_foo = A
67.155 -data ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
67.156 -
67.157 -end
68.1 --- a/src/HOL/Codatatype/Examples/Process.thy Fri Sep 21 16:34:40 2012 +0200
68.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
68.3 @@ -1,367 +0,0 @@
68.4 -(* Title: HOL/BNF/Examples/Process.thy
68.5 - Author: Andrei Popescu, TU Muenchen
68.6 - Copyright 2012
68.7 -
68.8 -Processes.
68.9 -*)
68.10 -
68.11 -header {* Processes *}
68.12 -
68.13 -theory Process
68.14 -imports "../BNF"
68.15 -begin
68.16 -
68.17 -hide_fact (open) Quotient_Product.prod_rel_def
68.18 -
68.19 -codata 'a process =
68.20 - isAction: Action (prefOf: 'a) (contOf: "'a process") |
68.21 - isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
68.22 -
68.23 -(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
68.24 -
68.25 -section {* Customization *}
68.26 -
68.27 -subsection {* Basic properties *}
68.28 -
68.29 -declare
68.30 - pre_process_rel_def[simp]
68.31 - sum_rel_def[simp]
68.32 - prod_rel_def[simp]
68.33 -
68.34 -(* Constructors versus discriminators *)
68.35 -theorem isAction_isChoice:
68.36 -"isAction p \<or> isChoice p"
68.37 -by (rule process.disc_exhaust) auto
68.38 -
68.39 -theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
68.40 -by (cases rule: process.exhaust[of p]) auto
68.41 -
68.42 -
68.43 -subsection{* Coinduction *}
68.44 -
68.45 -theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
68.46 -assumes phi: "\<phi> p p'" and
68.47 -iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
68.48 -Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
68.49 -Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
68.50 -shows "p = p'"
68.51 -proof(intro mp[OF process.rel_coinduct, of \<phi>, OF _ phi], clarify)
68.52 - fix p p' assume \<phi>: "\<phi> p p'"
68.53 - show "pre_process_rel (op =) \<phi> (process_dtor p) (process_dtor p')"
68.54 - proof(cases rule: process.exhaust[of p])
68.55 - case (Action a q) note p = Action
68.56 - hence "isAction p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
68.57 - then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process.exhaust[of p'], auto)
68.58 - have 0: "a = a' \<and> \<phi> q q'" using Act[OF \<phi>[unfolded p p']] .
68.59 - have dtor: "process_dtor p = Inl (a,q)" "process_dtor p' = Inl (a',q')"
68.60 - unfolding p p' Action_def process.dtor_ctor by simp_all
68.61 - show ?thesis using 0 unfolding dtor by simp
68.62 - next
68.63 - case (Choice p1 p2) note p = Choice
68.64 - hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
68.65 - then obtain p1' p2' where p': "p' = Choice p1' p2'"
68.66 - by (cases rule: process.exhaust[of p'], auto)
68.67 - have 0: "\<phi> p1 p1' \<and> \<phi> p2 p2'" using Ch[OF \<phi>[unfolded p p']] .
68.68 - have dtor: "process_dtor p = Inr (p1,p2)" "process_dtor p' = Inr (p1',p2')"
68.69 - unfolding p p' Choice_def process.dtor_ctor by simp_all
68.70 - show ?thesis using 0 unfolding dtor by simp
68.71 - qed
68.72 -qed
68.73 -
68.74 -(* Stronger coinduction, up to equality: *)
68.75 -theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
68.76 -assumes phi: "\<phi> p p'" and
68.77 -iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
68.78 -Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
68.79 -Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
68.80 -shows "p = p'"
68.81 -proof(intro mp[OF process.rel_strong_coinduct, of \<phi>, OF _ phi], clarify)
68.82 - fix p p' assume \<phi>: "\<phi> p p'"
68.83 - show "pre_process_rel (op =) (\<lambda>a b. \<phi> a b \<or> a = b) (process_dtor p) (process_dtor p')"
68.84 - proof(cases rule: process.exhaust[of p])
68.85 - case (Action a q) note p = Action
68.86 - hence "isAction p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
68.87 - then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process.exhaust[of p'], auto)
68.88 - have 0: "a = a' \<and> (\<phi> q q' \<or> q = q')" using Act[OF \<phi>[unfolded p p']] .
68.89 - have dtor: "process_dtor p = Inl (a,q)" "process_dtor p' = Inl (a',q')"
68.90 - unfolding p p' Action_def process.dtor_ctor by simp_all
68.91 - show ?thesis using 0 unfolding dtor by simp
68.92 - next
68.93 - case (Choice p1 p2) note p = Choice
68.94 - hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
68.95 - then obtain p1' p2' where p': "p' = Choice p1' p2'"
68.96 - by (cases rule: process.exhaust[of p'], auto)
68.97 - have 0: "(\<phi> p1 p1' \<or> p1 = p1') \<and> (\<phi> p2 p2' \<or> p2 = p2')" using Ch[OF \<phi>[unfolded p p']] .
68.98 - have dtor: "process_dtor p = Inr (p1,p2)" "process_dtor p' = Inr (p1',p2')"
68.99 - unfolding p p' Choice_def process.dtor_ctor by simp_all
68.100 - show ?thesis using 0 unfolding dtor by simp
68.101 - qed
68.102 -qed
68.103 -
68.104 -
68.105 -subsection {* Coiteration (unfold) *}
68.106 -
68.107 -
68.108 -section{* Coinductive definition of the notion of trace *}
68.109 -
68.110 -(* Say we have a type of streams: *)
68.111 -
68.112 -typedecl 'a stream
68.113 -
68.114 -consts Ccons :: "'a \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
68.115 -
68.116 -(* Use the existing coinductive package (distinct from our
68.117 -new codatatype package, but highly compatible with it): *)
68.118 -
68.119 -coinductive trace where
68.120 -"trace p as \<Longrightarrow> trace (Action a p) (Ccons a as)"
68.121 -|
68.122 -"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
68.123 -
68.124 -
68.125 -section{* Examples of corecursive definitions: *}
68.126 -
68.127 -subsection{* Single-guard fixpoint definition *}
68.128 -
68.129 -definition
68.130 -"BX \<equiv>
68.131 - process_unfold
68.132 - (\<lambda> P. True)
68.133 - (\<lambda> P. ''a'')
68.134 - (\<lambda> P. P)
68.135 - undefined
68.136 - undefined
68.137 - ()"
68.138 -
68.139 -lemma BX: "BX = Action ''a'' BX"
68.140 -unfolding BX_def
68.141 -using process.unfolds(1)[of "\<lambda> P. True" "()" "\<lambda> P. ''a''" "\<lambda> P. P"] by simp
68.142 -
68.143 -
68.144 -subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
68.145 -
68.146 -datatype x_y_ax = x | y | ax
68.147 -
68.148 -definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False |y \<Rightarrow> True |ax \<Rightarrow> True"
68.149 -definition "pr \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
68.150 -definition "co \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x |ax \<Rightarrow> x"
68.151 -lemmas Action_defs = isA_def pr_def co_def
68.152 -
68.153 -definition "c1 \<equiv> \<lambda> K. case K of x \<Rightarrow> ax |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
68.154 -definition "c2 \<equiv> \<lambda> K. case K of x \<Rightarrow> y |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
68.155 -lemmas Choice_defs = c1_def c2_def
68.156 -
68.157 -definition "F \<equiv> process_unfold isA pr co c1 c2"
68.158 -definition "X = F x" definition "Y = F y" definition "AX = F ax"
68.159 -
68.160 -lemma X_Y_AX: "X = Choice AX Y" "Y = Action ''b'' X" "AX = Action ''a'' X"
68.161 -unfolding X_def Y_def AX_def F_def
68.162 -using process.unfolds(2)[of isA x "pr" co c1 c2]
68.163 - process.unfolds(1)[of isA y "pr" co c1 c2]
68.164 - process.unfolds(1)[of isA ax "pr" co c1 c2]
68.165 -unfolding Action_defs Choice_defs by simp_all
68.166 -
68.167 -(* end product: *)
68.168 -lemma X_AX:
68.169 -"X = Choice AX (Action ''b'' X)"
68.170 -"AX = Action ''a'' X"
68.171 -using X_Y_AX by simp_all
68.172 -
68.173 -
68.174 -
68.175 -section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
68.176 -
68.177 -hide_const x y ax X Y AX
68.178 -
68.179 -(* Process terms *)
68.180 -datatype ('a,'pvar) process_term =
68.181 - VAR 'pvar |
68.182 - PROC "'a process" |
68.183 - ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
68.184 -
68.185 -(* below, sys represents a system of equations *)
68.186 -fun isACT where
68.187 -"isACT sys (VAR X) =
68.188 - (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
68.189 -|
68.190 -"isACT sys (PROC p) = isAction p"
68.191 -|
68.192 -"isACT sys (ACT a T) = True"
68.193 -|
68.194 -"isACT sys (CH T1 T2) = False"
68.195 -
68.196 -fun PREF where
68.197 -"PREF sys (VAR X) =
68.198 - (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
68.199 -|
68.200 -"PREF sys (PROC p) = prefOf p"
68.201 -|
68.202 -"PREF sys (ACT a T) = a"
68.203 -
68.204 -fun CONT where
68.205 -"CONT sys (VAR X) =
68.206 - (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
68.207 -|
68.208 -"CONT sys (PROC p) = PROC (contOf p)"
68.209 -|
68.210 -"CONT sys (ACT a T) = T"
68.211 -
68.212 -fun CH1 where
68.213 -"CH1 sys (VAR X) =
68.214 - (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
68.215 -|
68.216 -"CH1 sys (PROC p) = PROC (ch1Of p)"
68.217 -|
68.218 -"CH1 sys (CH T1 T2) = T1"
68.219 -
68.220 -fun CH2 where
68.221 -"CH2 sys (VAR X) =
68.222 - (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
68.223 -|
68.224 -"CH2 sys (PROC p) = PROC (ch2Of p)"
68.225 -|
68.226 -"CH2 sys (CH T1 T2) = T2"
68.227 -
68.228 -definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
68.229 -
68.230 -definition
68.231 -"solution sys \<equiv>
68.232 - process_unfold
68.233 - (isACT sys)
68.234 - (PREF sys)
68.235 - (CONT sys)
68.236 - (CH1 sys)
68.237 - (CH2 sys)"
68.238 -
68.239 -lemma solution_Action:
68.240 -assumes "isACT sys T"
68.241 -shows "solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
68.242 -unfolding solution_def
68.243 -using process.unfolds(1)[of "isACT sys" T "PREF sys" "CONT sys" "CH1 sys" "CH2 sys"]
68.244 - assms by simp
68.245 -
68.246 -lemma solution_Choice:
68.247 -assumes "\<not> isACT sys T"
68.248 -shows "solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
68.249 -unfolding solution_def
68.250 -using process.unfolds(2)[of "isACT sys" T "PREF sys" "CONT sys" "CH1 sys" "CH2 sys"]
68.251 - assms by simp
68.252 -
68.253 -lemma isACT_VAR:
68.254 -assumes g: "guarded sys"
68.255 -shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
68.256 -using g unfolding guarded_def by (cases "sys X") auto
68.257 -
68.258 -lemma solution_VAR:
68.259 -assumes g: "guarded sys"
68.260 -shows "solution sys (VAR X) = solution sys (sys X)"
68.261 -proof(cases "isACT sys (VAR X)")
68.262 - case True
68.263 - hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
68.264 - show ?thesis
68.265 - unfolding solution_Action[OF T] using solution_Action[of sys "VAR X"] True g
68.266 - unfolding guarded_def by (cases "sys X", auto)
68.267 -next
68.268 - case False note FFalse = False
68.269 - hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
68.270 - show ?thesis
68.271 - unfolding solution_Choice[OF TT] using solution_Choice[of sys "VAR X"] FFalse g
68.272 - unfolding guarded_def by (cases "sys X", auto)
68.273 -qed
68.274 -
68.275 -lemma solution_PROC[simp]:
68.276 -"solution sys (PROC p) = p"
68.277 -proof-
68.278 - {fix q assume "q = solution sys (PROC p)"
68.279 - hence "p = q"
68.280 - proof(induct rule: process_coind)
68.281 - case (iss p p')
68.282 - from isAction_isChoice[of p] show ?case
68.283 - proof
68.284 - assume p: "isAction p"
68.285 - hence 0: "isACT sys (PROC p)" by simp
68.286 - thus ?thesis using iss not_isAction_isChoice
68.287 - unfolding solution_Action[OF 0] by auto
68.288 - next
68.289 - assume "isChoice p"
68.290 - hence 0: "\<not> isACT sys (PROC p)"
68.291 - using not_isAction_isChoice by auto
68.292 - thus ?thesis using iss isAction_isChoice
68.293 - unfolding solution_Choice[OF 0] by auto
68.294 - qed
68.295 - next
68.296 - case (Action a a' p p')
68.297 - hence 0: "isACT sys (PROC (Action a p))" by simp
68.298 - show ?case using Action unfolding solution_Action[OF 0] by simp
68.299 - next
68.300 - case (Choice p q p' q')
68.301 - hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
68.302 - show ?case using Choice unfolding solution_Choice[OF 0] by simp
68.303 - qed
68.304 - }
68.305 - thus ?thesis by metis
68.306 -qed
68.307 -
68.308 -lemma solution_ACT[simp]:
68.309 -"solution sys (ACT a T) = Action a (solution sys T)"
68.310 -by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution_Action)
68.311 -
68.312 -lemma solution_CH[simp]:
68.313 -"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
68.314 -by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution_Choice)
68.315 -
68.316 -
68.317 -(* Example: *)
68.318 -
68.319 -fun sys where
68.320 -"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
68.321 -|
68.322 -"sys (Suc 0) = ACT ''a'' (VAR 0)"
68.323 -| (* dummy guarded term for variables outside the system: *)
68.324 -"sys X = ACT ''a'' (VAR 0)"
68.325 -
68.326 -lemma guarded_sys:
68.327 -"guarded sys"
68.328 -unfolding guarded_def proof (intro allI)
68.329 - fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
68.330 -qed
68.331 -
68.332 -(* the actual processes: *)
68.333 -definition "x \<equiv> solution sys (VAR 0)"
68.334 -definition "ax \<equiv> solution sys (VAR (Suc 0))"
68.335 -
68.336 -(* end product: *)
68.337 -lemma x_ax:
68.338 -"x = Choice ax (Action ''b'' x)"
68.339 -"ax = Action ''a'' x"
68.340 -unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
68.341 -
68.342 -
68.343 -(* Thanks to the inclusion of processes as process terms, one can
68.344 -also consider parametrized systems of equations---here, x is a (semantic)
68.345 -process parameter: *)
68.346 -
68.347 -fun sys' where
68.348 -"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
68.349 -|
68.350 -"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
68.351 -| (* dummy guarded term : *)
68.352 -"sys' X = ACT ''a'' (VAR 0)"
68.353 -
68.354 -lemma guarded_sys':
68.355 -"guarded sys'"
68.356 -unfolding guarded_def proof (intro allI)
68.357 - fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
68.358 -qed
68.359 -
68.360 -(* the actual processes: *)
68.361 -definition "y \<equiv> solution sys' (VAR 0)"
68.362 -definition "ay \<equiv> solution sys' (VAR (Suc 0))"
68.363 -
68.364 -(* end product: *)
68.365 -lemma y_ay:
68.366 -"y = Choice x (Action ''b'' y)"
68.367 -"ay = Choice (Action ''a'' y) x"
68.368 -unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
68.369 -
68.370 -end
69.1 --- a/src/HOL/Codatatype/Examples/Stream.thy Fri Sep 21 16:34:40 2012 +0200
69.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
69.3 @@ -1,157 +0,0 @@
69.4 -(* Title: HOL/BNF/Examples/Stream.thy
69.5 - Author: Dmitriy Traytel, TU Muenchen
69.6 - Author: Andrei Popescu, TU Muenchen
69.7 - Copyright 2012
69.8 -
69.9 -Infinite streams.
69.10 -*)
69.11 -
69.12 -header {* Infinite Streams *}
69.13 -
69.14 -theory Stream
69.15 -imports TreeFI
69.16 -begin
69.17 -
69.18 -hide_const (open) Quotient_Product.prod_rel
69.19 -hide_fact (open) Quotient_Product.prod_rel_def
69.20 -
69.21 -codata_raw stream: 's = "'a \<times> 's"
69.22 -
69.23 -(* selectors for streams *)
69.24 -definition "hdd as \<equiv> fst (stream_dtor as)"
69.25 -definition "tll as \<equiv> snd (stream_dtor as)"
69.26 -
69.27 -lemma unfold_pair_fun_hdd[simp]: "hdd (stream_dtor_unfold (f \<odot> g) t) = f t"
69.28 -unfolding hdd_def pair_fun_def stream.dtor_unfolds by simp
69.29 -
69.30 -lemma unfold_pair_fun_tll[simp]: "tll (stream_dtor_unfold (f \<odot> g) t) =
69.31 - stream_dtor_unfold (f \<odot> g) (g t)"
69.32 -unfolding tll_def pair_fun_def stream.dtor_unfolds by simp
69.33 -
69.34 -(* infinite trees: *)
69.35 -coinductive infiniteTr where
69.36 -"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
69.37 -
69.38 -lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
69.39 -assumes *: "phi tr" and
69.40 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
69.41 -shows "infiniteTr tr"
69.42 -using assms by (elim infiniteTr.coinduct) blast
69.43 -
69.44 -lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
69.45 -assumes *: "phi tr" and
69.46 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
69.47 -shows "infiniteTr tr"
69.48 -using assms by (elim infiniteTr.coinduct) blast
69.49 -
69.50 -lemma infiniteTr_sub[simp]:
69.51 -"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
69.52 -by (erule infiniteTr.cases) blast
69.53 -
69.54 -definition "konigPath \<equiv> stream_dtor_unfold
69.55 - (lab \<odot> (\<lambda>tr. SOME tr'. tr' \<in> listF_set (sub tr) \<and> infiniteTr tr'))"
69.56 -
69.57 -lemma hdd_simps1[simp]: "hdd (konigPath t) = lab t"
69.58 -unfolding konigPath_def by simp
69.59 -
69.60 -lemma tll_simps2[simp]: "tll (konigPath t) =
69.61 - konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
69.62 -unfolding konigPath_def by simp
69.63 -
69.64 -(* proper paths in trees: *)
69.65 -coinductive properPath where
69.66 -"\<lbrakk>hdd as = lab tr; tr' \<in> listF_set (sub tr); properPath (tll as) tr'\<rbrakk> \<Longrightarrow>
69.67 - properPath as tr"
69.68 -
69.69 -lemma properPath_strong_coind[consumes 1, case_names hdd_lab sub]:
69.70 -assumes *: "phi as tr" and
69.71 -**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
69.72 -***: "\<And> as tr.
69.73 - phi as tr \<Longrightarrow>
69.74 - \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
69.75 -shows "properPath as tr"
69.76 -using assms by (elim properPath.coinduct) blast
69.77 -
69.78 -lemma properPath_coind[consumes 1, case_names hdd_lab sub, induct pred: properPath]:
69.79 -assumes *: "phi as tr" and
69.80 -**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
69.81 -***: "\<And> as tr.
69.82 - phi as tr \<Longrightarrow>
69.83 - \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr'"
69.84 -shows "properPath as tr"
69.85 -using properPath_strong_coind[of phi, OF * **] *** by blast
69.86 -
69.87 -lemma properPath_hdd_lab:
69.88 -"properPath as tr \<Longrightarrow> hdd as = lab tr"
69.89 -by (erule properPath.cases) blast
69.90 -
69.91 -lemma properPath_sub:
69.92 -"properPath as tr \<Longrightarrow>
69.93 - \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
69.94 -by (erule properPath.cases) blast
69.95 -
69.96 -(* prove the following by coinduction *)
69.97 -theorem Konig:
69.98 - assumes "infiniteTr tr"
69.99 - shows "properPath (konigPath tr) tr"
69.100 -proof-
69.101 - {fix as
69.102 - assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
69.103 - proof (induct rule: properPath_coind, safe)
69.104 - fix t
69.105 - let ?t = "SOME t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'"
69.106 - assume "infiniteTr t"
69.107 - hence "\<exists>t' \<in> listF_set (sub t). infiniteTr t'" by simp
69.108 - hence "\<exists>t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'" by blast
69.109 - hence "?t \<in> listF_set (sub t) \<and> infiniteTr ?t" by (elim someI_ex)
69.110 - moreover have "tll (konigPath t) = konigPath ?t" by simp
69.111 - ultimately show "\<exists>t' \<in> listF_set (sub t).
69.112 - infiniteTr t' \<and> tll (konigPath t) = konigPath t'" by blast
69.113 - qed simp
69.114 - }
69.115 - thus ?thesis using assms by blast
69.116 -qed
69.117 -
69.118 -(* some more stream theorems *)
69.119 -
69.120 -lemma stream_map[simp]: "stream_map f = stream_dtor_unfold (f o hdd \<odot> tll)"
69.121 -unfolding stream_map_def pair_fun_def hdd_def[abs_def] tll_def[abs_def]
69.122 - map_pair_def o_def prod_case_beta by simp
69.123 -
69.124 -lemma prod_rel[simp]: "prod_rel \<phi>1 \<phi>2 a b = (\<phi>1 (fst a) (fst b) \<and> \<phi>2 (snd a) (snd b))"
69.125 -unfolding prod_rel_def by auto
69.126 -
69.127 -lemmas stream_coind =
69.128 - mp[OF stream.rel_coinduct, unfolded prod_rel[abs_def], folded hdd_def tll_def]
69.129 -
69.130 -definition plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
69.131 - [simp]: "plus xs ys =
69.132 - stream_dtor_unfold ((%(xs, ys). hdd xs + hdd ys) \<odot> (%(xs, ys). (tll xs, tll ys))) (xs, ys)"
69.133 -
69.134 -definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
69.135 - [simp]: "scalar n = stream_map (\<lambda>x. n * x)"
69.136 -
69.137 -definition ones :: "nat stream" where [simp]: "ones = stream_dtor_unfold ((%x. 1) \<odot> id) ()"
69.138 -definition twos :: "nat stream" where [simp]: "twos = stream_dtor_unfold ((%x. 2) \<odot> id) ()"
69.139 -definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
69.140 -
69.141 -lemma "ones \<oplus> ones = twos"
69.142 -by (intro stream_coind[where P="%x1 x2. \<exists>x. x1 = ones \<oplus> ones \<and> x2 = twos"]) auto
69.143 -
69.144 -lemma "n \<cdot> twos = ns (2 * n)"
69.145 -by (intro stream_coind[where P="%x1 x2. \<exists>n. x1 = n \<cdot> twos \<and> x2 = ns (2 * n)"]) force+
69.146 -
69.147 -lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
69.148 -by (intro stream_coind[where P="%x1 x2. \<exists>n m xs. x1 = (n * m) \<cdot> xs \<and> x2 = n \<cdot> m \<cdot> xs"]) force+
69.149 -
69.150 -lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
69.151 -by (intro stream_coind[where P="%x1 x2. \<exists>n xs ys. x1 = n \<cdot> (xs \<oplus> ys) \<and> x2 = n \<cdot> xs \<oplus> n \<cdot> ys"])
69.152 - (force simp: add_mult_distrib2)+
69.153 -
69.154 -lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
69.155 -by (intro stream_coind[where P="%x1 x2. \<exists>xs ys. x1 = xs \<oplus> ys \<and> x2 = ys \<oplus> xs"]) force+
69.156 -
69.157 -lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
69.158 -by (intro stream_coind[where P="%x1 x2. \<exists>xs ys zs. x1 = (xs \<oplus> ys) \<oplus> zs \<and> x2 = xs \<oplus> ys \<oplus> zs"]) force+
69.159 -
69.160 -end
70.1 --- a/src/HOL/Codatatype/Examples/TreeFI.thy Fri Sep 21 16:34:40 2012 +0200
70.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
70.3 @@ -1,83 +0,0 @@
70.4 -(* Title: HOL/BNF/Examples/TreeFI.thy
70.5 - Author: Dmitriy Traytel, TU Muenchen
70.6 - Author: Andrei Popescu, TU Muenchen
70.7 - Copyright 2012
70.8 -
70.9 -Finitely branching possibly infinite trees.
70.10 -*)
70.11 -
70.12 -header {* Finitely Branching Possibly Infinite Trees *}
70.13 -
70.14 -theory TreeFI
70.15 -imports ListF
70.16 -begin
70.17 -
70.18 -hide_const (open) Sublist.sub
70.19 -
70.20 -codata_raw treeFI: 'tree = "'a \<times> 'tree listF"
70.21 -
70.22 -lemma pre_treeFI_listF_set[simp]: "pre_treeFI_set2 (i, xs) = listF_set xs"
70.23 -unfolding pre_treeFI_set2_def collect_def[abs_def] prod_set_defs
70.24 -by (auto simp add: listF.set_natural')
70.25 -
70.26 -(* selectors for trees *)
70.27 -definition "lab tr \<equiv> fst (treeFI_dtor tr)"
70.28 -definition "sub tr \<equiv> snd (treeFI_dtor tr)"
70.29 -
70.30 -lemma dtor[simp]: "treeFI_dtor tr = (lab tr, sub tr)"
70.31 -unfolding lab_def sub_def by simp
70.32 -
70.33 -definition pair_fun (infixr "\<odot>" 50) where
70.34 - "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
70.35 -
70.36 -lemma unfold_pair_fun_lab: "lab (treeFI_dtor_unfold (f \<odot> g) t) = f t"
70.37 -unfolding lab_def pair_fun_def treeFI.dtor_unfolds pre_treeFI_map_def by simp
70.38 -
70.39 -lemma unfold_pair_fun_sub: "sub (treeFI_dtor_unfold (f \<odot> g) t) = listF_map (treeFI_dtor_unfold (f \<odot> g)) (g t)"
70.40 -unfolding sub_def pair_fun_def treeFI.dtor_unfolds pre_treeFI_map_def by simp
70.41 -
70.42 -(* Tree reverse:*)
70.43 -definition "trev \<equiv> treeFI_dtor_unfold (lab \<odot> lrev o sub)"
70.44 -
70.45 -lemma trev_simps1[simp]: "lab (trev t) = lab t"
70.46 -unfolding trev_def by (simp add: unfold_pair_fun_lab)
70.47 -
70.48 -lemma trev_simps2[simp]: "sub (trev t) = listF_map trev (lrev (sub t))"
70.49 -unfolding trev_def by (simp add: unfold_pair_fun_sub)
70.50 -
70.51 -lemma treeFI_coinduct:
70.52 -assumes *: "phi x y"
70.53 -and step: "\<And>a b. phi a b \<Longrightarrow>
70.54 - lab a = lab b \<and>
70.55 - lengthh (sub a) = lengthh (sub b) \<and>
70.56 - (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
70.57 -shows "x = y"
70.58 -proof (rule mp[OF treeFI.dtor_coinduct, of phi, OF _ *])
70.59 - fix a b :: "'a treeFI"
70.60 - let ?zs = "zipp (sub a) (sub b)"
70.61 - let ?z = "(lab a, ?zs)"
70.62 - assume "phi a b"
70.63 - with step have step': "lab a = lab b" "lengthh (sub a) = lengthh (sub b)"
70.64 - "\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i)" by auto
70.65 - hence "pre_treeFI_map id fst ?z = treeFI_dtor a" "pre_treeFI_map id snd ?z = treeFI_dtor b"
70.66 - unfolding pre_treeFI_map_def by auto
70.67 - moreover have "\<forall>(x, y) \<in> pre_treeFI_set2 ?z. phi x y"
70.68 - proof safe
70.69 - fix z1 z2
70.70 - assume "(z1, z2) \<in> pre_treeFI_set2 ?z"
70.71 - hence "(z1, z2) \<in> listF_set ?zs" by auto
70.72 - hence "\<exists>i < lengthh ?zs. nthh ?zs i = (z1, z2)" by auto
70.73 - with step'(2) obtain i where "i < lengthh (sub a)"
70.74 - "nthh (sub a) i = z1" "nthh (sub b) i = z2" by auto
70.75 - with step'(3) show "phi z1 z2" by auto
70.76 - qed
70.77 - ultimately show "\<exists>z.
70.78 - (pre_treeFI_map id fst z = treeFI_dtor a \<and>
70.79 - pre_treeFI_map id snd z = treeFI_dtor b) \<and>
70.80 - (\<forall>x y. (x, y) \<in> pre_treeFI_set2 z \<longrightarrow> phi x y)" by blast
70.81 -qed
70.82 -
70.83 -lemma trev_trev: "trev (trev tr) = tr"
70.84 -by (rule treeFI_coinduct[of "%a b. trev (trev b) = a"]) auto
70.85 -
70.86 -end
71.1 --- a/src/HOL/Codatatype/Examples/TreeFsetI.thy Fri Sep 21 16:34:40 2012 +0200
71.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
71.3 @@ -1,59 +0,0 @@
71.4 -(* Title: HOL/BNF/Examples/TreeFsetI.thy
71.5 - Author: Dmitriy Traytel, TU Muenchen
71.6 - Author: Andrei Popescu, TU Muenchen
71.7 - Copyright 2012
71.8 -
71.9 -Finitely branching possibly infinite trees, with sets of children.
71.10 -*)
71.11 -
71.12 -header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
71.13 -
71.14 -theory TreeFsetI
71.15 -imports "../BNF"
71.16 -begin
71.17 -
71.18 -hide_const (open) Sublist.sub
71.19 -hide_fact (open) Quotient_Product.prod_rel_def
71.20 -
71.21 -definition pair_fun (infixr "\<odot>" 50) where
71.22 - "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
71.23 -
71.24 -codata_raw treeFsetI: 't = "'a \<times> 't fset"
71.25 -
71.26 -(* selectors for trees *)
71.27 -definition "lab t \<equiv> fst (treeFsetI_dtor t)"
71.28 -definition "sub t \<equiv> snd (treeFsetI_dtor t)"
71.29 -
71.30 -lemma dtor[simp]: "treeFsetI_dtor t = (lab t, sub t)"
71.31 -unfolding lab_def sub_def by simp
71.32 -
71.33 -lemma unfold_pair_fun_lab: "lab (treeFsetI_dtor_unfold (f \<odot> g) t) = f t"
71.34 -unfolding lab_def pair_fun_def treeFsetI.dtor_unfolds pre_treeFsetI_map_def by simp
71.35 -
71.36 -lemma unfold_pair_fun_sub: "sub (treeFsetI_dtor_unfold (f \<odot> g) t) = map_fset (treeFsetI_dtor_unfold (f \<odot> g)) (g t)"
71.37 -unfolding sub_def pair_fun_def treeFsetI.dtor_unfolds pre_treeFsetI_map_def by simp
71.38 -
71.39 -(* tree map (contrived example): *)
71.40 -definition "tmap f \<equiv> treeFsetI_dtor_unfold (f o lab \<odot> sub)"
71.41 -
71.42 -lemma tmap_simps1[simp]: "lab (tmap f t) = f (lab t)"
71.43 -unfolding tmap_def by (simp add: unfold_pair_fun_lab)
71.44 -
71.45 -lemma trev_simps2[simp]: "sub (tmap f t) = map_fset (tmap f) (sub t)"
71.46 -unfolding tmap_def by (simp add: unfold_pair_fun_sub)
71.47 -
71.48 -lemma pre_treeFsetI_rel[simp]: "pre_treeFsetI_rel R1 R2 a b = (R1 (fst a) (fst b) \<and>
71.49 - (\<forall>t \<in> fset (snd a). (\<exists>u \<in> fset (snd b). R2 t u)) \<and>
71.50 - (\<forall>t \<in> fset (snd b). (\<exists>u \<in> fset (snd a). R2 u t)))"
71.51 -apply (cases a)
71.52 -apply (cases b)
71.53 -apply (simp add: pre_treeFsetI_rel_def prod_rel_def fset_rel_def)
71.54 -done
71.55 -
71.56 -lemmas treeFsetI_coind = mp[OF treeFsetI.rel_coinduct]
71.57 -
71.58 -lemma "tmap (f o g) x = tmap f (tmap g x)"
71.59 -by (intro treeFsetI_coind[where P="%x1 x2. \<exists>x. x1 = tmap (f o g) x \<and> x2 = tmap f (tmap g x)"])
71.60 - force+
71.61 -
71.62 -end
72.1 --- a/src/HOL/Codatatype/More_BNFs.thy Fri Sep 21 16:34:40 2012 +0200
72.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
72.3 @@ -1,1511 +0,0 @@
72.4 -(* Title: HOL/BNF/More_BNFs.thy
72.5 - Author: Dmitriy Traytel, TU Muenchen
72.6 - Author: Andrei Popescu, TU Muenchen
72.7 - Author: Andreas Lochbihler, Karlsruhe Institute of Technology
72.8 - Author: Jasmin Blanchette, TU Muenchen
72.9 - Copyright 2012
72.10 -
72.11 -Registration of various types as bounded natural functors.
72.12 -*)
72.13 -
72.14 -header {* Registration of Various Types as Bounded Natural Functors *}
72.15 -
72.16 -theory More_BNFs
72.17 -imports
72.18 - BNF_LFP
72.19 - BNF_GFP
72.20 - "~~/src/HOL/Quotient_Examples/FSet"
72.21 - "~~/src/HOL/Library/Multiset"
72.22 - Countable_Set
72.23 -begin
72.24 -
72.25 -lemma option_rec_conv_option_case: "option_rec = option_case"
72.26 -by (simp add: fun_eq_iff split: option.split)
72.27 -
72.28 -definition option_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> bool" where
72.29 -"option_rel R x_opt y_opt =
72.30 - (case (x_opt, y_opt) of
72.31 - (None, None) \<Rightarrow> True
72.32 - | (Some x, Some y) \<Rightarrow> R x y
72.33 - | _ \<Rightarrow> False)"
72.34 -
72.35 -bnf_def Option.map [Option.set] "\<lambda>_::'a option. natLeq" ["None"] option_rel
72.36 -proof -
72.37 - show "Option.map id = id" by (simp add: fun_eq_iff Option.map_def split: option.split)
72.38 -next
72.39 - fix f g
72.40 - show "Option.map (g \<circ> f) = Option.map g \<circ> Option.map f"
72.41 - by (auto simp add: fun_eq_iff Option.map_def split: option.split)
72.42 -next
72.43 - fix f g x
72.44 - assume "\<And>z. z \<in> Option.set x \<Longrightarrow> f z = g z"
72.45 - thus "Option.map f x = Option.map g x"
72.46 - by (simp cong: Option.map_cong)
72.47 -next
72.48 - fix f
72.49 - show "Option.set \<circ> Option.map f = op ` f \<circ> Option.set"
72.50 - by fastforce
72.51 -next
72.52 - show "card_order natLeq" by (rule natLeq_card_order)
72.53 -next
72.54 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
72.55 -next
72.56 - fix x
72.57 - show "|Option.set x| \<le>o natLeq"
72.58 - by (cases x) (simp_all add: ordLess_imp_ordLeq finite_iff_ordLess_natLeq[symmetric])
72.59 -next
72.60 - fix A
72.61 - have unfold: "{x. Option.set x \<subseteq> A} = Some ` A \<union> {None}"
72.62 - by (auto simp add: option_rec_conv_option_case Option.set_def split: option.split_asm)
72.63 - show "|{x. Option.set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
72.64 - apply (rule ordIso_ordLeq_trans)
72.65 - apply (rule card_of_ordIso_subst[OF unfold])
72.66 - apply (rule ordLeq_transitive)
72.67 - apply (rule Un_csum)
72.68 - apply (rule ordLeq_transitive)
72.69 - apply (rule csum_mono)
72.70 - apply (rule card_of_image)
72.71 - apply (rule ordIso_ordLeq_trans)
72.72 - apply (rule single_cone)
72.73 - apply (rule cone_ordLeq_ctwo)
72.74 - apply (rule ordLeq_cexp1)
72.75 - apply (simp_all add: natLeq_cinfinite natLeq_Card_order cinfinite_not_czero Card_order_csum)
72.76 - done
72.77 -next
72.78 - fix A B1 B2 f1 f2 p1 p2
72.79 - assume wpull: "wpull A B1 B2 f1 f2 p1 p2"
72.80 - show "wpull {x. Option.set x \<subseteq> A} {x. Option.set x \<subseteq> B1} {x. Option.set x \<subseteq> B2}
72.81 - (Option.map f1) (Option.map f2) (Option.map p1) (Option.map p2)"
72.82 - (is "wpull ?A ?B1 ?B2 ?f1 ?f2 ?p1 ?p2")
72.83 - unfolding wpull_def
72.84 - proof (intro strip, elim conjE)
72.85 - fix b1 b2
72.86 - assume "b1 \<in> ?B1" "b2 \<in> ?B2" "?f1 b1 = ?f2 b2"
72.87 - thus "\<exists>a \<in> ?A. ?p1 a = b1 \<and> ?p2 a = b2" using wpull
72.88 - unfolding wpull_def by (cases b2) (auto 4 5)
72.89 - qed
72.90 -next
72.91 - fix z
72.92 - assume "z \<in> Option.set None"
72.93 - thus False by simp
72.94 -next
72.95 - fix R
72.96 - show "{p. option_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
72.97 - (Gr {x. Option.set x \<subseteq> R} (Option.map fst))\<inverse> O Gr {x. Option.set x \<subseteq> R} (Option.map snd)"
72.98 - unfolding option_rel_def Gr_def relcomp_unfold converse_unfold
72.99 - by (auto simp: trans[OF eq_commute option_map_is_None] trans[OF eq_commute option_map_eq_Some]
72.100 - split: option.splits) blast
72.101 -qed
72.102 -
72.103 -lemma card_of_list_in:
72.104 - "|{xs. set xs \<subseteq> A}| \<le>o |Pfunc (UNIV :: nat set) A|" (is "|?LHS| \<le>o |?RHS|")
72.105 -proof -
72.106 - let ?f = "%xs. %i. if i < length xs \<and> set xs \<subseteq> A then Some (nth xs i) else None"
72.107 - have "inj_on ?f ?LHS" unfolding inj_on_def fun_eq_iff
72.108 - proof safe
72.109 - fix xs :: "'a list" and ys :: "'a list"
72.110 - assume su: "set xs \<subseteq> A" "set ys \<subseteq> A" and eq: "\<forall>i. ?f xs i = ?f ys i"
72.111 - hence *: "length xs = length ys"
72.112 - by (metis linorder_cases option.simps(2) order_less_irrefl)
72.113 - thus "xs = ys" by (rule nth_equalityI) (metis * eq su option.inject)
72.114 - qed
72.115 - moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Pfunc_def by fastforce
72.116 - ultimately show ?thesis using card_of_ordLeq by blast
72.117 -qed
72.118 -
72.119 -lemma list_in_empty: "A = {} \<Longrightarrow> {x. set x \<subseteq> A} = {[]}"
72.120 -by simp
72.121 -
72.122 -lemma card_of_Func: "|Func A B| =o |B| ^c |A|"
72.123 -unfolding cexp_def Field_card_of by (rule card_of_refl)
72.124 -
72.125 -lemma not_emp_czero_notIn_ordIso_Card_order:
72.126 -"A \<noteq> {} \<Longrightarrow> ( |A|, czero) \<notin> ordIso \<and> Card_order |A|"
72.127 - apply (rule conjI)
72.128 - apply (metis Field_card_of czeroE)
72.129 - by (rule card_of_Card_order)
72.130 -
72.131 -lemma list_in_bd: "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
72.132 -proof -
72.133 - fix A :: "'a set"
72.134 - show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
72.135 - proof (cases "A = {}")
72.136 - case False thus ?thesis
72.137 - apply -
72.138 - apply (rule ordLeq_transitive)
72.139 - apply (rule card_of_list_in)
72.140 - apply (rule ordLeq_transitive)
72.141 - apply (erule card_of_Pfunc_Pow_Func)
72.142 - apply (rule ordIso_ordLeq_trans)
72.143 - apply (rule Times_cprod)
72.144 - apply (rule cprod_cinfinite_bound)
72.145 - apply (rule ordIso_ordLeq_trans)
72.146 - apply (rule Pow_cexp_ctwo)
72.147 - apply (rule ordIso_ordLeq_trans)
72.148 - apply (rule cexp_cong2)
72.149 - apply (rule card_of_nat)
72.150 - apply (rule Card_order_ctwo)
72.151 - apply (rule card_of_Card_order)
72.152 - apply (rule natLeq_Card_order)
72.153 - apply (rule disjI1)
72.154 - apply (rule ctwo_Cnotzero)
72.155 - apply (rule cexp_mono1)
72.156 - apply (rule ordLeq_csum2)
72.157 - apply (rule Card_order_ctwo)
72.158 - apply (rule disjI1)
72.159 - apply (rule ctwo_Cnotzero)
72.160 - apply (rule natLeq_Card_order)
72.161 - apply (rule ordIso_ordLeq_trans)
72.162 - apply (rule card_of_Func)
72.163 - apply (rule ordIso_ordLeq_trans)
72.164 - apply (rule cexp_cong2)
72.165 - apply (rule card_of_nat)
72.166 - apply (rule card_of_Card_order)
72.167 - apply (rule card_of_Card_order)
72.168 - apply (rule natLeq_Card_order)
72.169 - apply (rule disjI1)
72.170 - apply (erule not_emp_czero_notIn_ordIso_Card_order)
72.171 - apply (rule cexp_mono1)
72.172 - apply (rule ordLeq_csum1)
72.173 - apply (rule card_of_Card_order)
72.174 - apply (rule disjI1)
72.175 - apply (erule not_emp_czero_notIn_ordIso_Card_order)
72.176 - apply (rule natLeq_Card_order)
72.177 - apply (rule card_of_Card_order)
72.178 - apply (rule card_of_Card_order)
72.179 - apply (rule Cinfinite_cexp)
72.180 - apply (rule ordLeq_csum2)
72.181 - apply (rule Card_order_ctwo)
72.182 - apply (rule conjI)
72.183 - apply (rule natLeq_cinfinite)
72.184 - by (rule natLeq_Card_order)
72.185 - next
72.186 - case True thus ?thesis
72.187 - apply -
72.188 - apply (rule ordIso_ordLeq_trans)
72.189 - apply (rule card_of_ordIso_subst)
72.190 - apply (erule list_in_empty)
72.191 - apply (rule ordIso_ordLeq_trans)
72.192 - apply (rule single_cone)
72.193 - apply (rule cone_ordLeq_cexp)
72.194 - apply (rule ordLeq_transitive)
72.195 - apply (rule cone_ordLeq_ctwo)
72.196 - apply (rule ordLeq_csum2)
72.197 - by (rule Card_order_ctwo)
72.198 - qed
72.199 -qed
72.200 -
72.201 -bnf_def map [set] "\<lambda>_::'a list. natLeq" ["[]"]
72.202 -proof -
72.203 - show "map id = id" by (rule List.map.id)
72.204 -next
72.205 - fix f g
72.206 - show "map (g o f) = map g o map f" by (rule List.map.comp[symmetric])
72.207 -next
72.208 - fix x f g
72.209 - assume "\<And>z. z \<in> set x \<Longrightarrow> f z = g z"
72.210 - thus "map f x = map g x" by simp
72.211 -next
72.212 - fix f
72.213 - show "set o map f = image f o set" by (rule ext, unfold o_apply, rule set_map)
72.214 -next
72.215 - show "card_order natLeq" by (rule natLeq_card_order)
72.216 -next
72.217 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
72.218 -next
72.219 - fix x
72.220 - show "|set x| \<le>o natLeq"
72.221 - apply (rule ordLess_imp_ordLeq)
72.222 - apply (rule finite_ordLess_infinite[OF _ natLeq_Well_order])
72.223 - unfolding Field_natLeq Field_card_of by (auto simp: card_of_well_order_on)
72.224 -next
72.225 - fix A :: "'a set"
72.226 - show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
72.227 -next
72.228 - fix A B1 B2 f1 f2 p1 p2
72.229 - assume "wpull A B1 B2 f1 f2 p1 p2"
72.230 - hence pull: "\<And>b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<Longrightarrow> \<exists>a \<in> A. p1 a = b1 \<and> p2 a = b2"
72.231 - unfolding wpull_def by auto
72.232 - show "wpull {x. set x \<subseteq> A} {x. set x \<subseteq> B1} {x. set x \<subseteq> B2} (map f1) (map f2) (map p1) (map p2)"
72.233 - (is "wpull ?A ?B1 ?B2 _ _ _ _")
72.234 - proof (unfold wpull_def)
72.235 - { fix as bs assume *: "as \<in> ?B1" "bs \<in> ?B2" "map f1 as = map f2 bs"
72.236 - hence "length as = length bs" by (metis length_map)
72.237 - hence "\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs" using *
72.238 - proof (induct as bs rule: list_induct2)
72.239 - case (Cons a as b bs)
72.240 - hence "a \<in> B1" "b \<in> B2" "f1 a = f2 b" by auto
72.241 - with pull obtain z where "z \<in> A" "p1 z = a" "p2 z = b" by blast
72.242 - moreover
72.243 - from Cons obtain zs where "zs \<in> ?A" "map p1 zs = as" "map p2 zs = bs" by auto
72.244 - ultimately have "z # zs \<in> ?A" "map p1 (z # zs) = a # as \<and> map p2 (z # zs) = b # bs" by auto
72.245 - thus ?case by (rule_tac x = "z # zs" in bexI)
72.246 - qed simp
72.247 - }
72.248 - thus "\<forall>as bs. as \<in> ?B1 \<and> bs \<in> ?B2 \<and> map f1 as = map f2 bs \<longrightarrow>
72.249 - (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
72.250 - qed
72.251 -qed simp+
72.252 -
72.253 -(* Finite sets *)
72.254 -abbreviation afset where "afset \<equiv> abs_fset"
72.255 -abbreviation rfset where "rfset \<equiv> rep_fset"
72.256 -
72.257 -lemma fset_fset_member:
72.258 -"fset A = {a. a |\<in>| A}"
72.259 -unfolding fset_def fset_member_def by auto
72.260 -
72.261 -lemma afset_rfset:
72.262 -"afset (rfset x) = x"
72.263 -by (rule Quotient_fset[unfolded Quotient_def, THEN conjunct1, rule_format])
72.264 -
72.265 -lemma afset_rfset_id:
72.266 -"afset o rfset = id"
72.267 -unfolding comp_def afset_rfset id_def ..
72.268 -
72.269 -lemma rfset:
72.270 -"rfset A = rfset B \<longleftrightarrow> A = B"
72.271 -by (metis afset_rfset)
72.272 -
72.273 -lemma afset_set:
72.274 -"afset as = afset bs \<longleftrightarrow> set as = set bs"
72.275 -using Quotient_fset unfolding Quotient_def list_eq_def by auto
72.276 -
72.277 -lemma surj_afset:
72.278 -"\<exists> as. A = afset as"
72.279 -by (metis afset_rfset)
72.280 -
72.281 -lemma fset_def2:
72.282 -"fset = set o rfset"
72.283 -unfolding fset_def map_fun_def[abs_def] by simp
72.284 -
72.285 -lemma fset_def2_raw:
72.286 -"fset A = set (rfset A)"
72.287 -unfolding fset_def2 by simp
72.288 -
72.289 -lemma fset_comp_afset:
72.290 -"fset o afset = set"
72.291 -unfolding fset_def2 comp_def apply(rule ext)
72.292 -unfolding afset_set[symmetric] afset_rfset ..
72.293 -
72.294 -lemma fset_afset:
72.295 -"fset (afset as) = set as"
72.296 -unfolding fset_comp_afset[symmetric] by simp
72.297 -
72.298 -lemma set_rfset_afset:
72.299 -"set (rfset (afset as)) = set as"
72.300 -unfolding afset_set[symmetric] afset_rfset ..
72.301 -
72.302 -lemma map_fset_comp_afset:
72.303 -"(map_fset f) o afset = afset o (map f)"
72.304 -unfolding map_fset_def map_fun_def[abs_def] comp_def apply(rule ext)
72.305 -unfolding afset_set set_map set_rfset_afset id_apply ..
72.306 -
72.307 -lemma map_fset_afset:
72.308 -"(map_fset f) (afset as) = afset (map f as)"
72.309 -using map_fset_comp_afset unfolding comp_def fun_eq_iff by auto
72.310 -
72.311 -lemma fset_map_fset:
72.312 -"fset (map_fset f A) = (image f) (fset A)"
72.313 -apply(subst afset_rfset[symmetric, of A])
72.314 -unfolding map_fset_afset fset_afset set_map
72.315 -unfolding fset_def2_raw ..
72.316 -
72.317 -lemma map_fset_def2:
72.318 -"map_fset f = afset o (map f) o rfset"
72.319 -unfolding map_fset_def map_fun_def[abs_def] by simp
72.320 -
72.321 -lemma map_fset_def2_raw:
72.322 -"map_fset f A = afset (map f (rfset A))"
72.323 -unfolding map_fset_def2 by simp
72.324 -
72.325 -lemma finite_ex_fset:
72.326 -assumes "finite A"
72.327 -shows "\<exists> B. fset B = A"
72.328 -by (metis assms finite_list fset_afset)
72.329 -
72.330 -lemma wpull_image:
72.331 -assumes "wpull A B1 B2 f1 f2 p1 p2"
72.332 -shows "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
72.333 -unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
72.334 - fix Y1 Y2 assume Y1: "Y1 \<subseteq> B1" and Y2: "Y2 \<subseteq> B2" and EQ: "f1 ` Y1 = f2 ` Y2"
72.335 - def X \<equiv> "{a \<in> A. p1 a \<in> Y1 \<and> p2 a \<in> Y2}"
72.336 - show "\<exists>X\<subseteq>A. p1 ` X = Y1 \<and> p2 ` X = Y2"
72.337 - proof (rule exI[of _ X], intro conjI)
72.338 - show "p1 ` X = Y1"
72.339 - proof
72.340 - show "Y1 \<subseteq> p1 ` X"
72.341 - proof safe
72.342 - fix y1 assume y1: "y1 \<in> Y1"
72.343 - then obtain y2 where y2: "y2 \<in> Y2" and eq: "f1 y1 = f2 y2" using EQ by auto
72.344 - then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
72.345 - using assms y1 Y1 Y2 unfolding wpull_def by blast
72.346 - thus "y1 \<in> p1 ` X" unfolding X_def using y1 y2 by auto
72.347 - qed
72.348 - qed(unfold X_def, auto)
72.349 - show "p2 ` X = Y2"
72.350 - proof
72.351 - show "Y2 \<subseteq> p2 ` X"
72.352 - proof safe
72.353 - fix y2 assume y2: "y2 \<in> Y2"
72.354 - then obtain y1 where y1: "y1 \<in> Y1" and eq: "f1 y1 = f2 y2" using EQ by force
72.355 - then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
72.356 - using assms y2 Y1 Y2 unfolding wpull_def by blast
72.357 - thus "y2 \<in> p2 ` X" unfolding X_def using y1 y2 by auto
72.358 - qed
72.359 - qed(unfold X_def, auto)
72.360 - qed(unfold X_def, auto)
72.361 -qed
72.362 -
72.363 -lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
72.364 -by (rule f_the_inv_into_f) (auto simp: inj_on_def fset_cong dest!: finite_ex_fset)
72.365 -
72.366 -definition fset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> bool" where
72.367 -"fset_rel R a b \<longleftrightarrow>
72.368 - (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and>
72.369 - (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
72.370 -
72.371 -lemma fset_rel_aux:
72.372 -"(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
72.373 - (a, b) \<in> (Gr {a. fset a \<subseteq> {(a, b). R a b}} (map_fset fst))\<inverse> O
72.374 - Gr {a. fset a \<subseteq> {(a, b). R a b}} (map_fset snd)" (is "?L = ?R")
72.375 -proof
72.376 - assume ?L
72.377 - def R' \<equiv> "the_inv fset (Collect (split R) \<inter> (fset a \<times> fset b))" (is "the_inv fset ?L'")
72.378 - have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) auto
72.379 - hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
72.380 - show ?R unfolding Gr_def relcomp_unfold converse_unfold
72.381 - proof (intro CollectI prod_caseI exI conjI)
72.382 - from * show "(R', a) = (R', map_fset fst R')" using conjunct1[OF `?L`]
72.383 - by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
72.384 - from * show "(R', b) = (R', map_fset snd R')" using conjunct2[OF `?L`]
72.385 - by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
72.386 - qed (auto simp add: *)
72.387 -next
72.388 - assume ?R thus ?L unfolding Gr_def relcomp_unfold converse_unfold
72.389 - apply (simp add: subset_eq Ball_def)
72.390 - apply (rule conjI)
72.391 - apply (clarsimp, metis snd_conv)
72.392 - by (clarsimp, metis fst_conv)
72.393 -qed
72.394 -
72.395 -bnf_def map_fset [fset] "\<lambda>_::'a fset. natLeq" ["{||}"] fset_rel
72.396 -proof -
72.397 - show "map_fset id = id"
72.398 - unfolding map_fset_def2 map_id o_id afset_rfset_id ..
72.399 -next
72.400 - fix f g
72.401 - show "map_fset (g o f) = map_fset g o map_fset f"
72.402 - unfolding map_fset_def2 map.comp[symmetric] comp_def apply(rule ext)
72.403 - unfolding afset_set set_map fset_def2_raw[symmetric] image_image[symmetric]
72.404 - unfolding map_fset_afset[symmetric] map_fset_image afset_rfset
72.405 - by (rule refl)
72.406 -next
72.407 - fix x f g
72.408 - assume "\<And>z. z \<in> fset x \<Longrightarrow> f z = g z"
72.409 - hence "map f (rfset x) = map g (rfset x)"
72.410 - apply(intro map_cong) unfolding fset_def2_raw by auto
72.411 - thus "map_fset f x = map_fset g x" unfolding map_fset_def2_raw
72.412 - by (rule arg_cong)
72.413 -next
72.414 - fix f
72.415 - show "fset o map_fset f = image f o fset"
72.416 - unfolding comp_def fset_map_fset ..
72.417 -next
72.418 - show "card_order natLeq" by (rule natLeq_card_order)
72.419 -next
72.420 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
72.421 -next
72.422 - fix x
72.423 - show "|fset x| \<le>o natLeq"
72.424 - unfolding fset_def2_raw
72.425 - apply (rule ordLess_imp_ordLeq)
72.426 - apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
72.427 - by (rule finite_set)
72.428 -next
72.429 - fix A :: "'a set"
72.430 - have "|{x. fset x \<subseteq> A}| \<le>o |afset ` {as. set as \<subseteq> A}|"
72.431 - apply(rule card_of_mono1) unfolding fset_def2_raw apply auto
72.432 - apply (rule image_eqI)
72.433 - by (auto simp: afset_rfset)
72.434 - also have "|afset ` {as. set as \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_image .
72.435 - also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
72.436 - finally show "|{x. fset x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
72.437 -next
72.438 - fix A B1 B2 f1 f2 p1 p2
72.439 - assume wp: "wpull A B1 B2 f1 f2 p1 p2"
72.440 - hence "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
72.441 - by (rule wpull_image)
72.442 - show "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
72.443 - (map_fset f1) (map_fset f2) (map_fset p1) (map_fset p2)"
72.444 - unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
72.445 - fix y1 y2
72.446 - assume Y1: "fset y1 \<subseteq> B1" and Y2: "fset y2 \<subseteq> B2"
72.447 - assume "map_fset f1 y1 = map_fset f2 y2"
72.448 - hence EQ: "f1 ` (fset y1) = f2 ` (fset y2)" unfolding map_fset_def2_raw
72.449 - unfolding afset_set set_map fset_def2_raw .
72.450 - with Y1 Y2 obtain X where X: "X \<subseteq> A"
72.451 - and Y1: "p1 ` X = fset y1" and Y2: "p2 ` X = fset y2"
72.452 - using wpull_image[OF wp] unfolding wpull_def Pow_def
72.453 - unfolding Bex_def mem_Collect_eq apply -
72.454 - apply(erule allE[of _ "fset y1"], erule allE[of _ "fset y2"]) by auto
72.455 - have "\<forall> y1' \<in> fset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
72.456 - then obtain q1 where q1: "\<forall> y1' \<in> fset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
72.457 - have "\<forall> y2' \<in> fset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
72.458 - then obtain q2 where q2: "\<forall> y2' \<in> fset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
72.459 - def X' \<equiv> "q1 ` (fset y1) \<union> q2 ` (fset y2)"
72.460 - have X': "X' \<subseteq> A" and Y1: "p1 ` X' = fset y1" and Y2: "p2 ` X' = fset y2"
72.461 - using X Y1 Y2 q1 q2 unfolding X'_def by auto
72.462 - have fX': "finite X'" unfolding X'_def by simp
72.463 - then obtain x where X'eq: "X' = fset x" by (auto dest: finite_ex_fset)
72.464 - show "\<exists>x. fset x \<subseteq> A \<and> map_fset p1 x = y1 \<and> map_fset p2 x = y2"
72.465 - apply(intro exI[of _ "x"]) using X' Y1 Y2
72.466 - unfolding X'eq map_fset_def2_raw fset_def2_raw set_map[symmetric]
72.467 - afset_set[symmetric] afset_rfset by simp
72.468 - qed
72.469 -next
72.470 - fix R
72.471 - show "{p. fset_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
72.472 - (Gr {x. fset x \<subseteq> R} (map_fset fst))\<inverse> O Gr {x. fset x \<subseteq> R} (map_fset snd)"
72.473 - unfolding fset_rel_def fset_rel_aux by simp
72.474 -qed auto
72.475 -
72.476 -(* Countable sets *)
72.477 -
72.478 -lemma card_of_countable_sets_range:
72.479 -fixes A :: "'a set"
72.480 -shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
72.481 -apply(rule card_of_ordLeqI[of fromNat]) using inj_on_fromNat
72.482 -unfolding inj_on_def by auto
72.483 -
72.484 -lemma card_of_countable_sets_Func:
72.485 -"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
72.486 -using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
72.487 -unfolding cexp_def Field_natLeq Field_card_of
72.488 -by (rule ordLeq_ordIso_trans)
72.489 -
72.490 -lemma ordLeq_countable_subsets:
72.491 -"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
72.492 -apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
72.493 -
72.494 -lemma finite_countable_subset:
72.495 -"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
72.496 -apply default
72.497 - apply (erule contrapos_pp)
72.498 - apply (rule card_of_ordLeq_infinite)
72.499 - apply (rule ordLeq_countable_subsets)
72.500 - apply assumption
72.501 -apply (rule finite_Collect_conjI)
72.502 -apply (rule disjI1)
72.503 -by (erule finite_Collect_subsets)
72.504 -
72.505 -lemma card_of_countable_sets:
72.506 -"|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
72.507 -(is "|?L| \<le>o _")
72.508 -proof(cases "finite A")
72.509 - let ?R = "Func (UNIV::nat set) (A <+> (UNIV::bool set))"
72.510 - case True hence "finite ?L" by simp
72.511 - moreover have "infinite ?R"
72.512 - apply(rule infinite_Func[of _ "Inr True" "Inr False"]) by auto
72.513 - ultimately show ?thesis unfolding cexp_def csum_def ctwo_def Field_natLeq Field_card_of
72.514 - apply(intro ordLess_imp_ordLeq) by (rule finite_ordLess_infinite2)
72.515 -next
72.516 - case False
72.517 - hence "|{X. X \<subseteq> A \<and> countable X}| =o |{X. X \<subseteq> A \<and> countable X} - {{}}|"
72.518 - by (intro card_of_infinite_diff_finitte finite.emptyI finite.insertI ordIso_symmetric)
72.519 - (unfold finite_countable_subset)
72.520 - also have "|{X. X \<subseteq> A \<and> countable X} - {{}}| \<le>o |A| ^c natLeq"
72.521 - using card_of_countable_sets_Func[of A] unfolding set_diff_eq by auto
72.522 - also have "|A| ^c natLeq \<le>o ( |A| +c ctwo) ^c natLeq"
72.523 - apply(rule cexp_mono1_cone_ordLeq)
72.524 - apply(rule ordLeq_csum1, rule card_of_Card_order)
72.525 - apply (rule cone_ordLeq_cexp)
72.526 - apply (rule cone_ordLeq_Cnotzero)
72.527 - using csum_Cnotzero2 ctwo_Cnotzero apply blast
72.528 - by (rule natLeq_Card_order)
72.529 - finally show ?thesis .
72.530 -qed
72.531 -
72.532 -lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
72.533 -apply (rule f_the_inv_into_f)
72.534 -unfolding inj_on_def rcset_inj using rcset_surj by auto
72.535 -
72.536 -lemma Collect_Int_Times:
72.537 -"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
72.538 -by auto
72.539 -
72.540 -lemma rcset_natural': "rcset (cIm f x) = f ` rcset x"
72.541 -unfolding cIm_def[abs_def] by simp
72.542 -
72.543 -definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
72.544 -"cset_rel R a b \<longleftrightarrow>
72.545 - (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
72.546 - (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
72.547 -
72.548 -lemma cset_rel_aux:
72.549 -"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
72.550 - (a, b) \<in> (Gr {x. rcset x \<subseteq> {(a, b). R a b}} (cIm fst))\<inverse> O
72.551 - Gr {x. rcset x \<subseteq> {(a, b). R a b}} (cIm snd)" (is "?L = ?R")
72.552 -proof
72.553 - assume ?L
72.554 - def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
72.555 - (is "the_inv rcset ?L'")
72.556 - have "countable ?L'" by auto
72.557 - hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
72.558 - show ?R unfolding Gr_def relcomp_unfold converse_unfold
72.559 - proof (intro CollectI prod_caseI exI conjI)
72.560 - have "rcset a = fst ` ({(x, y). R x y} \<inter> rcset a \<times> rcset b)" (is "_ = ?A")
72.561 - using conjunct1[OF `?L`] unfolding image_def by (auto simp add: Collect_Int_Times)
72.562 - hence "a = acset ?A" by (metis acset_rcset)
72.563 - thus "(R', a) = (R', cIm fst R')" unfolding cIm_def * by auto
72.564 - have "rcset b = snd ` ({(x, y). R x y} \<inter> rcset a \<times> rcset b)" (is "_ = ?B")
72.565 - using conjunct2[OF `?L`] unfolding image_def by (auto simp add: Collect_Int_Times)
72.566 - hence "b = acset ?B" by (metis acset_rcset)
72.567 - thus "(R', b) = (R', cIm snd R')" unfolding cIm_def * by auto
72.568 - qed (auto simp add: *)
72.569 -next
72.570 - assume ?R thus ?L unfolding Gr_def relcomp_unfold converse_unfold
72.571 - apply (simp add: subset_eq Ball_def)
72.572 - apply (rule conjI)
72.573 - apply (clarsimp, metis (lifting, no_types) rcset_natural' image_iff surjective_pairing)
72.574 - apply (clarsimp)
72.575 - by (metis Domain.intros Range.simps rcset_natural' fst_eq_Domain snd_eq_Range)
72.576 -qed
72.577 -
72.578 -bnf_def cIm [rcset] "\<lambda>_::'a cset. natLeq" ["cEmp"] cset_rel
72.579 -proof -
72.580 - show "cIm id = id" unfolding cIm_def[abs_def] id_def by auto
72.581 -next
72.582 - fix f g show "cIm (g \<circ> f) = cIm g \<circ> cIm f"
72.583 - unfolding cIm_def[abs_def] apply(rule ext) unfolding comp_def by auto
72.584 -next
72.585 - fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
72.586 - thus "cIm f C = cIm g C"
72.587 - unfolding cIm_def[abs_def] unfolding image_def by auto
72.588 -next
72.589 - fix f show "rcset \<circ> cIm f = op ` f \<circ> rcset" unfolding cIm_def[abs_def] by auto
72.590 -next
72.591 - show "card_order natLeq" by (rule natLeq_card_order)
72.592 -next
72.593 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
72.594 -next
72.595 - fix C show "|rcset C| \<le>o natLeq" using rcset unfolding countable_def .
72.596 -next
72.597 - fix A :: "'a set"
72.598 - have "|{Z. rcset Z \<subseteq> A}| \<le>o |acset ` {X. X \<subseteq> A \<and> countable X}|"
72.599 - apply(rule card_of_mono1) unfolding Pow_def image_def
72.600 - proof (rule Collect_mono, clarsimp)
72.601 - fix x
72.602 - assume "rcset x \<subseteq> A"
72.603 - hence "rcset x \<subseteq> A \<and> countable (rcset x) \<and> x = acset (rcset x)"
72.604 - using acset_rcset[of x] rcset[of x] by force
72.605 - thus "\<exists>y \<subseteq> A. countable y \<and> x = acset y" by blast
72.606 - qed
72.607 - also have "|acset ` {X. X \<subseteq> A \<and> countable X}| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
72.608 - using card_of_image .
72.609 - also have "|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
72.610 - using card_of_countable_sets .
72.611 - finally show "|{Z. rcset Z \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
72.612 -next
72.613 - fix A B1 B2 f1 f2 p1 p2
72.614 - assume wp: "wpull A B1 B2 f1 f2 p1 p2"
72.615 - show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
72.616 - (cIm f1) (cIm f2) (cIm p1) (cIm p2)"
72.617 - unfolding wpull_def proof safe
72.618 - fix y1 y2
72.619 - assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
72.620 - assume "cIm f1 y1 = cIm f2 y2"
72.621 - hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)"
72.622 - unfolding cIm_def by auto
72.623 - with Y1 Y2 obtain X where X: "X \<subseteq> A"
72.624 - and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
72.625 - using wpull_image[OF wp] unfolding wpull_def Pow_def
72.626 - unfolding Bex_def mem_Collect_eq apply -
72.627 - apply(erule allE[of _ "rcset y1"], erule allE[of _ "rcset y2"]) by auto
72.628 - have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
72.629 - then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
72.630 - have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
72.631 - then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
72.632 - def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
72.633 - have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
72.634 - using X Y1 Y2 q1 q2 unfolding X'_def by fast+
72.635 - have fX': "countable X'" unfolding X'_def by simp
72.636 - then obtain x where X'eq: "X' = rcset x" by (metis rcset_acset)
72.637 - show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cIm p1 x = y1 \<and> cIm p2 x = y2"
72.638 - apply(intro bexI[of _ "x"]) using X' Y1 Y2 unfolding X'eq cIm_def by auto
72.639 - qed
72.640 -next
72.641 - fix R
72.642 - show "{p. cset_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
72.643 - (Gr {x. rcset x \<subseteq> R} (cIm fst))\<inverse> O Gr {x. rcset x \<subseteq> R} (cIm snd)"
72.644 - unfolding cset_rel_def cset_rel_aux by simp
72.645 -qed (unfold cEmp_def, auto)
72.646 -
72.647 -
72.648 -(* Multisets *)
72.649 -
72.650 -(* The cardinal of a mutiset: this, and the following basic lemmas about it,
72.651 -should eventually go into Multiset.thy *)
72.652 -definition "mcard M \<equiv> setsum (count M) {a. count M a > 0}"
72.653 -
72.654 -lemma mcard_emp[simp]: "mcard {#} = 0"
72.655 -unfolding mcard_def by auto
72.656 -
72.657 -lemma mcard_emp_iff[simp]: "mcard M = 0 \<longleftrightarrow> M = {#}"
72.658 -unfolding mcard_def apply safe
72.659 - apply simp_all
72.660 - by (metis multi_count_eq zero_multiset.rep_eq)
72.661 -
72.662 -lemma mcard_singl[simp]: "mcard {#a#} = Suc 0"
72.663 -unfolding mcard_def by auto
72.664 -
72.665 -lemma mcard_Plus[simp]: "mcard (M + N) = mcard M + mcard N"
72.666 -proof-
72.667 - have "setsum (count M) {a. 0 < count M a + count N a} =
72.668 - setsum (count M) {a. a \<in># M}"
72.669 - apply(rule setsum_mono_zero_cong_right) by auto
72.670 - moreover
72.671 - have "setsum (count N) {a. 0 < count M a + count N a} =
72.672 - setsum (count N) {a. a \<in># N}"
72.673 - apply(rule setsum_mono_zero_cong_right) by auto
72.674 - ultimately show ?thesis
72.675 - unfolding mcard_def count_union[THEN ext] comm_monoid_add_class.setsum.F_fun_f by simp
72.676 -qed
72.677 -
72.678 -lemma setsum_gt_0_iff:
72.679 -fixes f :: "'a \<Rightarrow> nat" assumes "finite A"
72.680 -shows "setsum f A > 0 \<longleftrightarrow> (\<exists> a \<in> A. f a > 0)"
72.681 -(is "?L \<longleftrightarrow> ?R")
72.682 -proof-
72.683 - have "?L \<longleftrightarrow> \<not> setsum f A = 0" by fast
72.684 - also have "... \<longleftrightarrow> (\<exists> a \<in> A. f a \<noteq> 0)" using assms by simp
72.685 - also have "... \<longleftrightarrow> ?R" by simp
72.686 - finally show ?thesis .
72.687 -qed
72.688 -
72.689 -(* *)
72.690 -definition mmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> nat" where
72.691 -"mmap h f b = setsum f {a. h a = b \<and> f a > 0}"
72.692 -
72.693 -lemma mmap_id: "mmap id = id"
72.694 -proof (rule ext)+
72.695 - fix f a show "mmap id f a = id f a"
72.696 - proof(cases "f a = 0")
72.697 - case False
72.698 - hence 1: "{aa. aa = a \<and> 0 < f aa} = {a}" by auto
72.699 - show ?thesis by (simp add: mmap_def id_apply 1)
72.700 - qed(unfold mmap_def, auto)
72.701 -qed
72.702 -
72.703 -lemma inj_on_setsum_inv:
72.704 -assumes f: "f \<in> multiset"
72.705 -and 1: "(0::nat) < setsum f {a. h a = b' \<and> 0 < f a}" (is "0 < setsum f ?A'")
72.706 -and 2: "{a. h a = b \<and> 0 < f a} = {a. h a = b' \<and> 0 < f a}" (is "?A = ?A'")
72.707 -shows "b = b'"
72.708 -proof-
72.709 - have "finite ?A'" using f unfolding multiset_def by auto
72.710 - hence "?A' \<noteq> {}" using 1 setsum_gt_0_iff by auto
72.711 - thus ?thesis using 2 by auto
72.712 -qed
72.713 -
72.714 -lemma mmap_comp:
72.715 -fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
72.716 -assumes f: "f \<in> multiset"
72.717 -shows "mmap (h2 o h1) f = (mmap h2 o mmap h1) f"
72.718 -unfolding mmap_def[abs_def] comp_def proof(rule ext)+
72.719 - fix c :: 'c
72.720 - let ?A = "{a. h2 (h1 a) = c \<and> 0 < f a}"
72.721 - let ?As = "\<lambda> b. {a. h1 a = b \<and> 0 < f a}"
72.722 - let ?B = "{b. h2 b = c \<and> 0 < setsum f (?As b)}"
72.723 - have 0: "{?As b | b. b \<in> ?B} = ?As ` ?B" by auto
72.724 - have "\<And> b. finite (?As b)" using f unfolding multiset_def by simp
72.725 - hence "?B = {b. h2 b = c \<and> ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
72.726 - hence A: "?A = \<Union> {?As b | b. b \<in> ?B}" by auto
72.727 - have "setsum f ?A = setsum (setsum f) {?As b | b. b \<in> ?B}"
72.728 - unfolding A apply(rule setsum_Union_disjoint)
72.729 - using f unfolding multiset_def by auto
72.730 - also have "... = setsum (setsum f) (?As ` ?B)" unfolding 0 ..
72.731 - also have "... = setsum (setsum f o ?As) ?B" apply(rule setsum_reindex)
72.732 - unfolding inj_on_def apply auto using inj_on_setsum_inv[OF f, of h1] by blast
72.733 - also have "... = setsum (\<lambda> b. setsum f (?As b)) ?B" unfolding comp_def ..
72.734 - finally show "setsum f ?A = setsum (\<lambda> b. setsum f (?As b)) ?B" .
72.735 -qed
72.736 -
72.737 -lemma mmap_comp1:
72.738 -fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
72.739 -assumes "f \<in> multiset"
72.740 -shows "mmap (\<lambda> a. h2 (h1 a)) f = mmap h2 (mmap h1 f)"
72.741 -using mmap_comp[OF assms] unfolding comp_def by auto
72.742 -
72.743 -lemma mmap:
72.744 -assumes "f \<in> multiset"
72.745 -shows "mmap h f \<in> multiset"
72.746 -using assms unfolding mmap_def[abs_def] multiset_def proof safe
72.747 - assume fin: "finite {a. 0 < f a}" (is "finite ?A")
72.748 - show "finite {b. 0 < setsum f {a. h a = b \<and> 0 < f a}}"
72.749 - (is "finite {b. 0 < setsum f (?As b)}")
72.750 - proof- let ?B = "{b. 0 < setsum f (?As b)}"
72.751 - have "\<And> b. finite (?As b)" using assms unfolding multiset_def by simp
72.752 - hence B: "?B = {b. ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
72.753 - hence "?B \<subseteq> h ` ?A" by auto
72.754 - thus ?thesis using finite_surj[OF fin] by auto
72.755 - qed
72.756 -qed
72.757 -
72.758 -lemma mmap_cong:
72.759 -assumes "\<And>a. a \<in># M \<Longrightarrow> f a = g a"
72.760 -shows "mmap f (count M) = mmap g (count M)"
72.761 -using assms unfolding mmap_def[abs_def] by (intro ext, intro setsum_cong) auto
72.762 -
72.763 -abbreviation supp where "supp f \<equiv> {a. f a > 0}"
72.764 -
72.765 -lemma mmap_image_comp:
72.766 -assumes f: "f \<in> multiset"
72.767 -shows "(supp o mmap h) f = (image h o supp) f"
72.768 -unfolding mmap_def[abs_def] comp_def proof-
72.769 - have "\<And> b. finite {a. h a = b \<and> 0 < f a}" (is "\<And> b. finite (?As b)")
72.770 - using f unfolding multiset_def by auto
72.771 - thus "{b. 0 < setsum f (?As b)} = h ` {a. 0 < f a}"
72.772 - using setsum_gt_0_iff by auto
72.773 -qed
72.774 -
72.775 -lemma mmap_image:
72.776 -assumes f: "f \<in> multiset"
72.777 -shows "supp (mmap h f) = h ` (supp f)"
72.778 -using mmap_image_comp[OF assms] unfolding comp_def .
72.779 -
72.780 -lemma set_of_Abs_multiset:
72.781 -assumes f: "f \<in> multiset"
72.782 -shows "set_of (Abs_multiset f) = supp f"
72.783 -using assms unfolding set_of_def by (auto simp: Abs_multiset_inverse)
72.784 -
72.785 -lemma supp_count:
72.786 -"supp (count M) = set_of M"
72.787 -using assms unfolding set_of_def by auto
72.788 -
72.789 -lemma multiset_of_surj:
72.790 -"multiset_of ` {as. set as \<subseteq> A} = {M. set_of M \<subseteq> A}"
72.791 -proof safe
72.792 - fix M assume M: "set_of M \<subseteq> A"
72.793 - obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto
72.794 - hence "set as \<subseteq> A" using M by auto
72.795 - thus "M \<in> multiset_of ` {as. set as \<subseteq> A}" using eq by auto
72.796 -next
72.797 - show "\<And>x xa xb. \<lbrakk>set xa \<subseteq> A; xb \<in> set_of (multiset_of xa)\<rbrakk> \<Longrightarrow> xb \<in> A"
72.798 - by (erule set_mp) (unfold set_of_multiset_of)
72.799 -qed
72.800 -
72.801 -lemma card_of_set_of:
72.802 -"|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|"
72.803 -apply(rule card_of_ordLeqI2[of _ multiset_of]) using multiset_of_surj by auto
72.804 -
72.805 -lemma nat_sum_induct:
72.806 -assumes "\<And>n1 n2. (\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow> phi m1 m2) \<Longrightarrow> phi n1 n2"
72.807 -shows "phi (n1::nat) (n2::nat)"
72.808 -proof-
72.809 - let ?chi = "\<lambda> n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)"
72.810 - have "?chi (n1,n2)"
72.811 - apply(induct rule: measure_induct[of "\<lambda> n1n2. fst n1n2 + snd n1n2" ?chi])
72.812 - using assms by (metis fstI sndI)
72.813 - thus ?thesis by simp
72.814 -qed
72.815 -
72.816 -lemma matrix_count:
72.817 -fixes ct1 ct2 :: "nat \<Rightarrow> nat"
72.818 -assumes "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
72.819 -shows
72.820 -"\<exists> ct. (\<forall> i1 \<le> n1. setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ct1 i1) \<and>
72.821 - (\<forall> i2 \<le> n2. setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ct2 i2)"
72.822 -(is "?phi ct1 ct2 n1 n2")
72.823 -proof-
72.824 - have "\<forall> ct1 ct2 :: nat \<Rightarrow> nat.
72.825 - setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"
72.826 - proof(induct rule: nat_sum_induct[of
72.827 -"\<lambda> n1 n2. \<forall> ct1 ct2 :: nat \<Rightarrow> nat.
72.828 - setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"],
72.829 - clarify)
72.830 - fix n1 n2 :: nat and ct1 ct2 :: "nat \<Rightarrow> nat"
72.831 - assume IH: "\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow>
72.832 - \<forall> dt1 dt2 :: nat \<Rightarrow> nat.
72.833 - setsum dt1 {..<Suc m1} = setsum dt2 {..<Suc m2} \<longrightarrow> ?phi dt1 dt2 m1 m2"
72.834 - and ss: "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
72.835 - show "?phi ct1 ct2 n1 n2"
72.836 - proof(cases n1)
72.837 - case 0 note n1 = 0
72.838 - show ?thesis
72.839 - proof(cases n2)
72.840 - case 0 note n2 = 0
72.841 - let ?ct = "\<lambda> i1 i2. ct2 0"
72.842 - show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by simp
72.843 - next
72.844 - case (Suc m2) note n2 = Suc
72.845 - let ?ct = "\<lambda> i1 i2. ct2 i2"
72.846 - show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
72.847 - qed
72.848 - next
72.849 - case (Suc m1) note n1 = Suc
72.850 - show ?thesis
72.851 - proof(cases n2)
72.852 - case 0 note n2 = 0
72.853 - let ?ct = "\<lambda> i1 i2. ct1 i1"
72.854 - show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
72.855 - next
72.856 - case (Suc m2) note n2 = Suc
72.857 - show ?thesis
72.858 - proof(cases "ct1 n1 \<le> ct2 n2")
72.859 - case True
72.860 - def dt2 \<equiv> "\<lambda> i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2"
72.861 - have "setsum ct1 {..<Suc m1} = setsum dt2 {..<Suc n2}"
72.862 - unfolding dt2_def using ss n1 True by auto
72.863 - hence "?phi ct1 dt2 m1 n2" using IH[of m1 n2] n1 by simp
72.864 - then obtain dt where
72.865 - 1: "\<And> i1. i1 \<le> m1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc n2} = ct1 i1" and
72.866 - 2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc m1} = dt2 i2" by auto
72.867 - let ?ct = "\<lambda> i1 i2. if i1 = n1 then (if i2 = n2 then ct1 n1 else 0)
72.868 - else dt i1 i2"
72.869 - show ?thesis apply(rule exI[of _ ?ct])
72.870 - using n1 n2 1 2 True unfolding dt2_def by simp
72.871 - next
72.872 - case False
72.873 - hence False: "ct2 n2 < ct1 n1" by simp
72.874 - def dt1 \<equiv> "\<lambda> i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1"
72.875 - have "setsum dt1 {..<Suc n1} = setsum ct2 {..<Suc m2}"
72.876 - unfolding dt1_def using ss n2 False by auto
72.877 - hence "?phi dt1 ct2 n1 m2" using IH[of n1 m2] n2 by simp
72.878 - then obtain dt where
72.879 - 1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc m2} = dt1 i1" and
72.880 - 2: "\<And> i2. i2 \<le> m2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc n1} = ct2 i2" by force
72.881 - let ?ct = "\<lambda> i1 i2. if i2 = n2 then (if i1 = n1 then ct2 n2 else 0)
72.882 - else dt i1 i2"
72.883 - show ?thesis apply(rule exI[of _ ?ct])
72.884 - using n1 n2 1 2 False unfolding dt1_def by simp
72.885 - qed
72.886 - qed
72.887 - qed
72.888 - qed
72.889 - thus ?thesis using assms by auto
72.890 -qed
72.891 -
72.892 -definition
72.893 -"inj2 u B1 B2 \<equiv>
72.894 - \<forall> b1 b1' b2 b2'. {b1,b1'} \<subseteq> B1 \<and> {b2,b2'} \<subseteq> B2 \<and> u b1 b2 = u b1' b2'
72.895 - \<longrightarrow> b1 = b1' \<and> b2 = b2'"
72.896 -
72.897 -lemma matrix_setsum_finite:
72.898 -assumes B1: "B1 \<noteq> {}" "finite B1" and B2: "B2 \<noteq> {}" "finite B2" and u: "inj2 u B1 B2"
72.899 -and ss: "setsum N1 B1 = setsum N2 B2"
72.900 -shows "\<exists> M :: 'a \<Rightarrow> nat.
72.901 - (\<forall> b1 \<in> B1. setsum (\<lambda> b2. M (u b1 b2)) B2 = N1 b1) \<and>
72.902 - (\<forall> b2 \<in> B2. setsum (\<lambda> b1. M (u b1 b2)) B1 = N2 b2)"
72.903 -proof-
72.904 - obtain n1 where "card B1 = Suc n1" using B1 by (metis card_insert finite.simps)
72.905 - then obtain e1 where e1: "bij_betw e1 {..<Suc n1} B1"
72.906 - using ex_bij_betw_finite_nat[OF B1(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
72.907 - hence e1_inj: "inj_on e1 {..<Suc n1}" and e1_surj: "e1 ` {..<Suc n1} = B1"
72.908 - unfolding bij_betw_def by auto
72.909 - def f1 \<equiv> "inv_into {..<Suc n1} e1"
72.910 - have f1: "bij_betw f1 B1 {..<Suc n1}"
72.911 - and f1e1[simp]: "\<And> i1. i1 < Suc n1 \<Longrightarrow> f1 (e1 i1) = i1"
72.912 - and e1f1[simp]: "\<And> b1. b1 \<in> B1 \<Longrightarrow> e1 (f1 b1) = b1" unfolding f1_def
72.913 - apply (metis bij_betw_inv_into e1, metis bij_betw_inv_into_left e1 lessThan_iff)
72.914 - by (metis e1_surj f_inv_into_f)
72.915 - (* *)
72.916 - obtain n2 where "card B2 = Suc n2" using B2 by (metis card_insert finite.simps)
72.917 - then obtain e2 where e2: "bij_betw e2 {..<Suc n2} B2"
72.918 - using ex_bij_betw_finite_nat[OF B2(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
72.919 - hence e2_inj: "inj_on e2 {..<Suc n2}" and e2_surj: "e2 ` {..<Suc n2} = B2"
72.920 - unfolding bij_betw_def by auto
72.921 - def f2 \<equiv> "inv_into {..<Suc n2} e2"
72.922 - have f2: "bij_betw f2 B2 {..<Suc n2}"
72.923 - and f2e2[simp]: "\<And> i2. i2 < Suc n2 \<Longrightarrow> f2 (e2 i2) = i2"
72.924 - and e2f2[simp]: "\<And> b2. b2 \<in> B2 \<Longrightarrow> e2 (f2 b2) = b2" unfolding f2_def
72.925 - apply (metis bij_betw_inv_into e2, metis bij_betw_inv_into_left e2 lessThan_iff)
72.926 - by (metis e2_surj f_inv_into_f)
72.927 - (* *)
72.928 - let ?ct1 = "N1 o e1" let ?ct2 = "N2 o e2"
72.929 - have ss: "setsum ?ct1 {..<Suc n1} = setsum ?ct2 {..<Suc n2}"
72.930 - unfolding setsum_reindex[OF e1_inj, symmetric] setsum_reindex[OF e2_inj, symmetric]
72.931 - e1_surj e2_surj using ss .
72.932 - obtain ct where
72.933 - ct1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ?ct1 i1" and
72.934 - ct2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ?ct2 i2"
72.935 - using matrix_count[OF ss] by blast
72.936 - (* *)
72.937 - def A \<equiv> "{u b1 b2 | b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"
72.938 - have "\<forall> a \<in> A. \<exists> b1b2 \<in> B1 <*> B2. u (fst b1b2) (snd b1b2) = a"
72.939 - unfolding A_def Ball_def mem_Collect_eq by auto
72.940 - then obtain h1h2 where h12:
72.941 - "\<And>a. a \<in> A \<Longrightarrow> u (fst (h1h2 a)) (snd (h1h2 a)) = a \<and> h1h2 a \<in> B1 <*> B2" by metis
72.942 - def h1 \<equiv> "fst o h1h2" def h2 \<equiv> "snd o h1h2"
72.943 - have h12[simp]: "\<And>a. a \<in> A \<Longrightarrow> u (h1 a) (h2 a) = a"
72.944 - "\<And> a. a \<in> A \<Longrightarrow> h1 a \<in> B1" "\<And> a. a \<in> A \<Longrightarrow> h2 a \<in> B2"
72.945 - using h12 unfolding h1_def h2_def by force+
72.946 - {fix b1 b2 assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2"
72.947 - hence inA: "u b1 b2 \<in> A" unfolding A_def by auto
72.948 - hence "u b1 b2 = u (h1 (u b1 b2)) (h2 (u b1 b2))" by auto
72.949 - moreover have "h1 (u b1 b2) \<in> B1" "h2 (u b1 b2) \<in> B2" using inA by auto
72.950 - ultimately have "h1 (u b1 b2) = b1 \<and> h2 (u b1 b2) = b2"
72.951 - using u b1 b2 unfolding inj2_def by fastforce
72.952 - }
72.953 - hence h1[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h1 (u b1 b2) = b1" and
72.954 - h2[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h2 (u b1 b2) = b2" by auto
72.955 - def M \<equiv> "\<lambda> a. ct (f1 (h1 a)) (f2 (h2 a))"
72.956 - show ?thesis
72.957 - apply(rule exI[of _ M]) proof safe
72.958 - fix b1 assume b1: "b1 \<in> B1"
72.959 - hence f1b1: "f1 b1 \<le> n1" using f1 unfolding bij_betw_def
72.960 - by (metis bij_betwE f1 lessThan_iff less_Suc_eq_le)
72.961 - have "(\<Sum>b2\<in>B2. M (u b1 b2)) = (\<Sum>i2<Suc n2. ct (f1 b1) (f2 (e2 i2)))"
72.962 - unfolding e2_surj[symmetric] setsum_reindex[OF e2_inj]
72.963 - unfolding M_def comp_def apply(intro setsum_cong) apply force
72.964 - by (metis e2_surj b1 h1 h2 imageI)
72.965 - also have "... = N1 b1" using b1 ct1[OF f1b1] by simp
72.966 - finally show "(\<Sum>b2\<in>B2. M (u b1 b2)) = N1 b1" .
72.967 - next
72.968 - fix b2 assume b2: "b2 \<in> B2"
72.969 - hence f2b2: "f2 b2 \<le> n2" using f2 unfolding bij_betw_def
72.970 - by (metis bij_betwE f2 lessThan_iff less_Suc_eq_le)
72.971 - have "(\<Sum>b1\<in>B1. M (u b1 b2)) = (\<Sum>i1<Suc n1. ct (f1 (e1 i1)) (f2 b2))"
72.972 - unfolding e1_surj[symmetric] setsum_reindex[OF e1_inj]
72.973 - unfolding M_def comp_def apply(intro setsum_cong) apply force
72.974 - by (metis e1_surj b2 h1 h2 imageI)
72.975 - also have "... = N2 b2" using b2 ct2[OF f2b2] by simp
72.976 - finally show "(\<Sum>b1\<in>B1. M (u b1 b2)) = N2 b2" .
72.977 - qed
72.978 -qed
72.979 -
72.980 -lemma supp_vimage_mmap:
72.981 -assumes "M \<in> multiset"
72.982 -shows "supp M \<subseteq> f -` (supp (mmap f M))"
72.983 -using assms by (auto simp: mmap_image)
72.984 -
72.985 -lemma mmap_ge_0:
72.986 -assumes "M \<in> multiset"
72.987 -shows "0 < mmap f M b \<longleftrightarrow> (\<exists>a. 0 < M a \<and> f a = b)"
72.988 -proof-
72.989 - have f: "finite {a. f a = b \<and> 0 < M a}" using assms unfolding multiset_def by auto
72.990 - show ?thesis unfolding mmap_def setsum_gt_0_iff[OF f] by auto
72.991 -qed
72.992 -
72.993 -lemma finite_twosets:
72.994 -assumes "finite B1" and "finite B2"
72.995 -shows "finite {u b1 b2 |b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}" (is "finite ?A")
72.996 -proof-
72.997 - have A: "?A = (\<lambda> b1b2. u (fst b1b2) (snd b1b2)) ` (B1 <*> B2)" by force
72.998 - show ?thesis unfolding A using finite_cartesian_product[OF assms] by auto
72.999 -qed
72.1000 -
72.1001 -lemma wp_mmap:
72.1002 -fixes A :: "'a set" and B1 :: "'b1 set" and B2 :: "'b2 set"
72.1003 -assumes wp: "wpull A B1 B2 f1 f2 p1 p2"
72.1004 -shows
72.1005 -"wpull {M. M \<in> multiset \<and> supp M \<subseteq> A}
72.1006 - {N1. N1 \<in> multiset \<and> supp N1 \<subseteq> B1} {N2. N2 \<in> multiset \<and> supp N2 \<subseteq> B2}
72.1007 - (mmap f1) (mmap f2) (mmap p1) (mmap p2)"
72.1008 -unfolding wpull_def proof (safe, unfold Bex_def mem_Collect_eq)
72.1009 - fix N1 :: "'b1 \<Rightarrow> nat" and N2 :: "'b2 \<Rightarrow> nat"
72.1010 - assume mmap': "mmap f1 N1 = mmap f2 N2"
72.1011 - and N1[simp]: "N1 \<in> multiset" "supp N1 \<subseteq> B1"
72.1012 - and N2[simp]: "N2 \<in> multiset" "supp N2 \<subseteq> B2"
72.1013 - have mN1[simp]: "mmap f1 N1 \<in> multiset" using N1 by (auto simp: mmap)
72.1014 - have mN2[simp]: "mmap f2 N2 \<in> multiset" using N2 by (auto simp: mmap)
72.1015 - def P \<equiv> "mmap f1 N1"
72.1016 - have P1: "P = mmap f1 N1" and P2: "P = mmap f2 N2" unfolding P_def using mmap' by auto
72.1017 - note P = P1 P2
72.1018 - have P_mult[simp]: "P \<in> multiset" unfolding P_def using N1 by auto
72.1019 - have fin_N1[simp]: "finite (supp N1)" using N1(1) unfolding multiset_def by auto
72.1020 - have fin_N2[simp]: "finite (supp N2)" using N2(1) unfolding multiset_def by auto
72.1021 - have fin_P[simp]: "finite (supp P)" using P_mult unfolding multiset_def by auto
72.1022 - (* *)
72.1023 - def set1 \<equiv> "\<lambda> c. {b1 \<in> supp N1. f1 b1 = c}"
72.1024 - have set1[simp]: "\<And> c b1. b1 \<in> set1 c \<Longrightarrow> f1 b1 = c" unfolding set1_def by auto
72.1025 - have fin_set1: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set1 c)"
72.1026 - using N1(1) unfolding set1_def multiset_def by auto
72.1027 - have set1_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<noteq> {}"
72.1028 - unfolding set1_def P1 mmap_ge_0[OF N1(1)] by auto
72.1029 - have supp_N1_set1: "supp N1 = (\<Union> c \<in> supp P. set1 c)"
72.1030 - using supp_vimage_mmap[OF N1(1), of f1] unfolding set1_def P1 by auto
72.1031 - hence set1_inclN1: "\<And>c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> supp N1" by auto
72.1032 - hence set1_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> B1" using N1(2) by blast
72.1033 - have set1_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set1 c \<inter> set1 c' = {}"
72.1034 - unfolding set1_def by auto
72.1035 - have setsum_set1: "\<And> c. setsum N1 (set1 c) = P c"
72.1036 - unfolding P1 set1_def mmap_def apply(rule setsum_cong) by auto
72.1037 - (* *)
72.1038 - def set2 \<equiv> "\<lambda> c. {b2 \<in> supp N2. f2 b2 = c}"
72.1039 - have set2[simp]: "\<And> c b2. b2 \<in> set2 c \<Longrightarrow> f2 b2 = c" unfolding set2_def by auto
72.1040 - have fin_set2: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set2 c)"
72.1041 - using N2(1) unfolding set2_def multiset_def by auto
72.1042 - have set2_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<noteq> {}"
72.1043 - unfolding set2_def P2 mmap_ge_0[OF N2(1)] by auto
72.1044 - have supp_N2_set2: "supp N2 = (\<Union> c \<in> supp P. set2 c)"
72.1045 - using supp_vimage_mmap[OF N2(1), of f2] unfolding set2_def P2 by auto
72.1046 - hence set2_inclN2: "\<And>c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> supp N2" by auto
72.1047 - hence set2_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> B2" using N2(2) by blast
72.1048 - have set2_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set2 c \<inter> set2 c' = {}"
72.1049 - unfolding set2_def by auto
72.1050 - have setsum_set2: "\<And> c. setsum N2 (set2 c) = P c"
72.1051 - unfolding P2 set2_def mmap_def apply(rule setsum_cong) by auto
72.1052 - (* *)
72.1053 - have ss: "\<And> c. c \<in> supp P \<Longrightarrow> setsum N1 (set1 c) = setsum N2 (set2 c)"
72.1054 - unfolding setsum_set1 setsum_set2 ..
72.1055 - have "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
72.1056 - \<exists> a \<in> A. p1 a = fst b1b2 \<and> p2 a = snd b1b2"
72.1057 - using wp set1_incl set2_incl unfolding wpull_def Ball_def mem_Collect_eq
72.1058 - by simp (metis set1 set2 set_rev_mp)
72.1059 - then obtain uu where uu:
72.1060 - "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
72.1061 - uu c b1b2 \<in> A \<and> p1 (uu c b1b2) = fst b1b2 \<and> p2 (uu c b1b2) = snd b1b2" by metis
72.1062 - def u \<equiv> "\<lambda> c b1 b2. uu c (b1,b2)"
72.1063 - have u[simp]:
72.1064 - "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> A"
72.1065 - "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p1 (u c b1 b2) = b1"
72.1066 - "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p2 (u c b1 b2) = b2"
72.1067 - using uu unfolding u_def by auto
72.1068 - {fix c assume c: "c \<in> supp P"
72.1069 - have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify
72.1070 - fix b1 b1' b2 b2'
72.1071 - assume "{b1, b1'} \<subseteq> set1 c" "{b2, b2'} \<subseteq> set2 c" and 0: "u c b1 b2 = u c b1' b2'"
72.1072 - hence "p1 (u c b1 b2) = b1 \<and> p2 (u c b1 b2) = b2 \<and>
72.1073 - p1 (u c b1' b2') = b1' \<and> p2 (u c b1' b2') = b2'"
72.1074 - using u(2)[OF c] u(3)[OF c] by simp metis
72.1075 - thus "b1 = b1' \<and> b2 = b2'" using 0 by auto
72.1076 - qed
72.1077 - } note inj = this
72.1078 - def sset \<equiv> "\<lambda> c. {u c b1 b2 | b1 b2. b1 \<in> set1 c \<and> b2 \<in> set2 c}"
72.1079 - have fin_sset[simp]: "\<And> c. c \<in> supp P \<Longrightarrow> finite (sset c)" unfolding sset_def
72.1080 - using fin_set1 fin_set2 finite_twosets by blast
72.1081 - have sset_A: "\<And> c. c \<in> supp P \<Longrightarrow> sset c \<subseteq> A" unfolding sset_def by auto
72.1082 - {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
72.1083 - then obtain b1 b2 where b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
72.1084 - and a: "a = u c b1 b2" unfolding sset_def by auto
72.1085 - have "p1 a \<in> set1 c" and p2a: "p2 a \<in> set2 c"
72.1086 - using ac a b1 b2 c u(2) u(3) by simp+
72.1087 - hence "u c (p1 a) (p2 a) = a" unfolding a using b1 b2 inj[OF c]
72.1088 - unfolding inj2_def by (metis c u(2) u(3))
72.1089 - } note u_p12[simp] = this
72.1090 - {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
72.1091 - hence "p1 a \<in> set1 c" unfolding sset_def by auto
72.1092 - }note p1[simp] = this
72.1093 - {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
72.1094 - hence "p2 a \<in> set2 c" unfolding sset_def by auto
72.1095 - }note p2[simp] = this
72.1096 - (* *)
72.1097 - {fix c assume c: "c \<in> supp P"
72.1098 - hence "\<exists> M. (\<forall> b1 \<in> set1 c. setsum (\<lambda> b2. M (u c b1 b2)) (set2 c) = N1 b1) \<and>
72.1099 - (\<forall> b2 \<in> set2 c. setsum (\<lambda> b1. M (u c b1 b2)) (set1 c) = N2 b2)"
72.1100 - unfolding sset_def
72.1101 - using matrix_setsum_finite[OF set1_NE[OF c] fin_set1[OF c]
72.1102 - set2_NE[OF c] fin_set2[OF c] inj[OF c] ss[OF c]] by auto
72.1103 - }
72.1104 - then obtain Ms where
72.1105 - ss1: "\<And> c b1. \<lbrakk>c \<in> supp P; b1 \<in> set1 c\<rbrakk> \<Longrightarrow>
72.1106 - setsum (\<lambda> b2. Ms c (u c b1 b2)) (set2 c) = N1 b1" and
72.1107 - ss2: "\<And> c b2. \<lbrakk>c \<in> supp P; b2 \<in> set2 c\<rbrakk> \<Longrightarrow>
72.1108 - setsum (\<lambda> b1. Ms c (u c b1 b2)) (set1 c) = N2 b2"
72.1109 - by metis
72.1110 - def SET \<equiv> "\<Union> c \<in> supp P. sset c"
72.1111 - have fin_SET[simp]: "finite SET" unfolding SET_def apply(rule finite_UN_I) by auto
72.1112 - have SET_A: "SET \<subseteq> A" unfolding SET_def using sset_A by auto
72.1113 - have u_SET[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> SET"
72.1114 - unfolding SET_def sset_def by blast
72.1115 - {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p1a: "p1 a \<in> set1 c"
72.1116 - then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
72.1117 - unfolding SET_def by auto
72.1118 - hence "p1 a \<in> set1 c'" unfolding sset_def by auto
72.1119 - hence eq: "c = c'" using p1a c c' set1_disj by auto
72.1120 - hence "a \<in> sset c" using ac' by simp
72.1121 - } note p1_rev = this
72.1122 - {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p2a: "p2 a \<in> set2 c"
72.1123 - then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
72.1124 - unfolding SET_def by auto
72.1125 - hence "p2 a \<in> set2 c'" unfolding sset_def by auto
72.1126 - hence eq: "c = c'" using p2a c c' set2_disj by auto
72.1127 - hence "a \<in> sset c" using ac' by simp
72.1128 - } note p2_rev = this
72.1129 - (* *)
72.1130 - have "\<forall> a \<in> SET. \<exists> c \<in> supp P. a \<in> sset c" unfolding SET_def by auto
72.1131 - then obtain h where h: "\<forall> a \<in> SET. h a \<in> supp P \<and> a \<in> sset (h a)" by metis
72.1132 - have h_u[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
72.1133 - \<Longrightarrow> h (u c b1 b2) = c"
72.1134 - by (metis h p2 set2 u(3) u_SET)
72.1135 - have h_u1: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
72.1136 - \<Longrightarrow> h (u c b1 b2) = f1 b1"
72.1137 - using h unfolding sset_def by auto
72.1138 - have h_u2: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
72.1139 - \<Longrightarrow> h (u c b1 b2) = f2 b2"
72.1140 - using h unfolding sset_def by auto
72.1141 - def M \<equiv> "\<lambda> a. if a \<in> SET \<and> p1 a \<in> supp N1 \<and> p2 a \<in> supp N2 then Ms (h a) a else 0"
72.1142 - have sM: "supp M \<subseteq> SET" "supp M \<subseteq> p1 -` (supp N1)" "supp M \<subseteq> p2 -` (supp N2)"
72.1143 - unfolding M_def by auto
72.1144 - show "\<exists>M. (M \<in> multiset \<and> supp M \<subseteq> A) \<and> mmap p1 M = N1 \<and> mmap p2 M = N2"
72.1145 - proof(rule exI[of _ M], safe)
72.1146 - show "M \<in> multiset"
72.1147 - unfolding multiset_def using finite_subset[OF sM(1) fin_SET] by simp
72.1148 - next
72.1149 - fix a assume "0 < M a"
72.1150 - thus "a \<in> A" unfolding M_def using SET_A by (cases "a \<in> SET") auto
72.1151 - next
72.1152 - show "mmap p1 M = N1"
72.1153 - unfolding mmap_def[abs_def] proof(rule ext)
72.1154 - fix b1
72.1155 - let ?K = "{a. p1 a = b1 \<and> 0 < M a}"
72.1156 - show "setsum M ?K = N1 b1"
72.1157 - proof(cases "b1 \<in> supp N1")
72.1158 - case False
72.1159 - hence "?K = {}" using sM(2) by auto
72.1160 - thus ?thesis using False by auto
72.1161 - next
72.1162 - case True
72.1163 - def c \<equiv> "f1 b1"
72.1164 - have c: "c \<in> supp P" and b1: "b1 \<in> set1 c"
72.1165 - unfolding set1_def c_def P1 using True by (auto simp: mmap_image)
72.1166 - have "setsum M ?K = setsum M {a. p1 a = b1 \<and> a \<in> SET}"
72.1167 - apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
72.1168 - also have "... = setsum M ((\<lambda> b2. u c b1 b2) ` (set2 c))"
72.1169 - apply(rule setsum_cong) using c b1 proof safe
72.1170 - fix a assume p1a: "p1 a \<in> set1 c" and "0 < P c" and "a \<in> SET"
72.1171 - hence ac: "a \<in> sset c" using p1_rev by auto
72.1172 - hence "a = u c (p1 a) (p2 a)" using c by auto
72.1173 - moreover have "p2 a \<in> set2 c" using ac c by auto
72.1174 - ultimately show "a \<in> u c (p1 a) ` set2 c" by auto
72.1175 - next
72.1176 - fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
72.1177 - hence "u c b1 b2 \<in> SET" using c by auto
72.1178 - qed auto
72.1179 - also have "... = setsum (\<lambda> b2. M (u c b1 b2)) (set2 c)"
72.1180 - unfolding comp_def[symmetric] apply(rule setsum_reindex)
72.1181 - using inj unfolding inj_on_def inj2_def using b1 c u(3) by blast
72.1182 - also have "... = N1 b1" unfolding ss1[OF c b1, symmetric]
72.1183 - apply(rule setsum_cong[OF refl]) unfolding M_def
72.1184 - using True h_u[OF c b1] set2_def u(2,3)[OF c b1] u_SET[OF c b1] by fastforce
72.1185 - finally show ?thesis .
72.1186 - qed
72.1187 - qed
72.1188 - next
72.1189 - show "mmap p2 M = N2"
72.1190 - unfolding mmap_def[abs_def] proof(rule ext)
72.1191 - fix b2
72.1192 - let ?K = "{a. p2 a = b2 \<and> 0 < M a}"
72.1193 - show "setsum M ?K = N2 b2"
72.1194 - proof(cases "b2 \<in> supp N2")
72.1195 - case False
72.1196 - hence "?K = {}" using sM(3) by auto
72.1197 - thus ?thesis using False by auto
72.1198 - next
72.1199 - case True
72.1200 - def c \<equiv> "f2 b2"
72.1201 - have c: "c \<in> supp P" and b2: "b2 \<in> set2 c"
72.1202 - unfolding set2_def c_def P2 using True by (auto simp: mmap_image)
72.1203 - have "setsum M ?K = setsum M {a. p2 a = b2 \<and> a \<in> SET}"
72.1204 - apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
72.1205 - also have "... = setsum M ((\<lambda> b1. u c b1 b2) ` (set1 c))"
72.1206 - apply(rule setsum_cong) using c b2 proof safe
72.1207 - fix a assume p2a: "p2 a \<in> set2 c" and "0 < P c" and "a \<in> SET"
72.1208 - hence ac: "a \<in> sset c" using p2_rev by auto
72.1209 - hence "a = u c (p1 a) (p2 a)" using c by auto
72.1210 - moreover have "p1 a \<in> set1 c" using ac c by auto
72.1211 - ultimately show "a \<in> (\<lambda>b1. u c b1 (p2 a)) ` set1 c" by auto
72.1212 - next
72.1213 - fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
72.1214 - hence "u c b1 b2 \<in> SET" using c by auto
72.1215 - qed auto
72.1216 - also have "... = setsum (M o (\<lambda> b1. u c b1 b2)) (set1 c)"
72.1217 - apply(rule setsum_reindex)
72.1218 - using inj unfolding inj_on_def inj2_def using b2 c u(2) by blast
72.1219 - also have "... = setsum (\<lambda> b1. M (u c b1 b2)) (set1 c)"
72.1220 - unfolding comp_def[symmetric] by simp
72.1221 - also have "... = N2 b2" unfolding ss2[OF c b2, symmetric]
72.1222 - apply(rule setsum_cong[OF refl]) unfolding M_def set2_def
72.1223 - using True h_u1[OF c _ b2] u(2,3)[OF c _ b2] u_SET[OF c _ b2]
72.1224 - unfolding set1_def by fastforce
72.1225 - finally show ?thesis .
72.1226 - qed
72.1227 - qed
72.1228 - qed
72.1229 -qed
72.1230 -
72.1231 -definition multiset_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
72.1232 -"multiset_map h = Abs_multiset \<circ> mmap h \<circ> count"
72.1233 -
72.1234 -bnf_def multiset_map [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
72.1235 -unfolding multiset_map_def
72.1236 -proof -
72.1237 - show "Abs_multiset \<circ> mmap id \<circ> count = id" unfolding mmap_id by (auto simp: count_inverse)
72.1238 -next
72.1239 - fix f g
72.1240 - show "Abs_multiset \<circ> mmap (g \<circ> f) \<circ> count =
72.1241 - Abs_multiset \<circ> mmap g \<circ> count \<circ> (Abs_multiset \<circ> mmap f \<circ> count)"
72.1242 - unfolding comp_def apply(rule ext)
72.1243 - by (auto simp: Abs_multiset_inverse count mmap_comp1 mmap)
72.1244 -next
72.1245 - fix M f g assume eq: "\<And>a. a \<in> set_of M \<Longrightarrow> f a = g a"
72.1246 - thus "(Abs_multiset \<circ> mmap f \<circ> count) M = (Abs_multiset \<circ> mmap g \<circ> count) M" apply auto
72.1247 - unfolding cIm_def[abs_def] image_def
72.1248 - by (auto intro!: mmap_cong simp: Abs_multiset_inject count mmap)
72.1249 -next
72.1250 - fix f show "set_of \<circ> (Abs_multiset \<circ> mmap f \<circ> count) = op ` f \<circ> set_of"
72.1251 - by (auto simp: count mmap mmap_image set_of_Abs_multiset supp_count)
72.1252 -next
72.1253 - show "card_order natLeq" by (rule natLeq_card_order)
72.1254 -next
72.1255 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
72.1256 -next
72.1257 - fix M show "|set_of M| \<le>o natLeq"
72.1258 - apply(rule ordLess_imp_ordLeq)
72.1259 - unfolding finite_iff_ordLess_natLeq[symmetric] using finite_set_of .
72.1260 -next
72.1261 - fix A :: "'a set"
72.1262 - have "|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_set_of .
72.1263 - also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
72.1264 - by (rule list_in_bd)
72.1265 - finally show "|{M. set_of M \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
72.1266 -next
72.1267 - fix A B1 B2 f1 f2 p1 p2
72.1268 - let ?map = "\<lambda> f. Abs_multiset \<circ> mmap f \<circ> count"
72.1269 - assume wp: "wpull A B1 B2 f1 f2 p1 p2"
72.1270 - show "wpull {x. set_of x \<subseteq> A} {x. set_of x \<subseteq> B1} {x. set_of x \<subseteq> B2}
72.1271 - (?map f1) (?map f2) (?map p1) (?map p2)"
72.1272 - unfolding wpull_def proof safe
72.1273 - fix y1 y2
72.1274 - assume y1: "set_of y1 \<subseteq> B1" and y2: "set_of y2 \<subseteq> B2"
72.1275 - and m: "?map f1 y1 = ?map f2 y2"
72.1276 - def N1 \<equiv> "count y1" def N2 \<equiv> "count y2"
72.1277 - have "N1 \<in> multiset \<and> supp N1 \<subseteq> B1" and "N2 \<in> multiset \<and> supp N2 \<subseteq> B2"
72.1278 - and "mmap f1 N1 = mmap f2 N2"
72.1279 - using y1 y2 m unfolding N1_def N2_def
72.1280 - by (auto simp: Abs_multiset_inject count mmap)
72.1281 - then obtain M where M: "M \<in> multiset \<and> supp M \<subseteq> A"
72.1282 - and N1: "mmap p1 M = N1" and N2: "mmap p2 M = N2"
72.1283 - using wp_mmap[OF wp] unfolding wpull_def by auto
72.1284 - def x \<equiv> "Abs_multiset M"
72.1285 - show "\<exists>x\<in>{x. set_of x \<subseteq> A}. ?map p1 x = y1 \<and> ?map p2 x = y2"
72.1286 - apply(intro bexI[of _ x]) using M N1 N2 unfolding N1_def N2_def x_def
72.1287 - by (auto simp: count_inverse Abs_multiset_inverse)
72.1288 - qed
72.1289 -qed (unfold set_of_empty, auto)
72.1290 -
72.1291 -inductive multiset_rel' where
72.1292 -Zero: "multiset_rel' R {#} {#}"
72.1293 -|
72.1294 -Plus: "\<lbrakk>R a b; multiset_rel' R M N\<rbrakk> \<Longrightarrow> multiset_rel' R (M + {#a#}) (N + {#b#})"
72.1295 -
72.1296 -lemma multiset_map_Zero_iff[simp]: "multiset_map f M = {#} \<longleftrightarrow> M = {#}"
72.1297 -by (metis image_is_empty multiset.set_natural' set_of_eq_empty_iff)
72.1298 -
72.1299 -lemma multiset_map_Zero[simp]: "multiset_map f {#} = {#}" by simp
72.1300 -
72.1301 -lemma multiset_rel_Zero: "multiset_rel R {#} {#}"
72.1302 -unfolding multiset_rel_def Gr_def relcomp_unfold by auto
72.1303 -
72.1304 -declare multiset.count[simp]
72.1305 -declare mmap[simp]
72.1306 -declare Abs_multiset_inverse[simp]
72.1307 -declare multiset.count_inverse[simp]
72.1308 -declare union_preserves_multiset[simp]
72.1309 -
72.1310 -lemma mmap_Plus[simp]:
72.1311 -assumes "K \<in> multiset" and "L \<in> multiset"
72.1312 -shows "mmap f (\<lambda>a. K a + L a) a = mmap f K a + mmap f L a"
72.1313 -proof-
72.1314 - have "{aa. f aa = a \<and> (0 < K aa \<or> 0 < L aa)} \<subseteq>
72.1315 - {aa. 0 < K aa} \<union> {aa. 0 < L aa}" (is "?C \<subseteq> ?A \<union> ?B") by auto
72.1316 - moreover have "finite (?A \<union> ?B)" apply(rule finite_UnI)
72.1317 - using assms unfolding multiset_def by auto
72.1318 - ultimately have C: "finite ?C" using finite_subset by blast
72.1319 - have "setsum K {aa. f aa = a \<and> 0 < K aa} = setsum K {aa. f aa = a \<and> 0 < K aa + L aa}"
72.1320 - apply(rule setsum_mono_zero_cong_left) using C by auto
72.1321 - moreover
72.1322 - have "setsum L {aa. f aa = a \<and> 0 < L aa} = setsum L {aa. f aa = a \<and> 0 < K aa + L aa}"
72.1323 - apply(rule setsum_mono_zero_cong_left) using C by auto
72.1324 - ultimately show ?thesis
72.1325 - unfolding mmap_def unfolding comm_monoid_add_class.setsum.F_fun_f by auto
72.1326 -qed
72.1327 -
72.1328 -lemma multiset_map_Plus[simp]:
72.1329 -"multiset_map f (M1 + M2) = multiset_map f M1 + multiset_map f M2"
72.1330 -unfolding multiset_map_def
72.1331 -apply(subst multiset.count_inject[symmetric])
72.1332 -unfolding plus_multiset.rep_eq comp_def by auto
72.1333 -
72.1334 -lemma multiset_map_singl[simp]: "multiset_map f {#a#} = {#f a#}"
72.1335 -proof-
72.1336 - have 0: "\<And> b. card {aa. a = aa \<and> (a = aa \<longrightarrow> f aa = b)} =
72.1337 - (if b = f a then 1 else 0)" by auto
72.1338 - thus ?thesis
72.1339 - unfolding multiset_map_def comp_def mmap_def[abs_def] map_fun_def
72.1340 - by (simp, simp add: single_def)
72.1341 -qed
72.1342 -
72.1343 -lemma multiset_rel_Plus:
72.1344 -assumes ab: "R a b" and MN: "multiset_rel R M N"
72.1345 -shows "multiset_rel R (M + {#a#}) (N + {#b#})"
72.1346 -proof-
72.1347 - {fix y assume "R a b" and "set_of y \<subseteq> {(x, y). R x y}"
72.1348 - hence "\<exists>ya. multiset_map fst y + {#a#} = multiset_map fst ya \<and>
72.1349 - multiset_map snd y + {#b#} = multiset_map snd ya \<and>
72.1350 - set_of ya \<subseteq> {(x, y). R x y}"
72.1351 - apply(intro exI[of _ "y + {#(a,b)#}"]) by auto
72.1352 - }
72.1353 - thus ?thesis
72.1354 - using assms
72.1355 - unfolding multiset_rel_def Gr_def relcomp_unfold by force
72.1356 -qed
72.1357 -
72.1358 -lemma multiset_rel'_imp_multiset_rel:
72.1359 -"multiset_rel' R M N \<Longrightarrow> multiset_rel R M N"
72.1360 -apply(induct rule: multiset_rel'.induct)
72.1361 -using multiset_rel_Zero multiset_rel_Plus by auto
72.1362 -
72.1363 -lemma mcard_multiset_map[simp]: "mcard (multiset_map f M) = mcard M"
72.1364 -proof-
72.1365 - def A \<equiv> "\<lambda> b. {a. f a = b \<and> a \<in># M}"
72.1366 - let ?B = "{b. 0 < setsum (count M) (A b)}"
72.1367 - have "{b. \<exists>a. f a = b \<and> a \<in># M} \<subseteq> f ` {a. a \<in># M}" by auto
72.1368 - moreover have "finite (f ` {a. a \<in># M})" apply(rule finite_imageI)
72.1369 - using finite_Collect_mem .
72.1370 - ultimately have fin: "finite {b. \<exists>a. f a = b \<and> a \<in># M}" by(rule finite_subset)
72.1371 - have i: "inj_on A ?B" unfolding inj_on_def A_def apply clarsimp
72.1372 - by (metis (lifting, mono_tags) mem_Collect_eq rel_simps(54)
72.1373 - setsum_gt_0_iff setsum_infinite)
72.1374 - have 0: "\<And> b. 0 < setsum (count M) (A b) \<longleftrightarrow> (\<exists> a \<in> A b. count M a > 0)"
72.1375 - apply safe
72.1376 - apply (metis less_not_refl setsum_gt_0_iff setsum_infinite)
72.1377 - by (metis A_def finite_Collect_conjI finite_Collect_mem setsum_gt_0_iff)
72.1378 - hence AB: "A ` ?B = {A b | b. \<exists> a \<in> A b. count M a > 0}" by auto
72.1379 -
72.1380 - have "setsum (\<lambda> x. setsum (count M) (A x)) ?B = setsum (setsum (count M) o A) ?B"
72.1381 - unfolding comp_def ..
72.1382 - also have "... = (\<Sum>x\<in> A ` ?B. setsum (count M) x)"
72.1383 - unfolding comm_monoid_add_class.setsum_reindex[OF i, symmetric] ..
72.1384 - also have "... = setsum (count M) (\<Union>x\<in>A ` {b. 0 < setsum (count M) (A b)}. x)"
72.1385 - (is "_ = setsum (count M) ?J")
72.1386 - apply(rule comm_monoid_add_class.setsum_UN_disjoint[symmetric])
72.1387 - using 0 fin unfolding A_def by (auto intro!: finite_imageI)
72.1388 - also have "?J = {a. a \<in># M}" unfolding AB unfolding A_def by auto
72.1389 - finally have "setsum (\<lambda> x. setsum (count M) (A x)) ?B =
72.1390 - setsum (count M) {a. a \<in># M}" .
72.1391 - thus ?thesis unfolding A_def mcard_def multiset_map_def by (simp add: mmap_def)
72.1392 -qed
72.1393 -
72.1394 -lemma multiset_rel_mcard:
72.1395 -assumes "multiset_rel R M N"
72.1396 -shows "mcard M = mcard N"
72.1397 -using assms unfolding multiset_rel_def relcomp_unfold Gr_def by auto
72.1398 -
72.1399 -lemma multiset_induct2[case_names empty addL addR]:
72.1400 -assumes empty: "P {#} {#}"
72.1401 -and addL: "\<And>M N a. P M N \<Longrightarrow> P (M + {#a#}) N"
72.1402 -and addR: "\<And>M N a. P M N \<Longrightarrow> P M (N + {#a#})"
72.1403 -shows "P M N"
72.1404 -apply(induct N rule: multiset_induct)
72.1405 - apply(induct M rule: multiset_induct, rule empty, erule addL)
72.1406 - apply(induct M rule: multiset_induct, erule addR, erule addR)
72.1407 -done
72.1408 -
72.1409 -lemma multiset_induct2_mcard[consumes 1, case_names empty add]:
72.1410 -assumes c: "mcard M = mcard N"
72.1411 -and empty: "P {#} {#}"
72.1412 -and add: "\<And>M N a b. P M N \<Longrightarrow> P (M + {#a#}) (N + {#b#})"
72.1413 -shows "P M N"
72.1414 -using c proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
72.1415 - case (less M) show ?case
72.1416 - proof(cases "M = {#}")
72.1417 - case True hence "N = {#}" using less.prems by auto
72.1418 - thus ?thesis using True empty by auto
72.1419 - next
72.1420 - case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
72.1421 - have "N \<noteq> {#}" using False less.prems by auto
72.1422 - then obtain N1 b where N: "N = N1 + {#b#}" by (metis multi_nonempty_split)
72.1423 - have "mcard M1 = mcard N1" using less.prems unfolding M N by auto
72.1424 - thus ?thesis using M N less.hyps add by auto
72.1425 - qed
72.1426 -qed
72.1427 -
72.1428 -lemma msed_map_invL:
72.1429 -assumes "multiset_map f (M + {#a#}) = N"
72.1430 -shows "\<exists> N1. N = N1 + {#f a#} \<and> multiset_map f M = N1"
72.1431 -proof-
72.1432 - have "f a \<in># N"
72.1433 - using assms multiset.set_natural'[of f "M + {#a#}"] by auto
72.1434 - then obtain N1 where N: "N = N1 + {#f a#}" using multi_member_split by metis
72.1435 - have "multiset_map f M = N1" using assms unfolding N by simp
72.1436 - thus ?thesis using N by blast
72.1437 -qed
72.1438 -
72.1439 -lemma msed_map_invR:
72.1440 -assumes "multiset_map f M = N + {#b#}"
72.1441 -shows "\<exists> M1 a. M = M1 + {#a#} \<and> f a = b \<and> multiset_map f M1 = N"
72.1442 -proof-
72.1443 - obtain a where a: "a \<in># M" and fa: "f a = b"
72.1444 - using multiset.set_natural'[of f M] unfolding assms
72.1445 - by (metis image_iff mem_set_of_iff union_single_eq_member)
72.1446 - then obtain M1 where M: "M = M1 + {#a#}" using multi_member_split by metis
72.1447 - have "multiset_map f M1 = N" using assms unfolding M fa[symmetric] by simp
72.1448 - thus ?thesis using M fa by blast
72.1449 -qed
72.1450 -
72.1451 -lemma msed_rel_invL:
72.1452 -assumes "multiset_rel R (M + {#a#}) N"
72.1453 -shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> multiset_rel R M N1"
72.1454 -proof-
72.1455 - obtain K where KM: "multiset_map fst K = M + {#a#}"
72.1456 - and KN: "multiset_map snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
72.1457 - using assms
72.1458 - unfolding multiset_rel_def Gr_def relcomp_unfold by auto
72.1459 - obtain K1 ab where K: "K = K1 + {#ab#}" and a: "fst ab = a"
72.1460 - and K1M: "multiset_map fst K1 = M" using msed_map_invR[OF KM] by auto
72.1461 - obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "multiset_map snd K1 = N1"
72.1462 - using msed_map_invL[OF KN[unfolded K]] by auto
72.1463 - have Rab: "R a (snd ab)" using sK a unfolding K by auto
72.1464 - have "multiset_rel R M N1" using sK K1M K1N1
72.1465 - unfolding K multiset_rel_def Gr_def relcomp_unfold by auto
72.1466 - thus ?thesis using N Rab by auto
72.1467 -qed
72.1468 -
72.1469 -lemma msed_rel_invR:
72.1470 -assumes "multiset_rel R M (N + {#b#})"
72.1471 -shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> multiset_rel R M1 N"
72.1472 -proof-
72.1473 - obtain K where KN: "multiset_map snd K = N + {#b#}"
72.1474 - and KM: "multiset_map fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
72.1475 - using assms
72.1476 - unfolding multiset_rel_def Gr_def relcomp_unfold by auto
72.1477 - obtain K1 ab where K: "K = K1 + {#ab#}" and b: "snd ab = b"
72.1478 - and K1N: "multiset_map snd K1 = N" using msed_map_invR[OF KN] by auto
72.1479 - obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "multiset_map fst K1 = M1"
72.1480 - using msed_map_invL[OF KM[unfolded K]] by auto
72.1481 - have Rab: "R (fst ab) b" using sK b unfolding K by auto
72.1482 - have "multiset_rel R M1 N" using sK K1N K1M1
72.1483 - unfolding K multiset_rel_def Gr_def relcomp_unfold by auto
72.1484 - thus ?thesis using M Rab by auto
72.1485 -qed
72.1486 -
72.1487 -lemma multiset_rel_imp_multiset_rel':
72.1488 -assumes "multiset_rel R M N"
72.1489 -shows "multiset_rel' R M N"
72.1490 -using assms proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
72.1491 - case (less M)
72.1492 - have c: "mcard M = mcard N" using multiset_rel_mcard[OF less.prems] .
72.1493 - show ?case
72.1494 - proof(cases "M = {#}")
72.1495 - case True hence "N = {#}" using c by simp
72.1496 - thus ?thesis using True multiset_rel'.Zero by auto
72.1497 - next
72.1498 - case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
72.1499 - obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "multiset_rel R M1 N1"
72.1500 - using msed_rel_invL[OF less.prems[unfolded M]] by auto
72.1501 - have "multiset_rel' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
72.1502 - thus ?thesis using multiset_rel'.Plus[of R a b, OF R] unfolding M N by simp
72.1503 - qed
72.1504 -qed
72.1505 -
72.1506 -lemma multiset_rel_multiset_rel':
72.1507 -"multiset_rel R M N = multiset_rel' R M N"
72.1508 -using multiset_rel_imp_multiset_rel' multiset_rel'_imp_multiset_rel by auto
72.1509 -
72.1510 -(* The main end product for multiset_rel: inductive characterization *)
72.1511 -theorems multiset_rel_induct[case_names empty add, induct pred: multiset_rel] =
72.1512 - multiset_rel'.induct[unfolded multiset_rel_multiset_rel'[symmetric]]
72.1513 -
72.1514 -end
73.1 --- a/src/HOL/Codatatype/README.html Fri Sep 21 16:34:40 2012 +0200
73.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
73.3 @@ -1,54 +0,0 @@
73.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
73.5 -
73.6 -<html>
73.7 -
73.8 -<head>
73.9 - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
73.10 - <title>BNF Package</title>
73.11 -</head>
73.12 -
73.13 -<body>
73.14 -
73.15 -<h3><i>BNF</i>: A (co)datatype package based on bounded natural functors
73.16 -(BNFs)</h3>
73.17 -
73.18 -<p>
73.19 -The <i>BNF</i> package provides a fully modular framework for constructing
73.20 -inductive and coinductive datatypes in HOL, with support for mixed mutual and
73.21 -nested (co)recursion. Mixed (co)recursion enables type definitions involving
73.22 -both datatypes and codatatypes, such as the type of finitely branching trees of
73.23 -possibly infinite depth. The framework draws heavily from category theory.
73.24 -
73.25 -<p>
73.26 -The package is described in the following paper:
73.27 -
73.28 -<ul>
73.29 - <li><a href="http://www21.in.tum.de/~traytel/papers/codatatypes/index.html">Foundational, Compositional (Co)datatypes for Higher-Order Logic—Category Theory Applied to Theorem Proving</a>, <br>
73.30 - Dmitriy Traytel, Andrei Popescu, and Jasmin Christian Blanchette.<br>
73.31 - <i>Logic in Computer Science (LICS 2012)</i>, 2012.
73.32 -</ul>
73.33 -
73.34 -<p>
73.35 -The main entry point for applications is <tt>BNF.thy</tt>. The <tt>Examples</tt>
73.36 -directory contains various examples of (co)datatypes, including the examples
73.37 -from the paper.
73.38 -
73.39 -<p>
73.40 -The key notion underlying the package is that of a <i>bounded natural functor</i>
73.41 -(<i>BNF</i>)—an enriched type constructor satisfying specific properties
73.42 -preserved by interesting categorical operations (composition, least fixed point,
73.43 -and greatest fixed point). The <tt>Basic_BNFs.thy</tt> and <tt>More_BNFs.thy</tt>
73.44 -files register various basic types, notably for sums, products, function spaces,
73.45 -finite sets, multisets, and countable sets. Custom BNFs can be registered as well.
73.46 -
73.47 -<p>
73.48 -<b>Warning:</b> The package is under development. Please contact any nonempty
73.49 -subset of
73.50 -<a href="mailto:traytel@in.tum.de">the</a>
73.51 -<a href="mailto:popescua@in.tum.de">above</a>
73.52 -<a href="mailto:blanchette@in.tum.de">authors</a>
73.53 -if you have questions or comments.
73.54 -
73.55 -</body>
73.56 -
73.57 -</html>
74.1 --- a/src/HOL/Codatatype/Tools/bnf_comp.ML Fri Sep 21 16:34:40 2012 +0200
74.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
74.3 @@ -1,726 +0,0 @@
74.4 -(* Title: HOL/BNF/Tools/bnf_comp.ML
74.5 - Author: Dmitriy Traytel, TU Muenchen
74.6 - Author: Jasmin Blanchette, TU Muenchen
74.7 - Copyright 2012
74.8 -
74.9 -Composition of bounded natural functors.
74.10 -*)
74.11 -
74.12 -signature BNF_COMP =
74.13 -sig
74.14 - type unfold_set
74.15 - val empty_unfolds: unfold_set
74.16 - val map_unfolds_of: unfold_set -> thm list
74.17 - val rel_unfolds_of: unfold_set -> thm list
74.18 - val set_unfoldss_of: unfold_set -> thm list list
74.19 - val srel_unfolds_of: unfold_set -> thm list
74.20 -
74.21 - val bnf_of_typ: BNF_Def.const_policy -> (binding -> binding) ->
74.22 - ((string * sort) list list -> (string * sort) list) -> typ -> unfold_set * Proof.context ->
74.23 - (BNF_Def.BNF * (typ list * typ list)) * (unfold_set * Proof.context)
74.24 - val default_comp_sort: (string * sort) list list -> (string * sort) list
74.25 - val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
74.26 - (''a list list -> ''a list) -> BNF_Def.BNF list -> unfold_set -> Proof.context ->
74.27 - (int list list * ''a list) * (BNF_Def.BNF list * (unfold_set * Proof.context))
74.28 - val seal_bnf: unfold_set -> binding -> typ list -> BNF_Def.BNF -> Proof.context ->
74.29 - (BNF_Def.BNF * typ list) * local_theory
74.30 -end;
74.31 -
74.32 -structure BNF_Comp : BNF_COMP =
74.33 -struct
74.34 -
74.35 -open BNF_Def
74.36 -open BNF_Util
74.37 -open BNF_Tactics
74.38 -open BNF_Comp_Tactics
74.39 -
74.40 -type unfold_set = {
74.41 - map_unfolds: thm list,
74.42 - set_unfoldss: thm list list,
74.43 - rel_unfolds: thm list,
74.44 - srel_unfolds: thm list
74.45 -};
74.46 -
74.47 -val empty_unfolds = {map_unfolds = [], set_unfoldss = [], rel_unfolds = [], srel_unfolds = []};
74.48 -
74.49 -fun add_to_thms thms new = thms |> not (Thm.is_reflexive new) ? insert Thm.eq_thm new;
74.50 -fun adds_to_thms thms news = insert (eq_set Thm.eq_thm) (no_reflexive news) thms;
74.51 -
74.52 -fun add_to_unfolds map sets rel srel
74.53 - {map_unfolds, set_unfoldss, rel_unfolds, srel_unfolds} =
74.54 - {map_unfolds = add_to_thms map_unfolds map,
74.55 - set_unfoldss = adds_to_thms set_unfoldss sets,
74.56 - rel_unfolds = add_to_thms rel_unfolds rel,
74.57 - srel_unfolds = add_to_thms srel_unfolds srel};
74.58 -
74.59 -fun add_bnf_to_unfolds bnf =
74.60 - add_to_unfolds (map_def_of_bnf bnf) (set_defs_of_bnf bnf) (rel_def_of_bnf bnf)
74.61 - (srel_def_of_bnf bnf);
74.62 -
74.63 -val map_unfolds_of = #map_unfolds;
74.64 -val set_unfoldss_of = #set_unfoldss;
74.65 -val rel_unfolds_of = #rel_unfolds;
74.66 -val srel_unfolds_of = #srel_unfolds;
74.67 -
74.68 -val bdTN = "bdT";
74.69 -
74.70 -fun mk_killN n = "_kill" ^ string_of_int n;
74.71 -fun mk_liftN n = "_lift" ^ string_of_int n;
74.72 -fun mk_permuteN src dest =
74.73 - "_permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest);
74.74 -
74.75 -(*copied from Envir.expand_term_free*)
74.76 -fun expand_term_const defs =
74.77 - let
74.78 - val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
74.79 - val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
74.80 - in Envir.expand_term get end;
74.81 -
74.82 -fun clean_compose_bnf const_policy qualify b outer inners (unfold_set, lthy) =
74.83 - let
74.84 - val olive = live_of_bnf outer;
74.85 - val onwits = nwits_of_bnf outer;
74.86 - val odead = dead_of_bnf outer;
74.87 - val inner = hd inners;
74.88 - val ilive = live_of_bnf inner;
74.89 - val ideads = map dead_of_bnf inners;
74.90 - val inwitss = map nwits_of_bnf inners;
74.91 -
74.92 - (* TODO: check olive = length inners > 0,
74.93 - forall inner from inners. ilive = live,
74.94 - forall inner from inners. idead = dead *)
74.95 -
74.96 - val (oDs, lthy1) = apfst (map TFree)
74.97 - (Variable.invent_types (replicate odead HOLogic.typeS) lthy);
74.98 - val (Dss, lthy2) = apfst (map (map TFree))
74.99 - (fold_map Variable.invent_types (map (fn n => replicate n HOLogic.typeS) ideads) lthy1);
74.100 - val (Ass, lthy3) = apfst (replicate ilive o map TFree)
74.101 - (Variable.invent_types (replicate ilive HOLogic.typeS) lthy2);
74.102 - val As = if ilive > 0 then hd Ass else [];
74.103 - val Ass_repl = replicate olive As;
74.104 - val (Bs, _(*lthy4*)) = apfst (map TFree)
74.105 - (Variable.invent_types (replicate ilive HOLogic.typeS) lthy3);
74.106 - val Bss_repl = replicate olive Bs;
74.107 -
74.108 - val ((((fs', Qs'), Asets), xs), _(*names_lthy*)) = lthy
74.109 - |> apfst snd o mk_Frees' "f" (map2 (curry (op -->)) As Bs)
74.110 - ||>> apfst snd o mk_Frees' "Q" (map2 mk_pred2T As Bs)
74.111 - ||>> mk_Frees "A" (map HOLogic.mk_setT As)
74.112 - ||>> mk_Frees "x" As;
74.113 -
74.114 - val CAs = map3 mk_T_of_bnf Dss Ass_repl inners;
74.115 - val CCA = mk_T_of_bnf oDs CAs outer;
74.116 - val CBs = map3 mk_T_of_bnf Dss Bss_repl inners;
74.117 - val outer_sets = mk_sets_of_bnf (replicate olive oDs) (replicate olive CAs) outer;
74.118 - val inner_setss = map3 mk_sets_of_bnf (map (replicate ilive) Dss) (replicate olive Ass) inners;
74.119 - val inner_bds = map3 mk_bd_of_bnf Dss Ass_repl inners;
74.120 - val outer_bd = mk_bd_of_bnf oDs CAs outer;
74.121 -
74.122 - (*%f1 ... fn. outer.map (inner_1.map f1 ... fn) ... (inner_m.map f1 ... fn)*)
74.123 - val mapx = fold_rev Term.abs fs'
74.124 - (Term.list_comb (mk_map_of_bnf oDs CAs CBs outer,
74.125 - map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
74.126 - mk_map_of_bnf Ds As Bs) Dss inners));
74.127 - (*%Q1 ... Qn. outer.rel (inner_1.rel Q1 ... Qn) ... (inner_m.rel Q1 ... Qn)*)
74.128 - val rel = fold_rev Term.abs Qs'
74.129 - (Term.list_comb (mk_rel_of_bnf oDs CAs CBs outer,
74.130 - map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
74.131 - mk_rel_of_bnf Ds As Bs) Dss inners));
74.132 -
74.133 - (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
74.134 - (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
74.135 - fun mk_set i =
74.136 - let
74.137 - val (setTs, T) = `(replicate olive o HOLogic.mk_setT) (nth As i);
74.138 - val outer_set = mk_collect
74.139 - (mk_sets_of_bnf (replicate olive oDs) (replicate olive setTs) outer)
74.140 - (mk_T_of_bnf oDs setTs outer --> HOLogic.mk_setT T);
74.141 - val inner_sets = map (fn sets => nth sets i) inner_setss;
74.142 - val outer_map = mk_map_of_bnf oDs CAs setTs outer;
74.143 - val map_inner_sets = Term.list_comb (outer_map, inner_sets);
74.144 - val collect_image = mk_collect
74.145 - (map2 (fn f => fn set => HOLogic.mk_comp (mk_image f, set)) inner_sets outer_sets)
74.146 - (CCA --> HOLogic.mk_setT T);
74.147 - in
74.148 - (Library.foldl1 HOLogic.mk_comp [mk_Union T, outer_set, map_inner_sets],
74.149 - HOLogic.mk_comp (mk_Union T, collect_image))
74.150 - end;
74.151 -
74.152 - val (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
74.153 -
74.154 - (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
74.155 - val bd = Term.absdummy CCA (mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd);
74.156 -
74.157 - fun map_id_tac {context = ctxt, ...} =
74.158 - let
74.159 - (*order the theorems by reverse size to prevent bad interaction with nonconfluent rewrite
74.160 - rules*)
74.161 - val thms = (map map_id_of_bnf inners
74.162 - |> map (`(Term.size_of_term o Thm.prop_of))
74.163 - |> sort (rev_order o int_ord o pairself fst)
74.164 - |> map snd) @ [map_id_of_bnf outer];
74.165 - in
74.166 - (EVERY' (map (fn thm => subst_tac ctxt [thm]) thms) THEN' rtac refl) 1
74.167 - end;
74.168 -
74.169 - fun map_comp_tac _ =
74.170 - mk_comp_map_comp_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
74.171 - (map map_comp_of_bnf inners);
74.172 -
74.173 - fun mk_single_set_natural_tac i _ =
74.174 - mk_comp_set_natural_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
74.175 - (collect_set_natural_of_bnf outer)
74.176 - (map ((fn thms => nth thms i) o set_natural_of_bnf) inners);
74.177 -
74.178 - val set_natural_tacs = map mk_single_set_natural_tac (0 upto ilive - 1);
74.179 -
74.180 - fun bd_card_order_tac _ =
74.181 - mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
74.182 -
74.183 - fun bd_cinfinite_tac _ =
74.184 - mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
74.185 -
74.186 - val set_alt_thms =
74.187 - if ! quick_and_dirty then
74.188 - []
74.189 - else
74.190 - map (fn goal =>
74.191 - Skip_Proof.prove lthy [] [] goal
74.192 - (fn {context, ...} => (mk_comp_set_alt_tac context (collect_set_natural_of_bnf outer)))
74.193 - |> Thm.close_derivation)
74.194 - (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) sets sets_alt);
74.195 -
74.196 - fun map_cong_tac _ =
74.197 - mk_comp_map_cong_tac set_alt_thms (map_cong_of_bnf outer) (map map_cong_of_bnf inners);
74.198 -
74.199 - val set_bd_tacs =
74.200 - if ! quick_and_dirty then
74.201 - replicate (length set_alt_thms) (K all_tac)
74.202 - else
74.203 - let
74.204 - val outer_set_bds = set_bd_of_bnf outer;
74.205 - val inner_set_bdss = map set_bd_of_bnf inners;
74.206 - val inner_bd_Card_orders = map bd_Card_order_of_bnf inners;
74.207 - fun single_set_bd_thm i j =
74.208 - @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
74.209 - nth outer_set_bds j]
74.210 - val single_set_bd_thmss =
74.211 - map ((fn f => map f (0 upto olive - 1)) o single_set_bd_thm) (0 upto ilive - 1);
74.212 - in
74.213 - map2 (fn set_alt => fn single_set_bds => fn {context, ...} =>
74.214 - mk_comp_set_bd_tac context set_alt single_set_bds)
74.215 - set_alt_thms single_set_bd_thmss
74.216 - end;
74.217 -
74.218 - val in_alt_thm =
74.219 - let
74.220 - val inx = mk_in Asets sets CCA;
74.221 - val in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
74.222 - val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
74.223 - in
74.224 - Skip_Proof.prove lthy [] [] goal
74.225 - (fn {context, ...} => mk_comp_in_alt_tac context set_alt_thms)
74.226 - |> Thm.close_derivation
74.227 - end;
74.228 -
74.229 - fun in_bd_tac _ =
74.230 - mk_comp_in_bd_tac in_alt_thm (map in_bd_of_bnf inners) (in_bd_of_bnf outer)
74.231 - (map bd_Cinfinite_of_bnf inners) (bd_Card_order_of_bnf outer);
74.232 -
74.233 - fun map_wpull_tac _ =
74.234 - mk_map_wpull_tac in_alt_thm (map map_wpull_of_bnf inners) (map_wpull_of_bnf outer);
74.235 -
74.236 - fun srel_O_Gr_tac _ =
74.237 - let
74.238 - val basic_thms = @{thms mem_Collect_eq fst_conv snd_conv}; (*TODO: tune*)
74.239 - val outer_srel_Gr = srel_Gr_of_bnf outer RS sym;
74.240 - val outer_srel_cong = srel_cong_of_bnf outer;
74.241 - val thm =
74.242 - (trans OF [in_alt_thm RS @{thm subst_rel_def},
74.243 - trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
74.244 - [trans OF [outer_srel_Gr RS @{thm arg_cong[of _ _ converse]},
74.245 - srel_converse_of_bnf outer RS sym], outer_srel_Gr],
74.246 - trans OF [srel_O_of_bnf outer RS sym, outer_srel_cong OF
74.247 - (map (fn bnf => srel_O_Gr_of_bnf bnf RS sym) inners)]]] RS sym)
74.248 - |> unfold_thms lthy (basic_thms @ srel_def_of_bnf outer :: map srel_def_of_bnf inners);
74.249 - in
74.250 - unfold_thms_tac lthy basic_thms THEN rtac thm 1
74.251 - end;
74.252 -
74.253 - val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
74.254 - bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
74.255 -
74.256 - val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
74.257 -
74.258 - val inner_witss = map (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)))
74.259 - (map3 (fn Ds => fn n => mk_wits_of_bnf (replicate n Ds) (replicate n As))
74.260 - Dss inwitss inners);
74.261 -
74.262 - val inner_witsss = map (map (nth inner_witss) o fst) outer_wits;
74.263 -
74.264 - val wits = (inner_witsss, (map (single o snd) outer_wits))
74.265 - |-> map2 (fold (map_product (fn iwit => fn owit => owit $ iwit)))
74.266 - |> flat
74.267 - |> map (`(fn t => Term.add_frees t []))
74.268 - |> minimize_wits
74.269 - |> map (fn (frees, t) => fold absfree frees t);
74.270 -
74.271 - fun wit_tac {context = ctxt, ...} =
74.272 - mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_natural_of_bnf outer)
74.273 - (maps wit_thms_of_bnf inners);
74.274 -
74.275 - val (bnf', lthy') =
74.276 - bnf_def const_policy (K Derive_Few_Facts) qualify tacs wit_tac (SOME (oDs @ flat Dss))
74.277 - (((((b, mapx), sets), bd), wits), SOME rel) lthy;
74.278 - in
74.279 - (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.280 - end;
74.281 -
74.282 -(* Killing live variables *)
74.283 -
74.284 -fun kill_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
74.285 - let
74.286 - val b = Binding.suffix_name (mk_killN n) (name_of_bnf bnf);
74.287 - val live = live_of_bnf bnf;
74.288 - val dead = dead_of_bnf bnf;
74.289 - val nwits = nwits_of_bnf bnf;
74.290 -
74.291 - (* TODO: check 0 < n <= live *)
74.292 -
74.293 - val (Ds, lthy1) = apfst (map TFree)
74.294 - (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
74.295 - val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
74.296 - (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
74.297 - val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
74.298 - (Variable.invent_types (replicate (live - n) HOLogic.typeS) lthy2);
74.299 -
74.300 - val ((Asets, lives), _(*names_lthy*)) = lthy
74.301 - |> mk_Frees "A" (map HOLogic.mk_setT (drop n As))
74.302 - ||>> mk_Frees "x" (drop n As);
74.303 - val xs = map (fn T => HOLogic.choice_const T $ absdummy T @{term True}) killedAs @ lives;
74.304 -
74.305 - val T = mk_T_of_bnf Ds As bnf;
74.306 -
74.307 - (*bnf.map id ... id*)
74.308 - val mapx = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
74.309 - (*bnf.rel (op =) ... (op =)*)
74.310 - val rel = Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, map HOLogic.eq_const killedAs);
74.311 -
74.312 - val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
74.313 - val sets = drop n bnf_sets;
74.314 -
74.315 - (*(|UNIV :: A1 set| +c ... +c |UNIV :: An set|) *c bnf.bd*)
74.316 - val bnf_bd = mk_bd_of_bnf Ds As bnf;
74.317 - val bd = mk_cprod
74.318 - (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
74.319 -
74.320 - fun map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
74.321 - fun map_comp_tac {context, ...} =
74.322 - unfold_thms_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
74.323 - rtac refl 1;
74.324 - fun map_cong_tac {context, ...} =
74.325 - mk_kill_map_cong_tac context n (live - n) (map_cong_of_bnf bnf);
74.326 - val set_natural_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_natural_of_bnf bnf));
74.327 - fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
74.328 - fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
74.329 - val set_bd_tacs =
74.330 - map (fn thm => fn _ => mk_kill_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
74.331 - (drop n (set_bd_of_bnf bnf));
74.332 -
74.333 - val in_alt_thm =
74.334 - let
74.335 - val inx = mk_in Asets sets T;
74.336 - val in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
74.337 - val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
74.338 - in
74.339 - Skip_Proof.prove lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
74.340 - end;
74.341 -
74.342 - fun in_bd_tac _ =
74.343 - mk_kill_in_bd_tac n (live > n) in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf)
74.344 - (bd_Cinfinite_of_bnf bnf) (bd_Cnotzero_of_bnf bnf);
74.345 - fun map_wpull_tac _ = mk_map_wpull_tac in_alt_thm [] (map_wpull_of_bnf bnf);
74.346 -
74.347 - fun srel_O_Gr_tac _ =
74.348 - let
74.349 - val srel_Gr = srel_Gr_of_bnf bnf RS sym
74.350 - val thm =
74.351 - (trans OF [in_alt_thm RS @{thm subst_rel_def},
74.352 - trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
74.353 - [trans OF [srel_Gr RS @{thm arg_cong[of _ _ converse]},
74.354 - srel_converse_of_bnf bnf RS sym], srel_Gr],
74.355 - trans OF [srel_O_of_bnf bnf RS sym, srel_cong_of_bnf bnf OF
74.356 - (replicate n @{thm trans[OF Gr_UNIV_id[OF refl] Id_alt[symmetric]]} @
74.357 - replicate (live - n) @{thm Gr_fst_snd})]]] RS sym)
74.358 - |> unfold_thms lthy (srel_def_of_bnf bnf :: @{thms Id_def' mem_Collect_eq split_conv});
74.359 - in
74.360 - rtac thm 1
74.361 - end;
74.362 -
74.363 - val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
74.364 - bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
74.365 -
74.366 - val bnf_wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
74.367 -
74.368 - val wits = map (fn t => fold absfree (Term.add_frees t []) t)
74.369 - (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) bnf_wits);
74.370 -
74.371 - fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
74.372 -
74.373 - val (bnf', lthy') =
74.374 - bnf_def Smart_Inline (K Derive_Few_Facts) qualify tacs wit_tac (SOME (killedAs @ Ds))
74.375 - (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
74.376 - in
74.377 - (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.378 - end;
74.379 -
74.380 -(* Adding dummy live variables *)
74.381 -
74.382 -fun lift_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
74.383 - let
74.384 - val b = Binding.suffix_name (mk_liftN n) (name_of_bnf bnf);
74.385 - val live = live_of_bnf bnf;
74.386 - val dead = dead_of_bnf bnf;
74.387 - val nwits = nwits_of_bnf bnf;
74.388 -
74.389 - (* TODO: check 0 < n *)
74.390 -
74.391 - val (Ds, lthy1) = apfst (map TFree)
74.392 - (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
74.393 - val ((newAs, As), lthy2) = apfst (chop n o map TFree)
74.394 - (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy1);
74.395 - val ((newBs, Bs), _(*lthy3*)) = apfst (chop n o map TFree)
74.396 - (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy2);
74.397 -
74.398 - val (Asets, _(*names_lthy*)) = lthy
74.399 - |> mk_Frees "A" (map HOLogic.mk_setT (newAs @ As));
74.400 -
74.401 - val T = mk_T_of_bnf Ds As bnf;
74.402 -
74.403 - (*%f1 ... fn. bnf.map*)
74.404 - val mapx =
74.405 - fold_rev Term.absdummy (map2 (curry (op -->)) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
74.406 - (*%Q1 ... Qn. bnf.rel*)
74.407 - val rel = fold_rev Term.absdummy (map2 mk_pred2T newAs newBs) (mk_rel_of_bnf Ds As Bs bnf);
74.408 -
74.409 - val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
74.410 - val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
74.411 -
74.412 - val bd = mk_bd_of_bnf Ds As bnf;
74.413 -
74.414 - fun map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
74.415 - fun map_comp_tac {context, ...} =
74.416 - unfold_thms_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
74.417 - rtac refl 1;
74.418 - fun map_cong_tac {context, ...} =
74.419 - rtac (map_cong_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac context 1);
74.420 - val set_natural_tacs =
74.421 - if ! quick_and_dirty then
74.422 - replicate (n + live) (K all_tac)
74.423 - else
74.424 - replicate n (K empty_natural_tac) @
74.425 - map (fn thm => fn _ => rtac thm 1) (set_natural_of_bnf bnf);
74.426 - fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
74.427 - fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
74.428 - val set_bd_tacs =
74.429 - if ! quick_and_dirty then
74.430 - replicate (n + live) (K all_tac)
74.431 - else
74.432 - replicate n (K (mk_lift_set_bd_tac (bd_Card_order_of_bnf bnf))) @
74.433 - (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
74.434 -
74.435 - val in_alt_thm =
74.436 - let
74.437 - val inx = mk_in Asets sets T;
74.438 - val in_alt = mk_in (drop n Asets) bnf_sets T;
74.439 - val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
74.440 - in
74.441 - Skip_Proof.prove lthy [] [] goal (K lift_in_alt_tac) |> Thm.close_derivation
74.442 - end;
74.443 -
74.444 - fun in_bd_tac _ = mk_lift_in_bd_tac n in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf);
74.445 - fun map_wpull_tac _ = mk_map_wpull_tac in_alt_thm [] (map_wpull_of_bnf bnf);
74.446 -
74.447 - fun srel_O_Gr_tac _ =
74.448 - mk_simple_srel_O_Gr_tac lthy (srel_def_of_bnf bnf) (srel_O_Gr_of_bnf bnf) in_alt_thm;
74.449 -
74.450 - val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
74.451 - bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
74.452 -
74.453 - val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
74.454 -
74.455 - fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
74.456 -
74.457 - val (bnf', lthy') =
74.458 - bnf_def Smart_Inline (K Derive_Few_Facts) qualify tacs wit_tac (SOME Ds)
74.459 - (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
74.460 -
74.461 - in
74.462 - (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.463 - end;
74.464 -
74.465 -(* Changing the order of live variables *)
74.466 -
74.467 -fun permute_bnf qualify src dest bnf (unfold_set, lthy) =
74.468 - if src = dest then (bnf, (unfold_set, lthy)) else
74.469 - let
74.470 - val b = Binding.suffix_name (mk_permuteN src dest) (name_of_bnf bnf);
74.471 - val live = live_of_bnf bnf;
74.472 - val dead = dead_of_bnf bnf;
74.473 - val nwits = nwits_of_bnf bnf;
74.474 - fun permute xs = mk_permute src dest xs;
74.475 - fun permute_rev xs = mk_permute dest src xs;
74.476 -
74.477 - val (Ds, lthy1) = apfst (map TFree)
74.478 - (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
74.479 - val (As, lthy2) = apfst (map TFree)
74.480 - (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
74.481 - val (Bs, _(*lthy3*)) = apfst (map TFree)
74.482 - (Variable.invent_types (replicate live HOLogic.typeS) lthy2);
74.483 -
74.484 - val (Asets, _(*names_lthy*)) = lthy
74.485 - |> mk_Frees "A" (map HOLogic.mk_setT (permute As));
74.486 -
74.487 - val T = mk_T_of_bnf Ds As bnf;
74.488 -
74.489 - (*%f(1) ... f(n). bnf.map f\<sigma>(1) ... f\<sigma>(n)*)
74.490 - val mapx = fold_rev Term.absdummy (permute (map2 (curry op -->) As Bs))
74.491 - (Term.list_comb (mk_map_of_bnf Ds As Bs bnf, permute_rev (map Bound (live - 1 downto 0))));
74.492 - (*%Q(1) ... Q(n). bnf.rel Q\<sigma>(1) ... Q\<sigma>(n)*)
74.493 - val rel = fold_rev Term.absdummy (permute (map2 mk_pred2T As Bs))
74.494 - (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, permute_rev (map Bound (live - 1 downto 0))));
74.495 -
74.496 - val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
74.497 - val sets = permute bnf_sets;
74.498 -
74.499 - val bd = mk_bd_of_bnf Ds As bnf;
74.500 -
74.501 - fun map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
74.502 - fun map_comp_tac _ = rtac (map_comp_of_bnf bnf) 1;
74.503 - fun map_cong_tac {context, ...} =
74.504 - rtac (map_cong_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac context 1);
74.505 - val set_natural_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_natural_of_bnf bnf));
74.506 - fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
74.507 - fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
74.508 - val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
74.509 -
74.510 - val in_alt_thm =
74.511 - let
74.512 - val inx = mk_in Asets sets T;
74.513 - val in_alt = mk_in (permute_rev Asets) bnf_sets T;
74.514 - val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
74.515 - in
74.516 - Skip_Proof.prove lthy [] [] goal (K (mk_permute_in_alt_tac src dest))
74.517 - |> Thm.close_derivation
74.518 - end;
74.519 -
74.520 - fun in_bd_tac _ =
74.521 - mk_permute_in_bd_tac src dest in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf);
74.522 - fun map_wpull_tac _ = mk_map_wpull_tac in_alt_thm [] (map_wpull_of_bnf bnf);
74.523 -
74.524 - fun srel_O_Gr_tac _ =
74.525 - mk_simple_srel_O_Gr_tac lthy (srel_def_of_bnf bnf) (srel_O_Gr_of_bnf bnf) in_alt_thm;
74.526 -
74.527 - val tacs = zip_axioms map_id_tac map_comp_tac map_cong_tac set_natural_tacs bd_card_order_tac
74.528 - bd_cinfinite_tac set_bd_tacs in_bd_tac map_wpull_tac srel_O_Gr_tac;
74.529 -
74.530 - val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
74.531 -
74.532 - fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
74.533 -
74.534 - val (bnf', lthy') =
74.535 - bnf_def Smart_Inline (K Derive_Few_Facts) qualify tacs wit_tac (SOME Ds)
74.536 - (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
74.537 - in
74.538 - (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.539 - end;
74.540 -
74.541 -(* Composition pipeline *)
74.542 -
74.543 -fun permute_and_kill qualify n src dest bnf =
74.544 - bnf
74.545 - |> permute_bnf qualify src dest
74.546 - #> uncurry (kill_bnf qualify n);
74.547 -
74.548 -fun lift_and_permute qualify n src dest bnf =
74.549 - bnf
74.550 - |> lift_bnf qualify n
74.551 - #> uncurry (permute_bnf qualify src dest);
74.552 -
74.553 -fun normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy =
74.554 - let
74.555 - val before_kill_src = map (fn As => 0 upto (length As - 1)) Ass;
74.556 - val kill_poss = map (find_indices Ds) Ass;
74.557 - val live_poss = map2 (subtract (op =)) kill_poss before_kill_src;
74.558 - val before_kill_dest = map2 append kill_poss live_poss;
74.559 - val kill_ns = map length kill_poss;
74.560 - val (inners', (unfold_set', lthy')) =
74.561 - fold_map5 (fn i => permute_and_kill (qualify i))
74.562 - (if length bnfs = 1 then [0] else (1 upto length bnfs))
74.563 - kill_ns before_kill_src before_kill_dest bnfs (unfold_set, lthy);
74.564 -
74.565 - val Ass' = map2 (map o nth) Ass live_poss;
74.566 - val As = sort Ass';
74.567 - val after_lift_dest = replicate (length Ass') (0 upto (length As - 1));
74.568 - val old_poss = map (map (fn x => find_index (fn y => x = y) As)) Ass';
74.569 - val new_poss = map2 (subtract (op =)) old_poss after_lift_dest;
74.570 - val after_lift_src = map2 append new_poss old_poss;
74.571 - val lift_ns = map (fn xs => length As - length xs) Ass';
74.572 - in
74.573 - ((kill_poss, As), fold_map5 (fn i => lift_and_permute (qualify i))
74.574 - (if length bnfs = 1 then [0] else (1 upto length bnfs))
74.575 - lift_ns after_lift_src after_lift_dest inners' (unfold_set', lthy'))
74.576 - end;
74.577 -
74.578 -fun default_comp_sort Ass =
74.579 - Library.sort (Term_Ord.typ_ord o pairself TFree) (fold (fold (insert (op =))) Ass []);
74.580 -
74.581 -fun compose_bnf const_policy qualify sort outer inners oDs Dss tfreess (unfold_set, lthy) =
74.582 - let
74.583 - val b = name_of_bnf outer;
74.584 -
74.585 - val Ass = map (map Term.dest_TFree) tfreess;
74.586 - val Ds = fold (fold Term.add_tfreesT) (oDs :: Dss) [];
74.587 -
74.588 - val ((kill_poss, As), (inners', (unfold_set', lthy'))) =
74.589 - normalize_bnfs qualify Ass Ds sort inners unfold_set lthy;
74.590 -
74.591 - val Ds = oDs @ flat (map3 (append oo map o nth) tfreess kill_poss Dss);
74.592 - val As = map TFree As;
74.593 - in
74.594 - apfst (rpair (Ds, As))
74.595 - (clean_compose_bnf const_policy (qualify 0) b outer inners' (unfold_set', lthy'))
74.596 - end;
74.597 -
74.598 -(* Hide the type of the bound (optimization) and unfold the definitions (nicer to the user) *)
74.599 -
74.600 -fun seal_bnf unfold_set b Ds bnf lthy =
74.601 - let
74.602 - val live = live_of_bnf bnf;
74.603 - val nwits = nwits_of_bnf bnf;
74.604 -
74.605 - val (As, lthy1) = apfst (map TFree)
74.606 - (Variable.invent_types (replicate live HOLogic.typeS) (fold Variable.declare_typ Ds lthy));
74.607 - val (Bs, _) = apfst (map TFree)
74.608 - (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
74.609 -
74.610 - val map_unfolds = map_unfolds_of unfold_set;
74.611 - val set_unfoldss = set_unfoldss_of unfold_set;
74.612 - val rel_unfolds = rel_unfolds_of unfold_set;
74.613 - val srel_unfolds = srel_unfolds_of unfold_set;
74.614 -
74.615 - val expand_maps =
74.616 - fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) map_unfolds);
74.617 - val expand_sets =
74.618 - fold expand_term_const (map (map (Logic.dest_equals o Thm.prop_of)) set_unfoldss);
74.619 - val expand_rels =
74.620 - fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) rel_unfolds);
74.621 - val unfold_maps = fold (unfold_thms lthy o single) map_unfolds;
74.622 - val unfold_sets = fold (unfold_thms lthy) set_unfoldss;
74.623 - val unfold_rels = unfold_thms lthy rel_unfolds;
74.624 - val unfold_srels = unfold_thms lthy srel_unfolds;
74.625 - val unfold_all = unfold_sets o unfold_maps o unfold_rels o unfold_srels;
74.626 - val bnf_map = expand_maps (mk_map_of_bnf Ds As Bs bnf);
74.627 - val bnf_sets = map (expand_maps o expand_sets)
74.628 - (mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf);
74.629 - val bnf_bd = mk_bd_of_bnf Ds As bnf;
74.630 - val bnf_rel = expand_rels (mk_rel_of_bnf Ds As Bs bnf);
74.631 - val T = mk_T_of_bnf Ds As bnf;
74.632 -
74.633 - (*bd should only depend on dead type variables!*)
74.634 - val bd_repT = fst (dest_relT (fastype_of bnf_bd));
74.635 - val bdT_bind = Binding.suffix_name ("_" ^ bdTN) b;
74.636 - val params = fold Term.add_tfreesT Ds [];
74.637 - val deads = map TFree params;
74.638 -
74.639 - val ((bdT_name, (bdT_glob_info, bdT_loc_info)), lthy) =
74.640 - typedef false NONE (bdT_bind, params, NoSyn)
74.641 - (HOLogic.mk_UNIV bd_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
74.642 -
74.643 - val bnf_bd' = mk_dir_image bnf_bd
74.644 - (Const (#Abs_name bdT_glob_info, bd_repT --> Type (bdT_name, deads)))
74.645 -
74.646 - val Abs_bdT_inj = mk_Abs_inj_thm (#Abs_inject bdT_loc_info);
74.647 - val Abs_bdT_bij = mk_Abs_bij_thm lthy Abs_bdT_inj (#Abs_cases bdT_loc_info);
74.648 -
74.649 - val bd_ordIso = @{thm dir_image} OF [Abs_bdT_inj, bd_Card_order_of_bnf bnf];
74.650 - val bd_card_order =
74.651 - @{thm card_order_dir_image} OF [Abs_bdT_bij, bd_card_order_of_bnf bnf];
74.652 - val bd_cinfinite =
74.653 - (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
74.654 -
74.655 - val set_bds =
74.656 - map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
74.657 - val in_bd =
74.658 - @{thm ordLeq_ordIso_trans} OF [in_bd_of_bnf bnf,
74.659 - @{thm cexp_cong2_Cnotzero} OF [bd_ordIso, if live = 0 then
74.660 - @{thm ctwo_Cnotzero} else @{thm ctwo_Cnotzero} RS @{thm csum_Cnotzero2},
74.661 - bd_Card_order_of_bnf bnf]];
74.662 -
74.663 - fun mk_tac thm {context = ctxt, prems = _} =
74.664 - (rtac (unfold_all thm) THEN'
74.665 - SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
74.666 -
74.667 - val tacs = zip_axioms (mk_tac (map_id_of_bnf bnf)) (mk_tac (map_comp_of_bnf bnf))
74.668 - (mk_tac (map_cong_of_bnf bnf)) (map mk_tac (set_natural_of_bnf bnf))
74.669 - (K (rtac bd_card_order 1)) (K (rtac bd_cinfinite 1)) (map mk_tac set_bds) (mk_tac in_bd)
74.670 - (mk_tac (map_wpull_of_bnf bnf))
74.671 - (mk_tac (unfold_thms lthy [srel_def_of_bnf bnf] (srel_O_Gr_of_bnf bnf)));
74.672 -
74.673 - val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
74.674 -
74.675 - fun wit_tac _ = mk_simple_wit_tac (map unfold_all (wit_thms_of_bnf bnf));
74.676 -
74.677 - val policy = user_policy Derive_All_Facts;
74.678 -
74.679 - val (bnf', lthy') = bnf_def Hardly_Inline policy I tacs wit_tac (SOME deads)
74.680 - (((((b, bnf_map), bnf_sets), Term.absdummy T bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
74.681 - in
74.682 - ((bnf', deads), lthy')
74.683 - end;
74.684 -
74.685 -val ID_bnf = the (bnf_of @{context} "Basic_BNFs.ID");
74.686 -val DEADID_bnf = the (bnf_of @{context} "Basic_BNFs.DEADID");
74.687 -
74.688 -fun bnf_of_typ _ _ _ (T as TFree _) accum = ((ID_bnf, ([], [T])), accum)
74.689 - | bnf_of_typ _ _ _ (TVar _) _ = error "Unexpected schematic variable"
74.690 - | bnf_of_typ const_policy qualify' sort (T as Type (C, Ts)) (unfold_set, lthy) =
74.691 - let
74.692 - val tfrees = Term.add_tfreesT T [];
74.693 - val bnf_opt = if null tfrees then NONE else bnf_of lthy C;
74.694 - in
74.695 - (case bnf_opt of
74.696 - NONE => ((DEADID_bnf, ([T], [])), (unfold_set, lthy))
74.697 - | SOME bnf =>
74.698 - if forall (can Term.dest_TFree) Ts andalso length Ts = length tfrees then
74.699 - let
74.700 - val T' = T_of_bnf bnf;
74.701 - val deads = deads_of_bnf bnf;
74.702 - val lives = lives_of_bnf bnf;
74.703 - val tvars' = Term.add_tvarsT T' [];
74.704 - val deads_lives =
74.705 - pairself (map (Term.typ_subst_TVars (map fst tvars' ~~ map TFree tfrees)))
74.706 - (deads, lives);
74.707 - in ((bnf, deads_lives), (unfold_set, lthy)) end
74.708 - else
74.709 - let
74.710 - val name = Long_Name.base_name C;
74.711 - fun qualify i =
74.712 - let val namei = name ^ nonzero_string_of_int i;
74.713 - in qualify' o Binding.qualify true namei end;
74.714 - val odead = dead_of_bnf bnf;
74.715 - val olive = live_of_bnf bnf;
74.716 - val oDs_pos = find_indices [TFree ("dead", [])] (snd (Term.dest_Type
74.717 - (mk_T_of_bnf (replicate odead (TFree ("dead", []))) (replicate olive dummyT) bnf)));
74.718 - val oDs = map (nth Ts) oDs_pos;
74.719 - val Ts' = map (nth Ts) (subtract (op =) oDs_pos (0 upto length Ts - 1));
74.720 - val ((inners, (Dss, Ass)), (unfold_set', lthy')) =
74.721 - apfst (apsnd split_list o split_list)
74.722 - (fold_map2 (fn i => bnf_of_typ Smart_Inline (qualify i) sort)
74.723 - (if length Ts' = 1 then [0] else (1 upto length Ts')) Ts' (unfold_set, lthy));
74.724 - in
74.725 - compose_bnf const_policy qualify sort bnf inners oDs Dss Ass (unfold_set', lthy')
74.726 - end)
74.727 - end;
74.728 -
74.729 -end;
75.1 --- a/src/HOL/Codatatype/Tools/bnf_comp_tactics.ML Fri Sep 21 16:34:40 2012 +0200
75.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
75.3 @@ -1,416 +0,0 @@
75.4 -(* Title: HOL/BNF/Tools/bnf_comp_tactics.ML
75.5 - Author: Dmitriy Traytel, TU Muenchen
75.6 - Author: Jasmin Blanchette, TU Muenchen
75.7 - Copyright 2012
75.8 -
75.9 -Tactics for composition of bounded natural functors.
75.10 -*)
75.11 -
75.12 -signature BNF_COMP_TACTICS =
75.13 -sig
75.14 - val mk_comp_bd_card_order_tac: thm list -> thm -> tactic
75.15 - val mk_comp_bd_cinfinite_tac: thm -> thm -> tactic
75.16 - val mk_comp_in_alt_tac: Proof.context -> thm list -> tactic
75.17 - val mk_comp_in_bd_tac: thm -> thm list -> thm -> thm list -> thm -> tactic
75.18 - val mk_comp_map_comp_tac: thm -> thm -> thm list -> tactic
75.19 - val mk_comp_map_cong_tac: thm list -> thm -> thm list -> tactic
75.20 - val mk_comp_set_alt_tac: Proof.context -> thm -> tactic
75.21 - val mk_comp_set_bd_tac: Proof.context -> thm -> thm list -> tactic
75.22 - val mk_comp_set_natural_tac: thm -> thm -> thm -> thm list -> tactic
75.23 - val mk_comp_wit_tac: Proof.context -> thm list -> thm -> thm list -> tactic
75.24 -
75.25 - val mk_kill_bd_card_order_tac: int -> thm -> tactic
75.26 - val mk_kill_bd_cinfinite_tac: thm -> tactic
75.27 - val kill_in_alt_tac: tactic
75.28 - val mk_kill_in_bd_tac: int -> bool -> thm -> thm -> thm -> thm -> thm -> tactic
75.29 - val mk_kill_map_cong_tac: Proof.context -> int -> int -> thm -> tactic
75.30 - val mk_kill_set_bd_tac: thm -> thm -> tactic
75.31 -
75.32 - val empty_natural_tac: tactic
75.33 - val lift_in_alt_tac: tactic
75.34 - val mk_lift_in_bd_tac: int -> thm -> thm -> thm -> tactic
75.35 - val mk_lift_set_bd_tac: thm -> tactic
75.36 -
75.37 - val mk_permute_in_alt_tac: ''a list -> ''a list -> tactic
75.38 - val mk_permute_in_bd_tac: ''a list -> ''a list -> thm -> thm -> thm -> tactic
75.39 -
75.40 - val mk_map_wpull_tac: thm -> thm list -> thm -> tactic
75.41 - val mk_simple_srel_O_Gr_tac: Proof.context -> thm -> thm -> thm -> tactic
75.42 - val mk_simple_wit_tac: thm list -> tactic
75.43 -end;
75.44 -
75.45 -structure BNF_Comp_Tactics : BNF_COMP_TACTICS =
75.46 -struct
75.47 -
75.48 -open BNF_Util
75.49 -open BNF_Tactics
75.50 -
75.51 -val Card_order_csum = @{thm Card_order_csum};
75.52 -val Card_order_ctwo = @{thm Card_order_ctwo};
75.53 -val Cnotzero_UNIV = @{thm Cnotzero_UNIV};
75.54 -val arg_cong_Union = @{thm arg_cong[of _ _ Union]};
75.55 -val card_of_Card_order = @{thm card_of_Card_order};
75.56 -val csum_Cnotzero1 = @{thm csum_Cnotzero1};
75.57 -val csum_Cnotzero2 = @{thm csum_Cnotzero2};
75.58 -val ctwo_Cnotzero = @{thm ctwo_Cnotzero};
75.59 -val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
75.60 -val ordIso_transitive = @{thm ordIso_transitive};
75.61 -val ordLeq_csum2 = @{thm ordLeq_csum2};
75.62 -val trans_image_cong_o_apply = @{thm trans[OF image_cong[OF o_apply refl]]};
75.63 -val trans_o_apply = @{thm trans[OF o_apply]};
75.64 -
75.65 -
75.66 -
75.67 -(* Composition *)
75.68 -
75.69 -fun mk_comp_set_alt_tac ctxt collect_set_natural =
75.70 - unfold_thms_tac ctxt @{thms sym[OF o_assoc]} THEN
75.71 - unfold_thms_tac ctxt [collect_set_natural RS sym] THEN
75.72 - rtac refl 1;
75.73 -
75.74 -fun mk_comp_map_comp_tac Gmap_comp Gmap_cong map_comps =
75.75 - EVERY' ([rtac ext, rtac sym, rtac trans_o_apply,
75.76 - rtac (Gmap_comp RS sym RS o_eq_dest_lhs RS trans), rtac Gmap_cong] @
75.77 - map (fn thm => rtac (thm RS sym RS fun_cong)) map_comps) 1;
75.78 -
75.79 -fun mk_comp_set_natural_tac Gmap_comp Gmap_cong Gset_natural set_naturals =
75.80 - EVERY' ([rtac ext] @
75.81 - replicate 3 (rtac trans_o_apply) @
75.82 - [rtac (arg_cong_Union RS trans),
75.83 - rtac (@{thm arg_cong2[of _ _ _ _ collect, OF refl]} RS trans),
75.84 - rtac (Gmap_comp RS sym RS o_eq_dest_lhs RS trans),
75.85 - rtac Gmap_cong] @
75.86 - map (fn thm => rtac (thm RS fun_cong)) set_naturals @
75.87 - [rtac (Gset_natural RS o_eq_dest_lhs), rtac sym, rtac trans_o_apply,
75.88 - rtac trans_image_cong_o_apply, rtac trans_image_cong_o_apply,
75.89 - rtac (@{thm image_cong} OF [Gset_natural RS o_eq_dest_lhs RS arg_cong_Union, refl] RS trans),
75.90 - rtac @{thm trans[OF pointfreeE[OF Union_natural[symmetric]]]}, rtac arg_cong_Union,
75.91 - rtac @{thm trans[OF o_eq_dest_lhs[OF image_o_collect[symmetric]]]},
75.92 - rtac @{thm fun_cong[OF arg_cong[of _ _ collect]]}] @
75.93 - [REPEAT_DETERM_N (length set_naturals) o EVERY' [rtac @{thm trans[OF image_insert]},
75.94 - rtac @{thm arg_cong2[of _ _ _ _ insert]}, rtac ext, rtac trans_o_apply,
75.95 - rtac trans_image_cong_o_apply, rtac @{thm trans[OF image_image]},
75.96 - rtac @{thm sym[OF trans[OF o_apply]]}, rtac @{thm image_cong[OF refl o_apply]}],
75.97 - rtac @{thm image_empty}]) 1;
75.98 -
75.99 -fun mk_comp_map_cong_tac comp_set_alts map_cong map_congs =
75.100 - let
75.101 - val n = length comp_set_alts;
75.102 - in
75.103 - (if n = 0 then rtac refl 1
75.104 - else rtac map_cong 1 THEN
75.105 - EVERY' (map_index (fn (i, map_cong) =>
75.106 - rtac map_cong THEN' EVERY' (map_index (fn (k, set_alt) =>
75.107 - EVERY' [select_prem_tac n (dtac @{thm meta_spec}) (k + 1), etac @{thm meta_mp},
75.108 - rtac (equalityD2 RS set_mp), rtac (set_alt RS fun_cong RS trans),
75.109 - rtac trans_o_apply, rtac (@{thm collect_def} RS arg_cong_Union),
75.110 - rtac @{thm UnionI}, rtac @{thm UN_I}, REPEAT_DETERM_N i o rtac @{thm insertI2},
75.111 - rtac @{thm insertI1}, rtac (o_apply RS equalityD2 RS set_mp),
75.112 - etac @{thm imageI}, atac])
75.113 - comp_set_alts))
75.114 - map_congs) 1)
75.115 - end;
75.116 -
75.117 -fun mk_comp_bd_card_order_tac Fbd_card_orders Gbd_card_order =
75.118 - let
75.119 - val (card_orders, last_card_order) = split_last Fbd_card_orders;
75.120 - fun gen_before thm = rtac @{thm card_order_csum} THEN' rtac thm;
75.121 - in
75.122 - (rtac @{thm card_order_cprod} THEN'
75.123 - WRAP' gen_before (K (K all_tac)) card_orders (rtac last_card_order) THEN'
75.124 - rtac Gbd_card_order) 1
75.125 - end;
75.126 -
75.127 -fun mk_comp_bd_cinfinite_tac Fbd_cinfinite Gbd_cinfinite =
75.128 - (rtac @{thm cinfinite_cprod} THEN'
75.129 - ((K (TRY ((rtac @{thm cinfinite_csum} THEN' rtac disjI1) 1)) THEN'
75.130 - ((rtac @{thm cinfinite_csum} THEN' rtac disjI1 THEN' rtac Fbd_cinfinite) ORELSE'
75.131 - rtac Fbd_cinfinite)) ORELSE'
75.132 - rtac Fbd_cinfinite) THEN'
75.133 - rtac Gbd_cinfinite) 1;
75.134 -
75.135 -fun mk_comp_set_bd_tac ctxt comp_set_alt Gset_Fset_bds =
75.136 - let
75.137 - val (bds, last_bd) = split_last Gset_Fset_bds;
75.138 - fun gen_before bd =
75.139 - rtac ctrans THEN' rtac @{thm Un_csum} THEN'
75.140 - rtac ctrans THEN' rtac @{thm csum_mono} THEN'
75.141 - rtac bd;
75.142 - fun gen_after _ = rtac @{thm ordIso_imp_ordLeq} THEN' rtac @{thm cprod_csum_distrib1};
75.143 - in
75.144 - unfold_thms_tac ctxt [comp_set_alt] THEN
75.145 - rtac @{thm comp_set_bd_Union_o_collect} 1 THEN
75.146 - unfold_thms_tac ctxt @{thms Union_image_insert Union_image_empty Union_Un_distrib o_apply} THEN
75.147 - (rtac ctrans THEN'
75.148 - WRAP' gen_before gen_after bds (rtac last_bd) THEN'
75.149 - rtac @{thm ordIso_imp_ordLeq} THEN'
75.150 - rtac @{thm cprod_com}) 1
75.151 - end;
75.152 -
75.153 -val comp_in_alt_thms = @{thms o_apply collect_def SUP_def image_insert image_empty Union_insert
75.154 - Union_empty Un_empty_right Union_Un_distrib Un_subset_iff conj_subset_def UN_image_subset
75.155 - conj_assoc};
75.156 -
75.157 -fun mk_comp_in_alt_tac ctxt comp_set_alts =
75.158 - unfold_thms_tac ctxt (comp_set_alts @ comp_in_alt_thms) THEN
75.159 - unfold_thms_tac ctxt @{thms set_eq_subset} THEN
75.160 - rtac conjI 1 THEN
75.161 - REPEAT_DETERM (
75.162 - rtac @{thm subsetI} 1 THEN
75.163 - unfold_thms_tac ctxt @{thms mem_Collect_eq Ball_def} THEN
75.164 - (REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
75.165 - REPEAT_DETERM (CHANGED ((
75.166 - (rtac conjI THEN' (atac ORELSE' rtac subset_UNIV)) ORELSE'
75.167 - atac ORELSE'
75.168 - (rtac subset_UNIV)) 1)) ORELSE rtac subset_UNIV 1));
75.169 -
75.170 -fun mk_comp_in_bd_tac comp_in_alt Fin_bds Gin_bd Fbd_Cinfs Gbd_Card_order =
75.171 - let
75.172 - val (bds, last_bd) = split_last Fin_bds;
75.173 - val (Cinfs, _) = split_last Fbd_Cinfs;
75.174 - fun gen_before (bd, _) = rtac ctrans THEN' rtac @{thm csum_mono} THEN' rtac bd;
75.175 - fun gen_after (_, (bd_Cinf, next_bd_Cinf)) =
75.176 - TRY o (rtac @{thm csum_cexp} THEN'
75.177 - rtac bd_Cinf THEN'
75.178 - (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac next_bd_Cinf ORELSE'
75.179 - rtac next_bd_Cinf) THEN'
75.180 - ((rtac Card_order_csum THEN' rtac ordLeq_csum2) ORELSE'
75.181 - (rtac Card_order_ctwo THEN' rtac @{thm ordLeq_refl})) THEN'
75.182 - rtac Card_order_ctwo);
75.183 - in
75.184 - (rtac @{thm ordIso_ordLeq_trans} THEN'
75.185 - rtac @{thm card_of_ordIso_subst} THEN'
75.186 - rtac comp_in_alt THEN'
75.187 - rtac ctrans THEN'
75.188 - rtac Gin_bd THEN'
75.189 - rtac @{thm ordLeq_ordIso_trans} THEN'
75.190 - rtac @{thm cexp_mono1} THEN'
75.191 - rtac @{thm ordLeq_ordIso_trans} THEN'
75.192 - rtac @{thm csum_mono1} THEN'
75.193 - WRAP' gen_before gen_after (bds ~~ (Cinfs ~~ tl Fbd_Cinfs)) (rtac last_bd) THEN'
75.194 - rtac @{thm csum_absorb1} THEN'
75.195 - rtac @{thm Cinfinite_cexp} THEN'
75.196 - (rtac ordLeq_csum2 ORELSE' rtac @{thm ordLeq_refl}) THEN'
75.197 - rtac Card_order_ctwo THEN'
75.198 - (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac (hd Fbd_Cinfs) ORELSE'
75.199 - rtac (hd Fbd_Cinfs)) THEN'
75.200 - rtac @{thm ctwo_ordLeq_Cinfinite} THEN'
75.201 - rtac @{thm Cinfinite_cexp} THEN'
75.202 - (rtac ordLeq_csum2 ORELSE' rtac @{thm ordLeq_refl}) THEN'
75.203 - rtac Card_order_ctwo THEN'
75.204 - (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac (hd Fbd_Cinfs) ORELSE'
75.205 - rtac (hd Fbd_Cinfs)) THEN'
75.206 - rtac disjI1 THEN'
75.207 - TRY o rtac csum_Cnotzero2 THEN'
75.208 - rtac ctwo_Cnotzero THEN'
75.209 - rtac Gbd_Card_order THEN'
75.210 - rtac @{thm cexp_cprod} THEN'
75.211 - TRY o rtac csum_Cnotzero2 THEN'
75.212 - rtac ctwo_Cnotzero) 1
75.213 - end;
75.214 -
75.215 -val comp_wit_thms = @{thms Union_empty_conv o_apply collect_def SUP_def
75.216 - Union_image_insert Union_image_empty};
75.217 -
75.218 -fun mk_comp_wit_tac ctxt Gwit_thms collect_set_natural Fwit_thms =
75.219 - ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
75.220 - unfold_thms_tac ctxt (collect_set_natural :: comp_wit_thms) THEN
75.221 - REPEAT_DETERM (
75.222 - atac 1 ORELSE
75.223 - REPEAT_DETERM (eresolve_tac @{thms UnionE UnE imageE} 1) THEN
75.224 - (TRY o dresolve_tac Gwit_thms THEN'
75.225 - (etac FalseE ORELSE'
75.226 - hyp_subst_tac THEN'
75.227 - dresolve_tac Fwit_thms THEN'
75.228 - (etac FalseE ORELSE' atac))) 1);
75.229 -
75.230 -
75.231 -
75.232 -(* Kill operation *)
75.233 -
75.234 -fun mk_kill_map_cong_tac ctxt n m map_cong =
75.235 - (rtac map_cong THEN' EVERY' (replicate n (rtac refl)) THEN'
75.236 - EVERY' (replicate m (Goal.assume_rule_tac ctxt))) 1;
75.237 -
75.238 -fun mk_kill_bd_card_order_tac n bd_card_order =
75.239 - (rtac @{thm card_order_cprod} THEN'
75.240 - K (REPEAT_DETERM_N (n - 1)
75.241 - ((rtac @{thm card_order_csum} THEN'
75.242 - rtac @{thm card_of_card_order_on}) 1)) THEN'
75.243 - rtac @{thm card_of_card_order_on} THEN'
75.244 - rtac bd_card_order) 1;
75.245 -
75.246 -fun mk_kill_bd_cinfinite_tac bd_Cinfinite =
75.247 - (rtac @{thm cinfinite_cprod2} THEN'
75.248 - TRY o rtac csum_Cnotzero1 THEN'
75.249 - rtac Cnotzero_UNIV THEN'
75.250 - rtac bd_Cinfinite) 1;
75.251 -
75.252 -fun mk_kill_set_bd_tac bd_Card_order set_bd =
75.253 - (rtac ctrans THEN'
75.254 - rtac set_bd THEN'
75.255 - rtac @{thm ordLeq_cprod2} THEN'
75.256 - TRY o rtac csum_Cnotzero1 THEN'
75.257 - rtac Cnotzero_UNIV THEN'
75.258 - rtac bd_Card_order) 1
75.259 -
75.260 -val kill_in_alt_tac =
75.261 - ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
75.262 - REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
75.263 - REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
75.264 - rtac conjI THEN' rtac subset_UNIV) 1)) THEN
75.265 - (rtac subset_UNIV ORELSE' atac) 1 THEN
75.266 - REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
75.267 - REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1))) ORELSE
75.268 - ((rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
75.269 - REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac subset_UNIV 1));
75.270 -
75.271 -fun mk_kill_in_bd_tac n nontrivial_kill_in in_alt in_bd bd_Card_order bd_Cinfinite bd_Cnotzero =
75.272 - (rtac @{thm ordIso_ordLeq_trans} THEN'
75.273 - rtac @{thm card_of_ordIso_subst} THEN'
75.274 - rtac in_alt THEN'
75.275 - rtac ctrans THEN'
75.276 - rtac in_bd THEN'
75.277 - rtac @{thm ordIso_ordLeq_trans} THEN'
75.278 - rtac @{thm cexp_cong1}) 1 THEN
75.279 - (if nontrivial_kill_in then
75.280 - rtac ordIso_transitive 1 THEN
75.281 - REPEAT_DETERM_N (n - 1)
75.282 - ((rtac @{thm csum_cong1} THEN'
75.283 - rtac @{thm ordIso_symmetric} THEN'
75.284 - rtac @{thm csum_assoc} THEN'
75.285 - rtac ordIso_transitive) 1) THEN
75.286 - (rtac @{thm ordIso_refl} THEN'
75.287 - rtac Card_order_csum THEN'
75.288 - rtac ordIso_transitive THEN'
75.289 - rtac @{thm csum_assoc} THEN'
75.290 - rtac ordIso_transitive THEN'
75.291 - rtac @{thm csum_cong1} THEN'
75.292 - K (mk_flatten_assoc_tac
75.293 - (rtac @{thm ordIso_refl} THEN'
75.294 - FIRST' [rtac card_of_Card_order, rtac Card_order_csum])
75.295 - ordIso_transitive @{thm csum_assoc} @{thm csum_cong}) THEN'
75.296 - rtac @{thm ordIso_refl} THEN'
75.297 - (rtac card_of_Card_order ORELSE' rtac Card_order_csum)) 1
75.298 - else all_tac) THEN
75.299 - (rtac @{thm csum_com} THEN'
75.300 - rtac bd_Card_order THEN'
75.301 - rtac disjI1 THEN'
75.302 - rtac csum_Cnotzero2 THEN'
75.303 - rtac ctwo_Cnotzero THEN'
75.304 - rtac disjI1 THEN'
75.305 - rtac csum_Cnotzero2 THEN'
75.306 - TRY o rtac csum_Cnotzero1 THEN'
75.307 - rtac Cnotzero_UNIV THEN'
75.308 - rtac @{thm ordLeq_ordIso_trans} THEN'
75.309 - rtac @{thm cexp_mono1} THEN'
75.310 - rtac ctrans THEN'
75.311 - rtac @{thm csum_mono2} THEN'
75.312 - rtac @{thm ordLeq_cprod1} THEN'
75.313 - (rtac card_of_Card_order ORELSE' rtac Card_order_csum) THEN'
75.314 - rtac bd_Cnotzero THEN'
75.315 - rtac @{thm csum_cexp'} THEN'
75.316 - rtac @{thm Cinfinite_cprod2} THEN'
75.317 - TRY o rtac csum_Cnotzero1 THEN'
75.318 - rtac Cnotzero_UNIV THEN'
75.319 - rtac bd_Cinfinite THEN'
75.320 - ((rtac Card_order_ctwo THEN' rtac @{thm ordLeq_refl}) ORELSE'
75.321 - (rtac Card_order_csum THEN' rtac ordLeq_csum2)) THEN'
75.322 - rtac Card_order_ctwo THEN'
75.323 - rtac disjI1 THEN'
75.324 - rtac csum_Cnotzero2 THEN'
75.325 - TRY o rtac csum_Cnotzero1 THEN'
75.326 - rtac Cnotzero_UNIV THEN'
75.327 - rtac bd_Card_order THEN'
75.328 - rtac @{thm cexp_cprod_ordLeq} THEN'
75.329 - TRY o rtac csum_Cnotzero2 THEN'
75.330 - rtac ctwo_Cnotzero THEN'
75.331 - rtac @{thm Cinfinite_cprod2} THEN'
75.332 - TRY o rtac csum_Cnotzero1 THEN'
75.333 - rtac Cnotzero_UNIV THEN'
75.334 - rtac bd_Cinfinite THEN'
75.335 - rtac bd_Cnotzero THEN'
75.336 - rtac @{thm ordLeq_cprod2} THEN'
75.337 - TRY o rtac csum_Cnotzero1 THEN'
75.338 - rtac Cnotzero_UNIV THEN'
75.339 - rtac bd_Card_order) 1;
75.340 -
75.341 -
75.342 -
75.343 -(* Lift operation *)
75.344 -
75.345 -val empty_natural_tac = rtac @{thm empty_natural} 1;
75.346 -
75.347 -fun mk_lift_set_bd_tac bd_Card_order = (rtac @{thm Card_order_empty} THEN' rtac bd_Card_order) 1;
75.348 -
75.349 -val lift_in_alt_tac =
75.350 - ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
75.351 - REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
75.352 - REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1)) THEN
75.353 - REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
75.354 - REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
75.355 - rtac conjI THEN' rtac @{thm empty_subsetI}) 1)) THEN
75.356 - (rtac @{thm empty_subsetI} ORELSE' atac) 1) ORELSE
75.357 - ((rtac sym THEN' rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
75.358 - REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac @{thm empty_subsetI} 1));
75.359 -
75.360 -fun mk_lift_in_bd_tac n in_alt in_bd bd_Card_order =
75.361 - (rtac @{thm ordIso_ordLeq_trans} THEN'
75.362 - rtac @{thm card_of_ordIso_subst} THEN'
75.363 - rtac in_alt THEN'
75.364 - rtac ctrans THEN'
75.365 - rtac in_bd THEN'
75.366 - rtac @{thm cexp_mono1}) 1 THEN
75.367 - ((rtac @{thm csum_mono1} 1 THEN
75.368 - REPEAT_DETERM_N (n - 1)
75.369 - ((rtac ctrans THEN'
75.370 - rtac ordLeq_csum2 THEN'
75.371 - (rtac Card_order_csum ORELSE' rtac card_of_Card_order)) 1) THEN
75.372 - (rtac ordLeq_csum2 THEN'
75.373 - (rtac Card_order_csum ORELSE' rtac card_of_Card_order)) 1) ORELSE
75.374 - (rtac ordLeq_csum2 THEN' rtac Card_order_ctwo) 1) THEN
75.375 - (rtac disjI1 THEN' TRY o rtac csum_Cnotzero2 THEN' rtac ctwo_Cnotzero
75.376 - THEN' rtac bd_Card_order) 1;
75.377 -
75.378 -
75.379 -
75.380 -(* Permute operation *)
75.381 -
75.382 -fun mk_permute_in_alt_tac src dest =
75.383 - (rtac @{thm Collect_cong} THEN'
75.384 - mk_rotate_eq_tac (rtac refl) trans @{thm conj_assoc} @{thm conj_commute} @{thm conj_cong}
75.385 - dest src) 1;
75.386 -
75.387 -fun mk_permute_in_bd_tac src dest in_alt in_bd bd_Card_order =
75.388 - (rtac @{thm ordIso_ordLeq_trans} THEN'
75.389 - rtac @{thm card_of_ordIso_subst} THEN'
75.390 - rtac in_alt THEN'
75.391 - rtac @{thm ordLeq_ordIso_trans} THEN'
75.392 - rtac in_bd THEN'
75.393 - rtac @{thm cexp_cong1} THEN'
75.394 - rtac @{thm csum_cong1} THEN'
75.395 - mk_rotate_eq_tac
75.396 - (rtac @{thm ordIso_refl} THEN'
75.397 - FIRST' [rtac card_of_Card_order, rtac Card_order_csum])
75.398 - ordIso_transitive @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
75.399 - src dest THEN'
75.400 - rtac bd_Card_order THEN'
75.401 - rtac disjI1 THEN'
75.402 - TRY o rtac csum_Cnotzero2 THEN'
75.403 - rtac ctwo_Cnotzero THEN'
75.404 - rtac disjI1 THEN'
75.405 - TRY o rtac csum_Cnotzero2 THEN'
75.406 - rtac ctwo_Cnotzero) 1;
75.407 -
75.408 -fun mk_map_wpull_tac comp_in_alt inner_map_wpulls outer_map_wpull =
75.409 - (rtac (@{thm wpull_cong} OF (replicate 3 comp_in_alt)) THEN' rtac outer_map_wpull) 1 THEN
75.410 - WRAP (fn thm => rtac thm 1 THEN REPEAT_DETERM (atac 1)) (K all_tac) inner_map_wpulls all_tac THEN
75.411 - TRY (REPEAT_DETERM (atac 1 ORELSE rtac @{thm wpull_id} 1));
75.412 -
75.413 -fun mk_simple_srel_O_Gr_tac ctxt srel_def srel_O_Gr in_alt_thm =
75.414 - rtac (unfold_thms ctxt [srel_def]
75.415 - (trans OF [srel_O_Gr, in_alt_thm RS @{thm subst_rel_def} RS sym])) 1;
75.416 -
75.417 -fun mk_simple_wit_tac wit_thms = ALLGOALS (atac ORELSE' eresolve_tac (@{thm emptyE} :: wit_thms));
75.418 -
75.419 -end;
76.1 --- a/src/HOL/Codatatype/Tools/bnf_def.ML Fri Sep 21 16:34:40 2012 +0200
76.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
76.3 @@ -1,1238 +0,0 @@
76.4 -(* Title: HOL/BNF/Tools/bnf_def.ML
76.5 - Author: Dmitriy Traytel, TU Muenchen
76.6 - Author: Jasmin Blanchette, TU Muenchen
76.7 - Copyright 2012
76.8 -
76.9 -Definition of bounded natural functors.
76.10 -*)
76.11 -
76.12 -signature BNF_DEF =
76.13 -sig
76.14 - type BNF
76.15 - type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
76.16 -
76.17 - val bnf_of: Proof.context -> string -> BNF option
76.18 - val register_bnf: string -> (BNF * local_theory) -> (BNF * local_theory)
76.19 -
76.20 - val name_of_bnf: BNF -> binding
76.21 - val T_of_bnf: BNF -> typ
76.22 - val live_of_bnf: BNF -> int
76.23 - val lives_of_bnf: BNF -> typ list
76.24 - val dead_of_bnf: BNF -> int
76.25 - val deads_of_bnf: BNF -> typ list
76.26 - val nwits_of_bnf: BNF -> int
76.27 -
76.28 - val mapN: string
76.29 - val relN: string
76.30 - val setN: string
76.31 - val mk_setN: int -> string
76.32 - val srelN: string
76.33 -
76.34 - val map_of_bnf: BNF -> term
76.35 -
76.36 - val mk_T_of_bnf: typ list -> typ list -> BNF -> typ
76.37 - val mk_bd_of_bnf: typ list -> typ list -> BNF -> term
76.38 - val mk_map_of_bnf: typ list -> typ list -> typ list -> BNF -> term
76.39 - val mk_rel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
76.40 - val mk_sets_of_bnf: typ list list -> typ list list -> BNF -> term list
76.41 - val mk_srel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
76.42 - val mk_wits_of_bnf: typ list list -> typ list list -> BNF -> (int list * term) list
76.43 -
76.44 - val bd_Card_order_of_bnf: BNF -> thm
76.45 - val bd_Cinfinite_of_bnf: BNF -> thm
76.46 - val bd_Cnotzero_of_bnf: BNF -> thm
76.47 - val bd_card_order_of_bnf: BNF -> thm
76.48 - val bd_cinfinite_of_bnf: BNF -> thm
76.49 - val collect_set_natural_of_bnf: BNF -> thm
76.50 - val in_bd_of_bnf: BNF -> thm
76.51 - val in_cong_of_bnf: BNF -> thm
76.52 - val in_mono_of_bnf: BNF -> thm
76.53 - val in_srel_of_bnf: BNF -> thm
76.54 - val map_comp'_of_bnf: BNF -> thm
76.55 - val map_comp_of_bnf: BNF -> thm
76.56 - val map_cong_of_bnf: BNF -> thm
76.57 - val map_def_of_bnf: BNF -> thm
76.58 - val map_id'_of_bnf: BNF -> thm
76.59 - val map_id_of_bnf: BNF -> thm
76.60 - val map_wppull_of_bnf: BNF -> thm
76.61 - val map_wpull_of_bnf: BNF -> thm
76.62 - val rel_def_of_bnf: BNF -> thm
76.63 - val set_bd_of_bnf: BNF -> thm list
76.64 - val set_defs_of_bnf: BNF -> thm list
76.65 - val set_natural'_of_bnf: BNF -> thm list
76.66 - val set_natural_of_bnf: BNF -> thm list
76.67 - val sets_of_bnf: BNF -> term list
76.68 - val srel_def_of_bnf: BNF -> thm
76.69 - val srel_Gr_of_bnf: BNF -> thm
76.70 - val srel_Id_of_bnf: BNF -> thm
76.71 - val srel_O_of_bnf: BNF -> thm
76.72 - val srel_O_Gr_of_bnf: BNF -> thm
76.73 - val srel_cong_of_bnf: BNF -> thm
76.74 - val srel_converse_of_bnf: BNF -> thm
76.75 - val srel_mono_of_bnf: BNF -> thm
76.76 - val wit_thms_of_bnf: BNF -> thm list
76.77 - val wit_thmss_of_bnf: BNF -> thm list list
76.78 -
76.79 - val mk_witness: int list * term -> thm list -> nonemptiness_witness
76.80 - val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
76.81 - val wits_of_bnf: BNF -> nonemptiness_witness list
76.82 -
76.83 - val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list
76.84 -
76.85 - datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
76.86 - datatype fact_policy =
76.87 - Derive_Few_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms
76.88 - val bnf_note_all: bool Config.T
76.89 - val user_policy: fact_policy -> Proof.context -> fact_policy
76.90 -
76.91 - val print_bnfs: Proof.context -> unit
76.92 - val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
76.93 - ({prems: thm list, context: Proof.context} -> tactic) list ->
76.94 - ({prems: thm list, context: Proof.context} -> tactic) -> typ list option ->
76.95 - ((((binding * term) * term list) * term) * term list) * term option -> local_theory ->
76.96 - BNF * local_theory
76.97 -end;
76.98 -
76.99 -structure BNF_Def : BNF_DEF =
76.100 -struct
76.101 -
76.102 -open BNF_Util
76.103 -open BNF_Tactics
76.104 -open BNF_Def_Tactics
76.105 -
76.106 -type axioms = {
76.107 - map_id: thm,
76.108 - map_comp: thm,
76.109 - map_cong: thm,
76.110 - set_natural: thm list,
76.111 - bd_card_order: thm,
76.112 - bd_cinfinite: thm,
76.113 - set_bd: thm list,
76.114 - in_bd: thm,
76.115 - map_wpull: thm,
76.116 - srel_O_Gr: thm
76.117 -};
76.118 -
76.119 -fun mk_axioms' (((((((((id, comp), cong), nat), c_o), cinf), set_bd), in_bd), wpull), srel) =
76.120 - {map_id = id, map_comp = comp, map_cong = cong, set_natural = nat, bd_card_order = c_o,
76.121 - bd_cinfinite = cinf, set_bd = set_bd, in_bd = in_bd, map_wpull = wpull, srel_O_Gr = srel};
76.122 -
76.123 -fun dest_cons [] = raise Empty
76.124 - | dest_cons (x :: xs) = (x, xs);
76.125 -
76.126 -fun mk_axioms n thms = thms
76.127 - |> map the_single
76.128 - |> dest_cons
76.129 - ||>> dest_cons
76.130 - ||>> dest_cons
76.131 - ||>> chop n
76.132 - ||>> dest_cons
76.133 - ||>> dest_cons
76.134 - ||>> chop n
76.135 - ||>> dest_cons
76.136 - ||>> dest_cons
76.137 - ||> the_single
76.138 - |> mk_axioms';
76.139 -
76.140 -fun zip_axioms mid mcomp mcong snat bdco bdinf sbd inbd wpull srel =
76.141 - [mid, mcomp, mcong] @ snat @ [bdco, bdinf] @ sbd @ [inbd, wpull, srel];
76.142 -
76.143 -fun dest_axioms {map_id, map_comp, map_cong, set_natural, bd_card_order, bd_cinfinite, set_bd,
76.144 - in_bd, map_wpull, srel_O_Gr} =
76.145 - zip_axioms map_id map_comp map_cong set_natural bd_card_order bd_cinfinite set_bd in_bd map_wpull
76.146 - srel_O_Gr;
76.147 -
76.148 -fun map_axioms f {map_id, map_comp, map_cong, set_natural, bd_card_order, bd_cinfinite, set_bd,
76.149 - in_bd, map_wpull, srel_O_Gr} =
76.150 - {map_id = f map_id,
76.151 - map_comp = f map_comp,
76.152 - map_cong = f map_cong,
76.153 - set_natural = map f set_natural,
76.154 - bd_card_order = f bd_card_order,
76.155 - bd_cinfinite = f bd_cinfinite,
76.156 - set_bd = map f set_bd,
76.157 - in_bd = f in_bd,
76.158 - map_wpull = f map_wpull,
76.159 - srel_O_Gr = f srel_O_Gr};
76.160 -
76.161 -val morph_axioms = map_axioms o Morphism.thm;
76.162 -
76.163 -type defs = {
76.164 - map_def: thm,
76.165 - set_defs: thm list,
76.166 - rel_def: thm,
76.167 - srel_def: thm
76.168 -}
76.169 -
76.170 -fun mk_defs map sets rel srel = {map_def = map, set_defs = sets, rel_def = rel, srel_def = srel};
76.171 -
76.172 -fun map_defs f {map_def, set_defs, rel_def, srel_def} =
76.173 - {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def, srel_def = f srel_def};
76.174 -
76.175 -val morph_defs = map_defs o Morphism.thm;
76.176 -
76.177 -type facts = {
76.178 - bd_Card_order: thm,
76.179 - bd_Cinfinite: thm,
76.180 - bd_Cnotzero: thm,
76.181 - collect_set_natural: thm lazy,
76.182 - in_cong: thm lazy,
76.183 - in_mono: thm lazy,
76.184 - in_srel: thm lazy,
76.185 - map_comp': thm lazy,
76.186 - map_id': thm lazy,
76.187 - map_wppull: thm lazy,
76.188 - set_natural': thm lazy list,
76.189 - srel_cong: thm lazy,
76.190 - srel_mono: thm lazy,
76.191 - srel_Id: thm lazy,
76.192 - srel_Gr: thm lazy,
76.193 - srel_converse: thm lazy,
76.194 - srel_O: thm lazy
76.195 -};
76.196 -
76.197 -fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_natural in_cong in_mono in_srel
76.198 - map_comp' map_id' map_wppull set_natural' srel_cong srel_mono srel_Id srel_Gr srel_converse
76.199 - srel_O = {
76.200 - bd_Card_order = bd_Card_order,
76.201 - bd_Cinfinite = bd_Cinfinite,
76.202 - bd_Cnotzero = bd_Cnotzero,
76.203 - collect_set_natural = collect_set_natural,
76.204 - in_cong = in_cong,
76.205 - in_mono = in_mono,
76.206 - in_srel = in_srel,
76.207 - map_comp' = map_comp',
76.208 - map_id' = map_id',
76.209 - map_wppull = map_wppull,
76.210 - set_natural' = set_natural',
76.211 - srel_cong = srel_cong,
76.212 - srel_mono = srel_mono,
76.213 - srel_Id = srel_Id,
76.214 - srel_Gr = srel_Gr,
76.215 - srel_converse = srel_converse,
76.216 - srel_O = srel_O};
76.217 -
76.218 -fun map_facts f {
76.219 - bd_Card_order,
76.220 - bd_Cinfinite,
76.221 - bd_Cnotzero,
76.222 - collect_set_natural,
76.223 - in_cong,
76.224 - in_mono,
76.225 - in_srel,
76.226 - map_comp',
76.227 - map_id',
76.228 - map_wppull,
76.229 - set_natural',
76.230 - srel_cong,
76.231 - srel_mono,
76.232 - srel_Id,
76.233 - srel_Gr,
76.234 - srel_converse,
76.235 - srel_O} =
76.236 - {bd_Card_order = f bd_Card_order,
76.237 - bd_Cinfinite = f bd_Cinfinite,
76.238 - bd_Cnotzero = f bd_Cnotzero,
76.239 - collect_set_natural = Lazy.map f collect_set_natural,
76.240 - in_cong = Lazy.map f in_cong,
76.241 - in_mono = Lazy.map f in_mono,
76.242 - in_srel = Lazy.map f in_srel,
76.243 - map_comp' = Lazy.map f map_comp',
76.244 - map_id' = Lazy.map f map_id',
76.245 - map_wppull = Lazy.map f map_wppull,
76.246 - set_natural' = map (Lazy.map f) set_natural',
76.247 - srel_cong = Lazy.map f srel_cong,
76.248 - srel_mono = Lazy.map f srel_mono,
76.249 - srel_Id = Lazy.map f srel_Id,
76.250 - srel_Gr = Lazy.map f srel_Gr,
76.251 - srel_converse = Lazy.map f srel_converse,
76.252 - srel_O = Lazy.map f srel_O};
76.253 -
76.254 -val morph_facts = map_facts o Morphism.thm;
76.255 -
76.256 -type nonemptiness_witness = {
76.257 - I: int list,
76.258 - wit: term,
76.259 - prop: thm list
76.260 -};
76.261 -
76.262 -fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
76.263 -fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
76.264 -fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
76.265 -
76.266 -datatype BNF = BNF of {
76.267 - name: binding,
76.268 - T: typ,
76.269 - live: int,
76.270 - lives: typ list, (*source type variables of map, only for composition*)
76.271 - lives': typ list, (*target type variables of map, only for composition*)
76.272 - dead: int,
76.273 - deads: typ list, (*only for composition*)
76.274 - map: term,
76.275 - sets: term list,
76.276 - bd: term,
76.277 - axioms: axioms,
76.278 - defs: defs,
76.279 - facts: facts,
76.280 - nwits: int,
76.281 - wits: nonemptiness_witness list,
76.282 - rel: term,
76.283 - srel: term
76.284 -};
76.285 -
76.286 -(* getters *)
76.287 -
76.288 -fun rep_bnf (BNF bnf) = bnf;
76.289 -val name_of_bnf = #name o rep_bnf;
76.290 -val T_of_bnf = #T o rep_bnf;
76.291 -fun mk_T_of_bnf Ds Ts bnf =
76.292 - let val bnf_rep = rep_bnf bnf
76.293 - in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
76.294 -val live_of_bnf = #live o rep_bnf;
76.295 -val lives_of_bnf = #lives o rep_bnf;
76.296 -val dead_of_bnf = #dead o rep_bnf;
76.297 -val deads_of_bnf = #deads o rep_bnf;
76.298 -val axioms_of_bnf = #axioms o rep_bnf;
76.299 -val facts_of_bnf = #facts o rep_bnf;
76.300 -val nwits_of_bnf = #nwits o rep_bnf;
76.301 -val wits_of_bnf = #wits o rep_bnf;
76.302 -
76.303 -(*terms*)
76.304 -val map_of_bnf = #map o rep_bnf;
76.305 -val sets_of_bnf = #sets o rep_bnf;
76.306 -fun mk_map_of_bnf Ds Ts Us bnf =
76.307 - let val bnf_rep = rep_bnf bnf;
76.308 - in
76.309 - Term.subst_atomic_types
76.310 - ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
76.311 - end;
76.312 -fun mk_sets_of_bnf Dss Tss bnf =
76.313 - let val bnf_rep = rep_bnf bnf;
76.314 - in
76.315 - map2 (fn (Ds, Ts) => Term.subst_atomic_types
76.316 - ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
76.317 - end;
76.318 -val bd_of_bnf = #bd o rep_bnf;
76.319 -fun mk_bd_of_bnf Ds Ts bnf =
76.320 - let val bnf_rep = rep_bnf bnf;
76.321 - in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
76.322 -fun mk_wits_of_bnf Dss Tss bnf =
76.323 - let
76.324 - val bnf_rep = rep_bnf bnf;
76.325 - val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
76.326 - in
76.327 - map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
76.328 - ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
76.329 - end;
76.330 -val rel_of_bnf = #rel o rep_bnf;
76.331 -fun mk_rel_of_bnf Ds Ts Us bnf =
76.332 - let val bnf_rep = rep_bnf bnf;
76.333 - in
76.334 - Term.subst_atomic_types
76.335 - ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
76.336 - end;
76.337 -val srel_of_bnf = #srel o rep_bnf;
76.338 -fun mk_srel_of_bnf Ds Ts Us bnf =
76.339 - let val bnf_rep = rep_bnf bnf;
76.340 - in
76.341 - Term.subst_atomic_types
76.342 - ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#srel bnf_rep)
76.343 - end;
76.344 -
76.345 -(*thms*)
76.346 -val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
76.347 -val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
76.348 -val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
76.349 -val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
76.350 -val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
76.351 -val collect_set_natural_of_bnf = Lazy.force o #collect_set_natural o #facts o rep_bnf;
76.352 -val in_bd_of_bnf = #in_bd o #axioms o rep_bnf;
76.353 -val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
76.354 -val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
76.355 -val in_srel_of_bnf = Lazy.force o #in_srel o #facts o rep_bnf;
76.356 -val map_def_of_bnf = #map_def o #defs o rep_bnf;
76.357 -val map_id_of_bnf = #map_id o #axioms o rep_bnf;
76.358 -val map_id'_of_bnf = Lazy.force o #map_id' o #facts o rep_bnf;
76.359 -val map_comp_of_bnf = #map_comp o #axioms o rep_bnf;
76.360 -val map_comp'_of_bnf = Lazy.force o #map_comp' o #facts o rep_bnf;
76.361 -val map_cong_of_bnf = #map_cong o #axioms o rep_bnf;
76.362 -val map_wppull_of_bnf = Lazy.force o #map_wppull o #facts o rep_bnf;
76.363 -val map_wpull_of_bnf = #map_wpull o #axioms o rep_bnf;
76.364 -val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
76.365 -val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
76.366 -val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
76.367 -val set_natural_of_bnf = #set_natural o #axioms o rep_bnf;
76.368 -val set_natural'_of_bnf = map Lazy.force o #set_natural' o #facts o rep_bnf;
76.369 -val srel_cong_of_bnf = Lazy.force o #srel_cong o #facts o rep_bnf;
76.370 -val srel_mono_of_bnf = Lazy.force o #srel_mono o #facts o rep_bnf;
76.371 -val srel_def_of_bnf = #srel_def o #defs o rep_bnf;
76.372 -val srel_Id_of_bnf = Lazy.force o #srel_Id o #facts o rep_bnf;
76.373 -val srel_Gr_of_bnf = Lazy.force o #srel_Gr o #facts o rep_bnf;
76.374 -val srel_converse_of_bnf = Lazy.force o #srel_converse o #facts o rep_bnf;
76.375 -val srel_O_of_bnf = Lazy.force o #srel_O o #facts o rep_bnf;
76.376 -val srel_O_Gr_of_bnf = #srel_O_Gr o #axioms o rep_bnf;
76.377 -val wit_thms_of_bnf = maps #prop o wits_of_bnf;
76.378 -val wit_thmss_of_bnf = map #prop o wits_of_bnf;
76.379 -
76.380 -fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel srel =
76.381 - BNF {name = name, T = T,
76.382 - live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
76.383 - map = map, sets = sets, bd = bd,
76.384 - axioms = axioms, defs = defs, facts = facts,
76.385 - nwits = length wits, wits = wits, rel = rel, srel = srel};
76.386 -
76.387 -fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
76.388 - dead = dead, deads = deads, map = map, sets = sets, bd = bd,
76.389 - axioms = axioms, defs = defs, facts = facts,
76.390 - nwits = nwits, wits = wits, rel = rel, srel = srel}) =
76.391 - BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
76.392 - live = live, lives = List.map (Morphism.typ phi) lives,
76.393 - lives' = List.map (Morphism.typ phi) lives',
76.394 - dead = dead, deads = List.map (Morphism.typ phi) deads,
76.395 - map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
76.396 - bd = Morphism.term phi bd,
76.397 - axioms = morph_axioms phi axioms,
76.398 - defs = morph_defs phi defs,
76.399 - facts = morph_facts phi facts,
76.400 - nwits = nwits,
76.401 - wits = List.map (morph_witness phi) wits,
76.402 - rel = Morphism.term phi rel, srel = Morphism.term phi srel};
76.403 -
76.404 -fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
76.405 - BNF {T = T2, live = live2, dead = dead2, ...}) =
76.406 - Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
76.407 -
76.408 -structure Data = Generic_Data
76.409 -(
76.410 - type T = BNF Symtab.table;
76.411 - val empty = Symtab.empty;
76.412 - val extend = I;
76.413 - val merge = Symtab.merge eq_bnf;
76.414 -);
76.415 -
76.416 -val bnf_of = Symtab.lookup o Data.get o Context.Proof;
76.417 -
76.418 -
76.419 -
76.420 -(* Utilities *)
76.421 -
76.422 -fun normalize_set insts instA set =
76.423 - let
76.424 - val (T, T') = dest_funT (fastype_of set);
76.425 - val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
76.426 - val params = Term.add_tvar_namesT T [];
76.427 - in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
76.428 -
76.429 -fun normalize_rel ctxt instTs instA instB rel =
76.430 - let
76.431 - val thy = Proof_Context.theory_of ctxt;
76.432 - val tyenv =
76.433 - Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
76.434 - Vartab.empty;
76.435 - in Envir.subst_term (tyenv, Vartab.empty) rel end
76.436 - handle Type.TYPE_MATCH => error "Bad predicator";
76.437 -
76.438 -fun normalize_srel ctxt instTs instA instB srel =
76.439 - let
76.440 - val thy = Proof_Context.theory_of ctxt;
76.441 - val tyenv =
76.442 - Sign.typ_match thy (fastype_of srel, Library.foldr (op -->) (instTs, mk_relT (instA, instB)))
76.443 - Vartab.empty;
76.444 - in Envir.subst_term (tyenv, Vartab.empty) srel end
76.445 - handle Type.TYPE_MATCH => error "Bad relator";
76.446 -
76.447 -fun normalize_wit insts CA As wit =
76.448 - let
76.449 - fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
76.450 - if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
76.451 - | strip_param x = x;
76.452 - val (Ts, T) = strip_param ([], fastype_of wit);
76.453 - val subst = Term.add_tvar_namesT T [] ~~ insts;
76.454 - fun find y = find_index (fn x => x = y) As;
76.455 - in
76.456 - (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
76.457 - end;
76.458 -
76.459 -fun minimize_wits wits =
76.460 - let
76.461 - fun minimize done [] = done
76.462 - | minimize done ((I, wit) :: todo) =
76.463 - if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
76.464 - then minimize done todo
76.465 - else minimize ((I, wit) :: done) todo;
76.466 - in minimize [] wits end;
76.467 -
76.468 -
76.469 -
76.470 -(* Names *)
76.471 -
76.472 -val mapN = "map";
76.473 -val setN = "set";
76.474 -fun mk_setN i = setN ^ nonzero_string_of_int i;
76.475 -val bdN = "bd";
76.476 -val witN = "wit";
76.477 -fun mk_witN i = witN ^ nonzero_string_of_int i;
76.478 -val relN = "rel";
76.479 -val srelN = "srel";
76.480 -
76.481 -val bd_card_orderN = "bd_card_order";
76.482 -val bd_cinfiniteN = "bd_cinfinite";
76.483 -val bd_Card_orderN = "bd_Card_order";
76.484 -val bd_CinfiniteN = "bd_Cinfinite";
76.485 -val bd_CnotzeroN = "bd_Cnotzero";
76.486 -val collect_set_naturalN = "collect_set_natural";
76.487 -val in_bdN = "in_bd";
76.488 -val in_monoN = "in_mono";
76.489 -val in_srelN = "in_srel";
76.490 -val map_idN = "map_id";
76.491 -val map_id'N = "map_id'";
76.492 -val map_compN = "map_comp";
76.493 -val map_comp'N = "map_comp'";
76.494 -val map_congN = "map_cong";
76.495 -val map_wpullN = "map_wpull";
76.496 -val srel_IdN = "srel_Id";
76.497 -val srel_GrN = "srel_Gr";
76.498 -val srel_converseN = "srel_converse";
76.499 -val srel_monoN = "srel_mono"
76.500 -val srel_ON = "srel_comp";
76.501 -val srel_O_GrN = "srel_comp_Gr";
76.502 -val set_naturalN = "set_natural";
76.503 -val set_natural'N = "set_natural'";
76.504 -val set_bdN = "set_bd";
76.505 -
76.506 -datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
76.507 -
76.508 -datatype fact_policy =
76.509 - Derive_Few_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms;
76.510 -
76.511 -val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
76.512 -
76.513 -fun user_policy policy ctxt =
76.514 - if Config.get ctxt bnf_note_all then Note_All_Facts_and_Axioms else policy;
76.515 -
76.516 -val smart_max_inline_size = 25; (*FUDGE*)
76.517 -
76.518 -
76.519 -(* Define new BNFs *)
76.520 -
76.521 -fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt
76.522 - (((((raw_b, raw_map), raw_sets), raw_bd_Abs), raw_wits), raw_rel_opt) no_defs_lthy =
76.523 - let
76.524 - val fact_policy = mk_fact_policy no_defs_lthy;
76.525 - val b = qualify raw_b;
76.526 - val live = length raw_sets;
76.527 - val nwits = length raw_wits;
76.528 -
76.529 - val map_rhs = prep_term no_defs_lthy raw_map;
76.530 - val set_rhss = map (prep_term no_defs_lthy) raw_sets;
76.531 - val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
76.532 - Abs (_, T, t) => (T, t)
76.533 - | _ => error "Bad bound constant");
76.534 - val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
76.535 -
76.536 - fun err T =
76.537 - error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
76.538 - " as unnamed BNF");
76.539 -
76.540 - val (b, key) =
76.541 - if Binding.eq_name (b, Binding.empty) then
76.542 - (case bd_rhsT of
76.543 - Type (C, Ts) => if forall (is_some o try dest_TFree) Ts
76.544 - then (Binding.qualified_name C, C) else err bd_rhsT
76.545 - | T => err T)
76.546 - else (b, Local_Theory.full_name no_defs_lthy b);
76.547 -
76.548 - fun maybe_define user_specified (b, rhs) lthy =
76.549 - let
76.550 - val inline =
76.551 - (user_specified orelse fact_policy = Derive_Few_Facts) andalso
76.552 - (case const_policy of
76.553 - Dont_Inline => false
76.554 - | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
76.555 - | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
76.556 - | Do_Inline => true)
76.557 - in
76.558 - if inline then
76.559 - ((rhs, Drule.reflexive_thm), lthy)
76.560 - else
76.561 - let val b = b () in
76.562 - apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
76.563 - lthy)
76.564 - end
76.565 - end;
76.566 -
76.567 - fun maybe_restore lthy_old lthy =
76.568 - lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
76.569 -
76.570 - val map_bind_def = (fn () => Binding.suffix_name ("_" ^ mapN) b, map_rhs);
76.571 - val set_binds_defs =
76.572 - let
76.573 - val bs = if live = 1 then [fn () => Binding.suffix_name ("_" ^ setN) b]
76.574 - else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_setN i) b) (1 upto live)
76.575 - in map2 pair bs set_rhss end;
76.576 - val bd_bind_def = (fn () => Binding.suffix_name ("_" ^ bdN) b, bd_rhs);
76.577 - val wit_binds_defs =
76.578 - let
76.579 - val bs = if nwits = 1 then [fn () => Binding.suffix_name ("_" ^ witN) b]
76.580 - else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_witN i) b) (1 upto nwits);
76.581 - in map2 pair bs wit_rhss end;
76.582 -
76.583 - val (((((bnf_map_term, raw_map_def),
76.584 - (bnf_set_terms, raw_set_defs)),
76.585 - (bnf_bd_term, raw_bd_def)),
76.586 - (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
76.587 - no_defs_lthy
76.588 - |> maybe_define true map_bind_def
76.589 - ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
76.590 - ||>> maybe_define true bd_bind_def
76.591 - ||>> apfst split_list o fold_map (maybe_define true) wit_binds_defs
76.592 - ||> `(maybe_restore no_defs_lthy);
76.593 -
76.594 - val phi = Proof_Context.export_morphism lthy_old lthy;
76.595 -
76.596 - val bnf_map_def = Morphism.thm phi raw_map_def;
76.597 - val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
76.598 - val bnf_bd_def = Morphism.thm phi raw_bd_def;
76.599 - val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
76.600 -
76.601 - val bnf_map = Morphism.term phi bnf_map_term;
76.602 -
76.603 - (*TODO: handle errors*)
76.604 - (*simple shape analysis of a map function*)
76.605 - val ((alphas, betas), (CA, _)) =
76.606 - fastype_of bnf_map
76.607 - |> strip_typeN live
76.608 - |>> map_split dest_funT
76.609 - ||> dest_funT
76.610 - handle TYPE _ => error "Bad map function";
76.611 -
76.612 - val CA_params = map TVar (Term.add_tvarsT CA []);
76.613 -
76.614 - val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
76.615 - val bdT = Morphism.typ phi bd_rhsT;
76.616 - val bnf_bd =
76.617 - Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
76.618 - val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
76.619 -
76.620 - (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
76.621 - val deads = (case Ds_opt of
76.622 - NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
76.623 - | SOME Ds => map (Morphism.typ phi) Ds);
76.624 - val dead = length deads;
76.625 -
76.626 - (*TODO: further checks of type of bnf_map*)
76.627 - (*TODO: check types of bnf_sets*)
76.628 - (*TODO: check type of bnf_bd*)
76.629 - (*TODO: check type of bnf_rel*)
76.630 -
76.631 - val ((((((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), domTs), ranTs), ranTs'), ranTs''),
76.632 - (Ts, T)) = lthy
76.633 - |> mk_TFrees live
76.634 - ||>> mk_TFrees live
76.635 - ||>> mk_TFrees live
76.636 - ||>> mk_TFrees dead
76.637 - ||>> mk_TFrees live
76.638 - ||>> mk_TFrees live
76.639 - ||>> mk_TFrees live
76.640 - ||>> mk_TFrees live
76.641 - ||>> mk_TFrees live
76.642 - ||>> mk_TFrees live
76.643 - ||> fst o mk_TFrees 1
76.644 - ||> the_single
76.645 - ||> `(replicate live);
76.646 -
76.647 - fun mk_bnf_map As' Bs' =
76.648 - Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
76.649 - fun mk_bnf_t As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
76.650 - fun mk_bnf_T As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
76.651 -
76.652 - val (setRTs, RTs) = map_split (`HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Bs');
76.653 - val setRTsAsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Cs);
76.654 - val setRTsBsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ Cs);
76.655 - val setRT's = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ As');
76.656 - val self_setRTs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ As');
76.657 - val QTs = map2 mk_pred2T As' Bs';
76.658 -
76.659 - val CA' = mk_bnf_T As' CA;
76.660 - val CB' = mk_bnf_T Bs' CA;
76.661 - val CC' = mk_bnf_T Cs CA;
76.662 - val CRs' = mk_bnf_T RTs CA;
76.663 - val CA'CB' = HOLogic.mk_prodT (CA', CB');
76.664 -
76.665 - val bnf_map_AsAs = mk_bnf_map As' As';
76.666 - val bnf_map_AsBs = mk_bnf_map As' Bs';
76.667 - val bnf_map_AsCs = mk_bnf_map As' Cs;
76.668 - val bnf_map_BsCs = mk_bnf_map Bs' Cs;
76.669 - val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
76.670 - val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
76.671 - val bnf_bd_As = mk_bnf_t As' bnf_bd;
76.672 - val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
76.673 -
76.674 - val (((((((((((((((((((((((((fs, fs_copy), gs), hs), p), (x, x')), (y, y')), (z, z')), zs), As),
76.675 - As_copy), Xs), B1s), B2s), f1s), f2s), e1s), e2s), p1s), p2s), bs), (Rs, Rs')), Rs_copy), Ss),
76.676 - (Qs, Qs')), _) = lthy
76.677 - |> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
76.678 - ||>> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
76.679 - ||>> mk_Frees "g" (map2 (curry (op -->)) Bs' Cs)
76.680 - ||>> mk_Frees "h" (map2 (curry (op -->)) As' Ts)
76.681 - ||>> yield_singleton (mk_Frees "p") CA'CB'
76.682 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "x") CA'
76.683 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "y") CB'
76.684 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "z") CRs'
76.685 - ||>> mk_Frees "z" As'
76.686 - ||>> mk_Frees "A" (map HOLogic.mk_setT As')
76.687 - ||>> mk_Frees "A" (map HOLogic.mk_setT As')
76.688 - ||>> mk_Frees "A" (map HOLogic.mk_setT domTs)
76.689 - ||>> mk_Frees "B1" (map HOLogic.mk_setT B1Ts)
76.690 - ||>> mk_Frees "B2" (map HOLogic.mk_setT B2Ts)
76.691 - ||>> mk_Frees "f1" (map2 (curry (op -->)) B1Ts ranTs)
76.692 - ||>> mk_Frees "f2" (map2 (curry (op -->)) B2Ts ranTs)
76.693 - ||>> mk_Frees "e1" (map2 (curry (op -->)) B1Ts ranTs')
76.694 - ||>> mk_Frees "e2" (map2 (curry (op -->)) B2Ts ranTs'')
76.695 - ||>> mk_Frees "p1" (map2 (curry (op -->)) domTs B1Ts)
76.696 - ||>> mk_Frees "p2" (map2 (curry (op -->)) domTs B2Ts)
76.697 - ||>> mk_Frees "b" As'
76.698 - ||>> mk_Frees' "R" setRTs
76.699 - ||>> mk_Frees "R" setRTs
76.700 - ||>> mk_Frees "S" setRTsBsCs
76.701 - ||>> mk_Frees' "Q" QTs;
76.702 -
76.703 - (*Gr (in R1 .. Rn) (map fst .. fst)^-1 O Gr (in R1 .. Rn) (map snd .. snd)*)
76.704 - val O_Gr =
76.705 - let
76.706 - val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
76.707 - val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
76.708 - val bnf_in = mk_in (map Free Rs') (map (mk_bnf_t RTs) bnf_sets) CRs';
76.709 - in
76.710 - mk_rel_comp (mk_converse (mk_Gr bnf_in map1), mk_Gr bnf_in map2)
76.711 - end;
76.712 -
76.713 - fun mk_predicate_of_set x_name y_name t =
76.714 - let
76.715 - val (T, U) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of t));
76.716 - val x = Free (x_name, T);
76.717 - val y = Free (y_name, U);
76.718 - in fold_rev Term.lambda [x, y] (HOLogic.mk_mem (HOLogic.mk_prod (x, y), t)) end;
76.719 -
76.720 - val rel_rhs = (case raw_rel_opt of
76.721 - NONE =>
76.722 - fold_rev absfree Qs' (mk_predicate_of_set (fst x') (fst y')
76.723 - (Term.list_comb (fold_rev Term.absfree Rs' O_Gr, map3 (fn Q => fn T => fn U =>
76.724 - HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split Q) Qs As' Bs')))
76.725 - | SOME raw_rel => prep_term no_defs_lthy raw_rel);
76.726 -
76.727 - val rel_bind_def = (fn () => Binding.suffix_name ("_" ^ relN) b, rel_rhs);
76.728 -
76.729 - val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
76.730 - lthy
76.731 - |> maybe_define (is_some raw_rel_opt) rel_bind_def
76.732 - ||> `(maybe_restore lthy);
76.733 -
76.734 - val phi = Proof_Context.export_morphism lthy_old lthy;
76.735 - val bnf_rel_def = Morphism.thm phi raw_rel_def;
76.736 - val bnf_rel = Morphism.term phi bnf_rel_term;
76.737 -
76.738 - fun mk_bnf_rel QTs CA' CB' = normalize_rel lthy QTs CA' CB' bnf_rel;
76.739 -
76.740 - val rel = mk_bnf_rel QTs CA' CB';
76.741 -
76.742 - val srel_rhs =
76.743 - fold_rev Term.absfree Rs' (HOLogic.Collect_const CA'CB' $
76.744 - Term.lambda p (Term.list_comb (rel, map (mk_predicate_of_set (fst x') (fst y')) Rs) $
76.745 - HOLogic.mk_fst p $ HOLogic.mk_snd p));
76.746 -
76.747 - val srel_bind_def = (fn () => Binding.suffix_name ("_" ^ srelN) b, srel_rhs);
76.748 -
76.749 - val ((bnf_srel_term, raw_srel_def), (lthy, lthy_old)) =
76.750 - lthy
76.751 - |> maybe_define false srel_bind_def
76.752 - ||> `(maybe_restore lthy);
76.753 -
76.754 - val phi = Proof_Context.export_morphism lthy_old lthy;
76.755 - val bnf_srel_def = Morphism.thm phi raw_srel_def;
76.756 - val bnf_srel = Morphism.term phi bnf_srel_term;
76.757 -
76.758 - fun mk_bnf_srel setRTs CA' CB' = normalize_srel lthy setRTs CA' CB' bnf_srel;
76.759 -
76.760 - val srel = mk_bnf_srel setRTs CA' CB';
76.761 -
76.762 - val _ = case no_reflexive (raw_map_def :: raw_set_defs @ [raw_bd_def] @
76.763 - raw_wit_defs @ [raw_rel_def, raw_srel_def]) of
76.764 - [] => ()
76.765 - | defs => Proof_Display.print_consts true lthy_old (K false)
76.766 - (map (dest_Free o fst o Logic.dest_equals o prop_of) defs);
76.767 -
76.768 - val map_id_goal =
76.769 - let
76.770 - val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As');
76.771 - in
76.772 - HOLogic.mk_Trueprop
76.773 - (HOLogic.mk_eq (bnf_map_app_id, HOLogic.id_const CA'))
76.774 - end;
76.775 -
76.776 - val map_comp_goal =
76.777 - let
76.778 - val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
76.779 - val comp_bnf_map_app = HOLogic.mk_comp
76.780 - (Term.list_comb (bnf_map_BsCs, gs),
76.781 - Term.list_comb (bnf_map_AsBs, fs));
76.782 - in
76.783 - fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
76.784 - end;
76.785 -
76.786 - val map_cong_goal =
76.787 - let
76.788 - fun mk_prem z set f f_copy =
76.789 - Logic.all z (Logic.mk_implies
76.790 - (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
76.791 - mk_Trueprop_eq (f $ z, f_copy $ z)));
76.792 - val prems = map4 mk_prem zs bnf_sets_As fs fs_copy;
76.793 - val eq = HOLogic.mk_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
76.794 - Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
76.795 - in
76.796 - fold_rev Logic.all (x :: fs @ fs_copy)
76.797 - (Logic.list_implies (prems, HOLogic.mk_Trueprop eq))
76.798 - end;
76.799 -
76.800 - val set_naturals_goal =
76.801 - let
76.802 - fun mk_goal setA setB f =
76.803 - let
76.804 - val set_comp_map =
76.805 - HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
76.806 - val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
76.807 - in
76.808 - fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
76.809 - end;
76.810 - in
76.811 - map3 mk_goal bnf_sets_As bnf_sets_Bs fs
76.812 - end;
76.813 -
76.814 - val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
76.815 -
76.816 - val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
76.817 -
76.818 - val set_bds_goal =
76.819 - let
76.820 - fun mk_goal set =
76.821 - Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
76.822 - in
76.823 - map mk_goal bnf_sets_As
76.824 - end;
76.825 -
76.826 - val in_bd_goal =
76.827 - let
76.828 - val bd = mk_cexp
76.829 - (if live = 0 then ctwo
76.830 - else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
76.831 - bnf_bd_As;
76.832 - in
76.833 - fold_rev Logic.all As
76.834 - (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd))
76.835 - end;
76.836 -
76.837 - val map_wpull_goal =
76.838 - let
76.839 - val prems = map HOLogic.mk_Trueprop
76.840 - (map8 mk_wpull Xs B1s B2s f1s f2s (replicate live NONE) p1s p2s);
76.841 - val CX = mk_bnf_T domTs CA;
76.842 - val CB1 = mk_bnf_T B1Ts CA;
76.843 - val CB2 = mk_bnf_T B2Ts CA;
76.844 - val bnf_sets_CX = map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
76.845 - val bnf_sets_CB1 = map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
76.846 - val bnf_sets_CB2 = map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
76.847 - val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
76.848 - val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
76.849 - val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
76.850 - val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
76.851 -
76.852 - val map_wpull = mk_wpull (mk_in Xs bnf_sets_CX CX)
76.853 - (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
76.854 - bnf_map_app_f1 bnf_map_app_f2 NONE bnf_map_app_p1 bnf_map_app_p2;
76.855 - in
76.856 - fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
76.857 - (Logic.list_implies (prems, HOLogic.mk_Trueprop map_wpull))
76.858 - end;
76.859 -
76.860 - val srel_O_Gr_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (srel, Rs), O_Gr));
76.861 -
76.862 - val goals = zip_axioms map_id_goal map_comp_goal map_cong_goal set_naturals_goal
76.863 - card_order_bd_goal cinfinite_bd_goal set_bds_goal in_bd_goal map_wpull_goal srel_O_Gr_goal;
76.864 -
76.865 - fun mk_wit_goals (I, wit) =
76.866 - let
76.867 - val xs = map (nth bs) I;
76.868 - fun wit_goal i =
76.869 - let
76.870 - val z = nth zs i;
76.871 - val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
76.872 - val concl = HOLogic.mk_Trueprop
76.873 - (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
76.874 - else @{term False});
76.875 - in
76.876 - fold_rev Logic.all (z :: xs)
76.877 - (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
76.878 - end;
76.879 - in
76.880 - map wit_goal (0 upto live - 1)
76.881 - end;
76.882 -
76.883 - val wit_goalss = map mk_wit_goals bnf_wit_As;
76.884 -
76.885 - fun after_qed thms lthy =
76.886 - let
76.887 - val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
76.888 -
76.889 - val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
76.890 - val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
76.891 - val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
76.892 -
76.893 - fun mk_lazy f = if fact_policy <> Derive_Few_Facts then Lazy.value (f ()) else Lazy.lazy f;
76.894 -
76.895 - fun mk_collect_set_natural () =
76.896 - let
76.897 - val defT = mk_bnf_T Ts CA --> HOLogic.mk_setT T;
76.898 - val collect_map = HOLogic.mk_comp
76.899 - (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
76.900 - Term.list_comb (mk_bnf_map As' Ts, hs));
76.901 - val image_collect = mk_collect
76.902 - (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
76.903 - defT;
76.904 - (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
76.905 - val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
76.906 - in
76.907 - Skip_Proof.prove lthy [] [] goal
76.908 - (fn {context = ctxt, ...} => mk_collect_set_natural_tac ctxt (#set_natural axioms))
76.909 - |> Thm.close_derivation
76.910 - end;
76.911 -
76.912 - val collect_set_natural = mk_lazy mk_collect_set_natural;
76.913 -
76.914 - fun mk_in_mono () =
76.915 - let
76.916 - val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_subset) As As_copy;
76.917 - val in_mono_goal =
76.918 - fold_rev Logic.all (As @ As_copy)
76.919 - (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
76.920 - (mk_subset (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
76.921 - in
76.922 - Skip_Proof.prove lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
76.923 - |> Thm.close_derivation
76.924 - end;
76.925 -
76.926 - val in_mono = mk_lazy mk_in_mono;
76.927 -
76.928 - fun mk_in_cong () =
76.929 - let
76.930 - val prems_cong = map2 (HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) As As_copy;
76.931 - val in_cong_goal =
76.932 - fold_rev Logic.all (As @ As_copy)
76.933 - (Logic.list_implies (prems_cong, HOLogic.mk_Trueprop
76.934 - (HOLogic.mk_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA'))));
76.935 - in
76.936 - Skip_Proof.prove lthy [] [] in_cong_goal (K ((TRY o hyp_subst_tac THEN' rtac refl) 1))
76.937 - |> Thm.close_derivation
76.938 - end;
76.939 -
76.940 - val in_cong = mk_lazy mk_in_cong;
76.941 -
76.942 - val map_id' = mk_lazy (fn () => mk_id' (#map_id axioms));
76.943 - val map_comp' = mk_lazy (fn () => mk_comp' (#map_comp axioms));
76.944 -
76.945 - val set_natural' =
76.946 - map (fn thm => mk_lazy (fn () => mk_set_natural' thm)) (#set_natural axioms);
76.947 -
76.948 - fun mk_map_wppull () =
76.949 - let
76.950 - val prems = if live = 0 then [] else
76.951 - [HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
76.952 - (map8 mk_wpull Xs B1s B2s f1s f2s (map SOME (e1s ~~ e2s)) p1s p2s))];
76.953 - val CX = mk_bnf_T domTs CA;
76.954 - val CB1 = mk_bnf_T B1Ts CA;
76.955 - val CB2 = mk_bnf_T B2Ts CA;
76.956 - val bnf_sets_CX =
76.957 - map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
76.958 - val bnf_sets_CB1 =
76.959 - map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
76.960 - val bnf_sets_CB2 =
76.961 - map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
76.962 - val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
76.963 - val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
76.964 - val bnf_map_app_e1 = Term.list_comb (mk_bnf_map B1Ts ranTs', e1s);
76.965 - val bnf_map_app_e2 = Term.list_comb (mk_bnf_map B2Ts ranTs'', e2s);
76.966 - val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
76.967 - val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
76.968 -
76.969 - val concl = mk_wpull (mk_in Xs bnf_sets_CX CX)
76.970 - (mk_in B1s bnf_sets_CB1 CB1) (mk_in B2s bnf_sets_CB2 CB2)
76.971 - bnf_map_app_f1 bnf_map_app_f2 (SOME (bnf_map_app_e1, bnf_map_app_e2))
76.972 - bnf_map_app_p1 bnf_map_app_p2;
76.973 -
76.974 - val goal =
76.975 - fold_rev Logic.all (Xs @ B1s @ B2s @ f1s @ f2s @ e1s @ e2s @ p1s @ p2s)
76.976 - (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))
76.977 - in
76.978 - Skip_Proof.prove lthy [] [] goal
76.979 - (fn _ => mk_map_wppull_tac (#map_id axioms) (#map_cong axioms)
76.980 - (#map_wpull axioms) (Lazy.force map_comp') (map Lazy.force set_natural'))
76.981 - |> Thm.close_derivation
76.982 - end;
76.983 -
76.984 - val srel_O_Grs = no_refl [#srel_O_Gr axioms];
76.985 -
76.986 - val map_wppull = mk_lazy mk_map_wppull;
76.987 -
76.988 - fun mk_srel_Gr () =
76.989 - let
76.990 - val lhs = Term.list_comb (srel, map2 mk_Gr As fs);
76.991 - val rhs = mk_Gr (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
76.992 - val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
76.993 - in
76.994 - Skip_Proof.prove lthy [] [] goal
76.995 - (mk_srel_Gr_tac srel_O_Grs (#map_id axioms) (#map_cong axioms) (Lazy.force map_id')
76.996 - (Lazy.force map_comp') (map Lazy.force set_natural'))
76.997 - |> Thm.close_derivation
76.998 - end;
76.999 -
76.1000 - val srel_Gr = mk_lazy mk_srel_Gr;
76.1001 -
76.1002 - fun mk_srel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
76.1003 - fun mk_srel_concl f = HOLogic.mk_Trueprop
76.1004 - (f (Term.list_comb (srel, Rs), Term.list_comb (srel, Rs_copy)));
76.1005 -
76.1006 - fun mk_srel_mono () =
76.1007 - let
76.1008 - val mono_prems = mk_srel_prems mk_subset;
76.1009 - val mono_concl = mk_srel_concl (uncurry mk_subset);
76.1010 - in
76.1011 - Skip_Proof.prove lthy [] []
76.1012 - (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
76.1013 - (mk_srel_mono_tac srel_O_Grs (Lazy.force in_mono))
76.1014 - |> Thm.close_derivation
76.1015 - end;
76.1016 -
76.1017 - fun mk_srel_cong () =
76.1018 - let
76.1019 - val cong_prems = mk_srel_prems (curry HOLogic.mk_eq);
76.1020 - val cong_concl = mk_srel_concl HOLogic.mk_eq;
76.1021 - in
76.1022 - Skip_Proof.prove lthy [] []
76.1023 - (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
76.1024 - (fn _ => (TRY o hyp_subst_tac THEN' rtac refl) 1)
76.1025 - |> Thm.close_derivation
76.1026 - end;
76.1027 -
76.1028 - val srel_mono = mk_lazy mk_srel_mono;
76.1029 - val srel_cong = mk_lazy mk_srel_cong;
76.1030 -
76.1031 - fun mk_srel_Id () =
76.1032 - let val relAsAs = mk_bnf_srel self_setRTs CA' CA' in
76.1033 - Skip_Proof.prove lthy [] []
76.1034 - (HOLogic.mk_Trueprop
76.1035 - (HOLogic.mk_eq (Term.list_comb (relAsAs, map Id_const As'), Id_const CA')))
76.1036 - (mk_srel_Id_tac live (Lazy.force srel_Gr) (#map_id axioms))
76.1037 - |> Thm.close_derivation
76.1038 - end;
76.1039 -
76.1040 - val srel_Id = mk_lazy mk_srel_Id;
76.1041 -
76.1042 - fun mk_srel_converse () =
76.1043 - let
76.1044 - val relBsAs = mk_bnf_srel setRT's CB' CA';
76.1045 - val lhs = Term.list_comb (relBsAs, map mk_converse Rs);
76.1046 - val rhs = mk_converse (Term.list_comb (srel, Rs));
76.1047 - val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_subset lhs rhs));
76.1048 - val le_thm = Skip_Proof.prove lthy [] [] le_goal
76.1049 - (mk_srel_converse_le_tac srel_O_Grs (Lazy.force srel_Id) (#map_cong axioms)
76.1050 - (Lazy.force map_comp') (map Lazy.force set_natural'))
76.1051 - |> Thm.close_derivation
76.1052 - val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
76.1053 - in
76.1054 - Skip_Proof.prove lthy [] [] goal (fn _ => mk_srel_converse_tac le_thm)
76.1055 - |> Thm.close_derivation
76.1056 - end;
76.1057 -
76.1058 - val srel_converse = mk_lazy mk_srel_converse;
76.1059 -
76.1060 - fun mk_srel_O () =
76.1061 - let
76.1062 - val relAsCs = mk_bnf_srel setRTsAsCs CA' CC';
76.1063 - val relBsCs = mk_bnf_srel setRTsBsCs CB' CC';
76.1064 - val lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_comp) Rs Ss);
76.1065 - val rhs = mk_rel_comp (Term.list_comb (srel, Rs), Term.list_comb (relBsCs, Ss));
76.1066 - val goal = fold_rev Logic.all (Rs @ Ss) (mk_Trueprop_eq (lhs, rhs));
76.1067 - in
76.1068 - Skip_Proof.prove lthy [] [] goal
76.1069 - (mk_srel_O_tac srel_O_Grs (Lazy.force srel_Id) (#map_cong axioms)
76.1070 - (Lazy.force map_wppull) (Lazy.force map_comp') (map Lazy.force set_natural'))
76.1071 - |> Thm.close_derivation
76.1072 - end;
76.1073 -
76.1074 - val srel_O = mk_lazy mk_srel_O;
76.1075 -
76.1076 - fun mk_in_srel () =
76.1077 - let
76.1078 - val bnf_in = mk_in Rs (map (mk_bnf_t RTs) bnf_sets) CRs';
76.1079 - val map1 = Term.list_comb (mk_bnf_map RTs As', map fst_const RTs);
76.1080 - val map2 = Term.list_comb (mk_bnf_map RTs Bs', map snd_const RTs);
76.1081 - val map_fst_eq = HOLogic.mk_eq (map1 $ z, x);
76.1082 - val map_snd_eq = HOLogic.mk_eq (map2 $ z, y);
76.1083 - val lhs = HOLogic.mk_mem (HOLogic.mk_prod (x, y), Term.list_comb (srel, Rs));
76.1084 - val rhs =
76.1085 - HOLogic.mk_exists (fst z', snd z', HOLogic.mk_conj (HOLogic.mk_mem (z, bnf_in),
76.1086 - HOLogic.mk_conj (map_fst_eq, map_snd_eq)));
76.1087 - val goal =
76.1088 - fold_rev Logic.all (x :: y :: Rs) (mk_Trueprop_eq (lhs, rhs));
76.1089 - in
76.1090 - Skip_Proof.prove lthy [] [] goal (mk_in_srel_tac srel_O_Grs (length bnf_sets))
76.1091 - |> Thm.close_derivation
76.1092 - end;
76.1093 -
76.1094 - val in_srel = mk_lazy mk_in_srel;
76.1095 -
76.1096 - val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_srel_def;
76.1097 -
76.1098 - val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_natural in_cong
76.1099 - in_mono in_srel map_comp' map_id' map_wppull set_natural' srel_cong srel_mono srel_Id
76.1100 - srel_Gr srel_converse srel_O;
76.1101 -
76.1102 - val wits = map2 mk_witness bnf_wits wit_thms;
76.1103 -
76.1104 - val bnf_rel =
76.1105 - Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
76.1106 - val bnf_srel =
76.1107 - Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) srel;
76.1108 -
76.1109 - val bnf = mk_bnf b CA live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms defs facts
76.1110 - wits bnf_rel bnf_srel;
76.1111 - in
76.1112 - (bnf, lthy
76.1113 - |> (if fact_policy = Note_All_Facts_and_Axioms then
76.1114 - let
76.1115 - val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
76.1116 - val notes =
76.1117 - [(bd_card_orderN, [#bd_card_order axioms]),
76.1118 - (bd_cinfiniteN, [#bd_cinfinite axioms]),
76.1119 - (bd_Card_orderN, [#bd_Card_order facts]),
76.1120 - (bd_CinfiniteN, [#bd_Cinfinite facts]),
76.1121 - (bd_CnotzeroN, [#bd_Cnotzero facts]),
76.1122 - (collect_set_naturalN, [Lazy.force (#collect_set_natural facts)]),
76.1123 - (in_bdN, [#in_bd axioms]),
76.1124 - (in_monoN, [Lazy.force (#in_mono facts)]),
76.1125 - (in_srelN, [Lazy.force (#in_srel facts)]),
76.1126 - (map_compN, [#map_comp axioms]),
76.1127 - (map_idN, [#map_id axioms]),
76.1128 - (map_wpullN, [#map_wpull axioms]),
76.1129 - (set_naturalN, #set_natural axioms),
76.1130 - (set_bdN, #set_bd axioms)] @
76.1131 - map2 pair witNs wit_thms
76.1132 - |> map (fn (thmN, thms) =>
76.1133 - ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
76.1134 - [(thms, [])]));
76.1135 - in
76.1136 - Local_Theory.notes notes #> snd
76.1137 - end
76.1138 - else
76.1139 - I)
76.1140 - |> (if fact_policy = Note_All_Facts_and_Axioms orelse
76.1141 - fact_policy = Derive_All_Facts_Note_Most then
76.1142 - let
76.1143 - val notes =
76.1144 - [(map_comp'N, [Lazy.force (#map_comp' facts)]),
76.1145 - (map_congN, [#map_cong axioms]),
76.1146 - (map_id'N, [Lazy.force (#map_id' facts)]),
76.1147 - (set_natural'N, map Lazy.force (#set_natural' facts)),
76.1148 - (srel_O_GrN, srel_O_Grs),
76.1149 - (srel_IdN, [Lazy.force (#srel_Id facts)]),
76.1150 - (srel_GrN, [Lazy.force (#srel_Gr facts)]),
76.1151 - (srel_converseN, [Lazy.force (#srel_converse facts)]),
76.1152 - (srel_monoN, [Lazy.force (#srel_mono facts)]),
76.1153 - (srel_ON, [Lazy.force (#srel_O facts)])]
76.1154 - |> filter_out (null o #2)
76.1155 - |> map (fn (thmN, thms) =>
76.1156 - ((qualify (Binding.qualify true (Binding.name_of b) (Binding.name thmN)), []),
76.1157 - [(thms, [])]));
76.1158 - in
76.1159 - Local_Theory.notes notes #> snd
76.1160 - end
76.1161 - else
76.1162 - I))
76.1163 - end;
76.1164 -
76.1165 - val one_step_defs =
76.1166 - no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def,
76.1167 - bnf_srel_def]);
76.1168 - in
76.1169 - (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
76.1170 - end;
76.1171 -
76.1172 -fun register_bnf key (bnf, lthy) =
76.1173 - (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
76.1174 - (fn phi => Data.map (Symtab.update_new (key, morph_bnf phi bnf))) lthy);
76.1175 -
76.1176 -(* TODO: Once the invariant "nwits > 0" holds, remove "mk_conjunction_balanced'" and "rtac TrueI"
76.1177 - below *)
76.1178 -fun mk_conjunction_balanced' [] = @{prop True}
76.1179 - | mk_conjunction_balanced' ts = Logic.mk_conjunction_balanced ts;
76.1180 -
76.1181 -fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds =
76.1182 - (fn (_, goals, wit_goalss, after_qed, lthy, one_step_defs) =>
76.1183 - let
76.1184 - val wits_tac =
76.1185 - K (TRYALL Goal.conjunction_tac) THEN' K (TRYALL (rtac TrueI)) THEN'
76.1186 - mk_unfold_thms_then_tac lthy one_step_defs wit_tac;
76.1187 - val wit_goals = map mk_conjunction_balanced' wit_goalss;
76.1188 - val wit_thms =
76.1189 - Skip_Proof.prove lthy [] [] (mk_conjunction_balanced' wit_goals) wits_tac
76.1190 - |> Conjunction.elim_balanced (length wit_goals)
76.1191 - |> map2 (Conjunction.elim_balanced o length) wit_goalss
76.1192 - |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
76.1193 - in
76.1194 - map2 (Thm.close_derivation oo Skip_Proof.prove lthy [] [])
76.1195 - goals (map (mk_unfold_thms_then_tac lthy one_step_defs) tacs)
76.1196 - |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
76.1197 - end) oo prepare_def const_policy fact_policy qualify (K I) Ds;
76.1198 -
76.1199 -val bnf_def_cmd = (fn (key, goals, wit_goals, after_qed, lthy, defs) =>
76.1200 - Proof.unfolding ([[(defs, [])]])
76.1201 - (Proof.theorem NONE (snd o register_bnf key oo after_qed)
76.1202 - (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
76.1203 - prepare_def Do_Inline (user_policy Derive_All_Facts_Note_Most) I Syntax.read_term NONE;
76.1204 -
76.1205 -fun print_bnfs ctxt =
76.1206 - let
76.1207 - fun pretty_set sets i = Pretty.block
76.1208 - [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
76.1209 - Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
76.1210 -
76.1211 - fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
76.1212 - live = live, lives = lives, dead = dead, deads = deads, ...}) =
76.1213 - Pretty.big_list
76.1214 - (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
76.1215 - Pretty.quote (Syntax.pretty_typ ctxt T)]))
76.1216 - ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
76.1217 - Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
76.1218 - Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
76.1219 - Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
76.1220 - Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
76.1221 - Pretty.quote (Syntax.pretty_term ctxt map)]] @
76.1222 - List.map (pretty_set sets) (0 upto length sets - 1) @
76.1223 - [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
76.1224 - Pretty.quote (Syntax.pretty_term ctxt bd)]]);
76.1225 - in
76.1226 - Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
76.1227 - |> Pretty.writeln
76.1228 - end;
76.1229 -
76.1230 -val _ =
76.1231 - Outer_Syntax.improper_command @{command_spec "print_bnfs"} "print all BNFs"
76.1232 - (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
76.1233 -
76.1234 -val _ =
76.1235 - Outer_Syntax.local_theory_to_proof @{command_spec "bnf_def"} "define a BNF for an existing type"
76.1236 - ((parse_opt_binding_colon -- Parse.term --
76.1237 - (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Parse.term --
76.1238 - (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Scan.option Parse.term)
76.1239 - >> bnf_def_cmd);
76.1240 -
76.1241 -end;
77.1 --- a/src/HOL/Codatatype/Tools/bnf_def_tactics.ML Fri Sep 21 16:34:40 2012 +0200
77.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
77.3 @@ -1,209 +0,0 @@
77.4 -(* Title: HOL/BNF/Tools/bnf_def_tactics.ML
77.5 - Author: Dmitriy Traytel, TU Muenchen
77.6 - Author: Jasmin Blanchette, TU Muenchen
77.7 - Copyright 2012
77.8 -
77.9 -Tactics for definition of bounded natural functors.
77.10 -*)
77.11 -
77.12 -signature BNF_DEF_TACTICS =
77.13 -sig
77.14 - val mk_collect_set_natural_tac: Proof.context -> thm list -> tactic
77.15 - val mk_id': thm -> thm
77.16 - val mk_comp': thm -> thm
77.17 - val mk_in_mono_tac: int -> tactic
77.18 - val mk_map_wppull_tac: thm -> thm -> thm -> thm -> thm list -> tactic
77.19 - val mk_set_natural': thm -> thm
77.20 -
77.21 - val mk_srel_Gr_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
77.22 - {prems: thm list, context: Proof.context} -> tactic
77.23 - val mk_srel_Id_tac: int -> thm -> thm -> {prems: 'a, context: Proof.context} -> tactic
77.24 - val mk_srel_O_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
77.25 - {prems: thm list, context: Proof.context} -> tactic
77.26 - val mk_in_srel_tac: thm list -> int -> {prems: 'b, context: Proof.context} -> tactic
77.27 - val mk_srel_converse_tac: thm -> tactic
77.28 - val mk_srel_converse_le_tac: thm list -> thm -> thm -> thm -> thm list ->
77.29 - {prems: thm list, context: Proof.context} -> tactic
77.30 - val mk_srel_mono_tac: thm list -> thm -> {prems: 'a, context: Proof.context} -> tactic
77.31 -end;
77.32 -
77.33 -structure BNF_Def_Tactics : BNF_DEF_TACTICS =
77.34 -struct
77.35 -
77.36 -open BNF_Util
77.37 -open BNF_Tactics
77.38 -
77.39 -fun mk_id' id = mk_trans (fun_cong OF [id]) @{thm id_apply};
77.40 -fun mk_comp' comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
77.41 -fun mk_set_natural' set_natural = set_natural RS @{thm pointfreeE};
77.42 -fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
77.43 - else (rtac subsetI THEN'
77.44 - rtac CollectI) 1 THEN
77.45 - REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
77.46 - REPEAT_DETERM_N (n - 1)
77.47 - ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
77.48 - (etac subset_trans THEN' atac) 1;
77.49 -
77.50 -fun mk_collect_set_natural_tac ctxt set_naturals =
77.51 - substs_tac ctxt (@{thms collect_o image_insert image_empty} @ set_naturals) 1 THEN rtac refl 1;
77.52 -
77.53 -fun mk_map_wppull_tac map_id map_cong map_wpull map_comp set_naturals =
77.54 - if null set_naturals then
77.55 - EVERY' [rtac @{thm wppull_id}, rtac map_wpull, rtac map_id, rtac map_id] 1
77.56 - else EVERY' [REPEAT_DETERM o etac conjE, REPEAT_DETERM o dtac @{thm wppull_thePull},
77.57 - REPEAT_DETERM o etac exE, rtac @{thm wpull_wppull}, rtac map_wpull,
77.58 - REPEAT_DETERM o rtac @{thm wpull_thePull}, rtac ballI,
77.59 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac CollectI,
77.60 - CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
77.61 - rtac @{thm image_subsetI}, rtac conjunct1, etac bspec, etac set_mp, atac])
77.62 - set_naturals,
77.63 - CONJ_WRAP' (fn thm => EVERY' [rtac (map_comp RS trans), rtac (map_comp RS trans),
77.64 - rtac (map_comp RS trans RS sym), rtac map_cong,
77.65 - REPEAT_DETERM_N (length set_naturals) o EVERY' [rtac (o_apply RS trans),
77.66 - rtac (o_apply RS trans RS sym), rtac (o_apply RS trans), rtac thm,
77.67 - rtac conjunct2, etac bspec, etac set_mp, atac]]) [conjunct1, conjunct2]] 1;
77.68 -
77.69 -fun mk_srel_Gr_tac srel_O_Grs map_id map_cong map_id' map_comp set_naturals
77.70 - {context = ctxt, prems = _} =
77.71 - let
77.72 - val n = length set_naturals;
77.73 - in
77.74 - if null set_naturals then
77.75 - unfold_thms_tac ctxt srel_O_Grs THEN EVERY' [rtac @{thm Gr_UNIV_id}, rtac map_id] 1
77.76 - else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
77.77 - EVERY' [rtac equalityI, rtac subsetI,
77.78 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
77.79 - REPEAT_DETERM o dtac Pair_eqD,
77.80 - REPEAT_DETERM o etac conjE, hyp_subst_tac,
77.81 - rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
77.82 - rtac sym, rtac trans, rtac map_comp, rtac map_cong,
77.83 - REPEAT_DETERM_N n o EVERY' [dtac @{thm set_rev_mp}, atac,
77.84 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
77.85 - rtac (o_apply RS trans), rtac (@{thm fst_conv} RS arg_cong RS trans),
77.86 - rtac (@{thm snd_conv} RS sym)],
77.87 - rtac CollectI,
77.88 - CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
77.89 - rtac @{thm image_subsetI}, dtac @{thm set_rev_mp}, atac,
77.90 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
77.91 - stac @{thm fst_conv}, atac]) set_naturals,
77.92 - rtac @{thm subrelI}, etac CollectE, REPEAT_DETERM o eresolve_tac [exE, conjE],
77.93 - REPEAT_DETERM o dtac Pair_eqD,
77.94 - REPEAT_DETERM o etac conjE, hyp_subst_tac,
77.95 - rtac @{thm relcompI}, rtac @{thm converseI},
77.96 - EVERY' (map2 (fn convol => fn map_id =>
77.97 - EVERY' [rtac CollectI, rtac exI, rtac conjI,
77.98 - rtac Pair_eqI, rtac conjI, rtac refl, rtac sym,
77.99 - rtac (box_equals OF [map_cong, map_comp RS sym, map_id]),
77.100 - REPEAT_DETERM_N n o rtac (convol RS fun_cong),
77.101 - REPEAT_DETERM o eresolve_tac [CollectE, conjE],
77.102 - rtac CollectI,
77.103 - CONJ_WRAP' (fn thm =>
77.104 - EVERY' [rtac @{thm ord_eq_le_trans}, rtac thm, rtac @{thm image_subsetI},
77.105 - rtac @{thm convol_memI[of id _ "%x. x", OF id_apply refl]}, etac set_mp, atac])
77.106 - set_naturals])
77.107 - @{thms fst_convol snd_convol} [map_id', refl])] 1
77.108 - end;
77.109 -
77.110 -fun mk_srel_Id_tac n srel_Gr map_id {context = ctxt, prems = _} =
77.111 - unfold_thms_tac ctxt [srel_Gr, @{thm Id_alt}] THEN
77.112 - subst_tac ctxt [map_id] 1 THEN
77.113 - (if n = 0 then rtac refl 1
77.114 - else EVERY' [rtac @{thm arg_cong2[of _ _ _ _ Gr]},
77.115 - rtac equalityI, rtac subset_UNIV, rtac subsetI, rtac CollectI,
77.116 - CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto n), rtac refl] 1);
77.117 -
77.118 -fun mk_srel_mono_tac srel_O_Grs in_mono {context = ctxt, prems = _} =
77.119 - unfold_thms_tac ctxt srel_O_Grs THEN
77.120 - EVERY' [rtac @{thm relcomp_mono}, rtac @{thm iffD2[OF converse_mono]},
77.121 - rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac,
77.122 - rtac @{thm Gr_mono}, rtac in_mono, REPEAT_DETERM o atac] 1;
77.123 -
77.124 -fun mk_srel_converse_le_tac srel_O_Grs srel_Id map_cong map_comp set_naturals
77.125 - {context = ctxt, prems = _} =
77.126 - let
77.127 - val n = length set_naturals;
77.128 - in
77.129 - if null set_naturals then
77.130 - unfold_thms_tac ctxt [srel_Id] THEN rtac equalityD2 1 THEN rtac @{thm converse_Id} 1
77.131 - else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
77.132 - EVERY' [rtac @{thm subrelI},
77.133 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
77.134 - REPEAT_DETERM o dtac Pair_eqD,
77.135 - REPEAT_DETERM o etac conjE, hyp_subst_tac, rtac @{thm converseI},
77.136 - rtac @{thm relcompI}, rtac @{thm converseI},
77.137 - EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
77.138 - rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac trans,
77.139 - rtac map_cong, REPEAT_DETERM_N n o rtac thm,
77.140 - rtac (map_comp RS sym), rtac CollectI,
77.141 - CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
77.142 - etac @{thm flip_rel}]) set_naturals]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
77.143 - end;
77.144 -
77.145 -fun mk_srel_converse_tac le_converse =
77.146 - EVERY' [rtac equalityI, rtac le_converse, rtac @{thm xt1(6)}, rtac @{thm converse_shift},
77.147 - rtac le_converse, REPEAT_DETERM o stac @{thm converse_converse}, rtac subset_refl] 1;
77.148 -
77.149 -fun mk_srel_O_tac srel_O_Grs srel_Id map_cong map_wppull map_comp set_naturals
77.150 - {context = ctxt, prems = _} =
77.151 - let
77.152 - val n = length set_naturals;
77.153 - fun in_tac nthO_in = rtac CollectI THEN'
77.154 - CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS @{thm ord_eq_le_trans}),
77.155 - rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_naturals;
77.156 - in
77.157 - if null set_naturals then unfold_thms_tac ctxt [srel_Id] THEN rtac (@{thm Id_O_R} RS sym) 1
77.158 - else unfold_thms_tac ctxt (@{thm Gr_def} :: srel_O_Grs) THEN
77.159 - EVERY' [rtac equalityI, rtac @{thm subrelI},
77.160 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm relcompE}, @{thm converseE}],
77.161 - REPEAT_DETERM o dtac Pair_eqD,
77.162 - REPEAT_DETERM o etac conjE, hyp_subst_tac,
77.163 - rtac @{thm relcompI}, rtac @{thm relcompI}, rtac @{thm converseI},
77.164 - rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
77.165 - rtac sym, rtac trans, rtac map_comp, rtac sym, rtac map_cong,
77.166 - REPEAT_DETERM_N n o rtac @{thm fst_fstO},
77.167 - in_tac @{thm fstO_in},
77.168 - rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
77.169 - rtac sym, rtac trans, rtac map_comp, rtac map_cong,
77.170 - REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, rtac ballE, rtac subst,
77.171 - rtac @{thm csquare_def}, rtac @{thm csquare_fstO_sndO}, atac, etac notE,
77.172 - etac set_mp, atac],
77.173 - in_tac @{thm fstO_in},
77.174 - rtac @{thm relcompI}, rtac @{thm converseI},
77.175 - rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
77.176 - rtac sym, rtac trans, rtac map_comp, rtac map_cong,
77.177 - REPEAT_DETERM_N n o rtac o_apply,
77.178 - in_tac @{thm sndO_in},
77.179 - rtac CollectI, rtac exI, rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl,
77.180 - rtac sym, rtac trans, rtac map_comp, rtac sym, rtac map_cong,
77.181 - REPEAT_DETERM_N n o rtac @{thm snd_sndO},
77.182 - in_tac @{thm sndO_in},
77.183 - rtac @{thm subrelI},
77.184 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm relcompE}, @{thm converseE}],
77.185 - REPEAT_DETERM o eresolve_tac [exE, conjE],
77.186 - REPEAT_DETERM o dtac Pair_eqD,
77.187 - REPEAT_DETERM o etac conjE, hyp_subst_tac,
77.188 - rtac allE, rtac subst, rtac @{thm wppull_def}, rtac map_wppull,
77.189 - CONJ_WRAP' (K (rtac @{thm wppull_fstO_sndO})) set_naturals,
77.190 - etac allE, etac impE, etac conjI, etac conjI, atac,
77.191 - REPEAT_DETERM o eresolve_tac [bexE, conjE],
77.192 - rtac @{thm relcompI}, rtac @{thm converseI},
77.193 - EVERY' (map (fn thm => EVERY' [rtac CollectI, rtac exI,
77.194 - rtac conjI, rtac Pair_eqI, rtac conjI, rtac refl, rtac sym, rtac trans,
77.195 - rtac trans, rtac map_cong, REPEAT_DETERM_N n o rtac thm,
77.196 - rtac (map_comp RS sym), atac, atac]) [@{thm fst_fstO}, @{thm snd_sndO}])] 1
77.197 - end;
77.198 -
77.199 -fun mk_in_srel_tac srel_O_Grs m {context = ctxt, prems = _} =
77.200 - let
77.201 - val ls' = replicate (Int.max (1, m)) ();
77.202 - in
77.203 - unfold_thms_tac ctxt (srel_O_Grs @
77.204 - @{thms Gr_def converse_unfold relcomp_unfold mem_Collect_eq prod.cases Pair_eq}) THEN
77.205 - EVERY' [rtac iffI, REPEAT_DETERM o eresolve_tac [exE, conjE], hyp_subst_tac, rtac exI,
77.206 - rtac conjI, CONJ_WRAP' (K atac) ls', rtac conjI, rtac refl, rtac refl,
77.207 - REPEAT_DETERM o eresolve_tac [exE, conjE], rtac exI, rtac conjI,
77.208 - REPEAT_DETERM_N 2 o EVERY' [rtac exI, rtac conjI, etac @{thm conjI[OF refl sym]},
77.209 - CONJ_WRAP' (K atac) ls']] 1
77.210 - end;
77.211 -
77.212 -end;
78.1 --- a/src/HOL/Codatatype/Tools/bnf_fp.ML Fri Sep 21 16:34:40 2012 +0200
78.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
78.3 @@ -1,442 +0,0 @@
78.4 -(* Title: HOL/BNF/Tools/bnf_fp.ML
78.5 - Author: Dmitriy Traytel, TU Muenchen
78.6 - Copyright 2012
78.7 -
78.8 -Shared library for the datatype and codatatype constructions.
78.9 -*)
78.10 -
78.11 -signature BNF_FP =
78.12 -sig
78.13 - val time: Timer.real_timer -> string -> Timer.real_timer
78.14 -
78.15 - val IITN: string
78.16 - val LevN: string
78.17 - val algN: string
78.18 - val behN: string
78.19 - val bisN: string
78.20 - val carTN: string
78.21 - val caseN: string
78.22 - val coN: string
78.23 - val coinductN: string
78.24 - val corecN: string
78.25 - val corecsN: string
78.26 - val ctorN: string
78.27 - val ctor_dtorN: string
78.28 - val ctor_dtor_unfoldsN: string
78.29 - val ctor_dtor_corecsN: string
78.30 - val ctor_exhaustN: string
78.31 - val ctor_induct2N: string
78.32 - val ctor_inductN: string
78.33 - val ctor_injectN: string
78.34 - val ctor_foldN: string
78.35 - val ctor_fold_uniqueN: string
78.36 - val ctor_foldsN: string
78.37 - val ctor_recN: string
78.38 - val ctor_recsN: string
78.39 - val disc_unfold_iffN: string
78.40 - val disc_unfoldsN: string
78.41 - val disc_corec_iffN: string
78.42 - val disc_corecsN: string
78.43 - val dtorN: string
78.44 - val dtor_coinductN: string
78.45 - val dtor_unfoldN: string
78.46 - val dtor_unfold_uniqueN: string
78.47 - val dtor_unfoldsN: string
78.48 - val dtor_corecN: string
78.49 - val dtor_corecsN: string
78.50 - val dtor_exhaustN: string
78.51 - val dtor_ctorN: string
78.52 - val dtor_injectN: string
78.53 - val dtor_strong_coinductN: string
78.54 - val exhaustN: string
78.55 - val foldN: string
78.56 - val foldsN: string
78.57 - val hsetN: string
78.58 - val hset_recN: string
78.59 - val inductN: string
78.60 - val injectN: string
78.61 - val isNodeN: string
78.62 - val lsbisN: string
78.63 - val map_simpsN: string
78.64 - val map_uniqueN: string
78.65 - val min_algN: string
78.66 - val morN: string
78.67 - val nchotomyN: string
78.68 - val recN: string
78.69 - val recsN: string
78.70 - val rel_coinductN: string
78.71 - val rel_simpN: string
78.72 - val rel_strong_coinductN: string
78.73 - val rvN: string
78.74 - val sel_unfoldsN: string
78.75 - val sel_corecsN: string
78.76 - val set_inclN: string
78.77 - val set_set_inclN: string
78.78 - val simpsN: string
78.79 - val srel_coinductN: string
78.80 - val srel_simpN: string
78.81 - val srel_strong_coinductN: string
78.82 - val strTN: string
78.83 - val str_initN: string
78.84 - val strongN: string
78.85 - val sum_bdN: string
78.86 - val sum_bdTN: string
78.87 - val unfoldN: string
78.88 - val unfoldsN: string
78.89 - val uniqueN: string
78.90 -
78.91 - val mk_exhaustN: string -> string
78.92 - val mk_injectN: string -> string
78.93 - val mk_nchotomyN: string -> string
78.94 - val mk_set_simpsN: int -> string
78.95 - val mk_set_minimalN: int -> string
78.96 - val mk_set_inductN: int -> string
78.97 -
78.98 - val mk_common_name: string list -> string
78.99 -
78.100 - val split_conj_thm: thm -> thm list
78.101 - val split_conj_prems: int -> thm -> thm
78.102 -
78.103 - val retype_free: typ -> term -> term
78.104 -
78.105 - val mk_sumTN: typ list -> typ
78.106 - val mk_sumTN_balanced: typ list -> typ
78.107 -
78.108 - val id_const: typ -> term
78.109 - val id_abs: typ -> term
78.110 -
78.111 - val Inl_const: typ -> typ -> term
78.112 - val Inr_const: typ -> typ -> term
78.113 -
78.114 - val mk_Inl: typ -> term -> term
78.115 - val mk_Inr: typ -> term -> term
78.116 - val mk_InN: typ list -> term -> int -> term
78.117 - val mk_InN_balanced: typ -> int -> term -> int -> term
78.118 - val mk_sum_case: term * term -> term
78.119 - val mk_sum_caseN: term list -> term
78.120 - val mk_sum_caseN_balanced: term list -> term
78.121 -
78.122 - val dest_sumT: typ -> typ * typ
78.123 - val dest_sumTN: int -> typ -> typ list
78.124 - val dest_sumTN_balanced: int -> typ -> typ list
78.125 - val dest_tupleT: int -> typ -> typ list
78.126 -
78.127 - val mk_Field: term -> term
78.128 - val mk_If: term -> term -> term -> term
78.129 - val mk_union: term * term -> term
78.130 -
78.131 - val mk_sumEN: int -> thm
78.132 - val mk_sumEN_balanced: int -> thm
78.133 - val mk_sumEN_tupled_balanced: int list -> thm
78.134 - val mk_sum_casesN: int -> int -> thm
78.135 - val mk_sum_casesN_balanced: int -> int -> thm
78.136 -
78.137 - val fixpoint: ('a * 'a -> bool) -> ('a list -> 'a list) -> 'a list -> 'a list
78.138 -
78.139 - val fp_bnf: (mixfix list -> (string * sort) list option -> binding list ->
78.140 - typ list * typ list list -> BNF_Def.BNF list -> local_theory -> 'a) ->
78.141 - binding list -> mixfix list -> (string * sort) list -> ((string * sort) * typ) list ->
78.142 - local_theory -> BNF_Def.BNF list * 'a
78.143 - val fp_bnf_cmd: (mixfix list -> (string * sort) list option -> binding list ->
78.144 - typ list * typ list list -> BNF_Def.BNF list -> local_theory -> 'a) ->
78.145 - binding list * (string list * string list) -> local_theory -> 'a
78.146 -end;
78.147 -
78.148 -structure BNF_FP : BNF_FP =
78.149 -struct
78.150 -
78.151 -open BNF_Comp
78.152 -open BNF_Def
78.153 -open BNF_Util
78.154 -
78.155 -val timing = true;
78.156 -fun time timer msg = (if timing
78.157 - then warning (msg ^ ": " ^ ATP_Util.string_from_time (Timer.checkRealTimer timer))
78.158 - else (); Timer.startRealTimer ());
78.159 -
78.160 -val preN = "pre_"
78.161 -val rawN = "raw_"
78.162 -
78.163 -val coN = "co"
78.164 -val unN = "un"
78.165 -val algN = "alg"
78.166 -val IITN = "IITN"
78.167 -val foldN = "fold"
78.168 -val foldsN = foldN ^ "s"
78.169 -val unfoldN = unN ^ foldN
78.170 -val unfoldsN = unfoldN ^ "s"
78.171 -val uniqueN = "_unique"
78.172 -val simpsN = "simps"
78.173 -val ctorN = "ctor"
78.174 -val dtorN = "dtor"
78.175 -val ctor_foldN = ctorN ^ "_" ^ foldN
78.176 -val ctor_foldsN = ctor_foldN ^ "s"
78.177 -val dtor_unfoldN = dtorN ^ "_" ^ unfoldN
78.178 -val dtor_unfoldsN = dtor_unfoldN ^ "s"
78.179 -val ctor_fold_uniqueN = ctor_foldN ^ uniqueN
78.180 -val dtor_unfold_uniqueN = dtor_unfoldN ^ uniqueN
78.181 -val ctor_dtor_unfoldsN = ctorN ^ "_" ^ dtor_unfoldN ^ "s"
78.182 -val map_simpsN = mapN ^ "_" ^ simpsN
78.183 -val map_uniqueN = mapN ^ uniqueN
78.184 -val min_algN = "min_alg"
78.185 -val morN = "mor"
78.186 -val bisN = "bis"
78.187 -val lsbisN = "lsbis"
78.188 -val sum_bdTN = "sbdT"
78.189 -val sum_bdN = "sbd"
78.190 -val carTN = "carT"
78.191 -val strTN = "strT"
78.192 -val isNodeN = "isNode"
78.193 -val LevN = "Lev"
78.194 -val rvN = "recover"
78.195 -val behN = "beh"
78.196 -fun mk_set_simpsN i = mk_setN i ^ "_" ^ simpsN
78.197 -fun mk_set_minimalN i = mk_setN i ^ "_minimal"
78.198 -fun mk_set_inductN i = mk_setN i ^ "_induct"
78.199 -
78.200 -val str_initN = "str_init"
78.201 -val recN = "rec"
78.202 -val recsN = recN ^ "s"
78.203 -val corecN = coN ^ recN
78.204 -val corecsN = corecN ^ "s"
78.205 -val ctor_recN = ctorN ^ "_" ^ recN
78.206 -val ctor_recsN = ctor_recN ^ "s"
78.207 -val dtor_corecN = dtorN ^ "_" ^ corecN
78.208 -val dtor_corecsN = dtor_corecN ^ "s"
78.209 -val ctor_dtor_corecsN = ctorN ^ "_" ^ dtor_corecN ^ "s"
78.210 -
78.211 -val ctor_dtorN = ctorN ^ "_" ^ dtorN
78.212 -val dtor_ctorN = dtorN ^ "_" ^ ctorN
78.213 -val nchotomyN = "nchotomy"
78.214 -fun mk_nchotomyN s = s ^ "_" ^ nchotomyN
78.215 -val injectN = "inject"
78.216 -fun mk_injectN s = s ^ "_" ^ injectN
78.217 -val exhaustN = "exhaust"
78.218 -fun mk_exhaustN s = s ^ "_" ^ exhaustN
78.219 -val ctor_injectN = mk_injectN ctorN
78.220 -val ctor_exhaustN = mk_exhaustN ctorN
78.221 -val dtor_injectN = mk_injectN dtorN
78.222 -val dtor_exhaustN = mk_exhaustN dtorN
78.223 -val inductN = "induct"
78.224 -val coinductN = coN ^ inductN
78.225 -val ctor_inductN = ctorN ^ "_" ^ inductN
78.226 -val ctor_induct2N = ctor_inductN ^ "2"
78.227 -val dtor_coinductN = dtorN ^ "_" ^ coinductN
78.228 -val rel_coinductN = relN ^ "_" ^ coinductN
78.229 -val srel_coinductN = srelN ^ "_" ^ coinductN
78.230 -val simpN = "_simp";
78.231 -val srel_simpN = srelN ^ simpN;
78.232 -val rel_simpN = relN ^ simpN;
78.233 -val strongN = "strong_"
78.234 -val dtor_strong_coinductN = dtorN ^ "_" ^ strongN ^ coinductN
78.235 -val rel_strong_coinductN = relN ^ "_" ^ strongN ^ coinductN
78.236 -val srel_strong_coinductN = srelN ^ "_" ^ strongN ^ coinductN
78.237 -val hsetN = "Hset"
78.238 -val hset_recN = hsetN ^ "_rec"
78.239 -val set_inclN = "set_incl"
78.240 -val set_set_inclN = "set_set_incl"
78.241 -
78.242 -val caseN = "case"
78.243 -val discN = "disc"
78.244 -val disc_unfoldsN = discN ^ "_" ^ unfoldsN
78.245 -val disc_corecsN = discN ^ "_" ^ corecsN
78.246 -val iffN = "_iff"
78.247 -val disc_unfold_iffN = discN ^ "_" ^ unfoldN ^ iffN
78.248 -val disc_corec_iffN = discN ^ "_" ^ corecN ^ iffN
78.249 -val selN = "sel"
78.250 -val sel_unfoldsN = selN ^ "_" ^ unfoldsN
78.251 -val sel_corecsN = selN ^ "_" ^ corecsN
78.252 -
78.253 -val mk_common_name = space_implode "_";
78.254 -
78.255 -fun retype_free T (Free (s, _)) = Free (s, T);
78.256 -
78.257 -fun dest_sumT (Type (@{type_name sum}, [T, T'])) = (T, T');
78.258 -
78.259 -fun dest_sumTN 1 T = [T]
78.260 - | dest_sumTN n (Type (@{type_name sum}, [T, T'])) = T :: dest_sumTN (n - 1) T';
78.261 -
78.262 -val dest_sumTN_balanced = Balanced_Tree.dest dest_sumT;
78.263 -
78.264 -(* TODO: move something like this to "HOLogic"? *)
78.265 -fun dest_tupleT 0 @{typ unit} = []
78.266 - | dest_tupleT 1 T = [T]
78.267 - | dest_tupleT n (Type (@{type_name prod}, [T, T'])) = T :: dest_tupleT (n - 1) T';
78.268 -
78.269 -val mk_sumTN = Library.foldr1 mk_sumT;
78.270 -val mk_sumTN_balanced = Balanced_Tree.make mk_sumT;
78.271 -
78.272 -fun id_const T = Const (@{const_name id}, T --> T);
78.273 -fun id_abs T = Abs (Name.uu, T, Bound 0);
78.274 -
78.275 -fun Inl_const LT RT = Const (@{const_name Inl}, LT --> mk_sumT (LT, RT));
78.276 -fun mk_Inl RT t = Inl_const (fastype_of t) RT $ t;
78.277 -
78.278 -fun Inr_const LT RT = Const (@{const_name Inr}, RT --> mk_sumT (LT, RT));
78.279 -fun mk_Inr LT t = Inr_const LT (fastype_of t) $ t;
78.280 -
78.281 -fun mk_InN [_] t 1 = t
78.282 - | mk_InN (_ :: Ts) t 1 = mk_Inl (mk_sumTN Ts) t
78.283 - | mk_InN (LT :: Ts) t m = mk_Inr LT (mk_InN Ts t (m - 1))
78.284 - | mk_InN Ts t _ = raise (TYPE ("mk_InN", Ts, [t]));
78.285 -
78.286 -fun mk_InN_balanced sum_T n t k =
78.287 - let
78.288 - fun repair_types T (Const (s as @{const_name Inl}, _) $ t) = repair_inj_types T s fst t
78.289 - | repair_types T (Const (s as @{const_name Inr}, _) $ t) = repair_inj_types T s snd t
78.290 - | repair_types _ t = t
78.291 - and repair_inj_types T s get t =
78.292 - let val T' = get (dest_sumT T) in
78.293 - Const (s, T' --> T) $ repair_types T' t
78.294 - end;
78.295 - in
78.296 - Balanced_Tree.access {left = mk_Inl dummyT, right = mk_Inr dummyT, init = t} n k
78.297 - |> repair_types sum_T
78.298 - end;
78.299 -
78.300 -fun mk_sum_case (f, g) =
78.301 - let
78.302 - val fT = fastype_of f;
78.303 - val gT = fastype_of g;
78.304 - in
78.305 - Const (@{const_name sum_case},
78.306 - fT --> gT --> mk_sumT (domain_type fT, domain_type gT) --> range_type fT) $ f $ g
78.307 - end;
78.308 -
78.309 -val mk_sum_caseN = Library.foldr1 mk_sum_case;
78.310 -val mk_sum_caseN_balanced = Balanced_Tree.make mk_sum_case;
78.311 -
78.312 -fun mk_If p t f =
78.313 - let val T = fastype_of t;
78.314 - in Const (@{const_name If}, HOLogic.boolT --> T --> T --> T) $ p $ t $ f end;
78.315 -
78.316 -fun mk_Field r =
78.317 - let val T = fst (dest_relT (fastype_of r));
78.318 - in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
78.319 -
78.320 -val mk_union = HOLogic.mk_binop @{const_name sup};
78.321 -
78.322 -(*dangerous; use with monotonic, converging functions only!*)
78.323 -fun fixpoint eq f X = if subset eq (f X, X) then X else fixpoint eq f (f X);
78.324 -
78.325 -(* stolen from "~~/src/HOL/Tools/Datatype/datatype_aux.ML" *)
78.326 -fun split_conj_thm th =
78.327 - ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
78.328 -
78.329 -fun split_conj_prems limit th =
78.330 - let
78.331 - fun split n i th =
78.332 - if i = n then th else split n (i + 1) (conjI RSN (i, th)) handle THM _ => th;
78.333 - in split limit 1 th end;
78.334 -
78.335 -fun mk_sumEN 1 = @{thm one_pointE}
78.336 - | mk_sumEN 2 = @{thm sumE}
78.337 - | mk_sumEN n =
78.338 - (fold (fn i => fn thm => @{thm obj_sum_step} RSN (i, thm)) (2 upto n - 1) @{thm obj_sumE}) OF
78.339 - replicate n (impI RS allI);
78.340 -
78.341 -fun mk_obj_sumEN_balanced n =
78.342 - Balanced_Tree.make (fn (thm1, thm2) => thm1 RSN (1, thm2 RSN (2, @{thm obj_sumE_f})))
78.343 - (replicate n asm_rl);
78.344 -
78.345 -fun mk_sumEN_balanced' n all_impIs = mk_obj_sumEN_balanced n OF all_impIs RS @{thm obj_one_pointE};
78.346 -
78.347 -fun mk_sumEN_balanced 1 = @{thm one_pointE} (*optimization*)
78.348 - | mk_sumEN_balanced 2 = @{thm sumE} (*optimization*)
78.349 - | mk_sumEN_balanced n = mk_sumEN_balanced' n (replicate n (impI RS allI));
78.350 -
78.351 -fun mk_tupled_allIN 0 = @{thm unit_all_impI}
78.352 - | mk_tupled_allIN 1 = @{thm impI[THEN allI]}
78.353 - | mk_tupled_allIN 2 = @{thm prod_all_impI} (*optimization*)
78.354 - | mk_tupled_allIN n = mk_tupled_allIN (n - 1) RS @{thm prod_all_impI_step};
78.355 -
78.356 -fun mk_sumEN_tupled_balanced ms =
78.357 - let val n = length ms in
78.358 - if forall (curry (op =) 1) ms then mk_sumEN_balanced n
78.359 - else mk_sumEN_balanced' n (map mk_tupled_allIN ms)
78.360 - end;
78.361 -
78.362 -fun mk_sum_casesN 1 1 = refl
78.363 - | mk_sum_casesN _ 1 = @{thm sum.cases(1)}
78.364 - | mk_sum_casesN 2 2 = @{thm sum.cases(2)}
78.365 - | mk_sum_casesN n k = trans OF [@{thm sum_case_step(2)}, mk_sum_casesN (n - 1) (k - 1)];
78.366 -
78.367 -fun mk_sum_step base step thm =
78.368 - if Thm.eq_thm_prop (thm, refl) then base else trans OF [step, thm];
78.369 -
78.370 -fun mk_sum_casesN_balanced 1 1 = refl
78.371 - | mk_sum_casesN_balanced n k =
78.372 - Balanced_Tree.access {left = mk_sum_step @{thm sum.cases(1)} @{thm sum_case_step(1)},
78.373 - right = mk_sum_step @{thm sum.cases(2)} @{thm sum_case_step(2)}, init = refl} n k;
78.374 -
78.375 -(* FIXME: because of "@ lhss", the output could contain type variables that are not in the input;
78.376 - also, "fp_sort" should put the "resBs" first and in the order in which they appear *)
78.377 -fun fp_sort lhss NONE Ass = Library.sort (Term_Ord.typ_ord o pairself TFree)
78.378 - (subtract (op =) lhss (fold (fold (insert (op =))) Ass [])) @ lhss
78.379 - | fp_sort lhss (SOME resBs) Ass =
78.380 - (subtract (op =) lhss (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs)) @ lhss;
78.381 -
78.382 -fun mk_fp_bnf timer construct resBs bs sort lhss bnfs deadss livess unfold_set lthy =
78.383 - let
78.384 - val name = mk_common_name (map Binding.name_of bs);
78.385 - fun qualify i =
78.386 - let val namei = name ^ nonzero_string_of_int i;
78.387 - in Binding.qualify true namei end;
78.388 -
78.389 - val Ass = map (map dest_TFree) livess;
78.390 - val resDs = (case resBs of NONE => [] | SOME Ts => fold (subtract (op =)) Ass Ts);
78.391 - val Ds = fold (fold Term.add_tfreesT) deadss [];
78.392 -
78.393 - val _ = (case Library.inter (op =) Ds lhss of [] => ()
78.394 - | A :: _ => error ("Nonadmissible type recursion (cannot take fixed point of dead type \
78.395 - \variable " ^ quote (Syntax.string_of_typ lthy (TFree A)) ^ ")"));
78.396 -
78.397 - val timer = time (timer "Construction of BNFs");
78.398 -
78.399 - val ((kill_poss, _), (bnfs', (unfold_set', lthy'))) =
78.400 - normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy;
78.401 -
78.402 - val Dss = map3 (append oo map o nth) livess kill_poss deadss;
78.403 -
78.404 - val ((bnfs'', deadss), lthy'') =
78.405 - fold_map3 (seal_bnf unfold_set') (map (Binding.prefix_name preN) bs) Dss bnfs' lthy'
78.406 - |>> split_list;
78.407 -
78.408 - val timer = time (timer "Normalization & sealing of BNFs");
78.409 -
78.410 - val res = construct resBs bs (map TFree resDs, deadss) bnfs'' lthy'';
78.411 -
78.412 - val timer = time (timer "FP construction in total");
78.413 - in
78.414 - timer; (bnfs'', res)
78.415 - end;
78.416 -
78.417 -fun fp_bnf construct bs mixfixes resBs eqs lthy =
78.418 - let
78.419 - val timer = time (Timer.startRealTimer ());
78.420 - val (lhss, rhss) = split_list eqs;
78.421 - val sort = fp_sort lhss (SOME resBs);
78.422 - fun qualify b = Binding.qualify true (Binding.name_of (Binding.prefix_name rawN b));
78.423 - val ((bnfs, (Dss, Ass)), (unfold_set, lthy')) = apfst (apsnd split_list o split_list)
78.424 - (fold_map2 (fn b => bnf_of_typ Smart_Inline (qualify b) sort) bs rhss
78.425 - (empty_unfolds, lthy));
78.426 - in
78.427 - mk_fp_bnf timer (construct mixfixes) (SOME resBs) bs sort lhss bnfs Dss Ass unfold_set lthy'
78.428 - end;
78.429 -
78.430 -fun fp_bnf_cmd construct (bs, (raw_lhss, raw_bnfs)) lthy =
78.431 - let
78.432 - val timer = time (Timer.startRealTimer ());
78.433 - val lhss = map (dest_TFree o Syntax.read_typ lthy) raw_lhss;
78.434 - val sort = fp_sort lhss NONE;
78.435 - fun qualify b = Binding.qualify true (Binding.name_of (Binding.prefix_name rawN b));
78.436 - val ((bnfs, (Dss, Ass)), (unfold_set, lthy')) = apfst (apsnd split_list o split_list)
78.437 - (fold_map2 (fn b => fn rawT =>
78.438 - (bnf_of_typ Smart_Inline (qualify b) sort (Syntax.read_typ lthy rawT)))
78.439 - bs raw_bnfs (empty_unfolds, lthy));
78.440 - in
78.441 - snd (mk_fp_bnf timer
78.442 - (construct (map (K NoSyn) bs)) NONE bs sort lhss bnfs Dss Ass unfold_set lthy')
78.443 - end;
78.444 -
78.445 -end;
79.1 --- a/src/HOL/Codatatype/Tools/bnf_fp_sugar.ML Fri Sep 21 16:34:40 2012 +0200
79.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
79.3 @@ -1,911 +0,0 @@
79.4 -(* Title: HOL/BNF/Tools/bnf_fp_sugar.ML
79.5 - Author: Jasmin Blanchette, TU Muenchen
79.6 - Copyright 2012
79.7 -
79.8 -Sugared datatype and codatatype constructions.
79.9 -*)
79.10 -
79.11 -signature BNF_FP_SUGAR =
79.12 -sig
79.13 - val datatyp: bool ->
79.14 - (mixfix list -> (string * sort) list option -> binding list -> typ list * typ list list ->
79.15 - BNF_Def.BNF list -> local_theory ->
79.16 - (term list * term list * term list * term list * thm * thm list * thm list * thm list *
79.17 - thm list * thm list) * local_theory) ->
79.18 - bool * ((((typ * sort) list * binding) * mixfix) * ((((binding * binding) *
79.19 - (binding * typ) list) * (binding * term) list) * mixfix) list) list ->
79.20 - local_theory -> local_theory
79.21 - val parse_datatype_cmd: bool ->
79.22 - (mixfix list -> (string * sort) list option -> binding list -> typ list * typ list list ->
79.23 - BNF_Def.BNF list -> local_theory ->
79.24 - (term list * term list * term list * term list * thm * thm list * thm list * thm list *
79.25 - thm list * thm list) * local_theory) ->
79.26 - (local_theory -> local_theory) parser
79.27 -end;
79.28 -
79.29 -structure BNF_FP_Sugar : BNF_FP_SUGAR =
79.30 -struct
79.31 -
79.32 -open BNF_Util
79.33 -open BNF_Wrap
79.34 -open BNF_Def
79.35 -open BNF_FP
79.36 -open BNF_FP_Sugar_Tactics
79.37 -
79.38 -val simp_attrs = @{attributes [simp]};
79.39 -
79.40 -fun split_list8 xs =
79.41 - (map #1 xs, map #2 xs, map #3 xs, map #4 xs, map #5 xs, map #6 xs, map #7 xs, map #8 xs);
79.42 -
79.43 -fun resort_tfree S (TFree (s, _)) = TFree (s, S);
79.44 -
79.45 -fun typ_subst inst (T as Type (s, Ts)) =
79.46 - (case AList.lookup (op =) inst T of
79.47 - NONE => Type (s, map (typ_subst inst) Ts)
79.48 - | SOME T' => T')
79.49 - | typ_subst inst T = the_default T (AList.lookup (op =) inst T);
79.50 -
79.51 -val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs));
79.52 -
79.53 -fun mk_tupled_fun x f xs = HOLogic.tupled_lambda x (Term.list_comb (f, xs));
79.54 -fun mk_uncurried_fun f xs = mk_tupled_fun (HOLogic.mk_tuple xs) f xs;
79.55 -fun mk_uncurried2_fun f xss =
79.56 - mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat xss);
79.57 -
79.58 -fun tick u f = Term.lambda u (HOLogic.mk_prod (u, f $ u));
79.59 -
79.60 -fun tack z_name (c, u) f =
79.61 - let val z = Free (z_name, mk_sumT (fastype_of u, fastype_of c)) in
79.62 - Term.lambda z (mk_sum_case (Term.lambda u u, Term.lambda c (f $ c)) $ z)
79.63 - end;
79.64 -
79.65 -fun cannot_merge_types () = error "Mutually recursive types must have the same type parameters";
79.66 -
79.67 -fun merge_type_arg T T' = if T = T' then T else cannot_merge_types ();
79.68 -
79.69 -fun merge_type_args (As, As') =
79.70 - if length As = length As' then map2 merge_type_arg As As' else cannot_merge_types ();
79.71 -
79.72 -fun is_triv_implies thm =
79.73 - op aconv (Logic.dest_implies (Thm.prop_of thm))
79.74 - handle TERM _ => false;
79.75 -
79.76 -fun type_args_constrained_of (((cAs, _), _), _) = cAs;
79.77 -fun type_binding_of (((_, b), _), _) = b;
79.78 -fun mixfix_of ((_, mx), _) = mx;
79.79 -fun ctr_specs_of (_, ctr_specs) = ctr_specs;
79.80 -
79.81 -fun disc_of ((((disc, _), _), _), _) = disc;
79.82 -fun ctr_of ((((_, ctr), _), _), _) = ctr;
79.83 -fun args_of (((_, args), _), _) = args;
79.84 -fun defaults_of ((_, ds), _) = ds;
79.85 -fun ctr_mixfix_of (_, mx) = mx;
79.86 -
79.87 -fun define_datatype prepare_constraint prepare_typ prepare_term lfp construct (no_dests, specs)
79.88 - no_defs_lthy0 =
79.89 - let
79.90 - (* TODO: sanity checks on arguments *)
79.91 - (* TODO: integration with function package ("size") *)
79.92 -
79.93 - val _ = if not lfp andalso no_dests then error "Cannot define destructor-less codatatypes"
79.94 - else ();
79.95 -
79.96 - val nn = length specs;
79.97 - val fp_bs = map type_binding_of specs;
79.98 - val fp_b_names = map Binding.name_of fp_bs;
79.99 - val fp_common_name = mk_common_name fp_b_names;
79.100 -
79.101 - fun prepare_type_arg (ty, c) =
79.102 - let val TFree (s, _) = prepare_typ no_defs_lthy0 ty in
79.103 - TFree (s, prepare_constraint no_defs_lthy0 c)
79.104 - end;
79.105 -
79.106 - val Ass0 = map (map prepare_type_arg o type_args_constrained_of) specs;
79.107 - val unsorted_Ass0 = map (map (resort_tfree HOLogic.typeS)) Ass0;
79.108 - val unsorted_As = Library.foldr1 merge_type_args unsorted_Ass0;
79.109 -
79.110 - val ((Bs, Cs), no_defs_lthy) =
79.111 - no_defs_lthy0
79.112 - |> fold (Variable.declare_typ o resort_tfree dummyS) unsorted_As
79.113 - |> mk_TFrees nn
79.114 - ||>> mk_TFrees nn;
79.115 -
79.116 - (* TODO: cleaner handling of fake contexts, without "background_theory" *)
79.117 - (*the "perhaps o try" below helps gracefully handles the case where the new type is defined in a
79.118 - locale and shadows an existing global type*)
79.119 - val fake_thy =
79.120 - Theory.copy #> fold (fn spec => perhaps (try (Sign.add_type no_defs_lthy
79.121 - (type_binding_of spec, length (type_args_constrained_of spec), mixfix_of spec)))) specs;
79.122 - val fake_lthy = Proof_Context.background_theory fake_thy no_defs_lthy;
79.123 -
79.124 - fun mk_fake_T b =
79.125 - Type (fst (Term.dest_Type (Proof_Context.read_type_name fake_lthy true (Binding.name_of b))),
79.126 - unsorted_As);
79.127 -
79.128 - val fake_Ts = map mk_fake_T fp_bs;
79.129 -
79.130 - val mixfixes = map mixfix_of specs;
79.131 -
79.132 - val _ = (case duplicates Binding.eq_name fp_bs of [] => ()
79.133 - | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
79.134 -
79.135 - val ctr_specss = map ctr_specs_of specs;
79.136 -
79.137 - val disc_bindingss = map (map disc_of) ctr_specss;
79.138 - val ctr_bindingss =
79.139 - map2 (fn fp_b_name => map (Binding.qualify false fp_b_name o ctr_of)) fp_b_names ctr_specss;
79.140 - val ctr_argsss = map (map args_of) ctr_specss;
79.141 - val ctr_mixfixess = map (map ctr_mixfix_of) ctr_specss;
79.142 -
79.143 - val sel_bindingsss = map (map (map fst)) ctr_argsss;
79.144 - val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss;
79.145 - val raw_sel_defaultsss = map (map defaults_of) ctr_specss;
79.146 -
79.147 - val (As :: _) :: fake_ctr_Tsss =
79.148 - burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0);
79.149 -
79.150 - val _ = (case duplicates (op =) unsorted_As of [] => ()
79.151 - | A :: _ => error ("Duplicate type parameter " ^
79.152 - quote (Syntax.string_of_typ no_defs_lthy A)));
79.153 -
79.154 - val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss [];
79.155 - val _ = (case subtract (op =) (map dest_TFree As) rhs_As' of
79.156 - [] => ()
79.157 - | A' :: _ => error ("Extra type variable on right-hand side: " ^
79.158 - quote (Syntax.string_of_typ no_defs_lthy (TFree A'))));
79.159 -
79.160 - fun eq_fpT (T as Type (s, Us)) (Type (s', Us')) =
79.161 - s = s' andalso (Us = Us' orelse error ("Illegal occurrence of recursive type " ^
79.162 - quote (Syntax.string_of_typ fake_lthy T)))
79.163 - | eq_fpT _ _ = false;
79.164 -
79.165 - fun freeze_fp (T as Type (s, Us)) =
79.166 - (case find_index (eq_fpT T) fake_Ts of ~1 => Type (s, map freeze_fp Us) | j => nth Bs j)
79.167 - | freeze_fp T = T;
79.168 -
79.169 - val ctr_TsssBs = map (map (map freeze_fp)) fake_ctr_Tsss;
79.170 - val ctr_sum_prod_TsBs = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctr_TsssBs;
79.171 -
79.172 - val fp_eqs =
79.173 - map dest_TFree Bs ~~ map (Term.typ_subst_atomic (As ~~ unsorted_As)) ctr_sum_prod_TsBs;
79.174 -
79.175 - val (pre_bnfs, ((dtors0, ctors0, fp_folds0, fp_recs0, fp_induct, dtor_ctors, ctor_dtors,
79.176 - ctor_injects, fp_fold_thms, fp_rec_thms), lthy)) =
79.177 - fp_bnf construct fp_bs mixfixes (map dest_TFree unsorted_As) fp_eqs no_defs_lthy0;
79.178 -
79.179 - fun add_nesty_bnf_names Us =
79.180 - let
79.181 - fun add (Type (s, Ts)) ss =
79.182 - let val (needs, ss') = fold_map add Ts ss in
79.183 - if exists I needs then (true, insert (op =) s ss') else (false, ss')
79.184 - end
79.185 - | add T ss = (member (op =) Us T, ss);
79.186 - in snd oo add end;
79.187 -
79.188 - fun nesty_bnfs Us =
79.189 - map_filter (bnf_of lthy) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_TsssBs []);
79.190 -
79.191 - val nesting_bnfs = nesty_bnfs As;
79.192 - val nested_bnfs = nesty_bnfs Bs;
79.193 -
79.194 - val timer = time (Timer.startRealTimer ());
79.195 -
79.196 - fun mk_ctor_or_dtor get_T Ts t =
79.197 - let val Type (_, Ts0) = get_T (fastype_of t) in
79.198 - Term.subst_atomic_types (Ts0 ~~ Ts) t
79.199 - end;
79.200 -
79.201 - val mk_ctor = mk_ctor_or_dtor range_type;
79.202 - val mk_dtor = mk_ctor_or_dtor domain_type;
79.203 -
79.204 - val ctors = map (mk_ctor As) ctors0;
79.205 - val dtors = map (mk_dtor As) dtors0;
79.206 -
79.207 - val fpTs = map (domain_type o fastype_of) dtors;
79.208 -
79.209 - val exists_fp_subtype = exists_subtype (member (op =) fpTs);
79.210 -
79.211 - val ctr_Tsss = map (map (map (Term.typ_subst_atomic (Bs ~~ fpTs)))) ctr_TsssBs;
79.212 - val ns = map length ctr_Tsss;
79.213 - val kss = map (fn n => 1 upto n) ns;
79.214 - val mss = map (map length) ctr_Tsss;
79.215 - val Css = map2 replicate ns Cs;
79.216 -
79.217 - fun mk_rec_like Ts Us t =
79.218 - let
79.219 - val (bindings, body) = strip_type (fastype_of t);
79.220 - val (f_Us, prebody) = split_last bindings;
79.221 - val Type (_, Ts0) = if lfp then prebody else body;
79.222 - val Us0 = distinct (op =) (map (if lfp then body_type else domain_type) f_Us);
79.223 - in
79.224 - Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
79.225 - end;
79.226 -
79.227 - val fp_folds as fp_fold1 :: _ = map (mk_rec_like As Cs) fp_folds0;
79.228 - val fp_recs as fp_rec1 :: _ = map (mk_rec_like As Cs) fp_recs0;
79.229 -
79.230 - val fp_fold_fun_Ts = fst (split_last (binder_types (fastype_of fp_fold1)));
79.231 - val fp_rec_fun_Ts = fst (split_last (binder_types (fastype_of fp_rec1)));
79.232 -
79.233 - val (((fold_only as (gss, _, _), rec_only as (hss, _, _)),
79.234 - (zs, cs, cpss, unfold_only as ((pgss, crgsss), _), corec_only as ((phss, cshsss), _))),
79.235 - names_lthy) =
79.236 - if lfp then
79.237 - let
79.238 - val y_Tsss =
79.239 - map3 (fn n => fn ms => map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type)
79.240 - ns mss fp_fold_fun_Ts;
79.241 - val g_Tss = map2 (map2 (curry (op --->))) y_Tsss Css;
79.242 -
79.243 - val ((gss, ysss), lthy) =
79.244 - lthy
79.245 - |> mk_Freess "f" g_Tss
79.246 - ||>> mk_Freesss "x" y_Tsss;
79.247 - val yssss = map (map (map single)) ysss;
79.248 -
79.249 - fun dest_rec_prodT (T as Type (@{type_name prod}, Us as [_, U])) =
79.250 - if member (op =) Cs U then Us else [T]
79.251 - | dest_rec_prodT T = [T];
79.252 -
79.253 - val z_Tssss =
79.254 - map3 (fn n => fn ms => map2 (map dest_rec_prodT oo dest_tupleT) ms o
79.255 - dest_sumTN_balanced n o domain_type) ns mss fp_rec_fun_Ts;
79.256 - val h_Tss = map2 (map2 (fold_rev (curry (op --->)))) z_Tssss Css;
79.257 -
79.258 - val hss = map2 (map2 retype_free) h_Tss gss;
79.259 - val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
79.260 - val (zssss_tl, lthy) =
79.261 - lthy
79.262 - |> mk_Freessss "y" (map (map (map tl)) z_Tssss);
79.263 - val zssss = map2 (map2 (map2 cons)) zssss_hd zssss_tl;
79.264 - in
79.265 - ((((gss, g_Tss, yssss), (hss, h_Tss, zssss)),
79.266 - ([], [], [], (([], []), ([], [])), (([], []), ([], [])))), lthy)
79.267 - end
79.268 - else
79.269 - let
79.270 - (*avoid "'a itself" arguments in coiterators and corecursors*)
79.271 - val mss' = map (fn [0] => [1] | ms => ms) mss;
79.272 -
79.273 - val p_Tss = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs;
79.274 -
79.275 - fun zip_predss_getterss qss fss = maps (op @) (qss ~~ fss);
79.276 -
79.277 - fun zip_preds_predsss_gettersss [] [qss] [fss] = zip_predss_getterss qss fss
79.278 - | zip_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
79.279 - p :: zip_predss_getterss qss fss @ zip_preds_predsss_gettersss ps qsss fsss;
79.280 -
79.281 - fun mk_types maybe_dest_sumT fun_Ts =
79.282 - let
79.283 - val f_sum_prod_Ts = map range_type fun_Ts;
79.284 - val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
79.285 - val f_Tssss =
79.286 - map3 (fn C => map2 (map (map (curry (op -->) C) o maybe_dest_sumT) oo dest_tupleT))
79.287 - Cs mss' f_prod_Tss;
79.288 - val q_Tssss =
79.289 - map (map (map (fn [_] => [] | [_, C] => [mk_pred1T (domain_type C)]))) f_Tssss;
79.290 - val pf_Tss = map3 zip_preds_predsss_gettersss p_Tss q_Tssss f_Tssss;
79.291 - in (q_Tssss, f_sum_prod_Ts, f_Tssss, pf_Tss) end;
79.292 -
79.293 - val (r_Tssss, g_sum_prod_Ts, g_Tssss, pg_Tss) = mk_types single fp_fold_fun_Ts;
79.294 -
79.295 - val ((((Free (z, _), cs), pss), gssss), lthy) =
79.296 - lthy
79.297 - |> yield_singleton (mk_Frees "z") dummyT
79.298 - ||>> mk_Frees "a" Cs
79.299 - ||>> mk_Freess "p" p_Tss
79.300 - ||>> mk_Freessss "g" g_Tssss;
79.301 - val rssss = map (map (map (fn [] => []))) r_Tssss;
79.302 -
79.303 - fun dest_corec_sumT (T as Type (@{type_name sum}, Us as [_, U])) =
79.304 - if member (op =) Cs U then Us else [T]
79.305 - | dest_corec_sumT T = [T];
79.306 -
79.307 - val (s_Tssss, h_sum_prod_Ts, h_Tssss, ph_Tss) = mk_types dest_corec_sumT fp_rec_fun_Ts;
79.308 -
79.309 - val hssss_hd = map2 (map2 (map2 (fn T :: _ => fn [g] => retype_free T g))) h_Tssss gssss;
79.310 - val ((sssss, hssss_tl), lthy) =
79.311 - lthy
79.312 - |> mk_Freessss "q" s_Tssss
79.313 - ||>> mk_Freessss "h" (map (map (map tl)) h_Tssss);
79.314 - val hssss = map2 (map2 (map2 cons)) hssss_hd hssss_tl;
79.315 -
79.316 - val cpss = map2 (fn c => map (fn p => p $ c)) cs pss;
79.317 -
79.318 - fun mk_preds_getters_join [] [cf] = cf
79.319 - | mk_preds_getters_join [cq] [cf, cf'] =
79.320 - mk_If cq (mk_Inl (fastype_of cf') cf) (mk_Inr (fastype_of cf) cf');
79.321 -
79.322 - fun mk_terms qssss fssss =
79.323 - let
79.324 - val pfss = map3 zip_preds_predsss_gettersss pss qssss fssss;
79.325 - val cqssss = map2 (fn c => map (map (map (fn f => f $ c)))) cs qssss;
79.326 - val cfssss = map2 (fn c => map (map (map (fn f => f $ c)))) cs fssss;
79.327 - val cqfsss = map2 (map2 (map2 mk_preds_getters_join)) cqssss cfssss;
79.328 - in (pfss, cqfsss) end;
79.329 - in
79.330 - (((([], [], []), ([], [], [])),
79.331 - ([z], cs, cpss, (mk_terms rssss gssss, (g_sum_prod_Ts, pg_Tss)),
79.332 - (mk_terms sssss hssss, (h_sum_prod_Ts, ph_Tss)))), lthy)
79.333 - end;
79.334 -
79.335 - fun define_ctrs_case_for_type ((((((((((((((((((fp_b, fpT), C), ctor), dtor), fp_fold), fp_rec),
79.336 - ctor_dtor), dtor_ctor), ctor_inject), n), ks), ms), ctr_bindings), ctr_mixfixes), ctr_Tss),
79.337 - disc_bindings), sel_bindingss), raw_sel_defaultss) no_defs_lthy =
79.338 - let
79.339 - val fp_b_name = Binding.name_of fp_b;
79.340 -
79.341 - val dtorT = domain_type (fastype_of ctor);
79.342 - val ctr_prod_Ts = map HOLogic.mk_tupleT ctr_Tss;
79.343 - val ctr_sum_prod_T = mk_sumTN_balanced ctr_prod_Ts;
79.344 - val case_Ts = map (fn Ts => Ts ---> C) ctr_Tss;
79.345 -
79.346 - val ((((w, fs), xss), u'), _) =
79.347 - no_defs_lthy
79.348 - |> yield_singleton (mk_Frees "w") dtorT
79.349 - ||>> mk_Frees "f" case_Ts
79.350 - ||>> mk_Freess "x" ctr_Tss
79.351 - ||>> yield_singleton Variable.variant_fixes fp_b_name;
79.352 -
79.353 - val u = Free (u', fpT);
79.354 -
79.355 - val ctr_rhss =
79.356 - map2 (fn k => fn xs => fold_rev Term.lambda xs (ctor $
79.357 - mk_InN_balanced ctr_sum_prod_T n (HOLogic.mk_tuple xs) k)) ks xss;
79.358 -
79.359 - val case_binding = Binding.suffix_name ("_" ^ caseN) fp_b;
79.360 -
79.361 - val case_rhs =
79.362 - fold_rev Term.lambda (fs @ [u])
79.363 - (mk_sum_caseN_balanced (map2 mk_uncurried_fun fs xss) $ (dtor $ u));
79.364 -
79.365 - val ((raw_case :: raw_ctrs, raw_case_def :: raw_ctr_defs), (lthy', lthy)) = no_defs_lthy
79.366 - |> apfst split_list o fold_map3 (fn b => fn mx => fn rhs =>
79.367 - Local_Theory.define ((b, mx), ((Thm.def_binding b, []), rhs)) #>> apsnd snd)
79.368 - (case_binding :: ctr_bindings) (NoSyn :: ctr_mixfixes) (case_rhs :: ctr_rhss)
79.369 - ||> `Local_Theory.restore;
79.370 -
79.371 - val phi = Proof_Context.export_morphism lthy lthy';
79.372 -
79.373 - val ctr_defs = map (Morphism.thm phi) raw_ctr_defs;
79.374 - val case_def = Morphism.thm phi raw_case_def;
79.375 -
79.376 - val ctrs0 = map (Morphism.term phi) raw_ctrs;
79.377 - val casex0 = Morphism.term phi raw_case;
79.378 -
79.379 - val ctrs = map (mk_ctr As) ctrs0;
79.380 -
79.381 - fun exhaust_tac {context = ctxt, ...} =
79.382 - let
79.383 - val ctor_iff_dtor_thm =
79.384 - let
79.385 - val goal =
79.386 - fold_rev Logic.all [w, u]
79.387 - (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w)));
79.388 - in
79.389 - Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
79.390 - mk_ctor_iff_dtor_tac ctxt (map (SOME o certifyT lthy) [dtorT, fpT])
79.391 - (certify lthy ctor) (certify lthy dtor) ctor_dtor dtor_ctor)
79.392 - |> Thm.close_derivation
79.393 - |> Morphism.thm phi
79.394 - end;
79.395 -
79.396 - val sumEN_thm' =
79.397 - unfold_thms lthy @{thms all_unit_eq}
79.398 - (Drule.instantiate' (map (SOME o certifyT lthy) ctr_prod_Ts) []
79.399 - (mk_sumEN_balanced n))
79.400 - |> Morphism.thm phi;
79.401 - in
79.402 - mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'
79.403 - end;
79.404 -
79.405 - val inject_tacss =
79.406 - map2 (fn 0 => K [] | _ => fn ctr_def => [fn {context = ctxt, ...} =>
79.407 - mk_inject_tac ctxt ctr_def ctor_inject]) ms ctr_defs;
79.408 -
79.409 - val half_distinct_tacss =
79.410 - map (map (fn (def, def') => fn {context = ctxt, ...} =>
79.411 - mk_half_distinct_tac ctxt ctor_inject [def, def'])) (mk_half_pairss ctr_defs);
79.412 -
79.413 - val case_tacs =
79.414 - map3 (fn k => fn m => fn ctr_def => fn {context = ctxt, ...} =>
79.415 - mk_case_tac ctxt n k m case_def ctr_def dtor_ctor) ks ms ctr_defs;
79.416 -
79.417 - val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss @ [case_tacs];
79.418 -
79.419 - fun define_fold_rec (wrap_res, no_defs_lthy) =
79.420 - let
79.421 - val fpT_to_C = fpT --> C;
79.422 -
79.423 - fun generate_rec_like (suf, fp_rec_like, (fss, f_Tss, xssss)) =
79.424 - let
79.425 - val res_T = fold_rev (curry (op --->)) f_Tss fpT_to_C;
79.426 - val binding = Binding.suffix_name ("_" ^ suf) fp_b;
79.427 - val spec =
79.428 - mk_Trueprop_eq (lists_bmoc fss (Free (Binding.name_of binding, res_T)),
79.429 - Term.list_comb (fp_rec_like,
79.430 - map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss));
79.431 - in (binding, spec) end;
79.432 -
79.433 - val rec_like_infos =
79.434 - [(foldN, fp_fold, fold_only),
79.435 - (recN, fp_rec, rec_only)];
79.436 -
79.437 - val (bindings, specs) = map generate_rec_like rec_like_infos |> split_list;
79.438 -
79.439 - val ((csts, defs), (lthy', lthy)) = no_defs_lthy
79.440 - |> apfst split_list o fold_map2 (fn b => fn spec =>
79.441 - Specification.definition (SOME (b, NONE, NoSyn), ((Thm.def_binding b, []), spec))
79.442 - #>> apsnd snd) bindings specs
79.443 - ||> `Local_Theory.restore;
79.444 -
79.445 - val phi = Proof_Context.export_morphism lthy lthy';
79.446 -
79.447 - val [fold_def, rec_def] = map (Morphism.thm phi) defs;
79.448 -
79.449 - val [foldx, recx] = map (mk_rec_like As Cs o Morphism.term phi) csts;
79.450 - in
79.451 - ((wrap_res, ctrs, foldx, recx, xss, ctr_defs, fold_def, rec_def), lthy)
79.452 - end;
79.453 -
79.454 - fun define_unfold_corec (wrap_res, no_defs_lthy) =
79.455 - let
79.456 - val B_to_fpT = C --> fpT;
79.457 -
79.458 - fun mk_preds_getterss_join c n cps sum_prod_T cqfss =
79.459 - Term.lambda c (mk_IfN sum_prod_T cps
79.460 - (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)));
79.461 -
79.462 - fun generate_corec_like (suf, fp_rec_like, ((pfss, cqfsss), (f_sum_prod_Ts,
79.463 - pf_Tss))) =
79.464 - let
79.465 - val res_T = fold_rev (curry (op --->)) pf_Tss B_to_fpT;
79.466 - val binding = Binding.suffix_name ("_" ^ suf) fp_b;
79.467 - val spec =
79.468 - mk_Trueprop_eq (lists_bmoc pfss (Free (Binding.name_of binding, res_T)),
79.469 - Term.list_comb (fp_rec_like,
79.470 - map5 mk_preds_getterss_join cs ns cpss f_sum_prod_Ts cqfsss));
79.471 - in (binding, spec) end;
79.472 -
79.473 - val corec_like_infos =
79.474 - [(unfoldN, fp_fold, unfold_only),
79.475 - (corecN, fp_rec, corec_only)];
79.476 -
79.477 - val (bindings, specs) = map generate_corec_like corec_like_infos |> split_list;
79.478 -
79.479 - val ((csts, defs), (lthy', lthy)) = no_defs_lthy
79.480 - |> apfst split_list o fold_map2 (fn b => fn spec =>
79.481 - Specification.definition (SOME (b, NONE, NoSyn), ((Thm.def_binding b, []), spec))
79.482 - #>> apsnd snd) bindings specs
79.483 - ||> `Local_Theory.restore;
79.484 -
79.485 - val phi = Proof_Context.export_morphism lthy lthy';
79.486 -
79.487 - val [unfold_def, corec_def] = map (Morphism.thm phi) defs;
79.488 -
79.489 - val [unfold, corec] = map (mk_rec_like As Cs o Morphism.term phi) csts;
79.490 - in
79.491 - ((wrap_res, ctrs, unfold, corec, xss, ctr_defs, unfold_def, corec_def), lthy)
79.492 - end;
79.493 -
79.494 - fun wrap lthy =
79.495 - let val sel_defaultss = map (map (apsnd (prepare_term lthy))) raw_sel_defaultss in
79.496 - wrap_datatype tacss (((no_dests, ctrs0), casex0), (disc_bindings, (sel_bindingss,
79.497 - sel_defaultss))) lthy
79.498 - end;
79.499 -
79.500 - val define_rec_likes = if lfp then define_fold_rec else define_unfold_corec;
79.501 - in
79.502 - ((wrap, define_rec_likes), lthy')
79.503 - end;
79.504 -
79.505 - val pre_map_defs = map map_def_of_bnf pre_bnfs;
79.506 - val pre_set_defss = map set_defs_of_bnf pre_bnfs;
79.507 - val nested_set_natural's = maps set_natural'_of_bnf nested_bnfs;
79.508 - val nesting_map_ids = map map_id_of_bnf nesting_bnfs;
79.509 -
79.510 - fun mk_map live Ts Us t =
79.511 - let
79.512 - val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last
79.513 - in
79.514 - Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
79.515 - end;
79.516 -
79.517 - fun build_map build_arg (Type (s, Ts)) (Type (_, Us)) =
79.518 - let
79.519 - val bnf = the (bnf_of lthy s);
79.520 - val live = live_of_bnf bnf;
79.521 - val mapx = mk_map live Ts Us (map_of_bnf bnf);
79.522 - val TUs = map dest_funT (fst (strip_typeN live (fastype_of mapx)));
79.523 - val args = map build_arg TUs;
79.524 - in Term.list_comb (mapx, args) end;
79.525 -
79.526 - val mk_simp_thmss =
79.527 - map3 (fn (_, _, injects, distincts, cases, _, _, _) => fn rec_likes => fn fold_likes =>
79.528 - injects @ distincts @ cases @ rec_likes @ fold_likes);
79.529 -
79.530 - fun derive_induct_fold_rec_thms_for_types ((wrap_ress, ctrss, folds, recs, xsss, ctr_defss,
79.531 - fold_defs, rec_defs), lthy) =
79.532 - let
79.533 - val (((phis, phis'), us'), names_lthy) =
79.534 - lthy
79.535 - |> mk_Frees' "P" (map mk_pred1T fpTs)
79.536 - ||>> Variable.variant_fixes fp_b_names;
79.537 -
79.538 - val us = map2 (curry Free) us' fpTs;
79.539 -
79.540 - fun mk_sets_nested bnf =
79.541 - let
79.542 - val Type (T_name, Us) = T_of_bnf bnf;
79.543 - val lives = lives_of_bnf bnf;
79.544 - val sets = sets_of_bnf bnf;
79.545 - fun mk_set U =
79.546 - (case find_index (curry (op =) U) lives of
79.547 - ~1 => Term.dummy
79.548 - | i => nth sets i);
79.549 - in
79.550 - (T_name, map mk_set Us)
79.551 - end;
79.552 -
79.553 - val setss_nested = map mk_sets_nested nested_bnfs;
79.554 -
79.555 - val (induct_thms, induct_thm) =
79.556 - let
79.557 - fun mk_set Ts t =
79.558 - let val Type (_, Ts0) = domain_type (fastype_of t) in
79.559 - Term.subst_atomic_types (Ts0 ~~ Ts) t
79.560 - end;
79.561 -
79.562 - fun mk_raw_prem_prems names_lthy (x as Free (s, T as Type (T_name, Ts0))) =
79.563 - (case find_index (curry (op =) T) fpTs of
79.564 - ~1 =>
79.565 - (case AList.lookup (op =) setss_nested T_name of
79.566 - NONE => []
79.567 - | SOME raw_sets0 =>
79.568 - let
79.569 - val (Ts, raw_sets) =
79.570 - split_list (filter (exists_fp_subtype o fst) (Ts0 ~~ raw_sets0));
79.571 - val sets = map (mk_set Ts0) raw_sets;
79.572 - val (ys, names_lthy') = names_lthy |> mk_Frees s Ts;
79.573 - val xysets = map (pair x) (ys ~~ sets);
79.574 - val ppremss = map (mk_raw_prem_prems names_lthy') ys;
79.575 - in
79.576 - flat (map2 (map o apfst o cons) xysets ppremss)
79.577 - end)
79.578 - | i => [([], (i + 1, x))])
79.579 - | mk_raw_prem_prems _ _ = [];
79.580 -
79.581 - fun close_prem_prem xs t =
79.582 - fold_rev Logic.all (map Free (drop (nn + length xs)
79.583 - (rev (Term.add_frees t (map dest_Free xs @ phis'))))) t;
79.584 -
79.585 - fun mk_prem_prem xs (xysets, (j, x)) =
79.586 - close_prem_prem xs (Logic.list_implies (map (fn (x', (y, set)) =>
79.587 - HOLogic.mk_Trueprop (HOLogic.mk_mem (y, set $ x'))) xysets,
79.588 - HOLogic.mk_Trueprop (nth phis (j - 1) $ x)));
79.589 -
79.590 - fun mk_raw_prem phi ctr ctr_Ts =
79.591 - let
79.592 - val (xs, names_lthy') = names_lthy |> mk_Frees "x" ctr_Ts;
79.593 - val pprems = maps (mk_raw_prem_prems names_lthy') xs;
79.594 - in (xs, pprems, HOLogic.mk_Trueprop (phi $ Term.list_comb (ctr, xs))) end;
79.595 -
79.596 - fun mk_prem (xs, raw_pprems, concl) =
79.597 - fold_rev Logic.all xs (Logic.list_implies (map (mk_prem_prem xs) raw_pprems, concl));
79.598 -
79.599 - val raw_premss = map3 (map2 o mk_raw_prem) phis ctrss ctr_Tsss;
79.600 -
79.601 - val goal =
79.602 - Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
79.603 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) phis us)));
79.604 -
79.605 - val kksss = map (map (map (fst o snd) o #2)) raw_premss;
79.606 -
79.607 - val ctor_induct' = fp_induct OF (map mk_sumEN_tupled_balanced mss);
79.608 -
79.609 - val induct_thm =
79.610 - Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
79.611 - mk_induct_tac ctxt ns mss kksss (flat ctr_defss) ctor_induct'
79.612 - nested_set_natural's pre_set_defss)
79.613 - |> singleton (Proof_Context.export names_lthy lthy)
79.614 - in
79.615 - `(conj_dests nn) induct_thm
79.616 - end;
79.617 -
79.618 - (* TODO: Generate nicer names in case of clashes *)
79.619 - val induct_cases = Datatype_Prop.indexify_names (maps (map base_name_of_ctr) ctrss);
79.620 -
79.621 - val (fold_thmss, rec_thmss) =
79.622 - let
79.623 - val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss;
79.624 - val gfolds = map (lists_bmoc gss) folds;
79.625 - val hrecs = map (lists_bmoc hss) recs;
79.626 -
79.627 - fun mk_goal fss frec_like xctr f xs fxs =
79.628 - fold_rev (fold_rev Logic.all) (xs :: fss)
79.629 - (mk_Trueprop_eq (frec_like $ xctr, Term.list_comb (f, fxs)));
79.630 -
79.631 - fun build_call frec_likes maybe_tick (T, U) =
79.632 - if T = U then
79.633 - id_const T
79.634 - else
79.635 - (case find_index (curry (op =) T) fpTs of
79.636 - ~1 => build_map (build_call frec_likes maybe_tick) T U
79.637 - | j => maybe_tick (nth us j) (nth frec_likes j));
79.638 -
79.639 - fun mk_U maybe_mk_prodT =
79.640 - typ_subst (map2 (fn fpT => fn C => (fpT, maybe_mk_prodT fpT C)) fpTs Cs);
79.641 -
79.642 - fun intr_calls frec_likes maybe_cons maybe_tick maybe_mk_prodT (x as Free (_, T)) =
79.643 - if member (op =) fpTs T then
79.644 - maybe_cons x [build_call frec_likes (K I) (T, mk_U (K I) T) $ x]
79.645 - else if exists_fp_subtype T then
79.646 - [build_call frec_likes maybe_tick (T, mk_U maybe_mk_prodT T) $ x]
79.647 - else
79.648 - [x];
79.649 -
79.650 - val gxsss = map (map (maps (intr_calls gfolds (K I) (K I) (K I)))) xsss;
79.651 - val hxsss = map (map (maps (intr_calls hrecs cons tick (curry HOLogic.mk_prodT)))) xsss;
79.652 -
79.653 - val fold_goalss = map5 (map4 o mk_goal gss) gfolds xctrss gss xsss gxsss;
79.654 - val rec_goalss = map5 (map4 o mk_goal hss) hrecs xctrss hss xsss hxsss;
79.655 -
79.656 - val fold_tacss =
79.657 - map2 (map o mk_rec_like_tac pre_map_defs nesting_map_ids fold_defs) fp_fold_thms
79.658 - ctr_defss;
79.659 - val rec_tacss =
79.660 - map2 (map o mk_rec_like_tac pre_map_defs nesting_map_ids rec_defs) fp_rec_thms
79.661 - ctr_defss;
79.662 -
79.663 - fun prove goal tac = Skip_Proof.prove lthy [] [] goal (tac o #context);
79.664 - in
79.665 - (map2 (map2 prove) fold_goalss fold_tacss,
79.666 - map2 (map2 prove) rec_goalss rec_tacss)
79.667 - end;
79.668 -
79.669 - val simp_thmss = mk_simp_thmss wrap_ress rec_thmss fold_thmss;
79.670 -
79.671 - val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases));
79.672 - fun induct_type_attr T_name = Attrib.internal (K (Induct.induct_type T_name));
79.673 -
79.674 - (* TODO: Also note "recs", "simps", and "splits" if "nn > 1" (for compatibility with the
79.675 - old package)? And for codatatypes as well? *)
79.676 - val common_notes =
79.677 - (if nn > 1 then [(inductN, [induct_thm], [induct_case_names_attr])] else [])
79.678 - |> map (fn (thmN, thms, attrs) =>
79.679 - ((Binding.qualify true fp_common_name (Binding.name thmN), attrs), [(thms, [])]));
79.680 -
79.681 - val notes =
79.682 - [(inductN, map single induct_thms,
79.683 - fn T_name => [induct_case_names_attr, induct_type_attr T_name]),
79.684 - (foldsN, fold_thmss, K (Code.add_default_eqn_attrib :: simp_attrs)),
79.685 - (recsN, rec_thmss, K (Code.add_default_eqn_attrib :: simp_attrs)),
79.686 - (simpsN, simp_thmss, K [])]
79.687 - |> maps (fn (thmN, thmss, attrs) =>
79.688 - map3 (fn b => fn Type (T_name, _) => fn thms =>
79.689 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), attrs T_name),
79.690 - [(thms, [])])) fp_bs fpTs thmss);
79.691 - in
79.692 - lthy |> Local_Theory.notes (common_notes @ notes) |> snd
79.693 - end;
79.694 -
79.695 - fun derive_coinduct_unfold_corec_thms_for_types ((wrap_ress, ctrss, unfolds, corecs, _,
79.696 - ctr_defss, unfold_defs, corec_defs), lthy) =
79.697 - let
79.698 - val discss = map (map (mk_disc_or_sel As) o #1) wrap_ress;
79.699 - val selsss = map #2 wrap_ress;
79.700 - val disc_thmsss = map #6 wrap_ress;
79.701 - val discIss = map #7 wrap_ress;
79.702 - val sel_thmsss = map #8 wrap_ress;
79.703 -
79.704 - val (us', _) =
79.705 - lthy
79.706 - |> Variable.variant_fixes fp_b_names;
79.707 -
79.708 - val us = map2 (curry Free) us' fpTs;
79.709 -
79.710 - val (coinduct_thms, coinduct_thm) =
79.711 - let
79.712 - val coinduct_thm = fp_induct;
79.713 - in
79.714 - `(conj_dests nn) coinduct_thm
79.715 - end;
79.716 -
79.717 - fun mk_maybe_not pos = not pos ? HOLogic.mk_not;
79.718 -
79.719 - val z = the_single zs;
79.720 - val gunfolds = map (lists_bmoc pgss) unfolds;
79.721 - val hcorecs = map (lists_bmoc phss) corecs;
79.722 -
79.723 - val (unfold_thmss, corec_thmss, safe_unfold_thmss, safe_corec_thmss) =
79.724 - let
79.725 - fun mk_goal pfss c cps fcorec_like n k ctr m cfs' =
79.726 - fold_rev (fold_rev Logic.all) ([c] :: pfss)
79.727 - (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps,
79.728 - mk_Trueprop_eq (fcorec_like $ c, Term.list_comb (ctr, take m cfs'))));
79.729 -
79.730 - fun build_call frec_likes maybe_tack (T, U) =
79.731 - if T = U then
79.732 - id_const T
79.733 - else
79.734 - (case find_index (curry (op =) U) fpTs of
79.735 - ~1 => build_map (build_call frec_likes maybe_tack) T U
79.736 - | j => maybe_tack (nth cs j, nth us j) (nth frec_likes j));
79.737 -
79.738 - fun mk_U maybe_mk_sumT =
79.739 - typ_subst (map2 (fn C => fn fpT => (maybe_mk_sumT fpT C, fpT)) Cs fpTs);
79.740 -
79.741 - fun intr_calls frec_likes maybe_mk_sumT maybe_tack cqf =
79.742 - let val T = fastype_of cqf in
79.743 - if exists_subtype (member (op =) Cs) T then
79.744 - build_call frec_likes maybe_tack (T, mk_U maybe_mk_sumT T) $ cqf
79.745 - else
79.746 - cqf
79.747 - end;
79.748 -
79.749 - val crgsss' = map (map (map (intr_calls gunfolds (K I) (K I)))) crgsss;
79.750 - val cshsss' = map (map (map (intr_calls hcorecs (curry mk_sumT) (tack z)))) cshsss;
79.751 -
79.752 - val unfold_goalss =
79.753 - map8 (map4 oooo mk_goal pgss) cs cpss gunfolds ns kss ctrss mss crgsss';
79.754 - val corec_goalss =
79.755 - map8 (map4 oooo mk_goal phss) cs cpss hcorecs ns kss ctrss mss cshsss';
79.756 -
79.757 - val unfold_tacss =
79.758 - map3 (map oo mk_corec_like_tac unfold_defs nesting_map_ids) fp_fold_thms pre_map_defs
79.759 - ctr_defss;
79.760 - val corec_tacss =
79.761 - map3 (map oo mk_corec_like_tac corec_defs nesting_map_ids) fp_rec_thms pre_map_defs
79.762 - ctr_defss;
79.763 -
79.764 - fun prove goal tac =
79.765 - Skip_Proof.prove lthy [] [] goal (tac o #context) |> Thm.close_derivation;
79.766 -
79.767 - val unfold_thmss = map2 (map2 prove) unfold_goalss unfold_tacss;
79.768 - val corec_thmss =
79.769 - map2 (map2 prove) corec_goalss corec_tacss
79.770 - |> map (map (unfold_thms lthy @{thms sum_case_if}));
79.771 -
79.772 - val unfold_safesss = map2 (map2 (map2 (curry (op =)))) crgsss' crgsss;
79.773 - val corec_safesss = map2 (map2 (map2 (curry (op =)))) cshsss' cshsss;
79.774 -
79.775 - val filter_safesss =
79.776 - map2 (map_filter (fn (safes, thm) => if forall I safes then SOME thm else NONE) oo
79.777 - curry (op ~~));
79.778 -
79.779 - val safe_unfold_thmss = filter_safesss unfold_safesss unfold_thmss;
79.780 - val safe_corec_thmss = filter_safesss corec_safesss corec_thmss;
79.781 - in
79.782 - (unfold_thmss, corec_thmss, safe_unfold_thmss, safe_corec_thmss)
79.783 - end;
79.784 -
79.785 - val (disc_unfold_iff_thmss, disc_corec_iff_thmss) =
79.786 - let
79.787 - fun mk_goal c cps fcorec_like n k disc =
79.788 - mk_Trueprop_eq (disc $ (fcorec_like $ c),
79.789 - if n = 1 then @{const True}
79.790 - else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps));
79.791 -
79.792 - val unfold_goalss = map6 (map2 oooo mk_goal) cs cpss gunfolds ns kss discss;
79.793 - val corec_goalss = map6 (map2 oooo mk_goal) cs cpss hcorecs ns kss discss;
79.794 -
79.795 - fun mk_case_split' cp =
79.796 - Drule.instantiate' [] [SOME (certify lthy cp)] @{thm case_split};
79.797 -
79.798 - val case_splitss' = map (map mk_case_split') cpss;
79.799 -
79.800 - val unfold_tacss =
79.801 - map3 (map oo mk_disc_corec_like_iff_tac) case_splitss' unfold_thmss disc_thmsss;
79.802 - val corec_tacss =
79.803 - map3 (map oo mk_disc_corec_like_iff_tac) case_splitss' corec_thmss disc_thmsss;
79.804 -
79.805 - fun prove goal tac =
79.806 - Skip_Proof.prove lthy [] [] goal (tac o #context)
79.807 - |> Thm.close_derivation
79.808 - |> singleton (Proof_Context.export names_lthy no_defs_lthy);
79.809 -
79.810 - fun proves [_] [_] = []
79.811 - | proves goals tacs = map2 prove goals tacs;
79.812 - in
79.813 - (map2 proves unfold_goalss unfold_tacss,
79.814 - map2 proves corec_goalss corec_tacss)
79.815 - end;
79.816 -
79.817 - fun mk_disc_corec_like_thms corec_likes discIs =
79.818 - map (op RS) (filter_out (is_triv_implies o snd) (corec_likes ~~ discIs));
79.819 -
79.820 - val disc_unfold_thmss = map2 mk_disc_corec_like_thms unfold_thmss discIss;
79.821 - val disc_corec_thmss = map2 mk_disc_corec_like_thms corec_thmss discIss;
79.822 -
79.823 - fun mk_sel_corec_like_thm corec_like_thm sel sel_thm =
79.824 - let
79.825 - val (domT, ranT) = dest_funT (fastype_of sel);
79.826 - val arg_cong' =
79.827 - Drule.instantiate' (map (SOME o certifyT lthy) [domT, ranT])
79.828 - [NONE, NONE, SOME (certify lthy sel)] arg_cong
79.829 - |> Thm.varifyT_global;
79.830 - val sel_thm' = sel_thm RSN (2, trans);
79.831 - in
79.832 - corec_like_thm RS arg_cong' RS sel_thm'
79.833 - end;
79.834 -
79.835 - fun mk_sel_corec_like_thms corec_likess =
79.836 - map3 (map3 (map2 o mk_sel_corec_like_thm)) corec_likess selsss sel_thmsss |> map flat;
79.837 -
79.838 - val sel_unfold_thmss = mk_sel_corec_like_thms unfold_thmss;
79.839 - val sel_corec_thmss = mk_sel_corec_like_thms corec_thmss;
79.840 -
79.841 - fun zip_corec_like_thms corec_likes disc_corec_likes sel_corec_likes =
79.842 - corec_likes @ disc_corec_likes @ sel_corec_likes;
79.843 -
79.844 - val simp_thmss =
79.845 - mk_simp_thmss wrap_ress
79.846 - (map3 zip_corec_like_thms safe_corec_thmss disc_corec_thmss sel_corec_thmss)
79.847 - (map3 zip_corec_like_thms safe_unfold_thmss disc_unfold_thmss sel_unfold_thmss);
79.848 -
79.849 - val anonymous_notes =
79.850 - [(flat safe_unfold_thmss @ flat safe_corec_thmss, simp_attrs)]
79.851 - |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
79.852 -
79.853 - val common_notes =
79.854 - (if nn > 1 then [(coinductN, [coinduct_thm], [])] (* FIXME: attribs *) else [])
79.855 - |> map (fn (thmN, thms, attrs) =>
79.856 - ((Binding.qualify true fp_common_name (Binding.name thmN), attrs), [(thms, [])]));
79.857 -
79.858 - val notes =
79.859 - [(coinductN, map single coinduct_thms, []), (* FIXME: attribs *)
79.860 - (unfoldsN, unfold_thmss, []),
79.861 - (corecsN, corec_thmss, []),
79.862 - (disc_unfold_iffN, disc_unfold_iff_thmss, simp_attrs),
79.863 - (disc_unfoldsN, disc_unfold_thmss, simp_attrs),
79.864 - (disc_corec_iffN, disc_corec_iff_thmss, simp_attrs),
79.865 - (disc_corecsN, disc_corec_thmss, simp_attrs),
79.866 - (sel_unfoldsN, sel_unfold_thmss, simp_attrs),
79.867 - (sel_corecsN, sel_corec_thmss, simp_attrs),
79.868 - (simpsN, simp_thmss, [])]
79.869 - |> maps (fn (thmN, thmss, attrs) =>
79.870 - map_filter (fn (_, []) => NONE | (b, thms) =>
79.871 - SOME ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), attrs),
79.872 - [(thms, [])])) (fp_bs ~~ thmss));
79.873 - in
79.874 - lthy |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |> snd
79.875 - end;
79.876 -
79.877 - fun wrap_types_and_define_rec_likes ((wraps, define_rec_likess), lthy) =
79.878 - fold_map2 (curry (op o)) define_rec_likess wraps lthy |>> split_list8
79.879 -
79.880 - val lthy' = lthy
79.881 - |> fold_map define_ctrs_case_for_type (fp_bs ~~ fpTs ~~ Cs ~~ ctors ~~ dtors ~~ fp_folds ~~
79.882 - fp_recs ~~ ctor_dtors ~~ dtor_ctors ~~ ctor_injects ~~ ns ~~ kss ~~ mss ~~ ctr_bindingss ~~
79.883 - ctr_mixfixess ~~ ctr_Tsss ~~ disc_bindingss ~~ sel_bindingsss ~~ raw_sel_defaultsss)
79.884 - |>> split_list |> wrap_types_and_define_rec_likes
79.885 - |> (if lfp then derive_induct_fold_rec_thms_for_types
79.886 - else derive_coinduct_unfold_corec_thms_for_types);
79.887 -
79.888 - val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^
79.889 - (if lfp then "" else "co") ^ "datatype"));
79.890 - in
79.891 - timer; lthy'
79.892 - end;
79.893 -
79.894 -val datatyp = define_datatype (K I) (K I) (K I);
79.895 -
79.896 -val datatype_cmd = define_datatype Typedecl.read_constraint Syntax.parse_typ Syntax.read_term;
79.897 -
79.898 -val parse_ctr_arg =
79.899 - @{keyword "("} |-- parse_binding_colon -- Parse.typ --| @{keyword ")"} ||
79.900 - (Parse.typ >> pair Binding.empty);
79.901 -
79.902 -val parse_defaults =
79.903 - @{keyword "("} |-- @{keyword "defaults"} |-- Scan.repeat parse_bound_term --| @{keyword ")"};
79.904 -
79.905 -val parse_single_spec =
79.906 - Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix --
79.907 - (@{keyword "="} |-- Parse.enum1 "|" (parse_opt_binding_colon -- Parse.binding --
79.908 - Scan.repeat parse_ctr_arg -- Scan.optional parse_defaults [] -- Parse.opt_mixfix));
79.909 -
79.910 -val parse_datatype = parse_wrap_options -- Parse.and_list1 parse_single_spec;
79.911 -
79.912 -fun parse_datatype_cmd lfp construct = parse_datatype >> datatype_cmd lfp construct;
79.913 -
79.914 -end;
80.1 --- a/src/HOL/Codatatype/Tools/bnf_fp_sugar_tactics.ML Fri Sep 21 16:34:40 2012 +0200
80.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
80.3 @@ -1,133 +0,0 @@
80.4 -(* Title: HOL/BNF/Tools/bnf_fp_sugar_tactics.ML
80.5 - Author: Jasmin Blanchette, TU Muenchen
80.6 - Copyright 2012
80.7 -
80.8 -Tactics for datatype and codatatype sugar.
80.9 -*)
80.10 -
80.11 -signature BNF_FP_SUGAR_TACTICS =
80.12 -sig
80.13 - val mk_case_tac: Proof.context -> int -> int -> int -> thm -> thm -> thm -> tactic
80.14 - val mk_corec_like_tac: thm list -> thm list -> thm -> thm -> thm -> Proof.context -> tactic
80.15 - val mk_ctor_iff_dtor_tac: Proof.context -> ctyp option list -> cterm -> cterm -> thm -> thm ->
80.16 - tactic
80.17 - val mk_disc_corec_like_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic
80.18 - val mk_exhaust_tac: Proof.context -> int -> thm list -> thm -> thm -> tactic
80.19 - val mk_half_distinct_tac: Proof.context -> thm -> thm list -> tactic
80.20 - val mk_induct_tac: Proof.context -> int list -> int list list -> int list list list -> thm list ->
80.21 - thm -> thm list -> thm list list -> tactic
80.22 - val mk_inject_tac: Proof.context -> thm -> thm -> tactic
80.23 - val mk_rec_like_tac: thm list -> thm list -> thm list -> thm -> thm -> Proof.context -> tactic
80.24 -end;
80.25 -
80.26 -structure BNF_FP_Sugar_Tactics : BNF_FP_SUGAR_TACTICS =
80.27 -struct
80.28 -
80.29 -open BNF_Tactics
80.30 -open BNF_Util
80.31 -open BNF_FP
80.32 -
80.33 -val meta_mp = @{thm meta_mp};
80.34 -val meta_spec = @{thm meta_spec};
80.35 -
80.36 -fun inst_spurious_fs lthy thm =
80.37 - let
80.38 - val fs =
80.39 - Term.add_vars (prop_of thm) []
80.40 - |> filter (fn (_, Type (@{type_name fun}, [_, T'])) => T' <> HOLogic.boolT | _ => false);
80.41 - val cfs =
80.42 - map (fn f as (_, T) => (certify lthy (Var f), certify lthy (id_abs (domain_type T)))) fs;
80.43 - in
80.44 - Drule.cterm_instantiate cfs thm
80.45 - end;
80.46 -
80.47 -val inst_spurious_fs_tac = PRIMITIVE o inst_spurious_fs;
80.48 -
80.49 -fun mk_case_tac ctxt n k m case_def ctr_def dtor_ctor =
80.50 - unfold_thms_tac ctxt [case_def, ctr_def, dtor_ctor] THEN
80.51 - (rtac (mk_sum_casesN_balanced n k RS ssubst) THEN'
80.52 - REPEAT_DETERM_N (Int.max (0, m - 1)) o rtac (@{thm split} RS ssubst) THEN'
80.53 - rtac refl) 1;
80.54 -
80.55 -fun mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor sumEN' =
80.56 - unfold_thms_tac ctxt (ctor_iff_dtor :: ctr_defs) THEN rtac sumEN' 1 THEN
80.57 - unfold_thms_tac ctxt @{thms all_prod_eq} THEN
80.58 - EVERY' (maps (fn k => [select_prem_tac n (rotate_tac 1) k, REPEAT_DETERM o dtac meta_spec,
80.59 - etac meta_mp, atac]) (1 upto n)) 1;
80.60 -
80.61 -fun mk_ctor_iff_dtor_tac ctxt cTs cctor cdtor ctor_dtor dtor_ctor =
80.62 - (rtac iffI THEN'
80.63 - EVERY' (map3 (fn cTs => fn cx => fn th =>
80.64 - dtac (Drule.instantiate' cTs [NONE, NONE, SOME cx] arg_cong) THEN'
80.65 - SELECT_GOAL (unfold_thms_tac ctxt [th]) THEN'
80.66 - atac) [rev cTs, cTs] [cdtor, cctor] [dtor_ctor, ctor_dtor])) 1;
80.67 -
80.68 -fun mk_half_distinct_tac ctxt ctor_inject ctr_defs =
80.69 - unfold_thms_tac ctxt (ctor_inject :: @{thms sum.inject} @ ctr_defs) THEN
80.70 - rtac @{thm sum.distinct(1)} 1;
80.71 -
80.72 -fun mk_inject_tac ctxt ctr_def ctor_inject =
80.73 - unfold_thms_tac ctxt [ctr_def] THEN rtac (ctor_inject RS ssubst) 1 THEN
80.74 - unfold_thms_tac ctxt @{thms sum.inject Pair_eq conj_assoc} THEN rtac refl 1;
80.75 -
80.76 -val rec_like_unfold_thms =
80.77 - @{thms case_unit comp_def convol_def id_apply map_pair_def sum.simps(5,6) sum_map.simps
80.78 - split_conv};
80.79 -
80.80 -fun mk_rec_like_tac pre_map_defs map_ids rec_like_defs ctor_rec_like ctr_def ctxt =
80.81 - unfold_thms_tac ctxt (ctr_def :: ctor_rec_like :: rec_like_defs @ pre_map_defs @ map_ids @
80.82 - rec_like_unfold_thms) THEN unfold_thms_tac ctxt @{thms id_def} THEN rtac refl 1;
80.83 -
80.84 -val corec_like_ss = ss_only @{thms if_True if_False};
80.85 -val corec_like_unfold_thms = @{thms id_apply map_pair_def sum_map.simps prod.cases};
80.86 -
80.87 -fun mk_corec_like_tac corec_like_defs map_ids ctor_dtor_corec_like pre_map_def ctr_def ctxt =
80.88 - unfold_thms_tac ctxt (ctr_def :: corec_like_defs) THEN
80.89 - subst_tac ctxt [ctor_dtor_corec_like] 1 THEN asm_simp_tac corec_like_ss 1 THEN
80.90 - unfold_thms_tac ctxt (pre_map_def :: corec_like_unfold_thms @ map_ids) THEN
80.91 - unfold_thms_tac ctxt @{thms id_def} THEN
80.92 - TRY ((rtac refl ORELSE' subst_tac ctxt @{thms unit_eq} THEN' rtac refl) 1);
80.93 -
80.94 -fun mk_disc_corec_like_iff_tac case_splits' corec_likes discs ctxt =
80.95 - EVERY (map3 (fn case_split_tac => fn corec_like_thm => fn disc =>
80.96 - case_split_tac 1 THEN unfold_thms_tac ctxt [corec_like_thm] THEN
80.97 - asm_simp_tac (ss_only @{thms simp_thms(7,8,12,14,22,24)}) 1 THEN
80.98 - (if is_refl disc then all_tac else rtac disc 1))
80.99 - (map rtac case_splits' @ [K all_tac]) corec_likes discs);
80.100 -
80.101 -val solve_prem_prem_tac =
80.102 - REPEAT o (eresolve_tac @{thms bexE rev_bexI} ORELSE' rtac @{thm rev_bexI[OF UNIV_I]} ORELSE'
80.103 - hyp_subst_tac ORELSE' resolve_tac @{thms disjI1 disjI2}) THEN'
80.104 - (rtac refl ORELSE' atac ORELSE' rtac @{thm singletonI});
80.105 -
80.106 -val induct_prem_prem_thms =
80.107 - @{thms SUP_empty Sup_empty Sup_insert UN_insert Un_empty_left Un_empty_right Un_iff
80.108 - Union_Un_distrib collect_def[abs_def] image_def o_apply map_pair_simp
80.109 - mem_Collect_eq mem_UN_compreh_eq prod_set_simps sum_map.simps sum_set_simps};
80.110 -
80.111 -fun mk_induct_leverage_prem_prems_tac ctxt nn kks set_natural's pre_set_defs =
80.112 - EVERY' (maps (fn kk => [select_prem_tac nn (dtac meta_spec) kk, etac meta_mp,
80.113 - SELECT_GOAL (unfold_thms_tac ctxt (pre_set_defs @ set_natural's @ induct_prem_prem_thms)),
80.114 - solve_prem_prem_tac]) (rev kks)) 1;
80.115 -
80.116 -fun mk_induct_discharge_prem_tac ctxt nn n set_natural's pre_set_defs m k kks =
80.117 - let val r = length kks in
80.118 - EVERY' [select_prem_tac n (rotate_tac 1) k, rotate_tac ~1, hyp_subst_tac,
80.119 - REPEAT_DETERM_N m o (dtac meta_spec THEN' rotate_tac ~1)] 1 THEN
80.120 - EVERY [REPEAT_DETERM_N r
80.121 - (rotate_tac ~1 1 THEN dtac meta_mp 1 THEN rotate_tac 1 1 THEN prefer_tac 2),
80.122 - if r > 0 then PRIMITIVE Raw_Simplifier.norm_hhf else all_tac, atac 1,
80.123 - mk_induct_leverage_prem_prems_tac ctxt nn kks set_natural's pre_set_defs]
80.124 - end;
80.125 -
80.126 -fun mk_induct_tac ctxt ns mss kkss ctr_defs ctor_induct' set_natural's pre_set_defss =
80.127 - let
80.128 - val nn = length ns;
80.129 - val n = Integer.sum ns;
80.130 - in
80.131 - unfold_thms_tac ctxt ctr_defs THEN rtac ctor_induct' 1 THEN inst_spurious_fs_tac ctxt THEN
80.132 - EVERY (map4 (EVERY oooo map3 o mk_induct_discharge_prem_tac ctxt nn n set_natural's)
80.133 - pre_set_defss mss (unflat mss (1 upto n)) kkss)
80.134 - end;
80.135 -
80.136 -end;
81.1 --- a/src/HOL/Codatatype/Tools/bnf_gfp.ML Fri Sep 21 16:34:40 2012 +0200
81.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
81.3 @@ -1,3002 +0,0 @@
81.4 -(* Title: HOL/BNF/Tools/bnf_gfp.ML
81.5 - Author: Dmitriy Traytel, TU Muenchen
81.6 - Author: Andrei Popescu, TU Muenchen
81.7 - Author: Jasmin Blanchette, TU Muenchen
81.8 - Copyright 2012
81.9 -
81.10 -Codatatype construction.
81.11 -*)
81.12 -
81.13 -signature BNF_GFP =
81.14 -sig
81.15 - val bnf_gfp: mixfix list -> (string * sort) list option -> binding list ->
81.16 - typ list * typ list list -> BNF_Def.BNF list -> local_theory ->
81.17 - (term list * term list * term list * term list * thm * thm list * thm list * thm list *
81.18 - thm list * thm list) * local_theory
81.19 -end;
81.20 -
81.21 -structure BNF_GFP : BNF_GFP =
81.22 -struct
81.23 -
81.24 -open BNF_Def
81.25 -open BNF_Util
81.26 -open BNF_Tactics
81.27 -open BNF_FP
81.28 -open BNF_FP_Sugar
81.29 -open BNF_GFP_Util
81.30 -open BNF_GFP_Tactics
81.31 -
81.32 -datatype wit_tree = Wit_Leaf of int | Wit_Node of (int * int * int list) * wit_tree list;
81.33 -
81.34 -fun mk_tree_args (I, T) (I', Ts) = (sort_distinct int_ord (I @ I'), T :: Ts);
81.35 -
81.36 -fun finish Iss m seen i (nwit, I) =
81.37 - let
81.38 - val treess = map (fn j =>
81.39 - if j < m orelse member (op =) seen j then [([j], Wit_Leaf j)]
81.40 - else
81.41 - map_index (finish Iss m (insert (op =) j seen) j) (nth Iss (j - m))
81.42 - |> flat
81.43 - |> minimize_wits)
81.44 - I;
81.45 - in
81.46 - map (fn (I, t) => (I, Wit_Node ((i - m, nwit, filter (fn i => i < m) I), t)))
81.47 - (fold_rev (map_product mk_tree_args) treess [([], [])])
81.48 - |> minimize_wits
81.49 - end;
81.50 -
81.51 -fun tree_to_ctor_wit vars _ _ (Wit_Leaf j) = ([j], nth vars j)
81.52 - | tree_to_ctor_wit vars ctors witss (Wit_Node ((i, nwit, I), subtrees)) =
81.53 - (I, nth ctors i $ (Term.list_comb (snd (nth (nth witss i) nwit),
81.54 - map (snd o tree_to_ctor_wit vars ctors witss) subtrees)));
81.55 -
81.56 -fun tree_to_coind_wits _ (Wit_Leaf _) = []
81.57 - | tree_to_coind_wits lwitss (Wit_Node ((i, nwit, I), subtrees)) =
81.58 - ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
81.59 -
81.60 -(*all BNFs have the same lives*)
81.61 -fun bnf_gfp mixfixes resBs bs (resDs, Dss) bnfs lthy =
81.62 - let
81.63 - val timer = time (Timer.startRealTimer ());
81.64 -
81.65 - val live = live_of_bnf (hd bnfs);
81.66 - val n = length bnfs; (*active*)
81.67 - val ks = 1 upto n;
81.68 - val m = live - n (*passive, if 0 don't generate a new BNF*);
81.69 - val ls = 1 upto m;
81.70 - val b = Binding.name (mk_common_name (map Binding.name_of bs));
81.71 -
81.72 - (* TODO: check if m, n, etc., are sane *)
81.73 -
81.74 - val deads = fold (union (op =)) Dss resDs;
81.75 - val names_lthy = fold Variable.declare_typ deads lthy;
81.76 -
81.77 - (* tvars *)
81.78 - val ((((((((passiveAs, activeAs), allAs)), (passiveBs, activeBs)),
81.79 - (passiveCs, activeCs)), passiveXs), passiveYs), idxT) = names_lthy
81.80 - |> mk_TFrees live
81.81 - |> apfst (`(chop m))
81.82 - ||> mk_TFrees live
81.83 - ||>> apfst (chop m)
81.84 - ||> mk_TFrees live
81.85 - ||>> apfst (chop m)
81.86 - ||>> mk_TFrees m
81.87 - ||>> mk_TFrees m
81.88 - ||> fst o mk_TFrees 1
81.89 - ||> the_single;
81.90 -
81.91 - val Ass = replicate n allAs;
81.92 - val allBs = passiveAs @ activeBs;
81.93 - val Bss = replicate n allBs;
81.94 - val allCs = passiveAs @ activeCs;
81.95 - val allCs' = passiveBs @ activeCs;
81.96 - val Css' = replicate n allCs';
81.97 -
81.98 - (* typs *)
81.99 - val dead_poss =
81.100 - (case resBs of
81.101 - NONE => map SOME deads @ replicate m NONE
81.102 - | SOME Ts => map (fn T => if member (op =) deads (TFree T) then SOME (TFree T) else NONE) Ts);
81.103 - fun mk_param NONE passive = (hd passive, tl passive)
81.104 - | mk_param (SOME a) passive = (a, passive);
81.105 - val mk_params = fold_map mk_param dead_poss #> fst;
81.106 -
81.107 - fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
81.108 - val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
81.109 - val FTsAs = mk_FTs allAs;
81.110 - val FTsBs = mk_FTs allBs;
81.111 - val FTsCs = mk_FTs allCs;
81.112 - val ATs = map HOLogic.mk_setT passiveAs;
81.113 - val BTs = map HOLogic.mk_setT activeAs;
81.114 - val B'Ts = map HOLogic.mk_setT activeBs;
81.115 - val B''Ts = map HOLogic.mk_setT activeCs;
81.116 - val sTs = map2 (fn T => fn U => T --> U) activeAs FTsAs;
81.117 - val s'Ts = map2 (fn T => fn U => T --> U) activeBs FTsBs;
81.118 - val s''Ts = map2 (fn T => fn U => T --> U) activeCs FTsCs;
81.119 - val fTs = map2 (fn T => fn U => T --> U) activeAs activeBs;
81.120 - val all_fTs = map2 (fn T => fn U => T --> U) allAs allBs;
81.121 - val self_fTs = map (fn T => T --> T) activeAs;
81.122 - val gTs = map2 (fn T => fn U => T --> U) activeBs activeCs;
81.123 - val all_gTs = map2 (fn T => fn U => T --> U) allBs allCs';
81.124 - val RTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeBs;
81.125 - val sRTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeAs;
81.126 - val R'Ts = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeBs activeCs;
81.127 - val setsRTs = map HOLogic.mk_setT sRTs;
81.128 - val setRTs = map HOLogic.mk_setT RTs;
81.129 - val all_sbisT = HOLogic.mk_tupleT setsRTs;
81.130 - val setR'Ts = map HOLogic.mk_setT R'Ts;
81.131 - val FRTs = mk_FTs (passiveAs @ RTs);
81.132 - val sumBsAs = map2 (curry mk_sumT) activeBs activeAs;
81.133 - val sumFTs = mk_FTs (passiveAs @ sumBsAs);
81.134 - val sum_sTs = map2 (fn T => fn U => T --> U) activeAs sumFTs;
81.135 -
81.136 - (* terms *)
81.137 - val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
81.138 - val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
81.139 - val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
81.140 - val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
81.141 - val map_Inls = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ sumBsAs)) bnfs;
81.142 - val map_Inls_rev = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ sumBsAs)) Bss bnfs;
81.143 - val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Ass bnfs;
81.144 - val map_snds = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Bss bnfs;
81.145 - fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
81.146 - (map (replicate live) (replicate n Ts)) bnfs;
81.147 - val setssAs = mk_setss allAs;
81.148 - val setssAs' = transpose setssAs;
81.149 - val bis_setss = mk_setss (passiveAs @ RTs);
81.150 - val relsAsBs = map4 mk_srel_of_bnf Dss Ass Bss bnfs;
81.151 - val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
81.152 - val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
81.153 - val sum_bdT = fst (dest_relT (fastype_of sum_bd));
81.154 -
81.155 - val emptys = map (fn T => HOLogic.mk_set T []) passiveAs;
81.156 - val Zeros = map (fn empty =>
81.157 - HOLogic.mk_tuple (map (fn U => absdummy U empty) activeAs)) emptys;
81.158 - val hrecTs = map fastype_of Zeros;
81.159 - val hsetTs = map (fn hrecT => Library.foldr (op -->) (sTs, HOLogic.natT --> hrecT)) hrecTs;
81.160 -
81.161 - val (((((((((((((((((((((((((((((((((((zs, zs'), zs_copy), zs_copy2),
81.162 - z's), As), As_copy), Bs), Bs_copy), B's), B''s), ss), sum_ss), s's), s''s), fs), fs_copy),
81.163 - self_fs), all_fs), gs), all_gs), xFs), xFs_copy), RFs), (Rtuple, Rtuple')), (hrecs, hrecs')),
81.164 - (nat, nat')), Rs), Rs_copy), R's), sRs), (idx, idx')), Idx), Ris), Kss),
81.165 - names_lthy) = lthy
81.166 - |> mk_Frees' "b" activeAs
81.167 - ||>> mk_Frees "b" activeAs
81.168 - ||>> mk_Frees "b" activeAs
81.169 - ||>> mk_Frees "b" activeBs
81.170 - ||>> mk_Frees "A" ATs
81.171 - ||>> mk_Frees "A" ATs
81.172 - ||>> mk_Frees "B" BTs
81.173 - ||>> mk_Frees "B" BTs
81.174 - ||>> mk_Frees "B'" B'Ts
81.175 - ||>> mk_Frees "B''" B''Ts
81.176 - ||>> mk_Frees "s" sTs
81.177 - ||>> mk_Frees "sums" sum_sTs
81.178 - ||>> mk_Frees "s'" s'Ts
81.179 - ||>> mk_Frees "s''" s''Ts
81.180 - ||>> mk_Frees "f" fTs
81.181 - ||>> mk_Frees "f" fTs
81.182 - ||>> mk_Frees "f" self_fTs
81.183 - ||>> mk_Frees "f" all_fTs
81.184 - ||>> mk_Frees "g" gTs
81.185 - ||>> mk_Frees "g" all_gTs
81.186 - ||>> mk_Frees "x" FTsAs
81.187 - ||>> mk_Frees "x" FTsAs
81.188 - ||>> mk_Frees "x" FRTs
81.189 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Rtuple") all_sbisT
81.190 - ||>> mk_Frees' "rec" hrecTs
81.191 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "n") HOLogic.natT
81.192 - ||>> mk_Frees "R" setRTs
81.193 - ||>> mk_Frees "R" setRTs
81.194 - ||>> mk_Frees "R'" setR'Ts
81.195 - ||>> mk_Frees "R" setsRTs
81.196 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "i") idxT
81.197 - ||>> yield_singleton (mk_Frees "I") (HOLogic.mk_setT idxT)
81.198 - ||>> mk_Frees "Ri" (map (fn T => idxT --> T) setRTs)
81.199 - ||>> mk_Freess "K" (map (fn AT => map (fn T => T --> AT) activeAs) ATs);
81.200 -
81.201 - val passive_UNIVs = map HOLogic.mk_UNIV passiveAs;
81.202 - val passive_diags = map mk_diag As;
81.203 - val active_UNIVs = map HOLogic.mk_UNIV activeAs;
81.204 - val sum_UNIVs = map HOLogic.mk_UNIV sumBsAs;
81.205 - val passive_ids = map HOLogic.id_const passiveAs;
81.206 - val active_ids = map HOLogic.id_const activeAs;
81.207 - val Inls = map2 Inl_const activeBs activeAs;
81.208 - val fsts = map fst_const RTs;
81.209 - val snds = map snd_const RTs;
81.210 -
81.211 - (* thms *)
81.212 - val bd_card_orders = map bd_card_order_of_bnf bnfs;
81.213 - val bd_card_order = hd bd_card_orders
81.214 - val bd_Card_orders = map bd_Card_order_of_bnf bnfs;
81.215 - val bd_Card_order = hd bd_Card_orders;
81.216 - val bd_Cinfinites = map bd_Cinfinite_of_bnf bnfs;
81.217 - val bd_Cinfinite = hd bd_Cinfinites;
81.218 - val bd_Cnotzeros = map bd_Cnotzero_of_bnf bnfs;
81.219 - val bd_Cnotzero = hd bd_Cnotzeros;
81.220 - val in_bds = map in_bd_of_bnf bnfs;
81.221 - val in_monos = map in_mono_of_bnf bnfs;
81.222 - val map_comps = map map_comp_of_bnf bnfs;
81.223 - val map_comp's = map map_comp'_of_bnf bnfs;
81.224 - val map_congs = map map_cong_of_bnf bnfs;
81.225 - val map_id's = map map_id'_of_bnf bnfs;
81.226 - val map_wpulls = map map_wpull_of_bnf bnfs;
81.227 - val set_bdss = map set_bd_of_bnf bnfs;
81.228 - val set_natural'ss = map set_natural'_of_bnf bnfs;
81.229 - val srel_congs = map srel_cong_of_bnf bnfs;
81.230 - val srel_converses = map srel_converse_of_bnf bnfs;
81.231 - val srel_defs = map srel_def_of_bnf bnfs;
81.232 - val srel_Grs = map srel_Gr_of_bnf bnfs;
81.233 - val srel_Ids = map srel_Id_of_bnf bnfs;
81.234 - val srel_monos = map srel_mono_of_bnf bnfs;
81.235 - val srel_Os = map srel_O_of_bnf bnfs;
81.236 - val srel_O_Grs = map srel_O_Gr_of_bnf bnfs;
81.237 -
81.238 - val timer = time (timer "Extracted terms & thms");
81.239 -
81.240 - (* derived thms *)
81.241 -
81.242 - (*map g1 ... gm g(m+1) ... g(m+n) (map id ... id f(m+1) ... f(m+n) x)=
81.243 - map g1 ... gm (g(m+1) o f(m+1)) ... (g(m+n) o f(m+n)) x*)
81.244 - fun mk_map_comp_id x mapAsBs mapBsCs mapAsCs map_comp =
81.245 - let
81.246 - val lhs = Term.list_comb (mapBsCs, all_gs) $
81.247 - (Term.list_comb (mapAsBs, passive_ids @ fs) $ x);
81.248 - val rhs =
81.249 - Term.list_comb (mapAsCs, take m all_gs @ map HOLogic.mk_comp (drop m all_gs ~~ fs)) $ x;
81.250 - in
81.251 - Skip_Proof.prove lthy [] []
81.252 - (fold_rev Logic.all (x :: fs @ all_gs) (mk_Trueprop_eq (lhs, rhs)))
81.253 - (K (mk_map_comp_id_tac map_comp))
81.254 - |> Thm.close_derivation
81.255 - end;
81.256 -
81.257 - val map_comp_id_thms = map5 mk_map_comp_id xFs mapsAsBs mapsBsCs' mapsAsCs' map_comp's;
81.258 -
81.259 - (*forall a : set(m+1) x. f(m+1) a = a; ...; forall a : set(m+n) x. f(m+n) a = a ==>
81.260 - map id ... id f(m+1) ... f(m+n) x = x*)
81.261 - fun mk_map_congL x mapAsAs sets map_cong map_id' =
81.262 - let
81.263 - fun mk_prem set f z z' =
81.264 - HOLogic.mk_Trueprop
81.265 - (mk_Ball (set $ x) (Term.absfree z' (HOLogic.mk_eq (f $ z, z))));
81.266 - val prems = map4 mk_prem (drop m sets) self_fs zs zs';
81.267 - val goal = mk_Trueprop_eq (Term.list_comb (mapAsAs, passive_ids @ self_fs) $ x, x);
81.268 - in
81.269 - Skip_Proof.prove lthy [] []
81.270 - (fold_rev Logic.all (x :: self_fs) (Logic.list_implies (prems, goal)))
81.271 - (K (mk_map_congL_tac m map_cong map_id'))
81.272 - |> Thm.close_derivation
81.273 - end;
81.274 -
81.275 - val map_congL_thms = map5 mk_map_congL xFs mapsAsAs setssAs map_congs map_id's;
81.276 - val in_mono'_thms = map (fn thm =>
81.277 - (thm OF (replicate m subset_refl)) RS @{thm set_mp}) in_monos;
81.278 -
81.279 - val map_arg_cong_thms =
81.280 - let
81.281 - val prems = map2 (curry mk_Trueprop_eq) xFs xFs_copy;
81.282 - val maps = map (fn mapx => Term.list_comb (mapx, all_fs)) mapsAsBs;
81.283 - val concls =
81.284 - map3 (fn x => fn y => fn mapx => mk_Trueprop_eq (mapx $ x, mapx $ y)) xFs xFs_copy maps;
81.285 - val goals =
81.286 - map4 (fn prem => fn concl => fn x => fn y =>
81.287 - fold_rev Logic.all (x :: y :: all_fs) (Logic.mk_implies (prem, concl)))
81.288 - prems concls xFs xFs_copy;
81.289 - in
81.290 - map (fn goal => Skip_Proof.prove lthy [] [] goal
81.291 - (K ((hyp_subst_tac THEN' rtac refl) 1)) |> Thm.close_derivation) goals
81.292 - end;
81.293 -
81.294 - val timer = time (timer "Derived simple theorems");
81.295 -
81.296 - (* coalgebra *)
81.297 -
81.298 - val coalg_bind = Binding.suffix_name ("_" ^ coN ^ algN) b;
81.299 - val coalg_name = Binding.name_of coalg_bind;
81.300 - val coalg_def_bind = (Thm.def_binding coalg_bind, []);
81.301 -
81.302 - (*forall i = 1 ... n: (\<forall>x \<in> Bi. si \<in> Fi_in A1 .. Am B1 ... Bn)*)
81.303 - val coalg_spec =
81.304 - let
81.305 - val coalgT = Library.foldr (op -->) (ATs @ BTs @ sTs, HOLogic.boolT);
81.306 -
81.307 - val ins = map3 mk_in (replicate n (As @ Bs)) setssAs FTsAs;
81.308 - fun mk_coalg_conjunct B s X z z' =
81.309 - mk_Ball B (Term.absfree z' (HOLogic.mk_mem (s $ z, X)));
81.310 -
81.311 - val lhs = Term.list_comb (Free (coalg_name, coalgT), As @ Bs @ ss);
81.312 - val rhs = Library.foldr1 HOLogic.mk_conj (map5 mk_coalg_conjunct Bs ss ins zs zs')
81.313 - in
81.314 - mk_Trueprop_eq (lhs, rhs)
81.315 - end;
81.316 -
81.317 - val ((coalg_free, (_, coalg_def_free)), (lthy, lthy_old)) =
81.318 - lthy
81.319 - |> Specification.definition (SOME (coalg_bind, NONE, NoSyn), (coalg_def_bind, coalg_spec))
81.320 - ||> `Local_Theory.restore;
81.321 -
81.322 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.323 - val coalg = fst (Term.dest_Const (Morphism.term phi coalg_free));
81.324 - val coalg_def = Morphism.thm phi coalg_def_free;
81.325 -
81.326 - fun mk_coalg As Bs ss =
81.327 - let
81.328 - val args = As @ Bs @ ss;
81.329 - val Ts = map fastype_of args;
81.330 - val coalgT = Library.foldr (op -->) (Ts, HOLogic.boolT);
81.331 - in
81.332 - Term.list_comb (Const (coalg, coalgT), args)
81.333 - end;
81.334 -
81.335 - val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
81.336 -
81.337 - val coalg_in_thms = map (fn i =>
81.338 - coalg_def RS @{thm subst[of _ _ "%x. x"]} RS mk_conjunctN n i RS bspec) ks
81.339 -
81.340 - val coalg_set_thmss =
81.341 - let
81.342 - val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
81.343 - fun mk_prem x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B));
81.344 - fun mk_concl s x B set = HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) B);
81.345 - val prems = map2 mk_prem zs Bs;
81.346 - val conclss = map3 (fn s => fn x => fn sets => map2 (mk_concl s x) (As @ Bs) sets)
81.347 - ss zs setssAs;
81.348 - val goalss = map3 (fn x => fn prem => fn concls => map (fn concl =>
81.349 - fold_rev Logic.all (x :: As @ Bs @ ss)
81.350 - (Logic.list_implies (coalg_prem :: [prem], concl))) concls) zs prems conclss;
81.351 - in
81.352 - map (fn goals => map (fn goal => Skip_Proof.prove lthy [] [] goal
81.353 - (K (mk_coalg_set_tac coalg_def)) |> Thm.close_derivation) goals) goalss
81.354 - end;
81.355 -
81.356 - val coalg_set_thmss' = transpose coalg_set_thmss;
81.357 -
81.358 - fun mk_tcoalg ATs BTs = mk_coalg (map HOLogic.mk_UNIV ATs) (map HOLogic.mk_UNIV BTs);
81.359 -
81.360 - val tcoalg_thm =
81.361 - let
81.362 - val goal = fold_rev Logic.all ss
81.363 - (HOLogic.mk_Trueprop (mk_tcoalg passiveAs activeAs ss))
81.364 - in
81.365 - Skip_Proof.prove lthy [] [] goal
81.366 - (K (stac coalg_def 1 THEN CONJ_WRAP
81.367 - (K (EVERY' [rtac ballI, rtac CollectI,
81.368 - CONJ_WRAP' (K (EVERY' [rtac @{thm subset_UNIV}])) allAs] 1)) ss))
81.369 - |> Thm.close_derivation
81.370 - end;
81.371 -
81.372 - val timer = time (timer "Coalgebra definition & thms");
81.373 -
81.374 - (* morphism *)
81.375 -
81.376 - val mor_bind = Binding.suffix_name ("_" ^ morN) b;
81.377 - val mor_name = Binding.name_of mor_bind;
81.378 - val mor_def_bind = (Thm.def_binding mor_bind, []);
81.379 -
81.380 - (*fbetw) forall i = 1 ... n: (\<forall>x \<in> Bi. fi x \<in> B'i)*)
81.381 - (*mor) forall i = 1 ... n: (\<forall>x \<in> Bi.
81.382 - Fi_map id ... id f1 ... fn (si x) = si' (fi x)*)
81.383 - val mor_spec =
81.384 - let
81.385 - val morT = Library.foldr (op -->) (BTs @ sTs @ B'Ts @ s'Ts @ fTs, HOLogic.boolT);
81.386 -
81.387 - fun mk_fbetw f B1 B2 z z' =
81.388 - mk_Ball B1 (Term.absfree z' (HOLogic.mk_mem (f $ z, B2)));
81.389 - fun mk_mor B mapAsBs f s s' z z' =
81.390 - mk_Ball B (Term.absfree z' (HOLogic.mk_eq
81.391 - (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ z]), s' $ (f $ z))));
81.392 - val lhs = Term.list_comb (Free (mor_name, morT), Bs @ ss @ B's @ s's @ fs);
81.393 - val rhs = HOLogic.mk_conj
81.394 - (Library.foldr1 HOLogic.mk_conj (map5 mk_fbetw fs Bs B's zs zs'),
81.395 - Library.foldr1 HOLogic.mk_conj (map7 mk_mor Bs mapsAsBs fs ss s's zs zs'))
81.396 - in
81.397 - mk_Trueprop_eq (lhs, rhs)
81.398 - end;
81.399 -
81.400 - val ((mor_free, (_, mor_def_free)), (lthy, lthy_old)) =
81.401 - lthy
81.402 - |> Specification.definition (SOME (mor_bind, NONE, NoSyn), (mor_def_bind, mor_spec))
81.403 - ||> `Local_Theory.restore;
81.404 -
81.405 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.406 - val mor = fst (Term.dest_Const (Morphism.term phi mor_free));
81.407 - val mor_def = Morphism.thm phi mor_def_free;
81.408 -
81.409 - fun mk_mor Bs1 ss1 Bs2 ss2 fs =
81.410 - let
81.411 - val args = Bs1 @ ss1 @ Bs2 @ ss2 @ fs;
81.412 - val Ts = map fastype_of (Bs1 @ ss1 @ Bs2 @ ss2 @ fs);
81.413 - val morT = Library.foldr (op -->) (Ts, HOLogic.boolT);
81.414 - in
81.415 - Term.list_comb (Const (mor, morT), args)
81.416 - end;
81.417 -
81.418 - val mor_prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
81.419 -
81.420 - val (mor_image_thms, morE_thms) =
81.421 - let
81.422 - val prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
81.423 - fun mk_image_goal f B1 B2 = fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs)
81.424 - (Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_subset (mk_image f $ B1) B2)));
81.425 - val image_goals = map3 mk_image_goal fs Bs B's;
81.426 - fun mk_elim_goal B mapAsBs f s s' x =
81.427 - fold_rev Logic.all (x :: Bs @ ss @ B's @ s's @ fs)
81.428 - (Logic.list_implies ([prem, HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B))],
81.429 - mk_Trueprop_eq (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ x]), s' $ (f $ x))));
81.430 - val elim_goals = map6 mk_elim_goal Bs mapsAsBs fs ss s's zs;
81.431 - fun prove goal =
81.432 - Skip_Proof.prove lthy [] [] goal (K (mk_mor_elim_tac mor_def))
81.433 - |> Thm.close_derivation;
81.434 - in
81.435 - (map prove image_goals, map prove elim_goals)
81.436 - end;
81.437 -
81.438 - val mor_image'_thms = map (fn thm => @{thm set_mp} OF [thm, imageI]) mor_image_thms;
81.439 -
81.440 - val mor_incl_thm =
81.441 - let
81.442 - val prems = map2 (HOLogic.mk_Trueprop oo mk_subset) Bs Bs_copy;
81.443 - val concl = HOLogic.mk_Trueprop (mk_mor Bs ss Bs_copy ss active_ids);
81.444 - in
81.445 - Skip_Proof.prove lthy [] []
81.446 - (fold_rev Logic.all (Bs @ ss @ Bs_copy) (Logic.list_implies (prems, concl)))
81.447 - (K (mk_mor_incl_tac mor_def map_id's))
81.448 - |> Thm.close_derivation
81.449 - end;
81.450 -
81.451 - val mor_id_thm = mor_incl_thm OF (replicate n subset_refl);
81.452 -
81.453 - val mor_comp_thm =
81.454 - let
81.455 - val prems =
81.456 - [HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs),
81.457 - HOLogic.mk_Trueprop (mk_mor B's s's B''s s''s gs)];
81.458 - val concl =
81.459 - HOLogic.mk_Trueprop (mk_mor Bs ss B''s s''s (map2 (curry HOLogic.mk_comp) gs fs));
81.460 - in
81.461 - Skip_Proof.prove lthy [] []
81.462 - (fold_rev Logic.all (Bs @ ss @ B's @ s's @ B''s @ s''s @ fs @ gs)
81.463 - (Logic.list_implies (prems, concl)))
81.464 - (K (mk_mor_comp_tac mor_def mor_image'_thms morE_thms map_comp_id_thms))
81.465 - |> Thm.close_derivation
81.466 - end;
81.467 -
81.468 - val mor_cong_thm =
81.469 - let
81.470 - val prems = map HOLogic.mk_Trueprop
81.471 - (map2 (curry HOLogic.mk_eq) fs_copy fs @ [mk_mor Bs ss B's s's fs])
81.472 - val concl = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs_copy);
81.473 - in
81.474 - Skip_Proof.prove lthy [] []
81.475 - (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ fs_copy)
81.476 - (Logic.list_implies (prems, concl)))
81.477 - (K ((hyp_subst_tac THEN' atac) 1))
81.478 - |> Thm.close_derivation
81.479 - end;
81.480 -
81.481 - val mor_UNIV_thm =
81.482 - let
81.483 - fun mk_conjunct mapAsBs f s s' = HOLogic.mk_eq
81.484 - (HOLogic.mk_comp (Term.list_comb (mapAsBs, passive_ids @ fs), s),
81.485 - HOLogic.mk_comp (s', f));
81.486 - val lhs = mk_mor active_UNIVs ss (map HOLogic.mk_UNIV activeBs) s's fs;
81.487 - val rhs = Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct mapsAsBs fs ss s's);
81.488 - in
81.489 - Skip_Proof.prove lthy [] [] (fold_rev Logic.all (ss @ s's @ fs) (mk_Trueprop_eq (lhs, rhs)))
81.490 - (K (mk_mor_UNIV_tac morE_thms mor_def))
81.491 - |> Thm.close_derivation
81.492 - end;
81.493 -
81.494 - val mor_str_thm =
81.495 - let
81.496 - val maps = map2 (fn Ds => fn bnf => Term.list_comb
81.497 - (mk_map_of_bnf Ds allAs (passiveAs @ FTsAs) bnf, passive_ids @ ss)) Dss bnfs;
81.498 - in
81.499 - Skip_Proof.prove lthy [] []
81.500 - (fold_rev Logic.all ss (HOLogic.mk_Trueprop
81.501 - (mk_mor active_UNIVs ss (map HOLogic.mk_UNIV FTsAs) maps ss)))
81.502 - (K (mk_mor_str_tac ks mor_UNIV_thm))
81.503 - |> Thm.close_derivation
81.504 - end;
81.505 -
81.506 - val mor_sum_case_thm =
81.507 - let
81.508 - val maps = map3 (fn s => fn sum_s => fn mapx =>
81.509 - mk_sum_case (HOLogic.mk_comp (Term.list_comb (mapx, passive_ids @ Inls), s), sum_s))
81.510 - s's sum_ss map_Inls;
81.511 - in
81.512 - Skip_Proof.prove lthy [] []
81.513 - (fold_rev Logic.all (s's @ sum_ss) (HOLogic.mk_Trueprop
81.514 - (mk_mor (map HOLogic.mk_UNIV activeBs) s's sum_UNIVs maps Inls)))
81.515 - (K (mk_mor_sum_case_tac ks mor_UNIV_thm))
81.516 - |> Thm.close_derivation
81.517 - end;
81.518 -
81.519 - val timer = time (timer "Morphism definition & thms");
81.520 -
81.521 - fun hset_rec_bind j = Binding.suffix_name ("_" ^ hset_recN ^ (if m = 1 then "" else
81.522 - string_of_int j)) b;
81.523 - val hset_rec_name = Binding.name_of o hset_rec_bind;
81.524 - val hset_rec_def_bind = rpair [] o Thm.def_binding o hset_rec_bind;
81.525 -
81.526 - fun hset_rec_spec j Zero hsetT hrec hrec' =
81.527 - let
81.528 - fun mk_Suc s setsAs z z' =
81.529 - let
81.530 - val (set, sets) = apfst (fn xs => nth xs (j - 1)) (chop m setsAs);
81.531 - fun mk_UN set k = mk_UNION (set $ (s $ z)) (mk_nthN n hrec k);
81.532 - in
81.533 - Term.absfree z'
81.534 - (mk_union (set $ (s $ z), Library.foldl1 mk_union (map2 mk_UN sets ks)))
81.535 - end;
81.536 -
81.537 - val Suc = Term.absdummy HOLogic.natT (Term.absfree hrec'
81.538 - (HOLogic.mk_tuple (map4 mk_Suc ss setssAs zs zs')));
81.539 -
81.540 - val lhs = Term.list_comb (Free (hset_rec_name j, hsetT), ss);
81.541 - val rhs = mk_nat_rec Zero Suc;
81.542 - in
81.543 - mk_Trueprop_eq (lhs, rhs)
81.544 - end;
81.545 -
81.546 - val ((hset_rec_frees, (_, hset_rec_def_frees)), (lthy, lthy_old)) =
81.547 - lthy
81.548 - |> fold_map5 (fn j => fn Zero => fn hsetT => fn hrec => fn hrec' => Specification.definition
81.549 - (SOME (hset_rec_bind j, NONE, NoSyn),
81.550 - (hset_rec_def_bind j, hset_rec_spec j Zero hsetT hrec hrec')))
81.551 - ls Zeros hsetTs hrecs hrecs'
81.552 - |>> apsnd split_list o split_list
81.553 - ||> `Local_Theory.restore;
81.554 -
81.555 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.556 -
81.557 - val hset_rec_defs = map (Morphism.thm phi) hset_rec_def_frees;
81.558 - val hset_recs = map (fst o Term.dest_Const o Morphism.term phi) hset_rec_frees;
81.559 -
81.560 - fun mk_hset_rec ss nat i j T =
81.561 - let
81.562 - val args = ss @ [nat];
81.563 - val Ts = map fastype_of ss;
81.564 - val bTs = map domain_type Ts;
81.565 - val hrecT = HOLogic.mk_tupleT (map (fn U => U --> HOLogic.mk_setT T) bTs)
81.566 - val hset_recT = Library.foldr (op -->) (Ts, HOLogic.natT --> hrecT);
81.567 - in
81.568 - mk_nthN n (Term.list_comb (Const (nth hset_recs (j - 1), hset_recT), args)) i
81.569 - end;
81.570 -
81.571 - val hset_rec_0ss = mk_rec_simps n @{thm nat_rec_0} hset_rec_defs;
81.572 - val hset_rec_Sucss = mk_rec_simps n @{thm nat_rec_Suc} hset_rec_defs;
81.573 - val hset_rec_0ss' = transpose hset_rec_0ss;
81.574 - val hset_rec_Sucss' = transpose hset_rec_Sucss;
81.575 -
81.576 - fun hset_bind i j = Binding.suffix_name ("_" ^ hsetN ^
81.577 - (if m = 1 then "" else string_of_int j)) (nth bs (i - 1));
81.578 - val hset_name = Binding.name_of oo hset_bind;
81.579 - val hset_def_bind = rpair [] o Thm.def_binding oo hset_bind;
81.580 -
81.581 - fun hset_spec i j =
81.582 - let
81.583 - val U = nth activeAs (i - 1);
81.584 - val z = nth zs (i - 1);
81.585 - val T = nth passiveAs (j - 1);
81.586 - val setT = HOLogic.mk_setT T;
81.587 - val hsetT = Library.foldr (op -->) (sTs, U --> setT);
81.588 -
81.589 - val lhs = Term.list_comb (Free (hset_name i j, hsetT), ss @ [z]);
81.590 - val rhs = mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
81.591 - (Term.absfree nat' (mk_hset_rec ss nat i j T $ z));
81.592 - in
81.593 - mk_Trueprop_eq (lhs, rhs)
81.594 - end;
81.595 -
81.596 - val ((hset_frees, (_, hset_def_frees)), (lthy, lthy_old)) =
81.597 - lthy
81.598 - |> fold_map (fn i => fold_map (fn j => Specification.definition
81.599 - (SOME (hset_bind i j, NONE, NoSyn), (hset_def_bind i j, hset_spec i j))) ls) ks
81.600 - |>> map (apsnd split_list o split_list)
81.601 - |>> apsnd split_list o split_list
81.602 - ||> `Local_Theory.restore;
81.603 -
81.604 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.605 -
81.606 - val hset_defss = map (map (Morphism.thm phi)) hset_def_frees;
81.607 - val hset_defss' = transpose hset_defss;
81.608 - val hset_namess = map (map (fst o Term.dest_Const o Morphism.term phi)) hset_frees;
81.609 -
81.610 - fun mk_hset ss i j T =
81.611 - let
81.612 - val Ts = map fastype_of ss;
81.613 - val bTs = map domain_type Ts;
81.614 - val hsetT = Library.foldr (op -->) (Ts, nth bTs (i - 1) --> HOLogic.mk_setT T);
81.615 - in
81.616 - Term.list_comb (Const (nth (nth hset_namess (i - 1)) (j - 1), hsetT), ss)
81.617 - end;
81.618 -
81.619 - val hsetssAs = map (fn i => map2 (mk_hset ss i) ls passiveAs) ks;
81.620 -
81.621 - val (set_incl_hset_thmss, set_hset_incl_hset_thmsss) =
81.622 - let
81.623 - fun mk_set_incl_hset s x set hset = fold_rev Logic.all (x :: ss)
81.624 - (HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) (hset $ x)));
81.625 -
81.626 - fun mk_set_hset_incl_hset s x y set hset1 hset2 =
81.627 - fold_rev Logic.all (x :: y :: ss)
81.628 - (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x, set $ (s $ y))),
81.629 - HOLogic.mk_Trueprop (mk_subset (hset1 $ x) (hset2 $ y))));
81.630 -
81.631 - val set_incl_hset_goalss =
81.632 - map4 (fn s => fn x => fn sets => fn hsets =>
81.633 - map2 (mk_set_incl_hset s x) (take m sets) hsets)
81.634 - ss zs setssAs hsetssAs;
81.635 -
81.636 - (*xk : F(i)set(m+k) (si yi) ==> F(k)_hset(j) s1 ... sn xk <= F(i)_hset(j) s1 ... sn yi*)
81.637 - val set_hset_incl_hset_goalsss =
81.638 - map4 (fn si => fn yi => fn sets => fn hsetsi =>
81.639 - map3 (fn xk => fn set => fn hsetsk =>
81.640 - map2 (mk_set_hset_incl_hset si xk yi set) hsetsk hsetsi)
81.641 - zs_copy (drop m sets) hsetssAs)
81.642 - ss zs setssAs hsetssAs;
81.643 - in
81.644 - (map3 (fn goals => fn defs => fn rec_Sucs =>
81.645 - map3 (fn goal => fn def => fn rec_Suc =>
81.646 - Skip_Proof.prove lthy [] [] goal (K (mk_set_incl_hset_tac def rec_Suc))
81.647 - |> Thm.close_derivation)
81.648 - goals defs rec_Sucs)
81.649 - set_incl_hset_goalss hset_defss hset_rec_Sucss,
81.650 - map3 (fn goalss => fn defsi => fn rec_Sucs =>
81.651 - map3 (fn k => fn goals => fn defsk =>
81.652 - map4 (fn goal => fn defk => fn defi => fn rec_Suc =>
81.653 - Skip_Proof.prove lthy [] [] goal
81.654 - (K (mk_set_hset_incl_hset_tac n [defk, defi] rec_Suc k))
81.655 - |> Thm.close_derivation)
81.656 - goals defsk defsi rec_Sucs)
81.657 - ks goalss hset_defss)
81.658 - set_hset_incl_hset_goalsss hset_defss hset_rec_Sucss)
81.659 - end;
81.660 -
81.661 - val set_incl_hset_thmss' = transpose set_incl_hset_thmss;
81.662 - val set_hset_incl_hset_thmsss' = transpose (map transpose set_hset_incl_hset_thmsss);
81.663 - val set_hset_incl_hset_thmsss'' = map transpose set_hset_incl_hset_thmsss';
81.664 - val set_hset_thmss = map (map (fn thm => thm RS @{thm set_mp})) set_incl_hset_thmss;
81.665 - val set_hset_hset_thmsss = map (map (map (fn thm => thm RS @{thm set_mp})))
81.666 - set_hset_incl_hset_thmsss;
81.667 - val set_hset_thmss' = transpose set_hset_thmss;
81.668 - val set_hset_hset_thmsss' = transpose (map transpose set_hset_hset_thmsss);
81.669 -
81.670 - val set_incl_hin_thmss =
81.671 - let
81.672 - fun mk_set_incl_hin s x hsets1 set hsets2 T =
81.673 - fold_rev Logic.all (x :: ss @ As)
81.674 - (Logic.list_implies
81.675 - (map2 (fn hset => fn A => HOLogic.mk_Trueprop (mk_subset (hset $ x) A)) hsets1 As,
81.676 - HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) (mk_in As hsets2 T))));
81.677 -
81.678 - val set_incl_hin_goalss =
81.679 - map4 (fn s => fn x => fn sets => fn hsets =>
81.680 - map3 (mk_set_incl_hin s x hsets) (drop m sets) hsetssAs activeAs)
81.681 - ss zs setssAs hsetssAs;
81.682 - in
81.683 - map2 (map2 (fn goal => fn thms =>
81.684 - Skip_Proof.prove lthy [] [] goal (K (mk_set_incl_hin_tac thms))
81.685 - |> Thm.close_derivation))
81.686 - set_incl_hin_goalss set_hset_incl_hset_thmsss
81.687 - end;
81.688 -
81.689 - val hset_minimal_thms =
81.690 - let
81.691 - fun mk_passive_prem set s x K =
81.692 - Logic.all x (HOLogic.mk_Trueprop (mk_subset (set $ (s $ x)) (K $ x)));
81.693 -
81.694 - fun mk_active_prem s x1 K1 set x2 K2 =
81.695 - fold_rev Logic.all [x1, x2]
81.696 - (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x2, set $ (s $ x1))),
81.697 - HOLogic.mk_Trueprop (mk_subset (K2 $ x2) (K1 $ x1))));
81.698 -
81.699 - val premss = map2 (fn j => fn Ks =>
81.700 - map4 mk_passive_prem (map (fn xs => nth xs (j - 1)) setssAs) ss zs Ks @
81.701 - flat (map4 (fn sets => fn s => fn x1 => fn K1 =>
81.702 - map3 (mk_active_prem s x1 K1) (drop m sets) zs_copy Ks) setssAs ss zs Ks))
81.703 - ls Kss;
81.704 -
81.705 - val hset_rec_minimal_thms =
81.706 - let
81.707 - fun mk_conjunct j T i K x = mk_subset (mk_hset_rec ss nat i j T $ x) (K $ x);
81.708 - fun mk_concl j T Ks = list_all_free zs
81.709 - (Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs));
81.710 - val concls = map3 mk_concl ls passiveAs Kss;
81.711 -
81.712 - val goals = map2 (fn prems => fn concl =>
81.713 - Logic.list_implies (prems, HOLogic.mk_Trueprop concl)) premss concls
81.714 -
81.715 - val ctss =
81.716 - map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
81.717 - in
81.718 - map4 (fn goal => fn cts => fn hset_rec_0s => fn hset_rec_Sucs =>
81.719 - singleton (Proof_Context.export names_lthy lthy)
81.720 - (Skip_Proof.prove lthy [] [] goal
81.721 - (mk_hset_rec_minimal_tac m cts hset_rec_0s hset_rec_Sucs))
81.722 - |> Thm.close_derivation)
81.723 - goals ctss hset_rec_0ss' hset_rec_Sucss'
81.724 - end;
81.725 -
81.726 - fun mk_conjunct j T i K x = mk_subset (mk_hset ss i j T $ x) (K $ x);
81.727 - fun mk_concl j T Ks = Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs);
81.728 - val concls = map3 mk_concl ls passiveAs Kss;
81.729 -
81.730 - val goals = map3 (fn Ks => fn prems => fn concl =>
81.731 - fold_rev Logic.all (Ks @ ss @ zs)
81.732 - (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))) Kss premss concls;
81.733 - in
81.734 - map3 (fn goal => fn hset_defs => fn hset_rec_minimal =>
81.735 - Skip_Proof.prove lthy [] [] goal
81.736 - (mk_hset_minimal_tac n hset_defs hset_rec_minimal)
81.737 - |> Thm.close_derivation)
81.738 - goals hset_defss' hset_rec_minimal_thms
81.739 - end;
81.740 -
81.741 - val mor_hset_thmss =
81.742 - let
81.743 - val mor_hset_rec_thms =
81.744 - let
81.745 - fun mk_conjunct j T i f x B =
81.746 - HOLogic.mk_imp (HOLogic.mk_mem (x, B), HOLogic.mk_eq
81.747 - (mk_hset_rec s's nat i j T $ (f $ x), mk_hset_rec ss nat i j T $ x));
81.748 -
81.749 - fun mk_concl j T = list_all_free zs
81.750 - (Library.foldr1 HOLogic.mk_conj (map4 (mk_conjunct j T) ks fs zs Bs));
81.751 - val concls = map2 mk_concl ls passiveAs;
81.752 -
81.753 - val ctss =
81.754 - map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
81.755 -
81.756 - val goals = map (fn concl =>
81.757 - Logic.list_implies ([coalg_prem, mor_prem], HOLogic.mk_Trueprop concl)) concls;
81.758 - in
81.759 - map5 (fn j => fn goal => fn cts => fn hset_rec_0s => fn hset_rec_Sucs =>
81.760 - singleton (Proof_Context.export names_lthy lthy)
81.761 - (Skip_Proof.prove lthy [] [] goal
81.762 - (K (mk_mor_hset_rec_tac m n cts j hset_rec_0s hset_rec_Sucs
81.763 - morE_thms set_natural'ss coalg_set_thmss)))
81.764 - |> Thm.close_derivation)
81.765 - ls goals ctss hset_rec_0ss' hset_rec_Sucss'
81.766 - end;
81.767 -
81.768 - val mor_hset_rec_thmss = map (fn thm => map (fn i =>
81.769 - mk_specN n thm RS mk_conjunctN n i RS mp) ks) mor_hset_rec_thms;
81.770 -
81.771 - fun mk_prem x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B));
81.772 -
81.773 - fun mk_concl j T i f x =
81.774 - mk_Trueprop_eq (mk_hset s's i j T $ (f $ x), mk_hset ss i j T $ x);
81.775 -
81.776 - val goalss = map2 (fn j => fn T => map4 (fn i => fn f => fn x => fn B =>
81.777 - fold_rev Logic.all (x :: As @ Bs @ ss @ B's @ s's @ fs)
81.778 - (Logic.list_implies ([coalg_prem, mor_prem,
81.779 - mk_prem x B], mk_concl j T i f x))) ks fs zs Bs) ls passiveAs;
81.780 - in
81.781 - map3 (map3 (fn goal => fn hset_def => fn mor_hset_rec =>
81.782 - Skip_Proof.prove lthy [] [] goal
81.783 - (K (mk_mor_hset_tac hset_def mor_hset_rec))
81.784 - |> Thm.close_derivation))
81.785 - goalss hset_defss' mor_hset_rec_thmss
81.786 - end;
81.787 -
81.788 - val timer = time (timer "Hereditary sets");
81.789 -
81.790 - (* bisimulation *)
81.791 -
81.792 - val bis_bind = Binding.suffix_name ("_" ^ bisN) b;
81.793 - val bis_name = Binding.name_of bis_bind;
81.794 - val bis_def_bind = (Thm.def_binding bis_bind, []);
81.795 -
81.796 - fun mk_bis_le_conjunct R B1 B2 = mk_subset R (mk_Times (B1, B2));
81.797 - val bis_le = Library.foldr1 HOLogic.mk_conj (map3 mk_bis_le_conjunct Rs Bs B's)
81.798 -
81.799 - val bis_spec =
81.800 - let
81.801 - val bisT = Library.foldr (op -->) (ATs @ BTs @ sTs @ B'Ts @ s'Ts @ setRTs, HOLogic.boolT);
81.802 -
81.803 - val fst_args = passive_ids @ fsts;
81.804 - val snd_args = passive_ids @ snds;
81.805 - fun mk_bis R s s' b1 b2 RF map1 map2 sets =
81.806 - list_all_free [b1, b2] (HOLogic.mk_imp
81.807 - (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
81.808 - mk_Bex (mk_in (As @ Rs) sets (snd (dest_Free RF))) (Term.absfree (dest_Free RF)
81.809 - (HOLogic.mk_conj
81.810 - (HOLogic.mk_eq (Term.list_comb (map1, fst_args) $ RF, s $ b1),
81.811 - HOLogic.mk_eq (Term.list_comb (map2, snd_args) $ RF, s' $ b2))))));
81.812 -
81.813 - val lhs = Term.list_comb (Free (bis_name, bisT), As @ Bs @ ss @ B's @ s's @ Rs);
81.814 - val rhs = HOLogic.mk_conj
81.815 - (bis_le, Library.foldr1 HOLogic.mk_conj
81.816 - (map9 mk_bis Rs ss s's zs z's RFs map_fsts map_snds bis_setss))
81.817 - in
81.818 - mk_Trueprop_eq (lhs, rhs)
81.819 - end;
81.820 -
81.821 - val ((bis_free, (_, bis_def_free)), (lthy, lthy_old)) =
81.822 - lthy
81.823 - |> Specification.definition (SOME (bis_bind, NONE, NoSyn), (bis_def_bind, bis_spec))
81.824 - ||> `Local_Theory.restore;
81.825 -
81.826 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.827 - val bis = fst (Term.dest_Const (Morphism.term phi bis_free));
81.828 - val bis_def = Morphism.thm phi bis_def_free;
81.829 -
81.830 - fun mk_bis As Bs1 ss1 Bs2 ss2 Rs =
81.831 - let
81.832 - val args = As @ Bs1 @ ss1 @ Bs2 @ ss2 @ Rs;
81.833 - val Ts = map fastype_of args;
81.834 - val bisT = Library.foldr (op -->) (Ts, HOLogic.boolT);
81.835 - in
81.836 - Term.list_comb (Const (bis, bisT), args)
81.837 - end;
81.838 -
81.839 - val bis_cong_thm =
81.840 - let
81.841 - val prems = map HOLogic.mk_Trueprop
81.842 - (mk_bis As Bs ss B's s's Rs :: map2 (curry HOLogic.mk_eq) Rs_copy Rs)
81.843 - val concl = HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs_copy);
81.844 - in
81.845 - Skip_Proof.prove lthy [] []
81.846 - (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs @ Rs_copy)
81.847 - (Logic.list_implies (prems, concl)))
81.848 - (K ((hyp_subst_tac THEN' atac) 1))
81.849 - |> Thm.close_derivation
81.850 - end;
81.851 -
81.852 - val bis_srel_thm =
81.853 - let
81.854 - fun mk_conjunct R s s' b1 b2 srel =
81.855 - list_all_free [b1, b2] (HOLogic.mk_imp
81.856 - (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
81.857 - HOLogic.mk_mem (HOLogic.mk_prod (s $ b1, s' $ b2),
81.858 - Term.list_comb (srel, passive_diags @ Rs))));
81.859 -
81.860 - val rhs = HOLogic.mk_conj
81.861 - (bis_le, Library.foldr1 HOLogic.mk_conj
81.862 - (map6 mk_conjunct Rs ss s's zs z's relsAsBs))
81.863 - in
81.864 - Skip_Proof.prove lthy [] []
81.865 - (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
81.866 - (mk_Trueprop_eq (mk_bis As Bs ss B's s's Rs, rhs)))
81.867 - (K (mk_bis_srel_tac m bis_def srel_O_Grs map_comp's map_congs set_natural'ss))
81.868 - |> Thm.close_derivation
81.869 - end;
81.870 -
81.871 - val bis_converse_thm =
81.872 - Skip_Proof.prove lthy [] []
81.873 - (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
81.874 - (Logic.mk_implies
81.875 - (HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
81.876 - HOLogic.mk_Trueprop (mk_bis As B's s's Bs ss (map mk_converse Rs)))))
81.877 - (K (mk_bis_converse_tac m bis_srel_thm srel_congs srel_converses))
81.878 - |> Thm.close_derivation;
81.879 -
81.880 - val bis_O_thm =
81.881 - let
81.882 - val prems =
81.883 - [HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
81.884 - HOLogic.mk_Trueprop (mk_bis As B's s's B''s s''s R's)];
81.885 - val concl =
81.886 - HOLogic.mk_Trueprop (mk_bis As Bs ss B''s s''s (map2 (curry mk_rel_comp) Rs R's));
81.887 - in
81.888 - Skip_Proof.prove lthy [] []
81.889 - (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ B''s @ s''s @ Rs @ R's)
81.890 - (Logic.list_implies (prems, concl)))
81.891 - (K (mk_bis_O_tac m bis_srel_thm srel_congs srel_Os))
81.892 - |> Thm.close_derivation
81.893 - end;
81.894 -
81.895 - val bis_Gr_thm =
81.896 - let
81.897 - val concl =
81.898 - HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map2 mk_Gr Bs fs));
81.899 - in
81.900 - Skip_Proof.prove lthy [] []
81.901 - (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ fs)
81.902 - (Logic.list_implies ([coalg_prem, mor_prem], concl)))
81.903 - (mk_bis_Gr_tac bis_srel_thm srel_Grs mor_image_thms morE_thms coalg_in_thms)
81.904 - |> Thm.close_derivation
81.905 - end;
81.906 -
81.907 - val bis_image2_thm = bis_cong_thm OF
81.908 - ((bis_O_thm OF [bis_Gr_thm RS bis_converse_thm, bis_Gr_thm]) ::
81.909 - replicate n @{thm image2_Gr});
81.910 -
81.911 - val bis_diag_thm = bis_cong_thm OF ((mor_id_thm RSN (2, bis_Gr_thm)) ::
81.912 - replicate n @{thm diag_Gr});
81.913 -
81.914 - val bis_Union_thm =
81.915 - let
81.916 - val prem =
81.917 - HOLogic.mk_Trueprop (mk_Ball Idx
81.918 - (Term.absfree idx' (mk_bis As Bs ss B's s's (map (fn R => R $ idx) Ris))));
81.919 - val concl =
81.920 - HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map (mk_UNION Idx) Ris));
81.921 - in
81.922 - Skip_Proof.prove lthy [] []
81.923 - (fold_rev Logic.all (Idx :: As @ Bs @ ss @ B's @ s's @ Ris)
81.924 - (Logic.mk_implies (prem, concl)))
81.925 - (mk_bis_Union_tac bis_def in_mono'_thms)
81.926 - |> Thm.close_derivation
81.927 - end;
81.928 -
81.929 - (* self-bisimulation *)
81.930 -
81.931 - fun mk_sbis As Bs ss Rs = mk_bis As Bs ss Bs ss Rs;
81.932 -
81.933 - val sbis_prem = HOLogic.mk_Trueprop (mk_sbis As Bs ss sRs);
81.934 -
81.935 - (* largest self-bisimulation *)
81.936 -
81.937 - fun lsbis_bind i = Binding.suffix_name ("_" ^ lsbisN ^ (if n = 1 then "" else
81.938 - string_of_int i)) b;
81.939 - val lsbis_name = Binding.name_of o lsbis_bind;
81.940 - val lsbis_def_bind = rpair [] o Thm.def_binding o lsbis_bind;
81.941 -
81.942 - val all_sbis = HOLogic.mk_Collect (fst Rtuple', snd Rtuple', list_exists_free sRs
81.943 - (HOLogic.mk_conj (HOLogic.mk_eq (Rtuple, HOLogic.mk_tuple sRs), mk_sbis As Bs ss sRs)));
81.944 -
81.945 - fun lsbis_spec i RT =
81.946 - let
81.947 - fun mk_lsbisT RT =
81.948 - Library.foldr (op -->) (map fastype_of (As @ Bs @ ss), RT);
81.949 - val lhs = Term.list_comb (Free (lsbis_name i, mk_lsbisT RT), As @ Bs @ ss);
81.950 - val rhs = mk_UNION all_sbis (Term.absfree Rtuple' (mk_nthN n Rtuple i));
81.951 - in
81.952 - mk_Trueprop_eq (lhs, rhs)
81.953 - end;
81.954 -
81.955 - val ((lsbis_frees, (_, lsbis_def_frees)), (lthy, lthy_old)) =
81.956 - lthy
81.957 - |> fold_map2 (fn i => fn RT => Specification.definition
81.958 - (SOME (lsbis_bind i, NONE, NoSyn), (lsbis_def_bind i, lsbis_spec i RT))) ks setsRTs
81.959 - |>> apsnd split_list o split_list
81.960 - ||> `Local_Theory.restore;
81.961 -
81.962 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.963 -
81.964 - val lsbis_defs = map (Morphism.thm phi) lsbis_def_frees;
81.965 - val lsbiss = map (fst o Term.dest_Const o Morphism.term phi) lsbis_frees;
81.966 -
81.967 - fun mk_lsbis As Bs ss i =
81.968 - let
81.969 - val args = As @ Bs @ ss;
81.970 - val Ts = map fastype_of args;
81.971 - val RT = mk_relT (`I (HOLogic.dest_setT (fastype_of (nth Bs (i - 1)))));
81.972 - val lsbisT = Library.foldr (op -->) (Ts, RT);
81.973 - in
81.974 - Term.list_comb (Const (nth lsbiss (i - 1), lsbisT), args)
81.975 - end;
81.976 -
81.977 - val sbis_lsbis_thm =
81.978 - Skip_Proof.prove lthy [] []
81.979 - (fold_rev Logic.all (As @ Bs @ ss)
81.980 - (HOLogic.mk_Trueprop (mk_sbis As Bs ss (map (mk_lsbis As Bs ss) ks))))
81.981 - (K (mk_sbis_lsbis_tac lsbis_defs bis_Union_thm bis_cong_thm))
81.982 - |> Thm.close_derivation;
81.983 -
81.984 - val lsbis_incl_thms = map (fn i => sbis_lsbis_thm RS
81.985 - (bis_def RS @{thm subst[of _ _ "%x. x"]} RS conjunct1 RS mk_conjunctN n i)) ks;
81.986 - val lsbisE_thms = map (fn i => (mk_specN 2 (sbis_lsbis_thm RS
81.987 - (bis_def RS @{thm subst[of _ _ "%x. x"]} RS conjunct2 RS mk_conjunctN n i))) RS mp) ks;
81.988 -
81.989 - val incl_lsbis_thms =
81.990 - let
81.991 - fun mk_concl i R = HOLogic.mk_Trueprop (mk_subset R (mk_lsbis As Bs ss i));
81.992 - val goals = map2 (fn i => fn R => fold_rev Logic.all (As @ Bs @ ss @ sRs)
81.993 - (Logic.mk_implies (sbis_prem, mk_concl i R))) ks sRs;
81.994 - in
81.995 - map3 (fn goal => fn i => fn def => Skip_Proof.prove lthy [] [] goal
81.996 - (K (mk_incl_lsbis_tac n i def)) |> Thm.close_derivation) goals ks lsbis_defs
81.997 - end;
81.998 -
81.999 - val equiv_lsbis_thms =
81.1000 - let
81.1001 - fun mk_concl i B = HOLogic.mk_Trueprop (mk_equiv B (mk_lsbis As Bs ss i));
81.1002 - val goals = map2 (fn i => fn B => fold_rev Logic.all (As @ Bs @ ss)
81.1003 - (Logic.mk_implies (coalg_prem, mk_concl i B))) ks Bs;
81.1004 - in
81.1005 - map3 (fn goal => fn l_incl => fn incl_l =>
81.1006 - Skip_Proof.prove lthy [] [] goal
81.1007 - (K (mk_equiv_lsbis_tac sbis_lsbis_thm l_incl incl_l
81.1008 - bis_diag_thm bis_converse_thm bis_O_thm))
81.1009 - |> Thm.close_derivation)
81.1010 - goals lsbis_incl_thms incl_lsbis_thms
81.1011 - end;
81.1012 -
81.1013 - val timer = time (timer "Bisimulations");
81.1014 -
81.1015 - (* bounds *)
81.1016 -
81.1017 - val (lthy, sbd, sbdT,
81.1018 - sbd_card_order, sbd_Cinfinite, sbd_Cnotzero, sbd_Card_order, set_sbdss, in_sbds) =
81.1019 - if n = 1
81.1020 - then (lthy, sum_bd, sum_bdT,
81.1021 - bd_card_order, bd_Cinfinite, bd_Cnotzero, bd_Card_order, set_bdss, in_bds)
81.1022 - else
81.1023 - let
81.1024 - val sbdT_bind = Binding.suffix_name ("_" ^ sum_bdTN) b;
81.1025 -
81.1026 - val ((sbdT_name, (sbdT_glob_info, sbdT_loc_info)), lthy) =
81.1027 - typedef false NONE (sbdT_bind, params, NoSyn)
81.1028 - (HOLogic.mk_UNIV sum_bdT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
81.1029 -
81.1030 - val sbdT = Type (sbdT_name, params');
81.1031 - val Abs_sbdT = Const (#Abs_name sbdT_glob_info, sum_bdT --> sbdT);
81.1032 -
81.1033 - val sbd_bind = Binding.suffix_name ("_" ^ sum_bdN) b;
81.1034 - val sbd_name = Binding.name_of sbd_bind;
81.1035 - val sbd_def_bind = (Thm.def_binding sbd_bind, []);
81.1036 -
81.1037 - val sbd_spec = HOLogic.mk_Trueprop
81.1038 - (HOLogic.mk_eq (Free (sbd_name, mk_relT (`I sbdT)), mk_dir_image sum_bd Abs_sbdT));
81.1039 -
81.1040 - val ((sbd_free, (_, sbd_def_free)), (lthy, lthy_old)) =
81.1041 - lthy
81.1042 - |> Specification.definition (SOME (sbd_bind, NONE, NoSyn), (sbd_def_bind, sbd_spec))
81.1043 - ||> `Local_Theory.restore;
81.1044 -
81.1045 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1046 -
81.1047 - val sbd_def = Morphism.thm phi sbd_def_free;
81.1048 - val sbd = Const (fst (Term.dest_Const (Morphism.term phi sbd_free)), mk_relT (`I sbdT));
81.1049 -
81.1050 - val Abs_sbdT_inj = mk_Abs_inj_thm (#Abs_inject sbdT_loc_info);
81.1051 - val Abs_sbdT_bij = mk_Abs_bij_thm lthy Abs_sbdT_inj (#Abs_cases sbdT_loc_info);
81.1052 -
81.1053 - fun mk_sum_Cinfinite [thm] = thm
81.1054 - | mk_sum_Cinfinite (thm :: thms) =
81.1055 - @{thm Cinfinite_csum_strong} OF [thm, mk_sum_Cinfinite thms];
81.1056 -
81.1057 - val sum_Cinfinite = mk_sum_Cinfinite bd_Cinfinites;
81.1058 - val sum_Card_order = sum_Cinfinite RS conjunct2;
81.1059 -
81.1060 - fun mk_sum_card_order [thm] = thm
81.1061 - | mk_sum_card_order (thm :: thms) =
81.1062 - @{thm card_order_csum} OF [thm, mk_sum_card_order thms];
81.1063 -
81.1064 - val sum_card_order = mk_sum_card_order bd_card_orders;
81.1065 -
81.1066 - val sbd_ordIso = fold_thms lthy [sbd_def]
81.1067 - (@{thm dir_image} OF [Abs_sbdT_inj, sum_Card_order]);
81.1068 - val sbd_card_order = fold_thms lthy [sbd_def]
81.1069 - (@{thm card_order_dir_image} OF [Abs_sbdT_bij, sum_card_order]);
81.1070 - val sbd_Cinfinite = @{thm Cinfinite_cong} OF [sbd_ordIso, sum_Cinfinite];
81.1071 - val sbd_Cnotzero = sbd_Cinfinite RS @{thm Cinfinite_Cnotzero};
81.1072 - val sbd_Card_order = sbd_Cinfinite RS conjunct2;
81.1073 -
81.1074 - fun mk_set_sbd i bd_Card_order bds =
81.1075 - map (fn thm => @{thm ordLeq_ordIso_trans} OF
81.1076 - [bd_Card_order RS mk_ordLeq_csum n i thm, sbd_ordIso]) bds;
81.1077 - val set_sbdss = map3 mk_set_sbd ks bd_Card_orders set_bdss;
81.1078 -
81.1079 - fun mk_in_sbd i Co Cnz bd =
81.1080 - Cnz RS ((@{thm ordLeq_ordIso_trans} OF
81.1081 - [(Co RS mk_ordLeq_csum n i (Co RS @{thm ordLeq_refl})), sbd_ordIso]) RS
81.1082 - (bd RS @{thm ordLeq_transitive[OF _
81.1083 - cexp_mono2_Cnotzero[OF _ csum_Cnotzero2[OF ctwo_Cnotzero]]]}));
81.1084 - val in_sbds = map4 mk_in_sbd ks bd_Card_orders bd_Cnotzeros in_bds;
81.1085 - in
81.1086 - (lthy, sbd, sbdT,
81.1087 - sbd_card_order, sbd_Cinfinite, sbd_Cnotzero, sbd_Card_order, set_sbdss, in_sbds)
81.1088 - end;
81.1089 -
81.1090 - fun mk_sbd_sbd 1 = sbd_Card_order RS @{thm ordIso_refl}
81.1091 - | mk_sbd_sbd n = @{thm csum_absorb1} OF
81.1092 - [sbd_Cinfinite, mk_sbd_sbd (n - 1) RS @{thm ordIso_imp_ordLeq}];
81.1093 -
81.1094 - val sbd_sbd_thm = mk_sbd_sbd n;
81.1095 -
81.1096 - val sbdTs = replicate n sbdT;
81.1097 - val sum_sbd = Library.foldr1 (uncurry mk_csum) (replicate n sbd);
81.1098 - val sum_sbdT = mk_sumTN sbdTs;
81.1099 - val sum_sbd_listT = HOLogic.listT sum_sbdT;
81.1100 - val sum_sbd_list_setT = HOLogic.mk_setT sum_sbd_listT;
81.1101 - val bdTs = passiveAs @ replicate n sbdT;
81.1102 - val to_sbd_maps = map4 mk_map_of_bnf Dss Ass (replicate n bdTs) bnfs;
81.1103 - val bdFTs = mk_FTs bdTs;
81.1104 - val sbdFT = mk_sumTN bdFTs;
81.1105 - val treeT = HOLogic.mk_prodT (sum_sbd_list_setT, sum_sbd_listT --> sbdFT);
81.1106 - val treeQT = HOLogic.mk_setT treeT;
81.1107 - val treeTs = passiveAs @ replicate n treeT;
81.1108 - val treeQTs = passiveAs @ replicate n treeQT;
81.1109 - val treeFTs = mk_FTs treeTs;
81.1110 - val tree_maps = map4 mk_map_of_bnf Dss (replicate n bdTs) (replicate n treeTs) bnfs;
81.1111 - val final_maps = map4 mk_map_of_bnf Dss (replicate n treeTs) (replicate n treeQTs) bnfs;
81.1112 - val tree_setss = mk_setss treeTs;
81.1113 - val isNode_setss = mk_setss (passiveAs @ replicate n sbdT);
81.1114 -
81.1115 - val root = HOLogic.mk_set sum_sbd_listT [HOLogic.mk_list sum_sbdT []];
81.1116 - val Zero = HOLogic.mk_tuple (map (fn U => absdummy U root) activeAs);
81.1117 - val Lev_recT = fastype_of Zero;
81.1118 - val LevT = Library.foldr (op -->) (sTs, HOLogic.natT --> Lev_recT);
81.1119 -
81.1120 - val Nil = HOLogic.mk_tuple (map3 (fn i => fn z => fn z'=>
81.1121 - Term.absfree z' (mk_InN activeAs z i)) ks zs zs');
81.1122 - val rv_recT = fastype_of Nil;
81.1123 - val rvT = Library.foldr (op -->) (sTs, sum_sbd_listT --> rv_recT);
81.1124 -
81.1125 - val (((((((((((sumx, sumx'), (kks, kks')), (kl, kl')), (kl_copy, kl'_copy)), (Kl, Kl')),
81.1126 - (lab, lab')), (Kl_lab, Kl_lab')), xs), (Lev_rec, Lev_rec')), (rv_rec, rv_rec')),
81.1127 - names_lthy) = names_lthy
81.1128 - |> yield_singleton (apfst (op ~~) oo mk_Frees' "sumx") sum_sbdT
81.1129 - ||>> mk_Frees' "k" sbdTs
81.1130 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
81.1131 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
81.1132 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl") sum_sbd_list_setT
81.1133 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "lab") (sum_sbd_listT --> sbdFT)
81.1134 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl_lab") treeT
81.1135 - ||>> mk_Frees "x" bdFTs
81.1136 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") Lev_recT
81.1137 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") rv_recT;
81.1138 -
81.1139 - val (k, k') = (hd kks, hd kks')
81.1140 -
81.1141 - val timer = time (timer "Bounds");
81.1142 -
81.1143 - (* tree coalgebra *)
81.1144 -
81.1145 - fun isNode_bind i = Binding.suffix_name ("_" ^ isNodeN ^ (if n = 1 then "" else
81.1146 - string_of_int i)) b;
81.1147 - val isNode_name = Binding.name_of o isNode_bind;
81.1148 - val isNode_def_bind = rpair [] o Thm.def_binding o isNode_bind;
81.1149 -
81.1150 - val isNodeT =
81.1151 - Library.foldr (op -->) (map fastype_of (As @ [Kl, lab, kl]), HOLogic.boolT);
81.1152 -
81.1153 - val Succs = map3 (fn i => fn k => fn k' =>
81.1154 - HOLogic.mk_Collect (fst k', snd k', HOLogic.mk_mem (mk_InN sbdTs k i, mk_Succ Kl kl)))
81.1155 - ks kks kks';
81.1156 -
81.1157 - fun isNode_spec sets x i =
81.1158 - let
81.1159 - val (passive_sets, active_sets) = chop m (map (fn set => set $ x) sets);
81.1160 - val lhs = Term.list_comb (Free (isNode_name i, isNodeT), As @ [Kl, lab, kl]);
81.1161 - val rhs = list_exists_free [x]
81.1162 - (Library.foldr1 HOLogic.mk_conj (HOLogic.mk_eq (lab $ kl, mk_InN bdFTs x i) ::
81.1163 - map2 mk_subset passive_sets As @ map2 (curry HOLogic.mk_eq) active_sets Succs));
81.1164 - in
81.1165 - mk_Trueprop_eq (lhs, rhs)
81.1166 - end;
81.1167 -
81.1168 - val ((isNode_frees, (_, isNode_def_frees)), (lthy, lthy_old)) =
81.1169 - lthy
81.1170 - |> fold_map3 (fn i => fn x => fn sets => Specification.definition
81.1171 - (SOME (isNode_bind i, NONE, NoSyn), (isNode_def_bind i, isNode_spec sets x i)))
81.1172 - ks xs isNode_setss
81.1173 - |>> apsnd split_list o split_list
81.1174 - ||> `Local_Theory.restore;
81.1175 -
81.1176 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1177 -
81.1178 - val isNode_defs = map (Morphism.thm phi) isNode_def_frees;
81.1179 - val isNodes = map (fst o Term.dest_Const o Morphism.term phi) isNode_frees;
81.1180 -
81.1181 - fun mk_isNode As kl i =
81.1182 - Term.list_comb (Const (nth isNodes (i - 1), isNodeT), As @ [Kl, lab, kl]);
81.1183 -
81.1184 - val isTree =
81.1185 - let
81.1186 - val empty = HOLogic.mk_mem (HOLogic.mk_list sum_sbdT [], Kl);
81.1187 - val Field = mk_subset Kl (mk_Field (mk_clists sum_sbd));
81.1188 - val prefCl = mk_prefCl Kl;
81.1189 -
81.1190 - val tree = mk_Ball Kl (Term.absfree kl'
81.1191 - (HOLogic.mk_conj
81.1192 - (Library.foldr1 HOLogic.mk_disj (map (mk_isNode As kl) ks),
81.1193 - Library.foldr1 HOLogic.mk_conj (map4 (fn Succ => fn i => fn k => fn k' =>
81.1194 - mk_Ball Succ (Term.absfree k' (mk_isNode As
81.1195 - (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i])) i)))
81.1196 - Succs ks kks kks'))));
81.1197 -
81.1198 - val undef = list_all_free [kl] (HOLogic.mk_imp
81.1199 - (HOLogic.mk_not (HOLogic.mk_mem (kl, Kl)),
81.1200 - HOLogic.mk_eq (lab $ kl, mk_undefined sbdFT)));
81.1201 - in
81.1202 - Library.foldr1 HOLogic.mk_conj [empty, Field, prefCl, tree, undef]
81.1203 - end;
81.1204 -
81.1205 - fun carT_bind i = Binding.suffix_name ("_" ^ carTN ^ (if n = 1 then "" else
81.1206 - string_of_int i)) b;
81.1207 - val carT_name = Binding.name_of o carT_bind;
81.1208 - val carT_def_bind = rpair [] o Thm.def_binding o carT_bind;
81.1209 -
81.1210 - fun carT_spec i =
81.1211 - let
81.1212 - val carTT = Library.foldr (op -->) (ATs, HOLogic.mk_setT treeT);
81.1213 -
81.1214 - val lhs = Term.list_comb (Free (carT_name i, carTT), As);
81.1215 - val rhs = HOLogic.mk_Collect (fst Kl_lab', snd Kl_lab', list_exists_free [Kl, lab]
81.1216 - (HOLogic.mk_conj (HOLogic.mk_eq (Kl_lab, HOLogic.mk_prod (Kl, lab)),
81.1217 - HOLogic.mk_conj (isTree, mk_isNode As (HOLogic.mk_list sum_sbdT []) i))));
81.1218 - in
81.1219 - mk_Trueprop_eq (lhs, rhs)
81.1220 - end;
81.1221 -
81.1222 - val ((carT_frees, (_, carT_def_frees)), (lthy, lthy_old)) =
81.1223 - lthy
81.1224 - |> fold_map (fn i => Specification.definition
81.1225 - (SOME (carT_bind i, NONE, NoSyn), (carT_def_bind i, carT_spec i))) ks
81.1226 - |>> apsnd split_list o split_list
81.1227 - ||> `Local_Theory.restore;
81.1228 -
81.1229 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1230 -
81.1231 - val carT_defs = map (Morphism.thm phi) carT_def_frees;
81.1232 - val carTs = map (fst o Term.dest_Const o Morphism.term phi) carT_frees;
81.1233 -
81.1234 - fun mk_carT As i = Term.list_comb
81.1235 - (Const (nth carTs (i - 1),
81.1236 - Library.foldr (op -->) (map fastype_of As, HOLogic.mk_setT treeT)), As);
81.1237 -
81.1238 - fun strT_bind i = Binding.suffix_name ("_" ^ strTN ^ (if n = 1 then "" else
81.1239 - string_of_int i)) b;
81.1240 - val strT_name = Binding.name_of o strT_bind;
81.1241 - val strT_def_bind = rpair [] o Thm.def_binding o strT_bind;
81.1242 -
81.1243 - fun strT_spec mapFT FT i =
81.1244 - let
81.1245 - val strTT = treeT --> FT;
81.1246 -
81.1247 - fun mk_f i k k' =
81.1248 - let val in_k = mk_InN sbdTs k i;
81.1249 - in Term.absfree k' (HOLogic.mk_prod (mk_Shift Kl in_k, mk_shift lab in_k)) end;
81.1250 -
81.1251 - val f = Term.list_comb (mapFT, passive_ids @ map3 mk_f ks kks kks');
81.1252 - val (fTs1, fTs2) = apsnd tl (chop (i - 1) (map (fn T => T --> FT) bdFTs));
81.1253 - val fs = map mk_undefined fTs1 @ (f :: map mk_undefined fTs2);
81.1254 - val lhs = Free (strT_name i, strTT);
81.1255 - val rhs = HOLogic.mk_split (Term.absfree Kl' (Term.absfree lab'
81.1256 - (mk_sum_caseN fs $ (lab $ HOLogic.mk_list sum_sbdT []))));
81.1257 - in
81.1258 - mk_Trueprop_eq (lhs, rhs)
81.1259 - end;
81.1260 -
81.1261 - val ((strT_frees, (_, strT_def_frees)), (lthy, lthy_old)) =
81.1262 - lthy
81.1263 - |> fold_map3 (fn i => fn mapFT => fn FT => Specification.definition
81.1264 - (SOME (strT_bind i, NONE, NoSyn), (strT_def_bind i, strT_spec mapFT FT i)))
81.1265 - ks tree_maps treeFTs
81.1266 - |>> apsnd split_list o split_list
81.1267 - ||> `Local_Theory.restore;
81.1268 -
81.1269 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1270 -
81.1271 - val strT_defs = map ((fn def => trans OF [def RS fun_cong, @{thm prod.cases}]) o
81.1272 - Morphism.thm phi) strT_def_frees;
81.1273 - val strTs = map (fst o Term.dest_Const o Morphism.term phi) strT_frees;
81.1274 -
81.1275 - fun mk_strT FT i = Const (nth strTs (i - 1), treeT --> FT);
81.1276 -
81.1277 - val carTAs = map (mk_carT As) ks;
81.1278 - val carTAs_copy = map (mk_carT As_copy) ks;
81.1279 - val strTAs = map2 mk_strT treeFTs ks;
81.1280 - val hset_strTss = map (fn i => map2 (mk_hset strTAs i) ls passiveAs) ks;
81.1281 -
81.1282 - val coalgT_thm =
81.1283 - Skip_Proof.prove lthy [] []
81.1284 - (fold_rev Logic.all As (HOLogic.mk_Trueprop (mk_coalg As carTAs strTAs)))
81.1285 - (mk_coalgT_tac m (coalg_def :: isNode_defs @ carT_defs) strT_defs set_natural'ss)
81.1286 - |> Thm.close_derivation;
81.1287 -
81.1288 - val card_of_carT_thms =
81.1289 - let
81.1290 - val lhs = mk_card_of
81.1291 - (HOLogic.mk_Collect (fst Kl_lab', snd Kl_lab', list_exists_free [Kl, lab]
81.1292 - (HOLogic.mk_conj (HOLogic.mk_eq (Kl_lab, HOLogic.mk_prod (Kl, lab)), isTree))));
81.1293 - val rhs = mk_cexp
81.1294 - (if m = 0 then ctwo else
81.1295 - (mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo))
81.1296 - (mk_cexp sbd sbd);
81.1297 - val card_of_carT =
81.1298 - Skip_Proof.prove lthy [] []
81.1299 - (fold_rev Logic.all As (HOLogic.mk_Trueprop (mk_ordLeq lhs rhs)))
81.1300 - (K (mk_card_of_carT_tac m isNode_defs sbd_sbd_thm
81.1301 - sbd_card_order sbd_Card_order sbd_Cinfinite sbd_Cnotzero in_sbds))
81.1302 - |> Thm.close_derivation
81.1303 - in
81.1304 - map (fn def => @{thm ordLeq_transitive[OF
81.1305 - card_of_mono1[OF ord_eq_le_trans[OF _ Collect_restrict']]]} OF [def, card_of_carT])
81.1306 - carT_defs
81.1307 - end;
81.1308 -
81.1309 - val carT_set_thmss =
81.1310 - let
81.1311 - val Kl_lab = HOLogic.mk_prod (Kl, lab);
81.1312 - fun mk_goal carT strT set k i =
81.1313 - fold_rev Logic.all (sumx :: Kl :: lab :: k :: kl :: As)
81.1314 - (Logic.list_implies (map HOLogic.mk_Trueprop
81.1315 - [HOLogic.mk_mem (Kl_lab, carT), HOLogic.mk_mem (mk_Cons sumx kl, Kl),
81.1316 - HOLogic.mk_eq (sumx, mk_InN sbdTs k i)],
81.1317 - HOLogic.mk_Trueprop (HOLogic.mk_mem
81.1318 - (HOLogic.mk_prod (mk_Shift Kl sumx, mk_shift lab sumx),
81.1319 - set $ (strT $ Kl_lab)))));
81.1320 -
81.1321 - val goalss = map3 (fn carT => fn strT => fn sets =>
81.1322 - map3 (mk_goal carT strT) (drop m sets) kks ks) carTAs strTAs tree_setss;
81.1323 - in
81.1324 - map6 (fn i => fn goals =>
81.1325 - fn carT_def => fn strT_def => fn isNode_def => fn set_naturals =>
81.1326 - map2 (fn goal => fn set_natural =>
81.1327 - Skip_Proof.prove lthy [] [] goal
81.1328 - (mk_carT_set_tac n i carT_def strT_def isNode_def set_natural)
81.1329 - |> Thm.close_derivation)
81.1330 - goals (drop m set_naturals))
81.1331 - ks goalss carT_defs strT_defs isNode_defs set_natural'ss
81.1332 - end;
81.1333 -
81.1334 - val carT_set_thmss' = transpose carT_set_thmss;
81.1335 -
81.1336 - val isNode_hset_thmss =
81.1337 - let
81.1338 - val Kl_lab = HOLogic.mk_prod (Kl, lab);
81.1339 - fun mk_Kl_lab carT = HOLogic.mk_mem (Kl_lab, carT);
81.1340 -
81.1341 - val strT_hset_thmsss =
81.1342 - let
81.1343 - val strT_hset_thms =
81.1344 - let
81.1345 - fun mk_lab_kl i x = HOLogic.mk_eq (lab $ kl, mk_InN bdFTs x i);
81.1346 -
81.1347 - fun mk_inner_conjunct j T i x set i' carT =
81.1348 - HOLogic.mk_imp (HOLogic.mk_conj (mk_Kl_lab carT, mk_lab_kl i x),
81.1349 - mk_subset (set $ x) (mk_hset strTAs i' j T $ Kl_lab));
81.1350 -
81.1351 - fun mk_conjunct j T i x set =
81.1352 - Library.foldr1 HOLogic.mk_conj (map2 (mk_inner_conjunct j T i x set) ks carTAs);
81.1353 -
81.1354 - fun mk_concl j T = list_all_free (Kl :: lab :: xs @ As)
81.1355 - (HOLogic.mk_imp (HOLogic.mk_mem (kl, Kl),
81.1356 - Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T)
81.1357 - ks xs (map (fn xs => nth xs (j - 1)) isNode_setss))));
81.1358 - val concls = map2 mk_concl ls passiveAs;
81.1359 -
81.1360 - val cTs = [SOME (certifyT lthy sum_sbdT)];
81.1361 - val arg_cong_cTs = map (SOME o certifyT lthy) treeFTs;
81.1362 - val ctss =
81.1363 - map (fn phi => map (SOME o certify lthy) [Term.absfree kl' phi, kl]) concls;
81.1364 -
81.1365 - val goals = map HOLogic.mk_Trueprop concls;
81.1366 - in
81.1367 - map5 (fn j => fn goal => fn cts => fn set_incl_hsets => fn set_hset_incl_hsetss =>
81.1368 - singleton (Proof_Context.export names_lthy lthy)
81.1369 - (Skip_Proof.prove lthy [] [] goal
81.1370 - (K (mk_strT_hset_tac n m j arg_cong_cTs cTs cts
81.1371 - carT_defs strT_defs isNode_defs
81.1372 - set_incl_hsets set_hset_incl_hsetss coalg_set_thmss' carT_set_thmss'
81.1373 - coalgT_thm set_natural'ss)))
81.1374 - |> Thm.close_derivation)
81.1375 - ls goals ctss set_incl_hset_thmss' set_hset_incl_hset_thmsss''
81.1376 - end;
81.1377 -
81.1378 - val strT_hset'_thms = map (fn thm => mk_specN (2 + n + m) thm RS mp) strT_hset_thms;
81.1379 - in
81.1380 - map (fn thm => map (fn i => map (fn i' =>
81.1381 - thm RS mk_conjunctN n i RS mk_conjunctN n i' RS mp) ks) ks) strT_hset'_thms
81.1382 - end;
81.1383 -
81.1384 - val carT_prems = map (fn carT =>
81.1385 - HOLogic.mk_Trueprop (HOLogic.mk_mem (Kl_lab, carT))) carTAs_copy;
81.1386 - val prem = HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, Kl));
81.1387 - val in_prems = map (fn hsets =>
81.1388 - HOLogic.mk_Trueprop (HOLogic.mk_mem (Kl_lab, mk_in As hsets treeT))) hset_strTss;
81.1389 - val isNode_premss = replicate n (map (HOLogic.mk_Trueprop o mk_isNode As_copy kl) ks);
81.1390 - val conclss = replicate n (map (HOLogic.mk_Trueprop o mk_isNode As kl) ks);
81.1391 - in
81.1392 - map5 (fn carT_prem => fn isNode_prems => fn in_prem => fn concls => fn strT_hset_thmss =>
81.1393 - map4 (fn isNode_prem => fn concl => fn isNode_def => fn strT_hset_thms =>
81.1394 - Skip_Proof.prove lthy [] []
81.1395 - (fold_rev Logic.all (Kl :: lab :: kl :: As @ As_copy)
81.1396 - (Logic.list_implies ([carT_prem, prem, isNode_prem, in_prem], concl)))
81.1397 - (mk_isNode_hset_tac n isNode_def strT_hset_thms)
81.1398 - |> Thm.close_derivation)
81.1399 - isNode_prems concls isNode_defs
81.1400 - (if m = 0 then replicate n [] else transpose strT_hset_thmss))
81.1401 - carT_prems isNode_premss in_prems conclss
81.1402 - (if m = 0 then replicate n [] else transpose (map transpose strT_hset_thmsss))
81.1403 - end;
81.1404 -
81.1405 - val timer = time (timer "Tree coalgebra");
81.1406 -
81.1407 - fun mk_to_sbd s x i i' =
81.1408 - mk_toCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
81.1409 - fun mk_from_sbd s x i i' =
81.1410 - mk_fromCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
81.1411 -
81.1412 - fun mk_to_sbd_thmss thm = map (map (fn set_sbd =>
81.1413 - thm OF [set_sbd, sbd_Card_order]) o drop m) set_sbdss;
81.1414 -
81.1415 - val to_sbd_inj_thmss = mk_to_sbd_thmss @{thm toCard_inj};
81.1416 - val to_sbd_thmss = mk_to_sbd_thmss @{thm toCard};
81.1417 - val from_to_sbd_thmss = mk_to_sbd_thmss @{thm fromCard_toCard};
81.1418 -
81.1419 - val Lev_bind = Binding.suffix_name ("_" ^ LevN) b;
81.1420 - val Lev_name = Binding.name_of Lev_bind;
81.1421 - val Lev_def_bind = rpair [] (Thm.def_binding Lev_bind);
81.1422 -
81.1423 - val Lev_spec =
81.1424 - let
81.1425 - fun mk_Suc i s setsAs a a' =
81.1426 - let
81.1427 - val sets = drop m setsAs;
81.1428 - fun mk_set i' set b =
81.1429 - let
81.1430 - val Cons = HOLogic.mk_eq (kl_copy,
81.1431 - mk_Cons (mk_InN sbdTs (mk_to_sbd s a i i' $ b) i') kl)
81.1432 - val b_set = HOLogic.mk_mem (b, set $ (s $ a));
81.1433 - val kl_rec = HOLogic.mk_mem (kl, mk_nthN n Lev_rec i' $ b);
81.1434 - in
81.1435 - HOLogic.mk_Collect (fst kl'_copy, snd kl'_copy, list_exists_free [b, kl]
81.1436 - (HOLogic.mk_conj (Cons, HOLogic.mk_conj (b_set, kl_rec))))
81.1437 - end;
81.1438 - in
81.1439 - Term.absfree a' (Library.foldl1 mk_union (map3 mk_set ks sets zs_copy))
81.1440 - end;
81.1441 -
81.1442 - val Suc = Term.absdummy HOLogic.natT (Term.absfree Lev_rec'
81.1443 - (HOLogic.mk_tuple (map5 mk_Suc ks ss setssAs zs zs')));
81.1444 -
81.1445 - val lhs = Term.list_comb (Free (Lev_name, LevT), ss);
81.1446 - val rhs = mk_nat_rec Zero Suc;
81.1447 - in
81.1448 - mk_Trueprop_eq (lhs, rhs)
81.1449 - end;
81.1450 -
81.1451 - val ((Lev_free, (_, Lev_def_free)), (lthy, lthy_old)) =
81.1452 - lthy
81.1453 - |> Specification.definition (SOME (Lev_bind, NONE, NoSyn), (Lev_def_bind, Lev_spec))
81.1454 - ||> `Local_Theory.restore;
81.1455 -
81.1456 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1457 -
81.1458 - val Lev_def = Morphism.thm phi Lev_def_free;
81.1459 - val Lev = fst (Term.dest_Const (Morphism.term phi Lev_free));
81.1460 -
81.1461 - fun mk_Lev ss nat i =
81.1462 - let
81.1463 - val Ts = map fastype_of ss;
81.1464 - val LevT = Library.foldr (op -->) (Ts, HOLogic.natT -->
81.1465 - HOLogic.mk_tupleT (map (fn U => domain_type U --> sum_sbd_list_setT) Ts));
81.1466 - in
81.1467 - mk_nthN n (Term.list_comb (Const (Lev, LevT), ss) $ nat) i
81.1468 - end;
81.1469 -
81.1470 - val Lev_0s = flat (mk_rec_simps n @{thm nat_rec_0} [Lev_def]);
81.1471 - val Lev_Sucs = flat (mk_rec_simps n @{thm nat_rec_Suc} [Lev_def]);
81.1472 -
81.1473 - val rv_bind = Binding.suffix_name ("_" ^ rvN) b;
81.1474 - val rv_name = Binding.name_of rv_bind;
81.1475 - val rv_def_bind = rpair [] (Thm.def_binding rv_bind);
81.1476 -
81.1477 - val rv_spec =
81.1478 - let
81.1479 - fun mk_Cons i s b b' =
81.1480 - let
81.1481 - fun mk_case i' =
81.1482 - Term.absfree k' (mk_nthN n rv_rec i' $ (mk_from_sbd s b i i' $ k));
81.1483 - in
81.1484 - Term.absfree b' (mk_sum_caseN (map mk_case ks) $ sumx)
81.1485 - end;
81.1486 -
81.1487 - val Cons = Term.absfree sumx' (Term.absdummy sum_sbd_listT (Term.absfree rv_rec'
81.1488 - (HOLogic.mk_tuple (map4 mk_Cons ks ss zs zs'))));
81.1489 -
81.1490 - val lhs = Term.list_comb (Free (rv_name, rvT), ss);
81.1491 - val rhs = mk_list_rec Nil Cons;
81.1492 - in
81.1493 - mk_Trueprop_eq (lhs, rhs)
81.1494 - end;
81.1495 -
81.1496 - val ((rv_free, (_, rv_def_free)), (lthy, lthy_old)) =
81.1497 - lthy
81.1498 - |> Specification.definition (SOME (rv_bind, NONE, NoSyn), (rv_def_bind, rv_spec))
81.1499 - ||> `Local_Theory.restore;
81.1500 -
81.1501 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1502 -
81.1503 - val rv_def = Morphism.thm phi rv_def_free;
81.1504 - val rv = fst (Term.dest_Const (Morphism.term phi rv_free));
81.1505 -
81.1506 - fun mk_rv ss kl i =
81.1507 - let
81.1508 - val Ts = map fastype_of ss;
81.1509 - val As = map domain_type Ts;
81.1510 - val rvT = Library.foldr (op -->) (Ts, fastype_of kl -->
81.1511 - HOLogic.mk_tupleT (map (fn U => U --> mk_sumTN As) As));
81.1512 - in
81.1513 - mk_nthN n (Term.list_comb (Const (rv, rvT), ss) $ kl) i
81.1514 - end;
81.1515 -
81.1516 - val rv_Nils = flat (mk_rec_simps n @{thm list_rec_Nil} [rv_def]);
81.1517 - val rv_Conss = flat (mk_rec_simps n @{thm list_rec_Cons} [rv_def]);
81.1518 -
81.1519 - fun beh_bind i = Binding.suffix_name ("_" ^ behN ^ (if n = 1 then "" else
81.1520 - string_of_int i)) b;
81.1521 - val beh_name = Binding.name_of o beh_bind;
81.1522 - val beh_def_bind = rpair [] o Thm.def_binding o beh_bind;
81.1523 -
81.1524 - fun beh_spec i z =
81.1525 - let
81.1526 - val mk_behT = Library.foldr (op -->) (map fastype_of (ss @ [z]), treeT);
81.1527 -
81.1528 - fun mk_case i to_sbd_map s k k' =
81.1529 - Term.absfree k' (mk_InN bdFTs
81.1530 - (Term.list_comb (to_sbd_map, passive_ids @ map (mk_to_sbd s k i) ks) $ (s $ k)) i);
81.1531 -
81.1532 - val Lab = Term.absfree kl' (mk_If
81.1533 - (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))
81.1534 - (mk_sum_caseN (map5 mk_case ks to_sbd_maps ss zs zs') $ (mk_rv ss kl i $ z))
81.1535 - (mk_undefined sbdFT));
81.1536 -
81.1537 - val lhs = Term.list_comb (Free (beh_name i, mk_behT), ss) $ z;
81.1538 - val rhs = HOLogic.mk_prod (mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
81.1539 - (Term.absfree nat' (mk_Lev ss nat i $ z)), Lab);
81.1540 - in
81.1541 - mk_Trueprop_eq (lhs, rhs)
81.1542 - end;
81.1543 -
81.1544 - val ((beh_frees, (_, beh_def_frees)), (lthy, lthy_old)) =
81.1545 - lthy
81.1546 - |> fold_map2 (fn i => fn z => Specification.definition
81.1547 - (SOME (beh_bind i, NONE, NoSyn), (beh_def_bind i, beh_spec i z))) ks zs
81.1548 - |>> apsnd split_list o split_list
81.1549 - ||> `Local_Theory.restore;
81.1550 -
81.1551 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1552 -
81.1553 - val beh_defs = map (Morphism.thm phi) beh_def_frees;
81.1554 - val behs = map (fst o Term.dest_Const o Morphism.term phi) beh_frees;
81.1555 -
81.1556 - fun mk_beh ss i =
81.1557 - let
81.1558 - val Ts = map fastype_of ss;
81.1559 - val behT = Library.foldr (op -->) (Ts, nth activeAs (i - 1) --> treeT);
81.1560 - in
81.1561 - Term.list_comb (Const (nth behs (i - 1), behT), ss)
81.1562 - end;
81.1563 -
81.1564 - val Lev_sbd_thms =
81.1565 - let
81.1566 - fun mk_conjunct i z = mk_subset (mk_Lev ss nat i $ z) (mk_Field (mk_clists sum_sbd));
81.1567 - val goal = list_all_free zs
81.1568 - (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
81.1569 -
81.1570 - val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
81.1571 -
81.1572 - val Lev_sbd = singleton (Proof_Context.export names_lthy lthy)
81.1573 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.1574 - (K (mk_Lev_sbd_tac cts Lev_0s Lev_Sucs to_sbd_thmss))
81.1575 - |> Thm.close_derivation);
81.1576 -
81.1577 - val Lev_sbd' = mk_specN n Lev_sbd;
81.1578 - in
81.1579 - map (fn i => Lev_sbd' RS mk_conjunctN n i) ks
81.1580 - end;
81.1581 -
81.1582 - val (length_Lev_thms, length_Lev'_thms) =
81.1583 - let
81.1584 - fun mk_conjunct i z = HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
81.1585 - HOLogic.mk_eq (mk_size kl, nat));
81.1586 - val goal = list_all_free (kl :: zs)
81.1587 - (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
81.1588 -
81.1589 - val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
81.1590 -
81.1591 - val length_Lev = singleton (Proof_Context.export names_lthy lthy)
81.1592 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.1593 - (K (mk_length_Lev_tac cts Lev_0s Lev_Sucs))
81.1594 - |> Thm.close_derivation);
81.1595 -
81.1596 - val length_Lev' = mk_specN (n + 1) length_Lev;
81.1597 - val length_Levs = map (fn i => length_Lev' RS mk_conjunctN n i RS mp) ks;
81.1598 -
81.1599 - fun mk_goal i z = fold_rev Logic.all (z :: kl :: nat :: ss) (Logic.mk_implies
81.1600 - (HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z)),
81.1601 - HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))));
81.1602 - val goals = map2 mk_goal ks zs;
81.1603 -
81.1604 - val length_Levs' = map2 (fn goal => fn length_Lev =>
81.1605 - Skip_Proof.prove lthy [] [] goal (K (mk_length_Lev'_tac length_Lev))
81.1606 - |> Thm.close_derivation) goals length_Levs;
81.1607 - in
81.1608 - (length_Levs, length_Levs')
81.1609 - end;
81.1610 -
81.1611 - val prefCl_Lev_thms =
81.1612 - let
81.1613 - fun mk_conjunct i z = HOLogic.mk_imp
81.1614 - (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), mk_subset kl_copy kl),
81.1615 - HOLogic.mk_mem (kl_copy, mk_Lev ss (mk_size kl_copy) i $ z));
81.1616 - val goal = list_all_free (kl :: kl_copy :: zs)
81.1617 - (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
81.1618 -
81.1619 - val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
81.1620 -
81.1621 - val prefCl_Lev = singleton (Proof_Context.export names_lthy lthy)
81.1622 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.1623 - (K (mk_prefCl_Lev_tac cts Lev_0s Lev_Sucs)))
81.1624 - |> Thm.close_derivation;
81.1625 -
81.1626 - val prefCl_Lev' = mk_specN (n + 2) prefCl_Lev;
81.1627 - in
81.1628 - map (fn i => prefCl_Lev' RS mk_conjunctN n i RS mp) ks
81.1629 - end;
81.1630 -
81.1631 - val rv_last_thmss =
81.1632 - let
81.1633 - fun mk_conjunct i z i' z_copy = list_exists_free [z_copy]
81.1634 - (HOLogic.mk_eq
81.1635 - (mk_rv ss (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i'])) i $ z,
81.1636 - mk_InN activeAs z_copy i'));
81.1637 - val goal = list_all_free (k :: zs)
81.1638 - (Library.foldr1 HOLogic.mk_conj (map2 (fn i => fn z =>
81.1639 - Library.foldr1 HOLogic.mk_conj
81.1640 - (map2 (mk_conjunct i z) ks zs_copy)) ks zs));
81.1641 -
81.1642 - val cTs = [SOME (certifyT lthy sum_sbdT)];
81.1643 - val cts = map (SOME o certify lthy) [Term.absfree kl' goal, kl];
81.1644 -
81.1645 - val rv_last = singleton (Proof_Context.export names_lthy lthy)
81.1646 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.1647 - (K (mk_rv_last_tac cTs cts rv_Nils rv_Conss)))
81.1648 - |> Thm.close_derivation;
81.1649 -
81.1650 - val rv_last' = mk_specN (n + 1) rv_last;
81.1651 - in
81.1652 - map (fn i => map (fn i' => rv_last' RS mk_conjunctN n i RS mk_conjunctN n i') ks) ks
81.1653 - end;
81.1654 -
81.1655 - val set_rv_Lev_thmsss = if m = 0 then replicate n (replicate n []) else
81.1656 - let
81.1657 - fun mk_case s sets z z_free = Term.absfree z_free (Library.foldr1 HOLogic.mk_conj
81.1658 - (map2 (fn set => fn A => mk_subset (set $ (s $ z)) A) (take m sets) As));
81.1659 -
81.1660 - fun mk_conjunct i z B = HOLogic.mk_imp
81.1661 - (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), HOLogic.mk_mem (z, B)),
81.1662 - mk_sum_caseN (map4 mk_case ss setssAs zs zs') $ (mk_rv ss kl i $ z));
81.1663 -
81.1664 - val goal = list_all_free (kl :: zs)
81.1665 - (Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct ks zs Bs));
81.1666 -
81.1667 - val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
81.1668 -
81.1669 - val set_rv_Lev = singleton (Proof_Context.export names_lthy lthy)
81.1670 - (Skip_Proof.prove lthy [] []
81.1671 - (Logic.mk_implies (coalg_prem, HOLogic.mk_Trueprop goal))
81.1672 - (K (mk_set_rv_Lev_tac m cts Lev_0s Lev_Sucs rv_Nils rv_Conss
81.1673 - coalg_set_thmss from_to_sbd_thmss)))
81.1674 - |> Thm.close_derivation;
81.1675 -
81.1676 - val set_rv_Lev' = mk_specN (n + 1) set_rv_Lev;
81.1677 - in
81.1678 - map (fn i => map (fn i' =>
81.1679 - split_conj_thm (if n = 1 then set_rv_Lev' RS mk_conjunctN n i RS mp
81.1680 - else set_rv_Lev' RS mk_conjunctN n i RS mp RSN
81.1681 - (2, @{thm sum_case_weak_cong} RS @{thm subst[of _ _ "%x. x"]}) RS
81.1682 - (mk_sum_casesN n i' RS @{thm subst[of _ _ "%x. x"]}))) ks) ks
81.1683 - end;
81.1684 -
81.1685 - val set_Lev_thmsss =
81.1686 - let
81.1687 - fun mk_conjunct i z =
81.1688 - let
81.1689 - fun mk_conjunct' i' sets s z' =
81.1690 - let
81.1691 - fun mk_conjunct'' i'' set z'' = HOLogic.mk_imp
81.1692 - (HOLogic.mk_mem (z'', set $ (s $ z')),
81.1693 - HOLogic.mk_mem (mk_append (kl,
81.1694 - HOLogic.mk_list sum_sbdT [mk_InN sbdTs (mk_to_sbd s z' i' i'' $ z'') i'']),
81.1695 - mk_Lev ss (HOLogic.mk_Suc nat) i $ z));
81.1696 - in
81.1697 - HOLogic.mk_imp (HOLogic.mk_eq (mk_rv ss kl i $ z, mk_InN activeAs z' i'),
81.1698 - (Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct'' ks (drop m sets) zs_copy2)))
81.1699 - end;
81.1700 - in
81.1701 - HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
81.1702 - Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct' ks setssAs ss zs_copy))
81.1703 - end;
81.1704 -
81.1705 - val goal = list_all_free (kl :: zs @ zs_copy @ zs_copy2)
81.1706 - (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
81.1707 -
81.1708 - val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
81.1709 -
81.1710 - val set_Lev = singleton (Proof_Context.export names_lthy lthy)
81.1711 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.1712 - (K (mk_set_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbd_thmss)))
81.1713 - |> Thm.close_derivation;
81.1714 -
81.1715 - val set_Lev' = mk_specN (3 * n + 1) set_Lev;
81.1716 - in
81.1717 - map (fn i => map (fn i' => map (fn i'' => set_Lev' RS
81.1718 - mk_conjunctN n i RS mp RS
81.1719 - mk_conjunctN n i' RS mp RS
81.1720 - mk_conjunctN n i'' RS mp) ks) ks) ks
81.1721 - end;
81.1722 -
81.1723 - val set_image_Lev_thmsss =
81.1724 - let
81.1725 - fun mk_conjunct i z =
81.1726 - let
81.1727 - fun mk_conjunct' i' sets =
81.1728 - let
81.1729 - fun mk_conjunct'' i'' set s z'' = HOLogic.mk_imp
81.1730 - (HOLogic.mk_eq (mk_rv ss kl i $ z, mk_InN activeAs z'' i''),
81.1731 - HOLogic.mk_mem (k, mk_image (mk_to_sbd s z'' i'' i') $ (set $ (s $ z''))));
81.1732 - in
81.1733 - HOLogic.mk_imp (HOLogic.mk_mem
81.1734 - (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i']),
81.1735 - mk_Lev ss (HOLogic.mk_Suc nat) i $ z),
81.1736 - (Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct'' ks sets ss zs_copy)))
81.1737 - end;
81.1738 - in
81.1739 - HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
81.1740 - Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct' ks (drop m setssAs')))
81.1741 - end;
81.1742 -
81.1743 - val goal = list_all_free (kl :: k :: zs @ zs_copy)
81.1744 - (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
81.1745 -
81.1746 - val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
81.1747 -
81.1748 - val set_image_Lev = singleton (Proof_Context.export names_lthy lthy)
81.1749 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.1750 - (K (mk_set_image_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss
81.1751 - from_to_sbd_thmss to_sbd_inj_thmss)))
81.1752 - |> Thm.close_derivation;
81.1753 -
81.1754 - val set_image_Lev' = mk_specN (2 * n + 2) set_image_Lev;
81.1755 - in
81.1756 - map (fn i => map (fn i' => map (fn i'' => set_image_Lev' RS
81.1757 - mk_conjunctN n i RS mp RS
81.1758 - mk_conjunctN n i'' RS mp RS
81.1759 - mk_conjunctN n i' RS mp) ks) ks) ks
81.1760 - end;
81.1761 -
81.1762 - val mor_beh_thm =
81.1763 - Skip_Proof.prove lthy [] []
81.1764 - (fold_rev Logic.all (As @ Bs @ ss) (Logic.mk_implies (coalg_prem,
81.1765 - HOLogic.mk_Trueprop (mk_mor Bs ss carTAs strTAs (map (mk_beh ss) ks)))))
81.1766 - (mk_mor_beh_tac m mor_def mor_cong_thm
81.1767 - beh_defs carT_defs strT_defs isNode_defs
81.1768 - to_sbd_inj_thmss from_to_sbd_thmss Lev_0s Lev_Sucs rv_Nils rv_Conss Lev_sbd_thms
81.1769 - length_Lev_thms length_Lev'_thms prefCl_Lev_thms rv_last_thmss
81.1770 - set_rv_Lev_thmsss set_Lev_thmsss set_image_Lev_thmsss
81.1771 - set_natural'ss coalg_set_thmss map_comp_id_thms map_congs map_arg_cong_thms)
81.1772 - |> Thm.close_derivation;
81.1773 -
81.1774 - val timer = time (timer "Behavioral morphism");
81.1775 -
81.1776 - fun mk_LSBIS As i = mk_lsbis As (map (mk_carT As) ks) strTAs i;
81.1777 - fun mk_car_final As i =
81.1778 - mk_quotient (mk_carT As i) (mk_LSBIS As i);
81.1779 - fun mk_str_final As i =
81.1780 - mk_univ (HOLogic.mk_comp (Term.list_comb (nth final_maps (i - 1),
81.1781 - passive_ids @ map (mk_proj o mk_LSBIS As) ks), nth strTAs (i - 1)));
81.1782 -
81.1783 - val car_finalAs = map (mk_car_final As) ks;
81.1784 - val str_finalAs = map (mk_str_final As) ks;
81.1785 - val car_finals = map (mk_car_final passive_UNIVs) ks;
81.1786 - val str_finals = map (mk_str_final passive_UNIVs) ks;
81.1787 -
81.1788 - val coalgT_set_thmss = map (map (fn thm => coalgT_thm RS thm)) coalg_set_thmss;
81.1789 - val equiv_LSBIS_thms = map (fn thm => coalgT_thm RS thm) equiv_lsbis_thms;
81.1790 -
81.1791 - val congruent_str_final_thms =
81.1792 - let
81.1793 - fun mk_goal R final_map strT =
81.1794 - fold_rev Logic.all As (HOLogic.mk_Trueprop
81.1795 - (mk_congruent R (HOLogic.mk_comp
81.1796 - (Term.list_comb (final_map, passive_ids @ map (mk_proj o mk_LSBIS As) ks), strT))));
81.1797 -
81.1798 - val goals = map3 mk_goal (map (mk_LSBIS As) ks) final_maps strTAs;
81.1799 - in
81.1800 - map4 (fn goal => fn lsbisE => fn map_comp_id => fn map_cong =>
81.1801 - Skip_Proof.prove lthy [] [] goal
81.1802 - (K (mk_congruent_str_final_tac m lsbisE map_comp_id map_cong equiv_LSBIS_thms))
81.1803 - |> Thm.close_derivation)
81.1804 - goals lsbisE_thms map_comp_id_thms map_congs
81.1805 - end;
81.1806 -
81.1807 - val coalg_final_thm = Skip_Proof.prove lthy [] [] (fold_rev Logic.all As
81.1808 - (HOLogic.mk_Trueprop (mk_coalg As car_finalAs str_finalAs)))
81.1809 - (K (mk_coalg_final_tac m coalg_def congruent_str_final_thms equiv_LSBIS_thms
81.1810 - set_natural'ss coalgT_set_thmss))
81.1811 - |> Thm.close_derivation;
81.1812 -
81.1813 - val mor_T_final_thm = Skip_Proof.prove lthy [] [] (fold_rev Logic.all As
81.1814 - (HOLogic.mk_Trueprop (mk_mor carTAs strTAs car_finalAs str_finalAs
81.1815 - (map (mk_proj o mk_LSBIS As) ks))))
81.1816 - (K (mk_mor_T_final_tac mor_def congruent_str_final_thms equiv_LSBIS_thms))
81.1817 - |> Thm.close_derivation;
81.1818 -
81.1819 - val mor_final_thm = mor_comp_thm OF [mor_beh_thm, mor_T_final_thm];
81.1820 - val in_car_final_thms = map (fn mor_image' => mor_image' OF
81.1821 - [tcoalg_thm RS mor_final_thm, UNIV_I]) mor_image'_thms;
81.1822 -
81.1823 - val timer = time (timer "Final coalgebra");
81.1824 -
81.1825 - val ((T_names, (T_glob_infos, T_loc_infos)), lthy) =
81.1826 - lthy
81.1827 - |> fold_map4 (fn b => fn mx => fn car_final => fn in_car_final =>
81.1828 - typedef false NONE (b, params, mx) car_final NONE
81.1829 - (EVERY' [rtac exI, rtac in_car_final] 1)) bs mixfixes car_finals in_car_final_thms
81.1830 - |>> apsnd split_list o split_list;
81.1831 -
81.1832 - val Ts = map (fn name => Type (name, params')) T_names;
81.1833 - fun mk_Ts passive = map (Term.typ_subst_atomic (passiveAs ~~ passive)) Ts;
81.1834 - val Ts' = mk_Ts passiveBs;
81.1835 - val Ts'' = mk_Ts passiveCs;
81.1836 - val Rep_Ts = map2 (fn info => fn T => Const (#Rep_name info, T --> treeQT)) T_glob_infos Ts;
81.1837 - val Abs_Ts = map2 (fn info => fn T => Const (#Abs_name info, treeQT --> T)) T_glob_infos Ts;
81.1838 -
81.1839 - val Reps = map #Rep T_loc_infos;
81.1840 - val Rep_injects = map #Rep_inject T_loc_infos;
81.1841 - val Rep_inverses = map #Rep_inverse T_loc_infos;
81.1842 - val Abs_inverses = map #Abs_inverse T_loc_infos;
81.1843 -
81.1844 - val timer = time (timer "THE TYPEDEFs & Rep/Abs thms");
81.1845 -
81.1846 - val UNIVs = map HOLogic.mk_UNIV Ts;
81.1847 - val FTs = mk_FTs (passiveAs @ Ts);
81.1848 - val FTs' = mk_FTs (passiveBs @ Ts);
81.1849 - val prodTs = map (HOLogic.mk_prodT o `I) Ts;
81.1850 - val prodFTs = mk_FTs (passiveAs @ prodTs);
81.1851 - val FTs_setss = mk_setss (passiveAs @ Ts);
81.1852 - val prodFT_setss = mk_setss (passiveAs @ prodTs);
81.1853 - val map_FTs = map2 (fn Ds => mk_map_of_bnf Ds treeQTs (passiveAs @ Ts)) Dss bnfs;
81.1854 - val map_FT_nths = map2 (fn Ds =>
81.1855 - mk_map_of_bnf Ds (passiveAs @ prodTs) (passiveAs @ Ts)) Dss bnfs;
81.1856 - val fstsTs = map fst_const prodTs;
81.1857 - val sndsTs = map snd_const prodTs;
81.1858 - val dtorTs = map2 (curry (op -->)) Ts FTs;
81.1859 - val ctorTs = map2 (curry (op -->)) FTs Ts;
81.1860 - val unfold_fTs = map2 (curry op -->) activeAs Ts;
81.1861 - val corec_sTs = map (Term.typ_subst_atomic (activeBs ~~ Ts)) sum_sTs;
81.1862 - val corec_maps = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_Inls;
81.1863 - val corec_maps_rev = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_Inls_rev;
81.1864 - val corec_Inls = map (Term.subst_atomic_types (activeBs ~~ Ts)) Inls;
81.1865 -
81.1866 - val (((((((((((((Jzs, Jzs'), (Jz's, Jz's')), Jzs_copy), Jzs1), Jzs2), Jpairs),
81.1867 - FJzs), TRs), unfold_fs), unfold_fs_copy), corec_ss), phis), names_lthy) = names_lthy
81.1868 - |> mk_Frees' "z" Ts
81.1869 - ||>> mk_Frees' "z" Ts'
81.1870 - ||>> mk_Frees "z" Ts
81.1871 - ||>> mk_Frees "z1" Ts
81.1872 - ||>> mk_Frees "z2" Ts
81.1873 - ||>> mk_Frees "j" (map2 (curry HOLogic.mk_prodT) Ts Ts')
81.1874 - ||>> mk_Frees "x" prodFTs
81.1875 - ||>> mk_Frees "R" (map (mk_relT o `I) Ts)
81.1876 - ||>> mk_Frees "f" unfold_fTs
81.1877 - ||>> mk_Frees "g" unfold_fTs
81.1878 - ||>> mk_Frees "s" corec_sTs
81.1879 - ||>> mk_Frees "P" (map2 mk_pred2T Ts Ts);
81.1880 -
81.1881 - fun dtor_bind i = Binding.suffix_name ("_" ^ dtorN) (nth bs (i - 1));
81.1882 - val dtor_name = Binding.name_of o dtor_bind;
81.1883 - val dtor_def_bind = rpair [] o Thm.def_binding o dtor_bind;
81.1884 -
81.1885 - fun dtor_spec i rep str map_FT dtorT Jz Jz' =
81.1886 - let
81.1887 - val lhs = Free (dtor_name i, dtorT);
81.1888 - val rhs = Term.absfree Jz'
81.1889 - (Term.list_comb (map_FT, map HOLogic.id_const passiveAs @ Abs_Ts) $
81.1890 - (str $ (rep $ Jz)));
81.1891 - in
81.1892 - mk_Trueprop_eq (lhs, rhs)
81.1893 - end;
81.1894 -
81.1895 - val ((dtor_frees, (_, dtor_def_frees)), (lthy, lthy_old)) =
81.1896 - lthy
81.1897 - |> fold_map7 (fn i => fn rep => fn str => fn mapx => fn dtorT => fn Jz => fn Jz' =>
81.1898 - Specification.definition (SOME (dtor_bind i, NONE, NoSyn),
81.1899 - (dtor_def_bind i, dtor_spec i rep str mapx dtorT Jz Jz')))
81.1900 - ks Rep_Ts str_finals map_FTs dtorTs Jzs Jzs'
81.1901 - |>> apsnd split_list o split_list
81.1902 - ||> `Local_Theory.restore;
81.1903 -
81.1904 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1905 - fun mk_dtors passive =
81.1906 - map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ (mk_params passive)) o
81.1907 - Morphism.term phi) dtor_frees;
81.1908 - val dtors = mk_dtors passiveAs;
81.1909 - val dtor's = mk_dtors passiveBs;
81.1910 - val dtor_defs = map ((fn thm => thm RS fun_cong) o Morphism.thm phi) dtor_def_frees;
81.1911 -
81.1912 - val coalg_final_set_thmss = map (map (fn thm => coalg_final_thm RS thm)) coalg_set_thmss;
81.1913 - val (mor_Rep_thm, mor_Abs_thm) =
81.1914 - let
81.1915 - val mor_Rep =
81.1916 - Skip_Proof.prove lthy [] []
81.1917 - (HOLogic.mk_Trueprop (mk_mor UNIVs dtors car_finals str_finals Rep_Ts))
81.1918 - (mk_mor_Rep_tac m (mor_def :: dtor_defs) Reps Abs_inverses coalg_final_set_thmss
81.1919 - map_comp_id_thms map_congL_thms)
81.1920 - |> Thm.close_derivation;
81.1921 -
81.1922 - val mor_Abs =
81.1923 - Skip_Proof.prove lthy [] []
81.1924 - (HOLogic.mk_Trueprop (mk_mor car_finals str_finals UNIVs dtors Abs_Ts))
81.1925 - (mk_mor_Abs_tac (mor_def :: dtor_defs) Abs_inverses)
81.1926 - |> Thm.close_derivation;
81.1927 - in
81.1928 - (mor_Rep, mor_Abs)
81.1929 - end;
81.1930 -
81.1931 - val timer = time (timer "dtor definitions & thms");
81.1932 -
81.1933 - fun unfold_bind i = Binding.suffix_name ("_" ^ dtor_unfoldN) (nth bs (i - 1));
81.1934 - val unfold_name = Binding.name_of o unfold_bind;
81.1935 - val unfold_def_bind = rpair [] o Thm.def_binding o unfold_bind;
81.1936 -
81.1937 - fun unfold_spec i T AT abs f z z' =
81.1938 - let
81.1939 - val unfoldT = Library.foldr (op -->) (sTs, AT --> T);
81.1940 -
81.1941 - val lhs = Term.list_comb (Free (unfold_name i, unfoldT), ss);
81.1942 - val rhs = Term.absfree z' (abs $ (f $ z));
81.1943 - in
81.1944 - mk_Trueprop_eq (lhs, rhs)
81.1945 - end;
81.1946 -
81.1947 - val ((unfold_frees, (_, unfold_def_frees)), (lthy, lthy_old)) =
81.1948 - lthy
81.1949 - |> fold_map7 (fn i => fn T => fn AT => fn abs => fn f => fn z => fn z' =>
81.1950 - Specification.definition
81.1951 - (SOME (unfold_bind i, NONE, NoSyn), (unfold_def_bind i, unfold_spec i T AT abs f z z')))
81.1952 - ks Ts activeAs Abs_Ts (map (fn i => HOLogic.mk_comp
81.1953 - (mk_proj (mk_LSBIS passive_UNIVs i), mk_beh ss i)) ks) zs zs'
81.1954 - |>> apsnd split_list o split_list
81.1955 - ||> `Local_Theory.restore;
81.1956 -
81.1957 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.1958 - val unfolds = map (Morphism.term phi) unfold_frees;
81.1959 - val unfold_names = map (fst o dest_Const) unfolds;
81.1960 - fun mk_unfold Ts ss i = Term.list_comb (Const (nth unfold_names (i - 1), Library.foldr (op -->)
81.1961 - (map fastype_of ss, domain_type (fastype_of (nth ss (i - 1))) --> nth Ts (i - 1))), ss);
81.1962 - val unfold_defs = map ((fn thm => thm RS fun_cong) o Morphism.thm phi) unfold_def_frees;
81.1963 -
81.1964 - val mor_unfold_thm =
81.1965 - let
81.1966 - val Abs_inverses' = map2 (curry op RS) in_car_final_thms Abs_inverses;
81.1967 - val morEs' = map (fn thm =>
81.1968 - (thm OF [tcoalg_thm RS mor_final_thm, UNIV_I]) RS sym) morE_thms;
81.1969 - in
81.1970 - Skip_Proof.prove lthy [] []
81.1971 - (fold_rev Logic.all ss
81.1972 - (HOLogic.mk_Trueprop (mk_mor active_UNIVs ss UNIVs dtors (map (mk_unfold Ts ss) ks))))
81.1973 - (K (mk_mor_unfold_tac m mor_UNIV_thm dtor_defs unfold_defs Abs_inverses' morEs'
81.1974 - map_comp_id_thms map_congs))
81.1975 - |> Thm.close_derivation
81.1976 - end;
81.1977 - val dtor_unfold_thms = map (fn thm => (thm OF [mor_unfold_thm, UNIV_I]) RS sym) morE_thms;
81.1978 -
81.1979 - val (raw_coind_thms, raw_coind_thm) =
81.1980 - let
81.1981 - val prem = HOLogic.mk_Trueprop (mk_sbis passive_UNIVs UNIVs dtors TRs);
81.1982 - val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.1983 - (map2 (fn R => fn T => mk_subset R (Id_const T)) TRs Ts));
81.1984 - val goal = fold_rev Logic.all TRs (Logic.mk_implies (prem, concl));
81.1985 - in
81.1986 - `split_conj_thm (Skip_Proof.prove lthy [] [] goal
81.1987 - (K (mk_raw_coind_tac bis_def bis_cong_thm bis_O_thm bis_converse_thm bis_Gr_thm
81.1988 - tcoalg_thm coalgT_thm mor_T_final_thm sbis_lsbis_thm
81.1989 - lsbis_incl_thms incl_lsbis_thms equiv_LSBIS_thms mor_Rep_thm Rep_injects))
81.1990 - |> Thm.close_derivation)
81.1991 - end;
81.1992 -
81.1993 - val unique_mor_thms =
81.1994 - let
81.1995 - val prems = [HOLogic.mk_Trueprop (mk_coalg passive_UNIVs Bs ss), HOLogic.mk_Trueprop
81.1996 - (HOLogic.mk_conj (mk_mor Bs ss UNIVs dtors unfold_fs,
81.1997 - mk_mor Bs ss UNIVs dtors unfold_fs_copy))];
81.1998 - fun mk_fun_eq B f g z = HOLogic.mk_imp
81.1999 - (HOLogic.mk_mem (z, B), HOLogic.mk_eq (f $ z, g $ z));
81.2000 - val unique = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2001 - (map4 mk_fun_eq Bs unfold_fs unfold_fs_copy zs));
81.2002 -
81.2003 - val unique_mor = Skip_Proof.prove lthy [] []
81.2004 - (fold_rev Logic.all (Bs @ ss @ unfold_fs @ unfold_fs_copy @ zs)
81.2005 - (Logic.list_implies (prems, unique)))
81.2006 - (K (mk_unique_mor_tac raw_coind_thms bis_image2_thm))
81.2007 - |> Thm.close_derivation;
81.2008 - in
81.2009 - map (fn thm => conjI RSN (2, thm RS mp)) (split_conj_thm unique_mor)
81.2010 - end;
81.2011 -
81.2012 - val (unfold_unique_mor_thms, unfold_unique_mor_thm) =
81.2013 - let
81.2014 - val prem = HOLogic.mk_Trueprop (mk_mor active_UNIVs ss UNIVs dtors unfold_fs);
81.2015 - fun mk_fun_eq f i = HOLogic.mk_eq (f, mk_unfold Ts ss i);
81.2016 - val unique = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2017 - (map2 mk_fun_eq unfold_fs ks));
81.2018 -
81.2019 - val bis_thm = tcoalg_thm RSN (2, tcoalg_thm RS bis_image2_thm);
81.2020 - val mor_thm = mor_comp_thm OF [tcoalg_thm RS mor_final_thm, mor_Abs_thm];
81.2021 -
81.2022 - val unique_mor = Skip_Proof.prove lthy [] []
81.2023 - (fold_rev Logic.all (ss @ unfold_fs) (Logic.mk_implies (prem, unique)))
81.2024 - (K (mk_unfold_unique_mor_tac raw_coind_thms bis_thm mor_thm unfold_defs))
81.2025 - |> Thm.close_derivation;
81.2026 - in
81.2027 - `split_conj_thm unique_mor
81.2028 - end;
81.2029 -
81.2030 - val (dtor_unfold_unique_thms, dtor_unfold_unique_thm) = `split_conj_thm (split_conj_prems n
81.2031 - (mor_UNIV_thm RS @{thm ssubst[of _ _ "%x. x"]} RS unfold_unique_mor_thm));
81.2032 -
81.2033 - val unfold_dtor_thms = map (fn thm => mor_id_thm RS thm RS sym) unfold_unique_mor_thms;
81.2034 -
81.2035 - val unfold_o_dtor_thms =
81.2036 - let
81.2037 - val mor = mor_comp_thm OF [mor_str_thm, mor_unfold_thm];
81.2038 - in
81.2039 - map2 (fn unique => fn unfold_ctor =>
81.2040 - trans OF [mor RS unique, unfold_ctor]) unfold_unique_mor_thms unfold_dtor_thms
81.2041 - end;
81.2042 -
81.2043 - val timer = time (timer "unfold definitions & thms");
81.2044 -
81.2045 - val map_dtors = map2 (fn Ds => fn bnf =>
81.2046 - Term.list_comb (mk_map_of_bnf Ds (passiveAs @ Ts) (passiveAs @ FTs) bnf,
81.2047 - map HOLogic.id_const passiveAs @ dtors)) Dss bnfs;
81.2048 -
81.2049 - fun ctor_bind i = Binding.suffix_name ("_" ^ ctorN) (nth bs (i - 1));
81.2050 - val ctor_name = Binding.name_of o ctor_bind;
81.2051 - val ctor_def_bind = rpair [] o Thm.def_binding o ctor_bind;
81.2052 -
81.2053 - fun ctor_spec i ctorT =
81.2054 - let
81.2055 - val lhs = Free (ctor_name i, ctorT);
81.2056 - val rhs = mk_unfold Ts map_dtors i;
81.2057 - in
81.2058 - mk_Trueprop_eq (lhs, rhs)
81.2059 - end;
81.2060 -
81.2061 - val ((ctor_frees, (_, ctor_def_frees)), (lthy, lthy_old)) =
81.2062 - lthy
81.2063 - |> fold_map2 (fn i => fn ctorT =>
81.2064 - Specification.definition
81.2065 - (SOME (ctor_bind i, NONE, NoSyn), (ctor_def_bind i, ctor_spec i ctorT))) ks ctorTs
81.2066 - |>> apsnd split_list o split_list
81.2067 - ||> `Local_Theory.restore;
81.2068 -
81.2069 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.2070 - fun mk_ctors params =
81.2071 - map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ params) o Morphism.term phi)
81.2072 - ctor_frees;
81.2073 - val ctors = mk_ctors params';
81.2074 - val ctor_defs = map (Morphism.thm phi) ctor_def_frees;
81.2075 -
81.2076 - val ctor_o_dtor_thms = map2 (fold_thms lthy o single) ctor_defs unfold_o_dtor_thms;
81.2077 -
81.2078 - val dtor_o_ctor_thms =
81.2079 - let
81.2080 - fun mk_goal dtor ctor FT =
81.2081 - mk_Trueprop_eq (HOLogic.mk_comp (dtor, ctor), HOLogic.id_const FT);
81.2082 - val goals = map3 mk_goal dtors ctors FTs;
81.2083 - in
81.2084 - map5 (fn goal => fn ctor_def => fn unfold => fn map_comp_id => fn map_congL =>
81.2085 - Skip_Proof.prove lthy [] [] goal
81.2086 - (mk_dtor_o_ctor_tac ctor_def unfold map_comp_id map_congL unfold_o_dtor_thms)
81.2087 - |> Thm.close_derivation)
81.2088 - goals ctor_defs dtor_unfold_thms map_comp_id_thms map_congL_thms
81.2089 - end;
81.2090 -
81.2091 - val dtor_ctor_thms = map (fn thm => thm RS @{thm pointfree_idE}) dtor_o_ctor_thms;
81.2092 - val ctor_dtor_thms = map (fn thm => thm RS @{thm pointfree_idE}) ctor_o_dtor_thms;
81.2093 -
81.2094 - val bij_dtor_thms =
81.2095 - map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) ctor_o_dtor_thms dtor_o_ctor_thms;
81.2096 - val inj_dtor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_dtor_thms;
81.2097 - val surj_dtor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_dtor_thms;
81.2098 - val dtor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_dtor_thms;
81.2099 - val dtor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_dtor_thms;
81.2100 - val dtor_exhaust_thms = map (fn thm => thm RS exE) dtor_nchotomy_thms;
81.2101 -
81.2102 - val bij_ctor_thms =
81.2103 - map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) dtor_o_ctor_thms ctor_o_dtor_thms;
81.2104 - val inj_ctor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_ctor_thms;
81.2105 - val surj_ctor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_ctor_thms;
81.2106 - val ctor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_ctor_thms;
81.2107 - val ctor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_ctor_thms;
81.2108 - val ctor_exhaust_thms = map (fn thm => thm RS exE) ctor_nchotomy_thms;
81.2109 -
81.2110 - fun mk_ctor_dtor_unfold_like_thm dtor_inject dtor_ctor unfold =
81.2111 - iffD1 OF [dtor_inject, trans OF [unfold, dtor_ctor RS sym]];
81.2112 -
81.2113 - val ctor_dtor_unfold_thms =
81.2114 - map3 mk_ctor_dtor_unfold_like_thm dtor_inject_thms dtor_ctor_thms dtor_unfold_thms;
81.2115 -
81.2116 - val timer = time (timer "ctor definitions & thms");
81.2117 -
81.2118 - val corec_Inl_sum_thms =
81.2119 - let
81.2120 - val mor = mor_comp_thm OF [mor_sum_case_thm, mor_unfold_thm];
81.2121 - in
81.2122 - map2 (fn unique => fn unfold_dtor =>
81.2123 - trans OF [mor RS unique, unfold_dtor]) unfold_unique_mor_thms unfold_dtor_thms
81.2124 - end;
81.2125 -
81.2126 - fun corec_bind i = Binding.suffix_name ("_" ^ dtor_corecN) (nth bs (i - 1));
81.2127 - val corec_name = Binding.name_of o corec_bind;
81.2128 - val corec_def_bind = rpair [] o Thm.def_binding o corec_bind;
81.2129 -
81.2130 - fun corec_spec i T AT =
81.2131 - let
81.2132 - val corecT = Library.foldr (op -->) (corec_sTs, AT --> T);
81.2133 - val maps = map3 (fn dtor => fn sum_s => fn mapx => mk_sum_case
81.2134 - (HOLogic.mk_comp (Term.list_comb (mapx, passive_ids @ corec_Inls), dtor), sum_s))
81.2135 - dtors corec_ss corec_maps;
81.2136 -
81.2137 - val lhs = Term.list_comb (Free (corec_name i, corecT), corec_ss);
81.2138 - val rhs = HOLogic.mk_comp (mk_unfold Ts maps i, Inr_const T AT);
81.2139 - in
81.2140 - mk_Trueprop_eq (lhs, rhs)
81.2141 - end;
81.2142 -
81.2143 - val ((corec_frees, (_, corec_def_frees)), (lthy, lthy_old)) =
81.2144 - lthy
81.2145 - |> fold_map3 (fn i => fn T => fn AT =>
81.2146 - Specification.definition
81.2147 - (SOME (corec_bind i, NONE, NoSyn), (corec_def_bind i, corec_spec i T AT)))
81.2148 - ks Ts activeAs
81.2149 - |>> apsnd split_list o split_list
81.2150 - ||> `Local_Theory.restore;
81.2151 -
81.2152 - val phi = Proof_Context.export_morphism lthy_old lthy;
81.2153 - val corecs = map (Morphism.term phi) corec_frees;
81.2154 - val corec_names = map (fst o dest_Const) corecs;
81.2155 - fun mk_corec ss i = Term.list_comb (Const (nth corec_names (i - 1), Library.foldr (op -->)
81.2156 - (map fastype_of ss, domain_type (fastype_of (nth ss (i - 1))) --> nth Ts (i - 1))), ss);
81.2157 - val corec_defs = map (Morphism.thm phi) corec_def_frees;
81.2158 -
81.2159 - val sum_cases =
81.2160 - map2 (fn T => fn i => mk_sum_case (HOLogic.id_const T, mk_corec corec_ss i)) Ts ks;
81.2161 - val dtor_corec_thms =
81.2162 - let
81.2163 - fun mk_goal i corec_s corec_map dtor z =
81.2164 - let
81.2165 - val lhs = dtor $ (mk_corec corec_ss i $ z);
81.2166 - val rhs = Term.list_comb (corec_map, passive_ids @ sum_cases) $ (corec_s $ z);
81.2167 - in
81.2168 - fold_rev Logic.all (z :: corec_ss) (mk_Trueprop_eq (lhs, rhs))
81.2169 - end;
81.2170 - val goals = map5 mk_goal ks corec_ss corec_maps_rev dtors zs;
81.2171 - in
81.2172 - map3 (fn goal => fn unfold => fn map_cong =>
81.2173 - Skip_Proof.prove lthy [] [] goal
81.2174 - (mk_corec_tac m corec_defs unfold map_cong corec_Inl_sum_thms)
81.2175 - |> Thm.close_derivation)
81.2176 - goals dtor_unfold_thms map_congs
81.2177 - end;
81.2178 -
81.2179 - val ctor_dtor_corec_thms =
81.2180 - map3 mk_ctor_dtor_unfold_like_thm dtor_inject_thms dtor_ctor_thms dtor_corec_thms;
81.2181 -
81.2182 - val timer = time (timer "corec definitions & thms");
81.2183 -
81.2184 - val (dtor_coinduct_thm, coinduct_params, srel_coinduct_thm, rel_coinduct_thm,
81.2185 - dtor_strong_coinduct_thm, srel_strong_coinduct_thm, rel_strong_coinduct_thm) =
81.2186 - let
81.2187 - val zs = Jzs1 @ Jzs2;
81.2188 - val frees = phis @ zs;
81.2189 -
81.2190 - fun mk_Ids Id = if Id then map Id_const passiveAs else map mk_diag passive_UNIVs;
81.2191 -
81.2192 - fun mk_phi upto_eq phi z1 z2 = if upto_eq
81.2193 - then Term.absfree (dest_Free z1) (Term.absfree (dest_Free z2)
81.2194 - (HOLogic.mk_disj (phi $ z1 $ z2, HOLogic.mk_eq (z1, z2))))
81.2195 - else phi;
81.2196 -
81.2197 - fun phi_srels upto_eq = map4 (fn phi => fn T => fn z1 => fn z2 =>
81.2198 - HOLogic.Collect_const (HOLogic.mk_prodT (T, T)) $
81.2199 - HOLogic.mk_split (mk_phi upto_eq phi z1 z2)) phis Ts Jzs1 Jzs2;
81.2200 -
81.2201 - val srels = map (Term.subst_atomic_types ((activeAs ~~ Ts) @ (activeBs ~~ Ts))) relsAsBs;
81.2202 -
81.2203 - fun mk_concl phi z1 z2 = HOLogic.mk_imp (phi $ z1 $ z2, HOLogic.mk_eq (z1, z2));
81.2204 - val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2205 - (map3 mk_concl phis Jzs1 Jzs2));
81.2206 -
81.2207 - fun mk_srel_prem upto_eq phi dtor srel Jz Jz_copy =
81.2208 - let
81.2209 - val concl = HOLogic.mk_mem (HOLogic.mk_tuple [dtor $ Jz, dtor $ Jz_copy],
81.2210 - Term.list_comb (srel, mk_Ids upto_eq @ phi_srels upto_eq));
81.2211 - in
81.2212 - HOLogic.mk_Trueprop
81.2213 - (list_all_free [Jz, Jz_copy] (HOLogic.mk_imp (phi $ Jz $ Jz_copy, concl)))
81.2214 - end;
81.2215 -
81.2216 - val srel_prems = map5 (mk_srel_prem false) phis dtors srels Jzs Jzs_copy;
81.2217 - val srel_upto_prems = map5 (mk_srel_prem true) phis dtors srels Jzs Jzs_copy;
81.2218 -
81.2219 - val srel_coinduct_goal = fold_rev Logic.all frees (Logic.list_implies (srel_prems, concl));
81.2220 - val coinduct_params = rev (Term.add_tfrees srel_coinduct_goal []);
81.2221 -
81.2222 - val srel_coinduct = unfold_thms lthy @{thms diag_UNIV}
81.2223 - (Skip_Proof.prove lthy [] [] srel_coinduct_goal
81.2224 - (K (mk_srel_coinduct_tac ks raw_coind_thm bis_srel_thm))
81.2225 - |> Thm.close_derivation);
81.2226 -
81.2227 - fun mk_dtor_prem upto_eq phi dtor map_nth sets Jz Jz_copy FJz =
81.2228 - let
81.2229 - val xs = [Jz, Jz_copy];
81.2230 -
81.2231 - fun mk_map_conjunct nths x =
81.2232 - HOLogic.mk_eq (Term.list_comb (map_nth, passive_ids @ nths) $ FJz, dtor $ x);
81.2233 -
81.2234 - fun mk_set_conjunct set phi z1 z2 =
81.2235 - list_all_free [z1, z2]
81.2236 - (HOLogic.mk_imp (HOLogic.mk_mem (HOLogic.mk_prod (z1, z2), set $ FJz),
81.2237 - mk_phi upto_eq phi z1 z2 $ z1 $ z2));
81.2238 -
81.2239 - val concl = list_exists_free [FJz] (HOLogic.mk_conj
81.2240 - (Library.foldr1 HOLogic.mk_conj (map2 mk_map_conjunct [fstsTs, sndsTs] xs),
81.2241 - Library.foldr1 HOLogic.mk_conj
81.2242 - (map4 mk_set_conjunct (drop m sets) phis Jzs1 Jzs2)));
81.2243 - in
81.2244 - fold_rev Logic.all xs (Logic.mk_implies
81.2245 - (HOLogic.mk_Trueprop (Term.list_comb (phi, xs)), HOLogic.mk_Trueprop concl))
81.2246 - end;
81.2247 -
81.2248 - fun mk_dtor_prems upto_eq =
81.2249 - map7 (mk_dtor_prem upto_eq) phis dtors map_FT_nths prodFT_setss Jzs Jzs_copy FJzs;
81.2250 -
81.2251 - val dtor_prems = mk_dtor_prems false;
81.2252 - val dtor_upto_prems = mk_dtor_prems true;
81.2253 -
81.2254 - val dtor_coinduct_goal = fold_rev Logic.all frees (Logic.list_implies (dtor_prems, concl));
81.2255 - val dtor_coinduct = Skip_Proof.prove lthy [] [] dtor_coinduct_goal
81.2256 - (K (mk_dtor_coinduct_tac m ks raw_coind_thm bis_def))
81.2257 - |> Thm.close_derivation;
81.2258 -
81.2259 - val cTs = map (SOME o certifyT lthy o TFree) coinduct_params;
81.2260 - val cts = map3 (SOME o certify lthy ooo mk_phi true) phis Jzs1 Jzs2;
81.2261 -
81.2262 - val srel_strong_coinduct = singleton (Proof_Context.export names_lthy lthy)
81.2263 - (Skip_Proof.prove lthy [] []
81.2264 - (fold_rev Logic.all zs (Logic.list_implies (srel_upto_prems, concl)))
81.2265 - (K (mk_srel_strong_coinduct_tac m cTs cts srel_coinduct srel_monos srel_Ids)))
81.2266 - |> Thm.close_derivation;
81.2267 -
81.2268 - val dtor_strong_coinduct = singleton (Proof_Context.export names_lthy lthy)
81.2269 - (Skip_Proof.prove lthy [] []
81.2270 - (fold_rev Logic.all zs (Logic.list_implies (dtor_upto_prems, concl)))
81.2271 - (K (mk_dtor_strong_coinduct_tac ks cTs cts dtor_coinduct bis_def
81.2272 - (tcoalg_thm RS bis_diag_thm))))
81.2273 - |> Thm.close_derivation;
81.2274 -
81.2275 - val rel_of_srel_thms =
81.2276 - srel_defs @ @{thms Id_def' mem_Collect_eq fst_conv snd_conv split_conv};
81.2277 -
81.2278 - val rel_coinduct = unfold_thms lthy rel_of_srel_thms srel_coinduct;
81.2279 - val rel_strong_coinduct = unfold_thms lthy rel_of_srel_thms srel_strong_coinduct;
81.2280 - in
81.2281 - (dtor_coinduct, rev (Term.add_tfrees dtor_coinduct_goal []), srel_coinduct, rel_coinduct,
81.2282 - dtor_strong_coinduct, srel_strong_coinduct, rel_strong_coinduct)
81.2283 - end;
81.2284 -
81.2285 - val timer = time (timer "coinduction");
81.2286 -
81.2287 - (*register new codatatypes as BNFs*)
81.2288 - val lthy = if m = 0 then lthy else
81.2289 - let
81.2290 - val fTs = map2 (curry op -->) passiveAs passiveBs;
81.2291 - val gTs = map2 (curry op -->) passiveBs passiveCs;
81.2292 - val f1Ts = map2 (curry op -->) passiveAs passiveYs;
81.2293 - val f2Ts = map2 (curry op -->) passiveBs passiveYs;
81.2294 - val p1Ts = map2 (curry op -->) passiveXs passiveAs;
81.2295 - val p2Ts = map2 (curry op -->) passiveXs passiveBs;
81.2296 - val pTs = map2 (curry op -->) passiveXs passiveCs;
81.2297 - val uTs = map2 (curry op -->) Ts Ts';
81.2298 - val JRTs = map2 (curry mk_relT) passiveAs passiveBs;
81.2299 - val JphiTs = map2 mk_pred2T passiveAs passiveBs;
81.2300 - val prodTs = map2 (curry HOLogic.mk_prodT) Ts Ts';
81.2301 - val B1Ts = map HOLogic.mk_setT passiveAs;
81.2302 - val B2Ts = map HOLogic.mk_setT passiveBs;
81.2303 - val AXTs = map HOLogic.mk_setT passiveXs;
81.2304 - val XTs = mk_Ts passiveXs;
81.2305 - val YTs = mk_Ts passiveYs;
81.2306 -
81.2307 - val ((((((((((((((((((((fs, fs'), fs_copy), gs), us),
81.2308 - (Jys, Jys')), (Jys_copy, Jys'_copy)), set_induct_phiss), JRs), Jphis),
81.2309 - B1s), B2s), AXs), f1s), f2s), p1s), p2s), ps), (ys, ys')), (ys_copy, ys'_copy)),
81.2310 - names_lthy) = names_lthy
81.2311 - |> mk_Frees' "f" fTs
81.2312 - ||>> mk_Frees "f" fTs
81.2313 - ||>> mk_Frees "g" gTs
81.2314 - ||>> mk_Frees "u" uTs
81.2315 - ||>> mk_Frees' "b" Ts'
81.2316 - ||>> mk_Frees' "b" Ts'
81.2317 - ||>> mk_Freess "P" (map (fn A => map (mk_pred2T A) Ts) passiveAs)
81.2318 - ||>> mk_Frees "R" JRTs
81.2319 - ||>> mk_Frees "P" JphiTs
81.2320 - ||>> mk_Frees "B1" B1Ts
81.2321 - ||>> mk_Frees "B2" B2Ts
81.2322 - ||>> mk_Frees "A" AXTs
81.2323 - ||>> mk_Frees "f1" f1Ts
81.2324 - ||>> mk_Frees "f2" f2Ts
81.2325 - ||>> mk_Frees "p1" p1Ts
81.2326 - ||>> mk_Frees "p2" p2Ts
81.2327 - ||>> mk_Frees "p" pTs
81.2328 - ||>> mk_Frees' "y" passiveAs
81.2329 - ||>> mk_Frees' "y" passiveAs;
81.2330 -
81.2331 - val map_FTFT's = map2 (fn Ds =>
81.2332 - mk_map_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
81.2333 -
81.2334 - fun mk_maps ATs BTs Ts mk_T =
81.2335 - map2 (fn Ds => mk_map_of_bnf Ds (ATs @ Ts) (BTs @ map mk_T Ts)) Dss bnfs;
81.2336 - fun mk_Fmap mk_const fs Ts Fmap = Term.list_comb (Fmap, fs @ map mk_const Ts);
81.2337 - fun mk_map mk_const mk_T Ts fs Ts' dtors mk_maps =
81.2338 - mk_unfold Ts' (map2 (fn dtor => fn Fmap =>
81.2339 - HOLogic.mk_comp (mk_Fmap mk_const fs Ts Fmap, dtor)) dtors (mk_maps Ts mk_T));
81.2340 - val mk_map_id = mk_map HOLogic.id_const I;
81.2341 - val mk_mapsAB = mk_maps passiveAs passiveBs;
81.2342 - val mk_mapsBC = mk_maps passiveBs passiveCs;
81.2343 - val mk_mapsAC = mk_maps passiveAs passiveCs;
81.2344 - val mk_mapsAY = mk_maps passiveAs passiveYs;
81.2345 - val mk_mapsBY = mk_maps passiveBs passiveYs;
81.2346 - val mk_mapsXA = mk_maps passiveXs passiveAs;
81.2347 - val mk_mapsXB = mk_maps passiveXs passiveBs;
81.2348 - val mk_mapsXC = mk_maps passiveXs passiveCs;
81.2349 - val fs_maps = map (mk_map_id Ts fs Ts' dtors mk_mapsAB) ks;
81.2350 - val fs_copy_maps = map (mk_map_id Ts fs_copy Ts' dtors mk_mapsAB) ks;
81.2351 - val gs_maps = map (mk_map_id Ts' gs Ts'' dtor's mk_mapsBC) ks;
81.2352 - val fgs_maps =
81.2353 - map (mk_map_id Ts (map2 (curry HOLogic.mk_comp) gs fs) Ts'' dtors mk_mapsAC) ks;
81.2354 - val Xdtors = mk_dtors passiveXs;
81.2355 - val UNIV's = map HOLogic.mk_UNIV Ts';
81.2356 - val CUNIVs = map HOLogic.mk_UNIV passiveCs;
81.2357 - val UNIV''s = map HOLogic.mk_UNIV Ts'';
81.2358 - val fstsTsTs' = map fst_const prodTs;
81.2359 - val sndsTsTs' = map snd_const prodTs;
81.2360 - val dtor''s = mk_dtors passiveCs;
81.2361 - val f1s_maps = map (mk_map_id Ts f1s YTs dtors mk_mapsAY) ks;
81.2362 - val f2s_maps = map (mk_map_id Ts' f2s YTs dtor's mk_mapsBY) ks;
81.2363 - val pid_maps = map (mk_map_id XTs ps Ts'' Xdtors mk_mapsXC) ks;
81.2364 - val pfst_Fmaps =
81.2365 - map (mk_Fmap fst_const p1s prodTs) (mk_mapsXA prodTs (fst o HOLogic.dest_prodT));
81.2366 - val psnd_Fmaps =
81.2367 - map (mk_Fmap snd_const p2s prodTs) (mk_mapsXB prodTs (snd o HOLogic.dest_prodT));
81.2368 - val p1id_Fmaps = map (mk_Fmap HOLogic.id_const p1s prodTs) (mk_mapsXA prodTs I);
81.2369 - val p2id_Fmaps = map (mk_Fmap HOLogic.id_const p2s prodTs) (mk_mapsXB prodTs I);
81.2370 - val pid_Fmaps = map (mk_Fmap HOLogic.id_const ps prodTs) (mk_mapsXC prodTs I);
81.2371 -
81.2372 - val (map_simp_thms, map_thms) =
81.2373 - let
81.2374 - fun mk_goal fs_map map dtor dtor' = fold_rev Logic.all fs
81.2375 - (mk_Trueprop_eq (HOLogic.mk_comp (dtor', fs_map),
81.2376 - HOLogic.mk_comp (Term.list_comb (map, fs @ fs_maps), dtor)));
81.2377 - val goals = map4 mk_goal fs_maps map_FTFT's dtors dtor's;
81.2378 - val cTs = map (SOME o certifyT lthy) FTs';
81.2379 - val maps =
81.2380 - map5 (fn goal => fn cT => fn unfold => fn map_comp' => fn map_cong =>
81.2381 - Skip_Proof.prove lthy [] [] goal
81.2382 - (K (mk_map_tac m n cT unfold map_comp' map_cong))
81.2383 - |> Thm.close_derivation)
81.2384 - goals cTs dtor_unfold_thms map_comp's map_congs;
81.2385 - in
81.2386 - map_split (fn thm => (thm RS @{thm pointfreeE}, thm)) maps
81.2387 - end;
81.2388 -
81.2389 - val map_comp_thms =
81.2390 - let
81.2391 - val goal = fold_rev Logic.all (fs @ gs)
81.2392 - (HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2393 - (map3 (fn fmap => fn gmap => fn fgmap =>
81.2394 - HOLogic.mk_eq (HOLogic.mk_comp (gmap, fmap), fgmap))
81.2395 - fs_maps gs_maps fgs_maps)))
81.2396 - in
81.2397 - split_conj_thm (Skip_Proof.prove lthy [] [] goal
81.2398 - (K (mk_map_comp_tac m n map_thms map_comps map_congs dtor_unfold_unique_thm))
81.2399 - |> Thm.close_derivation)
81.2400 - end;
81.2401 -
81.2402 - val map_unique_thm =
81.2403 - let
81.2404 - fun mk_prem u map dtor dtor' =
81.2405 - mk_Trueprop_eq (HOLogic.mk_comp (dtor', u),
81.2406 - HOLogic.mk_comp (Term.list_comb (map, fs @ us), dtor));
81.2407 - val prems = map4 mk_prem us map_FTFT's dtors dtor's;
81.2408 - val goal =
81.2409 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2410 - (map2 (curry HOLogic.mk_eq) us fs_maps));
81.2411 - in
81.2412 - Skip_Proof.prove lthy [] []
81.2413 - (fold_rev Logic.all (us @ fs) (Logic.list_implies (prems, goal)))
81.2414 - (mk_map_unique_tac dtor_unfold_unique_thm map_comps)
81.2415 - |> Thm.close_derivation
81.2416 - end;
81.2417 -
81.2418 - val timer = time (timer "map functions for the new codatatypes");
81.2419 -
81.2420 - val bd = mk_ccexp sbd sbd;
81.2421 -
81.2422 - val timer = time (timer "bounds for the new codatatypes");
81.2423 -
81.2424 - val setss_by_bnf = map (fn i => map2 (mk_hset dtors i) ls passiveAs) ks;
81.2425 - val setss_by_bnf' = map (fn i => map2 (mk_hset dtor's i) ls passiveBs) ks;
81.2426 - val setss_by_range = transpose setss_by_bnf;
81.2427 -
81.2428 - val set_simp_thmss =
81.2429 - let
81.2430 - fun mk_simp_goal relate pas_set act_sets sets dtor z set =
81.2431 - relate (set $ z, mk_union (pas_set $ (dtor $ z),
81.2432 - Library.foldl1 mk_union
81.2433 - (map2 (fn X => mk_UNION (X $ (dtor $ z))) act_sets sets)));
81.2434 - fun mk_goals eq =
81.2435 - map2 (fn i => fn sets =>
81.2436 - map4 (fn Fsets =>
81.2437 - mk_simp_goal eq (nth Fsets (i - 1)) (drop m Fsets) sets)
81.2438 - FTs_setss dtors Jzs sets)
81.2439 - ls setss_by_range;
81.2440 -
81.2441 - val le_goals = map
81.2442 - (fold_rev Logic.all Jzs o HOLogic.mk_Trueprop o Library.foldr1 HOLogic.mk_conj)
81.2443 - (mk_goals (uncurry mk_subset));
81.2444 - val set_le_thmss = map split_conj_thm
81.2445 - (map4 (fn goal => fn hset_minimal => fn set_hsets => fn set_hset_hsetss =>
81.2446 - Skip_Proof.prove lthy [] [] goal
81.2447 - (K (mk_set_le_tac n hset_minimal set_hsets set_hset_hsetss))
81.2448 - |> Thm.close_derivation)
81.2449 - le_goals hset_minimal_thms set_hset_thmss' set_hset_hset_thmsss');
81.2450 -
81.2451 - val simp_goalss = map (map2 (fn z => fn goal =>
81.2452 - Logic.all z (HOLogic.mk_Trueprop goal)) Jzs)
81.2453 - (mk_goals HOLogic.mk_eq);
81.2454 - in
81.2455 - map4 (map4 (fn goal => fn set_le => fn set_incl_hset => fn set_hset_incl_hsets =>
81.2456 - Skip_Proof.prove lthy [] [] goal
81.2457 - (K (mk_set_simp_tac n set_le set_incl_hset set_hset_incl_hsets))
81.2458 - |> Thm.close_derivation))
81.2459 - simp_goalss set_le_thmss set_incl_hset_thmss' set_hset_incl_hset_thmsss'
81.2460 - end;
81.2461 -
81.2462 - val timer = time (timer "set functions for the new codatatypes");
81.2463 -
81.2464 - val colss = map2 (fn j => fn T =>
81.2465 - map (fn i => mk_hset_rec dtors nat i j T) ks) ls passiveAs;
81.2466 - val colss' = map2 (fn j => fn T =>
81.2467 - map (fn i => mk_hset_rec dtor's nat i j T) ks) ls passiveBs;
81.2468 - val Xcolss = map2 (fn j => fn T =>
81.2469 - map (fn i => mk_hset_rec Xdtors nat i j T) ks) ls passiveXs;
81.2470 -
81.2471 - val col_natural_thmss =
81.2472 - let
81.2473 - fun mk_col_natural f map z col col' =
81.2474 - HOLogic.mk_eq (mk_image f $ (col $ z), col' $ (map $ z));
81.2475 -
81.2476 - fun mk_goal f cols cols' = list_all_free Jzs (Library.foldr1 HOLogic.mk_conj
81.2477 - (map4 (mk_col_natural f) fs_maps Jzs cols cols'));
81.2478 -
81.2479 - val goals = map3 mk_goal fs colss colss';
81.2480 -
81.2481 - val ctss =
81.2482 - map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) goals;
81.2483 -
81.2484 - val thms =
81.2485 - map4 (fn goal => fn cts => fn rec_0s => fn rec_Sucs =>
81.2486 - singleton (Proof_Context.export names_lthy lthy)
81.2487 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.2488 - (mk_col_natural_tac cts rec_0s rec_Sucs map_simp_thms set_natural'ss))
81.2489 - |> Thm.close_derivation)
81.2490 - goals ctss hset_rec_0ss' hset_rec_Sucss';
81.2491 - in
81.2492 - map (split_conj_thm o mk_specN n) thms
81.2493 - end;
81.2494 -
81.2495 - val col_bd_thmss =
81.2496 - let
81.2497 - fun mk_col_bd z col = mk_ordLeq (mk_card_of (col $ z)) sbd;
81.2498 -
81.2499 - fun mk_goal cols = list_all_free Jzs (Library.foldr1 HOLogic.mk_conj
81.2500 - (map2 mk_col_bd Jzs cols));
81.2501 -
81.2502 - val goals = map mk_goal colss;
81.2503 -
81.2504 - val ctss =
81.2505 - map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) goals;
81.2506 -
81.2507 - val thms =
81.2508 - map5 (fn j => fn goal => fn cts => fn rec_0s => fn rec_Sucs =>
81.2509 - singleton (Proof_Context.export names_lthy lthy)
81.2510 - (Skip_Proof.prove lthy [] [] (HOLogic.mk_Trueprop goal)
81.2511 - (K (mk_col_bd_tac m j cts rec_0s rec_Sucs
81.2512 - sbd_Card_order sbd_Cinfinite set_sbdss)))
81.2513 - |> Thm.close_derivation)
81.2514 - ls goals ctss hset_rec_0ss' hset_rec_Sucss';
81.2515 - in
81.2516 - map (split_conj_thm o mk_specN n) thms
81.2517 - end;
81.2518 -
81.2519 - val map_cong_thms =
81.2520 - let
81.2521 - val cTs = map (SOME o certifyT lthy o
81.2522 - Term.typ_subst_atomic (passiveAs ~~ passiveBs) o TFree) coinduct_params;
81.2523 -
81.2524 - fun mk_prem z set f g y y' =
81.2525 - mk_Ball (set $ z) (Term.absfree y' (HOLogic.mk_eq (f $ y, g $ y)));
81.2526 -
81.2527 - fun mk_prems sets z =
81.2528 - Library.foldr1 HOLogic.mk_conj (map5 (mk_prem z) sets fs fs_copy ys ys')
81.2529 -
81.2530 - fun mk_map_cong sets z fmap gmap =
81.2531 - HOLogic.mk_imp (mk_prems sets z, HOLogic.mk_eq (fmap $ z, gmap $ z));
81.2532 -
81.2533 - fun mk_coind_body sets (x, T) z fmap gmap y y_copy =
81.2534 - HOLogic.mk_conj
81.2535 - (HOLogic.mk_mem (z, HOLogic.mk_Collect (x, T, mk_prems sets z)),
81.2536 - HOLogic.mk_conj (HOLogic.mk_eq (y, fmap $ z),
81.2537 - HOLogic.mk_eq (y_copy, gmap $ z)))
81.2538 -
81.2539 - fun mk_cphi sets (z' as (x, T)) z fmap gmap y' y y'_copy y_copy =
81.2540 - HOLogic.mk_exists (x, T, mk_coind_body sets z' z fmap gmap y y_copy)
81.2541 - |> Term.absfree y'_copy
81.2542 - |> Term.absfree y'
81.2543 - |> certify lthy;
81.2544 -
81.2545 - val cphis =
81.2546 - map9 mk_cphi setss_by_bnf Jzs' Jzs fs_maps fs_copy_maps Jys' Jys Jys'_copy Jys_copy;
81.2547 -
81.2548 - val coinduct = Drule.instantiate' cTs (map SOME cphis) dtor_coinduct_thm;
81.2549 -
81.2550 - val goal =
81.2551 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2552 - (map4 mk_map_cong setss_by_bnf Jzs fs_maps fs_copy_maps));
81.2553 -
81.2554 - val thm = singleton (Proof_Context.export names_lthy lthy)
81.2555 - (Skip_Proof.prove lthy [] [] goal
81.2556 - (K (mk_mcong_tac m (rtac coinduct) map_comp's map_simp_thms map_congs set_natural'ss
81.2557 - set_hset_thmss set_hset_hset_thmsss)))
81.2558 - |> Thm.close_derivation
81.2559 - in
81.2560 - split_conj_thm thm
81.2561 - end;
81.2562 -
81.2563 - val B1_ins = map2 (mk_in B1s) setss_by_bnf Ts;
81.2564 - val B2_ins = map2 (mk_in B2s) setss_by_bnf' Ts';
81.2565 - val thePulls = map4 mk_thePull B1_ins B2_ins f1s_maps f2s_maps;
81.2566 - val thePullTs = passiveXs @ map2 (curry HOLogic.mk_prodT) Ts Ts';
81.2567 - val thePull_ins = map2 (mk_in (AXs @ thePulls)) (mk_setss thePullTs) (mk_FTs thePullTs);
81.2568 - val pickFs = map5 mk_pickWP thePull_ins pfst_Fmaps psnd_Fmaps
81.2569 - (map2 (curry (op $)) dtors Jzs) (map2 (curry (op $)) dtor's Jz's);
81.2570 - val pickF_ss = map3 (fn pickF => fn z => fn z' =>
81.2571 - HOLogic.mk_split (Term.absfree z (Term.absfree z' pickF))) pickFs Jzs' Jz's';
81.2572 - val picks = map (mk_unfold XTs pickF_ss) ks;
81.2573 -
81.2574 - val wpull_prem = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
81.2575 - (map8 mk_wpull AXs B1s B2s f1s f2s (replicate m NONE) p1s p2s));
81.2576 -
81.2577 - val map_eq_thms = map2 (fn simp => fn diff => box_equals OF [diff RS iffD2, simp, simp])
81.2578 - map_simp_thms dtor_inject_thms;
81.2579 - val map_wpull_thms = map (fn thm => thm OF
81.2580 - (replicate m asm_rl @ replicate n @{thm wpull_thePull})) map_wpulls;
81.2581 - val pickWP_assms_tacs =
81.2582 - map3 mk_pickWP_assms_tac set_incl_hset_thmss set_incl_hin_thmss map_eq_thms;
81.2583 -
81.2584 - val coalg_thePull_thm =
81.2585 - let
81.2586 - val coalg = HOLogic.mk_Trueprop
81.2587 - (mk_coalg CUNIVs thePulls (map2 (curry HOLogic.mk_comp) pid_Fmaps pickF_ss));
81.2588 - val goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s @ ps)
81.2589 - (Logic.mk_implies (wpull_prem, coalg));
81.2590 - in
81.2591 - Skip_Proof.prove lthy [] [] goal (mk_coalg_thePull_tac m coalg_def map_wpull_thms
81.2592 - set_natural'ss pickWP_assms_tacs)
81.2593 - |> Thm.close_derivation
81.2594 - end;
81.2595 -
81.2596 - val (mor_thePull_fst_thm, mor_thePull_snd_thm, mor_thePull_pick_thm) =
81.2597 - let
81.2598 - val mor_fst = HOLogic.mk_Trueprop
81.2599 - (mk_mor thePulls (map2 (curry HOLogic.mk_comp) p1id_Fmaps pickF_ss)
81.2600 - UNIVs dtors fstsTsTs');
81.2601 - val mor_snd = HOLogic.mk_Trueprop
81.2602 - (mk_mor thePulls (map2 (curry HOLogic.mk_comp) p2id_Fmaps pickF_ss)
81.2603 - UNIV's dtor's sndsTsTs');
81.2604 - val mor_pick = HOLogic.mk_Trueprop
81.2605 - (mk_mor thePulls (map2 (curry HOLogic.mk_comp) pid_Fmaps pickF_ss)
81.2606 - UNIV''s dtor''s (map2 (curry HOLogic.mk_comp) pid_maps picks));
81.2607 -
81.2608 - val fst_goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
81.2609 - (Logic.mk_implies (wpull_prem, mor_fst));
81.2610 - val snd_goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s)
81.2611 - (Logic.mk_implies (wpull_prem, mor_snd));
81.2612 - val pick_goal = fold_rev Logic.all (AXs @ B1s @ B2s @ f1s @ f2s @ p1s @ p2s @ ps)
81.2613 - (Logic.mk_implies (wpull_prem, mor_pick));
81.2614 - in
81.2615 - (Skip_Proof.prove lthy [] [] fst_goal (mk_mor_thePull_fst_tac m mor_def map_wpull_thms
81.2616 - map_comp's pickWP_assms_tacs) |> Thm.close_derivation,
81.2617 - Skip_Proof.prove lthy [] [] snd_goal (mk_mor_thePull_snd_tac m mor_def map_wpull_thms
81.2618 - map_comp's pickWP_assms_tacs) |> Thm.close_derivation,
81.2619 - Skip_Proof.prove lthy [] [] pick_goal (mk_mor_thePull_pick_tac mor_def dtor_unfold_thms
81.2620 - map_comp's) |> Thm.close_derivation)
81.2621 - end;
81.2622 -
81.2623 - val pick_col_thmss =
81.2624 - let
81.2625 - fun mk_conjunct AX Jpair pick thePull col =
81.2626 - HOLogic.mk_imp (HOLogic.mk_mem (Jpair, thePull), mk_subset (col $ (pick $ Jpair)) AX);
81.2627 -
81.2628 - fun mk_concl AX cols =
81.2629 - list_all_free Jpairs (Library.foldr1 HOLogic.mk_conj
81.2630 - (map4 (mk_conjunct AX) Jpairs picks thePulls cols));
81.2631 -
81.2632 - val concls = map2 mk_concl AXs Xcolss;
81.2633 -
81.2634 - val ctss =
81.2635 - map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
81.2636 -
81.2637 - val goals =
81.2638 - map (fn concl => Logic.mk_implies (wpull_prem, HOLogic.mk_Trueprop concl)) concls;
81.2639 -
81.2640 - val thms =
81.2641 - map5 (fn j => fn goal => fn cts => fn rec_0s => fn rec_Sucs =>
81.2642 - singleton (Proof_Context.export names_lthy lthy) (Skip_Proof.prove lthy [] [] goal
81.2643 - (mk_pick_col_tac m j cts rec_0s rec_Sucs dtor_unfold_thms set_natural'ss
81.2644 - map_wpull_thms pickWP_assms_tacs))
81.2645 - |> Thm.close_derivation)
81.2646 - ls goals ctss hset_rec_0ss' hset_rec_Sucss';
81.2647 - in
81.2648 - map (map (fn thm => thm RS mp) o split_conj_thm o mk_specN n) thms
81.2649 - end;
81.2650 -
81.2651 - val timer = time (timer "helpers for BNF properties");
81.2652 -
81.2653 - val map_id_tacs =
81.2654 - map2 (K oo mk_map_id_tac map_thms) dtor_unfold_unique_thms unfold_dtor_thms;
81.2655 - val map_comp_tacs = map (fn thm => K (rtac (thm RS sym) 1)) map_comp_thms;
81.2656 - val map_cong_tacs = map (mk_map_cong_tac m) map_cong_thms;
81.2657 - val set_nat_tacss =
81.2658 - map2 (map2 (K oo mk_set_natural_tac)) hset_defss (transpose col_natural_thmss);
81.2659 -
81.2660 - val bd_co_tacs = replicate n (K (mk_bd_card_order_tac sbd_card_order));
81.2661 - val bd_cinf_tacs = replicate n (K (mk_bd_cinfinite_tac sbd_Cinfinite));
81.2662 -
81.2663 - val set_bd_tacss =
81.2664 - map2 (map2 (K oo mk_set_bd_tac sbd_Cinfinite)) hset_defss (transpose col_bd_thmss);
81.2665 -
81.2666 - val in_bd_tacs = map7 (fn i => fn isNode_hsets => fn carT_def =>
81.2667 - fn card_of_carT => fn mor_image => fn Rep_inverse => fn mor_hsets =>
81.2668 - K (mk_in_bd_tac (nth isNode_hsets (i - 1)) isNode_hsets carT_def
81.2669 - card_of_carT mor_image Rep_inverse mor_hsets
81.2670 - sbd_Cnotzero sbd_Card_order mor_Rep_thm coalgT_thm mor_T_final_thm tcoalg_thm))
81.2671 - ks isNode_hset_thmss carT_defs card_of_carT_thms
81.2672 - mor_image'_thms Rep_inverses (transpose mor_hset_thmss);
81.2673 -
81.2674 - val map_wpull_tacs =
81.2675 - map3 (K ooo mk_wpull_tac m coalg_thePull_thm mor_thePull_fst_thm mor_thePull_snd_thm
81.2676 - mor_thePull_pick_thm) unique_mor_thms (transpose pick_col_thmss) hset_defss;
81.2677 -
81.2678 - val srel_O_Gr_tacs = replicate n (simple_srel_O_Gr_tac o #context);
81.2679 -
81.2680 - val tacss = map10 zip_axioms map_id_tacs map_comp_tacs map_cong_tacs set_nat_tacss
81.2681 - bd_co_tacs bd_cinf_tacs set_bd_tacss in_bd_tacs map_wpull_tacs srel_O_Gr_tacs;
81.2682 -
81.2683 - val (hset_dtor_incl_thmss, hset_hset_dtor_incl_thmsss, hset_induct_thms) =
81.2684 - let
81.2685 - fun tinst_of dtor =
81.2686 - map (SOME o certify lthy) (dtor :: remove (op =) dtor dtors);
81.2687 - fun tinst_of' dtor = case tinst_of dtor of t :: ts => t :: NONE :: ts;
81.2688 - val Tinst = map (pairself (certifyT lthy))
81.2689 - (map Logic.varifyT_global (deads @ allAs) ~~ (deads @ passiveAs @ Ts));
81.2690 - val set_incl_thmss =
81.2691 - map2 (fn dtor => map (singleton (Proof_Context.export names_lthy lthy) o
81.2692 - Drule.instantiate' [] (tinst_of' dtor) o
81.2693 - Thm.instantiate (Tinst, []) o Drule.zero_var_indexes))
81.2694 - dtors set_incl_hset_thmss;
81.2695 -
81.2696 - val tinst = interleave (map (SOME o certify lthy) dtors) (replicate n NONE)
81.2697 - val set_minimal_thms =
81.2698 - map (Drule.instantiate' [] tinst o Thm.instantiate (Tinst, []) o
81.2699 - Drule.zero_var_indexes)
81.2700 - hset_minimal_thms;
81.2701 -
81.2702 - val set_set_incl_thmsss =
81.2703 - map2 (fn dtor => map (map (singleton (Proof_Context.export names_lthy lthy) o
81.2704 - Drule.instantiate' [] (NONE :: tinst_of' dtor) o
81.2705 - Thm.instantiate (Tinst, []) o Drule.zero_var_indexes)))
81.2706 - dtors set_hset_incl_hset_thmsss;
81.2707 -
81.2708 - val set_set_incl_thmsss' = transpose (map transpose set_set_incl_thmsss);
81.2709 -
81.2710 - val incls =
81.2711 - maps (map (fn thm => thm RS @{thm subset_Collect_iff})) set_incl_thmss @
81.2712 - @{thms subset_Collect_iff[OF subset_refl]};
81.2713 -
81.2714 - fun mk_induct_tinst phis jsets y y' =
81.2715 - map4 (fn phi => fn jset => fn Jz => fn Jz' =>
81.2716 - SOME (certify lthy (Term.absfree Jz' (HOLogic.mk_Collect (fst y', snd y',
81.2717 - HOLogic.mk_conj (HOLogic.mk_mem (y, jset $ Jz), phi $ y $ Jz))))))
81.2718 - phis jsets Jzs Jzs';
81.2719 - val set_induct_thms =
81.2720 - map6 (fn set_minimal => fn set_set_inclss => fn jsets => fn y => fn y' => fn phis =>
81.2721 - ((set_minimal
81.2722 - |> Drule.instantiate' [] (mk_induct_tinst phis jsets y y')
81.2723 - |> unfold_thms lthy incls) OF
81.2724 - (replicate n ballI @
81.2725 - maps (map (fn thm => thm RS @{thm subset_CollectI})) set_set_inclss))
81.2726 - |> singleton (Proof_Context.export names_lthy lthy)
81.2727 - |> rule_by_tactic lthy (ALLGOALS (TRY o etac asm_rl)))
81.2728 - set_minimal_thms set_set_incl_thmsss' setss_by_range ys ys' set_induct_phiss
81.2729 - in
81.2730 - (set_incl_thmss, set_set_incl_thmsss, set_induct_thms)
81.2731 - end;
81.2732 -
81.2733 - fun close_wit I wit = (I, fold_rev Term.absfree (map (nth ys') I) wit);
81.2734 -
81.2735 - val all_unitTs = replicate live HOLogic.unitT;
81.2736 - val unitTs = replicate n HOLogic.unitT;
81.2737 - val unit_funs = replicate n (Term.absdummy HOLogic.unitT HOLogic.unit);
81.2738 - fun mk_map_args I =
81.2739 - map (fn i =>
81.2740 - if member (op =) I i then Term.absdummy HOLogic.unitT (nth ys i)
81.2741 - else mk_undefined (HOLogic.unitT --> nth passiveAs i))
81.2742 - (0 upto (m - 1));
81.2743 -
81.2744 - fun mk_nat_wit Ds bnf (I, wit) () =
81.2745 - let
81.2746 - val passiveI = filter (fn i => i < m) I;
81.2747 - val map_args = mk_map_args passiveI;
81.2748 - in
81.2749 - Term.absdummy HOLogic.unitT (Term.list_comb
81.2750 - (mk_map_of_bnf Ds all_unitTs (passiveAs @ unitTs) bnf, map_args @ unit_funs) $ wit)
81.2751 - end;
81.2752 -
81.2753 - fun mk_dummy_wit Ds bnf I =
81.2754 - let
81.2755 - val map_args = mk_map_args I;
81.2756 - in
81.2757 - Term.absdummy HOLogic.unitT (Term.list_comb
81.2758 - (mk_map_of_bnf Ds all_unitTs (passiveAs @ unitTs) bnf, map_args @ unit_funs) $
81.2759 - mk_undefined (mk_T_of_bnf Ds all_unitTs bnf))
81.2760 - end;
81.2761 -
81.2762 - val nat_witss =
81.2763 - map2 (fn Ds => fn bnf => mk_wits_of_bnf (replicate (nwits_of_bnf bnf) Ds)
81.2764 - (replicate (nwits_of_bnf bnf) (replicate live HOLogic.unitT)) bnf
81.2765 - |> map (fn (I, wit) =>
81.2766 - (I, Lazy.lazy (mk_nat_wit Ds bnf (I, Term.list_comb (wit, map (K HOLogic.unit) I))))))
81.2767 - Dss bnfs;
81.2768 -
81.2769 - val nat_wit_thmss = map2 (curry op ~~) nat_witss (map wit_thmss_of_bnf bnfs)
81.2770 -
81.2771 - val Iss = map (map fst) nat_witss;
81.2772 -
81.2773 - fun filter_wits (I, wit) =
81.2774 - let val J = filter (fn i => i < m) I;
81.2775 - in (J, (length J < length I, wit)) end;
81.2776 -
81.2777 - val wit_treess = map_index (fn (i, Is) =>
81.2778 - map_index (finish Iss m [i+m] (i+m)) Is) Iss
81.2779 - |> map (minimize_wits o map filter_wits o minimize_wits o flat);
81.2780 -
81.2781 - val coind_wit_argsss =
81.2782 - map (map (tree_to_coind_wits nat_wit_thmss o snd o snd) o filter (fst o snd)) wit_treess;
81.2783 -
81.2784 - val nonredundant_coind_wit_argsss =
81.2785 - fold (fn i => fn argsss =>
81.2786 - nth_map (i - 1) (filter_out (fn xs =>
81.2787 - exists (fn ys =>
81.2788 - let
81.2789 - val xs' = (map (fst o fst) xs, snd (fst (hd xs)));
81.2790 - val ys' = (map (fst o fst) ys, snd (fst (hd ys)));
81.2791 - in
81.2792 - eq_pair (subset (op =)) (eq_set (op =)) (xs', ys') andalso not (fst xs' = fst ys')
81.2793 - end)
81.2794 - (flat argsss)))
81.2795 - argsss)
81.2796 - ks coind_wit_argsss;
81.2797 -
81.2798 - fun prepare_args args =
81.2799 - let
81.2800 - val I = snd (fst (hd args));
81.2801 - val (dummys, args') =
81.2802 - map_split (fn i =>
81.2803 - (case find_first (fn arg => fst (fst arg) = i - 1) args of
81.2804 - SOME (_, ((_, wit), thms)) => (NONE, (Lazy.force wit, thms))
81.2805 - | NONE =>
81.2806 - (SOME (i - 1), (mk_dummy_wit (nth Dss (i - 1)) (nth bnfs (i - 1)) I, []))))
81.2807 - ks;
81.2808 - in
81.2809 - ((I, dummys), apsnd flat (split_list args'))
81.2810 - end;
81.2811 -
81.2812 - fun mk_coind_wits ((I, dummys), (args, thms)) =
81.2813 - ((I, dummys), (map (fn i => mk_unfold Ts args i $ HOLogic.unit) ks, thms));
81.2814 -
81.2815 - val coind_witss =
81.2816 - maps (map (mk_coind_wits o prepare_args)) nonredundant_coind_wit_argsss;
81.2817 -
81.2818 - fun mk_coind_wit_thms ((I, dummys), (wits, wit_thms)) =
81.2819 - let
81.2820 - fun mk_goal sets y y_copy y'_copy j =
81.2821 - let
81.2822 - fun mk_conjunct set z dummy wit =
81.2823 - mk_Ball (set $ z) (Term.absfree y'_copy
81.2824 - (if dummy = NONE orelse member (op =) I (j - 1) then
81.2825 - HOLogic.mk_imp (HOLogic.mk_eq (z, wit),
81.2826 - if member (op =) I (j - 1) then HOLogic.mk_eq (y_copy, y)
81.2827 - else @{term False})
81.2828 - else @{term True}));
81.2829 - in
81.2830 - fold_rev Logic.all (map (nth ys) I @ Jzs) (HOLogic.mk_Trueprop
81.2831 - (Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct sets Jzs dummys wits)))
81.2832 - end;
81.2833 - val goals = map5 mk_goal setss_by_range ys ys_copy ys'_copy ls;
81.2834 - in
81.2835 - map2 (fn goal => fn induct =>
81.2836 - Skip_Proof.prove lthy [] [] goal
81.2837 - (mk_coind_wit_tac induct dtor_unfold_thms (flat set_natural'ss) wit_thms)
81.2838 - |> Thm.close_derivation)
81.2839 - goals hset_induct_thms
81.2840 - |> map split_conj_thm
81.2841 - |> transpose
81.2842 - |> map (map_filter (try (fn thm => thm RS bspec RS mp)))
81.2843 - |> curry op ~~ (map_index Library.I (map (close_wit I) wits))
81.2844 - |> filter (fn (_, thms) => length thms = m)
81.2845 - end;
81.2846 -
81.2847 - val coind_wit_thms = maps mk_coind_wit_thms coind_witss;
81.2848 -
81.2849 - val witss = map2 (fn Ds => fn bnf => mk_wits_of_bnf
81.2850 - (replicate (nwits_of_bnf bnf) Ds)
81.2851 - (replicate (nwits_of_bnf bnf) (passiveAs @ Ts)) bnf) Dss bnfs;
81.2852 -
81.2853 - val ctor_witss =
81.2854 - map (map (uncurry close_wit o tree_to_ctor_wit ys ctors witss o snd o snd) o
81.2855 - filter_out (fst o snd)) wit_treess;
81.2856 -
81.2857 - val all_witss =
81.2858 - fold (fn ((i, wit), thms) => fn witss =>
81.2859 - nth_map i (fn (thms', wits) => (thms @ thms', wit :: wits)) witss)
81.2860 - coind_wit_thms (map (pair []) ctor_witss)
81.2861 - |> map (apsnd (map snd o minimize_wits));
81.2862 -
81.2863 - val wit_tac = mk_wit_tac n dtor_ctor_thms (flat set_simp_thmss) (maps wit_thms_of_bnf bnfs);
81.2864 -
81.2865 - val policy = user_policy Derive_All_Facts_Note_Most;
81.2866 -
81.2867 - val (Jbnfs, lthy) =
81.2868 - fold_map6 (fn tacs => fn b => fn mapx => fn sets => fn T => fn (thms, wits) => fn lthy =>
81.2869 - bnf_def Dont_Inline policy I tacs (wit_tac thms) (SOME deads)
81.2870 - (((((b, fold_rev Term.absfree fs' mapx), sets), absdummy T bd), wits), NONE) lthy
81.2871 - |> register_bnf (Local_Theory.full_name lthy b))
81.2872 - tacss bs fs_maps setss_by_bnf Ts all_witss lthy;
81.2873 -
81.2874 - val fold_maps = fold_thms lthy (map (fn bnf =>
81.2875 - mk_unabs_def m (map_def_of_bnf bnf RS @{thm meta_eq_to_obj_eq})) Jbnfs);
81.2876 -
81.2877 - val fold_sets = fold_thms lthy (maps (fn bnf =>
81.2878 - map (fn thm => thm RS @{thm meta_eq_to_obj_eq}) (set_defs_of_bnf bnf)) Jbnfs);
81.2879 -
81.2880 - val timer = time (timer "registered new codatatypes as BNFs");
81.2881 -
81.2882 - val set_incl_thmss = map (map fold_sets) hset_dtor_incl_thmss;
81.2883 - val set_set_incl_thmsss = map (map (map fold_sets)) hset_hset_dtor_incl_thmsss;
81.2884 - val set_induct_thms = map fold_sets hset_induct_thms;
81.2885 -
81.2886 - val srels = map2 (fn Ds => mk_srel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
81.2887 - val Jsrels = map (mk_srel_of_bnf deads passiveAs passiveBs) Jbnfs;
81.2888 - val rels = map2 (fn Ds => mk_rel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
81.2889 - val Jrels = map (mk_rel_of_bnf deads passiveAs passiveBs) Jbnfs;
81.2890 -
81.2891 - val JrelRs = map (fn Jsrel => Term.list_comb (Jsrel, JRs)) Jsrels;
81.2892 - val relRs = map (fn srel => Term.list_comb (srel, JRs @ JrelRs)) srels;
81.2893 - val Jpredphis = map (fn Jsrel => Term.list_comb (Jsrel, Jphis)) Jrels;
81.2894 - val predphis = map (fn srel => Term.list_comb (srel, Jphis @ Jpredphis)) rels;
81.2895 -
81.2896 - val in_srels = map in_srel_of_bnf bnfs;
81.2897 - val in_Jsrels = map in_srel_of_bnf Jbnfs;
81.2898 - val Jsrel_defs = map srel_def_of_bnf Jbnfs;
81.2899 - val Jrel_defs = map rel_def_of_bnf Jbnfs;
81.2900 -
81.2901 - val folded_map_simp_thms = map fold_maps map_simp_thms;
81.2902 - val folded_set_simp_thmss = map (map fold_sets) set_simp_thmss;
81.2903 - val folded_set_simp_thmss' = transpose folded_set_simp_thmss;
81.2904 -
81.2905 - val Jsrel_simp_thms =
81.2906 - let
81.2907 - fun mk_goal Jz Jz' dtor dtor' JrelR relR = fold_rev Logic.all (Jz :: Jz' :: JRs)
81.2908 - (mk_Trueprop_eq (HOLogic.mk_mem (HOLogic.mk_prod (Jz, Jz'), JrelR),
81.2909 - HOLogic.mk_mem (HOLogic.mk_prod (dtor $ Jz, dtor' $ Jz'), relR)));
81.2910 - val goals = map6 mk_goal Jzs Jz's dtors dtor's JrelRs relRs;
81.2911 - in
81.2912 - map12 (fn i => fn goal => fn in_srel => fn map_comp => fn map_cong =>
81.2913 - fn map_simp => fn set_simps => fn dtor_inject => fn dtor_ctor =>
81.2914 - fn set_naturals => fn set_incls => fn set_set_inclss =>
81.2915 - Skip_Proof.prove lthy [] [] goal
81.2916 - (K (mk_srel_simp_tac in_Jsrels i in_srel map_comp map_cong map_simp set_simps
81.2917 - dtor_inject dtor_ctor set_naturals set_incls set_set_inclss))
81.2918 - |> Thm.close_derivation)
81.2919 - ks goals in_srels map_comp's map_congs folded_map_simp_thms folded_set_simp_thmss'
81.2920 - dtor_inject_thms dtor_ctor_thms set_natural'ss set_incl_thmss set_set_incl_thmsss
81.2921 - end;
81.2922 -
81.2923 - val Jrel_simp_thms =
81.2924 - let
81.2925 - fun mk_goal Jz Jz' dtor dtor' Jpredphi predphi = fold_rev Logic.all (Jz :: Jz' :: Jphis)
81.2926 - (mk_Trueprop_eq (Jpredphi $ Jz $ Jz', predphi $ (dtor $ Jz) $ (dtor' $ Jz')));
81.2927 - val goals = map6 mk_goal Jzs Jz's dtors dtor's Jpredphis predphis;
81.2928 - in
81.2929 - map3 (fn goal => fn srel_def => fn Jsrel_simp =>
81.2930 - Skip_Proof.prove lthy [] [] goal
81.2931 - (mk_rel_simp_tac srel_def Jrel_defs Jsrel_defs Jsrel_simp)
81.2932 - |> Thm.close_derivation)
81.2933 - goals srel_defs Jsrel_simp_thms
81.2934 - end;
81.2935 -
81.2936 - val timer = time (timer "additional properties");
81.2937 -
81.2938 - val ls' = if m = 1 then [0] else ls;
81.2939 -
81.2940 - val Jbnf_common_notes =
81.2941 - [(map_uniqueN, [fold_maps map_unique_thm])] @
81.2942 - map2 (fn i => fn thm => (mk_set_inductN i, [thm])) ls' set_induct_thms
81.2943 - |> map (fn (thmN, thms) =>
81.2944 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
81.2945 -
81.2946 - val Jbnf_notes =
81.2947 - [(map_simpsN, map single folded_map_simp_thms),
81.2948 - (rel_simpN, map single Jrel_simp_thms),
81.2949 - (set_inclN, set_incl_thmss),
81.2950 - (set_set_inclN, map flat set_set_incl_thmsss),
81.2951 - (srel_simpN, map single Jsrel_simp_thms)] @
81.2952 - map2 (fn i => fn thms => (mk_set_simpsN i, map single thms)) ls' folded_set_simp_thmss
81.2953 - |> maps (fn (thmN, thmss) =>
81.2954 - map2 (fn b => fn thms =>
81.2955 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
81.2956 - bs thmss)
81.2957 - in
81.2958 - timer; lthy |> Local_Theory.notes (Jbnf_common_notes @ Jbnf_notes) |> snd
81.2959 - end;
81.2960 -
81.2961 - val common_notes =
81.2962 - [(dtor_coinductN, [dtor_coinduct_thm]),
81.2963 - (dtor_strong_coinductN, [dtor_strong_coinduct_thm]),
81.2964 - (rel_coinductN, [rel_coinduct_thm]),
81.2965 - (rel_strong_coinductN, [rel_strong_coinduct_thm]),
81.2966 - (srel_coinductN, [srel_coinduct_thm]),
81.2967 - (srel_strong_coinductN, [srel_strong_coinduct_thm])]
81.2968 - |> map (fn (thmN, thms) =>
81.2969 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
81.2970 -
81.2971 - val notes =
81.2972 - [(ctor_dtorN, ctor_dtor_thms),
81.2973 - (ctor_dtor_unfoldsN, ctor_dtor_unfold_thms),
81.2974 - (ctor_dtor_corecsN, ctor_dtor_corec_thms),
81.2975 - (ctor_exhaustN, ctor_exhaust_thms),
81.2976 - (ctor_injectN, ctor_inject_thms),
81.2977 - (dtor_corecsN, dtor_corec_thms),
81.2978 - (dtor_ctorN, dtor_ctor_thms),
81.2979 - (dtor_exhaustN, dtor_exhaust_thms),
81.2980 - (dtor_injectN, dtor_inject_thms),
81.2981 - (dtor_unfold_uniqueN, dtor_unfold_unique_thms),
81.2982 - (dtor_unfoldsN, dtor_unfold_thms)]
81.2983 - |> map (apsnd (map single))
81.2984 - |> maps (fn (thmN, thmss) =>
81.2985 - map2 (fn b => fn thms =>
81.2986 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
81.2987 - bs thmss)
81.2988 - in
81.2989 - ((dtors, ctors, unfolds, corecs, dtor_coinduct_thm, dtor_ctor_thms, ctor_dtor_thms,
81.2990 - ctor_inject_thms, ctor_dtor_unfold_thms, ctor_dtor_corec_thms),
81.2991 - lthy |> Local_Theory.notes (common_notes @ notes) |> snd)
81.2992 - end;
81.2993 -
81.2994 -val _ =
81.2995 - Outer_Syntax.local_theory @{command_spec "codata_raw"}
81.2996 - "define BNF-based coinductive datatypes (low-level)"
81.2997 - (Parse.and_list1
81.2998 - ((Parse.binding --| @{keyword ":"}) -- (Parse.typ --| @{keyword "="} -- Parse.typ)) >>
81.2999 - (snd oo fp_bnf_cmd bnf_gfp o apsnd split_list o split_list));
81.3000 -
81.3001 -val _ =
81.3002 - Outer_Syntax.local_theory @{command_spec "codata"} "define BNF-based coinductive datatypes"
81.3003 - (parse_datatype_cmd false bnf_gfp);
81.3004 -
81.3005 -end;
82.1 --- a/src/HOL/Codatatype/Tools/bnf_gfp_tactics.ML Fri Sep 21 16:34:40 2012 +0200
82.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
82.3 @@ -1,1554 +0,0 @@
82.4 -(* Title: HOL/BNF/Tools/bnf_gfp_tactics.ML
82.5 - Author: Dmitriy Traytel, TU Muenchen
82.6 - Author: Andrei Popescu, TU Muenchen
82.7 - Author: Jasmin Blanchette, TU Muenchen
82.8 - Copyright 2012
82.9 -
82.10 -Tactics for the codatatype construction.
82.11 -*)
82.12 -
82.13 -signature BNF_GFP_TACTICS =
82.14 -sig
82.15 - val mk_Lev_sbd_tac: cterm option list -> thm list -> thm list -> thm list list -> tactic
82.16 - val mk_bd_card_order_tac: thm -> tactic
82.17 - val mk_bd_cinfinite_tac: thm -> tactic
82.18 - val mk_bis_Gr_tac: thm -> thm list -> thm list -> thm list -> thm list ->
82.19 - {prems: 'a, context: Proof.context} -> tactic
82.20 - val mk_bis_O_tac: int -> thm -> thm list -> thm list -> tactic
82.21 - val mk_bis_Union_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
82.22 - val mk_bis_converse_tac: int -> thm -> thm list -> thm list -> tactic
82.23 - val mk_bis_srel_tac: int -> thm -> thm list -> thm list -> thm list -> thm list list -> tactic
82.24 - val mk_carT_set_tac: int -> int -> thm -> thm -> thm -> thm ->
82.25 - {prems: 'a, context: Proof.context} -> tactic
82.26 - val mk_card_of_carT_tac: int -> thm list -> thm -> thm -> thm -> thm -> thm -> thm list -> tactic
82.27 - val mk_coalgT_tac: int -> thm list -> thm list -> thm list list ->
82.28 - {prems: 'a, context: Proof.context} -> tactic
82.29 - val mk_coalg_final_tac: int -> thm -> thm list -> thm list -> thm list list -> thm list list ->
82.30 - tactic
82.31 - val mk_coalg_set_tac: thm -> tactic
82.32 - val mk_coalg_thePull_tac: int -> thm -> thm list -> thm list list -> (int -> tactic) list ->
82.33 - {prems: 'a, context: Proof.context} -> tactic
82.34 - val mk_coind_wit_tac: thm -> thm list -> thm list -> thm list ->
82.35 - {prems: 'a, context: Proof.context} -> tactic
82.36 - val mk_col_bd_tac: int -> int -> cterm option list -> thm list -> thm list -> thm -> thm ->
82.37 - thm list list -> tactic
82.38 - val mk_col_natural_tac: cterm option list -> thm list -> thm list -> thm list -> thm list list ->
82.39 - {prems: 'a, context: Proof.context} -> tactic
82.40 - val mk_congruent_str_final_tac: int -> thm -> thm -> thm -> thm list -> tactic
82.41 - val mk_corec_tac: int -> thm list -> thm -> thm -> thm list ->
82.42 - {prems: 'a, context: Proof.context} -> tactic
82.43 - val mk_dtor_coinduct_tac: int -> int list -> thm -> thm -> tactic
82.44 - val mk_dtor_strong_coinduct_tac: int list -> ctyp option list -> cterm option list -> thm ->
82.45 - thm -> thm -> tactic
82.46 - val mk_dtor_o_ctor_tac: thm -> thm -> thm -> thm -> thm list ->
82.47 - {prems: 'a, context: Proof.context} -> tactic
82.48 - val mk_equiv_lsbis_tac: thm -> thm -> thm -> thm -> thm -> thm -> tactic
82.49 - val mk_hset_minimal_tac: int -> thm list -> thm -> {prems: 'a, context: Proof.context} -> tactic
82.50 - val mk_hset_rec_minimal_tac: int -> cterm option list -> thm list -> thm list ->
82.51 - {prems: 'a, context: Proof.context} -> tactic
82.52 - val mk_in_bd_tac: thm -> thm list -> thm -> thm -> thm -> thm -> thm list -> thm -> thm -> thm ->
82.53 - thm -> thm -> thm -> tactic
82.54 - val mk_incl_lsbis_tac: int -> int -> thm -> tactic
82.55 - val mk_isNode_hset_tac: int -> thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
82.56 - val mk_length_Lev'_tac: thm -> tactic
82.57 - val mk_length_Lev_tac: cterm option list -> thm list -> thm list -> tactic
82.58 - val mk_map_comp_tac: int -> int -> thm list -> thm list -> thm list -> thm -> tactic
82.59 - val mk_mcong_tac: int -> (int -> tactic) -> thm list -> thm list -> thm list -> thm list list ->
82.60 - thm list list -> thm list list list -> tactic
82.61 - val mk_map_id_tac: thm list -> thm -> thm -> tactic
82.62 - val mk_map_tac: int -> int -> ctyp option -> thm -> thm -> thm -> tactic
82.63 - val mk_map_unique_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
82.64 - val mk_mor_Abs_tac: thm list -> thm list -> {prems: 'a, context: Proof.context} -> tactic
82.65 - val mk_mor_Rep_tac: int -> thm list -> thm list -> thm list -> thm list list -> thm list ->
82.66 - thm list -> {prems: 'a, context: Proof.context} -> tactic
82.67 - val mk_mor_T_final_tac: thm -> thm list -> thm list -> tactic
82.68 - val mk_mor_UNIV_tac: thm list -> thm -> tactic
82.69 - val mk_mor_beh_tac: int -> thm -> thm -> thm list -> thm list -> thm list -> thm list ->
82.70 - thm list list -> thm list list -> thm list -> thm list -> thm list -> thm list -> thm list ->
82.71 - thm list -> thm list -> thm list -> thm list list -> thm list list list -> thm list list list ->
82.72 - thm list list list -> thm list list -> thm list list -> thm list -> thm list -> thm list ->
82.73 - {prems: 'a, context: Proof.context} -> tactic
82.74 - val mk_mor_comp_tac: thm -> thm list -> thm list -> thm list -> tactic
82.75 - val mk_mor_elim_tac: thm -> tactic
82.76 - val mk_mor_hset_rec_tac: int -> int -> cterm option list -> int -> thm list -> thm list ->
82.77 - thm list -> thm list list -> thm list list -> tactic
82.78 - val mk_mor_hset_tac: thm -> thm -> tactic
82.79 - val mk_mor_incl_tac: thm -> thm list -> tactic
82.80 - val mk_mor_str_tac: 'a list -> thm -> tactic
82.81 - val mk_mor_sum_case_tac: 'a list -> thm -> tactic
82.82 - val mk_mor_thePull_fst_tac: int -> thm -> thm list -> thm list -> (int -> tactic) list ->
82.83 - {prems: thm list, context: Proof.context} -> tactic
82.84 - val mk_mor_thePull_snd_tac: int -> thm -> thm list -> thm list -> (int -> tactic) list ->
82.85 - {prems: thm list, context: Proof.context} -> tactic
82.86 - val mk_mor_thePull_pick_tac: thm -> thm list -> thm list ->
82.87 - {prems: 'a, context: Proof.context} -> tactic
82.88 - val mk_mor_unfold_tac: int -> thm -> thm list -> thm list -> thm list -> thm list -> thm list ->
82.89 - thm list -> tactic
82.90 - val mk_prefCl_Lev_tac: cterm option list -> thm list -> thm list -> tactic
82.91 - val mk_pickWP_assms_tac: thm list -> thm list -> thm -> (int -> tactic)
82.92 - val mk_pick_col_tac: int -> int -> cterm option list -> thm list -> thm list -> thm list ->
82.93 - thm list list -> thm list -> (int -> tactic) list -> {prems: 'a, context: Proof.context} ->
82.94 - tactic
82.95 - val mk_raw_coind_tac: thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm list ->
82.96 - thm list -> thm list -> thm -> thm list -> tactic
82.97 - val mk_rv_last_tac: ctyp option list -> cterm option list -> thm list -> thm list -> tactic
82.98 - val mk_sbis_lsbis_tac: thm list -> thm -> thm -> tactic
82.99 - val mk_set_Lev_tac: cterm option list -> thm list -> thm list -> thm list -> thm list ->
82.100 - thm list list -> tactic
82.101 - val mk_set_bd_tac: thm -> thm -> thm -> tactic
82.102 - val mk_set_hset_incl_hset_tac: int -> thm list -> thm -> int -> tactic
82.103 - val mk_set_image_Lev_tac: cterm option list -> thm list -> thm list -> thm list -> thm list ->
82.104 - thm list list -> thm list list -> tactic
82.105 - val mk_set_incl_hin_tac: thm list -> tactic
82.106 - val mk_set_incl_hset_tac: thm -> thm -> tactic
82.107 - val mk_set_le_tac: int -> thm -> thm list -> thm list list -> tactic
82.108 - val mk_set_natural_tac: thm -> thm -> tactic
82.109 - val mk_set_rv_Lev_tac: int -> cterm option list -> thm list -> thm list -> thm list -> thm list ->
82.110 - thm list list -> thm list list -> tactic
82.111 - val mk_set_simp_tac: int -> thm -> thm -> thm list -> tactic
82.112 - val mk_srel_coinduct_tac: 'a list -> thm -> thm -> tactic
82.113 - val mk_srel_strong_coinduct_tac: int -> ctyp option list -> cterm option list -> thm ->
82.114 - thm list -> thm list -> tactic
82.115 - val mk_srel_simp_tac: thm list -> int -> thm -> thm -> thm -> thm -> thm list -> thm -> thm ->
82.116 - thm list -> thm list -> thm list list -> tactic
82.117 - val mk_strT_hset_tac: int -> int -> int -> ctyp option list -> ctyp option list ->
82.118 - cterm option list -> thm list -> thm list -> thm list -> thm list -> thm list list ->
82.119 - thm list list -> thm list list -> thm -> thm list list -> tactic
82.120 - val mk_unfold_unique_mor_tac: thm list -> thm -> thm -> thm list -> tactic
82.121 - val mk_unique_mor_tac: thm list -> thm -> tactic
82.122 - val mk_wit_tac: int -> thm list -> thm list -> thm list -> thm list ->
82.123 - {prems: 'a, context: Proof.context} -> tactic
82.124 - val mk_wpull_tac: int -> thm -> thm -> thm -> thm -> thm -> thm list -> thm list -> tactic
82.125 -end;
82.126 -
82.127 -structure BNF_GFP_Tactics : BNF_GFP_TACTICS =
82.128 -struct
82.129 -
82.130 -open BNF_Tactics
82.131 -open BNF_Util
82.132 -open BNF_FP
82.133 -open BNF_GFP_Util
82.134 -
82.135 -val fst_convol_fun_cong_sym = @{thm fst_convol} RS fun_cong RS sym;
82.136 -val list_inject_iffD1 = @{thm list.inject[THEN iffD1]};
82.137 -val nat_induct = @{thm nat_induct};
82.138 -val o_apply_trans_sym = o_apply RS trans RS sym;
82.139 -val ord_eq_le_trans = @{thm ord_eq_le_trans};
82.140 -val ord_eq_le_trans_trans_fun_cong_image_id_id_apply =
82.141 - @{thm ord_eq_le_trans[OF trans[OF fun_cong[OF image_id] id_apply]]};
82.142 -val ordIso_ordLeq_trans = @{thm ordIso_ordLeq_trans};
82.143 -val snd_convol_fun_cong_sym = @{thm snd_convol} RS fun_cong RS sym;
82.144 -val sum_case_weak_cong = @{thm sum_case_weak_cong};
82.145 -val trans_fun_cong_image_id_id_apply = @{thm trans[OF fun_cong[OF image_id] id_apply]};
82.146 -
82.147 -fun mk_coalg_set_tac coalg_def =
82.148 - dtac (coalg_def RS iffD1) 1 THEN
82.149 - REPEAT_DETERM (etac conjE 1) THEN
82.150 - EVERY' [dtac @{thm rev_bspec}, atac] 1 THEN
82.151 - REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN atac 1;
82.152 -
82.153 -fun mk_mor_elim_tac mor_def =
82.154 - (dtac (subst OF [mor_def]) THEN'
82.155 - REPEAT o etac conjE THEN'
82.156 - TRY o rtac @{thm image_subsetI} THEN'
82.157 - etac bspec THEN'
82.158 - atac) 1;
82.159 -
82.160 -fun mk_mor_incl_tac mor_def map_id's =
82.161 - (stac mor_def THEN'
82.162 - rtac conjI THEN'
82.163 - CONJ_WRAP' (K (EVERY' [rtac ballI, etac set_mp, stac @{thm id_apply}, atac]))
82.164 - map_id's THEN'
82.165 - CONJ_WRAP' (fn thm =>
82.166 - (EVERY' [rtac ballI, rtac (thm RS trans), rtac sym, rtac (@{thm id_apply} RS arg_cong)]))
82.167 - map_id's) 1;
82.168 -
82.169 -fun mk_mor_comp_tac mor_def mor_images morEs map_comp_ids =
82.170 - let
82.171 - fun fbetw_tac image = EVERY' [rtac ballI, stac o_apply, etac image, etac image, atac];
82.172 - fun mor_tac ((mor_image, morE), map_comp_id) =
82.173 - EVERY' [rtac ballI, stac o_apply, rtac trans, rtac (map_comp_id RS sym), rtac trans,
82.174 - etac (morE RS arg_cong), atac, etac morE, etac mor_image, atac];
82.175 - in
82.176 - (stac mor_def THEN' rtac conjI THEN'
82.177 - CONJ_WRAP' fbetw_tac mor_images THEN'
82.178 - CONJ_WRAP' mor_tac ((mor_images ~~ morEs) ~~ map_comp_ids)) 1
82.179 - end;
82.180 -
82.181 -fun mk_mor_UNIV_tac morEs mor_def =
82.182 - let
82.183 - val n = length morEs;
82.184 - fun mor_tac morE = EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, etac morE,
82.185 - rtac UNIV_I, rtac sym, rtac o_apply];
82.186 - in
82.187 - EVERY' [rtac iffI, CONJ_WRAP' mor_tac morEs,
82.188 - stac mor_def, rtac conjI, CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) morEs,
82.189 - CONJ_WRAP' (fn i =>
82.190 - EVERY' [dtac (mk_conjunctN n i), rtac ballI, etac @{thm pointfreeE}]) (1 upto n)] 1
82.191 - end;
82.192 -
82.193 -fun mk_mor_str_tac ks mor_UNIV =
82.194 - (stac mor_UNIV THEN' CONJ_WRAP' (K (rtac refl)) ks) 1;
82.195 -
82.196 -fun mk_mor_sum_case_tac ks mor_UNIV =
82.197 - (stac mor_UNIV THEN' CONJ_WRAP' (K (rtac @{thm sum_case_comp_Inl[symmetric]})) ks) 1;
82.198 -
82.199 -fun mk_set_incl_hset_tac def rec_Suc =
82.200 - EVERY' (stac def ::
82.201 - map rtac [@{thm incl_UNION_I}, UNIV_I, @{thm ord_le_eq_trans}, @{thm Un_upper1},
82.202 - sym, rec_Suc]) 1;
82.203 -
82.204 -fun mk_set_hset_incl_hset_tac n defs rec_Suc i =
82.205 - EVERY' (map (TRY oo stac) defs @
82.206 - map rtac [@{thm UN_least}, subsetI, @{thm UN_I}, UNIV_I, set_mp, equalityD2, rec_Suc, UnI2,
82.207 - mk_UnIN n i] @
82.208 - [etac @{thm UN_I}, atac]) 1;
82.209 -
82.210 -fun mk_set_incl_hin_tac incls =
82.211 - if null incls then rtac subset_UNIV 1
82.212 - else EVERY' [rtac subsetI, rtac CollectI,
82.213 - CONJ_WRAP' (fn incl => EVERY' [rtac subset_trans, etac incl, atac]) incls] 1;
82.214 -
82.215 -fun mk_hset_rec_minimal_tac m cts rec_0s rec_Sucs {context = ctxt, prems = _} =
82.216 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.217 - REPEAT_DETERM o rtac allI,
82.218 - CONJ_WRAP' (fn thm => EVERY'
82.219 - [rtac ord_eq_le_trans, rtac thm, rtac @{thm empty_subsetI}]) rec_0s,
82.220 - REPEAT_DETERM o rtac allI,
82.221 - CONJ_WRAP' (fn rec_Suc => EVERY'
82.222 - [rtac ord_eq_le_trans, rtac rec_Suc,
82.223 - if m = 0 then K all_tac
82.224 - else (rtac @{thm Un_least} THEN' Goal.assume_rule_tac ctxt),
82.225 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
82.226 - (K (EVERY' [rtac @{thm UN_least}, REPEAT_DETERM o eresolve_tac [allE, conjE],
82.227 - rtac subset_trans, atac, Goal.assume_rule_tac ctxt])) rec_0s])
82.228 - rec_Sucs] 1;
82.229 -
82.230 -fun mk_hset_minimal_tac n hset_defs hset_rec_minimal {context = ctxt, prems = _} =
82.231 - (CONJ_WRAP' (fn def => (EVERY' [rtac ord_eq_le_trans, rtac def,
82.232 - rtac @{thm UN_least}, rtac rev_mp, rtac hset_rec_minimal,
82.233 - EVERY' (replicate ((n + 1) * n) (Goal.assume_rule_tac ctxt)), rtac impI,
82.234 - REPEAT_DETERM o eresolve_tac [allE, conjE], atac])) hset_defs) 1
82.235 -
82.236 -fun mk_mor_hset_rec_tac m n cts j rec_0s rec_Sucs morEs set_naturalss coalg_setss =
82.237 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.238 - REPEAT_DETERM o rtac allI,
82.239 - CONJ_WRAP' (fn thm => EVERY' (map rtac [impI, thm RS trans, thm RS sym])) rec_0s,
82.240 - REPEAT_DETERM o rtac allI,
82.241 - CONJ_WRAP'
82.242 - (fn (rec_Suc, (morE, ((passive_set_naturals, active_set_naturals), coalg_sets))) =>
82.243 - EVERY' [rtac impI, rtac (rec_Suc RS trans), rtac (rec_Suc RS trans RS sym),
82.244 - if m = 0 then K all_tac
82.245 - else EVERY' [rtac @{thm Un_cong}, rtac box_equals,
82.246 - rtac (nth passive_set_naturals (j - 1) RS sym),
82.247 - rtac trans_fun_cong_image_id_id_apply, etac (morE RS arg_cong), atac],
82.248 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_cong}))
82.249 - (fn (i, (set_natural, coalg_set)) =>
82.250 - EVERY' [rtac sym, rtac trans, rtac (refl RSN (2, @{thm UN_cong})),
82.251 - etac (morE RS sym RS arg_cong RS trans), atac, rtac set_natural,
82.252 - rtac (@{thm UN_simps(10)} RS trans), rtac (refl RS @{thm UN_cong}),
82.253 - ftac coalg_set, atac, dtac set_mp, atac, rtac mp, rtac (mk_conjunctN n i),
82.254 - REPEAT_DETERM o etac allE, atac, atac])
82.255 - (rev ((1 upto n) ~~ (active_set_naturals ~~ coalg_sets)))])
82.256 - (rec_Sucs ~~ (morEs ~~ (map (chop m) set_naturalss ~~ map (drop m) coalg_setss)))] 1;
82.257 -
82.258 -fun mk_mor_hset_tac hset_def mor_hset_rec =
82.259 - EVERY' [rtac (hset_def RS trans), rtac (refl RS @{thm UN_cong} RS trans), etac mor_hset_rec,
82.260 - atac, atac, rtac (hset_def RS sym)] 1
82.261 -
82.262 -fun mk_bis_srel_tac m bis_def srel_O_Grs map_comps map_congs set_naturalss =
82.263 - let
82.264 - val n = length srel_O_Grs;
82.265 - val thms = ((1 upto n) ~~ map_comps ~~ map_congs ~~ set_naturalss ~~ srel_O_Grs);
82.266 -
82.267 - fun mk_if_tac ((((i, map_comp), map_cong), set_naturals), srel_O_Gr) =
82.268 - EVERY' [rtac allI, rtac allI, rtac impI, dtac (mk_conjunctN n i),
82.269 - etac allE, etac allE, etac impE, atac, etac bexE, etac conjE,
82.270 - rtac (srel_O_Gr RS equalityD2 RS set_mp),
82.271 - rtac @{thm relcompI}, rtac @{thm converseI},
82.272 - EVERY' (map (fn thm =>
82.273 - EVERY' [rtac @{thm GrI}, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
82.274 - rtac CollectI,
82.275 - CONJ_WRAP' (fn (i, thm) =>
82.276 - if i <= m
82.277 - then EVERY' [rtac ord_eq_le_trans, rtac thm, rtac subset_trans,
82.278 - etac @{thm image_mono}, rtac @{thm image_subsetI}, etac @{thm diagI}]
82.279 - else EVERY' [rtac ord_eq_le_trans, rtac trans, rtac thm,
82.280 - rtac trans_fun_cong_image_id_id_apply, atac])
82.281 - (1 upto (m + n) ~~ set_naturals),
82.282 - rtac trans, rtac trans, rtac map_comp, rtac map_cong, REPEAT_DETERM_N m o rtac thm,
82.283 - REPEAT_DETERM_N n o rtac (@{thm o_id} RS fun_cong), atac])
82.284 - @{thms fst_diag_id snd_diag_id})];
82.285 -
82.286 - fun mk_only_if_tac ((((i, map_comp), map_cong), set_naturals), srel_O_Gr) =
82.287 - EVERY' [dtac (mk_conjunctN n i), rtac allI, rtac allI, rtac impI,
82.288 - etac allE, etac allE, etac impE, atac,
82.289 - dtac (srel_O_Gr RS equalityD1 RS set_mp),
82.290 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm relcompE}, @{thm converseE}],
82.291 - REPEAT_DETERM o eresolve_tac [@{thm GrE}, exE, conjE],
82.292 - REPEAT_DETERM o dtac Pair_eqD,
82.293 - REPEAT_DETERM o etac conjE,
82.294 - hyp_subst_tac,
82.295 - REPEAT_DETERM o eresolve_tac [CollectE, conjE],
82.296 - rtac bexI, rtac conjI, rtac trans, rtac map_comp,
82.297 - REPEAT_DETERM_N m o stac @{thm id_o},
82.298 - REPEAT_DETERM_N n o stac @{thm o_id},
82.299 - etac sym, rtac trans, rtac map_comp,
82.300 - REPEAT_DETERM_N m o stac @{thm id_o},
82.301 - REPEAT_DETERM_N n o stac @{thm o_id},
82.302 - rtac trans, rtac map_cong,
82.303 - REPEAT_DETERM_N m o EVERY' [rtac @{thm diagE'}, etac set_mp, atac],
82.304 - REPEAT_DETERM_N n o rtac refl,
82.305 - etac sym, rtac CollectI,
82.306 - CONJ_WRAP' (fn (i, thm) =>
82.307 - if i <= m
82.308 - then EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
82.309 - rtac @{thm diag_fst}, etac set_mp, atac]
82.310 - else EVERY' [rtac ord_eq_le_trans, rtac trans, rtac thm,
82.311 - rtac trans_fun_cong_image_id_id_apply, atac])
82.312 - (1 upto (m + n) ~~ set_naturals)];
82.313 - in
82.314 - EVERY' [rtac (bis_def RS trans),
82.315 - rtac iffI, etac conjE, etac conjI, CONJ_WRAP' mk_if_tac thms,
82.316 - etac conjE, etac conjI, CONJ_WRAP' mk_only_if_tac thms] 1
82.317 - end;
82.318 -
82.319 -fun mk_bis_converse_tac m bis_srel srel_congs srel_converses =
82.320 - EVERY' [stac bis_srel, dtac (bis_srel RS iffD1),
82.321 - REPEAT_DETERM o etac conjE, rtac conjI,
82.322 - CONJ_WRAP' (K (EVERY' [rtac @{thm converse_shift}, etac subset_trans,
82.323 - rtac equalityD2, rtac @{thm converse_Times}])) srel_congs,
82.324 - CONJ_WRAP' (fn (srel_cong, srel_converse) =>
82.325 - EVERY' [rtac allI, rtac allI, rtac impI, rtac @{thm set_mp[OF equalityD2]},
82.326 - rtac (srel_cong RS trans),
82.327 - REPEAT_DETERM_N m o rtac @{thm diag_converse},
82.328 - REPEAT_DETERM_N (length srel_congs) o rtac refl,
82.329 - rtac srel_converse,
82.330 - REPEAT_DETERM o etac allE,
82.331 - rtac @{thm converseI}, etac mp, etac @{thm converseD}]) (srel_congs ~~ srel_converses)] 1;
82.332 -
82.333 -fun mk_bis_O_tac m bis_srel srel_congs srel_Os =
82.334 - EVERY' [stac bis_srel, REPEAT_DETERM o dtac (bis_srel RS iffD1),
82.335 - REPEAT_DETERM o etac conjE, rtac conjI,
82.336 - CONJ_WRAP' (K (EVERY' [etac @{thm relcomp_subset_Sigma}, atac])) srel_congs,
82.337 - CONJ_WRAP' (fn (srel_cong, srel_O) =>
82.338 - EVERY' [rtac allI, rtac allI, rtac impI, rtac @{thm set_mp[OF equalityD2]},
82.339 - rtac (srel_cong RS trans),
82.340 - REPEAT_DETERM_N m o rtac @{thm diag_Comp},
82.341 - REPEAT_DETERM_N (length srel_congs) o rtac refl,
82.342 - rtac srel_O,
82.343 - etac @{thm relcompE},
82.344 - REPEAT_DETERM o dtac Pair_eqD,
82.345 - etac conjE, hyp_subst_tac,
82.346 - REPEAT_DETERM o etac allE, rtac @{thm relcompI},
82.347 - etac mp, atac, etac mp, atac]) (srel_congs ~~ srel_Os)] 1;
82.348 -
82.349 -fun mk_bis_Gr_tac bis_srel srel_Grs mor_images morEs coalg_ins
82.350 - {context = ctxt, prems = _} =
82.351 - unfold_thms_tac ctxt (bis_srel :: @{thm diag_Gr} :: srel_Grs) THEN
82.352 - EVERY' [rtac conjI,
82.353 - CONJ_WRAP' (fn thm => rtac (@{thm Gr_incl} RS ssubst) THEN' etac thm) mor_images,
82.354 - CONJ_WRAP' (fn (coalg_in, morE) =>
82.355 - EVERY' [rtac allI, rtac allI, rtac impI, rtac @{thm GrI}, etac coalg_in,
82.356 - etac @{thm GrD1}, etac (morE RS trans), etac @{thm GrD1},
82.357 - etac (@{thm GrD2} RS arg_cong)]) (coalg_ins ~~ morEs)] 1;
82.358 -
82.359 -fun mk_bis_Union_tac bis_def in_monos {context = ctxt, prems = _} =
82.360 - let
82.361 - val n = length in_monos;
82.362 - val ks = 1 upto n;
82.363 - in
82.364 - unfold_thms_tac ctxt [bis_def] THEN
82.365 - EVERY' [rtac conjI,
82.366 - CONJ_WRAP' (fn i =>
82.367 - EVERY' [rtac @{thm UN_least}, dtac bspec, atac,
82.368 - dtac conjunct1, etac (mk_conjunctN n i)]) ks,
82.369 - CONJ_WRAP' (fn (i, in_mono) =>
82.370 - EVERY' [rtac allI, rtac allI, rtac impI, etac @{thm UN_E}, dtac bspec, atac,
82.371 - dtac conjunct2, dtac (mk_conjunctN n i), etac allE, etac allE, dtac mp,
82.372 - atac, etac bexE, rtac bexI, atac, rtac in_mono,
82.373 - REPEAT_DETERM_N n o etac @{thm incl_UNION_I[OF _ subset_refl]},
82.374 - atac]) (ks ~~ in_monos)] 1
82.375 - end;
82.376 -
82.377 -fun mk_sbis_lsbis_tac lsbis_defs bis_Union bis_cong =
82.378 - let
82.379 - val n = length lsbis_defs;
82.380 - in
82.381 - EVERY' [rtac (Thm.permute_prems 0 1 bis_cong), EVERY' (map rtac lsbis_defs),
82.382 - rtac bis_Union, rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE, exE],
82.383 - hyp_subst_tac, etac bis_cong, EVERY' (map (rtac o mk_nth_conv n) (1 upto n))] 1
82.384 - end;
82.385 -
82.386 -fun mk_incl_lsbis_tac n i lsbis_def =
82.387 - EVERY' [rtac @{thm xt1(3)}, rtac lsbis_def, rtac @{thm incl_UNION_I}, rtac CollectI,
82.388 - REPEAT_DETERM_N n o rtac exI, rtac conjI, rtac refl, atac, rtac equalityD2,
82.389 - rtac (mk_nth_conv n i)] 1;
82.390 -
82.391 -fun mk_equiv_lsbis_tac sbis_lsbis lsbis_incl incl_lsbis bis_diag bis_converse bis_O =
82.392 - EVERY' [rtac (@{thm equiv_def} RS iffD2),
82.393 -
82.394 - rtac conjI, rtac (@{thm refl_on_def} RS iffD2),
82.395 - rtac conjI, rtac lsbis_incl, rtac ballI, rtac set_mp,
82.396 - rtac incl_lsbis, rtac bis_diag, atac, etac @{thm diagI},
82.397 -
82.398 - rtac conjI, rtac (@{thm sym_def} RS iffD2),
82.399 - rtac allI, rtac allI, rtac impI, rtac set_mp,
82.400 - rtac incl_lsbis, rtac bis_converse, rtac sbis_lsbis, etac @{thm converseI},
82.401 -
82.402 - rtac (@{thm trans_def} RS iffD2),
82.403 - rtac allI, rtac allI, rtac allI, rtac impI, rtac impI, rtac set_mp,
82.404 - rtac incl_lsbis, rtac bis_O, rtac sbis_lsbis, rtac sbis_lsbis,
82.405 - etac @{thm relcompI}, atac] 1;
82.406 -
82.407 -fun mk_coalgT_tac m defs strT_defs set_naturalss {context = ctxt, prems = _} =
82.408 - let
82.409 - val n = length strT_defs;
82.410 - val ks = 1 upto n;
82.411 - fun coalg_tac (i, ((passive_sets, active_sets), def)) =
82.412 - EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
82.413 - hyp_subst_tac, rtac (def RS trans RS @{thm ssubst_mem}), etac (arg_cong RS trans),
82.414 - rtac (mk_sum_casesN n i), rtac CollectI,
82.415 - EVERY' (map (fn thm => EVERY' [rtac conjI, rtac (thm RS ord_eq_le_trans),
82.416 - etac ((trans OF [@{thm image_id} RS fun_cong, @{thm id_apply}]) RS ord_eq_le_trans)])
82.417 - passive_sets),
82.418 - CONJ_WRAP' (fn (i, thm) => EVERY' [rtac (thm RS ord_eq_le_trans),
82.419 - rtac @{thm image_subsetI}, rtac CollectI, rtac exI, rtac exI, rtac conjI, rtac refl,
82.420 - rtac conjI,
82.421 - rtac conjI, etac @{thm empty_Shift}, dtac set_rev_mp,
82.422 - etac equalityD1, etac CollectD,
82.423 - rtac conjI, etac @{thm Shift_clists},
82.424 - rtac conjI, etac @{thm Shift_prefCl},
82.425 - rtac conjI, rtac ballI,
82.426 - rtac conjI, dtac @{thm iffD1[OF ball_conj_distrib]}, dtac conjunct1,
82.427 - SELECT_GOAL (unfold_thms_tac ctxt @{thms Succ_Shift shift_def}),
82.428 - etac bspec, etac @{thm ShiftD},
82.429 - CONJ_WRAP' (fn i => EVERY' [rtac ballI, etac CollectE, dtac @{thm ShiftD},
82.430 - dtac bspec, etac thin_rl, atac, dtac conjunct2, dtac (mk_conjunctN n i),
82.431 - dtac bspec, rtac CollectI, etac @{thm set_mp[OF equalityD1[OF Succ_Shift]]},
82.432 - REPEAT_DETERM o eresolve_tac [exE, conjE], rtac exI,
82.433 - rtac conjI, rtac (@{thm shift_def} RS fun_cong RS trans),
82.434 - rtac (@{thm append_Cons} RS sym RS arg_cong RS trans), atac,
82.435 - REPEAT_DETERM_N m o (rtac conjI THEN' atac),
82.436 - CONJ_WRAP' (K (EVERY' [etac trans, rtac @{thm Collect_cong},
82.437 - rtac @{thm eqset_imp_iff}, rtac sym, rtac trans, rtac @{thm Succ_Shift},
82.438 - rtac (@{thm append_Cons} RS sym RS arg_cong)])) ks]) ks,
82.439 - rtac allI, rtac impI, REPEAT_DETERM o eresolve_tac [allE, impE],
82.440 - etac @{thm not_in_Shift}, rtac trans, rtac (@{thm shift_def} RS fun_cong), atac,
82.441 - dtac bspec, atac, dtac conjunct2, dtac (mk_conjunctN n i), dtac bspec,
82.442 - etac @{thm set_mp[OF equalityD1]}, atac,
82.443 - REPEAT_DETERM o eresolve_tac [exE, conjE], rtac exI,
82.444 - rtac conjI, rtac (@{thm shift_def} RS fun_cong RS trans),
82.445 - etac (@{thm append_Nil} RS sym RS arg_cong RS trans),
82.446 - REPEAT_DETERM_N m o (rtac conjI THEN' atac),
82.447 - CONJ_WRAP' (K (EVERY' [etac trans, rtac @{thm Collect_cong},
82.448 - rtac @{thm eqset_imp_iff}, rtac sym, rtac trans, rtac @{thm Succ_Shift},
82.449 - rtac (@{thm append_Nil} RS sym RS arg_cong)])) ks]) (ks ~~ active_sets)];
82.450 - in
82.451 - unfold_thms_tac ctxt defs THEN
82.452 - CONJ_WRAP' coalg_tac (ks ~~ (map (chop m) set_naturalss ~~ strT_defs)) 1
82.453 - end;
82.454 -
82.455 -fun mk_card_of_carT_tac m isNode_defs sbd_sbd
82.456 - sbd_card_order sbd_Card_order sbd_Cinfinite sbd_Cnotzero in_sbds =
82.457 - let
82.458 - val n = length isNode_defs;
82.459 - in
82.460 - EVERY' [rtac (Thm.permute_prems 0 1 ctrans),
82.461 - rtac @{thm card_of_Sigma_ordLeq_Cinfinite}, rtac @{thm Cinfinite_cexp},
82.462 - if m = 0 then rtac @{thm ordLeq_refl} else rtac @{thm ordLeq_csum2},
82.463 - rtac @{thm Card_order_ctwo}, rtac @{thm Cinfinite_cexp},
82.464 - rtac @{thm ctwo_ordLeq_Cinfinite}, rtac sbd_Cinfinite, rtac sbd_Cinfinite,
82.465 - rtac ctrans, rtac @{thm card_of_diff},
82.466 - rtac ordIso_ordLeq_trans, rtac @{thm card_of_Field_ordIso},
82.467 - rtac @{thm Card_order_cpow}, rtac ordIso_ordLeq_trans,
82.468 - rtac @{thm cpow_cexp_ctwo}, rtac ctrans, rtac @{thm cexp_mono1_Cnotzero},
82.469 - if m = 0 then rtac @{thm ordLeq_refl} else rtac @{thm ordLeq_csum2},
82.470 - rtac @{thm Card_order_ctwo}, rtac @{thm ctwo_Cnotzero}, rtac @{thm Card_order_clists},
82.471 - rtac @{thm cexp_mono2_Cnotzero}, rtac ordIso_ordLeq_trans,
82.472 - rtac @{thm clists_Cinfinite},
82.473 - if n = 1 then rtac sbd_Cinfinite else rtac (sbd_Cinfinite RS @{thm Cinfinite_csum1}),
82.474 - rtac ordIso_ordLeq_trans, rtac sbd_sbd, rtac @{thm infinite_ordLeq_cexp},
82.475 - rtac sbd_Cinfinite,
82.476 - if m = 0 then rtac @{thm ctwo_Cnotzero} else rtac @{thm csum_Cnotzero2[OF ctwo_Cnotzero]},
82.477 - rtac @{thm Cnotzero_clists},
82.478 - rtac ballI, rtac ordIso_ordLeq_trans, rtac @{thm card_of_Func_Ffunc},
82.479 - rtac ordIso_ordLeq_trans, rtac @{thm Func_cexp},
82.480 - rtac ctrans, rtac @{thm cexp_mono},
82.481 - rtac @{thm ordLeq_ordIso_trans},
82.482 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1
82.483 - (sbd_Cinfinite RS @{thm Cinfinite_cexp[OF ordLeq_csum2[OF Card_order_ctwo]]}
82.484 - RSN (3, @{thm Un_Cinfinite_bound}))))
82.485 - (fn thm => EVERY' [rtac ctrans, rtac @{thm card_of_image}, rtac thm]) (rev in_sbds),
82.486 - rtac @{thm cexp_cong1_Cnotzero}, rtac @{thm csum_cong1},
82.487 - REPEAT_DETERM_N m o rtac @{thm csum_cong2},
82.488 - CONJ_WRAP_GEN' (rtac @{thm csum_cong})
82.489 - (K (rtac (sbd_Card_order RS @{thm card_of_Field_ordIso}))) in_sbds,
82.490 - rtac sbd_Card_order,
82.491 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
82.492 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
82.493 - rtac @{thm ordLeq_ordIso_trans}, etac @{thm clists_bound},
82.494 - rtac @{thm clists_Cinfinite}, TRY o rtac @{thm Cinfinite_csum1}, rtac sbd_Cinfinite,
82.495 - rtac disjI2, rtac @{thm cone_ordLeq_cexp}, rtac @{thm cone_ordLeq_cexp},
82.496 - rtac ctrans, rtac @{thm cone_ordLeq_ctwo}, rtac @{thm ordLeq_csum2},
82.497 - rtac @{thm Card_order_ctwo}, rtac FalseE, etac @{thm cpow_clists_czero}, atac,
82.498 - rtac @{thm card_of_Card_order},
82.499 - rtac ordIso_ordLeq_trans, rtac @{thm cexp_cprod},
82.500 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
82.501 - rtac ordIso_ordLeq_trans, rtac @{thm cexp_cong2_Cnotzero},
82.502 - rtac @{thm ordIso_transitive}, rtac @{thm cprod_cong2}, rtac sbd_sbd,
82.503 - rtac @{thm cprod_infinite}, rtac sbd_Cinfinite,
82.504 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac @{thm Card_order_cprod},
82.505 - rtac ctrans, rtac @{thm cexp_mono1_Cnotzero},
82.506 - rtac ordIso_ordLeq_trans, rtac @{thm ordIso_transitive}, rtac @{thm csum_cong1},
82.507 - rtac @{thm ordIso_transitive},
82.508 - REPEAT_DETERM_N m o rtac @{thm csum_cong2},
82.509 - rtac sbd_sbd,
82.510 - BNF_Tactics.mk_rotate_eq_tac (rtac @{thm ordIso_refl} THEN'
82.511 - FIRST' [rtac @{thm card_of_Card_order},
82.512 - rtac @{thm Card_order_csum}, rtac sbd_Card_order])
82.513 - @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
82.514 - (1 upto m + 1) (m + 1 :: (1 upto m)),
82.515 - if m = 0 then K all_tac else EVERY' [rtac @{thm ordIso_transitive}, rtac @{thm csum_assoc}],
82.516 - rtac @{thm csum_com}, rtac @{thm csum_cexp'}, rtac sbd_Cinfinite,
82.517 - if m = 0 then rtac @{thm Card_order_ctwo} else rtac @{thm Card_order_csum},
82.518 - if m = 0 then rtac @{thm ordLeq_refl} else rtac @{thm ordLeq_csum2},
82.519 - rtac @{thm Card_order_ctwo},
82.520 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac sbd_Card_order,
82.521 - rtac ordIso_ordLeq_trans, rtac @{thm cexp_cprod_ordLeq},
82.522 - if m = 0 then rtac @{thm ctwo_Cnotzero} else rtac @{thm csum_Cnotzero2[OF ctwo_Cnotzero]},
82.523 - rtac sbd_Cinfinite, rtac sbd_Cnotzero, rtac @{thm ordLeq_refl}, rtac sbd_Card_order,
82.524 - rtac @{thm cexp_mono2_Cnotzero}, rtac @{thm infinite_ordLeq_cexp},
82.525 - rtac sbd_Cinfinite,
82.526 - if m = 0 then rtac @{thm ctwo_Cnotzero} else rtac @{thm csum_Cnotzero2[OF ctwo_Cnotzero]},
82.527 - rtac sbd_Cnotzero,
82.528 - rtac @{thm card_of_mono1}, rtac subsetI,
82.529 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE, @{thm prod_caseE}], hyp_subst_tac,
82.530 - rtac @{thm SigmaI}, rtac @{thm DiffI}, rtac set_mp, rtac equalityD2,
82.531 - rtac (@{thm cpow_def} RS arg_cong RS trans), rtac (@{thm Pow_def} RS arg_cong RS trans),
82.532 - rtac @{thm Field_card_of}, rtac CollectI, atac, rtac notI, etac @{thm singletonE},
82.533 - hyp_subst_tac, etac @{thm emptyE}, rtac (@{thm Ffunc_def} RS equalityD2 RS set_mp),
82.534 - rtac CollectI, rtac conjI, rtac ballI, dtac bspec, etac thin_rl, atac, dtac conjunct1,
82.535 - CONJ_WRAP_GEN' (etac disjE) (fn (i, def) => EVERY'
82.536 - [rtac (mk_UnIN n i), dtac (def RS iffD1),
82.537 - REPEAT_DETERM o eresolve_tac [exE, conjE], rtac @{thm image_eqI}, atac, rtac CollectI,
82.538 - REPEAT_DETERM_N m o (rtac conjI THEN' atac),
82.539 - CONJ_WRAP' (K (EVERY' [etac ord_eq_le_trans, rtac subset_trans,
82.540 - rtac subset_UNIV, rtac equalityD2, rtac @{thm Field_card_order},
82.541 - rtac sbd_card_order])) isNode_defs]) (1 upto n ~~ isNode_defs),
82.542 - atac] 1
82.543 - end;
82.544 -
82.545 -fun mk_carT_set_tac n i carT_def strT_def isNode_def set_natural {context = ctxt, prems = _}=
82.546 - EVERY' [dtac (carT_def RS equalityD1 RS set_mp),
82.547 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
82.548 - dtac Pair_eqD,
82.549 - etac conjE, hyp_subst_tac,
82.550 - dtac (isNode_def RS iffD1),
82.551 - REPEAT_DETERM o eresolve_tac [exE, conjE],
82.552 - rtac (equalityD2 RS set_mp),
82.553 - rtac (strT_def RS arg_cong RS trans),
82.554 - etac (arg_cong RS trans),
82.555 - fo_rtac (mk_sum_casesN n i RS arg_cong RS trans) ctxt,
82.556 - rtac set_natural, rtac imageI, etac (equalityD2 RS set_mp), rtac CollectI,
82.557 - etac @{thm prefCl_Succ}, atac] 1;
82.558 -
82.559 -fun mk_strT_hset_tac n m j arg_cong_cTs cTs cts carT_defs strT_defs isNode_defs
82.560 - set_incl_hsets set_hset_incl_hsetss coalg_setss carT_setss coalgT set_naturalss =
82.561 - let
82.562 - val set_naturals = map (fn xs => nth xs (j - 1)) set_naturalss;
82.563 - val ks = 1 upto n;
82.564 - fun base_tac (i, (cT, (strT_def, (set_incl_hset, set_natural)))) =
82.565 - CONJ_WRAP' (fn (i', (carT_def, isNode_def)) => rtac impI THEN' etac conjE THEN'
82.566 - (if i = i'
82.567 - then EVERY' [rtac @{thm xt1(4)}, rtac set_incl_hset,
82.568 - rtac (strT_def RS arg_cong RS trans), etac (arg_cong RS trans),
82.569 - rtac (Thm.permute_prems 0 1 (set_natural RS box_equals)),
82.570 - rtac (trans OF [@{thm image_id} RS fun_cong, @{thm id_apply}]),
82.571 - rtac (mk_sum_casesN n i RS (Drule.instantiate' [cT] [] arg_cong) RS sym)]
82.572 - else EVERY' [dtac (carT_def RS equalityD1 RS set_mp),
82.573 - REPEAT_DETERM o eresolve_tac [CollectE, exE], etac conjE,
82.574 - dtac conjunct2, dtac Pair_eqD, etac conjE,
82.575 - hyp_subst_tac, dtac (isNode_def RS iffD1),
82.576 - REPEAT_DETERM o eresolve_tac [exE, conjE],
82.577 - rtac (mk_InN_not_InM i i' RS notE), etac (sym RS trans), atac]))
82.578 - (ks ~~ (carT_defs ~~ isNode_defs));
82.579 - fun step_tac (i, (coalg_sets, (carT_sets, set_hset_incl_hsets))) =
82.580 - dtac (mk_conjunctN n i) THEN'
82.581 - CONJ_WRAP' (fn (coalg_set, (carT_set, set_hset_incl_hset)) =>
82.582 - EVERY' [rtac impI, etac conjE, etac impE, rtac conjI,
82.583 - rtac (coalgT RS coalg_set RS set_mp), atac, etac carT_set, atac, atac,
82.584 - etac (@{thm shift_def} RS fun_cong RS trans), etac subset_trans,
82.585 - rtac set_hset_incl_hset, etac carT_set, atac, atac])
82.586 - (coalg_sets ~~ (carT_sets ~~ set_hset_incl_hsets));
82.587 - in
82.588 - EVERY' [rtac (Drule.instantiate' cTs cts @{thm list.induct}),
82.589 - REPEAT_DETERM o rtac allI, rtac impI,
82.590 - CONJ_WRAP' base_tac
82.591 - (ks ~~ (arg_cong_cTs ~~ (strT_defs ~~ (set_incl_hsets ~~ set_naturals)))),
82.592 - REPEAT_DETERM o rtac allI, rtac impI,
82.593 - REPEAT_DETERM o eresolve_tac [allE, impE], etac @{thm ShiftI},
82.594 - CONJ_WRAP' (fn i => dtac (mk_conjunctN n i) THEN' rtac (mk_sumEN n) THEN'
82.595 - CONJ_WRAP_GEN' (K all_tac) step_tac
82.596 - (ks ~~ (drop m coalg_setss ~~ (carT_setss ~~ set_hset_incl_hsetss)))) ks] 1
82.597 - end;
82.598 -
82.599 -fun mk_isNode_hset_tac n isNode_def strT_hsets {context = ctxt, prems = _} =
82.600 - let
82.601 - val m = length strT_hsets;
82.602 - in
82.603 - if m = 0 then atac 1
82.604 - else (unfold_thms_tac ctxt [isNode_def] THEN
82.605 - EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
82.606 - rtac exI, rtac conjI, atac,
82.607 - CONJ_WRAP' (fn (thm, i) => if i > m then atac
82.608 - else EVERY' [rtac (thm RS subset_trans), atac, rtac conjI, atac, atac, atac])
82.609 - (strT_hsets @ (replicate n mp) ~~ (1 upto (m + n)))] 1)
82.610 - end;
82.611 -
82.612 -fun mk_Lev_sbd_tac cts Lev_0s Lev_Sucs to_sbdss =
82.613 - let
82.614 - val n = length Lev_0s;
82.615 - val ks = 1 upto n;
82.616 - in
82.617 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.618 - REPEAT_DETERM o rtac allI,
82.619 - CONJ_WRAP' (fn Lev_0 =>
82.620 - EVERY' (map rtac [ord_eq_le_trans, Lev_0, @{thm Nil_clists}])) Lev_0s,
82.621 - REPEAT_DETERM o rtac allI,
82.622 - CONJ_WRAP' (fn (Lev_Suc, to_sbds) =>
82.623 - EVERY' [rtac ord_eq_le_trans, rtac Lev_Suc,
82.624 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
82.625 - (fn (i, to_sbd) => EVERY' [rtac subsetI,
82.626 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
82.627 - rtac @{thm Cons_clists}, rtac (mk_InN_Field n i), etac to_sbd,
82.628 - etac set_rev_mp, REPEAT_DETERM o etac allE,
82.629 - etac (mk_conjunctN n i)])
82.630 - (rev (ks ~~ to_sbds))])
82.631 - (Lev_Sucs ~~ to_sbdss)] 1
82.632 - end;
82.633 -
82.634 -fun mk_length_Lev_tac cts Lev_0s Lev_Sucs =
82.635 - let
82.636 - val n = length Lev_0s;
82.637 - val ks = n downto 1;
82.638 - in
82.639 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.640 - REPEAT_DETERM o rtac allI,
82.641 - CONJ_WRAP' (fn Lev_0 =>
82.642 - EVERY' [rtac impI, dtac (Lev_0 RS equalityD1 RS set_mp),
82.643 - etac @{thm singletonE}, etac ssubst, rtac @{thm list.size(3)}]) Lev_0s,
82.644 - REPEAT_DETERM o rtac allI,
82.645 - CONJ_WRAP' (fn Lev_Suc =>
82.646 - EVERY' [rtac impI, dtac (Lev_Suc RS equalityD1 RS set_mp),
82.647 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
82.648 - (fn i => EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
82.649 - rtac trans, rtac @{thm length_Cons}, rtac @{thm arg_cong[of _ _ Suc]},
82.650 - REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i), etac mp, atac]) ks])
82.651 - Lev_Sucs] 1
82.652 - end;
82.653 -
82.654 -fun mk_length_Lev'_tac length_Lev =
82.655 - EVERY' [ftac length_Lev, etac ssubst, atac] 1;
82.656 -
82.657 -fun mk_prefCl_Lev_tac cts Lev_0s Lev_Sucs =
82.658 - let
82.659 - val n = length Lev_0s;
82.660 - val ks = n downto 1;
82.661 - in
82.662 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.663 - REPEAT_DETERM o rtac allI,
82.664 - CONJ_WRAP' (fn Lev_0 =>
82.665 - EVERY' [rtac impI, etac conjE, dtac (Lev_0 RS equalityD1 RS set_mp),
82.666 - etac @{thm singletonE}, hyp_subst_tac, dtac @{thm prefix_Nil[THEN subst, of "%x. x"]},
82.667 - hyp_subst_tac, rtac @{thm set_mp[OF equalityD2[OF trans[OF arg_cong[OF list.size(3)]]]]},
82.668 - rtac Lev_0, rtac @{thm singletonI}]) Lev_0s,
82.669 - REPEAT_DETERM o rtac allI,
82.670 - CONJ_WRAP' (fn (Lev_0, Lev_Suc) =>
82.671 - EVERY' [rtac impI, etac conjE, dtac (Lev_Suc RS equalityD1 RS set_mp),
82.672 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
82.673 - (fn i => EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
82.674 - dtac @{thm prefix_Cons[THEN subst, of "%x. x"]}, etac disjE, hyp_subst_tac,
82.675 - rtac @{thm set_mp[OF equalityD2[OF trans[OF arg_cong[OF list.size(3)]]]]},
82.676 - rtac Lev_0, rtac @{thm singletonI},
82.677 - REPEAT_DETERM o eresolve_tac [exE, conjE], hyp_subst_tac,
82.678 - rtac @{thm set_mp[OF equalityD2[OF trans[OF arg_cong[OF length_Cons]]]]},
82.679 - rtac Lev_Suc, rtac (mk_UnIN n i), rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI,
82.680 - rtac refl, etac conjI, REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i),
82.681 - etac mp, etac conjI, atac]) ks])
82.682 - (Lev_0s ~~ Lev_Sucs)] 1
82.683 - end;
82.684 -
82.685 -fun mk_rv_last_tac cTs cts rv_Nils rv_Conss =
82.686 - let
82.687 - val n = length rv_Nils;
82.688 - val ks = 1 upto n;
82.689 - in
82.690 - EVERY' [rtac (Drule.instantiate' cTs cts @{thm list.induct}),
82.691 - REPEAT_DETERM o rtac allI,
82.692 - CONJ_WRAP' (fn rv_Cons =>
82.693 - CONJ_WRAP' (fn (i, rv_Nil) => (EVERY' [rtac exI,
82.694 - rtac (@{thm append_Nil} RS arg_cong RS trans),
82.695 - rtac (rv_Cons RS trans), rtac (mk_sum_casesN n i RS arg_cong RS trans), rtac rv_Nil]))
82.696 - (ks ~~ rv_Nils))
82.697 - rv_Conss,
82.698 - REPEAT_DETERM o rtac allI, rtac (mk_sumEN n),
82.699 - EVERY' (map (fn i =>
82.700 - CONJ_WRAP' (fn rv_Cons => EVERY' [REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i),
82.701 - CONJ_WRAP' (fn i' => EVERY' [dtac (mk_conjunctN n i'), etac exE, rtac exI,
82.702 - rtac (@{thm append_Cons} RS arg_cong RS trans),
82.703 - rtac (rv_Cons RS trans), etac (sum_case_weak_cong RS arg_cong RS trans),
82.704 - rtac (mk_sum_casesN n i RS arg_cong RS trans), atac])
82.705 - ks])
82.706 - rv_Conss)
82.707 - ks)] 1
82.708 - end;
82.709 -
82.710 -fun mk_set_rv_Lev_tac m cts Lev_0s Lev_Sucs rv_Nils rv_Conss coalg_setss from_to_sbdss =
82.711 - let
82.712 - val n = length Lev_0s;
82.713 - val ks = 1 upto n;
82.714 - in
82.715 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.716 - REPEAT_DETERM o rtac allI,
82.717 - CONJ_WRAP' (fn (i, ((Lev_0, rv_Nil), coalg_sets)) =>
82.718 - EVERY' [rtac impI, REPEAT_DETERM o etac conjE,
82.719 - dtac (Lev_0 RS equalityD1 RS set_mp), etac @{thm singletonE}, etac ssubst,
82.720 - rtac (rv_Nil RS arg_cong RS iffD2),
82.721 - rtac (mk_sum_casesN n i RS iffD2),
82.722 - CONJ_WRAP' (fn thm => etac thm THEN' atac) (take m coalg_sets)])
82.723 - (ks ~~ ((Lev_0s ~~ rv_Nils) ~~ coalg_setss)),
82.724 - REPEAT_DETERM o rtac allI,
82.725 - CONJ_WRAP' (fn ((Lev_Suc, rv_Cons), (from_to_sbds, coalg_sets)) =>
82.726 - EVERY' [rtac impI, etac conjE, dtac (Lev_Suc RS equalityD1 RS set_mp),
82.727 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
82.728 - (fn (i, (from_to_sbd, coalg_set)) =>
82.729 - EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
82.730 - rtac (rv_Cons RS arg_cong RS iffD2),
82.731 - rtac (mk_sum_casesN n i RS arg_cong RS trans RS iffD2),
82.732 - etac (from_to_sbd RS arg_cong), REPEAT_DETERM o etac allE,
82.733 - dtac (mk_conjunctN n i), etac mp, etac conjI, etac set_rev_mp,
82.734 - etac coalg_set, atac])
82.735 - (rev (ks ~~ (from_to_sbds ~~ drop m coalg_sets)))])
82.736 - ((Lev_Sucs ~~ rv_Conss) ~~ (from_to_sbdss ~~ coalg_setss))] 1
82.737 - end;
82.738 -
82.739 -fun mk_set_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbdss =
82.740 - let
82.741 - val n = length Lev_0s;
82.742 - val ks = 1 upto n;
82.743 - in
82.744 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.745 - REPEAT_DETERM o rtac allI,
82.746 - CONJ_WRAP' (fn ((i, (Lev_0, Lev_Suc)), rv_Nil) =>
82.747 - EVERY' [rtac impI, dtac (Lev_0 RS equalityD1 RS set_mp),
82.748 - etac @{thm singletonE}, hyp_subst_tac,
82.749 - CONJ_WRAP' (fn i' => rtac impI THEN' dtac (sym RS trans) THEN' rtac rv_Nil THEN'
82.750 - (if i = i'
82.751 - then EVERY' [dtac (mk_InN_inject n i), hyp_subst_tac,
82.752 - CONJ_WRAP' (fn (i'', Lev_0'') =>
82.753 - EVERY' [rtac impI, rtac @{thm ssubst_mem[OF append_Nil]},
82.754 - rtac (Lev_Suc RS equalityD2 RS set_mp), rtac (mk_UnIN n i''),
82.755 - rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI, rtac refl,
82.756 - etac conjI, rtac (Lev_0'' RS equalityD2 RS set_mp),
82.757 - rtac @{thm singletonI}])
82.758 - (ks ~~ Lev_0s)]
82.759 - else etac (mk_InN_not_InM i' i RS notE)))
82.760 - ks])
82.761 - ((ks ~~ (Lev_0s ~~ Lev_Sucs)) ~~ rv_Nils),
82.762 - REPEAT_DETERM o rtac allI,
82.763 - CONJ_WRAP' (fn ((Lev_Suc, rv_Cons), from_to_sbds) =>
82.764 - EVERY' [rtac impI, dtac (Lev_Suc RS equalityD1 RS set_mp),
82.765 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
82.766 - (fn (i, from_to_sbd) =>
82.767 - EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
82.768 - CONJ_WRAP' (fn i' => rtac impI THEN'
82.769 - CONJ_WRAP' (fn i'' =>
82.770 - EVERY' [rtac impI, rtac (Lev_Suc RS equalityD2 RS set_mp),
82.771 - rtac @{thm ssubst_mem[OF append_Cons]}, rtac (mk_UnIN n i),
82.772 - rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI, rtac refl,
82.773 - rtac conjI, atac, dtac (sym RS trans RS sym),
82.774 - rtac (rv_Cons RS trans), rtac (mk_sum_casesN n i RS trans),
82.775 - etac (from_to_sbd RS arg_cong), REPEAT_DETERM o etac allE,
82.776 - dtac (mk_conjunctN n i), dtac mp, atac,
82.777 - dtac (mk_conjunctN n i'), dtac mp, atac,
82.778 - dtac (mk_conjunctN n i''), etac mp, atac])
82.779 - ks)
82.780 - ks])
82.781 - (rev (ks ~~ from_to_sbds))])
82.782 - ((Lev_Sucs ~~ rv_Conss) ~~ from_to_sbdss)] 1
82.783 - end;
82.784 -
82.785 -fun mk_set_image_Lev_tac cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbdss to_sbd_injss =
82.786 - let
82.787 - val n = length Lev_0s;
82.788 - val ks = 1 upto n;
82.789 - in
82.790 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.791 - REPEAT_DETERM o rtac allI,
82.792 - CONJ_WRAP' (fn ((i, (Lev_0, Lev_Suc)), rv_Nil) =>
82.793 - EVERY' [rtac impI, dtac (Lev_0 RS equalityD1 RS set_mp),
82.794 - etac @{thm singletonE}, hyp_subst_tac,
82.795 - CONJ_WRAP' (fn i' => rtac impI THEN'
82.796 - CONJ_WRAP' (fn i'' => rtac impI THEN' dtac (sym RS trans) THEN' rtac rv_Nil THEN'
82.797 - (if i = i''
82.798 - then EVERY' [dtac @{thm ssubst_mem[OF sym[OF append_Nil]]},
82.799 - dtac (Lev_Suc RS equalityD1 RS set_mp), dtac (mk_InN_inject n i),
82.800 - hyp_subst_tac,
82.801 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
82.802 - (fn k => REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE] THEN'
82.803 - dtac list_inject_iffD1 THEN' etac conjE THEN'
82.804 - (if k = i'
82.805 - then EVERY' [dtac (mk_InN_inject n k), hyp_subst_tac, etac imageI]
82.806 - else etac (mk_InN_not_InM i' k RS notE)))
82.807 - (rev ks)]
82.808 - else etac (mk_InN_not_InM i'' i RS notE)))
82.809 - ks)
82.810 - ks])
82.811 - ((ks ~~ (Lev_0s ~~ Lev_Sucs)) ~~ rv_Nils),
82.812 - REPEAT_DETERM o rtac allI,
82.813 - CONJ_WRAP' (fn ((Lev_Suc, rv_Cons), (from_to_sbds, to_sbd_injs)) =>
82.814 - EVERY' [rtac impI, dtac (Lev_Suc RS equalityD1 RS set_mp),
82.815 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE))
82.816 - (fn (i, (from_to_sbd, to_sbd_inj)) =>
82.817 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE] THEN' hyp_subst_tac THEN'
82.818 - CONJ_WRAP' (fn i' => rtac impI THEN'
82.819 - dtac @{thm ssubst_mem[OF sym[OF append_Cons]]} THEN'
82.820 - dtac (Lev_Suc RS equalityD1 RS set_mp) THEN'
82.821 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE)) (fn k =>
82.822 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE] THEN'
82.823 - dtac list_inject_iffD1 THEN' etac conjE THEN'
82.824 - (if k = i
82.825 - then EVERY' [dtac (mk_InN_inject n i),
82.826 - dtac (Thm.permute_prems 0 2 (to_sbd_inj RS iffD1)),
82.827 - atac, atac, hyp_subst_tac] THEN'
82.828 - CONJ_WRAP' (fn i'' =>
82.829 - EVERY' [rtac impI, dtac (sym RS trans),
82.830 - rtac (rv_Cons RS trans), rtac (mk_sum_casesN n i RS arg_cong RS trans),
82.831 - etac (from_to_sbd RS arg_cong),
82.832 - REPEAT_DETERM o etac allE,
82.833 - dtac (mk_conjunctN n i), dtac mp, atac,
82.834 - dtac (mk_conjunctN n i'), dtac mp, atac,
82.835 - dtac (mk_conjunctN n i''), etac mp, etac sym])
82.836 - ks
82.837 - else etac (mk_InN_not_InM i k RS notE)))
82.838 - (rev ks))
82.839 - ks)
82.840 - (rev (ks ~~ (from_to_sbds ~~ to_sbd_injs)))])
82.841 - ((Lev_Sucs ~~ rv_Conss) ~~ (from_to_sbdss ~~ to_sbd_injss))] 1
82.842 - end;
82.843 -
82.844 -fun mk_mor_beh_tac m mor_def mor_cong beh_defs carT_defs strT_defs isNode_defs
82.845 - to_sbd_injss from_to_sbdss Lev_0s Lev_Sucs rv_Nils rv_Conss Lev_sbds length_Levs length_Lev's
82.846 - prefCl_Levs rv_lastss set_rv_Levsss set_Levsss set_image_Levsss set_naturalss coalg_setss
82.847 - map_comp_ids map_congs map_arg_congs {context = ctxt, prems = _} =
82.848 - let
82.849 - val n = length beh_defs;
82.850 - val ks = 1 upto n;
82.851 -
82.852 - fun fbetw_tac (i, (carT_def, (isNode_def, (Lev_0, (rv_Nil, (Lev_sbd,
82.853 - ((length_Lev, length_Lev'), (prefCl_Lev, (rv_lasts, (set_naturals,
82.854 - (coalg_sets, (set_rv_Levss, (set_Levss, set_image_Levss))))))))))))) =
82.855 - EVERY' [rtac ballI, rtac (carT_def RS equalityD2 RS set_mp),
82.856 - rtac CollectI, REPEAT_DETERM o rtac exI, rtac conjI, rtac refl, rtac conjI,
82.857 - rtac conjI,
82.858 - rtac @{thm UN_I}, rtac UNIV_I, rtac (Lev_0 RS equalityD2 RS set_mp),
82.859 - rtac @{thm singletonI},
82.860 - rtac conjI,
82.861 - rtac @{thm UN_least}, rtac Lev_sbd,
82.862 - rtac conjI,
82.863 - rtac @{thm prefCl_UN}, rtac ssubst, rtac @{thm PrefCl_def}, REPEAT_DETERM o rtac allI,
82.864 - rtac impI, etac conjE, rtac exI, rtac conjI, rtac @{thm ord_le_eq_trans},
82.865 - etac @{thm prefix_length_le}, etac length_Lev, rtac prefCl_Lev, etac conjI, atac,
82.866 - rtac conjI,
82.867 - rtac ballI, etac @{thm UN_E}, rtac conjI,
82.868 - if n = 1 then K all_tac else rtac (mk_sumEN n),
82.869 - EVERY' (map6 (fn i => fn isNode_def => fn set_naturals =>
82.870 - fn set_rv_Levs => fn set_Levs => fn set_image_Levs =>
82.871 - EVERY' [rtac (mk_disjIN n i), rtac (isNode_def RS ssubst),
82.872 - rtac exI, rtac conjI,
82.873 - (if n = 1 then rtac @{thm if_P} THEN' etac length_Lev'
82.874 - else rtac (@{thm if_P} RS arg_cong RS trans) THEN' etac length_Lev' THEN'
82.875 - etac (sum_case_weak_cong RS trans) THEN' rtac (mk_sum_casesN n i)),
82.876 - EVERY' (map2 (fn set_natural => fn set_rv_Lev =>
82.877 - EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac (set_natural RS trans),
82.878 - rtac trans_fun_cong_image_id_id_apply,
82.879 - etac set_rv_Lev, TRY o atac, etac conjI, atac])
82.880 - (take m set_naturals) set_rv_Levs),
82.881 - CONJ_WRAP' (fn (set_natural, (set_Lev, set_image_Lev)) =>
82.882 - EVERY' [rtac (set_natural RS trans), rtac equalityI, rtac @{thm image_subsetI},
82.883 - rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, etac set_Lev,
82.884 - if n = 1 then rtac refl else atac, atac, rtac subsetI,
82.885 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
82.886 - rtac set_image_Lev, atac, dtac length_Lev, hyp_subst_tac, dtac length_Lev',
82.887 - etac @{thm set_mp[OF equalityD1[OF arg_cong[OF length_append_singleton]]]},
82.888 - if n = 1 then rtac refl else atac])
82.889 - (drop m set_naturals ~~ (set_Levs ~~ set_image_Levs))])
82.890 - ks isNode_defs set_naturalss set_rv_Levss set_Levss set_image_Levss),
82.891 - CONJ_WRAP' (fn (i, (rv_last, (isNode_def, (set_naturals,
82.892 - (set_rv_Levs, (set_Levs, set_image_Levs)))))) =>
82.893 - EVERY' [rtac ballI,
82.894 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
82.895 - rtac (rev_mp OF [rv_last, impI]), etac exE, rtac (isNode_def RS ssubst),
82.896 - rtac exI, rtac conjI,
82.897 - (if n = 1 then rtac @{thm if_P} THEN' etac length_Lev'
82.898 - else rtac (@{thm if_P} RS trans) THEN' etac length_Lev' THEN'
82.899 - etac (sum_case_weak_cong RS trans) THEN' rtac (mk_sum_casesN n i)),
82.900 - EVERY' (map2 (fn set_natural => fn set_rv_Lev =>
82.901 - EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac (set_natural RS trans),
82.902 - rtac trans_fun_cong_image_id_id_apply,
82.903 - etac set_rv_Lev, TRY o atac, etac conjI, atac])
82.904 - (take m set_naturals) set_rv_Levs),
82.905 - CONJ_WRAP' (fn (set_natural, (set_Lev, set_image_Lev)) =>
82.906 - EVERY' [rtac (set_natural RS trans), rtac equalityI, rtac @{thm image_subsetI},
82.907 - rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, etac set_Lev,
82.908 - if n = 1 then rtac refl else atac, atac, rtac subsetI,
82.909 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
82.910 - REPEAT_DETERM_N 4 o etac thin_rl,
82.911 - rtac set_image_Lev,
82.912 - atac, dtac length_Lev, hyp_subst_tac, dtac length_Lev',
82.913 - etac @{thm set_mp[OF equalityD1[OF arg_cong[OF length_append_singleton]]]},
82.914 - if n = 1 then rtac refl else atac])
82.915 - (drop m set_naturals ~~ (set_Levs ~~ set_image_Levs))])
82.916 - (ks ~~ (rv_lasts ~~ (isNode_defs ~~ (set_naturalss ~~
82.917 - (set_rv_Levss ~~ (set_Levss ~~ set_image_Levss)))))),
82.918 - (**)
82.919 - rtac allI, rtac impI, rtac @{thm if_not_P}, rtac notI,
82.920 - etac notE, etac @{thm UN_I[OF UNIV_I]},
82.921 - (*root isNode*)
82.922 - rtac (isNode_def RS ssubst), rtac exI, rtac conjI, rtac (@{thm if_P} RS trans),
82.923 - rtac length_Lev', rtac (Lev_0 RS equalityD2 RS set_mp), rtac @{thm singletonI},
82.924 - CONVERSION (Conv.top_conv
82.925 - (K (Conv.try_conv (Conv.rewr_conv (rv_Nil RS eq_reflection)))) ctxt),
82.926 - if n = 1 then rtac refl else rtac (mk_sum_casesN n i),
82.927 - EVERY' (map2 (fn set_natural => fn coalg_set =>
82.928 - EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac (set_natural RS trans),
82.929 - rtac trans_fun_cong_image_id_id_apply, etac coalg_set, atac])
82.930 - (take m set_naturals) (take m coalg_sets)),
82.931 - CONJ_WRAP' (fn (set_natural, (set_Lev, set_image_Lev)) =>
82.932 - EVERY' [rtac (set_natural RS trans), rtac equalityI, rtac @{thm image_subsetI},
82.933 - rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, rtac set_Lev,
82.934 - rtac (Lev_0 RS equalityD2 RS set_mp), rtac @{thm singletonI}, rtac rv_Nil,
82.935 - atac, rtac subsetI,
82.936 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm SuccE}, @{thm UN_E}],
82.937 - rtac set_image_Lev, rtac (Lev_0 RS equalityD2 RS set_mp),
82.938 - rtac @{thm singletonI}, dtac length_Lev',
82.939 - etac @{thm set_mp[OF equalityD1[OF arg_cong[OF
82.940 - trans[OF length_append_singleton arg_cong[of _ _ Suc, OF list.size(3)]]]]]},
82.941 - rtac rv_Nil])
82.942 - (drop m set_naturals ~~ (nth set_Levss (i - 1) ~~ nth set_image_Levss (i - 1)))];
82.943 -
82.944 - fun mor_tac (i, (strT_def, (((Lev_0, Lev_Suc), (rv_Nil, rv_Cons)),
82.945 - ((map_comp_id, (map_cong, map_arg_cong)), (length_Lev', (from_to_sbds, to_sbd_injs)))))) =
82.946 - EVERY' [rtac ballI, rtac sym, rtac trans, rtac strT_def,
82.947 - rtac (@{thm if_P} RS
82.948 - (if n = 1 then map_arg_cong else sum_case_weak_cong) RS trans),
82.949 - rtac (@{thm list.size(3)} RS arg_cong RS trans RS equalityD2 RS set_mp),
82.950 - rtac Lev_0, rtac @{thm singletonI},
82.951 - CONVERSION (Conv.top_conv
82.952 - (K (Conv.try_conv (Conv.rewr_conv (rv_Nil RS eq_reflection)))) ctxt),
82.953 - if n = 1 then K all_tac
82.954 - else (rtac (sum_case_weak_cong RS trans) THEN'
82.955 - rtac (mk_sum_casesN n i) THEN' rtac (mk_sum_casesN n i RS trans)),
82.956 - rtac (map_comp_id RS trans), rtac (map_cong OF replicate m refl),
82.957 - EVERY' (map3 (fn i' => fn to_sbd_inj => fn from_to_sbd =>
82.958 - DETERM o EVERY' [rtac trans, rtac o_apply, rtac Pair_eqI, rtac conjI,
82.959 - rtac trans, rtac @{thm Shift_def},
82.960 - rtac equalityI, rtac subsetI, etac thin_rl, etac thin_rl,
82.961 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm UN_E}], dtac length_Lev', dtac asm_rl,
82.962 - etac thin_rl, dtac @{thm set_rev_mp[OF _ equalityD1]},
82.963 - rtac (@{thm length_Cons} RS arg_cong RS trans), rtac Lev_Suc,
82.964 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE)) (fn i'' =>
82.965 - EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
82.966 - dtac list_inject_iffD1, etac conjE,
82.967 - if i' = i'' then EVERY' [dtac (mk_InN_inject n i'),
82.968 - dtac (Thm.permute_prems 0 2 (to_sbd_inj RS iffD1)),
82.969 - atac, atac, hyp_subst_tac, etac @{thm UN_I[OF UNIV_I]}]
82.970 - else etac (mk_InN_not_InM i' i'' RS notE)])
82.971 - (rev ks),
82.972 - rtac @{thm UN_least}, rtac subsetI, rtac CollectI, rtac @{thm UN_I[OF UNIV_I]},
82.973 - rtac (Lev_Suc RS equalityD2 RS set_mp), rtac (mk_UnIN n i'), rtac CollectI,
82.974 - REPEAT_DETERM o rtac exI, rtac conjI, rtac refl, etac conjI, atac,
82.975 - rtac trans, rtac @{thm shift_def}, rtac ssubst, rtac @{thm fun_eq_iff}, rtac allI,
82.976 - rtac @{thm if_cong}, rtac (@{thm length_Cons} RS arg_cong RS trans), rtac iffI,
82.977 - dtac asm_rl, dtac asm_rl, dtac asm_rl,
82.978 - dtac (Lev_Suc RS equalityD1 RS set_mp),
82.979 - CONJ_WRAP_GEN' (etac (Thm.permute_prems 1 1 UnE)) (fn i'' =>
82.980 - EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE],
82.981 - dtac list_inject_iffD1, etac conjE,
82.982 - if i' = i'' then EVERY' [dtac (mk_InN_inject n i'),
82.983 - dtac (Thm.permute_prems 0 2 (to_sbd_inj RS iffD1)),
82.984 - atac, atac, hyp_subst_tac, atac]
82.985 - else etac (mk_InN_not_InM i' i'' RS notE)])
82.986 - (rev ks),
82.987 - rtac (Lev_Suc RS equalityD2 RS set_mp), rtac (mk_UnIN n i'), rtac CollectI,
82.988 - REPEAT_DETERM o rtac exI, rtac conjI, rtac refl, etac conjI, atac,
82.989 - CONVERSION (Conv.top_conv
82.990 - (K (Conv.try_conv (Conv.rewr_conv (rv_Cons RS eq_reflection)))) ctxt),
82.991 - if n = 1 then K all_tac
82.992 - else rtac sum_case_weak_cong THEN' rtac (mk_sum_casesN n i' RS trans),
82.993 - SELECT_GOAL (unfold_thms_tac ctxt [from_to_sbd]), rtac refl,
82.994 - rtac refl])
82.995 - ks to_sbd_injs from_to_sbds)];
82.996 - in
82.997 - (rtac mor_cong THEN'
82.998 - EVERY' (map (fn thm => rtac (thm RS ext)) beh_defs) THEN'
82.999 - stac mor_def THEN' rtac conjI THEN'
82.1000 - CONJ_WRAP' fbetw_tac
82.1001 - (ks ~~ (carT_defs ~~ (isNode_defs ~~ (Lev_0s ~~ (rv_Nils ~~ (Lev_sbds ~~
82.1002 - ((length_Levs ~~ length_Lev's) ~~ (prefCl_Levs ~~ (rv_lastss ~~
82.1003 - (set_naturalss ~~ (coalg_setss ~~
82.1004 - (set_rv_Levsss ~~ (set_Levsss ~~ set_image_Levsss))))))))))))) THEN'
82.1005 - CONJ_WRAP' mor_tac
82.1006 - (ks ~~ (strT_defs ~~ (((Lev_0s ~~ Lev_Sucs) ~~ (rv_Nils ~~ rv_Conss)) ~~
82.1007 - ((map_comp_ids ~~ (map_congs ~~ map_arg_congs)) ~~
82.1008 - (length_Lev's ~~ (from_to_sbdss ~~ to_sbd_injss))))))) 1
82.1009 - end;
82.1010 -
82.1011 -fun mk_congruent_str_final_tac m lsbisE map_comp_id map_cong equiv_LSBISs =
82.1012 - EVERY' [rtac @{thm congruentI}, dtac lsbisE,
82.1013 - REPEAT_DETERM o eresolve_tac [CollectE, conjE, bexE], rtac (o_apply RS trans),
82.1014 - etac (sym RS arg_cong RS trans), rtac (map_comp_id RS trans),
82.1015 - rtac (map_cong RS trans), REPEAT_DETERM_N m o rtac refl,
82.1016 - EVERY' (map (fn equiv_LSBIS =>
82.1017 - EVERY' [rtac @{thm equiv_proj}, rtac equiv_LSBIS, etac set_mp, atac])
82.1018 - equiv_LSBISs), rtac sym, rtac (o_apply RS trans),
82.1019 - etac (sym RS arg_cong RS trans), rtac map_comp_id] 1;
82.1020 -
82.1021 -fun mk_coalg_final_tac m coalg_def congruent_str_finals equiv_LSBISs set_naturalss coalgT_setss =
82.1022 - EVERY' [stac coalg_def,
82.1023 - CONJ_WRAP' (fn ((set_naturals, coalgT_sets), (equiv_LSBIS, congruent_str_final)) =>
82.1024 - EVERY' [rtac @{thm univ_preserves}, rtac equiv_LSBIS, rtac congruent_str_final,
82.1025 - rtac ballI, rtac @{thm ssubst_mem}, rtac o_apply, rtac CollectI,
82.1026 - EVERY' (map2 (fn set_natural => fn coalgT_set =>
82.1027 - EVERY' [rtac conjI, rtac (set_natural RS ord_eq_le_trans),
82.1028 - rtac ord_eq_le_trans_trans_fun_cong_image_id_id_apply,
82.1029 - etac coalgT_set])
82.1030 - (take m set_naturals) (take m coalgT_sets)),
82.1031 - CONJ_WRAP' (fn (equiv_LSBIS, (set_natural, coalgT_set)) =>
82.1032 - EVERY' [rtac (set_natural RS ord_eq_le_trans),
82.1033 - rtac @{thm image_subsetI}, rtac ssubst, rtac @{thm proj_in_iff},
82.1034 - rtac equiv_LSBIS, etac set_rev_mp, etac coalgT_set])
82.1035 - (equiv_LSBISs ~~ drop m (set_naturals ~~ coalgT_sets))])
82.1036 - ((set_naturalss ~~ coalgT_setss) ~~ (equiv_LSBISs ~~ congruent_str_finals))] 1;
82.1037 -
82.1038 -fun mk_mor_T_final_tac mor_def congruent_str_finals equiv_LSBISs =
82.1039 - EVERY' [stac mor_def, rtac conjI,
82.1040 - CONJ_WRAP' (fn equiv_LSBIS =>
82.1041 - EVERY' [rtac ballI, rtac ssubst, rtac @{thm proj_in_iff}, rtac equiv_LSBIS, atac])
82.1042 - equiv_LSBISs,
82.1043 - CONJ_WRAP' (fn (equiv_LSBIS, congruent_str_final) =>
82.1044 - EVERY' [rtac ballI, rtac sym, rtac trans, rtac @{thm univ_commute}, rtac equiv_LSBIS,
82.1045 - rtac congruent_str_final, atac, rtac o_apply])
82.1046 - (equiv_LSBISs ~~ congruent_str_finals)] 1;
82.1047 -
82.1048 -fun mk_mor_Rep_tac m defs Reps Abs_inverses coalg_final_setss map_comp_ids map_congLs
82.1049 - {context = ctxt, prems = _} =
82.1050 - unfold_thms_tac ctxt defs THEN
82.1051 - EVERY' [rtac conjI,
82.1052 - CONJ_WRAP' (fn thm => rtac ballI THEN' rtac thm) Reps,
82.1053 - CONJ_WRAP' (fn (Rep, ((map_comp_id, map_congL), coalg_final_sets)) =>
82.1054 - EVERY' [rtac ballI, rtac (map_comp_id RS trans), rtac map_congL,
82.1055 - EVERY' (map2 (fn Abs_inverse => fn coalg_final_set =>
82.1056 - EVERY' [rtac ballI, rtac (o_apply RS trans), rtac Abs_inverse,
82.1057 - etac set_rev_mp, rtac coalg_final_set, rtac Rep])
82.1058 - Abs_inverses (drop m coalg_final_sets))])
82.1059 - (Reps ~~ ((map_comp_ids ~~ map_congLs) ~~ coalg_final_setss))] 1;
82.1060 -
82.1061 -fun mk_mor_Abs_tac defs Abs_inverses {context = ctxt, prems = _} =
82.1062 - unfold_thms_tac ctxt defs THEN
82.1063 - EVERY' [rtac conjI,
82.1064 - CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) Abs_inverses,
82.1065 - CONJ_WRAP' (fn thm => rtac ballI THEN' etac (thm RS arg_cong RS sym)) Abs_inverses] 1;
82.1066 -
82.1067 -fun mk_mor_unfold_tac m mor_UNIV dtor_defs unfold_defs Abs_inverses morEs map_comp_ids map_congs =
82.1068 - EVERY' [rtac iffD2, rtac mor_UNIV,
82.1069 - CONJ_WRAP' (fn ((Abs_inverse, morE), ((dtor_def, unfold_def), (map_comp_id, map_cong))) =>
82.1070 - EVERY' [rtac ext, rtac (o_apply RS trans RS sym), rtac (dtor_def RS trans),
82.1071 - rtac (unfold_def RS arg_cong RS trans), rtac (Abs_inverse RS arg_cong RS trans),
82.1072 - rtac (morE RS arg_cong RS trans), rtac (map_comp_id RS trans),
82.1073 - rtac (o_apply RS trans RS sym), rtac map_cong,
82.1074 - REPEAT_DETERM_N m o rtac refl,
82.1075 - EVERY' (map (fn thm => rtac (thm RS trans) THEN' rtac (o_apply RS sym)) unfold_defs)])
82.1076 - ((Abs_inverses ~~ morEs) ~~ ((dtor_defs ~~ unfold_defs) ~~ (map_comp_ids ~~ map_congs)))] 1;
82.1077 -
82.1078 -fun mk_raw_coind_tac bis_def bis_cong bis_O bis_converse bis_Gr tcoalg coalgT mor_T_final
82.1079 - sbis_lsbis lsbis_incls incl_lsbiss equiv_LSBISs mor_Rep Rep_injects =
82.1080 - let
82.1081 - val n = length Rep_injects;
82.1082 - in
82.1083 - EVERY' [rtac rev_mp, ftac (bis_def RS iffD1),
82.1084 - REPEAT_DETERM o etac conjE, rtac bis_cong, rtac bis_O, rtac bis_converse,
82.1085 - rtac bis_Gr, rtac tcoalg, rtac mor_Rep, rtac bis_O, atac, rtac bis_Gr, rtac tcoalg,
82.1086 - rtac mor_Rep, REPEAT_DETERM_N n o etac @{thm relImage_Gr},
82.1087 - rtac impI, rtac rev_mp, rtac bis_cong, rtac bis_O, rtac bis_Gr, rtac coalgT,
82.1088 - rtac mor_T_final, rtac bis_O, rtac sbis_lsbis, rtac bis_converse, rtac bis_Gr, rtac coalgT,
82.1089 - rtac mor_T_final, EVERY' (map (fn thm => rtac (thm RS @{thm relInvImage_Gr})) lsbis_incls),
82.1090 - rtac impI,
82.1091 - CONJ_WRAP' (fn (Rep_inject, (equiv_LSBIS , (incl_lsbis, lsbis_incl))) =>
82.1092 - EVERY' [rtac subset_trans, rtac @{thm relInvImage_UNIV_relImage}, rtac subset_trans,
82.1093 - rtac @{thm relInvImage_mono}, rtac subset_trans, etac incl_lsbis,
82.1094 - rtac ord_eq_le_trans, rtac @{thm sym[OF relImage_relInvImage]},
82.1095 - rtac @{thm xt1(3)}, rtac @{thm Sigma_cong},
82.1096 - rtac @{thm proj_image}, rtac @{thm proj_image}, rtac lsbis_incl,
82.1097 - rtac subset_trans, rtac @{thm relImage_mono}, rtac incl_lsbis, atac,
82.1098 - rtac @{thm relImage_proj}, rtac equiv_LSBIS, rtac @{thm relInvImage_diag},
82.1099 - rtac Rep_inject])
82.1100 - (Rep_injects ~~ (equiv_LSBISs ~~ (incl_lsbiss ~~ lsbis_incls)))] 1
82.1101 - end;
82.1102 -
82.1103 -fun mk_unique_mor_tac raw_coinds bis =
82.1104 - CONJ_WRAP' (fn raw_coind =>
82.1105 - EVERY' [rtac impI, rtac (bis RS raw_coind RS set_mp RS @{thm IdD}), atac,
82.1106 - etac conjunct1, atac, etac conjunct2, rtac @{thm image2_eqI}, rtac refl, rtac refl, atac])
82.1107 - raw_coinds 1;
82.1108 -
82.1109 -fun mk_unfold_unique_mor_tac raw_coinds bis mor unfold_defs =
82.1110 - CONJ_WRAP' (fn (raw_coind, unfold_def) =>
82.1111 - EVERY' [rtac ext, etac (bis RS raw_coind RS set_mp RS @{thm IdD}), rtac mor,
82.1112 - rtac @{thm image2_eqI}, rtac refl, rtac (unfold_def RS arg_cong RS trans),
82.1113 - rtac (o_apply RS sym), rtac UNIV_I]) (raw_coinds ~~ unfold_defs) 1;
82.1114 -
82.1115 -fun mk_dtor_o_ctor_tac ctor_def unfold map_comp_id map_congL unfold_o_dtors
82.1116 - {context = ctxt, prems = _} =
82.1117 - unfold_thms_tac ctxt [ctor_def] THEN EVERY' [rtac ext, rtac trans, rtac o_apply,
82.1118 - rtac trans, rtac unfold, rtac trans, rtac map_comp_id, rtac trans, rtac map_congL,
82.1119 - EVERY' (map (fn thm =>
82.1120 - rtac ballI THEN' rtac (trans OF [thm RS fun_cong, @{thm id_apply}])) unfold_o_dtors),
82.1121 - rtac sym, rtac @{thm id_apply}] 1;
82.1122 -
82.1123 -fun mk_corec_tac m corec_defs unfold map_cong corec_Inls {context = ctxt, prems = _} =
82.1124 - unfold_thms_tac ctxt corec_defs THEN EVERY' [rtac trans, rtac (o_apply RS arg_cong),
82.1125 - rtac trans, rtac unfold, fo_rtac (@{thm sum.cases(2)} RS arg_cong RS trans) ctxt, rtac map_cong,
82.1126 - REPEAT_DETERM_N m o rtac refl,
82.1127 - EVERY' (map (fn thm => rtac @{thm sum_case_expand_Inr} THEN' rtac thm) corec_Inls)] 1;
82.1128 -
82.1129 -fun mk_srel_coinduct_tac ks raw_coind bis_srel =
82.1130 - EVERY' [rtac rev_mp, rtac raw_coind, rtac ssubst, rtac bis_srel, rtac conjI,
82.1131 - CONJ_WRAP' (K (rtac @{thm ord_le_eq_trans[OF subset_UNIV UNIV_Times_UNIV[THEN sym]]})) ks,
82.1132 - CONJ_WRAP' (K (EVERY' [rtac allI, rtac allI, rtac impI,
82.1133 - REPEAT_DETERM o etac allE, etac mp, etac CollectE, etac @{thm splitD}])) ks,
82.1134 - rtac impI, REPEAT_DETERM o etac conjE,
82.1135 - CONJ_WRAP' (K (EVERY' [rtac impI, rtac @{thm IdD}, etac set_mp,
82.1136 - rtac CollectI, etac @{thm prod_caseI}])) ks] 1;
82.1137 -
82.1138 -fun mk_srel_strong_coinduct_tac m cTs cts srel_coinduct srel_monos srel_Ids =
82.1139 - EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts srel_coinduct),
82.1140 - EVERY' (map2 (fn srel_mono => fn srel_Id =>
82.1141 - EVERY' [REPEAT_DETERM o resolve_tac [allI, impI], REPEAT_DETERM o etac allE,
82.1142 - etac disjE, etac mp, atac, hyp_subst_tac, rtac (srel_mono RS set_mp),
82.1143 - REPEAT_DETERM_N m o rtac @{thm subset_refl},
82.1144 - REPEAT_DETERM_N (length srel_monos) o rtac @{thm Id_subset},
82.1145 - rtac (srel_Id RS equalityD2 RS set_mp), rtac @{thm IdI}])
82.1146 - srel_monos srel_Ids),
82.1147 - rtac impI, REPEAT_DETERM o etac conjE,
82.1148 - CONJ_WRAP' (K (rtac impI THEN' etac mp THEN' etac disjI1)) srel_Ids] 1;
82.1149 -
82.1150 -fun mk_dtor_coinduct_tac m ks raw_coind bis_def =
82.1151 - let
82.1152 - val n = length ks;
82.1153 - in
82.1154 - EVERY' [rtac rev_mp, rtac raw_coind, rtac ssubst, rtac bis_def, rtac conjI,
82.1155 - CONJ_WRAP' (K (rtac @{thm ord_le_eq_trans[OF subset_UNIV UNIV_Times_UNIV[THEN sym]]})) ks,
82.1156 - CONJ_WRAP' (fn i => EVERY' [select_prem_tac n (dtac asm_rl) i, REPEAT_DETERM o rtac allI,
82.1157 - rtac impI, REPEAT_DETERM o dtac @{thm meta_spec}, etac CollectE, etac @{thm meta_impE},
82.1158 - atac, etac exE, etac conjE, etac conjE, rtac bexI, rtac conjI,
82.1159 - etac @{thm fst_conv[THEN subst]}, etac @{thm snd_conv[THEN subst]},
82.1160 - rtac CollectI, REPEAT_DETERM_N m o (rtac conjI THEN' rtac subset_UNIV),
82.1161 - CONJ_WRAP' (fn i' => EVERY' [rtac subsetI, rtac CollectI, dtac (mk_conjunctN n i'),
82.1162 - REPEAT_DETERM o etac allE, etac mp, rtac @{thm ssubst_mem[OF pair_collapse]}, atac])
82.1163 - ks])
82.1164 - ks,
82.1165 - rtac impI,
82.1166 - CONJ_WRAP' (fn i => EVERY' [rtac impI, dtac (mk_conjunctN n i),
82.1167 - rtac @{thm subst[OF pair_in_Id_conv]}, etac set_mp,
82.1168 - rtac CollectI, etac (refl RSN (2, @{thm subst_Pair}))]) ks] 1
82.1169 - end;
82.1170 -
82.1171 -fun mk_dtor_strong_coinduct_tac ks cTs cts dtor_coinduct bis_def bis_diag =
82.1172 - EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts dtor_coinduct),
82.1173 - EVERY' (map (fn i =>
82.1174 - EVERY' [etac disjE, REPEAT_DETERM o dtac @{thm meta_spec}, etac @{thm meta_mp},
82.1175 - atac, rtac rev_mp, rtac subst, rtac bis_def, rtac bis_diag,
82.1176 - rtac impI, dtac conjunct2, dtac (mk_conjunctN (length ks) i), REPEAT_DETERM o etac allE,
82.1177 - etac impE, etac @{thm diag_UNIV_I}, REPEAT_DETERM o eresolve_tac [bexE, conjE, CollectE],
82.1178 - rtac exI, rtac conjI, etac conjI, atac,
82.1179 - CONJ_WRAP' (K (EVERY' [REPEAT_DETERM o resolve_tac [allI, impI],
82.1180 - rtac disjI2, rtac @{thm diagE}, etac set_mp, atac])) ks])
82.1181 - ks),
82.1182 - rtac impI, REPEAT_DETERM o etac conjE,
82.1183 - CONJ_WRAP' (K (rtac impI THEN' etac mp THEN' etac disjI1)) ks] 1;
82.1184 -
82.1185 -fun mk_map_tac m n cT unfold map_comp' map_cong =
82.1186 - EVERY' [rtac ext, rtac (o_apply RS trans RS sym), rtac (o_apply RS trans RS sym),
82.1187 - rtac (unfold RS trans), rtac (Thm.permute_prems 0 1 (map_comp' RS box_equals)), rtac map_cong,
82.1188 - REPEAT_DETERM_N m o rtac (@{thm id_o} RS fun_cong),
82.1189 - REPEAT_DETERM_N n o rtac (@{thm o_id} RS fun_cong),
82.1190 - rtac (o_apply RS (Drule.instantiate' [cT] [] arg_cong) RS sym)] 1;
82.1191 -
82.1192 -fun mk_set_le_tac n hset_minimal set_hsets set_hset_hsetss =
82.1193 - EVERY' [rtac hset_minimal,
82.1194 - REPEAT_DETERM_N n o rtac @{thm Un_upper1},
82.1195 - REPEAT_DETERM_N n o
82.1196 - EVERY' (map3 (fn i => fn set_hset => fn set_hset_hsets =>
82.1197 - EVERY' [rtac subsetI, rtac @{thm UnI2}, rtac (mk_UnIN n i), etac @{thm UN_I},
82.1198 - etac UnE, etac set_hset, REPEAT_DETERM_N (n - 1) o etac UnE,
82.1199 - EVERY' (map (fn thm => EVERY' [etac @{thm UN_E}, etac thm, atac]) set_hset_hsets)])
82.1200 - (1 upto n) set_hsets set_hset_hsetss)] 1;
82.1201 -
82.1202 -fun mk_set_simp_tac n set_le set_incl_hset set_hset_incl_hsets =
82.1203 - EVERY' [rtac equalityI, rtac set_le, rtac @{thm Un_least}, rtac set_incl_hset,
82.1204 - REPEAT_DETERM_N (n - 1) o rtac @{thm Un_least},
82.1205 - EVERY' (map (fn thm => rtac @{thm UN_least} THEN' etac thm) set_hset_incl_hsets)] 1;
82.1206 -
82.1207 -fun mk_map_id_tac maps unfold_unique unfold_dtor =
82.1208 - EVERY' [rtac (unfold_unique RS trans), EVERY' (map (fn thm => rtac (thm RS sym)) maps),
82.1209 - rtac unfold_dtor] 1;
82.1210 -
82.1211 -fun mk_map_comp_tac m n maps map_comps map_congs unfold_unique =
82.1212 - EVERY' [rtac unfold_unique,
82.1213 - EVERY' (map3 (fn map_thm => fn map_comp => fn map_cong =>
82.1214 - EVERY' (map rtac
82.1215 - ([@{thm o_assoc} RS trans,
82.1216 - @{thm arg_cong2[of _ _ _ _ "op o"]} OF [map_comp RS sym, refl] RS trans,
82.1217 - @{thm o_assoc} RS trans RS sym,
82.1218 - @{thm arg_cong2[of _ _ _ _ "op o"]} OF [map_thm, refl] RS trans,
82.1219 - @{thm o_assoc} RS sym RS trans, map_thm RS arg_cong RS trans, @{thm o_assoc} RS trans,
82.1220 - @{thm arg_cong2[of _ _ _ _ "op o"]} OF [map_comp RS sym, refl] RS trans,
82.1221 - ext, o_apply RS trans, o_apply RS trans RS sym, map_cong] @
82.1222 - replicate m (@{thm id_o} RS fun_cong) @
82.1223 - replicate n (@{thm o_id} RS fun_cong))))
82.1224 - maps map_comps map_congs)] 1;
82.1225 -
82.1226 -fun mk_mcong_tac m coinduct_tac map_comp's map_simps map_congs set_naturalss set_hsetss
82.1227 - set_hset_hsetsss =
82.1228 - let
82.1229 - val n = length map_comp's;
82.1230 - val ks = 1 upto n;
82.1231 - in
82.1232 - EVERY' ([rtac rev_mp,
82.1233 - coinduct_tac] @
82.1234 - maps (fn (((((map_comp'_trans, map_simps_trans), map_cong), set_naturals), set_hsets),
82.1235 - set_hset_hsetss) =>
82.1236 - [REPEAT_DETERM o eresolve_tac [exE, conjE], hyp_subst_tac, rtac exI, rtac conjI, rtac conjI,
82.1237 - rtac map_comp'_trans, rtac sym, rtac map_simps_trans, rtac map_cong,
82.1238 - REPEAT_DETERM_N m o (rtac o_apply_trans_sym THEN' rtac @{thm id_apply}),
82.1239 - REPEAT_DETERM_N n o rtac fst_convol_fun_cong_sym,
82.1240 - rtac map_comp'_trans, rtac sym, rtac map_simps_trans, rtac map_cong,
82.1241 - EVERY' (maps (fn set_hset =>
82.1242 - [rtac o_apply_trans_sym, rtac (@{thm id_apply} RS trans), etac CollectE,
82.1243 - REPEAT_DETERM o etac conjE, etac bspec, etac set_hset]) set_hsets),
82.1244 - REPEAT_DETERM_N n o rtac snd_convol_fun_cong_sym,
82.1245 - CONJ_WRAP' (fn (set_natural, set_hset_hsets) =>
82.1246 - EVERY' [REPEAT_DETERM o rtac allI, rtac impI, rtac @{thm image_convolD},
82.1247 - etac set_rev_mp, rtac ord_eq_le_trans, rtac set_natural,
82.1248 - rtac @{thm image_mono}, rtac subsetI, rtac CollectI, etac CollectE,
82.1249 - REPEAT_DETERM o etac conjE,
82.1250 - CONJ_WRAP' (fn set_hset_hset =>
82.1251 - EVERY' [rtac ballI, etac bspec, etac set_hset_hset, atac]) set_hset_hsets])
82.1252 - (drop m set_naturals ~~ set_hset_hsetss)])
82.1253 - (map (fn th => th RS trans) map_comp's ~~ map (fn th => th RS trans) map_simps ~~
82.1254 - map_congs ~~ set_naturalss ~~ set_hsetss ~~ set_hset_hsetsss) @
82.1255 - [rtac impI,
82.1256 - CONJ_WRAP' (fn k =>
82.1257 - EVERY' [rtac impI, dtac (mk_conjunctN n k), etac mp, rtac exI, rtac conjI, etac CollectI,
82.1258 - rtac conjI, rtac refl, rtac refl]) ks]) 1
82.1259 - end
82.1260 -
82.1261 -fun mk_map_unique_tac unfold_unique map_comps {context = ctxt, prems = _} =
82.1262 - rtac unfold_unique 1 THEN
82.1263 - unfold_thms_tac ctxt (map (fn thm => thm RS sym) map_comps @ @{thms o_assoc id_o o_id}) THEN
82.1264 - ALLGOALS (etac sym);
82.1265 -
82.1266 -fun mk_col_natural_tac cts rec_0s rec_Sucs map_simps set_naturalss
82.1267 - {context = ctxt, prems = _} =
82.1268 - let
82.1269 - val n = length map_simps;
82.1270 - in
82.1271 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.1272 - REPEAT_DETERM o rtac allI, SELECT_GOAL (unfold_thms_tac ctxt rec_0s),
82.1273 - CONJ_WRAP' (K (rtac @{thm image_empty})) rec_0s,
82.1274 - REPEAT_DETERM o rtac allI,
82.1275 - CONJ_WRAP' (fn (rec_Suc, (map_simp, set_nats)) => EVERY'
82.1276 - [SELECT_GOAL (unfold_thms_tac ctxt
82.1277 - (rec_Suc :: map_simp :: set_nats @ @{thms image_Un image_UN UN_simps(10)})),
82.1278 - rtac @{thm Un_cong}, rtac refl,
82.1279 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_cong}))
82.1280 - (fn i => EVERY' [rtac @{thm UN_cong[OF refl]},
82.1281 - REPEAT_DETERM o etac allE, etac (mk_conjunctN n i)]) (n downto 1)])
82.1282 - (rec_Sucs ~~ (map_simps ~~ set_naturalss))] 1
82.1283 - end;
82.1284 -
82.1285 -fun mk_set_natural_tac hset_def col_natural =
82.1286 - EVERY' (map rtac [ext, (o_apply RS trans), (hset_def RS trans), sym,
82.1287 - (o_apply RS trans), (@{thm image_cong} OF [hset_def, refl] RS trans),
82.1288 - (@{thm image_UN} RS trans), (refl RS @{thm UN_cong}), col_natural]) 1;
82.1289 -
82.1290 -fun mk_col_bd_tac m j cts rec_0s rec_Sucs sbd_Card_order sbd_Cinfinite set_sbdss =
82.1291 - let
82.1292 - val n = length rec_0s;
82.1293 - in
82.1294 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.1295 - REPEAT_DETERM o rtac allI,
82.1296 - CONJ_WRAP' (fn rec_0 => EVERY' (map rtac [ordIso_ordLeq_trans,
82.1297 - @{thm card_of_ordIso_subst}, rec_0, @{thm Card_order_empty}, sbd_Card_order])) rec_0s,
82.1298 - REPEAT_DETERM o rtac allI,
82.1299 - CONJ_WRAP' (fn (rec_Suc, set_sbds) => EVERY'
82.1300 - [rtac ordIso_ordLeq_trans, rtac @{thm card_of_ordIso_subst}, rtac rec_Suc,
82.1301 - rtac (sbd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})), rtac (nth set_sbds (j - 1)),
82.1302 - REPEAT_DETERM_N (n - 1) o rtac (sbd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})),
82.1303 - EVERY' (map2 (fn i => fn set_sbd => EVERY' [rtac @{thm UNION_Cinfinite_bound},
82.1304 - rtac set_sbd, rtac ballI, REPEAT_DETERM o etac allE,
82.1305 - etac (mk_conjunctN n i), rtac sbd_Cinfinite]) (1 upto n) (drop m set_sbds))])
82.1306 - (rec_Sucs ~~ set_sbdss)] 1
82.1307 - end;
82.1308 -
82.1309 -fun mk_set_bd_tac sbd_Cinfinite hset_def col_bd =
82.1310 - EVERY' (map rtac [ordIso_ordLeq_trans, @{thm card_of_ordIso_subst}, hset_def,
82.1311 - ctrans, @{thm UNION_Cinfinite_bound}, ordIso_ordLeq_trans, @{thm card_of_nat},
82.1312 - @{thm natLeq_ordLeq_cinfinite}, sbd_Cinfinite, ballI, col_bd, sbd_Cinfinite,
82.1313 - ctrans, @{thm infinite_ordLeq_cexp}, sbd_Cinfinite, @{thm cexp_ordLeq_ccexp}]) 1;
82.1314 -
82.1315 -fun mk_in_bd_tac isNode_hset isNode_hsets carT_def card_of_carT mor_image Rep_inverse mor_hsets
82.1316 - sbd_Cnotzero sbd_Card_order mor_Rep coalgT mor_T_final tcoalg =
82.1317 - let
82.1318 - val n = length isNode_hsets;
82.1319 - val in_hin_tac = rtac CollectI THEN'
82.1320 - CONJ_WRAP' (fn mor_hset => EVERY' (map etac
82.1321 - [mor_hset OF [coalgT, mor_T_final] RS sym RS ord_eq_le_trans,
82.1322 - arg_cong RS sym RS ord_eq_le_trans,
82.1323 - mor_hset OF [tcoalg, mor_Rep, UNIV_I] RS ord_eq_le_trans])) mor_hsets;
82.1324 - in
82.1325 - EVERY' [rtac (Thm.permute_prems 0 1 @{thm ordLeq_transitive}), rtac ctrans,
82.1326 - rtac @{thm card_of_image}, rtac ordIso_ordLeq_trans,
82.1327 - rtac @{thm card_of_ordIso_subst}, rtac @{thm sym[OF proj_image]}, rtac ctrans,
82.1328 - rtac @{thm card_of_image}, rtac ctrans, rtac card_of_carT, rtac @{thm cexp_mono2_Cnotzero},
82.1329 - rtac @{thm cexp_ordLeq_ccexp}, rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero},
82.1330 - rtac @{thm Cnotzero_cexp}, rtac sbd_Cnotzero, rtac sbd_Card_order,
82.1331 - rtac @{thm card_of_mono1}, rtac subsetI, rtac @{thm image_eqI}, rtac sym,
82.1332 - rtac Rep_inverse, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
82.1333 - rtac set_mp, rtac equalityD2, rtac @{thm sym[OF proj_image]}, rtac imageE,
82.1334 - rtac set_rev_mp, rtac mor_image, rtac mor_Rep, rtac UNIV_I, rtac equalityD2,
82.1335 - rtac @{thm proj_image}, rtac @{thm image_eqI}, atac,
82.1336 - ftac (carT_def RS equalityD1 RS set_mp),
82.1337 - REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac,
82.1338 - rtac (carT_def RS equalityD2 RS set_mp), rtac CollectI, REPEAT_DETERM o rtac exI,
82.1339 - rtac conjI, rtac refl, rtac conjI, etac conjI, etac conjI, etac conjI, rtac conjI,
82.1340 - rtac ballI, dtac bspec, atac, REPEAT_DETERM o etac conjE, rtac conjI,
82.1341 - CONJ_WRAP_GEN' (etac disjE) (fn (i, isNode_hset) =>
82.1342 - EVERY' [rtac (mk_disjIN n i), rtac isNode_hset, atac, atac, atac, in_hin_tac])
82.1343 - (1 upto n ~~ isNode_hsets),
82.1344 - CONJ_WRAP' (fn isNode_hset =>
82.1345 - EVERY' [rtac ballI, rtac isNode_hset, atac, ftac CollectD, etac @{thm SuccD},
82.1346 - etac bspec, atac, in_hin_tac])
82.1347 - isNode_hsets,
82.1348 - atac, rtac isNode_hset, atac, atac, atac, in_hin_tac] 1
82.1349 - end;
82.1350 -
82.1351 -fun mk_bd_card_order_tac sbd_card_order =
82.1352 - EVERY' (map rtac [@{thm card_order_ccexp}, sbd_card_order, sbd_card_order]) 1;
82.1353 -
82.1354 -fun mk_bd_cinfinite_tac sbd_Cinfinite =
82.1355 - EVERY' (map rtac [@{thm cinfinite_ccexp}, @{thm ctwo_ordLeq_Cinfinite},
82.1356 - sbd_Cinfinite, sbd_Cinfinite]) 1;
82.1357 -
82.1358 -fun mk_pickWP_assms_tac set_incl_hsets set_incl_hins map_eq =
82.1359 - let
82.1360 - val m = length set_incl_hsets;
82.1361 - in
82.1362 - EVERY' [REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
82.1363 - EVERY' (map (fn thm => rtac conjI THEN' etac (thm RS @{thm subset_trans})) set_incl_hsets),
82.1364 - CONJ_WRAP' (fn thm => rtac thm THEN' REPEAT_DETERM_N m o atac) set_incl_hins,
82.1365 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
82.1366 - EVERY' (map (fn thm => rtac conjI THEN' etac (thm RS @{thm subset_trans})) set_incl_hsets),
82.1367 - CONJ_WRAP' (fn thm => rtac thm THEN' REPEAT_DETERM_N m o atac) set_incl_hins,
82.1368 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], etac map_eq]
82.1369 - end;
82.1370 -
82.1371 -fun mk_coalg_thePull_tac m coalg_def map_wpulls set_naturalss pickWP_assms_tacs
82.1372 - {context = ctxt, prems = _} =
82.1373 - unfold_thms_tac ctxt [coalg_def] THEN
82.1374 - CONJ_WRAP' (fn (map_wpull, (pickWP_assms_tac, set_naturals)) =>
82.1375 - EVERY' [rtac ballI, dtac @{thm set_mp[OF equalityD1[OF thePull_def]]},
82.1376 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}],
82.1377 - hyp_subst_tac, rtac rev_mp, rtac (map_wpull RS @{thm pickWP(1)}),
82.1378 - EVERY' (map (etac o mk_conjunctN m) (1 upto m)),
82.1379 - pickWP_assms_tac,
82.1380 - SELECT_GOAL (unfold_thms_tac ctxt @{thms o_apply prod.cases}), rtac impI,
82.1381 - REPEAT_DETERM o eresolve_tac [CollectE, conjE],
82.1382 - rtac CollectI,
82.1383 - REPEAT_DETERM_N m o (rtac conjI THEN' rtac subset_UNIV),
82.1384 - CONJ_WRAP' (fn set_natural =>
82.1385 - EVERY' [rtac ord_eq_le_trans, rtac trans, rtac set_natural,
82.1386 - rtac trans_fun_cong_image_id_id_apply, atac])
82.1387 - (drop m set_naturals)])
82.1388 - (map_wpulls ~~ (pickWP_assms_tacs ~~ set_naturalss)) 1;
82.1389 -
82.1390 -fun mk_mor_thePull_nth_tac conv pick m mor_def map_wpulls map_comps pickWP_assms_tacs
82.1391 - {context = ctxt, prems = _} =
82.1392 - let
82.1393 - val n = length map_comps;
82.1394 - in
82.1395 - unfold_thms_tac ctxt [mor_def] THEN
82.1396 - EVERY' [rtac conjI,
82.1397 - CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) (1 upto n),
82.1398 - CONJ_WRAP' (fn (map_wpull, (pickWP_assms_tac, map_comp)) =>
82.1399 - EVERY' [rtac ballI, dtac @{thm set_mp[OF equalityD1[OF thePull_def]]},
82.1400 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}, conjE],
82.1401 - hyp_subst_tac,
82.1402 - SELECT_GOAL (unfold_thms_tac ctxt @{thms o_apply prod.cases}),
82.1403 - rtac (map_comp RS trans),
82.1404 - SELECT_GOAL (unfold_thms_tac ctxt (conv :: @{thms o_id id_o})),
82.1405 - rtac (map_wpull RS pick), REPEAT_DETERM_N m o atac,
82.1406 - pickWP_assms_tac])
82.1407 - (map_wpulls ~~ (pickWP_assms_tacs ~~ map_comps))] 1
82.1408 - end;
82.1409 -
82.1410 -val mk_mor_thePull_fst_tac = mk_mor_thePull_nth_tac @{thm fst_conv} @{thm pickWP(2)};
82.1411 -val mk_mor_thePull_snd_tac = mk_mor_thePull_nth_tac @{thm snd_conv} @{thm pickWP(3)};
82.1412 -
82.1413 -fun mk_mor_thePull_pick_tac mor_def unfolds map_comps {context = ctxt, prems = _} =
82.1414 - unfold_thms_tac ctxt [mor_def, @{thm thePull_def}] THEN rtac conjI 1 THEN
82.1415 - CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) unfolds 1 THEN
82.1416 - CONJ_WRAP' (fn (unfold, map_comp) =>
82.1417 - EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}, conjE],
82.1418 - hyp_subst_tac,
82.1419 - SELECT_GOAL (unfold_thms_tac ctxt (unfold :: map_comp :: @{thms comp_def id_def})),
82.1420 - rtac refl])
82.1421 - (unfolds ~~ map_comps) 1;
82.1422 -
82.1423 -fun mk_pick_col_tac m j cts rec_0s rec_Sucs unfolds set_naturalss map_wpulls pickWP_assms_tacs
82.1424 - {context = ctxt, prems = _} =
82.1425 - let
82.1426 - val n = length rec_0s;
82.1427 - val ks = n downto 1;
82.1428 - in
82.1429 - EVERY' [rtac (Drule.instantiate' [] cts nat_induct),
82.1430 - REPEAT_DETERM o rtac allI,
82.1431 - CONJ_WRAP' (fn thm => EVERY'
82.1432 - [rtac impI, rtac ord_eq_le_trans, rtac thm, rtac @{thm empty_subsetI}]) rec_0s,
82.1433 - REPEAT_DETERM o rtac allI,
82.1434 - CONJ_WRAP' (fn (rec_Suc, ((unfold, set_naturals), (map_wpull, pickWP_assms_tac))) =>
82.1435 - EVERY' [rtac impI, dtac @{thm set_mp[OF equalityD1[OF thePull_def]]},
82.1436 - REPEAT_DETERM o eresolve_tac [CollectE, @{thm prod_caseE}],
82.1437 - hyp_subst_tac, rtac rev_mp, rtac (map_wpull RS @{thm pickWP(1)}),
82.1438 - EVERY' (map (etac o mk_conjunctN m) (1 upto m)),
82.1439 - pickWP_assms_tac,
82.1440 - rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
82.1441 - rtac ord_eq_le_trans, rtac rec_Suc,
82.1442 - rtac @{thm Un_least},
82.1443 - SELECT_GOAL (unfold_thms_tac ctxt [unfold, nth set_naturals (j - 1),
82.1444 - @{thm prod.cases}]),
82.1445 - etac ord_eq_le_trans_trans_fun_cong_image_id_id_apply,
82.1446 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least})) (fn (i, set_natural) =>
82.1447 - EVERY' [rtac @{thm UN_least},
82.1448 - SELECT_GOAL (unfold_thms_tac ctxt [unfold, set_natural, @{thm prod.cases}]),
82.1449 - etac imageE, hyp_subst_tac, REPEAT_DETERM o etac allE,
82.1450 - dtac (mk_conjunctN n i), etac mp, etac set_mp, atac])
82.1451 - (ks ~~ rev (drop m set_naturals))])
82.1452 - (rec_Sucs ~~ ((unfolds ~~ set_naturalss) ~~ (map_wpulls ~~ pickWP_assms_tacs)))] 1
82.1453 - end;
82.1454 -
82.1455 -fun mk_wpull_tac m coalg_thePull mor_thePull_fst mor_thePull_snd mor_thePull_pick
82.1456 - mor_unique pick_cols hset_defs =
82.1457 - EVERY' [rtac (@{thm wpull_def} RS iffD2), REPEAT_DETERM o rtac allI, rtac impI,
82.1458 - REPEAT_DETERM o etac conjE, rtac bexI, rtac conjI,
82.1459 - rtac box_equals, rtac mor_unique,
82.1460 - rtac coalg_thePull, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1461 - rtac mor_thePull_pick, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1462 - rtac mor_thePull_fst, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1463 - rtac @{thm set_mp[OF equalityD2[OF thePull_def]]}, rtac CollectI,
82.1464 - rtac @{thm prod_caseI}, etac conjI, etac conjI, atac, rtac o_apply, rtac @{thm fst_conv},
82.1465 - rtac box_equals, rtac mor_unique,
82.1466 - rtac coalg_thePull, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1467 - rtac mor_thePull_pick, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1468 - rtac mor_thePull_snd, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1469 - rtac @{thm set_mp[OF equalityD2[OF thePull_def]]}, rtac CollectI,
82.1470 - rtac @{thm prod_caseI}, etac conjI, etac conjI, atac, rtac o_apply, rtac @{thm snd_conv},
82.1471 - rtac CollectI,
82.1472 - CONJ_WRAP' (fn (pick, def) =>
82.1473 - EVERY' [rtac (def RS ord_eq_le_trans), rtac @{thm UN_least},
82.1474 - rtac pick, REPEAT_DETERM_N (m - 1) o etac conjI, atac,
82.1475 - rtac @{thm set_mp[OF equalityD2[OF thePull_def]]}, rtac CollectI,
82.1476 - rtac @{thm prod_caseI}, etac conjI, etac conjI, atac])
82.1477 - (pick_cols ~~ hset_defs)] 1;
82.1478 -
82.1479 -fun mk_wit_tac n dtor_ctors set_simp wit coind_wits {context = ctxt, prems = _} =
82.1480 - ALLGOALS (TRY o (eresolve_tac coind_wits THEN' rtac refl)) THEN
82.1481 - REPEAT_DETERM (atac 1 ORELSE
82.1482 - EVERY' [dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
82.1483 - K (unfold_thms_tac ctxt dtor_ctors),
82.1484 - REPEAT_DETERM_N n o etac UnE,
82.1485 - REPEAT_DETERM o
82.1486 - (TRY o REPEAT_DETERM o etac UnE THEN' TRY o etac @{thm UN_E} THEN'
82.1487 - (eresolve_tac wit ORELSE'
82.1488 - (dresolve_tac wit THEN'
82.1489 - (etac FalseE ORELSE'
82.1490 - EVERY' [hyp_subst_tac, dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
82.1491 - K (unfold_thms_tac ctxt dtor_ctors), REPEAT_DETERM_N n o etac UnE]))))] 1);
82.1492 -
82.1493 -fun mk_coind_wit_tac induct unfolds set_nats wits {context = ctxt, prems = _} =
82.1494 - rtac induct 1 THEN ALLGOALS (TRY o rtac impI THEN' TRY o hyp_subst_tac) THEN
82.1495 - unfold_thms_tac ctxt (unfolds @ set_nats @ @{thms image_id id_apply}) THEN
82.1496 - ALLGOALS (REPEAT_DETERM o etac imageE THEN' TRY o hyp_subst_tac) THEN
82.1497 - ALLGOALS (TRY o
82.1498 - FIRST' [rtac TrueI, rtac refl, etac (refl RSN (2, mp)), dresolve_tac wits THEN' etac FalseE])
82.1499 -
82.1500 -fun mk_srel_simp_tac in_Jsrels i in_srel map_comp map_cong map_simp set_simps dtor_inject dtor_ctor
82.1501 - set_naturals set_incls set_set_inclss =
82.1502 - let
82.1503 - val m = length set_incls;
82.1504 - val n = length set_set_inclss;
82.1505 - val (passive_set_naturals, active_set_naturals) = chop m set_naturals;
82.1506 - val in_Jsrel = nth in_Jsrels (i - 1);
82.1507 - val if_tac =
82.1508 - EVERY' [dtac (in_Jsrel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
82.1509 - rtac (in_srel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
82.1510 - EVERY' (map2 (fn set_natural => fn set_incl =>
82.1511 - EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac set_natural,
82.1512 - rtac ord_eq_le_trans, rtac trans_fun_cong_image_id_id_apply,
82.1513 - etac (set_incl RS @{thm subset_trans})])
82.1514 - passive_set_naturals set_incls),
82.1515 - CONJ_WRAP' (fn (in_Jsrel, (set_natural, set_set_incls)) =>
82.1516 - EVERY' [rtac ord_eq_le_trans, rtac set_natural, rtac @{thm image_subsetI},
82.1517 - rtac (in_Jsrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
82.1518 - CONJ_WRAP' (fn thm => etac (thm RS @{thm subset_trans}) THEN' atac) set_set_incls,
82.1519 - rtac conjI, rtac refl, rtac refl])
82.1520 - (in_Jsrels ~~ (active_set_naturals ~~ set_set_inclss)),
82.1521 - CONJ_WRAP' (fn conv =>
82.1522 - EVERY' [rtac trans, rtac map_comp, rtac trans, rtac map_cong,
82.1523 - REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
82.1524 - REPEAT_DETERM_N n o EVERY' (map rtac [trans, o_apply, conv]),
82.1525 - rtac trans, rtac sym, rtac map_simp, rtac (dtor_inject RS iffD2), atac])
82.1526 - @{thms fst_conv snd_conv}];
82.1527 - val only_if_tac =
82.1528 - EVERY' [dtac (in_srel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
82.1529 - rtac (in_Jsrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
82.1530 - CONJ_WRAP' (fn (set_simp, passive_set_natural) =>
82.1531 - EVERY' [rtac ord_eq_le_trans, rtac set_simp, rtac @{thm Un_least},
82.1532 - rtac ord_eq_le_trans, rtac box_equals, rtac passive_set_natural,
82.1533 - rtac (dtor_ctor RS sym RS arg_cong), rtac trans_fun_cong_image_id_id_apply, atac,
82.1534 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
82.1535 - (fn (active_set_natural, in_Jsrel) => EVERY' [rtac ord_eq_le_trans,
82.1536 - rtac @{thm UN_cong[OF _ refl]}, rtac @{thm box_equals[OF _ _ refl]},
82.1537 - rtac active_set_natural, rtac (dtor_ctor RS sym RS arg_cong), rtac @{thm UN_least},
82.1538 - dtac set_rev_mp, etac @{thm image_mono}, etac imageE,
82.1539 - dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Jsrel RS iffD1),
82.1540 - dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE,
82.1541 - dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac,
82.1542 - hyp_subst_tac, REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac])
82.1543 - (rev (active_set_naturals ~~ in_Jsrels))])
82.1544 - (set_simps ~~ passive_set_naturals),
82.1545 - rtac conjI,
82.1546 - REPEAT_DETERM_N 2 o EVERY'[rtac (dtor_inject RS iffD1), rtac trans, rtac map_simp,
82.1547 - rtac box_equals, rtac map_comp, rtac (dtor_ctor RS sym RS arg_cong), rtac trans,
82.1548 - rtac map_cong, REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
82.1549 - EVERY' (map (fn in_Jsrel => EVERY' [rtac trans, rtac o_apply, dtac set_rev_mp, atac,
82.1550 - dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Jsrel RS iffD1),
82.1551 - dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, atac]) in_Jsrels),
82.1552 - atac]]
82.1553 - in
82.1554 - EVERY' [rtac iffI, if_tac, only_if_tac] 1
82.1555 - end;
82.1556 -
82.1557 -end;
83.1 --- a/src/HOL/Codatatype/Tools/bnf_gfp_util.ML Fri Sep 21 16:34:40 2012 +0200
83.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
83.3 @@ -1,197 +0,0 @@
83.4 -(* Title: HOL/BNF/Tools/bnf_gfp_util.ML
83.5 - Author: Dmitriy Traytel, TU Muenchen
83.6 - Copyright 2012
83.7 -
83.8 -Library for the codatatype construction.
83.9 -*)
83.10 -
83.11 -signature BNF_GFP_UTIL =
83.12 -sig
83.13 - val mk_rec_simps: int -> thm -> thm list -> thm list list
83.14 -
83.15 - val dest_listT: typ -> typ
83.16 -
83.17 - val mk_Cons: term -> term -> term
83.18 - val mk_Shift: term -> term -> term
83.19 - val mk_Succ: term -> term -> term
83.20 - val mk_Times: term * term -> term
83.21 - val mk_append: term * term -> term
83.22 - val mk_congruent: term -> term -> term
83.23 - val mk_clists: term -> term
83.24 - val mk_diag: term -> term
83.25 - val mk_equiv: term -> term -> term
83.26 - val mk_fromCard: term -> term -> term
83.27 - val mk_list_rec: term -> term -> term
83.28 - val mk_nat_rec: term -> term -> term
83.29 - val mk_pickWP: term -> term -> term -> term -> term -> term
83.30 - val mk_prefCl: term -> term
83.31 - val mk_proj: term -> term
83.32 - val mk_quotient: term -> term -> term
83.33 - val mk_shift: term -> term -> term
83.34 - val mk_size: term -> term
83.35 - val mk_thePull: term -> term -> term -> term -> term
83.36 - val mk_toCard: term -> term -> term
83.37 - val mk_undefined: typ -> term
83.38 - val mk_univ: term -> term
83.39 -
83.40 - val mk_specN: int -> thm -> thm
83.41 -
83.42 - val mk_InN_Field: int -> int -> thm
83.43 - val mk_InN_inject: int -> int -> thm
83.44 - val mk_InN_not_InM: int -> int -> thm
83.45 -end;
83.46 -
83.47 -structure BNF_GFP_Util : BNF_GFP_UTIL =
83.48 -struct
83.49 -
83.50 -open BNF_Util
83.51 -
83.52 -val mk_append = HOLogic.mk_binop @{const_name append};
83.53 -
83.54 -fun mk_equiv B R =
83.55 - Const (@{const_name equiv}, fastype_of B --> fastype_of R --> HOLogic.boolT) $ B $ R;
83.56 -
83.57 -fun mk_Sigma (A, B) =
83.58 - let
83.59 - val AT = fastype_of A;
83.60 - val BT = fastype_of B;
83.61 - val ABT = mk_relT (HOLogic.dest_setT AT, HOLogic.dest_setT (range_type BT));
83.62 - in Const (@{const_name Sigma}, AT --> BT --> ABT) $ A $ B end;
83.63 -
83.64 -fun mk_diag A =
83.65 - let
83.66 - val AT = fastype_of A;
83.67 - val AAT = mk_relT (HOLogic.dest_setT AT, HOLogic.dest_setT AT);
83.68 - in Const (@{const_name diag}, AT --> AAT) $ A end;
83.69 -
83.70 -fun mk_Times (A, B) =
83.71 - let val AT = HOLogic.dest_setT (fastype_of A);
83.72 - in mk_Sigma (A, Term.absdummy AT B) end;
83.73 -
83.74 -fun dest_listT (Type (@{type_name list}, [T])) = T
83.75 - | dest_listT T = raise TYPE ("dest_setT: set type expected", [T], []);
83.76 -
83.77 -fun mk_Succ Kl kl =
83.78 - let val T = fastype_of kl;
83.79 - in
83.80 - Const (@{const_name Succ},
83.81 - HOLogic.mk_setT T --> T --> HOLogic.mk_setT (dest_listT T)) $ Kl $ kl
83.82 - end;
83.83 -
83.84 -fun mk_Shift Kl k =
83.85 - let val T = fastype_of Kl;
83.86 - in
83.87 - Const (@{const_name Shift}, T --> dest_listT (HOLogic.dest_setT T) --> T) $ Kl $ k
83.88 - end;
83.89 -
83.90 -fun mk_shift lab k =
83.91 - let val T = fastype_of lab;
83.92 - in
83.93 - Const (@{const_name shift}, T --> dest_listT (Term.domain_type T) --> T) $ lab $ k
83.94 - end;
83.95 -
83.96 -fun mk_prefCl A =
83.97 - Const (@{const_name prefCl}, fastype_of A --> HOLogic.boolT) $ A;
83.98 -
83.99 -fun mk_clists r =
83.100 - let val T = fastype_of r;
83.101 - in Const (@{const_name clists}, T --> mk_relT (`I (HOLogic.listT (fst (dest_relT T))))) $ r end;
83.102 -
83.103 -fun mk_toCard A r =
83.104 - let
83.105 - val AT = fastype_of A;
83.106 - val rT = fastype_of r;
83.107 - in
83.108 - Const (@{const_name toCard},
83.109 - AT --> rT --> HOLogic.dest_setT AT --> fst (dest_relT rT)) $ A $ r
83.110 - end;
83.111 -
83.112 -fun mk_fromCard A r =
83.113 - let
83.114 - val AT = fastype_of A;
83.115 - val rT = fastype_of r;
83.116 - in
83.117 - Const (@{const_name fromCard},
83.118 - AT --> rT --> fst (dest_relT rT) --> HOLogic.dest_setT AT) $ A $ r
83.119 - end;
83.120 -
83.121 -fun mk_Cons x xs =
83.122 - let val T = fastype_of xs;
83.123 - in Const (@{const_name Cons}, dest_listT T --> T --> T) $ x $ xs end;
83.124 -
83.125 -fun mk_size t = HOLogic.size_const (fastype_of t) $ t;
83.126 -
83.127 -fun mk_quotient A R =
83.128 - let val T = fastype_of A;
83.129 - in Const (@{const_name quotient}, T --> fastype_of R --> HOLogic.mk_setT T) $ A $ R end;
83.130 -
83.131 -fun mk_proj R =
83.132 - let val ((AT, BT), T) = `dest_relT (fastype_of R);
83.133 - in Const (@{const_name proj}, T --> AT --> HOLogic.mk_setT BT) $ R end;
83.134 -
83.135 -fun mk_univ f =
83.136 - let val ((AT, BT), T) = `dest_funT (fastype_of f);
83.137 - in Const (@{const_name univ}, T --> HOLogic.mk_setT AT --> BT) $ f end;
83.138 -
83.139 -fun mk_congruent R f =
83.140 - Const (@{const_name congruent}, fastype_of R --> fastype_of f --> HOLogic.boolT) $ R $ f;
83.141 -
83.142 -fun mk_undefined T = Const (@{const_name undefined}, T);
83.143 -
83.144 -fun mk_nat_rec Zero Suc =
83.145 - let val T = fastype_of Zero;
83.146 - in Const (@{const_name nat_rec}, T --> fastype_of Suc --> HOLogic.natT --> T) $ Zero $ Suc end;
83.147 -
83.148 -fun mk_list_rec Nil Cons =
83.149 - let
83.150 - val T = fastype_of Nil;
83.151 - val (U, consT) = `(Term.domain_type) (fastype_of Cons);
83.152 - in
83.153 - Const (@{const_name list_rec}, T --> consT --> HOLogic.listT U --> T) $ Nil $ Cons
83.154 - end;
83.155 -
83.156 -fun mk_thePull B1 B2 f1 f2 =
83.157 - let
83.158 - val fT1 = fastype_of f1;
83.159 - val fT2 = fastype_of f2;
83.160 - val BT1 = domain_type fT1;
83.161 - val BT2 = domain_type fT2;
83.162 - in
83.163 - Const (@{const_name thePull}, HOLogic.mk_setT BT1 --> HOLogic.mk_setT BT2 --> fT1 --> fT2 -->
83.164 - mk_relT (BT1, BT2)) $ B1 $ B2 $ f1 $ f2
83.165 - end;
83.166 -
83.167 -fun mk_pickWP A f1 f2 b1 b2 =
83.168 - let
83.169 - val fT1 = fastype_of f1;
83.170 - val fT2 = fastype_of f2;
83.171 - val AT = domain_type fT1;
83.172 - val BT1 = range_type fT1;
83.173 - val BT2 = range_type fT2;
83.174 - in
83.175 - Const (@{const_name pickWP}, HOLogic.mk_setT AT --> fT1 --> fT2 --> BT1 --> BT2 --> AT) $
83.176 - A $ f1 $ f2 $ b1 $ b2
83.177 - end;
83.178 -
83.179 -fun mk_InN_not_InM 1 _ = @{thm Inl_not_Inr}
83.180 - | mk_InN_not_InM n m =
83.181 - if n > m then mk_InN_not_InM m n RS @{thm not_sym}
83.182 - else mk_InN_not_InM (n - 1) (m - 1) RS @{thm not_arg_cong_Inr};
83.183 -
83.184 -fun mk_InN_Field 1 1 = @{thm TrueE[OF TrueI]}
83.185 - | mk_InN_Field _ 1 = @{thm Inl_Field_csum}
83.186 - | mk_InN_Field 2 2 = @{thm Inr_Field_csum}
83.187 - | mk_InN_Field n m = mk_InN_Field (n - 1) (m - 1) RS @{thm Inr_Field_csum};
83.188 -
83.189 -fun mk_InN_inject 1 _ = @{thm TrueE[OF TrueI]}
83.190 - | mk_InN_inject _ 1 = @{thm Inl_inject}
83.191 - | mk_InN_inject 2 2 = @{thm Inr_inject}
83.192 - | mk_InN_inject n m = @{thm Inr_inject} RS mk_InN_inject (n - 1) (m - 1);
83.193 -
83.194 -fun mk_specN 0 thm = thm
83.195 - | mk_specN n thm = mk_specN (n - 1) (thm RS spec);
83.196 -
83.197 -fun mk_rec_simps n rec_thm defs = map (fn i =>
83.198 - map (fn def => def RS rec_thm RS mk_nthI n i RS fun_cong) defs) (1 upto n);
83.199 -
83.200 -end;
84.1 --- a/src/HOL/Codatatype/Tools/bnf_lfp.ML Fri Sep 21 16:34:40 2012 +0200
84.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
84.3 @@ -1,1838 +0,0 @@
84.4 -(* Title: HOL/BNF/Tools/bnf_lfp.ML
84.5 - Author: Dmitriy Traytel, TU Muenchen
84.6 - Author: Andrei Popescu, TU Muenchen
84.7 - Copyright 2012
84.8 -
84.9 -Datatype construction.
84.10 -*)
84.11 -
84.12 -signature BNF_LFP =
84.13 -sig
84.14 - val bnf_lfp: mixfix list -> (string * sort) list option -> binding list ->
84.15 - typ list * typ list list -> BNF_Def.BNF list -> local_theory ->
84.16 - (term list * term list * term list * term list * thm * thm list * thm list * thm list *
84.17 - thm list * thm list) * local_theory
84.18 -end;
84.19 -
84.20 -structure BNF_LFP : BNF_LFP =
84.21 -struct
84.22 -
84.23 -open BNF_Def
84.24 -open BNF_Util
84.25 -open BNF_Tactics
84.26 -open BNF_FP
84.27 -open BNF_FP_Sugar
84.28 -open BNF_LFP_Util
84.29 -open BNF_LFP_Tactics
84.30 -
84.31 -(*all BNFs have the same lives*)
84.32 -fun bnf_lfp mixfixes resBs bs (resDs, Dss) bnfs lthy =
84.33 - let
84.34 - val timer = time (Timer.startRealTimer ());
84.35 - val live = live_of_bnf (hd bnfs);
84.36 - val n = length bnfs; (*active*)
84.37 - val ks = 1 upto n;
84.38 - val m = live - n; (*passive, if 0 don't generate a new BNF*)
84.39 - val b = Binding.name (mk_common_name (map Binding.name_of bs));
84.40 -
84.41 - (* TODO: check if m, n, etc., are sane *)
84.42 -
84.43 - val deads = fold (union (op =)) Dss resDs;
84.44 - val names_lthy = fold Variable.declare_typ deads lthy;
84.45 -
84.46 - (* tvars *)
84.47 - val (((((((passiveAs, activeAs), allAs)), (passiveBs, activeBs)),
84.48 - activeCs), passiveXs), passiveYs) = names_lthy
84.49 - |> mk_TFrees live
84.50 - |> apfst (`(chop m))
84.51 - ||> mk_TFrees live
84.52 - ||>> apfst (chop m)
84.53 - ||>> mk_TFrees n
84.54 - ||>> mk_TFrees m
84.55 - ||> fst o mk_TFrees m;
84.56 -
84.57 - val Ass = replicate n allAs;
84.58 - val allBs = passiveAs @ activeBs;
84.59 - val Bss = replicate n allBs;
84.60 - val allCs = passiveAs @ activeCs;
84.61 - val allCs' = passiveBs @ activeCs;
84.62 - val Css' = replicate n allCs';
84.63 -
84.64 - (* typs *)
84.65 - val dead_poss =
84.66 - (case resBs of
84.67 - NONE => map SOME deads @ replicate m NONE
84.68 - | SOME Ts => map (fn T => if member (op =) deads (TFree T) then SOME (TFree T) else NONE) Ts);
84.69 - fun mk_param NONE passive = (hd passive, tl passive)
84.70 - | mk_param (SOME a) passive = (a, passive);
84.71 - val mk_params = fold_map mk_param dead_poss #> fst;
84.72 -
84.73 - fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
84.74 - val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
84.75 - val FTsAs = mk_FTs allAs;
84.76 - val FTsBs = mk_FTs allBs;
84.77 - val FTsCs = mk_FTs allCs;
84.78 - val ATs = map HOLogic.mk_setT passiveAs;
84.79 - val BTs = map HOLogic.mk_setT activeAs;
84.80 - val B'Ts = map HOLogic.mk_setT activeBs;
84.81 - val B''Ts = map HOLogic.mk_setT activeCs;
84.82 - val sTs = map2 (curry (op -->)) FTsAs activeAs;
84.83 - val s'Ts = map2 (curry (op -->)) FTsBs activeBs;
84.84 - val s''Ts = map2 (curry (op -->)) FTsCs activeCs;
84.85 - val fTs = map2 (curry (op -->)) activeAs activeBs;
84.86 - val inv_fTs = map2 (curry (op -->)) activeBs activeAs;
84.87 - val self_fTs = map2 (curry (op -->)) activeAs activeAs;
84.88 - val gTs = map2 (curry (op -->)) activeBs activeCs;
84.89 - val all_gTs = map2 (curry (op -->)) allBs allCs';
84.90 - val prodBsAs = map2 (curry HOLogic.mk_prodT) activeBs activeAs;
84.91 - val prodFTs = mk_FTs (passiveAs @ prodBsAs);
84.92 - val prod_sTs = map2 (curry (op -->)) prodFTs activeAs;
84.93 -
84.94 - (* terms *)
84.95 - val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
84.96 - val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
84.97 - val mapsBsAs = map4 mk_map_of_bnf Dss Bss Ass bnfs;
84.98 - val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
84.99 - val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
84.100 - val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ prodBsAs)) Bss bnfs;
84.101 - val map_fsts_rev = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ prodBsAs)) bnfs;
84.102 - fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
84.103 - (map (replicate live) (replicate n Ts)) bnfs;
84.104 - val setssAs = mk_setss allAs;
84.105 - val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
84.106 - val witss = map wits_of_bnf bnfs;
84.107 -
84.108 - val (((((((((((((((((((zs, zs'), As), Bs), Bs_copy), B's), B''s), ss), prod_ss), s's), s''s),
84.109 - fs), fs_copy), inv_fs), self_fs), gs), all_gs), (xFs, xFs')), (yFs, yFs')),
84.110 - names_lthy) = lthy
84.111 - |> mk_Frees' "z" activeAs
84.112 - ||>> mk_Frees "A" ATs
84.113 - ||>> mk_Frees "B" BTs
84.114 - ||>> mk_Frees "B" BTs
84.115 - ||>> mk_Frees "B'" B'Ts
84.116 - ||>> mk_Frees "B''" B''Ts
84.117 - ||>> mk_Frees "s" sTs
84.118 - ||>> mk_Frees "prods" prod_sTs
84.119 - ||>> mk_Frees "s'" s'Ts
84.120 - ||>> mk_Frees "s''" s''Ts
84.121 - ||>> mk_Frees "f" fTs
84.122 - ||>> mk_Frees "f" fTs
84.123 - ||>> mk_Frees "f" inv_fTs
84.124 - ||>> mk_Frees "f" self_fTs
84.125 - ||>> mk_Frees "g" gTs
84.126 - ||>> mk_Frees "g" all_gTs
84.127 - ||>> mk_Frees' "x" FTsAs
84.128 - ||>> mk_Frees' "y" FTsBs;
84.129 -
84.130 - val passive_UNIVs = map HOLogic.mk_UNIV passiveAs;
84.131 - val active_UNIVs = map HOLogic.mk_UNIV activeAs;
84.132 - val prod_UNIVs = map HOLogic.mk_UNIV prodBsAs;
84.133 - val passive_ids = map HOLogic.id_const passiveAs;
84.134 - val active_ids = map HOLogic.id_const activeAs;
84.135 - val fsts = map fst_const prodBsAs;
84.136 -
84.137 - (* thms *)
84.138 - val bd_card_orders = map bd_card_order_of_bnf bnfs;
84.139 - val bd_Card_orders = map bd_Card_order_of_bnf bnfs;
84.140 - val bd_Card_order = hd bd_Card_orders;
84.141 - val bd_Cinfinite = bd_Cinfinite_of_bnf (hd bnfs);
84.142 - val bd_Cnotzeros = map bd_Cnotzero_of_bnf bnfs;
84.143 - val bd_Cnotzero = hd bd_Cnotzeros;
84.144 - val in_bds = map in_bd_of_bnf bnfs;
84.145 - val map_comp's = map map_comp'_of_bnf bnfs;
84.146 - val map_congs = map map_cong_of_bnf bnfs;
84.147 - val map_ids = map map_id_of_bnf bnfs;
84.148 - val map_id's = map map_id'_of_bnf bnfs;
84.149 - val map_wpulls = map map_wpull_of_bnf bnfs;
84.150 - val set_bdss = map set_bd_of_bnf bnfs;
84.151 - val set_natural'ss = map set_natural'_of_bnf bnfs;
84.152 -
84.153 - val timer = time (timer "Extracted terms & thms");
84.154 -
84.155 - (* nonemptiness check *)
84.156 - fun new_wit X wit = subset (op =) (#I wit, (0 upto m - 1) @ map snd X);
84.157 -
84.158 - val all = m upto m + n - 1;
84.159 -
84.160 - fun enrich X = map_filter (fn i =>
84.161 - (case find_first (fn (_, i') => i = i') X of
84.162 - NONE =>
84.163 - (case find_index (new_wit X) (nth witss (i - m)) of
84.164 - ~1 => NONE
84.165 - | j => SOME (j, i))
84.166 - | SOME ji => SOME ji)) all;
84.167 - val reachable = fixpoint (op =) enrich [];
84.168 - val _ = (case subtract (op =) (map snd reachable) all of
84.169 - [] => ()
84.170 - | i :: _ => error ("Cannot define empty datatype " ^ quote (Binding.name_of (nth bs (i - m)))));
84.171 -
84.172 - val wit_thms = flat (map2 (fn bnf => fn (j, _) => nth (wit_thmss_of_bnf bnf) j) bnfs reachable);
84.173 -
84.174 - val timer = time (timer "Checked nonemptiness");
84.175 -
84.176 - (* derived thms *)
84.177 -
84.178 - (*map g1 ... gm g(m+1) ... g(m+n) (map id ... id f(m+1) ... f(m+n) x)=
84.179 - map g1 ... gm (g(m+1) o f(m+1)) ... (g(m+n) o f(m+n)) x*)
84.180 - fun mk_map_comp_id x mapAsBs mapBsCs mapAsCs map_comp =
84.181 - let
84.182 - val lhs = Term.list_comb (mapBsCs, all_gs) $
84.183 - (Term.list_comb (mapAsBs, passive_ids @ fs) $ x);
84.184 - val rhs = Term.list_comb (mapAsCs,
84.185 - take m all_gs @ map HOLogic.mk_comp (drop m all_gs ~~ fs)) $ x;
84.186 - in
84.187 - Skip_Proof.prove lthy [] []
84.188 - (fold_rev Logic.all (x :: fs @ all_gs) (mk_Trueprop_eq (lhs, rhs)))
84.189 - (K (mk_map_comp_id_tac map_comp))
84.190 - |> Thm.close_derivation
84.191 - end;
84.192 -
84.193 - val map_comp_id_thms = map5 mk_map_comp_id xFs mapsAsBs mapsBsCs' mapsAsCs' map_comp's;
84.194 -
84.195 - (*forall a : set(m+1) x. f(m+1) a = a; ...; forall a : set(m+n) x. f(m+n) a = a ==>
84.196 - map id ... id f(m+1) ... f(m+n) x = x*)
84.197 - fun mk_map_congL x mapAsAs sets map_cong map_id' =
84.198 - let
84.199 - fun mk_prem set f z z' = HOLogic.mk_Trueprop
84.200 - (mk_Ball (set $ x) (Term.absfree z' (HOLogic.mk_eq (f $ z, z))));
84.201 - val prems = map4 mk_prem (drop m sets) self_fs zs zs';
84.202 - val goal = mk_Trueprop_eq (Term.list_comb (mapAsAs, passive_ids @ self_fs) $ x, x);
84.203 - in
84.204 - Skip_Proof.prove lthy [] []
84.205 - (fold_rev Logic.all (x :: self_fs) (Logic.list_implies (prems, goal)))
84.206 - (K (mk_map_congL_tac m map_cong map_id'))
84.207 - |> Thm.close_derivation
84.208 - end;
84.209 -
84.210 - val map_congL_thms = map5 mk_map_congL xFs mapsAsAs setssAs map_congs map_id's;
84.211 - val in_mono'_thms = map (fn bnf => in_mono_of_bnf bnf OF (replicate m subset_refl)) bnfs
84.212 - val in_cong'_thms = map (fn bnf => in_cong_of_bnf bnf OF (replicate m refl)) bnfs
84.213 -
84.214 - val timer = time (timer "Derived simple theorems");
84.215 -
84.216 - (* algebra *)
84.217 -
84.218 - val alg_bind = Binding.suffix_name ("_" ^ algN) b;
84.219 - val alg_name = Binding.name_of alg_bind;
84.220 - val alg_def_bind = (Thm.def_binding alg_bind, []);
84.221 -
84.222 - (*forall i = 1 ... n: (\<forall>x \<in> Fi_in A1 .. Am B1 ... Bn. si x \<in> Bi)*)
84.223 - val alg_spec =
84.224 - let
84.225 - val algT = Library.foldr (op -->) (ATs @ BTs @ sTs, HOLogic.boolT);
84.226 -
84.227 - val ins = map3 mk_in (replicate n (As @ Bs)) setssAs FTsAs;
84.228 - fun mk_alg_conjunct B s X x x' =
84.229 - mk_Ball X (Term.absfree x' (HOLogic.mk_mem (s $ x, B)));
84.230 -
84.231 - val lhs = Term.list_comb (Free (alg_name, algT), As @ Bs @ ss);
84.232 - val rhs = Library.foldr1 HOLogic.mk_conj (map5 mk_alg_conjunct Bs ss ins xFs xFs')
84.233 - in
84.234 - mk_Trueprop_eq (lhs, rhs)
84.235 - end;
84.236 -
84.237 - val ((alg_free, (_, alg_def_free)), (lthy, lthy_old)) =
84.238 - lthy
84.239 - |> Specification.definition (SOME (alg_bind, NONE, NoSyn), (alg_def_bind, alg_spec))
84.240 - ||> `Local_Theory.restore;
84.241 -
84.242 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.243 - val alg = fst (Term.dest_Const (Morphism.term phi alg_free));
84.244 - val alg_def = Morphism.thm phi alg_def_free;
84.245 -
84.246 - fun mk_alg As Bs ss =
84.247 - let
84.248 - val args = As @ Bs @ ss;
84.249 - val Ts = map fastype_of args;
84.250 - val algT = Library.foldr (op -->) (Ts, HOLogic.boolT);
84.251 - in
84.252 - Term.list_comb (Const (alg, algT), args)
84.253 - end;
84.254 -
84.255 - val alg_set_thms =
84.256 - let
84.257 - val alg_prem = HOLogic.mk_Trueprop (mk_alg As Bs ss);
84.258 - fun mk_prem x set B = HOLogic.mk_Trueprop (mk_subset (set $ x) B);
84.259 - fun mk_concl s x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (s $ x, B));
84.260 - val premss = map2 ((fn x => fn sets => map2 (mk_prem x) sets (As @ Bs))) xFs setssAs;
84.261 - val concls = map3 mk_concl ss xFs Bs;
84.262 - val goals = map3 (fn x => fn prems => fn concl =>
84.263 - fold_rev Logic.all (x :: As @ Bs @ ss)
84.264 - (Logic.list_implies (alg_prem :: prems, concl))) xFs premss concls;
84.265 - in
84.266 - map (fn goal =>
84.267 - Skip_Proof.prove lthy [] [] goal (K (mk_alg_set_tac alg_def)) |> Thm.close_derivation)
84.268 - goals
84.269 - end;
84.270 -
84.271 - fun mk_talg ATs BTs = mk_alg (map HOLogic.mk_UNIV ATs) (map HOLogic.mk_UNIV BTs);
84.272 -
84.273 - val talg_thm =
84.274 - let
84.275 - val goal = fold_rev Logic.all ss
84.276 - (HOLogic.mk_Trueprop (mk_talg passiveAs activeAs ss))
84.277 - in
84.278 - Skip_Proof.prove lthy [] [] goal
84.279 - (K (stac alg_def 1 THEN CONJ_WRAP (K (EVERY' [rtac ballI, rtac UNIV_I] 1)) ss))
84.280 - |> Thm.close_derivation
84.281 - end;
84.282 -
84.283 - val timer = time (timer "Algebra definition & thms");
84.284 -
84.285 - val alg_not_empty_thms =
84.286 - let
84.287 - val alg_prem =
84.288 - HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
84.289 - val concls = map (HOLogic.mk_Trueprop o mk_not_empty) Bs;
84.290 - val goals =
84.291 - map (fn concl =>
84.292 - fold_rev Logic.all (Bs @ ss) (Logic.mk_implies (alg_prem, concl))) concls;
84.293 - in
84.294 - map2 (fn goal => fn alg_set =>
84.295 - Skip_Proof.prove lthy [] []
84.296 - goal (K (mk_alg_not_empty_tac alg_set alg_set_thms wit_thms))
84.297 - |> Thm.close_derivation)
84.298 - goals alg_set_thms
84.299 - end;
84.300 -
84.301 - val timer = time (timer "Proved nonemptiness");
84.302 -
84.303 - (* morphism *)
84.304 -
84.305 - val mor_bind = Binding.suffix_name ("_" ^ morN) b;
84.306 - val mor_name = Binding.name_of mor_bind;
84.307 - val mor_def_bind = (Thm.def_binding mor_bind, []);
84.308 -
84.309 - (*fbetw) forall i = 1 ... n: (\<forall>x \<in> Bi. f x \<in> B'i)*)
84.310 - (*mor) forall i = 1 ... n: (\<forall>x \<in> Fi_in UNIV ... UNIV B1 ... Bn.
84.311 - f (s1 x) = s1' (Fi_map id ... id f1 ... fn x))*)
84.312 - val mor_spec =
84.313 - let
84.314 - val morT = Library.foldr (op -->) (BTs @ sTs @ B'Ts @ s'Ts @ fTs, HOLogic.boolT);
84.315 -
84.316 - fun mk_fbetw f B1 B2 z z' =
84.317 - mk_Ball B1 (Term.absfree z' (HOLogic.mk_mem (f $ z, B2)));
84.318 - fun mk_mor sets mapAsBs f s s' T x x' =
84.319 - mk_Ball (mk_in (passive_UNIVs @ Bs) sets T)
84.320 - (Term.absfree x' (HOLogic.mk_eq (f $ (s $ x), s' $
84.321 - (Term.list_comb (mapAsBs, passive_ids @ fs) $ x))));
84.322 - val lhs = Term.list_comb (Free (mor_name, morT), Bs @ ss @ B's @ s's @ fs);
84.323 - val rhs = HOLogic.mk_conj
84.324 - (Library.foldr1 HOLogic.mk_conj (map5 mk_fbetw fs Bs B's zs zs'),
84.325 - Library.foldr1 HOLogic.mk_conj
84.326 - (map8 mk_mor setssAs mapsAsBs fs ss s's FTsAs xFs xFs'))
84.327 - in
84.328 - mk_Trueprop_eq (lhs, rhs)
84.329 - end;
84.330 -
84.331 - val ((mor_free, (_, mor_def_free)), (lthy, lthy_old)) =
84.332 - lthy
84.333 - |> Specification.definition (SOME (mor_bind, NONE, NoSyn), (mor_def_bind, mor_spec))
84.334 - ||> `Local_Theory.restore;
84.335 -
84.336 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.337 - val mor = fst (Term.dest_Const (Morphism.term phi mor_free));
84.338 - val mor_def = Morphism.thm phi mor_def_free;
84.339 -
84.340 - fun mk_mor Bs1 ss1 Bs2 ss2 fs =
84.341 - let
84.342 - val args = Bs1 @ ss1 @ Bs2 @ ss2 @ fs;
84.343 - val Ts = map fastype_of (Bs1 @ ss1 @ Bs2 @ ss2 @ fs);
84.344 - val morT = Library.foldr (op -->) (Ts, HOLogic.boolT);
84.345 - in
84.346 - Term.list_comb (Const (mor, morT), args)
84.347 - end;
84.348 -
84.349 - val (mor_image_thms, morE_thms) =
84.350 - let
84.351 - val prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
84.352 - fun mk_image_goal f B1 B2 = fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs)
84.353 - (Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_subset (mk_image f $ B1) B2)));
84.354 - val image_goals = map3 mk_image_goal fs Bs B's;
84.355 - fun mk_elim_prem sets x T = HOLogic.mk_Trueprop
84.356 - (HOLogic.mk_mem (x, mk_in (passive_UNIVs @ Bs) sets T));
84.357 - fun mk_elim_goal sets mapAsBs f s s' x T =
84.358 - fold_rev Logic.all (x :: Bs @ ss @ B's @ s's @ fs)
84.359 - (Logic.list_implies ([prem, mk_elim_prem sets x T],
84.360 - mk_Trueprop_eq (f $ (s $ x), s' $ Term.list_comb (mapAsBs, passive_ids @ fs @ [x]))));
84.361 - val elim_goals = map7 mk_elim_goal setssAs mapsAsBs fs ss s's xFs FTsAs;
84.362 - fun prove goal =
84.363 - Skip_Proof.prove lthy [] [] goal (K (mk_mor_elim_tac mor_def)) |> Thm.close_derivation;
84.364 - in
84.365 - (map prove image_goals, map prove elim_goals)
84.366 - end;
84.367 -
84.368 - val mor_incl_thm =
84.369 - let
84.370 - val prems = map2 (HOLogic.mk_Trueprop oo mk_subset) Bs Bs_copy;
84.371 - val concl = HOLogic.mk_Trueprop (mk_mor Bs ss Bs_copy ss active_ids);
84.372 - in
84.373 - Skip_Proof.prove lthy [] []
84.374 - (fold_rev Logic.all (Bs @ ss @ Bs_copy) (Logic.list_implies (prems, concl)))
84.375 - (K (mk_mor_incl_tac mor_def map_id's))
84.376 - |> Thm.close_derivation
84.377 - end;
84.378 -
84.379 - val mor_comp_thm =
84.380 - let
84.381 - val prems =
84.382 - [HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs),
84.383 - HOLogic.mk_Trueprop (mk_mor B's s's B''s s''s gs)];
84.384 - val concl =
84.385 - HOLogic.mk_Trueprop (mk_mor Bs ss B''s s''s (map2 (curry HOLogic.mk_comp) gs fs));
84.386 - in
84.387 - Skip_Proof.prove lthy [] []
84.388 - (fold_rev Logic.all (Bs @ ss @ B's @ s's @ B''s @ s''s @ fs @ gs)
84.389 - (Logic.list_implies (prems, concl)))
84.390 - (K (mk_mor_comp_tac mor_def set_natural'ss map_comp_id_thms))
84.391 - |> Thm.close_derivation
84.392 - end;
84.393 -
84.394 - val mor_inv_thm =
84.395 - let
84.396 - fun mk_inv_prem f inv_f B B' = HOLogic.mk_conj (mk_subset (mk_image inv_f $ B') B,
84.397 - HOLogic.mk_conj (mk_inver inv_f f B, mk_inver f inv_f B'));
84.398 - val prems = map HOLogic.mk_Trueprop
84.399 - ([mk_mor Bs ss B's s's fs,
84.400 - mk_alg passive_UNIVs Bs ss,
84.401 - mk_alg passive_UNIVs B's s's] @
84.402 - map4 mk_inv_prem fs inv_fs Bs B's);
84.403 - val concl = HOLogic.mk_Trueprop (mk_mor B's s's Bs ss inv_fs);
84.404 - in
84.405 - Skip_Proof.prove lthy [] []
84.406 - (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ inv_fs)
84.407 - (Logic.list_implies (prems, concl)))
84.408 - (K (mk_mor_inv_tac alg_def mor_def
84.409 - set_natural'ss morE_thms map_comp_id_thms map_congL_thms))
84.410 - |> Thm.close_derivation
84.411 - end;
84.412 -
84.413 - val mor_cong_thm =
84.414 - let
84.415 - val prems = map HOLogic.mk_Trueprop
84.416 - (map2 (curry HOLogic.mk_eq) fs_copy fs @ [mk_mor Bs ss B's s's fs])
84.417 - val concl = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs_copy);
84.418 - in
84.419 - Skip_Proof.prove lthy [] []
84.420 - (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ fs_copy)
84.421 - (Logic.list_implies (prems, concl)))
84.422 - (K ((hyp_subst_tac THEN' atac) 1))
84.423 - |> Thm.close_derivation
84.424 - end;
84.425 -
84.426 - val mor_str_thm =
84.427 - let
84.428 - val maps = map2 (fn Ds => fn bnf => Term.list_comb
84.429 - (mk_map_of_bnf Ds (passiveAs @ FTsAs) allAs bnf, passive_ids @ ss)) Dss bnfs;
84.430 - in
84.431 - Skip_Proof.prove lthy [] []
84.432 - (fold_rev Logic.all ss (HOLogic.mk_Trueprop
84.433 - (mk_mor (map HOLogic.mk_UNIV FTsAs) maps active_UNIVs ss ss)))
84.434 - (K (mk_mor_str_tac ks mor_def))
84.435 - |> Thm.close_derivation
84.436 - end;
84.437 -
84.438 - val mor_convol_thm =
84.439 - let
84.440 - val maps = map3 (fn s => fn prod_s => fn mapx =>
84.441 - mk_convol (HOLogic.mk_comp (s, Term.list_comb (mapx, passive_ids @ fsts)), prod_s))
84.442 - s's prod_ss map_fsts;
84.443 - in
84.444 - Skip_Proof.prove lthy [] []
84.445 - (fold_rev Logic.all (s's @ prod_ss) (HOLogic.mk_Trueprop
84.446 - (mk_mor prod_UNIVs maps (map HOLogic.mk_UNIV activeBs) s's fsts)))
84.447 - (K (mk_mor_convol_tac ks mor_def))
84.448 - |> Thm.close_derivation
84.449 - end;
84.450 -
84.451 - val mor_UNIV_thm =
84.452 - let
84.453 - fun mk_conjunct mapAsBs f s s' = HOLogic.mk_eq
84.454 - (HOLogic.mk_comp (f, s),
84.455 - HOLogic.mk_comp (s', Term.list_comb (mapAsBs, passive_ids @ fs)));
84.456 - val lhs = mk_mor active_UNIVs ss (map HOLogic.mk_UNIV activeBs) s's fs;
84.457 - val rhs = Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct mapsAsBs fs ss s's);
84.458 - in
84.459 - Skip_Proof.prove lthy [] [] (fold_rev Logic.all (ss @ s's @ fs) (mk_Trueprop_eq (lhs, rhs)))
84.460 - (K (mk_mor_UNIV_tac m morE_thms mor_def))
84.461 - |> Thm.close_derivation
84.462 - end;
84.463 -
84.464 - val timer = time (timer "Morphism definition & thms");
84.465 -
84.466 - (* isomorphism *)
84.467 -
84.468 - (*mor Bs1 ss1 Bs2 ss2 fs \<and> (\<exists>gs. mor Bs2 ss2 Bs1 ss1 fs \<and>
84.469 - forall i = 1 ... n. (inver gs[i] fs[i] Bs1[i] \<and> inver fs[i] gs[i] Bs2[i]))*)
84.470 - fun mk_iso Bs1 ss1 Bs2 ss2 fs gs =
84.471 - let
84.472 - val ex_inv_mor = list_exists_free gs
84.473 - (HOLogic.mk_conj (mk_mor Bs2 ss2 Bs1 ss1 gs,
84.474 - Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_conj)
84.475 - (map3 mk_inver gs fs Bs1) (map3 mk_inver fs gs Bs2))));
84.476 - in
84.477 - HOLogic.mk_conj (mk_mor Bs1 ss1 Bs2 ss2 fs, ex_inv_mor)
84.478 - end;
84.479 -
84.480 - val iso_alt_thm =
84.481 - let
84.482 - val prems = map HOLogic.mk_Trueprop
84.483 - [mk_alg passive_UNIVs Bs ss,
84.484 - mk_alg passive_UNIVs B's s's]
84.485 - val concl = mk_Trueprop_eq (mk_iso Bs ss B's s's fs inv_fs,
84.486 - HOLogic.mk_conj (mk_mor Bs ss B's s's fs,
84.487 - Library.foldr1 HOLogic.mk_conj (map3 mk_bij_betw fs Bs B's)));
84.488 - in
84.489 - Skip_Proof.prove lthy [] []
84.490 - (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs) (Logic.list_implies (prems, concl)))
84.491 - (K (mk_iso_alt_tac mor_image_thms mor_inv_thm))
84.492 - |> Thm.close_derivation
84.493 - end;
84.494 -
84.495 - val timer = time (timer "Isomorphism definition & thms");
84.496 -
84.497 - (* algebra copies *)
84.498 -
84.499 - val (copy_alg_thm, ex_copy_alg_thm) =
84.500 - let
84.501 - val prems = map HOLogic.mk_Trueprop
84.502 - (mk_alg passive_UNIVs Bs ss :: map3 mk_bij_betw inv_fs B's Bs);
84.503 - val inver_prems = map HOLogic.mk_Trueprop
84.504 - (map3 mk_inver inv_fs fs Bs @ map3 mk_inver fs inv_fs B's);
84.505 - val all_prems = prems @ inver_prems;
84.506 - fun mk_s f s mapT y y' = Term.absfree y' (f $ (s $
84.507 - (Term.list_comb (mapT, passive_ids @ inv_fs) $ y)));
84.508 -
84.509 - val alg = HOLogic.mk_Trueprop
84.510 - (mk_alg passive_UNIVs B's (map5 mk_s fs ss mapsBsAs yFs yFs'));
84.511 - val copy_str_thm = Skip_Proof.prove lthy [] []
84.512 - (fold_rev Logic.all (Bs @ ss @ B's @ inv_fs @ fs)
84.513 - (Logic.list_implies (all_prems, alg)))
84.514 - (K (mk_copy_str_tac set_natural'ss alg_def alg_set_thms))
84.515 - |> Thm.close_derivation;
84.516 -
84.517 - val iso = HOLogic.mk_Trueprop
84.518 - (mk_iso B's (map5 mk_s fs ss mapsBsAs yFs yFs') Bs ss inv_fs fs_copy);
84.519 - val copy_alg_thm = Skip_Proof.prove lthy [] []
84.520 - (fold_rev Logic.all (Bs @ ss @ B's @ inv_fs @ fs)
84.521 - (Logic.list_implies (all_prems, iso)))
84.522 - (K (mk_copy_alg_tac set_natural'ss alg_set_thms mor_def iso_alt_thm copy_str_thm))
84.523 - |> Thm.close_derivation;
84.524 -
84.525 - val ex = HOLogic.mk_Trueprop
84.526 - (list_exists_free s's
84.527 - (HOLogic.mk_conj (mk_alg passive_UNIVs B's s's,
84.528 - mk_iso B's s's Bs ss inv_fs fs_copy)));
84.529 - val ex_copy_alg_thm = Skip_Proof.prove lthy [] []
84.530 - (fold_rev Logic.all (Bs @ ss @ B's @ inv_fs @ fs)
84.531 - (Logic.list_implies (prems, ex)))
84.532 - (K (mk_ex_copy_alg_tac n copy_str_thm copy_alg_thm))
84.533 - |> Thm.close_derivation;
84.534 - in
84.535 - (copy_alg_thm, ex_copy_alg_thm)
84.536 - end;
84.537 -
84.538 - val timer = time (timer "Copy thms");
84.539 -
84.540 -
84.541 - (* bounds *)
84.542 -
84.543 - val sum_Card_order = if n = 1 then bd_Card_order else @{thm Card_order_csum};
84.544 - val sum_Cnotzero = if n = 1 then bd_Cnotzero else bd_Cnotzero RS @{thm csum_Cnotzero1};
84.545 - val sum_Cinfinite = if n = 1 then bd_Cinfinite else bd_Cinfinite RS @{thm Cinfinite_csum1};
84.546 - fun mk_set_bd_sums i bd_Card_order bds =
84.547 - if n = 1 then bds
84.548 - else map (fn thm => bd_Card_order RS mk_ordLeq_csum n i thm) bds;
84.549 - val set_bd_sumss = map3 mk_set_bd_sums ks bd_Card_orders set_bdss;
84.550 -
84.551 - fun mk_in_bd_sum i Co Cnz bd =
84.552 - if n = 1 then bd
84.553 - else Cnz RS ((Co RS mk_ordLeq_csum n i (Co RS @{thm ordLeq_refl})) RS
84.554 - (bd RS @{thm ordLeq_transitive[OF _
84.555 - cexp_mono2_Cnotzero[OF _ csum_Cnotzero2[OF ctwo_Cnotzero]]]}));
84.556 - val in_bd_sums = map4 mk_in_bd_sum ks bd_Card_orders bd_Cnotzeros in_bds;
84.557 -
84.558 - val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
84.559 - val suc_bd = mk_cardSuc sum_bd;
84.560 - val field_suc_bd = mk_Field suc_bd;
84.561 - val suc_bdT = fst (dest_relT (fastype_of suc_bd));
84.562 - fun mk_Asuc_bd [] = mk_cexp ctwo suc_bd
84.563 - | mk_Asuc_bd As =
84.564 - mk_cexp (mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo) suc_bd;
84.565 -
84.566 - val suc_bd_Card_order = if n = 1 then bd_Card_order RS @{thm cardSuc_Card_order}
84.567 - else @{thm cardSuc_Card_order[OF Card_order_csum]};
84.568 - val suc_bd_Cinfinite = if n = 1 then bd_Cinfinite RS @{thm Cinfinite_cardSuc}
84.569 - else bd_Cinfinite RS @{thm Cinfinite_cardSuc[OF Cinfinite_csum1]};
84.570 - val suc_bd_Cnotzero = suc_bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
84.571 - val suc_bd_worel = suc_bd_Card_order RS @{thm Card_order_wo_rel}
84.572 - val basis_Asuc = if m = 0 then @{thm ordLeq_refl[OF Card_order_ctwo]}
84.573 - else @{thm ordLeq_csum2[OF Card_order_ctwo]};
84.574 - val Asuc_bd_Cinfinite = suc_bd_Cinfinite RS (basis_Asuc RS @{thm Cinfinite_cexp});
84.575 - val Asuc_bd_Cnotzero = Asuc_bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
84.576 -
84.577 - val suc_bd_Asuc_bd = @{thm ordLess_ordLeq_trans[OF
84.578 - ordLess_ctwo_cexp
84.579 - cexp_mono1_Cnotzero[OF _ ctwo_Cnotzero]]} OF
84.580 - [suc_bd_Card_order, basis_Asuc, suc_bd_Card_order];
84.581 -
84.582 - val Asuc_bdT = fst (dest_relT (fastype_of (mk_Asuc_bd As)));
84.583 - val II_BTs = replicate n (HOLogic.mk_setT Asuc_bdT);
84.584 - val II_sTs = map2 (fn Ds => fn bnf =>
84.585 - mk_T_of_bnf Ds (passiveAs @ replicate n Asuc_bdT) bnf --> Asuc_bdT) Dss bnfs;
84.586 -
84.587 - val (((((((idxs, Asi_name), (idx, idx')), (jdx, jdx')), II_Bs), II_ss), Asuc_fs),
84.588 - names_lthy) = names_lthy
84.589 - |> mk_Frees "i" (replicate n suc_bdT)
84.590 - ||>> (fn ctxt => apfst the_single (mk_fresh_names ctxt 1 "Asi"))
84.591 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "i") suc_bdT
84.592 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "j") suc_bdT
84.593 - ||>> mk_Frees "IIB" II_BTs
84.594 - ||>> mk_Frees "IIs" II_sTs
84.595 - ||>> mk_Frees "f" (map (fn T => Asuc_bdT --> T) activeAs);
84.596 -
84.597 - val suc_bd_limit_thm =
84.598 - let
84.599 - val prem = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.600 - (map (fn idx => HOLogic.mk_mem (idx, field_suc_bd)) idxs));
84.601 - fun mk_conjunct idx = HOLogic.mk_conj (mk_not_eq idx jdx,
84.602 - HOLogic.mk_mem (HOLogic.mk_prod (idx, jdx), suc_bd));
84.603 - val concl = HOLogic.mk_Trueprop (mk_Bex field_suc_bd
84.604 - (Term.absfree jdx' (Library.foldr1 HOLogic.mk_conj (map mk_conjunct idxs))));
84.605 - in
84.606 - Skip_Proof.prove lthy [] []
84.607 - (fold_rev Logic.all idxs (Logic.list_implies ([prem], concl)))
84.608 - (K (mk_bd_limit_tac n suc_bd_Cinfinite))
84.609 - |> Thm.close_derivation
84.610 - end;
84.611 -
84.612 - val timer = time (timer "Bounds");
84.613 -
84.614 -
84.615 - (* minimal algebra *)
84.616 -
84.617 - fun mk_minG Asi i k = mk_UNION (mk_underS suc_bd $ i)
84.618 - (Term.absfree jdx' (mk_nthN n (Asi $ jdx) k));
84.619 -
84.620 - fun mk_minH_component As Asi i sets Ts s k =
84.621 - HOLogic.mk_binop @{const_name "sup"}
84.622 - (mk_minG Asi i k, mk_image s $ mk_in (As @ map (mk_minG Asi i) ks) sets Ts);
84.623 -
84.624 - fun mk_min_algs As ss =
84.625 - let
84.626 - val BTs = map (range_type o fastype_of) ss;
84.627 - val Ts = map (HOLogic.dest_setT o fastype_of) As @ BTs;
84.628 - val (Asi, Asi') = `Free (Asi_name, suc_bdT -->
84.629 - Library.foldr1 HOLogic.mk_prodT (map HOLogic.mk_setT BTs));
84.630 - in
84.631 - mk_worec suc_bd (Term.absfree Asi' (Term.absfree idx' (HOLogic.mk_tuple
84.632 - (map4 (mk_minH_component As Asi idx) (mk_setss Ts) (mk_FTs Ts) ss ks))))
84.633 - end;
84.634 -
84.635 - val (min_algs_thms, min_algs_mono_thms, card_of_min_algs_thm, least_min_algs_thm) =
84.636 - let
84.637 - val i_field = HOLogic.mk_mem (idx, field_suc_bd);
84.638 - val min_algs = mk_min_algs As ss;
84.639 - val min_algss = map (fn k => mk_nthN n (min_algs $ idx) k) ks;
84.640 -
84.641 - val concl = HOLogic.mk_Trueprop
84.642 - (HOLogic.mk_eq (min_algs $ idx, HOLogic.mk_tuple
84.643 - (map4 (mk_minH_component As min_algs idx) setssAs FTsAs ss ks)));
84.644 - val goal = fold_rev Logic.all (idx :: As @ ss)
84.645 - (Logic.mk_implies (HOLogic.mk_Trueprop i_field, concl));
84.646 -
84.647 - val min_algs_thm = Skip_Proof.prove lthy [] [] goal
84.648 - (K (mk_min_algs_tac suc_bd_worel in_cong'_thms))
84.649 - |> Thm.close_derivation;
84.650 -
84.651 - val min_algs_thms = map (fn k => min_algs_thm RS mk_nthI n k) ks;
84.652 -
84.653 - fun mk_mono_goal min_alg =
84.654 - fold_rev Logic.all (As @ ss) (HOLogic.mk_Trueprop (mk_relChain suc_bd
84.655 - (Term.absfree idx' min_alg)));
84.656 -
84.657 - val monos =
84.658 - map2 (fn goal => fn min_algs =>
84.659 - Skip_Proof.prove lthy [] [] goal (K (mk_min_algs_mono_tac min_algs))
84.660 - |> Thm.close_derivation)
84.661 - (map mk_mono_goal min_algss) min_algs_thms;
84.662 -
84.663 - val Asuc_bd = mk_Asuc_bd As;
84.664 -
84.665 - fun mk_card_conjunct min_alg = mk_ordLeq (mk_card_of min_alg) Asuc_bd;
84.666 - val card_conjunction = Library.foldr1 HOLogic.mk_conj (map mk_card_conjunct min_algss);
84.667 - val card_cT = certifyT lthy suc_bdT;
84.668 - val card_ct = certify lthy (Term.absfree idx' card_conjunction);
84.669 -
84.670 - val card_of = singleton (Proof_Context.export names_lthy lthy)
84.671 - (Skip_Proof.prove lthy [] []
84.672 - (HOLogic.mk_Trueprop (HOLogic.mk_imp (i_field, card_conjunction)))
84.673 - (K (mk_min_algs_card_of_tac card_cT card_ct
84.674 - m suc_bd_worel min_algs_thms in_bd_sums
84.675 - sum_Card_order sum_Cnotzero suc_bd_Card_order suc_bd_Cinfinite suc_bd_Cnotzero
84.676 - suc_bd_Asuc_bd Asuc_bd_Cinfinite Asuc_bd_Cnotzero)))
84.677 - |> Thm.close_derivation;
84.678 -
84.679 - val least_prem = HOLogic.mk_Trueprop (mk_alg As Bs ss);
84.680 - val least_conjunction = Library.foldr1 HOLogic.mk_conj (map2 mk_subset min_algss Bs);
84.681 - val least_cT = certifyT lthy suc_bdT;
84.682 - val least_ct = certify lthy (Term.absfree idx' least_conjunction);
84.683 -
84.684 - val least = singleton (Proof_Context.export names_lthy lthy)
84.685 - (Skip_Proof.prove lthy [] []
84.686 - (Logic.mk_implies (least_prem,
84.687 - HOLogic.mk_Trueprop (HOLogic.mk_imp (i_field, least_conjunction))))
84.688 - (K (mk_min_algs_least_tac least_cT least_ct
84.689 - suc_bd_worel min_algs_thms alg_set_thms)))
84.690 - |> Thm.close_derivation;
84.691 - in
84.692 - (min_algs_thms, monos, card_of, least)
84.693 - end;
84.694 -
84.695 - val timer = time (timer "min_algs definition & thms");
84.696 -
84.697 - fun min_alg_bind i = Binding.suffix_name
84.698 - ("_" ^ min_algN ^ (if n = 1 then "" else string_of_int i)) b;
84.699 - val min_alg_name = Binding.name_of o min_alg_bind;
84.700 - val min_alg_def_bind = rpair [] o Thm.def_binding o min_alg_bind;
84.701 -
84.702 - fun min_alg_spec i =
84.703 - let
84.704 - val min_algT =
84.705 - Library.foldr (op -->) (ATs @ sTs, HOLogic.mk_setT (nth activeAs (i - 1)));
84.706 -
84.707 - val lhs = Term.list_comb (Free (min_alg_name i, min_algT), As @ ss);
84.708 - val rhs = mk_UNION (field_suc_bd)
84.709 - (Term.absfree idx' (mk_nthN n (mk_min_algs As ss $ idx) i));
84.710 - in
84.711 - mk_Trueprop_eq (lhs, rhs)
84.712 - end;
84.713 -
84.714 - val ((min_alg_frees, (_, min_alg_def_frees)), (lthy, lthy_old)) =
84.715 - lthy
84.716 - |> fold_map (fn i => Specification.definition
84.717 - (SOME (min_alg_bind i, NONE, NoSyn), (min_alg_def_bind i, min_alg_spec i))) ks
84.718 - |>> apsnd split_list o split_list
84.719 - ||> `Local_Theory.restore;
84.720 -
84.721 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.722 - val min_algs = map (fst o Term.dest_Const o Morphism.term phi) min_alg_frees;
84.723 - val min_alg_defs = map (Morphism.thm phi) min_alg_def_frees;
84.724 -
84.725 - fun mk_min_alg As ss i =
84.726 - let
84.727 - val T = HOLogic.mk_setT (range_type (fastype_of (nth ss (i - 1))))
84.728 - val args = As @ ss;
84.729 - val Ts = map fastype_of args;
84.730 - val min_algT = Library.foldr (op -->) (Ts, T);
84.731 - in
84.732 - Term.list_comb (Const (nth min_algs (i - 1), min_algT), args)
84.733 - end;
84.734 -
84.735 - val (alg_min_alg_thm, card_of_min_alg_thms, least_min_alg_thms, mor_incl_min_alg_thm) =
84.736 - let
84.737 - val min_algs = map (mk_min_alg As ss) ks;
84.738 -
84.739 - val goal = fold_rev Logic.all (As @ ss) (HOLogic.mk_Trueprop (mk_alg As min_algs ss));
84.740 - val alg_min_alg = Skip_Proof.prove lthy [] [] goal
84.741 - (K (mk_alg_min_alg_tac m alg_def min_alg_defs suc_bd_limit_thm sum_Cinfinite
84.742 - set_bd_sumss min_algs_thms min_algs_mono_thms))
84.743 - |> Thm.close_derivation;
84.744 -
84.745 - val Asuc_bd = mk_Asuc_bd As;
84.746 - fun mk_card_of_thm min_alg def = Skip_Proof.prove lthy [] []
84.747 - (fold_rev Logic.all (As @ ss)
84.748 - (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of min_alg) Asuc_bd)))
84.749 - (K (mk_card_of_min_alg_tac def card_of_min_algs_thm
84.750 - suc_bd_Card_order suc_bd_Asuc_bd Asuc_bd_Cinfinite))
84.751 - |> Thm.close_derivation;
84.752 -
84.753 - val least_prem = HOLogic.mk_Trueprop (mk_alg As Bs ss);
84.754 - fun mk_least_thm min_alg B def = Skip_Proof.prove lthy [] []
84.755 - (fold_rev Logic.all (As @ Bs @ ss)
84.756 - (Logic.mk_implies (least_prem, HOLogic.mk_Trueprop (mk_subset min_alg B))))
84.757 - (K (mk_least_min_alg_tac def least_min_algs_thm))
84.758 - |> Thm.close_derivation;
84.759 -
84.760 - val leasts = map3 mk_least_thm min_algs Bs min_alg_defs;
84.761 -
84.762 - val incl_prem = HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
84.763 - val incl_min_algs = map (mk_min_alg passive_UNIVs ss) ks;
84.764 - val incl = Skip_Proof.prove lthy [] []
84.765 - (fold_rev Logic.all (Bs @ ss)
84.766 - (Logic.mk_implies (incl_prem,
84.767 - HOLogic.mk_Trueprop (mk_mor incl_min_algs ss Bs ss active_ids))))
84.768 - (K (EVERY' (rtac mor_incl_thm :: map etac leasts) 1))
84.769 - |> Thm.close_derivation;
84.770 - in
84.771 - (alg_min_alg, map2 mk_card_of_thm min_algs min_alg_defs, leasts, incl)
84.772 - end;
84.773 -
84.774 - val timer = time (timer "Minimal algebra definition & thms");
84.775 -
84.776 - val II_repT = HOLogic.mk_prodT (HOLogic.mk_tupleT II_BTs, HOLogic.mk_tupleT II_sTs);
84.777 - val IIT_bind = Binding.suffix_name ("_" ^ IITN) b;
84.778 -
84.779 - val ((IIT_name, (IIT_glob_info, IIT_loc_info)), lthy) =
84.780 - typedef false NONE (IIT_bind, params, NoSyn)
84.781 - (HOLogic.mk_UNIV II_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
84.782 -
84.783 - val IIT = Type (IIT_name, params');
84.784 - val Abs_IIT = Const (#Abs_name IIT_glob_info, II_repT --> IIT);
84.785 - val Rep_IIT = Const (#Rep_name IIT_glob_info, IIT --> II_repT);
84.786 - val Abs_IIT_inverse_thm = UNIV_I RS #Abs_inverse IIT_loc_info;
84.787 -
84.788 - val initT = IIT --> Asuc_bdT;
84.789 - val active_initTs = replicate n initT;
84.790 - val init_FTs = map2 (fn Ds => mk_T_of_bnf Ds (passiveAs @ active_initTs)) Dss bnfs;
84.791 - val init_fTs = map (fn T => initT --> T) activeAs;
84.792 -
84.793 - val (((((((iidx, iidx'), init_xs), (init_xFs, init_xFs')),
84.794 - init_fs), init_fs_copy), init_phis), names_lthy) = names_lthy
84.795 - |> yield_singleton (apfst (op ~~) oo mk_Frees' "i") IIT
84.796 - ||>> mk_Frees "ix" active_initTs
84.797 - ||>> mk_Frees' "x" init_FTs
84.798 - ||>> mk_Frees "f" init_fTs
84.799 - ||>> mk_Frees "f" init_fTs
84.800 - ||>> mk_Frees "P" (replicate n (mk_pred1T initT));
84.801 -
84.802 - val II = HOLogic.mk_Collect (fst iidx', IIT, list_exists_free (II_Bs @ II_ss)
84.803 - (HOLogic.mk_conj (HOLogic.mk_eq (iidx,
84.804 - Abs_IIT $ (HOLogic.mk_prod (HOLogic.mk_tuple II_Bs, HOLogic.mk_tuple II_ss))),
84.805 - mk_alg passive_UNIVs II_Bs II_ss)));
84.806 -
84.807 - val select_Bs = map (mk_nthN n (HOLogic.mk_fst (Rep_IIT $ iidx))) ks;
84.808 - val select_ss = map (mk_nthN n (HOLogic.mk_snd (Rep_IIT $ iidx))) ks;
84.809 -
84.810 - fun str_init_bind i = Binding.suffix_name ("_" ^ str_initN ^ (if n = 1 then "" else
84.811 - string_of_int i)) b;
84.812 - val str_init_name = Binding.name_of o str_init_bind;
84.813 - val str_init_def_bind = rpair [] o Thm.def_binding o str_init_bind;
84.814 -
84.815 - fun str_init_spec i =
84.816 - let
84.817 - val T = nth init_FTs (i - 1);
84.818 - val init_xF = nth init_xFs (i - 1)
84.819 - val select_s = nth select_ss (i - 1);
84.820 - val map = mk_map_of_bnf (nth Dss (i - 1))
84.821 - (passiveAs @ active_initTs) (passiveAs @ replicate n Asuc_bdT)
84.822 - (nth bnfs (i - 1));
84.823 - val map_args = passive_ids @ replicate n (mk_rapp iidx Asuc_bdT);
84.824 - val str_initT = T --> IIT --> Asuc_bdT;
84.825 -
84.826 - val lhs = Term.list_comb (Free (str_init_name i, str_initT), [init_xF, iidx]);
84.827 - val rhs = select_s $ (Term.list_comb (map, map_args) $ init_xF);
84.828 - in
84.829 - mk_Trueprop_eq (lhs, rhs)
84.830 - end;
84.831 -
84.832 - val ((str_init_frees, (_, str_init_def_frees)), (lthy, lthy_old)) =
84.833 - lthy
84.834 - |> fold_map (fn i => Specification.definition
84.835 - (SOME (str_init_bind i, NONE, NoSyn), (str_init_def_bind i, str_init_spec i))) ks
84.836 - |>> apsnd split_list o split_list
84.837 - ||> `Local_Theory.restore;
84.838 -
84.839 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.840 - val str_inits =
84.841 - map (Term.subst_atomic_types (map (`(Morphism.typ phi)) params') o Morphism.term phi)
84.842 - str_init_frees;
84.843 -
84.844 - val str_init_defs = map (Morphism.thm phi) str_init_def_frees;
84.845 -
84.846 - val car_inits = map (mk_min_alg passive_UNIVs str_inits) ks;
84.847 -
84.848 - (*TODO: replace with instantiate? (problem: figure out right type instantiation)*)
84.849 - val alg_init_thm = Skip_Proof.prove lthy [] []
84.850 - (HOLogic.mk_Trueprop (mk_alg passive_UNIVs car_inits str_inits))
84.851 - (K (rtac alg_min_alg_thm 1))
84.852 - |> Thm.close_derivation;
84.853 -
84.854 - val alg_select_thm = Skip_Proof.prove lthy [] []
84.855 - (HOLogic.mk_Trueprop (mk_Ball II
84.856 - (Term.absfree iidx' (mk_alg passive_UNIVs select_Bs select_ss))))
84.857 - (mk_alg_select_tac Abs_IIT_inverse_thm)
84.858 - |> Thm.close_derivation;
84.859 -
84.860 - val mor_select_thm =
84.861 - let
84.862 - val alg_prem = HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
84.863 - val i_prem = HOLogic.mk_Trueprop (HOLogic.mk_mem (iidx, II));
84.864 - val mor_prem = HOLogic.mk_Trueprop (mk_mor select_Bs select_ss Bs ss Asuc_fs);
84.865 - val prems = [alg_prem, i_prem, mor_prem];
84.866 - val concl = HOLogic.mk_Trueprop
84.867 - (mk_mor car_inits str_inits Bs ss
84.868 - (map (fn f => HOLogic.mk_comp (f, mk_rapp iidx Asuc_bdT)) Asuc_fs));
84.869 - in
84.870 - Skip_Proof.prove lthy [] []
84.871 - (fold_rev Logic.all (iidx :: Bs @ ss @ Asuc_fs) (Logic.list_implies (prems, concl)))
84.872 - (K (mk_mor_select_tac mor_def mor_cong_thm mor_comp_thm mor_incl_min_alg_thm alg_def
84.873 - alg_select_thm alg_set_thms set_natural'ss str_init_defs))
84.874 - |> Thm.close_derivation
84.875 - end;
84.876 -
84.877 - val (init_ex_mor_thm, init_unique_mor_thms) =
84.878 - let
84.879 - val prem = HOLogic.mk_Trueprop (mk_alg passive_UNIVs Bs ss);
84.880 - val concl = HOLogic.mk_Trueprop
84.881 - (list_exists_free init_fs (mk_mor car_inits str_inits Bs ss init_fs));
84.882 - val ex_mor = Skip_Proof.prove lthy [] []
84.883 - (fold_rev Logic.all (Bs @ ss) (Logic.mk_implies (prem, concl)))
84.884 - (mk_init_ex_mor_tac Abs_IIT_inverse_thm ex_copy_alg_thm alg_min_alg_thm
84.885 - card_of_min_alg_thms mor_comp_thm mor_select_thm mor_incl_min_alg_thm)
84.886 - |> Thm.close_derivation;
84.887 -
84.888 - val prems = map2 (HOLogic.mk_Trueprop oo curry HOLogic.mk_mem) init_xs car_inits
84.889 - val mor_prems = map HOLogic.mk_Trueprop
84.890 - [mk_mor car_inits str_inits Bs ss init_fs,
84.891 - mk_mor car_inits str_inits Bs ss init_fs_copy];
84.892 - fun mk_fun_eq f g x = HOLogic.mk_eq (f $ x, g $ x);
84.893 - val unique = HOLogic.mk_Trueprop
84.894 - (Library.foldr1 HOLogic.mk_conj (map3 mk_fun_eq init_fs init_fs_copy init_xs));
84.895 - val unique_mor = Skip_Proof.prove lthy [] []
84.896 - (fold_rev Logic.all (init_xs @ Bs @ ss @ init_fs @ init_fs_copy)
84.897 - (Logic.list_implies (prems @ mor_prems, unique)))
84.898 - (K (mk_init_unique_mor_tac m alg_def alg_init_thm least_min_alg_thms
84.899 - in_mono'_thms alg_set_thms morE_thms map_congs))
84.900 - |> Thm.close_derivation;
84.901 - in
84.902 - (ex_mor, split_conj_thm unique_mor)
84.903 - end;
84.904 -
84.905 - val init_setss = mk_setss (passiveAs @ active_initTs);
84.906 - val active_init_setss = map (drop m) init_setss;
84.907 - val init_ins = map2 (fn sets => mk_in (passive_UNIVs @ car_inits) sets) init_setss init_FTs;
84.908 -
84.909 - fun mk_closed phis =
84.910 - let
84.911 - fun mk_conjunct phi str_init init_sets init_in x x' =
84.912 - let
84.913 - val prem = Library.foldr1 HOLogic.mk_conj
84.914 - (map2 (fn set => mk_Ball (set $ x)) init_sets phis);
84.915 - val concl = phi $ (str_init $ x);
84.916 - in
84.917 - mk_Ball init_in (Term.absfree x' (HOLogic.mk_imp (prem, concl)))
84.918 - end;
84.919 - in
84.920 - Library.foldr1 HOLogic.mk_conj
84.921 - (map6 mk_conjunct phis str_inits active_init_setss init_ins init_xFs init_xFs')
84.922 - end;
84.923 -
84.924 - val init_induct_thm =
84.925 - let
84.926 - val prem = HOLogic.mk_Trueprop (mk_closed init_phis);
84.927 - val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.928 - (map2 mk_Ball car_inits init_phis));
84.929 - in
84.930 - Skip_Proof.prove lthy [] []
84.931 - (fold_rev Logic.all init_phis (Logic.mk_implies (prem, concl)))
84.932 - (K (mk_init_induct_tac m alg_def alg_init_thm least_min_alg_thms alg_set_thms))
84.933 - |> Thm.close_derivation
84.934 - end;
84.935 -
84.936 - val timer = time (timer "Initiality definition & thms");
84.937 -
84.938 - val ((T_names, (T_glob_infos, T_loc_infos)), lthy) =
84.939 - lthy
84.940 - |> fold_map3 (fn b => fn mx => fn car_init => typedef false NONE (b, params, mx) car_init NONE
84.941 - (EVERY' [rtac ssubst, rtac @{thm ex_in_conv}, resolve_tac alg_not_empty_thms,
84.942 - rtac alg_init_thm] 1)) bs mixfixes car_inits
84.943 - |>> apsnd split_list o split_list;
84.944 -
84.945 - val Ts = map (fn name => Type (name, params')) T_names;
84.946 - fun mk_Ts passive = map (Term.typ_subst_atomic (passiveAs ~~ passive)) Ts;
84.947 - val Ts' = mk_Ts passiveBs;
84.948 - val Rep_Ts = map2 (fn info => fn T => Const (#Rep_name info, T --> initT)) T_glob_infos Ts;
84.949 - val Abs_Ts = map2 (fn info => fn T => Const (#Abs_name info, initT --> T)) T_glob_infos Ts;
84.950 -
84.951 - val type_defs = map #type_definition T_loc_infos;
84.952 - val Reps = map #Rep T_loc_infos;
84.953 - val Rep_casess = map #Rep_cases T_loc_infos;
84.954 - val Rep_injects = map #Rep_inject T_loc_infos;
84.955 - val Rep_inverses = map #Rep_inverse T_loc_infos;
84.956 - val Abs_inverses = map #Abs_inverse T_loc_infos;
84.957 -
84.958 - fun mk_inver_thm mk_tac rep abs X thm =
84.959 - Skip_Proof.prove lthy [] []
84.960 - (HOLogic.mk_Trueprop (mk_inver rep abs X))
84.961 - (K (EVERY' [rtac ssubst, rtac @{thm inver_def}, rtac ballI, mk_tac thm] 1))
84.962 - |> Thm.close_derivation;
84.963 -
84.964 - val inver_Reps = map4 (mk_inver_thm rtac) Abs_Ts Rep_Ts (map HOLogic.mk_UNIV Ts) Rep_inverses;
84.965 - val inver_Abss = map4 (mk_inver_thm etac) Rep_Ts Abs_Ts car_inits Abs_inverses;
84.966 -
84.967 - val timer = time (timer "THE TYPEDEFs & Rep/Abs thms");
84.968 -
84.969 - val UNIVs = map HOLogic.mk_UNIV Ts;
84.970 - val FTs = mk_FTs (passiveAs @ Ts);
84.971 - val FTs' = mk_FTs (passiveBs @ Ts');
84.972 - fun mk_set_Ts T = passiveAs @ replicate n (HOLogic.mk_setT T);
84.973 - val setFTss = map (mk_FTs o mk_set_Ts) passiveAs;
84.974 - val FTs_setss = mk_setss (passiveAs @ Ts);
84.975 - val FTs'_setss = mk_setss (passiveBs @ Ts');
84.976 - val map_FT_inits = map2 (fn Ds =>
84.977 - mk_map_of_bnf Ds (passiveAs @ Ts) (passiveAs @ active_initTs)) Dss bnfs;
84.978 - val fTs = map2 (curry op -->) Ts activeAs;
84.979 - val foldT = Library.foldr1 HOLogic.mk_prodT (map2 (curry op -->) Ts activeAs);
84.980 - val rec_sTs = map (Term.typ_subst_atomic (activeBs ~~ Ts)) prod_sTs;
84.981 - val rec_maps = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_fsts;
84.982 - val rec_maps_rev = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_fsts_rev;
84.983 - val rec_fsts = map (Term.subst_atomic_types (activeBs ~~ Ts)) fsts;
84.984 -
84.985 - val (((((((((Izs1, Izs1'), (Izs2, Izs2')), (xFs, xFs')), yFs), (AFss, AFss')),
84.986 - (fold_f, fold_f')), fs), rec_ss), names_lthy) = names_lthy
84.987 - |> mk_Frees' "z1" Ts
84.988 - ||>> mk_Frees' "z2" Ts'
84.989 - ||>> mk_Frees' "x" FTs
84.990 - ||>> mk_Frees "y" FTs'
84.991 - ||>> mk_Freess' "z" setFTss
84.992 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "f") foldT
84.993 - ||>> mk_Frees "f" fTs
84.994 - ||>> mk_Frees "s" rec_sTs;
84.995 -
84.996 - val Izs = map2 retype_free Ts zs;
84.997 - val phis = map2 retype_free (map mk_pred1T Ts) init_phis;
84.998 - val phi2s = map2 retype_free (map2 mk_pred2T Ts Ts') init_phis;
84.999 -
84.1000 - fun ctor_bind i = Binding.suffix_name ("_" ^ ctorN) (nth bs (i - 1));
84.1001 - val ctor_name = Binding.name_of o ctor_bind;
84.1002 - val ctor_def_bind = rpair [] o Thm.def_binding o ctor_bind;
84.1003 -
84.1004 - fun ctor_spec i abs str map_FT_init x x' =
84.1005 - let
84.1006 - val ctorT = nth FTs (i - 1) --> nth Ts (i - 1);
84.1007 -
84.1008 - val lhs = Free (ctor_name i, ctorT);
84.1009 - val rhs = Term.absfree x' (abs $ (str $
84.1010 - (Term.list_comb (map_FT_init, map HOLogic.id_const passiveAs @ Rep_Ts) $ x)));
84.1011 - in
84.1012 - mk_Trueprop_eq (lhs, rhs)
84.1013 - end;
84.1014 -
84.1015 - val ((ctor_frees, (_, ctor_def_frees)), (lthy, lthy_old)) =
84.1016 - lthy
84.1017 - |> fold_map6 (fn i => fn abs => fn str => fn mapx => fn x => fn x' =>
84.1018 - Specification.definition
84.1019 - (SOME (ctor_bind i, NONE, NoSyn), (ctor_def_bind i, ctor_spec i abs str mapx x x')))
84.1020 - ks Abs_Ts str_inits map_FT_inits xFs xFs'
84.1021 - |>> apsnd split_list o split_list
84.1022 - ||> `Local_Theory.restore;
84.1023 -
84.1024 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.1025 - fun mk_ctors passive =
84.1026 - map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ (mk_params passive)) o
84.1027 - Morphism.term phi) ctor_frees;
84.1028 - val ctors = mk_ctors passiveAs;
84.1029 - val ctor's = mk_ctors passiveBs;
84.1030 - val ctor_defs = map (Morphism.thm phi) ctor_def_frees;
84.1031 -
84.1032 - val (mor_Rep_thm, mor_Abs_thm) =
84.1033 - let
84.1034 - val copy = alg_init_thm RS copy_alg_thm;
84.1035 - fun mk_bij inj Rep cases = @{thm bij_betwI'} OF [inj, Rep, cases];
84.1036 - val bijs = map3 mk_bij Rep_injects Reps Rep_casess;
84.1037 - val mor_Rep =
84.1038 - Skip_Proof.prove lthy [] []
84.1039 - (HOLogic.mk_Trueprop (mk_mor UNIVs ctors car_inits str_inits Rep_Ts))
84.1040 - (mk_mor_Rep_tac ctor_defs copy bijs inver_Abss inver_Reps)
84.1041 - |> Thm.close_derivation;
84.1042 -
84.1043 - val inv = mor_inv_thm OF [mor_Rep, talg_thm, alg_init_thm];
84.1044 - val mor_Abs =
84.1045 - Skip_Proof.prove lthy [] []
84.1046 - (HOLogic.mk_Trueprop (mk_mor car_inits str_inits UNIVs ctors Abs_Ts))
84.1047 - (K (mk_mor_Abs_tac inv inver_Abss inver_Reps))
84.1048 - |> Thm.close_derivation;
84.1049 - in
84.1050 - (mor_Rep, mor_Abs)
84.1051 - end;
84.1052 -
84.1053 - val timer = time (timer "ctor definitions & thms");
84.1054 -
84.1055 - val fold_fun = Term.absfree fold_f'
84.1056 - (mk_mor UNIVs ctors active_UNIVs ss (map (mk_nthN n fold_f) ks));
84.1057 - val foldx = HOLogic.choice_const foldT $ fold_fun;
84.1058 -
84.1059 - fun fold_bind i = Binding.suffix_name ("_" ^ ctor_foldN) (nth bs (i - 1));
84.1060 - val fold_name = Binding.name_of o fold_bind;
84.1061 - val fold_def_bind = rpair [] o Thm.def_binding o fold_bind;
84.1062 -
84.1063 - fun fold_spec i T AT =
84.1064 - let
84.1065 - val foldT = Library.foldr (op -->) (sTs, T --> AT);
84.1066 -
84.1067 - val lhs = Term.list_comb (Free (fold_name i, foldT), ss);
84.1068 - val rhs = mk_nthN n foldx i;
84.1069 - in
84.1070 - mk_Trueprop_eq (lhs, rhs)
84.1071 - end;
84.1072 -
84.1073 - val ((fold_frees, (_, fold_def_frees)), (lthy, lthy_old)) =
84.1074 - lthy
84.1075 - |> fold_map3 (fn i => fn T => fn AT =>
84.1076 - Specification.definition
84.1077 - (SOME (fold_bind i, NONE, NoSyn), (fold_def_bind i, fold_spec i T AT)))
84.1078 - ks Ts activeAs
84.1079 - |>> apsnd split_list o split_list
84.1080 - ||> `Local_Theory.restore;
84.1081 -
84.1082 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.1083 - val folds = map (Morphism.term phi) fold_frees;
84.1084 - val fold_names = map (fst o dest_Const) folds;
84.1085 - fun mk_fold Ts ss i = Term.list_comb (Const (nth fold_names (i - 1), Library.foldr (op -->)
84.1086 - (map fastype_of ss, nth Ts (i - 1) --> range_type (fastype_of (nth ss (i - 1))))), ss);
84.1087 - val fold_defs = map (Morphism.thm phi) fold_def_frees;
84.1088 -
84.1089 - val mor_fold_thm =
84.1090 - let
84.1091 - val ex_mor = talg_thm RS init_ex_mor_thm;
84.1092 - val mor_cong = mor_cong_thm OF (map (mk_nth_conv n) ks);
84.1093 - val mor_comp = mor_Rep_thm RS mor_comp_thm;
84.1094 - val cT = certifyT lthy foldT;
84.1095 - val ct = certify lthy fold_fun
84.1096 - in
84.1097 - singleton (Proof_Context.export names_lthy lthy)
84.1098 - (Skip_Proof.prove lthy [] []
84.1099 - (HOLogic.mk_Trueprop (mk_mor UNIVs ctors active_UNIVs ss (map (mk_fold Ts ss) ks)))
84.1100 - (K (mk_mor_fold_tac cT ct fold_defs ex_mor (mor_comp RS mor_cong))))
84.1101 - |> Thm.close_derivation
84.1102 - end;
84.1103 -
84.1104 - val ctor_fold_thms = map (fn morE => rule_by_tactic lthy
84.1105 - ((rtac CollectI THEN' CONJ_WRAP' (K (rtac @{thm subset_UNIV})) (1 upto m + n)) 1)
84.1106 - (mor_fold_thm RS morE)) morE_thms;
84.1107 -
84.1108 - val (fold_unique_mor_thms, fold_unique_mor_thm) =
84.1109 - let
84.1110 - val prem = HOLogic.mk_Trueprop (mk_mor UNIVs ctors active_UNIVs ss fs);
84.1111 - fun mk_fun_eq f i = HOLogic.mk_eq (f, mk_fold Ts ss i);
84.1112 - val unique = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_fun_eq fs ks));
84.1113 - val unique_mor = Skip_Proof.prove lthy [] []
84.1114 - (fold_rev Logic.all (ss @ fs) (Logic.mk_implies (prem, unique)))
84.1115 - (K (mk_fold_unique_mor_tac type_defs init_unique_mor_thms Reps
84.1116 - mor_comp_thm mor_Abs_thm mor_fold_thm))
84.1117 - |> Thm.close_derivation;
84.1118 - in
84.1119 - `split_conj_thm unique_mor
84.1120 - end;
84.1121 -
84.1122 - val ctor_fold_unique_thms =
84.1123 - split_conj_thm (mk_conjIN n RS
84.1124 - (mor_UNIV_thm RS @{thm ssubst[of _ _ "%x. x"]} RS fold_unique_mor_thm))
84.1125 -
84.1126 - val fold_ctor_thms =
84.1127 - map (fn thm => (mor_incl_thm OF replicate n @{thm subset_UNIV}) RS thm RS sym)
84.1128 - fold_unique_mor_thms;
84.1129 -
84.1130 - val ctor_o_fold_thms =
84.1131 - let
84.1132 - val mor = mor_comp_thm OF [mor_fold_thm, mor_str_thm];
84.1133 - in
84.1134 - map2 (fn unique => fn fold_ctor =>
84.1135 - trans OF [mor RS unique, fold_ctor]) fold_unique_mor_thms fold_ctor_thms
84.1136 - end;
84.1137 -
84.1138 - val timer = time (timer "fold definitions & thms");
84.1139 -
84.1140 - val map_ctors = map2 (fn Ds => fn bnf =>
84.1141 - Term.list_comb (mk_map_of_bnf Ds (passiveAs @ FTs) (passiveAs @ Ts) bnf,
84.1142 - map HOLogic.id_const passiveAs @ ctors)) Dss bnfs;
84.1143 -
84.1144 - fun dtor_bind i = Binding.suffix_name ("_" ^ dtorN) (nth bs (i - 1));
84.1145 - val dtor_name = Binding.name_of o dtor_bind;
84.1146 - val dtor_def_bind = rpair [] o Thm.def_binding o dtor_bind;
84.1147 -
84.1148 - fun dtor_spec i FT T =
84.1149 - let
84.1150 - val dtorT = T --> FT;
84.1151 -
84.1152 - val lhs = Free (dtor_name i, dtorT);
84.1153 - val rhs = mk_fold Ts map_ctors i;
84.1154 - in
84.1155 - mk_Trueprop_eq (lhs, rhs)
84.1156 - end;
84.1157 -
84.1158 - val ((dtor_frees, (_, dtor_def_frees)), (lthy, lthy_old)) =
84.1159 - lthy
84.1160 - |> fold_map3 (fn i => fn FT => fn T =>
84.1161 - Specification.definition
84.1162 - (SOME (dtor_bind i, NONE, NoSyn), (dtor_def_bind i, dtor_spec i FT T))) ks FTs Ts
84.1163 - |>> apsnd split_list o split_list
84.1164 - ||> `Local_Theory.restore;
84.1165 -
84.1166 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.1167 - fun mk_dtors params =
84.1168 - map (Term.subst_atomic_types (map (Morphism.typ phi) params' ~~ params) o Morphism.term phi)
84.1169 - dtor_frees;
84.1170 - val dtors = mk_dtors params';
84.1171 - val dtor_defs = map (Morphism.thm phi) dtor_def_frees;
84.1172 -
84.1173 - val ctor_o_dtor_thms = map2 (fold_thms lthy o single) dtor_defs ctor_o_fold_thms;
84.1174 -
84.1175 - val dtor_o_ctor_thms =
84.1176 - let
84.1177 - fun mk_goal dtor ctor FT =
84.1178 - mk_Trueprop_eq (HOLogic.mk_comp (dtor, ctor), HOLogic.id_const FT);
84.1179 - val goals = map3 mk_goal dtors ctors FTs;
84.1180 - in
84.1181 - map5 (fn goal => fn dtor_def => fn foldx => fn map_comp_id => fn map_congL =>
84.1182 - Skip_Proof.prove lthy [] [] goal
84.1183 - (K (mk_dtor_o_ctor_tac dtor_def foldx map_comp_id map_congL ctor_o_fold_thms))
84.1184 - |> Thm.close_derivation)
84.1185 - goals dtor_defs ctor_fold_thms map_comp_id_thms map_congL_thms
84.1186 - end;
84.1187 -
84.1188 - val dtor_ctor_thms = map (fn thm => thm RS @{thm pointfree_idE}) dtor_o_ctor_thms;
84.1189 - val ctor_dtor_thms = map (fn thm => thm RS @{thm pointfree_idE}) ctor_o_dtor_thms;
84.1190 -
84.1191 - val bij_dtor_thms =
84.1192 - map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) ctor_o_dtor_thms dtor_o_ctor_thms;
84.1193 - val inj_dtor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_dtor_thms;
84.1194 - val surj_dtor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_dtor_thms;
84.1195 - val dtor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_dtor_thms;
84.1196 - val dtor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_dtor_thms;
84.1197 - val dtor_exhaust_thms = map (fn thm => thm RS exE) dtor_nchotomy_thms;
84.1198 -
84.1199 - val bij_ctor_thms =
84.1200 - map2 (fn thm1 => fn thm2 => @{thm o_bij} OF [thm1, thm2]) dtor_o_ctor_thms ctor_o_dtor_thms;
84.1201 - val inj_ctor_thms = map (fn thm => thm RS @{thm bij_is_inj}) bij_ctor_thms;
84.1202 - val surj_ctor_thms = map (fn thm => thm RS @{thm bij_is_surj}) bij_ctor_thms;
84.1203 - val ctor_nchotomy_thms = map (fn thm => thm RS @{thm surjD}) surj_ctor_thms;
84.1204 - val ctor_inject_thms = map (fn thm => thm RS @{thm inj_eq}) inj_ctor_thms;
84.1205 - val ctor_exhaust_thms = map (fn thm => thm RS exE) ctor_nchotomy_thms;
84.1206 -
84.1207 - val timer = time (timer "dtor definitions & thms");
84.1208 -
84.1209 - val fst_rec_pair_thms =
84.1210 - let
84.1211 - val mor = mor_comp_thm OF [mor_fold_thm, mor_convol_thm];
84.1212 - in
84.1213 - map2 (fn unique => fn fold_ctor =>
84.1214 - trans OF [mor RS unique, fold_ctor]) fold_unique_mor_thms fold_ctor_thms
84.1215 - end;
84.1216 -
84.1217 - fun rec_bind i = Binding.suffix_name ("_" ^ ctor_recN) (nth bs (i - 1));
84.1218 - val rec_name = Binding.name_of o rec_bind;
84.1219 - val rec_def_bind = rpair [] o Thm.def_binding o rec_bind;
84.1220 -
84.1221 - fun rec_spec i T AT =
84.1222 - let
84.1223 - val recT = Library.foldr (op -->) (rec_sTs, T --> AT);
84.1224 - val maps = map3 (fn ctor => fn prod_s => fn mapx =>
84.1225 - mk_convol (HOLogic.mk_comp (ctor, Term.list_comb (mapx, passive_ids @ rec_fsts)), prod_s))
84.1226 - ctors rec_ss rec_maps;
84.1227 -
84.1228 - val lhs = Term.list_comb (Free (rec_name i, recT), rec_ss);
84.1229 - val rhs = HOLogic.mk_comp (snd_const (HOLogic.mk_prodT (T, AT)), mk_fold Ts maps i);
84.1230 - in
84.1231 - mk_Trueprop_eq (lhs, rhs)
84.1232 - end;
84.1233 -
84.1234 - val ((rec_frees, (_, rec_def_frees)), (lthy, lthy_old)) =
84.1235 - lthy
84.1236 - |> fold_map3 (fn i => fn T => fn AT =>
84.1237 - Specification.definition
84.1238 - (SOME (rec_bind i, NONE, NoSyn), (rec_def_bind i, rec_spec i T AT)))
84.1239 - ks Ts activeAs
84.1240 - |>> apsnd split_list o split_list
84.1241 - ||> `Local_Theory.restore;
84.1242 -
84.1243 - val phi = Proof_Context.export_morphism lthy_old lthy;
84.1244 - val recs = map (Morphism.term phi) rec_frees;
84.1245 - val rec_names = map (fst o dest_Const) recs;
84.1246 - fun mk_rec ss i = Term.list_comb (Const (nth rec_names (i - 1), Library.foldr (op -->)
84.1247 - (map fastype_of ss, nth Ts (i - 1) --> range_type (fastype_of (nth ss (i - 1))))), ss);
84.1248 - val rec_defs = map (Morphism.thm phi) rec_def_frees;
84.1249 -
84.1250 - val convols = map2 (fn T => fn i => mk_convol (HOLogic.id_const T, mk_rec rec_ss i)) Ts ks;
84.1251 - val ctor_rec_thms =
84.1252 - let
84.1253 - fun mk_goal i rec_s rec_map ctor x =
84.1254 - let
84.1255 - val lhs = mk_rec rec_ss i $ (ctor $ x);
84.1256 - val rhs = rec_s $ (Term.list_comb (rec_map, passive_ids @ convols) $ x);
84.1257 - in
84.1258 - fold_rev Logic.all (x :: rec_ss) (mk_Trueprop_eq (lhs, rhs))
84.1259 - end;
84.1260 - val goals = map5 mk_goal ks rec_ss rec_maps_rev ctors xFs;
84.1261 - in
84.1262 - map2 (fn goal => fn foldx =>
84.1263 - Skip_Proof.prove lthy [] [] goal (mk_rec_tac rec_defs foldx fst_rec_pair_thms)
84.1264 - |> Thm.close_derivation)
84.1265 - goals ctor_fold_thms
84.1266 - end;
84.1267 -
84.1268 - val timer = time (timer "rec definitions & thms");
84.1269 -
84.1270 - val (ctor_induct_thm, induct_params) =
84.1271 - let
84.1272 - fun mk_prem phi ctor sets x =
84.1273 - let
84.1274 - fun mk_IH phi set z =
84.1275 - let
84.1276 - val prem = HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x));
84.1277 - val concl = HOLogic.mk_Trueprop (phi $ z);
84.1278 - in
84.1279 - Logic.all z (Logic.mk_implies (prem, concl))
84.1280 - end;
84.1281 -
84.1282 - val IHs = map3 mk_IH phis (drop m sets) Izs;
84.1283 - val concl = HOLogic.mk_Trueprop (phi $ (ctor $ x));
84.1284 - in
84.1285 - Logic.all x (Logic.list_implies (IHs, concl))
84.1286 - end;
84.1287 -
84.1288 - val prems = map4 mk_prem phis ctors FTs_setss xFs;
84.1289 -
84.1290 - fun mk_concl phi z = phi $ z;
84.1291 - val concl =
84.1292 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_concl phis Izs));
84.1293 -
84.1294 - val goal = Logic.list_implies (prems, concl);
84.1295 - in
84.1296 - (Skip_Proof.prove lthy [] []
84.1297 - (fold_rev Logic.all (phis @ Izs) goal)
84.1298 - (K (mk_ctor_induct_tac m set_natural'ss init_induct_thm morE_thms mor_Abs_thm
84.1299 - Rep_inverses Abs_inverses Reps))
84.1300 - |> Thm.close_derivation,
84.1301 - rev (Term.add_tfrees goal []))
84.1302 - end;
84.1303 -
84.1304 - val cTs = map (SOME o certifyT lthy o TFree) induct_params;
84.1305 -
84.1306 - val weak_ctor_induct_thms =
84.1307 - let fun insts i = (replicate (i - 1) TrueI) @ (@{thm asm_rl} :: replicate (n - i) TrueI);
84.1308 - in map (fn i => (ctor_induct_thm OF insts i) RS mk_conjunctN n i) ks end;
84.1309 -
84.1310 - val (ctor_induct2_thm, induct2_params) =
84.1311 - let
84.1312 - fun mk_prem phi ctor ctor' sets sets' x y =
84.1313 - let
84.1314 - fun mk_IH phi set set' z1 z2 =
84.1315 - let
84.1316 - val prem1 = HOLogic.mk_Trueprop (HOLogic.mk_mem (z1, (set $ x)));
84.1317 - val prem2 = HOLogic.mk_Trueprop (HOLogic.mk_mem (z2, (set' $ y)));
84.1318 - val concl = HOLogic.mk_Trueprop (phi $ z1 $ z2);
84.1319 - in
84.1320 - fold_rev Logic.all [z1, z2] (Logic.list_implies ([prem1, prem2], concl))
84.1321 - end;
84.1322 -
84.1323 - val IHs = map5 mk_IH phi2s (drop m sets) (drop m sets') Izs1 Izs2;
84.1324 - val concl = HOLogic.mk_Trueprop (phi $ (ctor $ x) $ (ctor' $ y));
84.1325 - in
84.1326 - fold_rev Logic.all [x, y] (Logic.list_implies (IHs, concl))
84.1327 - end;
84.1328 -
84.1329 - val prems = map7 mk_prem phi2s ctors ctor's FTs_setss FTs'_setss xFs yFs;
84.1330 -
84.1331 - fun mk_concl phi z1 z2 = phi $ z1 $ z2;
84.1332 - val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.1333 - (map3 mk_concl phi2s Izs1 Izs2));
84.1334 - fun mk_t phi (z1, z1') (z2, z2') =
84.1335 - Term.absfree z1' (HOLogic.mk_all (fst z2', snd z2', phi $ z1 $ z2));
84.1336 - val cts = map3 (SOME o certify lthy ooo mk_t) phi2s (Izs1 ~~ Izs1') (Izs2 ~~ Izs2');
84.1337 - val goal = Logic.list_implies (prems, concl);
84.1338 - in
84.1339 - (singleton (Proof_Context.export names_lthy lthy)
84.1340 - (Skip_Proof.prove lthy [] [] goal
84.1341 - (mk_ctor_induct2_tac cTs cts ctor_induct_thm weak_ctor_induct_thms))
84.1342 - |> Thm.close_derivation,
84.1343 - rev (Term.add_tfrees goal []))
84.1344 - end;
84.1345 -
84.1346 - val timer = time (timer "induction");
84.1347 -
84.1348 - (*register new datatypes as BNFs*)
84.1349 - val lthy = if m = 0 then lthy else
84.1350 - let
84.1351 - val fTs = map2 (curry op -->) passiveAs passiveBs;
84.1352 - val f1Ts = map2 (curry op -->) passiveAs passiveYs;
84.1353 - val f2Ts = map2 (curry op -->) passiveBs passiveYs;
84.1354 - val p1Ts = map2 (curry op -->) passiveXs passiveAs;
84.1355 - val p2Ts = map2 (curry op -->) passiveXs passiveBs;
84.1356 - val uTs = map2 (curry op -->) Ts Ts';
84.1357 - val B1Ts = map HOLogic.mk_setT passiveAs;
84.1358 - val B2Ts = map HOLogic.mk_setT passiveBs;
84.1359 - val AXTs = map HOLogic.mk_setT passiveXs;
84.1360 - val XTs = mk_Ts passiveXs;
84.1361 - val YTs = mk_Ts passiveYs;
84.1362 - val IRTs = map2 (curry mk_relT) passiveAs passiveBs;
84.1363 - val IphiTs = map2 mk_pred2T passiveAs passiveBs;
84.1364 -
84.1365 - val (((((((((((((((fs, fs'), fs_copy), us),
84.1366 - B1s), B2s), AXs), (xs, xs')), f1s), f2s), p1s), p2s), (ys, ys')), IRs), Iphis),
84.1367 - names_lthy) = names_lthy
84.1368 - |> mk_Frees' "f" fTs
84.1369 - ||>> mk_Frees "f" fTs
84.1370 - ||>> mk_Frees "u" uTs
84.1371 - ||>> mk_Frees "B1" B1Ts
84.1372 - ||>> mk_Frees "B2" B2Ts
84.1373 - ||>> mk_Frees "A" AXTs
84.1374 - ||>> mk_Frees' "x" XTs
84.1375 - ||>> mk_Frees "f1" f1Ts
84.1376 - ||>> mk_Frees "f2" f2Ts
84.1377 - ||>> mk_Frees "p1" p1Ts
84.1378 - ||>> mk_Frees "p2" p2Ts
84.1379 - ||>> mk_Frees' "y" passiveAs
84.1380 - ||>> mk_Frees "R" IRTs
84.1381 - ||>> mk_Frees "P" IphiTs;
84.1382 -
84.1383 - val map_FTFT's = map2 (fn Ds =>
84.1384 - mk_map_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
84.1385 - fun mk_passive_maps ATs BTs Ts =
84.1386 - map2 (fn Ds => mk_map_of_bnf Ds (ATs @ Ts) (BTs @ Ts)) Dss bnfs;
84.1387 - fun mk_map_fold_arg fs Ts ctor fmap =
84.1388 - HOLogic.mk_comp (ctor, Term.list_comb (fmap, fs @ map HOLogic.id_const Ts));
84.1389 - fun mk_map Ts fs Ts' ctors mk_maps =
84.1390 - mk_fold Ts (map2 (mk_map_fold_arg fs Ts') ctors (mk_maps Ts'));
84.1391 - val pmapsABT' = mk_passive_maps passiveAs passiveBs;
84.1392 - val fs_maps = map (mk_map Ts fs Ts' ctor's pmapsABT') ks;
84.1393 - val fs_copy_maps = map (mk_map Ts fs_copy Ts' ctor's pmapsABT') ks;
84.1394 - val Yctors = mk_ctors passiveYs;
84.1395 - val f1s_maps = map (mk_map Ts f1s YTs Yctors (mk_passive_maps passiveAs passiveYs)) ks;
84.1396 - val f2s_maps = map (mk_map Ts' f2s YTs Yctors (mk_passive_maps passiveBs passiveYs)) ks;
84.1397 - val p1s_maps = map (mk_map XTs p1s Ts ctors (mk_passive_maps passiveXs passiveAs)) ks;
84.1398 - val p2s_maps = map (mk_map XTs p2s Ts' ctor's (mk_passive_maps passiveXs passiveBs)) ks;
84.1399 -
84.1400 - val map_simp_thms =
84.1401 - let
84.1402 - fun mk_goal fs_map map ctor ctor' = fold_rev Logic.all fs
84.1403 - (mk_Trueprop_eq (HOLogic.mk_comp (fs_map, ctor),
84.1404 - HOLogic.mk_comp (ctor', Term.list_comb (map, fs @ fs_maps))));
84.1405 - val goals = map4 mk_goal fs_maps map_FTFT's ctors ctor's;
84.1406 - val maps =
84.1407 - map4 (fn goal => fn foldx => fn map_comp_id => fn map_cong =>
84.1408 - Skip_Proof.prove lthy [] [] goal (K (mk_map_tac m n foldx map_comp_id map_cong))
84.1409 - |> Thm.close_derivation)
84.1410 - goals ctor_fold_thms map_comp_id_thms map_congs;
84.1411 - in
84.1412 - map (fn thm => thm RS @{thm pointfreeE}) maps
84.1413 - end;
84.1414 -
84.1415 - val (map_unique_thms, map_unique_thm) =
84.1416 - let
84.1417 - fun mk_prem u map ctor ctor' =
84.1418 - mk_Trueprop_eq (HOLogic.mk_comp (u, ctor),
84.1419 - HOLogic.mk_comp (ctor', Term.list_comb (map, fs @ us)));
84.1420 - val prems = map4 mk_prem us map_FTFT's ctors ctor's;
84.1421 - val goal =
84.1422 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.1423 - (map2 (curry HOLogic.mk_eq) us fs_maps));
84.1424 - val unique = Skip_Proof.prove lthy [] []
84.1425 - (fold_rev Logic.all (us @ fs) (Logic.list_implies (prems, goal)))
84.1426 - (K (mk_map_unique_tac m mor_def fold_unique_mor_thm map_comp_id_thms map_congs))
84.1427 - |> Thm.close_derivation;
84.1428 - in
84.1429 - `split_conj_thm unique
84.1430 - end;
84.1431 -
84.1432 - val timer = time (timer "map functions for the new datatypes");
84.1433 -
84.1434 - val bd = mk_cpow sum_bd;
84.1435 - val bd_Cinfinite = sum_Cinfinite RS @{thm Cinfinite_cpow};
84.1436 - fun mk_cpow_bd thm = @{thm ordLeq_transitive} OF
84.1437 - [thm, sum_Card_order RS @{thm cpow_greater_eq}];
84.1438 - val set_bd_cpowss = map (map mk_cpow_bd) set_bd_sumss;
84.1439 -
84.1440 - val timer = time (timer "bounds for the new datatypes");
84.1441 -
84.1442 - val ls = 1 upto m;
84.1443 - val setsss = map (mk_setss o mk_set_Ts) passiveAs;
84.1444 - val map_setss = map (fn T => map2 (fn Ds =>
84.1445 - mk_map_of_bnf Ds (passiveAs @ Ts) (mk_set_Ts T)) Dss bnfs) passiveAs;
84.1446 -
84.1447 - fun mk_col l T z z' sets =
84.1448 - let
84.1449 - fun mk_UN set = mk_Union T $ (set $ z);
84.1450 - in
84.1451 - Term.absfree z'
84.1452 - (mk_union (nth sets (l - 1) $ z,
84.1453 - Library.foldl1 mk_union (map mk_UN (drop m sets))))
84.1454 - end;
84.1455 -
84.1456 - val colss = map5 (fn l => fn T => map3 (mk_col l T)) ls passiveAs AFss AFss' setsss;
84.1457 - val setss_by_range = map (fn cols => map (mk_fold Ts cols) ks) colss;
84.1458 - val setss_by_bnf = transpose setss_by_range;
84.1459 -
84.1460 - val set_simp_thmss =
84.1461 - let
84.1462 - fun mk_goal sets ctor set col map =
84.1463 - mk_Trueprop_eq (HOLogic.mk_comp (set, ctor),
84.1464 - HOLogic.mk_comp (col, Term.list_comb (map, passive_ids @ sets)));
84.1465 - val goalss =
84.1466 - map3 (fn sets => map4 (mk_goal sets) ctors sets) setss_by_range colss map_setss;
84.1467 - val setss = map (map2 (fn foldx => fn goal =>
84.1468 - Skip_Proof.prove lthy [] [] goal (K (mk_set_tac foldx)) |> Thm.close_derivation)
84.1469 - ctor_fold_thms) goalss;
84.1470 -
84.1471 - fun mk_simp_goal pas_set act_sets sets ctor z set =
84.1472 - Logic.all z (mk_Trueprop_eq (set $ (ctor $ z),
84.1473 - mk_union (pas_set $ z,
84.1474 - Library.foldl1 mk_union (map2 (fn X => mk_UNION (X $ z)) act_sets sets))));
84.1475 - val simp_goalss =
84.1476 - map2 (fn i => fn sets =>
84.1477 - map4 (fn Fsets => mk_simp_goal (nth Fsets (i - 1)) (drop m Fsets) sets)
84.1478 - FTs_setss ctors xFs sets)
84.1479 - ls setss_by_range;
84.1480 -
84.1481 - val set_simpss = map3 (fn i => map3 (fn set_nats => fn goal => fn set =>
84.1482 - Skip_Proof.prove lthy [] [] goal
84.1483 - (K (mk_set_simp_tac set (nth set_nats (i - 1)) (drop m set_nats)))
84.1484 - |> Thm.close_derivation)
84.1485 - set_natural'ss) ls simp_goalss setss;
84.1486 - in
84.1487 - set_simpss
84.1488 - end;
84.1489 -
84.1490 - fun mk_set_thms set_simp = (@{thm xt1(3)} OF [set_simp, @{thm Un_upper1}]) ::
84.1491 - map (fn i => (@{thm xt1(3)} OF [set_simp, @{thm Un_upper2}]) RS
84.1492 - (mk_Un_upper n i RS subset_trans) RSN
84.1493 - (2, @{thm UN_upper} RS subset_trans))
84.1494 - (1 upto n);
84.1495 - val Fset_set_thmsss = transpose (map (map mk_set_thms) set_simp_thmss);
84.1496 -
84.1497 - val timer = time (timer "set functions for the new datatypes");
84.1498 -
84.1499 - val cxs = map (SOME o certify lthy) Izs;
84.1500 - val setss_by_bnf' =
84.1501 - map (map (Term.subst_atomic_types (passiveAs ~~ passiveBs))) setss_by_bnf;
84.1502 - val setss_by_range' = transpose setss_by_bnf';
84.1503 -
84.1504 - val set_natural_thmss =
84.1505 - let
84.1506 - fun mk_set_natural f map z set set' =
84.1507 - HOLogic.mk_eq (mk_image f $ (set $ z), set' $ (map $ z));
84.1508 -
84.1509 - fun mk_cphi f map z set set' = certify lthy
84.1510 - (Term.absfree (dest_Free z) (mk_set_natural f map z set set'));
84.1511 -
84.1512 - val csetss = map (map (certify lthy)) setss_by_range';
84.1513 -
84.1514 - val cphiss = map3 (fn f => fn sets => fn sets' =>
84.1515 - (map4 (mk_cphi f) fs_maps Izs sets sets')) fs setss_by_range setss_by_range';
84.1516 -
84.1517 - val inducts = map (fn cphis =>
84.1518 - Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm) cphiss;
84.1519 -
84.1520 - val goals =
84.1521 - map3 (fn f => fn sets => fn sets' =>
84.1522 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.1523 - (map4 (mk_set_natural f) fs_maps Izs sets sets')))
84.1524 - fs setss_by_range setss_by_range';
84.1525 -
84.1526 - fun mk_tac induct = mk_set_nat_tac m (rtac induct) set_natural'ss map_simp_thms;
84.1527 - val thms =
84.1528 - map5 (fn goal => fn csets => fn set_simps => fn induct => fn i =>
84.1529 - singleton (Proof_Context.export names_lthy lthy)
84.1530 - (Skip_Proof.prove lthy [] [] goal (mk_tac induct csets set_simps i))
84.1531 - |> Thm.close_derivation)
84.1532 - goals csetss set_simp_thmss inducts ls;
84.1533 - in
84.1534 - map split_conj_thm thms
84.1535 - end;
84.1536 -
84.1537 - val set_bd_thmss =
84.1538 - let
84.1539 - fun mk_set_bd z set = mk_ordLeq (mk_card_of (set $ z)) bd;
84.1540 -
84.1541 - fun mk_cphi z set = certify lthy (Term.absfree (dest_Free z) (mk_set_bd z set));
84.1542 -
84.1543 - val cphiss = map (map2 mk_cphi Izs) setss_by_range;
84.1544 -
84.1545 - val inducts = map (fn cphis =>
84.1546 - Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm) cphiss;
84.1547 -
84.1548 - val goals =
84.1549 - map (fn sets =>
84.1550 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.1551 - (map2 mk_set_bd Izs sets))) setss_by_range;
84.1552 -
84.1553 - fun mk_tac induct = mk_set_bd_tac m (rtac induct) bd_Cinfinite set_bd_cpowss;
84.1554 - val thms =
84.1555 - map4 (fn goal => fn set_simps => fn induct => fn i =>
84.1556 - singleton (Proof_Context.export names_lthy lthy)
84.1557 - (Skip_Proof.prove lthy [] [] goal (mk_tac induct set_simps i))
84.1558 - |> Thm.close_derivation)
84.1559 - goals set_simp_thmss inducts ls;
84.1560 - in
84.1561 - map split_conj_thm thms
84.1562 - end;
84.1563 -
84.1564 - val map_cong_thms =
84.1565 - let
84.1566 - fun mk_prem z set f g y y' =
84.1567 - mk_Ball (set $ z) (Term.absfree y' (HOLogic.mk_eq (f $ y, g $ y)));
84.1568 -
84.1569 - fun mk_map_cong sets z fmap gmap =
84.1570 - HOLogic.mk_imp
84.1571 - (Library.foldr1 HOLogic.mk_conj (map5 (mk_prem z) sets fs fs_copy ys ys'),
84.1572 - HOLogic.mk_eq (fmap $ z, gmap $ z));
84.1573 -
84.1574 - fun mk_cphi sets z fmap gmap =
84.1575 - certify lthy (Term.absfree (dest_Free z) (mk_map_cong sets z fmap gmap));
84.1576 -
84.1577 - val cphis = map4 mk_cphi setss_by_bnf Izs fs_maps fs_copy_maps;
84.1578 -
84.1579 - val induct = Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm;
84.1580 -
84.1581 - val goal =
84.1582 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.1583 - (map4 mk_map_cong setss_by_bnf Izs fs_maps fs_copy_maps));
84.1584 -
84.1585 - val thm = singleton (Proof_Context.export names_lthy lthy)
84.1586 - (Skip_Proof.prove lthy [] [] goal
84.1587 - (mk_mcong_tac (rtac induct) Fset_set_thmsss map_congs map_simp_thms))
84.1588 - |> Thm.close_derivation;
84.1589 - in
84.1590 - split_conj_thm thm
84.1591 - end;
84.1592 -
84.1593 - val in_incl_min_alg_thms =
84.1594 - let
84.1595 - fun mk_prem z sets =
84.1596 - HOLogic.mk_mem (z, mk_in As sets (fastype_of z));
84.1597 -
84.1598 - fun mk_incl z sets i =
84.1599 - HOLogic.mk_imp (mk_prem z sets, HOLogic.mk_mem (z, mk_min_alg As ctors i));
84.1600 -
84.1601 - fun mk_cphi z sets i =
84.1602 - certify lthy (Term.absfree (dest_Free z) (mk_incl z sets i));
84.1603 -
84.1604 - val cphis = map3 mk_cphi Izs setss_by_bnf ks;
84.1605 -
84.1606 - val induct = Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct_thm;
84.1607 -
84.1608 - val goal =
84.1609 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
84.1610 - (map3 mk_incl Izs setss_by_bnf ks));
84.1611 -
84.1612 - val thm = singleton (Proof_Context.export names_lthy lthy)
84.1613 - (Skip_Proof.prove lthy [] [] goal
84.1614 - (mk_incl_min_alg_tac (rtac induct) Fset_set_thmsss alg_set_thms alg_min_alg_thm))
84.1615 - |> Thm.close_derivation;
84.1616 - in
84.1617 - split_conj_thm thm
84.1618 - end;
84.1619 -
84.1620 - val Xsetss = map (map (Term.subst_atomic_types (passiveAs ~~ passiveXs))) setss_by_bnf;
84.1621 -
84.1622 - val map_wpull_thms =
84.1623 - let
84.1624 - val cTs = map (SOME o certifyT lthy o TFree) induct2_params;
84.1625 - val cxs = map (SOME o certify lthy) (interleave Izs1 Izs2);
84.1626 -
84.1627 - fun mk_prem z1 z2 sets1 sets2 map1 map2 =
84.1628 - HOLogic.mk_conj
84.1629 - (HOLogic.mk_mem (z1, mk_in B1s sets1 (fastype_of z1)),
84.1630 - HOLogic.mk_conj
84.1631 - (HOLogic.mk_mem (z2, mk_in B2s sets2 (fastype_of z2)),
84.1632 - HOLogic.mk_eq (map1 $ z1, map2 $ z2)));
84.1633 -
84.1634 - val prems = map6 mk_prem Izs1 Izs2 setss_by_bnf setss_by_bnf' f1s_maps f2s_maps;
84.1635 -
84.1636 - fun mk_concl z1 z2 sets map1 map2 T x x' =
84.1637 - mk_Bex (mk_in AXs sets T) (Term.absfree x'
84.1638 - (HOLogic.mk_conj (HOLogic.mk_eq (map1 $ x, z1), HOLogic.mk_eq (map2 $ x, z2))));
84.1639 -
84.1640 - val concls = map8 mk_concl Izs1 Izs2 Xsetss p1s_maps p2s_maps XTs xs xs';
84.1641 -
84.1642 - val goals = map2 (curry HOLogic.mk_imp) prems concls;
84.1643 -
84.1644 - fun mk_cphi z1 z2 goal = certify lthy (Term.absfree z1 (Term.absfree z2 goal));
84.1645 -
84.1646 - val cphis = map3 mk_cphi Izs1' Izs2' goals;
84.1647 -
84.1648 - val induct = Drule.instantiate' cTs (map SOME cphis @ cxs) ctor_induct2_thm;
84.1649 -
84.1650 - val goal = Logic.list_implies (map HOLogic.mk_Trueprop
84.1651 - (map8 mk_wpull AXs B1s B2s f1s f2s (replicate m NONE) p1s p2s),
84.1652 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj goals));
84.1653 -
84.1654 - val thm = singleton (Proof_Context.export names_lthy lthy)
84.1655 - (Skip_Proof.prove lthy [] [] goal
84.1656 - (K (mk_lfp_map_wpull_tac m (rtac induct) map_wpulls map_simp_thms
84.1657 - (transpose set_simp_thmss) Fset_set_thmsss ctor_inject_thms)))
84.1658 - |> Thm.close_derivation;
84.1659 - in
84.1660 - split_conj_thm thm
84.1661 - end;
84.1662 -
84.1663 - val timer = time (timer "helpers for BNF properties");
84.1664 -
84.1665 - val map_id_tacs = map (K o mk_map_id_tac map_ids) map_unique_thms;
84.1666 - val map_comp_tacs =
84.1667 - map2 (K oo mk_map_comp_tac map_comp's map_simp_thms) map_unique_thms ks;
84.1668 - val map_cong_tacs = map (mk_map_cong_tac m) map_cong_thms;
84.1669 - val set_nat_tacss = map (map (K o mk_set_natural_tac)) (transpose set_natural_thmss);
84.1670 - val bd_co_tacs = replicate n (K (mk_bd_card_order_tac bd_card_orders));
84.1671 - val bd_cinf_tacs = replicate n (K (rtac (bd_Cinfinite RS conjunct1) 1));
84.1672 - val set_bd_tacss = map (map (fn thm => K (rtac thm 1))) (transpose set_bd_thmss);
84.1673 - val in_bd_tacs = map2 (K oo mk_in_bd_tac sum_Card_order suc_bd_Cnotzero)
84.1674 - in_incl_min_alg_thms card_of_min_alg_thms;
84.1675 - val map_wpull_tacs = map (K o mk_wpull_tac) map_wpull_thms;
84.1676 -
84.1677 - val srel_O_Gr_tacs = replicate n (simple_srel_O_Gr_tac o #context);
84.1678 -
84.1679 - val tacss = map10 zip_axioms map_id_tacs map_comp_tacs map_cong_tacs set_nat_tacss
84.1680 - bd_co_tacs bd_cinf_tacs set_bd_tacss in_bd_tacs map_wpull_tacs srel_O_Gr_tacs;
84.1681 -
84.1682 - val ctor_witss =
84.1683 - let
84.1684 - val witss = map2 (fn Ds => fn bnf => mk_wits_of_bnf
84.1685 - (replicate (nwits_of_bnf bnf) Ds)
84.1686 - (replicate (nwits_of_bnf bnf) (passiveAs @ Ts)) bnf) Dss bnfs;
84.1687 - fun close_wit (I, wit) = fold_rev Term.absfree (map (nth ys') I) wit;
84.1688 - fun wit_apply (arg_I, arg_wit) (fun_I, fun_wit) =
84.1689 - (union (op =) arg_I fun_I, fun_wit $ arg_wit);
84.1690 -
84.1691 - fun gen_arg support i =
84.1692 - if i < m then [([i], nth ys i)]
84.1693 - else maps (mk_wit support (nth ctors (i - m)) (i - m)) (nth support (i - m))
84.1694 - and mk_wit support ctor i (I, wit) =
84.1695 - let val args = map (gen_arg (nth_map i (remove (op =) (I, wit)) support)) I;
84.1696 - in
84.1697 - (args, [([], wit)])
84.1698 - |-> fold (map_product wit_apply)
84.1699 - |> map (apsnd (fn t => ctor $ t))
84.1700 - |> minimize_wits
84.1701 - end;
84.1702 - in
84.1703 - map3 (fn ctor => fn i => map close_wit o minimize_wits o maps (mk_wit witss ctor i))
84.1704 - ctors (0 upto n - 1) witss
84.1705 - end;
84.1706 -
84.1707 - fun wit_tac _ = mk_wit_tac n (flat set_simp_thmss) (maps wit_thms_of_bnf bnfs);
84.1708 -
84.1709 - val policy = user_policy Derive_All_Facts_Note_Most;
84.1710 -
84.1711 - val (Ibnfs, lthy) =
84.1712 - fold_map6 (fn tacs => fn b => fn mapx => fn sets => fn T => fn wits => fn lthy =>
84.1713 - bnf_def Dont_Inline policy I tacs wit_tac (SOME deads)
84.1714 - (((((b, fold_rev Term.absfree fs' mapx), sets), absdummy T bd), wits), NONE) lthy
84.1715 - |> register_bnf (Local_Theory.full_name lthy b))
84.1716 - tacss bs fs_maps setss_by_bnf Ts ctor_witss lthy;
84.1717 -
84.1718 - val fold_maps = fold_thms lthy (map (fn bnf =>
84.1719 - mk_unabs_def m (map_def_of_bnf bnf RS @{thm meta_eq_to_obj_eq})) Ibnfs);
84.1720 -
84.1721 - val fold_sets = fold_thms lthy (maps (fn bnf =>
84.1722 - map (fn thm => thm RS @{thm meta_eq_to_obj_eq}) (set_defs_of_bnf bnf)) Ibnfs);
84.1723 -
84.1724 - val timer = time (timer "registered new datatypes as BNFs");
84.1725 -
84.1726 - val srels = map2 (fn Ds => mk_srel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
84.1727 - val Isrels = map (mk_srel_of_bnf deads passiveAs passiveBs) Ibnfs;
84.1728 - val rels = map2 (fn Ds => mk_rel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs;
84.1729 - val Irels = map (mk_rel_of_bnf deads passiveAs passiveBs) Ibnfs;
84.1730 -
84.1731 - val IrelRs = map (fn Isrel => Term.list_comb (Isrel, IRs)) Isrels;
84.1732 - val relRs = map (fn srel => Term.list_comb (srel, IRs @ IrelRs)) srels;
84.1733 - val Ipredphis = map (fn Isrel => Term.list_comb (Isrel, Iphis)) Irels;
84.1734 - val predphis = map (fn srel => Term.list_comb (srel, Iphis @ Ipredphis)) rels;
84.1735 -
84.1736 - val in_srels = map in_srel_of_bnf bnfs;
84.1737 - val in_Isrels = map in_srel_of_bnf Ibnfs;
84.1738 - val srel_defs = map srel_def_of_bnf bnfs;
84.1739 - val Isrel_defs = map srel_def_of_bnf Ibnfs;
84.1740 - val Irel_defs = map rel_def_of_bnf Ibnfs;
84.1741 -
84.1742 - val set_incl_thmss = map (map (fold_sets o hd)) Fset_set_thmsss;
84.1743 - val set_set_incl_thmsss = map (transpose o map (map fold_sets o tl)) Fset_set_thmsss;
84.1744 - val folded_map_simp_thms = map fold_maps map_simp_thms;
84.1745 - val folded_set_simp_thmss = map (map fold_sets) set_simp_thmss;
84.1746 - val folded_set_simp_thmss' = transpose folded_set_simp_thmss;
84.1747 -
84.1748 - val Isrel_simp_thms =
84.1749 - let
84.1750 - fun mk_goal xF yF ctor ctor' IrelR relR = fold_rev Logic.all (xF :: yF :: IRs)
84.1751 - (mk_Trueprop_eq (HOLogic.mk_mem (HOLogic.mk_prod (ctor $ xF, ctor' $ yF), IrelR),
84.1752 - HOLogic.mk_mem (HOLogic.mk_prod (xF, yF), relR)));
84.1753 - val goals = map6 mk_goal xFs yFs ctors ctor's IrelRs relRs;
84.1754 - in
84.1755 - map12 (fn i => fn goal => fn in_srel => fn map_comp => fn map_cong =>
84.1756 - fn map_simp => fn set_simps => fn ctor_inject => fn ctor_dtor =>
84.1757 - fn set_naturals => fn set_incls => fn set_set_inclss =>
84.1758 - Skip_Proof.prove lthy [] [] goal
84.1759 - (K (mk_srel_simp_tac in_Isrels i in_srel map_comp map_cong map_simp set_simps
84.1760 - ctor_inject ctor_dtor set_naturals set_incls set_set_inclss))
84.1761 - |> Thm.close_derivation)
84.1762 - ks goals in_srels map_comp's map_congs folded_map_simp_thms folded_set_simp_thmss'
84.1763 - ctor_inject_thms ctor_dtor_thms set_natural'ss set_incl_thmss set_set_incl_thmsss
84.1764 - end;
84.1765 -
84.1766 - val Irel_simp_thms =
84.1767 - let
84.1768 - fun mk_goal xF yF ctor ctor' Ipredphi predphi = fold_rev Logic.all (xF :: yF :: Iphis)
84.1769 - (mk_Trueprop_eq (Ipredphi $ (ctor $ xF) $ (ctor' $ yF), predphi $ xF $ yF));
84.1770 - val goals = map6 mk_goal xFs yFs ctors ctor's Ipredphis predphis;
84.1771 - in
84.1772 - map3 (fn goal => fn srel_def => fn Isrel_simp =>
84.1773 - Skip_Proof.prove lthy [] [] goal
84.1774 - (mk_rel_simp_tac srel_def Irel_defs Isrel_defs Isrel_simp)
84.1775 - |> Thm.close_derivation)
84.1776 - goals srel_defs Isrel_simp_thms
84.1777 - end;
84.1778 -
84.1779 - val timer = time (timer "additional properties");
84.1780 -
84.1781 - val ls' = if m = 1 then [0] else ls
84.1782 -
84.1783 - val Ibnf_common_notes =
84.1784 - [(map_uniqueN, [fold_maps map_unique_thm])]
84.1785 - |> map (fn (thmN, thms) =>
84.1786 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
84.1787 -
84.1788 - val Ibnf_notes =
84.1789 - [(map_simpsN, map single folded_map_simp_thms),
84.1790 - (set_inclN, set_incl_thmss),
84.1791 - (set_set_inclN, map flat set_set_incl_thmsss),
84.1792 - (srel_simpN, map single Isrel_simp_thms),
84.1793 - (rel_simpN, map single Irel_simp_thms)] @
84.1794 - map2 (fn i => fn thms => (mk_set_simpsN i, map single thms)) ls' folded_set_simp_thmss
84.1795 - |> maps (fn (thmN, thmss) =>
84.1796 - map2 (fn b => fn thms =>
84.1797 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
84.1798 - bs thmss)
84.1799 - in
84.1800 - timer; lthy |> Local_Theory.notes (Ibnf_common_notes @ Ibnf_notes) |> snd
84.1801 - end;
84.1802 -
84.1803 - val common_notes =
84.1804 - [(ctor_inductN, [ctor_induct_thm]),
84.1805 - (ctor_induct2N, [ctor_induct2_thm])]
84.1806 - |> map (fn (thmN, thms) =>
84.1807 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]));
84.1808 -
84.1809 - val notes =
84.1810 - [(ctor_dtorN, ctor_dtor_thms),
84.1811 - (ctor_exhaustN, ctor_exhaust_thms),
84.1812 - (ctor_fold_uniqueN, ctor_fold_unique_thms),
84.1813 - (ctor_foldsN, ctor_fold_thms),
84.1814 - (ctor_injectN, ctor_inject_thms),
84.1815 - (ctor_recsN, ctor_rec_thms),
84.1816 - (dtor_ctorN, dtor_ctor_thms),
84.1817 - (dtor_exhaustN, dtor_exhaust_thms),
84.1818 - (dtor_injectN, dtor_inject_thms)]
84.1819 - |> map (apsnd (map single))
84.1820 - |> maps (fn (thmN, thmss) =>
84.1821 - map2 (fn b => fn thms =>
84.1822 - ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
84.1823 - bs thmss)
84.1824 - in
84.1825 - ((dtors, ctors, folds, recs, ctor_induct_thm, dtor_ctor_thms, ctor_dtor_thms, ctor_inject_thms,
84.1826 - ctor_fold_thms, ctor_rec_thms),
84.1827 - lthy |> Local_Theory.notes (common_notes @ notes) |> snd)
84.1828 - end;
84.1829 -
84.1830 -val _ =
84.1831 - Outer_Syntax.local_theory @{command_spec "data_raw"}
84.1832 - "define BNF-based inductive datatypes (low-level)"
84.1833 - (Parse.and_list1
84.1834 - ((Parse.binding --| @{keyword ":"}) -- (Parse.typ --| @{keyword "="} -- Parse.typ)) >>
84.1835 - (snd oo fp_bnf_cmd bnf_lfp o apsnd split_list o split_list));
84.1836 -
84.1837 -val _ =
84.1838 - Outer_Syntax.local_theory @{command_spec "data"} "define BNF-based inductive datatypes"
84.1839 - (parse_datatype_cmd true bnf_lfp);
84.1840 -
84.1841 -end;
85.1 --- a/src/HOL/Codatatype/Tools/bnf_lfp_tactics.ML Fri Sep 21 16:34:40 2012 +0200
85.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
85.3 @@ -1,835 +0,0 @@
85.4 -(* Title: HOL/BNF/Tools/bnf_lfp_tactics.ML
85.5 - Author: Dmitriy Traytel, TU Muenchen
85.6 - Author: Andrei Popescu, TU Muenchen
85.7 - Copyright 2012
85.8 -
85.9 -Tactics for the datatype construction.
85.10 -*)
85.11 -
85.12 -signature BNF_LFP_TACTICS =
85.13 -sig
85.14 - val mk_alg_min_alg_tac: int -> thm -> thm list -> thm -> thm -> thm list list -> thm list ->
85.15 - thm list -> tactic
85.16 - val mk_alg_not_empty_tac: thm -> thm list -> thm list -> tactic
85.17 - val mk_alg_select_tac: thm -> {prems: 'a, context: Proof.context} -> tactic
85.18 - val mk_alg_set_tac: thm -> tactic
85.19 - val mk_bd_card_order_tac: thm list -> tactic
85.20 - val mk_bd_limit_tac: int -> thm -> tactic
85.21 - val mk_card_of_min_alg_tac: thm -> thm -> thm -> thm -> thm -> tactic
85.22 - val mk_copy_alg_tac: thm list list -> thm list -> thm -> thm -> thm -> tactic
85.23 - val mk_copy_str_tac: thm list list -> thm -> thm list -> tactic
85.24 - val mk_ctor_induct_tac: int -> thm list list -> thm -> thm list -> thm -> thm list -> thm list ->
85.25 - thm list -> tactic
85.26 - val mk_ctor_induct2_tac: ctyp option list -> cterm option list -> thm -> thm list ->
85.27 - {prems: 'a, context: Proof.context} -> tactic
85.28 - val mk_dtor_o_ctor_tac: thm -> thm -> thm -> thm -> thm list -> tactic
85.29 - val mk_ex_copy_alg_tac: int -> thm -> thm -> tactic
85.30 - val mk_in_bd_tac: thm -> thm -> thm -> thm -> tactic
85.31 - val mk_incl_min_alg_tac: (int -> tactic) -> thm list list list -> thm list -> thm ->
85.32 - {prems: 'a, context: Proof.context} -> tactic
85.33 - val mk_init_ex_mor_tac: thm -> thm -> thm -> thm list -> thm -> thm -> thm ->
85.34 - {prems: 'a, context: Proof.context} -> tactic
85.35 - val mk_init_induct_tac: int -> thm -> thm -> thm list -> thm list -> tactic
85.36 - val mk_init_unique_mor_tac: int -> thm -> thm -> thm list -> thm list -> thm list -> thm list ->
85.37 - thm list -> tactic
85.38 - val mk_iso_alt_tac: thm list -> thm -> tactic
85.39 - val mk_fold_unique_mor_tac: thm list -> thm list -> thm list -> thm -> thm -> thm -> tactic
85.40 - val mk_least_min_alg_tac: thm -> thm -> tactic
85.41 - val mk_lfp_map_wpull_tac: int -> (int -> tactic) -> thm list -> thm list -> thm list list ->
85.42 - thm list list list -> thm list -> tactic
85.43 - val mk_map_comp_tac: thm list -> thm list -> thm -> int -> tactic
85.44 - val mk_map_id_tac: thm list -> thm -> tactic
85.45 - val mk_map_tac: int -> int -> thm -> thm -> thm -> tactic
85.46 - val mk_map_unique_tac: int -> thm -> thm -> thm list -> thm list -> tactic
85.47 - val mk_mcong_tac: (int -> tactic) -> thm list list list -> thm list -> thm list ->
85.48 - {prems: 'a, context: Proof.context} -> tactic
85.49 - val mk_min_algs_card_of_tac: ctyp -> cterm -> int -> thm -> thm list -> thm list -> thm -> thm ->
85.50 - thm -> thm -> thm -> thm -> thm -> thm -> tactic
85.51 - val mk_min_algs_least_tac: ctyp -> cterm -> thm -> thm list -> thm list -> tactic
85.52 - val mk_min_algs_mono_tac: thm -> tactic
85.53 - val mk_min_algs_tac: thm -> thm list -> tactic
85.54 - val mk_mor_Abs_tac: thm -> thm list -> thm list -> tactic
85.55 - val mk_mor_Rep_tac: thm list -> thm -> thm list -> thm list -> thm list ->
85.56 - {prems: 'a, context: Proof.context} -> tactic
85.57 - val mk_mor_UNIV_tac: int -> thm list -> thm -> tactic
85.58 - val mk_mor_comp_tac: thm -> thm list list -> thm list -> tactic
85.59 - val mk_mor_convol_tac: 'a list -> thm -> tactic
85.60 - val mk_mor_elim_tac: thm -> tactic
85.61 - val mk_mor_incl_tac: thm -> thm list -> tactic
85.62 - val mk_mor_inv_tac: thm -> thm -> thm list list -> thm list -> thm list -> thm list -> tactic
85.63 - val mk_mor_fold_tac: ctyp -> cterm -> thm list -> thm -> thm -> tactic
85.64 - val mk_mor_select_tac: thm -> thm -> thm -> thm -> thm -> thm -> thm list -> thm list list ->
85.65 - thm list -> tactic
85.66 - val mk_mor_str_tac: 'a list -> thm -> tactic
85.67 - val mk_rec_tac: thm list -> thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
85.68 - val mk_set_bd_tac: int -> (int -> tactic) -> thm -> thm list list -> thm list -> int ->
85.69 - {prems: 'a, context: Proof.context} -> tactic
85.70 - val mk_set_nat_tac: int -> (int -> tactic) -> thm list list -> thm list -> cterm list ->
85.71 - thm list -> int -> {prems: 'a, context: Proof.context} -> tactic
85.72 - val mk_set_natural_tac: thm -> tactic
85.73 - val mk_set_simp_tac: thm -> thm -> thm list -> tactic
85.74 - val mk_set_tac: thm -> tactic
85.75 - val mk_srel_simp_tac: thm list -> int -> thm -> thm -> thm -> thm -> thm list -> thm ->
85.76 - thm -> thm list -> thm list -> thm list list -> tactic
85.77 - val mk_wit_tac: int -> thm list -> thm list -> tactic
85.78 - val mk_wpull_tac: thm -> tactic
85.79 -end;
85.80 -
85.81 -structure BNF_LFP_Tactics : BNF_LFP_TACTICS =
85.82 -struct
85.83 -
85.84 -open BNF_Tactics
85.85 -open BNF_LFP_Util
85.86 -open BNF_Util
85.87 -
85.88 -val fst_snd_convs = @{thms fst_conv snd_conv};
85.89 -val id_apply = @{thm id_apply};
85.90 -val meta_mp = @{thm meta_mp};
85.91 -val ord_eq_le_trans = @{thm ord_eq_le_trans};
85.92 -val subset_trans = @{thm subset_trans};
85.93 -val trans_fun_cong_image_id_id_apply = @{thm trans[OF fun_cong[OF image_id] id_apply]};
85.94 -
85.95 -fun mk_alg_set_tac alg_def =
85.96 - dtac (alg_def RS iffD1) 1 THEN
85.97 - REPEAT_DETERM (etac conjE 1) THEN
85.98 - EVERY' [etac bspec, rtac CollectI] 1 THEN
85.99 - REPEAT_DETERM (etac conjI 1) THEN atac 1;
85.100 -
85.101 -fun mk_alg_not_empty_tac alg_set alg_sets wits =
85.102 - (EVERY' [rtac notI, hyp_subst_tac, ftac alg_set] THEN'
85.103 - REPEAT_DETERM o FIRST'
85.104 - [rtac subset_UNIV,
85.105 - EVERY' [rtac @{thm subset_emptyI}, eresolve_tac wits],
85.106 - EVERY' [rtac subsetI, rtac FalseE, eresolve_tac wits],
85.107 - EVERY' [rtac subsetI, dresolve_tac wits, hyp_subst_tac,
85.108 - FIRST' (map (fn thm => rtac thm THEN' atac) alg_sets)]] THEN'
85.109 - etac @{thm emptyE}) 1;
85.110 -
85.111 -fun mk_mor_elim_tac mor_def =
85.112 - (dtac (subst OF [mor_def]) THEN'
85.113 - REPEAT o etac conjE THEN'
85.114 - TRY o rtac @{thm image_subsetI} THEN'
85.115 - etac bspec THEN'
85.116 - atac) 1;
85.117 -
85.118 -fun mk_mor_incl_tac mor_def map_id's =
85.119 - (stac mor_def THEN'
85.120 - rtac conjI THEN'
85.121 - CONJ_WRAP' (K (EVERY' [rtac ballI, etac set_mp, stac id_apply, atac])) map_id's THEN'
85.122 - CONJ_WRAP' (fn thm =>
85.123 - (EVERY' [rtac ballI, rtac trans, rtac id_apply, stac thm, rtac refl])) map_id's) 1;
85.124 -
85.125 -fun mk_mor_comp_tac mor_def set_natural's map_comp_ids =
85.126 - let
85.127 - val fbetw_tac = EVERY' [rtac ballI, stac o_apply, etac bspec, etac bspec, atac];
85.128 - fun mor_tac (set_natural', map_comp_id) =
85.129 - EVERY' [rtac ballI, stac o_apply, rtac trans,
85.130 - rtac trans, dtac @{thm rev_bspec}, atac, etac arg_cong,
85.131 - REPEAT o eresolve_tac [CollectE, conjE], etac bspec, rtac CollectI] THEN'
85.132 - CONJ_WRAP' (fn thm =>
85.133 - FIRST' [rtac subset_UNIV,
85.134 - (EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
85.135 - etac bspec, etac set_mp, atac])]) set_natural' THEN'
85.136 - rtac (map_comp_id RS arg_cong);
85.137 - in
85.138 - (dtac (mor_def RS subst) THEN' dtac (mor_def RS subst) THEN' stac mor_def THEN'
85.139 - REPEAT o etac conjE THEN'
85.140 - rtac conjI THEN'
85.141 - CONJ_WRAP' (K fbetw_tac) set_natural's THEN'
85.142 - CONJ_WRAP' mor_tac (set_natural's ~~ map_comp_ids)) 1
85.143 - end;
85.144 -
85.145 -fun mk_mor_inv_tac alg_def mor_def set_natural's morEs map_comp_ids map_congLs =
85.146 - let
85.147 - val fbetw_tac = EVERY' [rtac ballI, etac set_mp, etac imageI];
85.148 - fun Collect_tac set_natural' =
85.149 - CONJ_WRAP' (fn thm =>
85.150 - FIRST' [rtac subset_UNIV,
85.151 - (EVERY' [rtac ord_eq_le_trans, rtac thm, rtac subset_trans,
85.152 - etac @{thm image_mono}, atac])]) set_natural';
85.153 - fun mor_tac (set_natural', ((morE, map_comp_id), map_congL)) =
85.154 - EVERY' [rtac ballI, ftac @{thm rev_bspec}, atac,
85.155 - REPEAT o eresolve_tac [CollectE, conjE], rtac sym, rtac trans, rtac sym,
85.156 - etac @{thm inverE}, etac bspec, rtac CollectI, Collect_tac set_natural',
85.157 - rtac trans, etac (morE RS arg_cong), rtac CollectI, Collect_tac set_natural',
85.158 - rtac trans, rtac (map_comp_id RS arg_cong), rtac (map_congL RS arg_cong),
85.159 - REPEAT_DETERM_N (length morEs) o
85.160 - (EVERY' [rtac subst, rtac @{thm inver_pointfree}, etac @{thm inver_mono}, atac])];
85.161 - in
85.162 - (stac mor_def THEN'
85.163 - dtac (alg_def RS iffD1) THEN'
85.164 - dtac (alg_def RS iffD1) THEN'
85.165 - REPEAT o etac conjE THEN'
85.166 - rtac conjI THEN'
85.167 - CONJ_WRAP' (K fbetw_tac) set_natural's THEN'
85.168 - CONJ_WRAP' mor_tac (set_natural's ~~ (morEs ~~ map_comp_ids ~~ map_congLs))) 1
85.169 - end;
85.170 -
85.171 -fun mk_mor_str_tac ks mor_def =
85.172 - (stac mor_def THEN' rtac conjI THEN'
85.173 - CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) ks THEN'
85.174 - CONJ_WRAP' (K (EVERY' [rtac ballI, rtac refl])) ks) 1;
85.175 -
85.176 -fun mk_mor_convol_tac ks mor_def =
85.177 - (stac mor_def THEN' rtac conjI THEN'
85.178 - CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) ks THEN'
85.179 - CONJ_WRAP' (K (EVERY' [rtac ballI, rtac trans, rtac @{thm fst_convol'}, rtac o_apply])) ks) 1;
85.180 -
85.181 -fun mk_mor_UNIV_tac m morEs mor_def =
85.182 - let
85.183 - val n = length morEs;
85.184 - fun mor_tac morE = EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, etac morE,
85.185 - rtac CollectI, CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto m + n),
85.186 - rtac sym, rtac o_apply];
85.187 - in
85.188 - EVERY' [rtac iffI, CONJ_WRAP' mor_tac morEs,
85.189 - stac mor_def, rtac conjI, CONJ_WRAP' (K (rtac ballI THEN' rtac UNIV_I)) morEs,
85.190 - REPEAT_DETERM o etac conjE, REPEAT_DETERM_N n o dtac (@{thm fun_eq_iff} RS subst),
85.191 - CONJ_WRAP' (K (EVERY' [rtac ballI, REPEAT_DETERM o etac allE, rtac trans,
85.192 - etac (o_apply RS subst), rtac o_apply])) morEs] 1
85.193 - end;
85.194 -
85.195 -fun mk_iso_alt_tac mor_images mor_inv =
85.196 - let
85.197 - val n = length mor_images;
85.198 - fun if_wrap_tac thm =
85.199 - EVERY' [rtac ssubst, rtac @{thm bij_betw_iff_ex}, rtac exI, rtac conjI,
85.200 - rtac @{thm inver_surj}, etac thm, etac thm, atac, etac conjI, atac]
85.201 - val if_tac =
85.202 - EVERY' [etac thin_rl, etac thin_rl, REPEAT o eresolve_tac [conjE, exE],
85.203 - rtac conjI, atac, CONJ_WRAP' if_wrap_tac mor_images];
85.204 - val only_if_tac =
85.205 - EVERY' [rtac conjI, etac conjunct1, EVERY' (map (fn thm =>
85.206 - EVERY' [rtac exE, rtac @{thm bij_betw_ex_weakE}, etac (conjunct2 RS thm)])
85.207 - (map (mk_conjunctN n) (1 upto n))), REPEAT o rtac exI, rtac conjI, rtac mor_inv,
85.208 - etac conjunct1, atac, atac, REPEAT_DETERM_N n o atac,
85.209 - CONJ_WRAP' (K (etac conjunct2)) mor_images];
85.210 - in
85.211 - (rtac iffI THEN' if_tac THEN' only_if_tac) 1
85.212 - end;
85.213 -
85.214 -fun mk_copy_str_tac set_natural's alg_def alg_sets =
85.215 - let
85.216 - val n = length alg_sets;
85.217 - val bij_betw_inv_tac =
85.218 - EVERY' [etac thin_rl, REPEAT_DETERM_N n o EVERY' [dtac @{thm bij_betwI}, atac, atac],
85.219 - REPEAT_DETERM_N (2 * n) o etac thin_rl, REPEAT_DETERM_N (n - 1) o etac conjI, atac];
85.220 - fun set_tac thms =
85.221 - EVERY' [rtac ord_eq_le_trans, resolve_tac thms, rtac subset_trans,
85.222 - etac @{thm image_mono}, rtac equalityD1, etac @{thm bij_betw_imageE}];
85.223 - val copy_str_tac =
85.224 - CONJ_WRAP' (fn (thms, thm) =>
85.225 - EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac set_mp,
85.226 - rtac equalityD1, etac @{thm bij_betw_imageE}, rtac imageI, etac thm,
85.227 - REPEAT_DETERM o rtac subset_UNIV, REPEAT_DETERM_N n o (set_tac thms)])
85.228 - (set_natural's ~~ alg_sets);
85.229 - in
85.230 - (rtac rev_mp THEN' DETERM o bij_betw_inv_tac THEN' rtac impI THEN'
85.231 - stac alg_def THEN' copy_str_tac) 1
85.232 - end;
85.233 -
85.234 -fun mk_copy_alg_tac set_natural's alg_sets mor_def iso_alt copy_str =
85.235 - let
85.236 - val n = length alg_sets;
85.237 - val fbetw_tac = CONJ_WRAP' (K (etac @{thm bij_betwE})) alg_sets;
85.238 - fun set_tac thms =
85.239 - EVERY' [rtac ord_eq_le_trans, resolve_tac thms, rtac subset_trans,
85.240 - REPEAT_DETERM o etac conjE, etac @{thm image_mono},
85.241 - rtac equalityD1, etac @{thm bij_betw_imageE}];
85.242 - val mor_tac =
85.243 - CONJ_WRAP' (fn (thms, thm) =>
85.244 - EVERY' [rtac ballI, etac CollectE, etac @{thm inverE}, etac thm,
85.245 - REPEAT_DETERM o rtac subset_UNIV, REPEAT_DETERM_N n o (set_tac thms)])
85.246 - (set_natural's ~~ alg_sets);
85.247 - in
85.248 - (rtac (iso_alt RS @{thm ssubst[of _ _ "%x. x"]}) THEN'
85.249 - etac copy_str THEN' REPEAT_DETERM o atac THEN'
85.250 - rtac conjI THEN' stac mor_def THEN' rtac conjI THEN' fbetw_tac THEN' mor_tac THEN'
85.251 - CONJ_WRAP' (K atac) alg_sets) 1
85.252 - end;
85.253 -
85.254 -fun mk_ex_copy_alg_tac n copy_str copy_alg =
85.255 - EVERY' [REPEAT_DETERM_N n o rtac exI, rtac conjI, etac copy_str,
85.256 - REPEAT_DETERM_N n o atac,
85.257 - REPEAT_DETERM_N n o etac @{thm bij_betw_inver2},
85.258 - REPEAT_DETERM_N n o etac @{thm bij_betw_inver1}, etac copy_alg,
85.259 - REPEAT_DETERM_N n o atac,
85.260 - REPEAT_DETERM_N n o etac @{thm bij_betw_inver2},
85.261 - REPEAT_DETERM_N n o etac @{thm bij_betw_inver1}] 1;
85.262 -
85.263 -fun mk_bd_limit_tac n bd_Cinfinite =
85.264 - EVERY' [REPEAT_DETERM o etac conjE, rtac rev_mp, rtac @{thm Cinfinite_limit_finite},
85.265 - REPEAT_DETERM_N n o rtac @{thm finite.insertI}, rtac @{thm finite.emptyI},
85.266 - REPEAT_DETERM_N n o etac @{thm insert_subsetI}, rtac @{thm empty_subsetI},
85.267 - rtac bd_Cinfinite, rtac impI, etac bexE, rtac bexI,
85.268 - CONJ_WRAP' (fn i =>
85.269 - EVERY' [etac bspec, REPEAT_DETERM_N i o rtac @{thm insertI2}, rtac @{thm insertI1}])
85.270 - (0 upto n - 1),
85.271 - atac] 1;
85.272 -
85.273 -fun mk_min_algs_tac worel in_congs =
85.274 - let
85.275 - val minG_tac = EVERY' [rtac @{thm UN_cong}, rtac refl, dtac bspec, atac, etac arg_cong];
85.276 - fun minH_tac thm =
85.277 - EVERY' [rtac @{thm Un_cong}, minG_tac, rtac @{thm image_cong}, rtac thm,
85.278 - REPEAT_DETERM_N (length in_congs) o minG_tac, rtac refl];
85.279 - in
85.280 - (rtac (worel RS (@{thm wo_rel.worec_fixpoint} RS fun_cong)) THEN' rtac ssubst THEN'
85.281 - rtac meta_eq_to_obj_eq THEN' rtac (worel RS @{thm wo_rel.adm_wo_def}) THEN'
85.282 - REPEAT_DETERM_N 3 o rtac allI THEN' rtac impI THEN'
85.283 - CONJ_WRAP_GEN' (EVERY' [rtac Pair_eqI, rtac conjI]) minH_tac in_congs) 1
85.284 - end;
85.285 -
85.286 -fun mk_min_algs_mono_tac min_algs = EVERY' [stac @{thm relChain_def}, rtac allI, rtac allI,
85.287 - rtac impI, rtac @{thm case_split}, rtac @{thm xt1(3)}, rtac min_algs, etac @{thm FieldI2},
85.288 - rtac subsetI, rtac UnI1, rtac @{thm UN_I}, etac @{thm underS_I}, atac, atac,
85.289 - rtac equalityD1, dtac @{thm notnotD}, hyp_subst_tac, rtac refl] 1;
85.290 -
85.291 -fun mk_min_algs_card_of_tac cT ct m worel min_algs in_bds bd_Card_order bd_Cnotzero
85.292 - suc_Card_order suc_Cinfinite suc_Cnotzero suc_Asuc Asuc_Cinfinite Asuc_Cnotzero =
85.293 - let
85.294 - val induct = worel RS
85.295 - Drule.instantiate' [SOME cT] [NONE, SOME ct] @{thm well_order_induct_imp};
85.296 - val src = 1 upto m + 1;
85.297 - val dest = (m + 1) :: (1 upto m);
85.298 - val absorbAs_tac = if m = 0 then K (all_tac)
85.299 - else EVERY' [rtac @{thm ordIso_transitive}, rtac @{thm csum_cong1},
85.300 - rtac @{thm ordIso_transitive},
85.301 - BNF_Tactics.mk_rotate_eq_tac (rtac @{thm ordIso_refl} THEN'
85.302 - FIRST' [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum},
85.303 - rtac @{thm Card_order_cexp}])
85.304 - @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
85.305 - src dest,
85.306 - rtac @{thm csum_absorb1}, rtac Asuc_Cinfinite, rtac ctrans, rtac @{thm ordLeq_csum1},
85.307 - FIRST' [rtac @{thm Card_order_csum}, rtac @{thm card_of_Card_order}],
85.308 - rtac @{thm ordLeq_cexp1}, rtac suc_Cnotzero, rtac @{thm Card_order_csum}];
85.309 -
85.310 - val minG_tac = EVERY' [rtac @{thm UNION_Cinfinite_bound}, rtac @{thm ordLess_imp_ordLeq},
85.311 - rtac @{thm ordLess_transitive}, rtac @{thm card_of_underS}, rtac suc_Card_order,
85.312 - atac, rtac suc_Asuc, rtac ballI, etac allE, dtac mp, etac @{thm underS_E},
85.313 - dtac mp, etac @{thm underS_Field}, REPEAT o etac conjE, atac, rtac Asuc_Cinfinite]
85.314 -
85.315 - fun mk_minH_tac (min_alg, in_bd) = EVERY' [rtac @{thm ordIso_ordLeq_trans},
85.316 - rtac @{thm card_of_ordIso_subst}, etac min_alg, rtac @{thm Un_Cinfinite_bound},
85.317 - minG_tac, rtac ctrans, rtac @{thm card_of_image}, rtac ctrans, rtac in_bd, rtac ctrans,
85.318 - rtac @{thm cexp_mono1_Cnotzero}, rtac @{thm csum_mono1},
85.319 - REPEAT_DETERM_N m o rtac @{thm csum_mono2},
85.320 - CONJ_WRAP_GEN' (rtac @{thm csum_cinfinite_bound}) (K minG_tac) min_algs,
85.321 - REPEAT_DETERM o FIRST'
85.322 - [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum}, rtac Asuc_Cinfinite],
85.323 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac bd_Card_order,
85.324 - rtac @{thm ordIso_ordLeq_trans}, rtac @{thm cexp_cong1_Cnotzero}, absorbAs_tac,
85.325 - rtac @{thm csum_absorb1}, rtac Asuc_Cinfinite, rtac @{thm ctwo_ordLeq_Cinfinite},
85.326 - rtac Asuc_Cinfinite, rtac bd_Card_order,
85.327 - rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac Asuc_Cnotzero,
85.328 - rtac @{thm ordIso_imp_ordLeq}, rtac @{thm cexp_cprod_ordLeq},
85.329 - TRY o rtac @{thm csum_Cnotzero2}, rtac @{thm ctwo_Cnotzero}, rtac suc_Cinfinite,
85.330 - rtac bd_Cnotzero, rtac @{thm cardSuc_ordLeq}, rtac bd_Card_order, rtac Asuc_Cinfinite];
85.331 - in
85.332 - (rtac induct THEN'
85.333 - rtac impI THEN'
85.334 - CONJ_WRAP' mk_minH_tac (min_algs ~~ in_bds)) 1
85.335 - end;
85.336 -
85.337 -fun mk_min_algs_least_tac cT ct worel min_algs alg_sets =
85.338 - let
85.339 - val induct = worel RS
85.340 - Drule.instantiate' [SOME cT] [NONE, SOME ct] @{thm well_order_induct_imp};
85.341 -
85.342 - val minG_tac = EVERY' [rtac @{thm UN_least}, etac allE, dtac mp, etac @{thm underS_E},
85.343 - dtac mp, etac @{thm underS_Field}, REPEAT_DETERM o etac conjE, atac];
85.344 -
85.345 - fun mk_minH_tac (min_alg, alg_set) = EVERY' [rtac ord_eq_le_trans, etac min_alg,
85.346 - rtac @{thm Un_least}, minG_tac, rtac @{thm image_subsetI},
85.347 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], etac alg_set,
85.348 - REPEAT_DETERM o FIRST' [atac, etac subset_trans THEN' minG_tac]];
85.349 - in
85.350 - (rtac induct THEN'
85.351 - rtac impI THEN'
85.352 - CONJ_WRAP' mk_minH_tac (min_algs ~~ alg_sets)) 1
85.353 - end;
85.354 -
85.355 -fun mk_alg_min_alg_tac m alg_def min_alg_defs bd_limit bd_Cinfinite
85.356 - set_bdss min_algs min_alg_monos =
85.357 - let
85.358 - val n = length min_algs;
85.359 - fun mk_cardSuc_UNION_tac set_bds (mono, def) = EVERY'
85.360 - [rtac bexE, rtac @{thm cardSuc_UNION_Cinfinite}, rtac bd_Cinfinite, rtac mono,
85.361 - etac (def RSN (2, @{thm subset_trans[OF _ equalityD1]})), resolve_tac set_bds];
85.362 - fun mk_conjunct_tac (set_bds, (min_alg, min_alg_def)) =
85.363 - EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
85.364 - EVERY' (map (mk_cardSuc_UNION_tac set_bds) (min_alg_monos ~~ min_alg_defs)), rtac bexE,
85.365 - rtac bd_limit, REPEAT_DETERM_N (n - 1) o etac conjI, atac,
85.366 - rtac (min_alg_def RS @{thm set_mp[OF equalityD2]}),
85.367 - rtac @{thm UN_I}, REPEAT_DETERM_N (m + 3 * n) o etac thin_rl, atac, rtac set_mp,
85.368 - rtac equalityD2, rtac min_alg, atac, rtac UnI2, rtac @{thm image_eqI}, rtac refl,
85.369 - rtac CollectI, REPEAT_DETERM_N m o dtac asm_rl, REPEAT_DETERM_N n o etac thin_rl,
85.370 - REPEAT_DETERM o etac conjE,
85.371 - CONJ_WRAP' (K (FIRST' [atac,
85.372 - EVERY' [etac subset_trans, rtac subsetI, rtac @{thm UN_I},
85.373 - etac @{thm underS_I}, atac, atac]]))
85.374 - set_bds];
85.375 - in
85.376 - (rtac (alg_def RS @{thm ssubst[of _ _ "%x. x"]}) THEN'
85.377 - CONJ_WRAP' mk_conjunct_tac (set_bdss ~~ (min_algs ~~ min_alg_defs))) 1
85.378 - end;
85.379 -
85.380 -fun mk_card_of_min_alg_tac min_alg_def card_of suc_Card_order suc_Asuc Asuc_Cinfinite =
85.381 - EVERY' [stac min_alg_def, rtac @{thm UNION_Cinfinite_bound},
85.382 - rtac @{thm ordIso_ordLeq_trans}, rtac @{thm card_of_Field_ordIso}, rtac suc_Card_order,
85.383 - rtac @{thm ordLess_imp_ordLeq}, rtac suc_Asuc, rtac ballI, dtac rev_mp, rtac card_of,
85.384 - REPEAT_DETERM o etac conjE, atac, rtac Asuc_Cinfinite] 1;
85.385 -
85.386 -fun mk_least_min_alg_tac min_alg_def least =
85.387 - EVERY' [stac min_alg_def, rtac @{thm UN_least}, dtac least, dtac mp, atac,
85.388 - REPEAT_DETERM o etac conjE, atac] 1;
85.389 -
85.390 -fun mk_alg_select_tac Abs_inverse {context = ctxt, prems = _} =
85.391 - EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, exE, conjE], hyp_subst_tac] 1 THEN
85.392 - unfold_thms_tac ctxt (Abs_inverse :: fst_snd_convs) THEN atac 1;
85.393 -
85.394 -fun mk_mor_select_tac mor_def mor_cong mor_comp mor_incl_min_alg alg_def alg_select
85.395 - alg_sets set_natural's str_init_defs =
85.396 - let
85.397 - val n = length alg_sets;
85.398 - val fbetw_tac =
85.399 - CONJ_WRAP' (K (EVERY' [rtac ballI, etac @{thm rev_bspec}, etac CollectE, atac])) alg_sets;
85.400 - val mor_tac =
85.401 - CONJ_WRAP' (fn thm => EVERY' [rtac ballI, rtac thm]) str_init_defs;
85.402 - fun alg_epi_tac ((alg_set, str_init_def), set_natural') =
85.403 - EVERY' [rtac ballI, REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
85.404 - rtac ballI, ftac (alg_select RS bspec), stac str_init_def, etac alg_set,
85.405 - REPEAT_DETERM o FIRST' [rtac subset_UNIV,
85.406 - EVERY' [rtac ord_eq_le_trans, resolve_tac set_natural', rtac subset_trans,
85.407 - etac @{thm image_mono}, rtac @{thm image_Collect_subsetI}, etac bspec, atac]]];
85.408 - in
85.409 - (rtac mor_cong THEN' REPEAT_DETERM_N n o (rtac sym THEN' rtac @{thm o_id}) THEN'
85.410 - rtac (Thm.permute_prems 0 1 mor_comp) THEN' etac (Thm.permute_prems 0 1 mor_comp) THEN'
85.411 - stac mor_def THEN' rtac conjI THEN' fbetw_tac THEN' mor_tac THEN' rtac mor_incl_min_alg THEN'
85.412 - stac alg_def THEN' CONJ_WRAP' alg_epi_tac ((alg_sets ~~ str_init_defs) ~~ set_natural's)) 1
85.413 - end;
85.414 -
85.415 -fun mk_init_ex_mor_tac Abs_inverse copy_alg_ex alg_min_alg card_of_min_algs
85.416 - mor_comp mor_select mor_incl_min_alg {context = ctxt, prems = _} =
85.417 - let
85.418 - val n = length card_of_min_algs;
85.419 - val card_of_ordIso_tac = EVERY' [rtac ssubst, rtac @{thm card_of_ordIso},
85.420 - rtac @{thm ordIso_symmetric}, rtac conjunct1, rtac conjunct2, atac];
85.421 - fun internalize_tac card_of = EVERY' [rtac subst, rtac @{thm internalize_card_of_ordLeq2},
85.422 - rtac @{thm ordLeq_ordIso_trans}, rtac card_of, rtac subst,
85.423 - rtac @{thm Card_order_iff_ordIso_card_of}, rtac @{thm Card_order_cexp}];
85.424 - in
85.425 - (rtac rev_mp THEN'
85.426 - REPEAT_DETERM_N (2 * n) o (rtac mp THEN' rtac @{thm ex_mono} THEN' rtac impI) THEN'
85.427 - REPEAT_DETERM_N (n + 1) o etac thin_rl THEN' rtac (alg_min_alg RS copy_alg_ex) THEN'
85.428 - REPEAT_DETERM_N n o atac THEN'
85.429 - REPEAT_DETERM_N n o card_of_ordIso_tac THEN'
85.430 - EVERY' (map internalize_tac card_of_min_algs) THEN'
85.431 - rtac impI THEN'
85.432 - REPEAT_DETERM o eresolve_tac [exE, conjE] THEN'
85.433 - REPEAT_DETERM o rtac exI THEN'
85.434 - rtac mor_select THEN' atac THEN' rtac CollectI THEN'
85.435 - REPEAT_DETERM o rtac exI THEN'
85.436 - rtac conjI THEN' rtac refl THEN' atac THEN'
85.437 - K (unfold_thms_tac ctxt (Abs_inverse :: fst_snd_convs)) THEN'
85.438 - etac mor_comp THEN' etac mor_incl_min_alg) 1
85.439 - end;
85.440 -
85.441 -fun mk_init_unique_mor_tac m
85.442 - alg_def alg_min_alg least_min_algs in_monos alg_sets morEs map_congs =
85.443 - let
85.444 - val n = length least_min_algs;
85.445 - val ks = (1 upto n);
85.446 -
85.447 - fun mor_tac morE in_mono = EVERY' [etac morE, rtac set_mp, rtac in_mono,
85.448 - REPEAT_DETERM_N n o rtac @{thm Collect_restrict}, rtac CollectI,
85.449 - REPEAT_DETERM_N (m + n) o (TRY o rtac conjI THEN' atac)];
85.450 - fun cong_tac map_cong = EVERY' [rtac (map_cong RS arg_cong),
85.451 - REPEAT_DETERM_N m o rtac refl,
85.452 - REPEAT_DETERM_N n o (etac @{thm prop_restrict} THEN' atac)];
85.453 -
85.454 - fun mk_alg_tac (alg_set, (in_mono, (morE, map_cong))) = EVERY' [rtac ballI, rtac CollectI,
85.455 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac (alg_min_alg RS alg_set),
85.456 - REPEAT_DETERM_N m o rtac subset_UNIV,
85.457 - REPEAT_DETERM_N n o (etac subset_trans THEN' rtac @{thm Collect_restrict}),
85.458 - rtac trans, mor_tac morE in_mono,
85.459 - rtac trans, cong_tac map_cong,
85.460 - rtac sym, mor_tac morE in_mono];
85.461 -
85.462 - fun mk_unique_tac (k, least_min_alg) =
85.463 - select_prem_tac n (etac @{thm prop_restrict}) k THEN' rtac least_min_alg THEN'
85.464 - stac alg_def THEN'
85.465 - CONJ_WRAP' mk_alg_tac (alg_sets ~~ (in_monos ~~ (morEs ~~ map_congs)));
85.466 - in
85.467 - CONJ_WRAP' mk_unique_tac (ks ~~ least_min_algs) 1
85.468 - end;
85.469 -
85.470 -fun mk_init_induct_tac m alg_def alg_min_alg least_min_algs alg_sets =
85.471 - let
85.472 - val n = length least_min_algs;
85.473 -
85.474 - fun mk_alg_tac alg_set = EVERY' [rtac ballI, rtac CollectI,
85.475 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac conjI, rtac (alg_min_alg RS alg_set),
85.476 - REPEAT_DETERM_N m o rtac subset_UNIV,
85.477 - REPEAT_DETERM_N n o (etac subset_trans THEN' rtac @{thm Collect_restrict}),
85.478 - rtac mp, etac bspec, rtac CollectI,
85.479 - REPEAT_DETERM_N m o (rtac conjI THEN' atac),
85.480 - CONJ_WRAP' (K (etac subset_trans THEN' rtac @{thm Collect_restrict})) alg_sets,
85.481 - CONJ_WRAP' (K (rtac ballI THEN' etac @{thm prop_restrict} THEN' atac)) alg_sets];
85.482 -
85.483 - fun mk_induct_tac least_min_alg =
85.484 - rtac ballI THEN' etac @{thm prop_restrict} THEN' rtac least_min_alg THEN'
85.485 - stac alg_def THEN'
85.486 - CONJ_WRAP' mk_alg_tac alg_sets;
85.487 - in
85.488 - CONJ_WRAP' mk_induct_tac least_min_algs 1
85.489 - end;
85.490 -
85.491 -fun mk_mor_Rep_tac ctor_defs copy bijs inver_Abss inver_Reps {context = ctxt, prems = _} =
85.492 - (K (unfold_thms_tac ctxt ctor_defs) THEN' rtac conjunct1 THEN' rtac copy THEN'
85.493 - EVERY' (map (fn bij => EVERY' [rtac bij, atac, etac bexI, rtac UNIV_I]) bijs) THEN'
85.494 - EVERY' (map rtac inver_Abss) THEN'
85.495 - EVERY' (map rtac inver_Reps)) 1;
85.496 -
85.497 -fun mk_mor_Abs_tac inv inver_Abss inver_Reps =
85.498 - (rtac inv THEN'
85.499 - EVERY' (map2 (fn inver_Abs => fn inver_Rep =>
85.500 - EVERY' [rtac conjI, rtac subset_UNIV, rtac conjI, rtac inver_Rep, rtac inver_Abs])
85.501 - inver_Abss inver_Reps)) 1;
85.502 -
85.503 -fun mk_mor_fold_tac cT ct fold_defs ex_mor mor =
85.504 - (EVERY' (map stac fold_defs) THEN' EVERY' [rtac rev_mp, rtac ex_mor, rtac impI] THEN'
85.505 - REPEAT_DETERM_N (length fold_defs) o etac exE THEN'
85.506 - rtac (Drule.instantiate' [SOME cT] [SOME ct] @{thm someI}) THEN' etac mor) 1;
85.507 -
85.508 -fun mk_fold_unique_mor_tac type_defs init_unique_mors Reps mor_comp mor_Abs mor_fold =
85.509 - let
85.510 - fun mk_unique type_def =
85.511 - EVERY' [rtac @{thm surj_fun_eq}, rtac (type_def RS @{thm type_definition.Abs_image}),
85.512 - rtac ballI, resolve_tac init_unique_mors,
85.513 - EVERY' (map (fn thm => atac ORELSE' rtac thm) Reps),
85.514 - rtac mor_comp, rtac mor_Abs, atac,
85.515 - rtac mor_comp, rtac mor_Abs, rtac mor_fold];
85.516 - in
85.517 - CONJ_WRAP' mk_unique type_defs 1
85.518 - end;
85.519 -
85.520 -fun mk_dtor_o_ctor_tac dtor_def foldx map_comp_id map_congL ctor_o_folds =
85.521 - EVERY' [stac dtor_def, rtac ext, rtac trans, rtac o_apply, rtac trans, rtac foldx,
85.522 - rtac trans, rtac map_comp_id, rtac trans, rtac map_congL,
85.523 - EVERY' (map (fn thm => rtac ballI THEN' rtac (trans OF [thm RS fun_cong, id_apply]))
85.524 - ctor_o_folds),
85.525 - rtac sym, rtac id_apply] 1;
85.526 -
85.527 -fun mk_rec_tac rec_defs foldx fst_recs {context = ctxt, prems = _}=
85.528 - unfold_thms_tac ctxt
85.529 - (rec_defs @ map (fn thm => thm RS @{thm convol_expand_snd}) fst_recs) THEN
85.530 - EVERY' [rtac trans, rtac o_apply, rtac trans, rtac (foldx RS @{thm arg_cong[of _ _ snd]}),
85.531 - rtac @{thm snd_convol'}] 1;
85.532 -
85.533 -fun mk_ctor_induct_tac m set_natural'ss init_induct morEs mor_Abs Rep_invs Abs_invs Reps =
85.534 - let
85.535 - val n = length set_natural'ss;
85.536 - val ks = 1 upto n;
85.537 -
85.538 - fun mk_IH_tac Rep_inv Abs_inv set_natural' =
85.539 - DETERM o EVERY' [dtac meta_mp, rtac (Rep_inv RS arg_cong RS subst), etac bspec,
85.540 - dtac set_rev_mp, rtac equalityD1, rtac set_natural', etac imageE,
85.541 - hyp_subst_tac, rtac (Abs_inv RS ssubst), etac set_mp, atac, atac];
85.542 -
85.543 - fun mk_closed_tac (k, (morE, set_natural's)) =
85.544 - EVERY' [select_prem_tac n (dtac asm_rl) k, rtac ballI, rtac impI,
85.545 - rtac (mor_Abs RS morE RS arg_cong RS ssubst), atac,
85.546 - REPEAT_DETERM o eresolve_tac [CollectE, conjE], dtac @{thm meta_spec},
85.547 - EVERY' (map3 mk_IH_tac Rep_invs Abs_invs (drop m set_natural's)), atac];
85.548 -
85.549 - fun mk_induct_tac (Rep, Rep_inv) =
85.550 - EVERY' [rtac (Rep_inv RS arg_cong RS subst), etac (Rep RSN (2, bspec))];
85.551 - in
85.552 - (rtac mp THEN' rtac impI THEN'
85.553 - DETERM o CONJ_WRAP_GEN' (etac conjE THEN' rtac conjI) mk_induct_tac (Reps ~~ Rep_invs) THEN'
85.554 - rtac init_induct THEN'
85.555 - DETERM o CONJ_WRAP' mk_closed_tac (ks ~~ (morEs ~~ set_natural'ss))) 1
85.556 - end;
85.557 -
85.558 -fun mk_ctor_induct2_tac cTs cts ctor_induct weak_ctor_inducts {context = ctxt, prems = _} =
85.559 - let
85.560 - val n = length weak_ctor_inducts;
85.561 - val ks = 1 upto n;
85.562 - fun mk_inner_induct_tac induct i =
85.563 - EVERY' [rtac allI, fo_rtac induct ctxt,
85.564 - select_prem_tac n (dtac @{thm meta_spec2}) i,
85.565 - REPEAT_DETERM_N n o
85.566 - EVERY' [dtac meta_mp THEN_ALL_NEW Goal.norm_hhf_tac,
85.567 - REPEAT_DETERM o dtac @{thm meta_spec}, etac (spec RS meta_mp), atac],
85.568 - atac];
85.569 - in
85.570 - EVERY' [rtac rev_mp, rtac (Drule.instantiate' cTs cts ctor_induct),
85.571 - EVERY' (map2 mk_inner_induct_tac weak_ctor_inducts ks), rtac impI,
85.572 - REPEAT_DETERM o eresolve_tac [conjE, allE],
85.573 - CONJ_WRAP' (K atac) ks] 1
85.574 - end;
85.575 -
85.576 -fun mk_map_tac m n foldx map_comp_id map_cong =
85.577 - EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, rtac foldx, rtac trans, rtac o_apply,
85.578 - rtac trans, rtac (map_comp_id RS arg_cong), rtac trans, rtac (map_cong RS arg_cong),
85.579 - REPEAT_DETERM_N m o rtac refl,
85.580 - REPEAT_DETERM_N n o (EVERY' (map rtac [trans, o_apply, id_apply])),
85.581 - rtac sym, rtac o_apply] 1;
85.582 -
85.583 -fun mk_map_unique_tac m mor_def fold_unique_mor map_comp_ids map_congs =
85.584 - let
85.585 - val n = length map_congs;
85.586 - fun mk_mor (comp_id, cong) = EVERY' [rtac ballI, rtac trans, etac @{thm pointfreeE},
85.587 - rtac sym, rtac trans, rtac o_apply, rtac trans, rtac (comp_id RS arg_cong),
85.588 - rtac (cong RS arg_cong),
85.589 - REPEAT_DETERM_N m o rtac refl,
85.590 - REPEAT_DETERM_N n o (EVERY' (map rtac [trans, o_apply, id_apply]))];
85.591 - in
85.592 - EVERY' [rtac fold_unique_mor, rtac ssubst, rtac mor_def, rtac conjI,
85.593 - CONJ_WRAP' (K (EVERY' [rtac ballI, rtac UNIV_I])) map_congs,
85.594 - CONJ_WRAP' mk_mor (map_comp_ids ~~ map_congs)] 1
85.595 - end;
85.596 -
85.597 -fun mk_set_tac foldx = EVERY' [rtac ext, rtac trans, rtac o_apply,
85.598 - rtac trans, rtac foldx, rtac sym, rtac o_apply] 1;
85.599 -
85.600 -fun mk_set_simp_tac set set_natural' set_natural's =
85.601 - let
85.602 - val n = length set_natural's;
85.603 - fun mk_UN thm = rtac (thm RS @{thm arg_cong[of _ _ Union]} RS trans) THEN'
85.604 - rtac @{thm Union_image_eq};
85.605 - in
85.606 - EVERY' [rtac (set RS @{thm pointfreeE} RS trans), rtac @{thm Un_cong},
85.607 - rtac (trans OF [set_natural', trans_fun_cong_image_id_id_apply]),
85.608 - REPEAT_DETERM_N (n - 1) o rtac @{thm Un_cong},
85.609 - EVERY' (map mk_UN set_natural's)] 1
85.610 - end;
85.611 -
85.612 -fun mk_set_nat_tac m induct_tac set_natural'ss
85.613 - map_simps csets set_simps i {context = ctxt, prems = _} =
85.614 - let
85.615 - val n = length map_simps;
85.616 -
85.617 - fun useIH set_nat = EVERY' [rtac trans, rtac @{thm image_UN}, rtac trans, rtac @{thm UN_cong},
85.618 - rtac refl, Goal.assume_rule_tac ctxt, rtac sym, rtac trans, rtac @{thm UN_cong},
85.619 - rtac set_nat, rtac refl, rtac @{thm UN_simps(10)}];
85.620 -
85.621 - fun mk_set_nat cset map_simp set_simp set_nats =
85.622 - EVERY' [rtac trans, rtac @{thm image_cong}, rtac set_simp, rtac refl,
85.623 - rtac sym, rtac (trans OF [map_simp RS HOL_arg_cong cset, set_simp RS trans]),
85.624 - rtac sym, EVERY' (map rtac (trans :: @{thms image_Un Un_cong})),
85.625 - rtac sym, rtac (nth set_nats (i - 1)),
85.626 - REPEAT_DETERM_N (n - 1) o EVERY' (map rtac (trans :: @{thms image_Un Un_cong})),
85.627 - EVERY' (map useIH (drop m set_nats))];
85.628 - in
85.629 - (induct_tac THEN' EVERY' (map4 mk_set_nat csets map_simps set_simps set_natural'ss)) 1
85.630 - end;
85.631 -
85.632 -fun mk_set_bd_tac m induct_tac bd_Cinfinite set_bdss set_simps i {context = ctxt, prems = _} =
85.633 - let
85.634 - val n = length set_simps;
85.635 -
85.636 - fun useIH set_bd = EVERY' [rtac @{thm UNION_Cinfinite_bound}, rtac set_bd, rtac ballI,
85.637 - Goal.assume_rule_tac ctxt, rtac bd_Cinfinite];
85.638 -
85.639 - fun mk_set_nat set_simp set_bds =
85.640 - EVERY' [rtac @{thm ordIso_ordLeq_trans}, rtac @{thm card_of_ordIso_subst}, rtac set_simp,
85.641 - rtac (bd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})), rtac (nth set_bds (i - 1)),
85.642 - REPEAT_DETERM_N (n - 1) o rtac (bd_Cinfinite RSN (3, @{thm Un_Cinfinite_bound})),
85.643 - EVERY' (map useIH (drop m set_bds))];
85.644 - in
85.645 - (induct_tac THEN' EVERY' (map2 mk_set_nat set_simps set_bdss)) 1
85.646 - end;
85.647 -
85.648 -fun mk_mcong_tac induct_tac set_setsss map_congs map_simps {context = ctxt, prems = _} =
85.649 - let
85.650 - fun use_asm thm = EVERY' [etac bspec, etac set_rev_mp, rtac thm];
85.651 -
85.652 - fun useIH set_sets = EVERY' [rtac mp, Goal.assume_rule_tac ctxt,
85.653 - CONJ_WRAP' (fn thm =>
85.654 - EVERY' [rtac ballI, etac bspec, etac set_rev_mp, etac thm]) set_sets];
85.655 -
85.656 - fun mk_map_cong map_simp map_cong set_setss =
85.657 - EVERY' [rtac impI, REPEAT_DETERM o etac conjE,
85.658 - rtac trans, rtac map_simp, rtac trans, rtac (map_cong RS arg_cong),
85.659 - EVERY' (map use_asm (map hd set_setss)),
85.660 - EVERY' (map useIH (transpose (map tl set_setss))),
85.661 - rtac sym, rtac map_simp];
85.662 - in
85.663 - (induct_tac THEN' EVERY' (map3 mk_map_cong map_simps map_congs set_setsss)) 1
85.664 - end;
85.665 -
85.666 -fun mk_incl_min_alg_tac induct_tac set_setsss alg_sets alg_min_alg {context = ctxt, prems = _} =
85.667 - let
85.668 - fun use_asm thm = etac (thm RS subset_trans);
85.669 -
85.670 - fun useIH set_sets = EVERY' [rtac subsetI, rtac mp, Goal.assume_rule_tac ctxt,
85.671 - rtac CollectI, CONJ_WRAP' (fn thm => EVERY' [etac (thm RS subset_trans), atac]) set_sets];
85.672 -
85.673 - fun mk_incl alg_set set_setss =
85.674 - EVERY' [rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
85.675 - rtac (alg_min_alg RS alg_set),
85.676 - EVERY' (map use_asm (map hd set_setss)),
85.677 - EVERY' (map useIH (transpose (map tl set_setss)))];
85.678 - in
85.679 - (induct_tac THEN' EVERY' (map2 mk_incl alg_sets set_setsss)) 1
85.680 - end;
85.681 -
85.682 -fun mk_lfp_map_wpull_tac m induct_tac wpulls map_simps set_simpss set_setsss ctor_injects =
85.683 - let
85.684 - val n = length wpulls;
85.685 - val ks = 1 upto n;
85.686 - val ls = 1 upto m;
85.687 -
85.688 - fun use_pass_asm thm = rtac conjI THEN' etac (thm RS subset_trans);
85.689 - fun use_act_asm thm = etac (thm RS subset_trans) THEN' atac;
85.690 -
85.691 - fun useIH set_sets i = EVERY' [rtac ssubst, rtac @{thm wpull_def},
85.692 - REPEAT_DETERM_N m o etac thin_rl, select_prem_tac n (dtac asm_rl) i,
85.693 - rtac allI, rtac allI, rtac impI, REPEAT_DETERM o etac conjE,
85.694 - REPEAT_DETERM o dtac @{thm meta_spec},
85.695 - dtac meta_mp, atac,
85.696 - dtac meta_mp, atac, etac mp,
85.697 - rtac conjI, rtac CollectI, CONJ_WRAP' use_act_asm set_sets,
85.698 - rtac conjI, rtac CollectI, CONJ_WRAP' use_act_asm set_sets,
85.699 - atac];
85.700 -
85.701 - fun mk_subset thm = EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm Un_least}, atac,
85.702 - REPEAT_DETERM_N (n - 1) o rtac @{thm Un_least},
85.703 - REPEAT_DETERM_N n o
85.704 - EVERY' [rtac @{thm UN_least}, rtac CollectE, etac set_rev_mp, atac,
85.705 - REPEAT_DETERM o etac conjE, atac]];
85.706 -
85.707 - fun mk_wpull wpull map_simp set_simps set_setss ctor_inject =
85.708 - EVERY' [rtac impI, REPEAT_DETERM o eresolve_tac [CollectE, conjE],
85.709 - rtac rev_mp, rtac wpull,
85.710 - EVERY' (map (fn i => REPEAT_DETERM_N (i - 1) o etac thin_rl THEN' atac) ls),
85.711 - EVERY' (map2 useIH (transpose (map tl set_setss)) ks),
85.712 - rtac impI, REPEAT_DETERM_N (m + n) o etac thin_rl,
85.713 - dtac @{thm subst[OF wpull_def, of "%x. x"]}, etac allE, etac allE, etac impE,
85.714 - rtac conjI, rtac CollectI, EVERY' (map (use_pass_asm o hd) set_setss),
85.715 - CONJ_WRAP' (K (rtac subset_refl)) ks,
85.716 - rtac conjI, rtac CollectI, EVERY' (map (use_pass_asm o hd) set_setss),
85.717 - CONJ_WRAP' (K (rtac subset_refl)) ks,
85.718 - rtac subst, rtac ctor_inject, rtac trans, rtac sym, rtac map_simp,
85.719 - rtac trans, atac, rtac map_simp, REPEAT_DETERM o eresolve_tac [CollectE, conjE, bexE],
85.720 - hyp_subst_tac, rtac bexI, rtac conjI, rtac map_simp, rtac map_simp, rtac CollectI,
85.721 - CONJ_WRAP' mk_subset set_simps];
85.722 - in
85.723 - (induct_tac THEN' EVERY' (map5 mk_wpull wpulls map_simps set_simpss set_setsss ctor_injects)) 1
85.724 - end;
85.725 -
85.726 -(* BNF tactics *)
85.727 -
85.728 -fun mk_map_id_tac map_ids unique =
85.729 - (rtac sym THEN' rtac unique THEN'
85.730 - EVERY' (map (fn thm =>
85.731 - EVERY' [rtac trans, rtac @{thm id_o}, rtac trans, rtac sym, rtac @{thm o_id},
85.732 - rtac (thm RS sym RS arg_cong)]) map_ids)) 1;
85.733 -
85.734 -fun mk_map_comp_tac map_comps map_simps unique iplus1 =
85.735 - let
85.736 - val i = iplus1 - 1;
85.737 - val unique' = Thm.permute_prems 0 i unique;
85.738 - val map_comps' = drop i map_comps @ take i map_comps;
85.739 - val map_simps' = drop i map_simps @ take i map_simps;
85.740 - fun mk_comp comp simp =
85.741 - EVERY' [rtac ext, rtac trans, rtac o_apply, rtac trans, rtac o_apply,
85.742 - rtac trans, rtac (simp RS arg_cong), rtac trans, rtac simp,
85.743 - rtac trans, rtac (comp RS arg_cong), rtac sym, rtac o_apply];
85.744 - in
85.745 - (rtac sym THEN' rtac unique' THEN' EVERY' (map2 mk_comp map_comps' map_simps')) 1
85.746 - end;
85.747 -
85.748 -fun mk_set_natural_tac set_nat =
85.749 - EVERY' (map rtac [ext, trans, o_apply, sym, trans, o_apply, set_nat]) 1;
85.750 -
85.751 -fun mk_in_bd_tac sum_Card_order sucbd_Cnotzero incl card_of_min_alg =
85.752 - EVERY' [rtac ctrans, rtac @{thm card_of_mono1}, rtac subsetI, etac rev_mp,
85.753 - rtac incl, rtac ctrans, rtac card_of_min_alg, rtac @{thm cexp_mono2_Cnotzero},
85.754 - rtac @{thm cardSuc_ordLeq_cpow}, rtac sum_Card_order, rtac @{thm csum_Cnotzero2},
85.755 - rtac @{thm ctwo_Cnotzero}, rtac sucbd_Cnotzero] 1;
85.756 -
85.757 -fun mk_bd_card_order_tac bd_card_orders =
85.758 - (rtac @{thm card_order_cpow} THEN'
85.759 - CONJ_WRAP_GEN' (rtac @{thm card_order_csum}) rtac bd_card_orders) 1;
85.760 -
85.761 -fun mk_wpull_tac wpull =
85.762 - EVERY' [rtac ssubst, rtac @{thm wpull_def}, rtac allI, rtac allI,
85.763 - rtac wpull, REPEAT_DETERM o atac] 1;
85.764 -
85.765 -fun mk_wit_tac n set_simp wit =
85.766 - REPEAT_DETERM (atac 1 ORELSE
85.767 - EVERY' [dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
85.768 - REPEAT_DETERM o
85.769 - (TRY o REPEAT_DETERM o etac UnE THEN' TRY o etac @{thm UN_E} THEN'
85.770 - (eresolve_tac wit ORELSE'
85.771 - (dresolve_tac wit THEN'
85.772 - (etac FalseE ORELSE'
85.773 - EVERY' [hyp_subst_tac, dtac set_rev_mp, rtac equalityD1, resolve_tac set_simp,
85.774 - REPEAT_DETERM_N n o etac UnE]))))] 1);
85.775 -
85.776 -fun mk_srel_simp_tac in_Isrels i in_srel map_comp map_cong map_simp set_simps ctor_inject
85.777 - ctor_dtor set_naturals set_incls set_set_inclss =
85.778 - let
85.779 - val m = length set_incls;
85.780 - val n = length set_set_inclss;
85.781 -
85.782 - val (passive_set_naturals, active_set_naturals) = chop m set_naturals;
85.783 - val in_Isrel = nth in_Isrels (i - 1);
85.784 - val le_arg_cong_ctor_dtor = ctor_dtor RS arg_cong RS ord_eq_le_trans;
85.785 - val eq_arg_cong_ctor_dtor = ctor_dtor RS arg_cong RS trans;
85.786 - val if_tac =
85.787 - EVERY' [dtac (in_Isrel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
85.788 - rtac (in_srel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
85.789 - EVERY' (map2 (fn set_natural => fn set_incl =>
85.790 - EVERY' [rtac conjI, rtac ord_eq_le_trans, rtac set_natural,
85.791 - rtac ord_eq_le_trans, rtac trans_fun_cong_image_id_id_apply,
85.792 - rtac (set_incl RS subset_trans), etac le_arg_cong_ctor_dtor])
85.793 - passive_set_naturals set_incls),
85.794 - CONJ_WRAP' (fn (in_Isrel, (set_natural, set_set_incls)) =>
85.795 - EVERY' [rtac ord_eq_le_trans, rtac set_natural, rtac @{thm image_subsetI},
85.796 - rtac (in_Isrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
85.797 - CONJ_WRAP' (fn thm =>
85.798 - EVERY' (map etac [thm RS subset_trans, le_arg_cong_ctor_dtor]))
85.799 - set_set_incls,
85.800 - rtac conjI, rtac refl, rtac refl])
85.801 - (in_Isrels ~~ (active_set_naturals ~~ set_set_inclss)),
85.802 - CONJ_WRAP' (fn conv =>
85.803 - EVERY' [rtac trans, rtac map_comp, rtac trans, rtac map_cong,
85.804 - REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
85.805 - REPEAT_DETERM_N n o EVERY' (map rtac [trans, o_apply, conv]),
85.806 - rtac (ctor_inject RS iffD1), rtac trans, rtac sym, rtac map_simp,
85.807 - etac eq_arg_cong_ctor_dtor])
85.808 - fst_snd_convs];
85.809 - val only_if_tac =
85.810 - EVERY' [dtac (in_srel RS iffD1), REPEAT_DETERM o eresolve_tac [exE, conjE, CollectE],
85.811 - rtac (in_Isrel RS iffD2), rtac exI, rtac conjI, rtac CollectI,
85.812 - CONJ_WRAP' (fn (set_simp, passive_set_natural) =>
85.813 - EVERY' [rtac ord_eq_le_trans, rtac set_simp, rtac @{thm Un_least},
85.814 - rtac ord_eq_le_trans, rtac @{thm box_equals[OF _ refl]},
85.815 - rtac passive_set_natural, rtac trans_fun_cong_image_id_id_apply, atac,
85.816 - CONJ_WRAP_GEN' (rtac (Thm.permute_prems 0 1 @{thm Un_least}))
85.817 - (fn (active_set_natural, in_Isrel) => EVERY' [rtac ord_eq_le_trans,
85.818 - rtac @{thm UN_cong[OF _ refl]}, rtac active_set_natural, rtac @{thm UN_least},
85.819 - dtac set_rev_mp, etac @{thm image_mono}, etac imageE,
85.820 - dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Isrel RS iffD1),
85.821 - dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE,
85.822 - dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac,
85.823 - hyp_subst_tac, REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac])
85.824 - (rev (active_set_naturals ~~ in_Isrels))])
85.825 - (set_simps ~~ passive_set_naturals),
85.826 - rtac conjI,
85.827 - REPEAT_DETERM_N 2 o EVERY' [rtac trans, rtac map_simp, rtac (ctor_inject RS iffD2),
85.828 - rtac trans, rtac map_comp, rtac trans, rtac map_cong,
85.829 - REPEAT_DETERM_N m o rtac @{thm fun_cong[OF o_id]},
85.830 - EVERY' (map (fn in_Isrel => EVERY' [rtac trans, rtac o_apply, dtac set_rev_mp, atac,
85.831 - dtac @{thm ssubst_mem[OF pair_collapse]}, dtac (in_Isrel RS iffD1),
85.832 - dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, atac]) in_Isrels),
85.833 - atac]]
85.834 - in
85.835 - EVERY' [rtac iffI, if_tac, only_if_tac] 1
85.836 - end;
85.837 -
85.838 -end;
86.1 --- a/src/HOL/Codatatype/Tools/bnf_lfp_util.ML Fri Sep 21 16:34:40 2012 +0200
86.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
86.3 @@ -1,76 +0,0 @@
86.4 -(* Title: HOL/BNF/Tools/bnf_lfp_util.ML
86.5 - Author: Dmitriy Traytel, TU Muenchen
86.6 - Author: Jasmin Blanchette, TU Muenchen
86.7 - Copyright 2012
86.8 -
86.9 -Library for the datatype construction.
86.10 -*)
86.11 -
86.12 -signature BNF_LFP_UTIL =
86.13 -sig
86.14 - val HOL_arg_cong: cterm -> thm
86.15 -
86.16 - val mk_bij_betw: term -> term -> term -> term
86.17 - val mk_cardSuc: term -> term
86.18 - val mk_convol: term * term -> term
86.19 - val mk_cpow: term -> term
86.20 - val mk_inver: term -> term -> term -> term
86.21 - val mk_not_empty: term -> term
86.22 - val mk_not_eq: term -> term -> term
86.23 - val mk_rapp: term -> typ -> term
86.24 - val mk_relChain: term -> term -> term
86.25 - val mk_underS: term -> term
86.26 - val mk_worec: term -> term -> term
86.27 -end;
86.28 -
86.29 -structure BNF_LFP_Util : BNF_LFP_UTIL =
86.30 -struct
86.31 -
86.32 -open BNF_Util
86.33 -
86.34 -fun HOL_arg_cong ct = Drule.instantiate'
86.35 - (map SOME (Thm.dest_ctyp (Thm.ctyp_of_term ct))) [NONE, NONE, SOME ct] arg_cong;
86.36 -
86.37 -(*reverse application*)
86.38 -fun mk_rapp arg T = Term.absdummy (fastype_of arg --> T) (Bound 0 $ arg);
86.39 -
86.40 -fun mk_underS r =
86.41 - let val T = fst (dest_relT (fastype_of r));
86.42 - in Const (@{const_name rel.underS}, mk_relT (T, T) --> T --> HOLogic.mk_setT T) $ r end;
86.43 -
86.44 -fun mk_worec r f =
86.45 - let val (A, AB) = apfst domain_type (dest_funT (fastype_of f));
86.46 - in Const (@{const_name wo_rel.worec}, mk_relT (A, A) --> (AB --> AB) --> AB) $ r $ f end;
86.47 -
86.48 -fun mk_relChain r f =
86.49 - let val (A, AB) = `domain_type (fastype_of f);
86.50 - in Const (@{const_name relChain}, mk_relT (A, A) --> AB --> HOLogic.boolT) $ r $ f end;
86.51 -
86.52 -fun mk_cardSuc r =
86.53 - let val T = fst (dest_relT (fastype_of r));
86.54 - in Const (@{const_name cardSuc}, mk_relT (T, T) --> mk_relT (`I (HOLogic.mk_setT T))) $ r end;
86.55 -
86.56 -fun mk_cpow r =
86.57 - let val T = fst (dest_relT (fastype_of r));
86.58 - in Const (@{const_name cpow}, mk_relT (T, T) --> mk_relT (`I (HOLogic.mk_setT T))) $ r end;
86.59 -
86.60 -fun mk_bij_betw f A B =
86.61 - Const (@{const_name bij_betw},
86.62 - fastype_of f --> fastype_of A --> fastype_of B --> HOLogic.boolT) $ f $ A $ B;
86.63 -
86.64 -fun mk_inver f g A =
86.65 - Const (@{const_name inver}, fastype_of f --> fastype_of g --> fastype_of A --> HOLogic.boolT) $
86.66 - f $ g $ A;
86.67 -
86.68 -fun mk_not_eq x y = HOLogic.mk_not (HOLogic.mk_eq (x, y));
86.69 -
86.70 -fun mk_not_empty B = mk_not_eq B (HOLogic.mk_set (HOLogic.dest_setT (fastype_of B)) []);
86.71 -
86.72 -fun mk_convol (f, g) =
86.73 - let
86.74 - val (fU, fTU) = `range_type (fastype_of f);
86.75 - val ((gT, gU), gTU) = `dest_funT (fastype_of g);
86.76 - val convolT = fTU --> gTU --> gT --> HOLogic.mk_prodT (fU, gU);
86.77 - in Const (@{const_name convol}, convolT) $ f $ g end;
86.78 -
86.79 -end;
87.1 --- a/src/HOL/Codatatype/Tools/bnf_tactics.ML Fri Sep 21 16:34:40 2012 +0200
87.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
87.3 @@ -1,125 +0,0 @@
87.4 -(* Title: HOL/BNF/Tools/bnf_tactics.ML
87.5 - Author: Dmitriy Traytel, TU Muenchen
87.6 - Author: Jasmin Blanchette, TU Muenchen
87.7 - Copyright 2012
87.8 -
87.9 -General tactics for bounded natural functors.
87.10 -*)
87.11 -
87.12 -signature BNF_TACTICS =
87.13 -sig
87.14 - val ss_only: thm list -> simpset
87.15 -
87.16 - val prefer_tac: int -> tactic
87.17 - val select_prem_tac: int -> (int -> tactic) -> int -> int -> tactic
87.18 - val fo_rtac: thm -> Proof.context -> int -> tactic
87.19 - val subst_asm_tac: Proof.context -> thm list -> int -> tactic
87.20 - val subst_tac: Proof.context -> thm list -> int -> tactic
87.21 - val substs_tac: Proof.context -> thm list -> int -> tactic
87.22 - val unfold_thms_tac: Proof.context -> thm list -> tactic
87.23 - val mk_unfold_thms_then_tac: Proof.context -> thm list -> ('a -> tactic) -> 'a -> tactic
87.24 -
87.25 - val mk_flatten_assoc_tac: (int -> tactic) -> thm -> thm -> thm -> tactic
87.26 - val mk_rotate_eq_tac: (int -> tactic) -> thm -> thm -> thm -> thm -> ''a list -> ''a list ->
87.27 - int -> tactic
87.28 -
87.29 - val mk_Abs_bij_thm: Proof.context -> thm -> thm -> thm
87.30 - val mk_Abs_inj_thm: thm -> thm
87.31 -
87.32 - val simple_srel_O_Gr_tac: Proof.context -> tactic
87.33 - val mk_rel_simp_tac: thm -> thm list -> thm list -> thm -> {prems: 'a, context: Proof.context} ->
87.34 - tactic
87.35 -
87.36 - val mk_map_comp_id_tac: thm -> tactic
87.37 - val mk_map_cong_tac: int -> thm -> {prems: 'a, context: Proof.context} -> tactic
87.38 - val mk_map_congL_tac: int -> thm -> thm -> tactic
87.39 -end;
87.40 -
87.41 -structure BNF_Tactics : BNF_TACTICS =
87.42 -struct
87.43 -
87.44 -open BNF_Util
87.45 -
87.46 -fun ss_only thms = Simplifier.clear_ss HOL_basic_ss addsimps thms;
87.47 -
87.48 -(* FIXME: why not in "Pure"? *)
87.49 -fun prefer_tac i = defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1);
87.50 -
87.51 -fun select_prem_tac n tac k = DETERM o (EVERY' [REPEAT_DETERM_N (k - 1) o etac thin_rl,
87.52 - tac, REPEAT_DETERM_N (n - k) o etac thin_rl]);
87.53 -
87.54 -(*stolen from Christian Urban's Cookbook*)
87.55 -fun fo_rtac thm = Subgoal.FOCUS (fn {concl, ...} =>
87.56 - let
87.57 - val concl_pat = Drule.strip_imp_concl (cprop_of thm)
87.58 - val insts = Thm.first_order_match (concl_pat, concl)
87.59 - in
87.60 - rtac (Drule.instantiate_normalize insts thm) 1
87.61 - end);
87.62 -
87.63 -fun unfold_thms_tac ctxt thms = Local_Defs.unfold_tac ctxt (distinct Thm.eq_thm_prop thms);
87.64 -
87.65 -fun mk_unfold_thms_then_tac lthy defs tac x = unfold_thms_tac lthy defs THEN tac x;
87.66 -
87.67 -(*unlike "unfold_thms_tac", succeeds when the RHS contains schematic variables not in the LHS*)
87.68 -fun subst_asm_tac ctxt = EqSubst.eqsubst_asm_tac ctxt [0];
87.69 -fun subst_tac ctxt = EqSubst.eqsubst_tac ctxt [0];
87.70 -fun substs_tac ctxt = REPEAT_DETERM oo subst_tac ctxt;
87.71 -
87.72 -
87.73 -(* Theorems for open typedefs with UNIV as representing set *)
87.74 -
87.75 -fun mk_Abs_inj_thm inj = inj OF (replicate 2 UNIV_I);
87.76 -fun mk_Abs_bij_thm ctxt Abs_inj_thm surj = rule_by_tactic ctxt ((rtac surj THEN' etac exI) 1)
87.77 - (Abs_inj_thm RS @{thm bijI});
87.78 -
87.79 -
87.80 -
87.81 -(* General tactic generators *)
87.82 -
87.83 -(*applies assoc rule to the lhs of an equation as long as possible*)
87.84 -fun mk_flatten_assoc_tac refl_tac trans assoc cong = rtac trans 1 THEN
87.85 - REPEAT_DETERM (CHANGED ((FIRST' [rtac trans THEN' rtac assoc, rtac cong THEN' refl_tac]) 1)) THEN
87.86 - refl_tac 1;
87.87 -
87.88 -(*proves two sides of an equation to be equal assuming both are flattened and rhs can be obtained
87.89 -from lhs by the given permutation of monoms*)
87.90 -fun mk_rotate_eq_tac refl_tac trans assoc com cong =
87.91 - let
87.92 - fun gen_tac [] [] = K all_tac
87.93 - | gen_tac [x] [y] = if x = y then refl_tac else error "mk_rotate_eq_tac: different lists"
87.94 - | gen_tac (x :: xs) (y :: ys) = if x = y
87.95 - then rtac cong THEN' refl_tac THEN' gen_tac xs ys
87.96 - else rtac trans THEN' rtac com THEN'
87.97 - K (mk_flatten_assoc_tac refl_tac trans assoc cong) THEN'
87.98 - gen_tac (xs @ [x]) (y :: ys)
87.99 - | gen_tac _ _ = error "mk_rotate_eq_tac: different lists";
87.100 - in
87.101 - gen_tac
87.102 - end;
87.103 -
87.104 -fun simple_srel_O_Gr_tac ctxt =
87.105 - unfold_thms_tac ctxt @{thms Collect_fst_snd_mem_eq Collect_pair_mem_eq} THEN rtac refl 1;
87.106 -
87.107 -fun mk_rel_simp_tac srel_def IJrel_defs IJsrel_defs srel_simp {context = ctxt, prems = _} =
87.108 - unfold_thms_tac ctxt IJrel_defs THEN
87.109 - subst_tac ctxt [unfold_thms ctxt (IJrel_defs @ IJsrel_defs @
87.110 - @{thms Collect_pair_mem_eq mem_Collect_eq fst_conv snd_conv}) srel_simp] 1 THEN
87.111 - unfold_thms_tac ctxt (srel_def ::
87.112 - @{thms Collect_fst_snd_mem_eq mem_Collect_eq pair_mem_Collect_split fst_conv snd_conv
87.113 - split_conv}) THEN
87.114 - rtac refl 1;
87.115 -
87.116 -fun mk_map_comp_id_tac map_comp =
87.117 - (rtac trans THEN' rtac map_comp THEN' REPEAT_DETERM o stac @{thm o_id} THEN' rtac refl) 1;
87.118 -
87.119 -fun mk_map_cong_tac m map_cong {context = ctxt, prems = _} =
87.120 - EVERY' [rtac mp, rtac map_cong,
87.121 - CONJ_WRAP' (K (rtac ballI THEN' Goal.assume_rule_tac ctxt)) (1 upto m)] 1;
87.122 -
87.123 -fun mk_map_congL_tac passive map_cong map_id' =
87.124 - (rtac trans THEN' rtac map_cong THEN' EVERY' (replicate passive (rtac refl))) 1 THEN
87.125 - REPEAT_DETERM (EVERY' [rtac trans, etac bspec, atac, rtac sym, rtac @{thm id_apply}] 1) THEN
87.126 - rtac map_id' 1;
87.127 -
87.128 -end;
88.1 --- a/src/HOL/Codatatype/Tools/bnf_util.ML Fri Sep 21 16:34:40 2012 +0200
88.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
88.3 @@ -1,619 +0,0 @@
88.4 -(* Title: HOL/BNF/Tools/bnf_util.ML
88.5 - Author: Dmitriy Traytel, TU Muenchen
88.6 - Copyright 2012
88.7 -
88.8 -Library for bounded natural functors.
88.9 -*)
88.10 -
88.11 -signature BNF_UTIL =
88.12 -sig
88.13 - val map3: ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
88.14 - val map4: ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
88.15 - val map5: ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
88.16 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list
88.17 - val map6: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) ->
88.18 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list
88.19 - val map7: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) ->
88.20 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list
88.21 - val map8: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i) ->
88.22 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list -> 'i list
88.23 - val map9: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j) ->
88.24 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
88.25 - 'i list -> 'j list
88.26 - val map10: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k) ->
88.27 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
88.28 - 'i list -> 'j list -> 'k list
88.29 - val map11: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k -> 'l) ->
88.30 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
88.31 - 'i list -> 'j list -> 'k list -> 'l list
88.32 - val map12: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k -> 'l -> 'm) ->
88.33 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list ->
88.34 - 'i list -> 'j list -> 'k list -> 'l list -> 'm list
88.35 - val fold_map2: ('a -> 'b -> 'c -> 'd * 'c) -> 'a list -> 'b list -> 'c -> 'd list * 'c
88.36 - val fold_map3: ('a -> 'b -> 'c -> 'd -> 'e * 'd) ->
88.37 - 'a list -> 'b list -> 'c list -> 'd -> 'e list * 'd
88.38 - val fold_map4: ('a -> 'b -> 'c -> 'd -> 'e -> 'f * 'e) ->
88.39 - 'a list -> 'b list -> 'c list -> 'd list -> 'e -> 'f list * 'e
88.40 - val fold_map5: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g * 'f) ->
88.41 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f -> 'g list * 'f
88.42 - val fold_map6: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h * 'g) ->
88.43 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g -> 'h list * 'g
88.44 - val fold_map7: ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i * 'h) ->
88.45 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h -> 'i list * 'h
88.46 - val interleave: 'a list -> 'a list -> 'a list
88.47 - val transpose: 'a list list -> 'a list list
88.48 - val seq_conds: (bool -> 'a -> 'b) -> int -> int -> 'a list -> 'b list
88.49 -
88.50 - val mk_fresh_names: Proof.context -> int -> string -> string list * Proof.context
88.51 - val mk_TFrees: int -> Proof.context -> typ list * Proof.context
88.52 - val mk_TFreess: int list -> Proof.context -> typ list list * Proof.context
88.53 - val mk_TFrees': sort list -> Proof.context -> typ list * Proof.context
88.54 - val mk_Frees: string -> typ list -> Proof.context -> term list * Proof.context
88.55 - val mk_Freess: string -> typ list list -> Proof.context -> term list list * Proof.context
88.56 - val mk_Freesss: string -> typ list list list -> Proof.context ->
88.57 - term list list list * Proof.context
88.58 - val mk_Freessss: string -> typ list list list list -> Proof.context ->
88.59 - term list list list list * Proof.context
88.60 - val mk_Frees': string -> typ list -> Proof.context ->
88.61 - (term list * (string * typ) list) * Proof.context
88.62 - val mk_Freess': string -> typ list list -> Proof.context ->
88.63 - (term list list * (string * typ) list list) * Proof.context
88.64 - val nonzero_string_of_int: int -> string
88.65 -
88.66 - val strip_typeN: int -> typ -> typ list * typ
88.67 -
88.68 - val mk_predT: typ list -> typ
88.69 - val mk_pred1T: typ -> typ
88.70 - val mk_pred2T: typ -> typ -> typ
88.71 - val mk_optionT: typ -> typ
88.72 - val mk_relT: typ * typ -> typ
88.73 - val dest_relT: typ -> typ * typ
88.74 - val mk_sumT: typ * typ -> typ
88.75 -
88.76 - val ctwo: term
88.77 - val fst_const: typ -> term
88.78 - val snd_const: typ -> term
88.79 - val Id_const: typ -> term
88.80 -
88.81 - val mk_Ball: term -> term -> term
88.82 - val mk_Bex: term -> term -> term
88.83 - val mk_Card_order: term -> term
88.84 - val mk_Field: term -> term
88.85 - val mk_Gr: term -> term -> term
88.86 - val mk_IfN: typ -> term list -> term list -> term
88.87 - val mk_Trueprop_eq: term * term -> term
88.88 - val mk_UNION: term -> term -> term
88.89 - val mk_Union: typ -> term
88.90 - val mk_card_binop: string -> (typ * typ -> typ) -> term -> term -> term
88.91 - val mk_card_of: term -> term
88.92 - val mk_card_order: term -> term
88.93 - val mk_ccexp: term -> term -> term
88.94 - val mk_cexp: term -> term -> term
88.95 - val mk_cinfinite: term -> term
88.96 - val mk_collect: term list -> typ -> term
88.97 - val mk_converse: term -> term
88.98 - val mk_cprod: term -> term -> term
88.99 - val mk_csum: term -> term -> term
88.100 - val mk_dir_image: term -> term -> term
88.101 - val mk_image: term -> term
88.102 - val mk_in: term list -> term list -> typ -> term
88.103 - val mk_ordLeq: term -> term -> term
88.104 - val mk_rel_comp: term * term -> term
88.105 - val mk_subset: term -> term -> term
88.106 - val mk_wpull: term -> term -> term -> term -> term -> (term * term) option -> term -> term -> term
88.107 -
88.108 - val list_all_free: term list -> term -> term
88.109 - val list_exists_free: term list -> term -> term
88.110 -
88.111 - (*parameterized terms*)
88.112 - val mk_nthN: int -> term -> int -> term
88.113 -
88.114 - (*parameterized thms*)
88.115 - val mk_Un_upper: int -> int -> thm
88.116 - val mk_conjIN: int -> thm
88.117 - val mk_conjunctN: int -> int -> thm
88.118 - val conj_dests: int -> thm -> thm list
88.119 - val mk_disjIN: int -> int -> thm
88.120 - val mk_nthI: int -> int -> thm
88.121 - val mk_nth_conv: int -> int -> thm
88.122 - val mk_ordLeq_csum: int -> int -> thm -> thm
88.123 - val mk_UnIN: int -> int -> thm
88.124 -
88.125 - val ctrans: thm
88.126 - val o_apply: thm
88.127 - val set_mp: thm
88.128 - val set_rev_mp: thm
88.129 - val subset_UNIV: thm
88.130 - val Pair_eqD: thm
88.131 - val Pair_eqI: thm
88.132 - val mk_sym: thm -> thm
88.133 - val mk_trans: thm -> thm -> thm
88.134 - val mk_unabs_def: int -> thm -> thm
88.135 -
88.136 - val is_refl: thm -> bool
88.137 - val no_refl: thm list -> thm list
88.138 - val no_reflexive: thm list -> thm list
88.139 -
88.140 - val fold_thms: Proof.context -> thm list -> thm -> thm
88.141 - val unfold_thms: Proof.context -> thm list -> thm -> thm
88.142 -
88.143 - val mk_permute: ''a list -> ''a list -> 'b list -> 'b list
88.144 - val find_indices: ''a list -> ''a list -> int list
88.145 -
88.146 - val certifyT: Proof.context -> typ -> ctyp
88.147 - val certify: Proof.context -> term -> cterm
88.148 -
88.149 - val parse_binding_colon: Token.T list -> binding * Token.T list
88.150 - val parse_opt_binding_colon: Token.T list -> binding * Token.T list
88.151 -
88.152 - val typedef: bool -> binding option -> binding * (string * sort) list * mixfix -> term ->
88.153 - (binding * binding) option -> tactic -> local_theory -> (string * Typedef.info) * local_theory
88.154 -
88.155 - val WRAP: ('a -> tactic) -> ('a -> tactic) -> 'a list -> tactic -> tactic
88.156 - val WRAP': ('a -> int -> tactic) -> ('a -> int -> tactic) -> 'a list -> (int -> tactic) -> int ->
88.157 - tactic
88.158 - val CONJ_WRAP_GEN: tactic -> ('a -> tactic) -> 'a list -> tactic
88.159 - val CONJ_WRAP_GEN': (int -> tactic) -> ('a -> int -> tactic) -> 'a list -> int -> tactic
88.160 - val CONJ_WRAP: ('a -> tactic) -> 'a list -> tactic
88.161 - val CONJ_WRAP': ('a -> int -> tactic) -> 'a list -> int -> tactic
88.162 -end;
88.163 -
88.164 -structure BNF_Util : BNF_UTIL =
88.165 -struct
88.166 -
88.167 -(* Library proper *)
88.168 -
88.169 -fun map3 _ [] [] [] = []
88.170 - | map3 f (x1::x1s) (x2::x2s) (x3::x3s) = f x1 x2 x3 :: map3 f x1s x2s x3s
88.171 - | map3 _ _ _ _ = raise ListPair.UnequalLengths;
88.172 -
88.173 -fun map4 _ [] [] [] [] = []
88.174 - | map4 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) = f x1 x2 x3 x4 :: map4 f x1s x2s x3s x4s
88.175 - | map4 _ _ _ _ _ = raise ListPair.UnequalLengths;
88.176 -
88.177 -fun map5 _ [] [] [] [] [] = []
88.178 - | map5 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) =
88.179 - f x1 x2 x3 x4 x5 :: map5 f x1s x2s x3s x4s x5s
88.180 - | map5 _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.181 -
88.182 -fun map6 _ [] [] [] [] [] [] = []
88.183 - | map6 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) =
88.184 - f x1 x2 x3 x4 x5 x6 :: map6 f x1s x2s x3s x4s x5s x6s
88.185 - | map6 _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.186 -
88.187 -fun map7 _ [] [] [] [] [] [] [] = []
88.188 - | map7 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) (x7::x7s) =
88.189 - f x1 x2 x3 x4 x5 x6 x7 :: map7 f x1s x2s x3s x4s x5s x6s x7s
88.190 - | map7 _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.191 -
88.192 -fun map8 _ [] [] [] [] [] [] [] [] = []
88.193 - | map8 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) (x7::x7s) (x8::x8s) =
88.194 - f x1 x2 x3 x4 x5 x6 x7 x8 :: map8 f x1s x2s x3s x4s x5s x6s x7s x8s
88.195 - | map8 _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.196 -
88.197 -fun map9 _ [] [] [] [] [] [] [] [] [] = []
88.198 - | map9 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
88.199 - (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) =
88.200 - f x1 x2 x3 x4 x5 x6 x7 x8 x9 :: map9 f x1s x2s x3s x4s x5s x6s x7s x8s x9s
88.201 - | map9 _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.202 -
88.203 -fun map10 _ [] [] [] [] [] [] [] [] [] [] = []
88.204 - | map10 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
88.205 - (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) (x10::x10s) =
88.206 - f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 :: map10 f x1s x2s x3s x4s x5s x6s x7s x8s x9s x10s
88.207 - | map10 _ _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.208 -
88.209 -fun map11 _ [] [] [] [] [] [] [] [] [] [] [] = []
88.210 - | map11 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
88.211 - (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) (x10::x10s) (x11::x11s) =
88.212 - f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 :: map11 f x1s x2s x3s x4s x5s x6s x7s x8s x9s x10s x11s
88.213 - | map11 _ _ _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.214 -
88.215 -fun map12 _ [] [] [] [] [] [] [] [] [] [] [] [] = []
88.216 - | map12 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s)
88.217 - (x6::x6s) (x7::x7s) (x8::x8s) (x9::x9s) (x10::x10s) (x11::x11s) (x12::x12s) =
88.218 - f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 ::
88.219 - map12 f x1s x2s x3s x4s x5s x6s x7s x8s x9s x10s x11s x12s
88.220 - | map12 _ _ _ _ _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.221 -
88.222 -fun fold_map2 _ [] [] acc = ([], acc)
88.223 - | fold_map2 f (x1::x1s) (x2::x2s) acc =
88.224 - let
88.225 - val (x, acc') = f x1 x2 acc;
88.226 - val (xs, acc'') = fold_map2 f x1s x2s acc';
88.227 - in (x :: xs, acc'') end
88.228 - | fold_map2 _ _ _ _ = raise ListPair.UnequalLengths;
88.229 -
88.230 -fun fold_map3 _ [] [] [] acc = ([], acc)
88.231 - | fold_map3 f (x1::x1s) (x2::x2s) (x3::x3s) acc =
88.232 - let
88.233 - val (x, acc') = f x1 x2 x3 acc;
88.234 - val (xs, acc'') = fold_map3 f x1s x2s x3s acc';
88.235 - in (x :: xs, acc'') end
88.236 - | fold_map3 _ _ _ _ _ = raise ListPair.UnequalLengths;
88.237 -
88.238 -fun fold_map4 _ [] [] [] [] acc = ([], acc)
88.239 - | fold_map4 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) acc =
88.240 - let
88.241 - val (x, acc') = f x1 x2 x3 x4 acc;
88.242 - val (xs, acc'') = fold_map4 f x1s x2s x3s x4s acc';
88.243 - in (x :: xs, acc'') end
88.244 - | fold_map4 _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.245 -
88.246 -fun fold_map5 _ [] [] [] [] [] acc = ([], acc)
88.247 - | fold_map5 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) acc =
88.248 - let
88.249 - val (x, acc') = f x1 x2 x3 x4 x5 acc;
88.250 - val (xs, acc'') = fold_map5 f x1s x2s x3s x4s x5s acc';
88.251 - in (x :: xs, acc'') end
88.252 - | fold_map5 _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.253 -
88.254 -fun fold_map6 _ [] [] [] [] [] [] acc = ([], acc)
88.255 - | fold_map6 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) acc =
88.256 - let
88.257 - val (x, acc') = f x1 x2 x3 x4 x5 x6 acc;
88.258 - val (xs, acc'') = fold_map6 f x1s x2s x3s x4s x5s x6s acc';
88.259 - in (x :: xs, acc'') end
88.260 - | fold_map6 _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.261 -
88.262 -fun fold_map7 _ [] [] [] [] [] [] [] acc = ([], acc)
88.263 - | fold_map7 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) (x6::x6s) (x7::x7s) acc =
88.264 - let
88.265 - val (x, acc') = f x1 x2 x3 x4 x5 x6 x7 acc;
88.266 - val (xs, acc'') = fold_map7 f x1s x2s x3s x4s x5s x6s x7s acc';
88.267 - in (x :: xs, acc'') end
88.268 - | fold_map7 _ _ _ _ _ _ _ _ _ = raise ListPair.UnequalLengths;
88.269 -
88.270 -(*stolen from ~~/src/HOL/Tools/SMT/smt_utils.ML*)
88.271 -fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt);
88.272 -fun certifyT ctxt = Thm.ctyp_of (Proof_Context.theory_of ctxt);
88.273 -
88.274 -val parse_binding_colon = Parse.binding --| @{keyword ":"};
88.275 -val parse_opt_binding_colon = Scan.optional parse_binding_colon Binding.empty;
88.276 -
88.277 -(*TODO: is this really different from Typedef.add_typedef_global?*)
88.278 -fun typedef def opt_name typ set opt_morphs tac lthy =
88.279 - let
88.280 - val ((name, info), (lthy, lthy_old)) =
88.281 - lthy
88.282 - |> Typedef.add_typedef def opt_name typ set opt_morphs tac
88.283 - ||> `Local_Theory.restore;
88.284 - val phi = Proof_Context.export_morphism lthy_old lthy;
88.285 - in
88.286 - ((name, Typedef.transform_info phi info), lthy)
88.287 - end;
88.288 -
88.289 -(*Tactical WRAP surrounds a static given tactic (core) with two deterministic chains of tactics*)
88.290 -fun WRAP gen_before gen_after xs core_tac =
88.291 - fold_rev (fn x => fn tac => gen_before x THEN tac THEN gen_after x) xs core_tac;
88.292 -
88.293 -fun WRAP' gen_before gen_after xs core_tac =
88.294 - fold_rev (fn x => fn tac => gen_before x THEN' tac THEN' gen_after x) xs core_tac;
88.295 -
88.296 -fun CONJ_WRAP_GEN conj_tac gen_tac xs =
88.297 - let val (butlast, last) = split_last xs;
88.298 - in WRAP (fn thm => conj_tac THEN gen_tac thm) (K all_tac) butlast (gen_tac last) end;
88.299 -
88.300 -fun CONJ_WRAP_GEN' conj_tac gen_tac xs =
88.301 - let val (butlast, last) = split_last xs;
88.302 - in WRAP' (fn thm => conj_tac THEN' gen_tac thm) (K (K all_tac)) butlast (gen_tac last) end;
88.303 -
88.304 -(*not eta-converted because of monotype restriction*)
88.305 -fun CONJ_WRAP gen_tac = CONJ_WRAP_GEN (rtac conjI 1) gen_tac;
88.306 -fun CONJ_WRAP' gen_tac = CONJ_WRAP_GEN' (rtac conjI) gen_tac;
88.307 -
88.308 -
88.309 -
88.310 -(* Term construction *)
88.311 -
88.312 -(** Fresh variables **)
88.313 -
88.314 -fun nonzero_string_of_int 0 = ""
88.315 - | nonzero_string_of_int n = string_of_int n;
88.316 -
88.317 -val mk_TFrees' = apfst (map TFree) oo Variable.invent_types;
88.318 -
88.319 -fun mk_TFrees n = mk_TFrees' (replicate n HOLogic.typeS);
88.320 -val mk_TFreess = fold_map mk_TFrees;
88.321 -
88.322 -fun mk_names n x = if n = 1 then [x] else map (fn i => x ^ string_of_int i) (1 upto n);
88.323 -
88.324 -fun mk_fresh_names ctxt = (fn xs => Variable.variant_fixes xs ctxt) oo mk_names;
88.325 -fun mk_Frees x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => map2 (curry Free) xs Ts);
88.326 -fun mk_Freess x Tss = fold_map2 mk_Frees (mk_names (length Tss) x) Tss;
88.327 -fun mk_Freesss x Tsss = fold_map2 mk_Freess (mk_names (length Tsss) x) Tsss;
88.328 -fun mk_Freessss x Tssss = fold_map2 mk_Freesss (mk_names (length Tssss) x) Tssss;
88.329 -fun mk_Frees' x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => `(map Free) (xs ~~ Ts));
88.330 -fun mk_Freess' x Tss = fold_map2 mk_Frees' (mk_names (length Tss) x) Tss #>> split_list;
88.331 -
88.332 -
88.333 -(** Types **)
88.334 -
88.335 -fun strip_typeN 0 T = ([], T)
88.336 - | strip_typeN n (Type (@{type_name fun}, [T, T'])) = strip_typeN (n - 1) T' |>> cons T
88.337 - | strip_typeN _ T = raise TYPE ("strip_typeN", [T], []);
88.338 -
88.339 -fun mk_predT Ts = Ts ---> HOLogic.boolT;
88.340 -fun mk_pred1T T = mk_predT [T];
88.341 -fun mk_pred2T T U = mk_predT [T, U];
88.342 -fun mk_optionT T = Type (@{type_name option}, [T]);
88.343 -val mk_relT = HOLogic.mk_setT o HOLogic.mk_prodT;
88.344 -val dest_relT = HOLogic.dest_prodT o HOLogic.dest_setT;
88.345 -fun mk_sumT (LT, RT) = Type (@{type_name Sum_Type.sum}, [LT, RT]);
88.346 -fun mk_partial_funT (ranT, domT) = domT --> mk_optionT ranT;
88.347 -
88.348 -
88.349 -(** Constants **)
88.350 -
88.351 -fun fst_const T = Const (@{const_name fst}, T --> fst (HOLogic.dest_prodT T));
88.352 -fun snd_const T = Const (@{const_name snd}, T --> snd (HOLogic.dest_prodT T));
88.353 -fun Id_const T = Const (@{const_name Id}, mk_relT (T, T));
88.354 -
88.355 -
88.356 -(** Operators **)
88.357 -
88.358 -val mk_Trueprop_eq = HOLogic.mk_Trueprop o HOLogic.mk_eq;
88.359 -
88.360 -fun mk_IfN _ _ [t] = t
88.361 - | mk_IfN T (c :: cs) (t :: ts) =
88.362 - Const (@{const_name If}, HOLogic.boolT --> T --> T --> T) $ c $ t $ mk_IfN T cs ts;
88.363 -
88.364 -fun mk_converse R =
88.365 - let
88.366 - val RT = dest_relT (fastype_of R);
88.367 - val RST = mk_relT (snd RT, fst RT);
88.368 - in Const (@{const_name converse}, fastype_of R --> RST) $ R end;
88.369 -
88.370 -fun mk_rel_comp (R, S) =
88.371 - let
88.372 - val RT = fastype_of R;
88.373 - val ST = fastype_of S;
88.374 - val RST = mk_relT (fst (dest_relT RT), snd (dest_relT ST));
88.375 - in Const (@{const_name relcomp}, RT --> ST --> RST) $ R $ S end;
88.376 -
88.377 -fun mk_Gr A f =
88.378 - let val ((AT, BT), FT) = `dest_funT (fastype_of f);
88.379 - in Const (@{const_name Gr}, HOLogic.mk_setT AT --> FT --> mk_relT (AT, BT)) $ A $ f end;
88.380 -
88.381 -fun mk_image f =
88.382 - let val (T, U) = dest_funT (fastype_of f);
88.383 - in Const (@{const_name image},
88.384 - (T --> U) --> (HOLogic.mk_setT T) --> (HOLogic.mk_setT U)) $ f end;
88.385 -
88.386 -fun mk_Ball X f =
88.387 - Const (@{const_name Ball}, fastype_of X --> fastype_of f --> HOLogic.boolT) $ X $ f;
88.388 -
88.389 -fun mk_Bex X f =
88.390 - Const (@{const_name Bex}, fastype_of X --> fastype_of f --> HOLogic.boolT) $ X $ f;
88.391 -
88.392 -fun mk_UNION X f =
88.393 - let val (T, U) = dest_funT (fastype_of f);
88.394 - in Const (@{const_name SUPR}, fastype_of X --> (T --> U) --> U) $ X $ f end;
88.395 -
88.396 -fun mk_Union T =
88.397 - Const (@{const_name Sup}, HOLogic.mk_setT (HOLogic.mk_setT T) --> HOLogic.mk_setT T);
88.398 -
88.399 -fun mk_Field r =
88.400 - let val T = fst (dest_relT (fastype_of r));
88.401 - in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
88.402 -
88.403 -fun mk_card_order bd =
88.404 - let
88.405 - val T = fastype_of bd;
88.406 - val AT = fst (dest_relT T);
88.407 - in
88.408 - Const (@{const_name card_order_on}, HOLogic.mk_setT AT --> T --> HOLogic.boolT) $
88.409 - (HOLogic.mk_UNIV AT) $ bd
88.410 - end;
88.411 -
88.412 -fun mk_Card_order bd =
88.413 - let
88.414 - val T = fastype_of bd;
88.415 - val AT = fst (dest_relT T);
88.416 - in
88.417 - Const (@{const_name card_order_on}, HOLogic.mk_setT AT --> T --> HOLogic.boolT) $
88.418 - mk_Field bd $ bd
88.419 - end;
88.420 -
88.421 -fun mk_cinfinite bd =
88.422 - Const (@{const_name cinfinite}, fastype_of bd --> HOLogic.boolT) $ bd;
88.423 -
88.424 -fun mk_ordLeq t1 t2 =
88.425 - HOLogic.mk_mem (HOLogic.mk_prod (t1, t2),
88.426 - Const (@{const_name ordLeq}, mk_relT (fastype_of t1, fastype_of t2)));
88.427 -
88.428 -fun mk_card_of A =
88.429 - let
88.430 - val AT = fastype_of A;
88.431 - val T = HOLogic.dest_setT AT;
88.432 - in
88.433 - Const (@{const_name card_of}, AT --> mk_relT (T, T)) $ A
88.434 - end;
88.435 -
88.436 -fun mk_dir_image r f =
88.437 - let val (T, U) = dest_funT (fastype_of f);
88.438 - in Const (@{const_name dir_image}, mk_relT (T, T) --> (T --> U) --> mk_relT (U, U)) $ r $ f end;
88.439 -
88.440 -(*FIXME: "x"?*)
88.441 -(*(nth sets i) must be of type "T --> 'ai set"*)
88.442 -fun mk_in As sets T =
88.443 - let
88.444 - fun in_single set A =
88.445 - let val AT = fastype_of A;
88.446 - in Const (@{const_name less_eq},
88.447 - AT --> AT --> HOLogic.boolT) $ (set $ Free ("x", T)) $ A end;
88.448 - in
88.449 - if length sets > 0
88.450 - then HOLogic.mk_Collect ("x", T, foldr1 (HOLogic.mk_conj) (map2 in_single sets As))
88.451 - else HOLogic.mk_UNIV T
88.452 - end;
88.453 -
88.454 -fun mk_wpull A B1 B2 f1 f2 pseudo p1 p2 =
88.455 - let
88.456 - val AT = fastype_of A;
88.457 - val BT1 = fastype_of B1;
88.458 - val BT2 = fastype_of B2;
88.459 - val FT1 = fastype_of f1;
88.460 - val FT2 = fastype_of f2;
88.461 - val PT1 = fastype_of p1;
88.462 - val PT2 = fastype_of p2;
88.463 - val T1 = HOLogic.dest_setT BT1;
88.464 - val T2 = HOLogic.dest_setT BT2;
88.465 - val domP = domain_type PT1;
88.466 - val ranF = range_type FT1;
88.467 - val _ = if is_some pseudo orelse
88.468 - (HOLogic.dest_setT AT = domP andalso
88.469 - domain_type FT1 = T1 andalso
88.470 - domain_type FT2 = T2 andalso
88.471 - domain_type PT2 = domP andalso
88.472 - range_type PT1 = T1 andalso
88.473 - range_type PT2 = T2 andalso
88.474 - range_type FT2 = ranF)
88.475 - then () else raise TYPE ("mk_wpull", [BT1, BT2, FT1, FT2, PT1, PT2], []);
88.476 - in
88.477 - (case pseudo of
88.478 - NONE => Const (@{const_name wpull},
88.479 - AT --> BT1 --> BT2 --> FT1 --> FT2 --> PT1 --> PT2 --> HOLogic.boolT) $
88.480 - A $ B1 $ B2 $ f1 $ f2 $ p1 $ p2
88.481 - | SOME (e1, e2) => Const (@{const_name wppull},
88.482 - AT --> BT1 --> BT2 --> FT1 --> FT2 --> fastype_of e1 --> fastype_of e2 -->
88.483 - PT1 --> PT2 --> HOLogic.boolT) $
88.484 - A $ B1 $ B2 $ f1 $ f2 $ e1 $ e2 $ p1 $ p2)
88.485 - end;
88.486 -
88.487 -fun mk_subset t1 t2 =
88.488 - Const (@{const_name less_eq}, (fastype_of t1) --> (fastype_of t2) --> HOLogic.boolT) $ t1 $ t2;
88.489 -
88.490 -fun mk_card_binop binop typop t1 t2 =
88.491 - let
88.492 - val (T1, relT1) = `(fst o dest_relT) (fastype_of t1);
88.493 - val (T2, relT2) = `(fst o dest_relT) (fastype_of t2);
88.494 - in
88.495 - Const (binop, relT1 --> relT2 --> mk_relT (typop (T1, T2), typop (T1, T2))) $ t1 $ t2
88.496 - end;
88.497 -
88.498 -val mk_csum = mk_card_binop @{const_name csum} mk_sumT;
88.499 -val mk_cprod = mk_card_binop @{const_name cprod} HOLogic.mk_prodT;
88.500 -val mk_cexp = mk_card_binop @{const_name cexp} mk_partial_funT;
88.501 -val mk_ccexp = mk_card_binop @{const_name ccexp} mk_partial_funT;
88.502 -val ctwo = @{term ctwo};
88.503 -
88.504 -fun mk_collect xs defT =
88.505 - let val T = (case xs of [] => defT | (x::_) => fastype_of x);
88.506 - in Const (@{const_name collect}, HOLogic.mk_setT T --> T) $ (HOLogic.mk_set T xs) end;
88.507 -
88.508 -fun mk_permute src dest xs = map (nth xs o (fn x => find_index ((curry op =) x) src)) dest;
88.509 -
88.510 -val list_all_free =
88.511 - fold_rev (fn free => fn P =>
88.512 - let val (x, T) = Term.dest_Free free;
88.513 - in HOLogic.all_const T $ Term.absfree (x, T) P end);
88.514 -
88.515 -val list_exists_free =
88.516 - fold_rev (fn free => fn P =>
88.517 - let val (x, T) = Term.dest_Free free;
88.518 - in HOLogic.exists_const T $ Term.absfree (x, T) P end);
88.519 -
88.520 -fun find_indices xs ys = map_filter I
88.521 - (map_index (fn (i, y) => if member (op =) xs y then SOME i else NONE) ys);
88.522 -
88.523 -fun mk_trans thm1 thm2 = trans OF [thm1, thm2];
88.524 -fun mk_sym thm = sym OF [thm];
88.525 -
88.526 -(*TODO: antiquote heavily used theorems once*)
88.527 -val ctrans = @{thm ordLeq_transitive};
88.528 -val o_apply = @{thm o_apply};
88.529 -val set_mp = @{thm set_mp};
88.530 -val set_rev_mp = @{thm set_rev_mp};
88.531 -val subset_UNIV = @{thm subset_UNIV};
88.532 -val Pair_eqD = @{thm iffD1[OF Pair_eq]};
88.533 -val Pair_eqI = @{thm iffD2[OF Pair_eq]};
88.534 -
88.535 -fun mk_nthN 1 t 1 = t
88.536 - | mk_nthN _ t 1 = HOLogic.mk_fst t
88.537 - | mk_nthN 2 t 2 = HOLogic.mk_snd t
88.538 - | mk_nthN n t m = mk_nthN (n - 1) (HOLogic.mk_snd t) (m - 1);
88.539 -
88.540 -fun mk_nth_conv n m =
88.541 - let
88.542 - fun thm b = if b then @{thm fst_snd} else @{thm snd_snd}
88.543 - fun mk_nth_conv _ 1 1 = refl
88.544 - | mk_nth_conv _ _ 1 = @{thm fst_conv}
88.545 - | mk_nth_conv _ 2 2 = @{thm snd_conv}
88.546 - | mk_nth_conv b _ 2 = @{thm snd_conv} RS thm b
88.547 - | mk_nth_conv b n m = mk_nth_conv false (n - 1) (m - 1) RS thm b;
88.548 - in mk_nth_conv (not (m = n)) n m end;
88.549 -
88.550 -fun mk_nthI 1 1 = @{thm TrueE[OF TrueI]}
88.551 - | mk_nthI n m = fold (curry op RS) (replicate (m - 1) @{thm sndI})
88.552 - (if m = n then @{thm TrueE[OF TrueI]} else @{thm fstI});
88.553 -
88.554 -fun mk_conjunctN 1 1 = @{thm TrueE[OF TrueI]}
88.555 - | mk_conjunctN _ 1 = conjunct1
88.556 - | mk_conjunctN 2 2 = conjunct2
88.557 - | mk_conjunctN n m = conjunct2 RS (mk_conjunctN (n - 1) (m - 1));
88.558 -
88.559 -fun conj_dests n thm = map (fn k => thm RS mk_conjunctN n k) (1 upto n);
88.560 -
88.561 -fun mk_conjIN 1 = @{thm TrueE[OF TrueI]}
88.562 - | mk_conjIN n = mk_conjIN (n - 1) RSN (2, conjI);
88.563 -
88.564 -fun mk_disjIN 1 1 = @{thm TrueE[OF TrueI]}
88.565 - | mk_disjIN _ 1 = disjI1
88.566 - | mk_disjIN 2 2 = disjI2
88.567 - | mk_disjIN n m = (mk_disjIN (n - 1) (m - 1)) RS disjI2;
88.568 -
88.569 -fun mk_ordLeq_csum 1 1 thm = thm
88.570 - | mk_ordLeq_csum _ 1 thm = @{thm ordLeq_transitive} OF [thm, @{thm ordLeq_csum1}]
88.571 - | mk_ordLeq_csum 2 2 thm = @{thm ordLeq_transitive} OF [thm, @{thm ordLeq_csum2}]
88.572 - | mk_ordLeq_csum n m thm = @{thm ordLeq_transitive} OF
88.573 - [mk_ordLeq_csum (n - 1) (m - 1) thm, @{thm ordLeq_csum2[OF Card_order_csum]}];
88.574 -
88.575 -local
88.576 - fun mk_Un_upper' 0 = subset_refl
88.577 - | mk_Un_upper' 1 = @{thm Un_upper1}
88.578 - | mk_Un_upper' k = Library.foldr (op RS o swap)
88.579 - (replicate (k - 1) @{thm subset_trans[OF Un_upper1]}, @{thm Un_upper1});
88.580 -in
88.581 - fun mk_Un_upper 1 1 = subset_refl
88.582 - | mk_Un_upper n 1 = mk_Un_upper' (n - 2) RS @{thm subset_trans[OF Un_upper1]}
88.583 - | mk_Un_upper n m = mk_Un_upper' (n - m) RS @{thm subset_trans[OF Un_upper2]};
88.584 -end;
88.585 -
88.586 -local
88.587 - fun mk_UnIN' 0 = @{thm UnI2}
88.588 - | mk_UnIN' m = mk_UnIN' (m - 1) RS @{thm UnI1};
88.589 -in
88.590 - fun mk_UnIN 1 1 = @{thm TrueE[OF TrueI]}
88.591 - | mk_UnIN n 1 = Library.foldr1 (op RS o swap) (replicate (n - 1) @{thm UnI1})
88.592 - | mk_UnIN n m = mk_UnIN' (n - m)
88.593 -end;
88.594 -
88.595 -fun interleave xs ys = flat (map2 (fn x => fn y => [x, y]) xs ys);
88.596 -
88.597 -fun transpose [] = []
88.598 - | transpose ([] :: xss) = transpose xss
88.599 - | transpose xss = map hd xss :: transpose (map tl xss);
88.600 -
88.601 -fun seq_conds f n k xs =
88.602 - if k = n then
88.603 - map (f false) (take (k - 1) xs)
88.604 - else
88.605 - let val (negs, pos) = split_last (take k xs) in
88.606 - map (f false) negs @ [f true pos]
88.607 - end;
88.608 -
88.609 -fun mk_unabs_def 0 thm = thm
88.610 - | mk_unabs_def n thm = mk_unabs_def (n - 1) thm RS @{thm spec[OF iffD1[OF fun_eq_iff]]};
88.611 -
88.612 -fun is_refl thm =
88.613 - op aconv (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of thm)))
88.614 - handle TERM _ => false;
88.615 -
88.616 -val no_refl = filter_out is_refl;
88.617 -val no_reflexive = filter_out Thm.is_reflexive;
88.618 -
88.619 -fun fold_thms ctxt thms = Local_Defs.fold ctxt (distinct Thm.eq_thm_prop thms);
88.620 -fun unfold_thms ctxt thms = Local_Defs.unfold ctxt (distinct Thm.eq_thm_prop thms);
88.621 -
88.622 -end;
89.1 --- a/src/HOL/Codatatype/Tools/bnf_wrap.ML Fri Sep 21 16:34:40 2012 +0200
89.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
89.3 @@ -1,665 +0,0 @@
89.4 -(* Title: HOL/BNF/Tools/bnf_wrap.ML
89.5 - Author: Jasmin Blanchette, TU Muenchen
89.6 - Copyright 2012
89.7 -
89.8 -Wrapping existing datatypes.
89.9 -*)
89.10 -
89.11 -signature BNF_WRAP =
89.12 -sig
89.13 - val mk_half_pairss: 'a list -> ('a * 'a) list list
89.14 - val mk_ctr: typ list -> term -> term
89.15 - val mk_disc_or_sel: typ list -> term -> term
89.16 - val base_name_of_ctr: term -> string
89.17 - val wrap_datatype: ({prems: thm list, context: Proof.context} -> tactic) list list ->
89.18 - ((bool * term list) * term) *
89.19 - (binding list * (binding list list * (binding * term) list list)) -> local_theory ->
89.20 - (term list * term list list * thm list * thm list * thm list * thm list list * thm list *
89.21 - thm list list) * local_theory
89.22 - val parse_wrap_options: bool parser
89.23 - val parse_bound_term: (binding * string) parser
89.24 -end;
89.25 -
89.26 -structure BNF_Wrap : BNF_WRAP =
89.27 -struct
89.28 -
89.29 -open BNF_Util
89.30 -open BNF_Wrap_Tactics
89.31 -
89.32 -val isN = "is_";
89.33 -val unN = "un_";
89.34 -fun mk_unN 1 1 suf = unN ^ suf
89.35 - | mk_unN _ l suf = unN ^ suf ^ string_of_int l;
89.36 -
89.37 -val case_congN = "case_cong";
89.38 -val case_eqN = "case_eq";
89.39 -val casesN = "cases";
89.40 -val collapseN = "collapse";
89.41 -val disc_excludeN = "disc_exclude";
89.42 -val disc_exhaustN = "disc_exhaust";
89.43 -val discsN = "discs";
89.44 -val distinctN = "distinct";
89.45 -val exhaustN = "exhaust";
89.46 -val expandN = "expand";
89.47 -val injectN = "inject";
89.48 -val nchotomyN = "nchotomy";
89.49 -val selsN = "sels";
89.50 -val splitN = "split";
89.51 -val split_asmN = "split_asm";
89.52 -val weak_case_cong_thmsN = "weak_case_cong";
89.53 -
89.54 -val std_binding = @{binding _};
89.55 -
89.56 -val induct_simp_attrs = @{attributes [induct_simp]};
89.57 -val cong_attrs = @{attributes [cong]};
89.58 -val iff_attrs = @{attributes [iff]};
89.59 -val safe_elim_attrs = @{attributes [elim!]};
89.60 -val simp_attrs = @{attributes [simp]};
89.61 -
89.62 -fun pad_list x n xs = xs @ replicate (n - length xs) x;
89.63 -
89.64 -fun unflat_lookup eq ys zs = map (map (fn x => nth zs (find_index (curry eq x) ys)));
89.65 -
89.66 -fun mk_half_pairss' _ [] = []
89.67 - | mk_half_pairss' indent (x :: xs) =
89.68 - indent @ fold_rev (cons o single o pair x) xs (mk_half_pairss' ([] :: indent) xs);
89.69 -
89.70 -fun mk_half_pairss xs = mk_half_pairss' [[]] xs;
89.71 -
89.72 -fun join_halves n half_xss other_half_xss =
89.73 - let
89.74 - val xsss =
89.75 - map2 (map2 append) (Library.chop_groups n half_xss)
89.76 - (transpose (Library.chop_groups n other_half_xss))
89.77 - val xs = interleave (flat half_xss) (flat other_half_xss);
89.78 - in (xs, xsss |> `transpose) end;
89.79 -
89.80 -fun mk_undefined T = Const (@{const_name undefined}, T);
89.81 -
89.82 -fun mk_ctr Ts t =
89.83 - let val Type (_, Ts0) = body_type (fastype_of t) in
89.84 - Term.subst_atomic_types (Ts0 ~~ Ts) t
89.85 - end;
89.86 -
89.87 -fun mk_disc_or_sel Ts t =
89.88 - Term.subst_atomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t;
89.89 -
89.90 -fun base_name_of_ctr c =
89.91 - Long_Name.base_name (case head_of c of
89.92 - Const (s, _) => s
89.93 - | Free (s, _) => s
89.94 - | _ => error "Cannot extract name of constructor");
89.95 -
89.96 -fun rapp u t = betapply (t, u);
89.97 -
89.98 -fun eta_expand_arg xs f_xs = fold_rev Term.lambda xs f_xs;
89.99 -
89.100 -fun prepare_wrap_datatype prep_term (((no_dests, raw_ctrs), raw_case),
89.101 - (raw_disc_bindings, (raw_sel_bindingss, raw_sel_defaultss))) no_defs_lthy =
89.102 - let
89.103 - (* TODO: sanity checks on arguments *)
89.104 - (* TODO: case syntax *)
89.105 -
89.106 - val n = length raw_ctrs;
89.107 - val ks = 1 upto n;
89.108 -
89.109 - val _ = if n > 0 then () else error "No constructors specified";
89.110 -
89.111 - val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs;
89.112 - val case0 = prep_term no_defs_lthy raw_case;
89.113 - val sel_defaultss =
89.114 - pad_list [] n (map (map (apsnd (prep_term no_defs_lthy))) raw_sel_defaultss);
89.115 -
89.116 - val Type (dataT_name, As0) = body_type (fastype_of (hd ctrs0));
89.117 - val data_b = Binding.qualified_name dataT_name;
89.118 - val data_b_name = Binding.name_of data_b;
89.119 -
89.120 - val (As, B) =
89.121 - no_defs_lthy
89.122 - |> mk_TFrees' (map Type.sort_of_atyp As0)
89.123 - ||> the_single o fst o mk_TFrees 1;
89.124 -
89.125 - val dataT = Type (dataT_name, As);
89.126 - val ctrs = map (mk_ctr As) ctrs0;
89.127 - val ctr_Tss = map (binder_types o fastype_of) ctrs;
89.128 -
89.129 - val ms = map length ctr_Tss;
89.130 -
89.131 - val raw_disc_bindings' = pad_list Binding.empty n raw_disc_bindings;
89.132 -
89.133 - fun can_really_rely_on_disc k =
89.134 - not (Binding.eq_name (nth raw_disc_bindings' (k - 1), Binding.empty)) orelse
89.135 - nth ms (k - 1) = 0;
89.136 - fun can_rely_on_disc k =
89.137 - can_really_rely_on_disc k orelse (k = 1 andalso not (can_really_rely_on_disc 2));
89.138 - fun can_omit_disc_binding k m =
89.139 - n = 1 orelse m = 0 orelse (n = 2 andalso can_rely_on_disc (3 - k));
89.140 -
89.141 - val std_disc_binding =
89.142 - Binding.qualify false data_b_name o Binding.name o prefix isN o base_name_of_ctr;
89.143 -
89.144 - val disc_bindings =
89.145 - raw_disc_bindings'
89.146 - |> map4 (fn k => fn m => fn ctr => fn disc =>
89.147 - Option.map (Binding.qualify false data_b_name)
89.148 - (if Binding.eq_name (disc, Binding.empty) then
89.149 - if can_omit_disc_binding k m then NONE else SOME (std_disc_binding ctr)
89.150 - else if Binding.eq_name (disc, std_binding) then
89.151 - SOME (std_disc_binding ctr)
89.152 - else
89.153 - SOME disc)) ks ms ctrs0;
89.154 -
89.155 - val no_discs = map is_none disc_bindings;
89.156 - val no_discs_at_all = forall I no_discs;
89.157 -
89.158 - fun std_sel_binding m l = Binding.name o mk_unN m l o base_name_of_ctr;
89.159 -
89.160 - val sel_bindingss =
89.161 - pad_list [] n raw_sel_bindingss
89.162 - |> map3 (fn ctr => fn m => map2 (fn l => fn sel =>
89.163 - Binding.qualify false data_b_name
89.164 - (if Binding.eq_name (sel, Binding.empty) orelse Binding.eq_name (sel, std_binding) then
89.165 - std_sel_binding m l ctr
89.166 - else
89.167 - sel)) (1 upto m) o pad_list Binding.empty m) ctrs0 ms;
89.168 -
89.169 - fun mk_case Ts T =
89.170 - let
89.171 - val (bindings, body) = strip_type (fastype_of case0)
89.172 - val Type (_, Ts0) = List.last bindings
89.173 - in Term.subst_atomic_types ((body, T) :: (Ts0 ~~ Ts)) case0 end;
89.174 -
89.175 - val casex = mk_case As B;
89.176 - val case_Ts = map (fn Ts => Ts ---> B) ctr_Tss;
89.177 -
89.178 - val (((((((xss, xss'), yss), fs), gs), [u', v']), (p, p')), names_lthy) = no_defs_lthy |>
89.179 - mk_Freess' "x" ctr_Tss
89.180 - ||>> mk_Freess "y" ctr_Tss
89.181 - ||>> mk_Frees "f" case_Ts
89.182 - ||>> mk_Frees "g" case_Ts
89.183 - ||>> (apfst (map (rpair dataT)) oo Variable.variant_fixes) [data_b_name, data_b_name ^ "'"]
89.184 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "P") HOLogic.boolT;
89.185 -
89.186 - val u = Free u';
89.187 - val v = Free v';
89.188 - val q = Free (fst p', mk_pred1T B);
89.189 -
89.190 - val xctrs = map2 (curry Term.list_comb) ctrs xss;
89.191 - val yctrs = map2 (curry Term.list_comb) ctrs yss;
89.192 -
89.193 - val xfs = map2 (curry Term.list_comb) fs xss;
89.194 - val xgs = map2 (curry Term.list_comb) gs xss;
89.195 -
89.196 - val eta_fs = map2 eta_expand_arg xss xfs;
89.197 - val eta_gs = map2 eta_expand_arg xss xgs;
89.198 -
89.199 - val fcase = Term.list_comb (casex, eta_fs);
89.200 - val gcase = Term.list_comb (casex, eta_gs);
89.201 -
89.202 - val ufcase = fcase $ u;
89.203 - val vfcase = fcase $ v;
89.204 - val vgcase = gcase $ v;
89.205 -
89.206 - fun mk_u_eq_u () = HOLogic.mk_eq (u, u);
89.207 -
89.208 - val u_eq_v = mk_Trueprop_eq (u, v);
89.209 -
89.210 - val exist_xs_u_eq_ctrs =
89.211 - map2 (fn xctr => fn xs => list_exists_free xs (HOLogic.mk_eq (u, xctr))) xctrs xss;
89.212 -
89.213 - val unique_disc_no_def = TrueI; (*arbitrary marker*)
89.214 - val alternate_disc_no_def = FalseE; (*arbitrary marker*)
89.215 -
89.216 - fun alternate_disc_lhs get_udisc k =
89.217 - HOLogic.mk_not
89.218 - (case nth disc_bindings (k - 1) of
89.219 - NONE => nth exist_xs_u_eq_ctrs (k - 1)
89.220 - | SOME b => get_udisc b (k - 1));
89.221 -
89.222 - val (all_sels_distinct, discs, selss, udiscs, uselss, vdiscs, vselss, disc_defs, sel_defs,
89.223 - sel_defss, lthy') =
89.224 - if no_dests then
89.225 - (true, [], [], [], [], [], [], [], [], [], no_defs_lthy)
89.226 - else
89.227 - let
89.228 - fun disc_free b = Free (Binding.name_of b, mk_pred1T dataT);
89.229 -
89.230 - fun disc_spec b exist_xs_u_eq_ctr = mk_Trueprop_eq (disc_free b $ u, exist_xs_u_eq_ctr);
89.231 -
89.232 - fun alternate_disc k =
89.233 - Term.lambda u (alternate_disc_lhs (K o rapp u o disc_free) (3 - k));
89.234 -
89.235 - fun mk_default T t =
89.236 - let
89.237 - val Ts0 = map TFree (Term.add_tfreesT (fastype_of t) []);
89.238 - val Ts = map TFree (Term.add_tfreesT T []);
89.239 - in Term.subst_atomic_types (Ts0 ~~ Ts) t end;
89.240 -
89.241 - fun mk_sel_case_args b proto_sels T =
89.242 - map2 (fn Ts => fn k =>
89.243 - (case AList.lookup (op =) proto_sels k of
89.244 - NONE =>
89.245 - (case AList.lookup Binding.eq_name (rev (nth sel_defaultss (k - 1))) b of
89.246 - NONE => fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T)
89.247 - | SOME t => mk_default (Ts ---> T) t)
89.248 - | SOME (xs, x) => fold_rev Term.lambda xs x)) ctr_Tss ks;
89.249 -
89.250 - fun sel_spec b proto_sels =
89.251 - let
89.252 - val _ =
89.253 - (case duplicates (op =) (map fst proto_sels) of
89.254 - k :: _ => error ("Duplicate selector name " ^ quote (Binding.name_of b) ^
89.255 - " for constructor " ^
89.256 - quote (Syntax.string_of_term no_defs_lthy (nth ctrs (k - 1))))
89.257 - | [] => ())
89.258 - val T =
89.259 - (case distinct (op =) (map (fastype_of o snd o snd) proto_sels) of
89.260 - [T] => T
89.261 - | T :: T' :: _ => error ("Inconsistent range type for selector " ^
89.262 - quote (Binding.name_of b) ^ ": " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
89.263 - " vs. " ^ quote (Syntax.string_of_typ no_defs_lthy T')));
89.264 - in
89.265 - mk_Trueprop_eq (Free (Binding.name_of b, dataT --> T) $ u,
89.266 - Term.list_comb (mk_case As T, mk_sel_case_args b proto_sels T) $ u)
89.267 - end;
89.268 -
89.269 - val sel_bindings = flat sel_bindingss;
89.270 - val uniq_sel_bindings = distinct Binding.eq_name sel_bindings;
89.271 - val all_sels_distinct = (length uniq_sel_bindings = length sel_bindings);
89.272 -
89.273 - val sel_binding_index =
89.274 - if all_sels_distinct then 1 upto length sel_bindings
89.275 - else map (fn b => find_index (curry Binding.eq_name b) uniq_sel_bindings) sel_bindings;
89.276 -
89.277 - val proto_sels = flat (map3 (fn k => fn xs => map (fn x => (k, (xs, x)))) ks xss xss);
89.278 - val sel_infos =
89.279 - AList.group (op =) (sel_binding_index ~~ proto_sels)
89.280 - |> sort (int_ord o pairself fst)
89.281 - |> map snd |> curry (op ~~) uniq_sel_bindings;
89.282 - val sel_bindings = map fst sel_infos;
89.283 -
89.284 - fun unflat_selss xs = unflat_lookup Binding.eq_name sel_bindings xs sel_bindingss;
89.285 -
89.286 - val (((raw_discs, raw_disc_defs), (raw_sels, raw_sel_defs)), (lthy', lthy)) =
89.287 - no_defs_lthy
89.288 - |> apfst split_list o fold_map4 (fn k => fn m => fn exist_xs_u_eq_ctr =>
89.289 - fn NONE =>
89.290 - if n = 1 then pair (Term.lambda u (mk_u_eq_u ()), unique_disc_no_def)
89.291 - else if m = 0 then pair (Term.lambda u exist_xs_u_eq_ctr, refl)
89.292 - else pair (alternate_disc k, alternate_disc_no_def)
89.293 - | SOME b => Specification.definition (SOME (b, NONE, NoSyn),
89.294 - ((Thm.def_binding b, []), disc_spec b exist_xs_u_eq_ctr)) #>> apsnd snd)
89.295 - ks ms exist_xs_u_eq_ctrs disc_bindings
89.296 - ||>> apfst split_list o fold_map (fn (b, proto_sels) =>
89.297 - Specification.definition (SOME (b, NONE, NoSyn),
89.298 - ((Thm.def_binding b, []), sel_spec b proto_sels)) #>> apsnd snd) sel_infos
89.299 - ||> `Local_Theory.restore;
89.300 -
89.301 - val phi = Proof_Context.export_morphism lthy lthy';
89.302 -
89.303 - val disc_defs = map (Morphism.thm phi) raw_disc_defs;
89.304 - val sel_defs = map (Morphism.thm phi) raw_sel_defs;
89.305 - val sel_defss = unflat_selss sel_defs;
89.306 -
89.307 - val discs0 = map (Morphism.term phi) raw_discs;
89.308 - val selss0 = unflat_selss (map (Morphism.term phi) raw_sels);
89.309 -
89.310 - val discs = map (mk_disc_or_sel As) discs0;
89.311 - val selss = map (map (mk_disc_or_sel As)) selss0;
89.312 -
89.313 - val udiscs = map (rapp u) discs;
89.314 - val uselss = map (map (rapp u)) selss;
89.315 -
89.316 - val vdiscs = map (rapp v) discs;
89.317 - val vselss = map (map (rapp v)) selss;
89.318 - in
89.319 - (all_sels_distinct, discs, selss, udiscs, uselss, vdiscs, vselss, disc_defs, sel_defs,
89.320 - sel_defss, lthy')
89.321 - end;
89.322 -
89.323 - fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p);
89.324 -
89.325 - val exhaust_goal =
89.326 - let fun mk_prem xctr xs = fold_rev Logic.all xs (mk_imp_p [mk_Trueprop_eq (u, xctr)]) in
89.327 - fold_rev Logic.all [p, u] (mk_imp_p (map2 mk_prem xctrs xss))
89.328 - end;
89.329 -
89.330 - val inject_goalss =
89.331 - let
89.332 - fun mk_goal _ _ [] [] = []
89.333 - | mk_goal xctr yctr xs ys =
89.334 - [fold_rev Logic.all (xs @ ys) (mk_Trueprop_eq (HOLogic.mk_eq (xctr, yctr),
89.335 - Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) xs ys)))];
89.336 - in
89.337 - map4 mk_goal xctrs yctrs xss yss
89.338 - end;
89.339 -
89.340 - val half_distinct_goalss =
89.341 - let
89.342 - fun mk_goal ((xs, xc), (xs', xc')) =
89.343 - fold_rev Logic.all (xs @ xs')
89.344 - (HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (xc, xc'))));
89.345 - in
89.346 - map (map mk_goal) (mk_half_pairss (xss ~~ xctrs))
89.347 - end;
89.348 -
89.349 - val cases_goal =
89.350 - map3 (fn xs => fn xctr => fn xf =>
89.351 - fold_rev Logic.all (fs @ xs) (mk_Trueprop_eq (fcase $ xctr, xf))) xss xctrs xfs;
89.352 -
89.353 - val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss @ [cases_goal];
89.354 -
89.355 - fun after_qed thmss lthy =
89.356 - let
89.357 - val ([exhaust_thm], (inject_thmss, (half_distinct_thmss, [case_thms]))) =
89.358 - (hd thmss, apsnd (chop (n * n)) (chop n (tl thmss)));
89.359 -
89.360 - val inject_thms = flat inject_thmss;
89.361 -
89.362 - val Tinst = map (pairself (certifyT lthy)) (map Logic.varifyT_global As ~~ As);
89.363 -
89.364 - fun inst_thm t thm =
89.365 - Drule.instantiate' [] [SOME (certify lthy t)]
89.366 - (Thm.instantiate (Tinst, []) (Drule.zero_var_indexes thm));
89.367 -
89.368 - val uexhaust_thm = inst_thm u exhaust_thm;
89.369 -
89.370 - val exhaust_cases = map base_name_of_ctr ctrs;
89.371 -
89.372 - val other_half_distinct_thmss = map (map (fn thm => thm RS not_sym)) half_distinct_thmss;
89.373 -
89.374 - val (distinct_thms, (distinct_thmsss', distinct_thmsss)) =
89.375 - join_halves n half_distinct_thmss other_half_distinct_thmss;
89.376 -
89.377 - val nchotomy_thm =
89.378 - let
89.379 - val goal =
89.380 - HOLogic.mk_Trueprop (HOLogic.mk_all (fst u', snd u',
89.381 - Library.foldr1 HOLogic.mk_disj exist_xs_u_eq_ctrs));
89.382 - in
89.383 - Skip_Proof.prove lthy [] [] goal (fn _ => mk_nchotomy_tac n exhaust_thm)
89.384 - end;
89.385 -
89.386 - val (all_sel_thms, sel_thmss, disc_thmss, disc_thms, discI_thms, disc_exclude_thms,
89.387 - disc_exhaust_thms, collapse_thms, expand_thms, case_eq_thms) =
89.388 - if no_dests then
89.389 - ([], [], [], [], [], [], [], [], [], [])
89.390 - else
89.391 - let
89.392 - fun make_sel_thm xs' case_thm sel_def =
89.393 - zero_var_indexes (Drule.gen_all (Drule.rename_bvars' (map (SOME o fst) xs')
89.394 - (Drule.forall_intr_vars (case_thm RS (sel_def RS trans)))));
89.395 -
89.396 - fun has_undefined_rhs thm =
89.397 - (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of thm))) of
89.398 - Const (@{const_name undefined}, _) => true
89.399 - | _ => false);
89.400 -
89.401 - val sel_thmss = map3 (map oo make_sel_thm) xss' case_thms sel_defss;
89.402 -
89.403 - val all_sel_thms =
89.404 - (if all_sels_distinct andalso forall null sel_defaultss then
89.405 - flat sel_thmss
89.406 - else
89.407 - map_product (fn s => fn (xs', c) => make_sel_thm xs' c s) sel_defs
89.408 - (xss' ~~ case_thms))
89.409 - |> filter_out has_undefined_rhs;
89.410 -
89.411 - fun mk_unique_disc_def () =
89.412 - let
89.413 - val m = the_single ms;
89.414 - val goal = mk_Trueprop_eq (mk_u_eq_u (), the_single exist_xs_u_eq_ctrs);
89.415 - in
89.416 - Skip_Proof.prove lthy [] [] goal (fn _ => mk_unique_disc_def_tac m uexhaust_thm)
89.417 - |> singleton (Proof_Context.export names_lthy lthy)
89.418 - |> Thm.close_derivation
89.419 - end;
89.420 -
89.421 - fun mk_alternate_disc_def k =
89.422 - let
89.423 - val goal =
89.424 - mk_Trueprop_eq (alternate_disc_lhs (K (nth udiscs)) (3 - k),
89.425 - nth exist_xs_u_eq_ctrs (k - 1));
89.426 - in
89.427 - Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
89.428 - mk_alternate_disc_def_tac ctxt k (nth disc_defs (2 - k))
89.429 - (nth distinct_thms (2 - k)) uexhaust_thm)
89.430 - |> singleton (Proof_Context.export names_lthy lthy)
89.431 - |> Thm.close_derivation
89.432 - end;
89.433 -
89.434 - val has_alternate_disc_def =
89.435 - exists (fn def => Thm.eq_thm_prop (def, alternate_disc_no_def)) disc_defs;
89.436 -
89.437 - val disc_defs' =
89.438 - map2 (fn k => fn def =>
89.439 - if Thm.eq_thm_prop (def, unique_disc_no_def) then mk_unique_disc_def ()
89.440 - else if Thm.eq_thm_prop (def, alternate_disc_no_def) then mk_alternate_disc_def k
89.441 - else def) ks disc_defs;
89.442 -
89.443 - val discD_thms = map (fn def => def RS iffD1) disc_defs';
89.444 - val discI_thms =
89.445 - map2 (fn m => fn def => funpow m (fn thm => exI RS thm) (def RS iffD2)) ms
89.446 - disc_defs';
89.447 - val not_discI_thms =
89.448 - map2 (fn m => fn def => funpow m (fn thm => allI RS thm)
89.449 - (unfold_thms lthy @{thms not_ex} (def RS @{thm ssubst[of _ _ Not]})))
89.450 - ms disc_defs';
89.451 -
89.452 - val (disc_thmss', disc_thmss) =
89.453 - let
89.454 - fun mk_thm discI _ [] = refl RS discI
89.455 - | mk_thm _ not_discI [distinct] = distinct RS not_discI;
89.456 - fun mk_thms discI not_discI distinctss = map (mk_thm discI not_discI) distinctss;
89.457 - in
89.458 - map3 mk_thms discI_thms not_discI_thms distinct_thmsss' |> `transpose
89.459 - end;
89.460 -
89.461 - val disc_thms = flat (map2 (fn true => K [] | false => I) no_discs disc_thmss);
89.462 -
89.463 - val (disc_exclude_thms, (disc_exclude_thmsss', disc_exclude_thmsss)) =
89.464 - let
89.465 - fun mk_goal [] = []
89.466 - | mk_goal [((_, udisc), (_, udisc'))] =
89.467 - [Logic.all u (Logic.mk_implies (HOLogic.mk_Trueprop udisc,
89.468 - HOLogic.mk_Trueprop (HOLogic.mk_not udisc')))];
89.469 -
89.470 - fun prove tac goal = Skip_Proof.prove lthy [] [] goal (K tac);
89.471 -
89.472 - val infos = ms ~~ discD_thms ~~ udiscs;
89.473 - val half_pairss = mk_half_pairss infos;
89.474 -
89.475 - val half_goalss = map mk_goal half_pairss;
89.476 - val half_thmss =
89.477 - map3 (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] =>
89.478 - fn disc_thm => [prove (mk_half_disc_exclude_tac m discD disc_thm) goal])
89.479 - half_goalss half_pairss (flat disc_thmss');
89.480 -
89.481 - val other_half_goalss = map (mk_goal o map swap) half_pairss;
89.482 - val other_half_thmss =
89.483 - map2 (map2 (prove o mk_other_half_disc_exclude_tac)) half_thmss
89.484 - other_half_goalss;
89.485 - in
89.486 - join_halves n half_thmss other_half_thmss
89.487 - |>> has_alternate_disc_def ? K []
89.488 - end;
89.489 -
89.490 - val disc_exhaust_thm =
89.491 - let
89.492 - fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc];
89.493 - val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs));
89.494 - in
89.495 - Skip_Proof.prove lthy [] [] goal (fn _ =>
89.496 - mk_disc_exhaust_tac n exhaust_thm discI_thms)
89.497 - end;
89.498 -
89.499 - val disc_exhaust_thms =
89.500 - if has_alternate_disc_def orelse no_discs_at_all then [] else [disc_exhaust_thm];
89.501 -
89.502 - val (collapse_thms, collapse_thm_opts) =
89.503 - let
89.504 - fun mk_goal ctr udisc usels =
89.505 - let
89.506 - val prem = HOLogic.mk_Trueprop udisc;
89.507 - val concl =
89.508 - mk_Trueprop_eq ((null usels ? swap) (Term.list_comb (ctr, usels), u));
89.509 - in
89.510 - if prem aconv concl then NONE
89.511 - else SOME (Logic.all u (Logic.mk_implies (prem, concl)))
89.512 - end;
89.513 - val goals = map3 mk_goal ctrs udiscs uselss;
89.514 - in
89.515 - map4 (fn m => fn discD => fn sel_thms => Option.map (fn goal =>
89.516 - Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
89.517 - mk_collapse_tac ctxt m discD sel_thms)
89.518 - |> perhaps (try (fn thm => refl RS thm)))) ms discD_thms sel_thmss goals
89.519 - |> `(map_filter I)
89.520 - end;
89.521 -
89.522 - val expand_thms =
89.523 - let
89.524 - fun mk_prems k udisc usels vdisc vsels =
89.525 - (if k = n then [] else [mk_Trueprop_eq (udisc, vdisc)]) @
89.526 - (if null usels then
89.527 - []
89.528 - else
89.529 - [Logic.list_implies
89.530 - (if n = 1 then [] else map HOLogic.mk_Trueprop [udisc, vdisc],
89.531 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
89.532 - (map2 (curry HOLogic.mk_eq) usels vsels)))]);
89.533 -
89.534 - val uncollapse_thms =
89.535 - map (fn NONE => Drule.dummy_thm | SOME thm => thm RS sym) collapse_thm_opts;
89.536 -
89.537 - val goal =
89.538 - Library.foldr Logic.list_implies
89.539 - (map5 mk_prems ks udiscs uselss vdiscs vselss, u_eq_v);
89.540 - in
89.541 - [Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
89.542 - mk_expand_tac ctxt n ms (inst_thm u disc_exhaust_thm)
89.543 - (inst_thm v disc_exhaust_thm) uncollapse_thms disc_exclude_thmsss
89.544 - disc_exclude_thmsss')]
89.545 - |> Proof_Context.export names_lthy lthy
89.546 - end;
89.547 -
89.548 - val case_eq_thms =
89.549 - let
89.550 - fun mk_body f usels = Term.list_comb (f, usels);
89.551 - val goal = mk_Trueprop_eq (ufcase, mk_IfN B udiscs (map2 mk_body fs uselss));
89.552 - in
89.553 - [Skip_Proof.prove lthy [] [] goal (fn {context = ctxt, ...} =>
89.554 - mk_case_eq_tac ctxt n uexhaust_thm case_thms disc_thmss' sel_thmss)]
89.555 - |> Proof_Context.export names_lthy lthy
89.556 - end;
89.557 - in
89.558 - (all_sel_thms, sel_thmss, disc_thmss, disc_thms, discI_thms, disc_exclude_thms,
89.559 - disc_exhaust_thms, collapse_thms, expand_thms, case_eq_thms)
89.560 - end;
89.561 -
89.562 - val (case_cong_thm, weak_case_cong_thm) =
89.563 - let
89.564 - fun mk_prem xctr xs f g =
89.565 - fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr),
89.566 - mk_Trueprop_eq (f, g)));
89.567 -
89.568 - val goal =
89.569 - Logic.list_implies (u_eq_v :: map4 mk_prem xctrs xss fs gs,
89.570 - mk_Trueprop_eq (ufcase, vgcase));
89.571 - val weak_goal = Logic.mk_implies (u_eq_v, mk_Trueprop_eq (ufcase, vfcase));
89.572 - in
89.573 - (Skip_Proof.prove lthy [] [] goal (fn _ => mk_case_cong_tac uexhaust_thm case_thms),
89.574 - Skip_Proof.prove lthy [] [] weak_goal (K (etac arg_cong 1)))
89.575 - |> pairself (singleton (Proof_Context.export names_lthy lthy))
89.576 - end;
89.577 -
89.578 - val (split_thm, split_asm_thm) =
89.579 - let
89.580 - fun mk_conjunct xctr xs f_xs =
89.581 - list_all_free xs (HOLogic.mk_imp (HOLogic.mk_eq (u, xctr), q $ f_xs));
89.582 - fun mk_disjunct xctr xs f_xs =
89.583 - list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr),
89.584 - HOLogic.mk_not (q $ f_xs)));
89.585 -
89.586 - val lhs = q $ ufcase;
89.587 -
89.588 - val goal =
89.589 - mk_Trueprop_eq (lhs, Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct xctrs xss xfs));
89.590 - val asm_goal =
89.591 - mk_Trueprop_eq (lhs, HOLogic.mk_not (Library.foldr1 HOLogic.mk_disj
89.592 - (map3 mk_disjunct xctrs xss xfs)));
89.593 -
89.594 - val split_thm =
89.595 - Skip_Proof.prove lthy [] [] goal
89.596 - (fn _ => mk_split_tac uexhaust_thm case_thms inject_thmss distinct_thmsss)
89.597 - |> singleton (Proof_Context.export names_lthy lthy)
89.598 - val split_asm_thm =
89.599 - Skip_Proof.prove lthy [] [] asm_goal (fn {context = ctxt, ...} =>
89.600 - mk_split_asm_tac ctxt split_thm)
89.601 - |> singleton (Proof_Context.export names_lthy lthy)
89.602 - in
89.603 - (split_thm, split_asm_thm)
89.604 - end;
89.605 -
89.606 - val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
89.607 - val cases_type_attr = Attrib.internal (K (Induct.cases_type dataT_name));
89.608 -
89.609 - val notes =
89.610 - [(case_congN, [case_cong_thm], []),
89.611 - (case_eqN, case_eq_thms, []),
89.612 - (casesN, case_thms, simp_attrs),
89.613 - (collapseN, collapse_thms, simp_attrs),
89.614 - (discsN, disc_thms, simp_attrs),
89.615 - (disc_excludeN, disc_exclude_thms, []),
89.616 - (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
89.617 - (distinctN, distinct_thms, simp_attrs @ induct_simp_attrs),
89.618 - (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
89.619 - (expandN, expand_thms, []),
89.620 - (injectN, inject_thms, iff_attrs @ induct_simp_attrs),
89.621 - (nchotomyN, [nchotomy_thm], []),
89.622 - (selsN, all_sel_thms, simp_attrs),
89.623 - (splitN, [split_thm], []),
89.624 - (split_asmN, [split_asm_thm], []),
89.625 - (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)]
89.626 - |> filter_out (null o #2)
89.627 - |> map (fn (thmN, thms, attrs) =>
89.628 - ((Binding.qualify true data_b_name (Binding.name thmN), attrs), [(thms, [])]));
89.629 -
89.630 - val notes' =
89.631 - [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs)]
89.632 - |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
89.633 - in
89.634 - ((discs, selss, inject_thms, distinct_thms, case_thms, disc_thmss, discI_thms, sel_thmss),
89.635 - lthy |> Local_Theory.notes (notes' @ notes) |> snd)
89.636 - end;
89.637 - in
89.638 - (goalss, after_qed, lthy')
89.639 - end;
89.640 -
89.641 -fun wrap_datatype tacss = (fn (goalss, after_qed, lthy) =>
89.642 - map2 (map2 (Skip_Proof.prove lthy [] [])) goalss tacss
89.643 - |> (fn thms => after_qed thms lthy)) oo prepare_wrap_datatype (K I);
89.644 -
89.645 -val wrap_datatype_cmd = (fn (goalss, after_qed, lthy) =>
89.646 - Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo
89.647 - prepare_wrap_datatype Syntax.read_term;
89.648 -
89.649 -fun parse_bracket_list parser = @{keyword "["} |-- Parse.list parser --| @{keyword "]"};
89.650 -
89.651 -val parse_bindings = parse_bracket_list Parse.binding;
89.652 -val parse_bindingss = parse_bracket_list parse_bindings;
89.653 -
89.654 -val parse_bound_term = (Parse.binding --| @{keyword ":"}) -- Parse.term;
89.655 -val parse_bound_terms = parse_bracket_list parse_bound_term;
89.656 -val parse_bound_termss = parse_bracket_list parse_bound_terms;
89.657 -
89.658 -val parse_wrap_options =
89.659 - Scan.optional (@{keyword "("} |-- (@{keyword "no_dests"} >> K true) --| @{keyword ")"}) false;
89.660 -
89.661 -val _ =
89.662 - Outer_Syntax.local_theory_to_proof @{command_spec "wrap_data"} "wraps an existing datatype"
89.663 - ((parse_wrap_options -- (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) --
89.664 - Parse.term -- Scan.optional (parse_bindings -- Scan.optional (parse_bindingss --
89.665 - Scan.optional parse_bound_termss []) ([], [])) ([], ([], [])))
89.666 - >> wrap_datatype_cmd);
89.667 -
89.668 -end;
90.1 --- a/src/HOL/Codatatype/Tools/bnf_wrap_tactics.ML Fri Sep 21 16:34:40 2012 +0200
90.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
90.3 @@ -1,122 +0,0 @@
90.4 -(* Title: HOL/BNF/Tools/bnf_wrap_tactics.ML
90.5 - Author: Jasmin Blanchette, TU Muenchen
90.6 - Copyright 2012
90.7 -
90.8 -Tactics for wrapping datatypes.
90.9 -*)
90.10 -
90.11 -signature BNF_WRAP_TACTICS =
90.12 -sig
90.13 - val mk_alternate_disc_def_tac: Proof.context -> int -> thm -> thm -> thm -> tactic
90.14 - val mk_case_cong_tac: thm -> thm list -> tactic
90.15 - val mk_case_eq_tac: Proof.context -> int -> thm -> thm list -> thm list list -> thm list list ->
90.16 - tactic
90.17 - val mk_collapse_tac: Proof.context -> int -> thm -> thm list -> tactic
90.18 - val mk_disc_exhaust_tac: int -> thm -> thm list -> tactic
90.19 - val mk_expand_tac: Proof.context -> int -> int list -> thm -> thm -> thm list ->
90.20 - thm list list list -> thm list list list -> tactic
90.21 - val mk_half_disc_exclude_tac: int -> thm -> thm -> tactic
90.22 - val mk_nchotomy_tac: int -> thm -> tactic
90.23 - val mk_other_half_disc_exclude_tac: thm -> tactic
90.24 - val mk_split_tac: thm -> thm list -> thm list list -> thm list list list -> tactic
90.25 - val mk_split_asm_tac: Proof.context -> thm -> tactic
90.26 - val mk_unique_disc_def_tac: int -> thm -> tactic
90.27 -end;
90.28 -
90.29 -structure BNF_Wrap_Tactics : BNF_WRAP_TACTICS =
90.30 -struct
90.31 -
90.32 -open BNF_Util
90.33 -open BNF_Tactics
90.34 -
90.35 -val meta_mp = @{thm meta_mp};
90.36 -
90.37 -fun if_P_or_not_P_OF pos thm = thm RS (if pos then @{thm if_P} else @{thm if_not_P});
90.38 -
90.39 -fun mk_nchotomy_tac n exhaust =
90.40 - (rtac allI THEN' rtac exhaust THEN'
90.41 - EVERY' (maps (fn k => [rtac (mk_disjIN n k), REPEAT_DETERM o rtac exI, atac]) (1 upto n))) 1;
90.42 -
90.43 -fun mk_unique_disc_def_tac m uexhaust =
90.44 - EVERY' [rtac iffI, rtac uexhaust, REPEAT_DETERM_N m o rtac exI, atac, rtac refl] 1;
90.45 -
90.46 -fun mk_alternate_disc_def_tac ctxt k other_disc_def distinct uexhaust =
90.47 - EVERY' ([subst_tac ctxt [other_disc_def], rtac @{thm iffI_np}, REPEAT_DETERM o etac exE,
90.48 - hyp_subst_tac, SELECT_GOAL (unfold_thms_tac ctxt [not_ex]), REPEAT_DETERM o rtac allI,
90.49 - rtac distinct, rtac uexhaust] @
90.50 - (([etac notE, REPEAT_DETERM o rtac exI, atac], [REPEAT_DETERM o rtac exI, atac])
90.51 - |> k = 1 ? swap |> op @)) 1;
90.52 -
90.53 -fun mk_half_disc_exclude_tac m discD disc' =
90.54 - (dtac discD THEN' REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac THEN' rtac disc') 1;
90.55 -
90.56 -fun mk_other_half_disc_exclude_tac half = (etac @{thm contrapos_pn} THEN' etac half) 1;
90.57 -
90.58 -fun mk_disc_exhaust_tac n exhaust discIs =
90.59 - (rtac exhaust THEN'
90.60 - EVERY' (map2 (fn k => fn discI =>
90.61 - dtac discI THEN' select_prem_tac n (etac meta_mp) k THEN' atac) (1 upto n) discIs)) 1;
90.62 -
90.63 -fun mk_collapse_tac ctxt m discD sels =
90.64 - (dtac discD THEN'
90.65 - (if m = 0 then
90.66 - atac
90.67 - else
90.68 - REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac THEN'
90.69 - SELECT_GOAL (unfold_thms_tac ctxt sels) THEN' rtac refl)) 1;
90.70 -
90.71 -fun mk_expand_tac ctxt n ms udisc_exhaust vdisc_exhaust uncollapses disc_excludesss
90.72 - disc_excludesss' =
90.73 - if ms = [0] then
90.74 - rtac (@{thm trans_sym} OF (replicate 2 (the_single uncollapses RS sym))) 1
90.75 - else
90.76 - let
90.77 - val ks = 1 upto n;
90.78 - val maybe_atac = if n = 1 then K all_tac else atac;
90.79 - in
90.80 - (rtac udisc_exhaust THEN'
90.81 - EVERY' (map5 (fn k => fn m => fn disc_excludess => fn disc_excludess' => fn uuncollapse =>
90.82 - EVERY' [if m = 0 then K all_tac else subst_tac ctxt [uuncollapse] THEN' maybe_atac,
90.83 - rtac sym, rtac vdisc_exhaust,
90.84 - EVERY' (map4 (fn k' => fn disc_excludes => fn disc_excludes' => fn vuncollapse =>
90.85 - EVERY'
90.86 - (if k' = k then
90.87 - if m = 0 then
90.88 - [hyp_subst_tac, rtac refl]
90.89 - else
90.90 - [subst_tac ctxt [vuncollapse], maybe_atac,
90.91 - if n = 1 then K all_tac else EVERY' [dtac meta_mp, atac, dtac meta_mp, atac],
90.92 - REPEAT_DETERM_N (Int.max (0, m - 1)) o etac conjE, asm_simp_tac (ss_only [])]
90.93 - else
90.94 - [dtac (the_single (if k = n then disc_excludes else disc_excludes')),
90.95 - etac (if k = n then @{thm iff_contradict(1)} else @{thm iff_contradict(2)}),
90.96 - atac, atac]))
90.97 - ks disc_excludess disc_excludess' uncollapses)])
90.98 - ks ms disc_excludesss disc_excludesss' uncollapses)) 1
90.99 - end;
90.100 -
90.101 -fun mk_case_eq_tac ctxt n uexhaust cases discss' selss =
90.102 - (rtac uexhaust THEN'
90.103 - EVERY' (map3 (fn casex => fn if_discs => fn sels =>
90.104 - EVERY' [hyp_subst_tac, SELECT_GOAL (unfold_thms_tac ctxt (if_discs @ sels)), rtac casex])
90.105 - cases (map2 (seq_conds if_P_or_not_P_OF n) (1 upto n) discss') selss)) 1;
90.106 -
90.107 -fun mk_case_cong_tac uexhaust cases =
90.108 - (rtac uexhaust THEN'
90.109 - EVERY' (maps (fn casex => [dtac sym, asm_simp_tac (ss_only [casex])]) cases)) 1;
90.110 -
90.111 -val naked_ctxt = Proof_Context.init_global @{theory HOL};
90.112 -
90.113 -fun mk_split_tac uexhaust cases injectss distinctsss =
90.114 - rtac uexhaust 1 THEN
90.115 - ALLGOALS (fn k => (hyp_subst_tac THEN'
90.116 - simp_tac (ss_only (@{thms simp_thms} @ cases @ nth injectss (k - 1) @
90.117 - flat (nth distinctsss (k - 1))))) k) THEN
90.118 - ALLGOALS (blast_tac naked_ctxt);
90.119 -
90.120 -val split_asm_thms = @{thms imp_conv_disj de_Morgan_conj de_Morgan_disj not_not not_ex};
90.121 -
90.122 -fun mk_split_asm_tac ctxt split =
90.123 - rtac (split RS trans) 1 THEN unfold_thms_tac ctxt split_asm_thms THEN rtac refl 1;
90.124 -
90.125 -end;
91.1 --- a/src/HOL/ROOT Fri Sep 21 16:34:40 2012 +0200
91.2 +++ b/src/HOL/ROOT Fri Sep 21 16:45:06 2012 +0200
91.3 @@ -610,13 +610,13 @@
91.4 "document/root.tex"
91.5 "document/root.bib"
91.6
91.7 -session "HOL-Codatatype" in Codatatype = "HOL-Cardinals" +
91.8 - description {* New (Co)datatype Package *}
91.9 +session "HOL-BNF" in BNF = "HOL-Cardinals" +
91.10 + description {* Bounded Natural Functors for (Co)datatypes *}
91.11 options [document = false]
91.12 - theories Codatatype
91.13 + theories BNF
91.14
91.15 -session "HOL-Codatatype-Examples" in "Codatatype/Examples" = "HOL-Codatatype" +
91.16 - description {* Examples for the New (Co)datatype Package *}
91.17 +session "HOL-BNF-Examples" in "BNF/Examples" = "HOL-BNF" +
91.18 + description {* Examples for Bounded Natural Functors *}
91.19 options [document = false]
91.20 theories
91.21 HFset