added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
authorblanchet
Tue Aug 28 17:16:00 2012 +0200 (2012-08-28)
changeset 489757f79f94a432c
parent 48974 8882fc8005ad
child 48976 2d17c305f4bc
added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
src/HOL/Codatatype/BNF_Comp.thy
src/HOL/Codatatype/BNF_Def.thy
src/HOL/Codatatype/BNF_GFP.thy
src/HOL/Codatatype/BNF_LFP.thy
src/HOL/Codatatype/BNF_Library.thy
src/HOL/Codatatype/Basic_BNFs.thy
src/HOL/Codatatype/Codatatype.thy
src/HOL/Codatatype/Countable_Set.thy
src/HOL/Codatatype/Equiv_Relations_More.thy
src/HOL/Codatatype/Examples/HFset.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Gram_Lang.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Parallel.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Prelim.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Tree.thy
src/HOL/Codatatype/Examples/Lambda_Term.thy
src/HOL/Codatatype/Examples/ListF.thy
src/HOL/Codatatype/Examples/Misc_Codata.thy
src/HOL/Codatatype/Examples/Misc_Data.thy
src/HOL/Codatatype/Examples/Process.thy
src/HOL/Codatatype/Examples/Stream.thy
src/HOL/Codatatype/Examples/TreeFI.thy
src/HOL/Codatatype/Examples/TreeFsetI.thy
src/HOL/Codatatype/README.html
src/HOL/Codatatype/Tools/bnf_comp.ML
src/HOL/Codatatype/Tools/bnf_comp_tactics.ML
src/HOL/Codatatype/Tools/bnf_def.ML
src/HOL/Codatatype/Tools/bnf_fp_util.ML
src/HOL/Codatatype/Tools/bnf_gfp.ML
src/HOL/Codatatype/Tools/bnf_gfp_tactics.ML
src/HOL/Codatatype/Tools/bnf_gfp_util.ML
src/HOL/Codatatype/Tools/bnf_lfp.ML
src/HOL/Codatatype/Tools/bnf_lfp_tactics.ML
src/HOL/Codatatype/Tools/bnf_lfp_util.ML
src/HOL/Codatatype/Tools/bnf_tactics.ML
src/HOL/Codatatype/Tools/bnf_util.ML
src/HOL/Ordinals_and_Cardinals/Cardinal_Arithmetic.thy
src/HOL/Ordinals_and_Cardinals/Cardinal_Order_Relation.thy
src/HOL/Ordinals_and_Cardinals/Cardinal_Order_Relation_Base.thy
src/HOL/Ordinals_and_Cardinals/Constructions_on_Wellorders.thy
src/HOL/Ordinals_and_Cardinals/Constructions_on_Wellorders_Base.thy
src/HOL/Ordinals_and_Cardinals/Fun_More.thy
src/HOL/Ordinals_and_Cardinals/Fun_More_Base.thy
src/HOL/Ordinals_and_Cardinals/Order_Relation_More.thy
src/HOL/Ordinals_and_Cardinals/Order_Relation_More_Base.thy
src/HOL/Ordinals_and_Cardinals/README.txt
src/HOL/Ordinals_and_Cardinals/TODO.txt
src/HOL/Ordinals_and_Cardinals/Wellfounded_More.thy
src/HOL/Ordinals_and_Cardinals/Wellfounded_More_Base.thy
src/HOL/Ordinals_and_Cardinals/Wellorder_Embedding.thy
src/HOL/Ordinals_and_Cardinals/Wellorder_Embedding_Base.thy
src/HOL/Ordinals_and_Cardinals/Wellorder_Relation.thy
src/HOL/Ordinals_and_Cardinals/Wellorder_Relation_Base.thy
src/HOL/Ordinals_and_Cardinals/document/intro.tex
src/HOL/Ordinals_and_Cardinals/document/isabelle.sty
src/HOL/Ordinals_and_Cardinals/document/isabellesym.sty
src/HOL/Ordinals_and_Cardinals/document/isabelletags.sty
src/HOL/Ordinals_and_Cardinals/document/pdfsetup.sty
src/HOL/Ordinals_and_Cardinals/document/railsetup.sty
src/HOL/Ordinals_and_Cardinals/document/root.bib
src/HOL/Ordinals_and_Cardinals/document/root.tex
src/HOL/ROOT
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Codatatype/BNF_Comp.thy	Tue Aug 28 17:16:00 2012 +0200
     1.3 @@ -0,0 +1,20 @@
     1.4 +(*  Title:      HOL/Codatatype/BNF_Comp.thy
     1.5 +    Author:     Dmitriy Traytel, TU Muenchen
     1.6 +    Copyright   2012
     1.7 +
     1.8 +Composition of bounded natural functors.
     1.9 +*)
    1.10 +
    1.11 +header {* Composition of Bounded Natural Functors *}
    1.12 +
    1.13 +theory BNF_Comp
    1.14 +imports Basic_BNFs
    1.15 +keywords
    1.16 +  "bnf_of_typ" :: thy_decl
    1.17 +uses
    1.18 +  "Tools/bnf_comp_tactics.ML"
    1.19 +  "Tools/bnf_comp.ML"
    1.20 +  "Tools/bnf_fp_util.ML"
    1.21 +begin
    1.22 +
    1.23 +end
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Codatatype/BNF_Def.thy	Tue Aug 28 17:16:00 2012 +0200
     2.3 @@ -0,0 +1,22 @@
     2.4 +(*  Title:      HOL/Codatatype/BNF_Def.thy
     2.5 +    Author:     Dmitriy Traytel, TU Muenchen
     2.6 +    Copyright   2012
     2.7 +
     2.8 +Definition of bounded natural functors.
     2.9 +*)
    2.10 +
    2.11 +header {* Definition of Bounded Natural Functors *}
    2.12 +
    2.13 +theory BNF_Def
    2.14 +imports BNF_Library
    2.15 +keywords
    2.16 +  "print_bnfs" :: diag
    2.17 +and
    2.18 +  "bnf_def" :: thy_goal
    2.19 +uses
    2.20 +  "Tools/bnf_util.ML"
    2.21 +  "Tools/bnf_tactics.ML"
    2.22 +  "Tools/bnf_def.ML"
    2.23 +begin
    2.24 +
    2.25 +end
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Codatatype/BNF_GFP.thy	Tue Aug 28 17:16:00 2012 +0200
     3.3 @@ -0,0 +1,20 @@
     3.4 +(*  Title:      HOL/Codatatype/BNF_GFP.thy
     3.5 +    Author:     Dmitriy Traytel, TU Muenchen
     3.6 +    Copyright   2012
     3.7 +
     3.8 +Greatest fixed point operation on bounded natural functors.
     3.9 +*)
    3.10 +
    3.11 +header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
    3.12 +
    3.13 +theory BNF_GFP
    3.14 +imports BNF_Comp
    3.15 +keywords
    3.16 +  "bnf_codata" :: thy_decl
    3.17 +uses
    3.18 +  "Tools/bnf_gfp_util.ML"
    3.19 +  "Tools/bnf_gfp_tactics.ML"
    3.20 +  "Tools/bnf_gfp.ML"
    3.21 +begin
    3.22 +
    3.23 +end
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Codatatype/BNF_LFP.thy	Tue Aug 28 17:16:00 2012 +0200
     4.3 @@ -0,0 +1,20 @@
     4.4 +(*  Title:      HOL/Codatatype/BNF_LFP.thy
     4.5 +    Author:     Dmitriy Traytel, TU Muenchen
     4.6 +    Copyright   2012
     4.7 +
     4.8 +Least fixed point operation on bounded natural functors.
     4.9 +*)
    4.10 +
    4.11 +header {* Least Fixed Point Operation on Bounded Natural Functors *}
    4.12 +
    4.13 +theory BNF_LFP
    4.14 +imports BNF_Comp
    4.15 +keywords
    4.16 +  "bnf_data" :: thy_decl
    4.17 +uses
    4.18 +  "Tools/bnf_lfp_util.ML"
    4.19 +  "Tools/bnf_lfp_tactics.ML"
    4.20 +  "Tools/bnf_lfp.ML"
    4.21 +begin
    4.22 +
    4.23 +end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Codatatype/BNF_Library.thy	Tue Aug 28 17:16:00 2012 +0200
     5.3 @@ -0,0 +1,826 @@
     5.4 +(*  Title:      HOL/Codatatype/BNF_Library.thy
     5.5 +    Author:     Dmitriy Traytel, TU Muenchen
     5.6 +    Copyright   2012
     5.7 +
     5.8 +Library for bounded natural functors.
     5.9 +*)
    5.10 +
    5.11 +header {* Library for Bounded Natural Functors *}
    5.12 +
    5.13 +theory BNF_Library
    5.14 +imports
    5.15 +   "../Ordinals_and_Cardinals_Base/Cardinal_Arithmetic"
    5.16 +   "~~/src/HOL/Library/List_Prefix"
    5.17 +   Equiv_Relations_More
    5.18 +begin
    5.19 +
    5.20 +lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
    5.21 +by blast
    5.22 +
    5.23 +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})"
    5.24 +by blast
    5.25 +
    5.26 +lemma mem_Collect_eq_split: "{(x, y). (x, y) \<in> X} = X"
    5.27 +by simp
    5.28 +
    5.29 +lemma image_comp: "image (f o g) = image f o image g"
    5.30 +by (rule ext) (auto simp only: o_apply image_def)
    5.31 +
    5.32 +lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
    5.33 +by (rule ext) simp
    5.34 +
    5.35 +lemma Union_natural: "Union o image (image f) = image f o Union"
    5.36 +by (rule ext) (auto simp only: o_apply)
    5.37 +
    5.38 +lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
    5.39 +by (unfold o_assoc)
    5.40 +
    5.41 +lemma comp_single_set_bd:
    5.42 +  assumes fbd_Card_order: "Card_order fbd" and
    5.43 +    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
    5.44 +    gset_bd: "\<And>x. |gset x| \<le>o gbd"
    5.45 +  shows "|\<Union>fset ` gset x| \<le>o gbd *c fbd"
    5.46 +apply (subst sym[OF SUP_def])
    5.47 +apply (rule ordLeq_transitive)
    5.48 +apply (rule card_of_UNION_Sigma)
    5.49 +apply (subst SIGMA_CSUM)
    5.50 +apply (rule ordLeq_transitive)
    5.51 +apply (rule card_of_Csum_Times')
    5.52 +apply (rule fbd_Card_order)
    5.53 +apply (rule ballI)
    5.54 +apply (rule fset_bd)
    5.55 +apply (rule ordLeq_transitive)
    5.56 +apply (rule cprod_mono1)
    5.57 +apply (rule gset_bd)
    5.58 +apply (rule ordIso_imp_ordLeq)
    5.59 +apply (rule ordIso_refl)
    5.60 +apply (rule Card_order_cprod)
    5.61 +done
    5.62 +
    5.63 +lemma Union_image_insert: "\<Union>f ` insert a B = f a \<union> \<Union>f ` B"
    5.64 +by simp
    5.65 +
    5.66 +lemma Union_image_empty: "A \<union> \<Union>f ` {} = A"
    5.67 +by simp
    5.68 +
    5.69 +definition collect where
    5.70 +  "collect F x = (\<Union>f \<in> F. f x)"
    5.71 +
    5.72 +lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
    5.73 +by (rule ext) (auto simp only: o_apply collect_def)
    5.74 +
    5.75 +lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
    5.76 +by (rule ext) (auto simp add: collect_def)
    5.77 +
    5.78 +lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
    5.79 +by auto
    5.80 +
    5.81 +lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
    5.82 +by auto
    5.83 +
    5.84 +lemma rev_bspec: "a \<in> A \<Longrightarrow> \<forall>z \<in> A. P z \<Longrightarrow> P a"
    5.85 +by simp
    5.86 +
    5.87 +lemma Un_cong: "\<lbrakk>A = B; C = D\<rbrakk> \<Longrightarrow> A \<union> C = B \<union> D"
    5.88 +by auto
    5.89 +
    5.90 +lemma UN_image_subset: "\<Union>f ` g x \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
    5.91 +by auto
    5.92 +
    5.93 +lemma image_Collect_subsetI:
    5.94 +  "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
    5.95 +by auto
    5.96 +
    5.97 +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"
    5.98 +by (unfold o_apply collect_def SUP_def)
    5.99 +
   5.100 +lemma sum_case_comp_Inl:
   5.101 +"sum_case f g \<circ> Inl = f"
   5.102 +unfolding comp_def by simp
   5.103 +
   5.104 +lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
   5.105 +by (auto split: sum.splits)
   5.106 +
   5.107 +lemma converse_mono:
   5.108 +"R1 ^-1 \<subseteq> R2 ^-1 \<longleftrightarrow> R1 \<subseteq> R2"
   5.109 +unfolding converse_def by auto
   5.110 +
   5.111 +lemma converse_shift:
   5.112 +"R1 \<subseteq> R2 ^-1 \<Longrightarrow> R1 ^-1 \<subseteq> R2"
   5.113 +unfolding converse_def by auto
   5.114 +
   5.115 +lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
   5.116 +by auto
   5.117 +
   5.118 +lemma equiv_triv1:
   5.119 +assumes "equiv A R" and "(a, b) \<in> R" and "(a, c) \<in> R"
   5.120 +shows "(b, c) \<in> R"
   5.121 +using assms unfolding equiv_def sym_def trans_def by blast
   5.122 +
   5.123 +lemma equiv_triv2:
   5.124 +assumes "equiv A R" and "(a, b) \<in> R" and "(b, c) \<in> R"
   5.125 +shows "(a, c) \<in> R"
   5.126 +using assms unfolding equiv_def trans_def by blast
   5.127 +
   5.128 +lemma equiv_proj:
   5.129 +  assumes e: "equiv A R" and "z \<in> R"
   5.130 +  shows "(proj R o fst) z = (proj R o snd) z"
   5.131 +proof -
   5.132 +  from assms(2) have z: "(fst z, snd z) \<in> R" by auto
   5.133 +  have P: "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" by (erule equiv_triv1[OF e z])
   5.134 +  have "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R" by (erule equiv_triv2[OF e z])
   5.135 +  with P show ?thesis unfolding proj_def[abs_def] by auto
   5.136 +qed
   5.137 +
   5.138 +
   5.139 +section{* Weak pullbacks: *}
   5.140 +
   5.141 +definition csquare where
   5.142 +"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
   5.143 +
   5.144 +definition wpull where
   5.145 +"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
   5.146 + (\<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))"
   5.147 +
   5.148 +lemma wpull_cong:
   5.149 +"\<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"
   5.150 +by simp
   5.151 +
   5.152 +lemma wpull_id: "wpull UNIV B1 B2 id id id id"
   5.153 +unfolding wpull_def by simp
   5.154 +
   5.155 +
   5.156 +(* Weak pseudo-pullbacks *)
   5.157 +
   5.158 +definition wppull where
   5.159 +"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
   5.160 + (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
   5.161 +           (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
   5.162 +
   5.163 +
   5.164 +(* The pullback of sets *)
   5.165 +definition thePull where
   5.166 +"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
   5.167 +
   5.168 +lemma wpull_thePull:
   5.169 +"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
   5.170 +unfolding wpull_def thePull_def by auto
   5.171 +
   5.172 +lemma wppull_thePull:
   5.173 +assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
   5.174 +shows
   5.175 +"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
   5.176 +   j a' \<in> A \<and>
   5.177 +   e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
   5.178 +(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
   5.179 +proof(rule bchoice[of ?A' ?phi], default)
   5.180 +  fix a' assume a': "a' \<in> ?A'"
   5.181 +  hence "fst a' \<in> B1" unfolding thePull_def by auto
   5.182 +  moreover
   5.183 +  from a' have "snd a' \<in> B2" unfolding thePull_def by auto
   5.184 +  moreover have "f1 (fst a') = f2 (snd a')"
   5.185 +  using a' unfolding csquare_def thePull_def by auto
   5.186 +  ultimately show "\<exists> ja'. ?phi a' ja'"
   5.187 +  using assms unfolding wppull_def by auto
   5.188 +qed
   5.189 +
   5.190 +lemma wpull_wppull:
   5.191 +assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
   5.192 +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')"
   5.193 +shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
   5.194 +unfolding wppull_def proof safe
   5.195 +  fix b1 b2
   5.196 +  assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
   5.197 +  then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
   5.198 +  using wp unfolding wpull_def by blast
   5.199 +  show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
   5.200 +  apply(rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
   5.201 +qed
   5.202 +
   5.203 +lemma wppull_id: "\<lbrakk>wpull UNIV UNIV UNIV f1 f2 p1 p2; e1 = id; e2 = id\<rbrakk> \<Longrightarrow>
   5.204 +   wppull UNIV UNIV UNIV f1 f2 e1 e2 p1 p2"
   5.205 +by (erule wpull_wppull) auto
   5.206 +
   5.207 +
   5.208 +(* Operators: *)
   5.209 +definition diag where "diag A \<equiv> {(a,a) | a. a \<in> A}"
   5.210 +definition "Gr A f = {(a,f a) | a. a \<in> A}"
   5.211 +definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
   5.212 +
   5.213 +lemma diagI: "x \<in> A \<Longrightarrow> (x, x) \<in> diag A"
   5.214 +unfolding diag_def by simp
   5.215 +
   5.216 +lemma diagE: "(a, b) \<in> diag A \<Longrightarrow> a = b"
   5.217 +unfolding diag_def by simp
   5.218 +
   5.219 +lemma diagE': "x \<in> diag A \<Longrightarrow> fst x = snd x"
   5.220 +unfolding diag_def by auto
   5.221 +
   5.222 +lemma diag_fst: "x \<in> diag A \<Longrightarrow> fst x \<in> A"
   5.223 +unfolding diag_def by auto
   5.224 +
   5.225 +lemma diag_UNIV: "diag UNIV = Id"
   5.226 +unfolding diag_def by auto
   5.227 +
   5.228 +lemma diag_converse: "diag A = (diag A) ^-1"
   5.229 +unfolding diag_def by auto
   5.230 +
   5.231 +lemma diag_Comp: "diag A = diag A O diag A"
   5.232 +unfolding diag_def by auto
   5.233 +
   5.234 +lemma diag_Gr: "diag A = Gr A id"
   5.235 +unfolding diag_def Gr_def by simp
   5.236 +
   5.237 +lemma diag_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> diag UNIV"
   5.238 +unfolding diag_def by auto
   5.239 +
   5.240 +lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
   5.241 +unfolding image2_def by auto
   5.242 +
   5.243 +lemma Id_def': "Id = {(a,b). a = b}"
   5.244 +by auto
   5.245 +
   5.246 +lemma Id_alt: "Id = Gr UNIV id"
   5.247 +unfolding Gr_def by auto
   5.248 +
   5.249 +lemma Id_subset: "Id \<subseteq> {(a, b). P a b \<or> a = b}"
   5.250 +by auto
   5.251 +
   5.252 +lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
   5.253 +by auto
   5.254 +
   5.255 +lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
   5.256 +unfolding image2_def Gr_def by auto
   5.257 +
   5.258 +lemma GrI: "\<lbrakk>x \<in> A; f x = fx\<rbrakk> \<Longrightarrow> (x, fx) \<in> Gr A f"
   5.259 +unfolding Gr_def by simp
   5.260 +
   5.261 +lemma GrE: "(x, fx) \<in> Gr A f \<Longrightarrow> (x \<in> A \<Longrightarrow> f x = fx \<Longrightarrow> P) \<Longrightarrow> P"
   5.262 +unfolding Gr_def by simp
   5.263 +
   5.264 +lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
   5.265 +unfolding Gr_def by simp
   5.266 +
   5.267 +lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
   5.268 +unfolding Gr_def by simp
   5.269 +
   5.270 +lemma Gr_UNIV_id: "f = id \<Longrightarrow> (Gr UNIV f)^-1 O Gr UNIV f = Gr UNIV f"
   5.271 +unfolding Gr_def by auto
   5.272 +
   5.273 +lemma Gr_fst_snd: "(Gr R fst)^-1 O Gr R snd = R"
   5.274 +unfolding Gr_def by auto
   5.275 +
   5.276 +lemma Gr_mono: "A \<subseteq> B \<Longrightarrow> Gr A f \<subseteq> Gr B f"
   5.277 +unfolding Gr_def by auto
   5.278 +
   5.279 +lemma subst_rel_def: "A = B \<Longrightarrow> (Gr A f)^-1 O Gr A g = (Gr B f)^-1 O Gr B g"
   5.280 +by simp
   5.281 +
   5.282 +lemma abs_pred_def: "\<lbrakk>\<And>x y. (x, y) \<in> rel = pred x y\<rbrakk> \<Longrightarrow> rel = Collect (split pred)"
   5.283 +by auto
   5.284 +
   5.285 +lemma Collect_split_cong: "Collect (split pred) = Collect (split pred') \<Longrightarrow> pred = pred'"
   5.286 +by blast
   5.287 +
   5.288 +lemma pred_def_abs: "rel = Collect (split pred) \<Longrightarrow> pred = (\<lambda>x y. (x, y) \<in> rel)"
   5.289 +by auto
   5.290 +
   5.291 +lemma wpull_Gr:
   5.292 +"wpull (Gr A f) A (f ` A) f id fst snd"
   5.293 +unfolding wpull_def Gr_def by auto
   5.294 +
   5.295 +lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
   5.296 +unfolding Gr_def by auto
   5.297 +
   5.298 +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})"
   5.299 +unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
   5.300 +
   5.301 +definition relImage where
   5.302 +"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
   5.303 +
   5.304 +definition relInvImage where
   5.305 +"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
   5.306 +
   5.307 +lemma relImage_Gr:
   5.308 +"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
   5.309 +unfolding relImage_def Gr_def relcomp_def by auto
   5.310 +
   5.311 +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"
   5.312 +unfolding Gr_def relcomp_def image_def relInvImage_def by auto
   5.313 +
   5.314 +lemma relImage_mono:
   5.315 +"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
   5.316 +unfolding relImage_def by auto
   5.317 +
   5.318 +lemma relInvImage_mono:
   5.319 +"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
   5.320 +unfolding relInvImage_def by auto
   5.321 +
   5.322 +lemma relInvImage_diag:
   5.323 +"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (diag B) f \<subseteq> Id"
   5.324 +unfolding relInvImage_def diag_def by auto
   5.325 +
   5.326 +lemma relInvImage_UNIV_relImage:
   5.327 +"R \<subseteq> relInvImage UNIV (relImage R f) f"
   5.328 +unfolding relInvImage_def relImage_def by auto
   5.329 +
   5.330 +lemma relImage_proj:
   5.331 +assumes "equiv A R"
   5.332 +shows "relImage R (proj R) \<subseteq> diag (A//R)"
   5.333 +unfolding relImage_def diag_def apply safe
   5.334 +using proj_iff[OF assms]
   5.335 +by (metis assms equiv_Image proj_def proj_preserves)
   5.336 +
   5.337 +lemma relImage_relInvImage:
   5.338 +assumes "R \<subseteq> f ` A <*> f ` A"
   5.339 +shows "relImage (relInvImage A R f) f = R"
   5.340 +using assms unfolding relImage_def relInvImage_def by fastforce
   5.341 +
   5.342 +
   5.343 +(* Relation composition as a weak pseudo-pullback *)
   5.344 +
   5.345 +(* pick middle *)
   5.346 +definition "pickM P Q a c = (SOME b. (a,b) \<in> P \<and> (b,c) \<in> Q)"
   5.347 +
   5.348 +lemma pickM:
   5.349 +assumes "(a,c) \<in> P O Q"
   5.350 +shows "(a, pickM P Q a c) \<in> P \<and> (pickM P Q a c, c) \<in> Q"
   5.351 +unfolding pickM_def apply(rule someI_ex)
   5.352 +using assms unfolding relcomp_def by auto
   5.353 +
   5.354 +definition fstO where "fstO P Q ac = (fst ac, pickM P Q (fst ac) (snd ac))"
   5.355 +definition sndO where "sndO P Q ac = (pickM P Q (fst ac) (snd ac), snd ac)"
   5.356 +
   5.357 +lemma fstO_in: "ac \<in> P O Q \<Longrightarrow> fstO P Q ac \<in> P"
   5.358 +by (metis assms fstO_def pickM surjective_pairing)
   5.359 +
   5.360 +lemma fst_fstO: "fst bc = (fst \<circ> fstO P Q) bc"
   5.361 +unfolding comp_def fstO_def by simp
   5.362 +
   5.363 +lemma snd_sndO: "snd bc = (snd \<circ> sndO P Q) bc"
   5.364 +unfolding comp_def sndO_def by simp
   5.365 +
   5.366 +lemma sndO_in: "ac \<in> P O Q \<Longrightarrow> sndO P Q ac \<in> Q"
   5.367 +by (metis assms sndO_def pickM surjective_pairing)
   5.368 +
   5.369 +lemma csquare_fstO_sndO:
   5.370 +"csquare (P O Q) snd fst (fstO P Q) (sndO P Q)"
   5.371 +unfolding csquare_def fstO_def sndO_def using pickM by auto
   5.372 +
   5.373 +lemma wppull_fstO_sndO:
   5.374 +shows "wppull (P O Q) P Q snd fst fst snd (fstO P Q) (sndO P Q)"
   5.375 +using pickM unfolding wppull_def fstO_def sndO_def relcomp_def by auto
   5.376 +
   5.377 +lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
   5.378 +by simp
   5.379 +
   5.380 +lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
   5.381 +by (simp split: prod.split)
   5.382 +
   5.383 +lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
   5.384 +by (simp split: prod.split)
   5.385 +
   5.386 +lemma flip_rel: "A \<subseteq> (R ^-1) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> R"
   5.387 +by auto
   5.388 +
   5.389 +lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
   5.390 +by simp
   5.391 +
   5.392 +lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
   5.393 +by simp
   5.394 +
   5.395 +lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
   5.396 +by simp
   5.397 +
   5.398 +lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
   5.399 +by simp
   5.400 +
   5.401 +lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
   5.402 +by simp
   5.403 +
   5.404 +lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
   5.405 +by simp
   5.406 +
   5.407 +lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
   5.408 +by auto
   5.409 +
   5.410 +lemma Collect_restrict': "{(x, y) | x y. phi x y \<and> P x y} \<subseteq> {(x, y) | x y. phi x y}"
   5.411 +by auto
   5.412 +
   5.413 +lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
   5.414 +by auto
   5.415 +
   5.416 +lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> rel.underS R j"
   5.417 +unfolding rel.underS_def by simp
   5.418 +
   5.419 +lemma underS_E: "i \<in> rel.underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
   5.420 +unfolding rel.underS_def by simp
   5.421 +
   5.422 +lemma underS_Field: "i \<in> rel.underS R j \<Longrightarrow> i \<in> Field R"
   5.423 +unfolding rel.underS_def Field_def by auto
   5.424 +
   5.425 +lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
   5.426 +unfolding Field_def by auto
   5.427 +
   5.428 +
   5.429 +subsection {* Convolution product *}
   5.430 +
   5.431 +definition convol ("<_ , _>") where
   5.432 +"<f , g> \<equiv> %a. (f a, g a)"
   5.433 +
   5.434 +lemma fst_convol:
   5.435 +"fst o <f , g> = f"
   5.436 +apply(rule ext)
   5.437 +unfolding convol_def by simp
   5.438 +
   5.439 +lemma snd_convol:
   5.440 +"snd o <f , g> = g"
   5.441 +apply(rule ext)
   5.442 +unfolding convol_def by simp
   5.443 +
   5.444 +lemma fst_convol': "fst (<f, g> x) = f x"
   5.445 +using fst_convol unfolding convol_def by simp
   5.446 +
   5.447 +lemma snd_convol': "snd (<f, g> x) = g x"
   5.448 +using snd_convol unfolding convol_def by simp
   5.449 +
   5.450 +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"
   5.451 +unfolding convol_def by auto
   5.452 +
   5.453 +lemma convol_expand_snd: "fst o f = g \<Longrightarrow>  <g, snd o f> = f"
   5.454 +unfolding convol_def by auto
   5.455 +
   5.456 +subsection{* Facts about functions *}
   5.457 +
   5.458 +lemma pointfreeE: "f o g = f' o g' \<Longrightarrow> f (g x) = f' (g' x)"
   5.459 +unfolding o_def fun_eq_iff by simp
   5.460 +
   5.461 +lemma pointfree_idE: "f o g = id \<Longrightarrow> f (g x) = x"
   5.462 +unfolding o_def fun_eq_iff by simp
   5.463 +
   5.464 +definition inver where
   5.465 +  "inver g f A = (ALL a : A. g (f a) = a)"
   5.466 +
   5.467 +lemma bij_betw_iff_ex:
   5.468 +  "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
   5.469 +proof (rule iffI)
   5.470 +  assume ?L
   5.471 +  hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
   5.472 +  let ?phi = "% b a. a : A \<and> f a = b"
   5.473 +  have "ALL b : B. EX a. ?phi b a" using f by blast
   5.474 +  then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
   5.475 +    using bchoice[of B ?phi] by blast
   5.476 +  hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
   5.477 +  have gf: "inver g f A" unfolding inver_def by (metis gg imageI inj_f the_inv_into_f_f)
   5.478 +  moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
   5.479 +  moreover have "A \<le> g ` B"
   5.480 +  proof safe
   5.481 +    fix a assume a: "a : A"
   5.482 +    hence "f a : B" using f by auto
   5.483 +    moreover have "a = g (f a)" using a gf unfolding inver_def by auto
   5.484 +    ultimately show "a : g ` B" by blast
   5.485 +  qed
   5.486 +  ultimately show ?R by blast
   5.487 +next
   5.488 +  assume ?R
   5.489 +  then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
   5.490 +  show ?L unfolding bij_betw_def
   5.491 +  proof safe
   5.492 +    show "inj_on f A" unfolding inj_on_def
   5.493 +    proof safe
   5.494 +      fix a1 a2 assume a: "a1 : A"  "a2 : A" and "f a1 = f a2"
   5.495 +      hence "g (f a1) = g (f a2)" by simp
   5.496 +      thus "a1 = a2" using a g unfolding inver_def by simp
   5.497 +    qed
   5.498 +  next
   5.499 +    fix a assume "a : A"
   5.500 +    then obtain b where b: "b : B" and a: "a = g b" using g by blast
   5.501 +    hence "b = f (g b)" using g unfolding inver_def by auto
   5.502 +    thus "f a : B" unfolding a using b by simp
   5.503 +  next
   5.504 +    fix b assume "b : B"
   5.505 +    hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
   5.506 +    thus "b : f ` A" by auto
   5.507 +  qed
   5.508 +qed
   5.509 +
   5.510 +lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
   5.511 +unfolding bij_def inj_on_def by auto blast
   5.512 +
   5.513 +lemma bij_betw_ex_weakE:
   5.514 +  "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
   5.515 +by (auto simp only: bij_betw_iff_ex)
   5.516 +
   5.517 +lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
   5.518 +unfolding inver_def by auto (rule rev_image_eqI, auto)
   5.519 +
   5.520 +lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
   5.521 +unfolding inver_def by auto
   5.522 +
   5.523 +lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
   5.524 +unfolding inver_def by simp
   5.525 +
   5.526 +lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
   5.527 +unfolding bij_betw_def by auto
   5.528 +
   5.529 +lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
   5.530 +unfolding bij_betw_def by auto
   5.531 +
   5.532 +lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
   5.533 +unfolding inver_def by auto
   5.534 +
   5.535 +lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
   5.536 +unfolding bij_betw_def inver_def by auto
   5.537 +
   5.538 +lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
   5.539 +unfolding bij_betw_def inver_def by auto
   5.540 +
   5.541 +lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
   5.542 +by (metis bij_betw_iff_ex bij_betw_imageE)
   5.543 +
   5.544 +lemma bij_betwI':
   5.545 +  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
   5.546 +    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
   5.547 +    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
   5.548 +unfolding bij_betw_def inj_on_def by auto (metis rev_image_eqI)
   5.549 +
   5.550 +lemma o_bij:
   5.551 +  assumes gf: "g o f = id" and fg: "f o g = id"
   5.552 +  shows "bij f"
   5.553 +unfolding bij_def inj_on_def surj_def proof safe
   5.554 +  fix a1 a2 assume "f a1 = f a2"
   5.555 +  hence "g ( f a1) = g (f a2)" by simp
   5.556 +  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
   5.557 +next
   5.558 +  fix b
   5.559 +  have "b = f (g b)"
   5.560 +  using fg unfolding fun_eq_iff by simp
   5.561 +  thus "EX a. b = f a" by blast
   5.562 +qed
   5.563 +
   5.564 +lemma surj_fun_eq:
   5.565 +  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
   5.566 +  shows "g1 = g2"
   5.567 +proof (rule ext)
   5.568 +  fix y
   5.569 +  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
   5.570 +  thus "g1 y = g2 y" using eq_on by simp
   5.571 +qed
   5.572 +
   5.573 +lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
   5.574 +unfolding wo_rel_def card_order_on_def by blast 
   5.575 +
   5.576 +lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
   5.577 +  \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
   5.578 +unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
   5.579 +
   5.580 +lemma Card_order_trans:
   5.581 +  "\<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"
   5.582 +unfolding card_order_on_def well_order_on_def linear_order_on_def
   5.583 +  partial_order_on_def preorder_on_def trans_def antisym_def by blast
   5.584 +
   5.585 +lemma Cinfinite_limit2:
   5.586 + assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
   5.587 + shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
   5.588 +proof -
   5.589 +  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
   5.590 +    unfolding card_order_on_def well_order_on_def linear_order_on_def
   5.591 +      partial_order_on_def preorder_on_def by auto
   5.592 +  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
   5.593 +    using Cinfinite_limit[OF x1 r] by blast
   5.594 +  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
   5.595 +    using Cinfinite_limit[OF x2 r] by blast
   5.596 +  show ?thesis
   5.597 +  proof (cases "y1 = y2")
   5.598 +    case True with y1 y2 show ?thesis by blast
   5.599 +  next
   5.600 +    case False
   5.601 +    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
   5.602 +      unfolding total_on_def by auto
   5.603 +    thus ?thesis
   5.604 +    proof
   5.605 +      assume *: "(y1, y2) \<in> r"
   5.606 +      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
   5.607 +      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
   5.608 +    next
   5.609 +      assume *: "(y2, y1) \<in> r"
   5.610 +      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
   5.611 +      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
   5.612 +    qed
   5.613 +  qed
   5.614 +qed
   5.615 +
   5.616 +lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
   5.617 + \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
   5.618 +proof (induct X rule: finite_induct)
   5.619 +  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
   5.620 +next
   5.621 +  case (insert x X)
   5.622 +  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
   5.623 +  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"
   5.624 +    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
   5.625 +  show ?case by (metis Card_order_trans insert(5) insertE y(2) z)
   5.626 +qed
   5.627 +
   5.628 +lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
   5.629 +by auto
   5.630 +
   5.631 +(*helps resolution*)
   5.632 +lemma well_order_induct_imp:
   5.633 +  "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>
   5.634 +     x \<in> Field r \<longrightarrow> P x"
   5.635 +by (erule wo_rel.well_order_induct)
   5.636 +
   5.637 +lemma meta_spec2:
   5.638 +  assumes "(\<And>x y. PROP P x y)"
   5.639 +  shows "PROP P x y"
   5.640 +by (rule `(\<And>x y. PROP P x y)`)
   5.641 +
   5.642 +(*Extended List_Prefix*)
   5.643 +
   5.644 +definition prefCl where
   5.645 +  "prefCl Kl = (\<forall> kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
   5.646 +definition PrefCl where
   5.647 +  "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> kl' \<le> kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
   5.648 +
   5.649 +lemma prefCl_UN:
   5.650 +  "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
   5.651 +unfolding prefCl_def PrefCl_def by fastforce
   5.652 +
   5.653 +definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
   5.654 +definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
   5.655 +definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
   5.656 +
   5.657 +lemmas sh_def = Shift_def shift_def
   5.658 +
   5.659 +lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
   5.660 +unfolding Shift_def Succ_def by simp
   5.661 +
   5.662 +lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
   5.663 +unfolding Shift_def clists_def Field_card_of by auto
   5.664 +
   5.665 +lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
   5.666 +unfolding prefCl_def Shift_def
   5.667 +proof safe
   5.668 +  fix kl1 kl2
   5.669 +  assume "\<forall>kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
   5.670 +    "kl1 \<le> kl2" "k # kl2 \<in> Kl"
   5.671 +  thus "k # kl1 \<in> Kl" using Cons_prefix_Cons[of k kl1 k kl2] by blast
   5.672 +qed
   5.673 +
   5.674 +lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
   5.675 +unfolding Shift_def by simp
   5.676 +
   5.677 +lemma prefCl_Succ: "\<lbrakk>prefCl Kl; k # kl \<in> Kl\<rbrakk> \<Longrightarrow> k \<in> Succ Kl []"
   5.678 +unfolding Succ_def proof
   5.679 +  assume "prefCl Kl" "k # kl \<in> Kl"
   5.680 +  moreover have "k # [] \<le> k # kl" by auto
   5.681 +  ultimately have "k # [] \<in> Kl" unfolding prefCl_def by blast
   5.682 +  thus "[] @ [k] \<in> Kl" by simp
   5.683 +qed
   5.684 +
   5.685 +lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
   5.686 +unfolding Succ_def by simp
   5.687 +
   5.688 +lemmas SuccE = SuccD[elim_format]
   5.689 +
   5.690 +lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
   5.691 +unfolding Succ_def by simp
   5.692 +
   5.693 +lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
   5.694 +unfolding Shift_def by simp
   5.695 +
   5.696 +lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
   5.697 +unfolding Succ_def Shift_def by auto
   5.698 +
   5.699 +lemma ShiftI: "k # kl \<in> Kl \<Longrightarrow> kl \<in> Shift Kl k"
   5.700 +unfolding Shift_def by simp
   5.701 +
   5.702 +lemma Func_cexp: "|Func A B| =o |B| ^c |A|"
   5.703 +unfolding cexp_def Field_card_of by (simp only: card_of_refl)
   5.704 +
   5.705 +lemma clists_bound: "A \<in> Field (cpow (clists r)) - {{}} \<Longrightarrow> |A| \<le>o clists r"
   5.706 +unfolding cpow_def clists_def Field_card_of by (auto simp: card_of_mono1)
   5.707 +
   5.708 +lemma cpow_clists_czero: "\<lbrakk>A \<in> Field (cpow (clists r)) - {{}}; |A| =o czero\<rbrakk> \<Longrightarrow> False"
   5.709 +unfolding cpow_def clists_def
   5.710 +by (auto simp add: card_of_ordIso_czero_iff_empty[symmetric])
   5.711 +   (erule notE, erule ordIso_transitive, rule czero_ordIso)
   5.712 +
   5.713 +lemma incl_UNION_I:
   5.714 +assumes "i \<in> I" and "A \<subseteq> F i"
   5.715 +shows "A \<subseteq> UNION I F"
   5.716 +using assms by auto
   5.717 +
   5.718 +lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
   5.719 +unfolding clists_def Field_card_of by auto
   5.720 +
   5.721 +lemma Cons_clists:
   5.722 +  "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
   5.723 +unfolding clists_def Field_card_of by auto
   5.724 +
   5.725 +lemma length_Cons: "length (x#xs) = Suc (length xs)"
   5.726 +by simp
   5.727 +
   5.728 +lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
   5.729 +by simp
   5.730 +
   5.731 +(*injection into the field of a cardinal*)
   5.732 +definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
   5.733 +definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
   5.734 +
   5.735 +lemma ex_toCard_pred:
   5.736 +"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
   5.737 +unfolding toCard_pred_def
   5.738 +using card_of_ordLeq[of A "Field r"]
   5.739 +      ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
   5.740 +by blast
   5.741 +
   5.742 +lemma toCard_pred_toCard:
   5.743 +  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
   5.744 +unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
   5.745 +
   5.746 +lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
   5.747 +  toCard A r x = toCard A r y \<longleftrightarrow> x = y"
   5.748 +using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
   5.749 +
   5.750 +lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
   5.751 +using toCard_pred_toCard unfolding toCard_pred_def by blast
   5.752 +
   5.753 +definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
   5.754 +
   5.755 +lemma fromCard_toCard:
   5.756 +"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
   5.757 +unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
   5.758 +
   5.759 +(* pick according to the weak pullback *)
   5.760 +definition pickWP_pred where
   5.761 +"pickWP_pred A p1 p2 b1 b2 a \<equiv>
   5.762 + a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
   5.763 +
   5.764 +definition pickWP where
   5.765 +"pickWP A p1 p2 b1 b2 \<equiv>
   5.766 + SOME a. pickWP_pred A p1 p2 b1 b2 a"
   5.767 +
   5.768 +lemma pickWP_pred:
   5.769 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
   5.770 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
   5.771 +shows "\<exists> a. pickWP_pred A p1 p2 b1 b2 a"
   5.772 +using assms unfolding wpull_def pickWP_pred_def by blast
   5.773 +
   5.774 +lemma pickWP_pred_pickWP:
   5.775 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
   5.776 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
   5.777 +shows "pickWP_pred A p1 p2 b1 b2 (pickWP A p1 p2 b1 b2)"
   5.778 +unfolding pickWP_def using assms by(rule someI_ex[OF pickWP_pred])
   5.779 +
   5.780 +lemma pickWP:
   5.781 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
   5.782 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
   5.783 +shows "pickWP A p1 p2 b1 b2 \<in> A"
   5.784 +      "p1 (pickWP A p1 p2 b1 b2) = b1"
   5.785 +      "p2 (pickWP A p1 p2 b1 b2) = b2"
   5.786 +using assms pickWP_pred_pickWP unfolding pickWP_pred_def by fastforce+
   5.787 +
   5.788 +lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
   5.789 +
   5.790 +lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
   5.791 +unfolding Field_card_of csum_def by auto
   5.792 +
   5.793 +lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
   5.794 +unfolding Field_card_of csum_def by auto
   5.795 +
   5.796 +lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
   5.797 +by auto
   5.798 +
   5.799 +lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
   5.800 +by auto
   5.801 +
   5.802 +lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
   5.803 +by auto
   5.804 +
   5.805 +lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
   5.806 +by auto
   5.807 +
   5.808 +lemma sum_case_cong: "p = q \<Longrightarrow> sum_case f g p = sum_case f g q"
   5.809 +by simp
   5.810 +
   5.811 +lemma sum_case_step:
   5.812 +  "sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
   5.813 +  "sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
   5.814 +by auto
   5.815 +
   5.816 +lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   5.817 +by (cases s) auto
   5.818 +
   5.819 +lemma obj_sum_base: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   5.820 +by auto
   5.821 +
   5.822 +lemma obj_sum_step:
   5.823 +  "\<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"
   5.824 +by (metis obj_sumE)
   5.825 +
   5.826 +lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
   5.827 +by auto
   5.828 +
   5.829 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Codatatype/Basic_BNFs.thy	Tue Aug 28 17:16:00 2012 +0200
     6.3 @@ -0,0 +1,1529 @@
     6.4 +(*  Title:      HOL/Codatatype/Basic_BNFs.thy
     6.5 +    Author:     Dmitriy Traytel, TU Muenchen
     6.6 +    Author:     Andrei Popescu, TU Muenchen
     6.7 +    Author:     Jasmin Blanchette, TU Muenchen
     6.8 +    Copyright   2012
     6.9 +
    6.10 +Registration of various types as bounded natural functors.
    6.11 +*)
    6.12 +
    6.13 +header {* Registration of Various Types as Bounded Natural Functors *}
    6.14 +
    6.15 +theory Basic_BNFs
    6.16 +imports BNF_Def "~~/src/HOL/Quotient_Examples/FSet"
    6.17 +        "~~/src/HOL/Library/Multiset" Countable_Set
    6.18 +begin
    6.19 +
    6.20 +lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
    6.21 +
    6.22 +lemma ctwo_card_order: "card_order ctwo"
    6.23 +using Card_order_ctwo by (unfold ctwo_def Field_card_of)
    6.24 +
    6.25 +lemma natLeq_cinfinite: "cinfinite natLeq"
    6.26 +unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
    6.27 +
    6.28 +bnf_def ID = "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
    6.29 +apply auto
    6.30 +apply (rule natLeq_card_order)
    6.31 +apply (rule natLeq_cinfinite)
    6.32 +apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
    6.33 +apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)
    6.34 +apply (rule ordLeq_transitive)
    6.35 +apply (rule ordLeq_cexp1[of natLeq])
    6.36 +apply (rule Cinfinite_Cnotzero)
    6.37 +apply (rule conjI)
    6.38 +apply (rule natLeq_cinfinite)
    6.39 +apply (rule natLeq_Card_order)
    6.40 +apply (rule card_of_Card_order)
    6.41 +apply (rule cexp_mono1)
    6.42 +apply (rule ordLeq_csum1)
    6.43 +apply (rule card_of_Card_order)
    6.44 +apply (rule disjI2)
    6.45 +apply (rule cone_ordLeq_cexp)
    6.46 +apply (rule ordLeq_transitive)
    6.47 +apply (rule cone_ordLeq_ctwo)
    6.48 +apply (rule ordLeq_csum2)
    6.49 +apply (rule Card_order_ctwo)
    6.50 +apply (rule natLeq_Card_order)
    6.51 +done
    6.52 +
    6.53 +lemma ID_pred[simp]: "ID_pred \<phi> = \<phi>"
    6.54 +unfolding ID_pred_def ID_rel_def Gr_def fun_eq_iff by auto
    6.55 +
    6.56 +bnf_def DEADID = "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
    6.57 +apply (auto simp add: wpull_id)
    6.58 +apply (rule card_order_csum)
    6.59 +apply (rule natLeq_card_order)
    6.60 +apply (rule card_of_card_order_on)
    6.61 +apply (rule cinfinite_csum)
    6.62 +apply (rule disjI1)
    6.63 +apply (rule natLeq_cinfinite)
    6.64 +apply (rule ordLess_imp_ordLeq)
    6.65 +apply (rule ordLess_ordLeq_trans)
    6.66 +apply (rule ordLess_ctwo_cexp)
    6.67 +apply (rule card_of_Card_order)
    6.68 +apply (rule cexp_mono2'')
    6.69 +apply (rule ordLeq_csum2)
    6.70 +apply (rule card_of_Card_order)
    6.71 +apply (rule ctwo_Cnotzero)
    6.72 +by (rule card_of_Card_order)
    6.73 +
    6.74 +lemma DEADID_pred[simp]: "DEADID_pred = (op =)"
    6.75 +unfolding DEADID_pred_def DEADID.rel_Id by simp
    6.76 +
    6.77 +ML {*
    6.78 +
    6.79 +signature BASIC_BNFS =
    6.80 +sig
    6.81 +  val ID_bnf: BNF_Def.BNF
    6.82 +  val ID_rel_def: thm
    6.83 +  val ID_pred_def: thm
    6.84 +
    6.85 +  val DEADID_bnf: BNF_Def.BNF
    6.86 +end;
    6.87 +
    6.88 +structure Basic_BNFs : BASIC_BNFS =
    6.89 +struct
    6.90 +
    6.91 +  val ID_bnf = the (BNF_Def.bnf_of @{context} "ID");
    6.92 +  val DEADID_bnf = the (BNF_Def.bnf_of @{context} "DEADID");
    6.93 +
    6.94 +  val rel_def = BNF_Def.rel_def_of_bnf ID_bnf;
    6.95 +  val ID_rel_def = rel_def RS sym;
    6.96 +  val ID_pred_def =
    6.97 +    Local_Defs.unfold @{context} [rel_def] (BNF_Def.pred_def_of_bnf ID_bnf) RS sym;
    6.98 +
    6.99 +end;
   6.100 +*}
   6.101 +
   6.102 +definition sum_setl :: "'a + 'b \<Rightarrow> 'a set" where
   6.103 +"sum_setl x = (case x of Inl z => {z} | _ => {})"
   6.104 +
   6.105 +definition sum_setr :: "'a + 'b \<Rightarrow> 'b set" where
   6.106 +"sum_setr x = (case x of Inr z => {z} | _ => {})"
   6.107 +
   6.108 +lemmas sum_set_defs = sum_setl_def[abs_def] sum_setr_def[abs_def]
   6.109 +
   6.110 +bnf_def sum = sum_map [sum_setl, sum_setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr]
   6.111 +proof -
   6.112 +  show "sum_map id id = id" by (rule sum_map.id)
   6.113 +next
   6.114 +  fix f1 f2 g1 g2
   6.115 +  show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
   6.116 +    by (rule sum_map.comp[symmetric])
   6.117 +next
   6.118 +  fix x f1 f2 g1 g2
   6.119 +  assume a1: "\<And>z. z \<in> sum_setl x \<Longrightarrow> f1 z = g1 z" and
   6.120 +         a2: "\<And>z. z \<in> sum_setr x \<Longrightarrow> f2 z = g2 z"
   6.121 +  thus "sum_map f1 f2 x = sum_map g1 g2 x"
   6.122 +  proof (cases x)
   6.123 +    case Inl thus ?thesis using a1 by (clarsimp simp: sum_setl_def)
   6.124 +  next
   6.125 +    case Inr thus ?thesis using a2 by (clarsimp simp: sum_setr_def)
   6.126 +  qed
   6.127 +next
   6.128 +  fix f1 f2
   6.129 +  show "sum_setl o sum_map f1 f2 = image f1 o sum_setl"
   6.130 +    by (rule ext, unfold o_apply) (simp add: sum_setl_def split: sum.split)
   6.131 +next
   6.132 +  fix f1 f2
   6.133 +  show "sum_setr o sum_map f1 f2 = image f2 o sum_setr"
   6.134 +    by (rule ext, unfold o_apply) (simp add: sum_setr_def split: sum.split)
   6.135 +next
   6.136 +  show "card_order natLeq" by (rule natLeq_card_order)
   6.137 +next
   6.138 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
   6.139 +next
   6.140 +  fix x
   6.141 +  show "|sum_setl x| \<le>o natLeq"
   6.142 +    apply (rule ordLess_imp_ordLeq)
   6.143 +    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
   6.144 +    by (simp add: sum_setl_def split: sum.split)
   6.145 +next
   6.146 +  fix x
   6.147 +  show "|sum_setr x| \<le>o natLeq"
   6.148 +    apply (rule ordLess_imp_ordLeq)
   6.149 +    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
   6.150 +    by (simp add: sum_setr_def split: sum.split)
   6.151 +next
   6.152 +  fix A1 :: "'a set" and A2 :: "'b set"
   6.153 +  have in_alt: "{x. (case x of Inl z => {z} | _ => {}) \<subseteq> A1 \<and>
   6.154 +    (case x of Inr z => {z} | _ => {}) \<subseteq> A2} = A1 <+> A2" (is "?L = ?R")
   6.155 +  proof safe
   6.156 +    fix x :: "'a + 'b"
   6.157 +    assume "(case x of Inl z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A1" "(case x of Inr z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A2"
   6.158 +    hence "x \<in> Inl ` A1 \<or> x \<in> Inr ` A2" by (cases x) simp+
   6.159 +    thus "x \<in> A1 <+> A2" by blast
   6.160 +  qed (auto split: sum.split)
   6.161 +  show "|{x. sum_setl x \<subseteq> A1 \<and> sum_setr x \<subseteq> A2}| \<le>o
   6.162 +    (( |A1| +c |A2| ) +c ctwo) ^c natLeq"
   6.163 +    apply (rule ordIso_ordLeq_trans)
   6.164 +    apply (rule card_of_ordIso_subst)
   6.165 +    apply (unfold sum_set_defs)
   6.166 +    apply (rule in_alt)
   6.167 +    apply (rule ordIso_ordLeq_trans)
   6.168 +    apply (rule Plus_csum)
   6.169 +    apply (rule ordLeq_transitive)
   6.170 +    apply (rule ordLeq_csum1)
   6.171 +    apply (rule Card_order_csum)
   6.172 +    apply (rule ordLeq_cexp1)
   6.173 +    apply (rule conjI)
   6.174 +    using Field_natLeq UNIV_not_empty czeroE apply fast
   6.175 +    apply (rule natLeq_Card_order)
   6.176 +    by (rule Card_order_csum)
   6.177 +next
   6.178 +  fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
   6.179 +  assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
   6.180 +  hence
   6.181 +    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"
   6.182 +    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"
   6.183 +    unfolding wpull_def by blast+
   6.184 +  show "wpull {x. sum_setl x \<subseteq> A1 \<and> sum_setr x \<subseteq> A2}
   6.185 +  {x. sum_setl x \<subseteq> B11 \<and> sum_setr x \<subseteq> B12} {x. sum_setl x \<subseteq> B21 \<and> sum_setr x \<subseteq> B22}
   6.186 +  (sum_map f11 f12) (sum_map f21 f22) (sum_map p11 p12) (sum_map p21 p22)"
   6.187 +    (is "wpull ?in ?in1 ?in2 ?mapf1 ?mapf2 ?mapp1 ?mapp2")
   6.188 +  proof (unfold wpull_def)
   6.189 +    { fix B1 B2
   6.190 +      assume *: "B1 \<in> ?in1" "B2 \<in> ?in2" "?mapf1 B1 = ?mapf2 B2"
   6.191 +      have "\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2"
   6.192 +      proof (cases B1)
   6.193 +        case (Inl b1)
   6.194 +        { fix b2 assume "B2 = Inr b2"
   6.195 +          with Inl *(3) have False by simp
   6.196 +        } then obtain b2 where Inl': "B2 = Inl b2" by (cases B2) (simp, blast)
   6.197 +        with Inl * have "b1 \<in> B11" "b2 \<in> B21" "f11 b1 = f21 b2"
   6.198 +        by (simp add: sum_setl_def)+
   6.199 +        with pull1 obtain a where "a \<in> A1" "p11 a = b1" "p21 a = b2" by blast+
   6.200 +        with Inl Inl' have "Inl a \<in> ?in" "?mapp1 (Inl a) = B1 \<and> ?mapp2 (Inl a) = B2"
   6.201 +        by (simp add: sum_set_defs)+
   6.202 +        thus ?thesis by blast
   6.203 +      next
   6.204 +        case (Inr b1)
   6.205 +        { fix b2 assume "B2 = Inl b2"
   6.206 +          with Inr *(3) have False by simp
   6.207 +        } then obtain b2 where Inr': "B2 = Inr b2" by (cases B2) (simp, blast)
   6.208 +        with Inr * have "b1 \<in> B12" "b2 \<in> B22" "f12 b1 = f22 b2"
   6.209 +        by (simp add: sum_set_defs)+
   6.210 +        with pull2 obtain a where "a \<in> A2" "p12 a = b1" "p22 a = b2" by blast+
   6.211 +        with Inr Inr' have "Inr a \<in> ?in" "?mapp1 (Inr a) = B1 \<and> ?mapp2 (Inr a) = B2"
   6.212 +        by (simp add: sum_set_defs)+
   6.213 +        thus ?thesis by blast
   6.214 +      qed
   6.215 +    }
   6.216 +    thus "\<forall>B1 B2. B1 \<in> ?in1 \<and> B2 \<in> ?in2 \<and> ?mapf1 B1 = ?mapf2 B2 \<longrightarrow>
   6.217 +      (\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2)" by fastforce
   6.218 +  qed
   6.219 +qed (auto simp: sum_set_defs)
   6.220 +
   6.221 +lemma sum_pred[simp]:
   6.222 +  "sum_pred \<phi> \<psi> x y =
   6.223 +    (case x of Inl a1 \<Rightarrow> (case y of Inl a2 \<Rightarrow> \<phi> a1 a2 | Inr _ \<Rightarrow> False)
   6.224 +             | Inr b1 \<Rightarrow> (case y of Inl _ \<Rightarrow> False | Inr b2 \<Rightarrow> \<psi> b1 b2))"
   6.225 +unfolding sum_setl_def sum_setr_def sum_pred_def sum_rel_def Gr_def relcomp_unfold converse_unfold
   6.226 +by (fastforce split: sum.splits)+
   6.227 +
   6.228 +lemma singleton_ordLeq_ctwo_natLeq: "|{x}| \<le>o ctwo *c natLeq"
   6.229 +  apply (rule ordLeq_transitive)
   6.230 +  apply (rule ordLeq_cprod2)
   6.231 +  apply (rule ctwo_Cnotzero)
   6.232 +  apply (auto simp: Field_card_of intro: card_of_card_order_on)
   6.233 +  apply (rule cprod_mono2)
   6.234 +  apply (rule ordLess_imp_ordLeq)
   6.235 +  apply (unfold finite_iff_ordLess_natLeq[symmetric])
   6.236 +  by simp
   6.237 +
   6.238 +definition fsts :: "'a \<times> 'b \<Rightarrow> 'a set" where
   6.239 +"fsts x = {fst x}"
   6.240 +
   6.241 +definition snds :: "'a \<times> 'b \<Rightarrow> 'b set" where
   6.242 +"snds x = {snd x}"
   6.243 +
   6.244 +lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
   6.245 +
   6.246 +bnf_def prod = map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. ctwo *c natLeq" [Pair]
   6.247 +proof (unfold prod_set_defs)
   6.248 +  show "map_pair id id = id" by (rule map_pair.id)
   6.249 +next
   6.250 +  fix f1 f2 g1 g2
   6.251 +  show "map_pair (g1 o f1) (g2 o f2) = map_pair g1 g2 o map_pair f1 f2"
   6.252 +    by (rule map_pair.comp[symmetric])
   6.253 +next
   6.254 +  fix x f1 f2 g1 g2
   6.255 +  assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
   6.256 +  thus "map_pair f1 f2 x = map_pair g1 g2 x" by (cases x) simp
   6.257 +next
   6.258 +  fix f1 f2
   6.259 +  show "(\<lambda>x. {fst x}) o map_pair f1 f2 = image f1 o (\<lambda>x. {fst x})"
   6.260 +    by (rule ext, unfold o_apply) simp
   6.261 +next
   6.262 +  fix f1 f2
   6.263 +  show "(\<lambda>x. {snd x}) o map_pair f1 f2 = image f2 o (\<lambda>x. {snd x})"
   6.264 +    by (rule ext, unfold o_apply) simp
   6.265 +next
   6.266 +  show "card_order (ctwo *c natLeq)"
   6.267 +    apply (rule card_order_cprod)
   6.268 +    apply (rule ctwo_card_order)
   6.269 +    by (rule natLeq_card_order)
   6.270 +next
   6.271 +  show "cinfinite (ctwo *c natLeq)"
   6.272 +    apply (rule cinfinite_cprod2)
   6.273 +    apply (rule ctwo_Cnotzero)
   6.274 +    apply (rule conjI[OF _ natLeq_Card_order])
   6.275 +    by (rule natLeq_cinfinite)
   6.276 +next
   6.277 +  fix x
   6.278 +  show "|{fst x}| \<le>o ctwo *c natLeq"
   6.279 +    by (rule singleton_ordLeq_ctwo_natLeq)
   6.280 +next
   6.281 +  fix x
   6.282 +  show "|{snd x}| \<le>o ctwo *c natLeq"
   6.283 +    by (rule singleton_ordLeq_ctwo_natLeq)
   6.284 +next
   6.285 +  fix A1 :: "'a set" and A2 :: "'b set"
   6.286 +  have in_alt: "{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2} = A1 \<times> A2" by auto
   6.287 +  show "|{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}| \<le>o
   6.288 +    ( ( |A1| +c |A2| ) +c ctwo) ^c (ctwo *c natLeq)"
   6.289 +    apply (rule ordIso_ordLeq_trans)
   6.290 +    apply (rule card_of_ordIso_subst)
   6.291 +    apply (rule in_alt)
   6.292 +    apply (rule ordIso_ordLeq_trans)
   6.293 +    apply (rule Times_cprod)
   6.294 +    apply (rule ordLeq_transitive)
   6.295 +    apply (rule cprod_csum_cexp)
   6.296 +    apply (rule cexp_mono)
   6.297 +    apply (rule ordLeq_csum1)
   6.298 +    apply (rule Card_order_csum)
   6.299 +    apply (rule ordLeq_cprod1)
   6.300 +    apply (rule Card_order_ctwo)
   6.301 +    apply (rule Cinfinite_Cnotzero)
   6.302 +    apply (rule conjI[OF _ natLeq_Card_order])
   6.303 +    apply (rule natLeq_cinfinite)
   6.304 +    apply (rule disjI2)
   6.305 +    apply (rule cone_ordLeq_cexp)
   6.306 +    apply (rule ordLeq_transitive)
   6.307 +    apply (rule cone_ordLeq_ctwo)
   6.308 +    apply (rule ordLeq_csum2)
   6.309 +    apply (rule Card_order_ctwo)
   6.310 +    apply (rule notE)
   6.311 +    apply (rule ctwo_not_czero)
   6.312 +    apply assumption
   6.313 +    by (rule Card_order_ctwo)
   6.314 +next
   6.315 +  fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
   6.316 +  assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
   6.317 +  thus "wpull {x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}
   6.318 +    {x. {fst x} \<subseteq> B11 \<and> {snd x} \<subseteq> B12} {x. {fst x} \<subseteq> B21 \<and> {snd x} \<subseteq> B22}
   6.319 +   (map_pair f11 f12) (map_pair f21 f22) (map_pair p11 p12) (map_pair p21 p22)"
   6.320 +    unfolding wpull_def by simp fast
   6.321 +qed simp+
   6.322 +
   6.323 +lemma prod_pred[simp]:
   6.324 +"prod_pred \<phi> \<psi> p1 p2 = (case p1 of (a1, b1) \<Rightarrow> case p2 of (a2, b2) \<Rightarrow> (\<phi> a1 a2 \<and> \<psi> b1 b2))"
   6.325 +unfolding prod_set_defs prod_pred_def prod_rel_def Gr_def relcomp_unfold converse_unfold by auto
   6.326 +(* TODO: pred characterization for each basic BNF *)
   6.327 +
   6.328 +(* Categorical version of pullback: *)
   6.329 +lemma wpull_cat:
   6.330 +assumes p: "wpull A B1 B2 f1 f2 p1 p2"
   6.331 +and c: "f1 o q1 = f2 o q2"
   6.332 +and r: "range q1 \<subseteq> B1" "range q2 \<subseteq> B2"
   6.333 +obtains h where "range h \<subseteq> A \<and> q1 = p1 o h \<and> q2 = p2 o h"
   6.334 +proof-
   6.335 +  have *: "\<forall>d. \<exists>a \<in> A. p1 a = q1 d & p2 a = q2 d"
   6.336 +  proof safe
   6.337 +    fix d
   6.338 +    have "f1 (q1 d) = f2 (q2 d)" using c unfolding comp_def[abs_def] by (rule fun_cong)
   6.339 +    moreover
   6.340 +    have "q1 d : B1" "q2 d : B2" using r unfolding image_def by auto
   6.341 +    ultimately show "\<exists>a \<in> A. p1 a = q1 d \<and> p2 a = q2 d"
   6.342 +      using p unfolding wpull_def by auto
   6.343 +  qed
   6.344 +  then obtain h where "!! d. h d \<in> A & p1 (h d) = q1 d & p2 (h d) = q2 d" by metis
   6.345 +  thus ?thesis using that by fastforce
   6.346 +qed
   6.347 +
   6.348 +lemma card_of_bounded_range:
   6.349 +  "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
   6.350 +proof -
   6.351 +  let ?f = "\<lambda>f. %x. if f x \<in> B then Some (f x) else None"
   6.352 +  have "inj_on ?f ?LHS" unfolding inj_on_def
   6.353 +  proof (unfold fun_eq_iff, safe)
   6.354 +    fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
   6.355 +    assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
   6.356 +    hence "f x \<in> B" "g x \<in> B" by auto
   6.357 +    with eq have "Some (f x) = Some (g x)" by metis
   6.358 +    thus "f x = g x" by simp
   6.359 +  qed
   6.360 +  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
   6.361 +  ultimately show ?thesis using card_of_ordLeq by fast
   6.362 +qed
   6.363 +
   6.364 +bnf_def "fun" = "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|"
   6.365 +  ["%c x::'b::type. c::'a::type"]
   6.366 +proof
   6.367 +  fix f show "id \<circ> f = id f" by simp
   6.368 +next
   6.369 +  fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
   6.370 +  unfolding comp_def[abs_def] ..
   6.371 +next
   6.372 +  fix x f g
   6.373 +  assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
   6.374 +  thus "f \<circ> x = g \<circ> x" by auto
   6.375 +next
   6.376 +  fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
   6.377 +  unfolding image_def comp_def[abs_def] by auto
   6.378 +next
   6.379 +  show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
   6.380 +  apply (rule card_order_csum)
   6.381 +  apply (rule natLeq_card_order)
   6.382 +  by (rule card_of_card_order_on)
   6.383 +(*  *)
   6.384 +  show "cinfinite (natLeq +c ?U)"
   6.385 +    apply (rule cinfinite_csum)
   6.386 +    apply (rule disjI1)
   6.387 +    by (rule natLeq_cinfinite)
   6.388 +next
   6.389 +  fix f :: "'d => 'a"
   6.390 +  have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
   6.391 +  also have "?U \<le>o natLeq +c ?U"  by (rule ordLeq_csum2) (rule card_of_Card_order)
   6.392 +  finally show "|range f| \<le>o natLeq +c ?U" .
   6.393 +next
   6.394 +  fix B :: "'a set"
   6.395 +  have "|{f::'d => 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" by (rule card_of_bounded_range)
   6.396 +  also have "|Func (UNIV :: 'd set) B| =o |B| ^c |UNIV :: 'd set|"
   6.397 +    unfolding cexp_def Field_card_of by (rule card_of_refl)
   6.398 +  also have "|B| ^c |UNIV :: 'd set| \<le>o
   6.399 +             ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )"
   6.400 +    apply (rule cexp_mono)
   6.401 +     apply (rule ordLeq_csum1) apply (rule card_of_Card_order)
   6.402 +     apply (rule ordLeq_csum2) apply (rule card_of_Card_order)
   6.403 +     apply (rule disjI2) apply (rule cone_ordLeq_cexp)
   6.404 +      apply (rule ordLeq_transitive) apply (rule cone_ordLeq_ctwo) apply (rule ordLeq_csum2)
   6.405 +      apply (rule Card_order_ctwo)
   6.406 +     apply (rule notE) apply (rule conjunct1) apply (rule Cnotzero_UNIV) apply blast
   6.407 +     apply (rule card_of_Card_order)
   6.408 +  done
   6.409 +  finally
   6.410 +  show "|{f::'d => 'a. range f \<subseteq> B}| \<le>o
   6.411 +        ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )" .
   6.412 +next
   6.413 +  fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
   6.414 +  show "wpull {h. range h \<subseteq> A} {g1. range g1 \<subseteq> B1} {g2. range g2 \<subseteq> B2}
   6.415 +    (op \<circ> f1) (op \<circ> f2) (op \<circ> p1) (op \<circ> p2)"
   6.416 +  unfolding wpull_def
   6.417 +  proof safe
   6.418 +    fix g1 g2 assume r: "range g1 \<subseteq> B1" "range g2 \<subseteq> B2"
   6.419 +    and c: "f1 \<circ> g1 = f2 \<circ> g2"
   6.420 +    show "\<exists>h \<in> {h. range h \<subseteq> A}. p1 \<circ> h = g1 \<and> p2 \<circ> h = g2"
   6.421 +    using wpull_cat[OF p c r] by simp metis
   6.422 +  qed
   6.423 +qed auto
   6.424 +
   6.425 +lemma fun_pred[simp]: "fun_pred \<phi> f g = (\<forall>x. \<phi> (f x) (g x))"
   6.426 +unfolding fun_rel_def fun_pred_def Gr_def relcomp_unfold converse_unfold
   6.427 +by (auto intro!: exI dest!: in_mono)
   6.428 +
   6.429 +lemma card_of_list_in:
   6.430 +  "|{xs. set xs \<subseteq> A}| \<le>o |Pfunc (UNIV :: nat set) A|" (is "|?LHS| \<le>o |?RHS|")
   6.431 +proof -
   6.432 +  let ?f = "%xs. %i. if i < length xs \<and> set xs \<subseteq> A then Some (nth xs i) else None"
   6.433 +  have "inj_on ?f ?LHS" unfolding inj_on_def fun_eq_iff
   6.434 +  proof safe
   6.435 +    fix xs :: "'a list" and ys :: "'a list"
   6.436 +    assume su: "set xs \<subseteq> A" "set ys \<subseteq> A" and eq: "\<forall>i. ?f xs i = ?f ys i"
   6.437 +    hence *: "length xs = length ys"
   6.438 +    by (metis linorder_cases option.simps(2) order_less_irrefl)
   6.439 +    thus "xs = ys" by (rule nth_equalityI) (metis * eq su option.inject)
   6.440 +  qed
   6.441 +  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Pfunc_def by fastforce
   6.442 +  ultimately show ?thesis using card_of_ordLeq by blast
   6.443 +qed
   6.444 +
   6.445 +lemma list_in_empty: "A = {} \<Longrightarrow> {x. set x \<subseteq> A} = {[]}"
   6.446 +by simp
   6.447 +
   6.448 +lemma card_of_Func: "|Func A B| =o |B| ^c |A|"
   6.449 +unfolding cexp_def Field_card_of by (rule card_of_refl)
   6.450 +
   6.451 +lemma not_emp_czero_notIn_ordIso_Card_order:
   6.452 +"A \<noteq> {} \<Longrightarrow> ( |A|, czero) \<notin> ordIso \<and> Card_order |A|"
   6.453 +  apply (rule conjI)
   6.454 +  apply (metis Field_card_of czeroE)
   6.455 +  by (rule card_of_Card_order)
   6.456 +
   6.457 +lemma list_in_bd: "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
   6.458 +proof -
   6.459 +  fix A :: "'a set"
   6.460 +  show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
   6.461 +  proof (cases "A = {}")
   6.462 +    case False thus ?thesis
   6.463 +      apply -
   6.464 +      apply (rule ordLeq_transitive)
   6.465 +      apply (rule card_of_list_in)
   6.466 +      apply (rule ordLeq_transitive)
   6.467 +      apply (erule card_of_Pfunc_Pow_Func)
   6.468 +      apply (rule ordIso_ordLeq_trans)
   6.469 +      apply (rule Times_cprod)
   6.470 +      apply (rule cprod_cinfinite_bound)
   6.471 +      apply (rule ordIso_ordLeq_trans)
   6.472 +      apply (rule Pow_cexp_ctwo)
   6.473 +      apply (rule ordIso_ordLeq_trans)
   6.474 +      apply (rule cexp_cong2)
   6.475 +      apply (rule card_of_nat)
   6.476 +      apply (rule Card_order_ctwo)
   6.477 +      apply (rule card_of_Card_order)
   6.478 +      apply (rule natLeq_Card_order)
   6.479 +      apply (rule disjI1)
   6.480 +      apply (rule ctwo_Cnotzero)
   6.481 +      apply (rule cexp_mono1)
   6.482 +      apply (rule ordLeq_csum2)
   6.483 +      apply (rule Card_order_ctwo)
   6.484 +      apply (rule disjI1)
   6.485 +      apply (rule ctwo_Cnotzero)
   6.486 +      apply (rule natLeq_Card_order)
   6.487 +      apply (rule ordIso_ordLeq_trans)
   6.488 +      apply (rule card_of_Func)
   6.489 +      apply (rule ordIso_ordLeq_trans)
   6.490 +      apply (rule cexp_cong2)
   6.491 +      apply (rule card_of_nat)
   6.492 +      apply (rule card_of_Card_order)
   6.493 +      apply (rule card_of_Card_order)
   6.494 +      apply (rule natLeq_Card_order)
   6.495 +      apply (rule disjI1)
   6.496 +      apply (erule not_emp_czero_notIn_ordIso_Card_order)
   6.497 +      apply (rule cexp_mono1)
   6.498 +      apply (rule ordLeq_csum1)
   6.499 +      apply (rule card_of_Card_order)
   6.500 +      apply (rule disjI1)
   6.501 +      apply (erule not_emp_czero_notIn_ordIso_Card_order)
   6.502 +      apply (rule natLeq_Card_order)
   6.503 +      apply (rule card_of_Card_order)
   6.504 +      apply (rule card_of_Card_order)
   6.505 +      apply (rule Cinfinite_cexp)
   6.506 +      apply (rule ordLeq_csum2)
   6.507 +      apply (rule Card_order_ctwo)
   6.508 +      apply (rule conjI)
   6.509 +      apply (rule natLeq_cinfinite)
   6.510 +      by (rule natLeq_Card_order)
   6.511 +  next
   6.512 +    case True thus ?thesis
   6.513 +      apply -
   6.514 +      apply (rule ordIso_ordLeq_trans)
   6.515 +      apply (rule card_of_ordIso_subst)
   6.516 +      apply (erule list_in_empty)
   6.517 +      apply (rule ordIso_ordLeq_trans)
   6.518 +      apply (rule single_cone)
   6.519 +      apply (rule cone_ordLeq_cexp)
   6.520 +      apply (rule ordLeq_transitive)
   6.521 +      apply (rule cone_ordLeq_ctwo)
   6.522 +      apply (rule ordLeq_csum2)
   6.523 +      by (rule Card_order_ctwo)
   6.524 +  qed
   6.525 +qed
   6.526 +
   6.527 +bnf_def list = map [set] "\<lambda>_::'a list. natLeq" ["[]"]
   6.528 +proof -
   6.529 +  show "map id = id" by (rule List.map.id)
   6.530 +next
   6.531 +  fix f g
   6.532 +  show "map (g o f) = map g o map f" by (rule List.map.comp[symmetric])
   6.533 +next
   6.534 +  fix x f g
   6.535 +  assume "\<And>z. z \<in> set x \<Longrightarrow> f z = g z"
   6.536 +  thus "map f x = map g x" by simp
   6.537 +next
   6.538 +  fix f
   6.539 +  show "set o map f = image f o set" by (rule ext, unfold o_apply, rule set_map)
   6.540 +next
   6.541 +  show "card_order natLeq" by (rule natLeq_card_order)
   6.542 +next
   6.543 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
   6.544 +next
   6.545 +  fix x
   6.546 +  show "|set x| \<le>o natLeq"
   6.547 +    apply (rule ordLess_imp_ordLeq)
   6.548 +    apply (rule finite_ordLess_infinite[OF _ natLeq_Well_order])
   6.549 +    unfolding Field_natLeq Field_card_of by (auto simp: card_of_well_order_on)
   6.550 +next
   6.551 +  fix A :: "'a set"
   6.552 +  show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
   6.553 +next
   6.554 +  fix A B1 B2 f1 f2 p1 p2
   6.555 +  assume "wpull A B1 B2 f1 f2 p1 p2"
   6.556 +  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"
   6.557 +    unfolding wpull_def by auto
   6.558 +  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)"
   6.559 +    (is "wpull ?A ?B1 ?B2 _ _ _ _")
   6.560 +  proof (unfold wpull_def)
   6.561 +    { fix as bs assume *: "as \<in> ?B1" "bs \<in> ?B2" "map f1 as = map f2 bs"
   6.562 +      hence "length as = length bs" by (metis length_map)
   6.563 +      hence "\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs" using *
   6.564 +      proof (induct as bs rule: list_induct2)
   6.565 +        case (Cons a as b bs)
   6.566 +        hence "a \<in> B1" "b \<in> B2" "f1 a = f2 b" by auto
   6.567 +        with pull obtain z where "z \<in> A" "p1 z = a" "p2 z = b" by blast
   6.568 +        moreover
   6.569 +        from Cons obtain zs where "zs \<in> ?A" "map p1 zs = as" "map p2 zs = bs" by auto
   6.570 +        ultimately have "z # zs \<in> ?A" "map p1 (z # zs) = a # as \<and> map p2 (z # zs) = b # bs" by auto
   6.571 +        thus ?case by (rule_tac x = "z # zs" in bexI)
   6.572 +      qed simp
   6.573 +    }
   6.574 +    thus "\<forall>as bs. as \<in> ?B1 \<and> bs \<in> ?B2 \<and> map f1 as = map f2 bs \<longrightarrow>
   6.575 +      (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
   6.576 +  qed
   6.577 +qed auto
   6.578 +
   6.579 +bnf_def deadlist = "map id" [] "\<lambda>_::'a list. |lists (UNIV :: 'a set)|" ["[]"]
   6.580 +by (auto simp add: cinfinite_def wpull_def infinite_UNIV_listI map.id
   6.581 +  ordLeq_transitive ctwo_def card_of_card_order_on Field_card_of card_of_mono1 ordLeq_cexp2)
   6.582 +
   6.583 +(* Finite sets *)
   6.584 +abbreviation afset where "afset \<equiv> abs_fset"
   6.585 +abbreviation rfset where "rfset \<equiv> rep_fset"
   6.586 +
   6.587 +lemma fset_fset_member:
   6.588 +"fset A = {a. a |\<in>| A}"
   6.589 +unfolding fset_def fset_member_def by auto
   6.590 +
   6.591 +lemma afset_rfset:
   6.592 +"afset (rfset x) = x"
   6.593 +by (rule Quotient_fset[unfolded Quotient_def, THEN conjunct1, rule_format])
   6.594 +
   6.595 +lemma afset_rfset_id:
   6.596 +"afset o rfset = id"
   6.597 +unfolding comp_def afset_rfset id_def ..
   6.598 +
   6.599 +lemma rfset:
   6.600 +"rfset A = rfset B \<longleftrightarrow> A = B"
   6.601 +by (metis afset_rfset)
   6.602 +
   6.603 +lemma afset_set:
   6.604 +"afset as = afset bs \<longleftrightarrow> set as = set bs"
   6.605 +using Quotient_fset unfolding Quotient_def list_eq_def by auto
   6.606 +
   6.607 +lemma surj_afset:
   6.608 +"\<exists> as. A = afset as"
   6.609 +by (metis afset_rfset)
   6.610 +
   6.611 +lemma fset_def2:
   6.612 +"fset = set o rfset"
   6.613 +unfolding fset_def map_fun_def[abs_def] by simp
   6.614 +
   6.615 +lemma fset_def2_raw:
   6.616 +"fset A = set (rfset A)"
   6.617 +unfolding fset_def2 by simp
   6.618 +
   6.619 +lemma fset_comp_afset:
   6.620 +"fset o afset = set"
   6.621 +unfolding fset_def2 comp_def apply(rule ext)
   6.622 +unfolding afset_set[symmetric] afset_rfset ..
   6.623 +
   6.624 +lemma fset_afset:
   6.625 +"fset (afset as) = set as"
   6.626 +unfolding fset_comp_afset[symmetric] by simp
   6.627 +
   6.628 +lemma set_rfset_afset:
   6.629 +"set (rfset (afset as)) = set as"
   6.630 +unfolding afset_set[symmetric] afset_rfset ..
   6.631 +
   6.632 +lemma map_fset_comp_afset:
   6.633 +"(map_fset f) o afset = afset o (map f)"
   6.634 +unfolding map_fset_def map_fun_def[abs_def] comp_def apply(rule ext)
   6.635 +unfolding afset_set set_map set_rfset_afset id_apply ..
   6.636 +
   6.637 +lemma map_fset_afset:
   6.638 +"(map_fset f) (afset as) = afset (map f as)"
   6.639 +using map_fset_comp_afset unfolding comp_def fun_eq_iff by auto
   6.640 +
   6.641 +lemma fset_map_fset:
   6.642 +"fset (map_fset f A) = (image f) (fset A)"
   6.643 +apply(subst afset_rfset[symmetric, of A])
   6.644 +unfolding map_fset_afset fset_afset set_map
   6.645 +unfolding fset_def2_raw ..
   6.646 +
   6.647 +lemma map_fset_def2:
   6.648 +"map_fset f = afset o (map f) o rfset"
   6.649 +unfolding map_fset_def map_fun_def[abs_def] by simp
   6.650 +
   6.651 +lemma map_fset_def2_raw:
   6.652 +"map_fset f A = afset (map f (rfset A))"
   6.653 +unfolding map_fset_def2 by simp
   6.654 +
   6.655 +lemma finite_ex_fset:
   6.656 +assumes "finite A"
   6.657 +shows "\<exists> B. fset B = A"
   6.658 +by (metis assms finite_list fset_afset)
   6.659 +
   6.660 +lemma wpull_image:
   6.661 +assumes "wpull A B1 B2 f1 f2 p1 p2"
   6.662 +shows "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
   6.663 +unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
   6.664 +  fix Y1 Y2 assume Y1: "Y1 \<subseteq> B1" and Y2: "Y2 \<subseteq> B2" and EQ: "f1 ` Y1 = f2 ` Y2"
   6.665 +  def X \<equiv> "{a \<in> A. p1 a \<in> Y1 \<and> p2 a \<in> Y2}"
   6.666 +  show "\<exists>X\<subseteq>A. p1 ` X = Y1 \<and> p2 ` X = Y2"
   6.667 +  proof (rule exI[of _ X], intro conjI)
   6.668 +    show "p1 ` X = Y1"
   6.669 +    proof
   6.670 +      show "Y1 \<subseteq> p1 ` X"
   6.671 +      proof safe
   6.672 +        fix y1 assume y1: "y1 \<in> Y1"
   6.673 +        then obtain y2 where y2: "y2 \<in> Y2" and eq: "f1 y1 = f2 y2" using EQ by auto
   6.674 +        then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
   6.675 +        using assms y1 Y1 Y2 unfolding wpull_def by blast
   6.676 +        thus "y1 \<in> p1 ` X" unfolding X_def using y1 y2 by auto
   6.677 +      qed
   6.678 +    qed(unfold X_def, auto)
   6.679 +    show "p2 ` X = Y2"
   6.680 +    proof
   6.681 +      show "Y2 \<subseteq> p2 ` X"
   6.682 +      proof safe
   6.683 +        fix y2 assume y2: "y2 \<in> Y2"
   6.684 +        then obtain y1 where y1: "y1 \<in> Y1" and eq: "f1 y1 = f2 y2" using EQ by force
   6.685 +        then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
   6.686 +        using assms y2 Y1 Y2 unfolding wpull_def by blast
   6.687 +        thus "y2 \<in> p2 ` X" unfolding X_def using y1 y2 by auto
   6.688 +      qed
   6.689 +    qed(unfold X_def, auto)
   6.690 +  qed(unfold X_def, auto)
   6.691 +qed
   6.692 +
   6.693 +lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
   6.694 +by (rule f_the_inv_into_f) (auto simp: inj_on_def fset_cong dest!: finite_ex_fset)
   6.695 +
   6.696 +bnf_def fset = map_fset [fset] "\<lambda>_::'a fset. natLeq" ["{||}"]
   6.697 +proof -
   6.698 +  show "map_fset id = id"
   6.699 +  unfolding map_fset_def2 map_id o_id afset_rfset_id ..
   6.700 +next
   6.701 +  fix f g
   6.702 +  show "map_fset (g o f) = map_fset g o map_fset f"
   6.703 +  unfolding map_fset_def2 map.comp[symmetric] comp_def apply(rule ext)
   6.704 +  unfolding afset_set set_map fset_def2_raw[symmetric] image_image[symmetric]
   6.705 +  unfolding map_fset_afset[symmetric] map_fset_image afset_rfset
   6.706 +  by (rule refl)
   6.707 +next
   6.708 +  fix x f g
   6.709 +  assume "\<And>z. z \<in> fset x \<Longrightarrow> f z = g z"
   6.710 +  hence "map f (rfset x) = map g (rfset x)"
   6.711 +  apply(intro map_cong) unfolding fset_def2_raw by auto
   6.712 +  thus "map_fset f x = map_fset g x" unfolding map_fset_def2_raw
   6.713 +  by (rule arg_cong)
   6.714 +next
   6.715 +  fix f
   6.716 +  show "fset o map_fset f = image f o fset"
   6.717 +  unfolding comp_def fset_map_fset ..
   6.718 +next
   6.719 +  show "card_order natLeq" by (rule natLeq_card_order)
   6.720 +next
   6.721 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
   6.722 +next
   6.723 +  fix x
   6.724 +  show "|fset x| \<le>o natLeq"
   6.725 +  unfolding fset_def2_raw
   6.726 +  apply (rule ordLess_imp_ordLeq)
   6.727 +  apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
   6.728 +  by (rule finite_set)
   6.729 +next
   6.730 +  fix A :: "'a set"
   6.731 +  have "|{x. fset x \<subseteq> A}| \<le>o |afset ` {as. set as \<subseteq> A}|"
   6.732 +  apply(rule card_of_mono1) unfolding fset_def2_raw apply auto
   6.733 +  apply (rule image_eqI)
   6.734 +  by (auto simp: afset_rfset)
   6.735 +  also have "|afset ` {as. set as \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_image .
   6.736 +  also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
   6.737 +  finally show "|{x. fset x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
   6.738 +next
   6.739 +  fix A B1 B2 f1 f2 p1 p2
   6.740 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
   6.741 +  hence "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
   6.742 +  by(rule wpull_image)
   6.743 +  show "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
   6.744 +              (map_fset f1) (map_fset f2) (map_fset p1) (map_fset p2)"
   6.745 +  unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
   6.746 +    fix y1 y2
   6.747 +    assume Y1: "fset y1 \<subseteq> B1" and Y2: "fset y2 \<subseteq> B2"
   6.748 +    assume "map_fset f1 y1 = map_fset f2 y2"
   6.749 +    hence EQ: "f1 ` (fset y1) = f2 ` (fset y2)" unfolding map_fset_def2_raw
   6.750 +    unfolding afset_set set_map fset_def2_raw .
   6.751 +    with Y1 Y2 obtain X where X: "X \<subseteq> A"
   6.752 +    and Y1: "p1 ` X = fset y1" and Y2: "p2 ` X = fset y2"
   6.753 +    using wpull_image[OF wp] unfolding wpull_def Pow_def
   6.754 +    unfolding Bex_def mem_Collect_eq apply -
   6.755 +    apply(erule allE[of _ "fset y1"], erule allE[of _ "fset y2"]) by auto
   6.756 +    have "\<forall> y1' \<in> fset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
   6.757 +    then obtain q1 where q1: "\<forall> y1' \<in> fset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
   6.758 +    have "\<forall> y2' \<in> fset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
   6.759 +    then obtain q2 where q2: "\<forall> y2' \<in> fset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
   6.760 +    def X' \<equiv> "q1 ` (fset y1) \<union> q2 ` (fset y2)"
   6.761 +    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = fset y1" and Y2: "p2 ` X' = fset y2"
   6.762 +    using X Y1 Y2 q1 q2 unfolding X'_def by auto
   6.763 +    have fX': "finite X'" unfolding X'_def by simp
   6.764 +    then obtain x where X'eq: "X' = fset x" by (auto dest: finite_ex_fset)
   6.765 +    show "\<exists>x. fset x \<subseteq> A \<and> map_fset p1 x = y1 \<and> map_fset p2 x = y2"
   6.766 +    apply(intro exI[of _ "x"]) using X' Y1 Y2
   6.767 +    unfolding X'eq map_fset_def2_raw fset_def2_raw set_map[symmetric]
   6.768 +    afset_set[symmetric] afset_rfset by simp
   6.769 +  qed
   6.770 +qed auto
   6.771 +
   6.772 +lemma fset_pred[simp]: "fset_pred R a b \<longleftrightarrow>
   6.773 +  ((\<forall>t \<in> fset a. (\<exists>u \<in> fset b. R t u)) \<and>
   6.774 +   (\<forall>t \<in> fset b. (\<exists>u \<in> fset a. R u t)))" (is "?L = ?R")
   6.775 +proof
   6.776 +  assume ?L thus ?R unfolding fset_rel_def fset_pred_def
   6.777 +    Gr_def relcomp_unfold converse_unfold
   6.778 +  apply (simp add: subset_eq Ball_def)
   6.779 +  apply (rule conjI)
   6.780 +  apply (clarsimp, metis snd_conv)
   6.781 +  by (clarsimp, metis fst_conv)
   6.782 +next
   6.783 +  assume ?R
   6.784 +  def R' \<equiv> "the_inv fset (Collect (split R) \<inter> (fset a \<times> fset b))" (is "the_inv fset ?R'")
   6.785 +  have "finite ?R'" by (intro finite_Int[OF disjI2] finite_cartesian_product) auto
   6.786 +  hence *: "fset R' = ?R'" unfolding R'_def by (intro fset_to_fset)
   6.787 +  show ?L unfolding fset_rel_def fset_pred_def Gr_def relcomp_unfold converse_unfold
   6.788 +  proof (intro CollectI prod_caseI exI conjI)
   6.789 +    from * show "(R', a) = (R', map_fset fst R')" using conjunct1[OF `?R`]
   6.790 +      by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
   6.791 +    from * show "(R', b) = (R', map_fset snd R')" using conjunct2[OF `?R`]
   6.792 +      by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
   6.793 +  qed (auto simp add: *)
   6.794 +qed
   6.795 +
   6.796 +(* Countable sets *)
   6.797 +
   6.798 +lemma card_of_countable_sets_range:
   6.799 +fixes A :: "'a set"
   6.800 +shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
   6.801 +apply(rule card_of_ordLeqI[of fromNat]) using inj_on_fromNat
   6.802 +unfolding inj_on_def by auto
   6.803 +
   6.804 +lemma card_of_countable_sets_Func:
   6.805 +"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
   6.806 +using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
   6.807 +unfolding cexp_def Field_natLeq Field_card_of
   6.808 +by(rule ordLeq_ordIso_trans)
   6.809 +
   6.810 +lemma ordLeq_countable_subsets:
   6.811 +"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
   6.812 +apply(rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
   6.813 +
   6.814 +lemma finite_countable_subset:
   6.815 +"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
   6.816 +apply default
   6.817 + apply (erule contrapos_pp)
   6.818 + apply (rule card_of_ordLeq_infinite)
   6.819 + apply (rule ordLeq_countable_subsets)
   6.820 + apply assumption
   6.821 +apply (rule finite_Collect_conjI)
   6.822 +apply (rule disjI1)
   6.823 +by (erule finite_Collect_subsets)
   6.824 +
   6.825 +lemma card_of_countable_sets:
   6.826 +"|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
   6.827 +(is "|?L| \<le>o _")
   6.828 +proof(cases "finite A")
   6.829 +  let ?R = "Func (UNIV::nat set) (A <+> (UNIV::bool set))"
   6.830 +  case True hence "finite ?L" by simp
   6.831 +  moreover have "infinite ?R"
   6.832 +  apply(rule infinite_Func[of _ "Inr True" "Inr False"]) by auto
   6.833 +  ultimately show ?thesis unfolding cexp_def csum_def ctwo_def Field_natLeq Field_card_of
   6.834 +  apply(intro ordLess_imp_ordLeq) by (rule finite_ordLess_infinite2)
   6.835 +next
   6.836 +  case False
   6.837 +  hence "|{X. X \<subseteq> A \<and> countable X}| =o |{X. X \<subseteq> A \<and> countable X} - {{}}|"
   6.838 +  by (intro card_of_infinite_diff_finitte finite.emptyI finite.insertI ordIso_symmetric)
   6.839 +     (unfold finite_countable_subset)
   6.840 +  also have "|{X. X \<subseteq> A \<and> countable X} - {{}}| \<le>o |A| ^c natLeq"
   6.841 +  using card_of_countable_sets_Func[of A] unfolding set_diff_eq by auto
   6.842 +  also have "|A| ^c natLeq \<le>o ( |A| +c ctwo) ^c natLeq"
   6.843 +  apply(rule cexp_mono1_cone_ordLeq)
   6.844 +    apply(rule ordLeq_csum1, rule card_of_Card_order)
   6.845 +    apply (rule cone_ordLeq_cexp)
   6.846 +    apply (rule cone_ordLeq_Cnotzero)
   6.847 +    using csum_Cnotzero2 ctwo_Cnotzero apply blast
   6.848 +    by (rule natLeq_Card_order)
   6.849 +  finally show ?thesis .
   6.850 +qed
   6.851 +
   6.852 +bnf_def cset = cIm [rcset] "\<lambda>_::'a cset. natLeq" ["cEmp"]
   6.853 +proof -
   6.854 +  show "cIm id = id" unfolding cIm_def[abs_def] id_def by auto
   6.855 +next
   6.856 +  fix f g show "cIm (g \<circ> f) = cIm g \<circ> cIm f"
   6.857 +  unfolding cIm_def[abs_def] apply(rule ext) unfolding comp_def by auto
   6.858 +next
   6.859 +  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
   6.860 +  thus "cIm f C = cIm g C"
   6.861 +  unfolding cIm_def[abs_def] unfolding image_def by auto
   6.862 +next
   6.863 +  fix f show "rcset \<circ> cIm f = op ` f \<circ> rcset" unfolding cIm_def[abs_def] by auto
   6.864 +next
   6.865 +  show "card_order natLeq" by (rule natLeq_card_order)
   6.866 +next
   6.867 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
   6.868 +next
   6.869 +  fix C show "|rcset C| \<le>o natLeq" using rcset unfolding countable_def .
   6.870 +next
   6.871 +  fix A :: "'a set"
   6.872 +  have "|{Z. rcset Z \<subseteq> A}| \<le>o |acset ` {X. X \<subseteq> A \<and> countable X}|"
   6.873 +  apply(rule card_of_mono1) unfolding Pow_def image_def
   6.874 +  proof (rule Collect_mono, clarsimp)
   6.875 +    fix x
   6.876 +    assume "rcset x \<subseteq> A"
   6.877 +    hence "rcset x \<subseteq> A \<and> countable (rcset x) \<and> x = acset (rcset x)"
   6.878 +    using acset_rcset[of x] rcset[of x] by force
   6.879 +    thus "\<exists>y \<subseteq> A. countable y \<and> x = acset y" by blast
   6.880 +  qed
   6.881 +  also have "|acset ` {X. X \<subseteq> A \<and> countable X}| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
   6.882 +  using card_of_image .
   6.883 +  also have "|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
   6.884 +  using card_of_countable_sets .
   6.885 +  finally show "|{Z. rcset Z \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
   6.886 +next
   6.887 +  fix A B1 B2 f1 f2 p1 p2
   6.888 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
   6.889 +  show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
   6.890 +              (cIm f1) (cIm f2) (cIm p1) (cIm p2)"
   6.891 +  unfolding wpull_def proof safe
   6.892 +    fix y1 y2
   6.893 +    assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
   6.894 +    assume "cIm f1 y1 = cIm f2 y2"
   6.895 +    hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)"
   6.896 +    unfolding cIm_def by auto
   6.897 +    with Y1 Y2 obtain X where X: "X \<subseteq> A"
   6.898 +    and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
   6.899 +    using wpull_image[OF wp] unfolding wpull_def Pow_def
   6.900 +    unfolding Bex_def mem_Collect_eq apply -
   6.901 +    apply(erule allE[of _ "rcset y1"], erule allE[of _ "rcset y2"]) by auto
   6.902 +    have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
   6.903 +    then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
   6.904 +    have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
   6.905 +    then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
   6.906 +    def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
   6.907 +    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
   6.908 +    using X Y1 Y2 q1 q2 unfolding X'_def by fast+
   6.909 +    have fX': "countable X'" unfolding X'_def by simp
   6.910 +    then obtain x where X'eq: "X' = rcset x" by (metis rcset_acset)
   6.911 +    show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cIm p1 x = y1 \<and> cIm p2 x = y2"
   6.912 +    apply(intro bexI[of _ "x"]) using X' Y1 Y2 unfolding X'eq cIm_def by auto
   6.913 +  qed
   6.914 +qed (unfold cEmp_def, auto)
   6.915 +
   6.916 +
   6.917 +(* Multisets *)
   6.918 +
   6.919 +lemma setsum_gt_0_iff:
   6.920 +fixes f :: "'a \<Rightarrow> nat" assumes "finite A"
   6.921 +shows "setsum f A > 0 \<longleftrightarrow> (\<exists> a \<in> A. f a > 0)"
   6.922 +(is "?L \<longleftrightarrow> ?R")
   6.923 +proof-
   6.924 +  have "?L \<longleftrightarrow> \<not> setsum f A = 0" by fast
   6.925 +  also have "... \<longleftrightarrow> (\<exists> a \<in> A. f a \<noteq> 0)" using assms by simp
   6.926 +  also have "... \<longleftrightarrow> ?R" by simp
   6.927 +  finally show ?thesis .
   6.928 +qed
   6.929 +
   6.930 +(*   *)
   6.931 +definition mmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> nat" where
   6.932 +"mmap h f b = setsum f {a. h a = b \<and> f a > 0}"
   6.933 +
   6.934 +lemma mmap_id: "mmap id = id"
   6.935 +proof (rule ext)+
   6.936 +  fix f a show "mmap id f a = id f a"
   6.937 +  proof(cases "f a = 0")
   6.938 +    case False
   6.939 +    hence 1: "{aa. aa = a \<and> 0 < f aa} = {a}" by auto
   6.940 +    show ?thesis by (simp add: mmap_def id_apply 1)
   6.941 +  qed(unfold mmap_def, auto)
   6.942 +qed
   6.943 +
   6.944 +lemma inj_on_setsum_inv:
   6.945 +assumes f: "f \<in> multiset"
   6.946 +and 1: "(0::nat) < setsum f {a. h a = b' \<and> 0 < f a}" (is "0 < setsum f ?A'")
   6.947 +and 2: "{a. h a = b \<and> 0 < f a} = {a. h a = b' \<and> 0 < f a}" (is "?A = ?A'")
   6.948 +shows "b = b'"
   6.949 +proof-
   6.950 +  have "finite ?A'" using f unfolding multiset_def by auto
   6.951 +  hence "?A' \<noteq> {}" using 1 setsum_gt_0_iff by auto
   6.952 +  thus ?thesis using 2 by auto
   6.953 +qed
   6.954 +
   6.955 +lemma mmap_comp:
   6.956 +fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
   6.957 +assumes f: "f \<in> multiset"
   6.958 +shows "mmap (h2 o h1) f = (mmap h2 o mmap h1) f"
   6.959 +unfolding mmap_def[abs_def] comp_def proof(rule ext)+
   6.960 +  fix c :: 'c
   6.961 +  let ?A = "{a. h2 (h1 a) = c \<and> 0 < f a}"
   6.962 +  let ?As = "\<lambda> b. {a. h1 a = b \<and> 0 < f a}"
   6.963 +  let ?B = "{b. h2 b = c \<and> 0 < setsum f (?As b)}"
   6.964 +  have 0: "{?As b | b.  b \<in> ?B} = ?As ` ?B" by auto
   6.965 +  have "\<And> b. finite (?As b)" using f unfolding multiset_def by simp
   6.966 +  hence "?B = {b. h2 b = c \<and> ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
   6.967 +  hence A: "?A = \<Union> {?As b | b.  b \<in> ?B}" by auto
   6.968 +  have "setsum f ?A = setsum (setsum f) {?As b | b.  b \<in> ?B}"
   6.969 +  unfolding A apply(rule setsum_Union_disjoint)
   6.970 +  using f unfolding multiset_def by auto
   6.971 +  also have "... = setsum (setsum f) (?As ` ?B)" unfolding 0 ..
   6.972 +  also have "... = setsum (setsum f o ?As) ?B" apply(rule setsum_reindex)
   6.973 +  unfolding inj_on_def apply auto using inj_on_setsum_inv[OF f, of h1] by blast
   6.974 +  also have "... = setsum (\<lambda> b. setsum f (?As b)) ?B" unfolding comp_def ..
   6.975 +  finally show "setsum f ?A = setsum (\<lambda> b. setsum f (?As b)) ?B" .
   6.976 +qed
   6.977 +
   6.978 +lemma mmap_comp1:
   6.979 +fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
   6.980 +assumes "f \<in> multiset"
   6.981 +shows "mmap (\<lambda> a. h2 (h1 a)) f = mmap h2 (mmap h1 f)"
   6.982 +using mmap_comp[OF assms] unfolding comp_def by auto
   6.983 +
   6.984 +lemma mmap:
   6.985 +assumes "f \<in> multiset"
   6.986 +shows "mmap h f \<in> multiset"
   6.987 +using assms unfolding mmap_def[abs_def] multiset_def proof safe
   6.988 +  assume fin: "finite {a. 0 < f a}"  (is "finite ?A")
   6.989 +  show "finite {b. 0 < setsum f {a. h a = b \<and> 0 < f a}}"
   6.990 +  (is "finite {b. 0 < setsum f (?As b)}")
   6.991 +  proof- let ?B = "{b. 0 < setsum f (?As b)}"
   6.992 +    have "\<And> b. finite (?As b)" using assms unfolding multiset_def by simp
   6.993 +    hence B: "?B = {b. ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
   6.994 +    hence "?B \<subseteq> h ` ?A" by auto
   6.995 +    thus ?thesis using finite_surj[OF fin] by auto
   6.996 +  qed
   6.997 +qed
   6.998 +
   6.999 +lemma mmap_cong:
  6.1000 +assumes "\<And>a. a \<in># M \<Longrightarrow> f a = g a"
  6.1001 +shows "mmap f (count M) = mmap g (count M)"
  6.1002 +using assms unfolding mmap_def[abs_def] by (intro ext, intro setsum_cong) auto
  6.1003 +
  6.1004 +abbreviation supp where "supp f \<equiv> {a. f a > 0}"
  6.1005 +
  6.1006 +lemma mmap_image_comp:
  6.1007 +assumes f: "f \<in> multiset"
  6.1008 +shows "(supp o mmap h) f = (image h o supp) f"
  6.1009 +unfolding mmap_def[abs_def] comp_def proof-
  6.1010 +  have "\<And> b. finite {a. h a = b \<and> 0 < f a}" (is "\<And> b. finite (?As b)")
  6.1011 +  using f unfolding multiset_def by auto
  6.1012 +  thus "{b. 0 < setsum f (?As b)} = h ` {a. 0 < f a}"
  6.1013 +  using setsum_gt_0_iff by auto
  6.1014 +qed
  6.1015 +
  6.1016 +lemma mmap_image:
  6.1017 +assumes f: "f \<in> multiset"
  6.1018 +shows "supp (mmap h f) = h ` (supp f)"
  6.1019 +using mmap_image_comp[OF assms] unfolding comp_def .
  6.1020 +
  6.1021 +lemma set_of_Abs_multiset:
  6.1022 +assumes f: "f \<in> multiset"
  6.1023 +shows "set_of (Abs_multiset f) = supp f"
  6.1024 +using assms unfolding set_of_def by (auto simp: Abs_multiset_inverse)
  6.1025 +
  6.1026 +lemma supp_count:
  6.1027 +"supp (count M) = set_of M"
  6.1028 +using assms unfolding set_of_def by auto
  6.1029 +
  6.1030 +lemma multiset_of_surj:
  6.1031 +"multiset_of ` {as. set as \<subseteq> A} = {M. set_of M \<subseteq> A}"
  6.1032 +proof safe
  6.1033 +  fix M assume M: "set_of M \<subseteq> A"
  6.1034 +  obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto
  6.1035 +  hence "set as \<subseteq> A" using M by auto
  6.1036 +  thus "M \<in> multiset_of ` {as. set as \<subseteq> A}" using eq by auto
  6.1037 +next
  6.1038 +  show "\<And>x xa xb. \<lbrakk>set xa \<subseteq> A; xb \<in> set_of (multiset_of xa)\<rbrakk> \<Longrightarrow> xb \<in> A"
  6.1039 +  by (erule set_mp) (unfold set_of_multiset_of)
  6.1040 +qed
  6.1041 +
  6.1042 +lemma card_of_set_of:
  6.1043 +"|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|"
  6.1044 +apply(rule card_of_ordLeqI2[of _ multiset_of]) using multiset_of_surj by auto
  6.1045 +
  6.1046 +lemma nat_sum_induct:
  6.1047 +assumes "\<And>n1 n2. (\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow> phi m1 m2) \<Longrightarrow> phi n1 n2"
  6.1048 +shows "phi (n1::nat) (n2::nat)"
  6.1049 +proof-
  6.1050 +  let ?chi = "\<lambda> n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)"
  6.1051 +  have "?chi (n1,n2)"
  6.1052 +  apply(induct rule: measure_induct[of "\<lambda> n1n2. fst n1n2 + snd n1n2" ?chi])
  6.1053 +  using assms by (metis fstI sndI)
  6.1054 +  thus ?thesis by simp
  6.1055 +qed
  6.1056 +
  6.1057 +lemma matrix_count:
  6.1058 +fixes ct1 ct2 :: "nat \<Rightarrow> nat"
  6.1059 +assumes "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
  6.1060 +shows
  6.1061 +"\<exists> ct. (\<forall> i1 \<le> n1. setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ct1 i1) \<and>
  6.1062 +       (\<forall> i2 \<le> n2. setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ct2 i2)"
  6.1063 +(is "?phi ct1 ct2 n1 n2")
  6.1064 +proof-
  6.1065 +  have "\<forall> ct1 ct2 :: nat \<Rightarrow> nat.
  6.1066 +        setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"
  6.1067 +  proof(induct rule: nat_sum_induct[of
  6.1068 +"\<lambda> n1 n2. \<forall> ct1 ct2 :: nat \<Rightarrow> nat.
  6.1069 +     setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"],
  6.1070 +      clarify)
  6.1071 +  fix n1 n2 :: nat and ct1 ct2 :: "nat \<Rightarrow> nat"
  6.1072 +  assume IH: "\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow>
  6.1073 +                \<forall> dt1 dt2 :: nat \<Rightarrow> nat.
  6.1074 +                setsum dt1 {..<Suc m1} = setsum dt2 {..<Suc m2} \<longrightarrow> ?phi dt1 dt2 m1 m2"
  6.1075 +  and ss: "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
  6.1076 +  show "?phi ct1 ct2 n1 n2"
  6.1077 +  proof(cases n1)
  6.1078 +    case 0 note n1 = 0
  6.1079 +    show ?thesis
  6.1080 +    proof(cases n2)
  6.1081 +      case 0 note n2 = 0
  6.1082 +      let ?ct = "\<lambda> i1 i2. ct2 0"
  6.1083 +      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by simp
  6.1084 +    next
  6.1085 +      case (Suc m2) note n2 = Suc
  6.1086 +      let ?ct = "\<lambda> i1 i2. ct2 i2"
  6.1087 +      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
  6.1088 +    qed
  6.1089 +  next
  6.1090 +    case (Suc m1) note n1 = Suc
  6.1091 +    show ?thesis
  6.1092 +    proof(cases n2)
  6.1093 +      case 0 note n2 = 0
  6.1094 +      let ?ct = "\<lambda> i1 i2. ct1 i1"
  6.1095 +      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
  6.1096 +    next
  6.1097 +      case (Suc m2) note n2 = Suc
  6.1098 +      show ?thesis
  6.1099 +      proof(cases "ct1 n1 \<le> ct2 n2")
  6.1100 +        case True
  6.1101 +        def dt2 \<equiv> "\<lambda> i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2"
  6.1102 +        have "setsum ct1 {..<Suc m1} = setsum dt2 {..<Suc n2}"
  6.1103 +        unfolding dt2_def using ss n1 True by auto
  6.1104 +        hence "?phi ct1 dt2 m1 n2" using IH[of m1 n2] n1 by simp
  6.1105 +        then obtain dt where
  6.1106 +        1: "\<And> i1. i1 \<le> m1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc n2} = ct1 i1" and
  6.1107 +        2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc m1} = dt2 i2" by auto
  6.1108 +        let ?ct = "\<lambda> i1 i2. if i1 = n1 then (if i2 = n2 then ct1 n1 else 0)
  6.1109 +                                       else dt i1 i2"
  6.1110 +        show ?thesis apply(rule exI[of _ ?ct])
  6.1111 +        using n1 n2 1 2 True unfolding dt2_def by simp
  6.1112 +      next
  6.1113 +        case False
  6.1114 +        hence False: "ct2 n2 < ct1 n1" by simp
  6.1115 +        def dt1 \<equiv> "\<lambda> i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1"
  6.1116 +        have "setsum dt1 {..<Suc n1} = setsum ct2 {..<Suc m2}"
  6.1117 +        unfolding dt1_def using ss n2 False by auto
  6.1118 +        hence "?phi dt1 ct2 n1 m2" using IH[of n1 m2] n2 by simp
  6.1119 +        then obtain dt where
  6.1120 +        1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc m2} = dt1 i1" and
  6.1121 +        2: "\<And> i2. i2 \<le> m2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc n1} = ct2 i2" by force
  6.1122 +        let ?ct = "\<lambda> i1 i2. if i2 = n2 then (if i1 = n1 then ct2 n2 else 0)
  6.1123 +                                       else dt i1 i2"
  6.1124 +        show ?thesis apply(rule exI[of _ ?ct])
  6.1125 +        using n1 n2 1 2 False unfolding dt1_def by simp
  6.1126 +      qed
  6.1127 +    qed
  6.1128 +  qed
  6.1129 +  qed
  6.1130 +  thus ?thesis using assms by auto
  6.1131 +qed
  6.1132 +
  6.1133 +definition
  6.1134 +"inj2 u B1 B2 \<equiv>
  6.1135 + \<forall> b1 b1' b2 b2'. {b1,b1'} \<subseteq> B1 \<and> {b2,b2'} \<subseteq> B2 \<and> u b1 b2 = u b1' b2'
  6.1136 +                  \<longrightarrow> b1 = b1' \<and> b2 = b2'"
  6.1137 +
  6.1138 +lemma matrix_count_finite:
  6.1139 +assumes B1: "B1 \<noteq> {}" "finite B1" and B2: "B2 \<noteq> {}" "finite B2" and u: "inj2 u B1 B2"
  6.1140 +and ss: "setsum N1 B1 = setsum N2 B2"
  6.1141 +shows "\<exists> M :: 'a \<Rightarrow> nat.
  6.1142 +            (\<forall> b1 \<in> B1. setsum (\<lambda> b2. M (u b1 b2)) B2 = N1 b1) \<and>
  6.1143 +            (\<forall> b2 \<in> B2. setsum (\<lambda> b1. M (u b1 b2)) B1 = N2 b2)"
  6.1144 +proof-
  6.1145 +  obtain n1 where "card B1 = Suc n1" using B1 by (metis card_insert finite.simps)
  6.1146 +  then obtain e1 where e1: "bij_betw e1 {..<Suc n1} B1"
  6.1147 +  using ex_bij_betw_finite_nat[OF B1(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
  6.1148 +  hence e1_inj: "inj_on e1 {..<Suc n1}" and e1_surj: "e1 ` {..<Suc n1} = B1"
  6.1149 +  unfolding bij_betw_def by auto
  6.1150 +  def f1 \<equiv> "inv_into {..<Suc n1} e1"
  6.1151 +  have f1: "bij_betw f1 B1 {..<Suc n1}"
  6.1152 +  and f1e1[simp]: "\<And> i1. i1 < Suc n1 \<Longrightarrow> f1 (e1 i1) = i1"
  6.1153 +  and e1f1[simp]: "\<And> b1. b1 \<in> B1 \<Longrightarrow> e1 (f1 b1) = b1" unfolding f1_def
  6.1154 +  apply (metis bij_betw_inv_into e1, metis bij_betw_inv_into_left e1 lessThan_iff)
  6.1155 +  by (metis e1_surj f_inv_into_f)
  6.1156 +  (*  *)
  6.1157 +  obtain n2 where "card B2 = Suc n2" using B2 by (metis card_insert finite.simps)
  6.1158 +  then obtain e2 where e2: "bij_betw e2 {..<Suc n2} B2"
  6.1159 +  using ex_bij_betw_finite_nat[OF B2(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
  6.1160 +  hence e2_inj: "inj_on e2 {..<Suc n2}" and e2_surj: "e2 ` {..<Suc n2} = B2"
  6.1161 +  unfolding bij_betw_def by auto
  6.1162 +  def f2 \<equiv> "inv_into {..<Suc n2} e2"
  6.1163 +  have f2: "bij_betw f2 B2 {..<Suc n2}"
  6.1164 +  and f2e2[simp]: "\<And> i2. i2 < Suc n2 \<Longrightarrow> f2 (e2 i2) = i2"
  6.1165 +  and e2f2[simp]: "\<And> b2. b2 \<in> B2 \<Longrightarrow> e2 (f2 b2) = b2" unfolding f2_def
  6.1166 +  apply (metis bij_betw_inv_into e2, metis bij_betw_inv_into_left e2 lessThan_iff)
  6.1167 +  by (metis e2_surj f_inv_into_f)
  6.1168 +  (*  *)
  6.1169 +  let ?ct1 = "N1 o e1"  let ?ct2 = "N2 o e2"
  6.1170 +  have ss: "setsum ?ct1 {..<Suc n1} = setsum ?ct2 {..<Suc n2}"
  6.1171 +  unfolding setsum_reindex[OF e1_inj, symmetric] setsum_reindex[OF e2_inj, symmetric]
  6.1172 +  e1_surj e2_surj using ss .
  6.1173 +  obtain ct where
  6.1174 +  ct1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ?ct1 i1" and
  6.1175 +  ct2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ?ct2 i2"
  6.1176 +  using matrix_count[OF ss] by blast
  6.1177 +  (*  *)
  6.1178 +  def A \<equiv> "{u b1 b2 | b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"
  6.1179 +  have "\<forall> a \<in> A. \<exists> b1b2 \<in> B1 <*> B2. u (fst b1b2) (snd b1b2) = a"
  6.1180 +  unfolding A_def Ball_def mem_Collect_eq by auto
  6.1181 +  then obtain h1h2 where h12:
  6.1182 +  "\<And>a. a \<in> A \<Longrightarrow> u (fst (h1h2 a)) (snd (h1h2 a)) = a \<and> h1h2 a \<in> B1 <*> B2" by metis
  6.1183 +  def h1 \<equiv> "fst o h1h2"  def h2 \<equiv> "snd o h1h2"
  6.1184 +  have h12[simp]: "\<And>a. a \<in> A \<Longrightarrow> u (h1 a) (h2 a) = a"
  6.1185 +                  "\<And> a. a \<in> A \<Longrightarrow> h1 a \<in> B1"  "\<And> a. a \<in> A \<Longrightarrow> h2 a \<in> B2"
  6.1186 +  using h12 unfolding h1_def h2_def by force+
  6.1187 +  {fix b1 b2 assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2"
  6.1188 +   hence inA: "u b1 b2 \<in> A" unfolding A_def by auto
  6.1189 +   hence "u b1 b2 = u (h1 (u b1 b2)) (h2 (u b1 b2))" by auto
  6.1190 +   moreover have "h1 (u b1 b2) \<in> B1" "h2 (u b1 b2) \<in> B2" using inA by auto
  6.1191 +   ultimately have "h1 (u b1 b2) = b1 \<and> h2 (u b1 b2) = b2"
  6.1192 +   using u b1 b2 unfolding inj2_def by fastforce
  6.1193 +  }
  6.1194 +  hence h1[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h1 (u b1 b2) = b1" and
  6.1195 +        h2[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h2 (u b1 b2) = b2" by auto
  6.1196 +  def M \<equiv> "\<lambda> a. ct (f1 (h1 a)) (f2 (h2 a))"
  6.1197 +  show ?thesis
  6.1198 +  apply(rule exI[of _ M]) proof safe
  6.1199 +    fix b1 assume b1: "b1 \<in> B1"
  6.1200 +    hence f1b1: "f1 b1 \<le> n1" using f1 unfolding bij_betw_def
  6.1201 +    by (metis bij_betwE f1 lessThan_iff less_Suc_eq_le)
  6.1202 +    have "(\<Sum>b2\<in>B2. M (u b1 b2)) = (\<Sum>i2<Suc n2. ct (f1 b1) (f2 (e2 i2)))"
  6.1203 +    unfolding e2_surj[symmetric] setsum_reindex[OF e2_inj]
  6.1204 +    unfolding M_def comp_def apply(intro setsum_cong) apply force
  6.1205 +    by (metis e2_surj b1 h1 h2 imageI)
  6.1206 +    also have "... = N1 b1" using b1 ct1[OF f1b1] by simp
  6.1207 +    finally show "(\<Sum>b2\<in>B2. M (u b1 b2)) = N1 b1" .
  6.1208 +  next
  6.1209 +    fix b2 assume b2: "b2 \<in> B2"
  6.1210 +    hence f2b2: "f2 b2 \<le> n2" using f2 unfolding bij_betw_def
  6.1211 +    by (metis bij_betwE f2 lessThan_iff less_Suc_eq_le)
  6.1212 +    have "(\<Sum>b1\<in>B1. M (u b1 b2)) = (\<Sum>i1<Suc n1. ct (f1 (e1 i1)) (f2 b2))"
  6.1213 +    unfolding e1_surj[symmetric] setsum_reindex[OF e1_inj]
  6.1214 +    unfolding M_def comp_def apply(intro setsum_cong) apply force
  6.1215 +    by (metis e1_surj b2 h1 h2 imageI)
  6.1216 +    also have "... = N2 b2" using b2 ct2[OF f2b2] by simp
  6.1217 +    finally show "(\<Sum>b1\<in>B1. M (u b1 b2)) = N2 b2" .
  6.1218 +  qed
  6.1219 +qed
  6.1220 +
  6.1221 +lemma supp_vimage_mmap:
  6.1222 +assumes "M \<in> multiset"
  6.1223 +shows "supp M \<subseteq> f -` (supp (mmap f M))"
  6.1224 +using assms by (auto simp: mmap_image)
  6.1225 +
  6.1226 +lemma mmap_ge_0:
  6.1227 +assumes "M \<in> multiset"
  6.1228 +shows "0 < mmap f M b \<longleftrightarrow> (\<exists>a. 0 < M a \<and> f a = b)"
  6.1229 +proof-
  6.1230 +  have f: "finite {a. f a = b \<and> 0 < M a}" using assms unfolding multiset_def by auto
  6.1231 +  show ?thesis unfolding mmap_def setsum_gt_0_iff[OF f] by auto
  6.1232 +qed
  6.1233 +
  6.1234 +lemma finite_twosets:
  6.1235 +assumes "finite B1" and "finite B2"
  6.1236 +shows "finite {u b1 b2 |b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"  (is "finite ?A")
  6.1237 +proof-
  6.1238 +  have A: "?A = (\<lambda> b1b2. u (fst b1b2) (snd b1b2)) ` (B1 <*> B2)" by force
  6.1239 +  show ?thesis unfolding A using finite_cartesian_product[OF assms] by auto
  6.1240 +qed
  6.1241 +
  6.1242 +lemma wp_mmap:
  6.1243 +fixes A :: "'a set" and B1 :: "'b1 set" and B2 :: "'b2 set"
  6.1244 +assumes wp: "wpull A B1 B2 f1 f2 p1 p2"
  6.1245 +shows
  6.1246 +"wpull {M. M \<in> multiset \<and> supp M \<subseteq> A}
  6.1247 +       {N1. N1 \<in> multiset \<and> supp N1 \<subseteq> B1} {N2. N2 \<in> multiset \<and> supp N2 \<subseteq> B2}
  6.1248 +       (mmap f1) (mmap f2) (mmap p1) (mmap p2)"
  6.1249 +unfolding wpull_def proof (safe, unfold Bex_def mem_Collect_eq)
  6.1250 +  fix N1 :: "'b1 \<Rightarrow> nat" and N2 :: "'b2 \<Rightarrow> nat"
  6.1251 +  assume mmap': "mmap f1 N1 = mmap f2 N2"
  6.1252 +  and N1[simp]: "N1 \<in> multiset" "supp N1 \<subseteq> B1"
  6.1253 +  and N2[simp]: "N2 \<in> multiset" "supp N2 \<subseteq> B2"
  6.1254 +  have mN1[simp]: "mmap f1 N1 \<in> multiset" using N1 by (auto simp: mmap)
  6.1255 +  have mN2[simp]: "mmap f2 N2 \<in> multiset" using N2 by (auto simp: mmap)
  6.1256 +  def P \<equiv> "mmap f1 N1"
  6.1257 +  have P1: "P = mmap f1 N1" and P2: "P = mmap f2 N2" unfolding P_def using mmap' by auto
  6.1258 +  note P = P1 P2
  6.1259 +  have P_mult[simp]: "P \<in> multiset" unfolding P_def using N1 by auto
  6.1260 +  have fin_N1[simp]: "finite (supp N1)" using N1(1) unfolding multiset_def by auto
  6.1261 +  have fin_N2[simp]: "finite (supp N2)" using N2(1) unfolding multiset_def by auto
  6.1262 +  have fin_P[simp]: "finite (supp P)" using P_mult unfolding multiset_def by auto
  6.1263 +  (*  *)
  6.1264 +  def set1 \<equiv> "\<lambda> c. {b1 \<in> supp N1. f1 b1 = c}"
  6.1265 +  have set1[simp]: "\<And> c b1. b1 \<in> set1 c \<Longrightarrow> f1 b1 = c" unfolding set1_def by auto
  6.1266 +  have fin_set1: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set1 c)"
  6.1267 +  using N1(1) unfolding set1_def multiset_def by auto
  6.1268 +  have set1_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<noteq> {}"
  6.1269 +  unfolding set1_def P1 mmap_ge_0[OF N1(1)] by auto
  6.1270 +  have supp_N1_set1: "supp N1 = (\<Union> c \<in> supp P. set1 c)"
  6.1271 +  using supp_vimage_mmap[OF N1(1), of f1] unfolding set1_def P1 by auto
  6.1272 +  hence set1_inclN1: "\<And>c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> supp N1" by auto
  6.1273 +  hence set1_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> B1" using N1(2) by blast
  6.1274 +  have set1_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set1 c \<inter> set1 c' = {}"
  6.1275 +  unfolding set1_def by auto
  6.1276 +  have setsum_set1: "\<And> c. setsum N1 (set1 c) = P c"
  6.1277 +  unfolding P1 set1_def mmap_def apply(rule setsum_cong) by auto
  6.1278 +  (*  *)
  6.1279 +  def set2 \<equiv> "\<lambda> c. {b2 \<in> supp N2. f2 b2 = c}"
  6.1280 +  have set2[simp]: "\<And> c b2. b2 \<in> set2 c \<Longrightarrow> f2 b2 = c" unfolding set2_def by auto
  6.1281 +  have fin_set2: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set2 c)"
  6.1282 +  using N2(1) unfolding set2_def multiset_def by auto
  6.1283 +  have set2_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<noteq> {}"
  6.1284 +  unfolding set2_def P2 mmap_ge_0[OF N2(1)] by auto
  6.1285 +  have supp_N2_set2: "supp N2 = (\<Union> c \<in> supp P. set2 c)"
  6.1286 +  using supp_vimage_mmap[OF N2(1), of f2] unfolding set2_def P2 by auto
  6.1287 +  hence set2_inclN2: "\<And>c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> supp N2" by auto
  6.1288 +  hence set2_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> B2" using N2(2) by blast
  6.1289 +  have set2_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set2 c \<inter> set2 c' = {}"
  6.1290 +  unfolding set2_def by auto
  6.1291 +  have setsum_set2: "\<And> c. setsum N2 (set2 c) = P c"
  6.1292 +  unfolding P2 set2_def mmap_def apply(rule setsum_cong) by auto
  6.1293 +  (*  *)
  6.1294 +  have ss: "\<And> c. c \<in> supp P \<Longrightarrow> setsum N1 (set1 c) = setsum N2 (set2 c)"
  6.1295 +  unfolding setsum_set1 setsum_set2 ..
  6.1296 +  have "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
  6.1297 +          \<exists> a \<in> A. p1 a = fst b1b2 \<and> p2 a = snd b1b2"
  6.1298 +  using wp set1_incl set2_incl unfolding wpull_def Ball_def mem_Collect_eq
  6.1299 +  by simp (metis set1 set2 set_rev_mp)
  6.1300 +  then obtain uu where uu:
  6.1301 +  "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
  6.1302 +     uu c b1b2 \<in> A \<and> p1 (uu c b1b2) = fst b1b2 \<and> p2 (uu c b1b2) = snd b1b2" by metis
  6.1303 +  def u \<equiv> "\<lambda> c b1 b2. uu c (b1,b2)"
  6.1304 +  have u[simp]:
  6.1305 +  "\<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"
  6.1306 +  "\<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"
  6.1307 +  "\<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"
  6.1308 +  using uu unfolding u_def by auto
  6.1309 +  {fix c assume c: "c \<in> supp P"
  6.1310 +   have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify
  6.1311 +     fix b1 b1' b2 b2'
  6.1312 +     assume "{b1, b1'} \<subseteq> set1 c" "{b2, b2'} \<subseteq> set2 c" and 0: "u c b1 b2 = u c b1' b2'"
  6.1313 +     hence "p1 (u c b1 b2) = b1 \<and> p2 (u c b1 b2) = b2 \<and>
  6.1314 +            p1 (u c b1' b2') = b1' \<and> p2 (u c b1' b2') = b2'"
  6.1315 +     using u(2)[OF c] u(3)[OF c] by simp metis
  6.1316 +     thus "b1 = b1' \<and> b2 = b2'" using 0 by auto
  6.1317 +   qed
  6.1318 +  } note inj = this
  6.1319 +  def sset \<equiv> "\<lambda> c. {u c b1 b2 | b1 b2. b1 \<in> set1 c \<and> b2 \<in> set2 c}"
  6.1320 +  have fin_sset[simp]: "\<And> c. c \<in> supp P \<Longrightarrow> finite (sset c)" unfolding sset_def
  6.1321 +  using fin_set1 fin_set2 finite_twosets by blast
  6.1322 +  have sset_A: "\<And> c. c \<in> supp P \<Longrightarrow> sset c \<subseteq> A" unfolding sset_def by auto
  6.1323 +  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
  6.1324 +   then obtain b1 b2 where b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
  6.1325 +   and a: "a = u c b1 b2" unfolding sset_def by auto
  6.1326 +   have "p1 a \<in> set1 c" and p2a: "p2 a \<in> set2 c"
  6.1327 +   using ac a b1 b2 c u(2) u(3) by simp+
  6.1328 +   hence "u c (p1 a) (p2 a) = a" unfolding a using b1 b2 inj[OF c]
  6.1329 +   unfolding inj2_def by (metis c u(2) u(3))
  6.1330 +  } note u_p12[simp] = this
  6.1331 +  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
  6.1332 +   hence "p1 a \<in> set1 c" unfolding sset_def by auto
  6.1333 +  }note p1[simp] = this
  6.1334 +  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
  6.1335 +   hence "p2 a \<in> set2 c" unfolding sset_def by auto
  6.1336 +  }note p2[simp] = this
  6.1337 +  (*  *)
  6.1338 +  {fix c assume c: "c \<in> supp P"
  6.1339 +   hence "\<exists> M. (\<forall> b1 \<in> set1 c. setsum (\<lambda> b2. M (u c b1 b2)) (set2 c) = N1 b1) \<and>
  6.1340 +               (\<forall> b2 \<in> set2 c. setsum (\<lambda> b1. M (u c b1 b2)) (set1 c) = N2 b2)"
  6.1341 +   unfolding sset_def
  6.1342 +   using matrix_count_finite[OF set1_NE[OF c] fin_set1[OF c]
  6.1343 +                                set2_NE[OF c] fin_set2[OF c] inj[OF c] ss[OF c]] by auto
  6.1344 +  }
  6.1345 +  then obtain Ms where
  6.1346 +  ss1: "\<And> c b1. \<lbrakk>c \<in> supp P; b1 \<in> set1 c\<rbrakk> \<Longrightarrow>
  6.1347 +                   setsum (\<lambda> b2. Ms c (u c b1 b2)) (set2 c) = N1 b1" and
  6.1348 +  ss2: "\<And> c b2. \<lbrakk>c \<in> supp P; b2 \<in> set2 c\<rbrakk> \<Longrightarrow>
  6.1349 +                   setsum (\<lambda> b1. Ms c (u c b1 b2)) (set1 c) = N2 b2"
  6.1350 +  by metis
  6.1351 +  def SET \<equiv> "\<Union> c \<in> supp P. sset c"
  6.1352 +  have fin_SET[simp]: "finite SET" unfolding SET_def apply(rule finite_UN_I) by auto
  6.1353 +  have SET_A: "SET \<subseteq> A" unfolding SET_def using sset_A by auto
  6.1354 +  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"
  6.1355 +  unfolding SET_def sset_def by blast
  6.1356 +  {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p1a: "p1 a \<in> set1 c"
  6.1357 +   then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
  6.1358 +   unfolding SET_def by auto
  6.1359 +   hence "p1 a \<in> set1 c'" unfolding sset_def by auto
  6.1360 +   hence eq: "c = c'" using p1a c c' set1_disj by auto
  6.1361 +   hence "a \<in> sset c" using ac' by simp
  6.1362 +  } note p1_rev = this
  6.1363 +  {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p2a: "p2 a \<in> set2 c"
  6.1364 +   then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
  6.1365 +   unfolding SET_def by auto
  6.1366 +   hence "p2 a \<in> set2 c'" unfolding sset_def by auto
  6.1367 +   hence eq: "c = c'" using p2a c c' set2_disj by auto
  6.1368 +   hence "a \<in> sset c" using ac' by simp
  6.1369 +  } note p2_rev = this
  6.1370 +  (*  *)
  6.1371 +  have "\<forall> a \<in> SET. \<exists> c \<in> supp P. a \<in> sset c" unfolding SET_def by auto
  6.1372 +  then obtain h where h: "\<forall> a \<in> SET. h a \<in> supp P \<and> a \<in> sset (h a)" by metis
  6.1373 +  have h_u[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
  6.1374 +                      \<Longrightarrow> h (u c b1 b2) = c"
  6.1375 +  by (metis h p2 set2 u(3) u_SET)
  6.1376 +  have h_u1: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
  6.1377 +                      \<Longrightarrow> h (u c b1 b2) = f1 b1"
  6.1378 +  using h unfolding sset_def by auto
  6.1379 +  have h_u2: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
  6.1380 +                      \<Longrightarrow> h (u c b1 b2) = f2 b2"
  6.1381 +  using h unfolding sset_def by auto
  6.1382 +  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"
  6.1383 +  have sM: "supp M \<subseteq> SET" "supp M \<subseteq> p1 -` (supp N1)" "supp M \<subseteq> p2 -` (supp N2)"
  6.1384 +  unfolding M_def by auto
  6.1385 +  show "\<exists>M. (M \<in> multiset \<and> supp M \<subseteq> A) \<and> mmap p1 M = N1 \<and> mmap p2 M = N2"
  6.1386 +  proof(rule exI[of _ M], safe)
  6.1387 +    show "M \<in> multiset"
  6.1388 +    unfolding multiset_def using finite_subset[OF sM(1) fin_SET] by simp
  6.1389 +  next
  6.1390 +    fix a assume "0 < M a"
  6.1391 +    thus "a \<in> A" unfolding M_def using SET_A by (cases "a \<in> SET") auto
  6.1392 +  next
  6.1393 +    show "mmap p1 M = N1"
  6.1394 +    unfolding mmap_def[abs_def] proof(rule ext)
  6.1395 +      fix b1
  6.1396 +      let ?K = "{a. p1 a = b1 \<and> 0 < M a}"
  6.1397 +      show "setsum M ?K = N1 b1"
  6.1398 +      proof(cases "b1 \<in> supp N1")
  6.1399 +        case False
  6.1400 +        hence "?K = {}" using sM(2) by auto
  6.1401 +        thus ?thesis using False by auto
  6.1402 +      next
  6.1403 +        case True
  6.1404 +        def c \<equiv> "f1 b1"
  6.1405 +        have c: "c \<in> supp P" and b1: "b1 \<in> set1 c"
  6.1406 +        unfolding set1_def c_def P1 using True by (auto simp: mmap_image)
  6.1407 +        have "setsum M ?K = setsum M {a. p1 a = b1 \<and> a \<in> SET}"
  6.1408 +        apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
  6.1409 +        also have "... = setsum M ((\<lambda> b2. u c b1 b2) ` (set2 c))"
  6.1410 +        apply(rule setsum_cong) using c b1 proof safe
  6.1411 +          fix a assume p1a: "p1 a \<in> set1 c" and "0 < P c" and "a \<in> SET"
  6.1412 +          hence ac: "a \<in> sset c" using p1_rev by auto
  6.1413 +          hence "a = u c (p1 a) (p2 a)" using c by auto
  6.1414 +          moreover have "p2 a \<in> set2 c" using ac c by auto
  6.1415 +          ultimately show "a \<in> u c (p1 a) ` set2 c" by auto
  6.1416 +        next
  6.1417 +          fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
  6.1418 +          hence "u c b1 b2 \<in> SET" using c by auto
  6.1419 +        qed auto
  6.1420 +        also have "... = setsum (\<lambda> b2. M (u c b1 b2)) (set2 c)"
  6.1421 +        unfolding comp_def[symmetric] apply(rule setsum_reindex)
  6.1422 +        using inj unfolding inj_on_def inj2_def using b1 c u(3) by blast
  6.1423 +        also have "... = N1 b1" unfolding ss1[OF c b1, symmetric]
  6.1424 +          apply(rule setsum_cong[OF refl]) unfolding M_def
  6.1425 +          using True h_u[OF c b1] set2_def u(2,3)[OF c b1] u_SET[OF c b1] by fastforce
  6.1426 +        finally show ?thesis .
  6.1427 +      qed
  6.1428 +    qed
  6.1429 +  next
  6.1430 +    show "mmap p2 M = N2"
  6.1431 +    unfolding mmap_def[abs_def] proof(rule ext)
  6.1432 +      fix b2
  6.1433 +      let ?K = "{a. p2 a = b2 \<and> 0 < M a}"
  6.1434 +      show "setsum M ?K = N2 b2"
  6.1435 +      proof(cases "b2 \<in> supp N2")
  6.1436 +        case False
  6.1437 +        hence "?K = {}" using sM(3) by auto
  6.1438 +        thus ?thesis using False by auto
  6.1439 +      next
  6.1440 +        case True
  6.1441 +        def c \<equiv> "f2 b2"
  6.1442 +        have c: "c \<in> supp P" and b2: "b2 \<in> set2 c"
  6.1443 +        unfolding set2_def c_def P2 using True by (auto simp: mmap_image)
  6.1444 +        have "setsum M ?K = setsum M {a. p2 a = b2 \<and> a \<in> SET}"
  6.1445 +        apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
  6.1446 +        also have "... = setsum M ((\<lambda> b1. u c b1 b2) ` (set1 c))"
  6.1447 +        apply(rule setsum_cong) using c b2 proof safe
  6.1448 +          fix a assume p2a: "p2 a \<in> set2 c" and "0 < P c" and "a \<in> SET"
  6.1449 +          hence ac: "a \<in> sset c" using p2_rev by auto
  6.1450 +          hence "a = u c (p1 a) (p2 a)" using c by auto
  6.1451 +          moreover have "p1 a \<in> set1 c" using ac c by auto
  6.1452 +          ultimately show "a \<in> (\<lambda>b1. u c b1 (p2 a)) ` set1 c" by auto
  6.1453 +        next
  6.1454 +          fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
  6.1455 +          hence "u c b1 b2 \<in> SET" using c by auto
  6.1456 +        qed auto
  6.1457 +        also have "... = setsum (M o (\<lambda> b1. u c b1 b2)) (set1 c)"
  6.1458 +        apply(rule setsum_reindex)
  6.1459 +        using inj unfolding inj_on_def inj2_def using b2 c u(2) by blast
  6.1460 +        also have "... = setsum (\<lambda> b1. M (u c b1 b2)) (set1 c)"
  6.1461 +        unfolding comp_def[symmetric] by simp
  6.1462 +        also have "... = N2 b2" unfolding ss2[OF c b2, symmetric]
  6.1463 +          apply(rule setsum_cong[OF refl]) unfolding M_def set2_def
  6.1464 +          using True h_u1[OF c _ b2] u(2,3)[OF c _ b2] u_SET[OF c _ b2]
  6.1465 +          unfolding set1_def by fastforce
  6.1466 +        finally show ?thesis .
  6.1467 +      qed
  6.1468 +    qed
  6.1469 +  qed
  6.1470 +qed
  6.1471 +
  6.1472 +definition mset_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
  6.1473 +"mset_map h = Abs_multiset \<circ> mmap h \<circ> count"
  6.1474 +
  6.1475 +bnf_def mset = mset_map [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
  6.1476 +unfolding mset_map_def
  6.1477 +proof -
  6.1478 +  show "Abs_multiset \<circ> mmap id \<circ> count = id" unfolding mmap_id by (auto simp: count_inverse)
  6.1479 +next
  6.1480 +  fix f g
  6.1481 +  show "Abs_multiset \<circ> mmap (g \<circ> f) \<circ> count =
  6.1482 +        Abs_multiset \<circ> mmap g \<circ> count \<circ> (Abs_multiset \<circ> mmap f \<circ> count)"
  6.1483 +  unfolding comp_def apply(rule ext)
  6.1484 +  by (auto simp: Abs_multiset_inverse count mmap_comp1 mmap)
  6.1485 +next
  6.1486 +  fix M f g assume eq: "\<And>a. a \<in> set_of M \<Longrightarrow> f a = g a"
  6.1487 +  thus "(Abs_multiset \<circ> mmap f \<circ> count) M = (Abs_multiset \<circ> mmap g \<circ> count) M" apply auto
  6.1488 +  unfolding cIm_def[abs_def] image_def
  6.1489 +  by (auto intro!: mmap_cong simp: Abs_multiset_inject count mmap)
  6.1490 +next
  6.1491 +  fix f show "set_of \<circ> (Abs_multiset \<circ> mmap f \<circ> count) = op ` f \<circ> set_of"
  6.1492 +  by (auto simp: count mmap mmap_image set_of_Abs_multiset supp_count)
  6.1493 +next
  6.1494 +  show "card_order natLeq" by (rule natLeq_card_order)
  6.1495 +next
  6.1496 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  6.1497 +next
  6.1498 +  fix M show "|set_of M| \<le>o natLeq"
  6.1499 +  apply(rule ordLess_imp_ordLeq)
  6.1500 +  unfolding finite_iff_ordLess_natLeq[symmetric] using finite_set_of .
  6.1501 +next
  6.1502 +  fix A :: "'a set"
  6.1503 +  have "|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_set_of .
  6.1504 +  also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
  6.1505 +  by (rule list_in_bd)
  6.1506 +  finally show "|{M. set_of M \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
  6.1507 +next
  6.1508 +  fix A B1 B2 f1 f2 p1 p2
  6.1509 +  let ?map = "\<lambda> f. Abs_multiset \<circ> mmap f \<circ> count"
  6.1510 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
  6.1511 +  show "wpull {x. set_of x \<subseteq> A} {x. set_of x \<subseteq> B1} {x. set_of x \<subseteq> B2}
  6.1512 +              (?map f1) (?map f2) (?map p1) (?map p2)"
  6.1513 +  unfolding wpull_def proof safe
  6.1514 +    fix y1 y2
  6.1515 +    assume y1: "set_of y1 \<subseteq> B1" and y2: "set_of y2 \<subseteq> B2"
  6.1516 +    and m: "?map f1 y1 = ?map f2 y2"
  6.1517 +    def N1 \<equiv> "count y1"  def N2 \<equiv> "count y2"
  6.1518 +    have "N1 \<in> multiset \<and> supp N1 \<subseteq> B1" and "N2 \<in> multiset \<and> supp N2 \<subseteq> B2"
  6.1519 +    and "mmap f1 N1 = mmap f2 N2"
  6.1520 +    using y1 y2 m unfolding N1_def N2_def
  6.1521 +    by (auto simp: Abs_multiset_inject count mmap)
  6.1522 +    then obtain M where M: "M \<in> multiset \<and> supp M \<subseteq> A"
  6.1523 +    and N1: "mmap p1 M = N1" and N2: "mmap p2 M = N2"
  6.1524 +    using wp_mmap[OF wp] unfolding wpull_def by auto
  6.1525 +    def x \<equiv> "Abs_multiset M"
  6.1526 +    show "\<exists>x\<in>{x. set_of x \<subseteq> A}. ?map p1 x = y1 \<and> ?map p2 x = y2"
  6.1527 +    apply(intro bexI[of _ x]) using M N1 N2 unfolding N1_def N2_def x_def
  6.1528 +    by (auto simp: count_inverse Abs_multiset_inverse)
  6.1529 +  qed
  6.1530 +qed (unfold set_of_empty, auto)
  6.1531 +
  6.1532 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Codatatype/Codatatype.thy	Tue Aug 28 17:16:00 2012 +0200
     7.3 @@ -0,0 +1,14 @@
     7.4 +(*  Title:      HOL/Codatatype/Codatatype.thy
     7.5 +    Author:     Dmitriy Traytel, TU Muenchen
     7.6 +    Copyright   2012
     7.7 +
     7.8 +The (co)datatype package.
     7.9 +*)
    7.10 +
    7.11 +header {* The (Co)datatype Package *}
    7.12 +
    7.13 +theory Codatatype
    7.14 +imports BNF_LFP BNF_GFP
    7.15 +begin
    7.16 +
    7.17 +end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Codatatype/Countable_Set.thy	Tue Aug 28 17:16:00 2012 +0200
     8.3 @@ -0,0 +1,328 @@
     8.4 +(*  Title:      HOL/Codatatype/Countable_Set.thy
     8.5 +    Author:     Andrei Popescu, TU Muenchen
     8.6 +    Copyright   2012
     8.7 +
     8.8 +(At most) countable sets.
     8.9 +*)
    8.10 +
    8.11 +header {* (At Most) Countable Sets *}
    8.12 +
    8.13 +theory Countable_Set
    8.14 +imports "../Ordinals_and_Cardinals_Base/Cardinal_Arithmetic"
    8.15 +        "~~/src/HOL/Library/Countable"
    8.16 +begin
    8.17 +
    8.18 +
    8.19 +subsection{* Basics  *}
    8.20 +
    8.21 +definition "countable A \<equiv> |A| \<le>o natLeq"
    8.22 +
    8.23 +lemma countable_card_of_nat:
    8.24 +"countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
    8.25 +unfolding countable_def using card_of_nat
    8.26 +using ordLeq_ordIso_trans ordIso_symmetric by blast
    8.27 +
    8.28 +lemma countable_ex_to_nat:
    8.29 +fixes A :: "'a set"
    8.30 +shows "countable A \<longleftrightarrow> (\<exists> f::'a\<Rightarrow>nat. inj_on f A)"
    8.31 +unfolding countable_card_of_nat card_of_ordLeq[symmetric] by auto
    8.32 +
    8.33 +lemma countable_or_card_of:
    8.34 +assumes "countable A"
    8.35 +shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
    8.36 +       (infinite A  \<and> |A| =o |UNIV::nat set| )"
    8.37 +apply (cases "finite A")
    8.38 +  apply(metis finite_iff_cardOf_nat)
    8.39 +  by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
    8.40 +
    8.41 +lemma countable_or:
    8.42 +assumes "countable A"
    8.43 +shows "(\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or>
    8.44 +       (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
    8.45 +using countable_or_card_of[OF assms]
    8.46 +by (metis assms card_of_ordIso countable_ex_to_nat)
    8.47 +
    8.48 +lemma countable_cases_card_of[elim, consumes 1, case_names Fin Inf]:
    8.49 +assumes "countable A"
    8.50 +and "\<lbrakk>finite A; |A| <o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
    8.51 +and "\<lbrakk>infinite A; |A| =o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
    8.52 +shows phi
    8.53 +using assms countable_or_card_of by blast
    8.54 +
    8.55 +lemma countable_cases[elim, consumes 1, case_names Fin Inf]:
    8.56 +assumes "countable A"
    8.57 +and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>finite A; inj_on f A\<rbrakk> \<Longrightarrow> phi"
    8.58 +and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>infinite A; bij_betw f A UNIV\<rbrakk> \<Longrightarrow> phi"
    8.59 +shows phi
    8.60 +using assms countable_or by metis
    8.61 +
    8.62 +definition toNat_pred :: "'a set \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> bool"
    8.63 +where
    8.64 +"toNat_pred (A::'a set) f \<equiv>
    8.65 + (finite A \<and> inj_on f A) \<or> (infinite A \<and> bij_betw f A UNIV)"
    8.66 +definition toNat where "toNat A \<equiv> SOME f. toNat_pred A f"
    8.67 +
    8.68 +lemma toNat_pred:
    8.69 +assumes "countable A"
    8.70 +shows "\<exists> f. toNat_pred A f"
    8.71 +using assms countable_ex_to_nat toNat_pred_def by (cases rule: countable_cases) auto
    8.72 +
    8.73 +lemma toNat_pred_toNat:
    8.74 +assumes "countable A"
    8.75 +shows "toNat_pred A (toNat A)"
    8.76 +unfolding toNat_def apply(rule someI_ex[of "toNat_pred A"])
    8.77 +using toNat_pred[OF assms] .
    8.78 +
    8.79 +lemma bij_betw_toNat:
    8.80 +assumes c: "countable A" and i: "infinite A"
    8.81 +shows "bij_betw (toNat A) A (UNIV::nat set)"
    8.82 +using toNat_pred_toNat[OF c] unfolding toNat_pred_def using i by auto
    8.83 +
    8.84 +lemma inj_on_toNat:
    8.85 +assumes c: "countable A"
    8.86 +shows "inj_on (toNat A) A"
    8.87 +using c apply(cases rule: countable_cases)
    8.88 +using bij_betw_toNat[OF c] toNat_pred_toNat[OF c]
    8.89 +unfolding toNat_pred_def unfolding bij_betw_def by auto
    8.90 +
    8.91 +lemma toNat_inj[simp]:
    8.92 +assumes c: "countable A" and a: "a \<in> A" and b: "b \<in> A"
    8.93 +shows "toNat A a = toNat A b \<longleftrightarrow> a = b"
    8.94 +using inj_on_toNat[OF c] using a b unfolding inj_on_def by auto
    8.95 +
    8.96 +lemma image_toNat:
    8.97 +assumes c: "countable A" and i: "infinite A"
    8.98 +shows "toNat A ` A = UNIV"
    8.99 +using bij_betw_toNat[OF assms] unfolding bij_betw_def by simp
   8.100 +
   8.101 +lemma toNat_surj:
   8.102 +assumes "countable A" and i: "infinite A"
   8.103 +shows "\<exists> a. a \<in> A \<and> toNat A a = n"
   8.104 +using image_toNat[OF assms]
   8.105 +by (metis (no_types) image_iff iso_tuple_UNIV_I)
   8.106 +
   8.107 +definition
   8.108 +"fromNat A n \<equiv>
   8.109 + if n \<in> toNat A ` A then inv_into A (toNat A) n
   8.110 + else (SOME a. a \<in> A)"
   8.111 +
   8.112 +lemma fromNat:
   8.113 +assumes "A \<noteq> {}"
   8.114 +shows "fromNat A n \<in> A"
   8.115 +unfolding fromNat_def by (metis assms equals0I inv_into_into someI_ex)
   8.116 +
   8.117 +lemma toNat_fromNat[simp]:
   8.118 +assumes "n \<in> toNat A ` A"
   8.119 +shows "toNat A (fromNat A n) = n"
   8.120 +by (metis assms f_inv_into_f fromNat_def)
   8.121 +
   8.122 +lemma infinite_toNat_fromNat[simp]:
   8.123 +assumes c: "countable A" and i: "infinite A"
   8.124 +shows "toNat A (fromNat A n) = n"
   8.125 +apply(rule toNat_fromNat) using toNat_surj[OF assms]
   8.126 +by (metis image_iff)
   8.127 +
   8.128 +lemma fromNat_toNat[simp]:
   8.129 +assumes c: "countable A" and a: "a \<in> A"
   8.130 +shows "fromNat A (toNat A a) = a"
   8.131 +by (metis a c equals0D fromNat imageI toNat_fromNat toNat_inj)
   8.132 +
   8.133 +lemma fromNat_inj:
   8.134 +assumes c: "countable A" and i: "infinite A"
   8.135 +shows "fromNat A m = fromNat A n \<longleftrightarrow> m = n" (is "?L = ?R \<longleftrightarrow> ?K")
   8.136 +proof-
   8.137 +  have "?L = ?R \<longleftrightarrow> toNat A ?L = toNat A ?R"
   8.138 +  unfolding toNat_inj[OF c fromNat[OF infinite_imp_nonempty[OF i]]
   8.139 +                           fromNat[OF infinite_imp_nonempty[OF i]]] ..
   8.140 +  also have "... \<longleftrightarrow> ?K" using c i by simp
   8.141 +  finally show ?thesis .
   8.142 +qed
   8.143 +
   8.144 +lemma fromNat_surj:
   8.145 +assumes c: "countable A" and a: "a \<in> A"
   8.146 +shows "\<exists> n. fromNat A n = a"
   8.147 +apply(rule exI[of _ "toNat A a"]) using assms by simp
   8.148 +
   8.149 +lemma fromNat_image_incl:
   8.150 +assumes "A \<noteq> {}"
   8.151 +shows "fromNat A ` UNIV \<subseteq> A"
   8.152 +using fromNat[OF assms] by auto
   8.153 +
   8.154 +lemma incl_fromNat_image:
   8.155 +assumes "countable A"
   8.156 +shows "A \<subseteq> fromNat A ` UNIV"
   8.157 +unfolding image_def using fromNat_surj[OF assms] by auto
   8.158 +
   8.159 +lemma fromNat_image[simp]:
   8.160 +assumes "A \<noteq> {}" and "countable A"
   8.161 +shows "fromNat A ` UNIV = A"
   8.162 +by (metis assms equalityI fromNat_image_incl incl_fromNat_image)
   8.163 +
   8.164 +lemma fromNat_inject[simp]:
   8.165 +assumes A: "A \<noteq> {}" "countable A" and B: "B \<noteq> {}" "countable B"
   8.166 +shows "fromNat A = fromNat B \<longleftrightarrow> A = B"
   8.167 +by (metis assms fromNat_image)
   8.168 +
   8.169 +lemma inj_on_fromNat:
   8.170 +"inj_on fromNat ({A. A \<noteq> {} \<and> countable A})"
   8.171 +unfolding inj_on_def by auto
   8.172 +
   8.173 +
   8.174 +subsection {* Preservation under the set theoretic operations *}
   8.175 +
   8.176 +lemma contable_empty[simp,intro]:
   8.177 +"countable {}"
   8.178 +by (metis countable_ex_to_nat inj_on_empty)
   8.179 +
   8.180 +lemma incl_countable:
   8.181 +assumes "A \<subseteq> B" and "countable B"
   8.182 +shows "countable A"
   8.183 +by (metis assms countable_ex_to_nat subset_inj_on)
   8.184 +
   8.185 +lemma countable_diff:
   8.186 +assumes "countable A"
   8.187 +shows "countable (A - B)"
   8.188 +by (metis Diff_subset assms incl_countable)
   8.189 +
   8.190 +lemma finite_countable[simp]:
   8.191 +assumes "finite A"
   8.192 +shows "countable A"
   8.193 +by (metis assms countable_ex_to_nat finite_imp_inj_to_nat_seg)
   8.194 +
   8.195 +lemma countable_singl[simp]:
   8.196 +"countable {a}"
   8.197 +by simp
   8.198 +
   8.199 +lemma countable_insert[simp]:
   8.200 +"countable (insert a A) \<longleftrightarrow> countable A"
   8.201 +proof
   8.202 +  assume c: "countable A"
   8.203 +  thus "countable (insert a A)"
   8.204 +  apply (cases rule: countable_cases_card_of)
   8.205 +    apply (metis finite_countable finite_insert)
   8.206 +    unfolding countable_card_of_nat
   8.207 +    by (metis infinite_card_of_insert ordIso_imp_ordLeq ordIso_transitive)
   8.208 +qed(insert incl_countable, metis incl_countable subset_insertI)
   8.209 +
   8.210 +lemma contable_IntL[simp]:
   8.211 +assumes "countable A"
   8.212 +shows "countable (A \<inter> B)"
   8.213 +by (metis Int_lower1 assms incl_countable)
   8.214 +
   8.215 +lemma contable_IntR[simp]:
   8.216 +assumes "countable B"
   8.217 +shows "countable (A \<inter> B)"
   8.218 +by (metis assms contable_IntL inf.commute)
   8.219 +
   8.220 +lemma countable_UN[simp]:
   8.221 +assumes cI: "countable I" and cA: "\<And> i. i \<in> I \<Longrightarrow> countable (A i)"
   8.222 +shows "countable (\<Union> i \<in> I. A i)"
   8.223 +using assms unfolding countable_card_of_nat
   8.224 +apply(intro card_of_UNION_ordLeq_infinite) by auto
   8.225 +
   8.226 +lemma contable_Un[simp]:
   8.227 +"countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
   8.228 +proof safe
   8.229 +  assume cA: "countable A" and cB: "countable B"
   8.230 +  let ?I = "{0,Suc 0}"  let ?As = "\<lambda> i. case i of 0 \<Rightarrow> A|Suc 0 \<Rightarrow> B"
   8.231 +  have AB: "A \<union> B = (\<Union> i \<in> ?I. ?As i)" by simp
   8.232 +  show "countable (A \<union> B)" unfolding AB apply(rule countable_UN)
   8.233 +  using cA cB by auto
   8.234 +qed (metis Un_upper1 incl_countable, metis Un_upper2 incl_countable)
   8.235 +
   8.236 +lemma countable_INT[simp]:
   8.237 +assumes "i \<in> I" and "countable (A i)"
   8.238 +shows "countable (\<Inter> i \<in> I. A i)"
   8.239 +by (metis INF_insert assms contable_IntL insert_absorb)
   8.240 +
   8.241 +lemma countable_class[simp]:
   8.242 +fixes A :: "('a::countable) set"
   8.243 +shows "countable A"
   8.244 +proof-
   8.245 +  have "inj_on to_nat A" by (metis inj_on_to_nat)
   8.246 +  thus ?thesis by (metis countable_ex_to_nat)
   8.247 +qed
   8.248 +
   8.249 +lemma countable_image[simp]:
   8.250 +assumes "countable A"
   8.251 +shows "countable (f ` A)"
   8.252 +using assms unfolding countable_card_of_nat
   8.253 +by (metis card_of_image ordLeq_transitive)
   8.254 +
   8.255 +lemma countable_ordLeq:
   8.256 +assumes "|A| \<le>o |B|" and "countable B"
   8.257 +shows "countable A"
   8.258 +using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
   8.259 +
   8.260 +lemma countable_ordLess:
   8.261 +assumes AB: "|A| <o |B|" and B: "countable B"
   8.262 +shows "countable A"
   8.263 +using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
   8.264 +
   8.265 +lemma countable_vimage:
   8.266 +assumes "B \<subseteq> range f" and "countable (f -` B)"
   8.267 +shows "countable B"
   8.268 +by (metis Int_absorb2 assms countable_image image_vimage_eq)
   8.269 +
   8.270 +lemma surj_countable_vimage:
   8.271 +assumes s: "surj f" and c: "countable (f -` B)"
   8.272 +shows "countable B"
   8.273 +apply(rule countable_vimage[OF _ c]) using s by auto
   8.274 +
   8.275 +lemma countable_Collect[simp]:
   8.276 +assumes "countable A"
   8.277 +shows "countable {a \<in> A. \<phi> a}"
   8.278 +by (metis Collect_conj_eq Int_absorb Int_commute Int_def assms contable_IntR)
   8.279 +
   8.280 +
   8.281 +subsection{*  The type of countable sets *}
   8.282 +
   8.283 +typedef (open) 'a cset = "{A :: 'a set. countable A}"
   8.284 +apply(rule exI[of _ "{}"]) by simp
   8.285 +
   8.286 +abbreviation rcset where "rcset \<equiv> Rep_cset"
   8.287 +abbreviation acset where "acset \<equiv> Abs_cset"
   8.288 +
   8.289 +lemmas acset_rcset = Rep_cset_inverse
   8.290 +declare acset_rcset[simp]
   8.291 +
   8.292 +lemma acset_surj:
   8.293 +"\<exists> A. countable A \<and> acset A = C"
   8.294 +apply(cases rule: Abs_cset_cases[of C]) by auto
   8.295 +
   8.296 +lemma rcset_acset[simp]:
   8.297 +assumes "countable A"
   8.298 +shows "rcset (acset A) = A"
   8.299 +using Abs_cset_inverse assms by auto
   8.300 +
   8.301 +lemma acset_inj[simp]:
   8.302 +assumes "countable A" and "countable B"
   8.303 +shows "acset A = acset B \<longleftrightarrow> A = B"
   8.304 +using assms Abs_cset_inject by auto
   8.305 +
   8.306 +lemma rcset[simp]:
   8.307 +"countable (rcset C)"
   8.308 +using Rep_cset by simp
   8.309 +
   8.310 +lemma rcset_inj[simp]:
   8.311 +"rcset C = rcset D \<longleftrightarrow> C = D"
   8.312 +by (metis acset_rcset)
   8.313 +
   8.314 +lemma rcset_surj:
   8.315 +assumes "countable A"
   8.316 +shows "\<exists> C. rcset C = A"
   8.317 +apply(cases rule: Rep_cset_cases[of A])
   8.318 +using assms by auto
   8.319 +
   8.320 +definition "cIn a C \<equiv> (a \<in> rcset C)"
   8.321 +definition "cEmp \<equiv> acset {}"
   8.322 +definition "cIns a C \<equiv> acset (insert a (rcset C))"
   8.323 +abbreviation cSingl where "cSingl a \<equiv> cIns a cEmp"
   8.324 +definition "cUn C D \<equiv> acset (rcset C \<union> rcset D)"
   8.325 +definition "cInt C D \<equiv> acset (rcset C \<inter> rcset D)"
   8.326 +definition "cDif C D \<equiv> acset (rcset C - rcset D)"
   8.327 +definition "cIm f C \<equiv> acset (f ` rcset C)"
   8.328 +definition "cVim f D \<equiv> acset (f -` rcset D)"
   8.329 +(* TODO eventually: nice setup for these operations, copied from the set setup *)
   8.330 +
   8.331 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Codatatype/Equiv_Relations_More.thy	Tue Aug 28 17:16:00 2012 +0200
     9.3 @@ -0,0 +1,161 @@
     9.4 +(*  Title:      HOL/Codatatype/Equiv_Relations_More.thy
     9.5 +    Author:     Andrei Popescu, TU Muenchen
     9.6 +    Copyright   2012
     9.7 +
     9.8 +Some preliminaries on equivalence relations and quotients.
     9.9 +*)
    9.10 +
    9.11 +header {* Some Preliminaries on Equivalence Relations and Quotients *}
    9.12 +
    9.13 +theory Equiv_Relations_More
    9.14 +imports Equiv_Relations Hilbert_Choice
    9.15 +begin
    9.16 +
    9.17 +
    9.18 +(* Recall the following constants and lemmas:
    9.19 +
    9.20 +term Eps
    9.21 +term "A//r"
    9.22 +lemmas equiv_def
    9.23 +lemmas refl_on_def
    9.24 + -- note that "reflexivity on" also assumes inclusion of the relation's field into r
    9.25 +
    9.26 +*)
    9.27 +
    9.28 +definition proj where "proj r x = r `` {x}"
    9.29 +
    9.30 +definition univ where "univ f X == f (Eps (%x. x \<in> X))"
    9.31 +
    9.32 +lemma proj_preserves:
    9.33 +"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
    9.34 +unfolding proj_def by (rule quotientI)
    9.35 +
    9.36 +lemma proj_in_iff:
    9.37 +assumes "equiv A r"
    9.38 +shows "(proj r x \<in> A//r) = (x \<in> A)"
    9.39 +apply(rule iffI, auto simp add: proj_preserves)
    9.40 +unfolding proj_def quotient_def proof clarsimp
    9.41 +  fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
    9.42 +  moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by blast
    9.43 +  ultimately have "(x,y) \<in> r" by blast
    9.44 +  thus "x \<in> A" using assms unfolding equiv_def refl_on_def by blast
    9.45 +qed
    9.46 +
    9.47 +lemma proj_iff:
    9.48 +"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
    9.49 +by (simp add: proj_def eq_equiv_class_iff)
    9.50 +
    9.51 +(*
    9.52 +lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
    9.53 +unfolding proj_def equiv_def refl_on_def by blast
    9.54 +*)
    9.55 +
    9.56 +lemma proj_image: "(proj r) ` A = A//r"
    9.57 +unfolding proj_def[abs_def] quotient_def by blast
    9.58 +
    9.59 +lemma in_quotient_imp_non_empty:
    9.60 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<noteq> {}"
    9.61 +unfolding quotient_def using equiv_class_self by fast
    9.62 +
    9.63 +lemma in_quotient_imp_in_rel:
    9.64 +"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
    9.65 +using quotient_eq_iff by fastforce
    9.66 +
    9.67 +lemma in_quotient_imp_closed:
    9.68 +"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
    9.69 +unfolding quotient_def equiv_def trans_def by blast
    9.70 +
    9.71 +lemma in_quotient_imp_subset:
    9.72 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
    9.73 +using assms in_quotient_imp_in_rel equiv_type by fastforce
    9.74 +
    9.75 +lemma equiv_Eps_in:
    9.76 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
    9.77 +apply (rule someI2_ex)
    9.78 +using in_quotient_imp_non_empty by blast
    9.79 +
    9.80 +lemma equiv_Eps_preserves:
    9.81 +assumes ECH: "equiv A r" and X: "X \<in> A//r"
    9.82 +shows "Eps (%x. x \<in> X) \<in> A"
    9.83 +apply (rule in_mono[rule_format])
    9.84 + using assms apply (rule in_quotient_imp_subset)
    9.85 +by (rule equiv_Eps_in) (rule assms)+
    9.86 +
    9.87 +lemma proj_Eps:
    9.88 +assumes "equiv A r" and "X \<in> A//r"
    9.89 +shows "proj r (Eps (%x. x \<in> X)) = X"
    9.90 +unfolding proj_def proof auto
    9.91 +  fix x assume x: "x \<in> X"
    9.92 +  thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
    9.93 +next
    9.94 +  fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
    9.95 +  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
    9.96 +qed
    9.97 +
    9.98 +(*
    9.99 +lemma Eps_proj:
   9.100 +assumes "equiv A r" and "x \<in> A"
   9.101 +shows "(Eps (%y. y \<in> proj r x), x) \<in> r"
   9.102 +proof-
   9.103 +  have 1: "proj r x \<in> A//r" using assms proj_preserves by fastforce
   9.104 +  hence "Eps(%y. y \<in> proj r x) \<in> proj r x" using assms equiv_Eps_in by auto
   9.105 +  moreover have "x \<in> proj r x" using assms in_proj by fastforce
   9.106 +  ultimately show ?thesis using assms 1 in_quotient_imp_in_rel by fastforce
   9.107 +qed
   9.108 +
   9.109 +lemma equiv_Eps_iff:
   9.110 +assumes "equiv A r" and "{X,Y} \<subseteq> A//r"
   9.111 +shows "((Eps (%x. x \<in> X),Eps (%y. y \<in> Y)) \<in> r) = (X = Y)"
   9.112 +proof-
   9.113 +  have "Eps (%x. x \<in> X) \<in> X \<and> Eps (%y. y \<in> Y) \<in> Y" using assms equiv_Eps_in by auto
   9.114 +  thus ?thesis using assms quotient_eq_iff by fastforce
   9.115 +qed
   9.116 +
   9.117 +lemma equiv_Eps_inj_on:
   9.118 +assumes "equiv A r"
   9.119 +shows "inj_on (%X. Eps (%x. x \<in> X)) (A//r)"
   9.120 +unfolding inj_on_def proof clarify
   9.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)"
   9.122 +  hence "Eps (%x. x \<in> X) \<in> A" using assms equiv_Eps_preserves by auto
   9.123 +  hence "(Eps (%x. x \<in> X), Eps (%y. y \<in> Y)) \<in> r"
   9.124 +  using assms Eps unfolding quotient_def equiv_def refl_on_def by auto
   9.125 +  thus "X= Y" using X Y assms equiv_Eps_iff by auto
   9.126 +qed
   9.127 +*)
   9.128 +
   9.129 +lemma univ_commute:
   9.130 +assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
   9.131 +shows "(univ f) (proj r x) = f x"
   9.132 +unfolding univ_def proof -
   9.133 +  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
   9.134 +  hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
   9.135 +  moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
   9.136 +  ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
   9.137 +  thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
   9.138 +qed
   9.139 +
   9.140 +(*
   9.141 +lemma univ_unique:
   9.142 +assumes ECH: "equiv A r" and
   9.143 +        RES: "f respects r" and  COM: "\<forall> x \<in> A. G (proj r x) = f x"
   9.144 +shows "\<forall> X \<in> A//r. G X = univ f X"
   9.145 +proof
   9.146 +  fix X assume "X \<in> A//r"
   9.147 +  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
   9.148 +  have "G X = f x" unfolding X using x COM by simp
   9.149 +  thus "G X = univ f X" unfolding X using ECH RES x univ_commute by fastforce
   9.150 +qed
   9.151 +*)
   9.152 +
   9.153 +lemma univ_preserves:
   9.154 +assumes ECH: "equiv A r" and RES: "f respects r" and
   9.155 +        PRES: "\<forall> x \<in> A. f x \<in> B"
   9.156 +shows "\<forall> X \<in> A//r. univ f X \<in> B"
   9.157 +proof
   9.158 +  fix X assume "X \<in> A//r"
   9.159 +  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
   9.160 +  hence "univ f X = f x" using assms univ_commute by fastforce
   9.161 +  thus "univ f X \<in> B" using x PRES by simp
   9.162 +qed
   9.163 +
   9.164 +end
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Codatatype/Examples/HFset.thy	Tue Aug 28 17:16:00 2012 +0200
    10.3 @@ -0,0 +1,60 @@
    10.4 +(*  Title:      Codatatype_Examples/HFset.thy
    10.5 +    Author:     Andrei Popescu, TU Muenchen
    10.6 +    Copyright   2012
    10.7 +
    10.8 +Hereditary sets.
    10.9 +*)
   10.10 +
   10.11 +header {* Hereditary Sets *}
   10.12 +
   10.13 +theory HFset
   10.14 +imports "../Codatatype/Codatatype"
   10.15 +begin
   10.16 +
   10.17 +
   10.18 +section {* Datatype definition *}
   10.19 +
   10.20 +bnf_data hfset: 'hfset = "'hfset fset"
   10.21 +
   10.22 +
   10.23 +section {* Customization of terms *}
   10.24 +
   10.25 +subsection{* Constructors *}
   10.26 +
   10.27 +definition "Fold hs \<equiv> hfset_fld hs"
   10.28 +
   10.29 +lemma hfset_simps[simp]:
   10.30 +"\<And>hs1 hs2. Fold hs1 = Fold hs2 \<longrightarrow> hs1 = hs2"
   10.31 +unfolding Fold_def hfset.fld_inject by auto
   10.32 +
   10.33 +theorem hfset_cases[elim, case_names Fold]:
   10.34 +assumes Fold: "\<And> hs. h = Fold hs \<Longrightarrow> phi"
   10.35 +shows phi
   10.36 +using Fold unfolding Fold_def
   10.37 +by (cases rule: hfset.fld_exhaust[of h]) simp
   10.38 +
   10.39 +lemma hfset_induct[case_names Fold, induct type: hfset]:
   10.40 +assumes Fold: "\<And> hs. (\<And> h. h |\<in>| hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
   10.41 +shows "phi t"
   10.42 +apply (induct rule: hfset.fld_induct)
   10.43 +using Fold unfolding Fold_def fset_fset_member mem_Collect_eq ..
   10.44 +
   10.45 +(* alternative induction principle, using fset: *)
   10.46 +lemma hfset_induct_fset[case_names Fold, induct type: hfset]:
   10.47 +assumes Fold: "\<And> hs. (\<And> h. h \<in> fset hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
   10.48 +shows "phi t"
   10.49 +apply (induct rule: hfset_induct)
   10.50 +using Fold by (metis notin_fset)
   10.51 +
   10.52 +subsection{* Recursion and iteration *}
   10.53 +
   10.54 +lemma hfset_rec:
   10.55 +"hfset_rec R (Fold hs) = R (map_fset <id, hfset_rec R> hs)"
   10.56 +using hfset.rec unfolding Fold_def .
   10.57 +
   10.58 +(* The iterator has a simpler form: *)
   10.59 +lemma hfset_iter:
   10.60 +"hfset_iter R (Fold hs) = R (map_fset (hfset_iter R) hs)"
   10.61 +using hfset.iter unfolding Fold_def .
   10.62 +
   10.63 +end
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Gram_Lang.thy	Tue Aug 28 17:16:00 2012 +0200
    11.3 @@ -0,0 +1,1366 @@
    11.4 +(*  Title:      Gram_Lang.thy
    11.5 +    Author:     Andrei Popescu, TU Muenchen
    11.6 +    Copyright   2012
    11.7 +
    11.8 +Language of a grammar.
    11.9 +*)
   11.10 +
   11.11 +header {* Language of a Grammar *}
   11.12 +
   11.13 +theory Gram_Lang
   11.14 +imports Tree
   11.15 +begin 
   11.16 +
   11.17 +
   11.18 +consts P :: "(N \<times> (T + N) set) set"
   11.19 +axiomatization where 
   11.20 +    finite_N: "finite (UNIV::N set)"
   11.21 +and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
   11.22 +and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
   11.23 +
   11.24 +
   11.25 +subsection{* Tree basics: frontier, interior, etc. *}
   11.26 +
   11.27 +lemma Tree_cong: 
   11.28 +assumes "root tr = root tr'" and "cont tr = cont tr'"
   11.29 +shows "tr = tr'"
   11.30 +by (metis Node_root_cont assms)
   11.31 +
   11.32 +inductive finiteT where 
   11.33 +Node: "\<lbrakk>finite as; (finiteT^#) as\<rbrakk> \<Longrightarrow> finiteT (Node a as)"
   11.34 +monos lift_mono
   11.35 +
   11.36 +lemma finiteT_induct[consumes 1, case_names Node, induct pred: finiteT]:
   11.37 +assumes 1: "finiteT tr"
   11.38 +and IH: "\<And>as n. \<lbrakk>finite as; (\<phi>^#) as\<rbrakk> \<Longrightarrow> \<phi> (Node n as)"
   11.39 +shows "\<phi> tr"
   11.40 +using 1 apply(induct rule: finiteT.induct)
   11.41 +apply(rule IH) apply assumption apply(elim mono_lift) by simp
   11.42 +
   11.43 +
   11.44 +(* Frontier *)
   11.45 +
   11.46 +inductive inFr :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where 
   11.47 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
   11.48 +|
   11.49 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
   11.50 +
   11.51 +definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
   11.52 +
   11.53 +lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
   11.54 +by (metis inFr.simps)
   11.55 +
   11.56 +lemma inFr_mono: 
   11.57 +assumes "inFr ns tr t" and "ns \<subseteq> ns'"
   11.58 +shows "inFr ns' tr t"
   11.59 +using assms apply(induct arbitrary: ns' rule: inFr.induct)
   11.60 +using Base Ind by (metis inFr.simps set_mp)+
   11.61 +
   11.62 +lemma inFr_Ind_minus: 
   11.63 +assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
   11.64 +shows "inFr (insert (root tr) ns1) tr t"
   11.65 +using assms apply(induct rule: inFr.induct)
   11.66 +  apply (metis inFr.simps insert_iff)
   11.67 +  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
   11.68 +
   11.69 +(* alternative definition *)
   11.70 +inductive inFr2 :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where 
   11.71 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
   11.72 +|
   11.73 +Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk> 
   11.74 +      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
   11.75 +
   11.76 +lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
   11.77 +apply(induct rule: inFr2.induct) by auto
   11.78 +
   11.79 +lemma inFr2_mono: 
   11.80 +assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
   11.81 +shows "inFr2 ns' tr t"
   11.82 +using assms apply(induct arbitrary: ns' rule: inFr2.induct)
   11.83 +using Base Ind
   11.84 +apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset) 
   11.85 +
   11.86 +lemma inFr2_Ind:
   11.87 +assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr" 
   11.88 +shows "inFr2 ns tr t"
   11.89 +using assms apply(induct rule: inFr2.induct)
   11.90 +  apply (metis inFr2.simps insert_absorb)
   11.91 +  by (metis inFr2.simps insert_absorb)  
   11.92 +
   11.93 +lemma inFr_inFr2:
   11.94 +"inFr = inFr2"
   11.95 +apply (rule ext)+  apply(safe)
   11.96 +  apply(erule inFr.induct)
   11.97 +    apply (metis (lifting) inFr2.Base)
   11.98 +    apply (metis (lifting) inFr2_Ind) 
   11.99 +  apply(erule inFr2.induct)
  11.100 +    apply (metis (lifting) inFr.Base)
  11.101 +    apply (metis (lifting) inFr_Ind_minus)
  11.102 +done  
  11.103 +
  11.104 +lemma not_root_inFr:
  11.105 +assumes "root tr \<notin> ns"
  11.106 +shows "\<not> inFr ns tr t"
  11.107 +by (metis assms inFr_root_in)
  11.108 +
  11.109 +theorem not_root_Fr:
  11.110 +assumes "root tr \<notin> ns"
  11.111 +shows "Fr ns tr = {}"
  11.112 +using not_root_inFr[OF assms] unfolding Fr_def by auto 
  11.113 +
  11.114 +
  11.115 +(* Interior *)
  11.116 +
  11.117 +inductive inItr :: "N set \<Rightarrow> Tree \<Rightarrow> N \<Rightarrow> bool" where 
  11.118 +Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
  11.119 +|
  11.120 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
  11.121 +
  11.122 +definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
  11.123 +
  11.124 +lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
  11.125 +by (metis inItr.simps) 
  11.126 +
  11.127 +lemma inItr_mono: 
  11.128 +assumes "inItr ns tr n" and "ns \<subseteq> ns'"
  11.129 +shows "inItr ns' tr n"
  11.130 +using assms apply(induct arbitrary: ns' rule: inItr.induct)
  11.131 +using Base Ind by (metis inItr.simps set_mp)+
  11.132 +
  11.133 +
  11.134 +(* The subtree relation *)  
  11.135 +
  11.136 +inductive subtr where 
  11.137 +Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
  11.138 +|
  11.139 +Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
  11.140 +
  11.141 +lemma subtr_rootL_in: 
  11.142 +assumes "subtr ns tr1 tr2"
  11.143 +shows "root tr1 \<in> ns"
  11.144 +using assms apply(induct rule: subtr.induct) by auto
  11.145 +
  11.146 +lemma subtr_rootR_in: 
  11.147 +assumes "subtr ns tr1 tr2"
  11.148 +shows "root tr2 \<in> ns"
  11.149 +using assms apply(induct rule: subtr.induct) by auto
  11.150 +
  11.151 +lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
  11.152 +
  11.153 +lemma subtr_mono: 
  11.154 +assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
  11.155 +shows "subtr ns' tr1 tr2"
  11.156 +using assms apply(induct arbitrary: ns' rule: subtr.induct)
  11.157 +using Refl Step by (metis subtr.simps set_mp)+
  11.158 +
  11.159 +lemma subtr_trans_Un:
  11.160 +assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
  11.161 +shows "subtr (ns12 \<union> ns23) tr1 tr3"
  11.162 +proof-
  11.163 +  have "subtr ns23 tr2 tr3  \<Longrightarrow> 
  11.164 +        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
  11.165 +  apply(induct  rule: subtr.induct, safe)
  11.166 +    apply (metis subtr_mono sup_commute sup_ge2)
  11.167 +    by (metis (lifting) Step UnI2) 
  11.168 +  thus ?thesis using assms by auto
  11.169 +qed
  11.170 +
  11.171 +lemma subtr_trans:
  11.172 +assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
  11.173 +shows "subtr ns tr1 tr3"
  11.174 +using subtr_trans_Un[OF assms] by simp
  11.175 +
  11.176 +lemma subtr_StepL: 
  11.177 +assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
  11.178 +shows "subtr ns tr1 tr3"
  11.179 +apply(rule subtr_trans[OF _ s]) apply(rule Step[of tr2 ns tr1 tr1])
  11.180 +by (metis assms subtr_rootL_in Refl)+
  11.181 +
  11.182 +(* alternative definition: *)
  11.183 +inductive subtr2 where 
  11.184 +Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
  11.185 +|
  11.186 +Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
  11.187 +
  11.188 +lemma subtr2_rootL_in: 
  11.189 +assumes "subtr2 ns tr1 tr2"
  11.190 +shows "root tr1 \<in> ns"
  11.191 +using assms apply(induct rule: subtr2.induct) by auto
  11.192 +
  11.193 +lemma subtr2_rootR_in: 
  11.194 +assumes "subtr2 ns tr1 tr2"
  11.195 +shows "root tr2 \<in> ns"
  11.196 +using assms apply(induct rule: subtr2.induct) by auto
  11.197 +
  11.198 +lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
  11.199 +
  11.200 +lemma subtr2_mono: 
  11.201 +assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
  11.202 +shows "subtr2 ns' tr1 tr2"
  11.203 +using assms apply(induct arbitrary: ns' rule: subtr2.induct)
  11.204 +using Refl Step by (metis subtr2.simps set_mp)+
  11.205 +
  11.206 +lemma subtr2_trans_Un:
  11.207 +assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
  11.208 +shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
  11.209 +proof-
  11.210 +  have "subtr2 ns12 tr1 tr2  \<Longrightarrow> 
  11.211 +        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
  11.212 +  apply(induct  rule: subtr2.induct, safe)
  11.213 +    apply (metis subtr2_mono sup_commute sup_ge2)
  11.214 +    by (metis Un_iff subtr2.simps)
  11.215 +  thus ?thesis using assms by auto
  11.216 +qed
  11.217 +
  11.218 +lemma subtr2_trans:
  11.219 +assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
  11.220 +shows "subtr2 ns tr1 tr3"
  11.221 +using subtr2_trans_Un[OF assms] by simp
  11.222 +
  11.223 +lemma subtr2_StepR: 
  11.224 +assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
  11.225 +shows "subtr2 ns tr1 tr3"
  11.226 +apply(rule subtr2_trans[OF s]) apply(rule Step[of _ _ tr3])
  11.227 +by (metis assms subtr2_rootR_in Refl)+
  11.228 +
  11.229 +lemma subtr_subtr2:
  11.230 +"subtr = subtr2"
  11.231 +apply (rule ext)+  apply(safe)
  11.232 +  apply(erule subtr.induct)
  11.233 +    apply (metis (lifting) subtr2.Refl)
  11.234 +    apply (metis (lifting) subtr2_StepR) 
  11.235 +  apply(erule subtr2.induct)
  11.236 +    apply (metis (lifting) subtr.Refl)
  11.237 +    apply (metis (lifting) subtr_StepL)
  11.238 +done
  11.239 +
  11.240 +lemma subtr_inductL[consumes 1, case_names Refl Step]:
  11.241 +assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
  11.242 +and Step: 
  11.243 +"\<And>ns tr1 tr2 tr3. 
  11.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"
  11.245 +shows "\<phi> ns tr1 tr2"
  11.246 +using s unfolding subtr_subtr2 apply(rule subtr2.induct)
  11.247 +using Refl Step unfolding subtr_subtr2 by auto
  11.248 +
  11.249 +lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
  11.250 +assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
  11.251 +and Step: 
  11.252 +"\<And>tr1 tr2 tr3. 
  11.253 +   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
  11.254 +shows "\<phi> tr1 tr2"
  11.255 +using s apply(induct rule: subtr_inductL)
  11.256 +apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
  11.257 +
  11.258 +(* Subtree versus frontier: *)
  11.259 +lemma subtr_inFr:
  11.260 +assumes "inFr ns tr t" and "subtr ns tr tr1" 
  11.261 +shows "inFr ns tr1 t"
  11.262 +proof-
  11.263 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
  11.264 +  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
  11.265 +  thus ?thesis using assms by auto
  11.266 +qed
  11.267 +
  11.268 +corollary Fr_subtr: 
  11.269 +"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
  11.270 +unfolding Fr_def proof safe
  11.271 +  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)  
  11.272 +  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
  11.273 +  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
  11.274 +qed(metis subtr_inFr)
  11.275 +
  11.276 +lemma inFr_subtr:
  11.277 +assumes "inFr ns tr t" 
  11.278 +shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
  11.279 +using assms apply(induct rule: inFr.induct) apply safe
  11.280 +  apply (metis subtr.Refl)
  11.281 +  by (metis (lifting) subtr.Step)
  11.282 +
  11.283 +corollary Fr_subtr_cont: 
  11.284 +"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
  11.285 +unfolding Fr_def
  11.286 +apply safe
  11.287 +apply (frule inFr_subtr)
  11.288 +apply auto
  11.289 +by (metis inFr.Base subtr_inFr subtr_rootL_in)
  11.290 +
  11.291 +(* Subtree versus interior: *)
  11.292 +lemma subtr_inItr:
  11.293 +assumes "inItr ns tr n" and "subtr ns tr tr1" 
  11.294 +shows "inItr ns tr1 n"
  11.295 +proof-
  11.296 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
  11.297 +  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
  11.298 +  thus ?thesis using assms by auto
  11.299 +qed
  11.300 +
  11.301 +corollary Itr_subtr: 
  11.302 +"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
  11.303 +unfolding Itr_def apply safe
  11.304 +apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
  11.305 +by (metis subtr_inItr)
  11.306 +
  11.307 +lemma inItr_subtr:
  11.308 +assumes "inItr ns tr n" 
  11.309 +shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
  11.310 +using assms apply(induct rule: inItr.induct) apply safe
  11.311 +  apply (metis subtr.Refl)
  11.312 +  by (metis (lifting) subtr.Step)
  11.313 +
  11.314 +corollary Itr_subtr_cont: 
  11.315 +"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
  11.316 +unfolding Itr_def apply safe
  11.317 +  apply (metis (lifting, mono_tags) UnionI inItr_subtr mem_Collect_eq vimageI2)
  11.318 +  by (metis inItr.Base subtr_inItr subtr_rootL_in)
  11.319 +
  11.320 +
  11.321 +subsection{* The immediate subtree function *}
  11.322 +
  11.323 +(* production of: *)
  11.324 +abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
  11.325 +(* subtree of: *)
  11.326 +definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
  11.327 +
  11.328 +lemma subtrOf: 
  11.329 +assumes n: "Inr n \<in> prodOf tr"
  11.330 +shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
  11.331 +proof-
  11.332 +  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
  11.333 +  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
  11.334 +  thus ?thesis unfolding subtrOf_def by(rule someI)
  11.335 +qed
  11.336 +
  11.337 +lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
  11.338 +lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
  11.339 +
  11.340 +lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
  11.341 +proof safe
  11.342 +  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
  11.343 +  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
  11.344 +next
  11.345 +  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
  11.346 +  by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
  11.347 +qed
  11.348 +
  11.349 +lemma root_prodOf:
  11.350 +assumes "Inr tr' \<in> cont tr"
  11.351 +shows "Inr (root tr') \<in> prodOf tr"
  11.352 +by (metis (lifting) assms image_iff sum_map.simps(2))
  11.353 +
  11.354 +
  11.355 +subsection{* Derivation trees *}  
  11.356 +
  11.357 +coinductive dtree where 
  11.358 +Tree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
  11.359 +        lift dtree (cont tr)\<rbrakk> \<Longrightarrow> dtree tr"
  11.360 +monos lift_mono
  11.361 +
  11.362 +(* destruction rules: *)
  11.363 +lemma dtree_P: 
  11.364 +assumes "dtree tr"
  11.365 +shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
  11.366 +using assms unfolding dtree.simps by auto
  11.367 +
  11.368 +lemma dtree_inj_on: 
  11.369 +assumes "dtree tr"
  11.370 +shows "inj_on root (Inr -` cont tr)"
  11.371 +using assms unfolding dtree.simps by auto
  11.372 +
  11.373 +lemma dtree_inj[simp]: 
  11.374 +assumes "dtree tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
  11.375 +shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
  11.376 +using assms dtree_inj_on unfolding inj_on_def by auto
  11.377 +
  11.378 +lemma dtree_lift: 
  11.379 +assumes "dtree tr"
  11.380 +shows "lift dtree (cont tr)"
  11.381 +using assms unfolding dtree.simps by auto
  11.382 +
  11.383 +
  11.384 +(* coinduction:*)
  11.385 +lemma dtree_coind[elim, consumes 1, case_names Hyp]: 
  11.386 +assumes phi: "\<phi> tr"
  11.387 +and Hyp: 
  11.388 +"\<And> tr. \<phi> tr \<Longrightarrow> 
  11.389 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and> 
  11.390 +       inj_on root (Inr -` cont tr) \<and> 
  11.391 +       lift (\<lambda> tr. \<phi> tr \<or> dtree tr) (cont tr)"
  11.392 +shows "dtree tr"
  11.393 +apply(rule dtree.coinduct[of \<phi> tr, OF phi]) 
  11.394 +using Hyp by blast
  11.395 +
  11.396 +lemma dtree_raw_coind[elim, consumes 1, case_names Hyp]: 
  11.397 +assumes phi: "\<phi> tr"
  11.398 +and Hyp: 
  11.399 +"\<And> tr. \<phi> tr \<Longrightarrow> 
  11.400 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
  11.401 +       inj_on root (Inr -` cont tr) \<and> 
  11.402 +       lift \<phi> (cont tr)"
  11.403 +shows "dtree tr"
  11.404 +using phi apply(induct rule: dtree_coind)
  11.405 +using Hyp mono_lift 
  11.406 +by (metis (mono_tags) mono_lift)
  11.407 +
  11.408 +lemma dtree_subtr_inj_on: 
  11.409 +assumes d: "dtree tr1" and s: "subtr ns tr tr1"
  11.410 +shows "inj_on root (Inr -` cont tr)"
  11.411 +using s d apply(induct rule: subtr.induct)
  11.412 +apply (metis (lifting) dtree_inj_on) by (metis dtree_lift lift_def)
  11.413 +
  11.414 +lemma dtree_subtr_P: 
  11.415 +assumes d: "dtree tr1" and s: "subtr ns tr tr1"
  11.416 +shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
  11.417 +using s d apply(induct rule: subtr.induct)
  11.418 +apply (metis (lifting) dtree_P) by (metis dtree_lift lift_def)
  11.419 +
  11.420 +lemma subtrOf_root[simp]:
  11.421 +assumes tr: "dtree tr" and cont: "Inr tr' \<in> cont tr"
  11.422 +shows "subtrOf tr (root tr') = tr'"
  11.423 +proof-
  11.424 +  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
  11.425 +  by (metis (lifting) cont root_prodOf)
  11.426 +  have "root (subtrOf tr (root tr')) = root tr'"
  11.427 +  using root_subtrOf by (metis (lifting) cont root_prodOf)
  11.428 +  thus ?thesis unfolding dtree_inj[OF tr 0 cont] .
  11.429 +qed
  11.430 +
  11.431 +lemma surj_subtrOf: 
  11.432 +assumes "dtree tr" and 0: "Inr tr' \<in> cont tr"
  11.433 +shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
  11.434 +apply(rule exI[of _ "root tr'"]) 
  11.435 +using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
  11.436 +
  11.437 +lemma dtree_subtr: 
  11.438 +assumes "dtree tr1" and "subtr ns tr tr1"
  11.439 +shows "dtree tr" 
  11.440 +proof-
  11.441 +  have "(\<exists> ns tr1. dtree tr1 \<and> subtr ns tr tr1) \<Longrightarrow> dtree tr"
  11.442 +  proof (induct rule: dtree_raw_coind)
  11.443 +    case (Hyp tr)
  11.444 +    then obtain ns tr1 where tr1: "dtree tr1" and tr_tr1: "subtr ns tr tr1" by auto
  11.445 +    show ?case unfolding lift_def proof safe
  11.446 +      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using dtree_subtr_P[OF tr1 tr_tr1] .
  11.447 +    next 
  11.448 +      show "inj_on root (Inr -` cont tr)" using dtree_subtr_inj_on[OF tr1 tr_tr1] .
  11.449 +    next
  11.450 +      fix tr' assume tr': "Inr tr' \<in> cont tr"
  11.451 +      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
  11.452 +      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
  11.453 +      thus "\<exists>ns' tr1. dtree tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
  11.454 +    qed
  11.455 +  qed
  11.456 +  thus ?thesis using assms by auto
  11.457 +qed
  11.458 +
  11.459 +
  11.460 +subsection{* Default trees *}
  11.461 +
  11.462 +(* Pick a left-hand side of a production for each nonterminal *)
  11.463 +definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
  11.464 +
  11.465 +lemma S_P: "(n, S n) \<in> P"
  11.466 +using used unfolding S_def by(rule someI_ex)
  11.467 +
  11.468 +lemma finite_S: "finite (S n)"
  11.469 +using S_P finite_in_P by auto 
  11.470 +
  11.471 +
  11.472 +(* The default tree of a nonterminal *)
  11.473 +definition deftr :: "N \<Rightarrow> Tree" where  
  11.474 +"deftr \<equiv> coit id S"
  11.475 +
  11.476 +lemma deftr_simps[simp]:
  11.477 +"root (deftr n) = n" 
  11.478 +"cont (deftr n) = image (id \<oplus> deftr) (S n)"
  11.479 +using coit(1)[of id S n] coit(2)[of S n id, OF finite_S] 
  11.480 +unfolding deftr_def by simp_all
  11.481 +
  11.482 +lemmas root_deftr = deftr_simps(1)
  11.483 +lemmas cont_deftr = deftr_simps(2)
  11.484 +
  11.485 +lemma root_o_deftr[simp]: "root o deftr = id"
  11.486 +by (rule ext, auto)
  11.487 +
  11.488 +lemma dtree_deftr: "dtree (deftr n)"
  11.489 +proof-
  11.490 +  {fix tr assume "\<exists> n. tr = deftr n" hence "dtree tr"
  11.491 +   apply(induct rule: dtree_raw_coind) apply safe
  11.492 +   unfolding deftr_simps image_compose[symmetric] sum_map.comp id_o
  11.493 +   root_o_deftr sum_map.id image_id id_apply apply(rule S_P) 
  11.494 +   unfolding inj_on_def lift_def by auto   
  11.495 +  }
  11.496 +  thus ?thesis by auto
  11.497 +qed
  11.498 +
  11.499 +
  11.500 +subsection{* Hereditary substitution *}
  11.501 +
  11.502 +(* Auxiliary concept: The root-ommiting frontier: *)
  11.503 +definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
  11.504 +definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
  11.505 +
  11.506 +context 
  11.507 +fixes tr0 :: Tree 
  11.508 +begin
  11.509 +
  11.510 +definition "hsubst_r tr \<equiv> root tr"
  11.511 +definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
  11.512 +
  11.513 +(* Hereditary substitution: *)
  11.514 +definition hsubst :: "Tree \<Rightarrow> Tree" where  
  11.515 +"hsubst \<equiv> coit hsubst_r hsubst_c"
  11.516 +
  11.517 +lemma finite_hsubst_c: "finite (hsubst_c n)"
  11.518 +unfolding hsubst_c_def by (metis finite_cont) 
  11.519 +
  11.520 +lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
  11.521 +using coit(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
  11.522 +
  11.523 +lemma root_o_subst[simp]: "root o hsubst = root"
  11.524 +unfolding comp_def root_hsubst ..
  11.525 +
  11.526 +lemma cont_hsubst_eq[simp]:
  11.527 +assumes "root tr = root tr0"
  11.528 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
  11.529 +apply(subst id_o[symmetric, of id]) unfolding id_o
  11.530 +using coit(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c] 
  11.531 +unfolding hsubst_def hsubst_c_def using assms by simp
  11.532 +
  11.533 +lemma hsubst_eq:
  11.534 +assumes "root tr = root tr0"
  11.535 +shows "hsubst tr = hsubst tr0" 
  11.536 +apply(rule Tree_cong) using assms cont_hsubst_eq by auto
  11.537 +
  11.538 +lemma cont_hsubst_neq[simp]:
  11.539 +assumes "root tr \<noteq> root tr0"
  11.540 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
  11.541 +apply(subst id_o[symmetric, of id]) unfolding id_o
  11.542 +using coit(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c] 
  11.543 +unfolding hsubst_def hsubst_c_def using assms by simp
  11.544 +
  11.545 +lemma Inl_cont_hsubst_eq[simp]:
  11.546 +assumes "root tr = root tr0"
  11.547 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
  11.548 +unfolding cont_hsubst_eq[OF assms] by simp
  11.549 +
  11.550 +lemma Inr_cont_hsubst_eq[simp]:
  11.551 +assumes "root tr = root tr0"
  11.552 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
  11.553 +unfolding cont_hsubst_eq[OF assms] by simp
  11.554 +
  11.555 +lemma Inl_cont_hsubst_neq[simp]:
  11.556 +assumes "root tr \<noteq> root tr0"
  11.557 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
  11.558 +unfolding cont_hsubst_neq[OF assms] by simp
  11.559 +
  11.560 +lemma Inr_cont_hsubst_neq[simp]:
  11.561 +assumes "root tr \<noteq> root tr0"
  11.562 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
  11.563 +unfolding cont_hsubst_neq[OF assms] by simp  
  11.564 +
  11.565 +lemma dtree_hsubst:
  11.566 +assumes tr0: "dtree tr0" and tr: "dtree tr"
  11.567 +shows "dtree (hsubst tr)"
  11.568 +proof-
  11.569 +  {fix tr1 have "(\<exists> tr. dtree tr \<and> tr1 = hsubst tr) \<Longrightarrow> dtree tr1" 
  11.570 +   proof (induct rule: dtree_raw_coind)
  11.571 +     case (Hyp tr1) then obtain tr 
  11.572 +     where dtr: "dtree tr" and tr1: "tr1 = hsubst tr" by auto
  11.573 +     show ?case unfolding lift_def tr1 proof safe
  11.574 +       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
  11.575 +       unfolding tr1 apply(cases "root tr = root tr0") 
  11.576 +       using  dtree_P[OF dtr] dtree_P[OF tr0] 
  11.577 +       by (auto simp add: image_compose[symmetric] sum_map.comp)
  11.578 +       show "inj_on root (Inr -` cont (hsubst tr))" 
  11.579 +       apply(cases "root tr = root tr0") using dtree_inj_on[OF dtr] dtree_inj_on[OF tr0] 
  11.580 +       unfolding inj_on_def by (auto, blast)
  11.581 +       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
  11.582 +       thus "\<exists>tra. dtree tra \<and> tr' = hsubst tra"
  11.583 +       apply(cases "root tr = root tr0", simp_all)
  11.584 +         apply (metis dtree_lift lift_def tr0)
  11.585 +         by (metis dtr dtree_lift lift_def)
  11.586 +     qed
  11.587 +   qed
  11.588 +  }
  11.589 +  thus ?thesis using assms by blast
  11.590 +qed 
  11.591 +
  11.592 +lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
  11.593 +unfolding inFrr_def Frr_def Fr_def by auto
  11.594 +
  11.595 +lemma inFr_hsubst_imp: 
  11.596 +assumes "inFr ns (hsubst tr) t"
  11.597 +shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or> 
  11.598 +       inFr (ns - {root tr0}) tr t"
  11.599 +proof-
  11.600 +  {fix tr1 
  11.601 +   have "inFr ns tr1 t \<Longrightarrow> 
  11.602 +   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or> 
  11.603 +                              inFr (ns - {root tr0}) tr t))"
  11.604 +   proof(induct rule: inFr.induct)
  11.605 +     case (Base tr1 ns t tr)
  11.606 +     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
  11.607 +     by auto
  11.608 +     show ?case
  11.609 +     proof(cases "root tr1 = root tr0")
  11.610 +       case True
  11.611 +       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
  11.612 +       thus ?thesis by simp
  11.613 +     next
  11.614 +       case False
  11.615 +       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
  11.616 +       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
  11.617 +       thus ?thesis by simp
  11.618 +     qed
  11.619 +   next
  11.620 +     case (Ind tr1 ns tr1' t) note IH = Ind(4)
  11.621 +     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
  11.622 +     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
  11.623 +     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
  11.624 +     show ?case
  11.625 +     proof(cases "root tr1 = root tr0")
  11.626 +       case True
  11.627 +       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
  11.628 +       using tr1'_tr1 unfolding tr1 by auto
  11.629 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  11.630 +         assume "inFr (ns - {root tr0}) tr' t"         
  11.631 +         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
  11.632 +       qed auto
  11.633 +     next
  11.634 +       case False 
  11.635 +       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
  11.636 +       using tr1'_tr1 unfolding tr1 by auto
  11.637 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  11.638 +         assume "inFr (ns - {root tr0}) tr' t"         
  11.639 +         thus ?thesis using tr'_tr unfolding inFrr_def
  11.640 +         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1) 
  11.641 +       qed auto
  11.642 +     qed
  11.643 +   qed
  11.644 +  }
  11.645 +  thus ?thesis using assms by auto
  11.646 +qed 
  11.647 +
  11.648 +lemma inFr_hsubst_notin:
  11.649 +assumes "inFr ns tr t" and "root tr0 \<notin> ns" 
  11.650 +shows "inFr ns (hsubst tr) t"
  11.651 +using assms apply(induct rule: inFr.induct)
  11.652 +apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
  11.653 +by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
  11.654 +
  11.655 +lemma inFr_hsubst_minus:
  11.656 +assumes "inFr (ns - {root tr0}) tr t"
  11.657 +shows "inFr ns (hsubst tr) t"
  11.658 +proof-
  11.659 +  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
  11.660 +  using inFr_hsubst_notin[OF assms] by simp
  11.661 +  show ?thesis using inFr_mono[OF 1] by auto
  11.662 +qed
  11.663 +
  11.664 +lemma inFr_self_hsubst: 
  11.665 +assumes "root tr0 \<in> ns"
  11.666 +shows 
  11.667 +"inFr ns (hsubst tr0) t \<longleftrightarrow> 
  11.668 + t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
  11.669 +(is "?A \<longleftrightarrow> ?B \<or> ?C")
  11.670 +apply(intro iffI)
  11.671 +apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
  11.672 +  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
  11.673 +next
  11.674 +  assume ?C then obtain tr where 
  11.675 +  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"  
  11.676 +  unfolding inFrr_def by auto
  11.677 +  def tr1 \<equiv> "hsubst tr"
  11.678 +  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
  11.679 +  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
  11.680 +  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
  11.681 +qed
  11.682 +
  11.683 +theorem Fr_self_hsubst: 
  11.684 +assumes "root tr0 \<in> ns"
  11.685 +shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
  11.686 +using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
  11.687 +
  11.688 +end (* context *)
  11.689 +  
  11.690 +
  11.691 +subsection{* Regular trees *}
  11.692 +
  11.693 +hide_const regular
  11.694 +
  11.695 +definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
  11.696 +definition "regular tr \<equiv> \<exists> f. reg f tr"
  11.697 +
  11.698 +lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
  11.699 +unfolding reg_def using subtr_mono by (metis subset_UNIV) 
  11.700 +
  11.701 +lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
  11.702 +unfolding regular_def proof safe
  11.703 +  fix f assume f: "reg f tr"
  11.704 +  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
  11.705 +  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
  11.706 +  apply(rule exI[of _ g])
  11.707 +  using f deftr_simps(1) unfolding g_def reg_def apply safe
  11.708 +    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
  11.709 +    by (metis (full_types) inItr_subtr subtr_subtr2)
  11.710 +qed auto
  11.711 +
  11.712 +lemma reg_root: 
  11.713 +assumes "reg f tr"
  11.714 +shows "f (root tr) = tr"
  11.715 +using assms unfolding reg_def
  11.716 +by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
  11.717 +
  11.718 +
  11.719 +lemma reg_Inr_cont: 
  11.720 +assumes "reg f tr" and "Inr tr' \<in> cont tr"
  11.721 +shows "reg f tr'"
  11.722 +by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
  11.723 +
  11.724 +lemma reg_subtr: 
  11.725 +assumes "reg f tr" and "subtr ns tr' tr"
  11.726 +shows "reg f tr'"
  11.727 +using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
  11.728 +by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
  11.729 +
  11.730 +lemma regular_subtr: 
  11.731 +assumes r: "regular tr" and s: "subtr ns tr' tr"
  11.732 +shows "regular tr'"
  11.733 +using r reg_subtr[OF _ s] unfolding regular_def by auto
  11.734 +
  11.735 +lemma subtr_deftr: 
  11.736 +assumes "subtr ns tr' (deftr n)"
  11.737 +shows "tr' = deftr (root tr')"
  11.738 +proof-
  11.739 +  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
  11.740 +   apply (induct rule: subtr.induct)
  11.741 +   proof(metis (lifting) deftr_simps(1), safe) 
  11.742 +     fix tr3 ns tr1 tr2 n
  11.743 +     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
  11.744 +     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)" 
  11.745 +     and 3: "Inr tr2 \<in> cont (deftr n)"
  11.746 +     have "tr2 \<in> deftr ` UNIV" 
  11.747 +     using 3 unfolding deftr_simps image_def
  11.748 +     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr 
  11.749 +         iso_tuple_UNIV_I)
  11.750 +     then obtain n where "tr2 = deftr n" by auto
  11.751 +     thus "tr1 = deftr (root tr1)" using IH by auto
  11.752 +   qed 
  11.753 +  }
  11.754 +  thus ?thesis using assms by auto
  11.755 +qed
  11.756 +
  11.757 +lemma reg_deftr: "reg deftr (deftr n)"
  11.758 +unfolding reg_def using subtr_deftr by auto
  11.759 +
  11.760 +lemma dtree_subtrOf_Union: 
  11.761 +assumes "dtree tr" 
  11.762 +shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
  11.763 +       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
  11.764 +unfolding Union_eq Bex_def mem_Collect_eq proof safe
  11.765 +  fix x xa tr'
  11.766 +  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
  11.767 +  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
  11.768 +  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
  11.769 +    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
  11.770 +    by (metis (lifting) assms subtrOf_root tr'_tr x)
  11.771 +next
  11.772 +  fix x X n ttr
  11.773 +  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
  11.774 +  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
  11.775 +  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
  11.776 +    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
  11.777 +    using x .
  11.778 +qed
  11.779 +
  11.780 +
  11.781 +
  11.782 +
  11.783 +subsection {* Paths in a regular tree *}
  11.784 +
  11.785 +inductive path :: "(N \<Rightarrow> Tree) \<Rightarrow> N list \<Rightarrow> bool" for f where 
  11.786 +Base: "path f [n]"
  11.787 +|
  11.788 +Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk> 
  11.789 +      \<Longrightarrow> path f (n # n1 # nl)"
  11.790 +
  11.791 +lemma path_NE: 
  11.792 +assumes "path f nl"  
  11.793 +shows "nl \<noteq> Nil" 
  11.794 +using assms apply(induct rule: path.induct) by auto
  11.795 +
  11.796 +lemma path_post: 
  11.797 +assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
  11.798 +shows "path f nl"
  11.799 +proof-
  11.800 +  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
  11.801 +  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject) 
  11.802 +qed
  11.803 +
  11.804 +lemma path_post_concat: 
  11.805 +assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
  11.806 +shows "path f nl2"
  11.807 +using assms apply (induct nl1)
  11.808 +apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
  11.809 +
  11.810 +lemma path_concat: 
  11.811 +assumes "path f nl1" and "path f ((last nl1) # nl2)"
  11.812 +shows "path f (nl1 @ nl2)"
  11.813 +using assms apply(induct rule: path.induct) apply simp
  11.814 +by (metis append_Cons last.simps list.simps(3) path.Ind) 
  11.815 +
  11.816 +lemma path_distinct:
  11.817 +assumes "path f nl"
  11.818 +shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and> 
  11.819 +              set nl' \<subseteq> set nl \<and> distinct nl'"
  11.820 +using assms proof(induct rule: length_induct)
  11.821 +  case (1 nl)  hence p_nl: "path f nl" by simp
  11.822 +  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE) 
  11.823 +  show ?case
  11.824 +  proof(cases nl1)
  11.825 +    case Nil
  11.826 +    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
  11.827 +  next
  11.828 +    case (Cons n1 nl2)  
  11.829 +    hence p1: "path f nl1" by (metis list.simps nl p_nl path_post)
  11.830 +    show ?thesis
  11.831 +    proof(cases "n \<in> set nl1")
  11.832 +      case False
  11.833 +      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and 
  11.834 +      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'" 
  11.835 +      and s_nl1': "set nl1' \<subseteq> set nl1"
  11.836 +      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
  11.837 +      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
  11.838 +      unfolding Cons by(cases nl1', auto)
  11.839 +      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
  11.840 +        show "path f (n # nl1')" unfolding nl1' 
  11.841 +        apply(rule path.Ind, metis nl1' p1')
  11.842 +        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
  11.843 +      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
  11.844 +    next
  11.845 +      case True
  11.846 +      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12" 
  11.847 +      by (metis split_list) 
  11.848 +      have p12: "path f (n # nl12)" 
  11.849 +      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
  11.850 +      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and 
  11.851 +      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'" 
  11.852 +      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
  11.853 +      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
  11.854 +      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
  11.855 +    qed
  11.856 +  qed
  11.857 +qed
  11.858 +
  11.859 +lemma path_subtr: 
  11.860 +assumes f: "\<And> n. root (f n) = n"
  11.861 +and p: "path f nl"
  11.862 +shows "subtr (set nl) (f (last nl)) (f (hd nl))"
  11.863 +using p proof (induct rule: path.induct)
  11.864 +  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
  11.865 +  have "path f (n1 # nl)"
  11.866 +  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
  11.867 +  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
  11.868 +  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
  11.869 +  by (metis subset_insertI subtr_mono) 
  11.870 +  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
  11.871 +  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)" 
  11.872 +  using f subtr.Step[OF _ fn1_flast fn1] by auto 
  11.873 +  thus ?case unfolding 1 by simp 
  11.874 +qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
  11.875 +
  11.876 +lemma reg_subtr_path_aux:
  11.877 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  11.878 +shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  11.879 +using n f proof(induct rule: subtr.induct)
  11.880 +  case (Refl tr ns)
  11.881 +  thus ?case
  11.882 +  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
  11.883 +next
  11.884 +  case (Step tr ns tr2 tr1)
  11.885 +  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr" 
  11.886 +  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
  11.887 +  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
  11.888 +  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
  11.889 +  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1" 
  11.890 +  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
  11.891 +  have 0: "path f (root tr # nl)" apply (subst path.simps)
  11.892 +  using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv) 
  11.893 +  show ?case apply(rule exI[of _ "(root tr) # nl"])
  11.894 +  using 0 reg_root tr last_nl nl path_NE rtr set by auto
  11.895 +qed 
  11.896 +
  11.897 +lemma reg_subtr_path:
  11.898 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  11.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"
  11.900 +using reg_subtr_path_aux[OF assms] path_distinct[of f]
  11.901 +by (metis (lifting) order_trans)
  11.902 +
  11.903 +lemma subtr_iff_path:
  11.904 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  11.905 +shows "subtr ns tr1 tr \<longleftrightarrow> 
  11.906 +       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
  11.907 +proof safe
  11.908 +  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
  11.909 +  have "subtr (set nl) (f (last nl)) (f (hd nl))"
  11.910 +  apply(rule path_subtr) using p f by simp_all
  11.911 +  thus "subtr ns (f (last nl)) (f (hd nl))"
  11.912 +  using subtr_mono nl by auto
  11.913 +qed(insert reg_subtr_path[OF r], auto)
  11.914 +
  11.915 +lemma inFr_iff_path:
  11.916 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  11.917 +shows 
  11.918 +"inFr ns tr t \<longleftrightarrow> 
  11.919 + (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> 
  11.920 +            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)" 
  11.921 +apply safe
  11.922 +apply (metis (no_types) inFr_subtr r reg_subtr_path)
  11.923 +by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
  11.924 +
  11.925 +
  11.926 +
  11.927 +subsection{* The regular cut of a tree *}
  11.928 +
  11.929 +context fixes tr0 :: Tree
  11.930 +begin
  11.931 +
  11.932 +(* Picking a subtree of a certain root: *)
  11.933 +definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n" 
  11.934 +
  11.935 +lemma pick:
  11.936 +assumes "inItr UNIV tr0 n"
  11.937 +shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
  11.938 +proof-
  11.939 +  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n" 
  11.940 +  using assms by (metis (lifting) inItr_subtr)
  11.941 +  thus ?thesis unfolding pick_def by(rule someI_ex)
  11.942 +qed 
  11.943 +
  11.944 +lemmas subtr_pick = pick[THEN conjunct1]
  11.945 +lemmas root_pick = pick[THEN conjunct2]
  11.946 +
  11.947 +lemma dtree_pick:
  11.948 +assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n" 
  11.949 +shows "dtree (pick n)"
  11.950 +using dtree_subtr[OF tr0 subtr_pick[OF n]] .
  11.951 +
  11.952 +definition "regOf_r n \<equiv> root (pick n)"
  11.953 +definition "regOf_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
  11.954 +
  11.955 +(* The regular tree of a function: *)
  11.956 +definition regOf :: "N \<Rightarrow> Tree" where  
  11.957 +"regOf \<equiv> coit regOf_r regOf_c"
  11.958 +
  11.959 +lemma finite_regOf_c: "finite (regOf_c n)"
  11.960 +unfolding regOf_c_def by (metis finite_cont finite_imageI) 
  11.961 +
  11.962 +lemma root_regOf_pick: "root (regOf n) = root (pick n)"
  11.963 +using coit(1)[of regOf_r regOf_c n] unfolding regOf_def regOf_r_def by simp
  11.964 +
  11.965 +lemma root_regOf[simp]: 
  11.966 +assumes "inItr UNIV tr0 n"
  11.967 +shows "root (regOf n) = n"
  11.968 +unfolding root_regOf_pick root_pick[OF assms] ..
  11.969 +
  11.970 +lemma cont_regOf[simp]: 
  11.971 +"cont (regOf n) = (id \<oplus> (regOf o root)) ` cont (pick n)"
  11.972 +apply(subst id_o[symmetric, of id]) unfolding sum_map.comp[symmetric]
  11.973 +unfolding image_compose unfolding regOf_c_def[symmetric]
  11.974 +using coit(2)[of regOf_c n regOf_r, OF finite_regOf_c] 
  11.975 +unfolding regOf_def ..
  11.976 +
  11.977 +lemma Inl_cont_regOf[simp]:
  11.978 +"Inl -` (cont (regOf n)) = Inl -` (cont (pick n))" 
  11.979 +unfolding cont_regOf by simp
  11.980 +
  11.981 +lemma Inr_cont_regOf:
  11.982 +"Inr -` (cont (regOf n)) = (regOf \<circ> root) ` (Inr -` cont (pick n))"
  11.983 +unfolding cont_regOf by simp
  11.984 +
  11.985 +lemma subtr_regOf: 
  11.986 +assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (regOf n)"
  11.987 +shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1"
  11.988 +proof-
  11.989 +  {fix tr ns assume "subtr UNIV tr1 tr"
  11.990 +   hence "tr = regOf n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1)"
  11.991 +   proof (induct rule: subtr_UNIV_inductL) 
  11.992 +     case (Step tr2 tr1 tr) 
  11.993 +     show ?case proof
  11.994 +       assume "tr = regOf n"
  11.995 +       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
  11.996 +       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = regOf n1"
  11.997 +       using Step by auto
  11.998 +       obtain tr2' where tr2: "tr2 = regOf (root tr2')" 
  11.999 +       and tr2': "Inr tr2' \<in> cont (pick n1)"
 11.1000 +       using tr2 Inr_cont_regOf[of n1] 
 11.1001 +       unfolding tr1 image_def o_def using vimage_eq by auto
 11.1002 +       have "inItr UNIV tr0 (root tr2')" 
 11.1003 +       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
 11.1004 +       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = regOf n2" using tr2 by blast
 11.1005 +     qed
 11.1006 +   qed(insert n, auto)
 11.1007 +  }
 11.1008 +  thus ?thesis using assms by auto
 11.1009 +qed
 11.1010 +
 11.1011 +lemma root_regOf_root: 
 11.1012 +assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
 11.1013 +shows "(id \<oplus> (root \<circ> regOf \<circ> root)) t_tr = (id \<oplus> root) t_tr"
 11.1014 +using assms apply(cases t_tr)
 11.1015 +  apply (metis (lifting) sum_map.simps(1))
 11.1016 +  using pick regOf_def regOf_r_def coit(1) 
 11.1017 +      inItr.Base o_apply subtr_StepL subtr_inItr sum_map.simps(2)
 11.1018 +  by (metis UNIV_I)
 11.1019 +
 11.1020 +lemma regOf_P: 
 11.1021 +assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n" 
 11.1022 +shows "(n, (id \<oplus> root) ` cont (regOf n)) \<in> P" (is "?L \<in> P")
 11.1023 +proof- 
 11.1024 +  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
 11.1025 +  unfolding cont_regOf image_compose[symmetric] sum_map.comp id_o o_assoc
 11.1026 +  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
 11.1027 +  by(rule root_regOf_root[OF n])
 11.1028 +  moreover have "... \<in> P" by (metis (lifting) dtree_pick root_pick dtree_P n tr0) 
 11.1029 +  ultimately show ?thesis by simp
 11.1030 +qed
 11.1031 +
 11.1032 +lemma dtree_regOf:
 11.1033 +assumes tr0: "dtree tr0" and "inItr UNIV tr0 n" 
 11.1034 +shows "dtree (regOf n)"
 11.1035 +proof-
 11.1036 +  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = regOf n \<Longrightarrow> dtree tr" 
 11.1037 +   proof (induct rule: dtree_raw_coind)
 11.1038 +     case (Hyp tr) 
 11.1039 +     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" by auto
 11.1040 +     show ?case unfolding lift_def apply safe
 11.1041 +     apply (metis (lifting) regOf_P root_regOf n tr tr0)
 11.1042 +     unfolding tr Inr_cont_regOf unfolding inj_on_def apply clarsimp using root_regOf 
 11.1043 +     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
 11.1044 +     by (metis n subtr.Refl subtr_StepL subtr_regOf tr UNIV_I)
 11.1045 +   qed   
 11.1046 +  }
 11.1047 +  thus ?thesis using assms by blast
 11.1048 +qed
 11.1049 +
 11.1050 +(* The regular cut of a tree: *)   
 11.1051 +definition "rcut \<equiv> regOf (root tr0)"
 11.1052 +
 11.1053 +theorem reg_rcut: "reg regOf rcut"
 11.1054 +unfolding reg_def rcut_def 
 11.1055 +by (metis inItr.Base root_regOf subtr_regOf UNIV_I) 
 11.1056 +
 11.1057 +lemma rcut_reg:
 11.1058 +assumes "reg regOf tr0" 
 11.1059 +shows "rcut = tr0"
 11.1060 +using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
 11.1061 +
 11.1062 +theorem rcut_eq: "rcut = tr0 \<longleftrightarrow> reg regOf tr0"
 11.1063 +using reg_rcut rcut_reg by metis
 11.1064 +
 11.1065 +theorem regular_rcut: "regular rcut"
 11.1066 +using reg_rcut unfolding regular_def by blast
 11.1067 +
 11.1068 +theorem Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
 11.1069 +proof safe
 11.1070 +  fix t assume "t \<in> Fr UNIV rcut"
 11.1071 +  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (regOf (root tr0))"
 11.1072 +  using Fr_subtr[of UNIV "regOf (root tr0)"] unfolding rcut_def
 11.1073 +  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq) 
 11.1074 +  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" using tr
 11.1075 +  by (metis (lifting) inItr.Base subtr_regOf UNIV_I)
 11.1076 +  have "Inl t \<in> cont (pick n)" using t using Inl_cont_regOf[of n] unfolding tr
 11.1077 +  by (metis (lifting) vimageD vimageI2) 
 11.1078 +  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
 11.1079 +  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
 11.1080 +qed
 11.1081 +
 11.1082 +theorem dtree_rcut: 
 11.1083 +assumes "dtree tr0"
 11.1084 +shows "dtree rcut" 
 11.1085 +unfolding rcut_def using dtree_regOf[OF assms inItr.Base] by simp
 11.1086 +
 11.1087 +theorem root_rcut[simp]: "root rcut = root tr0" 
 11.1088 +unfolding rcut_def
 11.1089 +by (metis (lifting) root_regOf inItr.Base reg_def reg_root subtr_rootR_in) 
 11.1090 +
 11.1091 +end (* context *)
 11.1092 +
 11.1093 +
 11.1094 +subsection{* Recursive description of the regular tree frontiers *} 
 11.1095 +
 11.1096 +lemma regular_inFr:
 11.1097 +assumes r: "regular tr" and In: "root tr \<in> ns"
 11.1098 +and t: "inFr ns tr t"
 11.1099 +shows "t \<in> Inl -` (cont tr) \<or> 
 11.1100 +       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
 11.1101 +(is "?L \<or> ?R")
 11.1102 +proof-
 11.1103 +  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n" 
 11.1104 +  using r unfolding regular_def2 by auto
 11.1105 +  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr" 
 11.1106 +  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1" 
 11.1107 +  using t unfolding inFr_iff_path[OF r f] by auto
 11.1108 +  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps) 
 11.1109 +  hence f_n: "f n = tr" using hd_nl by simp
 11.1110 +  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
 11.1111 +  show ?thesis
 11.1112 +  proof(cases nl1)
 11.1113 +    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
 11.1114 +    hence ?L using t_tr1 by simp thus ?thesis by simp
 11.1115 +  next
 11.1116 +    case (Cons n1 nl2) note nl1 = Cons
 11.1117 +    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
 11.1118 +    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr" 
 11.1119 +    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
 11.1120 +    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
 11.1121 +    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
 11.1122 +    apply(intro exI[of _ nl1], intro exI[of _ tr1])
 11.1123 +    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
 11.1124 +    have root_tr: "root tr = n" by (metis f f_n) 
 11.1125 +    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
 11.1126 +    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
 11.1127 +    thus ?thesis using n1_tr by auto
 11.1128 +  qed
 11.1129 +qed
 11.1130 + 
 11.1131 +theorem regular_Fr: 
 11.1132 +assumes r: "regular tr" and In: "root tr \<in> ns"
 11.1133 +shows "Fr ns tr = 
 11.1134 +       Inl -` (cont tr) \<union> 
 11.1135 +       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
 11.1136 +unfolding Fr_def 
 11.1137 +using In inFr.Base regular_inFr[OF assms] apply safe
 11.1138 +apply (simp, metis (full_types) UnionI mem_Collect_eq)
 11.1139 +apply simp
 11.1140 +by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
 11.1141 +
 11.1142 +
 11.1143 +subsection{* The generated languages *} 
 11.1144 +
 11.1145 +(* The (possibly inifinite tree) generated language *)
 11.1146 +definition "L ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n}"
 11.1147 +
 11.1148 +(* The regular-tree generated language *)
 11.1149 +definition "Lr ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n \<and> regular tr}"
 11.1150 +
 11.1151 +theorem L_rec_notin:
 11.1152 +assumes "n \<notin> ns"
 11.1153 +shows "L ns n = {{}}"
 11.1154 +using assms unfolding L_def apply safe 
 11.1155 +  using not_root_Fr apply force
 11.1156 +  apply(rule exI[of _ "deftr n"])
 11.1157 +  by (metis (no_types) dtree_deftr not_root_Fr root_deftr)
 11.1158 +
 11.1159 +theorem Lr_rec_notin:
 11.1160 +assumes "n \<notin> ns"
 11.1161 +shows "Lr ns n = {{}}"
 11.1162 +using assms unfolding Lr_def apply safe
 11.1163 +  using not_root_Fr apply force
 11.1164 +  apply(rule exI[of _ "deftr n"])
 11.1165 +  by (metis (no_types) regular_def dtree_deftr not_root_Fr reg_deftr root_deftr)
 11.1166 +
 11.1167 +lemma dtree_subtrOf: 
 11.1168 +assumes "dtree tr" and "Inr n \<in> prodOf tr"
 11.1169 +shows "dtree (subtrOf tr n)"
 11.1170 +by (metis assms dtree_lift lift_def subtrOf) 
 11.1171 +  
 11.1172 +theorem Lr_rec_in: 
 11.1173 +assumes n: "n \<in> ns"
 11.1174 +shows "Lr ns n \<subseteq> 
 11.1175 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
 11.1176 +    (n,tns) \<in> P \<and> 
 11.1177 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
 11.1178 +(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
 11.1179 +proof safe
 11.1180 +  fix ts assume "ts \<in> Lr ns n"
 11.1181 +  then obtain tr where dtr: "dtree tr" and r: "root tr = n" and tr: "regular tr"
 11.1182 +  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
 11.1183 +  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
 11.1184 +  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
 11.1185 +  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
 11.1186 +  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
 11.1187 +    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
 11.1188 +    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
 11.1189 +    unfolding tns_def K_def r[symmetric]
 11.1190 +    unfolding Inl_prodOf dtree_subtrOf_Union[OF dtr] ..
 11.1191 +    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using dtree_P[OF dtr] .
 11.1192 +    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
 11.1193 +    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
 11.1194 +    using dtr tr apply(intro conjI refl)  unfolding tns_def
 11.1195 +      apply(erule dtree_subtrOf[OF dtr])
 11.1196 +      apply (metis subtrOf)
 11.1197 +      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
 11.1198 +  qed
 11.1199 +qed 
 11.1200 +
 11.1201 +lemma hsubst_aux: 
 11.1202 +fixes n ftr tns
 11.1203 +assumes n: "n \<in> ns" and tns: "finite tns" and 
 11.1204 +1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> dtree (ftr n')"
 11.1205 +defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
 11.1206 +shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 11.1207 +(is "_ = ?B") proof-
 11.1208 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 11.1209 +  unfolding tr_def using tns by auto
 11.1210 +  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 11.1211 +  unfolding Frr_def ctr by auto
 11.1212 +  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
 11.1213 +  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
 11.1214 +  also have "... = ?B" unfolding ctr Frr by simp
 11.1215 +  finally show ?thesis .
 11.1216 +qed
 11.1217 +
 11.1218 +theorem L_rec_in: 
 11.1219 +assumes n: "n \<in> ns"
 11.1220 +shows "
 11.1221 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
 11.1222 +    (n,tns) \<in> P \<and> 
 11.1223 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')} 
 11.1224 + \<subseteq> L ns n"
 11.1225 +proof safe
 11.1226 +  fix tns K
 11.1227 +  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
 11.1228 +  {fix n' assume "Inr n' \<in> tns"
 11.1229 +   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
 11.1230 +   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> dtree tr' \<and> root tr' = n'"
 11.1231 +   unfolding L_def mem_Collect_eq by auto
 11.1232 +  }
 11.1233 +  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>  
 11.1234 +  K n' = Fr (ns - {n}) (ftr n') \<and> dtree (ftr n') \<and> root (ftr n') = n'"
 11.1235 +  by metis
 11.1236 +  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
 11.1237 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 11.1238 +  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
 11.1239 +  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong) 
 11.1240 +  unfolding ctr apply simp apply simp apply safe 
 11.1241 +  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)     
 11.1242 +  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 11.1243 +  using 0 by auto
 11.1244 +  have dtr: "dtree tr" apply(rule dtree.Tree)
 11.1245 +    apply (metis (lifting) P prtr rtr) 
 11.1246 +    unfolding inj_on_def ctr lift_def using 0 by auto
 11.1247 +  hence dtr': "dtree tr'" unfolding tr'_def by (metis dtree_hsubst)
 11.1248 +  have tns: "finite tns" using finite_in_P P by simp
 11.1249 +  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
 11.1250 +  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
 11.1251 +  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
 11.1252 +  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
 11.1253 +qed
 11.1254 +
 11.1255 +lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns" 
 11.1256 +by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
 11.1257 +
 11.1258 +function LL where 
 11.1259 +"LL ns n = 
 11.1260 + (if n \<notin> ns then {{}} else 
 11.1261 + {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
 11.1262 +    (n,tns) \<in> P \<and> 
 11.1263 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
 11.1264 +by(pat_completeness, auto)
 11.1265 +termination apply(relation "inv_image (measure card) fst") 
 11.1266 +using card_N by auto
 11.1267 +
 11.1268 +declare LL.simps[code]  (* TODO: Does code generation for LL work? *)
 11.1269 +declare LL.simps[simp del]
 11.1270 +
 11.1271 +theorem Lr_LL: "Lr ns n \<subseteq> LL ns n" 
 11.1272 +proof (induct ns arbitrary: n rule: measure_induct[of card]) 
 11.1273 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 11.1274 +    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
 11.1275 +  next
 11.1276 +    case True show ?thesis apply(rule subset_trans)
 11.1277 +    using Lr_rec_in[OF True] apply assumption 
 11.1278 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 11.1279 +      fix tns K
 11.1280 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 11.1281 +      assume "(n, tns) \<in> P" 
 11.1282 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
 11.1283 +      thus "\<exists>tnsa Ka.
 11.1284 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 11.1285 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 11.1286 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
 11.1287 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 11.1288 +    qed
 11.1289 +  qed
 11.1290 +qed
 11.1291 +
 11.1292 +theorem LL_L: "LL ns n \<subseteq> L ns n" 
 11.1293 +proof (induct ns arbitrary: n rule: measure_induct[of card]) 
 11.1294 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 11.1295 +    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
 11.1296 +  next
 11.1297 +    case True show ?thesis apply(rule subset_trans)
 11.1298 +    prefer 2 using L_rec_in[OF True] apply assumption 
 11.1299 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 11.1300 +      fix tns K
 11.1301 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 11.1302 +      assume "(n, tns) \<in> P" 
 11.1303 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
 11.1304 +      thus "\<exists>tnsa Ka.
 11.1305 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 11.1306 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 11.1307 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
 11.1308 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 11.1309 +    qed
 11.1310 +  qed
 11.1311 +qed
 11.1312 +
 11.1313 +(* The subsumpsion relation between languages *)
 11.1314 +definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
 11.1315 +
 11.1316 +lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
 11.1317 +unfolding subs_def by auto
 11.1318 +
 11.1319 +lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
 11.1320 +
 11.1321 +lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3" 
 11.1322 +unfolding subs_def by (metis subset_trans) 
 11.1323 +
 11.1324 +(* Language equivalence *)
 11.1325 +definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
 11.1326 +
 11.1327 +lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
 11.1328 +unfolding leqv_def by auto
 11.1329 +
 11.1330 +lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
 11.1331 +unfolding leqv_def by auto
 11.1332 +
 11.1333 +lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
 11.1334 +
 11.1335 +lemma leqv_trans: 
 11.1336 +assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
 11.1337 +shows "leqv L1 L3"
 11.1338 +using assms unfolding leqv_def by (metis (lifting) subs_trans) 
 11.1339 +
 11.1340 +lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
 11.1341 +unfolding leqv_def by auto
 11.1342 +
 11.1343 +lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
 11.1344 +unfolding leqv_def by auto
 11.1345 +
 11.1346 +lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
 11.1347 +unfolding Lr_def L_def by auto
 11.1348 +
 11.1349 +lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
 11.1350 +unfolding subs_def proof safe
 11.1351 +  fix ts2 assume "ts2 \<in> L UNIV ts"
 11.1352 +  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "dtree tr" and rtr: "root tr = ts" 
 11.1353 +  unfolding L_def by auto
 11.1354 +  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
 11.1355 +  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
 11.1356 +  unfolding Lr_def L_def using Fr_rcut dtree_rcut root_rcut regular_rcut by auto
 11.1357 +qed
 11.1358 +
 11.1359 +theorem Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
 11.1360 +using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
 11.1361 +
 11.1362 +theorem LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
 11.1363 +by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
 11.1364 +
 11.1365 +theorem LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
 11.1366 +using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
 11.1367 +
 11.1368 +
 11.1369 +end
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Parallel.thy	Tue Aug 28 17:16:00 2012 +0200
    12.3 @@ -0,0 +1,143 @@
    12.4 +theory Parallel 
    12.5 +imports Tree
    12.6 +begin
    12.7 +
    12.8 +
    12.9 +consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
   12.10 +
   12.11 +axiomatization where 
   12.12 +    Nplus_comm: "(a::N) + b = b + (a::N)"
   12.13 +and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
   12.14 +
   12.15 +
   12.16 +
   12.17 +section{* Parallel composition *} 
   12.18 +
   12.19 +fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
   12.20 +fun par_c where 
   12.21 +"par_c (tr1,tr2) = 
   12.22 + Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union> 
   12.23 + Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
   12.24 +
   12.25 +declare par_r.simps[simp del]  declare par_c.simps[simp del]
   12.26 +
   12.27 +definition par :: "Tree \<times> Tree \<Rightarrow> Tree" where  
   12.28 +"par \<equiv> coit par_r par_c"
   12.29 +
   12.30 +abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
   12.31 +
   12.32 +lemma finite_par_c: "finite (par_c (tr1, tr2))"
   12.33 +unfolding par_c.simps apply(rule finite_UnI)
   12.34 +  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
   12.35 +  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
   12.36 +  using finite_cont by auto
   12.37 +
   12.38 +lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
   12.39 +using coit(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
   12.40 +
   12.41 +lemma cont_par: 
   12.42 +"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
   12.43 +using coit(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
   12.44 +unfolding par_def ..
   12.45 +
   12.46 +lemma Inl_cont_par[simp]:
   12.47 +"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)" 
   12.48 +unfolding cont_par par_c.simps by auto
   12.49 +
   12.50 +lemma Inr_cont_par[simp]:
   12.51 +"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)" 
   12.52 +unfolding cont_par par_c.simps by auto
   12.53 +
   12.54 +lemma Inl_in_cont_par:
   12.55 +"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
   12.56 +using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
   12.57 +
   12.58 +lemma Inr_in_cont_par:
   12.59 +"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
   12.60 +using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
   12.61 +
   12.62 +
   12.63 +section{* =-coinductive proofs *}
   12.64 +
   12.65 +(* Detailed proofs of commutativity and associativity: *)
   12.66 +theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
   12.67 +proof-
   12.68 +  let ?\<phi> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
   12.69 +  {fix trA trB
   12.70 +   assume "?\<phi> trA trB" hence "trA = trB"
   12.71 +   proof (induct rule: Tree_coind, safe)
   12.72 +     fix tr1 tr2 
   12.73 +     show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)" 
   12.74 +     unfolding root_par by (rule Nplus_comm)
   12.75 +   next
   12.76 +     fix tr1 tr2 :: Tree
   12.77 +     let ?trA = "tr1 \<parallel> tr2"  let ?trB = "tr2 \<parallel> tr1"
   12.78 +     show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
   12.79 +     unfolding lift2_def proof(intro conjI allI impI)
   12.80 +       fix n show "Inl n \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> Inl n \<in> cont (tr2 \<parallel> tr1)"
   12.81 +       unfolding Inl_in_cont_par by auto
   12.82 +     next
   12.83 +       fix trA' assume "Inr trA' \<in> cont ?trA"
   12.84 +       then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
   12.85 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   12.86 +       unfolding Inr_in_cont_par by auto
   12.87 +       thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
   12.88 +       apply(intro exI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   12.89 +     next
   12.90 +       fix trB' assume "Inr trB' \<in> cont ?trB"
   12.91 +       then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
   12.92 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   12.93 +       unfolding Inr_in_cont_par by auto
   12.94 +       thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
   12.95 +       apply(intro exI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
   12.96 +     qed
   12.97 +   qed
   12.98 +  }
   12.99 +  thus ?thesis by blast
  12.100 +qed
  12.101 +
  12.102 +theorem par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
  12.103 +proof-
  12.104 +  let ?\<phi> = 
  12.105 +  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> 
  12.106 +                             trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  12.107 +  {fix trA trB
  12.108 +   assume "?\<phi> trA trB" hence "trA = trB"
  12.109 +   proof (induct rule: Tree_coind, safe)
  12.110 +     fix tr1 tr2 tr3 
  12.111 +     show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))" 
  12.112 +     unfolding root_par by (rule Nplus_assoc)
  12.113 +   next
  12.114 +     fix tr1 tr2 tr3 
  12.115 +     let ?trA = "(tr1 \<parallel> tr2) \<parallel> tr3"  let ?trB = "tr1 \<parallel> (tr2 \<parallel> tr3)"
  12.116 +     show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
  12.117 +     unfolding lift2_def proof(intro conjI allI impI)
  12.118 +       fix n show "Inl n \<in> (cont ?trA) \<longleftrightarrow> Inl n \<in> (cont ?trB)"
  12.119 +       unfolding Inl_in_cont_par by simp
  12.120 +     next
  12.121 +       fix trA' assume "Inr trA' \<in> cont ?trA"
  12.122 +       then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
  12.123 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  12.124 +       and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  12.125 +       thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
  12.126 +       apply(intro exI[of _ "tr1' \<parallel> (tr2' \<parallel> tr3')"]) 
  12.127 +       unfolding Inr_in_cont_par by auto
  12.128 +     next
  12.129 +       fix trB' assume "Inr trB' \<in> cont ?trB"
  12.130 +       then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
  12.131 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  12.132 +       and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  12.133 +       thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
  12.134 +       apply(intro exI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"]) 
  12.135 +       unfolding Inr_in_cont_par by auto
  12.136 +     qed
  12.137 +   qed
  12.138 +  }
  12.139 +  thus ?thesis by blast
  12.140 +qed
  12.141 +
  12.142 +
  12.143 +
  12.144 +
  12.145 +
  12.146 +end
  12.147 \ No newline at end of file
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Prelim.thy	Tue Aug 28 17:16:00 2012 +0200
    13.3 @@ -0,0 +1,66 @@
    13.4 +(*  Title:      Gram_Tree.thy
    13.5 +    Author:     Andrei Popescu, TU Muenchen
    13.6 +    Copyright   2012
    13.7 +
    13.8 +Preliminaries
    13.9 +*)
   13.10 +
   13.11 +
   13.12 +theory Prelim
   13.13 +imports "../../Codatatype/Codatatype"
   13.14 +begin
   13.15 +
   13.16 +declare fset_to_fset[simp]
   13.17 +
   13.18 +lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
   13.19 +apply(rule ext) by (simp add: convol_def)
   13.20 +
   13.21 +abbreviation sm_abbrev (infix "\<oplus>" 60) 
   13.22 +where "f \<oplus> g \<equiv> Sum_Type.sum_map f g" 
   13.23 +
   13.24 +lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
   13.25 +by (cases z) auto
   13.26 +
   13.27 +lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
   13.28 +by (cases z) auto
   13.29 +
   13.30 +abbreviation sum_case_abbrev ("[[_,_]]" 800)
   13.31 +where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
   13.32 +
   13.33 +lemma inj_Inl[simp]: "inj Inl" unfolding inj_on_def by auto
   13.34 +lemma inj_Inr[simp]: "inj Inr" unfolding inj_on_def by auto
   13.35 +
   13.36 +lemma Inl_oplus_elim:
   13.37 +assumes "Inl tr \<in> (id \<oplus> f) ` tns"
   13.38 +shows "Inl tr \<in> tns"
   13.39 +using assms apply clarify by (case_tac x, auto)
   13.40 +
   13.41 +lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
   13.42 +using Inl_oplus_elim
   13.43 +by (metis id_def image_iff sum_map.simps(1))
   13.44 +
   13.45 +lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
   13.46 +using Inl_oplus_iff unfolding vimage_def by auto
   13.47 +
   13.48 +lemma Inr_oplus_elim:
   13.49 +assumes "Inr tr \<in> (id \<oplus> f) ` tns"
   13.50 +shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
   13.51 +using assms apply clarify by (case_tac x, auto)
   13.52 +
   13.53 +lemma Inr_oplus_iff[simp]: 
   13.54 +"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
   13.55 +apply (rule iffI)
   13.56 + apply (metis Inr_oplus_elim)
   13.57 +by (metis image_iff sum_map.simps(2))
   13.58 +
   13.59 +lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
   13.60 +using Inr_oplus_iff unfolding vimage_def by auto
   13.61 +
   13.62 +lemma Inl_Inr_image_cong:
   13.63 +assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
   13.64 +shows "A = B"
   13.65 +apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
   13.66 +
   13.67 +
   13.68 +
   13.69 +end
   13.70 \ No newline at end of file
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Tree.thy	Tue Aug 28 17:16:00 2012 +0200
    14.3 @@ -0,0 +1,326 @@
    14.4 +(*  Title:      Gram_Tree.thy
    14.5 +    Author:     Andrei Popescu, TU Muenchen
    14.6 +    Copyright   2012
    14.7 +
    14.8 +Trees with nonterminal internal nodes and terminal leafs.
    14.9 +*)
   14.10 +
   14.11 +
   14.12 +header {* Trees with nonterminal internal nodes and terminal leafs *}
   14.13 +
   14.14 +
   14.15 +theory Tree
   14.16 +imports Prelim
   14.17 +begin
   14.18 +
   14.19 +typedecl N  typedecl T
   14.20 +
   14.21 +bnf_codata Tree: 'Tree = "N \<times> (T + 'Tree) fset"
   14.22 +
   14.23 +
   14.24 +section {* Sugar notations for Tree *}
   14.25 +
   14.26 +subsection{* Setup for map, set, pred *}
   14.27 +
   14.28 +(* These should be eventually inferred from compositionality *)
   14.29 +
   14.30 +lemma TreeBNF_map: 
   14.31 +"TreeBNF_map f (n,as) = (n, map_fset (id \<oplus> f) as)"
   14.32 +unfolding TreeBNF_map_def id_apply 
   14.33 +sum_map_def by simp  
   14.34 +
   14.35 +lemma TreeBNF_map':
   14.36 +"TreeBNF_map f n_as = (fst n_as, map_fset (id \<oplus> f) (snd n_as))"
   14.37 +using TreeBNF_map by(cases n_as, simp)
   14.38 +
   14.39 +
   14.40 +definition 
   14.41 +"llift2 \<phi> as1 as2 \<longleftrightarrow> 
   14.42 + (\<forall> n. Inl n \<in> fset as1 \<longleftrightarrow> Inl n \<in> fset as2) \<and> 
   14.43 + (\<forall> tr1. Inr tr1 \<in> fset as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> fset as2 \<and> \<phi> tr1 tr2)) \<and> 
   14.44 + (\<forall> tr2. Inr tr2 \<in> fset as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> fset as1 \<and> \<phi> tr1 tr2))"
   14.45 +
   14.46 +lemma TreeBNF_pred: "TreeBNF_pred \<phi> (n1,as1) (n2,as2) \<longleftrightarrow> n1 = n2 \<and> llift2 \<phi> as1 as2"
   14.47 +unfolding llift2_def TreeBNF.pred_unfold
   14.48 +apply (auto split: sum.splits)
   14.49 +apply (metis sumE)
   14.50 +apply (metis sumE)
   14.51 +apply (metis sumE)
   14.52 +apply (metis sumE)
   14.53 +apply (metis sumE sum.simps(1,2,4))
   14.54 +apply (metis sumE sum.simps(1,2,4))
   14.55 +done
   14.56 +
   14.57 +
   14.58 +subsection{* Constructors *}
   14.59 +
   14.60 +definition NNode :: "N \<Rightarrow> (T + Tree)fset \<Rightarrow> Tree"
   14.61 +where "NNode n as \<equiv> Tree_fld (n,as)"
   14.62 +
   14.63 +lemmas ctor_defs = NNode_def
   14.64 +
   14.65 +
   14.66 +subsection {* Pre-selectors *}
   14.67 +
   14.68 +(* These are mere auxiliaries *)
   14.69 +
   14.70 +definition "asNNode tr \<equiv> SOME n_as. NNode (fst n_as) (snd n_as) = tr"
   14.71 +lemmas pre_sel_defs = asNNode_def 
   14.72 +
   14.73 +
   14.74 +subsection {* Selectors *}
   14.75 +
   14.76 +(* One for each pair (constructor, constructor argument) *)
   14.77 +
   14.78 +(* For NNode: *)
   14.79 +definition root :: "Tree \<Rightarrow> N" where "root tr = fst (asNNode tr)"
   14.80 +definition ccont :: "Tree \<Rightarrow> (T + Tree)fset" where "ccont tr = snd (asNNode tr)"
   14.81 +
   14.82 +lemmas sel_defs = root_def ccont_def
   14.83 +
   14.84 +
   14.85 +subsection {* Basic properties *}
   14.86 +
   14.87 +(* Constructors versus selectors *)
   14.88 +lemma NNode_surj: "\<exists> n as. NNode n as = tr"
   14.89 +unfolding NNode_def
   14.90 +by (metis Tree.fld_unf pair_collapse) 
   14.91 +
   14.92 +lemma NNode_asNNode: 
   14.93 +"NNode (fst (asNNode tr)) (snd (asNNode tr)) = tr"
   14.94 +proof-
   14.95 +  obtain n as where "NNode n as = tr" using NNode_surj[of tr] by blast
   14.96 +  hence "NNode (fst (n,as)) (snd (n,as)) = tr" by simp
   14.97 +  thus ?thesis unfolding asNNode_def by(rule someI)
   14.98 +qed
   14.99 +
  14.100 +theorem NNode_root_ccont[simp]: 
  14.101 +"NNode (root tr) (ccont tr) = tr"
  14.102 +using NNode_asNNode unfolding root_def ccont_def .
  14.103 +
  14.104 +(* Constructors *)
  14.105 +theorem TTree_simps[simp]: 
  14.106 +"NNode n as = NNode n' as' \<longleftrightarrow> n = n' \<and> as = as'"
  14.107 +unfolding ctor_defs Tree.fld_inject by auto
  14.108 +
  14.109 +theorem TTree_cases[elim, case_names NNode Choice]:
  14.110 +assumes NNode: "\<And> n as. tr = NNode n as \<Longrightarrow> phi"
  14.111 +shows phi
  14.112 +proof(cases rule: Tree.fld_exhaust[of tr])
  14.113 +  fix x assume "tr = Tree_fld x"
  14.114 +  thus ?thesis
  14.115 +  apply(cases x) 
  14.116 +    using NNode unfolding ctor_defs apply blast
  14.117 +  done
  14.118 +qed
  14.119 +
  14.120 +(* Constructors versus selectors *)
  14.121 +theorem TTree_sel_ctor[simp]:
  14.122 +"root (NNode n as) = n"
  14.123 +"ccont (NNode n as) = as"
  14.124 +unfolding root_def ccont_def
  14.125 +by (metis (no_types) NNode_asNNode TTree_simps)+
  14.126 +
  14.127 +
  14.128 +subsection{* Coinduction *}
  14.129 +
  14.130 +theorem TTree_coind_Node[elim, consumes 1, case_names NNode, induct pred: "HOL.eq"]:
  14.131 +assumes phi: "\<phi> tr1 tr2" and 
  14.132 +NNode: "\<And> n1 n2 as1 as2. 
  14.133 +          \<lbrakk>\<phi> (NNode n1 as1) (NNode n2 as2)\<rbrakk> \<Longrightarrow> 
  14.134 +          n1 = n2 \<and> llift2 \<phi> as1 as2"
  14.135 +shows "tr1 = tr2"
  14.136 +apply(rule mp[OF Tree.pred_coinduct[of \<phi> tr1 tr2] phi]) proof clarify
  14.137 +  fix tr1 tr2  assume \<phi>: "\<phi> tr1 tr2"
  14.138 +  show "TreeBNF_pred \<phi> (Tree_unf tr1) (Tree_unf tr2)" 
  14.139 +  apply(cases rule: Tree.fld_exhaust[of tr1], cases rule: Tree.fld_exhaust[of tr2])
  14.140 +  apply (simp add: Tree.unf_fld)  
  14.141 +  apply(case_tac x, case_tac xa, simp)
  14.142 +  unfolding TreeBNF_pred apply(rule NNode) using \<phi> unfolding NNode_def by simp
  14.143 +qed
  14.144 +
  14.145 +theorem TTree_coind[elim, consumes 1, case_names LLift]:
  14.146 +assumes phi: "\<phi> tr1 tr2" and 
  14.147 +LLift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> 
  14.148 +                   root tr1 = root tr2 \<and> llift2 \<phi> (ccont tr1) (ccont tr2)"
  14.149 +shows "tr1 = tr2"
  14.150 +using phi apply(induct rule: TTree_coind_Node)
  14.151 +using LLift by (metis TTree_sel_ctor) 
  14.152 +
  14.153 +
  14.154 +
  14.155 +subsection {* Coiteration *}
  14.156 + 
  14.157 +(* Preliminaries: *)  
  14.158 +declare Tree.unf_fld[simp]
  14.159 +declare Tree.fld_unf[simp]
  14.160 +
  14.161 +lemma Tree_unf_NNode[simp]:
  14.162 +"Tree_unf (NNode n as) = (n,as)"
  14.163 +unfolding NNode_def Tree.unf_fld ..
  14.164 +
  14.165 +lemma Tree_unf_root_ccont:
  14.166 +"Tree_unf tr = (root tr, ccont tr)"
  14.167 +unfolding root_def ccont_def
  14.168 +by (metis (lifting) NNode_asNNode Tree_unf_NNode) 
  14.169 +
  14.170 +(* Coiteration *)
  14.171 +definition TTree_coit :: 
  14.172 +"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + 'b) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
  14.173 +where "TTree_coit rt ct \<equiv> Tree_coiter <rt,ct>"  
  14.174 +
  14.175 +lemma Tree_coit_coit: 
  14.176 +"Tree_coiter s = TTree_coit (fst o s) (snd o s)"
  14.177 +apply(rule ext)
  14.178 +unfolding TTree_coit_def by simp
  14.179 +
  14.180 +theorem TTree_coit: 
  14.181 +"root (TTree_coit rt ct b) = rt b"  
  14.182 +"ccont (TTree_coit rt ct b) = map_fset (id \<oplus> TTree_coit rt ct) (ct b)"
  14.183 +using Tree.coiter[of "<rt,ct>" b] unfolding Tree_coit_coit fst_convol snd_convol
  14.184 +unfolding TreeBNF_map' fst_convol' snd_convol' 
  14.185 +unfolding Tree_unf_root_ccont by simp_all 
  14.186 +
  14.187 +(* Corecursion, stronger than coitation *)  
  14.188 +definition TTree_corec :: 
  14.189 +"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + (Tree + 'b)) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
  14.190 +where "TTree_corec rt ct \<equiv> Tree_corec <rt,ct>"  
  14.191 +
  14.192 +lemma Tree_corec_corec: 
  14.193 +"Tree_corec s = TTree_corec (fst o s) (snd o s)"
  14.194 +apply(rule ext)
  14.195 +unfolding TTree_corec_def by simp
  14.196 +
  14.197 +theorem TTree_corec: 
  14.198 +"root (TTree_corec rt ct b) = rt b" 
  14.199 +"ccont (TTree_corec rt ct b) = map_fset (id \<oplus> ([[id, TTree_corec rt ct]]) ) (ct b)"
  14.200 +using Tree.corec[of "<rt,ct>" b] unfolding Tree_corec_corec fst_convol snd_convol
  14.201 +unfolding TreeBNF_map' fst_convol' snd_convol' 
  14.202 +unfolding Tree_unf_root_ccont by simp_all
  14.203 +
  14.204 +
  14.205 +subsection{* The characteristic theorems transported from fset to set *}
  14.206 +
  14.207 +definition "Node n as \<equiv> NNode n (the_inv fset as)"
  14.208 +definition "cont \<equiv> fset o ccont"
  14.209 +definition "coit rt ct \<equiv> TTree_coit rt (the_inv fset o ct)"
  14.210 +definition "corec rt ct \<equiv> TTree_corec rt (the_inv fset o ct)"
  14.211 +
  14.212 +definition lift ("_ ^#" 200) where 
  14.213 +"lift \<phi> as \<longleftrightarrow> (\<forall> tr. Inr tr \<in> as \<longrightarrow> \<phi> tr)"
  14.214 +
  14.215 +definition lift2 ("_ ^#2" 200) where 
  14.216 +"lift2 \<phi> as1 as2 \<longleftrightarrow> 
  14.217 + (\<forall> n. Inl n \<in> as1 \<longleftrightarrow> Inl n \<in> as2) \<and> 
  14.218 + (\<forall> tr1. Inr tr1 \<in> as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> as2 \<and> \<phi> tr1 tr2)) \<and> 
  14.219 + (\<forall> tr2. Inr tr2 \<in> as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> as1 \<and> \<phi> tr1 tr2))"
  14.220 +
  14.221 +definition liftS ("_ ^#s" 200) where 
  14.222 +"liftS trs = {as. Inr -` as \<subseteq> trs}"
  14.223 +
  14.224 +lemma lift2_llift2: 
  14.225 +"\<lbrakk>finite as1; finite as2\<rbrakk> \<Longrightarrow> 
  14.226 + lift2 \<phi> as1 as2 \<longleftrightarrow> llift2 \<phi> (the_inv fset as1) (the_inv fset as2)"
  14.227 +unfolding lift2_def llift2_def by auto
  14.228 +
  14.229 +lemma llift2_lift2: 
  14.230 +"llift2 \<phi> as1 as2 \<longleftrightarrow> lift2 \<phi> (fset as1) (fset as2)"
  14.231 +using lift2_llift2 by (metis finite_fset fset_cong fset_to_fset)
  14.232 +
  14.233 +lemma mono_lift:
  14.234 +assumes "(\<phi>^#) as" 
  14.235 +and "\<And> tr. \<phi> tr \<Longrightarrow> \<phi>' tr"
  14.236 +shows "(\<phi>'^#) as"
  14.237 +using assms unfolding lift_def[abs_def] by blast
  14.238 +
  14.239 +lemma mono_liftS:
  14.240 +assumes "trs1 \<subseteq> trs2 "
  14.241 +shows "(trs1 ^#s) \<subseteq> (trs2 ^#s)" 
  14.242 +using assms unfolding liftS_def[abs_def] by blast
  14.243 +
  14.244 +lemma lift_mono: 
  14.245 +assumes "\<phi> \<le> \<phi>'"
  14.246 +shows "(\<phi>^#) \<le> (\<phi>'^#)"
  14.247 +using assms unfolding lift_def[abs_def] by blast
  14.248 +
  14.249 +lemma mono_lift2:
  14.250 +assumes "(\<phi>^#2) as1 as2"
  14.251 +and "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> \<phi>' tr1 tr2"
  14.252 +shows "(\<phi>'^#2) as1 as2"
  14.253 +using assms unfolding lift2_def[abs_def] by blast
  14.254 +
  14.255 +lemma lift2_mono: 
  14.256 +assumes "\<phi> \<le> \<phi>'"
  14.257 +shows "(\<phi>^#2) \<le> (\<phi>'^#2)"
  14.258 +using assms unfolding lift2_def[abs_def] by blast 
  14.259 +
  14.260 +lemma finite_cont[simp]: "finite (cont tr)"
  14.261 +unfolding cont_def by auto
  14.262 +
  14.263 +theorem Node_root_cont[simp]: 
  14.264 +"Node (root tr) (cont tr) = tr"
  14.265 +using NNode_root_ccont unfolding Node_def cont_def
  14.266 +by (metis cont_def finite_cont fset_cong fset_to_fset o_def)
  14.267 +
  14.268 +theorem Tree_simps[simp]: 
  14.269 +assumes "finite as" and "finite as'"
  14.270 +shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
  14.271 +using assms TTree_simps unfolding Node_def
  14.272 +by (metis fset_to_fset)
  14.273 +
  14.274 +theorem Tree_cases[elim, case_names Node Choice]:
  14.275 +assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
  14.276 +shows phi
  14.277 +apply(cases rule: TTree_cases[of tr])
  14.278 +using Node unfolding Node_def
  14.279 +by (metis Node Node_root_cont finite_cont)
  14.280 +
  14.281 +theorem Tree_sel_ctor[simp]:
  14.282 +"root (Node n as) = n" 
  14.283 +"finite as \<Longrightarrow> cont (Node n as) = as" 
  14.284 +unfolding Node_def cont_def by auto
  14.285 +
  14.286 +theorems root_Node = Tree_sel_ctor(1)
  14.287 +theorems cont_Node = Tree_sel_ctor(2)
  14.288 +
  14.289 +theorem Tree_coind_Node[elim, consumes 1, case_names Node]:
  14.290 +assumes phi: "\<phi> tr1 tr2" and 
  14.291 +Node: 
  14.292 +"\<And> n1 n2 as1 as2. 
  14.293 +   \<lbrakk>finite as1; finite as2; \<phi> (Node n1 as1) (Node n2 as2)\<rbrakk> 
  14.294 +   \<Longrightarrow> n1 = n2 \<and> (\<phi>^#2) as1 as2"
  14.295 +shows "tr1 = tr2"
  14.296 +using phi apply(induct rule: TTree_coind_Node)
  14.297 +unfolding llift2_lift2 apply(rule Node)
  14.298 +unfolding Node_def
  14.299 +apply (metis finite_fset)
  14.300 +apply (metis finite_fset)
  14.301 +by (metis finite_fset fset_cong fset_to_fset)
  14.302 +
  14.303 +theorem Tree_coind[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
  14.304 +assumes phi: "\<phi> tr1 tr2" and 
  14.305 +Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> 
  14.306 +                  root tr1 = root tr2 \<and> (\<phi>^#2) (cont tr1) (cont tr2)"
  14.307 +shows "tr1 = tr2"
  14.308 +using phi apply(induct rule: TTree_coind)
  14.309 +unfolding llift2_lift2 apply(rule Lift[unfolded cont_def comp_def]) .
  14.310 +
  14.311 +theorem coit: 
  14.312 +"root (coit rt ct b) = rt b" 
  14.313 +"finite (ct b) \<Longrightarrow> cont (coit rt ct b) = image (id \<oplus> coit rt ct) (ct b)"
  14.314 +using TTree_coit[of rt "the_inv fset \<circ> ct" b] unfolding coit_def
  14.315 +apply - apply metis
  14.316 +unfolding cont_def comp_def
  14.317 +by (metis (no_types) fset_to_fset map_fset_image)
  14.318 +
  14.319 +
  14.320 +theorem corec: 
  14.321 +"root (corec rt ct b) = rt b" 
  14.322 +"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
  14.323 +using TTree_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
  14.324 +apply - apply metis
  14.325 +unfolding cont_def comp_def
  14.326 +by (metis (no_types) fset_to_fset map_fset_image)
  14.327 +
  14.328 +
  14.329 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Codatatype/Examples/Lambda_Term.thy	Tue Aug 28 17:16:00 2012 +0200
    15.3 @@ -0,0 +1,259 @@
    15.4 +(*  Title:      Codatatype_Examples/Lambda_Term.thy
    15.5 +    Author:     Dmitriy Traytel, TU Muenchen
    15.6 +    Author:     Andrei Popescu, TU Muenchen
    15.7 +    Copyright   2012
    15.8 +
    15.9 +Lambda-terms.
   15.10 +*)
   15.11 +
   15.12 +header {* Lambda-Terms *}
   15.13 +
   15.14 +theory Lambda_Term
   15.15 +imports "../Codatatype/Codatatype"
   15.16 +begin
   15.17 +
   15.18 +
   15.19 +section {* Datatype definition *}
   15.20 +
   15.21 +bnf_data trm: 'trm = "'a + 'trm \<times> 'trm + 'a \<times> 'trm + ('a \<times> 'trm) fset \<times> 'trm"
   15.22 +
   15.23 +
   15.24 +section {* Customization of terms *}
   15.25 +
   15.26 +subsection{* Set and map *}
   15.27 +
   15.28 +lemma trmBNF_set2_Lt: "trmBNF_set2 (Inr (Inr (Inr (xts, t)))) = snd ` (fset xts) \<union> {t}"
   15.29 +unfolding trmBNF_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
   15.30 +by auto
   15.31 +
   15.32 +lemma trmBNF_set2_Var: "\<And>x. trmBNF_set2 (Inl x) = {}"
   15.33 +and trmBNF_set2_App:
   15.34 +"\<And>t1 t2. trmBNF_set2 (Inr (Inl t1t2)) = {fst t1t2, snd t1t2}"
   15.35 +and trmBNF_set2_Lam:
   15.36 +"\<And>x t. trmBNF_set2 (Inr (Inr (Inl (x, t)))) = {t}"
   15.37 +unfolding trmBNF_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
   15.38 +by auto
   15.39 +
   15.40 +lemma trmBNF_map:
   15.41 +"\<And> a1. trmBNF_map f1 f2 (Inl a1) = Inl (f1 a1)"
   15.42 +"\<And> a2 b2. trmBNF_map f1 f2 (Inr (Inl (a2,b2))) = Inr (Inl (f2 a2, f2 b2))"
   15.43 +"\<And> a1 a2. trmBNF_map f1 f2 (Inr (Inr (Inl (a1,a2)))) = Inr (Inr (Inl (f1 a1, f2 a2)))"
   15.44 +"\<And> a1a2s a2.
   15.45 +   trmBNF_map f1 f2 (Inr (Inr (Inr (a1a2s, a2)))) =
   15.46 +   Inr (Inr (Inr (map_fset (\<lambda> (a1', a2'). (f1 a1', f2 a2')) a1a2s, f2 a2)))"
   15.47 +unfolding trmBNF_map_def collect_def[abs_def] map_pair_def by auto
   15.48 +
   15.49 +
   15.50 +subsection{* Constructors *}
   15.51 +
   15.52 +definition "Var x \<equiv> trm_fld (Inl x)"
   15.53 +definition "App t1 t2 \<equiv> trm_fld (Inr (Inl (t1,t2)))"
   15.54 +definition "Lam x t \<equiv> trm_fld (Inr (Inr (Inl (x,t))))"
   15.55 +definition "Lt xts t \<equiv> trm_fld (Inr (Inr (Inr (xts,t))))"
   15.56 +
   15.57 +lemmas ctor_defs = Var_def App_def Lam_def Lt_def
   15.58 +
   15.59 +theorem trm_simps[simp]:
   15.60 +"\<And>x y. Var x = Var y \<longleftrightarrow> x = y"
   15.61 +"\<And>t1 t2 t1' t2'. App t1 t2 = App t1' t2' \<longleftrightarrow> t1 = t1' \<and> t2 = t2'"
   15.62 +"\<And>x x' t t'. Lam x t = Lam x' t' \<longleftrightarrow> x = x' \<and> t = t'"
   15.63 +"\<And> xts xts' t t'. Lt xts t = Lt xts' t' \<longleftrightarrow> xts = xts' \<and> t = t'"
   15.64 +(*  *)
   15.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"
   15.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"
   15.67 +"\<And>x t xts t1. Lam x t \<noteq> Lt xts t1"
   15.68 +unfolding ctor_defs trm.fld_inject by auto
   15.69 +
   15.70 +theorem trm_cases[elim, case_names Var App Lam Lt]:
   15.71 +assumes Var: "\<And> x. t = Var x \<Longrightarrow> phi"
   15.72 +and App: "\<And> t1 t2. t = App t1 t2 \<Longrightarrow> phi"
   15.73 +and Lam: "\<And> x t1. t = Lam x t1 \<Longrightarrow> phi"
   15.74 +and Lt: "\<And> xts t1. t = Lt xts t1 \<Longrightarrow> phi"
   15.75 +shows phi
   15.76 +proof(cases rule: trm.fld_exhaust[of t])
   15.77 +  fix x assume "t = trm_fld x"
   15.78 +  thus ?thesis
   15.79 +  apply(cases x) using Var unfolding ctor_defs apply blast
   15.80 +  apply(case_tac b) using App unfolding ctor_defs apply(case_tac a, blast)
   15.81 +  apply(case_tac ba) using Lam unfolding ctor_defs apply(case_tac a, blast)
   15.82 +  apply(case_tac bb) using Lt unfolding ctor_defs by blast
   15.83 +qed
   15.84 +
   15.85 +lemma trm_induct[case_names Var App Lam Lt, induct type: trm]:
   15.86 +assumes Var: "\<And> (x::'a). phi (Var x)"
   15.87 +and App: "\<And> t1 t2. \<lbrakk>phi t1; phi t2\<rbrakk> \<Longrightarrow> phi (App t1 t2)"
   15.88 +and Lam: "\<And> x t. phi t \<Longrightarrow> phi (Lam x t)"
   15.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)"
   15.90 +shows "phi t"
   15.91 +proof(induct rule: trm.fld_induct)
   15.92 +  fix u :: "'a + 'a trm \<times> 'a trm + 'a \<times> 'a trm + ('a \<times> 'a trm) fset \<times> 'a trm"
   15.93 +  assume IH: "\<And>t. t \<in> trmBNF_set2 u \<Longrightarrow> phi t"
   15.94 +  show "phi (trm_fld u)"
   15.95 +  proof(cases u)
   15.96 +    case (Inl x)
   15.97 +    show ?thesis using Var unfolding Var_def Inl .
   15.98 +  next
   15.99 +    case (Inr uu) note Inr1 = Inr
  15.100 +    show ?thesis
  15.101 +    proof(cases uu)
  15.102 +      case (Inl t1t2)
  15.103 +      obtain t1 t2 where t1t2: "t1t2 = (t1,t2)" by (cases t1t2, blast)
  15.104 +      show ?thesis unfolding Inr1 Inl t1t2 App_def[symmetric] apply(rule App)
  15.105 +      using IH unfolding Inr1 Inl trmBNF_set2_App t1t2 fst_conv snd_conv by blast+
  15.106 +    next
  15.107 +      case (Inr uuu) note Inr2 = Inr
  15.108 +      show ?thesis
  15.109 +      proof(cases uuu)
  15.110 +        case (Inl xt)
  15.111 +        obtain x t where xt: "xt = (x,t)" by (cases xt, blast)
  15.112 +        show ?thesis unfolding Inr1 Inr2 Inl xt Lam_def[symmetric] apply(rule Lam)
  15.113 +        using IH unfolding Inr1 Inr2 Inl trmBNF_set2_Lam xt by blast
  15.114 +      next
  15.115 +        case (Inr xts_t)
  15.116 +        obtain xts t where xts_t: "xts_t = (xts,t)" by (cases xts_t, blast)
  15.117 +        show ?thesis unfolding Inr1 Inr2 Inr xts_t Lt_def[symmetric] apply(rule Lt) using IH
  15.118 +        unfolding Inr1 Inr2 Inr trmBNF_set2_Lt xts_t fset_fset_member image_def by auto
  15.119 +      qed
  15.120 +    qed
  15.121 +  qed
  15.122 +qed
  15.123 +
  15.124 +
  15.125 +subsection{* Recursion and iteration *}
  15.126 +
  15.127 +definition
  15.128 +"sumJoin4 f1 f2 f3 f4 \<equiv>
  15.129 +\<lambda> k. (case k of
  15.130 + Inl x1 \<Rightarrow> f1 x1
  15.131 +|Inr k1 \<Rightarrow> (case k1 of
  15.132 + Inl ((s2,a2),(t2,b2)) \<Rightarrow> f2 s2 a2 t2 b2
  15.133 +|Inr k2 \<Rightarrow> (case k2 of Inl (x3,(t3,b3)) \<Rightarrow> f3 x3 t3 b3
  15.134 +|Inr (xts,(t4,b4)) \<Rightarrow> f4 xts t4 b4)))"
  15.135 +
  15.136 +lemma sumJoin4_simps[simp]:
  15.137 +"\<And>x. sumJoin4 var app lam lt (Inl x) = var x"
  15.138 +"\<And> t1 a1 t2 a2. sumJoin4 var app lam lt (Inr (Inl ((t1,a1),(t2,a2)))) = app t1 a1 t2 a2"
  15.139 +"\<And> x t a. sumJoin4 var app lam lt (Inr (Inr (Inl (x,(t,a))))) = lam x t a"
  15.140 +"\<And> xtas t a. sumJoin4 var app lam lt (Inr (Inr (Inr (xtas,(t,a))))) = lt xtas t a"
  15.141 +unfolding sumJoin4_def by auto
  15.142 +
  15.143 +definition "trmrec var app lam lt \<equiv> trm_rec (sumJoin4 var app lam lt)"
  15.144 +
  15.145 +lemma trmrec_Var[simp]:
  15.146 +"trmrec var app lam lt (Var x) = var x"
  15.147 +unfolding trmrec_def Var_def trm.rec trmBNF_map(1) by simp
  15.148 +
  15.149 +lemma trmrec_App[simp]:
  15.150 +"trmrec var app lam lt (App t1 t2) =
  15.151 + app t1 (trmrec var app lam lt t1) t2 (trmrec var app lam lt t2)"
  15.152 +unfolding trmrec_def App_def trm.rec trmBNF_map(2) convol_def by simp
  15.153 +
  15.154 +lemma trmrec_Lam[simp]:
  15.155 +"trmrec var app lam lt (Lam x t) = lam x t (trmrec var app lam lt t)"
  15.156 +unfolding trmrec_def Lam_def trm.rec trmBNF_map(3) convol_def by simp
  15.157 +
  15.158 +lemma trmrec_Lt[simp]:
  15.159 +"trmrec var app lam lt (Lt xts t) =
  15.160 + lt (map_fset (\<lambda> (x,t). (x,t,trmrec var app lam lt t)) xts) t (trmrec var app lam lt t)"
  15.161 +unfolding trmrec_def Lt_def trm.rec trmBNF_map(4) convol_def by simp
  15.162 +
  15.163 +definition
  15.164 +"sumJoinI4 f1 f2 f3 f4 \<equiv>
  15.165 +\<lambda> k. (case k of
  15.166 + Inl x1 \<Rightarrow> f1 x1
  15.167 +|Inr k1 \<Rightarrow> (case k1 of
  15.168 + Inl (a2,b2) \<Rightarrow> f2 a2 b2
  15.169 +|Inr k2 \<Rightarrow> (case k2 of Inl (x3,b3) \<Rightarrow> f3 x3 b3
  15.170 +|Inr (xts,b4) \<Rightarrow> f4 xts b4)))"
  15.171 +
  15.172 +lemma sumJoinI4_simps[simp]:
  15.173 +"\<And>x. sumJoinI4 var app lam lt (Inl x) = var x"
  15.174 +"\<And> a1 a2. sumJoinI4 var app lam lt (Inr (Inl (a1,a2))) = app a1 a2"
  15.175 +"\<And> x a. sumJoinI4 var app lam lt (Inr (Inr (Inl (x,a)))) = lam x a"
  15.176 +"\<And> xtas a. sumJoinI4 var app lam lt (Inr (Inr (Inr (xtas,a)))) = lt xtas a"
  15.177 +unfolding sumJoinI4_def by auto
  15.178 +
  15.179 +(* The iterator has a simpler, hence more manageable type. *)
  15.180 +definition "trmiter var app lam lt \<equiv> trm_iter (sumJoinI4 var app lam lt)"
  15.181 +
  15.182 +lemma trmiter_Var[simp]:
  15.183 +"trmiter var app lam lt (Var x) = var x"
  15.184 +unfolding trmiter_def Var_def trm.iter trmBNF_map(1) by simp
  15.185 +
  15.186 +lemma trmiter_App[simp]:
  15.187 +"trmiter var app lam lt (App t1 t2) =
  15.188 + app (trmiter var app lam lt t1) (trmiter var app lam lt t2)"
  15.189 +unfolding trmiter_def App_def trm.iter trmBNF_map(2) by simp
  15.190 +
  15.191 +lemma trmiter_Lam[simp]:
  15.192 +"trmiter var app lam lt (Lam x t) = lam x (trmiter var app lam lt t)"
  15.193 +unfolding trmiter_def Lam_def trm.iter trmBNF_map(3) by simp
  15.194 +
  15.195 +lemma trmiter_Lt[simp]:
  15.196 +"trmiter var app lam lt (Lt xts t) =
  15.197 + lt (map_fset (\<lambda> (x,t). (x,trmiter var app lam lt t)) xts) (trmiter var app lam lt t)"
  15.198 +unfolding trmiter_def Lt_def trm.iter trmBNF_map(4) by simp
  15.199 +
  15.200 +
  15.201 +subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
  15.202 +
  15.203 +definition "varsOf = trmiter
  15.204 +(\<lambda> x. {x})
  15.205 +(\<lambda> X1 X2. X1 \<union> X2)
  15.206 +(\<lambda> x X. X \<union> {x})
  15.207 +(\<lambda> xXs Y. Y \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| xXs}))"
  15.208 +
  15.209 +lemma varsOf_simps[simp]:
  15.210 +"varsOf (Var x) = {x}"
  15.211 +"varsOf (App t1 t2) = varsOf t1 \<union> varsOf t2"
  15.212 +"varsOf (Lam x t) = varsOf t \<union> {x}"
  15.213 +"varsOf (Lt xts t) =
  15.214 + varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,varsOf t1)) xts})"
  15.215 +unfolding varsOf_def by simp_all
  15.216 +
  15.217 +definition "fvarsOf = trmiter
  15.218 +(\<lambda> x. {x})
  15.219 +(\<lambda> X1 X2. X1 \<union> X2)
  15.220 +(\<lambda> x X. X - {x})
  15.221 +(\<lambda> xtXs Y. Y - {x | x X. (x,X) |\<in>| xtXs} \<union> (\<Union> {X | x X. (x,X) |\<in>| xtXs}))"
  15.222 +
  15.223 +lemma fvarsOf_simps[simp]:
  15.224 +"fvarsOf (Var x) = {x}"
  15.225 +"fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
  15.226 +"fvarsOf (Lam x t) = fvarsOf t - {x}"
  15.227 +"fvarsOf (Lt xts t) =
  15.228 + fvarsOf t
  15.229 + - {x | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts}
  15.230 + \<union> (\<Union> {X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts})"
  15.231 +unfolding fvarsOf_def by simp_all
  15.232 +
  15.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
  15.234 +
  15.235 +lemma in_map_fset_iff:
  15.236 +"(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, f t1)) xts \<longleftrightarrow>
  15.237 + (\<exists> t1. (x,t1) |\<in>| xts \<and> X = f t1)"
  15.238 +unfolding map_fset_def2_raw in_fset fset_afset unfolding fset_def2_raw by auto
  15.239 +
  15.240 +lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
  15.241 +proof induct
  15.242 +  case (Lt xts t)
  15.243 +  thus ?case unfolding fvarsOf_simps varsOf_simps
  15.244 +  proof (elim diff_Un_incl_triv)
  15.245 +    show
  15.246 +    "\<Union>{X | x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts}
  15.247 +     \<subseteq> \<Union>{{x} \<union> X |x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts}"
  15.248 +     (is "_ \<subseteq> \<Union> ?L")
  15.249 +    proof(rule Sup_mono, safe)
  15.250 +      fix a x X
  15.251 +      assume "(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts"
  15.252 +      then obtain t1 where x_t1: "(x,t1) |\<in>| xts" and X: "X = fvarsOf t1"
  15.253 +      unfolding in_map_fset_iff by auto
  15.254 +      let ?Y = "varsOf t1"
  15.255 +      have x_Y: "(x,?Y) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts"
  15.256 +      using x_t1 unfolding in_map_fset_iff by auto
  15.257 +      show "\<exists> Y \<in> ?L. X \<subseteq> Y" unfolding X using Lt(1) x_Y x_t1 by auto
  15.258 +    qed
  15.259 +  qed
  15.260 +qed auto
  15.261 +
  15.262 +end
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Codatatype/Examples/ListF.thy	Tue Aug 28 17:16:00 2012 +0200
    16.3 @@ -0,0 +1,171 @@
    16.4 +(*  Title:      Codatatype_Examples/ListF.thy
    16.5 +    Author:     Dmitriy Traytel, TU Muenchen
    16.6 +    Author:     Andrei Popescu, TU Muenchen
    16.7 +    Copyright   2012
    16.8 +
    16.9 +Finite lists.
   16.10 +*)
   16.11 +
   16.12 +header {* Finite Lists *}
   16.13 +
   16.14 +theory ListF
   16.15 +imports "../Codatatype/Codatatype"
   16.16 +begin
   16.17 +
   16.18 +bnf_data listF: 'list = "unit + 'a \<times> 'list"
   16.19 +
   16.20 +definition "NilF = listF_fld (Inl ())"
   16.21 +definition "Conss a as \<equiv> listF_fld (Inr (a, as))"
   16.22 +
   16.23 +lemma listF_map_NilF[simp]: "listF_map f NilF = NilF"
   16.24 +unfolding listF_map_def listFBNF_map_def NilF_def listF.iter by simp
   16.25 +
   16.26 +lemma listF_map_Conss[simp]:
   16.27 +  "listF_map f (Conss x xs) = Conss (f x) (listF_map f xs)"
   16.28 +unfolding listF_map_def listFBNF_map_def Conss_def listF.iter by simp
   16.29 +
   16.30 +lemma listF_set_NilF[simp]: "listF_set NilF = {}"
   16.31 +unfolding listF_set_def NilF_def listF.iter listFBNF_set1_def listFBNF_set2_def
   16.32 +  sum_set_defs listFBNF_map_def collect_def[abs_def] by simp
   16.33 +
   16.34 +lemma listF_set_Conss[simp]: "listF_set (Conss x xs) = {x} \<union> listF_set xs"
   16.35 +unfolding listF_set_def Conss_def listF.iter listFBNF_set1_def listFBNF_set2_def
   16.36 +  sum_set_defs prod_set_defs listFBNF_map_def collect_def[abs_def] by simp
   16.37 +
   16.38 +lemma iter_sum_case_NilF: "listF_iter (sum_case f g) NilF = f ()"
   16.39 +unfolding NilF_def listF.iter listFBNF_map_def by simp
   16.40 +
   16.41 +
   16.42 +lemma iter_sum_case_Conss:
   16.43 +  "listF_iter (sum_case f g) (Conss y ys) = g (y, listF_iter (sum_case f g) ys)"
   16.44 +unfolding Conss_def listF.iter listFBNF_map_def by simp
   16.45 +
   16.46 +(* familiar induction principle *)
   16.47 +lemma listF_induct:
   16.48 +  fixes xs :: "'a listF"
   16.49 +  assumes IB: "P NilF" and IH: "\<And>x xs. P xs \<Longrightarrow> P (Conss x xs)"
   16.50 +  shows "P xs"
   16.51 +proof (rule listF.fld_induct)
   16.52 +  fix xs :: "unit + 'a \<times> 'a listF"
   16.53 +  assume raw_IH: "\<And>a. a \<in> listFBNF_set2 xs \<Longrightarrow> P a"
   16.54 +  show "P (listF_fld xs)"
   16.55 +  proof (cases xs)
   16.56 +    case (Inl a) with IB show ?thesis unfolding NilF_def by simp
   16.57 +  next
   16.58 +    case (Inr b)
   16.59 +    then obtain y ys where yys: "listF_fld xs = Conss y ys"
   16.60 +      unfolding Conss_def listF.fld_inject by (blast intro: prod.exhaust)
   16.61 +    hence "ys \<in> listFBNF_set2 xs"
   16.62 +      unfolding listFBNF_set2_def Conss_def listF.fld_inject sum_set_defs prod_set_defs
   16.63 +        collect_def[abs_def] by simp
   16.64 +    with raw_IH have "P ys" by blast
   16.65 +    with IH have "P (Conss y ys)" by blast
   16.66 +    with yys show ?thesis by simp
   16.67 +  qed
   16.68 +qed
   16.69 +
   16.70 +rep_datatype NilF Conss
   16.71 +by (blast intro: listF_induct) (auto simp add: NilF_def Conss_def listF.fld_inject)
   16.72 +
   16.73 +definition Singll ("[[_]]") where
   16.74 +  [simp]: "Singll a \<equiv> Conss a NilF"
   16.75 +
   16.76 +definition appendd (infixr "@@" 65) where
   16.77 +  "appendd \<equiv> listF_iter (sum_case (\<lambda> _. id) (\<lambda> (a,f) bs. Conss a (f bs)))"
   16.78 +
   16.79 +definition "lrev \<equiv> listF_iter (sum_case (\<lambda> _. NilF) (\<lambda> (b,bs). bs @@ [[b]]))"
   16.80 +
   16.81 +lemma lrev_NilF[simp]: "lrev NilF = NilF"
   16.82 +unfolding lrev_def by (simp add: iter_sum_case_NilF)
   16.83 +
   16.84 +lemma lrev_Conss[simp]: "lrev (Conss y ys) = lrev ys @@ [[y]]"
   16.85 +unfolding lrev_def by (simp add: iter_sum_case_Conss)
   16.86 +
   16.87 +lemma NilF_appendd[simp]: "NilF @@ ys = ys"
   16.88 +unfolding appendd_def by (simp add: iter_sum_case_NilF)
   16.89 +
   16.90 +lemma Conss_append[simp]: "Conss x xs @@ ys = Conss x (xs @@ ys)"
   16.91 +unfolding appendd_def by (simp add: iter_sum_case_Conss)
   16.92 +
   16.93 +lemma appendd_NilF[simp]: "xs @@ NilF = xs"
   16.94 +by (rule listF_induct) auto
   16.95 +
   16.96 +lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
   16.97 +by (rule listF_induct) auto
   16.98 +
   16.99 +lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
  16.100 +by (rule listF_induct[of _ xs]) auto
  16.101 +
  16.102 +lemma listF_map_appendd[simp]:
  16.103 +  "listF_map f (xs @@ ys) = listF_map f xs @@ listF_map f ys"
  16.104 +by (rule listF_induct[of _ xs]) auto
  16.105 +
  16.106 +lemma lrev_listF_map[simp]: "lrev (listF_map f xs) = listF_map f (lrev xs)"
  16.107 +by (rule listF_induct[of _ xs]) auto
  16.108 +
  16.109 +lemma lrev_lrev[simp]: "lrev (lrev as) = as"
  16.110 +by (rule listF_induct) auto
  16.111 +
  16.112 +fun lengthh where
  16.113 +  "lengthh NilF = 0"
  16.114 +| "lengthh (Conss x xs) = Suc (lengthh xs)"
  16.115 +
  16.116 +fun nthh where
  16.117 +  "nthh (Conss x xs) 0 = x"
  16.118 +| "nthh (Conss x xs) (Suc n) = nthh xs n"
  16.119 +| "nthh xs i = undefined"
  16.120 +
  16.121 +lemma lengthh_listF_map[simp]: "lengthh (listF_map f xs) = lengthh xs"
  16.122 +by (rule listF_induct[of _ xs]) auto
  16.123 +
  16.124 +lemma nthh_listF_map[simp]:
  16.125 +  "i < lengthh xs \<Longrightarrow> nthh (listF_map f xs) i = f (nthh xs i)"
  16.126 +by (induct rule: nthh.induct) auto
  16.127 +
  16.128 +lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
  16.129 +by (induct rule: nthh.induct) auto
  16.130 +
  16.131 +lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
  16.132 +by (induct xs) auto
  16.133 +
  16.134 +lemma Conss_iff[iff]:
  16.135 +  "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
  16.136 +by (induct xs) auto
  16.137 +
  16.138 +lemma Conss_iff'[iff]:
  16.139 +  "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
  16.140 +by (induct xs) (simp, simp, blast)
  16.141 +
  16.142 +lemma listF_induct2: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
  16.143 +    \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
  16.144 +by (induct xs arbitrary: ys rule: listF_induct) auto
  16.145 +
  16.146 +fun zipp where
  16.147 +  "zipp NilF NilF = NilF"
  16.148 +| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
  16.149 +| "zipp xs ys = undefined"
  16.150 +
  16.151 +lemma listF_map_fst_zip[simp]:
  16.152 +  "lengthh xs = lengthh ys \<Longrightarrow> listF_map fst (zipp xs ys) = xs"
  16.153 +by (erule listF_induct2) auto
  16.154 +
  16.155 +lemma listF_map_snd_zip[simp]:
  16.156 +  "lengthh xs = lengthh ys \<Longrightarrow> listF_map snd (zipp xs ys) = ys"
  16.157 +by (erule listF_induct2) auto
  16.158 +
  16.159 +lemma lengthh_zip[simp]:
  16.160 +  "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
  16.161 +by (erule listF_induct2) auto
  16.162 +
  16.163 +lemma nthh_zip[simp]:
  16.164 +  assumes *: "lengthh xs = lengthh ys"
  16.165 +  shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
  16.166 +proof (induct arbitrary: i rule: listF_induct2[OF *])
  16.167 +  case (2 x xs y ys) thus ?case by (induct i) auto
  16.168 +qed simp
  16.169 +
  16.170 +lemma list_set_nthh[simp]:
  16.171 +  "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
  16.172 +by (induct xs) (auto, induct rule: nthh.induct, auto)
  16.173 +
  16.174 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Codatatype/Examples/Misc_Codata.thy	Tue Aug 28 17:16:00 2012 +0200
    17.3 @@ -0,0 +1,88 @@
    17.4 +(*  Title:      Codatatype_Examples/Misc_Data.thy
    17.5 +    Author:     Dmitriy Traytel, TU Muenchen
    17.6 +    Author:     Andrei Popescu, TU Muenchen
    17.7 +    Copyright   2012
    17.8 +
    17.9 +Miscellaneous codatatype declarations.
   17.10 +*)
   17.11 +
   17.12 +header {* Miscellaneous Codatatype Declarations *}
   17.13 +
   17.14 +theory Misc_Codata
   17.15 +imports "../Codatatype/Codatatype"
   17.16 +begin
   17.17 +
   17.18 +ML {* quick_and_dirty := false *}
   17.19 +
   17.20 +ML {* PolyML.fullGC (); *}
   17.21 +
   17.22 +bnf_codata simple: 'a = "unit + unit + unit + unit"
   17.23 +
   17.24 +bnf_codata stream: 's = "'a \<times> 's"
   17.25 +
   17.26 +bnf_codata llist: 'llist = "unit + 'a \<times> 'llist"
   17.27 +
   17.28 +bnf_codata some_passive: 'a = "'a + 'b + 'c + 'd + 'e"
   17.29 +
   17.30 +(*
   17.31 +  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   17.32 +  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   17.33 +*)
   17.34 +
   17.35 +bnf_codata F1: 'b1 = "'a \<times> 'b1 + 'a \<times> 'b2"
   17.36 +and F2: 'b2 = "unit + 'b1 * 'b2"
   17.37 +
   17.38 +bnf_codata EXPR:   'E = "'T + 'T \<times> 'E"
   17.39 +and TERM:   'T = "'F + 'F \<times> 'T"
   17.40 +and FACTOR: 'F = "'a + 'b + 'E"
   17.41 +
   17.42 +bnf_codata llambda:
   17.43 +  'trm = "string +
   17.44 +          'trm \<times> 'trm +
   17.45 +          string \<times> 'trm +
   17.46 +          (string \<times> 'trm) fset \<times> 'trm"
   17.47 +
   17.48 +bnf_codata par_llambda:
   17.49 +  'trm = "'a +
   17.50 +          'trm \<times> 'trm +
   17.51 +          'a \<times> 'trm +
   17.52 +          ('a \<times> 'trm) fset \<times> 'trm"
   17.53 +
   17.54 +(*
   17.55 +  'a tree = Empty | Node of 'a * 'a forest      ('b = unit + 'a * 'c)
   17.56 +  'a forest = Nil | Cons of 'a tree * 'a forest ('c = unit + 'b * 'c)
   17.57 +*)
   17.58 +
   17.59 +bnf_codata tree:     'tree = "unit + 'a \<times> 'forest"
   17.60 +and forest: 'forest = "unit + 'tree \<times> 'forest"
   17.61 +
   17.62 +bnf_codata CPS: 'a = "'b + 'b \<Rightarrow> 'a"
   17.63 +
   17.64 +bnf_codata fun_rhs: 'a = "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'a"
   17.65 +
   17.66 +bnf_codata fun_rhs': 'a = "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'b10 \<Rightarrow>
   17.67 +                    'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow> 'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow> 'a"
   17.68 +
   17.69 +bnf_codata some_killing: 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
   17.70 +and in_here: 'c = "'d \<times> 'b + 'e"
   17.71 +
   17.72 +bnf_codata some_killing': 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
   17.73 +and in_here': 'c = "'d + 'e"
   17.74 +
   17.75 +bnf_codata some_killing'': 'a = "'b \<Rightarrow> 'c"
   17.76 +and in_here'': 'c = "'d \<times> 'b + 'e"
   17.77 +
   17.78 +bnf_codata less_killing: 'a = "'b \<Rightarrow> 'c"
   17.79 +
   17.80 +(* SLOW, MEMORY-HUNGRY
   17.81 +bnf_codata K1': 'K1 = "'K2 + 'a list"
   17.82 +and K2': 'K2 = "'K3 + 'c fset"
   17.83 +and K3': 'K3 = "'K3 + 'K4 + 'K4 \<times> 'K5"
   17.84 +and K4': 'K4 = "'K5 + 'a list list list"
   17.85 +and K5': 'K5 = "'K6"
   17.86 +and K6': 'K6 = "'K7"
   17.87 +and K7': 'K7 = "'K8"
   17.88 +and K8': 'K8 = "'K1 list"
   17.89 +*)
   17.90 +
   17.91 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Codatatype/Examples/Misc_Data.thy	Tue Aug 28 17:16:00 2012 +0200
    18.3 @@ -0,0 +1,161 @@
    18.4 +(*  Title:      Codatatype_Examples/Misc_Data.thy
    18.5 +    Author:     Dmitriy Traytel, TU Muenchen
    18.6 +    Author:     Andrei Popescu, TU Muenchen
    18.7 +    Copyright   2012
    18.8 +
    18.9 +Miscellaneous datatype declarations.
   18.10 +*)
   18.11 +
   18.12 +header {* Miscellaneous Datatype Declarations *}
   18.13 +
   18.14 +theory Misc_Data
   18.15 +imports "../Codatatype/Codatatype"
   18.16 +begin
   18.17 +
   18.18 +ML {* quick_and_dirty := false *}
   18.19 +
   18.20 +ML {* PolyML.fullGC (); *}
   18.21 +
   18.22 +bnf_data simple: 'a = "unit + unit + unit + unit"
   18.23 +
   18.24 +bnf_data mylist: 'list = "unit + 'a \<times> 'list"
   18.25 +
   18.26 +bnf_data some_passive: 'a = "'a + 'b + 'c + 'd + 'e"
   18.27 +
   18.28 +bnf_data lambda:
   18.29 +  'trm = "string +
   18.30 +          'trm \<times> 'trm +
   18.31 +          string \<times> 'trm +
   18.32 +          (string \<times> 'trm) fset \<times> 'trm"
   18.33 +
   18.34 +bnf_data par_lambda:
   18.35 +  'trm = "'a +
   18.36 +          'trm \<times> 'trm +
   18.37 +          'a \<times> 'trm +
   18.38 +          ('a \<times> 'trm) fset \<times> 'trm"
   18.39 +
   18.40 +(*
   18.41 +  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   18.42 +  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   18.43 +*)
   18.44 +
   18.45 +bnf_data F1: 'b1 = "'a \<times> 'b1 + 'a \<times> 'b2"
   18.46 +and F2: 'b2 = "unit + 'b1 * 'b2"
   18.47 +
   18.48 +(*
   18.49 +  'a tree = Empty | Node of 'a * 'a forest      ('b = unit + 'a * 'c)
   18.50 +  'a forest = Nil | Cons of 'a tree * 'a forest ('c = unit + 'b * 'c)
   18.51 +*)
   18.52 +
   18.53 +bnf_data tree: 'tree = "unit + 'a \<times> 'forest"
   18.54 +and forest: 'forest = "unit + 'tree \<times> 'forest"
   18.55 +
   18.56 +(*
   18.57 +  'a tree = Empty | Node of 'a branch * 'a branch ('b = unit + 'c * 'c)
   18.58 +'  a branch = Branch of 'a * 'a tree              ('c = 'a * 'b)
   18.59 +*)
   18.60 +
   18.61 +bnf_data tree': 'tree = "unit + 'branch \<times> 'branch"
   18.62 +and branch: 'branch = "'a \<times> 'tree"
   18.63 +
   18.64 +(*
   18.65 +  exp = Sum of term * exp          ('c = 'd + 'd * 'c)
   18.66 +  term = Prod of factor * term     ('d = 'e + 'e * 'd)
   18.67 +  factor = C 'a | V 'b | Paren exp ('e = 'a + 'b + 'c)
   18.68 +*)
   18.69 +
   18.70 +bnf_data EXPR: 'E = "'T + 'T \<times> 'E"
   18.71 +and TERM: 'T = "'F + 'F \<times> 'T"
   18.72 +and FACTOR: 'F = "'a + 'b + 'E"
   18.73 +
   18.74 +bnf_data some_killing: 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
   18.75 +and in_here: 'c = "'d \<times> 'b + 'e"
   18.76 +
   18.77 +bnf_data nofail1: 'a = "'a \<times> 'b + 'b"
   18.78 +bnf_data nofail2: 'a = "('a \<times> 'b \<times> 'a \<times> 'b) list"
   18.79 +bnf_data nofail3: 'a = "'b \<times> ('a \<times> 'b \<times> 'a \<times> 'b) fset"
   18.80 +bnf_data nofail4: 'a = "('a \<times> ('a \<times> 'b \<times> 'a \<times> 'b) fset) list"
   18.81 +
   18.82 +(*
   18.83 +bnf_data fail: 'a = "'a \<times> 'b \<times> 'a \<times> 'b list"
   18.84 +bnf_data fail: 'a = "'a \<times> 'b \<times> 'a \<times> 'b"
   18.85 +bnf_data fail: 'a = "'a \<times> 'b + 'a"
   18.86 +bnf_data fail: 'a = "'a \<times> 'b"
   18.87 +*)
   18.88 +
   18.89 +bnf_data L1: 'L1 = "'L2 list"
   18.90 +and L2: 'L2 = "'L1 fset + 'L2"
   18.91 +
   18.92 +bnf_data K1: 'K1 = "'K2"
   18.93 +and K2: 'K2 = "'K3"
   18.94 +and K3: 'K3 = "'K1 list"
   18.95 +
   18.96 +bnf_data t1: 't1 = "'t3 + 't2"
   18.97 +and t2: 't2 = "'t1"
   18.98 +and t3: 't3 = "unit"
   18.99 +
  18.100 +bnf_data t1': 't1 = "'t2 + 't3"
  18.101 +and t2': 't2 = "'t1"
  18.102 +and t3': 't3 = "unit"
  18.103 +
  18.104 +(*
  18.105 +bnf_data fail1: 'L1 = "'L2"
  18.106 +and fail2: 'L2 = "'L3"
  18.107 +and fail2: 'L3 = "'L1"
  18.108 +
  18.109 +bnf_data fail1: 'L1 = "'L2 list \<times> 'L2"
  18.110 +and fail2: 'L2 = "'L2 fset \<times> 'L3"
  18.111 +and fail2: 'L3 = "'L1"
  18.112 +
  18.113 +bnf_data fail1: 'L1 = "'L2 list \<times> 'L2"
  18.114 +and fail2: 'L2 = "'L1 fset \<times> 'L1"
  18.115 +*)
  18.116 +(* SLOW
  18.117 +bnf_data K1': 'K1 = "'K2 + 'a list"
  18.118 +and K2': 'K2 = "'K3 + 'c fset"
  18.119 +and K3': 'K3 = "'K3 + 'K4 + 'K4 \<times> 'K5"
  18.120 +and K4': 'K4 = "'K5 + 'a list list list"
  18.121 +and K5': 'K5 = "'K6"
  18.122 +and K6': 'K6 = "'K7"
  18.123 +and K7': 'K7 = "'K8"
  18.124 +and K8': 'K8 = "'K1 list"
  18.125 +
  18.126 +(*time comparison*)
  18.127 +datatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  18.128 +     and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  18.129 +     and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  18.130 +     and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  18.131 +     and ('a, 'c) D5 = A5 "('a, 'c) D6"
  18.132 +     and ('a, 'c) D6 = A6 "('a, 'c) D7"
  18.133 +     and ('a, 'c) D7 = A7 "('a, 'c) D8"
  18.134 +     and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  18.135 +*)
  18.136 +
  18.137 +(* fail:
  18.138 +bnf_data t1: 't1 = "'t2 * 't3 + 't2 * 't4"
  18.139 +and t2: 't2 = "unit"
  18.140 +and t3: 't3 = 't4
  18.141 +and t4: 't4 = 't1
  18.142 +*)
  18.143 +
  18.144 +bnf_data k1: 'k1 = "'k2 * 'k3 + 'k2 * 'k4"
  18.145 +and k2: 'k2 = unit
  18.146 +and k3: 'k3 = 'k4
  18.147 +and k4: 'k4 = unit
  18.148 +
  18.149 +bnf_data tt1: 'tt1 = "'tt3 * 'tt2 + 'tt2 * 'tt4"
  18.150 +and tt2: 'tt2 = unit
  18.151 +and tt3: 'tt3 = 'tt1
  18.152 +and tt4: 'tt4 = unit
  18.153 +(* SLOW
  18.154 +bnf_data s1: 's1 = "'s2 * 's3 * 's4 + 's3 + 's2 * 's6 + 's4 * 's2 + 's2 * 's2"
  18.155 +and s2: 's2 = "'s7 * 's5 + 's5 * 's4 * 's6"
  18.156 +and s3: 's3 = "'s1 * 's7 * 's2 + 's3 * 's3 + 's4 * 's5"
  18.157 +and s4: 's4 = 's5
  18.158 +and s5: 's5 = unit
  18.159 +and s6: 's6 = "'s6 + 's1 * 's2 + 's6"
  18.160 +and s7: 's7 = "'s8 + 's5"
  18.161 +and s8: 's8 = nat
  18.162 +*)
  18.163 +
  18.164 +end
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Codatatype/Examples/Process.thy	Tue Aug 28 17:16:00 2012 +0200
    19.3 @@ -0,0 +1,742 @@
    19.4 +(*  Title:      Codatatype_Examples/Process.thy
    19.5 +    Author:     Andrei Popescu, TU Muenchen
    19.6 +    Copyright   2012
    19.7 +
    19.8 +Processes.
    19.9 +*)
   19.10 +
   19.11 +header {* Processes *}
   19.12 +
   19.13 +theory Process
   19.14 +imports "../Codatatype/Codatatype"
   19.15 +begin
   19.16 +
   19.17 +bnf_codata process: 'p = "'a * 'p + 'p * 'p"
   19.18 +(* codatatype
   19.19 +     'a process = Action (prefOf :: 'a) (contOf :: 'a process) |
   19.20 +                  Choice (ch1Of :: 'a process) (ch2Of :: 'a process)
   19.21 +*)
   19.22 +
   19.23 +(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
   19.24 +
   19.25 +section {* Customization *}
   19.26 +
   19.27 +subsection{* Setup for map, set, pred  *}
   19.28 +
   19.29 +(* These should be eventually inferred from compositionality *)
   19.30 +
   19.31 +lemma processBNF_map[simp]:
   19.32 +"processBNF_map fa fp (Inl (a ,p)) = Inl (fa a, fp p)"
   19.33 +"processBNF_map fa fp (Inr (p1, p2)) = Inr (fp p1, fp p2)"
   19.34 +unfolding processBNF_map_def by auto
   19.35 +
   19.36 +lemma processBNF_pred[simp]:
   19.37 +"processBNF_pred (op =) \<phi> (Inl (a,p)) (Inl (a',p')) \<longleftrightarrow> a = a' \<and> \<phi> p p'"
   19.38 +"processBNF_pred (op =) \<phi> (Inr (p,q)) (Inr (p',q')) \<longleftrightarrow> \<phi> p p' \<and> \<phi> q q'"
   19.39 +"\<not> processBNF_pred (op =) \<phi> (Inl ap) (Inr q1q2)"
   19.40 +"\<not> processBNF_pred (op =) \<phi> (Inr q1q2) (Inl ap)"
   19.41 +by (auto simp: diag_def processBNF.pred_unfold)
   19.42 +
   19.43 +
   19.44 +subsection{* Constructors *}
   19.45 +
   19.46 +definition Action :: "'a \<Rightarrow> 'a process \<Rightarrow> 'a process"
   19.47 +where "Action a p \<equiv> process_fld (Inl (a,p))"
   19.48 +
   19.49 +definition Choice :: "'a process \<Rightarrow> 'a process \<Rightarrow> 'a process"
   19.50 +where "Choice p1 p2 \<equiv> process_fld (Inr (p1,p2))"
   19.51 +
   19.52 +lemmas ctor_defs = Action_def Choice_def
   19.53 +
   19.54 +
   19.55 +subsection {* Discriminators *}
   19.56 +
   19.57 +(* One discriminator for each constructor. By the constructor exhaustiveness,
   19.58 +one of them is of course redundant, so for n constructors we only need n-1
   19.59 +discriminators. However, keeping n discriminators seems more uniform.   *)
   19.60 +
   19.61 +definition isAction :: "'a process \<Rightarrow> bool"
   19.62 +where "isAction q \<equiv> \<exists> a p. q = Action a p"
   19.63 +
   19.64 +definition isChoice :: "'a process \<Rightarrow> bool"
   19.65 +where "isChoice q \<equiv> \<exists> p1 p2. q = Choice p1 p2"
   19.66 +
   19.67 +lemmas discr_defs = isAction_def isChoice_def
   19.68 +
   19.69 +
   19.70 +subsection {* Pre-selectors *}
   19.71 +
   19.72 +(* These are mere auxiliaries *)
   19.73 +
   19.74 +definition "asAction q \<equiv> SOME ap. q = Action (fst ap) (snd ap)"
   19.75 +definition "asChoice q \<equiv> SOME p1p2. q = Choice (fst p1p2) (snd p1p2)"
   19.76 +lemmas pre_sel_defs = asAction_def asChoice_def
   19.77 +
   19.78 +
   19.79 +subsection {* Selectors *}
   19.80 +
   19.81 +(* One for each pair (constructor, constructor argument) *)
   19.82 +
   19.83 +(* For Action: *)
   19.84 +definition prefOf :: "'a process \<Rightarrow> 'a" where "prefOf q = fst (asAction q)"
   19.85 +definition contOf :: "'a process \<Rightarrow> 'a process" where "contOf q = snd (asAction q)"
   19.86 +
   19.87 +(* For Choice: *)
   19.88 +definition ch1Of :: "'a process \<Rightarrow> 'a process" where "ch1Of q = fst (asChoice q)"
   19.89 +definition ch2Of :: "'a process \<Rightarrow> 'a process" where "ch2Of q = snd (asChoice q)"
   19.90 +
   19.91 +lemmas sel_defs = prefOf_def contOf_def ch1Of_def ch2Of_def
   19.92 +
   19.93 +
   19.94 +subsection {* Basic properties *}
   19.95 +
   19.96 +(* Selectors versus discriminators *)
   19.97 +lemma isAction_asAction:
   19.98 +"isAction q \<longleftrightarrow> q = Action (fst (asAction q)) (snd (asAction q))"
   19.99 +(is "?L \<longleftrightarrow> ?R")
  19.100 +proof
  19.101 +  assume ?L
  19.102 +  then obtain a p where q: "q = Action a p" unfolding isAction_def by auto
  19.103 +  show ?R unfolding asAction_def q by (rule someI[of _ "(a,p)"]) simp
  19.104 +qed(unfold isAction_def, auto)
  19.105 +
  19.106 +theorem isAction_prefOf_contOf:
  19.107 +"isAction q \<longleftrightarrow> q = Action (prefOf q) (contOf q)"
  19.108 +using isAction_asAction unfolding prefOf_def contOf_def .
  19.109 +
  19.110 +lemma isChoice_asChoice:
  19.111 +"isChoice q \<longleftrightarrow> q = Choice (fst (asChoice q)) (snd (asChoice q))"
  19.112 +(is "?L \<longleftrightarrow> ?R")
  19.113 +proof
  19.114 +  assume ?L
  19.115 +  then obtain p1 p2 where q: "q = Choice p1 p2" unfolding isChoice_def by auto
  19.116 +  show ?R unfolding asChoice_def q by (rule someI[of _ "(p1,p2)"]) simp
  19.117 +qed(unfold isChoice_def, auto)
  19.118 +
  19.119 +theorem isChoice_ch1Of_ch2Of:
  19.120 +"isChoice q \<longleftrightarrow> q = Choice (ch1Of q) (ch2Of q)"
  19.121 +using isChoice_asChoice unfolding ch1Of_def ch2Of_def .
  19.122 +
  19.123 +(* Constructors *)
  19.124 +theorem process_simps[simp]:
  19.125 +"Action a p = Action a' p' \<longleftrightarrow> a = a' \<and> p = p'"
  19.126 +"Choice p1 p2 = Choice p1' p2' \<longleftrightarrow> p1 = p1' \<and> p2 = p2'"
  19.127 +(*  *)
  19.128 +"Action a p \<noteq> Choice p1 p2"
  19.129 +"Choice p1 p2 \<noteq> Action a p"
  19.130 +unfolding ctor_defs process.fld_inject by auto
  19.131 +
  19.132 +theorem process_cases[elim, case_names Action Choice]:
  19.133 +assumes Action: "\<And> a p. q = Action a p \<Longrightarrow> phi"
  19.134 +and Choice: "\<And> p1 p2. q = Choice p1 p2 \<Longrightarrow> phi"
  19.135 +shows phi
  19.136 +proof(cases rule: process.fld_exhaust[of q])
  19.137 +  fix x assume "q = process_fld x"
  19.138 +  thus ?thesis
  19.139 +  apply(cases x)
  19.140 +    apply(case_tac a) using Action unfolding ctor_defs apply blast
  19.141 +    apply(case_tac b) using Choice unfolding ctor_defs apply blast
  19.142 +  done
  19.143 +qed
  19.144 +
  19.145 +(* Constructors versus discriminators *)
  19.146 +theorem isAction_isChoice:
  19.147 +"isAction p \<or> isChoice p"
  19.148 +unfolding isAction_def isChoice_def by (cases rule: process_cases) auto
  19.149 +
  19.150 +theorem isAction_Action[simp]: "isAction (Action a p)"
  19.151 +unfolding isAction_def by auto
  19.152 +
  19.153 +theorem isAction_Choice[simp]: "\<not> isAction (Choice p1 p2)"
  19.154 +unfolding isAction_def by auto
  19.155 +
  19.156 +theorem isChoice_Choice[simp]: "isChoice (Choice p1 p2)"
  19.157 +unfolding isChoice_def by auto
  19.158 +
  19.159 +theorem isChoice_Action[simp]: "\<not> isChoice (Action a p)"
  19.160 +unfolding isChoice_def by auto
  19.161 +
  19.162 +theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
  19.163 +by (cases rule: process_cases[of p]) auto
  19.164 +
  19.165 +(* Constructors versus selectors *)
  19.166 +theorem dest_ctor[simp]:
  19.167 +"prefOf (Action a p) = a"
  19.168 +"contOf (Action a p) = p"
  19.169 +"ch1Of (Choice p1 p2) = p1"
  19.170 +"ch2Of (Choice p1 p2) = p2"
  19.171 +using isAction_Action[of a p]
  19.172 +      isChoice_Choice[of p1 p2]
  19.173 +unfolding isAction_prefOf_contOf
  19.174 +          isChoice_ch1Of_ch2Of by auto
  19.175 +
  19.176 +theorem ctor_dtor[simp]:
  19.177 +"\<And> p. isAction p \<Longrightarrow> Action (prefOf p) (contOf p) = p"
  19.178 +"\<And> p. isChoice p \<Longrightarrow> Choice (ch1Of p) (ch2Of p) = p"
  19.179 +unfolding isAction_def isChoice_def by auto
  19.180 +
  19.181 +
  19.182 +subsection{* Coinduction *}
  19.183 +
  19.184 +theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
  19.185 +assumes phi: "\<phi> p p'" and
  19.186 +iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
  19.187 +Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
  19.188 +Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
  19.189 +shows "p = p'"
  19.190 +proof(intro mp[OF process.pred_coinduct, of \<phi>, OF _ phi], clarify)
  19.191 +  fix p p'  assume \<phi>: "\<phi> p p'"
  19.192 +  show "processBNF_pred (op =) \<phi> (process_unf p) (process_unf p')"
  19.193 +  proof(cases rule: process_cases[of p])
  19.194 +    case (Action a q) note p = Action
  19.195 +    hence "isAction p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
  19.196 +    then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process_cases[of p'], auto)
  19.197 +    have 0: "a = a' \<and> \<phi> q q'" using Act[OF \<phi>[unfolded p p']] .
  19.198 +    have unf: "process_unf p = Inl (a,q)" "process_unf p' = Inl (a',q')"
  19.199 +    unfolding p p' Action_def process.unf_fld by simp_all
  19.200 +    show ?thesis using 0 unfolding unf by simp
  19.201 +  next
  19.202 +    case (Choice p1 p2) note p = Choice
  19.203 +    hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
  19.204 +    then obtain p1' p2' where p': "p' = Choice p1' p2'"
  19.205 +    by (cases rule: process_cases[of p'], auto)
  19.206 +    have 0: "\<phi> p1 p1' \<and> \<phi> p2 p2'" using Ch[OF \<phi>[unfolded p p']] .
  19.207 +    have unf: "process_unf p = Inr (p1,p2)" "process_unf p' = Inr (p1',p2')"
  19.208 +    unfolding p p' Choice_def process.unf_fld by simp_all
  19.209 +    show ?thesis using 0 unfolding unf by simp
  19.210 +  qed
  19.211 +qed
  19.212 +
  19.213 +(* Stronger coinduction, up to equality: *)
  19.214 +theorem process_coind_upto[elim, consumes 1, case_names iss Action Choice]:
  19.215 +assumes phi: "\<phi> p p'" and
  19.216 +iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
  19.217 +Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
  19.218 +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')"
  19.219 +shows "p = p'"
  19.220 +proof(intro mp[OF process.pred_coinduct_upto, of \<phi>, OF _ phi], clarify)
  19.221 +  fix p p'  assume \<phi>: "\<phi> p p'"
  19.222 +  show "processBNF_pred (op =) (\<lambda>a b. \<phi> a b \<or> a = b) (process_unf p) (process_unf p')"
  19.223 +  proof(cases rule: process_cases[of p])
  19.224 +    case (Action a q) note p = Action
  19.225 +    hence "isAction p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
  19.226 +    then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process_cases[of p'], auto)
  19.227 +    have 0: "a = a' \<and> (\<phi> q q' \<or> q = q')" using Act[OF \<phi>[unfolded p p']] .
  19.228 +    have unf: "process_unf p = Inl (a,q)" "process_unf p' = Inl (a',q')"
  19.229 +    unfolding p p' Action_def process.unf_fld by simp_all
  19.230 +    show ?thesis using 0 unfolding unf by simp
  19.231 +  next
  19.232 +    case (Choice p1 p2) note p = Choice
  19.233 +    hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
  19.234 +    then obtain p1' p2' where p': "p' = Choice p1' p2'"
  19.235 +    by (cases rule: process_cases[of p'], auto)
  19.236 +    have 0: "(\<phi> p1 p1' \<or> p1 = p1') \<and> (\<phi> p2 p2' \<or> p2 = p2')" using Ch[OF \<phi>[unfolded p p']] .
  19.237 +    have unf: "process_unf p = Inr (p1,p2)" "process_unf p' = Inr (p1',p2')"
  19.238 +    unfolding p p' Choice_def process.unf_fld by simp_all
  19.239 +    show ?thesis using 0 unfolding unf by simp
  19.240 +  qed
  19.241 +qed
  19.242 +
  19.243 +
  19.244 +subsection {* Coiteration and corecursion *}
  19.245 +
  19.246 +(* Preliminaries: *)
  19.247 +definition
  19.248 +"join22 isA pr co isC c1 c2 \<equiv>
  19.249 + \<lambda> P. if isA P then Inl (pr P, co P)
  19.250 + else if isC P then Inr (c1 P, c2 P)
  19.251 + else undefined"
  19.252 +
  19.253 +declare process.unf_fld[simp]
  19.254 +declare process.fld_unf[simp]
  19.255 +
  19.256 +lemma unf_Action[simp]:
  19.257 +"process_unf (Action a p) = Inl (a,p)"
  19.258 +unfolding Action_def process.unf_fld ..
  19.259 +
  19.260 +lemma unf_Choice[simp]:
  19.261 +"process_unf (Choice p1 p2) = Inr (p1,p2)"
  19.262 +unfolding Choice_def process.unf_fld ..
  19.263 +
  19.264 +lemma isAction_unf:
  19.265 +assumes "isAction p"
  19.266 +shows "process_unf p = Inl (prefOf p, contOf p)"
  19.267 +using assms unfolding isAction_def by auto
  19.268 +
  19.269 +lemma isChoice_unf:
  19.270 +assumes "isChoice p"
  19.271 +shows "process_unf p = Inr (ch1Of p, ch2Of p)"
  19.272 +using assms unfolding isChoice_def by auto
  19.273 +
  19.274 +lemma unf_join22:
  19.275 +"process_unf p = join22 isAction prefOf contOf isChoice ch1Of ch2Of p"
  19.276 +unfolding join22_def
  19.277 +using isAction_unf isChoice_unf not_isAction_isChoice isAction_isChoice by auto
  19.278 +
  19.279 +lemma isA_join22:
  19.280 +assumes "isA P"
  19.281 +shows "join22 isA pr co isC c1 c2 P = Inl (pr P, co P)"
  19.282 +using assms unfolding join22_def by auto
  19.283 +
  19.284 +lemma isC_join22:
  19.285 +assumes "\<not> isA P" and "isC P"
  19.286 +shows "join22 isA pr co isC c1 c2 P = Inr (c1 P, c2 P)"
  19.287 +using assms unfolding join22_def by auto
  19.288 +
  19.289 +(* Coiteration *)
  19.290 +definition pcoiter ::
  19.291 +"('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b)
  19.292 + \<Rightarrow>
  19.293 + ('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b)
  19.294 + \<Rightarrow>
  19.295 + 'b \<Rightarrow> 'a process"
  19.296 +where "pcoiter isA pr co isC c1 c2 \<equiv> process_coiter (join22 isA pr co isC c1 c2)"
  19.297 +
  19.298 +lemma unf_prefOf:
  19.299 +assumes "process_unf q = Inl (a,p)"
  19.300 +shows "prefOf q = a"
  19.301 +using assms by (cases rule: process_cases[of q]) auto
  19.302 +
  19.303 +lemma unf_contOf:
  19.304 +assumes "process_unf q = Inl (a,p)"
  19.305 +shows "contOf q = p"
  19.306 +using assms by (cases rule: process_cases[of q]) auto
  19.307 +
  19.308 +lemma unf_ch1Of:
  19.309 +assumes "process_unf q = Inr (p1,p2)"
  19.310 +shows "ch1Of q = p1"
  19.311 +using assms by (cases rule: process_cases[of q]) auto
  19.312 +
  19.313 +lemma unf_ch2Of:
  19.314 +assumes "process_unf q = Inr (p1,p2)"
  19.315 +shows "ch2Of q = p2"
  19.316 +using assms by (cases rule: process_cases[of q]) auto
  19.317 +
  19.318 +theorem pcoiter:
  19.319 +"\<And>P. isA P \<Longrightarrow>
  19.320 +    pcoiter isA pr co isC c1 c2 P =
  19.321 +    Action (pr P)
  19.322 +           (pcoiter isA pr co isC c1 c2 (co P))"
  19.323 +"\<And>P. \<lbrakk>\<not> isA P; isC P\<rbrakk> \<Longrightarrow>
  19.324 +    pcoiter isA pr co isC c1 c2 P =
  19.325 +    Choice (pcoiter isA pr co isC c1 c2 (c1 P))
  19.326 +           (pcoiter isA pr co isC c1 c2 (c2 P))"
  19.327 +proof-
  19.328 +  fix P
  19.329 +  let ?f = "pcoiter isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
  19.330 +  assume isA: "isA P"
  19.331 +  have unf: "process_unf (process_coiter ?s P) = Inl (pr P, ?f (co P))"
  19.332 +  using process.coiter[of ?s P]
  19.333 +  unfolding isA_join22[of isA P "pr" co isC c1 c2, OF isA]
  19.334 +            processBNF_map id_apply pcoiter_def .
  19.335 +  thus "?f P = Action (pr P) (?f (co P))"
  19.336 +  unfolding pcoiter_def Action_def using process.fld_unf by metis
  19.337 +next
  19.338 +  fix P
  19.339 +  let ?f = "pcoiter isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
  19.340 +  assume isA: "\<not> isA P" and isC: "isC P"
  19.341 +  have unf: "process_unf (process_coiter ?s P) = Inr (?f (c1 P), ?f (c2 P))"
  19.342 +  using process.coiter[of ?s P]
  19.343 +  unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
  19.344 +            processBNF_map id_apply pcoiter_def .
  19.345 +  thus "?f P = Choice (?f (c1 P)) (?f (c2 P))"
  19.346 +  unfolding pcoiter_def Choice_def using process.fld_unf by metis
  19.347 +qed
  19.348 +
  19.349 +(* Corecursion, more general than coiteration (often unnecessarily more general): *)
  19.350 +definition pcorec ::
  19.351 +"('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'a process + 'b)
  19.352 + \<Rightarrow>
  19.353 + ('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a process + 'b) \<Rightarrow> ('b \<Rightarrow> 'a process + 'b)
  19.354 + \<Rightarrow>
  19.355 + 'b \<Rightarrow> 'a process"
  19.356 +where
  19.357 +"pcorec isA pr co isC c1 c2 \<equiv> process_corec (join22 isA pr co isC c1 c2)"
  19.358 +
  19.359 +theorem pcorec_Action:
  19.360 +assumes isA: "isA P"
  19.361 +shows
  19.362 +"case co P of
  19.363 +   Inl p \<Rightarrow> pcorec isA pr co isC c1 c2 P = Action (pr P) p
  19.364 +  |Inr Q \<Rightarrow> pcorec isA pr co isC c1 c2 P =
  19.365 +            Action (pr P)
  19.366 +                   (pcorec isA pr co isC c1 c2 Q)"
  19.367 +proof-
  19.368 +  let ?f = "pcorec isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
  19.369 +  show ?thesis
  19.370 +  proof(cases "co P")
  19.371 +    case (Inl p)
  19.372 +    have "process_unf (process_corec ?s P) = Inl (pr P, p)"
  19.373 +    using process.corec[of ?s P]
  19.374 +    unfolding isA_join22[of isA P "pr" co isC c1 c2, OF isA]
  19.375 +              processBNF_map id_apply pcorec_def Inl by simp
  19.376 +    thus ?thesis unfolding Inl pcorec_def Action_def using process.fld_unf by (simp, metis)
  19.377 +  next
  19.378 +    case (Inr Q)
  19.379 +    have "process_unf (process_corec ?s P) = Inl (pr P, ?f Q)"
  19.380 +    using process.corec[of ?s P]
  19.381 +    unfolding isA_join22[of isA P "pr" co isC c1 c2, OF isA]
  19.382 +              processBNF_map id_apply pcorec_def Inr by simp
  19.383 +    thus ?thesis unfolding Inr pcorec_def Action_def using process.fld_unf by (simp, metis)
  19.384 +  qed
  19.385 +qed
  19.386 +
  19.387 +theorem pcorec_Choice:
  19.388 +assumes isA: "\<not> isA P" and isC: "isC P"
  19.389 +shows
  19.390 +"case (c1 P,c2 P) of
  19.391 +   (Inl p1, Inl p2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
  19.392 +                      Choice p1 p2
  19.393 +  |(Inl p1, Inr Q2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
  19.394 +                      Choice p1
  19.395 +                             (pcorec isA pr co isC c1 c2 Q2)
  19.396 +  |(Inr Q1, Inl p2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
  19.397 +                      Choice (pcorec isA pr co isC c1 c2 Q1)
  19.398 +                             p2
  19.399 +  |(Inr Q1, Inr Q2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
  19.400 +                      Choice (pcorec isA pr co isC c1 c2 Q1)
  19.401 +                             (pcorec isA pr co isC c1 c2 Q2)"
  19.402 +proof-
  19.403 +  let ?f = "pcorec isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
  19.404 +  show ?thesis
  19.405 +  proof(cases "c1 P")
  19.406 +    case (Inl p1) note c1 = Inl
  19.407 +    show ?thesis
  19.408 +    proof(cases "c2 P")
  19.409 +      case (Inl p2)  note c2 = Inl
  19.410 +      have "process_unf (process_corec ?s P) = Inr (p1, p2)"
  19.411 +      using process.corec[of ?s P]
  19.412 +      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
  19.413 +                processBNF_map id_apply pcorec_def c1 c2 by simp
  19.414 +      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
  19.415 +    next
  19.416 +      case (Inr Q2)  note c2 = Inr
  19.417 +      have "process_unf (process_corec ?s P) = Inr (p1, ?f Q2)"
  19.418 +      using process.corec[of ?s P]
  19.419 +      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
  19.420 +                processBNF_map id_apply pcorec_def c1 c2 by simp
  19.421 +      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
  19.422 +    qed
  19.423 +  next
  19.424 +    case (Inr Q1) note c1 = Inr
  19.425 +    show ?thesis
  19.426 +    proof(cases "c2 P")
  19.427 +      case (Inl p2)  note c2 = Inl
  19.428 +      have "process_unf (process_corec ?s P) = Inr (?f Q1, p2)"
  19.429 +      using process.corec[of ?s P]
  19.430 +      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
  19.431 +                processBNF_map id_apply pcorec_def c1 c2 by simp
  19.432 +      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
  19.433 +    next
  19.434 +      case (Inr Q2)  note c2 = Inr
  19.435 +      have "process_unf (process_corec ?s P) = Inr (?f Q1, ?f Q2)"
  19.436 +      using process.corec[of ?s P]
  19.437 +      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
  19.438 +                processBNF_map id_apply pcorec_def c1 c2 by simp
  19.439 +      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
  19.440 +    qed
  19.441 +  qed
  19.442 +qed
  19.443 +
  19.444 +theorems pcorec = pcorec_Action pcorec_Choice
  19.445 +
  19.446 +
  19.447 +section{* Coinductive definition of the notion of trace *}
  19.448 +
  19.449 +(* Say we have a type of streams: *)
  19.450 +typedecl 'a stream
  19.451 +consts Ccons :: "'a \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
  19.452 +
  19.453 +(* Use the existing coinductive package (distinct from our
  19.454 +new codatatype package, but highly compatible with it): *)
  19.455 +
  19.456 +coinductive trace where
  19.457 +"trace p as \<Longrightarrow> trace (Action a p) (Ccons a as)"
  19.458 +|
  19.459 +"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
  19.460 +
  19.461 +
  19.462 +section{* Examples of corecursive definitions: *}
  19.463 +
  19.464 +subsection{* Single-guard fixpoint definition *}
  19.465 +
  19.466 +definition
  19.467 +"BX \<equiv>
  19.468 + pcoiter
  19.469 +   (\<lambda> P. True)
  19.470 +   (\<lambda> P. ''a'')
  19.471 +   (\<lambda> P. P)
  19.472 +   undefined
  19.473 +   undefined
  19.474 +   undefined
  19.475 +   ()"
  19.476 +
  19.477 +lemma BX: "BX = Action ''a'' BX"
  19.478 +unfolding BX_def
  19.479 +using pcoiter(1)[of "\<lambda> P. True" "()"  "\<lambda> P. ''a''" "\<lambda> P. P"] by simp
  19.480 +
  19.481 +
  19.482 +subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
  19.483 +
  19.484 +datatype x_y_ax = x | y | ax
  19.485 +
  19.486 +definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False     |y \<Rightarrow> True  |ax \<Rightarrow> True"
  19.487 +definition "pr  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
  19.488 +definition "co  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x    |ax \<Rightarrow> x"
  19.489 +lemmas Action_defs = isA_def pr_def co_def
  19.490 +
  19.491 +definition "isC \<equiv> \<lambda> K. case K of x \<Rightarrow> True |y \<Rightarrow> False     |ax \<Rightarrow> False"
  19.492 +definition "c1  \<equiv> \<lambda> K. case K of x \<Rightarrow> ax   |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
  19.493 +definition "c2  \<equiv> \<lambda> K. case K of x \<Rightarrow> y    |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
  19.494 +lemmas Choice_defs = isC_def c1_def c2_def
  19.495 +
  19.496 +definition "F \<equiv> pcoiter isA pr co isC c1 c2"
  19.497 +definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
  19.498 +
  19.499 +lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
  19.500 +unfolding X_def Y_def AX_def F_def
  19.501 +using pcoiter(2)[of isA x isC "pr" co c1 c2]
  19.502 +      pcoiter(1)[of isA y  "pr" co isC c1 c2]
  19.503 +      pcoiter(1)[of isA ax "pr" co isC c1 c2]
  19.504 +unfolding Action_defs Choice_defs by simp_all
  19.505 +
  19.506 +(* end product: *)
  19.507 +lemma X_AX:
  19.508 +"X = Choice AX (Action ''b'' X)"
  19.509 +"AX = Action ''a'' X"
  19.510 +using X_Y_AX by simp_all
  19.511 +
  19.512 +
  19.513 +
  19.514 +section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
  19.515 +
  19.516 +hide_const x y ax X Y AX
  19.517 +
  19.518 +(* Process terms *)
  19.519 +datatype ('a,'pvar) process_term =
  19.520 + VAR 'pvar |
  19.521 + PROC "'a process" |
  19.522 + ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
  19.523 +
  19.524 +(* below, sys represents a system of equations *)
  19.525 +fun isACT where
  19.526 +"isACT sys (VAR X) =
  19.527 + (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
  19.528 +|
  19.529 +"isACT sys (PROC p) = isAction p"
  19.530 +|
  19.531 +"isACT sys (ACT a T) = True"
  19.532 +|
  19.533 +"isACT sys (CH T1 T2) = False"
  19.534 +
  19.535 +fun PREF where
  19.536 +"PREF sys (VAR X) =
  19.537 + (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
  19.538 +|
  19.539 +"PREF sys (PROC p) = prefOf p"
  19.540 +|
  19.541 +"PREF sys (ACT a T) = a"
  19.542 +
  19.543 +fun CONT where
  19.544 +"CONT sys (VAR X) =
  19.545 + (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
  19.546 +|
  19.547 +"CONT sys (PROC p) = PROC (contOf p)"
  19.548 +|
  19.549 +"CONT sys (ACT a T) = T"
  19.550 +
  19.551 +fun isCH where
  19.552 +"isCH sys (VAR X) =
  19.553 + (case sys X of CH T1 T2 \<Rightarrow> True |PROC p \<Rightarrow> isChoice p |_ \<Rightarrow> False)"
  19.554 +|
  19.555 +"isCH sys (PROC p) = isChoice p"
  19.556 +|
  19.557 +"isCH sys (ACT a T) = False"
  19.558 +|
  19.559 +"isCH sys (CH T1 T2) = True"
  19.560 +
  19.561 +fun CH1 where
  19.562 +"CH1 sys (VAR X) =
  19.563 + (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
  19.564 +|
  19.565 +"CH1 sys (PROC p) = PROC (ch1Of p)"
  19.566 +|
  19.567 +"CH1 sys (CH T1 T2) = T1"
  19.568 +
  19.569 +fun CH2 where
  19.570 +"CH2 sys (VAR X) =
  19.571 + (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
  19.572 +|
  19.573 +"CH2 sys (PROC p) = PROC (ch2Of p)"
  19.574 +|
  19.575 +"CH2 sys (CH T1 T2) = T2"
  19.576 +
  19.577 +definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
  19.578 +
  19.579 +lemma guarded_isACT_isCH:
  19.580 +assumes g: "guarded sys"
  19.581 +shows "isACT sys T \<or> isCH sys T"
  19.582 +proof(induct T)
  19.583 +  case (VAR X)
  19.584 +  thus ?case
  19.585 +  using g isAction_isChoice unfolding guarded_def by (cases "sys X", auto)
  19.586 +qed(insert isAction_isChoice assms, unfold guarded_def, auto)
  19.587 +
  19.588 +definition
  19.589 +"solution sys \<equiv>
  19.590 + pcoiter
  19.591 +   (isACT sys)
  19.592 +   (PREF sys)
  19.593 +   (CONT sys)
  19.594 +   (isCH sys)
  19.595 +   (CH1 sys)
  19.596 +   (CH2 sys)"
  19.597 +
  19.598 +lemma solution_Action:
  19.599 +assumes "isACT sys T"
  19.600 +shows "solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
  19.601 +unfolding solution_def
  19.602 +using pcoiter(1)[of "isACT sys" T "PREF sys" "CONT sys"
  19.603 +                        "isCH sys" "CH1 sys" "CH2 sys"] assms by simp
  19.604 +
  19.605 +lemma solution_Choice:
  19.606 +assumes "\<not> isACT sys T" "isCH sys T"
  19.607 +shows "solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
  19.608 +unfolding solution_def
  19.609 +using pcoiter(2)[of "isACT sys" T "isCH sys" "PREF sys" "CONT sys"
  19.610 +                        "CH1 sys" "CH2 sys"] assms by simp
  19.611 +
  19.612 +lemma isACT_VAR:
  19.613 +assumes g: "guarded sys"
  19.614 +shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
  19.615 +using g unfolding guarded_def by (cases "sys X") auto
  19.616 +
  19.617 +lemma isCH_VAR:
  19.618 +assumes g: "guarded sys"
  19.619 +shows "isCH sys (VAR X) \<longleftrightarrow> isCH sys (sys X)"
  19.620 +using g unfolding guarded_def by (cases "sys X") auto
  19.621 +
  19.622 +lemma solution_VAR:
  19.623 +assumes g: "guarded sys"
  19.624 +shows "solution sys (VAR X) = solution sys (sys X)"
  19.625 +proof(cases "isACT sys (VAR X)")
  19.626 +  case True
  19.627 +  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  19.628 +  show ?thesis
  19.629 +  unfolding solution_Action[OF T] using solution_Action[of sys "VAR X"] True g
  19.630 +  unfolding guarded_def by (cases "sys X", auto)
  19.631 +next
  19.632 +  case False note FFalse = False
  19.633 +  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  19.634 +  show ?thesis
  19.635 +  proof(cases "isCH sys (VAR X)")
  19.636 +    case True
  19.637 +    hence T: "isCH sys (sys X)" unfolding isCH_VAR[OF g] .
  19.638 +    show ?thesis
  19.639 +    unfolding solution_Choice[OF TT T] using solution_Choice[of sys "VAR X"] FFalse True g
  19.640 +    unfolding guarded_def by (cases "sys X", auto)
  19.641 +  next
  19.642 +    case False
  19.643 +    hence False using FFalse guarded_isACT_isCH[OF g, of "VAR X"] by simp
  19.644 +    thus ?thesis by simp
  19.645 +  qed
  19.646 +qed
  19.647 +
  19.648 +lemma solution_PROC[simp]:
  19.649 +"solution sys (PROC p) = p"
  19.650 +proof-
  19.651 +  {fix q assume "q = solution sys (PROC p)"
  19.652 +   hence "p = q"
  19.653 +   proof(induct rule: process_coind)
  19.654 +     case (iss p p')
  19.655 +     from isAction_isChoice[of p] show ?case
  19.656 +     proof
  19.657 +       assume p: "isAction p"
  19.658 +       hence 0: "isACT sys (PROC p)" by simp
  19.659 +       thus ?thesis using iss not_isAction_isChoice
  19.660 +       unfolding solution_Action[OF 0] by auto
  19.661 +     next
  19.662 +       assume "isChoice p"
  19.663 +       hence 0: "isCH sys (PROC p)" and p: "\<not> isAction p"
  19.664 +       using not_isAction_isChoice by auto
  19.665 +       hence 1: "\<not> isACT sys (PROC p)" by simp
  19.666 +       show ?thesis using 0 iss not_isAction_isChoice
  19.667 +       unfolding solution_Choice[OF 1 0] by auto
  19.668 +     qed
  19.669 +   next
  19.670 +     case (Action a a' p p')
  19.671 +     hence 0: "isACT sys (PROC (Action a p))" by simp
  19.672 +     show ?case using Action unfolding solution_Action[OF 0] by simp
  19.673 +   next
  19.674 +     case (Choice p q p' q')
  19.675 +     hence 0: "isCH sys (PROC (Choice p q))" by simp
  19.676 +     hence 1: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
  19.677 +     show ?case using Choice unfolding solution_Choice[OF 1 0] by simp
  19.678 +   qed
  19.679 +  }
  19.680 +  thus ?thesis by metis
  19.681 +qed
  19.682 +
  19.683 +lemma solution_ACT[simp]:
  19.684 +"solution sys (ACT a T) = Action a (solution sys T)"
  19.685 +by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution_Action)
  19.686 +
  19.687 +lemma solution_CH[simp]:
  19.688 +"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
  19.689 +by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) isCH.simps(4) solution_Choice)
  19.690 +
  19.691 +
  19.692 +(* Example: *)
  19.693 +
  19.694 +fun sys where
  19.695 +"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
  19.696 +|
  19.697 +"sys (Suc 0) = ACT ''a'' (VAR 0)"
  19.698 +| (* dummy guarded term for variables outside the system: *)
  19.699 +"sys X = ACT ''a'' (VAR 0)"
  19.700 +
  19.701 +lemma guarded_sys:
  19.702 +"guarded sys"
  19.703 +unfolding guarded_def proof (intro allI)
  19.704 +  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  19.705 +qed
  19.706 +
  19.707 +(* the actual processes: *)
  19.708 +definition "x \<equiv> solution sys (VAR 0)"
  19.709 +definition "ax \<equiv> solution sys (VAR (Suc 0))"
  19.710 +
  19.711 +(* end product: *)
  19.712 +lemma x_ax:
  19.713 +"x = Choice ax (Action ''b'' x)"
  19.714 +"ax = Action ''a'' x"
  19.715 +unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
  19.716 +
  19.717 +
  19.718 +(* Thanks to the inclusion of processes as process terms, one can
  19.719 +also consider parametrized systems of equations---here, x is a (semantic)
  19.720 +process parameter: *)
  19.721 +
  19.722 +fun sys' where
  19.723 +"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
  19.724 +|
  19.725 +"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
  19.726 +| (* dummy guarded term : *)
  19.727 +"sys' X = ACT ''a'' (VAR 0)"
  19.728 +
  19.729 +lemma guarded_sys':
  19.730 +"guarded sys'"
  19.731 +unfolding guarded_def proof (intro allI)
  19.732 +  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  19.733 +qed
  19.734 +
  19.735 +(* the actual processes: *)
  19.736 +definition "y \<equiv> solution sys' (VAR 0)"
  19.737 +definition "ay \<equiv> solution sys' (VAR (Suc 0))"
  19.738 +
  19.739 +(* end product: *)
  19.740 +lemma y_ay:
  19.741 +"y = Choice x (Action ''b'' y)"
  19.742 +"ay = Choice (Action ''a'' y) x"
  19.743 +unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
  19.744 +
  19.745 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Codatatype/Examples/Stream.thy	Tue Aug 28 17:16:00 2012 +0200
    20.3 @@ -0,0 +1,159 @@
    20.4 +(*  Title:      Codatatype_Examples/Stream.thy
    20.5 +    Author:     Dmitriy Traytel, TU Muenchen
    20.6 +    Author:     Andrei Popescu, TU Muenchen
    20.7 +    Copyright   2012
    20.8 +
    20.9 +Infinite streams.
   20.10 +*)
   20.11 +
   20.12 +header {* Infinite Streams *}
   20.13 +
   20.14 +theory Stream
   20.15 +imports TreeFI
   20.16 +begin
   20.17 +
   20.18 +bnf_codata stream: 's = "'a \<times> 's"
   20.19 +
   20.20 +(* selectors for streams *)
   20.21 +definition "hdd as \<equiv> fst (stream_unf as)"
   20.22 +definition "tll as \<equiv> snd (stream_unf as)"
   20.23 +
   20.24 +lemma coiter_pair_fun_hdd[simp]: "hdd (stream_coiter (f \<odot> g) t) = f t"
   20.25 +unfolding hdd_def pair_fun_def stream.coiter by simp
   20.26 +
   20.27 +lemma coiter_pair_fun_tll[simp]: "tll (stream_coiter (f \<odot> g) t) =
   20.28 + stream_coiter (f \<odot> g) (g t)"
   20.29 +unfolding tll_def pair_fun_def stream.coiter by simp
   20.30 +
   20.31 +(* infinite trees: *)
   20.32 +coinductive infiniteTr where
   20.33 +"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   20.34 +
   20.35 +lemma infiniteTr_coind_upto[consumes 1, case_names sub]:
   20.36 +assumes *: "phi tr" and
   20.37 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
   20.38 +shows "infiniteTr tr"
   20.39 +using assms by (elim infiniteTr.coinduct) blast
   20.40 +
   20.41 +lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
   20.42 +assumes *: "phi tr" and
   20.43 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
   20.44 +shows "infiniteTr tr"
   20.45 +using assms by (elim infiniteTr.coinduct) blast
   20.46 +
   20.47 +lemma infiniteTr_sub[simp]:
   20.48 +"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
   20.49 +by (erule infiniteTr.cases) blast
   20.50 +
   20.51 +definition "konigPath \<equiv> stream_coiter
   20.52 +  (lab \<odot> (\<lambda>tr. SOME tr'. tr' \<in> listF_set (sub tr) \<and> infiniteTr tr'))"
   20.53 +
   20.54 +lemma hdd_simps1[simp]: "hdd (konigPath t) = lab t"
   20.55 +unfolding konigPath_def by simp
   20.56 +
   20.57 +lemma tll_simps2[simp]: "tll (konigPath t) =
   20.58 +  konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
   20.59 +unfolding konigPath_def by simp
   20.60 +
   20.61 +(* proper paths in trees: *)
   20.62 +coinductive properPath where
   20.63 +"\<lbrakk>hdd as = lab tr; tr' \<in> listF_set (sub tr); properPath (tll as) tr'\<rbrakk> \<Longrightarrow>
   20.64 + properPath as tr"
   20.65 +
   20.66 +lemma properPath_coind_upto[consumes 1, case_names hdd_lab sub]:
   20.67 +assumes *: "phi as tr" and
   20.68 +**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
   20.69 +***: "\<And> as tr.
   20.70 +         phi as tr \<Longrightarrow>
   20.71 +         \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
   20.72 +shows "properPath as tr"
   20.73 +using assms by (elim properPath.coinduct) blast
   20.74 +
   20.75 +lemma properPath_coind[consumes 1, case_names hdd_lab sub, induct pred: properPath]:
   20.76 +assumes *: "phi as tr" and
   20.77 +**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
   20.78 +***: "\<And> as tr.
   20.79 +         phi as tr \<Longrightarrow>
   20.80 +         \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr'"
   20.81 +shows "properPath as tr"
   20.82 +using properPath_coind_upto[of phi, OF * **] *** by blast
   20.83 +
   20.84 +lemma properPath_hdd_lab:
   20.85 +"properPath as tr \<Longrightarrow> hdd as = lab tr"
   20.86 +by (erule properPath.cases) blast
   20.87 +
   20.88 +lemma properPath_sub:
   20.89 +"properPath as tr \<Longrightarrow>
   20.90 + \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
   20.91 +by (erule properPath.cases) blast
   20.92 +
   20.93 +(* prove the following by coinduction *)
   20.94 +theorem Konig:
   20.95 +  assumes "infiniteTr tr"
   20.96 +  shows "properPath (konigPath tr) tr"
   20.97 +proof-
   20.98 +  {fix as
   20.99 +   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
  20.100 +   proof (induct rule: properPath_coind, safe)
  20.101 +     fix t
  20.102 +     let ?t = "SOME t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'"
  20.103 +     assume "infiniteTr t"
  20.104 +     hence "\<exists>t' \<in> listF_set (sub t). infiniteTr t'" by simp
  20.105 +     hence "\<exists>t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'" by blast
  20.106 +     hence "?t \<in> listF_set (sub t) \<and> infiniteTr ?t" by (elim someI_ex)
  20.107 +     moreover have "tll (konigPath t) = konigPath ?t" by simp
  20.108 +     ultimately show "\<exists>t' \<in> listF_set (sub t).
  20.109 +             infiniteTr t' \<and> tll (konigPath t) = konigPath t'" by blast
  20.110 +   qed simp
  20.111 +  }
  20.112 +  thus ?thesis using assms by blast
  20.113 +qed
  20.114 +
  20.115 +(* some more stream theorems *)
  20.116 +
  20.117 +lemma stream_map[simp]: "stream_map f = stream_coiter (f o hdd \<odot> tll)"
  20.118 +unfolding stream_map_def pair_fun_def hdd_def[abs_def] tll_def[abs_def]
  20.119 +  map_pair_def o_def prod_case_beta by simp
  20.120 +
  20.121 +lemma streamBNF_pred[simp]: "streamBNF_pred \<phi>1 \<phi>2 a b = (\<phi>1 (fst a) (fst b) \<and> \<phi>2 (snd a) (snd b))"
  20.122 +by (auto simp: streamBNF.pred_unfold)
  20.123 +
  20.124 +lemmas stream_coind = mp[OF stream.pred_coinduct, unfolded streamBNF_pred[abs_def],
  20.125 +  folded hdd_def tll_def]
  20.126 +
  20.127 +definition plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
  20.128 +  [simp]: "plus xs ys =
  20.129 +    stream_coiter ((%(xs, ys). hdd xs + hdd ys) \<odot> (%(xs, ys). (tll xs, tll ys))) (xs, ys)"
  20.130 +
  20.131 +definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
  20.132 +  [simp]: "scalar n = stream_map (\<lambda>x. n * x)"
  20.133 +
  20.134 +definition ones :: "nat stream" where [simp]: "ones = stream_coiter ((%x. 1) \<odot> id) ()"
  20.135 +definition twos :: "nat stream" where [simp]: "twos = stream_coiter ((%x. 2) \<odot> id) ()"
  20.136 +definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
  20.137 +
  20.138 +lemma "ones \<oplus> ones = twos"
  20.139 +by (intro stream_coind[where phi="%x1 x2. \<exists>x. x1 = ones \<oplus> ones \<and> x2 = twos"])
  20.140 +   auto
  20.141 +
  20.142 +lemma "n \<cdot> twos = ns (2 * n)"
  20.143 +by (intro stream_coind[where phi="%x1 x2. \<exists>n. x1 = n \<cdot> twos \<and> x2 = ns (2 * n)"])
  20.144 +   force+
  20.145 +
  20.146 +lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
  20.147 +by (intro stream_coind[where phi="%x1 x2. \<exists>n m xs. x1 = (n * m) \<cdot> xs \<and> x2 = n \<cdot> m \<cdot> xs"])
  20.148 +   force+
  20.149 +
  20.150 +lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
  20.151 +by (intro stream_coind[where phi="%x1 x2. \<exists>n xs ys. x1 = n \<cdot> (xs \<oplus> ys) \<and> x2 = n \<cdot> xs \<oplus> n \<cdot> ys"])
  20.152 +   (force simp: add_mult_distrib2)+
  20.153 +
  20.154 +lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
  20.155 +by (intro stream_coind[where phi="%x1 x2. \<exists>xs ys. x1 = xs \<oplus> ys \<and> x2 = ys \<oplus> xs"])
  20.156 +   force+
  20.157 +
  20.158 +lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
  20.159 +by (intro stream_coind[where phi="%x1 x2. \<exists>xs ys zs. x1 = (xs \<oplus> ys) \<oplus> zs \<and> x2 = xs \<oplus> ys \<oplus> zs"])
  20.160 +   force+
  20.161 +
  20.162 +end
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/Codatatype/Examples/TreeFI.thy	Tue Aug 28 17:16:00 2012 +0200
    21.3 @@ -0,0 +1,81 @@
    21.4 +(*  Title:      Codatatype_Examples/TreeFI.thy
    21.5 +    Author:     Dmitriy Traytel, TU Muenchen
    21.6 +    Author:     Andrei Popescu, TU Muenchen
    21.7 +    Copyright   2012
    21.8 +
    21.9 +Finitely branching possibly infinite trees.
   21.10 +*)
   21.11 +
   21.12 +header {* Finitely Branching Possibly Infinite Trees *}
   21.13 +
   21.14 +theory TreeFI
   21.15 +imports ListF
   21.16 +begin
   21.17 +
   21.18 +bnf_codata treeFI: 'tree = "'a \<times> 'tree listF"
   21.19 +
   21.20 +lemma treeFIBNF_listF_set[simp]: "treeFIBNF_set2 (i, xs) = listF_set xs"
   21.21 +unfolding treeFIBNF_set2_def collect_def[abs_def] prod_set_defs
   21.22 +by (auto simp add: listF.set_natural')
   21.23 +
   21.24 +(* selectors for trees *)
   21.25 +definition "lab tr \<equiv> fst (treeFI_unf tr)"
   21.26 +definition "sub tr \<equiv> snd (treeFI_unf tr)"
   21.27 +
   21.28 +lemma unf[simp]: "treeFI_unf tr = (lab tr, sub tr)"
   21.29 +unfolding lab_def sub_def by simp
   21.30 +
   21.31 +definition pair_fun (infixr "\<odot>" 50) where
   21.32 +  "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
   21.33 +
   21.34 +lemma coiter_pair_fun_lab: "lab (treeFI_coiter (f \<odot> g) t) = f t"
   21.35 +unfolding lab_def pair_fun_def treeFI.coiter treeFIBNF_map_def by simp
   21.36 +
   21.37 +lemma coiter_pair_fun_sub: "sub (treeFI_coiter (f \<odot> g) t) = listF_map (treeFI_coiter (f \<odot> g)) (g t)"
   21.38 +unfolding sub_def pair_fun_def treeFI.coiter treeFIBNF_map_def by simp
   21.39 +
   21.40 +(* Tree reverse:*)
   21.41 +definition "trev \<equiv> treeFI_coiter (lab \<odot> lrev o sub)"
   21.42 +
   21.43 +lemma trev_simps1[simp]: "lab (trev t) = lab t"
   21.44 +unfolding trev_def by (simp add: coiter_pair_fun_lab)
   21.45 +
   21.46 +lemma trev_simps2[simp]: "sub (trev t) = listF_map trev (lrev (sub t))"
   21.47 +unfolding trev_def by (simp add: coiter_pair_fun_sub)
   21.48 +
   21.49 +lemma treeFI_coinduct:
   21.50 +assumes *: "phi x y"
   21.51 +and step: "\<And>a b. phi a b \<Longrightarrow>
   21.52 +   lab a = lab b \<and>
   21.53 +   lengthh (sub a) = lengthh (sub b) \<and>
   21.54 +   (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
   21.55 +shows "x = y"
   21.56 +proof (rule mp[OF treeFI.unf_coinduct, of phi, OF _ *])
   21.57 +  fix a b :: "'a treeFI"
   21.58 +  let ?zs = "zipp (sub a) (sub b)"
   21.59 +  let ?z = "(lab a, ?zs)"
   21.60 +  assume "phi a b"
   21.61 +  with step have step': "lab a = lab b" "lengthh (sub a) = lengthh (sub b)"
   21.62 +    "\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i)" by auto
   21.63 +  hence "treeFIBNF_map id fst ?z = treeFI_unf a" "treeFIBNF_map id snd ?z = treeFI_unf b"
   21.64 +    unfolding treeFIBNF_map_def by auto
   21.65 +  moreover have "\<forall>(x, y) \<in> treeFIBNF_set2 ?z. phi x y"
   21.66 +  proof safe
   21.67 +    fix z1 z2
   21.68 +    assume "(z1, z2) \<in> treeFIBNF_set2 ?z"
   21.69 +    hence "(z1, z2) \<in> listF_set ?zs" by auto
   21.70 +    hence "\<exists>i < lengthh ?zs. nthh ?zs i = (z1, z2)" by auto
   21.71 +    with step'(2) obtain i where "i < lengthh (sub a)"
   21.72 +      "nthh (sub a) i = z1" "nthh (sub b) i = z2" by auto
   21.73 +    with step'(3) show "phi z1 z2" by auto
   21.74 +  qed
   21.75 +  ultimately show "\<exists>z.
   21.76 +    (treeFIBNF_map id fst z = treeFI_unf a \<and>
   21.77 +    treeFIBNF_map id snd z = treeFI_unf b) \<and>
   21.78 +    (\<forall>x y. (x, y) \<in> treeFIBNF_set2 z \<longrightarrow> phi x y)" by blast
   21.79 +qed
   21.80 +
   21.81 +lemma trev_trev: "trev (trev tr) = tr"
   21.82 +by (rule treeFI_coinduct[of "%a b. trev (trev b) = a"]) auto
   21.83 +
   21.84 +end
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Codatatype/Examples/TreeFsetI.thy	Tue Aug 28 17:16:00 2012 +0200
    22.3 @@ -0,0 +1,56 @@
    22.4 +(*  Title:      Codatatype_Examples/TreeFsetI.thy
    22.5 +    Author:     Dmitriy Traytel, TU Muenchen
    22.6 +    Author:     Andrei Popescu, TU Muenchen
    22.7 +    Copyright   2012
    22.8 +
    22.9 +Finitely branching possibly infinite trees, with sets of children.
   22.10 +*)
   22.11 +
   22.12 +header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
   22.13 +
   22.14 +theory TreeFsetI
   22.15 +imports "../Codatatype/Codatatype"
   22.16 +begin
   22.17 +
   22.18 +definition pair_fun (infixr "\<odot>" 50) where
   22.19 +  "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
   22.20 +
   22.21 +bnf_codata treeFsetI: 't = "'a \<times> 't fset"
   22.22 +
   22.23 +(* selectors for trees *)
   22.24 +definition "lab t \<equiv> fst (treeFsetI_unf t)"
   22.25 +definition "sub t \<equiv> snd (treeFsetI_unf t)"
   22.26 +
   22.27 +lemma unf[simp]: "treeFsetI_unf t = (lab t, sub t)"
   22.28 +unfolding lab_def sub_def by simp
   22.29 +
   22.30 +lemma coiter_pair_fun_lab: "lab (treeFsetI_coiter (f \<odot> g) t) = f t"
   22.31 +unfolding lab_def pair_fun_def treeFsetI.coiter treeFsetIBNF_map_def by simp
   22.32 +
   22.33 +lemma coiter_pair_fun_sub: "sub (treeFsetI_coiter (f \<odot> g) t) = map_fset (treeFsetI_coiter (f \<odot> g)) (g t)"
   22.34 +unfolding sub_def pair_fun_def treeFsetI.coiter treeFsetIBNF_map_def by simp
   22.35 +
   22.36 +(* tree map (contrived example): *)
   22.37 +definition "tmap f \<equiv> treeFsetI_coiter (f o lab \<odot> sub)"
   22.38 +
   22.39 +lemma tmap_simps1[simp]: "lab (tmap f t) = f (lab t)"
   22.40 +unfolding tmap_def by (simp add: coiter_pair_fun_lab)
   22.41 +
   22.42 +lemma trev_simps2[simp]: "sub (tmap f t) = map_fset (tmap f) (sub t)"
   22.43 +unfolding tmap_def by (simp add: coiter_pair_fun_sub)
   22.44 +
   22.45 +lemma treeFsetIBNF_pred[simp]: "treeFsetIBNF_pred R1 R2 a b = (R1 (fst a) (fst b) \<and>
   22.46 +  (\<forall>t \<in> fset (snd a). (\<exists>u \<in> fset (snd b). R2 t u)) \<and>
   22.47 +  (\<forall>t \<in> fset (snd b). (\<exists>u \<in> fset (snd a). R2 u t)))"
   22.48 +apply (cases a)
   22.49 +apply (cases b)
   22.50 +apply (simp add: treeFsetIBNF.pred_unfold)
   22.51 +done
   22.52 +
   22.53 +lemmas treeFsetI_coind = mp[OF treeFsetI.pred_coinduct]
   22.54 +
   22.55 +lemma "tmap (f o g) x = tmap f (tmap g x)"
   22.56 +by (intro treeFsetI_coind[where phi="%x1 x2. \<exists>x. x1 = tmap (f o g) x \<and> x2 = tmap f (tmap g x)"])
   22.57 +   force+
   22.58 +
   22.59 +end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Codatatype/README.html	Tue Aug 28 17:16:00 2012 +0200
    23.3 @@ -0,0 +1,58 @@
    23.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
    23.5 +
    23.6 +<html>
    23.7 +
    23.8 +<head>
    23.9 +  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
   23.10 +  <title>Codatatype Package</title>
   23.11 +</head>
   23.12 +
   23.13 +<body>
   23.14 +
   23.15 +<h3><i>Codatatype</i>: A (co)datatype package based on bounded natural functors
   23.16 +(BNFs)</h3>
   23.17 +
   23.18 +<p>
   23.19 +The <i>Codatatype</i> package provides a fully modular framework for
   23.20 +constructing inductive and coinductive datatypes in HOL, with support for mixed
   23.21 +mutual and nested (co)recursion. Mixed (co)recursion enables type definitions
   23.22 +involving both datatypes and codatatypes, such as the type of finitely branching
   23.23 +trees of possibly infinite depth. The framework draws heavily from category
   23.24 +theory.
   23.25 +
   23.26 +<p>
   23.27 +The package is described in the following paper:
   23.28 +
   23.29 +<ul>
   23.30 +  <li><a href="http://www21.in.tum.de/~traytel/papers/codatatypes/index.html">Foundational, Compositional (Co)datatypes for Higher-Order Logic&mdash;Category Theory Applied to Theorem Proving</a>, <br>
   23.31 +  Dmitriy Traytel, Andrei Popescu, and Jasmin Christian Blanchette.<br>
   23.32 +  <i>Logic in Computer Science (LICS 2012)</i>, 2012.
   23.33 +</ul>
   23.34 +
   23.35 +<p>
   23.36 +The main entry point for applications is <tt>Codatatype.thy</tt>.
   23.37 +The <tt>Examples</tt> directory contains various examples of (co)datatypes,
   23.38 +including the examples from the paper.
   23.39 +
   23.40 +<p>
   23.41 +The key notion underlying the package is that of a <i>bounded natural functor</i>
   23.42 +(<i>BNF</i>)&mdash;an enriched type constructor satisfying specific properties
   23.43 +preserved by interesting categorical operations (composition, least fixed point,
   23.44 +and greatest fixed point). The <tt>Basic_BNFs.thy</tt> file registers
   23.45 +various basic types, notably for sums, products, function spaces, finite sets,
   23.46 +multisets, and countable sets. Custom BNFs can be registered as well.
   23.47 +
   23.48 +<p>
   23.49 +<b>Warning:</b> The package is under development. Future versions are expected
   23.50 +to support multiple constructors and selectors per (co)datatype (instead of a
   23.51 +single <i>fld</i> or <i>unf</i> constant) and provide a nicer syntax for
   23.52 +(co)datatype and (co)recursive function definitions. Please contact
   23.53 +any of
   23.54 +<a href="mailto:traytel@in.tum.de">the</a>
   23.55 +<a href="mailto:popescua@in.tum.de">above</a>
   23.56 +<a href="mailto:blanchette@in.tum.de">authors</a>
   23.57 +if you have questions or comments.
   23.58 +
   23.59 +</body>
   23.60 +
   23.61 +</html>
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/Codatatype/Tools/bnf_comp.ML	Tue Aug 28 17:16:00 2012 +0200
    24.3 @@ -0,0 +1,834 @@
    24.4 +(*  Title:      HOL/Codatatype/Tools/bnf_comp.ML
    24.5 +    Author:     Dmitriy Traytel, TU Muenchen
    24.6 +    Author:     Jasmin Blanchette, TU Muenchen
    24.7 +    Copyright   2012
    24.8 +
    24.9 +Composition of bounded natural functors.
   24.10 +*)
   24.11 +
   24.12 +signature BNF_COMP =
   24.13 +sig
   24.14 +  type unfold_thms
   24.15 +  val empty_unfold: unfold_thms
   24.16 +  val map_unfolds_of: unfold_thms -> thm list
   24.17 +  val set_unfoldss_of: unfold_thms -> thm list list
   24.18 +  val rel_unfolds_of: unfold_thms -> thm list
   24.19 +  val pred_unfolds_of: unfold_thms -> thm list
   24.20 +
   24.21 +  val default_comp_sort: (string * sort) list list -> (string * sort) list
   24.22 +  val bnf_of_typ: BNF_Def.const_policy -> binding -> (binding -> binding) ->
   24.23 +    ((string * sort) list list -> (string * sort) list) -> typ -> unfold_thms * Proof.context ->
   24.24 +    (BNF_Def.BNF * (typ list * typ list)) * (unfold_thms * Proof.context)
   24.25 +  val bnf_of_typ_cmd: binding * string -> Proof.context -> Proof.context
   24.26 +  val seal_bnf: unfold_thms -> binding -> typ list -> BNF_Def.BNF -> Proof.context ->
   24.27 +    BNF_Def.BNF * local_theory
   24.28 +  val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
   24.29 +    (''a list list -> ''a list) -> BNF_Def.BNF list -> unfold_thms -> Proof.context ->
   24.30 +    (int list list * ''a list) * (BNF_Def.BNF list * (unfold_thms * Proof.context))
   24.31 +end;
   24.32 +
   24.33 +structure BNF_Comp : BNF_COMP =
   24.34 +struct
   24.35 +
   24.36 +open BNF_Def
   24.37 +open BNF_Util
   24.38 +open BNF_Tactics
   24.39 +open BNF_Comp_Tactics
   24.40 +
   24.41 +type unfold_thms = {
   24.42 +  map_unfolds: thm list,
   24.43 +  set_unfoldss: thm list list,
   24.44 +  rel_unfolds: thm list,
   24.45 +  pred_unfolds: thm list
   24.46 +};
   24.47 +
   24.48 +fun add_to_thms thms NONE = thms
   24.49 +  | add_to_thms thms (SOME new) = if Thm.is_reflexive new then thms else insert Thm.eq_thm new thms;
   24.50 +fun adds_to_thms thms NONE = thms
   24.51 +  | adds_to_thms thms (SOME news) = insert (eq_set Thm.eq_thm) (filter_refl news) thms;
   24.52 +
   24.53 +fun mk_unfold_thms maps setss rels preds =
   24.54 +  {map_unfolds = maps, set_unfoldss = setss, rel_unfolds = rels, pred_unfolds = preds};
   24.55 +
   24.56 +val empty_unfold = mk_unfold_thms [] [] [] [];
   24.57 +
   24.58 +fun add_to_unfold_opt map_opt sets_opt rel_opt pred_opt
   24.59 +  {map_unfolds = maps, set_unfoldss = setss, rel_unfolds = rels, pred_unfolds = preds} = {
   24.60 +    map_unfolds = add_to_thms maps map_opt,
   24.61 +    set_unfoldss = adds_to_thms setss sets_opt,
   24.62 +    rel_unfolds = add_to_thms rels rel_opt,
   24.63 +    pred_unfolds = add_to_thms preds pred_opt};
   24.64 +
   24.65 +fun add_to_unfold map sets rel pred =
   24.66 +  add_to_unfold_opt (SOME map) (SOME sets) (SOME rel) (SOME pred);
   24.67 +
   24.68 +val map_unfolds_of = #map_unfolds;
   24.69 +val set_unfoldss_of = #set_unfoldss;
   24.70 +val rel_unfolds_of = #rel_unfolds;
   24.71 +val pred_unfolds_of = #pred_unfolds;
   24.72 +
   24.73 +val bdTN = "bdT";
   24.74 +
   24.75 +val compN = "comp_"
   24.76 +fun mk_killN n = "kill" ^ string_of_int n ^ "_";
   24.77 +fun mk_liftN n = "lift" ^ string_of_int n ^ "_";
   24.78 +fun mk_permuteN src dest =
   24.79 +  "permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest) ^ "_";
   24.80 +
   24.81 +val no_thm = refl;
   24.82 +val Collect_split_box_equals = box_equals RS @{thm Collect_split_cong};
   24.83 +val abs_pred_sym = sym RS @{thm abs_pred_def};
   24.84 +val abs_pred_sym_pred_abs = abs_pred_sym RS @{thm pred_def_abs};
   24.85 +
   24.86 +(*copied from Envir.expand_term_free*)
   24.87 +fun expand_term_const defs =
   24.88 +  let
   24.89 +    val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
   24.90 +    val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
   24.91 +  in Envir.expand_term get end;
   24.92 +
   24.93 +fun clean_compose_bnf const_policy qualify b outer inners (unfold, lthy) =
   24.94 +  let
   24.95 +    val olive = live_of_bnf outer;
   24.96 +    val onwits = nwits_of_bnf outer;
   24.97 +    val odead = dead_of_bnf outer;
   24.98 +    val inner = hd inners;
   24.99 +    val ilive = live_of_bnf inner;
  24.100 +    val ideads = map dead_of_bnf inners;
  24.101 +    val inwitss = map nwits_of_bnf inners;
  24.102 +
  24.103 +    (* TODO: check olive = length inners > 0,
  24.104 +                   forall inner from inners. ilive = live,
  24.105 +                   forall inner from inners. idead = dead  *)
  24.106 +
  24.107 +    val (oDs, lthy1) = apfst (map TFree)
  24.108 +      (Variable.invent_types (replicate odead HOLogic.typeS) lthy);
  24.109 +    val (Dss, lthy2) = apfst (map (map TFree))
  24.110 +        (fold_map Variable.invent_types (map (fn n => replicate n HOLogic.typeS) ideads) lthy1);
  24.111 +    val (Ass, lthy3) = apfst (replicate ilive o map TFree)
  24.112 +      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy2);
  24.113 +    val As = if ilive > 0 then hd Ass else [];
  24.114 +    val Ass_repl = replicate olive As;
  24.115 +    val (Bs, _(*lthy4*)) = apfst (map TFree)
  24.116 +      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy3);
  24.117 +    val Bss_repl = replicate olive Bs;
  24.118 +
  24.119 +    val (((fs', Asets), xs), _(*names_lthy*)) = lthy
  24.120 +      |> apfst snd o mk_Frees' "f" (map2 (curry (op -->)) As Bs)
  24.121 +      ||>> mk_Frees "A" (map (HOLogic.mk_setT) As)
  24.122 +      ||>> mk_Frees "x" As;
  24.123 +
  24.124 +    val CAs = map3 mk_T_of_bnf Dss Ass_repl inners;
  24.125 +    val CCA = mk_T_of_bnf oDs CAs outer;
  24.126 +    val CBs = map3 mk_T_of_bnf Dss Bss_repl inners;
  24.127 +    val outer_sets = mk_sets_of_bnf (replicate olive oDs) (replicate olive CAs) outer;
  24.128 +    val inner_setss = map3 mk_sets_of_bnf (map (replicate ilive) Dss) (replicate olive Ass) inners;
  24.129 +    val inner_bds = map3 mk_bd_of_bnf Dss Ass_repl inners;
  24.130 +    val outer_bd = mk_bd_of_bnf oDs CAs outer;
  24.131 +
  24.132 +    (*%f1 ... fn. outer.map (inner_1.map f1 ... fn) ... (inner_m.map f1 ... fn)*)
  24.133 +    val comp_map = fold_rev Term.abs fs'
  24.134 +      (Term.list_comb (mk_map_of_bnf oDs CAs CBs outer,
  24.135 +        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound ((ilive - 1) downto 0))) o
  24.136 +          mk_map_of_bnf Ds As Bs) Dss inners));
  24.137 +
  24.138 +    (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
  24.139 +    (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
  24.140 +    fun mk_comp_set i =
  24.141 +      let
  24.142 +        val (setTs, T) = `(replicate olive o HOLogic.mk_setT) (nth As i);
  24.143 +        val outer_set = mk_collect
  24.144 +          (mk_sets_of_bnf (replicate olive oDs) (replicate olive setTs) outer)
  24.145 +          (mk_T_of_bnf oDs setTs outer --> HOLogic.mk_setT T);
  24.146 +        val inner_sets = map (fn sets => nth sets i) inner_setss;
  24.147 +        val outer_map = mk_map_of_bnf oDs CAs setTs outer;
  24.148 +        val map_inner_sets = Term.list_comb (outer_map, inner_sets);
  24.149 +        val collect_image = mk_collect
  24.150 +          (map2 (fn f => fn set => HOLogic.mk_comp (mk_image f, set)) inner_sets outer_sets)
  24.151 +          (CCA --> HOLogic.mk_setT T);
  24.152 +      in
  24.153 +        (Library.foldl1 HOLogic.mk_comp [mk_Union T, outer_set, map_inner_sets],
  24.154 +        HOLogic.mk_comp (mk_Union T, collect_image))
  24.155 +      end;
  24.156 +
  24.157 +    val (comp_sets, comp_sets_alt) = map_split mk_comp_set (0 upto ilive - 1);
  24.158 +
  24.159 +    (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
  24.160 +    val comp_bd = Term.absdummy CCA (mk_cprod
  24.161 +      (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd);
  24.162 +
  24.163 +    fun comp_map_id_tac {context = ctxt, ...} =
  24.164 +      let
  24.165 +        (*order the theorems by reverse size to prevent bad interaction with nonconfluent rewrite
  24.166 +          rules*)
  24.167 +        val thms = (map map_id_of_bnf inners
  24.168 +          |> map (`(Term.size_of_term o Thm.prop_of))
  24.169 +          |> sort (rev_order o int_ord o pairself fst)
  24.170 +          |> map snd) @ [map_id_of_bnf outer];
  24.171 +      in
  24.172 +        (EVERY' (map (fn thm => subst_tac ctxt [thm]) thms) THEN' rtac refl) 1
  24.173 +      end;
  24.174 +
  24.175 +    fun comp_map_comp_tac _ =
  24.176 +      mk_comp_map_comp_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
  24.177 +        (map map_comp_of_bnf inners);
  24.178 +
  24.179 +    fun mk_single_comp_set_natural_tac i _ =
  24.180 +      mk_comp_set_natural_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
  24.181 +        (collect_set_natural_of_bnf outer)
  24.182 +        (map ((fn thms => nth thms i) o set_natural_of_bnf) inners);
  24.183 +
  24.184 +    val comp_set_natural_tacs = map mk_single_comp_set_natural_tac (0 upto ilive - 1);
  24.185 +
  24.186 +    fun comp_bd_card_order_tac _ =
  24.187 +      mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
  24.188 +
  24.189 +    fun comp_bd_cinfinite_tac _ =
  24.190 +      mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
  24.191 +
  24.192 +    val comp_set_alt_thms =
  24.193 +      if ! quick_and_dirty then
  24.194 +        replicate ilive no_thm
  24.195 +      else
  24.196 +        map (fn goal => Skip_Proof.prove lthy [] [] goal
  24.197 +        (fn {context, ...} => (mk_comp_set_alt_tac context (collect_set_natural_of_bnf outer))))
  24.198 +        (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) comp_sets comp_sets_alt);
  24.199 +
  24.200 +    fun comp_map_cong_tac _ =
  24.201 +      mk_comp_map_cong_tac comp_set_alt_thms (map_cong_of_bnf outer) (map map_cong_of_bnf inners);
  24.202 +
  24.203 +    val comp_set_bd_tacs =
  24.204 +      if ! quick_and_dirty then
  24.205 +        replicate (length comp_set_alt_thms) (K all_tac)
  24.206 +      else
  24.207 +        let
  24.208 +          val outer_set_bds = set_bd_of_bnf outer;
  24.209 +          val inner_set_bdss = map set_bd_of_bnf inners;
  24.210 +          val inner_bd_Card_orders = map bd_Card_order_of_bnf inners;
  24.211 +          fun comp_single_set_bd_thm i j =
  24.212 +            @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
  24.213 +              nth outer_set_bds j]
  24.214 +          val single_set_bd_thmss =
  24.215 +            map ((fn f => map f (0 upto olive - 1)) o comp_single_set_bd_thm) (0 upto ilive - 1);
  24.216 +        in
  24.217 +          map2 (fn comp_set_alt => fn single_set_bds => fn {context, ...} =>
  24.218 +            mk_comp_set_bd_tac context comp_set_alt single_set_bds)
  24.219 +          comp_set_alt_thms single_set_bd_thmss
  24.220 +        end;
  24.221 +
  24.222 +    val comp_in_alt_thm =
  24.223 +      if ! quick_and_dirty then
  24.224 +        no_thm
  24.225 +      else
  24.226 +        let
  24.227 +          val comp_in = mk_in Asets comp_sets CCA;
  24.228 +          val comp_in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
  24.229 +          val goal =
  24.230 +            fold_rev Logic.all Asets
  24.231 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq (comp_in, comp_in_alt)));
  24.232 +        in
  24.233 +          Skip_Proof.prove lthy [] [] goal
  24.234 +            (fn {context, ...} => mk_comp_in_alt_tac context comp_set_alt_thms)
  24.235 +        end;
  24.236 +
  24.237 +    fun comp_in_bd_tac _ =
  24.238 +      mk_comp_in_bd_tac comp_in_alt_thm (map in_bd_of_bnf inners) (in_bd_of_bnf outer)
  24.239 +        (map bd_Cinfinite_of_bnf inners) (bd_Card_order_of_bnf outer);
  24.240 +
  24.241 +    fun comp_map_wpull_tac _ =
  24.242 +      mk_map_wpull_tac comp_in_alt_thm (map map_wpull_of_bnf inners) (map_wpull_of_bnf outer);
  24.243 +
  24.244 +    val tacs = [comp_map_id_tac, comp_map_comp_tac, comp_map_cong_tac] @ comp_set_natural_tacs @
  24.245 +      [comp_bd_card_order_tac, comp_bd_cinfinite_tac] @ comp_set_bd_tacs @
  24.246 +      [comp_in_bd_tac, comp_map_wpull_tac];
  24.247 +
  24.248 +    val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
  24.249 +
  24.250 +    val inner_witss = map (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)))
  24.251 +      (map3 (fn Ds => fn n => mk_wits_of_bnf (replicate n Ds) (replicate n As))
  24.252 +        Dss inwitss inners);
  24.253 +
  24.254 +    val inner_witsss = map (map (nth inner_witss) o fst) outer_wits;
  24.255 +
  24.256 +    val comp_wits = (inner_witsss, (map (single o snd) outer_wits))
  24.257 +      |-> map2 (fold (map_product (fn iwit => fn owit => owit $ iwit)))
  24.258 +      |> flat
  24.259 +      |> map (`(fn t => Term.add_frees t []))
  24.260 +      |> minimize_wits
  24.261 +      |> map (fn (frees, t) => fold absfree frees t);
  24.262 +
  24.263 +    fun wit_tac {context = ctxt, ...} =
  24.264 +      mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_natural_of_bnf outer)
  24.265 +        (maps wit_thms_of_bnf inners);
  24.266 +
  24.267 +    val (bnf', lthy') =
  24.268 +      add_bnf const_policy (K Derive_Some_Facts) qualify tacs wit_tac (SOME (oDs @ flat Dss))
  24.269 +        ((((b, comp_map), comp_sets), comp_bd), comp_wits) lthy;
  24.270 +
  24.271 +    val outer_rel_Gr = rel_Gr_of_bnf outer RS sym;
  24.272 +    val outer_rel_cong = rel_cong_of_bnf outer;
  24.273 +
  24.274 +    val comp_rel_unfold_thm =
  24.275 +      trans OF [rel_def_of_bnf bnf',
  24.276 +        trans OF [comp_in_alt_thm RS @{thm subst_rel_def},
  24.277 +          trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
  24.278 +            [trans OF [outer_rel_Gr RS @{thm arg_cong[of _ _ converse]},
  24.279 +              rel_converse_of_bnf outer RS sym], outer_rel_Gr],
  24.280 +            trans OF [rel_O_of_bnf outer RS sym, outer_rel_cong OF
  24.281 +              (map (fn bnf => rel_def_of_bnf bnf RS sym) inners)]]]];
  24.282 +
  24.283 +    val comp_pred_unfold_thm = Collect_split_box_equals OF [comp_rel_unfold_thm,
  24.284 +      pred_def_of_bnf bnf' RS abs_pred_sym,
  24.285 +        trans OF [outer_rel_cong OF (map (fn bnf => pred_def_of_bnf bnf RS abs_pred_sym) inners),
  24.286 +          pred_def_of_bnf outer RS abs_pred_sym]];
  24.287 +
  24.288 +    val unfold' = add_to_unfold (map_def_of_bnf bnf') (set_defs_of_bnf bnf')
  24.289 +      comp_rel_unfold_thm comp_pred_unfold_thm unfold;
  24.290 +  in
  24.291 +    (bnf', (unfold', lthy'))
  24.292 +  end;
  24.293 +
  24.294 +fun clean_compose_bnf_cmd (outer, inners) lthy =
  24.295 +  let
  24.296 +    val outer = the (bnf_of lthy outer)
  24.297 +    val inners = map (the o bnf_of lthy) inners
  24.298 +    val b = name_of_bnf outer
  24.299 +      |> Binding.prefix_name compN
  24.300 +      |> Binding.suffix_name ("_" ^ implode (map (Binding.name_of o name_of_bnf) inners));
  24.301 +  in
  24.302 +    (snd o snd) (clean_compose_bnf Dont_Inline I b outer inners
  24.303 +      (empty_unfold, lthy))
  24.304 +  end;
  24.305 +
  24.306 +(* Killing live variables *)
  24.307 +
  24.308 +fun killN_bnf qualify n bnf (unfold, lthy) = if n = 0 then (bnf, (unfold, lthy)) else
  24.309 +  let
  24.310 +    val b = Binding.prefix_name (mk_killN n) (name_of_bnf bnf);
  24.311 +    val live = live_of_bnf bnf;
  24.312 +    val dead = dead_of_bnf bnf;
  24.313 +    val nwits = nwits_of_bnf bnf;
  24.314 +
  24.315 +    (* TODO: check 0 < n <= live *)
  24.316 +
  24.317 +    val (Ds, lthy1) = apfst (map TFree)
  24.318 +      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
  24.319 +    val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
  24.320 +      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
  24.321 +    val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
  24.322 +      (Variable.invent_types (replicate (live - n) HOLogic.typeS) lthy2);
  24.323 +
  24.324 +    val ((Asets, lives), _(*names_lthy*)) = lthy
  24.325 +      |> mk_Frees "A" (map (HOLogic.mk_setT) (drop n As))
  24.326 +      ||>> mk_Frees "x" (drop n As);
  24.327 +    val xs = map (fn T => HOLogic.choice_const T $ absdummy T @{term True}) killedAs @ lives;
  24.328 +
  24.329 +    val T = mk_T_of_bnf Ds As bnf;
  24.330 +
  24.331 +    (*bnf.map id ... id*)
  24.332 +    val killN_map = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
  24.333 +
  24.334 +    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
  24.335 +    val killN_sets = drop n bnf_sets;
  24.336 +
  24.337 +    (*(|UNIV :: A1 set| +c ... +c |UNIV :: An set|) *c bnf.bd*)
  24.338 +    val bnf_bd = mk_bd_of_bnf Ds As bnf;
  24.339 +    val killN_bd = mk_cprod
  24.340 +      (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
  24.341 +
  24.342 +    fun killN_map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
  24.343 +    fun killN_map_comp_tac {context, ...} =
  24.344 +      Local_Defs.unfold_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
  24.345 +      rtac refl 1;
  24.346 +    fun killN_map_cong_tac {context, ...} =
  24.347 +      mk_killN_map_cong_tac context n (live - n) (map_cong_of_bnf bnf);
  24.348 +    val killN_set_natural_tacs =
  24.349 +      map (fn thm => fn _ => rtac thm 1) (drop n (set_natural_of_bnf bnf));
  24.350 +    fun killN_bd_card_order_tac _ = mk_killN_bd_card_order_tac n (bd_card_order_of_bnf bnf);
  24.351 +    fun killN_bd_cinfinite_tac _ = mk_killN_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
  24.352 +    val killN_set_bd_tacs =
  24.353 +      map (fn thm => fn _ => mk_killN_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
  24.354 +        (drop n (set_bd_of_bnf bnf));
  24.355 +
  24.356 +    val killN_in_alt_thm =
  24.357 +      if ! quick_and_dirty then
  24.358 +        no_thm
  24.359 +      else
  24.360 +        let
  24.361 +          val killN_in = mk_in Asets killN_sets T;
  24.362 +          val killN_in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
  24.363 +          val goal =
  24.364 +            fold_rev Logic.all Asets (HOLogic.mk_Trueprop (HOLogic.mk_eq (killN_in, killN_in_alt)));
  24.365 +        in
  24.366 +          Skip_Proof.prove lthy [] [] goal (K killN_in_alt_tac)
  24.367 +        end;
  24.368 +
  24.369 +    fun killN_in_bd_tac _ =
  24.370 +      mk_killN_in_bd_tac n (live > n) killN_in_alt_thm (in_bd_of_bnf bnf)
  24.371 +         (bd_Card_order_of_bnf bnf) (bd_Cinfinite_of_bnf bnf) (bd_Cnotzero_of_bnf bnf);
  24.372 +    fun killN_map_wpull_tac _ =
  24.373 +      mk_map_wpull_tac killN_in_alt_thm [] (map_wpull_of_bnf bnf);
  24.374 +
  24.375 +    val tacs = [killN_map_id_tac, killN_map_comp_tac, killN_map_cong_tac] @ killN_set_natural_tacs @
  24.376 +      [killN_bd_card_order_tac, killN_bd_cinfinite_tac] @ killN_set_bd_tacs @
  24.377 +      [killN_in_bd_tac, killN_map_wpull_tac];
  24.378 +
  24.379 +    val wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
  24.380 +
  24.381 +    val killN_wits = map (fn t => fold absfree (Term.add_frees t []) t)
  24.382 +      (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) wits);
  24.383 +
  24.384 +    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
  24.385 +
  24.386 +    val (bnf', lthy') =
  24.387 +      add_bnf Smart_Inline (K Derive_Some_Facts) qualify tacs wit_tac (SOME (killedAs @ Ds))
  24.388 +        ((((b, killN_map), killN_sets), Term.absdummy T killN_bd), killN_wits) lthy;
  24.389 +
  24.390 +    val rel_Gr = rel_Gr_of_bnf bnf RS sym;
  24.391 +
  24.392 +    val killN_rel_unfold_thm =
  24.393 +      trans OF [rel_def_of_bnf bnf',
  24.394 +        trans OF [killN_in_alt_thm RS @{thm subst_rel_def},
  24.395 +          trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
  24.396 +            [trans OF [rel_Gr RS @{thm arg_cong[of _ _ converse]}, rel_converse_of_bnf bnf RS sym],
  24.397 +              rel_Gr],
  24.398 +            trans OF [rel_O_of_bnf bnf RS sym, rel_cong_of_bnf bnf OF
  24.399 +              (replicate n @{thm trans[OF Gr_UNIV_id[OF refl] Id_alt[symmetric]]} @
  24.400 +               replicate (live - n) @{thm Gr_fst_snd})]]]];
  24.401 +
  24.402 +    val killN_pred_unfold_thm = Collect_split_box_equals OF
  24.403 +      [Local_Defs.unfold lthy' @{thms Id_def'} killN_rel_unfold_thm,
  24.404 +        pred_def_of_bnf bnf' RS abs_pred_sym, pred_def_of_bnf bnf RS abs_pred_sym];
  24.405 +
  24.406 +    val unfold' = add_to_unfold (map_def_of_bnf bnf') (set_defs_of_bnf bnf')
  24.407 +      killN_rel_unfold_thm killN_pred_unfold_thm unfold;
  24.408 +  in
  24.409 +    (bnf', (unfold', lthy'))
  24.410 +  end;
  24.411 +
  24.412 +fun killN_bnf_cmd (n, raw_bnf) lthy =
  24.413 +  (snd o snd) (killN_bnf I n (the (bnf_of lthy raw_bnf)) (empty_unfold, lthy));
  24.414 +
  24.415 +(* Adding dummy live variables *)
  24.416 +
  24.417 +fun liftN_bnf qualify n bnf (unfold, lthy) = if n = 0 then (bnf, (unfold, lthy)) else
  24.418 +  let
  24.419 +    val b = Binding.prefix_name (mk_liftN n) (name_of_bnf bnf);
  24.420 +    val live = live_of_bnf bnf;
  24.421 +    val dead = dead_of_bnf bnf;
  24.422 +    val nwits = nwits_of_bnf bnf;