added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
authorblanchet
Tue, 28 Aug 2012 17:16:00 +0200
changeset 48975 7f79f94a432c
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
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/BNF_Comp.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,20 @@
+(*  Title:      HOL/Codatatype/BNF_Comp.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Copyright   2012
+
+Composition of bounded natural functors.
+*)
+
+header {* Composition of Bounded Natural Functors *}
+
+theory BNF_Comp
+imports Basic_BNFs
+keywords
+  "bnf_of_typ" :: thy_decl
+uses
+  "Tools/bnf_comp_tactics.ML"
+  "Tools/bnf_comp.ML"
+  "Tools/bnf_fp_util.ML"
+begin
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/BNF_Def.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,22 @@
+(*  Title:      HOL/Codatatype/BNF_Def.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Copyright   2012
+
+Definition of bounded natural functors.
+*)
+
+header {* Definition of Bounded Natural Functors *}
+
+theory BNF_Def
+imports BNF_Library
+keywords
+  "print_bnfs" :: diag
+and
+  "bnf_def" :: thy_goal
+uses
+  "Tools/bnf_util.ML"
+  "Tools/bnf_tactics.ML"
+  "Tools/bnf_def.ML"
+begin
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/BNF_GFP.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,20 @@
+(*  Title:      HOL/Codatatype/BNF_GFP.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Copyright   2012
+
+Greatest fixed point operation on bounded natural functors.
+*)
+
+header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
+
+theory BNF_GFP
+imports BNF_Comp
+keywords
+  "bnf_codata" :: thy_decl
+uses
+  "Tools/bnf_gfp_util.ML"
+  "Tools/bnf_gfp_tactics.ML"
+  "Tools/bnf_gfp.ML"
+begin
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/BNF_LFP.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,20 @@
+(*  Title:      HOL/Codatatype/BNF_LFP.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Copyright   2012
+
+Least fixed point operation on bounded natural functors.
+*)
+
+header {* Least Fixed Point Operation on Bounded Natural Functors *}
+
+theory BNF_LFP
+imports BNF_Comp
+keywords
+  "bnf_data" :: thy_decl
+uses
+  "Tools/bnf_lfp_util.ML"
+  "Tools/bnf_lfp_tactics.ML"
+  "Tools/bnf_lfp.ML"
+begin
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/BNF_Library.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,826 @@
+(*  Title:      HOL/Codatatype/BNF_Library.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Copyright   2012
+
+Library for bounded natural functors.
+*)
+
+header {* Library for Bounded Natural Functors *}
+
+theory BNF_Library
+imports
+   "../Ordinals_and_Cardinals_Base/Cardinal_Arithmetic"
+   "~~/src/HOL/Library/List_Prefix"
+   Equiv_Relations_More
+begin
+
+lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
+by blast
+
+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})"
+by blast
+
+lemma mem_Collect_eq_split: "{(x, y). (x, y) \<in> X} = X"
+by simp
+
+lemma image_comp: "image (f o g) = image f o image g"
+by (rule ext) (auto simp only: o_apply image_def)
+
+lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
+by (rule ext) simp
+
+lemma Union_natural: "Union o image (image f) = image f o Union"
+by (rule ext) (auto simp only: o_apply)
+
+lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
+by (unfold o_assoc)
+
+lemma comp_single_set_bd:
+  assumes fbd_Card_order: "Card_order fbd" and
+    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
+    gset_bd: "\<And>x. |gset x| \<le>o gbd"
+  shows "|\<Union>fset ` gset x| \<le>o gbd *c fbd"
+apply (subst sym[OF SUP_def])
+apply (rule ordLeq_transitive)
+apply (rule card_of_UNION_Sigma)
+apply (subst SIGMA_CSUM)
+apply (rule ordLeq_transitive)
+apply (rule card_of_Csum_Times')
+apply (rule fbd_Card_order)
+apply (rule ballI)
+apply (rule fset_bd)
+apply (rule ordLeq_transitive)
+apply (rule cprod_mono1)
+apply (rule gset_bd)
+apply (rule ordIso_imp_ordLeq)
+apply (rule ordIso_refl)
+apply (rule Card_order_cprod)
+done
+
+lemma Union_image_insert: "\<Union>f ` insert a B = f a \<union> \<Union>f ` B"
+by simp
+
+lemma Union_image_empty: "A \<union> \<Union>f ` {} = A"
+by simp
+
+definition collect where
+  "collect F x = (\<Union>f \<in> F. f x)"
+
+lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
+by (rule ext) (auto simp only: o_apply collect_def)
+
+lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
+by (rule ext) (auto simp add: collect_def)
+
+lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
+by auto
+
+lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
+by auto
+
+lemma rev_bspec: "a \<in> A \<Longrightarrow> \<forall>z \<in> A. P z \<Longrightarrow> P a"
+by simp
+
+lemma Un_cong: "\<lbrakk>A = B; C = D\<rbrakk> \<Longrightarrow> A \<union> C = B \<union> D"
+by auto
+
+lemma UN_image_subset: "\<Union>f ` g x \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
+by auto
+
+lemma image_Collect_subsetI:
+  "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
+by auto
+
+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"
+by (unfold o_apply collect_def SUP_def)
+
+lemma sum_case_comp_Inl:
+"sum_case f g \<circ> Inl = f"
+unfolding comp_def by simp
+
+lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
+by (auto split: sum.splits)
+
+lemma converse_mono:
+"R1 ^-1 \<subseteq> R2 ^-1 \<longleftrightarrow> R1 \<subseteq> R2"
+unfolding converse_def by auto
+
+lemma converse_shift:
+"R1 \<subseteq> R2 ^-1 \<Longrightarrow> R1 ^-1 \<subseteq> R2"
+unfolding converse_def by auto
+
+lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
+by auto
+
+lemma equiv_triv1:
+assumes "equiv A R" and "(a, b) \<in> R" and "(a, c) \<in> R"
+shows "(b, c) \<in> R"
+using assms unfolding equiv_def sym_def trans_def by blast
+
+lemma equiv_triv2:
+assumes "equiv A R" and "(a, b) \<in> R" and "(b, c) \<in> R"
+shows "(a, c) \<in> R"
+using assms unfolding equiv_def trans_def by blast
+
+lemma equiv_proj:
+  assumes e: "equiv A R" and "z \<in> R"
+  shows "(proj R o fst) z = (proj R o snd) z"
+proof -
+  from assms(2) have z: "(fst z, snd z) \<in> R" by auto
+  have P: "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" by (erule equiv_triv1[OF e z])
+  have "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R" by (erule equiv_triv2[OF e z])
+  with P show ?thesis unfolding proj_def[abs_def] by auto
+qed
+
+
+section{* Weak pullbacks: *}
+
+definition csquare where
+"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
+
+definition wpull where
+"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
+ (\<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))"
+
+lemma wpull_cong:
+"\<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"
+by simp
+
+lemma wpull_id: "wpull UNIV B1 B2 id id id id"
+unfolding wpull_def by simp
+
+
+(* Weak pseudo-pullbacks *)
+
+definition wppull where
+"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
+ (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
+           (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
+
+
+(* The pullback of sets *)
+definition thePull where
+"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
+
+lemma wpull_thePull:
+"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
+unfolding wpull_def thePull_def by auto
+
+lemma wppull_thePull:
+assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
+shows
+"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
+   j a' \<in> A \<and>
+   e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
+(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
+proof(rule bchoice[of ?A' ?phi], default)
+  fix a' assume a': "a' \<in> ?A'"
+  hence "fst a' \<in> B1" unfolding thePull_def by auto
+  moreover
+  from a' have "snd a' \<in> B2" unfolding thePull_def by auto
+  moreover have "f1 (fst a') = f2 (snd a')"
+  using a' unfolding csquare_def thePull_def by auto
+  ultimately show "\<exists> ja'. ?phi a' ja'"
+  using assms unfolding wppull_def by auto
+qed
+
+lemma wpull_wppull:
+assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
+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')"
+shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
+unfolding wppull_def proof safe
+  fix b1 b2
+  assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
+  then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
+  using wp unfolding wpull_def by blast
+  show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
+  apply(rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
+qed
+
+lemma wppull_id: "\<lbrakk>wpull UNIV UNIV UNIV f1 f2 p1 p2; e1 = id; e2 = id\<rbrakk> \<Longrightarrow>
+   wppull UNIV UNIV UNIV f1 f2 e1 e2 p1 p2"
+by (erule wpull_wppull) auto
+
+
+(* Operators: *)
+definition diag where "diag A \<equiv> {(a,a) | a. a \<in> A}"
+definition "Gr A f = {(a,f a) | a. a \<in> A}"
+definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
+
+lemma diagI: "x \<in> A \<Longrightarrow> (x, x) \<in> diag A"
+unfolding diag_def by simp
+
+lemma diagE: "(a, b) \<in> diag A \<Longrightarrow> a = b"
+unfolding diag_def by simp
+
+lemma diagE': "x \<in> diag A \<Longrightarrow> fst x = snd x"
+unfolding diag_def by auto
+
+lemma diag_fst: "x \<in> diag A \<Longrightarrow> fst x \<in> A"
+unfolding diag_def by auto
+
+lemma diag_UNIV: "diag UNIV = Id"
+unfolding diag_def by auto
+
+lemma diag_converse: "diag A = (diag A) ^-1"
+unfolding diag_def by auto
+
+lemma diag_Comp: "diag A = diag A O diag A"
+unfolding diag_def by auto
+
+lemma diag_Gr: "diag A = Gr A id"
+unfolding diag_def Gr_def by simp
+
+lemma diag_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> diag UNIV"
+unfolding diag_def by auto
+
+lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
+unfolding image2_def by auto
+
+lemma Id_def': "Id = {(a,b). a = b}"
+by auto
+
+lemma Id_alt: "Id = Gr UNIV id"
+unfolding Gr_def by auto
+
+lemma Id_subset: "Id \<subseteq> {(a, b). P a b \<or> a = b}"
+by auto
+
+lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
+by auto
+
+lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
+unfolding image2_def Gr_def by auto
+
+lemma GrI: "\<lbrakk>x \<in> A; f x = fx\<rbrakk> \<Longrightarrow> (x, fx) \<in> Gr A f"
+unfolding Gr_def by simp
+
+lemma GrE: "(x, fx) \<in> Gr A f \<Longrightarrow> (x \<in> A \<Longrightarrow> f x = fx \<Longrightarrow> P) \<Longrightarrow> P"
+unfolding Gr_def by simp
+
+lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
+unfolding Gr_def by simp
+
+lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
+unfolding Gr_def by simp
+
+lemma Gr_UNIV_id: "f = id \<Longrightarrow> (Gr UNIV f)^-1 O Gr UNIV f = Gr UNIV f"
+unfolding Gr_def by auto
+
+lemma Gr_fst_snd: "(Gr R fst)^-1 O Gr R snd = R"
+unfolding Gr_def by auto
+
+lemma Gr_mono: "A \<subseteq> B \<Longrightarrow> Gr A f \<subseteq> Gr B f"
+unfolding Gr_def by auto
+
+lemma subst_rel_def: "A = B \<Longrightarrow> (Gr A f)^-1 O Gr A g = (Gr B f)^-1 O Gr B g"
+by simp
+
+lemma abs_pred_def: "\<lbrakk>\<And>x y. (x, y) \<in> rel = pred x y\<rbrakk> \<Longrightarrow> rel = Collect (split pred)"
+by auto
+
+lemma Collect_split_cong: "Collect (split pred) = Collect (split pred') \<Longrightarrow> pred = pred'"
+by blast
+
+lemma pred_def_abs: "rel = Collect (split pred) \<Longrightarrow> pred = (\<lambda>x y. (x, y) \<in> rel)"
+by auto
+
+lemma wpull_Gr:
+"wpull (Gr A f) A (f ` A) f id fst snd"
+unfolding wpull_def Gr_def by auto
+
+lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
+unfolding Gr_def by auto
+
+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})"
+unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
+
+definition relImage where
+"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
+
+definition relInvImage where
+"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
+
+lemma relImage_Gr:
+"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
+unfolding relImage_def Gr_def relcomp_def by auto
+
+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"
+unfolding Gr_def relcomp_def image_def relInvImage_def by auto
+
+lemma relImage_mono:
+"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
+unfolding relImage_def by auto
+
+lemma relInvImage_mono:
+"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
+unfolding relInvImage_def by auto
+
+lemma relInvImage_diag:
+"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (diag B) f \<subseteq> Id"
+unfolding relInvImage_def diag_def by auto
+
+lemma relInvImage_UNIV_relImage:
+"R \<subseteq> relInvImage UNIV (relImage R f) f"
+unfolding relInvImage_def relImage_def by auto
+
+lemma relImage_proj:
+assumes "equiv A R"
+shows "relImage R (proj R) \<subseteq> diag (A//R)"
+unfolding relImage_def diag_def apply safe
+using proj_iff[OF assms]
+by (metis assms equiv_Image proj_def proj_preserves)
+
+lemma relImage_relInvImage:
+assumes "R \<subseteq> f ` A <*> f ` A"
+shows "relImage (relInvImage A R f) f = R"
+using assms unfolding relImage_def relInvImage_def by fastforce
+
+
+(* Relation composition as a weak pseudo-pullback *)
+
+(* pick middle *)
+definition "pickM P Q a c = (SOME b. (a,b) \<in> P \<and> (b,c) \<in> Q)"
+
+lemma pickM:
+assumes "(a,c) \<in> P O Q"
+shows "(a, pickM P Q a c) \<in> P \<and> (pickM P Q a c, c) \<in> Q"
+unfolding pickM_def apply(rule someI_ex)
+using assms unfolding relcomp_def by auto
+
+definition fstO where "fstO P Q ac = (fst ac, pickM P Q (fst ac) (snd ac))"
+definition sndO where "sndO P Q ac = (pickM P Q (fst ac) (snd ac), snd ac)"
+
+lemma fstO_in: "ac \<in> P O Q \<Longrightarrow> fstO P Q ac \<in> P"
+by (metis assms fstO_def pickM surjective_pairing)
+
+lemma fst_fstO: "fst bc = (fst \<circ> fstO P Q) bc"
+unfolding comp_def fstO_def by simp
+
+lemma snd_sndO: "snd bc = (snd \<circ> sndO P Q) bc"
+unfolding comp_def sndO_def by simp
+
+lemma sndO_in: "ac \<in> P O Q \<Longrightarrow> sndO P Q ac \<in> Q"
+by (metis assms sndO_def pickM surjective_pairing)
+
+lemma csquare_fstO_sndO:
+"csquare (P O Q) snd fst (fstO P Q) (sndO P Q)"
+unfolding csquare_def fstO_def sndO_def using pickM by auto
+
+lemma wppull_fstO_sndO:
+shows "wppull (P O Q) P Q snd fst fst snd (fstO P Q) (sndO P Q)"
+using pickM unfolding wppull_def fstO_def sndO_def relcomp_def by auto
+
+lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
+by simp
+
+lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
+by (simp split: prod.split)
+
+lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
+by (simp split: prod.split)
+
+lemma flip_rel: "A \<subseteq> (R ^-1) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> R"
+by auto
+
+lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
+by simp
+
+lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
+by simp
+
+lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
+by simp
+
+lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
+by simp
+
+lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
+by simp
+
+lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
+by simp
+
+lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
+by auto
+
+lemma Collect_restrict': "{(x, y) | x y. phi x y \<and> P x y} \<subseteq> {(x, y) | x y. phi x y}"
+by auto
+
+lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
+by auto
+
+lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> rel.underS R j"
+unfolding rel.underS_def by simp
+
+lemma underS_E: "i \<in> rel.underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
+unfolding rel.underS_def by simp
+
+lemma underS_Field: "i \<in> rel.underS R j \<Longrightarrow> i \<in> Field R"
+unfolding rel.underS_def Field_def by auto
+
+lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
+unfolding Field_def by auto
+
+
+subsection {* Convolution product *}
+
+definition convol ("<_ , _>") where
+"<f , g> \<equiv> %a. (f a, g a)"
+
+lemma fst_convol:
+"fst o <f , g> = f"
+apply(rule ext)
+unfolding convol_def by simp
+
+lemma snd_convol:
+"snd o <f , g> = g"
+apply(rule ext)
+unfolding convol_def by simp
+
+lemma fst_convol': "fst (<f, g> x) = f x"
+using fst_convol unfolding convol_def by simp
+
+lemma snd_convol': "snd (<f, g> x) = g x"
+using snd_convol unfolding convol_def by simp
+
+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"
+unfolding convol_def by auto
+
+lemma convol_expand_snd: "fst o f = g \<Longrightarrow>  <g, snd o f> = f"
+unfolding convol_def by auto
+
+subsection{* Facts about functions *}
+
+lemma pointfreeE: "f o g = f' o g' \<Longrightarrow> f (g x) = f' (g' x)"
+unfolding o_def fun_eq_iff by simp
+
+lemma pointfree_idE: "f o g = id \<Longrightarrow> f (g x) = x"
+unfolding o_def fun_eq_iff by simp
+
+definition inver where
+  "inver g f A = (ALL a : A. g (f a) = a)"
+
+lemma bij_betw_iff_ex:
+  "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
+proof (rule iffI)
+  assume ?L
+  hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
+  let ?phi = "% b a. a : A \<and> f a = b"
+  have "ALL b : B. EX a. ?phi b a" using f by blast
+  then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
+    using bchoice[of B ?phi] by blast
+  hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
+  have gf: "inver g f A" unfolding inver_def by (metis gg imageI inj_f the_inv_into_f_f)
+  moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
+  moreover have "A \<le> g ` B"
+  proof safe
+    fix a assume a: "a : A"
+    hence "f a : B" using f by auto
+    moreover have "a = g (f a)" using a gf unfolding inver_def by auto
+    ultimately show "a : g ` B" by blast
+  qed
+  ultimately show ?R by blast
+next
+  assume ?R
+  then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
+  show ?L unfolding bij_betw_def
+  proof safe
+    show "inj_on f A" unfolding inj_on_def
+    proof safe
+      fix a1 a2 assume a: "a1 : A"  "a2 : A" and "f a1 = f a2"
+      hence "g (f a1) = g (f a2)" by simp
+      thus "a1 = a2" using a g unfolding inver_def by simp
+    qed
+  next
+    fix a assume "a : A"
+    then obtain b where b: "b : B" and a: "a = g b" using g by blast
+    hence "b = f (g b)" using g unfolding inver_def by auto
+    thus "f a : B" unfolding a using b by simp
+  next
+    fix b assume "b : B"
+    hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
+    thus "b : f ` A" by auto
+  qed
+qed
+
+lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
+unfolding bij_def inj_on_def by auto blast
+
+lemma bij_betw_ex_weakE:
+  "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
+by (auto simp only: bij_betw_iff_ex)
+
+lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
+unfolding inver_def by auto (rule rev_image_eqI, auto)
+
+lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
+unfolding inver_def by auto
+
+lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
+unfolding inver_def by simp
+
+lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
+unfolding bij_betw_def by auto
+
+lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
+unfolding bij_betw_def by auto
+
+lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
+unfolding inver_def by auto
+
+lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
+unfolding bij_betw_def inver_def by auto
+
+lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
+unfolding bij_betw_def inver_def by auto
+
+lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
+by (metis bij_betw_iff_ex bij_betw_imageE)
+
+lemma bij_betwI':
+  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
+    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
+    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
+unfolding bij_betw_def inj_on_def by auto (metis rev_image_eqI)
+
+lemma o_bij:
+  assumes gf: "g o f = id" and fg: "f o g = id"
+  shows "bij f"
+unfolding bij_def inj_on_def surj_def proof safe
+  fix a1 a2 assume "f a1 = f a2"
+  hence "g ( f a1) = g (f a2)" by simp
+  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
+next
+  fix b
+  have "b = f (g b)"
+  using fg unfolding fun_eq_iff by simp
+  thus "EX a. b = f a" by blast
+qed
+
+lemma surj_fun_eq:
+  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
+  shows "g1 = g2"
+proof (rule ext)
+  fix y
+  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
+  thus "g1 y = g2 y" using eq_on by simp
+qed
+
+lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
+unfolding wo_rel_def card_order_on_def by blast 
+
+lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
+  \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
+unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
+
+lemma Card_order_trans:
+  "\<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"
+unfolding card_order_on_def well_order_on_def linear_order_on_def
+  partial_order_on_def preorder_on_def trans_def antisym_def by blast
+
+lemma Cinfinite_limit2:
+ assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
+ shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
+proof -
+  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
+    unfolding card_order_on_def well_order_on_def linear_order_on_def
+      partial_order_on_def preorder_on_def by auto
+  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
+    using Cinfinite_limit[OF x1 r] by blast
+  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
+    using Cinfinite_limit[OF x2 r] by blast
+  show ?thesis
+  proof (cases "y1 = y2")
+    case True with y1 y2 show ?thesis by blast
+  next
+    case False
+    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
+      unfolding total_on_def by auto
+    thus ?thesis
+    proof
+      assume *: "(y1, y2) \<in> r"
+      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
+      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
+    next
+      assume *: "(y2, y1) \<in> r"
+      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
+      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
+    qed
+  qed
+qed
+
+lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
+ \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
+proof (induct X rule: finite_induct)
+  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
+next
+  case (insert x X)
+  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
+  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"
+    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
+  show ?case by (metis Card_order_trans insert(5) insertE y(2) z)
+qed
+
+lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
+by auto
+
+(*helps resolution*)
+lemma well_order_induct_imp:
+  "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>
+     x \<in> Field r \<longrightarrow> P x"
+by (erule wo_rel.well_order_induct)
+
+lemma meta_spec2:
+  assumes "(\<And>x y. PROP P x y)"
+  shows "PROP P x y"
+by (rule `(\<And>x y. PROP P x y)`)
+
+(*Extended List_Prefix*)
+
+definition prefCl where
+  "prefCl Kl = (\<forall> kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
+definition PrefCl where
+  "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> kl' \<le> kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
+
+lemma prefCl_UN:
+  "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
+unfolding prefCl_def PrefCl_def by fastforce
+
+definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
+definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
+definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
+
+lemmas sh_def = Shift_def shift_def
+
+lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
+unfolding Shift_def Succ_def by simp
+
+lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
+unfolding Shift_def clists_def Field_card_of by auto
+
+lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
+unfolding prefCl_def Shift_def
+proof safe
+  fix kl1 kl2
+  assume "\<forall>kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
+    "kl1 \<le> kl2" "k # kl2 \<in> Kl"
+  thus "k # kl1 \<in> Kl" using Cons_prefix_Cons[of k kl1 k kl2] by blast
+qed
+
+lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
+unfolding Shift_def by simp
+
+lemma prefCl_Succ: "\<lbrakk>prefCl Kl; k # kl \<in> Kl\<rbrakk> \<Longrightarrow> k \<in> Succ Kl []"
+unfolding Succ_def proof
+  assume "prefCl Kl" "k # kl \<in> Kl"
+  moreover have "k # [] \<le> k # kl" by auto
+  ultimately have "k # [] \<in> Kl" unfolding prefCl_def by blast
+  thus "[] @ [k] \<in> Kl" by simp
+qed
+
+lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
+unfolding Succ_def by simp
+
+lemmas SuccE = SuccD[elim_format]
+
+lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
+unfolding Succ_def by simp
+
+lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
+unfolding Shift_def by simp
+
+lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
+unfolding Succ_def Shift_def by auto
+
+lemma ShiftI: "k # kl \<in> Kl \<Longrightarrow> kl \<in> Shift Kl k"
+unfolding Shift_def by simp
+
+lemma Func_cexp: "|Func A B| =o |B| ^c |A|"
+unfolding cexp_def Field_card_of by (simp only: card_of_refl)
+
+lemma clists_bound: "A \<in> Field (cpow (clists r)) - {{}} \<Longrightarrow> |A| \<le>o clists r"
+unfolding cpow_def clists_def Field_card_of by (auto simp: card_of_mono1)
+
+lemma cpow_clists_czero: "\<lbrakk>A \<in> Field (cpow (clists r)) - {{}}; |A| =o czero\<rbrakk> \<Longrightarrow> False"
+unfolding cpow_def clists_def
+by (auto simp add: card_of_ordIso_czero_iff_empty[symmetric])
+   (erule notE, erule ordIso_transitive, rule czero_ordIso)
+
+lemma incl_UNION_I:
+assumes "i \<in> I" and "A \<subseteq> F i"
+shows "A \<subseteq> UNION I F"
+using assms by auto
+
+lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
+unfolding clists_def Field_card_of by auto
+
+lemma Cons_clists:
+  "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
+unfolding clists_def Field_card_of by auto
+
+lemma length_Cons: "length (x#xs) = Suc (length xs)"
+by simp
+
+lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
+by simp
+
+(*injection into the field of a cardinal*)
+definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
+definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
+
+lemma ex_toCard_pred:
+"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
+unfolding toCard_pred_def
+using card_of_ordLeq[of A "Field r"]
+      ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
+by blast
+
+lemma toCard_pred_toCard:
+  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
+unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
+
+lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
+  toCard A r x = toCard A r y \<longleftrightarrow> x = y"
+using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
+
+lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
+using toCard_pred_toCard unfolding toCard_pred_def by blast
+
+definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
+
+lemma fromCard_toCard:
+"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
+unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
+
+(* pick according to the weak pullback *)
+definition pickWP_pred where
+"pickWP_pred A p1 p2 b1 b2 a \<equiv>
+ a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
+
+definition pickWP where
+"pickWP A p1 p2 b1 b2 \<equiv>
+ SOME a. pickWP_pred A p1 p2 b1 b2 a"
+
+lemma pickWP_pred:
+assumes "wpull A B1 B2 f1 f2 p1 p2" and
+"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
+shows "\<exists> a. pickWP_pred A p1 p2 b1 b2 a"
+using assms unfolding wpull_def pickWP_pred_def by blast
+
+lemma pickWP_pred_pickWP:
+assumes "wpull A B1 B2 f1 f2 p1 p2" and
+"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
+shows "pickWP_pred A p1 p2 b1 b2 (pickWP A p1 p2 b1 b2)"
+unfolding pickWP_def using assms by(rule someI_ex[OF pickWP_pred])
+
+lemma pickWP:
+assumes "wpull A B1 B2 f1 f2 p1 p2" and
+"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
+shows "pickWP A p1 p2 b1 b2 \<in> A"
+      "p1 (pickWP A p1 p2 b1 b2) = b1"
+      "p2 (pickWP A p1 p2 b1 b2) = b2"
+using assms pickWP_pred_pickWP unfolding pickWP_pred_def by fastforce+
+
+lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
+
+lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
+unfolding Field_card_of csum_def by auto
+
+lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
+unfolding Field_card_of csum_def by auto
+
+lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
+by auto
+
+lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
+by auto
+
+lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
+by auto
+
+lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
+by auto
+
+lemma sum_case_cong: "p = q \<Longrightarrow> sum_case f g p = sum_case f g q"
+by simp
+
+lemma sum_case_step:
+  "sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
+  "sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
+by auto
+
+lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+by (cases s) auto
+
+lemma obj_sum_base: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+by auto
+
+lemma obj_sum_step:
+  "\<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"
+by (metis obj_sumE)
+
+lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
+by auto
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Basic_BNFs.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,1529 @@
+(*  Title:      HOL/Codatatype/Basic_BNFs.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Author:     Jasmin Blanchette, TU Muenchen
+    Copyright   2012
+
+Registration of various types as bounded natural functors.
+*)
+
+header {* Registration of Various Types as Bounded Natural Functors *}
+
+theory Basic_BNFs
+imports BNF_Def "~~/src/HOL/Quotient_Examples/FSet"
+        "~~/src/HOL/Library/Multiset" Countable_Set
+begin
+
+lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
+
+lemma ctwo_card_order: "card_order ctwo"
+using Card_order_ctwo by (unfold ctwo_def Field_card_of)
+
+lemma natLeq_cinfinite: "cinfinite natLeq"
+unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
+
+bnf_def ID = "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
+apply auto
+apply (rule natLeq_card_order)
+apply (rule natLeq_cinfinite)
+apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
+apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)
+apply (rule ordLeq_transitive)
+apply (rule ordLeq_cexp1[of natLeq])
+apply (rule Cinfinite_Cnotzero)
+apply (rule conjI)
+apply (rule natLeq_cinfinite)
+apply (rule natLeq_Card_order)
+apply (rule card_of_Card_order)
+apply (rule cexp_mono1)
+apply (rule ordLeq_csum1)
+apply (rule card_of_Card_order)
+apply (rule disjI2)
+apply (rule cone_ordLeq_cexp)
+apply (rule ordLeq_transitive)
+apply (rule cone_ordLeq_ctwo)
+apply (rule ordLeq_csum2)
+apply (rule Card_order_ctwo)
+apply (rule natLeq_Card_order)
+done
+
+lemma ID_pred[simp]: "ID_pred \<phi> = \<phi>"
+unfolding ID_pred_def ID_rel_def Gr_def fun_eq_iff by auto
+
+bnf_def DEADID = "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
+apply (auto simp add: wpull_id)
+apply (rule card_order_csum)
+apply (rule natLeq_card_order)
+apply (rule card_of_card_order_on)
+apply (rule cinfinite_csum)
+apply (rule disjI1)
+apply (rule natLeq_cinfinite)
+apply (rule ordLess_imp_ordLeq)
+apply (rule ordLess_ordLeq_trans)
+apply (rule ordLess_ctwo_cexp)
+apply (rule card_of_Card_order)
+apply (rule cexp_mono2'')
+apply (rule ordLeq_csum2)
+apply (rule card_of_Card_order)
+apply (rule ctwo_Cnotzero)
+by (rule card_of_Card_order)
+
+lemma DEADID_pred[simp]: "DEADID_pred = (op =)"
+unfolding DEADID_pred_def DEADID.rel_Id by simp
+
+ML {*
+
+signature BASIC_BNFS =
+sig
+  val ID_bnf: BNF_Def.BNF
+  val ID_rel_def: thm
+  val ID_pred_def: thm
+
+  val DEADID_bnf: BNF_Def.BNF
+end;
+
+structure Basic_BNFs : BASIC_BNFS =
+struct
+
+  val ID_bnf = the (BNF_Def.bnf_of @{context} "ID");
+  val DEADID_bnf = the (BNF_Def.bnf_of @{context} "DEADID");
+
+  val rel_def = BNF_Def.rel_def_of_bnf ID_bnf;
+  val ID_rel_def = rel_def RS sym;
+  val ID_pred_def =
+    Local_Defs.unfold @{context} [rel_def] (BNF_Def.pred_def_of_bnf ID_bnf) RS sym;
+
+end;
+*}
+
+definition sum_setl :: "'a + 'b \<Rightarrow> 'a set" where
+"sum_setl x = (case x of Inl z => {z} | _ => {})"
+
+definition sum_setr :: "'a + 'b \<Rightarrow> 'b set" where
+"sum_setr x = (case x of Inr z => {z} | _ => {})"
+
+lemmas sum_set_defs = sum_setl_def[abs_def] sum_setr_def[abs_def]
+
+bnf_def sum = sum_map [sum_setl, sum_setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr]
+proof -
+  show "sum_map id id = id" by (rule sum_map.id)
+next
+  fix f1 f2 g1 g2
+  show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
+    by (rule sum_map.comp[symmetric])
+next
+  fix x f1 f2 g1 g2
+  assume a1: "\<And>z. z \<in> sum_setl x \<Longrightarrow> f1 z = g1 z" and
+         a2: "\<And>z. z \<in> sum_setr x \<Longrightarrow> f2 z = g2 z"
+  thus "sum_map f1 f2 x = sum_map g1 g2 x"
+  proof (cases x)
+    case Inl thus ?thesis using a1 by (clarsimp simp: sum_setl_def)
+  next
+    case Inr thus ?thesis using a2 by (clarsimp simp: sum_setr_def)
+  qed
+next
+  fix f1 f2
+  show "sum_setl o sum_map f1 f2 = image f1 o sum_setl"
+    by (rule ext, unfold o_apply) (simp add: sum_setl_def split: sum.split)
+next
+  fix f1 f2
+  show "sum_setr o sum_map f1 f2 = image f2 o sum_setr"
+    by (rule ext, unfold o_apply) (simp add: sum_setr_def split: sum.split)
+next
+  show "card_order natLeq" by (rule natLeq_card_order)
+next
+  show "cinfinite natLeq" by (rule natLeq_cinfinite)
+next
+  fix x
+  show "|sum_setl x| \<le>o natLeq"
+    apply (rule ordLess_imp_ordLeq)
+    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
+    by (simp add: sum_setl_def split: sum.split)
+next
+  fix x
+  show "|sum_setr x| \<le>o natLeq"
+    apply (rule ordLess_imp_ordLeq)
+    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
+    by (simp add: sum_setr_def split: sum.split)
+next
+  fix A1 :: "'a set" and A2 :: "'b set"
+  have in_alt: "{x. (case x of Inl z => {z} | _ => {}) \<subseteq> A1 \<and>
+    (case x of Inr z => {z} | _ => {}) \<subseteq> A2} = A1 <+> A2" (is "?L = ?R")
+  proof safe
+    fix x :: "'a + 'b"
+    assume "(case x of Inl z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A1" "(case x of Inr z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A2"
+    hence "x \<in> Inl ` A1 \<or> x \<in> Inr ` A2" by (cases x) simp+
+    thus "x \<in> A1 <+> A2" by blast
+  qed (auto split: sum.split)
+  show "|{x. sum_setl x \<subseteq> A1 \<and> sum_setr x \<subseteq> A2}| \<le>o
+    (( |A1| +c |A2| ) +c ctwo) ^c natLeq"
+    apply (rule ordIso_ordLeq_trans)
+    apply (rule card_of_ordIso_subst)
+    apply (unfold sum_set_defs)
+    apply (rule in_alt)
+    apply (rule ordIso_ordLeq_trans)
+    apply (rule Plus_csum)
+    apply (rule ordLeq_transitive)
+    apply (rule ordLeq_csum1)
+    apply (rule Card_order_csum)
+    apply (rule ordLeq_cexp1)
+    apply (rule conjI)
+    using Field_natLeq UNIV_not_empty czeroE apply fast
+    apply (rule natLeq_Card_order)
+    by (rule Card_order_csum)
+next
+  fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
+  assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
+  hence
+    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"
+    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"
+    unfolding wpull_def by blast+
+  show "wpull {x. sum_setl x \<subseteq> A1 \<and> sum_setr x \<subseteq> A2}
+  {x. sum_setl x \<subseteq> B11 \<and> sum_setr x \<subseteq> B12} {x. sum_setl x \<subseteq> B21 \<and> sum_setr x \<subseteq> B22}
+  (sum_map f11 f12) (sum_map f21 f22) (sum_map p11 p12) (sum_map p21 p22)"
+    (is "wpull ?in ?in1 ?in2 ?mapf1 ?mapf2 ?mapp1 ?mapp2")
+  proof (unfold wpull_def)
+    { fix B1 B2
+      assume *: "B1 \<in> ?in1" "B2 \<in> ?in2" "?mapf1 B1 = ?mapf2 B2"
+      have "\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2"
+      proof (cases B1)
+        case (Inl b1)
+        { fix b2 assume "B2 = Inr b2"
+          with Inl *(3) have False by simp
+        } then obtain b2 where Inl': "B2 = Inl b2" by (cases B2) (simp, blast)
+        with Inl * have "b1 \<in> B11" "b2 \<in> B21" "f11 b1 = f21 b2"
+        by (simp add: sum_setl_def)+
+        with pull1 obtain a where "a \<in> A1" "p11 a = b1" "p21 a = b2" by blast+
+        with Inl Inl' have "Inl a \<in> ?in" "?mapp1 (Inl a) = B1 \<and> ?mapp2 (Inl a) = B2"
+        by (simp add: sum_set_defs)+
+        thus ?thesis by blast
+      next
+        case (Inr b1)
+        { fix b2 assume "B2 = Inl b2"
+          with Inr *(3) have False by simp
+        } then obtain b2 where Inr': "B2 = Inr b2" by (cases B2) (simp, blast)
+        with Inr * have "b1 \<in> B12" "b2 \<in> B22" "f12 b1 = f22 b2"
+        by (simp add: sum_set_defs)+
+        with pull2 obtain a where "a \<in> A2" "p12 a = b1" "p22 a = b2" by blast+
+        with Inr Inr' have "Inr a \<in> ?in" "?mapp1 (Inr a) = B1 \<and> ?mapp2 (Inr a) = B2"
+        by (simp add: sum_set_defs)+
+        thus ?thesis by blast
+      qed
+    }
+    thus "\<forall>B1 B2. B1 \<in> ?in1 \<and> B2 \<in> ?in2 \<and> ?mapf1 B1 = ?mapf2 B2 \<longrightarrow>
+      (\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2)" by fastforce
+  qed
+qed (auto simp: sum_set_defs)
+
+lemma sum_pred[simp]:
+  "sum_pred \<phi> \<psi> x y =
+    (case x of Inl a1 \<Rightarrow> (case y of Inl a2 \<Rightarrow> \<phi> a1 a2 | Inr _ \<Rightarrow> False)
+             | Inr b1 \<Rightarrow> (case y of Inl _ \<Rightarrow> False | Inr b2 \<Rightarrow> \<psi> b1 b2))"
+unfolding sum_setl_def sum_setr_def sum_pred_def sum_rel_def Gr_def relcomp_unfold converse_unfold
+by (fastforce split: sum.splits)+
+
+lemma singleton_ordLeq_ctwo_natLeq: "|{x}| \<le>o ctwo *c natLeq"
+  apply (rule ordLeq_transitive)
+  apply (rule ordLeq_cprod2)
+  apply (rule ctwo_Cnotzero)
+  apply (auto simp: Field_card_of intro: card_of_card_order_on)
+  apply (rule cprod_mono2)
+  apply (rule ordLess_imp_ordLeq)
+  apply (unfold finite_iff_ordLess_natLeq[symmetric])
+  by simp
+
+definition fsts :: "'a \<times> 'b \<Rightarrow> 'a set" where
+"fsts x = {fst x}"
+
+definition snds :: "'a \<times> 'b \<Rightarrow> 'b set" where
+"snds x = {snd x}"
+
+lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
+
+bnf_def prod = map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. ctwo *c natLeq" [Pair]
+proof (unfold prod_set_defs)
+  show "map_pair id id = id" by (rule map_pair.id)
+next
+  fix f1 f2 g1 g2
+  show "map_pair (g1 o f1) (g2 o f2) = map_pair g1 g2 o map_pair f1 f2"
+    by (rule map_pair.comp[symmetric])
+next
+  fix x f1 f2 g1 g2
+  assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
+  thus "map_pair f1 f2 x = map_pair g1 g2 x" by (cases x) simp
+next
+  fix f1 f2
+  show "(\<lambda>x. {fst x}) o map_pair f1 f2 = image f1 o (\<lambda>x. {fst x})"
+    by (rule ext, unfold o_apply) simp
+next
+  fix f1 f2
+  show "(\<lambda>x. {snd x}) o map_pair f1 f2 = image f2 o (\<lambda>x. {snd x})"
+    by (rule ext, unfold o_apply) simp
+next
+  show "card_order (ctwo *c natLeq)"
+    apply (rule card_order_cprod)
+    apply (rule ctwo_card_order)
+    by (rule natLeq_card_order)
+next
+  show "cinfinite (ctwo *c natLeq)"
+    apply (rule cinfinite_cprod2)
+    apply (rule ctwo_Cnotzero)
+    apply (rule conjI[OF _ natLeq_Card_order])
+    by (rule natLeq_cinfinite)
+next
+  fix x
+  show "|{fst x}| \<le>o ctwo *c natLeq"
+    by (rule singleton_ordLeq_ctwo_natLeq)
+next
+  fix x
+  show "|{snd x}| \<le>o ctwo *c natLeq"
+    by (rule singleton_ordLeq_ctwo_natLeq)
+next
+  fix A1 :: "'a set" and A2 :: "'b set"
+  have in_alt: "{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2} = A1 \<times> A2" by auto
+  show "|{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}| \<le>o
+    ( ( |A1| +c |A2| ) +c ctwo) ^c (ctwo *c natLeq)"
+    apply (rule ordIso_ordLeq_trans)
+    apply (rule card_of_ordIso_subst)
+    apply (rule in_alt)
+    apply (rule ordIso_ordLeq_trans)
+    apply (rule Times_cprod)
+    apply (rule ordLeq_transitive)
+    apply (rule cprod_csum_cexp)
+    apply (rule cexp_mono)
+    apply (rule ordLeq_csum1)
+    apply (rule Card_order_csum)
+    apply (rule ordLeq_cprod1)
+    apply (rule Card_order_ctwo)
+    apply (rule Cinfinite_Cnotzero)
+    apply (rule conjI[OF _ natLeq_Card_order])
+    apply (rule natLeq_cinfinite)
+    apply (rule disjI2)
+    apply (rule cone_ordLeq_cexp)
+    apply (rule ordLeq_transitive)
+    apply (rule cone_ordLeq_ctwo)
+    apply (rule ordLeq_csum2)
+    apply (rule Card_order_ctwo)
+    apply (rule notE)
+    apply (rule ctwo_not_czero)
+    apply assumption
+    by (rule Card_order_ctwo)
+next
+  fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
+  assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
+  thus "wpull {x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}
+    {x. {fst x} \<subseteq> B11 \<and> {snd x} \<subseteq> B12} {x. {fst x} \<subseteq> B21 \<and> {snd x} \<subseteq> B22}
+   (map_pair f11 f12) (map_pair f21 f22) (map_pair p11 p12) (map_pair p21 p22)"
+    unfolding wpull_def by simp fast
+qed simp+
+
+lemma prod_pred[simp]:
+"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))"
+unfolding prod_set_defs prod_pred_def prod_rel_def Gr_def relcomp_unfold converse_unfold by auto
+(* TODO: pred characterization for each basic BNF *)
+
+(* Categorical version of pullback: *)
+lemma wpull_cat:
+assumes p: "wpull A B1 B2 f1 f2 p1 p2"
+and c: "f1 o q1 = f2 o q2"
+and r: "range q1 \<subseteq> B1" "range q2 \<subseteq> B2"
+obtains h where "range h \<subseteq> A \<and> q1 = p1 o h \<and> q2 = p2 o h"
+proof-
+  have *: "\<forall>d. \<exists>a \<in> A. p1 a = q1 d & p2 a = q2 d"
+  proof safe
+    fix d
+    have "f1 (q1 d) = f2 (q2 d)" using c unfolding comp_def[abs_def] by (rule fun_cong)
+    moreover
+    have "q1 d : B1" "q2 d : B2" using r unfolding image_def by auto
+    ultimately show "\<exists>a \<in> A. p1 a = q1 d \<and> p2 a = q2 d"
+      using p unfolding wpull_def by auto
+  qed
+  then obtain h where "!! d. h d \<in> A & p1 (h d) = q1 d & p2 (h d) = q2 d" by metis
+  thus ?thesis using that by fastforce
+qed
+
+lemma card_of_bounded_range:
+  "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
+proof -
+  let ?f = "\<lambda>f. %x. if f x \<in> B then Some (f x) else None"
+  have "inj_on ?f ?LHS" unfolding inj_on_def
+  proof (unfold fun_eq_iff, safe)
+    fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
+    assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
+    hence "f x \<in> B" "g x \<in> B" by auto
+    with eq have "Some (f x) = Some (g x)" by metis
+    thus "f x = g x" by simp
+  qed
+  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
+  ultimately show ?thesis using card_of_ordLeq by fast
+qed
+
+bnf_def "fun" = "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|"
+  ["%c x::'b::type. c::'a::type"]
+proof
+  fix f show "id \<circ> f = id f" by simp
+next
+  fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
+  unfolding comp_def[abs_def] ..
+next
+  fix x f g
+  assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
+  thus "f \<circ> x = g \<circ> x" by auto
+next
+  fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
+  unfolding image_def comp_def[abs_def] by auto
+next
+  show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
+  apply (rule card_order_csum)
+  apply (rule natLeq_card_order)
+  by (rule card_of_card_order_on)
+(*  *)
+  show "cinfinite (natLeq +c ?U)"
+    apply (rule cinfinite_csum)
+    apply (rule disjI1)
+    by (rule natLeq_cinfinite)
+next
+  fix f :: "'d => 'a"
+  have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
+  also have "?U \<le>o natLeq +c ?U"  by (rule ordLeq_csum2) (rule card_of_Card_order)
+  finally show "|range f| \<le>o natLeq +c ?U" .
+next
+  fix B :: "'a set"
+  have "|{f::'d => 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" by (rule card_of_bounded_range)
+  also have "|Func (UNIV :: 'd set) B| =o |B| ^c |UNIV :: 'd set|"
+    unfolding cexp_def Field_card_of by (rule card_of_refl)
+  also have "|B| ^c |UNIV :: 'd set| \<le>o
+             ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )"
+    apply (rule cexp_mono)
+     apply (rule ordLeq_csum1) apply (rule card_of_Card_order)
+     apply (rule ordLeq_csum2) apply (rule card_of_Card_order)
+     apply (rule disjI2) apply (rule cone_ordLeq_cexp)
+      apply (rule ordLeq_transitive) apply (rule cone_ordLeq_ctwo) apply (rule ordLeq_csum2)
+      apply (rule Card_order_ctwo)
+     apply (rule notE) apply (rule conjunct1) apply (rule Cnotzero_UNIV) apply blast
+     apply (rule card_of_Card_order)
+  done
+  finally
+  show "|{f::'d => 'a. range f \<subseteq> B}| \<le>o
+        ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )" .
+next
+  fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
+  show "wpull {h. range h \<subseteq> A} {g1. range g1 \<subseteq> B1} {g2. range g2 \<subseteq> B2}
+    (op \<circ> f1) (op \<circ> f2) (op \<circ> p1) (op \<circ> p2)"
+  unfolding wpull_def
+  proof safe
+    fix g1 g2 assume r: "range g1 \<subseteq> B1" "range g2 \<subseteq> B2"
+    and c: "f1 \<circ> g1 = f2 \<circ> g2"
+    show "\<exists>h \<in> {h. range h \<subseteq> A}. p1 \<circ> h = g1 \<and> p2 \<circ> h = g2"
+    using wpull_cat[OF p c r] by simp metis
+  qed
+qed auto
+
+lemma fun_pred[simp]: "fun_pred \<phi> f g = (\<forall>x. \<phi> (f x) (g x))"
+unfolding fun_rel_def fun_pred_def Gr_def relcomp_unfold converse_unfold
+by (auto intro!: exI dest!: in_mono)
+
+lemma card_of_list_in:
+  "|{xs. set xs \<subseteq> A}| \<le>o |Pfunc (UNIV :: nat set) A|" (is "|?LHS| \<le>o |?RHS|")
+proof -
+  let ?f = "%xs. %i. if i < length xs \<and> set xs \<subseteq> A then Some (nth xs i) else None"
+  have "inj_on ?f ?LHS" unfolding inj_on_def fun_eq_iff
+  proof safe
+    fix xs :: "'a list" and ys :: "'a list"
+    assume su: "set xs \<subseteq> A" "set ys \<subseteq> A" and eq: "\<forall>i. ?f xs i = ?f ys i"
+    hence *: "length xs = length ys"
+    by (metis linorder_cases option.simps(2) order_less_irrefl)
+    thus "xs = ys" by (rule nth_equalityI) (metis * eq su option.inject)
+  qed
+  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Pfunc_def by fastforce
+  ultimately show ?thesis using card_of_ordLeq by blast
+qed
+
+lemma list_in_empty: "A = {} \<Longrightarrow> {x. set x \<subseteq> A} = {[]}"
+by simp
+
+lemma card_of_Func: "|Func A B| =o |B| ^c |A|"
+unfolding cexp_def Field_card_of by (rule card_of_refl)
+
+lemma not_emp_czero_notIn_ordIso_Card_order:
+"A \<noteq> {} \<Longrightarrow> ( |A|, czero) \<notin> ordIso \<and> Card_order |A|"
+  apply (rule conjI)
+  apply (metis Field_card_of czeroE)
+  by (rule card_of_Card_order)
+
+lemma list_in_bd: "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
+proof -
+  fix A :: "'a set"
+  show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
+  proof (cases "A = {}")
+    case False thus ?thesis
+      apply -
+      apply (rule ordLeq_transitive)
+      apply (rule card_of_list_in)
+      apply (rule ordLeq_transitive)
+      apply (erule card_of_Pfunc_Pow_Func)
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule Times_cprod)
+      apply (rule cprod_cinfinite_bound)
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule Pow_cexp_ctwo)
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule cexp_cong2)
+      apply (rule card_of_nat)
+      apply (rule Card_order_ctwo)
+      apply (rule card_of_Card_order)
+      apply (rule natLeq_Card_order)
+      apply (rule disjI1)
+      apply (rule ctwo_Cnotzero)
+      apply (rule cexp_mono1)
+      apply (rule ordLeq_csum2)
+      apply (rule Card_order_ctwo)
+      apply (rule disjI1)
+      apply (rule ctwo_Cnotzero)
+      apply (rule natLeq_Card_order)
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule card_of_Func)
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule cexp_cong2)
+      apply (rule card_of_nat)
+      apply (rule card_of_Card_order)
+      apply (rule card_of_Card_order)
+      apply (rule natLeq_Card_order)
+      apply (rule disjI1)
+      apply (erule not_emp_czero_notIn_ordIso_Card_order)
+      apply (rule cexp_mono1)
+      apply (rule ordLeq_csum1)
+      apply (rule card_of_Card_order)
+      apply (rule disjI1)
+      apply (erule not_emp_czero_notIn_ordIso_Card_order)
+      apply (rule natLeq_Card_order)
+      apply (rule card_of_Card_order)
+      apply (rule card_of_Card_order)
+      apply (rule Cinfinite_cexp)
+      apply (rule ordLeq_csum2)
+      apply (rule Card_order_ctwo)
+      apply (rule conjI)
+      apply (rule natLeq_cinfinite)
+      by (rule natLeq_Card_order)
+  next
+    case True thus ?thesis
+      apply -
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule card_of_ordIso_subst)
+      apply (erule list_in_empty)
+      apply (rule ordIso_ordLeq_trans)
+      apply (rule single_cone)
+      apply (rule cone_ordLeq_cexp)
+      apply (rule ordLeq_transitive)
+      apply (rule cone_ordLeq_ctwo)
+      apply (rule ordLeq_csum2)
+      by (rule Card_order_ctwo)
+  qed
+qed
+
+bnf_def list = map [set] "\<lambda>_::'a list. natLeq" ["[]"]
+proof -
+  show "map id = id" by (rule List.map.id)
+next
+  fix f g
+  show "map (g o f) = map g o map f" by (rule List.map.comp[symmetric])
+next
+  fix x f g
+  assume "\<And>z. z \<in> set x \<Longrightarrow> f z = g z"
+  thus "map f x = map g x" by simp
+next
+  fix f
+  show "set o map f = image f o set" by (rule ext, unfold o_apply, rule set_map)
+next
+  show "card_order natLeq" by (rule natLeq_card_order)
+next
+  show "cinfinite natLeq" by (rule natLeq_cinfinite)
+next
+  fix x
+  show "|set x| \<le>o natLeq"
+    apply (rule ordLess_imp_ordLeq)
+    apply (rule finite_ordLess_infinite[OF _ natLeq_Well_order])
+    unfolding Field_natLeq Field_card_of by (auto simp: card_of_well_order_on)
+next
+  fix A :: "'a set"
+  show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
+next
+  fix A B1 B2 f1 f2 p1 p2
+  assume "wpull A B1 B2 f1 f2 p1 p2"
+  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"
+    unfolding wpull_def by auto
+  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)"
+    (is "wpull ?A ?B1 ?B2 _ _ _ _")
+  proof (unfold wpull_def)
+    { fix as bs assume *: "as \<in> ?B1" "bs \<in> ?B2" "map f1 as = map f2 bs"
+      hence "length as = length bs" by (metis length_map)
+      hence "\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs" using *
+      proof (induct as bs rule: list_induct2)
+        case (Cons a as b bs)
+        hence "a \<in> B1" "b \<in> B2" "f1 a = f2 b" by auto
+        with pull obtain z where "z \<in> A" "p1 z = a" "p2 z = b" by blast
+        moreover
+        from Cons obtain zs where "zs \<in> ?A" "map p1 zs = as" "map p2 zs = bs" by auto
+        ultimately have "z # zs \<in> ?A" "map p1 (z # zs) = a # as \<and> map p2 (z # zs) = b # bs" by auto
+        thus ?case by (rule_tac x = "z # zs" in bexI)
+      qed simp
+    }
+    thus "\<forall>as bs. as \<in> ?B1 \<and> bs \<in> ?B2 \<and> map f1 as = map f2 bs \<longrightarrow>
+      (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
+  qed
+qed auto
+
+bnf_def deadlist = "map id" [] "\<lambda>_::'a list. |lists (UNIV :: 'a set)|" ["[]"]
+by (auto simp add: cinfinite_def wpull_def infinite_UNIV_listI map.id
+  ordLeq_transitive ctwo_def card_of_card_order_on Field_card_of card_of_mono1 ordLeq_cexp2)
+
+(* Finite sets *)
+abbreviation afset where "afset \<equiv> abs_fset"
+abbreviation rfset where "rfset \<equiv> rep_fset"
+
+lemma fset_fset_member:
+"fset A = {a. a |\<in>| A}"
+unfolding fset_def fset_member_def by auto
+
+lemma afset_rfset:
+"afset (rfset x) = x"
+by (rule Quotient_fset[unfolded Quotient_def, THEN conjunct1, rule_format])
+
+lemma afset_rfset_id:
+"afset o rfset = id"
+unfolding comp_def afset_rfset id_def ..
+
+lemma rfset:
+"rfset A = rfset B \<longleftrightarrow> A = B"
+by (metis afset_rfset)
+
+lemma afset_set:
+"afset as = afset bs \<longleftrightarrow> set as = set bs"
+using Quotient_fset unfolding Quotient_def list_eq_def by auto
+
+lemma surj_afset:
+"\<exists> as. A = afset as"
+by (metis afset_rfset)
+
+lemma fset_def2:
+"fset = set o rfset"
+unfolding fset_def map_fun_def[abs_def] by simp
+
+lemma fset_def2_raw:
+"fset A = set (rfset A)"
+unfolding fset_def2 by simp
+
+lemma fset_comp_afset:
+"fset o afset = set"
+unfolding fset_def2 comp_def apply(rule ext)
+unfolding afset_set[symmetric] afset_rfset ..
+
+lemma fset_afset:
+"fset (afset as) = set as"
+unfolding fset_comp_afset[symmetric] by simp
+
+lemma set_rfset_afset:
+"set (rfset (afset as)) = set as"
+unfolding afset_set[symmetric] afset_rfset ..
+
+lemma map_fset_comp_afset:
+"(map_fset f) o afset = afset o (map f)"
+unfolding map_fset_def map_fun_def[abs_def] comp_def apply(rule ext)
+unfolding afset_set set_map set_rfset_afset id_apply ..
+
+lemma map_fset_afset:
+"(map_fset f) (afset as) = afset (map f as)"
+using map_fset_comp_afset unfolding comp_def fun_eq_iff by auto
+
+lemma fset_map_fset:
+"fset (map_fset f A) = (image f) (fset A)"
+apply(subst afset_rfset[symmetric, of A])
+unfolding map_fset_afset fset_afset set_map
+unfolding fset_def2_raw ..
+
+lemma map_fset_def2:
+"map_fset f = afset o (map f) o rfset"
+unfolding map_fset_def map_fun_def[abs_def] by simp
+
+lemma map_fset_def2_raw:
+"map_fset f A = afset (map f (rfset A))"
+unfolding map_fset_def2 by simp
+
+lemma finite_ex_fset:
+assumes "finite A"
+shows "\<exists> B. fset B = A"
+by (metis assms finite_list fset_afset)
+
+lemma wpull_image:
+assumes "wpull A B1 B2 f1 f2 p1 p2"
+shows "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
+unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
+  fix Y1 Y2 assume Y1: "Y1 \<subseteq> B1" and Y2: "Y2 \<subseteq> B2" and EQ: "f1 ` Y1 = f2 ` Y2"
+  def X \<equiv> "{a \<in> A. p1 a \<in> Y1 \<and> p2 a \<in> Y2}"
+  show "\<exists>X\<subseteq>A. p1 ` X = Y1 \<and> p2 ` X = Y2"
+  proof (rule exI[of _ X], intro conjI)
+    show "p1 ` X = Y1"
+    proof
+      show "Y1 \<subseteq> p1 ` X"
+      proof safe
+        fix y1 assume y1: "y1 \<in> Y1"
+        then obtain y2 where y2: "y2 \<in> Y2" and eq: "f1 y1 = f2 y2" using EQ by auto
+        then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
+        using assms y1 Y1 Y2 unfolding wpull_def by blast
+        thus "y1 \<in> p1 ` X" unfolding X_def using y1 y2 by auto
+      qed
+    qed(unfold X_def, auto)
+    show "p2 ` X = Y2"
+    proof
+      show "Y2 \<subseteq> p2 ` X"
+      proof safe
+        fix y2 assume y2: "y2 \<in> Y2"
+        then obtain y1 where y1: "y1 \<in> Y1" and eq: "f1 y1 = f2 y2" using EQ by force
+        then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
+        using assms y2 Y1 Y2 unfolding wpull_def by blast
+        thus "y2 \<in> p2 ` X" unfolding X_def using y1 y2 by auto
+      qed
+    qed(unfold X_def, auto)
+  qed(unfold X_def, auto)
+qed
+
+lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
+by (rule f_the_inv_into_f) (auto simp: inj_on_def fset_cong dest!: finite_ex_fset)
+
+bnf_def fset = map_fset [fset] "\<lambda>_::'a fset. natLeq" ["{||}"]
+proof -
+  show "map_fset id = id"
+  unfolding map_fset_def2 map_id o_id afset_rfset_id ..
+next
+  fix f g
+  show "map_fset (g o f) = map_fset g o map_fset f"
+  unfolding map_fset_def2 map.comp[symmetric] comp_def apply(rule ext)
+  unfolding afset_set set_map fset_def2_raw[symmetric] image_image[symmetric]
+  unfolding map_fset_afset[symmetric] map_fset_image afset_rfset
+  by (rule refl)
+next
+  fix x f g
+  assume "\<And>z. z \<in> fset x \<Longrightarrow> f z = g z"
+  hence "map f (rfset x) = map g (rfset x)"
+  apply(intro map_cong) unfolding fset_def2_raw by auto
+  thus "map_fset f x = map_fset g x" unfolding map_fset_def2_raw
+  by (rule arg_cong)
+next
+  fix f
+  show "fset o map_fset f = image f o fset"
+  unfolding comp_def fset_map_fset ..
+next
+  show "card_order natLeq" by (rule natLeq_card_order)
+next
+  show "cinfinite natLeq" by (rule natLeq_cinfinite)
+next
+  fix x
+  show "|fset x| \<le>o natLeq"
+  unfolding fset_def2_raw
+  apply (rule ordLess_imp_ordLeq)
+  apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
+  by (rule finite_set)
+next
+  fix A :: "'a set"
+  have "|{x. fset x \<subseteq> A}| \<le>o |afset ` {as. set as \<subseteq> A}|"
+  apply(rule card_of_mono1) unfolding fset_def2_raw apply auto
+  apply (rule image_eqI)
+  by (auto simp: afset_rfset)
+  also have "|afset ` {as. set as \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_image .
+  also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
+  finally show "|{x. fset x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
+next
+  fix A B1 B2 f1 f2 p1 p2
+  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
+  hence "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
+  by(rule wpull_image)
+  show "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
+              (map_fset f1) (map_fset f2) (map_fset p1) (map_fset p2)"
+  unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
+    fix y1 y2
+    assume Y1: "fset y1 \<subseteq> B1" and Y2: "fset y2 \<subseteq> B2"
+    assume "map_fset f1 y1 = map_fset f2 y2"
+    hence EQ: "f1 ` (fset y1) = f2 ` (fset y2)" unfolding map_fset_def2_raw
+    unfolding afset_set set_map fset_def2_raw .
+    with Y1 Y2 obtain X where X: "X \<subseteq> A"
+    and Y1: "p1 ` X = fset y1" and Y2: "p2 ` X = fset y2"
+    using wpull_image[OF wp] unfolding wpull_def Pow_def
+    unfolding Bex_def mem_Collect_eq apply -
+    apply(erule allE[of _ "fset y1"], erule allE[of _ "fset y2"]) by auto
+    have "\<forall> y1' \<in> fset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
+    then obtain q1 where q1: "\<forall> y1' \<in> fset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
+    have "\<forall> y2' \<in> fset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
+    then obtain q2 where q2: "\<forall> y2' \<in> fset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
+    def X' \<equiv> "q1 ` (fset y1) \<union> q2 ` (fset y2)"
+    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = fset y1" and Y2: "p2 ` X' = fset y2"
+    using X Y1 Y2 q1 q2 unfolding X'_def by auto
+    have fX': "finite X'" unfolding X'_def by simp
+    then obtain x where X'eq: "X' = fset x" by (auto dest: finite_ex_fset)
+    show "\<exists>x. fset x \<subseteq> A \<and> map_fset p1 x = y1 \<and> map_fset p2 x = y2"
+    apply(intro exI[of _ "x"]) using X' Y1 Y2
+    unfolding X'eq map_fset_def2_raw fset_def2_raw set_map[symmetric]
+    afset_set[symmetric] afset_rfset by simp
+  qed
+qed auto
+
+lemma fset_pred[simp]: "fset_pred R a b \<longleftrightarrow>
+  ((\<forall>t \<in> fset a. (\<exists>u \<in> fset b. R t u)) \<and>
+   (\<forall>t \<in> fset b. (\<exists>u \<in> fset a. R u t)))" (is "?L = ?R")
+proof
+  assume ?L thus ?R unfolding fset_rel_def fset_pred_def
+    Gr_def relcomp_unfold converse_unfold
+  apply (simp add: subset_eq Ball_def)
+  apply (rule conjI)
+  apply (clarsimp, metis snd_conv)
+  by (clarsimp, metis fst_conv)
+next
+  assume ?R
+  def R' \<equiv> "the_inv fset (Collect (split R) \<inter> (fset a \<times> fset b))" (is "the_inv fset ?R'")
+  have "finite ?R'" by (intro finite_Int[OF disjI2] finite_cartesian_product) auto
+  hence *: "fset R' = ?R'" unfolding R'_def by (intro fset_to_fset)
+  show ?L unfolding fset_rel_def fset_pred_def Gr_def relcomp_unfold converse_unfold
+  proof (intro CollectI prod_caseI exI conjI)
+    from * show "(R', a) = (R', map_fset fst R')" using conjunct1[OF `?R`]
+      by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
+    from * show "(R', b) = (R', map_fset snd R')" using conjunct2[OF `?R`]
+      by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
+  qed (auto simp add: *)
+qed
+
+(* Countable sets *)
+
+lemma card_of_countable_sets_range:
+fixes A :: "'a set"
+shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
+apply(rule card_of_ordLeqI[of fromNat]) using inj_on_fromNat
+unfolding inj_on_def by auto
+
+lemma card_of_countable_sets_Func:
+"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
+using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
+unfolding cexp_def Field_natLeq Field_card_of
+by(rule ordLeq_ordIso_trans)
+
+lemma ordLeq_countable_subsets:
+"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
+apply(rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
+
+lemma finite_countable_subset:
+"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
+apply default
+ apply (erule contrapos_pp)
+ apply (rule card_of_ordLeq_infinite)
+ apply (rule ordLeq_countable_subsets)
+ apply assumption
+apply (rule finite_Collect_conjI)
+apply (rule disjI1)
+by (erule finite_Collect_subsets)
+
+lemma card_of_countable_sets:
+"|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
+(is "|?L| \<le>o _")
+proof(cases "finite A")
+  let ?R = "Func (UNIV::nat set) (A <+> (UNIV::bool set))"
+  case True hence "finite ?L" by simp
+  moreover have "infinite ?R"
+  apply(rule infinite_Func[of _ "Inr True" "Inr False"]) by auto
+  ultimately show ?thesis unfolding cexp_def csum_def ctwo_def Field_natLeq Field_card_of
+  apply(intro ordLess_imp_ordLeq) by (rule finite_ordLess_infinite2)
+next
+  case False
+  hence "|{X. X \<subseteq> A \<and> countable X}| =o |{X. X \<subseteq> A \<and> countable X} - {{}}|"
+  by (intro card_of_infinite_diff_finitte finite.emptyI finite.insertI ordIso_symmetric)
+     (unfold finite_countable_subset)
+  also have "|{X. X \<subseteq> A \<and> countable X} - {{}}| \<le>o |A| ^c natLeq"
+  using card_of_countable_sets_Func[of A] unfolding set_diff_eq by auto
+  also have "|A| ^c natLeq \<le>o ( |A| +c ctwo) ^c natLeq"
+  apply(rule cexp_mono1_cone_ordLeq)
+    apply(rule ordLeq_csum1, rule card_of_Card_order)
+    apply (rule cone_ordLeq_cexp)
+    apply (rule cone_ordLeq_Cnotzero)
+    using csum_Cnotzero2 ctwo_Cnotzero apply blast
+    by (rule natLeq_Card_order)
+  finally show ?thesis .
+qed
+
+bnf_def cset = cIm [rcset] "\<lambda>_::'a cset. natLeq" ["cEmp"]
+proof -
+  show "cIm id = id" unfolding cIm_def[abs_def] id_def by auto
+next
+  fix f g show "cIm (g \<circ> f) = cIm g \<circ> cIm f"
+  unfolding cIm_def[abs_def] apply(rule ext) unfolding comp_def by auto
+next
+  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
+  thus "cIm f C = cIm g C"
+  unfolding cIm_def[abs_def] unfolding image_def by auto
+next
+  fix f show "rcset \<circ> cIm f = op ` f \<circ> rcset" unfolding cIm_def[abs_def] by auto
+next
+  show "card_order natLeq" by (rule natLeq_card_order)
+next
+  show "cinfinite natLeq" by (rule natLeq_cinfinite)
+next
+  fix C show "|rcset C| \<le>o natLeq" using rcset unfolding countable_def .
+next
+  fix A :: "'a set"
+  have "|{Z. rcset Z \<subseteq> A}| \<le>o |acset ` {X. X \<subseteq> A \<and> countable X}|"
+  apply(rule card_of_mono1) unfolding Pow_def image_def
+  proof (rule Collect_mono, clarsimp)
+    fix x
+    assume "rcset x \<subseteq> A"
+    hence "rcset x \<subseteq> A \<and> countable (rcset x) \<and> x = acset (rcset x)"
+    using acset_rcset[of x] rcset[of x] by force
+    thus "\<exists>y \<subseteq> A. countable y \<and> x = acset y" by blast
+  qed
+  also have "|acset ` {X. X \<subseteq> A \<and> countable X}| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
+  using card_of_image .
+  also have "|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
+  using card_of_countable_sets .
+  finally show "|{Z. rcset Z \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
+next
+  fix A B1 B2 f1 f2 p1 p2
+  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
+  show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
+              (cIm f1) (cIm f2) (cIm p1) (cIm p2)"
+  unfolding wpull_def proof safe
+    fix y1 y2
+    assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
+    assume "cIm f1 y1 = cIm f2 y2"
+    hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)"
+    unfolding cIm_def by auto
+    with Y1 Y2 obtain X where X: "X \<subseteq> A"
+    and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
+    using wpull_image[OF wp] unfolding wpull_def Pow_def
+    unfolding Bex_def mem_Collect_eq apply -
+    apply(erule allE[of _ "rcset y1"], erule allE[of _ "rcset y2"]) by auto
+    have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
+    then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
+    have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
+    then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
+    def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
+    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
+    using X Y1 Y2 q1 q2 unfolding X'_def by fast+
+    have fX': "countable X'" unfolding X'_def by simp
+    then obtain x where X'eq: "X' = rcset x" by (metis rcset_acset)
+    show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cIm p1 x = y1 \<and> cIm p2 x = y2"
+    apply(intro bexI[of _ "x"]) using X' Y1 Y2 unfolding X'eq cIm_def by auto
+  qed
+qed (unfold cEmp_def, auto)
+
+
+(* Multisets *)
+
+lemma setsum_gt_0_iff:
+fixes f :: "'a \<Rightarrow> nat" assumes "finite A"
+shows "setsum f A > 0 \<longleftrightarrow> (\<exists> a \<in> A. f a > 0)"
+(is "?L \<longleftrightarrow> ?R")
+proof-
+  have "?L \<longleftrightarrow> \<not> setsum f A = 0" by fast
+  also have "... \<longleftrightarrow> (\<exists> a \<in> A. f a \<noteq> 0)" using assms by simp
+  also have "... \<longleftrightarrow> ?R" by simp
+  finally show ?thesis .
+qed
+
+(*   *)
+definition mmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> nat" where
+"mmap h f b = setsum f {a. h a = b \<and> f a > 0}"
+
+lemma mmap_id: "mmap id = id"
+proof (rule ext)+
+  fix f a show "mmap id f a = id f a"
+  proof(cases "f a = 0")
+    case False
+    hence 1: "{aa. aa = a \<and> 0 < f aa} = {a}" by auto
+    show ?thesis by (simp add: mmap_def id_apply 1)
+  qed(unfold mmap_def, auto)
+qed
+
+lemma inj_on_setsum_inv:
+assumes f: "f \<in> multiset"
+and 1: "(0::nat) < setsum f {a. h a = b' \<and> 0 < f a}" (is "0 < setsum f ?A'")
+and 2: "{a. h a = b \<and> 0 < f a} = {a. h a = b' \<and> 0 < f a}" (is "?A = ?A'")
+shows "b = b'"
+proof-
+  have "finite ?A'" using f unfolding multiset_def by auto
+  hence "?A' \<noteq> {}" using 1 setsum_gt_0_iff by auto
+  thus ?thesis using 2 by auto
+qed
+
+lemma mmap_comp:
+fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
+assumes f: "f \<in> multiset"
+shows "mmap (h2 o h1) f = (mmap h2 o mmap h1) f"
+unfolding mmap_def[abs_def] comp_def proof(rule ext)+
+  fix c :: 'c
+  let ?A = "{a. h2 (h1 a) = c \<and> 0 < f a}"
+  let ?As = "\<lambda> b. {a. h1 a = b \<and> 0 < f a}"
+  let ?B = "{b. h2 b = c \<and> 0 < setsum f (?As b)}"
+  have 0: "{?As b | b.  b \<in> ?B} = ?As ` ?B" by auto
+  have "\<And> b. finite (?As b)" using f unfolding multiset_def by simp
+  hence "?B = {b. h2 b = c \<and> ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
+  hence A: "?A = \<Union> {?As b | b.  b \<in> ?B}" by auto
+  have "setsum f ?A = setsum (setsum f) {?As b | b.  b \<in> ?B}"
+  unfolding A apply(rule setsum_Union_disjoint)
+  using f unfolding multiset_def by auto
+  also have "... = setsum (setsum f) (?As ` ?B)" unfolding 0 ..
+  also have "... = setsum (setsum f o ?As) ?B" apply(rule setsum_reindex)
+  unfolding inj_on_def apply auto using inj_on_setsum_inv[OF f, of h1] by blast
+  also have "... = setsum (\<lambda> b. setsum f (?As b)) ?B" unfolding comp_def ..
+  finally show "setsum f ?A = setsum (\<lambda> b. setsum f (?As b)) ?B" .
+qed
+
+lemma mmap_comp1:
+fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
+assumes "f \<in> multiset"
+shows "mmap (\<lambda> a. h2 (h1 a)) f = mmap h2 (mmap h1 f)"
+using mmap_comp[OF assms] unfolding comp_def by auto
+
+lemma mmap:
+assumes "f \<in> multiset"
+shows "mmap h f \<in> multiset"
+using assms unfolding mmap_def[abs_def] multiset_def proof safe
+  assume fin: "finite {a. 0 < f a}"  (is "finite ?A")
+  show "finite {b. 0 < setsum f {a. h a = b \<and> 0 < f a}}"
+  (is "finite {b. 0 < setsum f (?As b)}")
+  proof- let ?B = "{b. 0 < setsum f (?As b)}"
+    have "\<And> b. finite (?As b)" using assms unfolding multiset_def by simp
+    hence B: "?B = {b. ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
+    hence "?B \<subseteq> h ` ?A" by auto
+    thus ?thesis using finite_surj[OF fin] by auto
+  qed
+qed
+
+lemma mmap_cong:
+assumes "\<And>a. a \<in># M \<Longrightarrow> f a = g a"
+shows "mmap f (count M) = mmap g (count M)"
+using assms unfolding mmap_def[abs_def] by (intro ext, intro setsum_cong) auto
+
+abbreviation supp where "supp f \<equiv> {a. f a > 0}"
+
+lemma mmap_image_comp:
+assumes f: "f \<in> multiset"
+shows "(supp o mmap h) f = (image h o supp) f"
+unfolding mmap_def[abs_def] comp_def proof-
+  have "\<And> b. finite {a. h a = b \<and> 0 < f a}" (is "\<And> b. finite (?As b)")
+  using f unfolding multiset_def by auto
+  thus "{b. 0 < setsum f (?As b)} = h ` {a. 0 < f a}"
+  using setsum_gt_0_iff by auto
+qed
+
+lemma mmap_image:
+assumes f: "f \<in> multiset"
+shows "supp (mmap h f) = h ` (supp f)"
+using mmap_image_comp[OF assms] unfolding comp_def .
+
+lemma set_of_Abs_multiset:
+assumes f: "f \<in> multiset"
+shows "set_of (Abs_multiset f) = supp f"
+using assms unfolding set_of_def by (auto simp: Abs_multiset_inverse)
+
+lemma supp_count:
+"supp (count M) = set_of M"
+using assms unfolding set_of_def by auto
+
+lemma multiset_of_surj:
+"multiset_of ` {as. set as \<subseteq> A} = {M. set_of M \<subseteq> A}"
+proof safe
+  fix M assume M: "set_of M \<subseteq> A"
+  obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto
+  hence "set as \<subseteq> A" using M by auto
+  thus "M \<in> multiset_of ` {as. set as \<subseteq> A}" using eq by auto
+next
+  show "\<And>x xa xb. \<lbrakk>set xa \<subseteq> A; xb \<in> set_of (multiset_of xa)\<rbrakk> \<Longrightarrow> xb \<in> A"
+  by (erule set_mp) (unfold set_of_multiset_of)
+qed
+
+lemma card_of_set_of:
+"|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|"
+apply(rule card_of_ordLeqI2[of _ multiset_of]) using multiset_of_surj by auto
+
+lemma nat_sum_induct:
+assumes "\<And>n1 n2. (\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow> phi m1 m2) \<Longrightarrow> phi n1 n2"
+shows "phi (n1::nat) (n2::nat)"
+proof-
+  let ?chi = "\<lambda> n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)"
+  have "?chi (n1,n2)"
+  apply(induct rule: measure_induct[of "\<lambda> n1n2. fst n1n2 + snd n1n2" ?chi])
+  using assms by (metis fstI sndI)
+  thus ?thesis by simp
+qed
+
+lemma matrix_count:
+fixes ct1 ct2 :: "nat \<Rightarrow> nat"
+assumes "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
+shows
+"\<exists> ct. (\<forall> i1 \<le> n1. setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ct1 i1) \<and>
+       (\<forall> i2 \<le> n2. setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ct2 i2)"
+(is "?phi ct1 ct2 n1 n2")
+proof-
+  have "\<forall> ct1 ct2 :: nat \<Rightarrow> nat.
+        setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"
+  proof(induct rule: nat_sum_induct[of
+"\<lambda> n1 n2. \<forall> ct1 ct2 :: nat \<Rightarrow> nat.
+     setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"],
+      clarify)
+  fix n1 n2 :: nat and ct1 ct2 :: "nat \<Rightarrow> nat"
+  assume IH: "\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow>
+                \<forall> dt1 dt2 :: nat \<Rightarrow> nat.
+                setsum dt1 {..<Suc m1} = setsum dt2 {..<Suc m2} \<longrightarrow> ?phi dt1 dt2 m1 m2"
+  and ss: "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
+  show "?phi ct1 ct2 n1 n2"
+  proof(cases n1)
+    case 0 note n1 = 0
+    show ?thesis
+    proof(cases n2)
+      case 0 note n2 = 0
+      let ?ct = "\<lambda> i1 i2. ct2 0"
+      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by simp
+    next
+      case (Suc m2) note n2 = Suc
+      let ?ct = "\<lambda> i1 i2. ct2 i2"
+      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
+    qed
+  next
+    case (Suc m1) note n1 = Suc
+    show ?thesis
+    proof(cases n2)
+      case 0 note n2 = 0
+      let ?ct = "\<lambda> i1 i2. ct1 i1"
+      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
+    next
+      case (Suc m2) note n2 = Suc
+      show ?thesis
+      proof(cases "ct1 n1 \<le> ct2 n2")
+        case True
+        def dt2 \<equiv> "\<lambda> i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2"
+        have "setsum ct1 {..<Suc m1} = setsum dt2 {..<Suc n2}"
+        unfolding dt2_def using ss n1 True by auto
+        hence "?phi ct1 dt2 m1 n2" using IH[of m1 n2] n1 by simp
+        then obtain dt where
+        1: "\<And> i1. i1 \<le> m1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc n2} = ct1 i1" and
+        2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc m1} = dt2 i2" by auto
+        let ?ct = "\<lambda> i1 i2. if i1 = n1 then (if i2 = n2 then ct1 n1 else 0)
+                                       else dt i1 i2"
+        show ?thesis apply(rule exI[of _ ?ct])
+        using n1 n2 1 2 True unfolding dt2_def by simp
+      next
+        case False
+        hence False: "ct2 n2 < ct1 n1" by simp
+        def dt1 \<equiv> "\<lambda> i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1"
+        have "setsum dt1 {..<Suc n1} = setsum ct2 {..<Suc m2}"
+        unfolding dt1_def using ss n2 False by auto
+        hence "?phi dt1 ct2 n1 m2" using IH[of n1 m2] n2 by simp
+        then obtain dt where
+        1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc m2} = dt1 i1" and
+        2: "\<And> i2. i2 \<le> m2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc n1} = ct2 i2" by force
+        let ?ct = "\<lambda> i1 i2. if i2 = n2 then (if i1 = n1 then ct2 n2 else 0)
+                                       else dt i1 i2"
+        show ?thesis apply(rule exI[of _ ?ct])
+        using n1 n2 1 2 False unfolding dt1_def by simp
+      qed
+    qed
+  qed
+  qed
+  thus ?thesis using assms by auto
+qed
+
+definition
+"inj2 u B1 B2 \<equiv>
+ \<forall> b1 b1' b2 b2'. {b1,b1'} \<subseteq> B1 \<and> {b2,b2'} \<subseteq> B2 \<and> u b1 b2 = u b1' b2'
+                  \<longrightarrow> b1 = b1' \<and> b2 = b2'"
+
+lemma matrix_count_finite:
+assumes B1: "B1 \<noteq> {}" "finite B1" and B2: "B2 \<noteq> {}" "finite B2" and u: "inj2 u B1 B2"
+and ss: "setsum N1 B1 = setsum N2 B2"
+shows "\<exists> M :: 'a \<Rightarrow> nat.
+            (\<forall> b1 \<in> B1. setsum (\<lambda> b2. M (u b1 b2)) B2 = N1 b1) \<and>
+            (\<forall> b2 \<in> B2. setsum (\<lambda> b1. M (u b1 b2)) B1 = N2 b2)"
+proof-
+  obtain n1 where "card B1 = Suc n1" using B1 by (metis card_insert finite.simps)
+  then obtain e1 where e1: "bij_betw e1 {..<Suc n1} B1"
+  using ex_bij_betw_finite_nat[OF B1(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
+  hence e1_inj: "inj_on e1 {..<Suc n1}" and e1_surj: "e1 ` {..<Suc n1} = B1"
+  unfolding bij_betw_def by auto
+  def f1 \<equiv> "inv_into {..<Suc n1} e1"
+  have f1: "bij_betw f1 B1 {..<Suc n1}"
+  and f1e1[simp]: "\<And> i1. i1 < Suc n1 \<Longrightarrow> f1 (e1 i1) = i1"
+  and e1f1[simp]: "\<And> b1. b1 \<in> B1 \<Longrightarrow> e1 (f1 b1) = b1" unfolding f1_def
+  apply (metis bij_betw_inv_into e1, metis bij_betw_inv_into_left e1 lessThan_iff)
+  by (metis e1_surj f_inv_into_f)
+  (*  *)
+  obtain n2 where "card B2 = Suc n2" using B2 by (metis card_insert finite.simps)
+  then obtain e2 where e2: "bij_betw e2 {..<Suc n2} B2"
+  using ex_bij_betw_finite_nat[OF B2(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
+  hence e2_inj: "inj_on e2 {..<Suc n2}" and e2_surj: "e2 ` {..<Suc n2} = B2"
+  unfolding bij_betw_def by auto
+  def f2 \<equiv> "inv_into {..<Suc n2} e2"
+  have f2: "bij_betw f2 B2 {..<Suc n2}"
+  and f2e2[simp]: "\<And> i2. i2 < Suc n2 \<Longrightarrow> f2 (e2 i2) = i2"
+  and e2f2[simp]: "\<And> b2. b2 \<in> B2 \<Longrightarrow> e2 (f2 b2) = b2" unfolding f2_def
+  apply (metis bij_betw_inv_into e2, metis bij_betw_inv_into_left e2 lessThan_iff)
+  by (metis e2_surj f_inv_into_f)
+  (*  *)
+  let ?ct1 = "N1 o e1"  let ?ct2 = "N2 o e2"
+  have ss: "setsum ?ct1 {..<Suc n1} = setsum ?ct2 {..<Suc n2}"
+  unfolding setsum_reindex[OF e1_inj, symmetric] setsum_reindex[OF e2_inj, symmetric]
+  e1_surj e2_surj using ss .
+  obtain ct where
+  ct1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ?ct1 i1" and
+  ct2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ?ct2 i2"
+  using matrix_count[OF ss] by blast
+  (*  *)
+  def A \<equiv> "{u b1 b2 | b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"
+  have "\<forall> a \<in> A. \<exists> b1b2 \<in> B1 <*> B2. u (fst b1b2) (snd b1b2) = a"
+  unfolding A_def Ball_def mem_Collect_eq by auto
+  then obtain h1h2 where h12:
+  "\<And>a. a \<in> A \<Longrightarrow> u (fst (h1h2 a)) (snd (h1h2 a)) = a \<and> h1h2 a \<in> B1 <*> B2" by metis
+  def h1 \<equiv> "fst o h1h2"  def h2 \<equiv> "snd o h1h2"
+  have h12[simp]: "\<And>a. a \<in> A \<Longrightarrow> u (h1 a) (h2 a) = a"
+                  "\<And> a. a \<in> A \<Longrightarrow> h1 a \<in> B1"  "\<And> a. a \<in> A \<Longrightarrow> h2 a \<in> B2"
+  using h12 unfolding h1_def h2_def by force+
+  {fix b1 b2 assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2"
+   hence inA: "u b1 b2 \<in> A" unfolding A_def by auto
+   hence "u b1 b2 = u (h1 (u b1 b2)) (h2 (u b1 b2))" by auto
+   moreover have "h1 (u b1 b2) \<in> B1" "h2 (u b1 b2) \<in> B2" using inA by auto
+   ultimately have "h1 (u b1 b2) = b1 \<and> h2 (u b1 b2) = b2"
+   using u b1 b2 unfolding inj2_def by fastforce
+  }
+  hence h1[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h1 (u b1 b2) = b1" and
+        h2[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h2 (u b1 b2) = b2" by auto
+  def M \<equiv> "\<lambda> a. ct (f1 (h1 a)) (f2 (h2 a))"
+  show ?thesis
+  apply(rule exI[of _ M]) proof safe
+    fix b1 assume b1: "b1 \<in> B1"
+    hence f1b1: "f1 b1 \<le> n1" using f1 unfolding bij_betw_def
+    by (metis bij_betwE f1 lessThan_iff less_Suc_eq_le)
+    have "(\<Sum>b2\<in>B2. M (u b1 b2)) = (\<Sum>i2<Suc n2. ct (f1 b1) (f2 (e2 i2)))"
+    unfolding e2_surj[symmetric] setsum_reindex[OF e2_inj]
+    unfolding M_def comp_def apply(intro setsum_cong) apply force
+    by (metis e2_surj b1 h1 h2 imageI)
+    also have "... = N1 b1" using b1 ct1[OF f1b1] by simp
+    finally show "(\<Sum>b2\<in>B2. M (u b1 b2)) = N1 b1" .
+  next
+    fix b2 assume b2: "b2 \<in> B2"
+    hence f2b2: "f2 b2 \<le> n2" using f2 unfolding bij_betw_def
+    by (metis bij_betwE f2 lessThan_iff less_Suc_eq_le)
+    have "(\<Sum>b1\<in>B1. M (u b1 b2)) = (\<Sum>i1<Suc n1. ct (f1 (e1 i1)) (f2 b2))"
+    unfolding e1_surj[symmetric] setsum_reindex[OF e1_inj]
+    unfolding M_def comp_def apply(intro setsum_cong) apply force
+    by (metis e1_surj b2 h1 h2 imageI)
+    also have "... = N2 b2" using b2 ct2[OF f2b2] by simp
+    finally show "(\<Sum>b1\<in>B1. M (u b1 b2)) = N2 b2" .
+  qed
+qed
+
+lemma supp_vimage_mmap:
+assumes "M \<in> multiset"
+shows "supp M \<subseteq> f -` (supp (mmap f M))"
+using assms by (auto simp: mmap_image)
+
+lemma mmap_ge_0:
+assumes "M \<in> multiset"
+shows "0 < mmap f M b \<longleftrightarrow> (\<exists>a. 0 < M a \<and> f a = b)"
+proof-
+  have f: "finite {a. f a = b \<and> 0 < M a}" using assms unfolding multiset_def by auto
+  show ?thesis unfolding mmap_def setsum_gt_0_iff[OF f] by auto
+qed
+
+lemma finite_twosets:
+assumes "finite B1" and "finite B2"
+shows "finite {u b1 b2 |b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"  (is "finite ?A")
+proof-
+  have A: "?A = (\<lambda> b1b2. u (fst b1b2) (snd b1b2)) ` (B1 <*> B2)" by force
+  show ?thesis unfolding A using finite_cartesian_product[OF assms] by auto
+qed
+
+lemma wp_mmap:
+fixes A :: "'a set" and B1 :: "'b1 set" and B2 :: "'b2 set"
+assumes wp: "wpull A B1 B2 f1 f2 p1 p2"
+shows
+"wpull {M. M \<in> multiset \<and> supp M \<subseteq> A}
+       {N1. N1 \<in> multiset \<and> supp N1 \<subseteq> B1} {N2. N2 \<in> multiset \<and> supp N2 \<subseteq> B2}
+       (mmap f1) (mmap f2) (mmap p1) (mmap p2)"
+unfolding wpull_def proof (safe, unfold Bex_def mem_Collect_eq)
+  fix N1 :: "'b1 \<Rightarrow> nat" and N2 :: "'b2 \<Rightarrow> nat"
+  assume mmap': "mmap f1 N1 = mmap f2 N2"
+  and N1[simp]: "N1 \<in> multiset" "supp N1 \<subseteq> B1"
+  and N2[simp]: "N2 \<in> multiset" "supp N2 \<subseteq> B2"
+  have mN1[simp]: "mmap f1 N1 \<in> multiset" using N1 by (auto simp: mmap)
+  have mN2[simp]: "mmap f2 N2 \<in> multiset" using N2 by (auto simp: mmap)
+  def P \<equiv> "mmap f1 N1"
+  have P1: "P = mmap f1 N1" and P2: "P = mmap f2 N2" unfolding P_def using mmap' by auto
+  note P = P1 P2
+  have P_mult[simp]: "P \<in> multiset" unfolding P_def using N1 by auto
+  have fin_N1[simp]: "finite (supp N1)" using N1(1) unfolding multiset_def by auto
+  have fin_N2[simp]: "finite (supp N2)" using N2(1) unfolding multiset_def by auto
+  have fin_P[simp]: "finite (supp P)" using P_mult unfolding multiset_def by auto
+  (*  *)
+  def set1 \<equiv> "\<lambda> c. {b1 \<in> supp N1. f1 b1 = c}"
+  have set1[simp]: "\<And> c b1. b1 \<in> set1 c \<Longrightarrow> f1 b1 = c" unfolding set1_def by auto
+  have fin_set1: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set1 c)"
+  using N1(1) unfolding set1_def multiset_def by auto
+  have set1_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<noteq> {}"
+  unfolding set1_def P1 mmap_ge_0[OF N1(1)] by auto
+  have supp_N1_set1: "supp N1 = (\<Union> c \<in> supp P. set1 c)"
+  using supp_vimage_mmap[OF N1(1), of f1] unfolding set1_def P1 by auto
+  hence set1_inclN1: "\<And>c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> supp N1" by auto
+  hence set1_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> B1" using N1(2) by blast
+  have set1_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set1 c \<inter> set1 c' = {}"
+  unfolding set1_def by auto
+  have setsum_set1: "\<And> c. setsum N1 (set1 c) = P c"
+  unfolding P1 set1_def mmap_def apply(rule setsum_cong) by auto
+  (*  *)
+  def set2 \<equiv> "\<lambda> c. {b2 \<in> supp N2. f2 b2 = c}"
+  have set2[simp]: "\<And> c b2. b2 \<in> set2 c \<Longrightarrow> f2 b2 = c" unfolding set2_def by auto
+  have fin_set2: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set2 c)"
+  using N2(1) unfolding set2_def multiset_def by auto
+  have set2_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<noteq> {}"
+  unfolding set2_def P2 mmap_ge_0[OF N2(1)] by auto
+  have supp_N2_set2: "supp N2 = (\<Union> c \<in> supp P. set2 c)"
+  using supp_vimage_mmap[OF N2(1), of f2] unfolding set2_def P2 by auto
+  hence set2_inclN2: "\<And>c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> supp N2" by auto
+  hence set2_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> B2" using N2(2) by blast
+  have set2_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set2 c \<inter> set2 c' = {}"
+  unfolding set2_def by auto
+  have setsum_set2: "\<And> c. setsum N2 (set2 c) = P c"
+  unfolding P2 set2_def mmap_def apply(rule setsum_cong) by auto
+  (*  *)
+  have ss: "\<And> c. c \<in> supp P \<Longrightarrow> setsum N1 (set1 c) = setsum N2 (set2 c)"
+  unfolding setsum_set1 setsum_set2 ..
+  have "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
+          \<exists> a \<in> A. p1 a = fst b1b2 \<and> p2 a = snd b1b2"
+  using wp set1_incl set2_incl unfolding wpull_def Ball_def mem_Collect_eq
+  by simp (metis set1 set2 set_rev_mp)
+  then obtain uu where uu:
+  "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
+     uu c b1b2 \<in> A \<and> p1 (uu c b1b2) = fst b1b2 \<and> p2 (uu c b1b2) = snd b1b2" by metis
+  def u \<equiv> "\<lambda> c b1 b2. uu c (b1,b2)"
+  have u[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> A"
+  "\<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"
+  "\<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"
+  using uu unfolding u_def by auto
+  {fix c assume c: "c \<in> supp P"
+   have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify
+     fix b1 b1' b2 b2'
+     assume "{b1, b1'} \<subseteq> set1 c" "{b2, b2'} \<subseteq> set2 c" and 0: "u c b1 b2 = u c b1' b2'"
+     hence "p1 (u c b1 b2) = b1 \<and> p2 (u c b1 b2) = b2 \<and>
+            p1 (u c b1' b2') = b1' \<and> p2 (u c b1' b2') = b2'"
+     using u(2)[OF c] u(3)[OF c] by simp metis
+     thus "b1 = b1' \<and> b2 = b2'" using 0 by auto
+   qed
+  } note inj = this
+  def sset \<equiv> "\<lambda> c. {u c b1 b2 | b1 b2. b1 \<in> set1 c \<and> b2 \<in> set2 c}"
+  have fin_sset[simp]: "\<And> c. c \<in> supp P \<Longrightarrow> finite (sset c)" unfolding sset_def
+  using fin_set1 fin_set2 finite_twosets by blast
+  have sset_A: "\<And> c. c \<in> supp P \<Longrightarrow> sset c \<subseteq> A" unfolding sset_def by auto
+  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
+   then obtain b1 b2 where b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
+   and a: "a = u c b1 b2" unfolding sset_def by auto
+   have "p1 a \<in> set1 c" and p2a: "p2 a \<in> set2 c"
+   using ac a b1 b2 c u(2) u(3) by simp+
+   hence "u c (p1 a) (p2 a) = a" unfolding a using b1 b2 inj[OF c]
+   unfolding inj2_def by (metis c u(2) u(3))
+  } note u_p12[simp] = this
+  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
+   hence "p1 a \<in> set1 c" unfolding sset_def by auto
+  }note p1[simp] = this
+  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
+   hence "p2 a \<in> set2 c" unfolding sset_def by auto
+  }note p2[simp] = this
+  (*  *)
+  {fix c assume c: "c \<in> supp P"
+   hence "\<exists> M. (\<forall> b1 \<in> set1 c. setsum (\<lambda> b2. M (u c b1 b2)) (set2 c) = N1 b1) \<and>
+               (\<forall> b2 \<in> set2 c. setsum (\<lambda> b1. M (u c b1 b2)) (set1 c) = N2 b2)"
+   unfolding sset_def
+   using matrix_count_finite[OF set1_NE[OF c] fin_set1[OF c]
+                                set2_NE[OF c] fin_set2[OF c] inj[OF c] ss[OF c]] by auto
+  }
+  then obtain Ms where
+  ss1: "\<And> c b1. \<lbrakk>c \<in> supp P; b1 \<in> set1 c\<rbrakk> \<Longrightarrow>
+                   setsum (\<lambda> b2. Ms c (u c b1 b2)) (set2 c) = N1 b1" and
+  ss2: "\<And> c b2. \<lbrakk>c \<in> supp P; b2 \<in> set2 c\<rbrakk> \<Longrightarrow>
+                   setsum (\<lambda> b1. Ms c (u c b1 b2)) (set1 c) = N2 b2"
+  by metis
+  def SET \<equiv> "\<Union> c \<in> supp P. sset c"
+  have fin_SET[simp]: "finite SET" unfolding SET_def apply(rule finite_UN_I) by auto
+  have SET_A: "SET \<subseteq> A" unfolding SET_def using sset_A by auto
+  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"
+  unfolding SET_def sset_def by blast
+  {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p1a: "p1 a \<in> set1 c"
+   then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
+   unfolding SET_def by auto
+   hence "p1 a \<in> set1 c'" unfolding sset_def by auto
+   hence eq: "c = c'" using p1a c c' set1_disj by auto
+   hence "a \<in> sset c" using ac' by simp
+  } note p1_rev = this
+  {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p2a: "p2 a \<in> set2 c"
+   then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
+   unfolding SET_def by auto
+   hence "p2 a \<in> set2 c'" unfolding sset_def by auto
+   hence eq: "c = c'" using p2a c c' set2_disj by auto
+   hence "a \<in> sset c" using ac' by simp
+  } note p2_rev = this
+  (*  *)
+  have "\<forall> a \<in> SET. \<exists> c \<in> supp P. a \<in> sset c" unfolding SET_def by auto
+  then obtain h where h: "\<forall> a \<in> SET. h a \<in> supp P \<and> a \<in> sset (h a)" by metis
+  have h_u[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
+                      \<Longrightarrow> h (u c b1 b2) = c"
+  by (metis h p2 set2 u(3) u_SET)
+  have h_u1: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
+                      \<Longrightarrow> h (u c b1 b2) = f1 b1"
+  using h unfolding sset_def by auto
+  have h_u2: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
+                      \<Longrightarrow> h (u c b1 b2) = f2 b2"
+  using h unfolding sset_def by auto
+  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"
+  have sM: "supp M \<subseteq> SET" "supp M \<subseteq> p1 -` (supp N1)" "supp M \<subseteq> p2 -` (supp N2)"
+  unfolding M_def by auto
+  show "\<exists>M. (M \<in> multiset \<and> supp M \<subseteq> A) \<and> mmap p1 M = N1 \<and> mmap p2 M = N2"
+  proof(rule exI[of _ M], safe)
+    show "M \<in> multiset"
+    unfolding multiset_def using finite_subset[OF sM(1) fin_SET] by simp
+  next
+    fix a assume "0 < M a"
+    thus "a \<in> A" unfolding M_def using SET_A by (cases "a \<in> SET") auto
+  next
+    show "mmap p1 M = N1"
+    unfolding mmap_def[abs_def] proof(rule ext)
+      fix b1
+      let ?K = "{a. p1 a = b1 \<and> 0 < M a}"
+      show "setsum M ?K = N1 b1"
+      proof(cases "b1 \<in> supp N1")
+        case False
+        hence "?K = {}" using sM(2) by auto
+        thus ?thesis using False by auto
+      next
+        case True
+        def c \<equiv> "f1 b1"
+        have c: "c \<in> supp P" and b1: "b1 \<in> set1 c"
+        unfolding set1_def c_def P1 using True by (auto simp: mmap_image)
+        have "setsum M ?K = setsum M {a. p1 a = b1 \<and> a \<in> SET}"
+        apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
+        also have "... = setsum M ((\<lambda> b2. u c b1 b2) ` (set2 c))"
+        apply(rule setsum_cong) using c b1 proof safe
+          fix a assume p1a: "p1 a \<in> set1 c" and "0 < P c" and "a \<in> SET"
+          hence ac: "a \<in> sset c" using p1_rev by auto
+          hence "a = u c (p1 a) (p2 a)" using c by auto
+          moreover have "p2 a \<in> set2 c" using ac c by auto
+          ultimately show "a \<in> u c (p1 a) ` set2 c" by auto
+        next
+          fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
+          hence "u c b1 b2 \<in> SET" using c by auto
+        qed auto
+        also have "... = setsum (\<lambda> b2. M (u c b1 b2)) (set2 c)"
+        unfolding comp_def[symmetric] apply(rule setsum_reindex)
+        using inj unfolding inj_on_def inj2_def using b1 c u(3) by blast
+        also have "... = N1 b1" unfolding ss1[OF c b1, symmetric]
+          apply(rule setsum_cong[OF refl]) unfolding M_def
+          using True h_u[OF c b1] set2_def u(2,3)[OF c b1] u_SET[OF c b1] by fastforce
+        finally show ?thesis .
+      qed
+    qed
+  next
+    show "mmap p2 M = N2"
+    unfolding mmap_def[abs_def] proof(rule ext)
+      fix b2
+      let ?K = "{a. p2 a = b2 \<and> 0 < M a}"
+      show "setsum M ?K = N2 b2"
+      proof(cases "b2 \<in> supp N2")
+        case False
+        hence "?K = {}" using sM(3) by auto
+        thus ?thesis using False by auto
+      next
+        case True
+        def c \<equiv> "f2 b2"
+        have c: "c \<in> supp P" and b2: "b2 \<in> set2 c"
+        unfolding set2_def c_def P2 using True by (auto simp: mmap_image)
+        have "setsum M ?K = setsum M {a. p2 a = b2 \<and> a \<in> SET}"
+        apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
+        also have "... = setsum M ((\<lambda> b1. u c b1 b2) ` (set1 c))"
+        apply(rule setsum_cong) using c b2 proof safe
+          fix a assume p2a: "p2 a \<in> set2 c" and "0 < P c" and "a \<in> SET"
+          hence ac: "a \<in> sset c" using p2_rev by auto
+          hence "a = u c (p1 a) (p2 a)" using c by auto
+          moreover have "p1 a \<in> set1 c" using ac c by auto
+          ultimately show "a \<in> (\<lambda>b1. u c b1 (p2 a)) ` set1 c" by auto
+        next
+          fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
+          hence "u c b1 b2 \<in> SET" using c by auto
+        qed auto
+        also have "... = setsum (M o (\<lambda> b1. u c b1 b2)) (set1 c)"
+        apply(rule setsum_reindex)
+        using inj unfolding inj_on_def inj2_def using b2 c u(2) by blast
+        also have "... = setsum (\<lambda> b1. M (u c b1 b2)) (set1 c)"
+        unfolding comp_def[symmetric] by simp
+        also have "... = N2 b2" unfolding ss2[OF c b2, symmetric]
+          apply(rule setsum_cong[OF refl]) unfolding M_def set2_def
+          using True h_u1[OF c _ b2] u(2,3)[OF c _ b2] u_SET[OF c _ b2]
+          unfolding set1_def by fastforce
+        finally show ?thesis .
+      qed
+    qed
+  qed
+qed
+
+definition mset_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
+"mset_map h = Abs_multiset \<circ> mmap h \<circ> count"
+
+bnf_def mset = mset_map [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
+unfolding mset_map_def
+proof -
+  show "Abs_multiset \<circ> mmap id \<circ> count = id" unfolding mmap_id by (auto simp: count_inverse)
+next
+  fix f g
+  show "Abs_multiset \<circ> mmap (g \<circ> f) \<circ> count =
+        Abs_multiset \<circ> mmap g \<circ> count \<circ> (Abs_multiset \<circ> mmap f \<circ> count)"
+  unfolding comp_def apply(rule ext)
+  by (auto simp: Abs_multiset_inverse count mmap_comp1 mmap)
+next
+  fix M f g assume eq: "\<And>a. a \<in> set_of M \<Longrightarrow> f a = g a"
+  thus "(Abs_multiset \<circ> mmap f \<circ> count) M = (Abs_multiset \<circ> mmap g \<circ> count) M" apply auto
+  unfolding cIm_def[abs_def] image_def
+  by (auto intro!: mmap_cong simp: Abs_multiset_inject count mmap)
+next
+  fix f show "set_of \<circ> (Abs_multiset \<circ> mmap f \<circ> count) = op ` f \<circ> set_of"
+  by (auto simp: count mmap mmap_image set_of_Abs_multiset supp_count)
+next
+  show "card_order natLeq" by (rule natLeq_card_order)
+next
+  show "cinfinite natLeq" by (rule natLeq_cinfinite)
+next
+  fix M show "|set_of M| \<le>o natLeq"
+  apply(rule ordLess_imp_ordLeq)
+  unfolding finite_iff_ordLess_natLeq[symmetric] using finite_set_of .
+next
+  fix A :: "'a set"
+  have "|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_set_of .
+  also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
+  by (rule list_in_bd)
+  finally show "|{M. set_of M \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
+next
+  fix A B1 B2 f1 f2 p1 p2
+  let ?map = "\<lambda> f. Abs_multiset \<circ> mmap f \<circ> count"
+  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
+  show "wpull {x. set_of x \<subseteq> A} {x. set_of x \<subseteq> B1} {x. set_of x \<subseteq> B2}
+              (?map f1) (?map f2) (?map p1) (?map p2)"
+  unfolding wpull_def proof safe
+    fix y1 y2
+    assume y1: "set_of y1 \<subseteq> B1" and y2: "set_of y2 \<subseteq> B2"
+    and m: "?map f1 y1 = ?map f2 y2"
+    def N1 \<equiv> "count y1"  def N2 \<equiv> "count y2"
+    have "N1 \<in> multiset \<and> supp N1 \<subseteq> B1" and "N2 \<in> multiset \<and> supp N2 \<subseteq> B2"
+    and "mmap f1 N1 = mmap f2 N2"
+    using y1 y2 m unfolding N1_def N2_def
+    by (auto simp: Abs_multiset_inject count mmap)
+    then obtain M where M: "M \<in> multiset \<and> supp M \<subseteq> A"
+    and N1: "mmap p1 M = N1" and N2: "mmap p2 M = N2"
+    using wp_mmap[OF wp] unfolding wpull_def by auto
+    def x \<equiv> "Abs_multiset M"
+    show "\<exists>x\<in>{x. set_of x \<subseteq> A}. ?map p1 x = y1 \<and> ?map p2 x = y2"
+    apply(intro bexI[of _ x]) using M N1 N2 unfolding N1_def N2_def x_def
+    by (auto simp: count_inverse Abs_multiset_inverse)
+  qed
+qed (unfold set_of_empty, auto)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Codatatype.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,14 @@
+(*  Title:      HOL/Codatatype/Codatatype.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Copyright   2012
+
+The (co)datatype package.
+*)
+
+header {* The (Co)datatype Package *}
+
+theory Codatatype
+imports BNF_LFP BNF_GFP
+begin
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Countable_Set.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,328 @@
+(*  Title:      HOL/Codatatype/Countable_Set.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+(At most) countable sets.
+*)
+
+header {* (At Most) Countable Sets *}
+
+theory Countable_Set
+imports "../Ordinals_and_Cardinals_Base/Cardinal_Arithmetic"
+        "~~/src/HOL/Library/Countable"
+begin
+
+
+subsection{* Basics  *}
+
+definition "countable A \<equiv> |A| \<le>o natLeq"
+
+lemma countable_card_of_nat:
+"countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
+unfolding countable_def using card_of_nat
+using ordLeq_ordIso_trans ordIso_symmetric by blast
+
+lemma countable_ex_to_nat:
+fixes A :: "'a set"
+shows "countable A \<longleftrightarrow> (\<exists> f::'a\<Rightarrow>nat. inj_on f A)"
+unfolding countable_card_of_nat card_of_ordLeq[symmetric] by auto
+
+lemma countable_or_card_of:
+assumes "countable A"
+shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
+       (infinite A  \<and> |A| =o |UNIV::nat set| )"
+apply (cases "finite A")
+  apply(metis finite_iff_cardOf_nat)
+  by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
+
+lemma countable_or:
+assumes "countable A"
+shows "(\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or>
+       (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
+using countable_or_card_of[OF assms]
+by (metis assms card_of_ordIso countable_ex_to_nat)
+
+lemma countable_cases_card_of[elim, consumes 1, case_names Fin Inf]:
+assumes "countable A"
+and "\<lbrakk>finite A; |A| <o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
+and "\<lbrakk>infinite A; |A| =o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
+shows phi
+using assms countable_or_card_of by blast
+
+lemma countable_cases[elim, consumes 1, case_names Fin Inf]:
+assumes "countable A"
+and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>finite A; inj_on f A\<rbrakk> \<Longrightarrow> phi"
+and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>infinite A; bij_betw f A UNIV\<rbrakk> \<Longrightarrow> phi"
+shows phi
+using assms countable_or by metis
+
+definition toNat_pred :: "'a set \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> bool"
+where
+"toNat_pred (A::'a set) f \<equiv>
+ (finite A \<and> inj_on f A) \<or> (infinite A \<and> bij_betw f A UNIV)"
+definition toNat where "toNat A \<equiv> SOME f. toNat_pred A f"
+
+lemma toNat_pred:
+assumes "countable A"
+shows "\<exists> f. toNat_pred A f"
+using assms countable_ex_to_nat toNat_pred_def by (cases rule: countable_cases) auto
+
+lemma toNat_pred_toNat:
+assumes "countable A"
+shows "toNat_pred A (toNat A)"
+unfolding toNat_def apply(rule someI_ex[of "toNat_pred A"])
+using toNat_pred[OF assms] .
+
+lemma bij_betw_toNat:
+assumes c: "countable A" and i: "infinite A"
+shows "bij_betw (toNat A) A (UNIV::nat set)"
+using toNat_pred_toNat[OF c] unfolding toNat_pred_def using i by auto
+
+lemma inj_on_toNat:
+assumes c: "countable A"
+shows "inj_on (toNat A) A"
+using c apply(cases rule: countable_cases)
+using bij_betw_toNat[OF c] toNat_pred_toNat[OF c]
+unfolding toNat_pred_def unfolding bij_betw_def by auto
+
+lemma toNat_inj[simp]:
+assumes c: "countable A" and a: "a \<in> A" and b: "b \<in> A"
+shows "toNat A a = toNat A b \<longleftrightarrow> a = b"
+using inj_on_toNat[OF c] using a b unfolding inj_on_def by auto
+
+lemma image_toNat:
+assumes c: "countable A" and i: "infinite A"
+shows "toNat A ` A = UNIV"
+using bij_betw_toNat[OF assms] unfolding bij_betw_def by simp
+
+lemma toNat_surj:
+assumes "countable A" and i: "infinite A"
+shows "\<exists> a. a \<in> A \<and> toNat A a = n"
+using image_toNat[OF assms]
+by (metis (no_types) image_iff iso_tuple_UNIV_I)
+
+definition
+"fromNat A n \<equiv>
+ if n \<in> toNat A ` A then inv_into A (toNat A) n
+ else (SOME a. a \<in> A)"
+
+lemma fromNat:
+assumes "A \<noteq> {}"
+shows "fromNat A n \<in> A"
+unfolding fromNat_def by (metis assms equals0I inv_into_into someI_ex)
+
+lemma toNat_fromNat[simp]:
+assumes "n \<in> toNat A ` A"
+shows "toNat A (fromNat A n) = n"
+by (metis assms f_inv_into_f fromNat_def)
+
+lemma infinite_toNat_fromNat[simp]:
+assumes c: "countable A" and i: "infinite A"
+shows "toNat A (fromNat A n) = n"
+apply(rule toNat_fromNat) using toNat_surj[OF assms]
+by (metis image_iff)
+
+lemma fromNat_toNat[simp]:
+assumes c: "countable A" and a: "a \<in> A"
+shows "fromNat A (toNat A a) = a"
+by (metis a c equals0D fromNat imageI toNat_fromNat toNat_inj)
+
+lemma fromNat_inj:
+assumes c: "countable A" and i: "infinite A"
+shows "fromNat A m = fromNat A n \<longleftrightarrow> m = n" (is "?L = ?R \<longleftrightarrow> ?K")
+proof-
+  have "?L = ?R \<longleftrightarrow> toNat A ?L = toNat A ?R"
+  unfolding toNat_inj[OF c fromNat[OF infinite_imp_nonempty[OF i]]
+                           fromNat[OF infinite_imp_nonempty[OF i]]] ..
+  also have "... \<longleftrightarrow> ?K" using c i by simp
+  finally show ?thesis .
+qed
+
+lemma fromNat_surj:
+assumes c: "countable A" and a: "a \<in> A"
+shows "\<exists> n. fromNat A n = a"
+apply(rule exI[of _ "toNat A a"]) using assms by simp
+
+lemma fromNat_image_incl:
+assumes "A \<noteq> {}"
+shows "fromNat A ` UNIV \<subseteq> A"
+using fromNat[OF assms] by auto
+
+lemma incl_fromNat_image:
+assumes "countable A"
+shows "A \<subseteq> fromNat A ` UNIV"
+unfolding image_def using fromNat_surj[OF assms] by auto
+
+lemma fromNat_image[simp]:
+assumes "A \<noteq> {}" and "countable A"
+shows "fromNat A ` UNIV = A"
+by (metis assms equalityI fromNat_image_incl incl_fromNat_image)
+
+lemma fromNat_inject[simp]:
+assumes A: "A \<noteq> {}" "countable A" and B: "B \<noteq> {}" "countable B"
+shows "fromNat A = fromNat B \<longleftrightarrow> A = B"
+by (metis assms fromNat_image)
+
+lemma inj_on_fromNat:
+"inj_on fromNat ({A. A \<noteq> {} \<and> countable A})"
+unfolding inj_on_def by auto
+
+
+subsection {* Preservation under the set theoretic operations *}
+
+lemma contable_empty[simp,intro]:
+"countable {}"
+by (metis countable_ex_to_nat inj_on_empty)
+
+lemma incl_countable:
+assumes "A \<subseteq> B" and "countable B"
+shows "countable A"
+by (metis assms countable_ex_to_nat subset_inj_on)
+
+lemma countable_diff:
+assumes "countable A"
+shows "countable (A - B)"
+by (metis Diff_subset assms incl_countable)
+
+lemma finite_countable[simp]:
+assumes "finite A"
+shows "countable A"
+by (metis assms countable_ex_to_nat finite_imp_inj_to_nat_seg)
+
+lemma countable_singl[simp]:
+"countable {a}"
+by simp
+
+lemma countable_insert[simp]:
+"countable (insert a A) \<longleftrightarrow> countable A"
+proof
+  assume c: "countable A"
+  thus "countable (insert a A)"
+  apply (cases rule: countable_cases_card_of)
+    apply (metis finite_countable finite_insert)
+    unfolding countable_card_of_nat
+    by (metis infinite_card_of_insert ordIso_imp_ordLeq ordIso_transitive)
+qed(insert incl_countable, metis incl_countable subset_insertI)
+
+lemma contable_IntL[simp]:
+assumes "countable A"
+shows "countable (A \<inter> B)"
+by (metis Int_lower1 assms incl_countable)
+
+lemma contable_IntR[simp]:
+assumes "countable B"
+shows "countable (A \<inter> B)"
+by (metis assms contable_IntL inf.commute)
+
+lemma countable_UN[simp]:
+assumes cI: "countable I" and cA: "\<And> i. i \<in> I \<Longrightarrow> countable (A i)"
+shows "countable (\<Union> i \<in> I. A i)"
+using assms unfolding countable_card_of_nat
+apply(intro card_of_UNION_ordLeq_infinite) by auto
+
+lemma contable_Un[simp]:
+"countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
+proof safe
+  assume cA: "countable A" and cB: "countable B"
+  let ?I = "{0,Suc 0}"  let ?As = "\<lambda> i. case i of 0 \<Rightarrow> A|Suc 0 \<Rightarrow> B"
+  have AB: "A \<union> B = (\<Union> i \<in> ?I. ?As i)" by simp
+  show "countable (A \<union> B)" unfolding AB apply(rule countable_UN)
+  using cA cB by auto
+qed (metis Un_upper1 incl_countable, metis Un_upper2 incl_countable)
+
+lemma countable_INT[simp]:
+assumes "i \<in> I" and "countable (A i)"
+shows "countable (\<Inter> i \<in> I. A i)"
+by (metis INF_insert assms contable_IntL insert_absorb)
+
+lemma countable_class[simp]:
+fixes A :: "('a::countable) set"
+shows "countable A"
+proof-
+  have "inj_on to_nat A" by (metis inj_on_to_nat)
+  thus ?thesis by (metis countable_ex_to_nat)
+qed
+
+lemma countable_image[simp]:
+assumes "countable A"
+shows "countable (f ` A)"
+using assms unfolding countable_card_of_nat
+by (metis card_of_image ordLeq_transitive)
+
+lemma countable_ordLeq:
+assumes "|A| \<le>o |B|" and "countable B"
+shows "countable A"
+using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
+
+lemma countable_ordLess:
+assumes AB: "|A| <o |B|" and B: "countable B"
+shows "countable A"
+using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
+
+lemma countable_vimage:
+assumes "B \<subseteq> range f" and "countable (f -` B)"
+shows "countable B"
+by (metis Int_absorb2 assms countable_image image_vimage_eq)
+
+lemma surj_countable_vimage:
+assumes s: "surj f" and c: "countable (f -` B)"
+shows "countable B"
+apply(rule countable_vimage[OF _ c]) using s by auto
+
+lemma countable_Collect[simp]:
+assumes "countable A"
+shows "countable {a \<in> A. \<phi> a}"
+by (metis Collect_conj_eq Int_absorb Int_commute Int_def assms contable_IntR)
+
+
+subsection{*  The type of countable sets *}
+
+typedef (open) 'a cset = "{A :: 'a set. countable A}"
+apply(rule exI[of _ "{}"]) by simp
+
+abbreviation rcset where "rcset \<equiv> Rep_cset"
+abbreviation acset where "acset \<equiv> Abs_cset"
+
+lemmas acset_rcset = Rep_cset_inverse
+declare acset_rcset[simp]
+
+lemma acset_surj:
+"\<exists> A. countable A \<and> acset A = C"
+apply(cases rule: Abs_cset_cases[of C]) by auto
+
+lemma rcset_acset[simp]:
+assumes "countable A"
+shows "rcset (acset A) = A"
+using Abs_cset_inverse assms by auto
+
+lemma acset_inj[simp]:
+assumes "countable A" and "countable B"
+shows "acset A = acset B \<longleftrightarrow> A = B"
+using assms Abs_cset_inject by auto
+
+lemma rcset[simp]:
+"countable (rcset C)"
+using Rep_cset by simp
+
+lemma rcset_inj[simp]:
+"rcset C = rcset D \<longleftrightarrow> C = D"
+by (metis acset_rcset)
+
+lemma rcset_surj:
+assumes "countable A"
+shows "\<exists> C. rcset C = A"
+apply(cases rule: Rep_cset_cases[of A])
+using assms by auto
+
+definition "cIn a C \<equiv> (a \<in> rcset C)"
+definition "cEmp \<equiv> acset {}"
+definition "cIns a C \<equiv> acset (insert a (rcset C))"
+abbreviation cSingl where "cSingl a \<equiv> cIns a cEmp"
+definition "cUn C D \<equiv> acset (rcset C \<union> rcset D)"
+definition "cInt C D \<equiv> acset (rcset C \<inter> rcset D)"
+definition "cDif C D \<equiv> acset (rcset C - rcset D)"
+definition "cIm f C \<equiv> acset (f ` rcset C)"
+definition "cVim f D \<equiv> acset (f -` rcset D)"
+(* TODO eventually: nice setup for these operations, copied from the set setup *)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Equiv_Relations_More.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,161 @@
+(*  Title:      HOL/Codatatype/Equiv_Relations_More.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Some preliminaries on equivalence relations and quotients.
+*)
+
+header {* Some Preliminaries on Equivalence Relations and Quotients *}
+
+theory Equiv_Relations_More
+imports Equiv_Relations Hilbert_Choice
+begin
+
+
+(* Recall the following constants and lemmas:
+
+term Eps
+term "A//r"
+lemmas equiv_def
+lemmas refl_on_def
+ -- note that "reflexivity on" also assumes inclusion of the relation's field into r
+
+*)
+
+definition proj where "proj r x = r `` {x}"
+
+definition univ where "univ f X == f (Eps (%x. x \<in> X))"
+
+lemma proj_preserves:
+"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
+unfolding proj_def by (rule quotientI)
+
+lemma proj_in_iff:
+assumes "equiv A r"
+shows "(proj r x \<in> A//r) = (x \<in> A)"
+apply(rule iffI, auto simp add: proj_preserves)
+unfolding proj_def quotient_def proof clarsimp
+  fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
+  moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by blast
+  ultimately have "(x,y) \<in> r" by blast
+  thus "x \<in> A" using assms unfolding equiv_def refl_on_def by blast
+qed
+
+lemma proj_iff:
+"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
+by (simp add: proj_def eq_equiv_class_iff)
+
+(*
+lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
+unfolding proj_def equiv_def refl_on_def by blast
+*)
+
+lemma proj_image: "(proj r) ` A = A//r"
+unfolding proj_def[abs_def] quotient_def by blast
+
+lemma in_quotient_imp_non_empty:
+"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<noteq> {}"
+unfolding quotient_def using equiv_class_self by fast
+
+lemma in_quotient_imp_in_rel:
+"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
+using quotient_eq_iff by fastforce
+
+lemma in_quotient_imp_closed:
+"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
+unfolding quotient_def equiv_def trans_def by blast
+
+lemma in_quotient_imp_subset:
+"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
+using assms in_quotient_imp_in_rel equiv_type by fastforce
+
+lemma equiv_Eps_in:
+"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
+apply (rule someI2_ex)
+using in_quotient_imp_non_empty by blast
+
+lemma equiv_Eps_preserves:
+assumes ECH: "equiv A r" and X: "X \<in> A//r"
+shows "Eps (%x. x \<in> X) \<in> A"
+apply (rule in_mono[rule_format])
+ using assms apply (rule in_quotient_imp_subset)
+by (rule equiv_Eps_in) (rule assms)+
+
+lemma proj_Eps:
+assumes "equiv A r" and "X \<in> A//r"
+shows "proj r (Eps (%x. x \<in> X)) = X"
+unfolding proj_def proof auto
+  fix x assume x: "x \<in> X"
+  thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
+next
+  fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
+  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
+qed
+
+(*
+lemma Eps_proj:
+assumes "equiv A r" and "x \<in> A"
+shows "(Eps (%y. y \<in> proj r x), x) \<in> r"
+proof-
+  have 1: "proj r x \<in> A//r" using assms proj_preserves by fastforce
+  hence "Eps(%y. y \<in> proj r x) \<in> proj r x" using assms equiv_Eps_in by auto
+  moreover have "x \<in> proj r x" using assms in_proj by fastforce
+  ultimately show ?thesis using assms 1 in_quotient_imp_in_rel by fastforce
+qed
+
+lemma equiv_Eps_iff:
+assumes "equiv A r" and "{X,Y} \<subseteq> A//r"
+shows "((Eps (%x. x \<in> X),Eps (%y. y \<in> Y)) \<in> r) = (X = Y)"
+proof-
+  have "Eps (%x. x \<in> X) \<in> X \<and> Eps (%y. y \<in> Y) \<in> Y" using assms equiv_Eps_in by auto
+  thus ?thesis using assms quotient_eq_iff by fastforce
+qed
+
+lemma equiv_Eps_inj_on:
+assumes "equiv A r"
+shows "inj_on (%X. Eps (%x. x \<in> X)) (A//r)"
+unfolding inj_on_def proof clarify
+  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)"
+  hence "Eps (%x. x \<in> X) \<in> A" using assms equiv_Eps_preserves by auto
+  hence "(Eps (%x. x \<in> X), Eps (%y. y \<in> Y)) \<in> r"
+  using assms Eps unfolding quotient_def equiv_def refl_on_def by auto
+  thus "X= Y" using X Y assms equiv_Eps_iff by auto
+qed
+*)
+
+lemma univ_commute:
+assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
+shows "(univ f) (proj r x) = f x"
+unfolding univ_def proof -
+  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
+  hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
+  moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
+  ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
+  thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
+qed
+
+(*
+lemma univ_unique:
+assumes ECH: "equiv A r" and
+        RES: "f respects r" and  COM: "\<forall> x \<in> A. G (proj r x) = f x"
+shows "\<forall> X \<in> A//r. G X = univ f X"
+proof
+  fix X assume "X \<in> A//r"
+  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
+  have "G X = f x" unfolding X using x COM by simp
+  thus "G X = univ f X" unfolding X using ECH RES x univ_commute by fastforce
+qed
+*)
+
+lemma univ_preserves:
+assumes ECH: "equiv A r" and RES: "f respects r" and
+        PRES: "\<forall> x \<in> A. f x \<in> B"
+shows "\<forall> X \<in> A//r. univ f X \<in> B"
+proof
+  fix X assume "X \<in> A//r"
+  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
+  hence "univ f X = f x" using assms univ_commute by fastforce
+  thus "univ f X \<in> B" using x PRES by simp
+qed
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/HFset.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,60 @@
+(*  Title:      Codatatype_Examples/HFset.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Hereditary sets.
+*)
+
+header {* Hereditary Sets *}
+
+theory HFset
+imports "../Codatatype/Codatatype"
+begin
+
+
+section {* Datatype definition *}
+
+bnf_data hfset: 'hfset = "'hfset fset"
+
+
+section {* Customization of terms *}
+
+subsection{* Constructors *}
+
+definition "Fold hs \<equiv> hfset_fld hs"
+
+lemma hfset_simps[simp]:
+"\<And>hs1 hs2. Fold hs1 = Fold hs2 \<longrightarrow> hs1 = hs2"
+unfolding Fold_def hfset.fld_inject by auto
+
+theorem hfset_cases[elim, case_names Fold]:
+assumes Fold: "\<And> hs. h = Fold hs \<Longrightarrow> phi"
+shows phi
+using Fold unfolding Fold_def
+by (cases rule: hfset.fld_exhaust[of h]) simp
+
+lemma hfset_induct[case_names Fold, induct type: hfset]:
+assumes Fold: "\<And> hs. (\<And> h. h |\<in>| hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
+shows "phi t"
+apply (induct rule: hfset.fld_induct)
+using Fold unfolding Fold_def fset_fset_member mem_Collect_eq ..
+
+(* alternative induction principle, using fset: *)
+lemma hfset_induct_fset[case_names Fold, induct type: hfset]:
+assumes Fold: "\<And> hs. (\<And> h. h \<in> fset hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
+shows "phi t"
+apply (induct rule: hfset_induct)
+using Fold by (metis notin_fset)
+
+subsection{* Recursion and iteration *}
+
+lemma hfset_rec:
+"hfset_rec R (Fold hs) = R (map_fset <id, hfset_rec R> hs)"
+using hfset.rec unfolding Fold_def .
+
+(* The iterator has a simpler form: *)
+lemma hfset_iter:
+"hfset_iter R (Fold hs) = R (map_fset (hfset_iter R) hs)"
+using hfset.iter unfolding Fold_def .
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Gram_Lang.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,1366 @@
+(*  Title:      Gram_Lang.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Language of a grammar.
+*)
+
+header {* Language of a Grammar *}
+
+theory Gram_Lang
+imports Tree
+begin 
+
+
+consts P :: "(N \<times> (T + N) set) set"
+axiomatization where 
+    finite_N: "finite (UNIV::N set)"
+and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
+and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
+
+
+subsection{* Tree basics: frontier, interior, etc. *}
+
+lemma Tree_cong: 
+assumes "root tr = root tr'" and "cont tr = cont tr'"
+shows "tr = tr'"
+by (metis Node_root_cont assms)
+
+inductive finiteT where 
+Node: "\<lbrakk>finite as; (finiteT^#) as\<rbrakk> \<Longrightarrow> finiteT (Node a as)"
+monos lift_mono
+
+lemma finiteT_induct[consumes 1, case_names Node, induct pred: finiteT]:
+assumes 1: "finiteT tr"
+and IH: "\<And>as n. \<lbrakk>finite as; (\<phi>^#) as\<rbrakk> \<Longrightarrow> \<phi> (Node n as)"
+shows "\<phi> tr"
+using 1 apply(induct rule: finiteT.induct)
+apply(rule IH) apply assumption apply(elim mono_lift) by simp
+
+
+(* Frontier *)
+
+inductive inFr :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where 
+Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
+|
+Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
+
+definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
+
+lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
+by (metis inFr.simps)
+
+lemma inFr_mono: 
+assumes "inFr ns tr t" and "ns \<subseteq> ns'"
+shows "inFr ns' tr t"
+using assms apply(induct arbitrary: ns' rule: inFr.induct)
+using Base Ind by (metis inFr.simps set_mp)+
+
+lemma inFr_Ind_minus: 
+assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
+shows "inFr (insert (root tr) ns1) tr t"
+using assms apply(induct rule: inFr.induct)
+  apply (metis inFr.simps insert_iff)
+  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
+
+(* alternative definition *)
+inductive inFr2 :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where 
+Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
+|
+Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk> 
+      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
+
+lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
+apply(induct rule: inFr2.induct) by auto
+
+lemma inFr2_mono: 
+assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
+shows "inFr2 ns' tr t"
+using assms apply(induct arbitrary: ns' rule: inFr2.induct)
+using Base Ind
+apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset) 
+
+lemma inFr2_Ind:
+assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr" 
+shows "inFr2 ns tr t"
+using assms apply(induct rule: inFr2.induct)
+  apply (metis inFr2.simps insert_absorb)
+  by (metis inFr2.simps insert_absorb)  
+
+lemma inFr_inFr2:
+"inFr = inFr2"
+apply (rule ext)+  apply(safe)
+  apply(erule inFr.induct)
+    apply (metis (lifting) inFr2.Base)
+    apply (metis (lifting) inFr2_Ind) 
+  apply(erule inFr2.induct)
+    apply (metis (lifting) inFr.Base)
+    apply (metis (lifting) inFr_Ind_minus)
+done  
+
+lemma not_root_inFr:
+assumes "root tr \<notin> ns"
+shows "\<not> inFr ns tr t"
+by (metis assms inFr_root_in)
+
+theorem not_root_Fr:
+assumes "root tr \<notin> ns"
+shows "Fr ns tr = {}"
+using not_root_inFr[OF assms] unfolding Fr_def by auto 
+
+
+(* Interior *)
+
+inductive inItr :: "N set \<Rightarrow> Tree \<Rightarrow> N \<Rightarrow> bool" where 
+Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
+|
+Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
+
+definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
+
+lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
+by (metis inItr.simps) 
+
+lemma inItr_mono: 
+assumes "inItr ns tr n" and "ns \<subseteq> ns'"
+shows "inItr ns' tr n"
+using assms apply(induct arbitrary: ns' rule: inItr.induct)
+using Base Ind by (metis inItr.simps set_mp)+
+
+
+(* The subtree relation *)  
+
+inductive subtr where 
+Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
+|
+Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
+
+lemma subtr_rootL_in: 
+assumes "subtr ns tr1 tr2"
+shows "root tr1 \<in> ns"
+using assms apply(induct rule: subtr.induct) by auto
+
+lemma subtr_rootR_in: 
+assumes "subtr ns tr1 tr2"
+shows "root tr2 \<in> ns"
+using assms apply(induct rule: subtr.induct) by auto
+
+lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
+
+lemma subtr_mono: 
+assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
+shows "subtr ns' tr1 tr2"
+using assms apply(induct arbitrary: ns' rule: subtr.induct)
+using Refl Step by (metis subtr.simps set_mp)+
+
+lemma subtr_trans_Un:
+assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
+shows "subtr (ns12 \<union> ns23) tr1 tr3"
+proof-
+  have "subtr ns23 tr2 tr3  \<Longrightarrow> 
+        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
+  apply(induct  rule: subtr.induct, safe)
+    apply (metis subtr_mono sup_commute sup_ge2)
+    by (metis (lifting) Step UnI2) 
+  thus ?thesis using assms by auto
+qed
+
+lemma subtr_trans:
+assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
+shows "subtr ns tr1 tr3"
+using subtr_trans_Un[OF assms] by simp
+
+lemma subtr_StepL: 
+assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
+shows "subtr ns tr1 tr3"
+apply(rule subtr_trans[OF _ s]) apply(rule Step[of tr2 ns tr1 tr1])
+by (metis assms subtr_rootL_in Refl)+
+
+(* alternative definition: *)
+inductive subtr2 where 
+Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
+|
+Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
+
+lemma subtr2_rootL_in: 
+assumes "subtr2 ns tr1 tr2"
+shows "root tr1 \<in> ns"
+using assms apply(induct rule: subtr2.induct) by auto
+
+lemma subtr2_rootR_in: 
+assumes "subtr2 ns tr1 tr2"
+shows "root tr2 \<in> ns"
+using assms apply(induct rule: subtr2.induct) by auto
+
+lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
+
+lemma subtr2_mono: 
+assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
+shows "subtr2 ns' tr1 tr2"
+using assms apply(induct arbitrary: ns' rule: subtr2.induct)
+using Refl Step by (metis subtr2.simps set_mp)+
+
+lemma subtr2_trans_Un:
+assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
+shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
+proof-
+  have "subtr2 ns12 tr1 tr2  \<Longrightarrow> 
+        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
+  apply(induct  rule: subtr2.induct, safe)
+    apply (metis subtr2_mono sup_commute sup_ge2)
+    by (metis Un_iff subtr2.simps)
+  thus ?thesis using assms by auto
+qed
+
+lemma subtr2_trans:
+assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
+shows "subtr2 ns tr1 tr3"
+using subtr2_trans_Un[OF assms] by simp
+
+lemma subtr2_StepR: 
+assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
+shows "subtr2 ns tr1 tr3"
+apply(rule subtr2_trans[OF s]) apply(rule Step[of _ _ tr3])
+by (metis assms subtr2_rootR_in Refl)+
+
+lemma subtr_subtr2:
+"subtr = subtr2"
+apply (rule ext)+  apply(safe)
+  apply(erule subtr.induct)
+    apply (metis (lifting) subtr2.Refl)
+    apply (metis (lifting) subtr2_StepR) 
+  apply(erule subtr2.induct)
+    apply (metis (lifting) subtr.Refl)
+    apply (metis (lifting) subtr_StepL)
+done
+
+lemma subtr_inductL[consumes 1, case_names Refl Step]:
+assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
+and Step: 
+"\<And>ns tr1 tr2 tr3. 
+   \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
+shows "\<phi> ns tr1 tr2"
+using s unfolding subtr_subtr2 apply(rule subtr2.induct)
+using Refl Step unfolding subtr_subtr2 by auto
+
+lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
+assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
+and Step: 
+"\<And>tr1 tr2 tr3. 
+   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
+shows "\<phi> tr1 tr2"
+using s apply(induct rule: subtr_inductL)
+apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
+
+(* Subtree versus frontier: *)
+lemma subtr_inFr:
+assumes "inFr ns tr t" and "subtr ns tr tr1" 
+shows "inFr ns tr1 t"
+proof-
+  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
+  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
+  thus ?thesis using assms by auto
+qed
+
+corollary Fr_subtr: 
+"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
+unfolding Fr_def proof safe
+  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)  
+  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
+  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
+qed(metis subtr_inFr)
+
+lemma inFr_subtr:
+assumes "inFr ns tr t" 
+shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
+using assms apply(induct rule: inFr.induct) apply safe
+  apply (metis subtr.Refl)
+  by (metis (lifting) subtr.Step)
+
+corollary Fr_subtr_cont: 
+"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
+unfolding Fr_def
+apply safe
+apply (frule inFr_subtr)
+apply auto
+by (metis inFr.Base subtr_inFr subtr_rootL_in)
+
+(* Subtree versus interior: *)
+lemma subtr_inItr:
+assumes "inItr ns tr n" and "subtr ns tr tr1" 
+shows "inItr ns tr1 n"
+proof-
+  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
+  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
+  thus ?thesis using assms by auto
+qed
+
+corollary Itr_subtr: 
+"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
+unfolding Itr_def apply safe
+apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
+by (metis subtr_inItr)
+
+lemma inItr_subtr:
+assumes "inItr ns tr n" 
+shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
+using assms apply(induct rule: inItr.induct) apply safe
+  apply (metis subtr.Refl)
+  by (metis (lifting) subtr.Step)
+
+corollary Itr_subtr_cont: 
+"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
+unfolding Itr_def apply safe
+  apply (metis (lifting, mono_tags) UnionI inItr_subtr mem_Collect_eq vimageI2)
+  by (metis inItr.Base subtr_inItr subtr_rootL_in)
+
+
+subsection{* The immediate subtree function *}
+
+(* production of: *)
+abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
+(* subtree of: *)
+definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
+
+lemma subtrOf: 
+assumes n: "Inr n \<in> prodOf tr"
+shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
+proof-
+  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
+  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
+  thus ?thesis unfolding subtrOf_def by(rule someI)
+qed
+
+lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
+lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
+
+lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
+proof safe
+  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
+  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
+next
+  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
+  by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
+qed
+
+lemma root_prodOf:
+assumes "Inr tr' \<in> cont tr"
+shows "Inr (root tr') \<in> prodOf tr"
+by (metis (lifting) assms image_iff sum_map.simps(2))
+
+
+subsection{* Derivation trees *}  
+
+coinductive dtree where 
+Tree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
+        lift dtree (cont tr)\<rbrakk> \<Longrightarrow> dtree tr"
+monos lift_mono
+
+(* destruction rules: *)
+lemma dtree_P: 
+assumes "dtree tr"
+shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
+using assms unfolding dtree.simps by auto
+
+lemma dtree_inj_on: 
+assumes "dtree tr"
+shows "inj_on root (Inr -` cont tr)"
+using assms unfolding dtree.simps by auto
+
+lemma dtree_inj[simp]: 
+assumes "dtree tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
+shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
+using assms dtree_inj_on unfolding inj_on_def by auto
+
+lemma dtree_lift: 
+assumes "dtree tr"
+shows "lift dtree (cont tr)"
+using assms unfolding dtree.simps by auto
+
+
+(* coinduction:*)
+lemma dtree_coind[elim, consumes 1, case_names Hyp]: 
+assumes phi: "\<phi> tr"
+and Hyp: 
+"\<And> tr. \<phi> tr \<Longrightarrow> 
+       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and> 
+       inj_on root (Inr -` cont tr) \<and> 
+       lift (\<lambda> tr. \<phi> tr \<or> dtree tr) (cont tr)"
+shows "dtree tr"
+apply(rule dtree.coinduct[of \<phi> tr, OF phi]) 
+using Hyp by blast
+
+lemma dtree_raw_coind[elim, consumes 1, case_names Hyp]: 
+assumes phi: "\<phi> tr"
+and Hyp: 
+"\<And> tr. \<phi> tr \<Longrightarrow> 
+       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
+       inj_on root (Inr -` cont tr) \<and> 
+       lift \<phi> (cont tr)"
+shows "dtree tr"
+using phi apply(induct rule: dtree_coind)
+using Hyp mono_lift 
+by (metis (mono_tags) mono_lift)
+
+lemma dtree_subtr_inj_on: 
+assumes d: "dtree tr1" and s: "subtr ns tr tr1"
+shows "inj_on root (Inr -` cont tr)"
+using s d apply(induct rule: subtr.induct)
+apply (metis (lifting) dtree_inj_on) by (metis dtree_lift lift_def)
+
+lemma dtree_subtr_P: 
+assumes d: "dtree tr1" and s: "subtr ns tr tr1"
+shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
+using s d apply(induct rule: subtr.induct)
+apply (metis (lifting) dtree_P) by (metis dtree_lift lift_def)
+
+lemma subtrOf_root[simp]:
+assumes tr: "dtree tr" and cont: "Inr tr' \<in> cont tr"
+shows "subtrOf tr (root tr') = tr'"
+proof-
+  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
+  by (metis (lifting) cont root_prodOf)
+  have "root (subtrOf tr (root tr')) = root tr'"
+  using root_subtrOf by (metis (lifting) cont root_prodOf)
+  thus ?thesis unfolding dtree_inj[OF tr 0 cont] .
+qed
+
+lemma surj_subtrOf: 
+assumes "dtree tr" and 0: "Inr tr' \<in> cont tr"
+shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
+apply(rule exI[of _ "root tr'"]) 
+using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
+
+lemma dtree_subtr: 
+assumes "dtree tr1" and "subtr ns tr tr1"
+shows "dtree tr" 
+proof-
+  have "(\<exists> ns tr1. dtree tr1 \<and> subtr ns tr tr1) \<Longrightarrow> dtree tr"
+  proof (induct rule: dtree_raw_coind)
+    case (Hyp tr)
+    then obtain ns tr1 where tr1: "dtree tr1" and tr_tr1: "subtr ns tr tr1" by auto
+    show ?case unfolding lift_def proof safe
+      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using dtree_subtr_P[OF tr1 tr_tr1] .
+    next 
+      show "inj_on root (Inr -` cont tr)" using dtree_subtr_inj_on[OF tr1 tr_tr1] .
+    next
+      fix tr' assume tr': "Inr tr' \<in> cont tr"
+      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
+      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
+      thus "\<exists>ns' tr1. dtree tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
+    qed
+  qed
+  thus ?thesis using assms by auto
+qed
+
+
+subsection{* Default trees *}
+
+(* Pick a left-hand side of a production for each nonterminal *)
+definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
+
+lemma S_P: "(n, S n) \<in> P"
+using used unfolding S_def by(rule someI_ex)
+
+lemma finite_S: "finite (S n)"
+using S_P finite_in_P by auto 
+
+
+(* The default tree of a nonterminal *)
+definition deftr :: "N \<Rightarrow> Tree" where  
+"deftr \<equiv> coit id S"
+
+lemma deftr_simps[simp]:
+"root (deftr n) = n" 
+"cont (deftr n) = image (id \<oplus> deftr) (S n)"
+using coit(1)[of id S n] coit(2)[of S n id, OF finite_S] 
+unfolding deftr_def by simp_all
+
+lemmas root_deftr = deftr_simps(1)
+lemmas cont_deftr = deftr_simps(2)
+
+lemma root_o_deftr[simp]: "root o deftr = id"
+by (rule ext, auto)
+
+lemma dtree_deftr: "dtree (deftr n)"
+proof-
+  {fix tr assume "\<exists> n. tr = deftr n" hence "dtree tr"
+   apply(induct rule: dtree_raw_coind) apply safe
+   unfolding deftr_simps image_compose[symmetric] sum_map.comp id_o
+   root_o_deftr sum_map.id image_id id_apply apply(rule S_P) 
+   unfolding inj_on_def lift_def by auto   
+  }
+  thus ?thesis by auto
+qed
+
+
+subsection{* Hereditary substitution *}
+
+(* Auxiliary concept: The root-ommiting frontier: *)
+definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
+definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
+
+context 
+fixes tr0 :: Tree 
+begin
+
+definition "hsubst_r tr \<equiv> root tr"
+definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
+
+(* Hereditary substitution: *)
+definition hsubst :: "Tree \<Rightarrow> Tree" where  
+"hsubst \<equiv> coit hsubst_r hsubst_c"
+
+lemma finite_hsubst_c: "finite (hsubst_c n)"
+unfolding hsubst_c_def by (metis finite_cont) 
+
+lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
+using coit(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
+
+lemma root_o_subst[simp]: "root o hsubst = root"
+unfolding comp_def root_hsubst ..
+
+lemma cont_hsubst_eq[simp]:
+assumes "root tr = root tr0"
+shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
+apply(subst id_o[symmetric, of id]) unfolding id_o
+using coit(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c] 
+unfolding hsubst_def hsubst_c_def using assms by simp
+
+lemma hsubst_eq:
+assumes "root tr = root tr0"
+shows "hsubst tr = hsubst tr0" 
+apply(rule Tree_cong) using assms cont_hsubst_eq by auto
+
+lemma cont_hsubst_neq[simp]:
+assumes "root tr \<noteq> root tr0"
+shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
+apply(subst id_o[symmetric, of id]) unfolding id_o
+using coit(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c] 
+unfolding hsubst_def hsubst_c_def using assms by simp
+
+lemma Inl_cont_hsubst_eq[simp]:
+assumes "root tr = root tr0"
+shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
+unfolding cont_hsubst_eq[OF assms] by simp
+
+lemma Inr_cont_hsubst_eq[simp]:
+assumes "root tr = root tr0"
+shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
+unfolding cont_hsubst_eq[OF assms] by simp
+
+lemma Inl_cont_hsubst_neq[simp]:
+assumes "root tr \<noteq> root tr0"
+shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
+unfolding cont_hsubst_neq[OF assms] by simp
+
+lemma Inr_cont_hsubst_neq[simp]:
+assumes "root tr \<noteq> root tr0"
+shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
+unfolding cont_hsubst_neq[OF assms] by simp  
+
+lemma dtree_hsubst:
+assumes tr0: "dtree tr0" and tr: "dtree tr"
+shows "dtree (hsubst tr)"
+proof-
+  {fix tr1 have "(\<exists> tr. dtree tr \<and> tr1 = hsubst tr) \<Longrightarrow> dtree tr1" 
+   proof (induct rule: dtree_raw_coind)
+     case (Hyp tr1) then obtain tr 
+     where dtr: "dtree tr" and tr1: "tr1 = hsubst tr" by auto
+     show ?case unfolding lift_def tr1 proof safe
+       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
+       unfolding tr1 apply(cases "root tr = root tr0") 
+       using  dtree_P[OF dtr] dtree_P[OF tr0] 
+       by (auto simp add: image_compose[symmetric] sum_map.comp)
+       show "inj_on root (Inr -` cont (hsubst tr))" 
+       apply(cases "root tr = root tr0") using dtree_inj_on[OF dtr] dtree_inj_on[OF tr0] 
+       unfolding inj_on_def by (auto, blast)
+       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
+       thus "\<exists>tra. dtree tra \<and> tr' = hsubst tra"
+       apply(cases "root tr = root tr0", simp_all)
+         apply (metis dtree_lift lift_def tr0)
+         by (metis dtr dtree_lift lift_def)
+     qed
+   qed
+  }
+  thus ?thesis using assms by blast
+qed 
+
+lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
+unfolding inFrr_def Frr_def Fr_def by auto
+
+lemma inFr_hsubst_imp: 
+assumes "inFr ns (hsubst tr) t"
+shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or> 
+       inFr (ns - {root tr0}) tr t"
+proof-
+  {fix tr1 
+   have "inFr ns tr1 t \<Longrightarrow> 
+   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or> 
+                              inFr (ns - {root tr0}) tr t))"
+   proof(induct rule: inFr.induct)
+     case (Base tr1 ns t tr)
+     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
+     by auto
+     show ?case
+     proof(cases "root tr1 = root tr0")
+       case True
+       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
+       thus ?thesis by simp
+     next
+       case False
+       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
+       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
+       thus ?thesis by simp
+     qed
+   next
+     case (Ind tr1 ns tr1' t) note IH = Ind(4)
+     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
+     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
+     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
+     show ?case
+     proof(cases "root tr1 = root tr0")
+       case True
+       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
+       using tr1'_tr1 unfolding tr1 by auto
+       show ?thesis using IH[OF tr1'] proof (elim disjE)
+         assume "inFr (ns - {root tr0}) tr' t"         
+         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
+       qed auto
+     next
+       case False 
+       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
+       using tr1'_tr1 unfolding tr1 by auto
+       show ?thesis using IH[OF tr1'] proof (elim disjE)
+         assume "inFr (ns - {root tr0}) tr' t"         
+         thus ?thesis using tr'_tr unfolding inFrr_def
+         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1) 
+       qed auto
+     qed
+   qed
+  }
+  thus ?thesis using assms by auto
+qed 
+
+lemma inFr_hsubst_notin:
+assumes "inFr ns tr t" and "root tr0 \<notin> ns" 
+shows "inFr ns (hsubst tr) t"
+using assms apply(induct rule: inFr.induct)
+apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
+by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
+
+lemma inFr_hsubst_minus:
+assumes "inFr (ns - {root tr0}) tr t"
+shows "inFr ns (hsubst tr) t"
+proof-
+  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
+  using inFr_hsubst_notin[OF assms] by simp
+  show ?thesis using inFr_mono[OF 1] by auto
+qed
+
+lemma inFr_self_hsubst: 
+assumes "root tr0 \<in> ns"
+shows 
+"inFr ns (hsubst tr0) t \<longleftrightarrow> 
+ t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
+(is "?A \<longleftrightarrow> ?B \<or> ?C")
+apply(intro iffI)
+apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
+  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
+next
+  assume ?C then obtain tr where 
+  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"  
+  unfolding inFrr_def by auto
+  def tr1 \<equiv> "hsubst tr"
+  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
+  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
+  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
+qed
+
+theorem Fr_self_hsubst: 
+assumes "root tr0 \<in> ns"
+shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
+using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
+
+end (* context *)
+  
+
+subsection{* Regular trees *}
+
+hide_const regular
+
+definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
+definition "regular tr \<equiv> \<exists> f. reg f tr"
+
+lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
+unfolding reg_def using subtr_mono by (metis subset_UNIV) 
+
+lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
+unfolding regular_def proof safe
+  fix f assume f: "reg f tr"
+  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
+  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
+  apply(rule exI[of _ g])
+  using f deftr_simps(1) unfolding g_def reg_def apply safe
+    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
+    by (metis (full_types) inItr_subtr subtr_subtr2)
+qed auto
+
+lemma reg_root: 
+assumes "reg f tr"
+shows "f (root tr) = tr"
+using assms unfolding reg_def
+by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
+
+
+lemma reg_Inr_cont: 
+assumes "reg f tr" and "Inr tr' \<in> cont tr"
+shows "reg f tr'"
+by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
+
+lemma reg_subtr: 
+assumes "reg f tr" and "subtr ns tr' tr"
+shows "reg f tr'"
+using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
+by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
+
+lemma regular_subtr: 
+assumes r: "regular tr" and s: "subtr ns tr' tr"
+shows "regular tr'"
+using r reg_subtr[OF _ s] unfolding regular_def by auto
+
+lemma subtr_deftr: 
+assumes "subtr ns tr' (deftr n)"
+shows "tr' = deftr (root tr')"
+proof-
+  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
+   apply (induct rule: subtr.induct)
+   proof(metis (lifting) deftr_simps(1), safe) 
+     fix tr3 ns tr1 tr2 n
+     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
+     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)" 
+     and 3: "Inr tr2 \<in> cont (deftr n)"
+     have "tr2 \<in> deftr ` UNIV" 
+     using 3 unfolding deftr_simps image_def
+     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr 
+         iso_tuple_UNIV_I)
+     then obtain n where "tr2 = deftr n" by auto
+     thus "tr1 = deftr (root tr1)" using IH by auto
+   qed 
+  }
+  thus ?thesis using assms by auto
+qed
+
+lemma reg_deftr: "reg deftr (deftr n)"
+unfolding reg_def using subtr_deftr by auto
+
+lemma dtree_subtrOf_Union: 
+assumes "dtree tr" 
+shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
+       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
+unfolding Union_eq Bex_def mem_Collect_eq proof safe
+  fix x xa tr'
+  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
+  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
+  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
+    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
+    by (metis (lifting) assms subtrOf_root tr'_tr x)
+next
+  fix x X n ttr
+  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
+  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
+  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
+    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
+    using x .
+qed
+
+
+
+
+subsection {* Paths in a regular tree *}
+
+inductive path :: "(N \<Rightarrow> Tree) \<Rightarrow> N list \<Rightarrow> bool" for f where 
+Base: "path f [n]"
+|
+Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk> 
+      \<Longrightarrow> path f (n # n1 # nl)"
+
+lemma path_NE: 
+assumes "path f nl"  
+shows "nl \<noteq> Nil" 
+using assms apply(induct rule: path.induct) by auto
+
+lemma path_post: 
+assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
+shows "path f nl"
+proof-
+  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
+  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject) 
+qed
+
+lemma path_post_concat: 
+assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
+shows "path f nl2"
+using assms apply (induct nl1)
+apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
+
+lemma path_concat: 
+assumes "path f nl1" and "path f ((last nl1) # nl2)"
+shows "path f (nl1 @ nl2)"
+using assms apply(induct rule: path.induct) apply simp
+by (metis append_Cons last.simps list.simps(3) path.Ind) 
+
+lemma path_distinct:
+assumes "path f nl"
+shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and> 
+              set nl' \<subseteq> set nl \<and> distinct nl'"
+using assms proof(induct rule: length_induct)
+  case (1 nl)  hence p_nl: "path f nl" by simp
+  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE) 
+  show ?case
+  proof(cases nl1)
+    case Nil
+    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
+  next
+    case (Cons n1 nl2)  
+    hence p1: "path f nl1" by (metis list.simps nl p_nl path_post)
+    show ?thesis
+    proof(cases "n \<in> set nl1")
+      case False
+      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and 
+      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'" 
+      and s_nl1': "set nl1' \<subseteq> set nl1"
+      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
+      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
+      unfolding Cons by(cases nl1', auto)
+      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
+        show "path f (n # nl1')" unfolding nl1' 
+        apply(rule path.Ind, metis nl1' p1')
+        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
+      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
+    next
+      case True
+      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12" 
+      by (metis split_list) 
+      have p12: "path f (n # nl12)" 
+      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
+      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and 
+      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'" 
+      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
+      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
+      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
+    qed
+  qed
+qed
+
+lemma path_subtr: 
+assumes f: "\<And> n. root (f n) = n"
+and p: "path f nl"
+shows "subtr (set nl) (f (last nl)) (f (hd nl))"
+using p proof (induct rule: path.induct)
+  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
+  have "path f (n1 # nl)"
+  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
+  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
+  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
+  by (metis subset_insertI subtr_mono) 
+  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
+  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)" 
+  using f subtr.Step[OF _ fn1_flast fn1] by auto 
+  thus ?case unfolding 1 by simp 
+qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
+
+lemma reg_subtr_path_aux:
+assumes f: "reg f tr" and n: "subtr ns tr1 tr"
+shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
+using n f proof(induct rule: subtr.induct)
+  case (Refl tr ns)
+  thus ?case
+  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
+next
+  case (Step tr ns tr2 tr1)
+  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr" 
+  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
+  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
+  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
+  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1" 
+  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
+  have 0: "path f (root tr # nl)" apply (subst path.simps)
+  using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv) 
+  show ?case apply(rule exI[of _ "(root tr) # nl"])
+  using 0 reg_root tr last_nl nl path_NE rtr set by auto
+qed 
+
+lemma reg_subtr_path:
+assumes f: "reg f tr" and n: "subtr ns tr1 tr"
+shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
+using reg_subtr_path_aux[OF assms] path_distinct[of f]
+by (metis (lifting) order_trans)
+
+lemma subtr_iff_path:
+assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
+shows "subtr ns tr1 tr \<longleftrightarrow> 
+       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
+proof safe
+  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
+  have "subtr (set nl) (f (last nl)) (f (hd nl))"
+  apply(rule path_subtr) using p f by simp_all
+  thus "subtr ns (f (last nl)) (f (hd nl))"
+  using subtr_mono nl by auto
+qed(insert reg_subtr_path[OF r], auto)
+
+lemma inFr_iff_path:
+assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
+shows 
+"inFr ns tr t \<longleftrightarrow> 
+ (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> 
+            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)" 
+apply safe
+apply (metis (no_types) inFr_subtr r reg_subtr_path)
+by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
+
+
+
+subsection{* The regular cut of a tree *}
+
+context fixes tr0 :: Tree
+begin
+
+(* Picking a subtree of a certain root: *)
+definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n" 
+
+lemma pick:
+assumes "inItr UNIV tr0 n"
+shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
+proof-
+  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n" 
+  using assms by (metis (lifting) inItr_subtr)
+  thus ?thesis unfolding pick_def by(rule someI_ex)
+qed 
+
+lemmas subtr_pick = pick[THEN conjunct1]
+lemmas root_pick = pick[THEN conjunct2]
+
+lemma dtree_pick:
+assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n" 
+shows "dtree (pick n)"
+using dtree_subtr[OF tr0 subtr_pick[OF n]] .
+
+definition "regOf_r n \<equiv> root (pick n)"
+definition "regOf_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
+
+(* The regular tree of a function: *)
+definition regOf :: "N \<Rightarrow> Tree" where  
+"regOf \<equiv> coit regOf_r regOf_c"
+
+lemma finite_regOf_c: "finite (regOf_c n)"
+unfolding regOf_c_def by (metis finite_cont finite_imageI) 
+
+lemma root_regOf_pick: "root (regOf n) = root (pick n)"
+using coit(1)[of regOf_r regOf_c n] unfolding regOf_def regOf_r_def by simp
+
+lemma root_regOf[simp]: 
+assumes "inItr UNIV tr0 n"
+shows "root (regOf n) = n"
+unfolding root_regOf_pick root_pick[OF assms] ..
+
+lemma cont_regOf[simp]: 
+"cont (regOf n) = (id \<oplus> (regOf o root)) ` cont (pick n)"
+apply(subst id_o[symmetric, of id]) unfolding sum_map.comp[symmetric]
+unfolding image_compose unfolding regOf_c_def[symmetric]
+using coit(2)[of regOf_c n regOf_r, OF finite_regOf_c] 
+unfolding regOf_def ..
+
+lemma Inl_cont_regOf[simp]:
+"Inl -` (cont (regOf n)) = Inl -` (cont (pick n))" 
+unfolding cont_regOf by simp
+
+lemma Inr_cont_regOf:
+"Inr -` (cont (regOf n)) = (regOf \<circ> root) ` (Inr -` cont (pick n))"
+unfolding cont_regOf by simp
+
+lemma subtr_regOf: 
+assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (regOf n)"
+shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1"
+proof-
+  {fix tr ns assume "subtr UNIV tr1 tr"
+   hence "tr = regOf n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1)"
+   proof (induct rule: subtr_UNIV_inductL) 
+     case (Step tr2 tr1 tr) 
+     show ?case proof
+       assume "tr = regOf n"
+       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
+       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = regOf n1"
+       using Step by auto
+       obtain tr2' where tr2: "tr2 = regOf (root tr2')" 
+       and tr2': "Inr tr2' \<in> cont (pick n1)"
+       using tr2 Inr_cont_regOf[of n1] 
+       unfolding tr1 image_def o_def using vimage_eq by auto
+       have "inItr UNIV tr0 (root tr2')" 
+       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
+       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = regOf n2" using tr2 by blast
+     qed
+   qed(insert n, auto)
+  }
+  thus ?thesis using assms by auto
+qed
+
+lemma root_regOf_root: 
+assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
+shows "(id \<oplus> (root \<circ> regOf \<circ> root)) t_tr = (id \<oplus> root) t_tr"
+using assms apply(cases t_tr)
+  apply (metis (lifting) sum_map.simps(1))
+  using pick regOf_def regOf_r_def coit(1) 
+      inItr.Base o_apply subtr_StepL subtr_inItr sum_map.simps(2)
+  by (metis UNIV_I)
+
+lemma regOf_P: 
+assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n" 
+shows "(n, (id \<oplus> root) ` cont (regOf n)) \<in> P" (is "?L \<in> P")
+proof- 
+  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
+  unfolding cont_regOf image_compose[symmetric] sum_map.comp id_o o_assoc
+  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
+  by(rule root_regOf_root[OF n])
+  moreover have "... \<in> P" by (metis (lifting) dtree_pick root_pick dtree_P n tr0) 
+  ultimately show ?thesis by simp
+qed
+
+lemma dtree_regOf:
+assumes tr0: "dtree tr0" and "inItr UNIV tr0 n" 
+shows "dtree (regOf n)"
+proof-
+  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = regOf n \<Longrightarrow> dtree tr" 
+   proof (induct rule: dtree_raw_coind)
+     case (Hyp tr) 
+     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" by auto
+     show ?case unfolding lift_def apply safe
+     apply (metis (lifting) regOf_P root_regOf n tr tr0)
+     unfolding tr Inr_cont_regOf unfolding inj_on_def apply clarsimp using root_regOf 
+     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
+     by (metis n subtr.Refl subtr_StepL subtr_regOf tr UNIV_I)
+   qed   
+  }
+  thus ?thesis using assms by blast
+qed
+
+(* The regular cut of a tree: *)   
+definition "rcut \<equiv> regOf (root tr0)"
+
+theorem reg_rcut: "reg regOf rcut"
+unfolding reg_def rcut_def 
+by (metis inItr.Base root_regOf subtr_regOf UNIV_I) 
+
+lemma rcut_reg:
+assumes "reg regOf tr0" 
+shows "rcut = tr0"
+using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
+
+theorem rcut_eq: "rcut = tr0 \<longleftrightarrow> reg regOf tr0"
+using reg_rcut rcut_reg by metis
+
+theorem regular_rcut: "regular rcut"
+using reg_rcut unfolding regular_def by blast
+
+theorem Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
+proof safe
+  fix t assume "t \<in> Fr UNIV rcut"
+  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (regOf (root tr0))"
+  using Fr_subtr[of UNIV "regOf (root tr0)"] unfolding rcut_def
+  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq) 
+  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" using tr
+  by (metis (lifting) inItr.Base subtr_regOf UNIV_I)
+  have "Inl t \<in> cont (pick n)" using t using Inl_cont_regOf[of n] unfolding tr
+  by (metis (lifting) vimageD vimageI2) 
+  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
+  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
+qed
+
+theorem dtree_rcut: 
+assumes "dtree tr0"
+shows "dtree rcut" 
+unfolding rcut_def using dtree_regOf[OF assms inItr.Base] by simp
+
+theorem root_rcut[simp]: "root rcut = root tr0" 
+unfolding rcut_def
+by (metis (lifting) root_regOf inItr.Base reg_def reg_root subtr_rootR_in) 
+
+end (* context *)
+
+
+subsection{* Recursive description of the regular tree frontiers *} 
+
+lemma regular_inFr:
+assumes r: "regular tr" and In: "root tr \<in> ns"
+and t: "inFr ns tr t"
+shows "t \<in> Inl -` (cont tr) \<or> 
+       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
+(is "?L \<or> ?R")
+proof-
+  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n" 
+  using r unfolding regular_def2 by auto
+  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr" 
+  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1" 
+  using t unfolding inFr_iff_path[OF r f] by auto
+  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps) 
+  hence f_n: "f n = tr" using hd_nl by simp
+  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
+  show ?thesis
+  proof(cases nl1)
+    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
+    hence ?L using t_tr1 by simp thus ?thesis by simp
+  next
+    case (Cons n1 nl2) note nl1 = Cons
+    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
+    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr" 
+    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
+    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
+    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
+    apply(intro exI[of _ nl1], intro exI[of _ tr1])
+    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
+    have root_tr: "root tr = n" by (metis f f_n) 
+    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
+    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
+    thus ?thesis using n1_tr by auto
+  qed
+qed
+ 
+theorem regular_Fr: 
+assumes r: "regular tr" and In: "root tr \<in> ns"
+shows "Fr ns tr = 
+       Inl -` (cont tr) \<union> 
+       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
+unfolding Fr_def 
+using In inFr.Base regular_inFr[OF assms] apply safe
+apply (simp, metis (full_types) UnionI mem_Collect_eq)
+apply simp
+by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
+
+
+subsection{* The generated languages *} 
+
+(* The (possibly inifinite tree) generated language *)
+definition "L ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n}"
+
+(* The regular-tree generated language *)
+definition "Lr ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n \<and> regular tr}"
+
+theorem L_rec_notin:
+assumes "n \<notin> ns"
+shows "L ns n = {{}}"
+using assms unfolding L_def apply safe 
+  using not_root_Fr apply force
+  apply(rule exI[of _ "deftr n"])
+  by (metis (no_types) dtree_deftr not_root_Fr root_deftr)
+
+theorem Lr_rec_notin:
+assumes "n \<notin> ns"
+shows "Lr ns n = {{}}"
+using assms unfolding Lr_def apply safe
+  using not_root_Fr apply force
+  apply(rule exI[of _ "deftr n"])
+  by (metis (no_types) regular_def dtree_deftr not_root_Fr reg_deftr root_deftr)
+
+lemma dtree_subtrOf: 
+assumes "dtree tr" and "Inr n \<in> prodOf tr"
+shows "dtree (subtrOf tr n)"
+by (metis assms dtree_lift lift_def subtrOf) 
+  
+theorem Lr_rec_in: 
+assumes n: "n \<in> ns"
+shows "Lr ns n \<subseteq> 
+{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
+    (n,tns) \<in> P \<and> 
+    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
+(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
+proof safe
+  fix ts assume "ts \<in> Lr ns n"
+  then obtain tr where dtr: "dtree tr" and r: "root tr = n" and tr: "regular tr"
+  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
+  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
+  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
+  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
+  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
+    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
+    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
+    unfolding tns_def K_def r[symmetric]
+    unfolding Inl_prodOf dtree_subtrOf_Union[OF dtr] ..
+    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using dtree_P[OF dtr] .
+    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
+    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
+    using dtr tr apply(intro conjI refl)  unfolding tns_def
+      apply(erule dtree_subtrOf[OF dtr])
+      apply (metis subtrOf)
+      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
+  qed
+qed 
+
+lemma hsubst_aux: 
+fixes n ftr tns
+assumes n: "n \<in> ns" and tns: "finite tns" and 
+1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> dtree (ftr n')"
+defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
+shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
+(is "_ = ?B") proof-
+  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
+  unfolding tr_def using tns by auto
+  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
+  unfolding Frr_def ctr by auto
+  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
+  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
+  also have "... = ?B" unfolding ctr Frr by simp
+  finally show ?thesis .
+qed
+
+theorem L_rec_in: 
+assumes n: "n \<in> ns"
+shows "
+{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
+    (n,tns) \<in> P \<and> 
+    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')} 
+ \<subseteq> L ns n"
+proof safe
+  fix tns K
+  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
+  {fix n' assume "Inr n' \<in> tns"
+   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
+   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> dtree tr' \<and> root tr' = n'"
+   unfolding L_def mem_Collect_eq by auto
+  }
+  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>  
+  K n' = Fr (ns - {n}) (ftr n') \<and> dtree (ftr n') \<and> root (ftr n') = n'"
+  by metis
+  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
+  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
+  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
+  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong) 
+  unfolding ctr apply simp apply simp apply safe 
+  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)     
+  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
+  using 0 by auto
+  have dtr: "dtree tr" apply(rule dtree.Tree)
+    apply (metis (lifting) P prtr rtr) 
+    unfolding inj_on_def ctr lift_def using 0 by auto
+  hence dtr': "dtree tr'" unfolding tr'_def by (metis dtree_hsubst)
+  have tns: "finite tns" using finite_in_P P by simp
+  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
+  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
+  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
+  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
+qed
+
+lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns" 
+by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
+
+function LL where 
+"LL ns n = 
+ (if n \<notin> ns then {{}} else 
+ {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
+    (n,tns) \<in> P \<and> 
+    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
+by(pat_completeness, auto)
+termination apply(relation "inv_image (measure card) fst") 
+using card_N by auto
+
+declare LL.simps[code]  (* TODO: Does code generation for LL work? *)
+declare LL.simps[simp del]
+
+theorem Lr_LL: "Lr ns n \<subseteq> LL ns n" 
+proof (induct ns arbitrary: n rule: measure_induct[of card]) 
+  case (1 ns n) show ?case proof(cases "n \<in> ns")
+    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
+  next
+    case True show ?thesis apply(rule subset_trans)
+    using Lr_rec_in[OF True] apply assumption 
+    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
+      fix tns K
+      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
+      assume "(n, tns) \<in> P" 
+      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
+      thus "\<exists>tnsa Ka.
+             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
+             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
+             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
+      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
+    qed
+  qed
+qed
+
+theorem LL_L: "LL ns n \<subseteq> L ns n" 
+proof (induct ns arbitrary: n rule: measure_induct[of card]) 
+  case (1 ns n) show ?case proof(cases "n \<in> ns")
+    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
+  next
+    case True show ?thesis apply(rule subset_trans)
+    prefer 2 using L_rec_in[OF True] apply assumption 
+    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
+      fix tns K
+      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
+      assume "(n, tns) \<in> P" 
+      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
+      thus "\<exists>tnsa Ka.
+             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
+             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
+             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
+      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
+    qed
+  qed
+qed
+
+(* The subsumpsion relation between languages *)
+definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
+
+lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
+unfolding subs_def by auto
+
+lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
+
+lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3" 
+unfolding subs_def by (metis subset_trans) 
+
+(* Language equivalence *)
+definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
+
+lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
+unfolding leqv_def by auto
+
+lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
+unfolding leqv_def by auto
+
+lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
+
+lemma leqv_trans: 
+assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
+shows "leqv L1 L3"
+using assms unfolding leqv_def by (metis (lifting) subs_trans) 
+
+lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
+unfolding leqv_def by auto
+
+lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
+unfolding leqv_def by auto
+
+lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
+unfolding Lr_def L_def by auto
+
+lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
+unfolding subs_def proof safe
+  fix ts2 assume "ts2 \<in> L UNIV ts"
+  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "dtree tr" and rtr: "root tr = ts" 
+  unfolding L_def by auto
+  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
+  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
+  unfolding Lr_def L_def using Fr_rcut dtree_rcut root_rcut regular_rcut by auto
+qed
+
+theorem Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
+using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
+
+theorem LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
+by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
+
+theorem LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
+using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
+
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Parallel.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,143 @@
+theory Parallel 
+imports Tree
+begin
+
+
+consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
+
+axiomatization where 
+    Nplus_comm: "(a::N) + b = b + (a::N)"
+and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
+
+
+
+section{* Parallel composition *} 
+
+fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
+fun par_c where 
+"par_c (tr1,tr2) = 
+ Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union> 
+ Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
+
+declare par_r.simps[simp del]  declare par_c.simps[simp del]
+
+definition par :: "Tree \<times> Tree \<Rightarrow> Tree" where  
+"par \<equiv> coit par_r par_c"
+
+abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
+
+lemma finite_par_c: "finite (par_c (tr1, tr2))"
+unfolding par_c.simps apply(rule finite_UnI)
+  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
+  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
+  using finite_cont by auto
+
+lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
+using coit(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
+
+lemma cont_par: 
+"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
+using coit(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
+unfolding par_def ..
+
+lemma Inl_cont_par[simp]:
+"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)" 
+unfolding cont_par par_c.simps by auto
+
+lemma Inr_cont_par[simp]:
+"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)" 
+unfolding cont_par par_c.simps by auto
+
+lemma Inl_in_cont_par:
+"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
+using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
+
+lemma Inr_in_cont_par:
+"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
+using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
+
+
+section{* =-coinductive proofs *}
+
+(* Detailed proofs of commutativity and associativity: *)
+theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
+proof-
+  let ?\<phi> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
+  {fix trA trB
+   assume "?\<phi> trA trB" hence "trA = trB"
+   proof (induct rule: Tree_coind, safe)
+     fix tr1 tr2 
+     show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)" 
+     unfolding root_par by (rule Nplus_comm)
+   next
+     fix tr1 tr2 :: Tree
+     let ?trA = "tr1 \<parallel> tr2"  let ?trB = "tr2 \<parallel> tr1"
+     show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
+     unfolding lift2_def proof(intro conjI allI impI)
+       fix n show "Inl n \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> Inl n \<in> cont (tr2 \<parallel> tr1)"
+       unfolding Inl_in_cont_par by auto
+     next
+       fix trA' assume "Inr trA' \<in> cont ?trA"
+       then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
+       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+       unfolding Inr_in_cont_par by auto
+       thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
+       apply(intro exI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
+     next
+       fix trB' assume "Inr trB' \<in> cont ?trB"
+       then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
+       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+       unfolding Inr_in_cont_par by auto
+       thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
+       apply(intro exI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
+     qed
+   qed
+  }
+  thus ?thesis by blast
+qed
+
+theorem par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
+proof-
+  let ?\<phi> = 
+  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> 
+                             trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
+  {fix trA trB
+   assume "?\<phi> trA trB" hence "trA = trB"
+   proof (induct rule: Tree_coind, safe)
+     fix tr1 tr2 tr3 
+     show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))" 
+     unfolding root_par by (rule Nplus_assoc)
+   next
+     fix tr1 tr2 tr3 
+     let ?trA = "(tr1 \<parallel> tr2) \<parallel> tr3"  let ?trB = "tr1 \<parallel> (tr2 \<parallel> tr3)"
+     show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
+     unfolding lift2_def proof(intro conjI allI impI)
+       fix n show "Inl n \<in> (cont ?trA) \<longleftrightarrow> Inl n \<in> (cont ?trB)"
+       unfolding Inl_in_cont_par by simp
+     next
+       fix trA' assume "Inr trA' \<in> cont ?trA"
+       then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
+       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+       and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
+       thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
+       apply(intro exI[of _ "tr1' \<parallel> (tr2' \<parallel> tr3')"]) 
+       unfolding Inr_in_cont_par by auto
+     next
+       fix trB' assume "Inr trB' \<in> cont ?trB"
+       then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
+       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+       and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
+       thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
+       apply(intro exI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"]) 
+       unfolding Inr_in_cont_par by auto
+     qed
+   qed
+  }
+  thus ?thesis by blast
+qed
+
+
+
+
+
+end
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Prelim.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,66 @@
+(*  Title:      Gram_Tree.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Preliminaries
+*)
+
+
+theory Prelim
+imports "../../Codatatype/Codatatype"
+begin
+
+declare fset_to_fset[simp]
+
+lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
+apply(rule ext) by (simp add: convol_def)
+
+abbreviation sm_abbrev (infix "\<oplus>" 60) 
+where "f \<oplus> g \<equiv> Sum_Type.sum_map f g" 
+
+lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
+by (cases z) auto
+
+lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
+by (cases z) auto
+
+abbreviation sum_case_abbrev ("[[_,_]]" 800)
+where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
+
+lemma inj_Inl[simp]: "inj Inl" unfolding inj_on_def by auto
+lemma inj_Inr[simp]: "inj Inr" unfolding inj_on_def by auto
+
+lemma Inl_oplus_elim:
+assumes "Inl tr \<in> (id \<oplus> f) ` tns"
+shows "Inl tr \<in> tns"
+using assms apply clarify by (case_tac x, auto)
+
+lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
+using Inl_oplus_elim
+by (metis id_def image_iff sum_map.simps(1))
+
+lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
+using Inl_oplus_iff unfolding vimage_def by auto
+
+lemma Inr_oplus_elim:
+assumes "Inr tr \<in> (id \<oplus> f) ` tns"
+shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
+using assms apply clarify by (case_tac x, auto)
+
+lemma Inr_oplus_iff[simp]: 
+"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
+apply (rule iffI)
+ apply (metis Inr_oplus_elim)
+by (metis image_iff sum_map.simps(2))
+
+lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
+using Inr_oplus_iff unfolding vimage_def by auto
+
+lemma Inl_Inr_image_cong:
+assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
+shows "A = B"
+apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
+
+
+
+end
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Tree.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,326 @@
+(*  Title:      Gram_Tree.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Trees with nonterminal internal nodes and terminal leafs.
+*)
+
+
+header {* Trees with nonterminal internal nodes and terminal leafs *}
+
+
+theory Tree
+imports Prelim
+begin
+
+typedecl N  typedecl T
+
+bnf_codata Tree: 'Tree = "N \<times> (T + 'Tree) fset"
+
+
+section {* Sugar notations for Tree *}
+
+subsection{* Setup for map, set, pred *}
+
+(* These should be eventually inferred from compositionality *)
+
+lemma TreeBNF_map: 
+"TreeBNF_map f (n,as) = (n, map_fset (id \<oplus> f) as)"
+unfolding TreeBNF_map_def id_apply 
+sum_map_def by simp  
+
+lemma TreeBNF_map':
+"TreeBNF_map f n_as = (fst n_as, map_fset (id \<oplus> f) (snd n_as))"
+using TreeBNF_map by(cases n_as, simp)
+
+
+definition 
+"llift2 \<phi> as1 as2 \<longleftrightarrow> 
+ (\<forall> n. Inl n \<in> fset as1 \<longleftrightarrow> Inl n \<in> fset as2) \<and> 
+ (\<forall> tr1. Inr tr1 \<in> fset as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> fset as2 \<and> \<phi> tr1 tr2)) \<and> 
+ (\<forall> tr2. Inr tr2 \<in> fset as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> fset as1 \<and> \<phi> tr1 tr2))"
+
+lemma TreeBNF_pred: "TreeBNF_pred \<phi> (n1,as1) (n2,as2) \<longleftrightarrow> n1 = n2 \<and> llift2 \<phi> as1 as2"
+unfolding llift2_def TreeBNF.pred_unfold
+apply (auto split: sum.splits)
+apply (metis sumE)
+apply (metis sumE)
+apply (metis sumE)
+apply (metis sumE)
+apply (metis sumE sum.simps(1,2,4))
+apply (metis sumE sum.simps(1,2,4))
+done
+
+
+subsection{* Constructors *}
+
+definition NNode :: "N \<Rightarrow> (T + Tree)fset \<Rightarrow> Tree"
+where "NNode n as \<equiv> Tree_fld (n,as)"
+
+lemmas ctor_defs = NNode_def
+
+
+subsection {* Pre-selectors *}
+
+(* These are mere auxiliaries *)
+
+definition "asNNode tr \<equiv> SOME n_as. NNode (fst n_as) (snd n_as) = tr"
+lemmas pre_sel_defs = asNNode_def 
+
+
+subsection {* Selectors *}
+
+(* One for each pair (constructor, constructor argument) *)
+
+(* For NNode: *)
+definition root :: "Tree \<Rightarrow> N" where "root tr = fst (asNNode tr)"
+definition ccont :: "Tree \<Rightarrow> (T + Tree)fset" where "ccont tr = snd (asNNode tr)"
+
+lemmas sel_defs = root_def ccont_def
+
+
+subsection {* Basic properties *}
+
+(* Constructors versus selectors *)
+lemma NNode_surj: "\<exists> n as. NNode n as = tr"
+unfolding NNode_def
+by (metis Tree.fld_unf pair_collapse) 
+
+lemma NNode_asNNode: 
+"NNode (fst (asNNode tr)) (snd (asNNode tr)) = tr"
+proof-
+  obtain n as where "NNode n as = tr" using NNode_surj[of tr] by blast
+  hence "NNode (fst (n,as)) (snd (n,as)) = tr" by simp
+  thus ?thesis unfolding asNNode_def by(rule someI)
+qed
+
+theorem NNode_root_ccont[simp]: 
+"NNode (root tr) (ccont tr) = tr"
+using NNode_asNNode unfolding root_def ccont_def .
+
+(* Constructors *)
+theorem TTree_simps[simp]: 
+"NNode n as = NNode n' as' \<longleftrightarrow> n = n' \<and> as = as'"
+unfolding ctor_defs Tree.fld_inject by auto
+
+theorem TTree_cases[elim, case_names NNode Choice]:
+assumes NNode: "\<And> n as. tr = NNode n as \<Longrightarrow> phi"
+shows phi
+proof(cases rule: Tree.fld_exhaust[of tr])
+  fix x assume "tr = Tree_fld x"
+  thus ?thesis
+  apply(cases x) 
+    using NNode unfolding ctor_defs apply blast
+  done
+qed
+
+(* Constructors versus selectors *)
+theorem TTree_sel_ctor[simp]:
+"root (NNode n as) = n"
+"ccont (NNode n as) = as"
+unfolding root_def ccont_def
+by (metis (no_types) NNode_asNNode TTree_simps)+
+
+
+subsection{* Coinduction *}
+
+theorem TTree_coind_Node[elim, consumes 1, case_names NNode, induct pred: "HOL.eq"]:
+assumes phi: "\<phi> tr1 tr2" and 
+NNode: "\<And> n1 n2 as1 as2. 
+          \<lbrakk>\<phi> (NNode n1 as1) (NNode n2 as2)\<rbrakk> \<Longrightarrow> 
+          n1 = n2 \<and> llift2 \<phi> as1 as2"
+shows "tr1 = tr2"
+apply(rule mp[OF Tree.pred_coinduct[of \<phi> tr1 tr2] phi]) proof clarify
+  fix tr1 tr2  assume \<phi>: "\<phi> tr1 tr2"
+  show "TreeBNF_pred \<phi> (Tree_unf tr1) (Tree_unf tr2)" 
+  apply(cases rule: Tree.fld_exhaust[of tr1], cases rule: Tree.fld_exhaust[of tr2])
+  apply (simp add: Tree.unf_fld)  
+  apply(case_tac x, case_tac xa, simp)
+  unfolding TreeBNF_pred apply(rule NNode) using \<phi> unfolding NNode_def by simp
+qed
+
+theorem TTree_coind[elim, consumes 1, case_names LLift]:
+assumes phi: "\<phi> tr1 tr2" and 
+LLift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> 
+                   root tr1 = root tr2 \<and> llift2 \<phi> (ccont tr1) (ccont tr2)"
+shows "tr1 = tr2"
+using phi apply(induct rule: TTree_coind_Node)
+using LLift by (metis TTree_sel_ctor) 
+
+
+
+subsection {* Coiteration *}
+ 
+(* Preliminaries: *)  
+declare Tree.unf_fld[simp]
+declare Tree.fld_unf[simp]
+
+lemma Tree_unf_NNode[simp]:
+"Tree_unf (NNode n as) = (n,as)"
+unfolding NNode_def Tree.unf_fld ..
+
+lemma Tree_unf_root_ccont:
+"Tree_unf tr = (root tr, ccont tr)"
+unfolding root_def ccont_def
+by (metis (lifting) NNode_asNNode Tree_unf_NNode) 
+
+(* Coiteration *)
+definition TTree_coit :: 
+"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + 'b) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
+where "TTree_coit rt ct \<equiv> Tree_coiter <rt,ct>"  
+
+lemma Tree_coit_coit: 
+"Tree_coiter s = TTree_coit (fst o s) (snd o s)"
+apply(rule ext)
+unfolding TTree_coit_def by simp
+
+theorem TTree_coit: 
+"root (TTree_coit rt ct b) = rt b"  
+"ccont (TTree_coit rt ct b) = map_fset (id \<oplus> TTree_coit rt ct) (ct b)"
+using Tree.coiter[of "<rt,ct>" b] unfolding Tree_coit_coit fst_convol snd_convol
+unfolding TreeBNF_map' fst_convol' snd_convol' 
+unfolding Tree_unf_root_ccont by simp_all 
+
+(* Corecursion, stronger than coitation *)  
+definition TTree_corec :: 
+"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + (Tree + 'b)) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
+where "TTree_corec rt ct \<equiv> Tree_corec <rt,ct>"  
+
+lemma Tree_corec_corec: 
+"Tree_corec s = TTree_corec (fst o s) (snd o s)"
+apply(rule ext)
+unfolding TTree_corec_def by simp
+
+theorem TTree_corec: 
+"root (TTree_corec rt ct b) = rt b" 
+"ccont (TTree_corec rt ct b) = map_fset (id \<oplus> ([[id, TTree_corec rt ct]]) ) (ct b)"
+using Tree.corec[of "<rt,ct>" b] unfolding Tree_corec_corec fst_convol snd_convol
+unfolding TreeBNF_map' fst_convol' snd_convol' 
+unfolding Tree_unf_root_ccont by simp_all
+
+
+subsection{* The characteristic theorems transported from fset to set *}
+
+definition "Node n as \<equiv> NNode n (the_inv fset as)"
+definition "cont \<equiv> fset o ccont"
+definition "coit rt ct \<equiv> TTree_coit rt (the_inv fset o ct)"
+definition "corec rt ct \<equiv> TTree_corec rt (the_inv fset o ct)"
+
+definition lift ("_ ^#" 200) where 
+"lift \<phi> as \<longleftrightarrow> (\<forall> tr. Inr tr \<in> as \<longrightarrow> \<phi> tr)"
+
+definition lift2 ("_ ^#2" 200) where 
+"lift2 \<phi> as1 as2 \<longleftrightarrow> 
+ (\<forall> n. Inl n \<in> as1 \<longleftrightarrow> Inl n \<in> as2) \<and> 
+ (\<forall> tr1. Inr tr1 \<in> as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> as2 \<and> \<phi> tr1 tr2)) \<and> 
+ (\<forall> tr2. Inr tr2 \<in> as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> as1 \<and> \<phi> tr1 tr2))"
+
+definition liftS ("_ ^#s" 200) where 
+"liftS trs = {as. Inr -` as \<subseteq> trs}"
+
+lemma lift2_llift2: 
+"\<lbrakk>finite as1; finite as2\<rbrakk> \<Longrightarrow> 
+ lift2 \<phi> as1 as2 \<longleftrightarrow> llift2 \<phi> (the_inv fset as1) (the_inv fset as2)"
+unfolding lift2_def llift2_def by auto
+
+lemma llift2_lift2: 
+"llift2 \<phi> as1 as2 \<longleftrightarrow> lift2 \<phi> (fset as1) (fset as2)"
+using lift2_llift2 by (metis finite_fset fset_cong fset_to_fset)
+
+lemma mono_lift:
+assumes "(\<phi>^#) as" 
+and "\<And> tr. \<phi> tr \<Longrightarrow> \<phi>' tr"
+shows "(\<phi>'^#) as"
+using assms unfolding lift_def[abs_def] by blast
+
+lemma mono_liftS:
+assumes "trs1 \<subseteq> trs2 "
+shows "(trs1 ^#s) \<subseteq> (trs2 ^#s)" 
+using assms unfolding liftS_def[abs_def] by blast
+
+lemma lift_mono: 
+assumes "\<phi> \<le> \<phi>'"
+shows "(\<phi>^#) \<le> (\<phi>'^#)"
+using assms unfolding lift_def[abs_def] by blast
+
+lemma mono_lift2:
+assumes "(\<phi>^#2) as1 as2"
+and "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> \<phi>' tr1 tr2"
+shows "(\<phi>'^#2) as1 as2"
+using assms unfolding lift2_def[abs_def] by blast
+
+lemma lift2_mono: 
+assumes "\<phi> \<le> \<phi>'"
+shows "(\<phi>^#2) \<le> (\<phi>'^#2)"
+using assms unfolding lift2_def[abs_def] by blast 
+
+lemma finite_cont[simp]: "finite (cont tr)"
+unfolding cont_def by auto
+
+theorem Node_root_cont[simp]: 
+"Node (root tr) (cont tr) = tr"
+using NNode_root_ccont unfolding Node_def cont_def
+by (metis cont_def finite_cont fset_cong fset_to_fset o_def)
+
+theorem Tree_simps[simp]: 
+assumes "finite as" and "finite as'"
+shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
+using assms TTree_simps unfolding Node_def
+by (metis fset_to_fset)
+
+theorem Tree_cases[elim, case_names Node Choice]:
+assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
+shows phi
+apply(cases rule: TTree_cases[of tr])
+using Node unfolding Node_def
+by (metis Node Node_root_cont finite_cont)
+
+theorem Tree_sel_ctor[simp]:
+"root (Node n as) = n" 
+"finite as \<Longrightarrow> cont (Node n as) = as" 
+unfolding Node_def cont_def by auto
+
+theorems root_Node = Tree_sel_ctor(1)
+theorems cont_Node = Tree_sel_ctor(2)
+
+theorem Tree_coind_Node[elim, consumes 1, case_names Node]:
+assumes phi: "\<phi> tr1 tr2" and 
+Node: 
+"\<And> n1 n2 as1 as2. 
+   \<lbrakk>finite as1; finite as2; \<phi> (Node n1 as1) (Node n2 as2)\<rbrakk> 
+   \<Longrightarrow> n1 = n2 \<and> (\<phi>^#2) as1 as2"
+shows "tr1 = tr2"
+using phi apply(induct rule: TTree_coind_Node)
+unfolding llift2_lift2 apply(rule Node)
+unfolding Node_def
+apply (metis finite_fset)
+apply (metis finite_fset)
+by (metis finite_fset fset_cong fset_to_fset)
+
+theorem Tree_coind[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
+assumes phi: "\<phi> tr1 tr2" and 
+Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> 
+                  root tr1 = root tr2 \<and> (\<phi>^#2) (cont tr1) (cont tr2)"
+shows "tr1 = tr2"
+using phi apply(induct rule: TTree_coind)
+unfolding llift2_lift2 apply(rule Lift[unfolded cont_def comp_def]) .
+
+theorem coit: 
+"root (coit rt ct b) = rt b" 
+"finite (ct b) \<Longrightarrow> cont (coit rt ct b) = image (id \<oplus> coit rt ct) (ct b)"
+using TTree_coit[of rt "the_inv fset \<circ> ct" b] unfolding coit_def
+apply - apply metis
+unfolding cont_def comp_def
+by (metis (no_types) fset_to_fset map_fset_image)
+
+
+theorem corec: 
+"root (corec rt ct b) = rt b" 
+"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
+using TTree_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
+apply - apply metis
+unfolding cont_def comp_def
+by (metis (no_types) fset_to_fset map_fset_image)
+
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Lambda_Term.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,259 @@
+(*  Title:      Codatatype_Examples/Lambda_Term.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Lambda-terms.
+*)
+
+header {* Lambda-Terms *}
+
+theory Lambda_Term
+imports "../Codatatype/Codatatype"
+begin
+
+
+section {* Datatype definition *}
+
+bnf_data trm: 'trm = "'a + 'trm \<times> 'trm + 'a \<times> 'trm + ('a \<times> 'trm) fset \<times> 'trm"
+
+
+section {* Customization of terms *}
+
+subsection{* Set and map *}
+
+lemma trmBNF_set2_Lt: "trmBNF_set2 (Inr (Inr (Inr (xts, t)))) = snd ` (fset xts) \<union> {t}"
+unfolding trmBNF_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
+by auto
+
+lemma trmBNF_set2_Var: "\<And>x. trmBNF_set2 (Inl x) = {}"
+and trmBNF_set2_App:
+"\<And>t1 t2. trmBNF_set2 (Inr (Inl t1t2)) = {fst t1t2, snd t1t2}"
+and trmBNF_set2_Lam:
+"\<And>x t. trmBNF_set2 (Inr (Inr (Inl (x, t)))) = {t}"
+unfolding trmBNF_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
+by auto
+
+lemma trmBNF_map:
+"\<And> a1. trmBNF_map f1 f2 (Inl a1) = Inl (f1 a1)"
+"\<And> a2 b2. trmBNF_map f1 f2 (Inr (Inl (a2,b2))) = Inr (Inl (f2 a2, f2 b2))"
+"\<And> a1 a2. trmBNF_map f1 f2 (Inr (Inr (Inl (a1,a2)))) = Inr (Inr (Inl (f1 a1, f2 a2)))"
+"\<And> a1a2s a2.
+   trmBNF_map f1 f2 (Inr (Inr (Inr (a1a2s, a2)))) =
+   Inr (Inr (Inr (map_fset (\<lambda> (a1', a2'). (f1 a1', f2 a2')) a1a2s, f2 a2)))"
+unfolding trmBNF_map_def collect_def[abs_def] map_pair_def by auto
+
+
+subsection{* Constructors *}
+
+definition "Var x \<equiv> trm_fld (Inl x)"
+definition "App t1 t2 \<equiv> trm_fld (Inr (Inl (t1,t2)))"
+definition "Lam x t \<equiv> trm_fld (Inr (Inr (Inl (x,t))))"
+definition "Lt xts t \<equiv> trm_fld (Inr (Inr (Inr (xts,t))))"
+
+lemmas ctor_defs = Var_def App_def Lam_def Lt_def
+
+theorem trm_simps[simp]:
+"\<And>x y. Var x = Var y \<longleftrightarrow> x = y"
+"\<And>t1 t2 t1' t2'. App t1 t2 = App t1' t2' \<longleftrightarrow> t1 = t1' \<and> t2 = t2'"
+"\<And>x x' t t'. Lam x t = Lam x' t' \<longleftrightarrow> x = x' \<and> t = t'"
+"\<And> xts xts' t t'. Lt xts t = Lt xts' t' \<longleftrightarrow> xts = xts' \<and> t = t'"
+(*  *)
+"\<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"
+"\<And> t1 t2 x t. App t1 t2 \<noteq> Lam x t"  "\<And> t1 t2 xts t. App t1 t2 \<noteq> Lt xts t"
+"\<And>x t xts t1. Lam x t \<noteq> Lt xts t1"
+unfolding ctor_defs trm.fld_inject by auto
+
+theorem trm_cases[elim, case_names Var App Lam Lt]:
+assumes Var: "\<And> x. t = Var x \<Longrightarrow> phi"
+and App: "\<And> t1 t2. t = App t1 t2 \<Longrightarrow> phi"
+and Lam: "\<And> x t1. t = Lam x t1 \<Longrightarrow> phi"
+and Lt: "\<And> xts t1. t = Lt xts t1 \<Longrightarrow> phi"
+shows phi
+proof(cases rule: trm.fld_exhaust[of t])
+  fix x assume "t = trm_fld x"
+  thus ?thesis
+  apply(cases x) using Var unfolding ctor_defs apply blast
+  apply(case_tac b) using App unfolding ctor_defs apply(case_tac a, blast)
+  apply(case_tac ba) using Lam unfolding ctor_defs apply(case_tac a, blast)
+  apply(case_tac bb) using Lt unfolding ctor_defs by blast
+qed
+
+lemma trm_induct[case_names Var App Lam Lt, induct type: trm]:
+assumes Var: "\<And> (x::'a). phi (Var x)"
+and App: "\<And> t1 t2. \<lbrakk>phi t1; phi t2\<rbrakk> \<Longrightarrow> phi (App t1 t2)"
+and Lam: "\<And> x t. phi t \<Longrightarrow> phi (Lam x t)"
+and Lt: "\<And> xts t. \<lbrakk>\<And> x1 t1. (x1,t1) |\<in>| xts \<Longrightarrow> phi t1; phi t\<rbrakk> \<Longrightarrow> phi (Lt xts t)"
+shows "phi t"
+proof(induct rule: trm.fld_induct)
+  fix u :: "'a + 'a trm \<times> 'a trm + 'a \<times> 'a trm + ('a \<times> 'a trm) fset \<times> 'a trm"
+  assume IH: "\<And>t. t \<in> trmBNF_set2 u \<Longrightarrow> phi t"
+  show "phi (trm_fld u)"
+  proof(cases u)
+    case (Inl x)
+    show ?thesis using Var unfolding Var_def Inl .
+  next
+    case (Inr uu) note Inr1 = Inr
+    show ?thesis
+    proof(cases uu)
+      case (Inl t1t2)
+      obtain t1 t2 where t1t2: "t1t2 = (t1,t2)" by (cases t1t2, blast)
+      show ?thesis unfolding Inr1 Inl t1t2 App_def[symmetric] apply(rule App)
+      using IH unfolding Inr1 Inl trmBNF_set2_App t1t2 fst_conv snd_conv by blast+
+    next
+      case (Inr uuu) note Inr2 = Inr
+      show ?thesis
+      proof(cases uuu)
+        case (Inl xt)
+        obtain x t where xt: "xt = (x,t)" by (cases xt, blast)
+        show ?thesis unfolding Inr1 Inr2 Inl xt Lam_def[symmetric] apply(rule Lam)
+        using IH unfolding Inr1 Inr2 Inl trmBNF_set2_Lam xt by blast
+      next
+        case (Inr xts_t)
+        obtain xts t where xts_t: "xts_t = (xts,t)" by (cases xts_t, blast)
+        show ?thesis unfolding Inr1 Inr2 Inr xts_t Lt_def[symmetric] apply(rule Lt) using IH
+        unfolding Inr1 Inr2 Inr trmBNF_set2_Lt xts_t fset_fset_member image_def by auto
+      qed
+    qed
+  qed
+qed
+
+
+subsection{* Recursion and iteration *}
+
+definition
+"sumJoin4 f1 f2 f3 f4 \<equiv>
+\<lambda> k. (case k of
+ Inl x1 \<Rightarrow> f1 x1
+|Inr k1 \<Rightarrow> (case k1 of
+ Inl ((s2,a2),(t2,b2)) \<Rightarrow> f2 s2 a2 t2 b2
+|Inr k2 \<Rightarrow> (case k2 of Inl (x3,(t3,b3)) \<Rightarrow> f3 x3 t3 b3
+|Inr (xts,(t4,b4)) \<Rightarrow> f4 xts t4 b4)))"
+
+lemma sumJoin4_simps[simp]:
+"\<And>x. sumJoin4 var app lam lt (Inl x) = var x"
+"\<And> t1 a1 t2 a2. sumJoin4 var app lam lt (Inr (Inl ((t1,a1),(t2,a2)))) = app t1 a1 t2 a2"
+"\<And> x t a. sumJoin4 var app lam lt (Inr (Inr (Inl (x,(t,a))))) = lam x t a"
+"\<And> xtas t a. sumJoin4 var app lam lt (Inr (Inr (Inr (xtas,(t,a))))) = lt xtas t a"
+unfolding sumJoin4_def by auto
+
+definition "trmrec var app lam lt \<equiv> trm_rec (sumJoin4 var app lam lt)"
+
+lemma trmrec_Var[simp]:
+"trmrec var app lam lt (Var x) = var x"
+unfolding trmrec_def Var_def trm.rec trmBNF_map(1) by simp
+
+lemma trmrec_App[simp]:
+"trmrec var app lam lt (App t1 t2) =
+ app t1 (trmrec var app lam lt t1) t2 (trmrec var app lam lt t2)"
+unfolding trmrec_def App_def trm.rec trmBNF_map(2) convol_def by simp
+
+lemma trmrec_Lam[simp]:
+"trmrec var app lam lt (Lam x t) = lam x t (trmrec var app lam lt t)"
+unfolding trmrec_def Lam_def trm.rec trmBNF_map(3) convol_def by simp
+
+lemma trmrec_Lt[simp]:
+"trmrec var app lam lt (Lt xts t) =
+ lt (map_fset (\<lambda> (x,t). (x,t,trmrec var app lam lt t)) xts) t (trmrec var app lam lt t)"
+unfolding trmrec_def Lt_def trm.rec trmBNF_map(4) convol_def by simp
+
+definition
+"sumJoinI4 f1 f2 f3 f4 \<equiv>
+\<lambda> k. (case k of
+ Inl x1 \<Rightarrow> f1 x1
+|Inr k1 \<Rightarrow> (case k1 of
+ Inl (a2,b2) \<Rightarrow> f2 a2 b2
+|Inr k2 \<Rightarrow> (case k2 of Inl (x3,b3) \<Rightarrow> f3 x3 b3
+|Inr (xts,b4) \<Rightarrow> f4 xts b4)))"
+
+lemma sumJoinI4_simps[simp]:
+"\<And>x. sumJoinI4 var app lam lt (Inl x) = var x"
+"\<And> a1 a2. sumJoinI4 var app lam lt (Inr (Inl (a1,a2))) = app a1 a2"
+"\<And> x a. sumJoinI4 var app lam lt (Inr (Inr (Inl (x,a)))) = lam x a"
+"\<And> xtas a. sumJoinI4 var app lam lt (Inr (Inr (Inr (xtas,a)))) = lt xtas a"
+unfolding sumJoinI4_def by auto
+
+(* The iterator has a simpler, hence more manageable type. *)
+definition "trmiter var app lam lt \<equiv> trm_iter (sumJoinI4 var app lam lt)"
+
+lemma trmiter_Var[simp]:
+"trmiter var app lam lt (Var x) = var x"
+unfolding trmiter_def Var_def trm.iter trmBNF_map(1) by simp
+
+lemma trmiter_App[simp]:
+"trmiter var app lam lt (App t1 t2) =
+ app (trmiter var app lam lt t1) (trmiter var app lam lt t2)"
+unfolding trmiter_def App_def trm.iter trmBNF_map(2) by simp
+
+lemma trmiter_Lam[simp]:
+"trmiter var app lam lt (Lam x t) = lam x (trmiter var app lam lt t)"
+unfolding trmiter_def Lam_def trm.iter trmBNF_map(3) by simp
+
+lemma trmiter_Lt[simp]:
+"trmiter var app lam lt (Lt xts t) =
+ lt (map_fset (\<lambda> (x,t). (x,trmiter var app lam lt t)) xts) (trmiter var app lam lt t)"
+unfolding trmiter_def Lt_def trm.iter trmBNF_map(4) by simp
+
+
+subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
+
+definition "varsOf = trmiter
+(\<lambda> x. {x})
+(\<lambda> X1 X2. X1 \<union> X2)
+(\<lambda> x X. X \<union> {x})
+(\<lambda> xXs Y. Y \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| xXs}))"
+
+lemma varsOf_simps[simp]:
+"varsOf (Var x) = {x}"
+"varsOf (App t1 t2) = varsOf t1 \<union> varsOf t2"
+"varsOf (Lam x t) = varsOf t \<union> {x}"
+"varsOf (Lt xts t) =
+ varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,varsOf t1)) xts})"
+unfolding varsOf_def by simp_all
+
+definition "fvarsOf = trmiter
+(\<lambda> x. {x})
+(\<lambda> X1 X2. X1 \<union> X2)
+(\<lambda> x X. X - {x})
+(\<lambda> xtXs Y. Y - {x | x X. (x,X) |\<in>| xtXs} \<union> (\<Union> {X | x X. (x,X) |\<in>| xtXs}))"
+
+lemma fvarsOf_simps[simp]:
+"fvarsOf (Var x) = {x}"
+"fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
+"fvarsOf (Lam x t) = fvarsOf t - {x}"
+"fvarsOf (Lt xts t) =
+ fvarsOf t
+ - {x | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts}
+ \<union> (\<Union> {X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts})"
+unfolding fvarsOf_def by simp_all
+
+lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
+
+lemma in_map_fset_iff:
+"(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, f t1)) xts \<longleftrightarrow>
+ (\<exists> t1. (x,t1) |\<in>| xts \<and> X = f t1)"
+unfolding map_fset_def2_raw in_fset fset_afset unfolding fset_def2_raw by auto
+
+lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
+proof induct
+  case (Lt xts t)
+  thus ?case unfolding fvarsOf_simps varsOf_simps
+  proof (elim diff_Un_incl_triv)
+    show
+    "\<Union>{X | x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts}
+     \<subseteq> \<Union>{{x} \<union> X |x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts}"
+     (is "_ \<subseteq> \<Union> ?L")
+    proof(rule Sup_mono, safe)
+      fix a x X
+      assume "(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts"
+      then obtain t1 where x_t1: "(x,t1) |\<in>| xts" and X: "X = fvarsOf t1"
+      unfolding in_map_fset_iff by auto
+      let ?Y = "varsOf t1"
+      have x_Y: "(x,?Y) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts"
+      using x_t1 unfolding in_map_fset_iff by auto
+      show "\<exists> Y \<in> ?L. X \<subseteq> Y" unfolding X using Lt(1) x_Y x_t1 by auto
+    qed
+  qed
+qed auto
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/ListF.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,171 @@
+(*  Title:      Codatatype_Examples/ListF.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Finite lists.
+*)
+
+header {* Finite Lists *}
+
+theory ListF
+imports "../Codatatype/Codatatype"
+begin
+
+bnf_data listF: 'list = "unit + 'a \<times> 'list"
+
+definition "NilF = listF_fld (Inl ())"
+definition "Conss a as \<equiv> listF_fld (Inr (a, as))"
+
+lemma listF_map_NilF[simp]: "listF_map f NilF = NilF"
+unfolding listF_map_def listFBNF_map_def NilF_def listF.iter by simp
+
+lemma listF_map_Conss[simp]:
+  "listF_map f (Conss x xs) = Conss (f x) (listF_map f xs)"
+unfolding listF_map_def listFBNF_map_def Conss_def listF.iter by simp
+
+lemma listF_set_NilF[simp]: "listF_set NilF = {}"
+unfolding listF_set_def NilF_def listF.iter listFBNF_set1_def listFBNF_set2_def
+  sum_set_defs listFBNF_map_def collect_def[abs_def] by simp
+
+lemma listF_set_Conss[simp]: "listF_set (Conss x xs) = {x} \<union> listF_set xs"
+unfolding listF_set_def Conss_def listF.iter listFBNF_set1_def listFBNF_set2_def
+  sum_set_defs prod_set_defs listFBNF_map_def collect_def[abs_def] by simp
+
+lemma iter_sum_case_NilF: "listF_iter (sum_case f g) NilF = f ()"
+unfolding NilF_def listF.iter listFBNF_map_def by simp
+
+
+lemma iter_sum_case_Conss:
+  "listF_iter (sum_case f g) (Conss y ys) = g (y, listF_iter (sum_case f g) ys)"
+unfolding Conss_def listF.iter listFBNF_map_def by simp
+
+(* familiar induction principle *)
+lemma listF_induct:
+  fixes xs :: "'a listF"
+  assumes IB: "P NilF" and IH: "\<And>x xs. P xs \<Longrightarrow> P (Conss x xs)"
+  shows "P xs"
+proof (rule listF.fld_induct)
+  fix xs :: "unit + 'a \<times> 'a listF"
+  assume raw_IH: "\<And>a. a \<in> listFBNF_set2 xs \<Longrightarrow> P a"
+  show "P (listF_fld xs)"
+  proof (cases xs)
+    case (Inl a) with IB show ?thesis unfolding NilF_def by simp
+  next
+    case (Inr b)
+    then obtain y ys where yys: "listF_fld xs = Conss y ys"
+      unfolding Conss_def listF.fld_inject by (blast intro: prod.exhaust)
+    hence "ys \<in> listFBNF_set2 xs"
+      unfolding listFBNF_set2_def Conss_def listF.fld_inject sum_set_defs prod_set_defs
+        collect_def[abs_def] by simp
+    with raw_IH have "P ys" by blast
+    with IH have "P (Conss y ys)" by blast
+    with yys show ?thesis by simp
+  qed
+qed
+
+rep_datatype NilF Conss
+by (blast intro: listF_induct) (auto simp add: NilF_def Conss_def listF.fld_inject)
+
+definition Singll ("[[_]]") where
+  [simp]: "Singll a \<equiv> Conss a NilF"
+
+definition appendd (infixr "@@" 65) where
+  "appendd \<equiv> listF_iter (sum_case (\<lambda> _. id) (\<lambda> (a,f) bs. Conss a (f bs)))"
+
+definition "lrev \<equiv> listF_iter (sum_case (\<lambda> _. NilF) (\<lambda> (b,bs). bs @@ [[b]]))"
+
+lemma lrev_NilF[simp]: "lrev NilF = NilF"
+unfolding lrev_def by (simp add: iter_sum_case_NilF)
+
+lemma lrev_Conss[simp]: "lrev (Conss y ys) = lrev ys @@ [[y]]"
+unfolding lrev_def by (simp add: iter_sum_case_Conss)
+
+lemma NilF_appendd[simp]: "NilF @@ ys = ys"
+unfolding appendd_def by (simp add: iter_sum_case_NilF)
+
+lemma Conss_append[simp]: "Conss x xs @@ ys = Conss x (xs @@ ys)"
+unfolding appendd_def by (simp add: iter_sum_case_Conss)
+
+lemma appendd_NilF[simp]: "xs @@ NilF = xs"
+by (rule listF_induct) auto
+
+lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
+by (rule listF_induct) auto
+
+lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
+by (rule listF_induct[of _ xs]) auto
+
+lemma listF_map_appendd[simp]:
+  "listF_map f (xs @@ ys) = listF_map f xs @@ listF_map f ys"
+by (rule listF_induct[of _ xs]) auto
+
+lemma lrev_listF_map[simp]: "lrev (listF_map f xs) = listF_map f (lrev xs)"
+by (rule listF_induct[of _ xs]) auto
+
+lemma lrev_lrev[simp]: "lrev (lrev as) = as"
+by (rule listF_induct) auto
+
+fun lengthh where
+  "lengthh NilF = 0"
+| "lengthh (Conss x xs) = Suc (lengthh xs)"
+
+fun nthh where
+  "nthh (Conss x xs) 0 = x"
+| "nthh (Conss x xs) (Suc n) = nthh xs n"
+| "nthh xs i = undefined"
+
+lemma lengthh_listF_map[simp]: "lengthh (listF_map f xs) = lengthh xs"
+by (rule listF_induct[of _ xs]) auto
+
+lemma nthh_listF_map[simp]:
+  "i < lengthh xs \<Longrightarrow> nthh (listF_map f xs) i = f (nthh xs i)"
+by (induct rule: nthh.induct) auto
+
+lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
+by (induct rule: nthh.induct) auto
+
+lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
+by (induct xs) auto
+
+lemma Conss_iff[iff]:
+  "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
+by (induct xs) auto
+
+lemma Conss_iff'[iff]:
+  "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
+by (induct xs) (simp, simp, blast)
+
+lemma listF_induct2: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
+    \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
+by (induct xs arbitrary: ys rule: listF_induct) auto
+
+fun zipp where
+  "zipp NilF NilF = NilF"
+| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
+| "zipp xs ys = undefined"
+
+lemma listF_map_fst_zip[simp]:
+  "lengthh xs = lengthh ys \<Longrightarrow> listF_map fst (zipp xs ys) = xs"
+by (erule listF_induct2) auto
+
+lemma listF_map_snd_zip[simp]:
+  "lengthh xs = lengthh ys \<Longrightarrow> listF_map snd (zipp xs ys) = ys"
+by (erule listF_induct2) auto
+
+lemma lengthh_zip[simp]:
+  "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
+by (erule listF_induct2) auto
+
+lemma nthh_zip[simp]:
+  assumes *: "lengthh xs = lengthh ys"
+  shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
+proof (induct arbitrary: i rule: listF_induct2[OF *])
+  case (2 x xs y ys) thus ?case by (induct i) auto
+qed simp
+
+lemma list_set_nthh[simp]:
+  "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
+by (induct xs) (auto, induct rule: nthh.induct, auto)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Misc_Codata.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,88 @@
+(*  Title:      Codatatype_Examples/Misc_Data.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Miscellaneous codatatype declarations.
+*)
+
+header {* Miscellaneous Codatatype Declarations *}
+
+theory Misc_Codata
+imports "../Codatatype/Codatatype"
+begin
+
+ML {* quick_and_dirty := false *}
+
+ML {* PolyML.fullGC (); *}
+
+bnf_codata simple: 'a = "unit + unit + unit + unit"
+
+bnf_codata stream: 's = "'a \<times> 's"
+
+bnf_codata llist: 'llist = "unit + 'a \<times> 'llist"
+
+bnf_codata some_passive: 'a = "'a + 'b + 'c + 'd + 'e"
+
+(*
+  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
+  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
+*)
+
+bnf_codata F1: 'b1 = "'a \<times> 'b1 + 'a \<times> 'b2"
+and F2: 'b2 = "unit + 'b1 * 'b2"
+
+bnf_codata EXPR:   'E = "'T + 'T \<times> 'E"
+and TERM:   'T = "'F + 'F \<times> 'T"
+and FACTOR: 'F = "'a + 'b + 'E"
+
+bnf_codata llambda:
+  'trm = "string +
+          'trm \<times> 'trm +
+          string \<times> 'trm +
+          (string \<times> 'trm) fset \<times> 'trm"
+
+bnf_codata par_llambda:
+  'trm = "'a +
+          'trm \<times> 'trm +
+          'a \<times> 'trm +
+          ('a \<times> 'trm) fset \<times> 'trm"
+
+(*
+  'a tree = Empty | Node of 'a * 'a forest      ('b = unit + 'a * 'c)
+  'a forest = Nil | Cons of 'a tree * 'a forest ('c = unit + 'b * 'c)
+*)
+
+bnf_codata tree:     'tree = "unit + 'a \<times> 'forest"
+and forest: 'forest = "unit + 'tree \<times> 'forest"
+
+bnf_codata CPS: 'a = "'b + 'b \<Rightarrow> 'a"
+
+bnf_codata fun_rhs: 'a = "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'a"
+
+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>
+                    'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow> 'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow> 'a"
+
+bnf_codata some_killing: 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
+and in_here: 'c = "'d \<times> 'b + 'e"
+
+bnf_codata some_killing': 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
+and in_here': 'c = "'d + 'e"
+
+bnf_codata some_killing'': 'a = "'b \<Rightarrow> 'c"
+and in_here'': 'c = "'d \<times> 'b + 'e"
+
+bnf_codata less_killing: 'a = "'b \<Rightarrow> 'c"
+
+(* SLOW, MEMORY-HUNGRY
+bnf_codata K1': 'K1 = "'K2 + 'a list"
+and K2': 'K2 = "'K3 + 'c fset"
+and K3': 'K3 = "'K3 + 'K4 + 'K4 \<times> 'K5"
+and K4': 'K4 = "'K5 + 'a list list list"
+and K5': 'K5 = "'K6"
+and K6': 'K6 = "'K7"
+and K7': 'K7 = "'K8"
+and K8': 'K8 = "'K1 list"
+*)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Misc_Data.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,161 @@
+(*  Title:      Codatatype_Examples/Misc_Data.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Miscellaneous datatype declarations.
+*)
+
+header {* Miscellaneous Datatype Declarations *}
+
+theory Misc_Data
+imports "../Codatatype/Codatatype"
+begin
+
+ML {* quick_and_dirty := false *}
+
+ML {* PolyML.fullGC (); *}
+
+bnf_data simple: 'a = "unit + unit + unit + unit"
+
+bnf_data mylist: 'list = "unit + 'a \<times> 'list"
+
+bnf_data some_passive: 'a = "'a + 'b + 'c + 'd + 'e"
+
+bnf_data lambda:
+  'trm = "string +
+          'trm \<times> 'trm +
+          string \<times> 'trm +
+          (string \<times> 'trm) fset \<times> 'trm"
+
+bnf_data par_lambda:
+  'trm = "'a +
+          'trm \<times> 'trm +
+          'a \<times> 'trm +
+          ('a \<times> 'trm) fset \<times> 'trm"
+
+(*
+  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
+  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
+*)
+
+bnf_data F1: 'b1 = "'a \<times> 'b1 + 'a \<times> 'b2"
+and F2: 'b2 = "unit + 'b1 * 'b2"
+
+(*
+  'a tree = Empty | Node of 'a * 'a forest      ('b = unit + 'a * 'c)
+  'a forest = Nil | Cons of 'a tree * 'a forest ('c = unit + 'b * 'c)
+*)
+
+bnf_data tree: 'tree = "unit + 'a \<times> 'forest"
+and forest: 'forest = "unit + 'tree \<times> 'forest"
+
+(*
+  'a tree = Empty | Node of 'a branch * 'a branch ('b = unit + 'c * 'c)
+'  a branch = Branch of 'a * 'a tree              ('c = 'a * 'b)
+*)
+
+bnf_data tree': 'tree = "unit + 'branch \<times> 'branch"
+and branch: 'branch = "'a \<times> 'tree"
+
+(*
+  exp = Sum of term * exp          ('c = 'd + 'd * 'c)
+  term = Prod of factor * term     ('d = 'e + 'e * 'd)
+  factor = C 'a | V 'b | Paren exp ('e = 'a + 'b + 'c)
+*)
+
+bnf_data EXPR: 'E = "'T + 'T \<times> 'E"
+and TERM: 'T = "'F + 'F \<times> 'T"
+and FACTOR: 'F = "'a + 'b + 'E"
+
+bnf_data some_killing: 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
+and in_here: 'c = "'d \<times> 'b + 'e"
+
+bnf_data nofail1: 'a = "'a \<times> 'b + 'b"
+bnf_data nofail2: 'a = "('a \<times> 'b \<times> 'a \<times> 'b) list"
+bnf_data nofail3: 'a = "'b \<times> ('a \<times> 'b \<times> 'a \<times> 'b) fset"
+bnf_data nofail4: 'a = "('a \<times> ('a \<times> 'b \<times> 'a \<times> 'b) fset) list"
+
+(*
+bnf_data fail: 'a = "'a \<times> 'b \<times> 'a \<times> 'b list"
+bnf_data fail: 'a = "'a \<times> 'b \<times> 'a \<times> 'b"
+bnf_data fail: 'a = "'a \<times> 'b + 'a"
+bnf_data fail: 'a = "'a \<times> 'b"
+*)
+
+bnf_data L1: 'L1 = "'L2 list"
+and L2: 'L2 = "'L1 fset + 'L2"
+
+bnf_data K1: 'K1 = "'K2"
+and K2: 'K2 = "'K3"
+and K3: 'K3 = "'K1 list"
+
+bnf_data t1: 't1 = "'t3 + 't2"
+and t2: 't2 = "'t1"
+and t3: 't3 = "unit"
+
+bnf_data t1': 't1 = "'t2 + 't3"
+and t2': 't2 = "'t1"
+and t3': 't3 = "unit"
+
+(*
+bnf_data fail1: 'L1 = "'L2"
+and fail2: 'L2 = "'L3"
+and fail2: 'L3 = "'L1"
+
+bnf_data fail1: 'L1 = "'L2 list \<times> 'L2"
+and fail2: 'L2 = "'L2 fset \<times> 'L3"
+and fail2: 'L3 = "'L1"
+
+bnf_data fail1: 'L1 = "'L2 list \<times> 'L2"
+and fail2: 'L2 = "'L1 fset \<times> 'L1"
+*)
+(* SLOW
+bnf_data K1': 'K1 = "'K2 + 'a list"
+and K2': 'K2 = "'K3 + 'c fset"
+and K3': 'K3 = "'K3 + 'K4 + 'K4 \<times> 'K5"
+and K4': 'K4 = "'K5 + 'a list list list"
+and K5': 'K5 = "'K6"
+and K6': 'K6 = "'K7"
+and K7': 'K7 = "'K8"
+and K8': 'K8 = "'K1 list"
+
+(*time comparison*)
+datatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
+     and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
+     and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
+     and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
+     and ('a, 'c) D5 = A5 "('a, 'c) D6"
+     and ('a, 'c) D6 = A6 "('a, 'c) D7"
+     and ('a, 'c) D7 = A7 "('a, 'c) D8"
+     and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
+*)
+
+(* fail:
+bnf_data t1: 't1 = "'t2 * 't3 + 't2 * 't4"
+and t2: 't2 = "unit"
+and t3: 't3 = 't4
+and t4: 't4 = 't1
+*)
+
+bnf_data k1: 'k1 = "'k2 * 'k3 + 'k2 * 'k4"
+and k2: 'k2 = unit
+and k3: 'k3 = 'k4
+and k4: 'k4 = unit
+
+bnf_data tt1: 'tt1 = "'tt3 * 'tt2 + 'tt2 * 'tt4"
+and tt2: 'tt2 = unit
+and tt3: 'tt3 = 'tt1
+and tt4: 'tt4 = unit
+(* SLOW
+bnf_data s1: 's1 = "'s2 * 's3 * 's4 + 's3 + 's2 * 's6 + 's4 * 's2 + 's2 * 's2"
+and s2: 's2 = "'s7 * 's5 + 's5 * 's4 * 's6"
+and s3: 's3 = "'s1 * 's7 * 's2 + 's3 * 's3 + 's4 * 's5"
+and s4: 's4 = 's5
+and s5: 's5 = unit
+and s6: 's6 = "'s6 + 's1 * 's2 + 's6"
+and s7: 's7 = "'s8 + 's5"
+and s8: 's8 = nat
+*)
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Process.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,742 @@
+(*  Title:      Codatatype_Examples/Process.thy
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Processes.
+*)
+
+header {* Processes *}
+
+theory Process
+imports "../Codatatype/Codatatype"
+begin
+
+bnf_codata process: 'p = "'a * 'p + 'p * 'p"
+(* codatatype
+     'a process = Action (prefOf :: 'a) (contOf :: 'a process) |
+                  Choice (ch1Of :: 'a process) (ch2Of :: 'a process)
+*)
+
+(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
+
+section {* Customization *}
+
+subsection{* Setup for map, set, pred  *}
+
+(* These should be eventually inferred from compositionality *)
+
+lemma processBNF_map[simp]:
+"processBNF_map fa fp (Inl (a ,p)) = Inl (fa a, fp p)"
+"processBNF_map fa fp (Inr (p1, p2)) = Inr (fp p1, fp p2)"
+unfolding processBNF_map_def by auto
+
+lemma processBNF_pred[simp]:
+"processBNF_pred (op =) \<phi> (Inl (a,p)) (Inl (a',p')) \<longleftrightarrow> a = a' \<and> \<phi> p p'"
+"processBNF_pred (op =) \<phi> (Inr (p,q)) (Inr (p',q')) \<longleftrightarrow> \<phi> p p' \<and> \<phi> q q'"
+"\<not> processBNF_pred (op =) \<phi> (Inl ap) (Inr q1q2)"
+"\<not> processBNF_pred (op =) \<phi> (Inr q1q2) (Inl ap)"
+by (auto simp: diag_def processBNF.pred_unfold)
+
+
+subsection{* Constructors *}
+
+definition Action :: "'a \<Rightarrow> 'a process \<Rightarrow> 'a process"
+where "Action a p \<equiv> process_fld (Inl (a,p))"
+
+definition Choice :: "'a process \<Rightarrow> 'a process \<Rightarrow> 'a process"
+where "Choice p1 p2 \<equiv> process_fld (Inr (p1,p2))"
+
+lemmas ctor_defs = Action_def Choice_def
+
+
+subsection {* Discriminators *}
+
+(* One discriminator for each constructor. By the constructor exhaustiveness,
+one of them is of course redundant, so for n constructors we only need n-1
+discriminators. However, keeping n discriminators seems more uniform.   *)
+
+definition isAction :: "'a process \<Rightarrow> bool"
+where "isAction q \<equiv> \<exists> a p. q = Action a p"
+
+definition isChoice :: "'a process \<Rightarrow> bool"
+where "isChoice q \<equiv> \<exists> p1 p2. q = Choice p1 p2"
+
+lemmas discr_defs = isAction_def isChoice_def
+
+
+subsection {* Pre-selectors *}
+
+(* These are mere auxiliaries *)
+
+definition "asAction q \<equiv> SOME ap. q = Action (fst ap) (snd ap)"
+definition "asChoice q \<equiv> SOME p1p2. q = Choice (fst p1p2) (snd p1p2)"
+lemmas pre_sel_defs = asAction_def asChoice_def
+
+
+subsection {* Selectors *}
+
+(* One for each pair (constructor, constructor argument) *)
+
+(* For Action: *)
+definition prefOf :: "'a process \<Rightarrow> 'a" where "prefOf q = fst (asAction q)"
+definition contOf :: "'a process \<Rightarrow> 'a process" where "contOf q = snd (asAction q)"
+
+(* For Choice: *)
+definition ch1Of :: "'a process \<Rightarrow> 'a process" where "ch1Of q = fst (asChoice q)"
+definition ch2Of :: "'a process \<Rightarrow> 'a process" where "ch2Of q = snd (asChoice q)"
+
+lemmas sel_defs = prefOf_def contOf_def ch1Of_def ch2Of_def
+
+
+subsection {* Basic properties *}
+
+(* Selectors versus discriminators *)
+lemma isAction_asAction:
+"isAction q \<longleftrightarrow> q = Action (fst (asAction q)) (snd (asAction q))"
+(is "?L \<longleftrightarrow> ?R")
+proof
+  assume ?L
+  then obtain a p where q: "q = Action a p" unfolding isAction_def by auto
+  show ?R unfolding asAction_def q by (rule someI[of _ "(a,p)"]) simp
+qed(unfold isAction_def, auto)
+
+theorem isAction_prefOf_contOf:
+"isAction q \<longleftrightarrow> q = Action (prefOf q) (contOf q)"
+using isAction_asAction unfolding prefOf_def contOf_def .
+
+lemma isChoice_asChoice:
+"isChoice q \<longleftrightarrow> q = Choice (fst (asChoice q)) (snd (asChoice q))"
+(is "?L \<longleftrightarrow> ?R")
+proof
+  assume ?L
+  then obtain p1 p2 where q: "q = Choice p1 p2" unfolding isChoice_def by auto
+  show ?R unfolding asChoice_def q by (rule someI[of _ "(p1,p2)"]) simp
+qed(unfold isChoice_def, auto)
+
+theorem isChoice_ch1Of_ch2Of:
+"isChoice q \<longleftrightarrow> q = Choice (ch1Of q) (ch2Of q)"
+using isChoice_asChoice unfolding ch1Of_def ch2Of_def .
+
+(* Constructors *)
+theorem process_simps[simp]:
+"Action a p = Action a' p' \<longleftrightarrow> a = a' \<and> p = p'"
+"Choice p1 p2 = Choice p1' p2' \<longleftrightarrow> p1 = p1' \<and> p2 = p2'"
+(*  *)
+"Action a p \<noteq> Choice p1 p2"
+"Choice p1 p2 \<noteq> Action a p"
+unfolding ctor_defs process.fld_inject by auto
+
+theorem process_cases[elim, case_names Action Choice]:
+assumes Action: "\<And> a p. q = Action a p \<Longrightarrow> phi"
+and Choice: "\<And> p1 p2. q = Choice p1 p2 \<Longrightarrow> phi"
+shows phi
+proof(cases rule: process.fld_exhaust[of q])
+  fix x assume "q = process_fld x"
+  thus ?thesis
+  apply(cases x)
+    apply(case_tac a) using Action unfolding ctor_defs apply blast
+    apply(case_tac b) using Choice unfolding ctor_defs apply blast
+  done
+qed
+
+(* Constructors versus discriminators *)
+theorem isAction_isChoice:
+"isAction p \<or> isChoice p"
+unfolding isAction_def isChoice_def by (cases rule: process_cases) auto
+
+theorem isAction_Action[simp]: "isAction (Action a p)"
+unfolding isAction_def by auto
+
+theorem isAction_Choice[simp]: "\<not> isAction (Choice p1 p2)"
+unfolding isAction_def by auto
+
+theorem isChoice_Choice[simp]: "isChoice (Choice p1 p2)"
+unfolding isChoice_def by auto
+
+theorem isChoice_Action[simp]: "\<not> isChoice (Action a p)"
+unfolding isChoice_def by auto
+
+theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
+by (cases rule: process_cases[of p]) auto
+
+(* Constructors versus selectors *)
+theorem dest_ctor[simp]:
+"prefOf (Action a p) = a"
+"contOf (Action a p) = p"
+"ch1Of (Choice p1 p2) = p1"
+"ch2Of (Choice p1 p2) = p2"
+using isAction_Action[of a p]
+      isChoice_Choice[of p1 p2]
+unfolding isAction_prefOf_contOf
+          isChoice_ch1Of_ch2Of by auto
+
+theorem ctor_dtor[simp]:
+"\<And> p. isAction p \<Longrightarrow> Action (prefOf p) (contOf p) = p"
+"\<And> p. isChoice p \<Longrightarrow> Choice (ch1Of p) (ch2Of p) = p"
+unfolding isAction_def isChoice_def by auto
+
+
+subsection{* Coinduction *}
+
+theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
+assumes phi: "\<phi> p p'" and
+iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
+Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
+Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
+shows "p = p'"
+proof(intro mp[OF process.pred_coinduct, of \<phi>, OF _ phi], clarify)
+  fix p p'  assume \<phi>: "\<phi> p p'"
+  show "processBNF_pred (op =) \<phi> (process_unf p) (process_unf p')"
+  proof(cases rule: process_cases[of p])
+    case (Action a q) note p = Action
+    hence "isAction p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
+    then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process_cases[of p'], auto)
+    have 0: "a = a' \<and> \<phi> q q'" using Act[OF \<phi>[unfolded p p']] .
+    have unf: "process_unf p = Inl (a,q)" "process_unf p' = Inl (a',q')"
+    unfolding p p' Action_def process.unf_fld by simp_all
+    show ?thesis using 0 unfolding unf by simp
+  next
+    case (Choice p1 p2) note p = Choice
+    hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
+    then obtain p1' p2' where p': "p' = Choice p1' p2'"
+    by (cases rule: process_cases[of p'], auto)
+    have 0: "\<phi> p1 p1' \<and> \<phi> p2 p2'" using Ch[OF \<phi>[unfolded p p']] .
+    have unf: "process_unf p = Inr (p1,p2)" "process_unf p' = Inr (p1',p2')"
+    unfolding p p' Choice_def process.unf_fld by simp_all
+    show ?thesis using 0 unfolding unf by simp
+  qed
+qed
+
+(* Stronger coinduction, up to equality: *)
+theorem process_coind_upto[elim, consumes 1, case_names iss Action Choice]:
+assumes phi: "\<phi> p p'" and
+iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
+Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
+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')"
+shows "p = p'"
+proof(intro mp[OF process.pred_coinduct_upto, of \<phi>, OF _ phi], clarify)
+  fix p p'  assume \<phi>: "\<phi> p p'"
+  show "processBNF_pred (op =) (\<lambda>a b. \<phi> a b \<or> a = b) (process_unf p) (process_unf p')"
+  proof(cases rule: process_cases[of p])
+    case (Action a q) note p = Action
+    hence "isAction p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
+    then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process_cases[of p'], auto)
+    have 0: "a = a' \<and> (\<phi> q q' \<or> q = q')" using Act[OF \<phi>[unfolded p p']] .
+    have unf: "process_unf p = Inl (a,q)" "process_unf p' = Inl (a',q')"
+    unfolding p p' Action_def process.unf_fld by simp_all
+    show ?thesis using 0 unfolding unf by simp
+  next
+    case (Choice p1 p2) note p = Choice
+    hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process_cases[of p'], auto)
+    then obtain p1' p2' where p': "p' = Choice p1' p2'"
+    by (cases rule: process_cases[of p'], auto)
+    have 0: "(\<phi> p1 p1' \<or> p1 = p1') \<and> (\<phi> p2 p2' \<or> p2 = p2')" using Ch[OF \<phi>[unfolded p p']] .
+    have unf: "process_unf p = Inr (p1,p2)" "process_unf p' = Inr (p1',p2')"
+    unfolding p p' Choice_def process.unf_fld by simp_all
+    show ?thesis using 0 unfolding unf by simp
+  qed
+qed
+
+
+subsection {* Coiteration and corecursion *}
+
+(* Preliminaries: *)
+definition
+"join22 isA pr co isC c1 c2 \<equiv>
+ \<lambda> P. if isA P then Inl (pr P, co P)
+ else if isC P then Inr (c1 P, c2 P)
+ else undefined"
+
+declare process.unf_fld[simp]
+declare process.fld_unf[simp]
+
+lemma unf_Action[simp]:
+"process_unf (Action a p) = Inl (a,p)"
+unfolding Action_def process.unf_fld ..
+
+lemma unf_Choice[simp]:
+"process_unf (Choice p1 p2) = Inr (p1,p2)"
+unfolding Choice_def process.unf_fld ..
+
+lemma isAction_unf:
+assumes "isAction p"
+shows "process_unf p = Inl (prefOf p, contOf p)"
+using assms unfolding isAction_def by auto
+
+lemma isChoice_unf:
+assumes "isChoice p"
+shows "process_unf p = Inr (ch1Of p, ch2Of p)"
+using assms unfolding isChoice_def by auto
+
+lemma unf_join22:
+"process_unf p = join22 isAction prefOf contOf isChoice ch1Of ch2Of p"
+unfolding join22_def
+using isAction_unf isChoice_unf not_isAction_isChoice isAction_isChoice by auto
+
+lemma isA_join22:
+assumes "isA P"
+shows "join22 isA pr co isC c1 c2 P = Inl (pr P, co P)"
+using assms unfolding join22_def by auto
+
+lemma isC_join22:
+assumes "\<not> isA P" and "isC P"
+shows "join22 isA pr co isC c1 c2 P = Inr (c1 P, c2 P)"
+using assms unfolding join22_def by auto
+
+(* Coiteration *)
+definition pcoiter ::
+"('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b)
+ \<Rightarrow>
+ ('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b)
+ \<Rightarrow>
+ 'b \<Rightarrow> 'a process"
+where "pcoiter isA pr co isC c1 c2 \<equiv> process_coiter (join22 isA pr co isC c1 c2)"
+
+lemma unf_prefOf:
+assumes "process_unf q = Inl (a,p)"
+shows "prefOf q = a"
+using assms by (cases rule: process_cases[of q]) auto
+
+lemma unf_contOf:
+assumes "process_unf q = Inl (a,p)"
+shows "contOf q = p"
+using assms by (cases rule: process_cases[of q]) auto
+
+lemma unf_ch1Of:
+assumes "process_unf q = Inr (p1,p2)"
+shows "ch1Of q = p1"
+using assms by (cases rule: process_cases[of q]) auto
+
+lemma unf_ch2Of:
+assumes "process_unf q = Inr (p1,p2)"
+shows "ch2Of q = p2"
+using assms by (cases rule: process_cases[of q]) auto
+
+theorem pcoiter:
+"\<And>P. isA P \<Longrightarrow>
+    pcoiter isA pr co isC c1 c2 P =
+    Action (pr P)
+           (pcoiter isA pr co isC c1 c2 (co P))"
+"\<And>P. \<lbrakk>\<not> isA P; isC P\<rbrakk> \<Longrightarrow>
+    pcoiter isA pr co isC c1 c2 P =
+    Choice (pcoiter isA pr co isC c1 c2 (c1 P))
+           (pcoiter isA pr co isC c1 c2 (c2 P))"
+proof-
+  fix P
+  let ?f = "pcoiter isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
+  assume isA: "isA P"
+  have unf: "process_unf (process_coiter ?s P) = Inl (pr P, ?f (co P))"
+  using process.coiter[of ?s P]
+  unfolding isA_join22[of isA P "pr" co isC c1 c2, OF isA]
+            processBNF_map id_apply pcoiter_def .
+  thus "?f P = Action (pr P) (?f (co P))"
+  unfolding pcoiter_def Action_def using process.fld_unf by metis
+next
+  fix P
+  let ?f = "pcoiter isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
+  assume isA: "\<not> isA P" and isC: "isC P"
+  have unf: "process_unf (process_coiter ?s P) = Inr (?f (c1 P), ?f (c2 P))"
+  using process.coiter[of ?s P]
+  unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
+            processBNF_map id_apply pcoiter_def .
+  thus "?f P = Choice (?f (c1 P)) (?f (c2 P))"
+  unfolding pcoiter_def Choice_def using process.fld_unf by metis
+qed
+
+(* Corecursion, more general than coiteration (often unnecessarily more general): *)
+definition pcorec ::
+"('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'a process + 'b)
+ \<Rightarrow>
+ ('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a process + 'b) \<Rightarrow> ('b \<Rightarrow> 'a process + 'b)
+ \<Rightarrow>
+ 'b \<Rightarrow> 'a process"
+where
+"pcorec isA pr co isC c1 c2 \<equiv> process_corec (join22 isA pr co isC c1 c2)"
+
+theorem pcorec_Action:
+assumes isA: "isA P"
+shows
+"case co P of
+   Inl p \<Rightarrow> pcorec isA pr co isC c1 c2 P = Action (pr P) p
+  |Inr Q \<Rightarrow> pcorec isA pr co isC c1 c2 P =
+            Action (pr P)
+                   (pcorec isA pr co isC c1 c2 Q)"
+proof-
+  let ?f = "pcorec isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
+  show ?thesis
+  proof(cases "co P")
+    case (Inl p)
+    have "process_unf (process_corec ?s P) = Inl (pr P, p)"
+    using process.corec[of ?s P]
+    unfolding isA_join22[of isA P "pr" co isC c1 c2, OF isA]
+              processBNF_map id_apply pcorec_def Inl by simp
+    thus ?thesis unfolding Inl pcorec_def Action_def using process.fld_unf by (simp, metis)
+  next
+    case (Inr Q)
+    have "process_unf (process_corec ?s P) = Inl (pr P, ?f Q)"
+    using process.corec[of ?s P]
+    unfolding isA_join22[of isA P "pr" co isC c1 c2, OF isA]
+              processBNF_map id_apply pcorec_def Inr by simp
+    thus ?thesis unfolding Inr pcorec_def Action_def using process.fld_unf by (simp, metis)
+  qed
+qed
+
+theorem pcorec_Choice:
+assumes isA: "\<not> isA P" and isC: "isC P"
+shows
+"case (c1 P,c2 P) of
+   (Inl p1, Inl p2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
+                      Choice p1 p2
+  |(Inl p1, Inr Q2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
+                      Choice p1
+                             (pcorec isA pr co isC c1 c2 Q2)
+  |(Inr Q1, Inl p2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
+                      Choice (pcorec isA pr co isC c1 c2 Q1)
+                             p2
+  |(Inr Q1, Inr Q2) \<Rightarrow> pcorec isA pr co isC c1 c2 P =
+                      Choice (pcorec isA pr co isC c1 c2 Q1)
+                             (pcorec isA pr co isC c1 c2 Q2)"
+proof-
+  let ?f = "pcorec isA pr co isC c1 c2"  let ?s = "join22 isA pr co isC c1 c2"
+  show ?thesis
+  proof(cases "c1 P")
+    case (Inl p1) note c1 = Inl
+    show ?thesis
+    proof(cases "c2 P")
+      case (Inl p2)  note c2 = Inl
+      have "process_unf (process_corec ?s P) = Inr (p1, p2)"
+      using process.corec[of ?s P]
+      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
+                processBNF_map id_apply pcorec_def c1 c2 by simp
+      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
+    next
+      case (Inr Q2)  note c2 = Inr
+      have "process_unf (process_corec ?s P) = Inr (p1, ?f Q2)"
+      using process.corec[of ?s P]
+      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
+                processBNF_map id_apply pcorec_def c1 c2 by simp
+      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
+    qed
+  next
+    case (Inr Q1) note c1 = Inr
+    show ?thesis
+    proof(cases "c2 P")
+      case (Inl p2)  note c2 = Inl
+      have "process_unf (process_corec ?s P) = Inr (?f Q1, p2)"
+      using process.corec[of ?s P]
+      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
+                processBNF_map id_apply pcorec_def c1 c2 by simp
+      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
+    next
+      case (Inr Q2)  note c2 = Inr
+      have "process_unf (process_corec ?s P) = Inr (?f Q1, ?f Q2)"
+      using process.corec[of ?s P]
+      unfolding isC_join22[of isA P isC "pr" co c1 c2, OF isA isC]
+                processBNF_map id_apply pcorec_def c1 c2 by simp
+      thus ?thesis unfolding c1 c2 pcorec_def Choice_def using process.fld_unf by (simp, metis)
+    qed
+  qed
+qed
+
+theorems pcorec = pcorec_Action pcorec_Choice
+
+
+section{* Coinductive definition of the notion of trace *}
+
+(* Say we have a type of streams: *)
+typedecl 'a stream
+consts Ccons :: "'a \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
+
+(* Use the existing coinductive package (distinct from our
+new codatatype package, but highly compatible with it): *)
+
+coinductive trace where
+"trace p as \<Longrightarrow> trace (Action a p) (Ccons a as)"
+|
+"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
+
+
+section{* Examples of corecursive definitions: *}
+
+subsection{* Single-guard fixpoint definition *}
+
+definition
+"BX \<equiv>
+ pcoiter
+   (\<lambda> P. True)
+   (\<lambda> P. ''a'')
+   (\<lambda> P. P)
+   undefined
+   undefined
+   undefined
+   ()"
+
+lemma BX: "BX = Action ''a'' BX"
+unfolding BX_def
+using pcoiter(1)[of "\<lambda> P. True" "()"  "\<lambda> P. ''a''" "\<lambda> P. P"] by simp
+
+
+subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
+
+datatype x_y_ax = x | y | ax
+
+definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False     |y \<Rightarrow> True  |ax \<Rightarrow> True"
+definition "pr  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
+definition "co  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x    |ax \<Rightarrow> x"
+lemmas Action_defs = isA_def pr_def co_def
+
+definition "isC \<equiv> \<lambda> K. case K of x \<Rightarrow> True |y \<Rightarrow> False     |ax \<Rightarrow> False"
+definition "c1  \<equiv> \<lambda> K. case K of x \<Rightarrow> ax   |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
+definition "c2  \<equiv> \<lambda> K. case K of x \<Rightarrow> y    |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
+lemmas Choice_defs = isC_def c1_def c2_def
+
+definition "F \<equiv> pcoiter isA pr co isC c1 c2"
+definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
+
+lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
+unfolding X_def Y_def AX_def F_def
+using pcoiter(2)[of isA x isC "pr" co c1 c2]
+      pcoiter(1)[of isA y  "pr" co isC c1 c2]
+      pcoiter(1)[of isA ax "pr" co isC c1 c2]
+unfolding Action_defs Choice_defs by simp_all
+
+(* end product: *)
+lemma X_AX:
+"X = Choice AX (Action ''b'' X)"
+"AX = Action ''a'' X"
+using X_Y_AX by simp_all
+
+
+
+section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
+
+hide_const x y ax X Y AX
+
+(* Process terms *)
+datatype ('a,'pvar) process_term =
+ VAR 'pvar |
+ PROC "'a process" |
+ ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
+
+(* below, sys represents a system of equations *)
+fun isACT where
+"isACT sys (VAR X) =
+ (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
+|
+"isACT sys (PROC p) = isAction p"
+|
+"isACT sys (ACT a T) = True"
+|
+"isACT sys (CH T1 T2) = False"
+
+fun PREF where
+"PREF sys (VAR X) =
+ (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
+|
+"PREF sys (PROC p) = prefOf p"
+|
+"PREF sys (ACT a T) = a"
+
+fun CONT where
+"CONT sys (VAR X) =
+ (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
+|
+"CONT sys (PROC p) = PROC (contOf p)"
+|
+"CONT sys (ACT a T) = T"
+
+fun isCH where
+"isCH sys (VAR X) =
+ (case sys X of CH T1 T2 \<Rightarrow> True |PROC p \<Rightarrow> isChoice p |_ \<Rightarrow> False)"
+|
+"isCH sys (PROC p) = isChoice p"
+|
+"isCH sys (ACT a T) = False"
+|
+"isCH sys (CH T1 T2) = True"
+
+fun CH1 where
+"CH1 sys (VAR X) =
+ (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
+|
+"CH1 sys (PROC p) = PROC (ch1Of p)"
+|
+"CH1 sys (CH T1 T2) = T1"
+
+fun CH2 where
+"CH2 sys (VAR X) =
+ (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
+|
+"CH2 sys (PROC p) = PROC (ch2Of p)"
+|
+"CH2 sys (CH T1 T2) = T2"
+
+definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
+
+lemma guarded_isACT_isCH:
+assumes g: "guarded sys"
+shows "isACT sys T \<or> isCH sys T"
+proof(induct T)
+  case (VAR X)
+  thus ?case
+  using g isAction_isChoice unfolding guarded_def by (cases "sys X", auto)
+qed(insert isAction_isChoice assms, unfold guarded_def, auto)
+
+definition
+"solution sys \<equiv>
+ pcoiter
+   (isACT sys)
+   (PREF sys)
+   (CONT sys)
+   (isCH sys)
+   (CH1 sys)
+   (CH2 sys)"
+
+lemma solution_Action:
+assumes "isACT sys T"
+shows "solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
+unfolding solution_def
+using pcoiter(1)[of "isACT sys" T "PREF sys" "CONT sys"
+                        "isCH sys" "CH1 sys" "CH2 sys"] assms by simp
+
+lemma solution_Choice:
+assumes "\<not> isACT sys T" "isCH sys T"
+shows "solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
+unfolding solution_def
+using pcoiter(2)[of "isACT sys" T "isCH sys" "PREF sys" "CONT sys"
+                        "CH1 sys" "CH2 sys"] assms by simp
+
+lemma isACT_VAR:
+assumes g: "guarded sys"
+shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
+using g unfolding guarded_def by (cases "sys X") auto
+
+lemma isCH_VAR:
+assumes g: "guarded sys"
+shows "isCH sys (VAR X) \<longleftrightarrow> isCH sys (sys X)"
+using g unfolding guarded_def by (cases "sys X") auto
+
+lemma solution_VAR:
+assumes g: "guarded sys"
+shows "solution sys (VAR X) = solution sys (sys X)"
+proof(cases "isACT sys (VAR X)")
+  case True
+  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
+  show ?thesis
+  unfolding solution_Action[OF T] using solution_Action[of sys "VAR X"] True g
+  unfolding guarded_def by (cases "sys X", auto)
+next
+  case False note FFalse = False
+  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
+  show ?thesis
+  proof(cases "isCH sys (VAR X)")
+    case True
+    hence T: "isCH sys (sys X)" unfolding isCH_VAR[OF g] .
+    show ?thesis
+    unfolding solution_Choice[OF TT T] using solution_Choice[of sys "VAR X"] FFalse True g
+    unfolding guarded_def by (cases "sys X", auto)
+  next
+    case False
+    hence False using FFalse guarded_isACT_isCH[OF g, of "VAR X"] by simp
+    thus ?thesis by simp
+  qed
+qed
+
+lemma solution_PROC[simp]:
+"solution sys (PROC p) = p"
+proof-
+  {fix q assume "q = solution sys (PROC p)"
+   hence "p = q"
+   proof(induct rule: process_coind)
+     case (iss p p')
+     from isAction_isChoice[of p] show ?case
+     proof
+       assume p: "isAction p"
+       hence 0: "isACT sys (PROC p)" by simp
+       thus ?thesis using iss not_isAction_isChoice
+       unfolding solution_Action[OF 0] by auto
+     next
+       assume "isChoice p"
+       hence 0: "isCH sys (PROC p)" and p: "\<not> isAction p"
+       using not_isAction_isChoice by auto
+       hence 1: "\<not> isACT sys (PROC p)" by simp
+       show ?thesis using 0 iss not_isAction_isChoice
+       unfolding solution_Choice[OF 1 0] by auto
+     qed
+   next
+     case (Action a a' p p')
+     hence 0: "isACT sys (PROC (Action a p))" by simp
+     show ?case using Action unfolding solution_Action[OF 0] by simp
+   next
+     case (Choice p q p' q')
+     hence 0: "isCH sys (PROC (Choice p q))" by simp
+     hence 1: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
+     show ?case using Choice unfolding solution_Choice[OF 1 0] by simp
+   qed
+  }
+  thus ?thesis by metis
+qed
+
+lemma solution_ACT[simp]:
+"solution sys (ACT a T) = Action a (solution sys T)"
+by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution_Action)
+
+lemma solution_CH[simp]:
+"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
+by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) isCH.simps(4) solution_Choice)
+
+
+(* Example: *)
+
+fun sys where
+"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
+|
+"sys (Suc 0) = ACT ''a'' (VAR 0)"
+| (* dummy guarded term for variables outside the system: *)
+"sys X = ACT ''a'' (VAR 0)"
+
+lemma guarded_sys:
+"guarded sys"
+unfolding guarded_def proof (intro allI)
+  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
+qed
+
+(* the actual processes: *)
+definition "x \<equiv> solution sys (VAR 0)"
+definition "ax \<equiv> solution sys (VAR (Suc 0))"
+
+(* end product: *)
+lemma x_ax:
+"x = Choice ax (Action ''b'' x)"
+"ax = Action ''a'' x"
+unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
+
+
+(* Thanks to the inclusion of processes as process terms, one can
+also consider parametrized systems of equations---here, x is a (semantic)
+process parameter: *)
+
+fun sys' where
+"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
+|
+"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
+| (* dummy guarded term : *)
+"sys' X = ACT ''a'' (VAR 0)"
+
+lemma guarded_sys':
+"guarded sys'"
+unfolding guarded_def proof (intro allI)
+  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
+qed
+
+(* the actual processes: *)
+definition "y \<equiv> solution sys' (VAR 0)"
+definition "ay \<equiv> solution sys' (VAR (Suc 0))"
+
+(* end product: *)
+lemma y_ay:
+"y = Choice x (Action ''b'' y)"
+"ay = Choice (Action ''a'' y) x"
+unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/Stream.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,159 @@
+(*  Title:      Codatatype_Examples/Stream.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Infinite streams.
+*)
+
+header {* Infinite Streams *}
+
+theory Stream
+imports TreeFI
+begin
+
+bnf_codata stream: 's = "'a \<times> 's"
+
+(* selectors for streams *)
+definition "hdd as \<equiv> fst (stream_unf as)"
+definition "tll as \<equiv> snd (stream_unf as)"
+
+lemma coiter_pair_fun_hdd[simp]: "hdd (stream_coiter (f \<odot> g) t) = f t"
+unfolding hdd_def pair_fun_def stream.coiter by simp
+
+lemma coiter_pair_fun_tll[simp]: "tll (stream_coiter (f \<odot> g) t) =
+ stream_coiter (f \<odot> g) (g t)"
+unfolding tll_def pair_fun_def stream.coiter by simp
+
+(* infinite trees: *)
+coinductive infiniteTr where
+"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
+
+lemma infiniteTr_coind_upto[consumes 1, case_names sub]:
+assumes *: "phi tr" and
+**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
+shows "infiniteTr tr"
+using assms by (elim infiniteTr.coinduct) blast
+
+lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
+assumes *: "phi tr" and
+**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
+shows "infiniteTr tr"
+using assms by (elim infiniteTr.coinduct) blast
+
+lemma infiniteTr_sub[simp]:
+"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
+by (erule infiniteTr.cases) blast
+
+definition "konigPath \<equiv> stream_coiter
+  (lab \<odot> (\<lambda>tr. SOME tr'. tr' \<in> listF_set (sub tr) \<and> infiniteTr tr'))"
+
+lemma hdd_simps1[simp]: "hdd (konigPath t) = lab t"
+unfolding konigPath_def by simp
+
+lemma tll_simps2[simp]: "tll (konigPath t) =
+  konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
+unfolding konigPath_def by simp
+
+(* proper paths in trees: *)
+coinductive properPath where
+"\<lbrakk>hdd as = lab tr; tr' \<in> listF_set (sub tr); properPath (tll as) tr'\<rbrakk> \<Longrightarrow>
+ properPath as tr"
+
+lemma properPath_coind_upto[consumes 1, case_names hdd_lab sub]:
+assumes *: "phi as tr" and
+**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
+***: "\<And> as tr.
+         phi as tr \<Longrightarrow>
+         \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
+shows "properPath as tr"
+using assms by (elim properPath.coinduct) blast
+
+lemma properPath_coind[consumes 1, case_names hdd_lab sub, induct pred: properPath]:
+assumes *: "phi as tr" and
+**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
+***: "\<And> as tr.
+         phi as tr \<Longrightarrow>
+         \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr'"
+shows "properPath as tr"
+using properPath_coind_upto[of phi, OF * **] *** by blast
+
+lemma properPath_hdd_lab:
+"properPath as tr \<Longrightarrow> hdd as = lab tr"
+by (erule properPath.cases) blast
+
+lemma properPath_sub:
+"properPath as tr \<Longrightarrow>
+ \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
+by (erule properPath.cases) blast
+
+(* prove the following by coinduction *)
+theorem Konig:
+  assumes "infiniteTr tr"
+  shows "properPath (konigPath tr) tr"
+proof-
+  {fix as
+   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
+   proof (induct rule: properPath_coind, safe)
+     fix t
+     let ?t = "SOME t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'"
+     assume "infiniteTr t"
+     hence "\<exists>t' \<in> listF_set (sub t). infiniteTr t'" by simp
+     hence "\<exists>t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'" by blast
+     hence "?t \<in> listF_set (sub t) \<and> infiniteTr ?t" by (elim someI_ex)
+     moreover have "tll (konigPath t) = konigPath ?t" by simp
+     ultimately show "\<exists>t' \<in> listF_set (sub t).
+             infiniteTr t' \<and> tll (konigPath t) = konigPath t'" by blast
+   qed simp
+  }
+  thus ?thesis using assms by blast
+qed
+
+(* some more stream theorems *)
+
+lemma stream_map[simp]: "stream_map f = stream_coiter (f o hdd \<odot> tll)"
+unfolding stream_map_def pair_fun_def hdd_def[abs_def] tll_def[abs_def]
+  map_pair_def o_def prod_case_beta by simp
+
+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))"
+by (auto simp: streamBNF.pred_unfold)
+
+lemmas stream_coind = mp[OF stream.pred_coinduct, unfolded streamBNF_pred[abs_def],
+  folded hdd_def tll_def]
+
+definition plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
+  [simp]: "plus xs ys =
+    stream_coiter ((%(xs, ys). hdd xs + hdd ys) \<odot> (%(xs, ys). (tll xs, tll ys))) (xs, ys)"
+
+definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
+  [simp]: "scalar n = stream_map (\<lambda>x. n * x)"
+
+definition ones :: "nat stream" where [simp]: "ones = stream_coiter ((%x. 1) \<odot> id) ()"
+definition twos :: "nat stream" where [simp]: "twos = stream_coiter ((%x. 2) \<odot> id) ()"
+definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
+
+lemma "ones \<oplus> ones = twos"
+by (intro stream_coind[where phi="%x1 x2. \<exists>x. x1 = ones \<oplus> ones \<and> x2 = twos"])
+   auto
+
+lemma "n \<cdot> twos = ns (2 * n)"
+by (intro stream_coind[where phi="%x1 x2. \<exists>n. x1 = n \<cdot> twos \<and> x2 = ns (2 * n)"])
+   force+
+
+lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
+by (intro stream_coind[where phi="%x1 x2. \<exists>n m xs. x1 = (n * m) \<cdot> xs \<and> x2 = n \<cdot> m \<cdot> xs"])
+   force+
+
+lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
+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"])
+   (force simp: add_mult_distrib2)+
+
+lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
+by (intro stream_coind[where phi="%x1 x2. \<exists>xs ys. x1 = xs \<oplus> ys \<and> x2 = ys \<oplus> xs"])
+   force+
+
+lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
+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"])
+   force+
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/TreeFI.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,81 @@
+(*  Title:      Codatatype_Examples/TreeFI.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Finitely branching possibly infinite trees.
+*)
+
+header {* Finitely Branching Possibly Infinite Trees *}
+
+theory TreeFI
+imports ListF
+begin
+
+bnf_codata treeFI: 'tree = "'a \<times> 'tree listF"
+
+lemma treeFIBNF_listF_set[simp]: "treeFIBNF_set2 (i, xs) = listF_set xs"
+unfolding treeFIBNF_set2_def collect_def[abs_def] prod_set_defs
+by (auto simp add: listF.set_natural')
+
+(* selectors for trees *)
+definition "lab tr \<equiv> fst (treeFI_unf tr)"
+definition "sub tr \<equiv> snd (treeFI_unf tr)"
+
+lemma unf[simp]: "treeFI_unf tr = (lab tr, sub tr)"
+unfolding lab_def sub_def by simp
+
+definition pair_fun (infixr "\<odot>" 50) where
+  "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
+
+lemma coiter_pair_fun_lab: "lab (treeFI_coiter (f \<odot> g) t) = f t"
+unfolding lab_def pair_fun_def treeFI.coiter treeFIBNF_map_def by simp
+
+lemma coiter_pair_fun_sub: "sub (treeFI_coiter (f \<odot> g) t) = listF_map (treeFI_coiter (f \<odot> g)) (g t)"
+unfolding sub_def pair_fun_def treeFI.coiter treeFIBNF_map_def by simp
+
+(* Tree reverse:*)
+definition "trev \<equiv> treeFI_coiter (lab \<odot> lrev o sub)"
+
+lemma trev_simps1[simp]: "lab (trev t) = lab t"
+unfolding trev_def by (simp add: coiter_pair_fun_lab)
+
+lemma trev_simps2[simp]: "sub (trev t) = listF_map trev (lrev (sub t))"
+unfolding trev_def by (simp add: coiter_pair_fun_sub)
+
+lemma treeFI_coinduct:
+assumes *: "phi x y"
+and step: "\<And>a b. phi a b \<Longrightarrow>
+   lab a = lab b \<and>
+   lengthh (sub a) = lengthh (sub b) \<and>
+   (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
+shows "x = y"
+proof (rule mp[OF treeFI.unf_coinduct, of phi, OF _ *])
+  fix a b :: "'a treeFI"
+  let ?zs = "zipp (sub a) (sub b)"
+  let ?z = "(lab a, ?zs)"
+  assume "phi a b"
+  with step have step': "lab a = lab b" "lengthh (sub a) = lengthh (sub b)"
+    "\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i)" by auto
+  hence "treeFIBNF_map id fst ?z = treeFI_unf a" "treeFIBNF_map id snd ?z = treeFI_unf b"
+    unfolding treeFIBNF_map_def by auto
+  moreover have "\<forall>(x, y) \<in> treeFIBNF_set2 ?z. phi x y"
+  proof safe
+    fix z1 z2
+    assume "(z1, z2) \<in> treeFIBNF_set2 ?z"
+    hence "(z1, z2) \<in> listF_set ?zs" by auto
+    hence "\<exists>i < lengthh ?zs. nthh ?zs i = (z1, z2)" by auto
+    with step'(2) obtain i where "i < lengthh (sub a)"
+      "nthh (sub a) i = z1" "nthh (sub b) i = z2" by auto
+    with step'(3) show "phi z1 z2" by auto
+  qed
+  ultimately show "\<exists>z.
+    (treeFIBNF_map id fst z = treeFI_unf a \<and>
+    treeFIBNF_map id snd z = treeFI_unf b) \<and>
+    (\<forall>x y. (x, y) \<in> treeFIBNF_set2 z \<longrightarrow> phi x y)" by blast
+qed
+
+lemma trev_trev: "trev (trev tr) = tr"
+by (rule treeFI_coinduct[of "%a b. trev (trev b) = a"]) auto
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Examples/TreeFsetI.thy	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,56 @@
+(*  Title:      Codatatype_Examples/TreeFsetI.thy
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Andrei Popescu, TU Muenchen
+    Copyright   2012
+
+Finitely branching possibly infinite trees, with sets of children.
+*)
+
+header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
+
+theory TreeFsetI
+imports "../Codatatype/Codatatype"
+begin
+
+definition pair_fun (infixr "\<odot>" 50) where
+  "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
+
+bnf_codata treeFsetI: 't = "'a \<times> 't fset"
+
+(* selectors for trees *)
+definition "lab t \<equiv> fst (treeFsetI_unf t)"
+definition "sub t \<equiv> snd (treeFsetI_unf t)"
+
+lemma unf[simp]: "treeFsetI_unf t = (lab t, sub t)"
+unfolding lab_def sub_def by simp
+
+lemma coiter_pair_fun_lab: "lab (treeFsetI_coiter (f \<odot> g) t) = f t"
+unfolding lab_def pair_fun_def treeFsetI.coiter treeFsetIBNF_map_def by simp
+
+lemma coiter_pair_fun_sub: "sub (treeFsetI_coiter (f \<odot> g) t) = map_fset (treeFsetI_coiter (f \<odot> g)) (g t)"
+unfolding sub_def pair_fun_def treeFsetI.coiter treeFsetIBNF_map_def by simp
+
+(* tree map (contrived example): *)
+definition "tmap f \<equiv> treeFsetI_coiter (f o lab \<odot> sub)"
+
+lemma tmap_simps1[simp]: "lab (tmap f t) = f (lab t)"
+unfolding tmap_def by (simp add: coiter_pair_fun_lab)
+
+lemma trev_simps2[simp]: "sub (tmap f t) = map_fset (tmap f) (sub t)"
+unfolding tmap_def by (simp add: coiter_pair_fun_sub)
+
+lemma treeFsetIBNF_pred[simp]: "treeFsetIBNF_pred R1 R2 a b = (R1 (fst a) (fst b) \<and>
+  (\<forall>t \<in> fset (snd a). (\<exists>u \<in> fset (snd b). R2 t u)) \<and>
+  (\<forall>t \<in> fset (snd b). (\<exists>u \<in> fset (snd a). R2 u t)))"
+apply (cases a)
+apply (cases b)
+apply (simp add: treeFsetIBNF.pred_unfold)
+done
+
+lemmas treeFsetI_coind = mp[OF treeFsetI.pred_coinduct]
+
+lemma "tmap (f o g) x = tmap f (tmap g x)"
+by (intro treeFsetI_coind[where phi="%x1 x2. \<exists>x. x1 = tmap (f o g) x \<and> x2 = tmap f (tmap g x)"])
+   force+
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/README.html	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,58 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+
+<html>
+
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+  <title>Codatatype Package</title>
+</head>
+
+<body>
+
+<h3><i>Codatatype</i>: A (co)datatype package based on bounded natural functors
+(BNFs)</h3>
+
+<p>
+The <i>Codatatype</i> package provides a fully modular framework for
+constructing inductive and coinductive datatypes in HOL, with support for mixed
+mutual and nested (co)recursion. Mixed (co)recursion enables type definitions
+involving both datatypes and codatatypes, such as the type of finitely branching
+trees of possibly infinite depth. The framework draws heavily from category
+theory.
+
+<p>
+The package is described in the following paper:
+
+<ul>
+  <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>
+  Dmitriy Traytel, Andrei Popescu, and Jasmin Christian Blanchette.<br>
+  <i>Logic in Computer Science (LICS 2012)</i>, 2012.
+</ul>
+
+<p>
+The main entry point for applications is <tt>Codatatype.thy</tt>.
+The <tt>Examples</tt> directory contains various examples of (co)datatypes,
+including the examples from the paper.
+
+<p>
+The key notion underlying the package is that of a <i>bounded natural functor</i>
+(<i>BNF</i>)&mdash;an enriched type constructor satisfying specific properties
+preserved by interesting categorical operations (composition, least fixed point,
+and greatest fixed point). The <tt>Basic_BNFs.thy</tt> file registers
+various basic types, notably for sums, products, function spaces, finite sets,
+multisets, and countable sets. Custom BNFs can be registered as well.
+
+<p>
+<b>Warning:</b> The package is under development. Future versions are expected
+to support multiple constructors and selectors per (co)datatype (instead of a
+single <i>fld</i> or <i>unf</i> constant) and provide a nicer syntax for
+(co)datatype and (co)recursive function definitions. Please contact
+any of
+<a href="mailto:traytel@in.tum.de">the</a>
+<a href="mailto:popescua@in.tum.de">above</a>
+<a href="mailto:blanchette@in.tum.de">authors</a>
+if you have questions or comments.
+
+</body>
+
+</html>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Tools/bnf_comp.ML	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,834 @@
+(*  Title:      HOL/Codatatype/Tools/bnf_comp.ML
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Jasmin Blanchette, TU Muenchen
+    Copyright   2012
+
+Composition of bounded natural functors.
+*)
+
+signature BNF_COMP =
+sig
+  type unfold_thms
+  val empty_unfold: unfold_thms
+  val map_unfolds_of: unfold_thms -> thm list
+  val set_unfoldss_of: unfold_thms -> thm list list
+  val rel_unfolds_of: unfold_thms -> thm list
+  val pred_unfolds_of: unfold_thms -> thm list
+
+  val default_comp_sort: (string * sort) list list -> (string * sort) list
+  val bnf_of_typ: BNF_Def.const_policy -> binding -> (binding -> binding) ->
+    ((string * sort) list list -> (string * sort) list) -> typ -> unfold_thms * Proof.context ->
+    (BNF_Def.BNF * (typ list * typ list)) * (unfold_thms * Proof.context)
+  val bnf_of_typ_cmd: binding * string -> Proof.context -> Proof.context
+  val seal_bnf: unfold_thms -> binding -> typ list -> BNF_Def.BNF -> Proof.context ->
+    BNF_Def.BNF * local_theory
+  val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
+    (''a list list -> ''a list) -> BNF_Def.BNF list -> unfold_thms -> Proof.context ->
+    (int list list * ''a list) * (BNF_Def.BNF list * (unfold_thms * Proof.context))
+end;
+
+structure BNF_Comp : BNF_COMP =
+struct
+
+open BNF_Def
+open BNF_Util
+open BNF_Tactics
+open BNF_Comp_Tactics
+
+type unfold_thms = {
+  map_unfolds: thm list,
+  set_unfoldss: thm list list,
+  rel_unfolds: thm list,
+  pred_unfolds: thm list
+};
+
+fun add_to_thms thms NONE = thms
+  | add_to_thms thms (SOME new) = if Thm.is_reflexive new then thms else insert Thm.eq_thm new thms;
+fun adds_to_thms thms NONE = thms
+  | adds_to_thms thms (SOME news) = insert (eq_set Thm.eq_thm) (filter_refl news) thms;
+
+fun mk_unfold_thms maps setss rels preds =
+  {map_unfolds = maps, set_unfoldss = setss, rel_unfolds = rels, pred_unfolds = preds};
+
+val empty_unfold = mk_unfold_thms [] [] [] [];
+
+fun add_to_unfold_opt map_opt sets_opt rel_opt pred_opt
+  {map_unfolds = maps, set_unfoldss = setss, rel_unfolds = rels, pred_unfolds = preds} = {
+    map_unfolds = add_to_thms maps map_opt,
+    set_unfoldss = adds_to_thms setss sets_opt,
+    rel_unfolds = add_to_thms rels rel_opt,
+    pred_unfolds = add_to_thms preds pred_opt};
+
+fun add_to_unfold map sets rel pred =
+  add_to_unfold_opt (SOME map) (SOME sets) (SOME rel) (SOME pred);
+
+val map_unfolds_of = #map_unfolds;
+val set_unfoldss_of = #set_unfoldss;
+val rel_unfolds_of = #rel_unfolds;
+val pred_unfolds_of = #pred_unfolds;
+
+val bdTN = "bdT";
+
+val compN = "comp_"
+fun mk_killN n = "kill" ^ string_of_int n ^ "_";
+fun mk_liftN n = "lift" ^ string_of_int n ^ "_";
+fun mk_permuteN src dest =
+  "permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest) ^ "_";
+
+val no_thm = refl;
+val Collect_split_box_equals = box_equals RS @{thm Collect_split_cong};
+val abs_pred_sym = sym RS @{thm abs_pred_def};
+val abs_pred_sym_pred_abs = abs_pred_sym RS @{thm pred_def_abs};
+
+(*copied from Envir.expand_term_free*)
+fun expand_term_const defs =
+  let
+    val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
+    val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
+  in Envir.expand_term get end;
+
+fun clean_compose_bnf const_policy qualify b outer inners (unfold, lthy) =
+  let
+    val olive = live_of_bnf outer;
+    val onwits = nwits_of_bnf outer;
+    val odead = dead_of_bnf outer;
+    val inner = hd inners;
+    val ilive = live_of_bnf inner;
+    val ideads = map dead_of_bnf inners;
+    val inwitss = map nwits_of_bnf inners;
+
+    (* TODO: check olive = length inners > 0,
+                   forall inner from inners. ilive = live,
+                   forall inner from inners. idead = dead  *)
+
+    val (oDs, lthy1) = apfst (map TFree)
+      (Variable.invent_types (replicate odead HOLogic.typeS) lthy);
+    val (Dss, lthy2) = apfst (map (map TFree))
+        (fold_map Variable.invent_types (map (fn n => replicate n HOLogic.typeS) ideads) lthy1);
+    val (Ass, lthy3) = apfst (replicate ilive o map TFree)
+      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy2);
+    val As = if ilive > 0 then hd Ass else [];
+    val Ass_repl = replicate olive As;
+    val (Bs, _(*lthy4*)) = apfst (map TFree)
+      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy3);
+    val Bss_repl = replicate olive Bs;
+
+    val (((fs', Asets), xs), _(*names_lthy*)) = lthy
+      |> apfst snd o mk_Frees' "f" (map2 (curry (op -->)) As Bs)
+      ||>> mk_Frees "A" (map (HOLogic.mk_setT) As)
+      ||>> mk_Frees "x" As;
+
+    val CAs = map3 mk_T_of_bnf Dss Ass_repl inners;
+    val CCA = mk_T_of_bnf oDs CAs outer;
+    val CBs = map3 mk_T_of_bnf Dss Bss_repl inners;
+    val outer_sets = mk_sets_of_bnf (replicate olive oDs) (replicate olive CAs) outer;
+    val inner_setss = map3 mk_sets_of_bnf (map (replicate ilive) Dss) (replicate olive Ass) inners;
+    val inner_bds = map3 mk_bd_of_bnf Dss Ass_repl inners;
+    val outer_bd = mk_bd_of_bnf oDs CAs outer;
+
+    (*%f1 ... fn. outer.map (inner_1.map f1 ... fn) ... (inner_m.map f1 ... fn)*)
+    val comp_map = fold_rev Term.abs fs'
+      (Term.list_comb (mk_map_of_bnf oDs CAs CBs outer,
+        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound ((ilive - 1) downto 0))) o
+          mk_map_of_bnf Ds As Bs) Dss inners));
+
+    (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
+    (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
+    fun mk_comp_set i =
+      let
+        val (setTs, T) = `(replicate olive o HOLogic.mk_setT) (nth As i);
+        val outer_set = mk_collect
+          (mk_sets_of_bnf (replicate olive oDs) (replicate olive setTs) outer)
+          (mk_T_of_bnf oDs setTs outer --> HOLogic.mk_setT T);
+        val inner_sets = map (fn sets => nth sets i) inner_setss;
+        val outer_map = mk_map_of_bnf oDs CAs setTs outer;
+        val map_inner_sets = Term.list_comb (outer_map, inner_sets);
+        val collect_image = mk_collect
+          (map2 (fn f => fn set => HOLogic.mk_comp (mk_image f, set)) inner_sets outer_sets)
+          (CCA --> HOLogic.mk_setT T);
+      in
+        (Library.foldl1 HOLogic.mk_comp [mk_Union T, outer_set, map_inner_sets],
+        HOLogic.mk_comp (mk_Union T, collect_image))
+      end;
+
+    val (comp_sets, comp_sets_alt) = map_split mk_comp_set (0 upto ilive - 1);
+
+    (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
+    val comp_bd = Term.absdummy CCA (mk_cprod
+      (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd);
+
+    fun comp_map_id_tac {context = ctxt, ...} =
+      let
+        (*order the theorems by reverse size to prevent bad interaction with nonconfluent rewrite
+          rules*)
+        val thms = (map map_id_of_bnf inners
+          |> map (`(Term.size_of_term o Thm.prop_of))
+          |> sort (rev_order o int_ord o pairself fst)
+          |> map snd) @ [map_id_of_bnf outer];
+      in
+        (EVERY' (map (fn thm => subst_tac ctxt [thm]) thms) THEN' rtac refl) 1
+      end;
+
+    fun comp_map_comp_tac _ =
+      mk_comp_map_comp_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
+        (map map_comp_of_bnf inners);
+
+    fun mk_single_comp_set_natural_tac i _ =
+      mk_comp_set_natural_tac (map_comp_of_bnf outer) (map_cong_of_bnf outer)
+        (collect_set_natural_of_bnf outer)
+        (map ((fn thms => nth thms i) o set_natural_of_bnf) inners);
+
+    val comp_set_natural_tacs = map mk_single_comp_set_natural_tac (0 upto ilive - 1);
+
+    fun comp_bd_card_order_tac _ =
+      mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
+
+    fun comp_bd_cinfinite_tac _ =
+      mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
+
+    val comp_set_alt_thms =
+      if ! quick_and_dirty then
+        replicate ilive no_thm
+      else
+        map (fn goal => Skip_Proof.prove lthy [] [] goal
+        (fn {context, ...} => (mk_comp_set_alt_tac context (collect_set_natural_of_bnf outer))))
+        (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) comp_sets comp_sets_alt);
+
+    fun comp_map_cong_tac _ =
+      mk_comp_map_cong_tac comp_set_alt_thms (map_cong_of_bnf outer) (map map_cong_of_bnf inners);
+
+    val comp_set_bd_tacs =
+      if ! quick_and_dirty then
+        replicate (length comp_set_alt_thms) (K all_tac)
+      else
+        let
+          val outer_set_bds = set_bd_of_bnf outer;
+          val inner_set_bdss = map set_bd_of_bnf inners;
+          val inner_bd_Card_orders = map bd_Card_order_of_bnf inners;
+          fun comp_single_set_bd_thm i j =
+            @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
+              nth outer_set_bds j]
+          val single_set_bd_thmss =
+            map ((fn f => map f (0 upto olive - 1)) o comp_single_set_bd_thm) (0 upto ilive - 1);
+        in
+          map2 (fn comp_set_alt => fn single_set_bds => fn {context, ...} =>
+            mk_comp_set_bd_tac context comp_set_alt single_set_bds)
+          comp_set_alt_thms single_set_bd_thmss
+        end;
+
+    val comp_in_alt_thm =
+      if ! quick_and_dirty then
+        no_thm
+      else
+        let
+          val comp_in = mk_in Asets comp_sets CCA;
+          val comp_in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
+          val goal =
+            fold_rev Logic.all Asets
+              (HOLogic.mk_Trueprop (HOLogic.mk_eq (comp_in, comp_in_alt)));
+        in
+          Skip_Proof.prove lthy [] [] goal
+            (fn {context, ...} => mk_comp_in_alt_tac context comp_set_alt_thms)
+        end;
+
+    fun comp_in_bd_tac _ =
+      mk_comp_in_bd_tac comp_in_alt_thm (map in_bd_of_bnf inners) (in_bd_of_bnf outer)
+        (map bd_Cinfinite_of_bnf inners) (bd_Card_order_of_bnf outer);
+
+    fun comp_map_wpull_tac _ =
+      mk_map_wpull_tac comp_in_alt_thm (map map_wpull_of_bnf inners) (map_wpull_of_bnf outer);
+
+    val tacs = [comp_map_id_tac, comp_map_comp_tac, comp_map_cong_tac] @ comp_set_natural_tacs @
+      [comp_bd_card_order_tac, comp_bd_cinfinite_tac] @ comp_set_bd_tacs @
+      [comp_in_bd_tac, comp_map_wpull_tac];
+
+    val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
+
+    val inner_witss = map (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)))
+      (map3 (fn Ds => fn n => mk_wits_of_bnf (replicate n Ds) (replicate n As))
+        Dss inwitss inners);
+
+    val inner_witsss = map (map (nth inner_witss) o fst) outer_wits;
+
+    val comp_wits = (inner_witsss, (map (single o snd) outer_wits))
+      |-> map2 (fold (map_product (fn iwit => fn owit => owit $ iwit)))
+      |> flat
+      |> map (`(fn t => Term.add_frees t []))
+      |> minimize_wits
+      |> map (fn (frees, t) => fold absfree frees t);
+
+    fun wit_tac {context = ctxt, ...} =
+      mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_natural_of_bnf outer)
+        (maps wit_thms_of_bnf inners);
+
+    val (bnf', lthy') =
+      add_bnf const_policy (K Derive_Some_Facts) qualify tacs wit_tac (SOME (oDs @ flat Dss))
+        ((((b, comp_map), comp_sets), comp_bd), comp_wits) lthy;
+
+    val outer_rel_Gr = rel_Gr_of_bnf outer RS sym;
+    val outer_rel_cong = rel_cong_of_bnf outer;
+
+    val comp_rel_unfold_thm =
+      trans OF [rel_def_of_bnf bnf',
+        trans OF [comp_in_alt_thm RS @{thm subst_rel_def},
+          trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
+            [trans OF [outer_rel_Gr RS @{thm arg_cong[of _ _ converse]},
+              rel_converse_of_bnf outer RS sym], outer_rel_Gr],
+            trans OF [rel_O_of_bnf outer RS sym, outer_rel_cong OF
+              (map (fn bnf => rel_def_of_bnf bnf RS sym) inners)]]]];
+
+    val comp_pred_unfold_thm = Collect_split_box_equals OF [comp_rel_unfold_thm,
+      pred_def_of_bnf bnf' RS abs_pred_sym,
+        trans OF [outer_rel_cong OF (map (fn bnf => pred_def_of_bnf bnf RS abs_pred_sym) inners),
+          pred_def_of_bnf outer RS abs_pred_sym]];
+
+    val unfold' = add_to_unfold (map_def_of_bnf bnf') (set_defs_of_bnf bnf')
+      comp_rel_unfold_thm comp_pred_unfold_thm unfold;
+  in
+    (bnf', (unfold', lthy'))
+  end;
+
+fun clean_compose_bnf_cmd (outer, inners) lthy =
+  let
+    val outer = the (bnf_of lthy outer)
+    val inners = map (the o bnf_of lthy) inners
+    val b = name_of_bnf outer
+      |> Binding.prefix_name compN
+      |> Binding.suffix_name ("_" ^ implode (map (Binding.name_of o name_of_bnf) inners));
+  in
+    (snd o snd) (clean_compose_bnf Dont_Inline I b outer inners
+      (empty_unfold, lthy))
+  end;
+
+(* Killing live variables *)
+
+fun killN_bnf qualify n bnf (unfold, lthy) = if n = 0 then (bnf, (unfold, lthy)) else
+  let
+    val b = Binding.prefix_name (mk_killN n) (name_of_bnf bnf);
+    val live = live_of_bnf bnf;
+    val dead = dead_of_bnf bnf;
+    val nwits = nwits_of_bnf bnf;
+
+    (* TODO: check 0 < n <= live *)
+
+    val (Ds, lthy1) = apfst (map TFree)
+      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
+    val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
+      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
+    val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
+      (Variable.invent_types (replicate (live - n) HOLogic.typeS) lthy2);
+
+    val ((Asets, lives), _(*names_lthy*)) = lthy
+      |> mk_Frees "A" (map (HOLogic.mk_setT) (drop n As))
+      ||>> mk_Frees "x" (drop n As);
+    val xs = map (fn T => HOLogic.choice_const T $ absdummy T @{term True}) killedAs @ lives;
+
+    val T = mk_T_of_bnf Ds As bnf;
+
+    (*bnf.map id ... id*)
+    val killN_map = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
+
+    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
+    val killN_sets = drop n bnf_sets;
+
+    (*(|UNIV :: A1 set| +c ... +c |UNIV :: An set|) *c bnf.bd*)
+    val bnf_bd = mk_bd_of_bnf Ds As bnf;
+    val killN_bd = mk_cprod
+      (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
+
+    fun killN_map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
+    fun killN_map_comp_tac {context, ...} =
+      Local_Defs.unfold_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
+      rtac refl 1;
+    fun killN_map_cong_tac {context, ...} =
+      mk_killN_map_cong_tac context n (live - n) (map_cong_of_bnf bnf);
+    val killN_set_natural_tacs =
+      map (fn thm => fn _ => rtac thm 1) (drop n (set_natural_of_bnf bnf));
+    fun killN_bd_card_order_tac _ = mk_killN_bd_card_order_tac n (bd_card_order_of_bnf bnf);
+    fun killN_bd_cinfinite_tac _ = mk_killN_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
+    val killN_set_bd_tacs =
+      map (fn thm => fn _ => mk_killN_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
+        (drop n (set_bd_of_bnf bnf));
+
+    val killN_in_alt_thm =
+      if ! quick_and_dirty then
+        no_thm
+      else
+        let
+          val killN_in = mk_in Asets killN_sets T;
+          val killN_in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
+          val goal =
+            fold_rev Logic.all Asets (HOLogic.mk_Trueprop (HOLogic.mk_eq (killN_in, killN_in_alt)));
+        in
+          Skip_Proof.prove lthy [] [] goal (K killN_in_alt_tac)
+        end;
+
+    fun killN_in_bd_tac _ =
+      mk_killN_in_bd_tac n (live > n) killN_in_alt_thm (in_bd_of_bnf bnf)
+         (bd_Card_order_of_bnf bnf) (bd_Cinfinite_of_bnf bnf) (bd_Cnotzero_of_bnf bnf);
+    fun killN_map_wpull_tac _ =
+      mk_map_wpull_tac killN_in_alt_thm [] (map_wpull_of_bnf bnf);
+
+    val tacs = [killN_map_id_tac, killN_map_comp_tac, killN_map_cong_tac] @ killN_set_natural_tacs @
+      [killN_bd_card_order_tac, killN_bd_cinfinite_tac] @ killN_set_bd_tacs @
+      [killN_in_bd_tac, killN_map_wpull_tac];
+
+    val wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
+
+    val killN_wits = map (fn t => fold absfree (Term.add_frees t []) t)
+      (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) wits);
+
+    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
+
+    val (bnf', lthy') =
+      add_bnf Smart_Inline (K Derive_Some_Facts) qualify tacs wit_tac (SOME (killedAs @ Ds))
+        ((((b, killN_map), killN_sets), Term.absdummy T killN_bd), killN_wits) lthy;
+
+    val rel_Gr = rel_Gr_of_bnf bnf RS sym;
+
+    val killN_rel_unfold_thm =
+      trans OF [rel_def_of_bnf bnf',
+        trans OF [killN_in_alt_thm RS @{thm subst_rel_def},
+          trans OF [@{thm arg_cong2[of _ _ _ _ relcomp]} OF
+            [trans OF [rel_Gr RS @{thm arg_cong[of _ _ converse]}, rel_converse_of_bnf bnf RS sym],
+              rel_Gr],
+            trans OF [rel_O_of_bnf bnf RS sym, rel_cong_of_bnf bnf OF
+              (replicate n @{thm trans[OF Gr_UNIV_id[OF refl] Id_alt[symmetric]]} @
+               replicate (live - n) @{thm Gr_fst_snd})]]]];
+
+    val killN_pred_unfold_thm = Collect_split_box_equals OF
+      [Local_Defs.unfold lthy' @{thms Id_def'} killN_rel_unfold_thm,
+        pred_def_of_bnf bnf' RS abs_pred_sym, pred_def_of_bnf bnf RS abs_pred_sym];
+
+    val unfold' = add_to_unfold (map_def_of_bnf bnf') (set_defs_of_bnf bnf')
+      killN_rel_unfold_thm killN_pred_unfold_thm unfold;
+  in
+    (bnf', (unfold', lthy'))
+  end;
+
+fun killN_bnf_cmd (n, raw_bnf) lthy =
+  (snd o snd) (killN_bnf I n (the (bnf_of lthy raw_bnf)) (empty_unfold, lthy));
+
+(* Adding dummy live variables *)
+
+fun liftN_bnf qualify n bnf (unfold, lthy) = if n = 0 then (bnf, (unfold, lthy)) else
+  let
+    val b = Binding.prefix_name (mk_liftN n) (name_of_bnf bnf);
+    val live = live_of_bnf bnf;
+    val dead = dead_of_bnf bnf;
+    val nwits = nwits_of_bnf bnf;
+
+    (* TODO: check 0 < n *)
+
+    val (Ds, lthy1) = apfst (map TFree)
+      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
+    val ((newAs, As), lthy2) = apfst (chop n o map TFree)
+      (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy1);
+    val ((newBs, Bs), _(*lthy3*)) = apfst (chop n o map TFree)
+      (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy2);
+
+    val (Asets, _(*names_lthy*)) = lthy
+      |> mk_Frees "A" (map (HOLogic.mk_setT) (newAs @ As));
+
+    val T = mk_T_of_bnf Ds As bnf;
+
+    (*%f1 ... fn. bnf.map*)
+    val liftN_map =
+      fold_rev Term.absdummy (map2 (curry (op -->)) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
+
+    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
+    val liftN_sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
+
+    val liftN_bd = mk_bd_of_bnf Ds As bnf;
+
+    fun liftN_map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
+    fun liftN_map_comp_tac {context, ...} =
+      Local_Defs.unfold_tac context ((map_comp_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
+      rtac refl 1;
+    fun liftN_map_cong_tac {context, ...} =
+      rtac (map_cong_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac context 1);
+    val liftN_set_natural_tacs =
+      if ! quick_and_dirty then
+        replicate (n + live) (K all_tac)
+      else
+        replicate n (K empty_natural_tac) @
+        map (fn thm => fn _ => rtac thm 1) (set_natural_of_bnf bnf);
+    fun liftN_bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
+    fun liftN_bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
+    val liftN_set_bd_tacs =
+      if ! quick_and_dirty then
+        replicate (n + live) (K all_tac)
+      else
+        replicate n (K (mk_liftN_set_bd_tac (bd_Card_order_of_bnf bnf))) @
+        (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
+
+    val liftN_in_alt_thm =
+      if ! quick_and_dirty then
+        no_thm
+      else
+        let
+          val liftN_in = mk_in Asets liftN_sets T;
+          val liftN_in_alt = mk_in (drop n Asets) bnf_sets T;
+          val goal =
+            fold_rev Logic.all Asets (HOLogic.mk_Trueprop (HOLogic.mk_eq (liftN_in, liftN_in_alt)))
+        in
+          Skip_Proof.prove lthy [] [] goal (K liftN_in_alt_tac)
+        end;
+
+    fun liftN_in_bd_tac _ =
+      mk_liftN_in_bd_tac n liftN_in_alt_thm (in_bd_of_bnf bnf) (bd_Card_order_of_bnf bnf);
+    fun liftN_map_wpull_tac _ =
+      mk_map_wpull_tac liftN_in_alt_thm [] (map_wpull_of_bnf bnf);
+
+    val tacs = [liftN_map_id_tac, liftN_map_comp_tac, liftN_map_cong_tac] @ liftN_set_natural_tacs @
+      [liftN_bd_card_order_tac, liftN_bd_cinfinite_tac] @ liftN_set_bd_tacs @
+      [liftN_in_bd_tac, liftN_map_wpull_tac];
+
+    val liftN_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
+
+    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
+
+    val (bnf', lthy') =
+      add_bnf Smart_Inline (K Derive_Some_Facts) qualify tacs wit_tac (SOME Ds)
+        ((((b, liftN_map), liftN_sets), Term.absdummy T liftN_bd), liftN_wits) lthy;
+
+    val liftN_rel_unfold_thm =
+      trans OF [rel_def_of_bnf bnf',
+        trans OF [liftN_in_alt_thm RS @{thm subst_rel_def}, rel_def_of_bnf bnf RS sym]];
+
+    val liftN_pred_unfold_thm = Collect_split_box_equals OF [liftN_rel_unfold_thm,
+      pred_def_of_bnf bnf' RS abs_pred_sym, pred_def_of_bnf bnf RS abs_pred_sym];
+
+    val unfold' = add_to_unfold (map_def_of_bnf bnf') (set_defs_of_bnf bnf')
+      liftN_rel_unfold_thm liftN_pred_unfold_thm unfold;
+  in
+    (bnf', (unfold', lthy'))
+  end;
+
+fun liftN_bnf_cmd (n, raw_bnf) lthy =
+  (snd o snd) (liftN_bnf I n (the (bnf_of lthy raw_bnf)) (empty_unfold, lthy));
+
+(* Changing the order of live variables *)
+
+fun permute_bnf qualify src dest bnf (unfold, lthy) = if src = dest then (bnf, (unfold, lthy)) else
+  let
+    val b = Binding.prefix_name (mk_permuteN src dest) (name_of_bnf bnf);
+    val live = live_of_bnf bnf;
+    val dead = dead_of_bnf bnf;
+    val nwits = nwits_of_bnf bnf;
+    fun permute xs = mk_permute src dest xs;
+    fun permute_rev xs = mk_permute dest src xs;
+
+    val (Ds, lthy1) = apfst (map TFree)
+      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
+    val (As, lthy2) = apfst (map TFree)
+      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
+    val (Bs, _(*lthy3*)) = apfst (map TFree)
+      (Variable.invent_types (replicate live HOLogic.typeS) lthy2);
+
+    val (Asets, _(*names_lthy*)) = lthy
+      |> mk_Frees "A" (map (HOLogic.mk_setT) (permute As));
+
+    val T = mk_T_of_bnf Ds As bnf;
+
+    (*%f(1) ... f(n). bnf.map f\<sigma>(1) ... f\<sigma>(n)*)
+    val permute_map = fold_rev Term.absdummy (permute (map2 (curry op -->) As Bs))
+      (Term.list_comb (mk_map_of_bnf Ds As Bs bnf,
+        permute_rev (map Bound ((live - 1) downto 0))));
+
+    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
+    val permute_sets = permute bnf_sets;
+
+    val permute_bd = mk_bd_of_bnf Ds As bnf;
+
+    fun permute_map_id_tac _ = rtac (map_id_of_bnf bnf) 1;
+    fun permute_map_comp_tac _ = rtac (map_comp_of_bnf bnf) 1;
+    fun permute_map_cong_tac {context, ...} =
+      rtac (map_cong_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac context 1);
+    val permute_set_natural_tacs =
+      permute (map (fn thm => fn _ => rtac thm 1) (set_natural_of_bnf bnf));
+    fun permute_bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
+    fun permute_bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
+    val permute_set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
+
+    val permute_in_alt_thm =
+      if ! quick_and_dirty then
+        no_thm
+      else
+        let
+          val permute_in = mk_in Asets permute_sets T;
+          val permute_in_alt = mk_in (permute_rev Asets) bnf_sets T;
+          val goal =
+            fold_rev Logic.all Asets
+              (HOLogic.mk_Trueprop (HOLogic.mk_eq (permute_in, permute_in_alt)));
+        in
+          Skip_Proof.prove lthy [] [] goal (K (mk_permute_in_alt_tac src dest))
+        end;
+
+    fun permute_in_bd_tac _ =
+      mk_permute_in_bd_tac src dest permute_in_alt_thm (in_bd_of_bnf bnf)
+        (bd_Card_order_of_bnf bnf);
+    fun permute_map_wpull_tac _ =
+      mk_map_wpull_tac permute_in_alt_thm [] (map_wpull_of_bnf bnf);
+
+    val tacs = [permute_map_id_tac, permute_map_comp_tac, permute_map_cong_tac] @
+      permute_set_natural_tacs @ [permute_bd_card_order_tac, permute_bd_cinfinite_tac] @
+      permute_set_bd_tacs @ [permute_in_bd_tac, permute_map_wpull_tac];
+
+    val permute_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
+
+    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
+
+    val (bnf', lthy') =
+      add_bnf Smart_Inline (K Derive_Some_Facts) qualify tacs wit_tac (SOME Ds)
+        ((((b, permute_map), permute_sets), Term.absdummy T permute_bd), permute_wits) lthy;
+
+    val permute_rel_unfold_thm =
+      trans OF [rel_def_of_bnf bnf',
+        trans OF [permute_in_alt_thm RS @{thm subst_rel_def}, rel_def_of_bnf bnf RS sym]];
+
+    val permute_pred_unfold_thm = Collect_split_box_equals OF [permute_rel_unfold_thm,
+      pred_def_of_bnf bnf' RS abs_pred_sym, pred_def_of_bnf bnf RS abs_pred_sym];
+
+    val unfold' = add_to_unfold (map_def_of_bnf bnf') (set_defs_of_bnf bnf')
+      permute_rel_unfold_thm permute_pred_unfold_thm unfold;
+  in
+    (bnf', (unfold', lthy'))
+  end;
+
+fun permute_bnf_cmd ((src, dest), raw_bnf) lthy =
+  (snd o snd) (permute_bnf I src dest (the (bnf_of lthy raw_bnf))
+    (empty_unfold, lthy));
+
+(* Hide the type of the bound (optimization) and unfold the definitions (nicer to the user) *)
+
+fun seal_bnf unfold b Ds bnf lthy =
+  let
+    val live = live_of_bnf bnf;
+    val nwits = nwits_of_bnf bnf;
+
+    val (As, lthy1) = apfst (map TFree)
+      (Variable.invent_types (replicate live HOLogic.typeS) (fold Variable.declare_typ Ds lthy));
+    val (Bs, _) = apfst (map TFree)
+      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
+
+    val map_unfolds = filter_refl (map_unfolds_of unfold);
+    val set_unfoldss = map filter_refl (set_unfoldss_of unfold);
+
+    val expand_maps = fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of)
+      map_unfolds);
+    val expand_sets = fold expand_term_const (map (map (Logic.dest_equals o Thm.prop_of))
+      set_unfoldss);
+    val unfold_maps = fold (Local_Defs.unfold lthy o single) map_unfolds;
+    val unfold_sets = fold (Local_Defs.unfold lthy) set_unfoldss;
+    val unfold_defs = unfold_sets o unfold_maps;
+    val bnf_map = expand_maps (mk_map_of_bnf Ds As Bs bnf);
+    val bnf_sets = map (expand_maps o expand_sets)
+      (mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf);
+    val bnf_bd = mk_bd_of_bnf Ds As bnf;
+    val T = mk_T_of_bnf Ds As bnf;
+
+    (*bd should only depend on dead type variables!*)
+    val bd_repT = fst (dest_relT (fastype_of bnf_bd));
+    val bdT_bind = Binding.suffix_name ("_" ^ bdTN) b;
+    val params = fold Term.add_tfreesT Ds [];
+
+    val ((bdT_name, (bdT_glob_info, bdT_loc_info)), (lthy', lthy)) =
+      lthy
+      |> Typedef.add_typedef true NONE (bdT_bind, params, NoSyn)
+        (HOLogic.mk_UNIV bd_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1)
+      ||> `Local_Theory.restore;
+
+    val phi = Proof_Context.export_morphism lthy lthy';
+
+    val bnf_bd' = mk_dir_image bnf_bd
+      (Const (#Abs_name bdT_glob_info, bd_repT --> Type (bdT_name, map TFree params)))
+
+    val set_def = Morphism.thm phi (the (#set_def bdT_loc_info));
+    val Abs_inject = Morphism.thm phi (#Abs_inject bdT_loc_info);
+    val Abs_cases = Morphism.thm phi (#Abs_cases bdT_loc_info);
+
+    val Abs_bdT_inj = mk_Abs_inj_thm set_def Abs_inject;
+    val Abs_bdT_bij = mk_Abs_bij_thm lthy' set_def Abs_inject Abs_cases;
+
+    val bd_ordIso = @{thm dir_image} OF [Abs_bdT_inj, bd_Card_order_of_bnf bnf];
+    val bd_card_order =
+      @{thm card_order_dir_image} OF [Abs_bdT_bij, bd_card_order_of_bnf bnf];
+    val bd_cinfinite =
+      (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
+
+    val set_bds =
+      map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
+    val in_bd =
+      @{thm ordLeq_ordIso_trans} OF [in_bd_of_bnf bnf,
+        @{thm cexp_cong2_Cnotzero} OF [bd_ordIso, if live = 0 then
+          @{thm ctwo_Cnotzero} else @{thm ctwo_Cnotzero} RS @{thm csum_Cnotzero2},
+            bd_Card_order_of_bnf bnf]];
+
+    fun mk_tac thm {context = ctxt, prems = _} = (rtac (unfold_defs thm) THEN'
+      SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
+    val tacs =
+      map mk_tac ([map_id_of_bnf bnf, map_comp_of_bnf bnf, map_cong_of_bnf bnf] @
+        set_natural_of_bnf bnf) @
+      map K [rtac bd_card_order 1, rtac bd_cinfinite 1] @
+      map mk_tac (set_bds @ [in_bd, map_wpull_of_bnf bnf]);
+
+    val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
+
+    fun wit_tac _ = mk_simple_wit_tac (map unfold_defs (wit_thms_of_bnf bnf));
+
+    val (bnf', lthy') = add_bnf Hardly_Inline (K Derive_All_Facts) I tacs wit_tac NONE
+        ((((b, bnf_map), bnf_sets), Term.absdummy T bnf_bd'), bnf_wits) lthy;
+
+    val defs' = filter_refl (map_def_of_bnf bnf' :: set_defs_of_bnf bnf');
+    val unfold_defs' = unfold_defs o Local_Defs.unfold lthy' defs';
+
+    val rel_def = unfold_defs' (rel_def_of_bnf bnf');
+    val rel_unfold = Local_Defs.unfold lthy'
+      (map unfold_defs (filter_refl (rel_unfolds_of unfold))) rel_def;
+
+    val unfold_defs'' =
+      unfold_defs' o (Local_Defs.unfold lthy' (filter_refl [rel_def_of_bnf bnf']));
+
+    val pred_def = unfold_defs'' (pred_def_of_bnf bnf' RS abs_pred_sym_pred_abs);
+    val pred_unfold = Local_Defs.unfold lthy'
+      (map unfold_defs (filter_refl (pred_unfolds_of unfold))) pred_def;
+
+    fun note thmN thms =
+      snd o Local_Theory.note
+        ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), thms);
+  in
+    (bnf', lthy'
+      |> note rel_unfoldN [rel_unfold]
+      |> note pred_unfoldN [pred_unfold])
+  end;
+
+(* Composition pipeline *)
+
+fun permute_and_kill qualify n src dest bnf =
+  bnf
+  |> permute_bnf qualify src dest
+  #> uncurry (killN_bnf qualify n);
+
+fun lift_and_permute qualify n src dest bnf =
+  bnf
+  |> liftN_bnf qualify n
+  #> uncurry (permute_bnf qualify src dest);
+
+fun normalize_bnfs qualify Ass Ds sort bnfs unfold lthy =
+  let
+    val before_kill_src = map (fn As => 0 upto (length As - 1)) Ass;
+    val kill_poss = map (find_indices Ds) Ass;
+    val live_poss = map2 (subtract (op =)) kill_poss before_kill_src;
+    val before_kill_dest = map2 append kill_poss live_poss;
+    val kill_ns = map length kill_poss;
+    val (inners', (unfold', lthy')) =
+      fold_map5 (fn i => permute_and_kill (qualify i))
+        (if length bnfs = 1 then [0] else (1 upto length bnfs))
+        kill_ns before_kill_src before_kill_dest bnfs (unfold, lthy);
+
+    val Ass' = map2 (map o nth) Ass live_poss;
+    val As = sort Ass';
+    val after_lift_dest = replicate (length Ass') (0 upto (length As - 1));
+    val old_poss = map (map (fn x => find_index (fn y => x = y) As)) Ass';
+    val new_poss = map2 (subtract (op =)) old_poss after_lift_dest;
+    val after_lift_src = map2 append new_poss old_poss;
+    val lift_ns = map (fn xs => length As - length xs) Ass';
+  in
+    ((kill_poss, As), fold_map5 (fn i => lift_and_permute (qualify i))
+      (if length bnfs = 1 then [0] else (1 upto length bnfs))
+      lift_ns after_lift_src after_lift_dest inners' (unfold', lthy'))
+  end;
+
+fun default_comp_sort Ass =
+  Library.sort (Term_Ord.typ_ord o pairself TFree) (fold (fold (insert (op =))) Ass []);
+
+fun compose_bnf const_policy qualify' b sort outer inners oDs Dss tfreess (unfold, lthy) =
+  let
+    val name = Binding.name_of b;
+    fun qualify i bind =
+      let val namei = if i > 0 then name ^ string_of_int i else name;
+      in
+        if member (op =) (#2 (Binding.dest bind)) (namei, true) then qualify' bind
+        else qualify' (Binding.prefix_name namei bind)
+      end;
+
+    val Ass = map (map dest_TFree) tfreess;
+    val Ds = fold (fold Term.add_tfreesT) (oDs :: Dss) [];
+
+    val ((kill_poss, As), (inners', (unfold', lthy'))) =
+      normalize_bnfs qualify Ass Ds sort inners unfold lthy;
+
+    val Ds = oDs @ flat (map3 (append oo map o nth) tfreess kill_poss Dss);
+    val As = map TFree As;
+  in
+    apfst (rpair (Ds, As)) (clean_compose_bnf const_policy I b outer inners' (unfold', lthy'))
+  end;
+
+fun compose_bnf_cmd (((((b, outer), inners), oDs), Dss), Ass) lthy = (snd o snd)
+  (compose_bnf Dont_Inline I b default_comp_sort (the (bnf_of lthy outer))
+    (map (the o bnf_of lthy) inners)
+    (map (Syntax.read_typ lthy) oDs) (map (map (Syntax.read_typ lthy)) Dss)
+    (map (map (Syntax.read_typ lthy)) Ass) (empty_unfold, lthy));
+
+fun bnf_of_typ _ _ _ _ (T as TFree _) (unfold, lthy) =
+    ((Basic_BNFs.ID_bnf, ([], [T])), (add_to_unfold_opt NONE NONE
+      (SOME Basic_BNFs.ID_rel_def) (SOME Basic_BNFs.ID_pred_def) unfold, lthy))
+  | bnf_of_typ _ _ _ _ (TVar _) _ = error "Unexpected schematic variable"
+  | bnf_of_typ const_policy b qualify' sort (T as Type (C, Ts)) (unfold, lthy) =
+    let val tfrees = Term.add_tfreesT T [];
+    in
+      if null tfrees then
+        ((Basic_BNFs.DEADID_bnf, ([T], [])), (unfold, lthy))
+      else if forall (can Term.dest_TFree) Ts andalso length Ts = length tfrees then let
+        val bnf = the (bnf_of lthy (Long_Name.base_name C));
+        val T' = T_of_bnf bnf;
+        val deads = deads_of_bnf bnf;
+        val lives = lives_of_bnf bnf;
+        val tvars' = Term.add_tvarsT T' [];
+        val deads_lives =
+          pairself (map (Term.typ_subst_TVars (map fst tvars' ~~ map TFree tfrees)))
+          (deads, lives);
+      val rel_def = rel_def_of_bnf bnf;
+      val unfold' = add_to_unfold_opt NONE NONE (SOME (rel_def RS sym))
+        (SOME (Local_Defs.unfold lthy [rel_def] (pred_def_of_bnf bnf) RS sym)) unfold;
+      in ((bnf, deads_lives), (unfold', lthy)) end
+      else
+        let
+          (* FIXME: we should allow several BNFs with the same base name *)
+          val Tname = Long_Name.base_name C;
+          val name = Binding.name_of b ^ "_" ^ Tname;
+          fun qualify i bind =
+            let val namei = if i > 0 then name ^ string_of_int i else name;
+            in
+              if member (op =) (#2 (Binding.dest bind)) (namei, true) then qualify' bind
+              else qualify' (Binding.prefix_name namei bind)
+            end;
+          val outer = the (bnf_of lthy Tname);
+          val odead = dead_of_bnf outer;
+          val olive = live_of_bnf outer;
+          val oDs_pos = find_indices [TFree ("dead", [])]
+            (snd (dest_Type
+              (mk_T_of_bnf (replicate odead (TFree ("dead", []))) (replicate olive dummyT) outer)));
+          val oDs = map (nth Ts) oDs_pos;
+          val Ts' = map (nth Ts) (subtract (op =) oDs_pos (0 upto length Ts - 1));
+          val ((inners, (Dss, Ass)), (unfold', lthy')) =
+            apfst (apsnd split_list o split_list)
+              (fold_map2 (fn i =>
+                  bnf_of_typ Smart_Inline (Binding.name (name ^ string_of_int i)) (qualify i) sort)
+                (if length Ts' = 1 then [0] else (1 upto length Ts'))
+                Ts' (unfold, lthy));
+        in
+          compose_bnf const_policy (qualify 0) b sort outer inners oDs Dss Ass (unfold', lthy')
+        end
+    end;
+
+fun bnf_of_typ_cmd (b, rawT) lthy = (snd o snd)
+  (bnf_of_typ Dont_Inline b I default_comp_sort (Syntax.read_typ lthy rawT)
+    (empty_unfold, lthy));
+
+val _ =
+  Outer_Syntax.local_theory @{command_spec "bnf_of_typ"} "parse a type as composition of BNFs"
+    (((Parse.binding --| Parse.$$$ "=") -- Parse.typ) >> bnf_of_typ_cmd);
+
+end;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Tools/bnf_comp_tactics.ML	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,394 @@
+(*  Title:      HOL/Codatatype/Tools/bnf_comp_tactics.ML
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Jasmin Blanchette, TU Muenchen
+    Copyright   2012
+
+Tactics for composition of bounded natural functors.
+*)
+
+signature BNF_COMP_TACTICS =
+sig
+  val mk_comp_bd_card_order_tac: thm list -> thm -> tactic
+  val mk_comp_bd_cinfinite_tac: thm -> thm -> tactic
+  val mk_comp_in_alt_tac: Proof.context -> thm list -> tactic
+  val mk_comp_in_bd_tac: thm -> thm list -> thm -> thm list -> thm -> tactic
+  val mk_comp_map_comp_tac: thm -> thm -> thm list -> tactic
+  val mk_comp_map_cong_tac: thm list -> thm -> thm list -> tactic
+  val mk_comp_set_alt_tac: Proof.context -> thm -> tactic
+  val mk_comp_set_bd_tac: Proof.context -> thm -> thm list -> tactic
+  val mk_comp_set_natural_tac: thm -> thm -> thm -> thm list -> tactic
+  val mk_comp_wit_tac: Proof.context -> thm list -> thm -> thm list -> tactic
+
+  val mk_killN_bd_card_order_tac: int -> thm -> tactic
+  val mk_killN_bd_cinfinite_tac: thm -> tactic
+  val killN_in_alt_tac: tactic
+  val mk_killN_in_bd_tac: int -> bool -> thm -> thm -> thm -> thm -> thm -> tactic
+  val mk_killN_map_cong_tac: Proof.context -> int -> int -> thm -> tactic
+  val mk_killN_set_bd_tac: thm -> thm -> tactic
+
+  val empty_natural_tac: tactic
+  val liftN_in_alt_tac: tactic
+  val mk_liftN_in_bd_tac: int -> thm -> thm -> thm -> tactic
+  val mk_liftN_set_bd_tac: thm -> tactic
+
+  val mk_permute_in_alt_tac: ''a list -> ''a list -> tactic
+  val mk_permute_in_bd_tac: ''a list -> ''a list -> thm -> thm -> thm -> tactic
+end;
+
+structure BNF_Comp_Tactics : BNF_COMP_TACTICS =
+struct
+
+open BNF_Util
+open BNF_Tactics
+
+val arg_cong_Union = @{thm arg_cong[of _ _ Union]};
+val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
+val set_mp = @{thm set_mp};
+val trans_image_cong_o_apply = @{thm trans[OF image_cong[OF o_apply refl]]};
+val trans_o_apply = @{thm trans[OF o_apply]};
+
+
+
+(* Composition *)
+
+fun mk_comp_set_alt_tac ctxt collect_set_natural =
+  Local_Defs.unfold_tac ctxt @{thms sym[OF o_assoc]} THEN
+  Local_Defs.unfold_tac ctxt [collect_set_natural RS sym] THEN
+  rtac refl 1;
+
+fun mk_comp_map_comp_tac Gmap_comp Gmap_cong map_comps =
+  EVERY' ([rtac ext, rtac sym, rtac trans_o_apply,
+    rtac (Gmap_comp RS sym RS o_eq_dest_lhs RS trans), rtac Gmap_cong] @
+    map (fn thm => rtac (thm RS sym RS fun_cong)) map_comps) 1;
+
+fun mk_comp_set_natural_tac Gmap_comp Gmap_cong Gset_natural set_naturals =
+  EVERY' ([rtac ext] @
+    replicate 3 (rtac trans_o_apply) @
+    [rtac (arg_cong_Union RS trans),
+     rtac (@{thm arg_cong2[of _ _ _ _ collect, OF refl]} RS trans),
+     rtac (Gmap_comp RS sym RS o_eq_dest_lhs RS trans),
+     rtac Gmap_cong] @
+     map (fn thm => rtac (thm RS fun_cong)) set_naturals @
+     [rtac (Gset_natural RS o_eq_dest_lhs), rtac sym, rtac trans_o_apply,
+     rtac trans_image_cong_o_apply, rtac trans_image_cong_o_apply,
+     rtac (@{thm image_cong} OF [Gset_natural RS o_eq_dest_lhs RS arg_cong_Union, refl] RS trans),
+     rtac @{thm trans[OF pointfreeE[OF Union_natural[symmetric]]]}, rtac arg_cong_Union,
+     rtac @{thm trans[OF o_eq_dest_lhs[OF image_o_collect[symmetric]]]},
+     rtac @{thm fun_cong[OF arg_cong[of _ _ collect]]}] @
+     [REPEAT_DETERM_N (length set_naturals) o EVERY' [rtac @{thm trans[OF image_insert]},
+        rtac @{thm arg_cong2[of _ _ _ _ insert]}, rtac ext, rtac trans_o_apply,
+        rtac @{thm trans[OF image_cong[OF o_apply refl]]}, rtac @{thm trans[OF image_image]},
+        rtac @{thm sym[OF trans[OF o_apply]]}, rtac @{thm image_cong[OF refl o_apply]}],
+     rtac @{thm image_empty}]) 1;
+
+fun mk_comp_map_cong_tac comp_set_alts map_cong map_congs =
+  let
+     val n = length comp_set_alts;
+  in
+    (if n = 0 then rtac refl 1
+    else rtac map_cong 1 THEN
+      EVERY' (map_index (fn (i, map_cong) =>
+        rtac map_cong THEN' EVERY' (map_index (fn (k, set_alt) =>
+          EVERY' [select_prem_tac n (dtac @{thm meta_spec}) (k + 1), etac @{thm meta_mp},
+            rtac (equalityD2 RS set_mp), rtac (set_alt RS fun_cong RS trans),
+            rtac trans_o_apply, rtac (@{thm collect_def} RS arg_cong_Union),
+            rtac @{thm UnionI}, rtac @{thm UN_I}, REPEAT_DETERM_N i o rtac @{thm insertI2},
+            rtac @{thm insertI1}, rtac (o_apply RS equalityD2 RS set_mp),
+            etac @{thm imageI}, atac])
+          comp_set_alts))
+      map_congs) 1)
+  end;
+
+fun mk_comp_bd_card_order_tac Fbd_card_orders Gbd_card_order =
+  let
+    val (card_orders, last_card_order) = split_last Fbd_card_orders;
+    fun gen_before thm = rtac @{thm card_order_csum} THEN' rtac thm;
+  in
+    (rtac @{thm card_order_cprod} THEN'
+    WRAP' gen_before (K (K all_tac)) card_orders (rtac last_card_order) THEN'
+    rtac Gbd_card_order) 1
+  end;
+
+fun mk_comp_bd_cinfinite_tac Fbd_cinfinite Gbd_cinfinite =
+  (rtac @{thm cinfinite_cprod} THEN'
+   ((K (TRY ((rtac @{thm cinfinite_csum} THEN' rtac disjI1) 1)) THEN'
+     ((rtac @{thm cinfinite_csum} THEN' rtac disjI1 THEN' rtac Fbd_cinfinite) ORELSE'
+      rtac Fbd_cinfinite)) ORELSE'
+    rtac Fbd_cinfinite) THEN'
+   rtac Gbd_cinfinite) 1;
+
+fun mk_comp_set_bd_tac ctxt comp_set_alt Gset_Fset_bds =
+  let
+    val (bds, last_bd) = split_last Gset_Fset_bds;
+    fun gen_before bd =
+      rtac ctrans THEN' rtac @{thm Un_csum} THEN'
+      rtac ctrans THEN' rtac @{thm csum_mono} THEN'
+      rtac bd;
+    fun gen_after _ = rtac @{thm ordIso_imp_ordLeq} THEN' rtac @{thm cprod_csum_distrib1};
+  in
+    Local_Defs.unfold_tac ctxt [comp_set_alt] THEN
+    rtac @{thm comp_set_bd_Union_o_collect} 1 THEN
+    Local_Defs.unfold_tac ctxt @{thms Union_image_insert Union_image_empty Union_Un_distrib
+      o_apply} THEN
+    (rtac ctrans THEN'
+     WRAP' gen_before gen_after bds (rtac last_bd) THEN'
+     rtac @{thm ordIso_imp_ordLeq} THEN'
+     rtac @{thm cprod_com}) 1
+  end;
+
+val comp_in_alt_thms = @{thms o_apply collect_def SUP_def image_insert image_empty Union_insert
+  Union_empty Un_empty_right Union_Un_distrib Un_subset_iff conj_subset_def UN_image_subset
+  conj_assoc};
+
+fun mk_comp_in_alt_tac ctxt comp_set_alts =
+  Local_Defs.unfold_tac ctxt (comp_set_alts @ comp_in_alt_thms) THEN
+  Local_Defs.unfold_tac ctxt @{thms set_eq_subset} THEN
+  rtac conjI 1 THEN
+  REPEAT_DETERM (
+    rtac @{thm subsetI} 1 THEN
+    Local_Defs.unfold_tac ctxt @{thms mem_Collect_eq Ball_def} THEN
+    (REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
+     REPEAT_DETERM (CHANGED ((
+       (rtac conjI THEN' (atac ORELSE' rtac @{thm subset_UNIV})) ORELSE'
+       atac ORELSE'
+       (rtac @{thm subset_UNIV})) 1)) ORELSE rtac @{thm subset_UNIV} 1));
+
+fun mk_comp_in_bd_tac comp_in_alt Fin_bds Gin_bd Fbd_Cinfs Gbd_Card_order =
+  let
+    val (bds, last_bd) = split_last Fin_bds;
+    val (Cinfs, _) = split_last Fbd_Cinfs;
+    fun gen_before (bd, _) = rtac ctrans THEN' rtac @{thm csum_mono} THEN' rtac bd;
+    fun gen_after (_, (bd_Cinf, next_bd_Cinf)) =
+      TRY o (rtac @{thm csum_cexp} THEN'
+        rtac bd_Cinf THEN'
+        (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac next_bd_Cinf ORELSE'
+           rtac next_bd_Cinf) THEN'
+        ((rtac @{thm Card_order_csum} THEN' rtac @{thm ordLeq_csum2}) ORELSE'
+          (rtac @{thm Card_order_ctwo} THEN' rtac @{thm ordLeq_refl})) THEN'
+        rtac @{thm Card_order_ctwo});
+  in
+    (rtac @{thm ordIso_ordLeq_trans} THEN'
+     rtac @{thm card_of_ordIso_subst} THEN'
+     rtac comp_in_alt THEN'
+     rtac ctrans THEN'
+     rtac Gin_bd THEN'
+     rtac @{thm ordLeq_ordIso_trans} THEN'
+     rtac @{thm cexp_mono1} THEN'
+     rtac @{thm ordLeq_ordIso_trans} THEN'
+     rtac @{thm csum_mono1} THEN'
+     WRAP' gen_before gen_after (bds ~~ (Cinfs ~~ tl Fbd_Cinfs)) (rtac last_bd) THEN'
+     rtac @{thm csum_absorb1} THEN'
+     rtac @{thm Cinfinite_cexp} THEN'
+     (rtac @{thm ordLeq_csum2} ORELSE' rtac @{thm ordLeq_refl}) THEN'
+     rtac @{thm Card_order_ctwo} THEN'
+     (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac (hd Fbd_Cinfs) ORELSE'
+       rtac (hd Fbd_Cinfs)) THEN'
+     rtac @{thm ctwo_ordLeq_Cinfinite} THEN'
+     rtac @{thm Cinfinite_cexp} THEN'
+     (rtac @{thm ordLeq_csum2} ORELSE' rtac @{thm ordLeq_refl}) THEN'
+     rtac @{thm Card_order_ctwo} THEN'
+     (TRY o (rtac @{thm Cinfinite_csum} THEN' rtac disjI1) THEN' rtac (hd Fbd_Cinfs) ORELSE'
+       rtac (hd Fbd_Cinfs)) THEN'
+     rtac disjI1 THEN'
+     TRY o rtac @{thm csum_Cnotzero2} THEN'
+     rtac @{thm ctwo_Cnotzero} THEN'
+     rtac Gbd_Card_order THEN'
+     rtac @{thm cexp_cprod} THEN'
+     TRY o rtac @{thm csum_Cnotzero2} THEN'
+     rtac @{thm ctwo_Cnotzero}) 1
+  end;
+
+val comp_wit_thms = @{thms Union_empty_conv o_apply collect_def SUP_def
+  Union_image_insert Union_image_empty};
+
+fun mk_comp_wit_tac ctxt Gwit_thms collect_set_natural Fwit_thms =
+  ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
+  Local_Defs.unfold_tac ctxt (collect_set_natural :: comp_wit_thms) THEN
+  REPEAT_DETERM (
+    atac 1 ORELSE
+    REPEAT_DETERM (eresolve_tac @{thms UnionE UnE imageE} 1) THEN
+    (TRY o dresolve_tac Gwit_thms THEN'
+    (etac FalseE ORELSE'
+    hyp_subst_tac THEN'
+    dresolve_tac Fwit_thms THEN'
+    (etac FalseE ORELSE' atac))) 1);
+
+
+
+(* Kill operation *)
+
+fun mk_killN_map_cong_tac ctxt n m map_cong =
+  (rtac map_cong THEN' EVERY' (replicate n (rtac refl)) THEN'
+    EVERY' (replicate m (Goal.assume_rule_tac ctxt))) 1;
+
+fun mk_killN_bd_card_order_tac n bd_card_order =
+  (rtac @{thm card_order_cprod} THEN'
+  K (REPEAT_DETERM_N (n - 1)
+    ((rtac @{thm card_order_csum} THEN'
+    rtac @{thm card_of_card_order_on}) 1)) THEN'
+  rtac @{thm card_of_card_order_on} THEN'
+  rtac bd_card_order) 1;
+
+fun mk_killN_bd_cinfinite_tac bd_Cinfinite =
+  (rtac @{thm cinfinite_cprod2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac bd_Cinfinite) 1;
+
+fun mk_killN_set_bd_tac bd_Card_order set_bd =
+  (rtac ctrans THEN'
+  rtac set_bd THEN'
+  rtac @{thm ordLeq_cprod2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac bd_Card_order) 1
+
+val killN_in_alt_tac =
+  ((rtac @{thm Collect_cong} THEN' rtac @{thm iffI}) 1 THEN
+  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
+  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
+    rtac conjI THEN' rtac @{thm subset_UNIV}) 1)) THEN
+  (rtac @{thm subset_UNIV} ORELSE' atac) 1 THEN
+  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
+  REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1))) ORELSE
+  ((rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
+    REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac @{thm subset_UNIV} 1));
+
+fun mk_killN_in_bd_tac n nontrivial_killN_in in_alt in_bd bd_Card_order bd_Cinfinite bd_Cnotzero =
+  (rtac @{thm ordIso_ordLeq_trans} THEN'
+  rtac @{thm card_of_ordIso_subst} THEN'
+  rtac in_alt THEN'
+  rtac ctrans THEN'
+  rtac in_bd THEN'
+  rtac @{thm ordIso_ordLeq_trans} THEN'
+  rtac @{thm cexp_cong1}) 1 THEN
+  (if nontrivial_killN_in then
+    rtac @{thm ordIso_transitive} 1 THEN
+    REPEAT_DETERM_N (n - 1)
+      ((rtac @{thm csum_cong1} THEN'
+      rtac @{thm ordIso_symmetric} THEN'
+      rtac @{thm csum_assoc} THEN'
+      rtac @{thm ordIso_transitive}) 1) THEN
+    (rtac @{thm ordIso_refl} THEN'
+    rtac @{thm Card_order_csum} THEN'
+    rtac @{thm ordIso_transitive} THEN'
+    rtac @{thm csum_assoc} THEN'
+    rtac @{thm ordIso_transitive} THEN'
+    rtac @{thm csum_cong1} THEN'
+    K (mk_flatten_assoc_tac
+      (rtac @{thm ordIso_refl} THEN'
+        FIRST' [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum}])
+      @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_cong}) THEN'
+    rtac @{thm ordIso_refl} THEN'
+    (rtac @{thm card_of_Card_order} ORELSE' rtac @{thm Card_order_csum})) 1
+  else all_tac) THEN
+  (rtac @{thm csum_com} THEN'
+  rtac bd_Card_order THEN'
+  rtac disjI1 THEN'
+  rtac @{thm csum_Cnotzero2} THEN'
+  rtac @{thm ctwo_Cnotzero} THEN'
+  rtac disjI1 THEN'
+  rtac @{thm csum_Cnotzero2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac @{thm ordLeq_ordIso_trans} THEN'
+  rtac @{thm cexp_mono1} THEN'
+  rtac ctrans THEN'
+  rtac @{thm csum_mono2} THEN'
+  rtac @{thm ordLeq_cprod1} THEN'
+  (rtac @{thm card_of_Card_order} ORELSE' rtac @{thm Card_order_csum}) THEN'
+  rtac bd_Cnotzero THEN'
+  rtac @{thm csum_cexp'} THEN'
+  rtac @{thm Cinfinite_cprod2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac bd_Cinfinite THEN'
+  ((rtac @{thm Card_order_ctwo} THEN' rtac @{thm ordLeq_refl}) ORELSE'
+    (rtac @{thm Card_order_csum} THEN' rtac @{thm ordLeq_csum2})) THEN'
+  rtac @{thm Card_order_ctwo} THEN'
+  rtac disjI1 THEN'
+  rtac @{thm csum_Cnotzero2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac bd_Card_order THEN'
+  rtac @{thm cexp_cprod_ordLeq} THEN'
+  TRY o rtac @{thm csum_Cnotzero2} THEN'
+  rtac @{thm ctwo_Cnotzero} THEN'
+  rtac @{thm Cinfinite_cprod2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac bd_Cinfinite THEN'
+  rtac bd_Cnotzero THEN'
+  rtac @{thm ordLeq_cprod2} THEN'
+  TRY o rtac @{thm csum_Cnotzero1} THEN'
+  rtac @{thm Cnotzero_UNIV} THEN'
+  rtac bd_Card_order) 1;
+
+
+
+(* Lift operation *)
+
+val empty_natural_tac = rtac @{thm empty_natural} 1;
+
+fun mk_liftN_set_bd_tac bd_Card_order = (rtac @{thm Card_order_empty} THEN' rtac bd_Card_order) 1;
+
+val liftN_in_alt_tac =
+  ((rtac @{thm Collect_cong} THEN' rtac @{thm iffI}) 1 THEN
+  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
+  REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1)) THEN
+  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
+  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
+    rtac conjI THEN' rtac @{thm empty_subsetI}) 1)) THEN
+  (rtac @{thm empty_subsetI} ORELSE' atac) 1) ORELSE
+  ((rtac sym THEN' rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
+    REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac @{thm empty_subsetI} 1));
+
+fun mk_liftN_in_bd_tac n in_alt in_bd bd_Card_order =
+  (rtac @{thm ordIso_ordLeq_trans} THEN'
+  rtac @{thm card_of_ordIso_subst} THEN'
+  rtac in_alt THEN'
+  rtac ctrans THEN'
+  rtac in_bd THEN'
+  rtac @{thm cexp_mono1}) 1 THEN
+  ((rtac @{thm csum_mono1} 1 THEN
+  REPEAT_DETERM_N (n - 1)
+    ((rtac ctrans THEN'
+    rtac @{thm ordLeq_csum2} THEN'
+    (rtac @{thm Card_order_csum} ORELSE' rtac @{thm card_of_Card_order})) 1) THEN
+  (rtac @{thm ordLeq_csum2} THEN'
+  (rtac @{thm Card_order_csum} ORELSE' rtac @{thm card_of_Card_order})) 1) ORELSE
+  (rtac @{thm ordLeq_csum2} THEN' rtac @{thm Card_order_ctwo}) 1) THEN
+  (rtac disjI1 THEN' TRY o rtac @{thm csum_Cnotzero2} THEN' rtac @{thm ctwo_Cnotzero}
+   THEN' rtac bd_Card_order) 1;
+
+
+
+(* Permute operation *)
+
+fun mk_permute_in_alt_tac src dest =
+  (rtac @{thm Collect_cong} THEN'
+  mk_rotate_eq_tac (rtac refl) trans @{thm conj_assoc} @{thm conj_commute} @{thm conj_cong}
+    dest src) 1;
+
+fun mk_permute_in_bd_tac src dest in_alt in_bd bd_Card_order =
+  (rtac @{thm ordIso_ordLeq_trans} THEN'
+  rtac @{thm card_of_ordIso_subst} THEN'
+  rtac in_alt THEN'
+  rtac @{thm ordLeq_ordIso_trans} THEN'
+  rtac in_bd THEN'
+  rtac @{thm cexp_cong1} THEN'
+  rtac @{thm csum_cong1} THEN'
+  mk_rotate_eq_tac
+    (rtac @{thm ordIso_refl} THEN'
+      FIRST' [rtac @{thm card_of_Card_order}, rtac @{thm Card_order_csum}])
+    @{thm ordIso_transitive} @{thm csum_assoc} @{thm csum_com} @{thm csum_cong}
+    src dest THEN'
+  rtac bd_Card_order THEN'
+  rtac disjI1 THEN'
+  TRY o rtac @{thm csum_Cnotzero2} THEN'
+  rtac @{thm ctwo_Cnotzero} THEN'
+  rtac disjI1 THEN'
+  TRY o rtac @{thm csum_Cnotzero2} THEN'
+  rtac @{thm ctwo_Cnotzero}) 1;
+
+end;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codatatype/Tools/bnf_def.ML	Tue Aug 28 17:16:00 2012 +0200
@@ -0,0 +1,1217 @@
+(*  Title:      HOL/Codatatype/Tools/bnf_def.ML
+    Author:     Dmitriy Traytel, TU Muenchen
+    Author:     Jasmin Blanchette, TU Muenchen
+    Copyright   2012
+
+Definition of bounded natural functors.
+*)
+
+signature BNF_DEF =
+sig
+  type BNF
+  type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
+
+  val bnf_of: Proof.context -> string -> BNF option
+  val name_of_bnf: BNF -> binding
+  val T_of_bnf: BNF -> typ
+  val live_of_bnf: BNF -> int
+  val lives_of_bnf: BNF -> typ list
+  val dead_of_bnf: BNF -> int
+  val deads_of_bnf: BNF -> typ list
+  val nwits_of_bnf: BNF -> int
+
+  val mapN: string
+  val setN: string
+  val relN: string
+  val predN: string
+  val mk_setN: int -> string
+  val rel_unfoldN: string
+  val pred_unfoldN: string
+
+  val mk_T_of_bnf: typ list -> typ list -> BNF -> typ
+  val mk_bd_of_bnf: typ list -> typ list -> BNF -> term
+  val mk_map_of_bnf: typ list -> typ list -> typ list -> BNF -> term
+  val mk_pred_of_bnf: typ list -> typ list -> typ list -> BNF -> term
+  val mk_rel_of_bnf: typ list -> typ list -> typ list -> BNF -> term
+  val mk_sets_of_bnf: typ list list -> typ list list -> BNF -> term list
+  val mk_wits_of_bnf: typ list list -> typ list list -> BNF -> (int list * term) list
+
+  val bd_Card_order_of_bnf: BNF -> thm
+  val bd_Cinfinite_of_bnf: BNF -> thm
+  val bd_Cnotzero_of_bnf: BNF -> thm
+  val bd_card_order_of_bnf: BNF -> thm
+  val bd_cinfinite_of_bnf: BNF -> thm
+  val collect_set_natural_of_bnf: BNF -> thm
+  val in_bd_of_bnf: BNF -> thm
+  val in_cong_of_bnf: BNF -> thm
+  val in_mono_of_bnf: BNF -> thm
+  val in_rel_of_bnf: BNF -> thm
+  val map_comp'_of_bnf: BNF -> thm
+  val map_comp_of_bnf: BNF -> thm
+  val map_cong_of_bnf: BNF -> thm
+  val map_def_of_bnf: BNF -> thm
+  val map_id'_of_bnf: BNF -> thm
+  val map_id_of_bnf: BNF -> thm
+  val map_wppull_of_bnf: BNF -> thm
+  val map_wpull_of_bnf: BNF -> thm
+  val pred_def_of_bnf: BNF -> thm
+  val rel_Gr_of_bnf: BNF -> thm
+  val rel_Id_of_bnf: BNF -> thm
+  val rel_O_of_bnf: BNF -> thm
+  val rel_cong_of_bnf: BNF -> thm
+  val rel_converse_of_bnf: BNF -> thm
+  val rel_def_of_bnf: BNF -> thm
+  val rel_mono_of_bnf: BNF -> thm
+  val set_bd_of_bnf: BNF -> thm list
+  val set_defs_of_bnf: BNF -> thm list
+  val set_natural'_of_bnf: BNF -> thm list
+  val set_natural_of_bnf: BNF -> thm list
+  val sets_of_bnf: BNF -> term list
+  val wit_thms_of_bnf: BNF -> thm list
+  val wit_thmss_of_bnf: BNF -> thm list list
+
+  val mk_witness: int list * term -> thm list -> nonemptiness_witness
+  val minimize_wits: (''a list * term) list -> (''a list * term) list
+  val wits_of_bnf: BNF -> nonemptiness_witness list
+
+  datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
+  datatype fact_policy =
+    Derive_Some_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms
+  val bnf_note_all: bool Config.T
+  val user_policy: Proof.context -> fact_policy
+
+  val print_bnfs: Proof.context -> unit
+  val add_bnf: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
+    ({prems: thm list, context: Proof.context} -> tactic) list ->
+    ({prems: thm list, context: Proof.context} -> tactic) -> typ list option ->
+    (((binding * term) * term list) * term) * term list -> local_theory ->
+    BNF * local_theory
+
+  val filter_refl: thm list -> thm list
+  val add_bnf_cmd: (((binding * string) * string list) * string) * string list -> local_theory ->
+    Proof.state
+end;
+
+structure BNF_Def : BNF_DEF =
+struct
+
+open BNF_Util
+open BNF_Tactics
+
+type axioms = {
+  map_id: thm,
+  map_comp: thm,
+  map_cong: thm,
+  set_natural: thm list,
+  bd_card_order: thm,
+  bd_cinfinite: thm,
+  set_bd: thm list,
+  in_bd: thm,
+  map_wpull: thm
+};
+
+fun mk_axioms' ((((((((id, comp), cong), nat), c_o), cinf), set_bd), in_bd), wpull) =
+  {map_id = id, map_comp = comp, map_cong = cong, set_natural = nat, bd_card_order = c_o,
+   bd_cinfinite = cinf, set_bd = set_bd, in_bd = in_bd, map_wpull = wpull};
+
+fun dest_cons [] = raise Empty
+  | dest_cons (x :: xs) = (x, xs);
+
+fun mk_axioms n thms = thms
+  |> map the_single
+  |> dest_cons
+  ||>> dest_cons
+  ||>> dest_cons
+  ||>> chop n
+  ||>> dest_cons
+  ||>> dest_cons
+  ||>> chop n
+  ||>> dest_cons
+  ||> the_single
+  |> mk_axioms';
+
+fun dest_axioms {map_id, map_comp, map_cong, set_natural,
+  bd_card_order, bd_cinfinite, set_bd, in_bd, map_wpull} =
+  [map_id, map_comp, map_cong] @ set_natural @ [bd_card_order, bd_cinfinite] @
+  set_bd @ [in_bd, map_wpull];
+
+fun map_axioms f
+  {map_id = map_id, map_comp = map_comp, map_cong = map_cong, set_natural = set_natural,
+   bd_card_order = bd_card_order, bd_cinfinite = bd_cinfinite,
+   set_bd = set_bd, in_bd = in_bd, map_wpull = map_wpull} =
+  {map_id = f map_id,
+   map_comp = f map_comp,
+   map_cong = f map_cong,
+   set_natural = map f set_natural,
+   bd_card_order = f bd_card_order,
+   bd_cinfinite = f bd_cinfinite,
+   set_bd = map f set_bd,
+   in_bd = f in_bd,
+   map_wpull = f map_wpull};
+
+val morph_axioms = map_axioms o Morphism.thm;
+
+type defs = {
+  map_def: thm,
+  set_defs: thm list,
+  rel_def: thm,
+  pred_def: thm
+}
+
+fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred};
+
+fun map_defs f {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred} =
+  {map_def = f map, set_defs = List.map f sets, rel_def = f rel, pred_def = f pred};
+
+val morph_defs = map_defs o Morphism.thm;
+
+type facts = {
+  bd_Card_order: thm,
+  bd_Cinfinite: thm,
+  bd_Cnotzero: thm,
+  collect_set_natural: thm lazy,
+  in_cong: thm lazy,
+  in_mono: thm lazy,
+  in_rel: thm lazy,
+  map_comp': thm lazy,
+  map_id': thm lazy,
+  map_wppull: thm lazy,
+  rel_cong: thm lazy,
+  rel_mono: thm lazy,
+  rel_Id: thm lazy,
+  rel_Gr: thm lazy,
+  rel_converse: thm lazy,
+  rel_O: thm lazy,
+  set_natural': thm lazy list
+};
+
+fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero
+    collect_set_natural in_cong in_mono in_rel map_comp' map_id' map_wppull
+    rel_cong rel_mono rel_Id rel_Gr rel_converse rel_O set_natural' = {
+  bd_Card_order = bd_Card_order,
+  bd_Cinfinite = bd_Cinfinite,
+  bd_Cnotzero = bd_Cnotzero,
+  collect_set_natural = collect_set_natural,
+  in_cong = in_cong,
+  in_mono = in_mono,
+  in_rel = in_rel,
+  map_comp' = map_comp',
+  map_id' = map_id',
+  map_wppull = map_wppull,
+  rel_cong = rel_cong,
+  rel_mono = rel_mono,
+  rel_Id = rel_Id,
+  rel_Gr = rel_Gr,
+  rel_converse = rel_converse,
+  rel_O = rel_O,
+  set_natural' = set_natural'};
+
+fun map_facts f {
+  bd_Card_order,
+  bd_Cinfinite,
+  bd_Cnotzero,
+  collect_set_natural,
+  in_cong,
+  in_mono,
+  in_rel,
+  map_comp',
+  map_id',
+  map_wppull,
+  rel_cong,
+  rel_mono,
+  rel_Id,
+  rel_Gr,
+  rel_converse,
+  rel_O,
+  set_natural'} =
+  {bd_Card_order = f bd_Card_order,
+    bd_Cinfinite = f bd_Cinfinite,
+    bd_Cnotzero = f bd_Cnotzero,
+    collect_set_natural = Lazy.map f collect_set_natural,
+    in_cong = Lazy.map f in_cong,
+    in_mono = Lazy.map f in_mono,
+    in_rel = Lazy.map f in_rel,
+    map_comp' = Lazy.map f map_comp',
+    map_id' = Lazy.map f map_id',
+    map_wppull = Lazy.map f map_wppull,
+    rel_cong = Lazy.map f rel_cong,
+    rel_mono = Lazy.map f rel_mono,
+    rel_Id = Lazy.map f rel_Id,
+    rel_Gr = Lazy.map f rel_Gr,
+    rel_converse = Lazy.map f rel_converse,
+    rel_O = Lazy.map f rel_O,
+    set_natural' = map (Lazy.map f) set_natural'};
+
+val morph_facts = map_facts o Morphism.thm;
+
+type nonemptiness_witness = {
+  I: int list,
+  wit: term,
+  prop: thm list
+};
+
+fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
+fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
+fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
+
+datatype BNF = BNF of {
+  name: binding,
+  T: typ,
+  live: int,
+  lives: typ list, (*source type variables of map, only for composition*)
+  lives': typ list, (*target type variables of map, only for composition*)
+  dead: int,
+  deads: typ list, (*only for composition*)
+  map: term,
+  sets: term list,
+  bd: term,
+  axioms: axioms,
+  defs: defs,
+  facts: facts,
+  nwits: int,
+  wits: nonemptiness_witness list,
+  rel: term,
+  pred: term
+};
+
+(* getters *)
+
+fun rep_bnf (BNF bnf) = bnf;
+val name_of_bnf = #name o rep_bnf;
+val T_of_bnf = #T o rep_bnf;
+fun mk_T_of_bnf Ds Ts bnf =
+  let val bnf_rep = rep_bnf bnf
+  in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
+val live_of_bnf = #live o rep_bnf;
+val lives_of_bnf = #lives o rep_bnf;
+val dead_of_bnf = #dead o rep_bnf;
+val deads_of_bnf = #deads o rep_bnf;
+val axioms_of_bnf = #axioms o rep_bnf;
+val facts_of_bnf = #facts o rep_bnf;
+val nwits_of_bnf = #nwits o rep_bnf;
+val wits_of_bnf = #wits o rep_bnf;
+
+(*terms*)
+val map_of_bnf = #map o rep_bnf;
+val sets_of_bnf = #sets o rep_bnf;
+fun mk_map_of_bnf Ds Ts Us bnf =
+  let val bnf_rep = rep_bnf bnf;
+  in
+    Term.subst_atomic_types
+      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
+  end;
+fun mk_sets_of_bnf Dss Tss bnf =
+  let val bnf_rep = rep_bnf bnf;
+  in
+    map2 (fn (Ds, Ts) => Term.subst_atomic_types
+      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
+  end;
+val bd_of_bnf = #bd o rep_bnf;
+fun mk_bd_of_bnf Ds Ts bnf =
+  let val bnf_rep = rep_bnf bnf;
+  in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
+fun mk_wits_of_bnf Dss Tss bnf =
+  let
+    val bnf_rep = rep_bnf bnf;
+    val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
+  in
+    map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
+      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
+  end;
+val rel_of_bnf = #rel o rep_bnf;
+fun mk_rel_of_bnf Ds Ts Us bnf =
+  let val bnf_rep = rep_bnf bnf;
+  in
+    Term.subst_atomic_types
+      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
+  end;
+val pred_of_bnf = #pred o rep_bnf;
+fun mk_pred_of_bnf Ds Ts Us bnf =
+  let val bnf_rep = rep_bnf bnf;
+  in
+    Term.subst_atomic_types
+      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#pred bnf_rep)
+  end;
+
+(*thms*)
+val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
+val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
+val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
+val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
+val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
+val collect_set_natural_of_bnf = Lazy.force o #collect_set_natural o #facts o rep_bnf;
+val in_bd_of_bnf = #in_bd o #axioms o rep_bnf;
+val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
+val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
+val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
+val map_def_of_bnf = #map_def o #defs o rep_bnf;
+val map_id_of_bnf = #map_id o #axioms o rep_bnf;
+val map_id'_of_bnf = Lazy.force o #map_id' o #facts o rep_bnf;
+val map_comp_of_bnf = #map_comp o #axioms o rep_bnf;
+val map_comp'_of_bnf = Lazy.force o #map_comp' o #facts o rep_bnf;
+val map_cong_of_bnf = #map_cong o #axioms o rep_bnf;
+val map_wppull_of_bnf = Lazy.force o #map_wppull o #facts o rep_bnf;
+val map_wpull_of_bnf = #map_wpull o #axioms o rep_bnf;
+val pred_def_of_bnf = #pred_def o #defs o rep_bnf;
+val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
+val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
+val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
+val rel_Id_of_bnf = Lazy.force o #rel_Id o #facts o rep_bnf;
+val rel_Gr_of_bnf = Lazy.force o #rel_Gr o #facts o rep_bnf;
+val rel_converse_of_bnf = Lazy.force o #rel_converse o #facts o rep_bnf;
+val rel_O_of_bnf = Lazy.force o #rel_O o #facts o rep_bnf;
+val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
+val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
+val set_natural_of_bnf = #set_natural o #axioms o rep_bnf;
+val set_natural'_of_bnf = map Lazy.force o #set_natural' o #facts o rep_bnf;
+val wit_thms_of_bnf = maps #prop o wits_of_bnf;
+val wit_thmss_of_bnf = map #prop o wits_of_bnf;
+
+fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred =
+  BNF {name = name, T = T,
+       live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
+       map = map, sets = sets, bd = bd,
+       axioms = axioms, defs = defs, facts = facts,
+       nwits = length wits, wits = wits, rel = rel, pred = pred};
+
+fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
+  dead = dead, deads = deads, map = map, sets = sets, bd = bd,
+  axioms = axioms, defs = defs, facts = facts,
+  nwits = nwits, wits = wits, rel = rel, pred = pred}) =
+  BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
+    live = live, lives = List.map (Morphism.typ phi) lives,
+    lives' = List.map (Morphism.typ phi) lives',
+    dead = dead, deads = List.map (Morphism.typ phi) deads,
+    map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
+    bd = Morphism.term phi bd,
+    axioms = morph_axioms phi axioms,
+    defs = morph_defs phi defs,
+    facts = morph_facts phi facts,
+    nwits = nwits,
+    wits = List.map (morph_witness phi) wits,
+    rel = Morphism.term phi rel, pred = Morphism.term phi pred};
+
+fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
+  BNF {T = T2, live = live2, dead = dead2, ...}) =
+  Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
+
+structure Data = Generic_Data
+(
+  type T = BNF Symtab.table;
+  val empty = Symtab.empty;
+  val extend = I;
+  val merge = Symtab.merge (eq_bnf);
+);
+
+val bnf_of = Symtab.lookup o Data.get o Context.Proof;
+
+
+
+(* Utilities *)
+
+fun normalize_set insts instA set =
+  let
+    val (T, T') = dest_funT (fastype_of set);
+    val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
+    val params = Term.add_tvar_namesT T [];
+  in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
+
+fun normalize_rel ctxt instTs instA instB rel =
+  let
+    val thy = Proof_Context.theory_of ctxt;
+    val tyenv =
+      Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_relT (instA, instB)))
+        Vartab.empty;
+  in Envir.subst_term (tyenv, Vartab.empty) rel end;
+
+fun normalize_pred ctxt instTs instA instB pred =
+  let
+    val thy = Proof_Context.theory_of ctxt;
+    val tyenv =
+      Sign.typ_match thy (fastype_of pred,
+        Library.foldr (op -->) (instTs, instA --> instB --> HOLogic.boolT)) Vartab.empty;
+  in Envir.subst_term (tyenv, Vartab.empty) pred end;
+
+fun normalize_wit insts CA As wit =
+  let
+    fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
+        if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
+      | strip_param x = x;
+    val (Ts, T) = strip_param ([], fastype_of wit);
+    val subst = Term.add_tvar_namesT T [] ~~ insts;
+    fun find y = find_index (fn x => x = y) As;
+  in
+    (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
+  end;
+
+fun minimize_wits wits =
+ let
+   fun minimize done [] = done
+     | minimize done ((I, wit : term) :: todo) =
+       if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
+       then minimize done todo
+       else minimize ((I, wit) :: done) todo;
+ in minimize [] wits end;
+
+fun unfold_defs_tac lthy defs mk_tac context = Local_Defs.unfold_tac lthy defs THEN mk_tac context;
+
+
+
+(* Names *)
+
+fun nonzero_string_of_int 0 = ""
+  | nonzero_string_of_int n = string_of_int n;
+
+val mapN = "map";
+val setN = "set";
+fun mk_setN i = setN ^ nonzero_string_of_int i;
+val bdN = "bd";
+val witN = "wit";
+fun mk_witN i = witN ^ nonzero_string_of_int i;
+val relN = "rel";
+val predN = "pred";
+val rel_unfoldN = relN ^ "_unfold";
+val pred_unfoldN = predN ^ "_unfold";
+
+val bd_card_orderN = "bd_card_order";
+val bd_cinfiniteN = "bd_cinfinite";
+val bd_Card_orderN = "bd_Card_order";
+val bd_CinfiniteN = "bd_Cinfinite";
+val bd_CnotzeroN = "bd_Cnotzero";
+val collect_set_naturalN = "collect_set_natural";
+val in_bdN = "in_bd";
+val in_congN = "in_cong";
+val in_monoN = "in_mono";
+val in_relN = "in_rel";
+val map_idN = "map_id";
+val map_id'N = "map_id'";
+val map_compN = "map_comp";
+val map_comp'N = "map_comp'";
+val map_congN = "map_cong";
+val map_wppullN = "map_wppull";
+val map_wpullN = "map_wpull";
+val rel_congN = "rel_cong";
+val rel_IdN = "rel_Id";
+val rel_GrN = "rel_Gr";
+val rel_converseN = "rel_converse";
+val rel_ON = "rel_comp";
+val set_naturalN = "set_natural";
+val set_natural'N = "set_natural'";
+val set_bdN = "set_bd";
+
+datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
+
+datatype fact_policy =
+  Derive_Some_Facts | Derive_All_Facts | Derive_All_Facts_Note_Most | Note_All_Facts_and_Axioms;
+
+val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
+
+fun user_policy ctxt =
+  if Config.get ctxt bnf_note_all then Note_All_Facts_and_Axioms
+  else Derive_All_Facts_Note_Most;
+
+val smart_max_inline_size = 25; (*FUDGE*)
+
+val no_def = Drule.reflexive_thm;
+val no_fact = refl;
+
+fun is_reflexive th =
+  let val t = Thm.prop_of th;
+  in
+    op aconv (Logic.dest_equals t)
+    handle TERM _ => op aconv (HOLogic.dest_eq (HOLogic.dest_Trueprop t))
+      handle TERM _ => false
+  end;
+
+val filter_refl = filter_out is_reflexive;
+
+
+
+(* Define new BNFs *)
+
+fun prepare_bnf const_policy mk_fact_policy qualify prep_term Ds_opt
+  ((((raw_b, raw_map), raw_sets), raw_bd_Abs), raw_wits) no_defs_lthy =
+  let
+    val fact_policy = mk_fact_policy no_defs_lthy;
+    val b = qualify raw_b;
+    val live = length raw_sets;
+    val nwits = length raw_wits;
+
+    val map_rhs = prep_term no_defs_lthy raw_map;
+    val set_rhss = map (prep_term no_defs_lthy) raw_sets;
+    val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
+      Abs (_, T, t) => (T, t)
+    | _ => error "Bad bound constant");
+    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
+
+    val map_bind_def = (fn () => Binding.suffix_name ("_" ^ mapN) b, map_rhs);
+    val set_binds_defs =
+      let
+        val bs = if live = 1 then [fn () => Binding.suffix_name ("_" ^ setN) b]
+          else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_setN i) b) (1 upto live)
+      in map2 pair bs set_rhss end;
+    val bd_bind_def = (fn () => Binding.suffix_name ("_" ^ bdN) b, bd_rhs);
+    val wit_binds_defs =
+      let
+        val bs = if nwits = 1 then [fn () => Binding.suffix_name ("_" ^ witN) b]
+          else map (fn i => fn () => Binding.suffix_name ("_" ^ mk_witN i) b) (1 upto nwits);
+      in map2 pair bs wit_rhss end;
+
+    fun maybe_define needed_for_fp (b, rhs) lthy =
+      let
+        val inline =
+          (not needed_for_fp orelse fact_policy = Derive_Some_Facts) andalso
+          (case const_policy of
+            Dont_Inline => false
+          | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
+          | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
+          | Do_Inline => true)
+      in
+        if inline then
+          ((rhs, no_def), lthy)
+        else
+          let val b = b () in
+            apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
+              lthy)
+          end
+      end;
+    fun maybe_restore lthy0 lthy = lthy |> not (pointer_eq (lthy0, lthy)) ? Local_Theory.restore;
+
+    val (((((bnf_map_term, raw_map_def),
+      (bnf_set_terms, raw_set_defs)),
+      (bnf_bd_term, raw_bd_def)),
+      (bnf_wit_terms, raw_wit_defs)), (lthy', lthy)) =
+        no_defs_lthy
+        |> maybe_define false map_bind_def
+        ||>> apfst split_list o fold_map (maybe_define false) set_binds_defs
+        ||>> maybe_define false bd_bind_def
+        ||>> apfst split_list o fold_map (maybe_define false) wit_binds_defs
+        ||> `(maybe_restore no_defs_lthy);
+
+    (*transforms defined frees into consts (and more)*)
+    val phi = Proof_Context.export_morphism lthy lthy';
+
+    val bnf_map_def = Morphism.thm phi raw_map_def;
+    val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
+    val bnf_bd_def = Morphism.thm phi raw_bd_def;
+    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
+
+    val one_step_defs = filter_refl (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs);
+
+    val _ = case map_filter (try dest_Free)
+        (bnf_map_term :: bnf_set_terms @ [bnf_bd_term] @ bnf_wit_terms) of
+        [] => ()
+      | frees => Proof_Display.print_consts true lthy (K false) frees;
+
+    val bnf_map = Morphism.term phi bnf_map_term;
+
+    fun iter_split ((Ts, T1), T2) = if length Ts < live then error "Bad map function"
+      else if length Ts = live then ((Ts, T1), T2)
+      else iter_split (split_last Ts, T1 --> T2);
+
+    (*TODO: handle errors*)
+    (*simple shape analysis of a map function*)
+    val (((alphas, betas), CA), _) =
+      apfst (apfst (map_split dest_funT))
+        (iter_split (apfst split_last (strip_type (fastype_of bnf_map))));
+
+    val CA_params = map TVar (Term.add_tvarsT CA []);
+
+    val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
+    val bdT = Morphism.typ phi bd_rhsT;
+    val bnf_bd =
+      Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
+    val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
+
+    (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
+    val deads = (case Ds_opt of
+      NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
+    | SOME Ds => map (Morphism.typ phi) Ds);
+    val dead = length deads;
+
+    (*FIXME: check DUP here, not in after_qed*)
+    val key = Name_Space.full_name Name_Space.default_naming b;
+
+    (*TODO: further checks of type of bnf_map*)
+    (*TODO: check types of bnf_sets*)
+    (*TODO: check type of bnf_bd*)
+
+    val ((((((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), domTs), ranTs), ranTs'), ranTs''),
+      (Ts, T)) = lthy'
+      |> mk_TFrees live
+      ||>> mk_TFrees live
+      ||>> mk_TFrees live
+      ||>> mk_TFrees dead
+      ||>> mk_TFrees live
+      ||>> mk_TFrees live
+      ||>> mk_TFrees live
+      ||>> mk_TFrees live
+      ||>> mk_TFrees live
+      ||>> mk_TFrees live
+      ||> fst o mk_TFrees 1
+      ||> the_single
+      ||> `(replicate live);
+
+    fun mk_bnf_map As' Bs' =
+      Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
+    fun mk_bnf_t As' t =
+      Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As')) t;
+    fun mk_bnf_T As' T =
+      Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As')) T;
+
+    val (setRTs, RTs) = map_split (`HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Bs');
+    val setRTsAsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ Cs);
+    val setRTsBsCs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ Cs);
+    val setRT's = map (HOLogic.mk_setT o HOLogic.mk_prodT) (Bs' ~~ As');
+    val self_setRTs = map (HOLogic.mk_setT o HOLogic.mk_prodT) (As' ~~ As');
+    val QTs = map2 (fn T => fn U => T --> U --> HOLogic.boolT) As' Bs';
+
+    val bnf_map_AsAs = mk_bnf_map As' As';
+    val bnf_map_AsBs = mk_bnf_map As' Bs';
+    val bnf_map_AsCs = mk_bnf_map As' Cs;
+    val bnf_map_BsCs = mk_bnf_map Bs' Cs;
+    val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
+    val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
+    val bnf_bd_As = mk_bnf_t As' bnf_bd;
+    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
+    val CA' = mk_bnf_T As' CA;
+    val CB' = mk_bnf_T Bs' CA;
+    val CC' = mk_bnf_T Cs CA;
+    val CRs' = mk_bnf_T RTs CA;
+
+    val ((((((((((((((((((((((((fs, fs_copy), gs), hs), (x, x')), (y, y')), (z, z')), zs), As),
+      As_copy), Xs), B1s), B2s), f1s), f2s), e1s), e2s), p1s), p2s), bs),
+      (Rs, Rs')), Rs_copy), Ss), (Qs, Qs')), _) = lthy'
+      |> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
+      ||>> mk_Frees "f" (map2 (curry (op -->)) As' Bs')
+      ||>> mk_Frees "g" (map2 (curry (op -->)) Bs' Cs)
+      ||>> mk_Frees "h" (map2 (curry (op -->)) As' Ts)
+      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "x") CA'
+      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "y") CB'
+      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "z") CRs'
+      ||>> mk_Frees "z" As'
+      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
+      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
+      ||>> mk_Frees "A" (map HOLogic.mk_setT domTs)
+      ||>> mk_Frees "B1" (map HOLogic.mk_setT B1Ts)
+      ||>> mk_Frees "B2" (map HOLogic.mk_setT B2Ts)
+      ||>> mk_Frees "f1" (map2 (curry (op -->)) B1Ts ranTs)
+      ||>> mk_Frees "f2" (map2 (curry (op -->)) B2Ts ranTs)
+      ||>> mk_Frees "e1" (map2 (curry (op -->)) B1Ts ranTs')
+      ||>> mk_Frees "e2" (map2 (curry (op -->)) B2Ts ranTs'')
+      ||>> mk_Frees "p1" (map2 (curry (op -->)) domTs B1Ts)
+      ||>> mk_Frees "p2" (map2 (curry (op -->)) domTs B2Ts)
+      ||>> mk_Frees "b" As'
+      ||>> mk_Frees' "R" setRTs
+      ||>> mk_Frees "R" setRTs
+      ||>> mk_Frees "S" setRTsBsCs
+      ||>> mk_Frees' "Q" QTs;
+
+    val goal_map_id =
+      let
+        val bnf_map_app_id = Term.list_comb
+          (bnf_map_AsAs, map HOLogic.id_const As');
+      in
+        HOLogic.mk_Trueprop
+          (HOLogic.mk_eq (bnf_map_app_id, HOLogic.id_const CA'))
+      end;
+
+    val goal_map_comp =
+      let
+        val bnf_map_app_comp = Term.list_comb
+          (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
+        val comp_bnf_map_app = HOLogic.mk_comp
+          (Term.list_comb (bnf_map_BsCs, gs),
+           Term.list_comb (bnf_map_AsBs, fs));
+      in
+        fold_rev Logic.all (fs @ gs)
+          (HOLogic.mk_Trueprop (HOLogic.mk_eq (bnf_map_app_comp, comp_bnf_map_app)))
+      end;
+
+    val goal_map_cong =
+      let
+        fun mk_prem z set f f_copy =
+          Logic.all z (Logic.mk_implies
+            (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
+            HOLogic.mk_Trueprop (HOLogic.mk_eq (f $ z, f_copy $ z))));
+        val prems = map4 mk_prem zs bnf_sets_As fs fs_copy;
+        val eq = HOLogic.mk_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
+          Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
+      in
+        fold_rev Logic.all (x :: fs @ fs_copy)
+          (Logic.list_implies (prems, HOLogic.mk_Trueprop eq))
+      end;
+
+    val goal_set_naturals =
+      let
+        fun mk_goal setA setB f =
+          let
+            val set_comp_map =
+              HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
+            val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
+          in
+            fold_rev Logic.all fs
+              (HOLogic.mk_Trueprop (HOLogic.mk_eq (set_comp_map, image_comp_set)))
+          end;
+      in
+        map3 mk_goal bnf_sets_As bnf_sets_Bs fs
+      end;
+
+    val goal_card_order_bd = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
+
+    val goal_cinfinite_bd = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
+
+    val goal_set_bds =
+      let
+        fun mk_goal set =
+          Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
+      in
+        map mk_goal bnf_sets_As
+      end;
+
+    val goal_in_bd =
+      let
+        val bd = mk_cexp
+          (if live = 0 then ctwo
+            else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
+          bnf_bd_As;
+      in
+        fold_rev Logic.all As
+          (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd))
+      end;
+
+    val goal_map_wpull =
+      let
+        val prems = map HOLogic.mk_Trueprop
+          (map8 mk_wpull Xs B1s B2s f1s f2s (replicate live NONE) p1s p2s);
+        val CX = mk_bnf_T domTs CA;
+        val CB1 = mk_bnf_T B1Ts CA;
+        val CB2 = mk_bnf_T B2Ts CA;
+        val bnf_sets_CX = map2 (normalize_set (map (mk_bnf_T domTs) CA_params)) domTs bnf_sets;
+        val bnf_sets_CB1 = map2 (normalize_set (map (mk_bnf_T B1Ts) CA_params)) B1Ts bnf_sets;
+        val bnf_sets_CB2 = map2 (normalize_set (map (mk_bnf_T B2Ts) CA_params)) B2Ts bnf_sets;
+        val bnf_map_app_f1 = Term.list_comb (mk_bnf_map B1Ts ranTs, f1s);
+        val bnf_map_app_f2 = Term.list_comb (mk_bnf_map B2Ts ranTs, f2s);
+        val bnf_map_app_p1 = Term.list_comb (mk_bnf_map domTs B1Ts, p1s);
+        val bnf_map_app_p2 = Term.list_comb (mk_bnf_map domTs B2Ts, p2s);
+
+        val map_wpull = mk_wpull (mk_in Xs bnf_sets_CX CX)
+          (mk_in B1s bnf_sets_