moved BNF files to 'HOL'
authorblanchet
Mon, 20 Jan 2014 18:24:56 +0100
changeset 55058 4e700eb471d4
parent 55057 6b0fcbeebaba
child 55059 ef2e0fb783c6
moved BNF files to 'HOL'
src/HOL/BNF/BNF.thy
src/HOL/BNF/BNF_Comp.thy
src/HOL/BNF/BNF_Def.thy
src/HOL/BNF/BNF_FP_Base.thy
src/HOL/BNF/BNF_GFP.thy
src/HOL/BNF/BNF_LFP.thy
src/HOL/BNF/BNF_Util.thy
src/HOL/BNF/Basic_BNFs.thy
src/HOL/BNF/Tools/bnf_comp.ML
src/HOL/BNF/Tools/bnf_comp_tactics.ML
src/HOL/BNF/Tools/bnf_def.ML
src/HOL/BNF/Tools/bnf_def_tactics.ML
src/HOL/BNF/Tools/bnf_fp_def_sugar.ML
src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML
src/HOL/BNF/Tools/bnf_fp_n2m.ML
src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML
src/HOL/BNF/Tools/bnf_fp_n2m_tactics.ML
src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML
src/HOL/BNF/Tools/bnf_fp_util.ML
src/HOL/BNF/Tools/bnf_gfp.ML
src/HOL/BNF/Tools/bnf_gfp_rec_sugar.ML
src/HOL/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML
src/HOL/BNF/Tools/bnf_gfp_tactics.ML
src/HOL/BNF/Tools/bnf_gfp_util.ML
src/HOL/BNF/Tools/bnf_lfp.ML
src/HOL/BNF/Tools/bnf_lfp_compat.ML
src/HOL/BNF/Tools/bnf_lfp_rec_sugar.ML
src/HOL/BNF/Tools/bnf_lfp_tactics.ML
src/HOL/BNF/Tools/bnf_lfp_util.ML
src/HOL/BNF/Tools/bnf_tactics.ML
src/HOL/BNF/Tools/bnf_util.ML
src/HOL/BNF_Comp.thy
src/HOL/BNF_Def.thy
src/HOL/BNF_FP_Base.thy
src/HOL/BNF_GFP.thy
src/HOL/BNF_LFP.thy
src/HOL/BNF_Util.thy
src/HOL/Basic_BNFs.thy
src/HOL/Main.thy
src/HOL/Tools/BNF/Tools/bnf_comp.ML
src/HOL/Tools/BNF/Tools/bnf_comp_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_decl.ML
src/HOL/Tools/BNF/Tools/bnf_def.ML
src/HOL/Tools/BNF/Tools/bnf_def_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_fp_def_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_fp_def_sugar_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_fp_n2m.ML
src/HOL/Tools/BNF/Tools/bnf_fp_n2m_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_fp_n2m_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_fp_rec_sugar_util.ML
src/HOL/Tools/BNF/Tools/bnf_fp_util.ML
src/HOL/Tools/BNF/Tools/bnf_gfp.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_rec_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_util.ML
src/HOL/Tools/BNF/Tools/bnf_lfp.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_compat.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_rec_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_util.ML
src/HOL/Tools/BNF/Tools/bnf_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_util.ML
--- a/src/HOL/BNF/BNF.thy	Mon Jan 20 18:24:55 2014 +0100
+++ b/src/HOL/BNF/BNF.thy	Mon Jan 20 18:24:56 2014 +0100
@@ -10,7 +10,7 @@
 header {* Bounded Natural Functors for (Co)datatypes *}
 
 theory BNF
-imports Countable_Set_Type BNF_LFP BNF_GFP BNF_Decl
+imports Countable_Set_Type BNF_Decl
 begin
 
 hide_const (open) image2 image2p vimage2p Gr Grp collect fsts snds setl setr 
--- a/src/HOL/BNF/BNF_Comp.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,76 +0,0 @@
-(*  Title:      HOL/BNF/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
-begin
-
-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
-
-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 blast
-
-lemma UN_image_subset: "\<Union>(f ` g x) \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
-by blast
-
-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 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 Grp_fst_snd: "(Grp (Collect (split R)) fst)^--1 OO Grp (Collect (split R)) snd = R"
-unfolding Grp_def fun_eq_iff relcompp.simps by auto
-
-lemma OO_Grp_cong: "A = B \<Longrightarrow> (Grp A f)^--1 OO Grp A g = (Grp B f)^--1 OO Grp B g"
-by simp
-
-ML_file "Tools/bnf_comp_tactics.ML"
-ML_file "Tools/bnf_comp.ML"
-
-end
--- a/src/HOL/BNF/BNF_Def.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,163 +0,0 @@
-(*  Title:      HOL/BNF/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_Util
-   (*FIXME: register fundef_cong attribute in an interpretation to remove this dependency*)
-  FunDef
-keywords
-  "print_bnfs" :: diag and
-  "bnf" :: thy_goal
-begin
-
-lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
-  by (rule ext) (auto simp only: o_apply collect_def)
-
-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 convol_mem_GrpI:
-"x \<in> A \<Longrightarrow> <id , g> x \<in> (Collect (split (Grp A g)))"
-unfolding convol_def Grp_def by auto
-
-definition csquare where
-"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
-
-lemma eq_alt: "op = = Grp UNIV id"
-unfolding Grp_def by auto
-
-lemma leq_conversepI: "R = op = \<Longrightarrow> R \<le> R^--1"
-  by auto
-
-lemma leq_OOI: "R = op = \<Longrightarrow> R \<le> R OO R"
-  by auto
-
-lemma OO_Grp_alt: "(Grp A f)^--1 OO Grp A g = (\<lambda>x y. \<exists>z. z \<in> A \<and> f z = x \<and> g z = y)"
-  unfolding Grp_def by auto
-
-lemma Grp_UNIV_id: "f = id \<Longrightarrow> (Grp UNIV f)^--1 OO Grp UNIV f = Grp UNIV f"
-unfolding Grp_def by auto
-
-lemma Grp_UNIV_idI: "x = y \<Longrightarrow> Grp UNIV id x y"
-unfolding Grp_def by auto
-
-lemma Grp_mono: "A \<le> B \<Longrightarrow> Grp A f \<le> Grp B f"
-unfolding Grp_def by auto
-
-lemma GrpI: "\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> Grp A f x y"
-unfolding Grp_def by auto
-
-lemma GrpE: "Grp A f x y \<Longrightarrow> (\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
-unfolding Grp_def by auto
-
-lemma Collect_split_Grp_eqD: "z \<in> Collect (split (Grp A f)) \<Longrightarrow> (f \<circ> fst) z = snd z"
-unfolding Grp_def o_def by auto
-
-lemma Collect_split_Grp_inD: "z \<in> Collect (split (Grp A f)) \<Longrightarrow> fst z \<in> A"
-unfolding Grp_def o_def by auto
-
-definition "pick_middlep P Q a c = (SOME b. P a b \<and> Q b c)"
-
-lemma pick_middlep:
-"(P OO Q) a c \<Longrightarrow> P a (pick_middlep P Q a c) \<and> Q (pick_middlep P Q a c) c"
-unfolding pick_middlep_def apply(rule someI_ex) by auto
-
-definition fstOp where "fstOp P Q ac = (fst ac, pick_middlep P Q (fst ac) (snd ac))"
-definition sndOp where "sndOp P Q ac = (pick_middlep P Q (fst ac) (snd ac), (snd ac))"
-
-lemma fstOp_in: "ac \<in> Collect (split (P OO Q)) \<Longrightarrow> fstOp P Q ac \<in> Collect (split P)"
-unfolding fstOp_def mem_Collect_eq
-by (subst (asm) surjective_pairing, unfold prod.cases) (erule pick_middlep[THEN conjunct1])
-
-lemma fst_fstOp: "fst bc = (fst \<circ> fstOp P Q) bc"
-unfolding comp_def fstOp_def by simp
-
-lemma snd_sndOp: "snd bc = (snd \<circ> sndOp P Q) bc"
-unfolding comp_def sndOp_def by simp
-
-lemma sndOp_in: "ac \<in> Collect (split (P OO Q)) \<Longrightarrow> sndOp P Q ac \<in> Collect (split Q)"
-unfolding sndOp_def mem_Collect_eq
-by (subst (asm) surjective_pairing, unfold prod.cases) (erule pick_middlep[THEN conjunct2])
-
-lemma csquare_fstOp_sndOp:
-"csquare (Collect (split (P OO Q))) snd fst (fstOp P Q) (sndOp P Q)"
-unfolding csquare_def fstOp_def sndOp_def using pick_middlep 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_pred: "A \<subseteq> Collect (split (R ^--1)) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> Collect (split R)"
-by auto
-
-lemma Collect_split_mono: "A \<le> B \<Longrightarrow> Collect (split A) \<subseteq> Collect (split B)"
-  by auto
-
-lemma Collect_split_mono_strong: 
-  "\<lbrakk>\<forall>a\<in>fst ` A. \<forall>b \<in> snd ` A. P a b \<longrightarrow> Q a b; A \<subseteq> Collect (split P)\<rbrakk> \<Longrightarrow>
-  A \<subseteq> Collect (split Q)"
-  by fastforce
-
-lemma predicate2_eqD: "A = B \<Longrightarrow> A a b \<longleftrightarrow> B a b"
-by metis
-
-lemma sum_case_o_inj:
-"sum_case f g \<circ> Inl = f"
-"sum_case f g \<circ> Inr = g"
-by auto
-
-lemma card_order_csum_cone_cexp_def:
-  "card_order r \<Longrightarrow> ( |A1| +c cone) ^c r = |Func UNIV (Inl ` A1 \<union> {Inr ()})|"
-  unfolding cexp_def cone_def Field_csum Field_card_of by (auto dest: Field_card_order)
-
-lemma If_the_inv_into_in_Func:
-  "\<lbrakk>inj_on g C; C \<subseteq> B \<union> {x}\<rbrakk> \<Longrightarrow>
-  (\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) \<in> Func UNIV (B \<union> {x})"
-unfolding Func_def by (auto dest: the_inv_into_into)
-
-lemma If_the_inv_into_f_f:
-  "\<lbrakk>i \<in> C; inj_on g C\<rbrakk> \<Longrightarrow>
-  ((\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) o g) i = id i"
-unfolding Func_def by (auto elim: the_inv_into_f_f)
-
-definition vimage2p where
-  "vimage2p f g R = (\<lambda>x y. R (f x) (g y))"
-
-lemma vimage2pI: "R (f x) (g y) \<Longrightarrow> vimage2p f g R x y"
-  unfolding vimage2p_def by -
-
-lemma fun_rel_iff_leq_vimage2p: "(fun_rel R S) f g = (R \<le> vimage2p f g S)"
-  unfolding fun_rel_def vimage2p_def by auto
-
-lemma convol_image_vimage2p: "<f o fst, g o snd> ` Collect (split (vimage2p f g R)) \<subseteq> Collect (split R)"
-  unfolding vimage2p_def convol_def by auto
-
-lemma vimage2p_Grp: "vimage2p f g P = Grp UNIV f OO P OO (Grp UNIV g)\<inverse>\<inverse>"
-  unfolding vimage2p_def Grp_def by auto
-
-(*FIXME: duplicates lemma from Record.thy*)
-lemma o_eq_dest_lhs: "a o b = c \<Longrightarrow> a (b v) = c v"
-  by clarsimp
-
-ML_file "Tools/bnf_def_tactics.ML"
-ML_file "Tools/bnf_def.ML"
-
-end
--- a/src/HOL/BNF/BNF_FP_Base.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,170 +0,0 @@
-(*  Title:      HOL/BNF/BNF_FP_Base.thy
-    Author:     Lorenz Panny, TU Muenchen
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
-
-Shared fixed point operations on bounded natural functors, including
-*)
-
-header {* Shared Fixed Point Operations on Bounded Natural Functors *}
-
-theory BNF_FP_Base
-imports BNF_Comp Ctr_Sugar
-begin
-
-lemma mp_conj: "(P \<longrightarrow> Q) \<and> R \<Longrightarrow> P \<Longrightarrow> R \<and> Q"
-by auto
-
-lemma eq_sym_Unity_conv: "(x = (() = ())) = x"
-by blast
-
-lemma unit_case_Unity: "(case u of () \<Rightarrow> f) = f"
-by (cases u) (hypsubst, rule unit.cases)
-
-lemma prod_case_Pair_iden: "(case p of (x, y) \<Rightarrow> (x, y)) = p"
-by simp
-
-lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
-by simp
-
-lemma prod_all_impI: "(\<And>x y. P (x, y) \<Longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
-by clarify
-
-lemma prod_all_impI_step: "(\<And>x. \<forall>y. P (x, y) \<longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
-by auto
-
-lemma pointfree_idE: "f \<circ> g = id \<Longrightarrow> f (g x) = x"
-unfolding o_def fun_eq_iff by simp
-
-lemma o_bij:
-  assumes gf: "g \<circ> f = id" and fg: "f \<circ> 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 ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" 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 one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
-by simp
-
-lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
-by blast
-
-lemma obj_sumE_f:
-"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f x \<longrightarrow> P"
-by (rule allI) (metis sumE)
-
-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 sum_case_if:
-"sum_case f g (if p then Inl x else Inr y) = (if p then f x else g y)"
-by simp
-
-lemma mem_UN_compreh_eq: "(z : \<Union>{y. \<exists>x\<in>A. y = F x}) = (\<exists>x\<in>A. z : F x)"
-by blast
-
-lemma UN_compreh_eq_eq:
-"\<Union>{y. \<exists>x\<in>A. y = {}} = {}"
-"\<Union>{y. \<exists>x\<in>A. y = {x}} = A"
-by blast+
-
-lemma Inl_Inr_False: "(Inl x = Inr y) = False"
-by simp
-
-lemma prod_set_simps:
-"fsts (x, y) = {x}"
-"snds (x, y) = {y}"
-unfolding fsts_def snds_def by simp+
-
-lemma sum_set_simps:
-"setl (Inl x) = {x}"
-"setl (Inr x) = {}"
-"setr (Inl x) = {}"
-"setr (Inr x) = {x}"
-unfolding sum_set_defs by simp+
-
-lemma prod_rel_simp:
-"prod_rel P Q (x, y) (x', y') \<longleftrightarrow> P x x' \<and> Q y y'"
-unfolding prod_rel_def by simp
-
-lemma sum_rel_simps:
-"sum_rel P Q (Inl x) (Inl x') \<longleftrightarrow> P x x'"
-"sum_rel P Q (Inr y) (Inr y') \<longleftrightarrow> Q y y'"
-"sum_rel P Q (Inl x) (Inr y') \<longleftrightarrow> False"
-"sum_rel P Q (Inr y) (Inl x') \<longleftrightarrow> False"
-unfolding sum_rel_def by simp+
-
-lemma spec2: "\<forall>x y. P x y \<Longrightarrow> P x y"
-by blast
-
-lemma rewriteR_comp_comp: "\<lbrakk>g o h = r\<rbrakk> \<Longrightarrow> f o g o h = f o r"
-  unfolding o_def fun_eq_iff by auto
-
-lemma rewriteR_comp_comp2: "\<lbrakk>g o h = r1 o r2; f o r1 = l\<rbrakk> \<Longrightarrow> f o g o h = l o r2"
-  unfolding o_def fun_eq_iff by auto
-
-lemma rewriteL_comp_comp: "\<lbrakk>f o g = l\<rbrakk> \<Longrightarrow> f o (g o h) = l o h"
-  unfolding o_def fun_eq_iff by auto
-
-lemma rewriteL_comp_comp2: "\<lbrakk>f o g = l1 o l2; l2 o h = r\<rbrakk> \<Longrightarrow> f o (g o h) = l1 o r"
-  unfolding o_def fun_eq_iff by auto
-
-lemma convol_o: "<f, g> o h = <f o h, g o h>"
-  unfolding convol_def by auto
-
-lemma map_pair_o_convol: "map_pair h1 h2 o <f, g> = <h1 o f, h2 o g>"
-  unfolding convol_def by auto
-
-lemma map_pair_o_convol_id: "(map_pair f id \<circ> <id , g>) x = <id \<circ> f , g> x"
-  unfolding map_pair_o_convol id_o o_id ..
-
-lemma o_sum_case: "h o sum_case f g = sum_case (h o f) (h o g)"
-  unfolding o_def by (auto split: sum.splits)
-
-lemma sum_case_o_sum_map: "sum_case f g o sum_map h1 h2 = sum_case (f o h1) (g o h2)"
-  unfolding o_def by (auto split: sum.splits)
-
-lemma sum_case_o_sum_map_id: "(sum_case id g o sum_map f id) x = sum_case (f o id) g x"
-  unfolding sum_case_o_sum_map id_o o_id ..
-
-lemma fun_rel_def_butlast:
-  "(fun_rel R (fun_rel S T)) f g = (\<forall>x y. R x y \<longrightarrow> (fun_rel S T) (f x) (g y))"
-  unfolding fun_rel_def ..
-
-lemma subst_eq_imp: "(\<forall>a b. a = b \<longrightarrow> P a b) \<equiv> (\<forall>a. P a a)"
-  by auto
-
-lemma eq_subset: "op = \<le> (\<lambda>a b. P a b \<or> a = b)"
-  by auto
-
-lemma eq_le_Grp_id_iff: "(op = \<le> Grp (Collect R) id) = (All R)"
-  unfolding Grp_def id_apply by blast
-
-lemma Grp_id_mono_subst: "(\<And>x y. Grp P id x y \<Longrightarrow> Grp Q id (f x) (f y)) \<equiv>
-   (\<And>x. x \<in> P \<Longrightarrow> f x \<in> Q)"
-  unfolding Grp_def by rule auto
-
-ML_file "Tools/bnf_fp_util.ML"
-ML_file "Tools/bnf_fp_def_sugar_tactics.ML"
-ML_file "Tools/bnf_fp_def_sugar.ML"
-ML_file "Tools/bnf_fp_n2m_tactics.ML"
-ML_file "Tools/bnf_fp_n2m.ML"
-ML_file "Tools/bnf_fp_n2m_sugar.ML"
-ML_file "Tools/bnf_fp_rec_sugar_util.ML"
-
-end
--- a/src/HOL/BNF/BNF_GFP.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,356 +0,0 @@
-(*  Title:      HOL/BNF/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_FP_Base
-keywords
-  "codatatype" :: thy_decl and
-  "primcorecursive" :: thy_goal and
-  "primcorec" :: thy_decl
-begin
-
-setup {*
-Sign.const_alias @{binding proj} @{const_name Equiv_Relations.proj}
-*}
-
-lemma not_TrueE: "\<not> True \<Longrightarrow> P"
-by (erule notE, rule TrueI)
-
-lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
-by fast
-
-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 sum_case_expand_Inr': "f o Inl = g \<Longrightarrow> h = f o Inr \<longleftrightarrow> sum_case g h = f"
-apply rule
- apply (rule ext, force split: sum.split)
-by (rule ext, metis sum_case_o_inj(2))
-
-lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
-by fast
-
-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
-  with e have "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R"
-    unfolding equiv_def sym_def trans_def by blast+
-  then show ?thesis unfolding proj_def[abs_def] by auto
-qed
-
-(* Operators: *)
-definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
-
-lemma Id_onD: "(a, b) \<in> Id_on A \<Longrightarrow> a = b"
-unfolding Id_on_def by simp
-
-lemma Id_onD': "x \<in> Id_on A \<Longrightarrow> fst x = snd x"
-unfolding Id_on_def by auto
-
-lemma Id_on_fst: "x \<in> Id_on A \<Longrightarrow> fst x \<in> A"
-unfolding Id_on_def by auto
-
-lemma Id_on_UNIV: "Id_on UNIV = Id"
-unfolding Id_on_def by auto
-
-lemma Id_on_Comp: "Id_on A = Id_on A O Id_on A"
-unfolding Id_on_def by auto
-
-lemma Id_on_Gr: "Id_on A = Gr A id"
-unfolding Id_on_def Gr_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 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 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_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
-unfolding Gr_def by auto
-
-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 in_rel_Collect_split_eq: "in_rel (Collect (split X)) = X"
-unfolding fun_eq_iff by auto
-
-lemma Collect_split_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (split (in_rel Y))"
-by auto
-
-lemma Collect_split_in_rel_leE: "X \<subseteq> Collect (split (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
-by force
-
-lemma Collect_split_in_relI: "x \<in> X \<Longrightarrow> x \<in> Collect (split (in_rel X))"
-by auto
-
-lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
-unfolding fun_eq_iff by auto
-
-lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
-unfolding fun_eq_iff by auto
-
-lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
-unfolding Gr_def Grp_def fun_eq_iff by auto
-
-lemma in_rel_Id_on_UNIV: "in_rel (Id_on UNIV) = op ="
-unfolding fun_eq_iff by auto
-
-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_Id_on:
-"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
-unfolding relInvImage_def Id_on_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> Id_on (A//R)"
-unfolding relImage_def Id_on_def
-using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
-by (auto simp: 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 fast
-
-lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
-by simp
-
-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 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
-
-(*Extended Sublist*)
-
-definition clists where "clists r = |lists (Field r)|"
-
-definition prefCl where
-  "prefCl Kl = (\<forall> kl1 kl2. prefixeq kl1 kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
-definition PrefCl where
-  "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> prefixeq kl' 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))"
-
-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. prefixeq kl1 kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
-    "prefixeq kl1 kl2" "k # kl2 \<in> Kl"
-  thus "k # kl1 \<in> Kl" using Cons_prefixeq_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 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 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)
-
-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 not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
-by simp
-
-lemma Collect_splitD: "x \<in> Collect (split A) \<Longrightarrow> A (fst x) (snd x)"
-by auto
-
-definition image2p where
-  "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"
-
-lemma image2pI: "R x y \<Longrightarrow> (image2p f g R) (f x) (g y)"
-  unfolding image2p_def by blast
-
-lemma image2pE: "\<lbrakk>(image2p f g R) fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
-  unfolding image2p_def by blast
-
-lemma fun_rel_iff_geq_image2p: "(fun_rel R S) f g = (image2p f g R \<le> S)"
-  unfolding fun_rel_def image2p_def by auto
-
-lemma fun_rel_image2p: "(fun_rel R (image2p f g R)) f g"
-  unfolding fun_rel_def image2p_def by auto
-
-
-subsection {* Equivalence relations, quotients, and Hilbert's choice *}
-
-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
-
-definition univ where "univ f X == f (Eps (%x. x \<in> X))"
-
-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_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
-
-ML_file "Tools/bnf_gfp_rec_sugar_tactics.ML"
-ML_file "Tools/bnf_gfp_rec_sugar.ML"
-ML_file "Tools/bnf_gfp_util.ML"
-ML_file "Tools/bnf_gfp_tactics.ML"
-ML_file "Tools/bnf_gfp.ML"
-
-end
--- a/src/HOL/BNF/BNF_LFP.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,243 +0,0 @@
-(*  Title:      HOL/BNF/BNF_LFP.thy
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Lorenz Panny, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
-
-Least fixed point operation on bounded natural functors.
-*)
-
-header {* Least Fixed Point Operation on Bounded Natural Functors *}
-
-theory BNF_LFP
-imports BNF_FP_Base
-keywords
-  "datatype_new" :: thy_decl and
-  "datatype_new_compat" :: thy_decl and
-  "primrec_new" :: thy_decl
-begin
-
-lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
-by blast
-
-lemma image_Collect_subsetI:
-  "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
-by blast
-
-lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
-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> underS R j"
-unfolding underS_def by simp
-
-lemma underS_E: "i \<in> underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
-unfolding underS_def by simp
-
-lemma underS_Field: "i \<in> underS R j \<Longrightarrow> i \<in> Field R"
-unfolding underS_def Field_def by auto
-
-lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
-unfolding Field_def by auto
-
-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 convol_expand_snd: "fst o f = g \<Longrightarrow>  <g, snd o f> = f"
-unfolding convol_def by auto
-
-lemma convol_expand_snd': "(fst o f = g) \<Longrightarrow> (h = snd o f) \<longleftrightarrow> (<g, h> = f)"
-  by (metis convol_expand_snd snd_convol)
-
-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 (no_types) gg imageI[of _ A f] the_inv_into_f_f[OF inj_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 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 (drule bij_betw_imageE, unfold bij_betw_iff_ex) blast
-
-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 blast
-
-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
-    apply (intro bexI ballI)
-    apply (erule insertE)
-    apply hypsubst
-    apply (rule z(2))
-    using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
-    apply blast
-    apply (rule z(1))
-    done
-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)`)
-
-lemma nchotomy_relcomppE:
-  "\<lbrakk>\<And>y. \<exists>x. y = f x; (r OO s) a c; (\<And>b. r a (f b) \<Longrightarrow> s (f b) c \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
-  by (metis relcompp.cases)
-
-lemma vimage2p_fun_rel: "(fun_rel (vimage2p f g R) R) f g"
-  unfolding fun_rel_def vimage2p_def by auto
-
-lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
-  unfolding vimage2p_def by auto
-
-ML_file "Tools/bnf_lfp_rec_sugar.ML"
-ML_file "Tools/bnf_lfp_util.ML"
-ML_file "Tools/bnf_lfp_tactics.ML"
-ML_file "Tools/bnf_lfp.ML"
-ML_file "Tools/bnf_lfp_compat.ML"
-
-end
--- a/src/HOL/BNF/BNF_Util.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-(*  Title:      HOL/BNF/BNF_Util.thy
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012
-
-Library for bounded natural functors.
-*)
-
-header {* Library for Bounded Natural Functors *}
-
-theory BNF_Util
-imports BNF_Cardinal_Arithmetic
-  Transfer (*FIXME: define fun_rel here, reuse in Transfer once this theory is in HOL*)
-begin
-
-definition collect where
-"collect F x = (\<Union>f \<in> F. f x)"
-
-lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
-by simp
-
-lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
-by simp
-
-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
-
-(* Operator: *)
-definition "Gr A f = {(a, f a) | a. a \<in> A}"
-
-definition "Grp A f = (\<lambda>a b. b = f a \<and> a \<in> A)"
-
-ML_file "Tools/bnf_util.ML"
-ML_file "Tools/bnf_tactics.ML"
-
-end
--- a/src/HOL/BNF/Basic_BNFs.thy	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,204 +0,0 @@
-(*  Title:      HOL/BNF/Basic_BNFs.thy
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Andrei Popescu, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012
-
-Registration of basic types as bounded natural functors.
-*)
-
-header {* Registration of Basic Types as Bounded Natural Functors *}
-
-theory Basic_BNFs
-imports BNF_Def
-   (*FIXME: define relators here, reuse in Lifting_* once this theory is in HOL*)
-  Lifting_Sum
-  Lifting_Product
-  Main
-begin
-
-bnf ID: 'a
-  map: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
-  sets: "\<lambda>x. {x}"
-  bd: natLeq
-  rel: "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
-apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order 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)[3]
-done
-
-bnf DEADID: 'a
-  map: "id :: 'a \<Rightarrow> 'a"
-  bd: "natLeq +c |UNIV :: 'a set|"
-  rel: "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
-by (auto simp add: Grp_def
-  card_order_csum natLeq_card_order card_of_card_order_on
-  cinfinite_csum natLeq_cinfinite)
-
-definition setl :: "'a + 'b \<Rightarrow> 'a set" where
-"setl x = (case x of Inl z => {z} | _ => {})"
-
-definition setr :: "'a + 'b \<Rightarrow> 'b set" where
-"setr x = (case x of Inr z => {z} | _ => {})"
-
-lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
-
-bnf "'a + 'b"
-  map: sum_map
-  sets: setl setr
-  bd: natLeq
-  wits: Inl Inr
-  rel: sum_rel
-proof -
-  show "sum_map id id = id" by (rule sum_map.id)
-next
-  fix f1 :: "'o \<Rightarrow> 's" and f2 :: "'p \<Rightarrow> 't" and g1 :: "'s \<Rightarrow> 'q" and g2 :: "'t \<Rightarrow> 'r"
-  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 and f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r" and g1 g2
-  assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
-         a2: "\<And>z. z \<in> 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: setl_def)
-  next
-    case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
-  qed
-next
-  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
-  show "setl o sum_map f1 f2 = image f1 o setl"
-    by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
-next
-  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
-  show "setr o sum_map f1 f2 = image f2 o setr"
-    by (rule ext, unfold o_apply) (simp add: 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 :: "'o + 'p"
-  show "|setl x| \<le>o natLeq"
-    apply (rule ordLess_imp_ordLeq)
-    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
-    by (simp add: setl_def split: sum.split)
-next
-  fix x :: "'o + 'p"
-  show "|setr x| \<le>o natLeq"
-    apply (rule ordLess_imp_ordLeq)
-    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
-    by (simp add: setr_def split: sum.split)
-next
-  fix R1 R2 S1 S2
-  show "sum_rel R1 R2 OO sum_rel S1 S2 \<le> sum_rel (R1 OO S1) (R2 OO S2)"
-    by (auto simp: sum_rel_def split: sum.splits)
-next
-  fix R S
-  show "sum_rel R S =
-        (Grp {x. setl x \<subseteq> Collect (split R) \<and> setr x \<subseteq> Collect (split S)} (sum_map fst fst))\<inverse>\<inverse> OO
-        Grp {x. setl x \<subseteq> Collect (split R) \<and> setr x \<subseteq> Collect (split S)} (sum_map snd snd)"
-  unfolding setl_def setr_def sum_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
-  by (fastforce split: sum.splits)
-qed (auto simp: sum_set_defs)
-
-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 "'a \<times> 'b"
-  map: map_pair
-  sets: fsts snds
-  bd: natLeq
-  rel: prod_rel
-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 natLeq" by (rule natLeq_card_order)
-next
-  show "cinfinite natLeq" by (rule natLeq_cinfinite)
-next
-  fix x
-  show "|{fst x}| \<le>o natLeq"
-    by (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq finite.emptyI finite_insert)
-next
-  fix x
-  show "|{snd x}| \<le>o natLeq"
-    by (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq finite.emptyI finite_insert)
-next
-  fix R1 R2 S1 S2
-  show "prod_rel R1 R2 OO prod_rel S1 S2 \<le> prod_rel (R1 OO S1) (R2 OO S2)" by auto
-next
-  fix R S
-  show "prod_rel R S =
-        (Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair fst fst))\<inverse>\<inverse> OO
-        Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair snd snd)"
-  unfolding prod_set_defs prod_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
-  by auto
-qed
-
-bnf "'a \<Rightarrow> 'b"
-  map: "op \<circ>"
-  sets: range
-  bd: "natLeq +c |UNIV :: 'a set|"
-  rel: "fun_rel op ="
-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 R S
-  show "fun_rel op = R OO fun_rel op = S \<le> fun_rel op = (R OO S)" by (auto simp: fun_rel_def)
-next
-  fix R
-  show "fun_rel op = R =
-        (Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> fst))\<inverse>\<inverse> OO
-         Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> snd)"
-  unfolding fun_rel_def Grp_def fun_eq_iff relcompp.simps conversep.simps  subset_iff image_iff
-  by auto (force, metis (no_types) pair_collapse)
-qed
-
-end
--- a/src/HOL/BNF/Tools/bnf_comp.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,704 +0,0 @@
-(*  Title:      HOL/BNF/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
-  val ID_bnf: BNF_Def.bnf
-  val DEADID_bnf: BNF_Def.bnf
-
-  type unfold_set
-  val empty_unfolds: unfold_set
-
-  exception BAD_DEAD of typ * typ
-
-  val bnf_of_typ: BNF_Def.const_policy -> (binding -> binding) ->
-    ((string * sort) list list -> (string * sort) list) -> (string * sort) list -> typ ->
-    unfold_set * Proof.context ->
-    (BNF_Def.bnf * (typ list * typ list)) * (unfold_set * Proof.context)
-  val default_comp_sort: (string * sort) list list -> (string * sort) list
-  val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
-    (''a list list -> ''a list) -> BNF_Def.bnf list -> unfold_set -> Proof.context ->
-    (int list list * ''a list) * (BNF_Def.bnf list * (unfold_set * Proof.context))
-  val seal_bnf: (binding -> binding) -> unfold_set -> binding -> typ list -> BNF_Def.bnf ->
-    Proof.context -> (BNF_Def.bnf * typ list) * local_theory
-end;
-
-structure BNF_Comp : BNF_COMP =
-struct
-
-open BNF_Def
-open BNF_Util
-open BNF_Tactics
-open BNF_Comp_Tactics
-
-val ID_bnf = the (bnf_of @{context} "Basic_BNFs.ID");
-val DEADID_bnf = the (bnf_of @{context} "Basic_BNFs.DEADID");
-
-(* TODO: Replace by "BNF_Defs.defs list" *)
-type unfold_set = {
-  map_unfolds: thm list,
-  set_unfoldss: thm list list,
-  rel_unfolds: thm list
-};
-
-val empty_unfolds = {map_unfolds = [], set_unfoldss = [], rel_unfolds = []};
-
-fun add_to_thms thms new = thms |> not (Thm.is_reflexive new) ? insert Thm.eq_thm new;
-fun adds_to_thms thms news = insert (eq_set Thm.eq_thm) (no_reflexive news) thms;
-
-fun add_to_unfolds map sets rel
-  {map_unfolds, set_unfoldss, rel_unfolds} =
-  {map_unfolds = add_to_thms map_unfolds map,
-    set_unfoldss = adds_to_thms set_unfoldss sets,
-    rel_unfolds = add_to_thms rel_unfolds rel};
-
-fun add_bnf_to_unfolds bnf =
-  add_to_unfolds (map_def_of_bnf bnf) (set_defs_of_bnf bnf) (rel_def_of_bnf bnf);
-
-val bdTN = "bdT";
-
-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);
-
-(*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_set, 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', Qs'), Asets), xs), _(*names_lthy*)) = lthy
-      |> apfst snd o mk_Frees' "f" (map2 (curry op -->) As Bs)
-      ||>> apfst snd o mk_Frees' "Q" (map2 mk_pred2T 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 mapx = 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));
-    (*%Q1 ... Qn. outer.rel (inner_1.rel Q1 ... Qn) ... (inner_m.rel Q1 ... Qn)*)
-    val rel = fold_rev Term.abs Qs'
-      (Term.list_comb (mk_rel_of_bnf oDs CAs CBs outer,
-        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
-          mk_rel_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_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 (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
-
-    (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
-    val bd = mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd;
-
-    fun map_id0_tac _ =
-      mk_comp_map_id0_tac (map_id0_of_bnf outer) (map_cong0_of_bnf outer)
-        (map map_id0_of_bnf inners);
-
-    fun map_comp0_tac _ =
-      mk_comp_map_comp0_tac (map_comp0_of_bnf outer) (map_cong0_of_bnf outer)
-        (map map_comp0_of_bnf inners);
-
-    fun mk_single_set_map0_tac i _ =
-      mk_comp_set_map0_tac (map_comp0_of_bnf outer) (map_cong0_of_bnf outer)
-        (collect_set_map_of_bnf outer)
-        (map ((fn thms => nth thms i) o set_map0_of_bnf) inners);
-
-    val set_map0_tacs = map mk_single_set_map0_tac (0 upto ilive - 1);
-
-    fun bd_card_order_tac _ =
-      mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
-
-    fun bd_cinfinite_tac _ =
-      mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
-
-    val set_alt_thms =
-      if Config.get lthy quick_and_dirty then
-        []
-      else
-        map (fn goal =>
-          Goal.prove_sorry lthy [] [] goal
-            (fn {context = ctxt, prems = _} =>
-              mk_comp_set_alt_tac ctxt (collect_set_map_of_bnf outer))
-          |> Thm.close_derivation)
-        (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) sets sets_alt);
-
-    fun map_cong0_tac _ =
-      mk_comp_map_cong0_tac set_alt_thms (map_cong0_of_bnf outer) (map map_cong0_of_bnf inners);
-
-    val set_bd_tacs =
-      if Config.get lthy quick_and_dirty then
-        replicate ilive (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 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 single_set_bd_thm) (0 upto ilive - 1);
-        in
-          map2 (fn set_alt => fn single_set_bds => fn {context = ctxt, prems = _} =>
-            mk_comp_set_bd_tac ctxt set_alt single_set_bds)
-          set_alt_thms single_set_bd_thmss
-        end;
-
-    val in_alt_thm =
-      let
-        val inx = mk_in Asets sets CCA;
-        val in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
-        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
-      in
-        Goal.prove_sorry lthy [] [] goal
-          (fn {context = ctxt, prems = _} => mk_comp_in_alt_tac ctxt set_alt_thms)
-        |> Thm.close_derivation
-      end;
-
-    fun le_rel_OO_tac _ = mk_le_rel_OO_tac (le_rel_OO_of_bnf outer) (rel_mono_of_bnf outer)
-      (map le_rel_OO_of_bnf inners);
-
-    fun rel_OO_Grp_tac _ =
-      let
-        val outer_rel_Grp = rel_Grp_of_bnf outer RS sym;
-        val outer_rel_cong = rel_cong_of_bnf outer;
-        val thm =
-          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
-             trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
-               [trans OF [outer_rel_Grp RS @{thm arg_cong[of _ _ conversep]},
-                 rel_conversep_of_bnf outer RS sym], outer_rel_Grp],
-               trans OF [rel_OO_of_bnf outer RS sym, outer_rel_cong OF
-                 (map (fn bnf => rel_OO_Grp_of_bnf bnf RS sym) inners)]]] RS sym)
-          (*|> unfold_thms lthy (rel_def_of_bnf outer :: map rel_def_of_bnf inners)*);
-      in
-        rtac thm 1
-      end;
-
-    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
-      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_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 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, prems = _} =
-      mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_map_of_bnf outer)
-        (maps wit_thms_of_bnf inners);
-
-    val (bnf', lthy') =
-      bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
-        Binding.empty [] ((((((b, CCA), mapx), sets), bd), wits), SOME rel) lthy;
-  in
-    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
-  end;
-
-(* Killing live variables *)
-
-fun kill_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
-  let
-    val b = Binding.suffix_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 mapx = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
-    (*bnf.rel (op =) ... (op =)*)
-    val rel = Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, map HOLogic.eq_const killedAs);
-
-    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
-    val 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 bd = mk_cprod
-      (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
-
-    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
-    fun map_comp0_tac {context = ctxt, prems = _} =
-      unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
-      rtac refl 1;
-    fun map_cong0_tac {context = ctxt, prems = _} =
-      mk_kill_map_cong0_tac ctxt n (live - n) (map_cong0_of_bnf bnf);
-    val set_map0_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_map0_of_bnf bnf));
-    fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
-    fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
-    val set_bd_tacs =
-      map (fn thm => fn _ => mk_kill_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
-        (drop n (set_bd_of_bnf bnf));
-
-    val in_alt_thm =
-      let
-        val inx = mk_in Asets sets T;
-        val in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
-        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
-      in
-        Goal.prove_sorry lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
-      end;
-
-    fun le_rel_OO_tac {context = ctxt, prems = _} =
-      EVERY' [rtac @{thm ord_le_eq_trans}, rtac (le_rel_OO_of_bnf bnf)] 1 THEN
-      unfold_thms_tac ctxt @{thms eq_OO} THEN rtac refl 1;
-
-    fun rel_OO_Grp_tac _ =
-      let
-        val rel_Grp = rel_Grp_of_bnf bnf RS sym
-        val thm =
-          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
-            trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
-              [trans OF [rel_Grp RS @{thm arg_cong[of _ _ conversep]},
-                rel_conversep_of_bnf bnf RS sym], rel_Grp],
-              trans OF [rel_OO_of_bnf bnf RS sym, rel_cong_of_bnf bnf OF
-                (replicate n @{thm trans[OF Grp_UNIV_id[OF refl] eq_alt[symmetric]]} @
-                 replicate (live - n) @{thm Grp_fst_snd})]]] RS sym);
-      in
-        rtac thm 1
-      end;
-
-    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
-      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
-
-    val bnf_wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
-
-    val wits = map (fn t => fold absfree (Term.add_frees t []) t)
-      (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) bnf_wits);
-
-    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
-
-    val (bnf', lthy') =
-      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME (killedAs @ Ds)) Binding.empty
-        Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
-  in
-    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
-  end;
-
-(* Adding dummy live variables *)
-
-fun lift_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
-  let
-    val b = Binding.suffix_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 mapx =
-      fold_rev Term.absdummy (map2 (curry op -->) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
-    (*%Q1 ... Qn. bnf.rel*)
-    val rel = fold_rev Term.absdummy (map2 mk_pred2T newAs newBs) (mk_rel_of_bnf Ds As Bs bnf);
-
-    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
-    val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
-
-    val bd = mk_bd_of_bnf Ds As bnf;
-
-    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
-    fun map_comp0_tac {context = ctxt, prems = _} =
-      unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
-      rtac refl 1;
-    fun map_cong0_tac {context = ctxt, prems = _} =
-      rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
-    val set_map0_tacs =
-      if Config.get lthy 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_map0_of_bnf bnf);
-    fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
-    fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
-    val set_bd_tacs =
-      if Config.get lthy quick_and_dirty then
-        replicate (n + live) (K all_tac)
-      else
-        replicate n (K (mk_lift_set_bd_tac (bd_Card_order_of_bnf bnf))) @
-        (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
-
-    val in_alt_thm =
-      let
-        val inx = mk_in Asets sets T;
-        val in_alt = mk_in (drop n Asets) bnf_sets T;
-        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
-      in
-        Goal.prove_sorry lthy [] [] goal (K lift_in_alt_tac) |> Thm.close_derivation
-      end;
-
-    fun le_rel_OO_tac _ = rtac (le_rel_OO_of_bnf bnf) 1;
-
-    fun rel_OO_Grp_tac _ = mk_simple_rel_OO_Grp_tac (rel_OO_Grp_of_bnf bnf) in_alt_thm;
-
-    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
-      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
-
-    val 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') =
-      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
-        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
-  in
-    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
-  end;
-
-(* Changing the order of live variables *)
-
-fun permute_bnf qualify src dest bnf (unfold_set, lthy) =
-  if src = dest then (bnf, (unfold_set, lthy)) else
-  let
-    val b = Binding.suffix_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 = permute_like (op =) src dest xs;
-    fun unpermute xs = permute_like (op =) 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 mapx = fold_rev Term.absdummy (permute (map2 (curry op -->) As Bs))
-      (Term.list_comb (mk_map_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
-    (*%Q(1) ... Q(n). bnf.rel Q\<sigma>(1) ... Q\<sigma>(n)*)
-    val rel = fold_rev Term.absdummy (permute (map2 mk_pred2T As Bs))
-      (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
-
-    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
-    val sets = permute bnf_sets;
-
-    val bd = mk_bd_of_bnf Ds As bnf;
-
-    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
-    fun map_comp0_tac _ = rtac (map_comp0_of_bnf bnf) 1;
-    fun map_cong0_tac {context = ctxt, prems = _} =
-      rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
-    val set_map0_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf));
-    fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
-    fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
-    val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
-
-    val in_alt_thm =
-      let
-        val inx = mk_in Asets sets T;
-        val in_alt = mk_in (unpermute Asets) bnf_sets T;
-        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
-      in
-        Goal.prove_sorry lthy [] [] goal (K (mk_permute_in_alt_tac src dest))
-        |> Thm.close_derivation
-      end;
-
-    fun le_rel_OO_tac _ = rtac (le_rel_OO_of_bnf bnf) 1;
-
-    fun rel_OO_Grp_tac _ = mk_simple_rel_OO_Grp_tac (rel_OO_Grp_of_bnf bnf) in_alt_thm;
-
-    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
-      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
-
-    val 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') =
-      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
-        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
-  in
-    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
-  end;
-
-(* Composition pipeline *)
-
-fun permute_and_kill qualify n src dest bnf =
-  bnf
-  |> permute_bnf qualify src dest
-  #> uncurry (kill_bnf qualify n);
-
-fun lift_and_permute qualify n src dest bnf =
-  bnf
-  |> lift_bnf qualify n
-  #> uncurry (permute_bnf qualify src dest);
-
-fun normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy =
-  let
-    val before_kill_src = map (fn As => 0 upto (length As - 1)) Ass;
-    val kill_poss = map (find_indices op = 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_set', 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_set, 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_set', 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 sort outer inners oDs Dss tfreess (unfold_set, lthy) =
-  let
-    val b = name_of_bnf outer;
-
-    val Ass = map (map Term.dest_TFree) tfreess;
-    val Ds = fold (fold Term.add_tfreesT) (oDs :: Dss) [];
-
-    val ((kill_poss, As), (inners', (unfold_set', lthy'))) =
-      normalize_bnfs qualify Ass Ds sort inners unfold_set 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 (qualify 0) b outer inners' (unfold_set', lthy'))
-  end;
-
-(* Hide the type of the bound (optimization) and unfold the definitions (nicer to the user) *)
-
-fun seal_bnf qualify (unfold_set : unfold_set) 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 = #map_unfolds unfold_set;
-    val set_unfoldss = #set_unfoldss unfold_set;
-    val rel_unfolds = #rel_unfolds unfold_set;
-
-    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 expand_rels =
-      fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) rel_unfolds);
-    fun unfold_maps ctxt = fold (unfold_thms ctxt o single) map_unfolds;
-    fun unfold_sets ctxt = fold (unfold_thms ctxt) set_unfoldss;
-    fun unfold_rels ctxt = unfold_thms ctxt rel_unfolds;
-    fun unfold_all ctxt = unfold_sets ctxt o unfold_maps ctxt o unfold_rels ctxt;
-    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 bnf_rel = expand_rels (mk_rel_of_bnf Ds As Bs 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 = qualify (Binding.suffix_name ("_" ^ bdTN) b);
-    val params = fold Term.add_tfreesT Ds [];
-    val deads = map TFree params;
-
-    val ((bdT_name, (bdT_glob_info, bdT_loc_info)), lthy) =
-      typedef (bdT_bind, params, NoSyn)
-        (HOLogic.mk_UNIV bd_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
-
-    val bnf_bd' = mk_dir_image bnf_bd
-      (Const (#Abs_name bdT_glob_info, bd_repT --> Type (bdT_name, deads)))
-
-    val Abs_bdT_inj = mk_Abs_inj_thm (#Abs_inject bdT_loc_info);
-    val Abs_bdT_bij = mk_Abs_bij_thm lthy Abs_bdT_inj (#Abs_cases bdT_loc_info);
-
-    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);
-
-    fun mk_tac thm {context = ctxt, prems = _} =
-      (rtac (unfold_all ctxt thm) THEN'
-      SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
-
-    val tacs = zip_axioms (mk_tac (map_id0_of_bnf bnf)) (mk_tac (map_comp0_of_bnf bnf))
-      (mk_tac (map_cong0_of_bnf bnf)) (map mk_tac (set_map0_of_bnf bnf))
-      (K (rtac bd_card_order 1)) (K (rtac bd_cinfinite 1)) (map mk_tac set_bds)
-      (mk_tac (le_rel_OO_of_bnf bnf))
-      (mk_tac (rel_OO_Grp_of_bnf bnf));
-
-    val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
-
-    fun wit_tac {context = ctxt, prems = _} =
-      mk_simple_wit_tac (map (unfold_all ctxt) (wit_thms_of_bnf bnf));
-
-    val (bnf', lthy') =
-      bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
-        Binding.empty Binding.empty []
-        ((((((b, T), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
-  in
-    ((bnf', deads), lthy')
-  end;
-
-exception BAD_DEAD of typ * typ;
-
-fun bnf_of_typ _ _ _ _ (T as TFree _) accum = ((ID_bnf, ([], [T])), accum)
-  | bnf_of_typ _ _ _ _ (TVar _) _ = error "Unexpected schematic variable"
-  | bnf_of_typ const_policy qualify' sort Xs (T as Type (C, Ts)) (unfold_set, lthy) =
-    let
-      fun check_bad_dead ((_, (deads, _)), _) =
-        let val Ds = fold Term.add_tfreesT deads [] in
-          (case Library.inter (op =) Ds Xs of [] => ()
-           | X :: _ => raise BAD_DEAD (TFree X, T))
-        end;
-
-      val tfrees = Term.add_tfreesT T [];
-      val bnf_opt = if null tfrees then NONE else bnf_of lthy C;
-    in
-      (case bnf_opt of
-        NONE => ((DEADID_bnf, ([T], [])), (unfold_set, lthy))
-      | SOME bnf =>
-        if forall (can Term.dest_TFree) Ts andalso length Ts = length tfrees then
-          let
-            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);
-          in ((bnf, deads_lives), (unfold_set, lthy)) end
-        else
-          let
-            val name = Long_Name.base_name C;
-            fun qualify i =
-              let val namei = name ^ nonzero_string_of_int i;
-              in qualify' o Binding.qualify true namei end;
-            val odead = dead_of_bnf bnf;
-            val olive = live_of_bnf bnf;
-            val oDs_pos = find_indices op = [TFree ("dead", [])] (snd (Term.dest_Type
-              (mk_T_of_bnf (replicate odead (TFree ("dead", []))) (replicate olive dummyT) bnf)));
-            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_set', lthy')) =
-              apfst (apsnd split_list o split_list)
-                (fold_map2 (fn i => bnf_of_typ Smart_Inline (qualify i) sort Xs)
-                (if length Ts' = 1 then [0] else (1 upto length Ts')) Ts' (unfold_set, lthy));
-          in
-            compose_bnf const_policy qualify sort bnf inners oDs Dss Ass (unfold_set', lthy')
-          end)
-      |> tap check_bad_dead
-    end;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_comp_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,252 +0,0 @@
-(*  Title:      HOL/BNF/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_map_comp0_tac: thm -> thm -> thm list -> tactic
-  val mk_comp_map_cong0_tac: thm list -> thm -> thm list -> tactic
-  val mk_comp_map_id0_tac: thm -> 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_map0_tac: thm -> thm -> thm -> thm list -> tactic
-  val mk_comp_wit_tac: Proof.context -> thm list -> thm -> thm list -> tactic
-
-  val mk_kill_bd_card_order_tac: int -> thm -> tactic
-  val mk_kill_bd_cinfinite_tac: thm -> tactic
-  val kill_in_alt_tac: tactic
-  val mk_kill_map_cong0_tac: Proof.context -> int -> int -> thm -> tactic
-  val mk_kill_set_bd_tac: thm -> thm -> tactic
-
-  val empty_natural_tac: tactic
-  val lift_in_alt_tac: tactic
-  val mk_lift_set_bd_tac: thm -> tactic
-
-  val mk_permute_in_alt_tac: ''a list -> ''a list -> tactic
-
-  val mk_le_rel_OO_tac: thm -> thm -> thm list -> tactic
-  val mk_simple_rel_OO_Grp_tac: thm -> thm -> tactic
-  val mk_simple_wit_tac: thm list -> tactic
-end;
-
-structure BNF_Comp_Tactics : BNF_COMP_TACTICS =
-struct
-
-open BNF_Util
-open BNF_Tactics
-
-val Cnotzero_UNIV = @{thm Cnotzero_UNIV};
-val arg_cong_Union = @{thm arg_cong[of _ _ Union]};
-val csum_Cnotzero1 = @{thm csum_Cnotzero1};
-val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
-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_map =
-  unfold_thms_tac ctxt @{thms sym[OF o_assoc]} THEN
-  unfold_thms_tac ctxt [collect_set_map RS sym] THEN
-  rtac refl 1;
-
-fun mk_comp_map_id0_tac Gmap_id0 Gmap_cong0 map_id0s =
-  EVERY' ([rtac ext, rtac (Gmap_cong0 RS trans)] @
-    map (fn thm => rtac (thm RS fun_cong)) map_id0s @ [rtac (Gmap_id0 RS fun_cong)]) 1;
-
-fun mk_comp_map_comp0_tac Gmap_comp0 Gmap_cong0 map_comp0s =
-  EVERY' ([rtac ext, rtac sym, rtac trans_o_apply,
-    rtac (Gmap_comp0 RS sym RS o_eq_dest_lhs RS trans), rtac Gmap_cong0] @
-    map (fn thm => rtac (thm RS sym RS fun_cong)) map_comp0s) 1;
-
-fun mk_comp_set_map0_tac Gmap_comp0 Gmap_cong0 Gset_map0 set_map0s =
-  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_comp0 RS sym RS o_eq_dest_lhs RS trans),
-     rtac Gmap_cong0] @
-     map (fn thm => rtac (thm RS fun_cong)) set_map0s @
-     [rtac (Gset_map0 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_map0 RS o_eq_dest_lhs RS arg_cong_Union, refl] RS trans),
-     rtac @{thm trans[OF comp_eq_dest[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_map0s) o EVERY' [rtac @{thm trans[OF image_insert]},
-        rtac @{thm arg_cong2[of _ _ _ _ insert]}, rtac ext, rtac trans_o_apply,
-        rtac trans_image_cong_o_apply, 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_cong0_tac comp_set_alts map_cong0 map_cong0s =
-  let
-     val n = length comp_set_alts;
-  in
-    (if n = 0 then rtac refl 1
-    else rtac map_cong0 1 THEN
-      EVERY' (map_index (fn (i, map_cong0) =>
-        rtac map_cong0 THEN' EVERY' (map_index (fn (k, set_alt) =>
-          EVERY' [select_prem_tac n (dtac @{thm meta_spec}) (k + 1), etac 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_cong0s) 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
-    unfold_thms_tac ctxt [comp_set_alt] THEN
-    rtac @{thm comp_set_bd_Union_o_collect} 1 THEN
-    unfold_thms_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 =
-  unfold_thms_tac ctxt (comp_set_alts @ comp_in_alt_thms) THEN
-  unfold_thms_tac ctxt @{thms set_eq_subset} THEN
-  rtac conjI 1 THEN
-  REPEAT_DETERM (
-    rtac @{thm subsetI} 1 THEN
-    unfold_thms_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 subset_UNIV)) ORELSE'
-       atac ORELSE'
-       (rtac subset_UNIV)) 1)) ORELSE rtac subset_UNIV 1));
-
-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_map Fwit_thms =
-  ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
-  unfold_thms_tac ctxt (collect_set_map :: comp_wit_thms) THEN
-  REPEAT_DETERM ((atac ORELSE'
-    REPEAT_DETERM o eresolve_tac @{thms UnionE UnE} THEN'
-    etac imageE THEN' TRY o dresolve_tac Gwit_thms THEN'
-    (etac FalseE ORELSE'
-    hyp_subst_tac ctxt THEN'
-    dresolve_tac Fwit_thms THEN'
-    (etac FalseE ORELSE' atac))) 1);
-
-
-
-(* Kill operation *)
-
-fun mk_kill_map_cong0_tac ctxt n m map_cong0 =
-  (rtac map_cong0 THEN' EVERY' (replicate n (rtac refl)) THEN'
-    EVERY' (replicate m (Goal.assume_rule_tac ctxt))) 1;
-
-fun mk_kill_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_kill_bd_cinfinite_tac bd_Cinfinite =
-  (rtac @{thm cinfinite_cprod2} THEN'
-  TRY o rtac csum_Cnotzero1 THEN'
-  rtac Cnotzero_UNIV THEN'
-  rtac bd_Cinfinite) 1;
-
-fun mk_kill_set_bd_tac bd_Card_order set_bd =
-  (rtac ctrans THEN'
-  rtac set_bd THEN'
-  rtac @{thm ordLeq_cprod2} THEN'
-  TRY o rtac csum_Cnotzero1 THEN'
-  rtac Cnotzero_UNIV THEN'
-  rtac bd_Card_order) 1
-
-val kill_in_alt_tac =
-  ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
-  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
-  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
-    rtac conjI THEN' rtac subset_UNIV) 1)) THEN
-  (rtac 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 subset_UNIV 1));
-
-
-
-(* Lift operation *)
-
-val empty_natural_tac = rtac @{thm empty_natural} 1;
-
-fun mk_lift_set_bd_tac bd_Card_order = (rtac @{thm Card_order_empty} THEN' rtac bd_Card_order) 1;
-
-val lift_in_alt_tac =
-  ((rtac @{thm Collect_cong} THEN' rtac 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));
-
-
-
-(* 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_le_rel_OO_tac outer_le_rel_OO outer_rel_mono inner_le_rel_OOs =
-  EVERY' (map rtac (@{thm order_trans} :: outer_le_rel_OO :: outer_rel_mono :: inner_le_rel_OOs)) 1;
-
-fun mk_simple_rel_OO_Grp_tac rel_OO_Grp in_alt_thm =
-  rtac (trans OF [rel_OO_Grp, in_alt_thm RS @{thm OO_Grp_cong} RS sym]) 1;
-
-fun mk_simple_wit_tac wit_thms = ALLGOALS (atac ORELSE' eresolve_tac (@{thm emptyE} :: wit_thms));
-
-end;
--- a/src/HOL/BNF/Tools/bnf_def.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1393 +0,0 @@
-(*  Title:      HOL/BNF/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 morph_bnf: morphism -> bnf -> bnf
-  val eq_bnf: bnf * bnf -> bool
-  val bnf_of: Proof.context -> string -> bnf option
-  val register_bnf: string -> (bnf * local_theory) -> (bnf * local_theory)
-
-  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 relN: string
-  val setN: string
-  val mk_setN: int -> string
-  val mk_witN: int -> string
-
-  val map_of_bnf: bnf -> term
-  val sets_of_bnf: bnf -> term list
-  val rel_of_bnf: bnf -> term
-
-  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_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_map_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_comp0_of_bnf: bnf -> thm
-  val map_comp_of_bnf: bnf -> thm
-  val map_cong0_of_bnf: bnf -> thm
-  val map_cong_of_bnf: bnf -> thm
-  val map_def_of_bnf: bnf -> thm
-  val map_id0_of_bnf: bnf -> thm
-  val map_id_of_bnf: bnf -> thm
-  val map_transfer_of_bnf: bnf -> thm
-  val le_rel_OO_of_bnf: bnf -> thm
-  val rel_def_of_bnf: bnf -> thm
-  val rel_Grp_of_bnf: bnf -> thm
-  val rel_OO_of_bnf: bnf -> thm
-  val rel_OO_Grp_of_bnf: bnf -> thm
-  val rel_cong_of_bnf: bnf -> thm
-  val rel_conversep_of_bnf: bnf -> thm
-  val rel_mono_of_bnf: bnf -> thm
-  val rel_mono_strong_of_bnf: bnf -> thm
-  val rel_eq_of_bnf: bnf -> thm
-  val rel_flip_of_bnf: bnf -> thm
-  val set_bd_of_bnf: bnf -> thm list
-  val set_defs_of_bnf: bnf -> thm list
-  val set_map0_of_bnf: bnf -> thm list
-  val set_map_of_bnf: bnf -> thm list
-  val wit_thms_of_bnf: bnf -> thm list
-  val wit_thmss_of_bnf: bnf -> thm list list
-
-  val mk_map: int -> typ list -> typ list -> term -> term
-  val mk_rel: int -> typ list -> typ list -> term -> term
-  val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
-  val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
-  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
-  val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
-    'a list
-
-  val mk_witness: int list * term -> thm list -> nonemptiness_witness
-  val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
-  val wits_of_bnf: bnf -> nonemptiness_witness list
-
-  val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
-
-  datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
-  datatype fact_policy = Dont_Note | Note_Some | Note_All
-
-  val bnf_note_all: bool Config.T
-  val bnf_timing: bool Config.T
-  val user_policy: fact_policy -> Proof.context -> fact_policy
-  val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> Proof.context ->
-    Proof.context
-
-  val print_bnfs: Proof.context -> unit
-  val prepare_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
-    (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> typ list option ->
-    binding -> binding -> binding list ->
-    (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
-    string * term list *
-    ((thm list -> {context: Proof.context, prems: thm list} -> tactic) option * term list list) *
-    ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
-    local_theory * thm list
-
-  val define_bnf_consts: const_policy -> fact_policy -> typ list option ->
-    binding -> binding -> binding list ->
-    (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
-      ((typ list * typ list * typ list * typ) *
-       (term * term list * term * (int list * term) list * term) *
-       (thm * thm list * thm * thm list * thm) *
-       ((typ list -> typ list -> typ list -> term) *
-        (typ list -> typ list -> term -> term) *
-        (typ list -> typ list -> typ -> typ) *
-        (typ list -> typ list -> typ list -> term) *
-        (typ list -> typ list -> typ list -> term))) * local_theory
-
-  val bnf_def: 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 ->
-    binding -> binding list ->
-    (((((binding * typ) * term) * term list) * term) * term list) * term option ->
-    local_theory -> bnf * local_theory
-end;
-
-structure BNF_Def : BNF_DEF =
-struct
-
-open BNF_Util
-open BNF_Tactics
-open BNF_Def_Tactics
-
-val fundefcong_attrs = @{attributes [fundef_cong]};
-
-type axioms = {
-  map_id0: thm,
-  map_comp0: thm,
-  map_cong0: thm,
-  set_map0: thm list,
-  bd_card_order: thm,
-  bd_cinfinite: thm,
-  set_bd: thm list,
-  le_rel_OO: thm,
-  rel_OO_Grp: thm
-};
-
-fun mk_axioms' ((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel) =
-  {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
-   bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel};
-
-fun dest_cons [] = raise List.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 zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel =
-  [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel];
-
-fun dest_axioms {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
-  le_rel_OO, rel_OO_Grp} =
-  zip_axioms map_id0 map_comp0 map_cong0 set_map0 bd_card_order bd_cinfinite set_bd le_rel_OO
-    rel_OO_Grp;
-
-fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
-  le_rel_OO, rel_OO_Grp} =
-  {map_id0 = f map_id0,
-    map_comp0 = f map_comp0,
-    map_cong0 = f map_cong0,
-    set_map0 = map f set_map0,
-    bd_card_order = f bd_card_order,
-    bd_cinfinite = f bd_cinfinite,
-    set_bd = map f set_bd,
-    le_rel_OO = f le_rel_OO,
-    rel_OO_Grp = f rel_OO_Grp};
-
-val morph_axioms = map_axioms o Morphism.thm;
-
-type defs = {
-  map_def: thm,
-  set_defs: thm list,
-  rel_def: thm
-}
-
-fun mk_defs map sets rel = {map_def = map, set_defs = sets, rel_def = rel};
-
-fun map_defs f {map_def, set_defs, rel_def} =
-  {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def};
-
-val morph_defs = map_defs o Morphism.thm;
-
-type facts = {
-  bd_Card_order: thm,
-  bd_Cinfinite: thm,
-  bd_Cnotzero: thm,
-  collect_set_map: thm lazy,
-  in_bd: thm lazy,
-  in_cong: thm lazy,
-  in_mono: thm lazy,
-  in_rel: thm lazy,
-  map_comp: thm lazy,
-  map_cong: thm lazy,
-  map_id: thm lazy,
-  map_transfer: thm lazy,
-  rel_eq: thm lazy,
-  rel_flip: thm lazy,
-  set_map: thm lazy list,
-  rel_cong: thm lazy,
-  rel_mono: thm lazy,
-  rel_mono_strong: thm lazy,
-  rel_Grp: thm lazy,
-  rel_conversep: thm lazy,
-  rel_OO: thm lazy
-};
-
-fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
-    map_comp map_cong map_id map_transfer rel_eq rel_flip set_map rel_cong rel_mono
-    rel_mono_strong rel_Grp rel_conversep rel_OO = {
-  bd_Card_order = bd_Card_order,
-  bd_Cinfinite = bd_Cinfinite,
-  bd_Cnotzero = bd_Cnotzero,
-  collect_set_map = collect_set_map,
-  in_bd = in_bd,
-  in_cong = in_cong,
-  in_mono = in_mono,
-  in_rel = in_rel,
-  map_comp = map_comp,
-  map_cong = map_cong,
-  map_id = map_id,
-  map_transfer = map_transfer,
-  rel_eq = rel_eq,
-  rel_flip = rel_flip,
-  set_map = set_map,
-  rel_cong = rel_cong,
-  rel_mono = rel_mono,
-  rel_mono_strong = rel_mono_strong,
-  rel_Grp = rel_Grp,
-  rel_conversep = rel_conversep,
-  rel_OO = rel_OO};
-
-fun map_facts f {
-  bd_Card_order,
-  bd_Cinfinite,
-  bd_Cnotzero,
-  collect_set_map,
-  in_bd,
-  in_cong,
-  in_mono,
-  in_rel,
-  map_comp,
-  map_cong,
-  map_id,
-  map_transfer,
-  rel_eq,
-  rel_flip,
-  set_map,
-  rel_cong,
-  rel_mono,
-  rel_mono_strong,
-  rel_Grp,
-  rel_conversep,
-  rel_OO} =
-  {bd_Card_order = f bd_Card_order,
-    bd_Cinfinite = f bd_Cinfinite,
-    bd_Cnotzero = f bd_Cnotzero,
-    collect_set_map = Lazy.map f collect_set_map,
-    in_bd = Lazy.map f in_bd,
-    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_cong = Lazy.map f map_cong,
-    map_id = Lazy.map f map_id,
-    map_transfer = Lazy.map f map_transfer,
-    rel_eq = Lazy.map f rel_eq,
-    rel_flip = Lazy.map f rel_flip,
-    set_map = map (Lazy.map f) set_map,
-    rel_cong = Lazy.map f rel_cong,
-    rel_mono = Lazy.map f rel_mono,
-    rel_mono_strong = Lazy.map f rel_mono_strong,
-    rel_Grp = Lazy.map f rel_Grp,
-    rel_conversep = Lazy.map f rel_conversep,
-    rel_OO = Lazy.map f rel_OO};
-
-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*)
-  lives': typ list, (*target type variables of map*)
-  dead: int,
-  deads: typ list,
-  map: term,
-  sets: term list,
-  bd: term,
-  axioms: axioms,
-  defs: defs,
-  facts: facts,
-  nwits: int,
-  wits: nonemptiness_witness list,
-  rel: 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;
-
-fun flatten_type_args_of_bnf bnf dead_x xs =
-  let
-    val Type (_, Ts) = T_of_bnf bnf;
-    val lives = lives_of_bnf bnf;
-    val deads = deads_of_bnf bnf;
-  in
-    permute_like (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs)
-  end;
-
-(*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;
-
-(*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_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
-val in_bd_of_bnf = Lazy.force o #in_bd o #facts 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_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
-val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
-val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
-val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
-val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
-val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
-val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
-val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
-val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
-val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
-val rel_flip_of_bnf = Lazy.force o #rel_flip 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_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
-val set_map_of_bnf = map Lazy.force o #set_map o #facts 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_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
-val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
-val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
-val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
-val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms 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 =
-  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};
-
-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}) =
-  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};
-
-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;
-);
-
-fun bnf_of ctxt =
-  Symtab.lookup (Data.get (Context.Proof ctxt))
-  #> Option.map (morph_bnf (Morphism.transfer_morphism (Proof_Context.theory_of ctxt)));
-
-
-(* 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_pred2T instA instB))
-        Vartab.empty;
-  in Envir.subst_term (tyenv, Vartab.empty) rel end
-  handle Type.TYPE_MATCH => error "Bad relator";
-
-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) :: 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 mk_map live Ts Us t =
-  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
-    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
-  end;
-
-fun mk_rel live Ts Us t =
-  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
-    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
-  end;
-
-fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
-  let
-    fun build (TU as (T, U)) =
-      if T = U then
-        const T
-      else
-        (case TU of
-          (Type (s, Ts), Type (s', Us)) =>
-          if s = s' then
-            let
-              val bnf = the (bnf_of ctxt s);
-              val live = live_of_bnf bnf;
-              val mapx = mk live Ts Us (of_bnf bnf);
-              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
-            in Term.list_comb (mapx, map build TUs') end
-          else
-            build_simple TU
-        | _ => build_simple TU);
-  in build end;
-
-val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
-val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
-
-fun map_flattened_map_args ctxt s map_args fs =
-  let
-    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
-    val flat_fs' = map_args flat_fs;
-  in
-    permute_like (op aconv) flat_fs fs flat_fs'
-  end;
-
-
-(* Names *)
-
-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 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_mapN = "collect_set_map";
-val in_bdN = "in_bd";
-val in_monoN = "in_mono";
-val in_relN = "in_rel";
-val map_id0N = "map_id0";
-val map_idN = "map_id";
-val map_comp0N = "map_comp0";
-val map_compN = "map_comp";
-val map_cong0N = "map_cong0";
-val map_congN = "map_cong";
-val map_transferN = "map_transfer";
-val rel_eqN = "rel_eq";
-val rel_flipN = "rel_flip";
-val set_map0N = "set_map0";
-val set_mapN = "set_map";
-val set_bdN = "set_bd";
-val rel_GrpN = "rel_Grp";
-val rel_conversepN = "rel_conversep";
-val rel_monoN = "rel_mono"
-val rel_mono_strongN = "rel_mono_strong"
-val rel_comppN = "rel_compp";
-val rel_compp_GrpN = "rel_compp_Grp";
-
-datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
-
-datatype fact_policy = Dont_Note | Note_Some | Note_All;
-
-val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
-val bnf_timing = Attrib.setup_config_bool @{binding bnf_timing} (K false);
-
-fun user_policy policy ctxt = if Config.get ctxt bnf_note_all then Note_All else policy;
-
-val smart_max_inline_size = 25; (*FUDGE*)
-
-fun note_bnf_thms fact_policy qualify' bnf_b bnf =
-  let
-    val axioms = axioms_of_bnf bnf;
-    val facts = facts_of_bnf bnf;
-    val wits = wits_of_bnf bnf;
-    val qualify =
-      let val (_, qs, _) = Binding.dest bnf_b;
-      in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify' end;
-  in
-    (if fact_policy = Note_All then
-      let
-        val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
-        val notes =
-          [(bd_card_orderN, [#bd_card_order axioms]),
-            (bd_cinfiniteN, [#bd_cinfinite axioms]),
-            (bd_Card_orderN, [#bd_Card_order facts]),
-            (bd_CinfiniteN, [#bd_Cinfinite facts]),
-            (bd_CnotzeroN, [#bd_Cnotzero facts]),
-            (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
-            (in_bdN, [Lazy.force (#in_bd facts)]),
-            (in_monoN, [Lazy.force (#in_mono facts)]),
-            (in_relN, [Lazy.force (#in_rel facts)]),
-            (map_comp0N, [#map_comp0 axioms]),
-            (map_id0N, [#map_id0 axioms]),
-            (map_transferN, [Lazy.force (#map_transfer facts)]),
-            (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)]),
-            (set_map0N, #set_map0 axioms),
-            (set_bdN, #set_bd axioms)] @
-            (witNs ~~ wit_thmss_of_bnf bnf)
-            |> map (fn (thmN, thms) =>
-              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []),
-              [(thms, [])]));
-        in
-          Local_Theory.notes notes #> snd
-        end
-      else
-        I)
-    #> (if fact_policy <> Dont_Note then
-        let
-          val notes =
-            [(map_compN, [Lazy.force (#map_comp facts)], []),
-            (map_cong0N, [#map_cong0 axioms], []),
-            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
-            (map_idN, [Lazy.force (#map_id facts)], []),
-            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
-            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
-            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
-            (rel_eqN, [Lazy.force (#rel_eq facts)], []),
-            (rel_flipN, [Lazy.force (#rel_flip facts)], []),
-            (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
-            (rel_monoN, [Lazy.force (#rel_mono facts)], []),
-            (set_mapN, map Lazy.force (#set_map facts), [])]
-            |> filter_out (null o #2)
-            |> map (fn (thmN, thms, attrs) =>
-              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)),
-                attrs), [(thms, [])]));
-        in
-          Local_Theory.notes notes #> snd
-        end
-      else
-        I)
-  end;
-
-
-(* Define new BNFs *)
-
-fun define_bnf_consts const_policy fact_policy Ds_opt map_b rel_b set_bs
-  ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy =
-  let
-    val live = length set_rhss;
-
-    val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
-
-    fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
-
-    fun maybe_define user_specified (b, rhs) lthy =
-      let
-        val inline =
-          (user_specified orelse fact_policy = Dont_Note) 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, Drule.reflexive_thm), 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 lthy_old lthy =
-      lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
-
-    val map_bind_def =
-      (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
-         map_rhs);
-    val set_binds_defs =
-      let
-        fun set_name i get_b =
-          (case try (nth set_bs) (i - 1) of
-            SOME b => if Binding.is_empty b then get_b else K b
-          | NONE => get_b) #> def_qualify;
-        val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
-          else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
-      in bs ~~ set_rhss end;
-    val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
-
-    val ((((bnf_map_term, raw_map_def),
-      (bnf_set_terms, raw_set_defs)),
-      (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
-        no_defs_lthy
-        |> maybe_define true map_bind_def
-        ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
-        ||>> maybe_define true bd_bind_def
-        ||> `(maybe_restore no_defs_lthy);
-
-    val phi = Proof_Context.export_morphism lthy_old 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_map = Morphism.term phi bnf_map_term;
-
-    (*TODO: handle errors*)
-    (*simple shape analysis of a map function*)
-    val ((alphas, betas), (Calpha, _)) =
-      fastype_of bnf_map
-      |> strip_typeN live
-      |>> map_split dest_funT
-      ||> dest_funT
-      handle TYPE _ => error "Bad map function";
-
-    val Calpha_params = map TVar (Term.add_tvarsT Calpha []);
-
-    val bnf_T = Morphism.typ phi T_rhs;
-    val bad_args = Term.add_tfreesT bnf_T [];
-    val _ = if null bad_args then () else error ("Locally fixed type arguments " ^
-      commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
-
-    val bnf_sets =
-      map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms);
-    val bnf_bd =
-      Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params)
-        (Morphism.term phi bnf_bd_term);
-
-    (*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);
-
-    (*TODO: further checks of type of bnf_map*)
-    (*TODO: check types of bnf_sets*)
-    (*TODO: check type of bnf_bd*)
-    (*TODO: check type of bnf_rel*)
-
-    fun mk_bnf_map Ds As' Bs' =
-      Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
-    fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
-    fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
-
-    val (((As, Bs), Ds), names_lthy) = lthy
-      |> mk_TFrees live
-      ||>> mk_TFrees live
-      ||>> mk_TFrees (length deads);
-    val RTs = map2 (curry HOLogic.mk_prodT) As Bs;
-    val pred2RTs = map2 mk_pred2T As Bs;
-    val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst
-    val CA = mk_bnf_T Ds As Calpha;
-    val CR = mk_bnf_T Ds RTs Calpha;
-    val setRs =
-      map3 (fn R => fn T => fn U =>
-          HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split R) Rs As Bs;
-
-    (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
-      Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
-    val OO_Grp =
-      let
-        val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
-        val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
-        val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR;
-      in
-        mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2)
-        |> fold_rev Term.absfree Rs'
-      end;
-
-    val rel_rhs = the_default OO_Grp rel_rhs_opt;
-
-    val rel_bind_def =
-      (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
-         rel_rhs);
-
-    val wit_rhss =
-      if null wit_rhss then
-        [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
-          map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $
-          Const (@{const_name undefined}, CA))]
-      else wit_rhss;
-    val nwits = length wit_rhss;
-    val wit_binds_defs =
-      let
-        val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
-          else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
-      in bs ~~ wit_rhss end;
-
-    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
-      lthy
-      |> maybe_define (is_some rel_rhs_opt) rel_bind_def
-      ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
-      ||> `(maybe_restore lthy);
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-    val bnf_rel_def = Morphism.thm phi raw_rel_def;
-    val bnf_rel = Morphism.term phi bnf_rel_term;
-    fun mk_bnf_rel Ds As' Bs' =
-      normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
-        bnf_rel;
-
-    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
-    val bnf_wits =
-      map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
-
-    fun mk_OO_Grp Ds' As' Bs' =
-      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) OO_Grp;
-  in
-    (((alphas, betas, deads, Calpha),
-     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
-     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
-     (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_OO_Grp)), lthy)
-  end;
-
-fun prepare_def const_policy mk_fact_policy qualify prep_typ prep_term Ds_opt map_b rel_b set_bs
-  ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
-  no_defs_lthy =
-  let
-    val fact_policy = mk_fact_policy no_defs_lthy;
-    val bnf_b = qualify raw_bnf_b;
-    val live = length raw_sets;
-
-    val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
-    val map_rhs = prep_term no_defs_lthy raw_map;
-    val set_rhss = map (prep_term no_defs_lthy) raw_sets;
-    val bd_rhs = prep_term no_defs_lthy raw_bd;
-    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
-    val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
-
-    fun err T =
-      error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
-        " as unnamed BNF");
-
-    val (bnf_b, key) =
-      if Binding.eq_name (bnf_b, Binding.empty) then
-        (case T_rhs of
-          Type (C, Ts) => if forall (can dest_TFree) Ts
-            then (Binding.qualified_name C, C) else err T_rhs
-        | T => err T)
-      else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
-
-    val (((alphas, betas, deads, Calpha),
-     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
-     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
-     (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, mk_OO_Grp)), lthy) =
-       define_bnf_consts const_policy fact_policy Ds_opt map_b rel_b set_bs
-         ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy;
-
-    val dead = length deads;
-
-    val ((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), (Ts, T)) = lthy
-      |> mk_TFrees live
-      ||>> mk_TFrees live
-      ||>> mk_TFrees live
-      ||>> mk_TFrees dead
-      ||>> mk_TFrees live
-      ||>> mk_TFrees live
-      ||> fst o mk_TFrees 1
-      ||> the_single
-      ||> `(replicate live);
-
-    val mk_bnf_map = mk_bnf_map_Ds Ds;
-    val mk_bnf_t = mk_bnf_t_Ds Ds;
-    val mk_bnf_T = mk_bnf_T_Ds Ds;
-
-    val pred2RTs = map2 mk_pred2T As' Bs';
-    val pred2RTsAsCs = map2 mk_pred2T As' Cs;
-    val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
-    val pred2RT's = map2 mk_pred2T Bs' As';
-    val self_pred2RTs = map2 mk_pred2T As' As';
-    val transfer_domRTs = map2 mk_pred2T As' B1Ts;
-    val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts;
-
-    val CA' = mk_bnf_T As' Calpha;
-    val CB' = mk_bnf_T Bs' Calpha;
-    val CC' = mk_bnf_T Cs Calpha;
-    val CB1 = mk_bnf_T B1Ts Calpha;
-    val CB2 = mk_bnf_T B2Ts Calpha;
-
-    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;
-    fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
-
-    val pre_names_lthy = lthy;
-    val (((((((((((((((fs, gs), hs), x), y), zs), ys), As),
-      As_copy), bs), Rs), Rs_copy), Ss),
-      transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy
-      |> 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 (mk_Frees "x") CA'
-      ||>> yield_singleton (mk_Frees "y") CB'
-      ||>> mk_Frees "z" As'
-      ||>> mk_Frees "y" Bs'
-      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
-      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
-      ||>> mk_Frees "b" As'
-      ||>> mk_Frees "R" pred2RTs
-      ||>> mk_Frees "R" pred2RTs
-      ||>> mk_Frees "S" pred2RTsBsCs
-      ||>> mk_Frees "R" transfer_domRTs
-      ||>> mk_Frees "S" transfer_ranRTs;
-
-    val fs_copy = map2 (retype_free o fastype_of) fs gs;
-    val x_copy = retype_free CA' y;
-
-    val rel = mk_bnf_rel pred2RTs CA' CB';
-    val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
-    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
-
-    val map_id0_goal =
-      let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
-        mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
-      end;
-
-    val map_comp0_goal =
-      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) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
-      end;
-
-    fun mk_map_cong_prem x z set f f_copy =
-      Logic.all z (Logic.mk_implies
-        (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
-        mk_Trueprop_eq (f $ z, f_copy $ z)));
-
-    val map_cong0_goal =
-      let
-        val prems = map4 (mk_map_cong_prem x) zs bnf_sets_As fs fs_copy;
-        val eq = mk_Trueprop_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, eq))
-      end;
-
-    val set_map0s_goal =
-      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 (mk_Trueprop_eq (set_comp_map, image_comp_set))
-          end;
-      in
-        map3 mk_goal bnf_sets_As bnf_sets_Bs fs
-      end;
-
-    val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
-
-    val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
-
-    val set_bds_goal =
-      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 relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC';
-    val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC';
-    val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss);
-    val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss));
-    val le_rel_OO_goal =
-      fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
-
-    val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
-      Term.list_comb (mk_OO_Grp Ds As' Bs', Rs)));
-
-    val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
-      card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal;
-
-    fun mk_wit_goals (I, wit) =
-      let
-        val xs = map (nth bs) I;
-        fun wit_goal i =
-          let
-            val z = nth zs i;
-            val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
-            val concl = HOLogic.mk_Trueprop
-              (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
-              else @{term False});
-          in
-            fold_rev Logic.all (z :: xs)
-              (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
-          end;
-      in
-        map wit_goal (0 upto live - 1)
-      end;
-
-    val triv_wit_tac = mk_trivial_wit_tac bnf_wit_defs;
-
-    val wit_goalss =
-      (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
-
-    fun after_qed mk_wit_thms thms lthy =
-      let
-        val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
-
-        val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
-        val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
-        val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
-
-        fun mk_collect_set_map () =
-          let
-            val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T;
-            val collect_map = HOLogic.mk_comp
-              (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
-              Term.list_comb (mk_bnf_map As' Ts, hs));
-            val image_collect = mk_collect
-              (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
-              defT;
-            (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
-            val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
-          in
-            Goal.prove_sorry lthy [] [] goal (K (mk_collect_set_map_tac (#set_map0 axioms)))
-            |> Thm.close_derivation
-          end;
-
-        val collect_set_map = Lazy.lazy mk_collect_set_map;
-
-        fun mk_in_mono () =
-          let
-            val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy;
-            val in_mono_goal =
-              fold_rev Logic.all (As @ As_copy)
-                (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
-                  (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
-          in
-            Goal.prove_sorry lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
-            |> Thm.close_derivation
-          end;
-
-        val in_mono = Lazy.lazy mk_in_mono;
-
-        fun mk_in_cong () =
-          let
-            val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
-            val in_cong_goal =
-              fold_rev Logic.all (As @ As_copy)
-                (Logic.list_implies (prems_cong,
-                  mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
-          in
-            Goal.prove_sorry lthy [] [] in_cong_goal
-              (K ((TRY o hyp_subst_tac lthy THEN' rtac refl) 1))
-            |> Thm.close_derivation
-          end;
-
-        val in_cong = Lazy.lazy mk_in_cong;
-
-        val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms));
-        val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms));
-
-        fun mk_map_cong () =
-          let
-            val prem0 = mk_Trueprop_eq (x, x_copy);
-            val prems = map4 (mk_map_cong_prem x_copy) zs bnf_sets_As fs fs_copy;
-            val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
-              Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
-            val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
-              (Logic.list_implies (prem0 :: prems, eq));
-          in
-            Goal.prove_sorry lthy [] [] goal (fn _ => mk_map_cong_tac lthy (#map_cong0 axioms))
-            |> Thm.close_derivation
-          end;
-
-        val map_cong = Lazy.lazy mk_map_cong;
-
-        val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
-
-        val wit_thms =
-          if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
-
-        fun mk_in_bd () =
-          let
-            val bdT = fst (dest_relT (fastype_of bnf_bd_As));
-            val bdTs = replicate live bdT;
-            val bd_bnfT = mk_bnf_T bdTs Calpha;
-            val surj_imp_ordLeq_inst = (if live = 0 then TrueI else
-              let
-                val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As';
-                val funTs = map (fn T => bdT --> T) ranTs;
-                val ran_bnfT = mk_bnf_T ranTs Calpha;
-                val (revTs, Ts) = `rev (bd_bnfT :: funTs);
-                val cTs = map (SOME o certifyT lthy) [ran_bnfT, Library.foldr1 HOLogic.mk_prodT Ts];
-                val tinst = fold (fn T => fn t => HOLogic.mk_split (Term.absdummy T t)) (tl revTs)
-                  (Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs,
-                    map Bound (live - 1 downto 0)) $ Bound live));
-                val cts = [NONE, SOME (certify lthy tinst)];
-              in
-                Drule.instantiate' cTs cts @{thm surj_imp_ordLeq}
-              end);
-            val bd = mk_cexp
-              (if live = 0 then ctwo
-                else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
-              (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT)));
-            val in_bd_goal =
-              fold_rev Logic.all As
-                (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd));
-          in
-            Goal.prove_sorry lthy [] [] in_bd_goal
-              (mk_in_bd_tac live surj_imp_ordLeq_inst
-                (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms)
-                (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms)
-                bd_Card_order bd_Cinfinite bd_Cnotzero)
-            |> Thm.close_derivation
-          end;
-
-        val in_bd = Lazy.lazy mk_in_bd;
-
-        val rel_OO_Grp = #rel_OO_Grp axioms;
-        val rel_OO_Grps = no_refl [rel_OO_Grp];
-
-        fun mk_rel_Grp () =
-          let
-            val lhs = Term.list_comb (rel, map2 mk_Grp As fs);
-            val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
-            val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
-          in
-            Goal.prove_sorry lthy [] [] goal
-              (mk_rel_Grp_tac rel_OO_Grps (#map_id0 axioms) (#map_cong0 axioms) (Lazy.force map_id)
-                (Lazy.force map_comp) (map Lazy.force set_map))
-            |> Thm.close_derivation
-          end;
-
-        val rel_Grp = Lazy.lazy mk_rel_Grp;
-
-        fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
-        fun mk_rel_concl f = HOLogic.mk_Trueprop
-          (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy)));
-
-        fun mk_rel_mono () =
-          let
-            val mono_prems = mk_rel_prems mk_leq;
-            val mono_concl = mk_rel_concl (uncurry mk_leq);
-          in
-            Goal.prove_sorry lthy [] []
-              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
-              (K (mk_rel_mono_tac rel_OO_Grps (Lazy.force in_mono)))
-            |> Thm.close_derivation
-          end;
-
-        fun mk_rel_cong () =
-          let
-            val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
-            val cong_concl = mk_rel_concl HOLogic.mk_eq;
-          in
-            Goal.prove_sorry lthy [] []
-              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
-              (fn _ => (TRY o hyp_subst_tac lthy THEN' rtac refl) 1)
-            |> Thm.close_derivation
-          end;
-
-        val rel_mono = Lazy.lazy mk_rel_mono;
-        val rel_cong = Lazy.lazy mk_rel_cong;
-
-        fun mk_rel_eq () =
-          Goal.prove_sorry lthy [] []
-            (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'),
-              HOLogic.eq_const CA'))
-            (K (mk_rel_eq_tac live (Lazy.force rel_Grp) (Lazy.force rel_cong) (#map_id0 axioms)))
-          |> Thm.close_derivation;
-
-        val rel_eq = Lazy.lazy mk_rel_eq;
-
-        fun mk_rel_conversep () =
-          let
-            val relBsAs = mk_bnf_rel pred2RT's CB' CA';
-            val lhs = Term.list_comb (relBsAs, map mk_conversep Rs);
-            val rhs = mk_conversep (Term.list_comb (rel, Rs));
-            val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs));
-            val le_thm = Goal.prove_sorry lthy [] [] le_goal
-              (mk_rel_conversep_le_tac rel_OO_Grps (Lazy.force rel_eq) (#map_cong0 axioms)
-                (Lazy.force map_comp) (map Lazy.force set_map))
-              |> Thm.close_derivation
-            val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
-          in
-            Goal.prove_sorry lthy [] [] goal
-              (K (mk_rel_conversep_tac le_thm (Lazy.force rel_mono)))
-            |> Thm.close_derivation
-          end;
-
-        val rel_conversep = Lazy.lazy mk_rel_conversep;
-
-        fun mk_rel_OO () =
-          Goal.prove_sorry lthy [] []
-            (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs)))
-            (mk_rel_OO_le_tac rel_OO_Grps (Lazy.force rel_eq) (#map_cong0 axioms)
-              (Lazy.force map_comp) (map Lazy.force set_map))
-          |> Thm.close_derivation
-          |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]);
-
-        val rel_OO = Lazy.lazy mk_rel_OO;
-
-        fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD};
-
-        val in_rel = Lazy.lazy mk_in_rel;
-
-        fun mk_rel_flip () =
-          let
-            val rel_conversep_thm = Lazy.force rel_conversep;
-            val cts = map (SOME o certify lthy) Rs;
-            val rel_conversep_thm' = cterm_instantiate_pos cts rel_conversep_thm;
-          in
-            unfold_thms lthy @{thms conversep_iff} (rel_conversep_thm' RS @{thm predicate2_eqD})
-            |> singleton (Proof_Context.export names_lthy pre_names_lthy)
-          end;
-
-        val rel_flip = Lazy.lazy mk_rel_flip;
-
-        fun mk_rel_mono_strong () =
-          let
-            fun mk_prem setA setB R S a b =
-              HOLogic.mk_Trueprop
-                (mk_Ball (setA $ x) (Term.absfree (dest_Free a)
-                  (mk_Ball (setB $ y) (Term.absfree (dest_Free b)
-                    (HOLogic.mk_imp (R $ a $ b, S $ a $ b))))));
-            val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) :: 
-              map6 mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys;
-            val concl = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs_copy) $ x $ y);
-          in
-            Goal.prove_sorry lthy [] []
-              (fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl)))
-              (mk_rel_mono_strong_tac (Lazy.force in_rel) (map Lazy.force set_map))
-            |> Thm.close_derivation
-          end;
-
-        val rel_mono_strong = Lazy.lazy mk_rel_mono_strong;
-
-        fun mk_map_transfer () =
-          let
-            val rels = map2 mk_fun_rel transfer_domRs transfer_ranRs;
-            val rel = mk_fun_rel
-              (Term.list_comb (mk_bnf_rel transfer_domRTs CA' CB1, transfer_domRs))
-              (Term.list_comb (mk_bnf_rel transfer_ranRTs CB' CB2, transfer_ranRs));
-            val concl = HOLogic.mk_Trueprop
-              (fold_rev mk_fun_rel rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts);
-          in
-            Goal.prove_sorry lthy [] []
-              (fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl)
-              (mk_map_transfer_tac (Lazy.force rel_mono) (Lazy.force in_rel)
-                (map Lazy.force set_map) (#map_cong0 axioms) (Lazy.force map_comp))
-            |> Thm.close_derivation
-          end;
-
-        val map_transfer = Lazy.lazy mk_map_transfer;
-
-        val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def;
-
-        val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong
-          in_mono in_rel map_comp map_cong map_id map_transfer rel_eq rel_flip set_map
-          rel_cong rel_mono rel_mono_strong rel_Grp rel_conversep rel_OO;
-
-        val wits = map2 mk_witness bnf_wits wit_thms;
-
-        val bnf_rel =
-          Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
-
-        val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms
-          defs facts wits bnf_rel;
-      in
-        (bnf, lthy |> note_bnf_thms fact_policy qualify bnf_b bnf)
-      end;
-
-    val one_step_defs =
-      no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def]);
-  in
-    (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
-  end;
-
-fun register_bnf key (bnf, lthy) =
-  (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
-    (fn phi => Data.map (Symtab.default (key, morph_bnf phi bnf))) lthy);
-
-fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
-  (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
-  let
-    fun mk_wits_tac set_maps =
-      K (TRYALL Goal.conjunction_tac) THEN'
-      (case triv_tac_opt of
-        SOME tac => tac set_maps
-      | NONE => fn {context = ctxt, prems} =>
-          unfold_thms_tac ctxt one_step_defs THEN wit_tac {context = ctxt, prems = prems});
-    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
-    fun mk_wit_thms set_maps =
-      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
-        |> Conjunction.elim_balanced (length wit_goals)
-        |> map2 (Conjunction.elim_balanced o length) wit_goalss
-        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
-  in
-    map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
-      goals (map (fn tac => fn {context = ctxt, prems} =>
-        unfold_thms_tac ctxt one_step_defs THEN tac {context = ctxt, prems = prems}) tacs)
-    |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
-  end) oo prepare_def const_policy fact_policy qualify (K I) (K I) Ds map_b rel_b set_bs;
-
-val bnf_cmd = (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
-  let
-    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
-    fun mk_triv_wit_thms tac set_maps =
-      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
-        (K (TRYALL Goal.conjunction_tac) THEN' tac set_maps)
-        |> Conjunction.elim_balanced (length wit_goals)
-        |> map2 (Conjunction.elim_balanced o length) wit_goalss
-        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
-    val (mk_wit_thms, nontriv_wit_goals) = 
-      (case triv_tac_opt of
-        NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
-      | SOME tac => (mk_triv_wit_thms tac, []));
-  in
-    Proof.unfolding ([[(defs, [])]])
-      (Proof.theorem NONE (snd o register_bnf key oo after_qed mk_wit_thms)
-        (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
-  end) oo prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_typ Syntax.read_term NONE
-    Binding.empty Binding.empty [];
-
-fun print_bnfs ctxt =
-  let
-    fun pretty_set sets i = Pretty.block
-      [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
-          Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
-
-    fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
-      live = live, lives = lives, dead = dead, deads = deads, ...}) =
-      Pretty.big_list
-        (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
-          Pretty.quote (Syntax.pretty_typ ctxt T)]))
-        ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
-            Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
-          Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
-            Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
-          Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
-            Pretty.quote (Syntax.pretty_term ctxt map)]] @
-          List.map (pretty_set sets) (0 upto length sets - 1) @
-          [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
-            Pretty.quote (Syntax.pretty_term ctxt bd)]]);
-  in
-    Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
-    |> Pretty.writeln
-  end;
-
-val _ =
-  Outer_Syntax.improper_command @{command_spec "print_bnfs"}
-    "print all bounded natural functors"
-    (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
-
-val _ =
-  Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
-    "register a type as a bounded natural functor"
-    (parse_opt_binding_colon -- Parse.typ --|
-       (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
-       (Scan.option ((Parse.reserved "sets" -- @{keyword ":"}) |--
-         Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) >> the_default []) --|
-       (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
-       (Scan.option ((Parse.reserved "wits" -- @{keyword ":"}) |--
-         Scan.repeat1 (Scan.unless (Parse.reserved "rel") Parse.term)) >> the_default []) --
-       Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term)
-       >> bnf_cmd);
-
-end;
--- a/src/HOL/BNF/Tools/bnf_def_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,284 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_def_tactics.ML
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012
-
-Tactics for definition of bounded natural functors.
-*)
-
-signature BNF_DEF_TACTICS =
-sig
-  val mk_collect_set_map_tac: thm list -> tactic
-  val mk_map_id: thm -> thm
-  val mk_map_comp: thm -> thm
-  val mk_map_cong_tac: Proof.context -> thm -> tactic
-  val mk_in_mono_tac: int -> tactic
-  val mk_set_map: thm -> thm
-
-  val mk_rel_Grp_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
-    {prems: thm list, context: Proof.context} -> tactic
-  val mk_rel_eq_tac: int -> thm -> thm -> thm -> tactic
-  val mk_rel_OO_le_tac: thm list -> thm -> thm -> thm -> thm list ->
-    {prems: thm list, context: Proof.context} -> tactic
-  val mk_rel_conversep_tac: thm -> thm -> tactic
-  val mk_rel_conversep_le_tac: thm list -> thm -> thm -> thm -> thm list ->
-    {prems: thm list, context: Proof.context} -> tactic
-  val mk_rel_mono_tac: thm list -> thm -> tactic
-  val mk_rel_mono_strong_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
-
-  val mk_map_transfer_tac: thm -> thm -> thm list -> thm -> thm ->
-    {prems: thm list, context: Proof.context} -> tactic
-
-  val mk_in_bd_tac: int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm ->
-    thm -> {prems: thm list, context: Proof.context} -> tactic
-
-  val mk_trivial_wit_tac: thm list -> thm list -> {prems: thm list, context: Proof.context} ->
-    tactic
-end;
-
-structure BNF_Def_Tactics : BNF_DEF_TACTICS =
-struct
-
-open BNF_Util
-open BNF_Tactics
-
-val ord_eq_le_trans = @{thm ord_eq_le_trans};
-val ord_le_eq_trans = @{thm ord_le_eq_trans};
-val conversep_shift = @{thm conversep_le_swap} RS iffD1;
-
-fun mk_map_id id = mk_trans (fun_cong OF [id]) @{thm id_apply};
-fun mk_map_comp comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
-fun mk_map_cong_tac ctxt cong0 =
-  (hyp_subst_tac ctxt THEN' rtac cong0 THEN'
-   REPEAT_DETERM o (dtac meta_spec THEN' etac meta_mp THEN' atac)) 1;
-fun mk_set_map set_map0 = set_map0 RS @{thm comp_eq_dest};
-fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
-  else (rtac subsetI THEN'
-  rtac CollectI) 1 THEN
-  REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
-  REPEAT_DETERM_N (n - 1)
-    ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
-  (etac subset_trans THEN' atac) 1;
-
-fun mk_collect_set_map_tac set_map0s =
-  (rtac (@{thm collect_o} RS trans) THEN' rtac @{thm arg_cong[of _ _ collect]} THEN'
-  EVERY' (map (fn set_map0 =>
-    rtac (mk_trans @{thm image_insert} @{thm arg_cong2[of _ _ _ _ insert]}) THEN'
-    rtac set_map0) set_map0s) THEN'
-  rtac @{thm image_empty}) 1;
-
-fun mk_rel_Grp_tac rel_OO_Grps map_id0 map_cong0 map_id map_comp set_maps
-  {context = ctxt, prems = _} =
-  let
-    val n = length set_maps;
-    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac (hd rel_OO_Grps RS trans);
-  in
-    if null set_maps then
-      unfold_thms_tac ctxt ((map_id0 RS @{thm Grp_UNIV_id}) :: rel_OO_Grps) THEN
-      rtac @{thm Grp_UNIV_idI[OF refl]} 1
-    else
-      EVERY' [rel_OO_Grps_tac, rtac @{thm antisym}, rtac @{thm predicate2I},
-        REPEAT_DETERM o
-          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
-        hyp_subst_tac ctxt, rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0,
-        REPEAT_DETERM_N n o EVERY' [rtac @{thm Collect_split_Grp_eqD}, etac @{thm set_mp}, atac],
-        rtac CollectI,
-        CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
-          rtac @{thm image_subsetI}, rtac @{thm Collect_split_Grp_inD}, etac @{thm set_mp}, atac])
-        set_maps,
-        rtac @{thm predicate2I}, REPEAT_DETERM o eresolve_tac [@{thm GrpE}, exE, conjE],
-        hyp_subst_tac ctxt,
-        rtac @{thm relcomppI}, rtac @{thm conversepI},
-        EVERY' (map2 (fn convol => fn map_id0 =>
-          EVERY' [rtac @{thm GrpI}, rtac (box_equals OF [map_cong0, map_comp RS sym, map_id0]),
-            REPEAT_DETERM_N n o rtac (convol RS fun_cong),
-            REPEAT_DETERM o eresolve_tac [CollectE, conjE],
-            rtac CollectI,
-            CONJ_WRAP' (fn thm =>
-              EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
-                rtac @{thm convol_mem_GrpI}, etac set_mp, atac])
-            set_maps])
-          @{thms fst_convol snd_convol} [map_id, refl])] 1
-  end;
-
-fun mk_rel_eq_tac n rel_Grp rel_cong map_id0 =
-  (EVERY' (rtac (rel_cong RS trans) :: replicate n (rtac @{thm eq_alt})) THEN'
-  rtac (rel_Grp RSN (2, @{thm box_equals[OF _ sym sym[OF eq_alt]]})) THEN'
-  (if n = 0 then rtac refl
-  else EVERY' [rtac @{thm arg_cong2[of _ _ _ _ "Grp"]},
-    rtac @{thm equalityI}, rtac subset_UNIV, rtac subsetI, rtac CollectI,
-    CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto n), rtac map_id0])) 1;
-
-fun mk_rel_mono_tac rel_OO_Grps in_mono =
-  let
-    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
-      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
-        rtac (hd rel_OO_Grps RS sym RSN (2, ord_le_eq_trans));
-  in
-    EVERY' [rel_OO_Grps_tac, rtac @{thm relcompp_mono}, rtac @{thm iffD2[OF conversep_mono]},
-      rtac @{thm Grp_mono}, rtac in_mono, REPEAT_DETERM o etac @{thm Collect_split_mono},
-      rtac @{thm Grp_mono}, rtac in_mono, REPEAT_DETERM o etac @{thm Collect_split_mono}] 1
-  end;
-
-fun mk_rel_conversep_le_tac rel_OO_Grps rel_eq map_cong0 map_comp set_maps
-  {context = ctxt, prems = _} =
-  let
-    val n = length set_maps;
-    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
-      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
-        rtac (hd rel_OO_Grps RS sym RS @{thm arg_cong[of _ _ conversep]} RSN (2, ord_le_eq_trans));
-  in
-    if null set_maps then rtac (rel_eq RS @{thm leq_conversepI}) 1
-    else
-      EVERY' [rel_OO_Grps_tac, rtac @{thm predicate2I},
-        REPEAT_DETERM o
-          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
-        hyp_subst_tac ctxt, rtac @{thm conversepI}, rtac @{thm relcomppI}, rtac @{thm conversepI},
-        EVERY' (map (fn thm => EVERY' [rtac @{thm GrpI}, rtac sym, rtac trans,
-          rtac map_cong0, REPEAT_DETERM_N n o rtac thm,
-          rtac (map_comp RS sym), rtac CollectI,
-          CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
-            etac @{thm flip_pred}]) set_maps]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
-  end;
-
-fun mk_rel_conversep_tac le_conversep rel_mono =
-  EVERY' [rtac @{thm antisym}, rtac le_conversep, rtac @{thm xt1(6)}, rtac conversep_shift,
-    rtac le_conversep, rtac @{thm iffD2[OF conversep_mono]}, rtac rel_mono,
-    REPEAT_DETERM o rtac @{thm eq_refl[OF sym[OF conversep_conversep]]}] 1;
-
-fun mk_rel_OO_le_tac rel_OO_Grps rel_eq map_cong0 map_comp set_maps
-  {context = ctxt, prems = _} =
-  let
-    val n = length set_maps;
-    fun in_tac nthO_in = rtac CollectI THEN'
-        CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
-          rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_maps;
-    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
-      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
-        rtac (@{thm arg_cong2[of _ _ _ _ "op OO"]} OF (replicate 2 (hd rel_OO_Grps RS sym)) RSN
-          (2, ord_le_eq_trans));
-  in
-    if null set_maps then rtac (rel_eq RS @{thm leq_OOI}) 1
-    else
-      EVERY' [rel_OO_Grps_tac, rtac @{thm predicate2I},
-        REPEAT_DETERM o
-          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
-        hyp_subst_tac ctxt,
-        rtac @{thm relcomppI}, rtac @{thm relcomppI}, rtac @{thm conversepI}, rtac @{thm GrpI},
-        rtac trans, rtac map_comp, rtac sym, rtac map_cong0,
-        REPEAT_DETERM_N n o rtac @{thm fst_fstOp},
-        in_tac @{thm fstOp_in},
-        rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0,
-        REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, 
-          rtac ballE, rtac subst,
-          rtac @{thm csquare_def}, rtac @{thm csquare_fstOp_sndOp}, atac, etac notE,
-          etac set_mp, atac],
-        in_tac @{thm fstOp_in},
-        rtac @{thm relcomppI}, rtac @{thm conversepI}, rtac @{thm GrpI},
-        rtac trans, rtac map_comp, rtac map_cong0,
-        REPEAT_DETERM_N n o rtac o_apply,
-        in_tac @{thm sndOp_in},
-        rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac sym, rtac map_cong0,
-        REPEAT_DETERM_N n o rtac @{thm snd_sndOp},
-        in_tac @{thm sndOp_in}] 1
-  end;
-
-fun mk_rel_mono_strong_tac in_rel set_maps {context = ctxt, prems = _} =
-  if null set_maps then atac 1
-  else
-    unfold_tac ctxt [in_rel] THEN
-    REPEAT_DETERM (eresolve_tac [exE, CollectE, conjE] 1) THEN
-    hyp_subst_tac ctxt 1 THEN
-    unfold_tac ctxt set_maps THEN
-    EVERY' [rtac exI, rtac @{thm conjI[OF CollectI conjI[OF refl refl]]},
-      CONJ_WRAP' (K (etac @{thm Collect_split_mono_strong} THEN' atac)) set_maps] 1;
-
-fun mk_map_transfer_tac rel_mono in_rel set_maps map_cong0 map_comp
-  {context = ctxt, prems = _} =
-  let
-    val n = length set_maps;
-    val in_tac = if n = 0 then rtac UNIV_I else
-      rtac CollectI THEN' CONJ_WRAP' (fn thm =>
-        etac (thm RS
-          @{thm ord_eq_le_trans[OF _ subset_trans[OF image_mono convol_image_vimage2p]]}))
-      set_maps;
-  in
-    REPEAT_DETERM_N n (HEADGOAL (rtac @{thm fun_relI})) THEN
-    unfold_thms_tac ctxt @{thms fun_rel_iff_leq_vimage2p} THEN
-    HEADGOAL (EVERY' [rtac @{thm order_trans}, rtac rel_mono, REPEAT_DETERM_N n o atac,
-      rtac @{thm predicate2I}, dtac (in_rel RS iffD1),
-      REPEAT_DETERM o eresolve_tac [exE, CollectE, conjE], hyp_subst_tac ctxt,
-      rtac @{thm vimage2pI}, rtac (in_rel RS iffD2), rtac exI, rtac conjI, in_tac,
-      rtac conjI,
-      EVERY' (map (fn convol =>
-        rtac (box_equals OF [map_cong0, map_comp RS sym, map_comp RS sym]) THEN'
-        REPEAT_DETERM_N n o rtac (convol RS fun_cong)) @{thms fst_convol snd_convol})])
-  end;
-
-fun mk_in_bd_tac live surj_imp_ordLeq_inst map_comp map_id map_cong0 set_maps set_bds
-  bd_card_order bd_Card_order bd_Cinfinite bd_Cnotzero {context = ctxt, prems = _} =
-  if live = 0 then
-    rtac @{thm ordLeq_transitive[OF ordLeq_csum2[OF card_of_Card_order]
-      ordLeq_cexp2[OF ordLeq_refl[OF Card_order_ctwo] Card_order_csum]]} 1
-  else
-    let
-      val bd'_Cinfinite = bd_Cinfinite RS @{thm Cinfinite_csum1};
-      val inserts =
-        map (fn set_bd => 
-          iffD2 OF [@{thm card_of_ordLeq}, @{thm ordLeq_ordIso_trans} OF
-            [set_bd, bd_Card_order RS @{thm card_of_Field_ordIso} RS @{thm ordIso_symmetric}]])
-        set_bds;        
-    in
-      EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac @{thm cprod_cinfinite_bound},
-        rtac (ctrans OF @{thms ordLeq_csum2 ordLeq_cexp2}), rtac @{thm card_of_Card_order},
-        rtac @{thm ordLeq_csum2}, rtac @{thm Card_order_ctwo}, rtac @{thm Card_order_csum},
-        rtac @{thm ordIso_ordLeq_trans}, rtac @{thm cexp_cong1},
-        if live = 1 then rtac @{thm ordIso_refl[OF Card_order_csum]}
-        else
-          REPEAT_DETERM_N (live - 2) o rtac @{thm ordIso_transitive[OF csum_cong2]} THEN'
-          REPEAT_DETERM_N (live - 1) o rtac @{thm csum_csum},
-        rtac bd_Card_order, rtac (@{thm cexp_mono2_Cnotzero} RS ctrans), rtac @{thm ordLeq_csum1},
-        rtac bd_Card_order, rtac @{thm Card_order_csum}, rtac bd_Cnotzero,
-        rtac @{thm csum_Cfinite_cexp_Cinfinite},
-        rtac (if live = 1 then @{thm card_of_Card_order} else @{thm Card_order_csum}),
-        CONJ_WRAP_GEN' (rtac @{thm Cfinite_csum}) (K (rtac @{thm Cfinite_cone})) set_maps,
-        rtac bd'_Cinfinite, rtac @{thm card_of_Card_order},
-        rtac @{thm Card_order_cexp}, rtac @{thm Cinfinite_cexp}, rtac @{thm ordLeq_csum2},
-        rtac @{thm Card_order_ctwo}, rtac bd'_Cinfinite,
-        rtac (Drule.rotate_prems 1 (@{thm cprod_mono2} RSN (2, ctrans))),
-        REPEAT_DETERM_N (live - 1) o
-          (rtac (bd_Cinfinite RS @{thm cprod_cexp_csum_cexp_Cinfinite} RSN (2, ctrans)) THEN'
-           rtac @{thm ordLeq_ordIso_trans[OF cprod_mono2 ordIso_symmetric[OF cprod_cexp]]}),
-        rtac @{thm ordLeq_refl[OF Card_order_cexp]}] 1 THEN
-      unfold_thms_tac ctxt [bd_card_order RS @{thm card_order_csum_cone_cexp_def}] THEN
-      unfold_thms_tac ctxt @{thms cprod_def Field_card_of} THEN
-      EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac surj_imp_ordLeq_inst, rtac subsetI,
-        Method.insert_tac inserts, REPEAT_DETERM o dtac meta_spec,
-        REPEAT_DETERM o eresolve_tac [exE, Tactic.make_elim conjunct1], etac CollectE,
-        if live = 1 then K all_tac
-        else REPEAT_DETERM_N (live - 2) o (etac conjE THEN' rotate_tac ~1) THEN' etac conjE,
-        rtac (Drule.rotate_prems 1 @{thm image_eqI}), rtac @{thm SigmaI}, rtac @{thm UNIV_I},
-        CONJ_WRAP_GEN' (rtac @{thm SigmaI})
-          (K (etac @{thm If_the_inv_into_in_Func} THEN' atac)) set_maps,
-        rtac sym,
-        rtac (Drule.rotate_prems 1
-           ((box_equals OF [map_cong0 OF replicate live @{thm If_the_inv_into_f_f},
-             map_comp RS sym, map_id]) RSN (2, trans))),
-        REPEAT_DETERM_N (2 * live) o atac,
-        REPEAT_DETERM_N live o rtac (@{thm prod.cases} RS trans),
-        rtac refl,
-        rtac @{thm surj_imp_ordLeq}, rtac subsetI, rtac (Drule.rotate_prems 1 @{thm image_eqI}),
-        REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
-        CONJ_WRAP' (fn thm =>
-          rtac (thm RS ord_eq_le_trans) THEN' etac @{thm subset_trans[OF image_mono Un_upper1]})
-        set_maps,
-        rtac sym,
-        rtac (box_equals OF [map_cong0 OF replicate live @{thm fun_cong[OF sum_case_o_inj(1)]},
-           map_comp RS sym, map_id])] 1
-  end;
-
-fun mk_trivial_wit_tac wit_defs set_maps {context = ctxt, prems = _} =
-  unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm =>
-    dtac (thm RS equalityD1 RS set_mp) THEN' etac imageE THEN' atac) set_maps)) THEN ALLGOALS atac;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1523 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_def_sugar.ML
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
-
-Sugared datatype and codatatype constructions.
-*)
-
-signature BNF_FP_DEF_SUGAR =
-sig
-  type fp_sugar =
-    {T: typ,
-     fp: BNF_FP_Util.fp_kind,
-     index: int,
-     pre_bnfs: BNF_Def.bnf list,
-     nested_bnfs: BNF_Def.bnf list,
-     nesting_bnfs: BNF_Def.bnf list,
-     fp_res: BNF_FP_Util.fp_result,
-     ctr_defss: thm list list,
-     ctr_sugars: Ctr_Sugar.ctr_sugar list,
-     co_iterss: term list list,
-     mapss: thm list list,
-     co_inducts: thm list,
-     co_iter_thmsss: thm list list list,
-     disc_co_itersss: thm list list list,
-     sel_co_iterssss: thm list list list list};
-
-  val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
-  val eq_fp_sugar: fp_sugar * fp_sugar -> bool
-  val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar
-  val transfer_fp_sugar: Proof.context -> fp_sugar -> fp_sugar
-  val fp_sugar_of: Proof.context -> string -> fp_sugar option
-  val fp_sugars_of: Proof.context -> fp_sugar list
-
-  val co_induct_of: 'a list -> 'a
-  val strong_co_induct_of: 'a list -> 'a
-
-  val tvar_subst: theory -> typ list -> typ list -> ((string * int) * typ) list
-  val exists_subtype_in: typ list -> typ -> bool
-  val flat_rec_arg_args: 'a list list -> 'a list
-  val flat_corec_preds_predsss_gettersss: 'a list -> 'a list list list -> 'a list list list ->
-    'a list
-  val mk_co_iter: theory -> BNF_FP_Util.fp_kind -> typ -> typ list -> term -> term
-  val nesty_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list
-
-  type lfp_sugar_thms =
-    (thm list * thm * Args.src list)
-    * (thm list list * thm list list * Args.src list)
-
-  val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms
-  val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms
-
-  type gfp_sugar_thms =
-    ((thm list * thm) list * Args.src list)
-    * (thm list list * thm list list * Args.src list)
-    * (thm list list * thm list list * Args.src list)
-    * (thm list list * thm list list * Args.src list)
-    * (thm list list list * thm list list list * Args.src list)
-
-  val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms
-  val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms
-
-  val mk_co_iters_prelims: BNF_FP_Util.fp_kind -> typ list list list -> typ list -> typ list ->
-    int list -> int list list -> term list list -> Proof.context ->
-    (term list list
-     * (typ list list * typ list list list list * term list list
-        * term list list list list) list option
-     * (string * term list * term list list
-        * ((term list list * term list list list) * (typ list * typ list list)) list) option)
-    * Proof.context
-  val mk_iter_fun_arg_types: typ list list list -> int list -> int list list -> term ->
-    typ list list list list
-  val mk_coiter_fun_arg_types: typ list list list -> typ list -> int list -> term ->
-    typ list list
-    * (typ list list list list * typ list list list * typ list list list list * typ list)
-  val define_iters: string list ->
-    (typ list list * typ list list list list * term list list * term list list list list) list ->
-    (string -> binding) -> typ list -> typ list -> term list -> Proof.context ->
-    (term list * thm list) * Proof.context
-  val define_coiters: string list -> string * term list * term list list
-    * ((term list list * term list list list) * (typ list * typ list list)) list ->
-    (string -> binding) -> typ list -> typ list -> term list -> Proof.context ->
-    (term list * thm list) * Proof.context
-  val derive_induct_iters_thms_for_types: BNF_Def.bnf list ->
-    (typ list list * typ list list list list * term list list * term list list list list) list ->
-    thm -> thm list list -> BNF_Def.bnf list -> BNF_Def.bnf list -> typ list -> typ list ->
-    typ list -> typ list list list -> term list list -> thm list list -> term list list ->
-    thm list list -> local_theory -> lfp_sugar_thms
-  val derive_coinduct_coiters_thms_for_types: BNF_Def.bnf list ->
-    string * term list * term list list * ((term list list * term list list list)
-      * (typ list * typ list list)) list ->
-    thm -> thm list -> thm list -> thm list list -> BNF_Def.bnf list -> typ list -> typ list ->
-    typ list -> typ list list list -> int list list -> int list list -> int list -> thm list list ->
-    Ctr_Sugar.ctr_sugar list -> term list list -> thm list list -> (thm list -> thm list) ->
-    local_theory -> gfp_sugar_thms
-  val co_datatypes: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
-      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
-      BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
-    (bool * (bool * bool)) * (((((binding * (typ * sort)) list * binding) * (binding * binding))
-      * mixfix) * ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
-        mixfix) list) list ->
-    local_theory -> local_theory
-  val parse_co_datatype_cmd: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
-      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
-      BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
-    (local_theory -> local_theory) parser
-end;
-
-structure BNF_FP_Def_Sugar : BNF_FP_DEF_SUGAR =
-struct
-
-open Ctr_Sugar
-open BNF_Util
-open BNF_Comp
-open BNF_Def
-open BNF_FP_Util
-open BNF_FP_Def_Sugar_Tactics
-
-val EqN = "Eq_";
-
-type fp_sugar =
-  {T: typ,
-   fp: fp_kind,
-   index: int,
-   pre_bnfs: bnf list,
-   nested_bnfs: bnf list,
-   nesting_bnfs: bnf list,
-   fp_res: fp_result,
-   ctr_defss: thm list list,
-   ctr_sugars: ctr_sugar list,
-   co_iterss: term list list,
-   mapss: thm list list,
-   co_inducts: thm list,
-   co_iter_thmsss: thm list list list,
-   disc_co_itersss: thm list list list,
-   sel_co_iterssss: thm list list list list};
-
-fun of_fp_sugar f (fp_sugar as ({index, ...}: fp_sugar)) = nth (f fp_sugar) index;
-
-fun eq_fp_sugar ({T = T1, fp = fp1, index = index1, fp_res = fp_res1, ...} : fp_sugar,
-    {T = T2, fp = fp2, index = index2, fp_res = fp_res2, ...} : fp_sugar) =
-  T1 = T2 andalso fp1 = fp2 andalso index1 = index2 andalso eq_fp_result (fp_res1, fp_res2);
-
-fun morph_fp_sugar phi ({T, fp, index, pre_bnfs, nested_bnfs, nesting_bnfs, fp_res, ctr_defss,
-    ctr_sugars, co_iterss, mapss, co_inducts, co_iter_thmsss, disc_co_itersss, sel_co_iterssss}
-    : fp_sugar) =
-  {T = Morphism.typ phi T, fp = fp, index = index, pre_bnfs = map (morph_bnf phi) pre_bnfs,
-    nested_bnfs = map (morph_bnf phi) nested_bnfs, nesting_bnfs = map (morph_bnf phi) nesting_bnfs,
-   fp_res = morph_fp_result phi fp_res,
-   ctr_defss = map (map (Morphism.thm phi)) ctr_defss,
-   ctr_sugars = map (morph_ctr_sugar phi) ctr_sugars,
-   co_iterss = map (map (Morphism.term phi)) co_iterss,
-   mapss = map (map (Morphism.thm phi)) mapss,
-   co_inducts = map (Morphism.thm phi) co_inducts,
-   co_iter_thmsss = map (map (map (Morphism.thm phi))) co_iter_thmsss,
-   disc_co_itersss = map (map (map (Morphism.thm phi))) disc_co_itersss,
-   sel_co_iterssss = map (map (map (map (Morphism.thm phi)))) sel_co_iterssss};
-
-val transfer_fp_sugar =
-  morph_fp_sugar o Morphism.transfer_morphism o Proof_Context.theory_of;
-
-structure Data = Generic_Data
-(
-  type T = fp_sugar Symtab.table;
-  val empty = Symtab.empty;
-  val extend = I;
-  val merge = Symtab.merge eq_fp_sugar;
-);
-
-fun fp_sugar_of ctxt =
-  Symtab.lookup (Data.get (Context.Proof ctxt))
-  #> Option.map (transfer_fp_sugar ctxt);
-
-fun fp_sugars_of ctxt =
-  Symtab.fold (cons o transfer_fp_sugar ctxt o snd) (Data.get (Context.Proof ctxt)) [];
-
-fun co_induct_of (i :: _) = i;
-fun strong_co_induct_of [_, s] = s;
-
-(* TODO: register "sum" and "prod" as datatypes to enable N2M reduction for them *)
-
-fun register_fp_sugar key fp_sugar =
-  Local_Theory.declaration {syntax = false, pervasive = true}
-    (fn phi => Data.map (Symtab.default (key, morph_fp_sugar phi fp_sugar)));
-
-fun register_fp_sugars fp pre_bnfs nested_bnfs nesting_bnfs (fp_res as {Ts, ...}) ctr_defss
-    ctr_sugars co_iterss mapss co_inducts co_iter_thmsss disc_co_itersss sel_co_iterssss lthy =
-  (0, lthy)
-  |> fold (fn T as Type (s, _) => fn (kk, lthy) => (kk + 1,
-    register_fp_sugar s {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs,
-        nested_bnfs = nested_bnfs, nesting_bnfs = nesting_bnfs, fp_res = fp_res,
-        ctr_defss = ctr_defss, ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss,
-        co_inducts = co_inducts, co_iter_thmsss = co_iter_thmsss, disc_co_itersss = disc_co_itersss,
-        sel_co_iterssss = sel_co_iterssss}
-      lthy)) Ts
-  |> snd;
-
-(* This function could produce clashes in contrived examples (e.g., "x.A", "x.x_A", "y.A"). *)
-fun quasi_unambiguous_case_names names =
-  let
-    val ps = map (`Long_Name.base_name) names;
-    val dups = Library.duplicates (op =) (map fst ps);
-    fun underscore s =
-      let val ss = space_explode Long_Name.separator s in
-        space_implode "_" (drop (length ss - 2) ss)
-      end;
-  in
-    map (fn (base, full) => if member (op =) dups base then underscore full else base) ps
-  end;
-
-val id_def = @{thm id_def};
-val mp_conj = @{thm mp_conj};
-
-val nitpicksimp_attrs = @{attributes [nitpick_simp]};
-val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
-val simp_attrs = @{attributes [simp]};
-
-fun tvar_subst thy Ts Us =
-  Vartab.fold (cons o apsnd snd) (fold (Sign.typ_match thy) (Ts ~~ Us) Vartab.empty) [];
-
-val exists_subtype_in = Term.exists_subtype o member (op =);
-
-val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs));
-
-fun flat_rec_arg_args xss =
-  (* FIXME (once the old datatype package is phased out): The first line below gives the preferred
-     order. The second line is for compatibility with the old datatype package. *)
-(*
-  flat xss
-*)
-  map hd xss @ maps tl xss;
-
-fun flat_corec_predss_getterss qss fss = maps (op @) (qss ~~ fss);
-
-fun flat_corec_preds_predsss_gettersss [] [qss] [fss] = flat_corec_predss_getterss qss fss
-  | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
-    p :: flat_corec_predss_getterss qss fss @ flat_corec_preds_predsss_gettersss ps qsss fsss;
-
-fun mk_tupled_fun x f xs =
-  if xs = [x] then f else HOLogic.tupled_lambda x (Term.list_comb (f, xs));
-
-fun mk_uncurried2_fun f xss =
-  mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat_rec_arg_args xss);
-
-fun mk_flip (x, Type (_, [T1, Type (_, [T2, T3])])) =
-  Abs ("x", T1, Abs ("y", T2, Var (x, T2 --> T1 --> T3) $ Bound 0 $ Bound 1));
-
-fun flip_rels lthy n thm =
-  let
-    val Rs = Term.add_vars (prop_of thm) [];
-    val Rs' = rev (drop (length Rs - n) Rs);
-    val cRs = map (fn f => (certify lthy (Var f), certify lthy (mk_flip f))) Rs';
-  in
-    Drule.cterm_instantiate cRs thm
-  end;
-
-fun mk_ctor_or_dtor get_T Ts t =
-  let val Type (_, Ts0) = get_T (fastype_of t) in
-    Term.subst_atomic_types (Ts0 ~~ Ts) t
-  end;
-
-val mk_ctor = mk_ctor_or_dtor range_type;
-val mk_dtor = mk_ctor_or_dtor domain_type;
-
-fun mk_co_iter thy fp fpT Cs t =
-  let
-    val (f_Cs, Type (_, [prebody, body])) = strip_fun_type (fastype_of t);
-    val fpT0 = fp_case fp prebody body;
-    val Cs0 = distinct (op =) (map (fp_case fp body_type domain_type) f_Cs);
-    val rho = tvar_subst thy (fpT0 :: Cs0) (fpT :: Cs);
-  in
-    Term.subst_TVars rho t
-  end;
-
-fun mk_co_iters thy fp fpTs Cs ts0 =
-  let
-    val nn = length fpTs;
-    val (fpTs0, Cs0) =
-      map ((fp = Greatest_FP ? swap) o dest_funT o snd o strip_typeN nn o fastype_of) ts0
-      |> split_list;
-    val rho = tvar_subst thy (fpTs0 @ Cs0) (fpTs @ Cs);
-  in
-    map (Term.subst_TVars rho) ts0
-  end;
-
-val mk_fp_iter_fun_types = binder_fun_types o fastype_of;
-
-fun unzip_recT (Type (@{type_name prod}, _)) T = [T]
-  | unzip_recT _ (Type (@{type_name prod}, Ts)) = Ts
-  | unzip_recT _ T = [T];
-
-fun unzip_corecT (Type (@{type_name sum}, _)) T = [T]
-  | unzip_corecT _ (Type (@{type_name sum}, Ts)) = Ts
-  | unzip_corecT _ T = [T];
-
-fun liveness_of_fp_bnf n bnf =
-  (case T_of_bnf bnf of
-    Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts
-  | _ => replicate n false);
-
-fun cannot_merge_types () = error "Mutually recursive types must have the same type parameters";
-
-fun merge_type_arg T T' = if T = T' then T else cannot_merge_types ();
-
-fun merge_type_args (As, As') =
-  if length As = length As' then map2 merge_type_arg As As' else cannot_merge_types ();
-
-fun reassoc_conjs thm =
-  reassoc_conjs (thm RS @{thm conj_assoc[THEN iffD1]})
-  handle THM _ => thm;
-
-fun type_args_named_constrained_of ((((ncAs, _), _), _), _) = ncAs;
-fun type_binding_of ((((_, b), _), _), _) = b;
-fun map_binding_of (((_, (b, _)), _), _) = b;
-fun rel_binding_of (((_, (_, b)), _), _) = b;
-fun mixfix_of ((_, mx), _) = mx;
-fun ctr_specs_of (_, ctr_specs) = ctr_specs;
-
-fun disc_of ((((disc, _), _), _), _) = disc;
-fun ctr_of ((((_, ctr), _), _), _) = ctr;
-fun args_of (((_, args), _), _) = args;
-fun defaults_of ((_, ds), _) = ds;
-fun ctr_mixfix_of (_, mx) = mx;
-
-fun add_nesty_bnf_names Us =
-  let
-    fun add (Type (s, Ts)) ss =
-        let val (needs, ss') = fold_map add Ts ss in
-          if exists I needs then (true, insert (op =) s ss') else (false, ss')
-        end
-      | add T ss = (member (op =) Us T, ss);
-  in snd oo add end;
-
-fun nesty_bnfs ctxt ctr_Tsss Us =
-  map_filter (bnf_of ctxt) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_Tsss []);
-
-fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p;
-
-type lfp_sugar_thms =
-  (thm list * thm * Args.src list)
-  * (thm list list * thm list list * Args.src list)
-
-fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (foldss, recss, iter_attrs)) =
-  ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs),
-   (map (map (Morphism.thm phi)) foldss, map (map (Morphism.thm phi)) recss, iter_attrs));
-
-val transfer_lfp_sugar_thms =
-  morph_lfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of;
-
-type gfp_sugar_thms =
-  ((thm list * thm) list * Args.src list)
-  * (thm list list * thm list list * Args.src list)
-  * (thm list list * thm list list * Args.src list)
-  * (thm list list * thm list list * Args.src list)
-  * (thm list list list * thm list list list * Args.src list);
-
-fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs),
-    (unfoldss, corecss, coiter_attrs), (disc_unfoldss, disc_corecss, disc_iter_attrs),
-    (disc_unfold_iffss, disc_corec_iffss, disc_iter_iff_attrs),
-    (sel_unfoldsss, sel_corecsss, sel_iter_attrs)) =
-  ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs,
-    coinduct_attrs),
-   (map (map (Morphism.thm phi)) unfoldss, map (map (Morphism.thm phi)) corecss, coiter_attrs),
-   (map (map (Morphism.thm phi)) disc_unfoldss, map (map (Morphism.thm phi)) disc_corecss,
-    disc_iter_attrs),
-   (map (map (Morphism.thm phi)) disc_unfold_iffss, map (map (Morphism.thm phi)) disc_corec_iffss,
-    disc_iter_iff_attrs),
-   (map (map (map (Morphism.thm phi))) sel_unfoldsss,
-    map (map (map (Morphism.thm phi))) sel_corecsss, sel_iter_attrs));
-
-val transfer_gfp_sugar_thms =
-  morph_gfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of;
-
-fun mk_iter_fun_arg_types0 n ms = map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type;
-
-fun mk_iter_fun_arg_types ctr_Tsss ns mss =
-  mk_fp_iter_fun_types
-  #> map3 mk_iter_fun_arg_types0 ns mss
-  #> map2 (map2 (map2 unzip_recT)) ctr_Tsss;
-
-fun mk_iters_args_types ctr_Tsss Cs ns mss ctor_iter_fun_Tss lthy =
-  let
-    val Css = map2 replicate ns Cs;
-    val y_Tsss = map3 mk_iter_fun_arg_types0 ns mss (map un_fold_of ctor_iter_fun_Tss);
-    val g_Tss = map2 (fn C => map (fn y_Ts => y_Ts ---> C)) Cs y_Tsss;
-
-    val ((gss, ysss), lthy) =
-      lthy
-      |> mk_Freess "f" g_Tss
-      ||>> mk_Freesss "x" y_Tsss;
-
-    val y_Tssss = map (map (map single)) y_Tsss;
-    val yssss = map (map (map single)) ysss;
-
-    val z_Tssss =
-      map4 (fn n => fn ms => fn ctr_Tss => fn ctor_iter_fun_Ts =>
-          map3 (fn m => fn ctr_Ts => fn ctor_iter_fun_T =>
-              map2 unzip_recT ctr_Ts (dest_tupleT m ctor_iter_fun_T))
-            ms ctr_Tss (dest_sumTN_balanced n (domain_type (co_rec_of ctor_iter_fun_Ts))))
-        ns mss ctr_Tsss ctor_iter_fun_Tss;
-
-    val z_Tsss' = map (map flat_rec_arg_args) z_Tssss;
-    val h_Tss = map2 (map2 (curry (op --->))) z_Tsss' Css;
-
-    val hss = map2 (map2 retype_free) h_Tss gss;
-    val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
-    val (zssss_tl, lthy) =
-      lthy
-      |> mk_Freessss "y" (map (map (map tl)) z_Tssss);
-    val zssss = map2 (map2 (map2 cons)) zssss_hd zssss_tl;
-  in
-    ([(g_Tss, y_Tssss, gss, yssss), (h_Tss, z_Tssss, hss, zssss)], lthy)
-  end;
-
-fun mk_coiter_fun_arg_types0 ctr_Tsss Cs ns fun_Ts =
-  let
-    (*avoid "'a itself" arguments in coiterators*)
-    fun repair_arity [[]] = [[@{typ unit}]]
-      | repair_arity Tss = Tss;
-
-    val ctr_Tsss' = map repair_arity ctr_Tsss;
-    val f_sum_prod_Ts = map range_type fun_Ts;
-    val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
-    val f_Tsss = map2 (map2 (dest_tupleT o length)) ctr_Tsss' f_prod_Tss;
-    val f_Tssss = map3 (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT)))
-      Cs ctr_Tsss' f_Tsss;
-    val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) f_Tssss;
-  in
-    (q_Tssss, f_Tsss, f_Tssss, f_sum_prod_Ts)
-  end;
-
-fun mk_coiter_p_pred_types Cs ns = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs;
-
-fun mk_coiter_fun_arg_types ctr_Tsss Cs ns dtor_coiter =
-  (mk_coiter_p_pred_types Cs ns,
-   mk_fp_iter_fun_types dtor_coiter |> mk_coiter_fun_arg_types0 ctr_Tsss Cs ns);
-
-fun mk_coiters_args_types ctr_Tsss Cs ns dtor_coiter_fun_Tss lthy =
-  let
-    val p_Tss = mk_coiter_p_pred_types Cs ns;
-
-    fun mk_types get_Ts =
-      let
-        val fun_Ts = map get_Ts dtor_coiter_fun_Tss;
-        val (q_Tssss, f_Tsss, f_Tssss, f_sum_prod_Ts) = mk_coiter_fun_arg_types0 ctr_Tsss Cs ns fun_Ts;
-        val pf_Tss = map3 flat_corec_preds_predsss_gettersss p_Tss q_Tssss f_Tssss;
-      in
-        (q_Tssss, f_Tsss, f_Tssss, (f_sum_prod_Ts, pf_Tss))
-      end;
-
-    val (r_Tssss, g_Tsss, g_Tssss, unfold_types) = mk_types un_fold_of;
-    val (s_Tssss, h_Tsss, h_Tssss, corec_types) = mk_types co_rec_of;
-
-    val ((((Free (z, _), cs), pss), gssss), lthy) =
-      lthy
-      |> yield_singleton (mk_Frees "z") dummyT
-      ||>> mk_Frees "a" Cs
-      ||>> mk_Freess "p" p_Tss
-      ||>> mk_Freessss "g" g_Tssss;
-    val rssss = map (map (map (fn [] => []))) r_Tssss;
-
-    val hssss_hd = map2 (map2 (map2 (fn T :: _ => fn [g] => retype_free T g))) h_Tssss gssss;
-    val ((sssss, hssss_tl), lthy) =
-      lthy
-      |> mk_Freessss "q" s_Tssss
-      ||>> mk_Freessss "h" (map (map (map tl)) h_Tssss);
-    val hssss = map2 (map2 (map2 cons)) hssss_hd hssss_tl;
-
-    val cpss = map2 (map o rapp) cs pss;
-
-    fun build_sum_inj mk_inj = build_map lthy (uncurry mk_inj o dest_sumT o snd);
-
-    fun build_dtor_coiter_arg _ [] [cf] = cf
-      | build_dtor_coiter_arg T [cq] [cf, cf'] =
-        mk_If cq (build_sum_inj Inl_const (fastype_of cf, T) $ cf)
-          (build_sum_inj Inr_const (fastype_of cf', T) $ cf');
-
-    fun mk_args qssss fssss f_Tsss =
-      let
-        val pfss = map3 flat_corec_preds_predsss_gettersss pss qssss fssss;
-        val cqssss = map2 (map o map o map o rapp) cs qssss;
-        val cfssss = map2 (map o map o map o rapp) cs fssss;
-        val cqfsss = map3 (map3 (map3 build_dtor_coiter_arg)) f_Tsss cqssss cfssss;
-      in (pfss, cqfsss) end;
-
-    val unfold_args = mk_args rssss gssss g_Tsss;
-    val corec_args = mk_args sssss hssss h_Tsss;
-  in
-    ((z, cs, cpss, [(unfold_args, unfold_types), (corec_args, corec_types)]), lthy)
-  end;
-
-fun mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy =
-  let
-    val thy = Proof_Context.theory_of lthy;
-
-    val (xtor_co_iter_fun_Tss, xtor_co_iterss) =
-      map (mk_co_iters thy fp fpTs Cs #> `(mk_fp_iter_fun_types o hd)) (transpose xtor_co_iterss0)
-      |> apsnd transpose o apfst transpose o split_list;
-
-    val ((iters_args_types, coiters_args_types), lthy') =
-      if fp = Least_FP then
-        mk_iters_args_types ctr_Tsss Cs ns mss xtor_co_iter_fun_Tss lthy |>> (rpair NONE o SOME)
-      else
-        mk_coiters_args_types ctr_Tsss Cs ns xtor_co_iter_fun_Tss lthy |>> (pair NONE o SOME)
-  in
-    ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy')
-  end;
-
-fun mk_preds_getterss_join c cps sum_prod_T cqfss =
-  let val n = length cqfss in
-    Term.lambda c (mk_IfN sum_prod_T cps
-      (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)))
-  end;
-
-fun define_co_iters fp fpT Cs binding_specs lthy0 =
-  let
-    val thy = Proof_Context.theory_of lthy0;
-
-    val maybe_conceal_def_binding = Thm.def_binding
-      #> Config.get lthy0 bnf_note_all = false ? Binding.conceal;
-
-    val ((csts, defs), (lthy', lthy)) = lthy0
-      |> apfst split_list o fold_map (fn (b, rhs) =>
-        Local_Theory.define ((b, NoSyn), ((maybe_conceal_def_binding b, []), rhs))
-        #>> apsnd snd) binding_specs
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy lthy';
-
-    val csts' = map (mk_co_iter thy fp fpT Cs o Morphism.term phi) csts;
-    val defs' = map (Morphism.thm phi) defs;
-  in
-    ((csts', defs'), lthy')
-  end;
-
-fun define_iters iterNs iter_args_typess' mk_binding fpTs Cs ctor_iters lthy =
-  let
-    val nn = length fpTs;
-
-    val fpT_to_C as Type (_, [fpT, _]) = snd (strip_typeN nn (fastype_of (hd ctor_iters)));
-
-    fun generate_iter pre (_, _, fss, xssss) ctor_iter =
-      (mk_binding pre,
-       fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_iter,
-         map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss)));
-  in
-    define_co_iters Least_FP fpT Cs (map3 generate_iter iterNs iter_args_typess' ctor_iters) lthy
-  end;
-
-fun define_coiters coiterNs (_, cs, cpss, coiter_args_typess') mk_binding fpTs Cs dtor_coiters
-    lthy =
-  let
-    val nn = length fpTs;
-
-    val C_to_fpT as Type (_, [_, fpT]) = snd (strip_typeN nn (fastype_of (hd dtor_coiters)));
-
-    fun generate_coiter pre ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
-      (mk_binding pre,
-       fold_rev (fold_rev Term.lambda) pfss (Term.list_comb (dtor_coiter,
-         map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss)));
-  in
-    define_co_iters Greatest_FP fpT Cs
-      (map3 generate_coiter coiterNs coiter_args_typess' dtor_coiters) lthy
-  end;
-
-fun derive_induct_iters_thms_for_types pre_bnfs [fold_args_types, rec_args_types] ctor_induct
-    ctor_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss iterss iter_defss
-    lthy =
-  let
-    val iterss' = transpose iterss;
-    val iter_defss' = transpose iter_defss;
-
-    val [folds, recs] = iterss';
-    val [fold_defs, rec_defs] = iter_defss';
-
-    val ctr_Tsss = map (map (binder_types o fastype_of)) ctrss;
-
-    val nn = length pre_bnfs;
-    val ns = map length ctr_Tsss;
-    val mss = map (map length) ctr_Tsss;
-
-    val pre_map_defs = map map_def_of_bnf pre_bnfs;
-    val pre_set_defss = map set_defs_of_bnf pre_bnfs;
-    val nesting_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nesting_bnfs;
-    val nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs;
-    val nested_set_maps = maps set_map_of_bnf nested_bnfs;
-
-    val fp_b_names = map base_name_of_typ fpTs;
-
-    val ((((ps, ps'), xsss), us'), names_lthy) =
-      lthy
-      |> mk_Frees' "P" (map mk_pred1T fpTs)
-      ||>> mk_Freesss "x" ctr_Tsss
-      ||>> Variable.variant_fixes fp_b_names;
-
-    val us = map2 (curry Free) us' fpTs;
-
-    fun mk_sets_nested bnf =
-      let
-        val Type (T_name, Us) = T_of_bnf bnf;
-        val lives = lives_of_bnf bnf;
-        val sets = sets_of_bnf bnf;
-        fun mk_set U =
-          (case find_index (curry (op =) U) lives of
-            ~1 => Term.dummy
-          | i => nth sets i);
-      in
-        (T_name, map mk_set Us)
-      end;
-
-    val setss_nested = map mk_sets_nested nested_bnfs;
-
-    val (induct_thms, induct_thm) =
-      let
-        fun mk_set Ts t =
-          let val Type (_, Ts0) = domain_type (fastype_of t) in
-            Term.subst_atomic_types (Ts0 ~~ Ts) t
-          end;
-
-        fun mk_raw_prem_prems _ (x as Free (_, Type _)) (X as TFree _) =
-            [([], (find_index (curry (op =) X) Xs + 1, x))]
-          | mk_raw_prem_prems names_lthy (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) =
-            (case AList.lookup (op =) setss_nested T_name of
-              NONE => []
-            | SOME raw_sets0 =>
-              let
-                val (Xs_Ts, (Ts, raw_sets)) =
-                  filter (exists_subtype_in Xs o fst) (Xs_Ts0 ~~ (Ts0 ~~ raw_sets0))
-                  |> split_list ||> split_list;
-                val sets = map (mk_set Ts0) raw_sets;
-                val (ys, names_lthy') = names_lthy |> mk_Frees s Ts;
-                val xysets = map (pair x) (ys ~~ sets);
-                val ppremss = map2 (mk_raw_prem_prems names_lthy') ys Xs_Ts;
-              in
-                flat (map2 (map o apfst o cons) xysets ppremss)
-              end)
-          | mk_raw_prem_prems _ _ _ = [];
-
-        fun close_prem_prem xs t =
-          fold_rev Logic.all (map Free (drop (nn + length xs)
-            (rev (Term.add_frees t (map dest_Free xs @ ps'))))) t;
-
-        fun mk_prem_prem xs (xysets, (j, x)) =
-          close_prem_prem xs (Logic.list_implies (map (fn (x', (y, set)) =>
-              HOLogic.mk_Trueprop (HOLogic.mk_mem (y, set $ x'))) xysets,
-            HOLogic.mk_Trueprop (nth ps (j - 1) $ x)));
-
-        fun mk_raw_prem phi ctr ctr_Ts ctrXs_Ts =
-          let
-            val (xs, names_lthy') = names_lthy |> mk_Frees "x" ctr_Ts;
-            val pprems = flat (map2 (mk_raw_prem_prems names_lthy') xs ctrXs_Ts);
-          in (xs, pprems, HOLogic.mk_Trueprop (phi $ Term.list_comb (ctr, xs))) end;
-
-        fun mk_prem (xs, raw_pprems, concl) =
-          fold_rev Logic.all xs (Logic.list_implies (map (mk_prem_prem xs) raw_pprems, concl));
-
-        val raw_premss = map4 (map3 o mk_raw_prem) ps ctrss ctr_Tsss ctrXs_Tsss;
-
-        val goal =
-          Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
-            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)));
-
-        val kksss = map (map (map (fst o snd) o #2)) raw_premss;
-
-        val ctor_induct' = ctor_induct OF (map mk_sumEN_tupled_balanced mss);
-
-        val thm =
-          Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
-            mk_induct_tac ctxt nn ns mss kksss (flat ctr_defss) ctor_induct' nested_set_maps
-              pre_set_defss)
-          |> singleton (Proof_Context.export names_lthy lthy)
-          |> Thm.close_derivation;
-      in
-        `(conj_dests nn) thm
-      end;
-
-    val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss);
-    val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases));
-
-    val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss;
-
-    fun mk_iter_thmss (_, x_Tssss, fss, _) iters iter_defs ctor_iter_thms =
-      let
-        val fiters = map (lists_bmoc fss) iters;
-
-        fun mk_goal fss fiter xctr f xs fxs =
-          fold_rev (fold_rev Logic.all) (xs :: fss)
-            (mk_Trueprop_eq (fiter $ xctr, Term.list_comb (f, fxs)));
-
-        fun maybe_tick (T, U) u f =
-          if try (fst o HOLogic.dest_prodT) U = SOME T then
-            Term.lambda u (HOLogic.mk_prod (u, f $ u))
-          else
-            f;
-
-        fun build_iter (x as Free (_, T)) U =
-          if T = U then
-            x
-          else
-            build_map lthy (indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs
-              (fn kk => fn TU => maybe_tick TU (nth us kk) (nth fiters kk))) (T, U) $ x;
-
-        val fxsss = map2 (map2 (flat_rec_arg_args oo map2 (map o build_iter))) xsss x_Tssss;
-
-        val goalss = map5 (map4 o mk_goal fss) fiters xctrss fss xsss fxsss;
-
-        val tacss =
-          map2 (map o mk_iter_tac pre_map_defs (nested_map_idents @ nesting_map_idents) iter_defs)
-            ctor_iter_thms ctr_defss;
-
-        fun prove goal tac =
-          Goal.prove_sorry lthy [] [] goal (tac o #context)
-          |> Thm.close_derivation;
-      in
-        map2 (map2 prove) goalss tacss
-      end;
-
-    val fold_thmss = mk_iter_thmss fold_args_types folds fold_defs (map un_fold_of ctor_iter_thmss);
-    val rec_thmss = mk_iter_thmss rec_args_types recs rec_defs (map co_rec_of ctor_iter_thmss);
-  in
-    ((induct_thms, induct_thm, [induct_case_names_attr]),
-     (fold_thmss, rec_thmss, code_nitpicksimp_attrs @ simp_attrs))
-  end;
-
-fun derive_coinduct_coiters_thms_for_types pre_bnfs (z, cs, cpss,
-      coiters_args_types as [((pgss, crgsss), _), ((phss, cshsss), _)])
-    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss
-    mss ns ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
-  let
-    fun mk_ctor_dtor_coiter_thm dtor_inject dtor_ctor coiter =
-      iffD1 OF [dtor_inject, trans OF [coiter, dtor_ctor RS sym]];
-
-    val ctor_dtor_coiter_thmss =
-      map3 (map oo mk_ctor_dtor_coiter_thm) dtor_injects dtor_ctors dtor_coiter_thmss;
-
-    val coiterss' = transpose coiterss;
-    val coiter_defss' = transpose coiter_defss;
-
-    val [unfold_defs, corec_defs] = coiter_defss';
-
-    val nn = length pre_bnfs;
-
-    val pre_map_defs = map map_def_of_bnf pre_bnfs;
-    val pre_rel_defs = map rel_def_of_bnf pre_bnfs;
-    val nesting_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nesting_bnfs;
-    val nesting_rel_eqs = map rel_eq_of_bnf nesting_bnfs;
-
-    val fp_b_names = map base_name_of_typ fpTs;
-
-    val ctrss = map #ctrs ctr_sugars;
-    val discss = map #discs ctr_sugars;
-    val selsss = map #selss ctr_sugars;
-    val exhausts = map #exhaust ctr_sugars;
-    val disc_thmsss = map #disc_thmss ctr_sugars;
-    val discIss = map #discIs ctr_sugars;
-    val sel_thmsss = map #sel_thmss ctr_sugars;
-
-    val (((rs, us'), vs'), names_lthy) =
-      lthy
-      |> mk_Frees "R" (map (fn T => mk_pred2T T T) fpTs)
-      ||>> Variable.variant_fixes fp_b_names
-      ||>> Variable.variant_fixes (map (suffix "'") fp_b_names);
-
-    val us = map2 (curry Free) us' fpTs;
-    val udiscss = map2 (map o rapp) us discss;
-    val uselsss = map2 (map o map o rapp) us selsss;
-
-    val vs = map2 (curry Free) vs' fpTs;
-    val vdiscss = map2 (map o rapp) vs discss;
-    val vselsss = map2 (map o map o rapp) vs selsss;
-
-    val coinduct_thms_pairs =
-      let
-        val uvrs = map3 (fn r => fn u => fn v => r $ u $ v) rs us vs;
-        val uv_eqs = map2 (curry HOLogic.mk_eq) us vs;
-        val strong_rs =
-          map4 (fn u => fn v => fn uvr => fn uv_eq =>
-            fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs;
-
-        fun build_the_rel rs' T Xs_T =
-          build_rel lthy (fn (_, X) => nth rs' (find_index (curry (op =) X) Xs)) (T, Xs_T)
-          |> Term.subst_atomic_types (Xs ~~ fpTs);
-
-        fun build_rel_app rs' usel vsel Xs_T =
-          fold rapp [usel, vsel] (build_the_rel rs' (fastype_of usel) Xs_T);
-
-        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels ctrXs_Ts =
-          (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @
-          (if null usels then
-             []
-           else
-             [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc],
-                Library.foldr1 HOLogic.mk_conj (map3 (build_rel_app rs') usels vsels ctrXs_Ts))]);
-
-        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss =
-          Library.foldr1 HOLogic.mk_conj (flat (map6 (mk_prem_ctr_concls rs' n)
-            (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss))
-          handle List.Empty => @{term True};
-
-        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss =
-          fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr,
-            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss)));
-
-        val concl =
-          HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
-            (map3 (fn uvr => fn u => fn v => HOLogic.mk_imp (uvr, HOLogic.mk_eq (u, v)))
-               uvrs us vs));
-
-        fun mk_goal rs' =
-          Logic.list_implies (map9 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss
-            ctrXs_Tsss, concl);
-
-        val goals = map mk_goal [rs, strong_rs];
-
-        fun prove dtor_coinduct' goal =
-          Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
-            mk_coinduct_tac ctxt nesting_rel_eqs nn ns dtor_coinduct' pre_rel_defs dtor_ctors
-              exhausts ctr_defss disc_thmsss sel_thmsss)
-          |> singleton (Proof_Context.export names_lthy lthy)
-          |> Thm.close_derivation;
-
-        fun postproc nn thm =
-          Thm.permute_prems 0 nn
-            (if nn = 1 then thm RS mp else funpow nn (fn thm => reassoc_conjs (thm RS mp_conj)) thm)
-          |> Drule.zero_var_indexes
-          |> `(conj_dests nn);
-
-        val rel_eqs = map rel_eq_of_bnf pre_bnfs;
-        val rel_monos = map rel_mono_of_bnf pre_bnfs;
-        val dtor_coinducts =
-          [dtor_coinduct, mk_strong_coinduct_thm dtor_coinduct rel_eqs rel_monos lthy];
-      in
-        map2 (postproc nn oo prove) dtor_coinducts goals
-      end;
-
-    fun mk_coinduct_concls ms discs ctrs =
-      let
-        fun mk_disc_concl disc = [name_of_disc disc];
-        fun mk_ctr_concl 0 _ = []
-          | mk_ctr_concl _ ctor = [name_of_ctr ctor];
-        val disc_concls = map mk_disc_concl (fst (split_last discs)) @ [[]];
-        val ctr_concls = map2 mk_ctr_concl ms ctrs;
-      in
-        flat (map2 append disc_concls ctr_concls)
-      end;
-
-    val coinduct_cases = quasi_unambiguous_case_names (map (prefix EqN) fp_b_names);
-    val coinduct_conclss =
-      map3 (quasi_unambiguous_case_names ooo mk_coinduct_concls) mss discss ctrss;
-
-    fun mk_maybe_not pos = not pos ? HOLogic.mk_not;
-
-    val fcoiterss' as [gunfolds, hcorecs] =
-      map2 (fn (pfss, _) => map (lists_bmoc pfss)) (map fst coiters_args_types) coiterss';
-
-    val (unfold_thmss, corec_thmss) =
-      let
-        fun mk_goal pfss c cps fcoiter n k ctr m cfs' =
-          fold_rev (fold_rev Logic.all) ([c] :: pfss)
-            (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps,
-               mk_Trueprop_eq (fcoiter $ c, Term.list_comb (ctr, take m cfs'))));
-
-        fun mk_U maybe_mk_sumT =
-          typ_subst_nonatomic (map2 (fn C => fn fpT => (maybe_mk_sumT fpT C, fpT)) Cs fpTs);
-
-        fun tack z_name (c, u) f =
-          let val z = Free (z_name, mk_sumT (fastype_of u, fastype_of c)) in
-            Term.lambda z (mk_sum_case (Term.lambda u u, Term.lambda c (f $ c)) $ z)
-          end;
-
-        fun build_coiter fcoiters maybe_mk_sumT maybe_tack cqf =
-          let val T = fastype_of cqf in
-            if exists_subtype_in Cs T then
-              let val U = mk_U maybe_mk_sumT T in
-                build_map lthy (indexify snd fpTs (fn kk => fn _ =>
-                  maybe_tack (nth cs kk, nth us kk) (nth fcoiters kk))) (T, U) $ cqf
-              end
-            else
-              cqf
-          end;
-
-        val crgsss' = map (map (map (build_coiter (un_fold_of fcoiterss') (K I) (K I)))) crgsss;
-        val cshsss' = map (map (map (build_coiter (co_rec_of fcoiterss') (curry mk_sumT) (tack z))))
-          cshsss;
-
-        val unfold_goalss = map8 (map4 oooo mk_goal pgss) cs cpss gunfolds ns kss ctrss mss crgsss';
-        val corec_goalss = map8 (map4 oooo mk_goal phss) cs cpss hcorecs ns kss ctrss mss cshsss';
-
-        val unfold_tacss =
-          map3 (map oo mk_coiter_tac unfold_defs nesting_map_idents)
-            (map un_fold_of ctor_dtor_coiter_thmss) pre_map_defs ctr_defss;
-        val corec_tacss =
-          map3 (map oo mk_coiter_tac corec_defs nesting_map_idents)
-            (map co_rec_of ctor_dtor_coiter_thmss) pre_map_defs ctr_defss;
-
-        fun prove goal tac =
-          Goal.prove_sorry lthy [] [] goal (tac o #context)
-          |> Thm.close_derivation;
-
-        val unfold_thmss = map2 (map2 prove) unfold_goalss unfold_tacss;
-        val corec_thmss =
-          map2 (map2 prove) corec_goalss corec_tacss
-          |> map (map (unfold_thms lthy @{thms sum_case_if}));
-      in
-        (unfold_thmss, corec_thmss)
-      end;
-
-    val (disc_unfold_iff_thmss, disc_corec_iff_thmss) =
-      let
-        fun mk_goal c cps fcoiter n k disc =
-          mk_Trueprop_eq (disc $ (fcoiter $ c),
-            if n = 1 then @{const True}
-            else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps));
-
-        val unfold_goalss = map6 (map2 oooo mk_goal) cs cpss gunfolds ns kss discss;
-        val corec_goalss = map6 (map2 oooo mk_goal) cs cpss hcorecs ns kss discss;
-
-        fun mk_case_split' cp = Drule.instantiate' [] [SOME (certify lthy cp)] @{thm case_split};
-
-        val case_splitss' = map (map mk_case_split') cpss;
-
-        val unfold_tacss =
-          map3 (map oo mk_disc_coiter_iff_tac) case_splitss' unfold_thmss disc_thmsss;
-        val corec_tacss =
-          map3 (map oo mk_disc_coiter_iff_tac) case_splitss' corec_thmss disc_thmsss;
-
-        fun prove goal tac =
-          Goal.prove_sorry lthy [] [] goal (tac o #context)
-          |> singleton export_args
-          |> singleton (Proof_Context.export names_lthy lthy)
-          |> Thm.close_derivation;
-
-        fun proves [_] [_] = []
-          | proves goals tacs = map2 prove goals tacs;
-      in
-        (map2 proves unfold_goalss unfold_tacss, map2 proves corec_goalss corec_tacss)
-      end;
-
-    fun mk_disc_coiter_thms coiters discIs = map (op RS) (coiters ~~ discIs);
-
-    val disc_unfold_thmss = map2 mk_disc_coiter_thms unfold_thmss discIss;
-    val disc_corec_thmss = map2 mk_disc_coiter_thms corec_thmss discIss;
-
-    fun mk_sel_coiter_thm coiter_thm sel sel_thm =
-      let
-        val (domT, ranT) = dest_funT (fastype_of sel);
-        val arg_cong' =
-          Drule.instantiate' (map (SOME o certifyT lthy) [domT, ranT])
-            [NONE, NONE, SOME (certify lthy sel)] arg_cong
-          |> Thm.varifyT_global;
-        val sel_thm' = sel_thm RSN (2, trans);
-      in
-        coiter_thm RS arg_cong' RS sel_thm'
-      end;
-
-    fun mk_sel_coiter_thms coiter_thmss =
-      map3 (map3 (map2 o mk_sel_coiter_thm)) coiter_thmss selsss sel_thmsss;
-
-    val sel_unfold_thmsss = mk_sel_coiter_thms unfold_thmss;
-    val sel_corec_thmsss = mk_sel_coiter_thms corec_thmss;
-
-    val coinduct_consumes_attr = Attrib.internal (K (Rule_Cases.consumes nn));
-    val coinduct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names coinduct_cases));
-    val coinduct_case_concl_attrs =
-      map2 (fn casex => fn concls =>
-          Attrib.internal (K (Rule_Cases.case_conclusion (casex, concls))))
-        coinduct_cases coinduct_conclss;
-    val coinduct_case_attrs =
-      coinduct_consumes_attr :: coinduct_case_names_attr :: coinduct_case_concl_attrs;
-  in
-    ((coinduct_thms_pairs, coinduct_case_attrs),
-     (unfold_thmss, corec_thmss, code_nitpicksimp_attrs),
-     (disc_unfold_thmss, disc_corec_thmss, []),
-     (disc_unfold_iff_thmss, disc_corec_iff_thmss, simp_attrs),
-     (sel_unfold_thmsss, sel_corec_thmsss, simp_attrs))
-  end;
-
-fun define_co_datatypes prepare_constraint prepare_typ prepare_term fp construct_fp
-    (wrap_opts as (no_discs_sels, (_, rep_compat)), specs) no_defs_lthy0 =
-  let
-    (* TODO: sanity checks on arguments *)
-
-    val _ = if fp = Greatest_FP andalso no_discs_sels then
-        error "Cannot define codatatypes without discriminators and selectors"
-      else
-        ();
-
-    fun qualify mandatory fp_b_name =
-      Binding.qualify mandatory fp_b_name o (rep_compat ? Binding.qualify false rep_compat_prefix);
-
-    val nn = length specs;
-    val fp_bs = map type_binding_of specs;
-    val fp_b_names = map Binding.name_of fp_bs;
-    val fp_common_name = mk_common_name fp_b_names;
-    val map_bs = map map_binding_of specs;
-    val rel_bs = map rel_binding_of specs;
-
-    fun prepare_type_arg (_, (ty, c)) =
-      let val TFree (s, _) = prepare_typ no_defs_lthy0 ty in
-        TFree (s, prepare_constraint no_defs_lthy0 c)
-      end;
-
-    val Ass0 = map (map prepare_type_arg o type_args_named_constrained_of) specs;
-    val unsorted_Ass0 = map (map (resort_tfree HOLogic.typeS)) Ass0;
-    val unsorted_As = Library.foldr1 merge_type_args unsorted_Ass0;
-    val num_As = length unsorted_As;
-    val set_bss = map (map fst o type_args_named_constrained_of) specs;
-
-    val (((Bs0, Cs), Xs), no_defs_lthy) =
-      no_defs_lthy0
-      |> fold (Variable.declare_typ o resort_tfree dummyS) unsorted_As
-      |> mk_TFrees num_As
-      ||>> mk_TFrees nn
-      ||>> variant_tfrees fp_b_names;
-
-    fun add_fake_type spec = Typedecl.basic_typedecl (type_binding_of spec, num_As, mixfix_of spec);
-
-    val (fake_T_names, fake_lthy) = fold_map add_fake_type specs no_defs_lthy0;
-
-    val qsoty = quote o Syntax.string_of_typ fake_lthy;
-
-    val _ = (case Library.duplicates (op =) unsorted_As of [] => ()
-      | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^
-          "datatype specification"));
-
-    val bad_args =
-      map (Logic.type_map (singleton (Variable.polymorphic no_defs_lthy0))) unsorted_As
-      |> filter_out Term.is_TVar;
-    val _ = null bad_args orelse
-      error ("Locally fixed type argument " ^ qsoty (hd bad_args) ^ " in " ^ co_prefix fp ^
-        "datatype specification");
-
-    val mixfixes = map mixfix_of specs;
-
-    val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => ()
-      | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
-
-    val ctr_specss = map ctr_specs_of specs;
-
-    val disc_bindingss = map (map disc_of) ctr_specss;
-    val ctr_bindingss =
-      map2 (fn fp_b_name => map (qualify false fp_b_name o ctr_of)) fp_b_names ctr_specss;
-    val ctr_argsss = map (map args_of) ctr_specss;
-    val ctr_mixfixess = map (map ctr_mixfix_of) ctr_specss;
-
-    val sel_bindingsss = map (map (map fst)) ctr_argsss;
-    val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss;
-    val raw_sel_defaultsss = map (map defaults_of) ctr_specss;
-
-    val (As :: _) :: fake_ctr_Tsss =
-      burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0);
-    val As' = map dest_TFree As;
-
-    val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss [];
-    val _ = (case subtract (op =) As' rhs_As' of [] => ()
-      | extras => error ("Extra type variables on right-hand side: " ^
-          commas (map (qsoty o TFree) extras)));
-
-    val fake_Ts = map (fn s => Type (s, As)) fake_T_names;
-
-    fun eq_fpT_check (T as Type (s, Ts)) (T' as Type (s', Ts')) =
-        s = s' andalso (Ts = Ts' orelse
-          error ("Wrong type arguments in " ^ co_prefix fp ^ "recursive type " ^ qsoty T ^
-            " (expected " ^ qsoty T' ^ ")"))
-      | eq_fpT_check _ _ = false;
-
-    fun freeze_fp (T as Type (s, Ts)) =
-        (case find_index (eq_fpT_check T) fake_Ts of
-          ~1 => Type (s, map freeze_fp Ts)
-        | kk => nth Xs kk)
-      | freeze_fp T = T;
-
-    val unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fake_Ts);
-
-    val ctrXs_Tsss = map (map (map freeze_fp)) fake_ctr_Tsss;
-    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
-
-    val fp_eqs =
-      map dest_TFree Xs ~~ map (Term.typ_subst_atomic (As ~~ unsorted_As)) ctrXs_sum_prod_Ts;
-
-    val rhsXs_As' = fold (fold (fold Term.add_tfreesT)) ctrXs_Tsss [];
-    val _ = (case subtract (op =) rhsXs_As' As' of [] => ()
-      | extras => List.app (fn extra => warning ("Unused type variable on right-hand side of " ^
-          co_prefix fp ^ "datatype definition: " ^ qsoty (TFree extra))) extras);
-
-    val (pre_bnfs, (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, ctors = ctors0, dtors = dtors0,
-           xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects,
-           dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms, xtor_co_iter_thmss, ...},
-           lthy)) =
-      fp_bnf (construct_fp mixfixes map_bs rel_bs set_bss) fp_bs (map dest_TFree unsorted_As) fp_eqs
-        no_defs_lthy0
-      handle BAD_DEAD (X, X_backdrop) =>
-        (case X_backdrop of
-          Type (bad_tc, _) =>
-          let
-            val fake_T = qsoty (unfreeze_fp X);
-            val fake_T_backdrop = qsoty (unfreeze_fp X_backdrop);
-            fun register_hint () =
-              "\nUse the " ^ quote (fst (fst @{command_spec "bnf"})) ^ " command to register " ^
-              quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \
-              \it";
-          in
-            if is_some (bnf_of no_defs_lthy bad_tc) orelse
-               is_some (fp_sugar_of no_defs_lthy bad_tc) then
-              error ("Inadmissible " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
-                " in type expression " ^ fake_T_backdrop)
-            else if is_some (Datatype_Data.get_info (Proof_Context.theory_of no_defs_lthy)
-                bad_tc) then
-              error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
-                " via the old-style datatype " ^ quote bad_tc ^ " in type expression " ^
-                fake_T_backdrop ^ register_hint ())
-            else
-              error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
-                " via type constructor " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^
-                register_hint ())
-          end);
-
-    val time = time lthy;
-    val timer = time (Timer.startRealTimer ());
-
-    val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
-    val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
-
-    val pre_map_defs = map map_def_of_bnf pre_bnfs;
-    val pre_set_defss = map set_defs_of_bnf pre_bnfs;
-    val pre_rel_defs = map rel_def_of_bnf pre_bnfs;
-    val nesting_set_maps = maps set_map_of_bnf nesting_bnfs;
-    val nested_set_maps = maps set_map_of_bnf nested_bnfs;
-
-    val live = live_of_bnf any_fp_bnf;
-    val _ =
-      if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs) then
-        warning "Map function and relator names ignored"
-      else
-        ();
-
-    val Bs =
-      map3 (fn alive => fn A as TFree (_, S) => fn B => if alive then resort_tfree S B else A)
-        (liveness_of_fp_bnf num_As any_fp_bnf) As Bs0;
-
-    val B_ify = Term.typ_subst_atomic (As ~~ Bs);
-
-    val ctors = map (mk_ctor As) ctors0;
-    val dtors = map (mk_dtor As) dtors0;
-
-    val fpTs = map (domain_type o fastype_of) dtors;
-
-    fun massage_simple_notes base =
-      filter_out (null o #2)
-      #> map (fn (thmN, thms, attrs) =>
-        ((qualify true base (Binding.name thmN), attrs), [(thms, [])]));
-
-    val massage_multi_notes =
-      maps (fn (thmN, thmss, attrs) =>
-        map3 (fn fp_b_name => fn Type (T_name, _) => fn thms =>
-            ((qualify true fp_b_name (Binding.name thmN), attrs T_name), [(thms, [])]))
-          fp_b_names fpTs thmss)
-      #> filter_out (null o fst o hd o snd);
-
-    val ctr_Tsss = map (map (map (Term.typ_subst_atomic (Xs ~~ fpTs)))) ctrXs_Tsss;
-    val ns = map length ctr_Tsss;
-    val kss = map (fn n => 1 upto n) ns;
-    val mss = map (map length) ctr_Tsss;
-
-    val ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy') =
-      mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
-
-    fun define_ctrs_dtrs_for_type (((((((((((((((((((((((fp_bnf, fp_b), fpT), ctor), dtor),
-            xtor_co_iters), ctor_dtor), dtor_ctor), ctor_inject), pre_map_def), pre_set_defs),
-          pre_rel_def), fp_map_thm), fp_set_thms), fp_rel_thm), n), ks), ms), ctr_bindings),
-        ctr_mixfixes), ctr_Tss), disc_bindings), sel_bindingss), raw_sel_defaultss) no_defs_lthy =
-      let
-        val fp_b_name = Binding.name_of fp_b;
-
-        val dtorT = domain_type (fastype_of ctor);
-        val ctr_prod_Ts = map HOLogic.mk_tupleT ctr_Tss;
-        val ctr_sum_prod_T = mk_sumTN_balanced ctr_prod_Ts;
-
-        val ((((w, xss), yss), u'), names_lthy) =
-          no_defs_lthy
-          |> yield_singleton (mk_Frees "w") dtorT
-          ||>> mk_Freess "x" ctr_Tss
-          ||>> mk_Freess "y" (map (map B_ify) ctr_Tss)
-          ||>> yield_singleton Variable.variant_fixes fp_b_name;
-
-        val u = Free (u', fpT);
-
-        val tuple_xs = map HOLogic.mk_tuple xss;
-        val tuple_ys = map HOLogic.mk_tuple yss;
-
-        val ctr_rhss =
-          map3 (fn k => fn xs => fn tuple_x => fold_rev Term.lambda xs (ctor $
-            mk_InN_balanced ctr_sum_prod_T n tuple_x k)) ks xss tuple_xs;
-
-        val maybe_conceal_def_binding = Thm.def_binding
-          #> Config.get no_defs_lthy bnf_note_all = false ? Binding.conceal;
-
-        val ((raw_ctrs, raw_ctr_defs), (lthy', lthy)) = no_defs_lthy
-          |> apfst split_list o fold_map3 (fn b => fn mx => fn rhs =>
-              Local_Theory.define ((b, mx), ((maybe_conceal_def_binding b, []), rhs)) #>> apsnd snd)
-            ctr_bindings ctr_mixfixes ctr_rhss
-          ||> `Local_Theory.restore;
-
-        val phi = Proof_Context.export_morphism lthy lthy';
-
-        val ctr_defs = map (Morphism.thm phi) raw_ctr_defs;
-        val ctr_defs' =
-          map2 (fn m => fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) ms ctr_defs;
-
-        val ctrs0 = map (Morphism.term phi) raw_ctrs;
-        val ctrs = map (mk_ctr As) ctrs0;
-
-        fun wrap_ctrs lthy =
-          let
-            fun exhaust_tac {context = ctxt, prems = _} =
-              let
-                val ctor_iff_dtor_thm =
-                  let
-                    val goal =
-                      fold_rev Logic.all [w, u]
-                        (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w)));
-                  in
-                    Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
-                      mk_ctor_iff_dtor_tac ctxt (map (SOME o certifyT lthy) [dtorT, fpT])
-                        (certify lthy ctor) (certify lthy dtor) ctor_dtor dtor_ctor)
-                    |> Thm.close_derivation
-                    |> Morphism.thm phi
-                  end;
-
-                val sumEN_thm' =
-                  unfold_thms lthy @{thms unit_all_eq1}
-                    (Drule.instantiate' (map (SOME o certifyT lthy) ctr_prod_Ts) []
-                       (mk_sumEN_balanced n))
-                  |> Morphism.thm phi;
-              in
-                mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'
-              end;
-
-            val inject_tacss =
-              map2 (fn 0 => K [] | _ => fn ctr_def => [fn {context = ctxt, ...} =>
-                mk_inject_tac ctxt ctr_def ctor_inject]) ms ctr_defs;
-
-            val half_distinct_tacss =
-              map (map (fn (def, def') => fn {context = ctxt, ...} =>
-                mk_half_distinct_tac ctxt ctor_inject [def, def'])) (mk_half_pairss (`I ctr_defs));
-
-            val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss;
-
-            val sel_defaultss = map (map (apsnd (prepare_term lthy))) raw_sel_defaultss
-          in
-            wrap_free_constructors tacss (((wrap_opts, ctrs0), standard_binding), (disc_bindings,
-              (sel_bindingss, sel_defaultss))) lthy
-          end;
-
-        fun derive_maps_sets_rels (ctr_sugar, lthy) =
-          if live = 0 then
-            ((([], [], [], []), ctr_sugar), lthy)
-          else
-            let
-              val rel_flip = rel_flip_of_bnf fp_bnf;
-              val nones = replicate live NONE;
-
-              val ctor_cong =
-                if fp = Least_FP then
-                  Drule.dummy_thm
-                else
-                  let val ctor' = mk_ctor Bs ctor in
-                    cterm_instantiate_pos [NONE, NONE, SOME (certify lthy ctor')] arg_cong
-                  end;
-
-              fun mk_cIn ify =
-                certify lthy o (fp = Greatest_FP ? curry (op $) (map_types ify ctor)) oo
-                mk_InN_balanced (ify ctr_sum_prod_T) n;
-
-              val cxIns = map2 (mk_cIn I) tuple_xs ks;
-              val cyIns = map2 (mk_cIn B_ify) tuple_ys ks;
-
-              fun mk_map_thm ctr_def' cxIn =
-                fold_thms lthy [ctr_def']
-                  (unfold_thms lthy (pre_map_def ::
-                       (if fp = Least_FP then [] else [ctor_dtor, dtor_ctor]) @ sum_prod_thms_map)
-                     (cterm_instantiate_pos (nones @ [SOME cxIn])
-                        (if fp = Least_FP then fp_map_thm else fp_map_thm RS ctor_cong)))
-                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
-
-              fun mk_set_thm fp_set_thm ctr_def' cxIn =
-                fold_thms lthy [ctr_def']
-                  (unfold_thms lthy (pre_set_defs @ nested_set_maps @ nesting_set_maps @
-                       (if fp = Least_FP then [] else [dtor_ctor]) @ sum_prod_thms_set)
-                     (cterm_instantiate_pos [SOME cxIn] fp_set_thm))
-                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
-
-              fun mk_set_thms fp_set_thm = map2 (mk_set_thm fp_set_thm) ctr_defs' cxIns;
-
-              val map_thms = map2 mk_map_thm ctr_defs' cxIns;
-              val set_thmss = map mk_set_thms fp_set_thms;
-
-              val rel_infos = (ctr_defs' ~~ cxIns, ctr_defs' ~~ cyIns);
-
-              fun mk_rel_thm postproc ctr_defs' cxIn cyIn =
-                fold_thms lthy ctr_defs'
-                  (unfold_thms lthy (@{thm Inl_Inr_False} :: pre_rel_def ::
-                       (if fp = Least_FP then [] else [dtor_ctor]) @ sum_prod_thms_rel)
-                     (cterm_instantiate_pos (nones @ [SOME cxIn, SOME cyIn]) fp_rel_thm))
-                |> postproc
-                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
-
-              fun mk_rel_inject_thm ((ctr_def', cxIn), (_, cyIn)) =
-                mk_rel_thm (unfold_thms lthy @{thms eq_sym_Unity_conv}) [ctr_def'] cxIn cyIn;
-
-              val rel_inject_thms = map mk_rel_inject_thm (op ~~ rel_infos);
-
-              fun mk_half_rel_distinct_thm ((xctr_def', cxIn), (yctr_def', cyIn)) =
-                mk_rel_thm (fn thm => thm RS @{thm eq_False[THEN iffD1]}) [xctr_def', yctr_def']
-                  cxIn cyIn;
-
-              fun mk_other_half_rel_distinct_thm thm =
-                flip_rels lthy live thm
-                RS (rel_flip RS sym RS @{thm arg_cong[of _ _ Not]} RS iffD2);
-
-              val half_rel_distinct_thmss =
-                map (map mk_half_rel_distinct_thm) (mk_half_pairss rel_infos);
-              val other_half_rel_distinct_thmss =
-                map (map mk_other_half_rel_distinct_thm) half_rel_distinct_thmss;
-              val (rel_distinct_thms, _) =
-                join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss;
-
-              val anonymous_notes =
-                [(map (fn th => th RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms,
-                  code_nitpicksimp_attrs),
-                 (map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th)
-                    rel_inject_thms ms, code_nitpicksimp_attrs)]
-                |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
-
-              val notes =
-                [(mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs),
-                 (rel_distinctN, rel_distinct_thms, simp_attrs),
-                 (rel_injectN, rel_inject_thms, simp_attrs),
-                 (setN, flat set_thmss, code_nitpicksimp_attrs @ simp_attrs)]
-                |> massage_simple_notes fp_b_name;
-            in
-              (((map_thms, rel_inject_thms, rel_distinct_thms, set_thmss), ctr_sugar),
-               lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd)
-            end;
-
-        fun mk_binding pre = qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b);
-
-        fun massage_res (((maps_sets_rels, ctr_sugar), co_iter_res), lthy) =
-          (((maps_sets_rels, (ctrs, xss, ctr_defs, ctr_sugar)), co_iter_res), lthy);
-      in
-        (wrap_ctrs
-         #> derive_maps_sets_rels
-         ##>>
-           (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
-            else define_coiters [unfoldN, corecN] (the coiters_args_types))
-             mk_binding fpTs Cs xtor_co_iters
-         #> massage_res, lthy')
-      end;
-
-    fun wrap_types_etc (wrap_types_etcs, lthy) =
-      fold_map I wrap_types_etcs lthy
-      |>> apsnd split_list o apfst (apsnd split_list4 o apfst split_list4 o split_list)
-        o split_list;
-
-    fun mk_simp_thms ({injects, distincts, case_thms, ...} : ctr_sugar) un_folds co_recs
-        mapsx rel_injects rel_distincts setss =
-      injects @ distincts @ case_thms @ co_recs @ un_folds @ mapsx @ rel_injects @ rel_distincts
-      @ flat setss;
-
-    fun derive_note_induct_iters_thms_for_types
-        ((((mapss, rel_injects, rel_distincts, setss), (ctrss, _, ctr_defss, ctr_sugars)),
-          (iterss, iter_defss)), lthy) =
-      let
-        val ((induct_thms, induct_thm, induct_attrs), (fold_thmss, rec_thmss, iter_attrs)) =
-          derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
-            xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss iterss
-            iter_defss lthy;
-
-        val induct_type_attr = Attrib.internal o K o Induct.induct_type;
-
-        val simp_thmss =
-          map7 mk_simp_thms ctr_sugars fold_thmss rec_thmss mapss rel_injects rel_distincts setss;
-
-        val common_notes =
-          (if nn > 1 then [(inductN, [induct_thm], induct_attrs)] else [])
-          |> massage_simple_notes fp_common_name;
-
-        val notes =
-          [(foldN, fold_thmss, K iter_attrs),
-           (inductN, map single induct_thms, fn T_name => induct_attrs @ [induct_type_attr T_name]),
-           (recN, rec_thmss, K iter_attrs),
-           (simpsN, simp_thmss, K [])]
-          |> massage_multi_notes;
-      in
-        lthy
-        |> Local_Theory.notes (common_notes @ notes) |> snd
-        |> register_fp_sugars Least_FP pre_bnfs nested_bnfs nesting_bnfs fp_res ctr_defss ctr_sugars
-          iterss mapss [induct_thm] (transpose [fold_thmss, rec_thmss]) [] []
-      end;
-
-    fun derive_note_coinduct_coiters_thms_for_types
-        ((((mapss, rel_injects, rel_distincts, setss), (_, _, ctr_defss, ctr_sugars)),
-          (coiterss, coiter_defss)), lthy) =
-      let
-        val (([(coinduct_thms, coinduct_thm), (strong_coinduct_thms, strong_coinduct_thm)],
-              coinduct_attrs),
-             (unfold_thmss, corec_thmss, coiter_attrs),
-             (disc_unfold_thmss, disc_corec_thmss, disc_coiter_attrs),
-             (disc_unfold_iff_thmss, disc_corec_iff_thmss, disc_coiter_iff_attrs),
-             (sel_unfold_thmsss, sel_corec_thmsss, sel_coiter_attrs)) =
-          derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
-            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns
-            ctr_defss ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy)
-            lthy;
-
-        val sel_unfold_thmss = map flat sel_unfold_thmsss;
-        val sel_corec_thmss = map flat sel_corec_thmsss;
-
-        val coinduct_type_attr = Attrib.internal o K o Induct.coinduct_type;
-
-        val flat_coiter_thms = append oo append;
-
-        val simp_thmss =
-          map7 mk_simp_thms ctr_sugars
-            (map3 flat_coiter_thms disc_unfold_thmss disc_unfold_iff_thmss sel_unfold_thmss)
-            (map3 flat_coiter_thms disc_corec_thmss disc_corec_iff_thmss sel_corec_thmss)
-            mapss rel_injects rel_distincts setss;
-
-        val common_notes =
-          (if nn > 1 then
-             [(coinductN, [coinduct_thm], coinduct_attrs),
-              (strong_coinductN, [strong_coinduct_thm], coinduct_attrs)]
-           else
-             [])
-          |> massage_simple_notes fp_common_name;
-
-        val notes =
-          [(coinductN, map single coinduct_thms,
-            fn T_name => coinduct_attrs @ [coinduct_type_attr T_name]),
-           (corecN, corec_thmss, K coiter_attrs),
-           (disc_corecN, disc_corec_thmss, K disc_coiter_attrs),
-           (disc_corec_iffN, disc_corec_iff_thmss, K disc_coiter_iff_attrs),
-           (disc_unfoldN, disc_unfold_thmss, K disc_coiter_attrs),
-           (disc_unfold_iffN, disc_unfold_iff_thmss, K disc_coiter_iff_attrs),
-           (sel_corecN, sel_corec_thmss, K sel_coiter_attrs),
-           (sel_unfoldN, sel_unfold_thmss, K sel_coiter_attrs),
-           (simpsN, simp_thmss, K []),
-           (strong_coinductN, map single strong_coinduct_thms, K coinduct_attrs),
-           (unfoldN, unfold_thmss, K coiter_attrs)]
-          |> massage_multi_notes;
-
-        fun is_codatatype (Type (s, _)) =
-            (case fp_sugar_of lthy s of SOME {fp = Greatest_FP, ...} => true | _ => false)
-          | is_codatatype _ = false;
-
-        val nitpick_supported = forall (is_codatatype o T_of_bnf) nested_bnfs;
-
-        fun register_nitpick fpT ({ctrs, casex, ...} : ctr_sugar) =
-          Nitpick_HOL.register_codatatype fpT (fst (dest_Const casex))
-            (map (dest_Const o mk_ctr As) ctrs)
-          |> Generic_Target.theory_declaration;
-      in
-        lthy
-        |> Local_Theory.notes (common_notes @ notes) |> snd
-        |> register_fp_sugars Greatest_FP pre_bnfs nested_bnfs nesting_bnfs fp_res ctr_defss
-          ctr_sugars coiterss mapss [coinduct_thm, strong_coinduct_thm]
-          (transpose [unfold_thmss, corec_thmss]) (transpose [disc_unfold_thmss, disc_corec_thmss])
-          (transpose [sel_unfold_thmsss, sel_corec_thmsss])
-        |> nitpick_supported ? fold2 register_nitpick fpTs ctr_sugars
-      end;
-
-    val lthy'' = lthy'
-      |> fold_map define_ctrs_dtrs_for_type (fp_bnfs ~~ fp_bs ~~ fpTs ~~ ctors ~~ dtors ~~
-        xtor_co_iterss ~~ ctor_dtors ~~ dtor_ctors ~~ ctor_injects ~~ pre_map_defs ~~
-        pre_set_defss ~~ pre_rel_defs ~~ xtor_map_thms ~~ xtor_set_thmss ~~ xtor_rel_thms ~~ ns ~~
-        kss ~~ mss ~~ ctr_bindingss ~~ ctr_mixfixess ~~ ctr_Tsss ~~ disc_bindingss ~~
-        sel_bindingsss ~~ raw_sel_defaultsss)
-      |> wrap_types_etc
-      |> fp_case fp derive_note_induct_iters_thms_for_types
-           derive_note_coinduct_coiters_thms_for_types;
-
-    val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^
-      co_prefix fp ^ "datatype"));
-  in
-    timer; lthy''
-  end;
-
-fun co_datatypes x = define_co_datatypes (K I) (K I) (K I) x;
-
-fun co_datatype_cmd x =
-  define_co_datatypes Typedecl.read_constraint Syntax.parse_typ Syntax.parse_term x;
-
-val parse_ctr_arg =
-  @{keyword "("} |-- parse_binding_colon -- Parse.typ --| @{keyword ")"} ||
-  (Parse.typ >> pair Binding.empty);
-
-val parse_defaults =
-  @{keyword "("} |-- Parse.reserved "defaults" |-- Scan.repeat parse_bound_term --| @{keyword ")"};
-
-val parse_type_arg_constrained =
-  Parse.type_ident -- Scan.option (@{keyword "::"} |-- Parse.!!! Parse.sort);
-
-val parse_type_arg_named_constrained = parse_opt_binding_colon -- parse_type_arg_constrained;
-
-(*FIXME: use parse_type_args_named_constrained from BNF_Util and thus 
-  allow users to kill certain arguments of a (co)datatype*)
-val parse_type_args_named_constrained =
-  parse_type_arg_constrained >> (single o pair Binding.empty) ||
-  @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
-  Scan.succeed [];
-
-val parse_ctr_spec =
-  parse_opt_binding_colon -- parse_binding -- Scan.repeat parse_ctr_arg --
-  Scan.optional parse_defaults [] -- Parse.opt_mixfix;
-
-val parse_spec =
-  parse_type_args_named_constrained -- parse_binding -- parse_map_rel_bindings --
-  Parse.opt_mixfix -- (@{keyword "="} |-- Parse.enum1 "|" parse_ctr_spec);
-
-val parse_co_datatype = parse_wrap_free_constructors_options -- Parse.and_list1 parse_spec;
-
-fun parse_co_datatype_cmd fp construct_fp = parse_co_datatype >> co_datatype_cmd fp construct_fp;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,181 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012
-
-Tactics for datatype and codatatype sugar.
-*)
-
-signature BNF_FP_DEF_SUGAR_TACTICS =
-sig
-  val sum_prod_thms_map: thm list
-  val sum_prod_thms_set: thm list
-  val sum_prod_thms_rel: thm list
-
-  val mk_coinduct_tac: Proof.context -> thm list -> int -> int list -> thm -> thm list ->
-    thm list -> thm list -> thm list list -> thm list list list -> thm list list list -> tactic
-  val mk_coiter_tac: thm list -> thm list -> thm -> thm -> thm -> Proof.context -> tactic
-  val mk_ctor_iff_dtor_tac: Proof.context -> ctyp option list -> cterm -> cterm -> thm -> thm ->
-    tactic
-  val mk_disc_coiter_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic
-  val mk_exhaust_tac: Proof.context -> int -> thm list -> thm -> thm -> tactic
-  val mk_half_distinct_tac: Proof.context -> thm -> thm list -> tactic
-  val mk_induct_tac: Proof.context -> int -> int list -> int list list -> int list list list ->
-    thm list -> thm -> thm list -> thm list list -> tactic
-  val mk_inject_tac: Proof.context -> thm -> thm -> tactic
-  val mk_iter_tac: thm list -> thm list -> thm list -> thm -> thm -> Proof.context -> tactic
-end;
-
-structure BNF_FP_Def_Sugar_Tactics : BNF_FP_DEF_SUGAR_TACTICS =
-struct
-
-open BNF_Tactics
-open BNF_Util
-open BNF_FP_Util
-
-val basic_simp_thms = @{thms simp_thms(7,8,12,14,22,24)};
-val more_simp_thms = basic_simp_thms @ @{thms simp_thms(11,15,16,21)};
-
-val sum_prod_thms_map = @{thms id_apply map_pair_simp prod.cases sum.cases sum_map.simps};
-val sum_prod_thms_set0 =
-  @{thms SUP_empty Sup_empty Sup_insert UN_insert Un_empty_left Un_empty_right Un_iff
-      Union_Un_distrib collect_def[abs_def] image_def o_apply map_pair_simp
-      mem_Collect_eq mem_UN_compreh_eq prod_set_simps sum_map.simps sum_set_simps};
-val sum_prod_thms_set = @{thms UN_compreh_eq_eq} @ sum_prod_thms_set0;
-val sum_prod_thms_rel = @{thms prod_rel_simp sum_rel_simps id_apply};
-
-fun hhf_concl_conv cv ctxt ct =
-  (case Thm.term_of ct of
-    Const (@{const_name all}, _) $ Abs _ =>
-    Conv.arg_conv (Conv.abs_conv (hhf_concl_conv cv o snd) ctxt) ct
-  | _ => Conv.concl_conv ~1 cv ct);
-
-fun co_induct_inst_as_projs ctxt k thm =
-  let
-    val fs = Term.add_vars (prop_of thm) []
-      |> filter (fn (_, Type (@{type_name fun}, [_, T'])) => T' <> HOLogic.boolT | _ => false);
-    fun mk_cfp (f as (_, T)) =
-      (certify ctxt (Var f), certify ctxt (mk_proj T (num_binder_types T) k));
-    val cfps = map mk_cfp fs;
-  in
-    Drule.cterm_instantiate cfps thm
-  end;
-
-val co_induct_inst_as_projs_tac = PRIMITIVE oo co_induct_inst_as_projs;
-
-fun mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor sumEN' =
-  unfold_thms_tac ctxt (ctor_iff_dtor :: ctr_defs) THEN HEADGOAL (rtac sumEN') THEN
-  unfold_thms_tac ctxt @{thms split_paired_all} THEN
-  HEADGOAL (EVERY' (maps (fn k => [select_prem_tac n (rotate_tac 1) k,
-    REPEAT_DETERM o dtac meta_spec, etac meta_mp, atac]) (1 upto n)));
-
-fun mk_ctor_iff_dtor_tac ctxt cTs cctor cdtor ctor_dtor dtor_ctor =
-  HEADGOAL (rtac iffI THEN'
-    EVERY' (map3 (fn cTs => fn cx => fn th =>
-      dtac (Drule.instantiate' cTs [NONE, NONE, SOME cx] arg_cong) THEN'
-      SELECT_GOAL (unfold_thms_tac ctxt [th]) THEN'
-      atac) [rev cTs, cTs] [cdtor, cctor] [dtor_ctor, ctor_dtor]));
-
-fun mk_half_distinct_tac ctxt ctor_inject ctr_defs =
-  unfold_thms_tac ctxt (ctor_inject :: @{thms sum.inject} @ ctr_defs) THEN
-  HEADGOAL (rtac @{thm sum.distinct(1)});
-
-fun mk_inject_tac ctxt ctr_def ctor_inject =
-  unfold_thms_tac ctxt [ctr_def] THEN HEADGOAL (rtac (ctor_inject RS ssubst)) THEN
-  unfold_thms_tac ctxt @{thms sum.inject Pair_eq conj_assoc} THEN HEADGOAL (rtac refl);
-
-val iter_unfold_thms =
-  @{thms comp_def convol_def fst_conv id_def prod_case_Pair_iden snd_conv
-      split_conv unit_case_Unity} @ sum_prod_thms_map;
-
-fun mk_iter_tac pre_map_defs map_idents iter_defs ctor_iter ctr_def ctxt =
-  unfold_thms_tac ctxt (ctr_def :: ctor_iter :: iter_defs @ pre_map_defs @ map_idents @
-    iter_unfold_thms) THEN HEADGOAL (rtac refl);
-
-val coiter_unfold_thms = @{thms id_def} @ sum_prod_thms_map;
-val ss_if_True_False = simpset_of (ss_only @{thms if_True if_False} @{context});
-
-fun mk_coiter_tac coiter_defs map_idents ctor_dtor_coiter pre_map_def ctr_def ctxt =
-  unfold_thms_tac ctxt (ctr_def :: coiter_defs) THEN
-  HEADGOAL (rtac (ctor_dtor_coiter RS trans) THEN'
-    asm_simp_tac (put_simpset ss_if_True_False ctxt)) THEN_MAYBE
-  (unfold_thms_tac ctxt (pre_map_def :: map_idents @ coiter_unfold_thms) THEN
-   HEADGOAL (rtac refl ORELSE' rtac (@{thm unit_eq} RS arg_cong)));
-
-fun mk_disc_coiter_iff_tac case_splits' coiters discs ctxt =
-  EVERY (map3 (fn case_split_tac => fn coiter_thm => fn disc =>
-      HEADGOAL case_split_tac THEN unfold_thms_tac ctxt [coiter_thm] THEN
-      HEADGOAL (asm_simp_tac (ss_only basic_simp_thms ctxt)) THEN
-      (if is_refl disc then all_tac else HEADGOAL (rtac disc)))
-    (map rtac case_splits' @ [K all_tac]) coiters discs);
-
-fun solve_prem_prem_tac ctxt =
-  REPEAT o (eresolve_tac @{thms bexE rev_bexI} ORELSE' rtac @{thm rev_bexI[OF UNIV_I]} ORELSE'
-    hyp_subst_tac ctxt ORELSE' resolve_tac @{thms disjI1 disjI2}) THEN'
-  (rtac refl ORELSE' atac ORELSE' rtac @{thm singletonI});
-
-fun mk_induct_leverage_prem_prems_tac ctxt nn kks set_maps pre_set_defs =
-  HEADGOAL (EVERY' (maps (fn kk => [select_prem_tac nn (dtac meta_spec) kk, etac meta_mp,
-    SELECT_GOAL (unfold_thms_tac ctxt (pre_set_defs @ set_maps @ sum_prod_thms_set0)),
-    solve_prem_prem_tac ctxt]) (rev kks)));
-
-fun mk_induct_discharge_prem_tac ctxt nn n set_maps pre_set_defs m k kks =
-  let val r = length kks in
-    HEADGOAL (EVERY' [select_prem_tac n (rotate_tac 1) k, rotate_tac ~1, hyp_subst_tac ctxt,
-      REPEAT_DETERM_N m o (dtac meta_spec THEN' rotate_tac ~1)]) THEN
-    EVERY [REPEAT_DETERM_N r
-        (HEADGOAL (rotate_tac ~1 THEN' dtac meta_mp THEN' rotate_tac 1) THEN prefer_tac 2),
-      if r > 0 then ALLGOALS (Goal.norm_hhf_tac ctxt) else all_tac, HEADGOAL atac,
-      mk_induct_leverage_prem_prems_tac ctxt nn kks set_maps pre_set_defs]
-  end;
-
-fun mk_induct_tac ctxt nn ns mss kkss ctr_defs ctor_induct' set_maps pre_set_defss =
-  let val n = Integer.sum ns in
-    unfold_thms_tac ctxt ctr_defs THEN HEADGOAL (rtac ctor_induct') THEN
-    co_induct_inst_as_projs_tac ctxt 0 THEN
-    EVERY (map4 (EVERY oooo map3 o mk_induct_discharge_prem_tac ctxt nn n set_maps) pre_set_defss
-      mss (unflat mss (1 upto n)) kkss)
-  end;
-
-fun mk_coinduct_same_ctr_tac ctxt rel_eqs pre_rel_def dtor_ctor ctr_def discs sels =
-  hyp_subst_tac ctxt THEN'
-  CONVERSION (hhf_concl_conv
-    (Conv.top_conv (K (Conv.try_conv (Conv.rewr_conv ctr_def))) ctxt) ctxt) THEN'
-  SELECT_GOAL (unfold_thms_tac ctxt (pre_rel_def :: dtor_ctor :: sels)) THEN'
-  SELECT_GOAL (unfold_thms_tac ctxt (pre_rel_def :: dtor_ctor :: sels @ sum_prod_thms_rel)) THEN'
-  (atac ORELSE' REPEAT o etac conjE THEN'
-     full_simp_tac
-       (ss_only (@{thm prod.inject} :: no_refl discs @ rel_eqs @ more_simp_thms) ctxt) THEN'
-     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN'
-     REPEAT o (resolve_tac [refl, conjI] ORELSE' atac));
-
-fun mk_coinduct_distinct_ctrs_tac ctxt discs discs' =
-  let
-    val discs'' = map (perhaps (try (fn th => th RS @{thm notnotD}))) (discs @ discs')
-      |> distinct Thm.eq_thm_prop;
-  in
-    hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
-    full_simp_tac (ss_only (refl :: no_refl discs'' @ basic_simp_thms) ctxt)
-  end;
-
-fun mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn kk n pre_rel_def dtor_ctor exhaust ctr_defs
-    discss selss =
-  let val ks = 1 upto n in
-    EVERY' ([rtac allI, rtac allI, rtac impI, select_prem_tac nn (dtac meta_spec) kk,
-        dtac meta_spec, dtac meta_mp, atac, rtac exhaust, K (co_induct_inst_as_projs_tac ctxt 0),
-        hyp_subst_tac ctxt] @
-      map4 (fn k => fn ctr_def => fn discs => fn sels =>
-        EVERY' ([rtac exhaust, K (co_induct_inst_as_projs_tac ctxt 1)] @
-          map2 (fn k' => fn discs' =>
-            if k' = k then
-              mk_coinduct_same_ctr_tac ctxt rel_eqs' pre_rel_def dtor_ctor ctr_def discs sels
-            else
-              mk_coinduct_distinct_ctrs_tac ctxt discs discs') ks discss)) ks ctr_defs discss selss)
-  end;
-
-fun mk_coinduct_tac ctxt rel_eqs' nn ns dtor_coinduct' pre_rel_defs dtor_ctors exhausts ctr_defss
-    discsss selsss =
-  HEADGOAL (rtac dtor_coinduct' THEN'
-    EVERY' (map8 (mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn)
-      (1 upto nn) ns pre_rel_defs dtor_ctors exhausts ctr_defss discsss selsss));
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_n2m.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,378 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_n2m.ML
-    Author:     Dmitriy Traytel, TU Muenchen
-    Copyright   2013
-
-Flattening of nested to mutual (co)recursion.
-*)
-
-signature BNF_FP_N2M =
-sig
-  val construct_mutualized_fp: BNF_FP_Util.fp_kind  -> typ list -> BNF_FP_Def_Sugar.fp_sugar list ->
-    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
-    local_theory -> BNF_FP_Util.fp_result * local_theory
-end;
-
-structure BNF_FP_N2M : BNF_FP_N2M =
-struct
-
-open BNF_Def
-open BNF_Util
-open BNF_FP_Util
-open BNF_FP_Def_Sugar
-open BNF_Tactics
-open BNF_FP_N2M_Tactics
-
-fun force_typ ctxt T =
-  map_types Type_Infer.paramify_vars
-  #> Type.constraint T
-  #> Syntax.check_term ctxt
-  #> singleton (Variable.polymorphic ctxt);
-
-fun mk_prod_map f g =
-  let
-    val ((fAT, fBT), fT) = `dest_funT (fastype_of f);
-    val ((gAT, gBT), gT) = `dest_funT (fastype_of g);
-  in
-    Const (@{const_name map_pair},
-      fT --> gT --> HOLogic.mk_prodT (fAT, gAT) --> HOLogic.mk_prodT (fBT, gBT)) $ f $ g
-  end;
-
-fun mk_sum_map f g =
-  let
-    val ((fAT, fBT), fT) = `dest_funT (fastype_of f);
-    val ((gAT, gBT), gT) = `dest_funT (fastype_of g);
-  in
-    Const (@{const_name sum_map}, fT --> gT --> mk_sumT (fAT, gAT) --> mk_sumT (fBT, gBT)) $ f $ g
-  end;
-
-fun construct_mutualized_fp fp fpTs fp_sugars bs resBs (resDs, Dss) bnfs lthy =
-  let
-    fun steal get = map (of_fp_sugar (get o #fp_res)) fp_sugars;
-
-    val n = length bnfs;
-    val deads = fold (union (op =)) Dss resDs;
-    val As = subtract (op =) deads (map TFree resBs);
-    val names_lthy = fold Variable.declare_typ (As @ deads) lthy;
-    val m = length As;
-    val live = m + n;
-    val ((Xs, Bs), names_lthy) = names_lthy
-      |> mk_TFrees n
-      ||>> mk_TFrees m;
-    val allAs = As @ Xs;
-    val phiTs = map2 mk_pred2T As Bs;
-    val theta = As ~~ Bs;
-    val fpTs' = map (Term.typ_subst_atomic theta) fpTs;
-    val pre_phiTs = map2 mk_pred2T fpTs fpTs';
-
-    fun mk_co_algT T U = fp_case fp (T --> U) (U --> T);
-    fun co_swap pair = fp_case fp I swap pair;
-    val dest_co_algT = co_swap o dest_funT;
-    val co_alg_argT = fp_case fp range_type domain_type;
-    val co_alg_funT = fp_case fp domain_type range_type;
-    val mk_co_product = curry (fp_case fp mk_convol mk_sum_case);
-    val mk_map_co_product = fp_case fp mk_prod_map mk_sum_map;
-    val co_proj1_const = fp_case fp (fst_const o fst) (uncurry Inl_const o dest_sumT o snd);
-    val mk_co_productT = curry (fp_case fp HOLogic.mk_prodT mk_sumT);
-    val dest_co_productT = fp_case fp HOLogic.dest_prodT dest_sumT;
-
-    val ((ctors, dtors), (xtor's, xtors)) =
-      let
-        val ctors = map2 (force_typ names_lthy o (fn T => dummyT --> T)) fpTs (steal #ctors);
-        val dtors = map2 (force_typ names_lthy o (fn T => T --> dummyT)) fpTs (steal #dtors);
-      in
-        ((ctors, dtors), `(map (Term.subst_atomic_types theta)) (fp_case fp ctors dtors))
-      end;
-
-    val xTs = map (domain_type o fastype_of) xtors;
-    val yTs = map (domain_type o fastype_of) xtor's;
-
-    val (((((phis, phis'), pre_phis), xs), ys), names_lthy) = names_lthy
-      |> mk_Frees' "R" phiTs
-      ||>> mk_Frees "S" pre_phiTs
-      ||>> mk_Frees "x" xTs
-      ||>> mk_Frees "y" yTs;
-
-    val fp_bnfs = steal #bnfs;
-    val pre_bnfs = map (of_fp_sugar #pre_bnfs) fp_sugars;
-    val pre_bnfss = map #pre_bnfs fp_sugars;
-    val nesty_bnfss = map (fn sugar => #nested_bnfs sugar @ #nesting_bnfs sugar) fp_sugars;
-    val fp_nesty_bnfss = fp_bnfs :: nesty_bnfss;
-    val fp_nesty_bnfs = distinct eq_bnf (flat fp_nesty_bnfss);
-
-    val rels =
-      let
-        fun find_rel T As Bs = fp_nesty_bnfss
-          |> map (filter_out (curry eq_bnf BNF_Comp.DEADID_bnf))
-          |> get_first (find_first (fn bnf => Type.could_unify (T_of_bnf bnf, T)))
-          |> Option.map (fn bnf =>
-            let val live = live_of_bnf bnf;
-            in (mk_rel live As Bs (rel_of_bnf bnf), live) end)
-          |> the_default (HOLogic.eq_const T, 0);
-
-        fun mk_rel (T as Type (_, Ts)) (Type (_, Us)) =
-              let
-                val (rel, live) = find_rel T Ts Us;
-                val (Ts', Us') = fastype_of rel |> strip_typeN live |> fst |> map_split dest_pred2T;
-                val rels = map2 mk_rel Ts' Us';
-              in
-                Term.list_comb (rel, rels)
-              end
-          | mk_rel (T as TFree _) _ = (nth phis (find_index (curry op = T) As)
-              handle General.Subscript => HOLogic.eq_const T)
-          | mk_rel _ _ = raise Fail "fpTs contains schematic type variables";
-      in
-        map2 (fold_rev Term.absfree phis' oo mk_rel) fpTs fpTs'
-      end;
-
-    val pre_rels = map2 (fn Ds => mk_rel_of_bnf Ds (As @ fpTs) (Bs @ fpTs')) Dss bnfs;
-
-    val rel_unfoldss = map (maps (fn bnf => no_refl [rel_def_of_bnf bnf])) pre_bnfss;
-    val rel_xtor_co_inducts = steal (split_conj_thm o #rel_xtor_co_induct_thm)
-      |> map2 (fn unfs => unfold_thms lthy (id_apply :: unfs)) rel_unfoldss;
-
-    val rel_defs = map rel_def_of_bnf bnfs;
-    val rel_monos = map rel_mono_of_bnf bnfs;
-
-    val rel_xtor_co_induct_thm =
-      mk_rel_xtor_co_induct_thm fp pre_rels pre_phis rels phis xs ys xtors xtor's
-        (mk_rel_xtor_co_induct_tactic fp rel_xtor_co_inducts rel_defs rel_monos) lthy;
-
-    val rel_eqs = no_refl (map rel_eq_of_bnf fp_nesty_bnfs);
-    val map_id0s = no_refl (map map_id0_of_bnf bnfs);
-
-    val xtor_co_induct_thm =
-      (case fp of
-        Least_FP =>
-          let
-            val (Ps, names_lthy) = names_lthy
-              |> mk_Frees "P" (map (fn T => T --> HOLogic.boolT) fpTs);
-            fun mk_Grp_id P =
-              let val T = domain_type (fastype_of P);
-              in mk_Grp (HOLogic.Collect_const T $ P) (HOLogic.id_const T) end;
-            val cts = map (SOME o certify lthy) (map HOLogic.eq_const As @ map mk_Grp_id Ps);
-          in
-            cterm_instantiate_pos cts rel_xtor_co_induct_thm
-            |> singleton (Proof_Context.export names_lthy lthy)
-            |> unfold_thms lthy (@{thms eq_le_Grp_id_iff all_simps(1,2)[symmetric]} @ rel_eqs)
-            |> funpow n (fn thm => thm RS spec)
-            |> unfold_thms lthy (@{thm eq_alt} :: map rel_Grp_of_bnf bnfs @ map_id0s)
-            |> unfold_thms lthy @{thms Grp_id_mono_subst eqTrueI[OF subset_UNIV] simp_thms(22)}
-            |> unfold_thms lthy @{thms subset_iff mem_Collect_eq
-               atomize_conjL[symmetric] atomize_all[symmetric] atomize_imp[symmetric]}
-            |> unfold_thms lthy (maps set_defs_of_bnf bnfs)
-          end
-      | Greatest_FP =>
-          let
-            val cts = NONE :: map (SOME o certify lthy) (map HOLogic.eq_const As);
-          in
-            cterm_instantiate_pos cts rel_xtor_co_induct_thm
-            |> unfold_thms lthy (@{thms le_fun_def le_bool_def all_simps(1,2)[symmetric]} @ rel_eqs)
-            |> funpow (2 * n) (fn thm => thm RS spec)
-            |> Conv.fconv_rule (Object_Logic.atomize lthy)
-            |> funpow n (fn thm => thm RS mp)
-          end);
-
-    val fold_preTs = map2 (fn Ds => mk_T_of_bnf Ds allAs) Dss bnfs;
-    val fold_pre_deads_only_Ts = map2 (fn Ds => mk_T_of_bnf Ds (replicate live dummyT)) Dss bnfs;
-    val rec_theta = Xs ~~ map2 mk_co_productT fpTs Xs;
-    val rec_preTs = map (Term.typ_subst_atomic rec_theta) fold_preTs;
-
-    val fold_strTs = map2 mk_co_algT fold_preTs Xs;
-    val rec_strTs = map2 mk_co_algT rec_preTs Xs;
-    val resTs = map2 mk_co_algT fpTs Xs;
-
-    val (((fold_strs, fold_strs'), (rec_strs, rec_strs')), names_lthy) = names_lthy
-      |> mk_Frees' "s" fold_strTs
-      ||>> mk_Frees' "s" rec_strTs;
-
-    val co_iters = steal #xtor_co_iterss;
-    val ns = map (length o #pre_bnfs) fp_sugars;
-    fun substT rho (Type (@{type_name "fun"}, [T, U])) = substT rho T --> substT rho U
-      | substT rho (Type (s, Ts)) = Type (s, map (typ_subst_nonatomic rho) Ts)
-      | substT _ T = T;
-    fun force_iter is_rec i TU TU_rec raw_iters =
-      let
-        val approx_fold = un_fold_of raw_iters
-          |> force_typ names_lthy
-            (replicate (nth ns i) dummyT ---> (if is_rec then TU_rec else TU));
-        val TUs = binder_fun_types (Term.typ_subst_atomic (Xs ~~ fpTs) (fastype_of approx_fold));
-        val js = find_indices Type.could_unify
-          TUs (map (Term.typ_subst_atomic (Xs ~~ fpTs)) fold_strTs);
-        val Tpats = map (fn j => mk_co_algT (nth fold_pre_deads_only_Ts j) (nth Xs j)) js;
-        val iter = raw_iters |> (if is_rec then co_rec_of else un_fold_of);
-      in
-        force_typ names_lthy (Tpats ---> TU) iter
-      end;
-
-    fun mk_iter b_opt is_rec iters lthy TU =
-      let
-        val x = co_alg_argT TU;
-        val i = find_index (fn T => x = T) Xs;
-        val TUiter =
-          (case find_first (fn f => body_fun_type (fastype_of f) = TU) iters of
-            NONE => nth co_iters i
-              |> force_iter is_rec i
-                (TU |> (is_none b_opt andalso not is_rec) ? substT (fpTs ~~ Xs))
-                (TU |> (is_none b_opt) ? substT (map2 mk_co_productT fpTs Xs ~~ Xs))
-          | SOME f => f);
-        val TUs = binder_fun_types (fastype_of TUiter);
-        val iter_preTs = if is_rec then rec_preTs else fold_preTs;
-        val iter_strs = if is_rec then rec_strs else fold_strs;
-        fun mk_s TU' =
-          let
-            val i = find_index (fn T => co_alg_argT TU' = T) Xs;
-            val sF = co_alg_funT TU';
-            val F = nth iter_preTs i;
-            val s = nth iter_strs i;
-          in
-            (if sF = F then s
-            else
-              let
-                val smapT = replicate live dummyT ---> mk_co_algT sF F;
-                fun hidden_to_unit t =
-                  Term.subst_TVars (map (rpair HOLogic.unitT) (Term.add_tvar_names t [])) t;
-                val smap = map_of_bnf (nth bnfs i)
-                  |> force_typ names_lthy smapT
-                  |> hidden_to_unit;
-                val smap_argTs = strip_typeN live (fastype_of smap) |> fst;
-                fun mk_smap_arg TU =
-                  (if domain_type TU = range_type TU then
-                    HOLogic.id_const (domain_type TU)
-                  else if is_rec then
-                    let
-                      val (TY, (U, X)) = TU |> dest_co_algT ||> dest_co_productT;
-                      val T = mk_co_algT TY U;
-                    in
-                      (case try (force_typ lthy T o build_map lthy co_proj1_const o dest_funT) T of
-                        SOME f => mk_co_product f
-                          (fst (fst (mk_iter NONE is_rec iters lthy (mk_co_algT TY X))))
-                      | NONE => mk_map_co_product
-                          (build_map lthy co_proj1_const
-                            (dest_funT (mk_co_algT (dest_co_productT TY |> fst) U)))
-                          (HOLogic.id_const X))
-                    end
-                  else
-                    fst (fst (mk_iter NONE is_rec iters lthy TU)))
-                val smap_args = map mk_smap_arg smap_argTs;
-              in
-                HOLogic.mk_comp (co_swap (s, Term.list_comb (smap, smap_args)))
-              end)
-          end;
-        val t = Term.list_comb (TUiter, map mk_s TUs);
-      in
-        (case b_opt of
-          NONE => ((t, Drule.dummy_thm), lthy)
-        | SOME b => Local_Theory.define ((b, NoSyn), ((Binding.conceal (Thm.def_binding b), []),
-            fold_rev Term.absfree (if is_rec then rec_strs' else fold_strs') t)) lthy |>> apsnd snd)
-      end;
-
-    fun mk_iters is_rec name lthy =
-      fold2 (fn TU => fn b => fn ((iters, defs), lthy) =>
-        mk_iter (SOME b) is_rec iters lthy TU |>> (fn (f, d) => (f :: iters, d :: defs)))
-      resTs (map (Binding.suffix_name ("_" ^ name)) bs) (([], []), lthy)
-      |>> apfst rev o apsnd rev;
-    val foldN = fp_case fp ctor_foldN dtor_unfoldN;
-    val recN = fp_case fp ctor_recN dtor_corecN;
-    val (((raw_un_folds, raw_un_fold_defs), (raw_co_recs, raw_co_rec_defs)), (lthy, raw_lthy)) =
-      lthy
-      |> mk_iters false foldN
-      ||>> mk_iters true recN
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism raw_lthy lthy;
-
-    val un_folds = map (Morphism.term phi) raw_un_folds;
-    val co_recs = map (Morphism.term phi) raw_co_recs;
-
-    val (xtor_un_fold_thms, xtor_co_rec_thms) =
-      let
-        val folds = map (fn f => Term.list_comb (f, fold_strs)) raw_un_folds;
-        val recs = map (fn r => Term.list_comb (r, rec_strs)) raw_co_recs;
-        val fold_mapTs = co_swap (As @ fpTs, As @ Xs);
-        val rec_mapTs = co_swap (As @ fpTs, As @ map2 mk_co_productT fpTs Xs);
-        val pre_fold_maps =
-          map2 (fn Ds => fn bnf =>
-            Term.list_comb (uncurry (mk_map_of_bnf Ds) fold_mapTs bnf,
-              map HOLogic.id_const As @ folds))
-          Dss bnfs;
-        val pre_rec_maps =
-          map2 (fn Ds => fn bnf =>
-            Term.list_comb (uncurry (mk_map_of_bnf Ds) rec_mapTs bnf,
-              map HOLogic.id_const As @ map2 (mk_co_product o HOLogic.id_const) fpTs recs))
-          Dss bnfs;
-
-        fun mk_goals f xtor s smap =
-          ((f, xtor), (s, smap))
-          |> pairself (HOLogic.mk_comp o co_swap)
-          |> HOLogic.mk_eq;
-
-        val fold_goals = map4 mk_goals folds xtors fold_strs pre_fold_maps
-        val rec_goals = map4 mk_goals recs xtors rec_strs pre_rec_maps;
-
-        fun mk_thms ss goals tac =
-          Library.foldr1 HOLogic.mk_conj goals
-          |> HOLogic.mk_Trueprop
-          |> fold_rev Logic.all ss
-          |> (fn goal => Goal.prove_sorry raw_lthy [] [] goal tac)
-          |> Thm.close_derivation
-          |> Morphism.thm phi
-          |> split_conj_thm
-          |> map (fn thm => thm RS @{thm comp_eq_dest});
-
-        val pre_map_defs = no_refl (map map_def_of_bnf bnfs);
-        val fp_pre_map_defs = no_refl (map map_def_of_bnf pre_bnfs);
-
-        val map_unfoldss = map (maps (fn bnf => no_refl [map_def_of_bnf bnf])) pre_bnfss;
-        val unfold_map = map2 (fn unfs => unfold_thms lthy (id_apply :: unfs)) map_unfoldss;
-
-        val fp_xtor_co_iterss = steal #xtor_co_iter_thmss;
-        val fp_xtor_un_folds = map (mk_pointfree lthy o un_fold_of) fp_xtor_co_iterss |> unfold_map;
-        val fp_xtor_co_recs = map (mk_pointfree lthy o co_rec_of) fp_xtor_co_iterss |> unfold_map;
-
-        val fp_co_iter_o_mapss = steal #xtor_co_iter_o_map_thmss;
-        val fp_fold_o_maps = map un_fold_of fp_co_iter_o_mapss |> unfold_map;
-        val fp_rec_o_maps = map co_rec_of fp_co_iter_o_mapss |> unfold_map;
-        val fold_thms = fp_case fp @{thm o_assoc[symmetric]} @{thm o_assoc} ::
-          @{thms id_apply o_apply o_id id_o map_pair.comp map_pair.id sum_map.comp sum_map.id};
-        val rec_thms = fold_thms @ fp_case fp
-          @{thms fst_convol map_pair_o_convol convol_o}
-          @{thms sum_case_o_inj(1) sum_case_o_sum_map o_sum_case};
-        val map_thms = no_refl (maps (fn bnf =>
-          [map_comp0_of_bnf bnf RS sym, map_id0_of_bnf bnf]) fp_nesty_bnfs);
-
-        fun mk_tac defs o_map_thms xtor_thms thms {context = ctxt, prems = _} =
-          unfold_thms_tac ctxt
-            (flat [thms, defs, pre_map_defs, fp_pre_map_defs, xtor_thms, o_map_thms, map_thms]) THEN
-          CONJ_WRAP (K (HEADGOAL (rtac refl))) bnfs;
-
-        val fold_tac = mk_tac raw_un_fold_defs fp_fold_o_maps fp_xtor_un_folds fold_thms;
-        val rec_tac = mk_tac raw_co_rec_defs fp_rec_o_maps fp_xtor_co_recs rec_thms;
-      in
-        (mk_thms fold_strs fold_goals fold_tac, mk_thms rec_strs rec_goals rec_tac)
-      end;
-
-    (* These results are half broken. This is deliberate. We care only about those fields that are
-       used by "primrec_new", "primcorecursive", and "datatype_new_compat". *)
-    val fp_res =
-      ({Ts = fpTs,
-        bnfs = steal #bnfs,
-        dtors = dtors,
-        ctors = ctors,
-        xtor_co_iterss = transpose [un_folds, co_recs],
-        xtor_co_induct = xtor_co_induct_thm,
-        dtor_ctors = steal #dtor_ctors (*too general types*),
-        ctor_dtors = steal #ctor_dtors (*too general types*),
-        ctor_injects = steal #ctor_injects (*too general types*),
-        dtor_injects = steal #dtor_injects (*too general types*),
-        xtor_map_thms = steal #xtor_map_thms (*too general types and terms*),
-        xtor_set_thmss = steal #xtor_set_thmss (*too general types and terms*),
-        xtor_rel_thms = steal #xtor_rel_thms (*too general types and terms*),
-        xtor_co_iter_thmss = transpose [xtor_un_fold_thms, xtor_co_rec_thms],
-        xtor_co_iter_o_map_thmss = steal #xtor_co_iter_o_map_thmss (*theorem about old constant*),
-        rel_xtor_co_induct_thm = rel_xtor_co_induct_thm}
-       |> morph_fp_result (Morphism.term_morphism "BNF" (singleton (Variable.polymorphic lthy))));
-  in
-    (fp_res, lthy)
-  end;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,394 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_n2m_sugar.ML
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2013
-
-Suggared flattening of nested to mutual (co)recursion.
-*)
-
-signature BNF_FP_N2M_SUGAR =
-sig
-  val unfold_let: term -> term
-  val dest_map: Proof.context -> string -> term -> term * term list
-
-  val mutualize_fp_sugars: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
-    term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> local_theory ->
-    (BNF_FP_Def_Sugar.fp_sugar list
-     * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
-    * local_theory
-  val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list ->
-    term list list list
-  val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
-    (term * term list list) list list -> local_theory ->
-    (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list
-     * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
-    * local_theory
-end;
-
-structure BNF_FP_N2M_Sugar : BNF_FP_N2M_SUGAR =
-struct
-
-open Ctr_Sugar
-open BNF_Util
-open BNF_Def
-open BNF_FP_Util
-open BNF_FP_Def_Sugar
-open BNF_FP_N2M
-
-val n2mN = "n2m_"
-
-type n2m_sugar = fp_sugar list * (lfp_sugar_thms option * gfp_sugar_thms option);
-
-structure Data = Generic_Data
-(
-  type T = n2m_sugar Typtab.table;
-  val empty = Typtab.empty;
-  val extend = I;
-  val merge = Typtab.merge (eq_fst (eq_list eq_fp_sugar));
-);
-
-fun morph_n2m_sugar phi (fp_sugars, (lfp_sugar_thms_opt, gfp_sugar_thms_opt)) =
-  (map (morph_fp_sugar phi) fp_sugars,
-   (Option.map (morph_lfp_sugar_thms phi) lfp_sugar_thms_opt,
-    Option.map (morph_gfp_sugar_thms phi) gfp_sugar_thms_opt));
-
-val transfer_n2m_sugar =
-  morph_n2m_sugar o Morphism.transfer_morphism o Proof_Context.theory_of;
-
-fun n2m_sugar_of ctxt =
-  Typtab.lookup (Data.get (Context.Proof ctxt))
-  #> Option.map (transfer_n2m_sugar ctxt);
-
-fun register_n2m_sugar key n2m_sugar =
-  Local_Theory.declaration {syntax = false, pervasive = false}
-    (fn phi => Data.map (Typtab.default (key, morph_n2m_sugar phi n2m_sugar)));
-
-fun unfold_let (Const (@{const_name Let}, _) $ arg1 $ arg2) = unfold_let (betapply (arg2, arg1))
-  | unfold_let (Const (@{const_name prod_case}, _) $ t) =
-    (case unfold_let t of
-      t' as Abs (s1, T1, Abs (s2, T2, _)) =>
-      let val v = Var ((s1 ^ s2, Term.maxidx_of_term t' + 1), HOLogic.mk_prodT (T1, T2)) in
-        lambda v (incr_boundvars 1 (betapplys (t', [HOLogic.mk_fst v, HOLogic.mk_snd v])))
-      end
-    | _ => t)
-  | unfold_let (t $ u) = betapply (unfold_let t, unfold_let u)
-  | unfold_let (Abs (s, T, t)) = Abs (s, T, unfold_let t)
-  | unfold_let t = t;
-
-fun mk_map_pattern ctxt s =
-  let
-    val bnf = the (bnf_of ctxt s);
-    val mapx = map_of_bnf bnf;
-    val live = live_of_bnf bnf;
-    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
-    val fs = map_index (fn (i, T) => Var (("?f", i), T)) f_Ts;
-  in
-    (mapx, betapplys (mapx, fs))
-  end;
-
-fun dest_map ctxt s call =
-  let
-    val (map0, pat) = mk_map_pattern ctxt s;
-    val (_, tenv) = fo_match ctxt call pat;
-  in
-    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
-  end;
-
-fun dest_abs_or_applied_map _ _ (Abs (_, _, t)) = (Term.dummy, [t])
-  | dest_abs_or_applied_map ctxt s (t1 $ _) = dest_map ctxt s t1;
-
-fun map_partition f xs =
-  fold_rev (fn x => fn (ys, (good, bad)) =>
-      case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad)))
-    xs ([], ([], []));
-
-fun key_of_fp_eqs fp fpTs fp_eqs =
-  Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs);
-
-(* TODO: test with sort constraints on As *)
-fun mutualize_fp_sugars fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
-  let
-    val thy = Proof_Context.theory_of no_defs_lthy0;
-
-    val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
-
-    fun incompatible_calls t1 t2 =
-      error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
-    fun nested_self_call t =
-      error ("Unsupported nested self-call " ^ qsotm t);
-
-    val b_names = map Binding.name_of bs;
-    val fp_b_names = map base_name_of_typ fpTs;
-
-    val nn = length fpTs;
-
-    fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
-      let
-        val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
-        val phi = Morphism.term_morphism "BNF" (Term.subst_TVars rho);
-      in
-        morph_ctr_sugar phi (nth ctr_sugars index)
-      end;
-
-    val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
-    val mapss = map (of_fp_sugar #mapss) fp_sugars0;
-    val ctr_sugars = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
-
-    val ctrss = map #ctrs ctr_sugars;
-    val ctr_Tss = map (map fastype_of) ctrss;
-
-    val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
-    val As = map TFree As';
-
-    val ((Cs, Xs), no_defs_lthy) =
-      no_defs_lthy0
-      |> fold Variable.declare_typ As
-      |> mk_TFrees nn
-      ||>> variant_tfrees fp_b_names;
-
-    fun check_call_dead live_call call =
-      if null (get_indices call) then () else incompatible_calls live_call call;
-
-    fun freeze_fpTs_simple (T as Type (s, Ts)) =
-        (case find_index (curry (op =) T) fpTs of
-          ~1 => Type (s, map freeze_fpTs_simple Ts)
-        | kk => nth Xs kk)
-      | freeze_fpTs_simple T = T;
-
-    fun freeze_fpTs_map (fpT as Type (_, Ts')) (callss, (live_call :: _, dead_calls))
-        (T as Type (s, Ts)) =
-      if Ts' = Ts then
-        nested_self_call live_call
-      else
-        (List.app (check_call_dead live_call) dead_calls;
-         Type (s, map2 (freeze_fpTs fpT) (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
-           (transpose callss)) Ts))
-    and freeze_fpTs fpT calls (T as Type (s, _)) =
-        (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of
-          ([], _) =>
-          (case map_partition (try (snd o dest_abs_or_applied_map no_defs_lthy s)) calls of
-            ([], _) => freeze_fpTs_simple T
-          | callsp => freeze_fpTs_map fpT callsp T)
-        | callsp => freeze_fpTs_map fpT callsp T)
-      | freeze_fpTs _ _ T = T;
-
-    val ctr_Tsss = map (map binder_types) ctr_Tss;
-    val ctrXs_Tsss = map3 (map2 o map2 o freeze_fpTs) fpTs callssss ctr_Tsss;
-    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
-    val ctr_Ts = map (body_type o hd) ctr_Tss;
-
-    val ns = map length ctr_Tsss;
-    val kss = map (fn n => 1 upto n) ns;
-    val mss = map (map length) ctr_Tsss;
-
-    val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
-    val key = key_of_fp_eqs fp fpTs fp_eqs;
-  in
-    (case n2m_sugar_of no_defs_lthy key of
-      SOME n2m_sugar => (n2m_sugar, no_defs_lthy)
-    | NONE =>
-      let
-        val base_fp_names = Name.variant_list [] fp_b_names;
-        val fp_bs = map2 (fn b_name => fn base_fp_name =>
-            Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
-          b_names base_fp_names;
-
-        val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_injects,
-               dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
-          fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
-
-        val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
-        val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
-
-        val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
-          mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
-
-        fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
-
-        val ((co_iterss, co_iter_defss), lthy) =
-          fold_map2 (fn b =>
-            (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
-             else define_coiters [unfoldN, corecN] (the coiters_args_types))
-              (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
-          |>> split_list;
-
-        val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
-              sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
-          if fp = Least_FP then
-            derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
-              xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
-              co_iterss co_iter_defss lthy
-            |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
-              ([induct], fold_thmss, rec_thmss, [], [], [], []))
-            ||> (fn info => (SOME info, NONE))
-          else
-            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
-              dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss
-              ns ctr_defss ctr_sugars co_iterss co_iter_defss
-              (Proof_Context.export lthy no_defs_lthy) lthy
-            |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
-                    (disc_unfold_thmss, disc_corec_thmss, _), _,
-                    (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
-              (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
-               disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
-            ||> (fn info => (NONE, SOME info));
-
-        val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
-
-        fun mk_target_fp_sugar (kk, T) =
-          {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
-           nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
-           ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
-           co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
-           disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
-           sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
-          |> morph_fp_sugar phi;
-
-        val n2m_sugar = (map_index mk_target_fp_sugar fpTs, fp_sugar_thms);
-      in
-        (n2m_sugar, lthy |> register_n2m_sugar key n2m_sugar)
-      end)
-  end;
-
-fun indexify_callsss fp_sugar callsss =
-  let
-    val {ctrs, ...} = of_fp_sugar #ctr_sugars fp_sugar;
-    fun indexify_ctr ctr =
-      (case AList.lookup Term.aconv_untyped callsss ctr of
-        NONE => replicate (num_binder_types (fastype_of ctr)) []
-      | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss);
-  in
-    map indexify_ctr ctrs
-  end;
-
-fun retypargs tyargs (Type (s, _)) = Type (s, tyargs);
-
-fun fold_subtype_pairs f (T as Type (s, Ts), U as Type (s', Us)) =
-    f (T, U) #> (if s = s' then fold (fold_subtype_pairs f) (Ts ~~ Us) else I)
-  | fold_subtype_pairs f TU = f TU;
-
-fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy =
-  let
-    val qsoty = quote o Syntax.string_of_typ lthy;
-    val qsotys = space_implode " or " o map qsoty;
-
-    fun duplicate_datatype T = error (qsoty T ^ " is not mutually recursive with itself");
-    fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
-    fun not_co_datatype (T as Type (s, _)) =
-        if fp = Least_FP andalso
-           is_some (Datatype_Data.get_info (Proof_Context.theory_of lthy) s) then
-          error (qsoty T ^ " is not a new-style datatype (cf. \"datatype_new\")")
-        else
-          not_co_datatype0 T
-      | not_co_datatype T = not_co_datatype0 T;
-    fun not_mutually_nested_rec Ts1 Ts2 =
-      error (qsotys Ts1 ^ " is neither mutually recursive with " ^ qsotys Ts2 ^
-        " nor nested recursive via " ^ qsotys Ts2);
-
-    val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
-
-    val perm_actual_Ts =
-      sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
-
-    fun the_ctrs_of (Type (s, Ts)) = map (mk_ctr Ts) (#ctrs (the (ctr_sugar_of lthy s)));
-
-    fun the_fp_sugar_of (T as Type (T_name, _)) =
-      (case fp_sugar_of lthy T_name of
-        SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
-      | NONE => not_co_datatype T);
-
-    fun gen_rhss_in gen_Ts rho subTs =
-      let
-        fun maybe_insert (T, Type (_, gen_tyargs)) =
-            if member (op =) subTs T then insert (op =) gen_tyargs else I
-          | maybe_insert _ = I;
-
-        val ctrs = maps the_ctrs_of gen_Ts;
-        val gen_ctr_Ts = maps (binder_types o fastype_of) ctrs;
-        val ctr_Ts = map (Term.typ_subst_atomic rho) gen_ctr_Ts;
-      in
-        fold (fold_subtype_pairs maybe_insert) (ctr_Ts ~~ gen_ctr_Ts) []
-      end;
-
-    fun gather_types _ _ num_groups seen gen_seen [] = (num_groups, seen, gen_seen)
-      | gather_types lthy rho num_groups seen gen_seen ((T as Type (_, tyargs)) :: Ts) =
-        let
-          val {fp_res = {Ts = mutual_Ts0, ...}, ...} = the_fp_sugar_of T;
-          val mutual_Ts = map (retypargs tyargs) mutual_Ts0;
-
-          val _ = seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
-            not_mutually_nested_rec mutual_Ts seen;
-
-          fun fresh_tyargs () =
-            let
-              (* The name "'z" is unlikely to clash with the context, yielding more cache hits. *)
-              val (gen_tyargs, lthy') =
-                variant_tfrees (replicate (length tyargs) "z") lthy
-                |>> map Logic.varifyT_global;
-              val rho' = (gen_tyargs ~~ tyargs) @ rho;
-            in
-              (rho', gen_tyargs, gen_seen, lthy')
-            end;
-
-          val (rho', gen_tyargs, gen_seen', lthy') =
-            if exists (exists_subtype_in seen) mutual_Ts then
-              (case gen_rhss_in gen_seen rho mutual_Ts of
-                [] => fresh_tyargs ()
-              | gen_tyargs :: gen_tyargss_tl =>
-                let
-                  val unify_pairs = split_list (maps (curry (op ~~) gen_tyargs) gen_tyargss_tl);
-                  val mgu = Type.raw_unifys unify_pairs Vartab.empty;
-                  val gen_tyargs' = map (Envir.subst_type mgu) gen_tyargs;
-                  val gen_seen' = map (Envir.subst_type mgu) gen_seen;
-                in
-                  (rho, gen_tyargs', gen_seen', lthy)
-                end)
-            else
-              fresh_tyargs ();
-
-          val gen_mutual_Ts = map (retypargs gen_tyargs) mutual_Ts0;
-          val Ts' = filter_out (member (op =) mutual_Ts) Ts;
-        in
-          gather_types lthy' rho' (num_groups + 1) (seen @ mutual_Ts) (gen_seen' @ gen_mutual_Ts)
-            Ts'
-        end
-      | gather_types _ _ _ _ _ (T :: _) = not_co_datatype T;
-
-    val (num_groups, perm_Ts, perm_gen_Ts) = gather_types lthy [] 0 [] [] perm_actual_Ts;
-    val perm_frozen_gen_Ts = map Logic.unvarifyT_global perm_gen_Ts;
-
-    val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
-    val Ts = actual_Ts @ missing_Ts;
-
-    val nn = length Ts;
-    val kks = 0 upto nn - 1;
-
-    val callssss0 = pad_list [] nn actual_callssss0;
-
-    val common_name = mk_common_name (map Binding.name_of actual_bs);
-    val bs = pad_list (Binding.name common_name) nn actual_bs;
-
-    fun permute xs = permute_like (op =) Ts perm_Ts xs;
-    fun unpermute perm_xs = permute_like (op =) perm_Ts Ts perm_xs;
-
-    val perm_bs = permute bs;
-    val perm_kks = permute kks;
-    val perm_callssss0 = permute callssss0;
-    val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts;
-
-    val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0;
-
-    val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices;
-
-    val ((perm_fp_sugars, fp_sugar_thms), lthy) =
-      if num_groups > 1 then
-        mutualize_fp_sugars fp perm_bs perm_frozen_gen_Ts get_perm_indices perm_callssss
-          perm_fp_sugars0 lthy
-      else
-        ((perm_fp_sugars0, (NONE, NONE)), lthy);
-
-    val fp_sugars = unpermute perm_fp_sugars;
-  in
-    ((missing_Ts, perm_kks, fp_sugars, fp_sugar_thms), lthy)
-  end;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_n2m_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,41 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_n2m_tactics.ML
-    Author:     Dmitriy Traytel, TU Muenchen
-    Copyright   2013
-
-Tactics for mutualization of nested (co)datatypes.
-*)
-
-signature BNF_FP_N2M_TACTICS =
-sig
-  val mk_rel_xtor_co_induct_tactic: BNF_FP_Util.fp_kind -> thm list -> thm list -> thm list ->
-    {prems: thm list, context: Proof.context} -> tactic
-end;
-
-structure BNF_FP_N2M_Tactics : BNF_FP_N2M_TACTICS =
-struct
-
-open BNF_Util
-open BNF_FP_Util
-
-fun mk_rel_xtor_co_induct_tactic fp co_inducts rel_defs rel_monos
-  {context = ctxt, prems = raw_C_IHs} =
-  let
-    val unfolds = map (fn def => unfold_thms ctxt (id_apply :: no_reflexive [def])) rel_defs;
-    val folded_C_IHs = map (fn thm => thm RS @{thm spec2} RS mp) raw_C_IHs;
-    val C_IHs = map2 (curry op |>) folded_C_IHs unfolds;
-    val C_IH_monos =
-      map3 (fn C_IH => fn mono => fn unfold =>
-        (mono RSN (2, @{thm rev_predicate2D}), C_IH)
-        |> fp = Greatest_FP ? swap
-        |> op RS
-        |> unfold)
-      folded_C_IHs rel_monos unfolds;
-  in
-    HEADGOAL (CONJ_WRAP_GEN' (rtac @{thm context_conjI})
-      (fn thm => rtac thm THEN_ALL_NEW (rotate_tac ~1 THEN'
-         REPEAT_ALL_NEW (FIRST' [eresolve_tac C_IHs, eresolve_tac C_IH_monos,
-           rtac @{thm order_refl}, atac, resolve_tac co_inducts])))
-    co_inducts)
-  end;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,67 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML
-    Author:     Lorenz Panny, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2013
-
-Library for recursor and corecursor sugar.
-*)
-
-signature BNF_FP_REC_SUGAR_UTIL =
-sig
-  val indexed: 'a list -> int -> int list * int
-  val indexedd: 'a list list -> int -> int list list * int
-  val indexeddd: 'a list list list -> int -> int list list list * int
-  val indexedddd: 'a list list list list -> int -> int list list list list * int
-  val find_index_eq: ''a list -> ''a -> int
-  val finds: ('a * 'b -> bool) -> 'a list -> 'b list -> ('a * 'b list) list * 'b list
-
-  val drop_all: term -> term
-
-  val mk_partial_compN: int -> typ -> term -> term
-  val mk_partial_comp: typ -> typ -> term -> term
-  val mk_compN: int -> typ list -> term * term -> term
-  val mk_comp: typ list -> term * term -> term
-
-  val get_indices: ((binding * typ) * 'a) list -> term -> int list
-end;
-
-structure BNF_FP_Rec_Sugar_Util : BNF_FP_REC_SUGAR_UTIL =
-struct
-
-fun indexe _ h = (h, h + 1);
-fun indexed xs = fold_map indexe xs;
-fun indexedd xss = fold_map indexed xss;
-fun indexeddd xsss = fold_map indexedd xsss;
-fun indexedddd xssss = fold_map indexeddd xssss;
-
-fun find_index_eq hs h = find_index (curry (op =) h) hs;
-
-fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
-
-fun drop_all t =
-  subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
-    strip_qnt_body @{const_name all} t);
-
-fun mk_partial_comp gT fT g =
-  let val T = domain_type fT --> range_type gT in
-    Const (@{const_name Fun.comp}, gT --> fT --> T) $ g
-  end;
-
-fun mk_partial_compN 0 _ g = g
-  | mk_partial_compN n fT g =
-    let val g' = mk_partial_compN (n - 1) (range_type fT) g in
-      mk_partial_comp (fastype_of g') fT g'
-    end;
-
-fun mk_compN n bound_Ts (g, f) =
-  let val typof = curry fastype_of1 bound_Ts in
-    mk_partial_compN n (typof f) g $ f
-  end;
-
-val mk_comp = mk_compN 1;
-
-fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
-  |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
-  |> map_filter I;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_fp_util.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,635 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_fp_util.ML
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
-
-Shared library for the datatype and codatatype constructions.
-*)
-
-signature BNF_FP_UTIL =
-sig
-  datatype fp_kind = Least_FP | Greatest_FP
-  val fp_case: fp_kind -> 'a -> 'a -> 'a
-
-  type fp_result =
-    {Ts: typ list,
-     bnfs: BNF_Def.bnf list,
-     ctors: term list,
-     dtors: term list,
-     xtor_co_iterss: term list list,
-     xtor_co_induct: thm,
-     dtor_ctors: thm list,
-     ctor_dtors: thm list,
-     ctor_injects: thm list,
-     dtor_injects: thm list,
-     xtor_map_thms: thm list,
-     xtor_set_thmss: thm list list,
-     xtor_rel_thms: thm list,
-     xtor_co_iter_thmss: thm list list,
-     xtor_co_iter_o_map_thmss: thm list list,
-     rel_xtor_co_induct_thm: thm}
-
-  val morph_fp_result: morphism -> fp_result -> fp_result
-  val eq_fp_result: fp_result * fp_result -> bool
-  val un_fold_of: 'a list -> 'a
-  val co_rec_of: 'a list -> 'a
-
-  val time: Proof.context -> Timer.real_timer -> string -> Timer.real_timer
-
-  val IITN: string
-  val LevN: string
-  val algN: string
-  val behN: string
-  val bisN: string
-  val carTN: string
-  val caseN: string
-  val coN: string
-  val coinductN: string
-  val corecN: string
-  val ctorN: string
-  val ctor_dtorN: string
-  val ctor_exhaustN: string
-  val ctor_induct2N: string
-  val ctor_inductN: string
-  val ctor_injectN: string
-  val ctor_foldN: string
-  val ctor_fold_o_mapN: string
-  val ctor_fold_transferN: string
-  val ctor_fold_uniqueN: string
-  val ctor_mapN: string
-  val ctor_map_uniqueN: string
-  val ctor_recN: string
-  val ctor_rec_o_mapN: string
-  val ctor_rec_uniqueN: string
-  val ctor_relN: string
-  val ctor_set_inclN: string
-  val ctor_set_set_inclN: string
-  val disc_unfoldN: string
-  val disc_unfold_iffN: string
-  val disc_corecN: string
-  val disc_corec_iffN: string
-  val dtorN: string
-  val dtor_coinductN: string
-  val dtor_corecN: string
-  val dtor_corec_o_mapN: string
-  val dtor_corec_uniqueN: string
-  val dtor_ctorN: string
-  val dtor_exhaustN: string
-  val dtor_injectN: string
-  val dtor_mapN: string
-  val dtor_map_coinductN: string
-  val dtor_map_strong_coinductN: string
-  val dtor_map_uniqueN: string
-  val dtor_relN: string
-  val dtor_set_inclN: string
-  val dtor_set_set_inclN: string
-  val dtor_strong_coinductN: string
-  val dtor_unfoldN: string
-  val dtor_unfold_o_mapN: string
-  val dtor_unfold_transferN: string
-  val dtor_unfold_uniqueN: string
-  val exhaustN: string
-  val foldN: string
-  val hsetN: string
-  val hset_recN: string
-  val inductN: string
-  val injectN: string
-  val isNodeN: string
-  val lsbisN: string
-  val mapN: string
-  val map_uniqueN: string
-  val min_algN: string
-  val morN: string
-  val nchotomyN: string
-  val recN: string
-  val rel_coinductN: string
-  val rel_inductN: string
-  val rel_injectN: string
-  val rel_distinctN: string
-  val rvN: string
-  val sel_corecN: string
-  val set_inclN: string
-  val set_set_inclN: string
-  val sel_unfoldN: string
-  val setN: string
-  val simpsN: string
-  val strTN: string
-  val str_initN: string
-  val strong_coinductN: string
-  val sum_bdN: string
-  val sum_bdTN: string
-  val unfoldN: string
-  val uniqueN: string
-
-  (* TODO: Don't index set facts. Isabelle packages traditionally generate uniform names. *)
-  val mk_ctor_setN: int -> string
-  val mk_dtor_setN: int -> string
-  val mk_dtor_set_inductN: int -> string
-  val mk_set_inductN: int -> string
-
-  val co_prefix: fp_kind -> string
-
-  val base_name_of_typ: typ -> string
-  val mk_common_name: string list -> string
-
-  val split_conj_thm: thm -> thm list
-  val split_conj_prems: int -> thm -> thm
-
-  val mk_sumTN: typ list -> typ
-  val mk_sumTN_balanced: typ list -> typ
-
-  val mk_proj: typ -> int -> int -> term
-
-  val mk_convol: term * term -> term
-
-  val Inl_const: typ -> typ -> term
-  val Inr_const: typ -> typ -> term
-
-  val mk_Inl: typ -> term -> term
-  val mk_Inr: typ -> term -> term
-  val mk_InN: typ list -> term -> int -> term
-  val mk_InN_balanced: typ -> int -> term -> int -> term
-  val mk_sum_case: term * term -> term
-  val mk_sum_caseN: term list -> term
-  val mk_sum_caseN_balanced: term list -> term
-
-  val dest_sumT: typ -> typ * typ
-  val dest_sumTN: int -> typ -> typ list
-  val dest_sumTN_balanced: int -> typ -> typ list
-  val dest_tupleT: int -> typ -> typ list
-
-  val If_const: typ -> term
-
-  val mk_Field: term -> term
-  val mk_If: term -> term -> term -> term
-  val mk_union: term * term -> term
-
-  val mk_sumEN: int -> thm
-  val mk_sumEN_balanced: int -> thm
-  val mk_sumEN_tupled_balanced: int list -> thm
-  val mk_sum_casesN: int -> int -> thm
-  val mk_sum_casesN_balanced: int -> int -> thm
-
-  val fixpoint: ('a * 'a -> bool) -> ('a list -> 'a list) -> 'a list -> 'a list
-
-  val mk_rel_xtor_co_induct_thm: fp_kind -> term list -> term list -> term list -> term list ->
-    term list -> term list -> term list -> term list ->
-    ({prems: thm list, context: Proof.context} -> tactic) -> Proof.context -> thm
-  val mk_un_fold_transfer_thms: fp_kind -> term list -> term list -> term list -> term list ->
-    term list -> term list -> ({prems: thm list, context: Proof.context} -> tactic) ->
-    Proof.context -> thm list
-  val mk_xtor_un_fold_o_map_thms: fp_kind -> bool -> int -> thm -> thm list -> thm list ->
-    thm list -> thm list -> thm list
-
-  val mk_strong_coinduct_thm: thm -> thm list -> thm list -> Proof.context -> thm
-
-  val fp_bnf: (binding list -> (string * sort) list -> typ list * typ list list ->
-      BNF_Def.bnf list -> local_theory -> 'a) ->
-    binding list -> (string * sort) list -> ((string * sort) * typ) list -> local_theory ->
-    BNF_Def.bnf list * 'a
-end;
-
-structure BNF_FP_Util : BNF_FP_UTIL =
-struct
-
-open BNF_Comp
-open BNF_Def
-open BNF_Util
-
-datatype fp_kind = Least_FP | Greatest_FP;
-
-fun fp_case Least_FP l _ = l
-  | fp_case Greatest_FP _ g = g;
-
-type fp_result =
-  {Ts: typ list,
-   bnfs: BNF_Def.bnf list,
-   ctors: term list,
-   dtors: term list,
-   xtor_co_iterss: term list list,
-   xtor_co_induct: thm,
-   dtor_ctors: thm list,
-   ctor_dtors: thm list,
-   ctor_injects: thm list,
-   dtor_injects: thm list,
-   xtor_map_thms: thm list,
-   xtor_set_thmss: thm list list,
-   xtor_rel_thms: thm list,
-   xtor_co_iter_thmss: thm list list,
-   xtor_co_iter_o_map_thmss: thm list list,
-   rel_xtor_co_induct_thm: thm};
-
-fun morph_fp_result phi {Ts, bnfs, ctors, dtors, xtor_co_iterss, xtor_co_induct, dtor_ctors,
-    ctor_dtors, ctor_injects, dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms,
-    xtor_co_iter_thmss, xtor_co_iter_o_map_thmss, rel_xtor_co_induct_thm} =
-  {Ts = map (Morphism.typ phi) Ts,
-   bnfs = map (morph_bnf phi) bnfs,
-   ctors = map (Morphism.term phi) ctors,
-   dtors = map (Morphism.term phi) dtors,
-   xtor_co_iterss = map (map (Morphism.term phi)) xtor_co_iterss,
-   xtor_co_induct = Morphism.thm phi xtor_co_induct,
-   dtor_ctors = map (Morphism.thm phi) dtor_ctors,
-   ctor_dtors = map (Morphism.thm phi) ctor_dtors,
-   ctor_injects = map (Morphism.thm phi) ctor_injects,
-   dtor_injects = map (Morphism.thm phi) dtor_injects,
-   xtor_map_thms = map (Morphism.thm phi) xtor_map_thms,
-   xtor_set_thmss = map (map (Morphism.thm phi)) xtor_set_thmss,
-   xtor_rel_thms = map (Morphism.thm phi) xtor_rel_thms,
-   xtor_co_iter_thmss = map (map (Morphism.thm phi)) xtor_co_iter_thmss,
-   xtor_co_iter_o_map_thmss = map (map (Morphism.thm phi)) xtor_co_iter_o_map_thmss,
-   rel_xtor_co_induct_thm = Morphism.thm phi rel_xtor_co_induct_thm};
-
-fun eq_fp_result ({bnfs = bnfs1, ...} : fp_result, {bnfs = bnfs2, ...} : fp_result) =
-  eq_list eq_bnf (bnfs1, bnfs2);
-
-fun un_fold_of [f, _] = f;
-fun co_rec_of [_, r] = r;
-
-
-fun time ctxt timer msg = (if Config.get ctxt bnf_timing
-  then warning (msg ^ ": " ^ ATP_Util.string_of_time (Timer.checkRealTimer timer))
-  else (); Timer.startRealTimer ());
-
-val preN = "pre_"
-val rawN = "raw_"
-
-val coN = "co"
-val unN = "un"
-val algN = "alg"
-val IITN = "IITN"
-val foldN = "fold"
-val unfoldN = unN ^ foldN
-val uniqueN = "_unique"
-val transferN = "_transfer"
-val simpsN = "simps"
-val ctorN = "ctor"
-val dtorN = "dtor"
-val ctor_foldN = ctorN ^ "_" ^ foldN
-val dtor_unfoldN = dtorN ^ "_" ^ unfoldN
-val ctor_fold_uniqueN = ctor_foldN ^ uniqueN
-val ctor_fold_o_mapN = ctor_foldN ^ "_o_" ^ mapN
-val dtor_unfold_uniqueN = dtor_unfoldN ^ uniqueN
-val dtor_unfold_o_mapN = dtor_unfoldN ^ "_o_" ^ mapN
-val ctor_fold_transferN = ctor_foldN ^ transferN
-val dtor_unfold_transferN = dtor_unfoldN ^ transferN
-val ctor_mapN = ctorN ^ "_" ^ mapN
-val dtor_mapN = dtorN ^ "_" ^ mapN
-val map_uniqueN = mapN ^ uniqueN
-val ctor_map_uniqueN = ctorN ^ "_" ^ map_uniqueN
-val dtor_map_uniqueN = dtorN ^ "_" ^ map_uniqueN
-val min_algN = "min_alg"
-val morN = "mor"
-val bisN = "bis"
-val lsbisN = "lsbis"
-val sum_bdTN = "sbdT"
-val sum_bdN = "sbd"
-val carTN = "carT"
-val strTN = "strT"
-val isNodeN = "isNode"
-val LevN = "Lev"
-val rvN = "recover"
-val behN = "beh"
-val setN = "set"
-val mk_ctor_setN = prefix (ctorN ^ "_") o mk_setN
-val mk_dtor_setN = prefix (dtorN ^ "_") o mk_setN
-fun mk_set_inductN i = mk_setN i ^ "_induct"
-val mk_dtor_set_inductN = prefix (dtorN ^ "_") o mk_set_inductN
-
-val str_initN = "str_init"
-val recN = "rec"
-val corecN = coN ^ recN
-val ctor_recN = ctorN ^ "_" ^ recN
-val ctor_rec_o_mapN = ctor_recN ^ "_o_" ^ mapN
-val ctor_rec_uniqueN = ctor_recN ^ uniqueN
-val dtor_corecN = dtorN ^ "_" ^ corecN
-val dtor_corec_o_mapN = dtor_corecN ^ "_o_" ^ mapN
-val dtor_corec_uniqueN = dtor_corecN ^ uniqueN
-
-val ctor_dtorN = ctorN ^ "_" ^ dtorN
-val dtor_ctorN = dtorN ^ "_" ^ ctorN
-val nchotomyN = "nchotomy"
-val injectN = "inject"
-val exhaustN = "exhaust"
-val ctor_injectN = ctorN ^ "_" ^ injectN
-val ctor_exhaustN = ctorN ^ "_" ^ exhaustN
-val dtor_injectN = dtorN ^ "_" ^ injectN
-val dtor_exhaustN = dtorN ^ "_" ^ exhaustN
-val ctor_relN = ctorN ^ "_" ^ relN
-val dtor_relN = dtorN ^ "_" ^ relN
-val inductN = "induct"
-val coinductN = coN ^ inductN
-val ctor_inductN = ctorN ^ "_" ^ inductN
-val ctor_induct2N = ctor_inductN ^ "2"
-val dtor_map_coinductN = dtor_mapN ^ "_" ^ coinductN
-val dtor_coinductN = dtorN ^ "_" ^ coinductN
-val strong_coinductN = "strong_" ^ coinductN
-val dtor_map_strong_coinductN = dtor_mapN ^ "_" ^ strong_coinductN
-val dtor_strong_coinductN = dtorN ^ "_" ^ strong_coinductN
-val hsetN = "Hset"
-val hset_recN = hsetN ^ "_rec"
-val set_inclN = "set_incl"
-val ctor_set_inclN = ctorN ^ "_" ^ set_inclN
-val dtor_set_inclN = dtorN ^ "_" ^ set_inclN
-val set_set_inclN = "set_set_incl"
-val ctor_set_set_inclN = ctorN ^ "_" ^ set_set_inclN
-val dtor_set_set_inclN = dtorN ^ "_" ^ set_set_inclN
-
-val caseN = "case"
-val discN = "disc"
-val disc_unfoldN = discN ^ "_" ^ unfoldN
-val disc_corecN = discN ^ "_" ^ corecN
-val iffN = "_iff"
-val disc_unfold_iffN = discN ^ "_" ^ unfoldN ^ iffN
-val disc_corec_iffN = discN ^ "_" ^ corecN ^ iffN
-val distinctN = "distinct"
-val rel_distinctN = relN ^ "_" ^ distinctN
-val injectN = "inject"
-val rel_injectN = relN ^ "_" ^ injectN
-val rel_coinductN = relN ^ "_" ^ coinductN
-val rel_inductN = relN ^ "_" ^ inductN
-val selN = "sel"
-val sel_unfoldN = selN ^ "_" ^ unfoldN
-val sel_corecN = selN ^ "_" ^ corecN
-
-fun co_prefix fp = (if fp = Greatest_FP then "co" else "");
-
-fun add_components_of_typ (Type (s, Ts)) =
-    cons (Long_Name.base_name s) #> fold_rev add_components_of_typ Ts
-  | add_components_of_typ _ = I;
-
-fun base_name_of_typ T = space_implode "_" (add_components_of_typ T []);
-
-val mk_common_name = space_implode "_";
-
-fun dest_sumT (Type (@{type_name sum}, [T, T'])) = (T, T');
-
-fun dest_sumTN 1 T = [T]
-  | dest_sumTN n (Type (@{type_name sum}, [T, T'])) = T :: dest_sumTN (n - 1) T';
-
-val dest_sumTN_balanced = Balanced_Tree.dest dest_sumT;
-
-(* TODO: move something like this to "HOLogic"? *)
-fun dest_tupleT 0 @{typ unit} = []
-  | dest_tupleT 1 T = [T]
-  | dest_tupleT n (Type (@{type_name prod}, [T, T'])) = T :: dest_tupleT (n - 1) T';
-
-val mk_sumTN = Library.foldr1 mk_sumT;
-val mk_sumTN_balanced = Balanced_Tree.make mk_sumT;
-
-fun mk_proj T n k =
-  let val (binders, _) = strip_typeN n T in
-    fold_rev (fn T => fn t => Abs (Name.uu, T, t)) binders (Bound (n - k - 1))
-  end;
-
-fun mk_convol (f, g) =
-  let
-    val (fU, fTU) = `range_type (fastype_of f);
-    val ((gT, gU), gTU) = `dest_funT (fastype_of g);
-    val convolT = fTU --> gTU --> gT --> HOLogic.mk_prodT (fU, gU);
-  in Const (@{const_name convol}, convolT) $ f $ g end;
-
-fun Inl_const LT RT = Const (@{const_name Inl}, LT --> mk_sumT (LT, RT));
-fun mk_Inl RT t = Inl_const (fastype_of t) RT $ t;
-
-fun Inr_const LT RT = Const (@{const_name Inr}, RT --> mk_sumT (LT, RT));
-fun mk_Inr LT t = Inr_const LT (fastype_of t) $ t;
-
-fun mk_InN [_] t 1 = t
-  | mk_InN (_ :: Ts) t 1 = mk_Inl (mk_sumTN Ts) t
-  | mk_InN (LT :: Ts) t m = mk_Inr LT (mk_InN Ts t (m - 1))
-  | mk_InN Ts t _ = raise (TYPE ("mk_InN", Ts, [t]));
-
-fun mk_InN_balanced sum_T n t k =
-  let
-    fun repair_types T (Const (s as @{const_name Inl}, _) $ t) = repair_inj_types T s fst t
-      | repair_types T (Const (s as @{const_name Inr}, _) $ t) = repair_inj_types T s snd t
-      | repair_types _ t = t
-    and repair_inj_types T s get t =
-      let val T' = get (dest_sumT T) in
-        Const (s, T' --> T) $ repair_types T' t
-      end;
-  in
-    Balanced_Tree.access {left = mk_Inl dummyT, right = mk_Inr dummyT, init = t} n k
-    |> repair_types sum_T
-  end;
-
-fun mk_sum_case (f, g) =
-  let
-    val fT = fastype_of f;
-    val gT = fastype_of g;
-  in
-    Const (@{const_name sum_case},
-      fT --> gT --> mk_sumT (domain_type fT, domain_type gT) --> range_type fT) $ f $ g
-  end;
-
-val mk_sum_caseN = Library.foldr1 mk_sum_case;
-val mk_sum_caseN_balanced = Balanced_Tree.make mk_sum_case;
-
-fun If_const T = Const (@{const_name If}, HOLogic.boolT --> T --> T --> T);
-fun mk_If p t f = let val T = fastype_of t in If_const T $ p $ t $ f end;
-
-fun mk_Field r =
-  let val T = fst (dest_relT (fastype_of r));
-  in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
-
-val mk_union = HOLogic.mk_binop @{const_name sup};
-
-(*dangerous; use with monotonic, converging functions only!*)
-fun fixpoint eq f X = if subset eq (f X, X) then X else fixpoint eq f (f X);
-
-(* stolen from "~~/src/HOL/Tools/Datatype/datatype_aux.ML" *)
-fun split_conj_thm th =
-  ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
-
-fun split_conj_prems limit th =
-  let
-    fun split n i th =
-      if i = n then th else split n (i + 1) (conjI RSN (i, th)) handle THM _ => th;
-  in split limit 1 th end;
-
-fun mk_sumEN 1 = @{thm one_pointE}
-  | mk_sumEN 2 = @{thm sumE}
-  | mk_sumEN n =
-    (fold (fn i => fn thm => @{thm obj_sumE_f} RSN (i, thm)) (2 upto n - 1) @{thm obj_sumE}) OF
-      replicate n (impI RS allI);
-
-fun mk_obj_sumEN_balanced n =
-  Balanced_Tree.make (fn (thm1, thm2) => thm1 RSN (1, thm2 RSN (2, @{thm obj_sumE_f})))
-    (replicate n asm_rl);
-
-fun mk_sumEN_balanced' n all_impIs = mk_obj_sumEN_balanced n OF all_impIs RS @{thm obj_one_pointE};
-
-fun mk_sumEN_balanced 1 = @{thm one_pointE} (*optimization*)
-  | mk_sumEN_balanced 2 = @{thm sumE} (*optimization*)
-  | mk_sumEN_balanced n = mk_sumEN_balanced' n (replicate n (impI RS allI));
-
-fun mk_tupled_allIN 0 = @{thm unit_all_impI}
-  | mk_tupled_allIN 1 = @{thm impI[THEN allI]}
-  | mk_tupled_allIN 2 = @{thm prod_all_impI} (*optimization*)
-  | mk_tupled_allIN n = mk_tupled_allIN (n - 1) RS @{thm prod_all_impI_step};
-
-fun mk_sumEN_tupled_balanced ms =
-  let val n = length ms in
-    if forall (curry op = 1) ms then mk_sumEN_balanced n
-    else mk_sumEN_balanced' n (map mk_tupled_allIN ms)
-  end;
-
-fun mk_sum_casesN 1 1 = refl
-  | mk_sum_casesN _ 1 = @{thm sum.cases(1)}
-  | mk_sum_casesN 2 2 = @{thm sum.cases(2)}
-  | mk_sum_casesN n k = trans OF [@{thm sum_case_step(2)}, mk_sum_casesN (n - 1) (k - 1)];
-
-fun mk_sum_step base step thm =
-  if Thm.eq_thm_prop (thm, refl) then base else trans OF [step, thm];
-
-fun mk_sum_casesN_balanced 1 1 = refl
-  | mk_sum_casesN_balanced n k =
-    Balanced_Tree.access {left = mk_sum_step @{thm sum.cases(1)} @{thm sum_case_step(1)},
-      right = mk_sum_step @{thm sum.cases(2)} @{thm sum_case_step(2)}, init = refl} n k;
-
-fun mk_rel_xtor_co_induct_thm fp pre_rels pre_phis rels phis xs ys xtors xtor's tac lthy =
-  let
-    val pre_relphis = map (fn rel => Term.list_comb (rel, phis @ pre_phis)) pre_rels;
-    val relphis = map (fn rel => Term.list_comb (rel, phis)) rels;
-    fun mk_xtor fp' xtor x = if fp = fp' then xtor $ x else x;
-    val dtor = mk_xtor Greatest_FP;
-    val ctor = mk_xtor Least_FP;
-    fun flip f x y = if fp = Greatest_FP then f y x else f x y;
-
-    fun mk_prem pre_relphi phi x y xtor xtor' =
-      HOLogic.mk_Trueprop (list_all_free [x, y] (flip (curry HOLogic.mk_imp)
-        (pre_relphi $ (dtor xtor x) $ (dtor xtor' y)) (phi $ (ctor xtor x) $ (ctor xtor' y))));
-    val prems = map6 mk_prem pre_relphis pre_phis xs ys xtors xtor's;
-
-    val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
-      (map2 (flip mk_leq) relphis pre_phis));
-  in
-    Goal.prove_sorry lthy (map (fst o dest_Free) (phis @ pre_phis)) prems concl tac
-    |> Thm.close_derivation
-    |> (fn thm => thm OF (replicate (length pre_rels) @{thm allI[OF allI[OF impI]]}))
-  end;
-
-fun mk_un_fold_transfer_thms fp pre_rels pre_phis rels phis un_folds un_folds' tac lthy =
-  let
-    val pre_relphis = map (fn rel => Term.list_comb (rel, phis @ pre_phis)) pre_rels;
-    val relphis = map (fn rel => Term.list_comb (rel, phis)) rels;
-    fun flip f x y = if fp = Greatest_FP then f y x else f x y;
-
-    val arg_rels = map2 (flip mk_fun_rel) pre_relphis pre_phis;
-    fun mk_transfer relphi pre_phi un_fold un_fold' =
-      fold_rev mk_fun_rel arg_rels (flip mk_fun_rel relphi pre_phi) $ un_fold $ un_fold';
-    val transfers = map4 mk_transfer relphis pre_phis un_folds un_folds';
-
-    val goal = fold_rev Logic.all (phis @ pre_phis)
-      (HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj transfers));
-  in
-    Goal.prove_sorry lthy [] [] goal tac
-    |> Thm.close_derivation
-    |> split_conj_thm
-  end;
-
-fun mk_xtor_un_fold_o_map_thms fp is_rec m un_fold_unique xtor_maps xtor_un_folds sym_map_comps
-    map_cong0s =
-  let
-    val n = length sym_map_comps;
-    val rewrite_comp_comp2 = fp_case fp @{thm rewriteR_comp_comp2} @{thm rewriteL_comp_comp2};
-    val rewrite_comp_comp = fp_case fp @{thm rewriteR_comp_comp} @{thm rewriteL_comp_comp};
-    val map_cong_passive_args1 = replicate m (fp_case fp @{thm id_o} @{thm o_id} RS fun_cong);
-    val map_cong_active_args1 = replicate n (if is_rec
-      then fp_case fp @{thm convol_o} @{thm o_sum_case} RS fun_cong
-      else refl);
-    val map_cong_passive_args2 = replicate m (fp_case fp @{thm o_id} @{thm id_o} RS fun_cong);
-    val map_cong_active_args2 = replicate n (if is_rec
-      then fp_case fp @{thm map_pair_o_convol_id} @{thm sum_case_o_sum_map_id}
-      else fp_case fp @{thm id_o} @{thm o_id} RS fun_cong);
-    fun mk_map_congs passive active = map (fn thm => thm OF (passive @ active) RS ext) map_cong0s;
-    val map_cong1s = mk_map_congs map_cong_passive_args1 map_cong_active_args1;
-    val map_cong2s = mk_map_congs map_cong_passive_args2 map_cong_active_args2;
-    
-    fun mk_rewrites map_congs = map2 (fn sym_map_comp => fn map_cong =>
-      mk_trans sym_map_comp map_cong RS rewrite_comp_comp) sym_map_comps map_congs;
-    val rewrite1s = mk_rewrites map_cong1s;
-    val rewrite2s = mk_rewrites map_cong2s;
-    val unique_prems =
-      map4 (fn xtor_map => fn un_fold => fn rewrite1 => fn rewrite2 =>
-        mk_trans (rewrite_comp_comp2 OF [xtor_map, un_fold])
-          (mk_trans rewrite1 (mk_sym rewrite2)))
-      xtor_maps xtor_un_folds rewrite1s rewrite2s;
-  in
-    split_conj_thm (un_fold_unique OF map (fp_case fp I mk_sym) unique_prems)
-  end;
-
-fun mk_strong_coinduct_thm coind rel_eqs rel_monos ctxt =
-  let
-    val n = Thm.nprems_of coind;
-    val m = Thm.nprems_of (hd rel_monos) - n;
-    fun mk_inst phi = (phi, mk_union (phi, HOLogic.eq_const (fst (dest_pred2T (fastype_of phi)))))
-      |> pairself (certify ctxt);
-    val insts = Term.add_vars (Thm.prop_of coind) [] |> rev |> take n |> map (mk_inst o Var);
-    fun mk_unfold rel_eq rel_mono =
-      let
-        val eq = iffD2 OF [rel_eq RS @{thm predicate2_eqD}, refl];
-        val mono = rel_mono OF (replicate m @{thm order_refl} @ replicate n @{thm eq_subset});
-      in eq RS (mono RS @{thm predicate2D}) RS @{thm eqTrueI} end;
-    val unfolds = map2 mk_unfold rel_eqs rel_monos @ @{thms sup_fun_def sup_bool_def
-      imp_disjL all_conj_distrib subst_eq_imp simp_thms(18,21,35)};
-  in
-    Thm.instantiate ([], insts) coind
-    |> unfold_thms ctxt unfolds
-  end;
-
-fun fp_bnf construct_fp bs resBs fp_eqs lthy =
-  let
-    val time = time lthy;
-    val timer = time (Timer.startRealTimer ());
-    val (Xs, rhsXs) = split_list fp_eqs;
-
-    (* FIXME: because of "@ Xs", the output could contain type variables that are not in the
-       input; also, "fp_sort" should put the "resBs" first and in the order in which they appear *)
-    fun fp_sort Ass =
-      subtract (op =) Xs (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs) @ Xs;
-
-    fun raw_qualify base_b =
-      let val (_, qs, n) = Binding.dest base_b;
-      in
-        Binding.prefix_name rawN
-        #> fold_rev (fn (s, mand) => Binding.qualify mand s) (qs @ [(n, true)])
-        #> Binding.conceal
-      end;
-
-    val ((bnfs, (deadss, livess)), (unfold_set, lthy)) = apfst (apsnd split_list o split_list)
-      (fold_map2 (fn b => bnf_of_typ Smart_Inline (raw_qualify b) fp_sort Xs) bs rhsXs
-        (empty_unfolds, lthy));
-
-    fun norm_qualify i = Binding.qualify true (Binding.name_of (nth bs (Int.max (0, i - 1))))
-      #> Binding.conceal;
-
-    val Ass = map (map dest_TFree) livess;
-    val resDs = fold (subtract (op =)) Ass resBs;
-    val Ds = fold (fold Term.add_tfreesT) deadss [];
-
-    val timer = time (timer "Construction of BNFs");
-
-    val ((kill_poss, _), (bnfs', (unfold_set', lthy'))) =
-      normalize_bnfs norm_qualify Ass Ds fp_sort bnfs unfold_set lthy;
-
-    val Dss = map3 (append oo map o nth) livess kill_poss deadss;
-
-    fun pre_qualify b = Binding.qualify false (Binding.name_of b)
-      #> Config.get lthy' bnf_note_all = false ? Binding.conceal;
-
-    val ((pre_bnfs, deadss), lthy'') =
-      fold_map3 (fn b => seal_bnf (pre_qualify b) unfold_set' (Binding.prefix_name preN b))
-        bs Dss bnfs' lthy'
-      |>> split_list;
-
-    val timer = time (timer "Normalization & sealing of BNFs");
-
-    val res = construct_fp bs resBs (map TFree resDs, deadss) pre_bnfs lthy'';
-
-    val timer = time (timer "FP construction in total");
-  in
-    timer; (pre_bnfs, res)
-  end;
-
-end;
--- a/src/HOL/BNF/Tools/bnf_gfp.ML	Mon Jan 20 18:24:55 2014 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,2827 +0,0 @@
-(*  Title:      HOL/BNF/Tools/bnf_gfp.ML
-    Author:     Dmitriy Traytel, TU Muenchen
-    Author:     Andrei Popescu, TU Muenchen
-    Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012
-
-Codatatype construction.
-*)
-
-signature BNF_GFP =
-sig
-  val construct_gfp: mixfix list -> binding list -> binding list -> binding list list ->
-    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
-    local_theory -> BNF_FP_Util.fp_result * local_theory
-end;
-
-structure BNF_GFP : BNF_GFP =
-struct
-
-open BNF_Def
-open BNF_Util
-open BNF_Tactics
-open BNF_Comp
-open BNF_FP_Util
-open BNF_FP_Def_Sugar
-open BNF_GFP_Rec_Sugar
-open BNF_GFP_Util
-open BNF_GFP_Tactics
-
-datatype wit_tree = Wit_Leaf of int | Wit_Node of (int * int * int list) * wit_tree list;
-
-fun mk_tree_args (I, T) (I', Ts) = (sort_distinct int_ord (I @ I'), T :: Ts);
-
-fun finish Iss m seen i (nwit, I) =
-  let
-    val treess = map (fn j =>
-        if j < m orelse member (op =) seen j then [([j], Wit_Leaf j)]
-        else
-          map_index (finish Iss m (insert (op =) j seen) j) (nth Iss (j - m))
-          |> flat
-          |> minimize_wits)
-      I;
-  in
-    map (fn (I, t) => (I, Wit_Node ((i - m, nwit, filter (fn i => i < m) I), t)))
-      (fold_rev (map_product mk_tree_args) treess [([], [])])
-    |> minimize_wits
-  end;
-
-fun tree_to_ctor_wit vars _ _ (Wit_Leaf j) = ([j], nth vars j)
-  | tree_to_ctor_wit vars ctors witss (Wit_Node ((i, nwit, I), subtrees)) =
-     (I, nth ctors i $ (Term.list_comb (snd (nth (nth witss i) nwit),
-       map (snd o tree_to_ctor_wit vars ctors witss) subtrees)));
-
-fun tree_to_coind_wits _ (Wit_Leaf _) = []
-  | tree_to_coind_wits lwitss (Wit_Node ((i, nwit, I), subtrees)) =
-     ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
-
-(*all BNFs have the same lives*)
-fun construct_gfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs lthy =
-  let
-    val time = time lthy;
-    val timer = time (Timer.startRealTimer ());
-
-    val live = live_of_bnf (hd bnfs);
-    val n = length bnfs; (*active*)
-    val ks = 1 upto n;
-    val m = live - n; (*passive, if 0 don't generate a new BNF*)
-    val ls = 1 upto m;
-
-    val note_all = Config.get lthy bnf_note_all;
-    val b_names = map Binding.name_of bs;
-    val b_name = mk_common_name b_names;
-    val b = Binding.name b_name;
-    val mk_internal_b = Binding.name #> Binding.prefix true b_name #> Binding.conceal;
-    fun mk_internal_bs name =
-      map (fn b =>
-        Binding.prefix true b_name (Binding.prefix_name (name ^ "_") b) |> Binding.conceal) bs;
-    val external_bs = map2 (Binding.prefix false) b_names bs
-      |> note_all = false ? map Binding.conceal;
-
-    (* TODO: check if m, n, etc., are sane *)
-
-    val deads = fold (union (op =)) Dss resDs;
-    val names_lthy = fold Variable.declare_typ deads lthy;
-    val passives = map fst (subtract (op = o apsnd TFree) deads resBs);
-
-    (* tvars *)
-    val ((((((passiveAs, activeAs), passiveBs), activeBs), passiveCs), activeCs), idxT) = names_lthy
-      |> variant_tfrees passives
-      ||>> mk_TFrees n
-      ||>> variant_tfrees passives
-      ||>> mk_TFrees n
-      ||>> mk_TFrees m
-      ||>> mk_TFrees n
-      ||> fst o mk_TFrees 1
-      ||> the_single;
-
-    val allAs = passiveAs @ activeAs;
-    val allBs' = passiveBs @ activeBs;
-    val Ass = replicate n allAs;
-    val allBs = passiveAs @ activeBs;
-    val Bss = replicate n allBs;
-    val allCs = passiveAs @ activeCs;
-    val allCs' = passiveBs @ activeCs;
-    val Css' = replicate n allCs';
-
-    (* types *)
-    val dead_poss =
-      map (fn x => if member (op =) deads (TFree x) then SOME (TFree x) else NONE) resBs;
-    fun mk_param NONE passive = (hd passive, tl passive)
-      | mk_param (SOME a) passive = (a, passive);
-    val mk_params = fold_map mk_param dead_poss #> fst;
-
-    fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
-    val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
-    val (dead_params, dead_params') = `(map Term.dest_TFree) (subtract (op =) passiveAs params');
-    val FTsAs = mk_FTs allAs;
-    val FTsBs = mk_FTs allBs;
-    val FTsCs = mk_FTs allCs;
-    val ATs = map HOLogic.mk_setT passiveAs;
-    val BTs = map HOLogic.mk_setT activeAs;
-    val B'Ts = map HOLogic.mk_setT activeBs;
-    val B''Ts = map HOLogic.mk_setT activeCs;
-    val sTs = map2 (fn T => fn U => T --> U) activeAs FTsAs;
-    val s'Ts = map2 (fn T => fn U => T --> U) activeBs FTsBs;
-    val s''Ts = map2 (fn T => fn U => T --> U) activeCs FTsCs;
-    val fTs = map2 (fn T => fn U => T --> U) activeAs activeBs;
-    val self_fTs = map (fn T => T --> T) activeAs;
-    val gTs = map2 (fn T => fn U => T --> U) activeBs activeCs;
-    val all_gTs = map2 (fn T => fn U => T --> U) allBs allCs';
-    val RTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeBs;
-    val sRTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeAs;
-    val R'Ts = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeBs activeCs;
-    val setsRTs = map HOLogic.mk_setT sRTs;
-    val setRTs = map HOLogic.mk_setT RTs;
-    val all_sbisT = HOLogic.mk_tupleT setsRTs;
-    val setR'Ts = map HOLogic.mk_setT R'Ts;
-    val FRTs = mk_FTs (passiveAs @ RTs);
-    val sumBsAs = map2 (curry mk_sumT) activeBs activeAs;
-    val sumFTs = mk_FTs (passiveAs @ sumBsAs);
-    val sum_sTs = map2 (fn T => fn U => T --> U) activeAs sumFTs;
-
-    (* terms *)
-    val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
-    val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
-    val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
-    val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
-    val map_Inls = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ sumBsAs)) bnfs;
-    val map_Inls_rev = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ sumBsAs)) Bss bnfs;
-    val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Ass bnfs;
-    val map_snds = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Bss bnfs;
-    fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
-      (map (replicate live) (replicate n Ts)) bnfs;
-    val setssAs = mk_setss allAs;
-    val setssAs' = transpose setssAs;
-    val bis_setss = mk_setss (passiveAs @ RTs);
-    val relsAsBs = map4 mk_rel_of_bnf Dss Ass Bss bnfs;
-    val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
-    val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
-    val sum_bdT = fst (dest_relT (fastype_of sum_bd));
-
-    val emptys = map (fn T => HOLogic.mk_set T []) passiveAs;
-    val Zeros = map (fn empty =>
-     HOLogic.mk_tuple (map (fn U => absdummy U empty) activeAs)) emptys;
-    val hrecTs = map fastype_of Zeros;
-    val hsetTs = map (fn hrecT => Library.foldr (op -->) (sTs, HOLogic.natT --> hrecT)) hrecTs;
-
-    val (((((((((((((((((((((((((((((((((((zs, zs'), zs_copy), zs_copy2), z's), (ys, ys')),
-      As), Bs), Bs_copy), B's), B''s), ss), sum_ss), s's), s''s), fs), fs_copy),
-      self_fs), gs), all_gs), xFs), yFs), yFs_copy), RFs), (Rtuple, Rtuple')), (hrecs, hrecs')),
-      (nat, nat')), Rs), Rs_copy), R's), sRs), (idx, idx')), Idx), Ris), Kss), names_lthy) = lthy
-      |> mk_Frees' "b" activeAs
-      ||>> mk_Frees "b" activeAs
-      ||>> mk_Frees "b" activeAs
-      ||>> mk_Frees "b" activeBs
-      ||>> mk_Frees' "y" passiveAs
-      ||>> mk_Frees "A" ATs
-      ||>> mk_Frees "B" BTs
-      ||>> mk_Frees "B" BTs
-      ||>> mk_Frees "B'" B'Ts
-      ||>> mk_Frees "B''" B''Ts
-      ||>> mk_Frees "s" sTs
-      ||>> mk_Frees "sums" sum_sTs
-      ||>> mk_Frees "s'" s'Ts
-      ||>> mk_Frees "s''" s''Ts
-      ||>> mk_Frees "f" fTs
-      ||>> mk_Frees "f" fTs
-      ||>> mk_Frees "f" self_fTs
-      ||>> mk_Frees "g" gTs
-      ||>> mk_Frees "g" all_gTs
-      ||>> mk_Frees "x" FTsAs
-      ||>> mk_Frees "y" FTsBs
-      ||>> mk_Frees "y" FTsBs
-      ||>> mk_Frees "x" FRTs
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Rtuple") all_sbisT
-      ||>> mk_Frees' "rec" hrecTs
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "n") HOLogic.natT
-      ||>> mk_Frees "R" setRTs
-      ||>> mk_Frees "R" setRTs
-      ||>> mk_Frees "R'" setR'Ts
-      ||>> mk_Frees "R" setsRTs
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "i") idxT
-      ||>> yield_singleton (mk_Frees "I") (HOLogic.mk_setT idxT)
-      ||>> mk_Frees "Ri" (map (fn T => idxT --> T) setRTs)
-      ||>> mk_Freess "K" (map (fn AT => map (fn T => T --> AT) activeAs) ATs);
-
-    val passive_UNIVs = map HOLogic.mk_UNIV passiveAs;
-    val passive_Id_ons = map mk_Id_on As;
-    val active_UNIVs = map HOLogic.mk_UNIV activeAs;
-    val sum_UNIVs = map HOLogic.mk_UNIV sumBsAs;
-    val passive_ids = map HOLogic.id_const passiveAs;
-    val active_ids = map HOLogic.id_const activeAs;
-    val Inls = map2 Inl_const activeBs activeAs;
-    val fsts = map fst_const RTs;
-    val snds = map snd_const RTs;
-
-    (* thms *)
-    val bd_card_orders = map bd_card_order_of_bnf bnfs;
-    val bd_card_order = hd bd_card_orders
-    val bd_Card_orders = map bd_Card_order_of_bnf bnfs;
-    val bd_Card_order = hd bd_Card_orders;
-    val bd_Cinfinites = map bd_Cinfinite_of_bnf bnfs;
-    val bd_Cinfinite = hd bd_Cinfinites;
-    val in_monos = map in_mono_of_bnf bnfs;
-    val map_comp0s = map map_comp0_of_bnf bnfs;
-    val sym_map_comps = map mk_sym map_comp0s;
-    val map_comps = map map_comp_of_bnf bnfs;
-    val map_cong0s = map map_cong0_of_bnf bnfs;
-    val map_id0s = map map_id0_of_bnf bnfs;
-    val map_ids = map map_id_of_bnf bnfs;
-    val set_bdss = map set_bd_of_bnf bnfs;
-    val set_mapss = map set_map_of_bnf bnfs;
-    val rel_congs = map rel_cong_of_bnf bnfs;
-    val rel_converseps = map rel_conversep_of_bnf bnfs;
-    val rel_Grps = map rel_Grp_of_bnf bnfs;
-    val rel_OOs = map rel_OO_of_bnf bnfs;
-    val rel_OO_Grps = map rel_OO_Grp_of_bnf bnfs;
-
-    val timer = time (timer "Extracted terms & thms");
-
-    (* derived thms *)
-
-    (*map g1 ... gm g(m+1) ... g(m+n) (map id ... id f(m+1) ... f(m+n) x) =
-      map g1 ... gm (g(m+1) o f(m+1)) ... (g(m+n) o f(m+n)) x*)
-    fun mk_map_comp_id x mapAsBs mapBsCs mapAsCs map_comp0 =
-      let
-        val lhs = Term.list_comb (mapBsCs, all_gs) $
-          (Term.list_comb (mapAsBs, passive_ids @ fs) $ x);
-        val rhs =
-          Term.list_comb (mapAsCs, take m all_gs @ map HOLogic.mk_comp (drop m all_gs ~~ fs)) $ x;
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (x :: fs @ all_gs) (mk_Trueprop_eq (lhs, rhs)))
-          (K (mk_map_comp_id_tac map_comp0))
-        |> Thm.close_derivation
-      end;
-
-    val map_comp_id_thms = map5 mk_map_comp_id xFs mapsAsBs mapsBsCs' mapsAsCs' map_comps;
-
-    (*forall a : set(m+1) x. f(m+1) a = a; ...; forall a : set(m+n) x. f(m+n) a = a ==>
-      map id ... id f(m+1) ... f(m+n) x = x*)
-    fun mk_map_cong0L x mapAsAs sets map_cong0 map_id =
-      let
-        fun mk_prem set f z z' =
-          HOLogic.mk_Trueprop
-            (mk_Ball (set $ x) (Term.absfree z' (HOLogic.mk_eq (f $ z, z))));
-        val prems = map4 mk_prem (drop m sets) self_fs zs zs';
-        val goal = mk_Trueprop_eq (Term.list_comb (mapAsAs, passive_ids @ self_fs) $ x, x);
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (x :: self_fs) (Logic.list_implies (prems, goal)))
-          (K (mk_map_cong0L_tac m map_cong0 map_id))
-        |> Thm.close_derivation
-      end;
-
-    val map_cong0L_thms = map5 mk_map_cong0L xFs mapsAsAs setssAs map_cong0s map_ids;
-    val in_mono'_thms = map (fn thm =>
-      (thm OF (replicate m subset_refl)) RS @{thm set_mp}) in_monos;
-
-    val map_arg_cong_thms =
-      let
-        val prems = map2 (curry mk_Trueprop_eq) yFs yFs_copy;
-        val maps = map (fn mapx => Term.list_comb (mapx, all_gs)) mapsBsCs';
-        val concls =
-          map3 (fn x => fn y => fn mapx => mk_Trueprop_eq (mapx $ x, mapx $ y)) yFs yFs_copy maps;
-        val goals =
-          map4 (fn prem => fn concl => fn x => fn y =>
-            fold_rev Logic.all (x :: y :: all_gs) (Logic.mk_implies (prem, concl)))
-          prems concls yFs yFs_copy;
-      in
-        map (fn goal => Goal.prove_sorry lthy [] [] goal
-          (K ((hyp_subst_tac lthy THEN' rtac refl) 1)) |> Thm.close_derivation) goals
-      end;
-
-    val timer = time (timer "Derived simple theorems");
-
-    (* coalgebra *)
-
-    val coalg_bind = mk_internal_b (coN ^ algN) ;
-    val coalg_name = Binding.name_of coalg_bind;
-    val coalg_def_bind = (Thm.def_binding coalg_bind, []);
-
-    (*forall i = 1 ... n: (\<forall>x \<in> Bi. si \<in> Fi_in A1 .. Am B1 ... Bn)*)
-    val coalg_spec =
-      let
-        val coalgT = Library.foldr (op -->) (ATs @ BTs @ sTs, HOLogic.boolT);
-
-        val ins = map3 mk_in (replicate n (As @ Bs)) setssAs FTsAs;
-        fun mk_coalg_conjunct B s X z z' =
-          mk_Ball B (Term.absfree z' (HOLogic.mk_mem (s $ z, X)));
-
-        val lhs = Term.list_comb (Free (coalg_name, coalgT), As @ Bs @ ss);
-        val rhs = Library.foldr1 HOLogic.mk_conj (map5 mk_coalg_conjunct Bs ss ins zs zs')
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((coalg_free, (_, coalg_def_free)), (lthy, lthy_old)) =
-      lthy
-      |> Specification.definition (SOME (coalg_bind, NONE, NoSyn), (coalg_def_bind, coalg_spec))
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-    val coalg = fst (Term.dest_Const (Morphism.term phi coalg_free));
-    val coalg_def = Morphism.thm phi coalg_def_free;
-
-    fun mk_coalg As Bs ss =
-      let
-        val args = As @ Bs @ ss;
-        val Ts = map fastype_of args;
-        val coalgT = Library.foldr (op -->) (Ts, HOLogic.boolT);
-      in
-        Term.list_comb (Const (coalg, coalgT), args)
-      end;
-
-    val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
-
-    val coalg_in_thms = map (fn i =>
-      coalg_def RS iffD1 RS mk_conjunctN n i RS bspec) ks
-
-    val coalg_set_thmss =
-      let
-        val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
-        fun mk_prem x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B));
-        fun mk_concl s x B set = HOLogic.mk_Trueprop (mk_leq (set $ (s $ x)) B);
-        val prems = map2 mk_prem zs Bs;
-        val conclss = map3 (fn s => fn x => fn sets => map2 (mk_concl s x) (As @ Bs) sets)
-          ss zs setssAs;
-        val goalss = map3 (fn x => fn prem => fn concls => map (fn concl =>
-          fold_rev Logic.all (x :: As @ Bs @ ss)
-            (Logic.list_implies (coalg_prem :: [prem], concl))) concls) zs prems conclss;
-      in
-        map (fn goals => map (fn goal => Goal.prove_sorry lthy [] [] goal
-          (K (mk_coalg_set_tac coalg_def)) |> Thm.close_derivation) goals) goalss
-      end;
-
-    fun mk_tcoalg ATs BTs = mk_coalg (map HOLogic.mk_UNIV ATs) (map HOLogic.mk_UNIV BTs);
-
-    val tcoalg_thm =
-      let
-        val goal = fold_rev Logic.all ss
-          (HOLogic.mk_Trueprop (mk_tcoalg passiveAs activeAs ss))
-      in
-        Goal.prove_sorry lthy [] [] goal
-          (K (stac coalg_def 1 THEN CONJ_WRAP
-            (K (EVERY' [rtac ballI, rtac CollectI,
-              CONJ_WRAP' (K (EVERY' [rtac @{thm subset_UNIV}])) allAs] 1)) ss))
-        |> Thm.close_derivation
-      end;
-
-    val timer = time (timer "Coalgebra definition & thms");
-
-    (* morphism *)
-
-    val mor_bind = mk_internal_b morN;
-    val mor_name = Binding.name_of mor_bind;
-    val mor_def_bind = (Thm.def_binding mor_bind, []);
-
-    (*fbetw) forall i = 1 ... n: (\<forall>x \<in> Bi. fi x \<in> B'i)*)
-    (*mor) forall i = 1 ... n: (\<forall>x \<in> Bi.
-       Fi_map id ... id f1 ... fn (si x) = si' (fi x)*)
-    val mor_spec =
-      let
-        val morT = Library.foldr (op -->) (BTs @ sTs @ B'Ts @ s'Ts @ fTs, HOLogic.boolT);
-
-        fun mk_fbetw f B1 B2 z z' =
-          mk_Ball B1 (Term.absfree z' (HOLogic.mk_mem (f $ z, B2)));
-        fun mk_mor B mapAsBs f s s' z z' =
-          mk_Ball B (Term.absfree z' (HOLogic.mk_eq
-            (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ z]), s' $ (f $ z))));
-        val lhs = Term.list_comb (Free (mor_name, morT), Bs @ ss @ B's @ s's @ fs);
-        val rhs = HOLogic.mk_conj
-          (Library.foldr1 HOLogic.mk_conj (map5 mk_fbetw fs Bs B's zs zs'),
-           Library.foldr1 HOLogic.mk_conj (map7 mk_mor Bs mapsAsBs fs ss s's zs zs'))
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((mor_free, (_, mor_def_free)), (lthy, lthy_old)) =
-      lthy
-      |> Specification.definition (SOME (mor_bind, NONE, NoSyn), (mor_def_bind, mor_spec))
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-    val mor = fst (Term.dest_Const (Morphism.term phi mor_free));
-    val mor_def = Morphism.thm phi mor_def_free;
-
-    fun mk_mor Bs1 ss1 Bs2 ss2 fs =
-      let
-        val args = Bs1 @ ss1 @ Bs2 @ ss2 @ fs;
-        val Ts = map fastype_of (Bs1 @ ss1 @ Bs2 @ ss2 @ fs);
-        val morT = Library.foldr (op -->) (Ts, HOLogic.boolT);
-      in
-        Term.list_comb (Const (mor, morT), args)
-      end;
-
-    val mor_prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
-
-    val (mor_image_thms, morE_thms) =
-      let
-        val prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
-        fun mk_image_goal f B1 B2 = fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs)
-          (Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_leq (mk_image f $ B1) B2)));
-        val image_goals = map3 mk_image_goal fs Bs B's;
-        fun mk_elim_goal B mapAsBs f s s' x =
-          fold_rev Logic.all (x :: Bs @ ss @ B's @ s's @ fs)
-            (Logic.list_implies ([prem, HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B))],
-              mk_Trueprop_eq (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ x]), s' $ (f $ x))));
-        val elim_goals = map6 mk_elim_goal Bs mapsAsBs fs ss s's zs;
-        fun prove goal =
-          Goal.prove_sorry lthy [] [] goal (K (mk_mor_elim_tac mor_def))
-          |> Thm.close_derivation;
-      in
-        (map prove image_goals, map prove elim_goals)
-      end;
-
-    val mor_image'_thms = map (fn thm => @{thm set_mp} OF [thm, imageI]) mor_image_thms;
-
-    val mor_incl_thm =
-      let
-        val prems = map2 (HOLogic.mk_Trueprop oo mk_leq) Bs Bs_copy;
-        val concl = HOLogic.mk_Trueprop (mk_mor Bs ss Bs_copy ss active_ids);
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (Bs @ ss @ Bs_copy) (Logic.list_implies (prems, concl)))
-          (K (mk_mor_incl_tac mor_def map_ids))
-        |> Thm.close_derivation
-      end;
-
-    val mor_id_thm = mor_incl_thm OF (replicate n subset_refl);
-
-    val mor_comp_thm =
-      let
-        val prems =
-          [HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs),
-           HOLogic.mk_Trueprop (mk_mor B's s's B''s s''s gs)];
-        val concl =
-          HOLogic.mk_Trueprop (mk_mor Bs ss B''s s''s (map2 (curry HOLogic.mk_comp) gs fs));
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (Bs @ ss @ B's @ s's @ B''s @ s''s @ fs @ gs)
-            (Logic.list_implies (prems, concl)))
-          (K (mk_mor_comp_tac mor_def mor_image'_thms morE_thms map_comp_id_thms))
-        |> Thm.close_derivation
-      end;
-
-    val mor_cong_thm =
-      let
-        val prems = map HOLogic.mk_Trueprop
-         (map2 (curry HOLogic.mk_eq) fs_copy fs @ [mk_mor Bs ss B's s's fs])
-        val concl = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs_copy);
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ fs_copy)
-            (Logic.list_implies (prems, concl)))
-          (K ((hyp_subst_tac lthy THEN' atac) 1))
-        |> Thm.close_derivation
-      end;
-
-    val mor_UNIV_thm =
-      let
-        fun mk_conjunct mapAsBs f s s' = HOLogic.mk_eq
-            (HOLogic.mk_comp (Term.list_comb (mapAsBs, passive_ids @ fs), s),
-            HOLogic.mk_comp (s', f));
-        val lhs = mk_mor active_UNIVs ss (map HOLogic.mk_UNIV activeBs) s's fs;
-        val rhs = Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct mapsAsBs fs ss s's);
-      in
-        Goal.prove_sorry lthy [] [] (fold_rev Logic.all (ss @ s's @ fs) (mk_Trueprop_eq (lhs, rhs)))
-          (K (mk_mor_UNIV_tac morE_thms mor_def))
-        |> Thm.close_derivation
-      end;
-
-    val mor_str_thm =
-      let
-        val maps = map2 (fn Ds => fn bnf => Term.list_comb
-          (mk_map_of_bnf Ds allAs (passiveAs @ FTsAs) bnf, passive_ids @ ss)) Dss bnfs;
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all ss (HOLogic.mk_Trueprop
-            (mk_mor active_UNIVs ss (map HOLogic.mk_UNIV FTsAs) maps ss)))
-          (K (mk_mor_str_tac ks mor_UNIV_thm))
-        |> Thm.close_derivation
-      end;
-
-    val mor_sum_case_thm =
-      let
-        val maps = map3 (fn s => fn sum_s => fn mapx =>
-          mk_sum_case (HOLogic.mk_comp (Term.list_comb (mapx, passive_ids @ Inls), s), sum_s))
-          s's sum_ss map_Inls;
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (s's @ sum_ss) (HOLogic.mk_Trueprop
-            (mk_mor (map HOLogic.mk_UNIV activeBs) s's sum_UNIVs maps Inls)))
-          (K (mk_mor_sum_case_tac ks mor_UNIV_thm))
-        |> Thm.close_derivation
-      end;
-
-    val timer = time (timer "Morphism definition & thms");
-
-    fun hset_rec_bind j = mk_internal_b (hset_recN ^ (if m = 1 then "" else string_of_int j));
-    val hset_rec_name = Binding.name_of o hset_rec_bind;
-    val hset_rec_def_bind = rpair [] o Thm.def_binding o hset_rec_bind;
-
-    fun hset_rec_spec j Zero hsetT hrec hrec' =
-      let
-        fun mk_Suc s setsAs z z' =
-          let
-            val (set, sets) = apfst (fn xs => nth xs (j - 1)) (chop m setsAs);
-            fun mk_UN set k = mk_UNION (set $ (s $ z)) (mk_nthN n hrec k);
-          in
-            Term.absfree z'
-              (mk_union (set $ (s $ z), Library.foldl1 mk_union (map2 mk_UN sets ks)))
-          end;
-
-        val Suc = Term.absdummy HOLogic.natT (Term.absfree hrec'
-          (HOLogic.mk_tuple (map4 mk_Suc ss setssAs zs zs')));
-
-        val lhs = Term.list_comb (Free (hset_rec_name j, hsetT), ss);
-        val rhs = mk_nat_rec Zero Suc;
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((hset_rec_frees, (_, hset_rec_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map5 (fn j => fn Zero => fn hsetT => fn hrec => fn hrec' => Specification.definition
-        (SOME (hset_rec_bind j, NONE, NoSyn),
-          (hset_rec_def_bind j, hset_rec_spec j Zero hsetT hrec hrec')))
-        ls Zeros hsetTs hrecs hrecs'
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val hset_rec_defs = map (Morphism.thm phi) hset_rec_def_frees;
-    val hset_recs = map (fst o Term.dest_Const o Morphism.term phi) hset_rec_frees;
-
-    fun mk_hset_rec ss nat i j T =
-      let
-        val args = ss @ [nat];
-        val Ts = map fastype_of ss;
-        val bTs = map domain_type Ts;
-        val hrecT = HOLogic.mk_tupleT (map (fn U => U --> HOLogic.mk_setT T) bTs)
-        val hset_recT = Library.foldr (op -->) (Ts, HOLogic.natT --> hrecT);
-      in
-        mk_nthN n (Term.list_comb (Const (nth hset_recs (j - 1), hset_recT), args)) i
-      end;
-
-    val hset_rec_0ss = mk_rec_simps n @{thm nat_rec_0} hset_rec_defs;
-    val hset_rec_Sucss = mk_rec_simps n @{thm nat_rec_Suc} hset_rec_defs;
-    val hset_rec_0ss' = transpose hset_rec_0ss;
-    val hset_rec_Sucss' = transpose hset_rec_Sucss;
-
-    fun hset_binds j = mk_internal_bs (hsetN ^ (if m = 1 then "" else string_of_int j))
-    fun hset_bind i j = nth (hset_binds j) (i - 1);
-    val hset_name = Binding.name_of oo hset_bind;
-    val hset_def_bind = rpair [] o Thm.def_binding oo hset_bind;
-
-    fun hset_spec i j =
-      let
-        val U = nth activeAs (i - 1);
-        val z = nth zs (i - 1);
-        val T = nth passiveAs (j - 1);
-        val setT = HOLogic.mk_setT T;
-        val hsetT = Library.foldr (op -->) (sTs, U --> setT);
-
-        val lhs = Term.list_comb (Free (hset_name i j, hsetT), ss @ [z]);
-        val rhs = mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
-          (Term.absfree nat' (mk_hset_rec ss nat i j T $ z));
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((hset_frees, (_, hset_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map (fn i => fold_map (fn j => Specification.definition
-        (SOME (hset_bind i j, NONE, NoSyn), (hset_def_bind i j, hset_spec i j))) ls) ks
-      |>> map (apsnd split_list o split_list)
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val hset_defss = map (map (Morphism.thm phi)) hset_def_frees;
-    val hset_defss' = transpose hset_defss;
-    val hset_namess = map (map (fst o Term.dest_Const o Morphism.term phi)) hset_frees;
-
-    fun mk_hset ss i j T =
-      let
-        val Ts = map fastype_of ss;
-        val bTs = map domain_type Ts;
-        val hsetT = Library.foldr (op -->) (Ts, nth bTs (i - 1) --> HOLogic.mk_setT T);
-      in
-        Term.list_comb (Const (nth (nth hset_namess (i - 1)) (j - 1), hsetT), ss)
-      end;
-
-    val hsetssAs = map (fn i => map2 (mk_hset ss i) ls passiveAs) ks;
-
-    val (set_incl_hset_thmss, set_hset_incl_hset_thmsss) =
-      let
-        fun mk_set_incl_hset s x set hset = fold_rev Logic.all (x :: ss)
-          (HOLogic.mk_Trueprop (mk_leq (set $ (s $ x)) (hset $ x)));
-
-        fun mk_set_hset_incl_hset s x y set hset1 hset2 =
-          fold_rev Logic.all (x :: y :: ss)
-            (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x, set $ (s $ y))),
-            HOLogic.mk_Trueprop (mk_leq (hset1 $ x) (hset2 $ y))));
-
-        val set_incl_hset_goalss =
-          map4 (fn s => fn x => fn sets => fn hsets =>
-            map2 (mk_set_incl_hset s x) (take m sets) hsets)
-          ss zs setssAs hsetssAs;
-
-        (*xk : F(i)set(m+k) (si yi) ==> F(k)_hset(j) s1 ... sn xk <= F(i)_hset(j) s1 ... sn yi*)
-        val set_hset_incl_hset_goalsss =
-          map4 (fn si => fn yi => fn sets => fn hsetsi =>
-            map3 (fn xk => fn set => fn hsetsk =>
-              map2 (mk_set_hset_incl_hset si xk yi set) hsetsk hsetsi)
-            zs_copy (drop m sets) hsetssAs)
-          ss zs setssAs hsetssAs;
-      in
-        (map3 (fn goals => fn defs => fn rec_Sucs =>
-          map3 (fn goal => fn def => fn rec_Suc =>
-            Goal.prove_sorry lthy [] [] goal (K (mk_set_incl_hset_tac def rec_Suc))
-            |> Thm.close_derivation)
-          goals defs rec_Sucs)
-        set_incl_hset_goalss hset_defss hset_rec_Sucss,
-        map3 (fn goalss => fn defsi => fn rec_Sucs =>
-          map3 (fn k => fn goals => fn defsk =>
-            map4 (fn goal => fn defk => fn defi => fn rec_Suc =>
-              Goal.prove_sorry lthy [] [] goal
-                (K (mk_set_hset_incl_hset_tac n [defk, defi] rec_Suc k))
-              |> Thm.close_derivation)
-            goals defsk defsi rec_Sucs)
-          ks goalss hset_defss)
-        set_hset_incl_hset_goalsss hset_defss hset_rec_Sucss)
-      end;
-
-    val set_incl_hset_thmss' = transpose set_incl_hset_thmss;
-    val set_hset_incl_hset_thmsss' = transpose (map transpose set_hset_incl_hset_thmsss);
-    val set_hset_thmss = map (map (fn thm => thm RS @{thm set_mp})) set_incl_hset_thmss;
-    val set_hset_hset_thmsss = map (map (map (fn thm => thm RS @{thm set_mp})))
-      set_hset_incl_hset_thmsss;
-    val set_hset_thmss' = transpose set_hset_thmss;
-    val set_hset_hset_thmsss' = transpose (map transpose set_hset_hset_thmsss);
-
-    val hset_minimal_thms =
-      let
-        fun mk_passive_prem set s x K =
-          Logic.all x (HOLogic.mk_Trueprop (mk_leq (set $ (s $ x)) (K $ x)));
-
-        fun mk_active_prem s x1 K1 set x2 K2 =
-          fold_rev Logic.all [x1, x2]
-            (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x2, set $ (s $ x1))),
-              HOLogic.mk_Trueprop (mk_leq (K2 $ x2) (K1 $ x1))));
-
-        val premss = map2 (fn j => fn Ks =>
-          map4 mk_passive_prem (map (fn xs => nth xs (j - 1)) setssAs) ss zs Ks @
-            flat (map4 (fn sets => fn s => fn x1 => fn K1 =>
-              map3 (mk_active_prem s x1 K1) (drop m sets) zs_copy Ks) setssAs ss zs Ks))
-          ls Kss;
-
-        val hset_rec_minimal_thms =
-          let
-            fun mk_conjunct j T i K x = mk_leq (mk_hset_rec ss nat i j T $ x) (K $ x);
-            fun mk_concl j T Ks = list_all_free zs
-              (Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs));
-            val concls = map3 mk_concl ls passiveAs Kss;
-
-            val goals = map2 (fn prems => fn concl =>
-              Logic.list_implies (prems, HOLogic.mk_Trueprop concl)) premss concls
-
-            val ctss =
-              map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
-          in
-            map4 (fn goal => fn cts => fn hset_rec_0s => fn hset_rec_Sucs =>
-              singleton (Proof_Context.export names_lthy lthy)
-                (Goal.prove_sorry lthy [] [] goal
-                  (mk_hset_rec_minimal_tac m cts hset_rec_0s hset_rec_Sucs))
-              |> Thm.close_derivation)
-            goals ctss hset_rec_0ss' hset_rec_Sucss'
-          end;
-
-        fun mk_conjunct j T i K x = mk_leq (mk_hset ss i j T $ x) (K $ x);
-        fun mk_concl j T Ks = Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs);
-        val concls = map3 mk_concl ls passiveAs Kss;
-
-        val goals = map3 (fn Ks => fn prems => fn concl =>
-          fold_rev Logic.all (Ks @ ss @ zs)
-            (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))) Kss premss concls;
-      in
-        map3 (fn goal => fn hset_defs => fn hset_rec_minimal =>
-          Goal.prove_sorry lthy [] [] goal
-            (mk_hset_minimal_tac n hset_defs hset_rec_minimal)
-          |> Thm.close_derivation)
-        goals hset_defss' hset_rec_minimal_thms
-      end;
-
-    val timer = time (timer "Hereditary sets");
-
-    (* bisimulation *)
-
-    val bis_bind = mk_internal_b bisN;
-    val bis_name = Binding.name_of bis_bind;
-    val bis_def_bind = (Thm.def_binding bis_bind, []);
-
-    fun mk_bis_le_conjunct R B1 B2 = mk_leq R (mk_Times (B1, B2));
-    val bis_le = Library.foldr1 HOLogic.mk_conj (map3 mk_bis_le_conjunct Rs Bs B's)
-
-    val bis_spec =
-      let
-        val bisT = Library.foldr (op -->) (ATs @ BTs @ sTs @ B'Ts @ s'Ts @ setRTs, HOLogic.boolT);
-
-        val fst_args = passive_ids @ fsts;
-        val snd_args = passive_ids @ snds;
-        fun mk_bis R s s' b1 b2 RF map1 map2 sets =
-          list_all_free [b1, b2] (HOLogic.mk_imp
-            (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
-            mk_Bex (mk_in (As @ Rs) sets (snd (dest_Free RF))) (Term.absfree (dest_Free RF)
-              (HOLogic.mk_conj
-                (HOLogic.mk_eq (Term.list_comb (map1, fst_args) $ RF, s $ b1),
-                HOLogic.mk_eq (Term.list_comb (map2, snd_args) $ RF, s' $ b2))))));
-
-        val lhs = Term.list_comb (Free (bis_name, bisT), As @ Bs @ ss @ B's @ s's @ Rs);
-        val rhs = HOLogic.mk_conj
-          (bis_le, Library.foldr1 HOLogic.mk_conj
-            (map9 mk_bis Rs ss s's zs z's RFs map_fsts map_snds bis_setss))
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((bis_free, (_, bis_def_free)), (lthy, lthy_old)) =
-      lthy
-      |> Specification.definition (SOME (bis_bind, NONE, NoSyn), (bis_def_bind, bis_spec))
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-    val bis = fst (Term.dest_Const (Morphism.term phi bis_free));
-    val bis_def = Morphism.thm phi bis_def_free;
-
-    fun mk_bis As Bs1 ss1 Bs2 ss2 Rs =
-      let
-        val args = As @ Bs1 @ ss1 @ Bs2 @ ss2 @ Rs;
-        val Ts = map fastype_of args;
-        val bisT = Library.foldr (op -->) (Ts, HOLogic.boolT);
-      in
-        Term.list_comb (Const (bis, bisT), args)
-      end;
-
-    val bis_cong_thm =
-      let
-        val prems = map HOLogic.mk_Trueprop
-         (mk_bis As Bs ss B's s's Rs :: map2 (curry HOLogic.mk_eq) Rs_copy Rs)
-        val concl = HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs_copy);
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs @ Rs_copy)
-            (Logic.list_implies (prems, concl)))
-          (K ((hyp_subst_tac lthy THEN' atac) 1))
-        |> Thm.close_derivation
-      end;
-
-    val bis_rel_thm =
-      let
-        fun mk_conjunct R s s' b1 b2 rel =
-          list_all_free [b1, b2] (HOLogic.mk_imp
-            (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
-            Term.list_comb (rel, map mk_in_rel (passive_Id_ons @ Rs)) $ (s $ b1) $ (s' $ b2)));
-
-        val rhs = HOLogic.mk_conj
-          (bis_le, Library.foldr1 HOLogic.mk_conj
-            (map6 mk_conjunct Rs ss s's zs z's relsAsBs))
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
-            (mk_Trueprop_eq (mk_bis As Bs ss B's s's Rs, rhs)))
-          (K (mk_bis_rel_tac lthy m bis_def rel_OO_Grps map_comps map_cong0s set_mapss))
-        |> Thm.close_derivation
-      end;
-
-    val bis_converse_thm =
-      Goal.prove_sorry lthy [] []
-        (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
-          (Logic.mk_implies
-            (HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
-            HOLogic.mk_Trueprop (mk_bis As B's s's Bs ss (map mk_converse Rs)))))
-        (K (mk_bis_converse_tac m bis_rel_thm rel_congs rel_converseps))
-      |> Thm.close_derivation;
-
-    val bis_O_thm =
-      let
-        val prems =
-          [HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
-           HOLogic.mk_Trueprop (mk_bis As B's s's B''s s''s R's)];
-        val concl =
-          HOLogic.mk_Trueprop (mk_bis As Bs ss B''s s''s (map2 (curry mk_rel_comp) Rs R's));
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ B''s @ s''s @ Rs @ R's)
-            (Logic.list_implies (prems, concl)))
-          (K (mk_bis_O_tac lthy m bis_rel_thm rel_congs rel_OOs))
-        |> Thm.close_derivation
-      end;
-
-    val bis_Gr_thm =
-      let
-        val concl =
-          HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map2 mk_Gr Bs fs));
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ fs)
-            (Logic.list_implies ([coalg_prem, mor_prem], concl)))
-          (mk_bis_Gr_tac bis_rel_thm rel_Grps mor_image_thms morE_thms coalg_in_thms)
-        |> Thm.close_derivation
-      end;
-
-    val bis_image2_thm = bis_cong_thm OF
-      ((bis_O_thm OF [bis_Gr_thm RS bis_converse_thm, bis_Gr_thm]) ::
-      replicate n @{thm image2_Gr});
-
-    val bis_Id_on_thm = bis_cong_thm OF ((mor_id_thm RSN (2, bis_Gr_thm)) ::
-      replicate n @{thm Id_on_Gr});
-
-    val bis_Union_thm =
-      let
-        val prem =
-          HOLogic.mk_Trueprop (mk_Ball Idx
-            (Term.absfree idx' (mk_bis As Bs ss B's s's (map (fn R => R $ idx) Ris))));
-        val concl =
-          HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map (mk_UNION Idx) Ris));
-      in
-        Goal.prove_sorry lthy [] []
-          (fold_rev Logic.all (Idx :: As @ Bs @ ss @ B's @ s's @ Ris)
-            (Logic.mk_implies (prem, concl)))
-          (mk_bis_Union_tac bis_def in_mono'_thms)
-        |> Thm.close_derivation
-      end;
-
-    (* self-bisimulation *)
-
-    fun mk_sbis As Bs ss Rs = mk_bis As Bs ss Bs ss Rs;
-
-    val sbis_prem = HOLogic.mk_Trueprop (mk_sbis As Bs ss sRs);
-
-    (* largest self-bisimulation *)
-
-    val lsbis_binds = mk_internal_bs lsbisN;
-    fun lsbis_bind i = nth lsbis_binds (i - 1);
-    val lsbis_name = Binding.name_of o lsbis_bind;
-    val lsbis_def_bind = rpair [] o Thm.def_binding o lsbis_bind;
-
-    val all_sbis = HOLogic.mk_Collect (fst Rtuple', snd Rtuple', list_exists_free sRs
-      (HOLogic.mk_conj (HOLogic.mk_eq (Rtuple, HOLogic.mk_tuple sRs), mk_sbis As Bs ss sRs)));
-
-    fun lsbis_spec i RT =
-      let
-        fun mk_lsbisT RT =
-          Library.foldr (op -->) (map fastype_of (As @ Bs @ ss), RT);
-        val lhs = Term.list_comb (Free (lsbis_name i, mk_lsbisT RT), As @ Bs @ ss);
-        val rhs = mk_UNION all_sbis (Term.absfree Rtuple' (mk_nthN n Rtuple i));
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((lsbis_frees, (_, lsbis_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map2 (fn i => fn RT => Specification.definition
-        (SOME (lsbis_bind i, NONE, NoSyn), (lsbis_def_bind i, lsbis_spec i RT))) ks setsRTs
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val lsbis_defs = map (Morphism.thm phi) lsbis_def_frees;
-    val lsbiss = map (fst o Term.dest_Const o Morphism.term phi) lsbis_frees;
-
-    fun mk_lsbis As Bs ss i =
-      let
-        val args = As @ Bs @ ss;
-        val Ts = map fastype_of args;
-        val RT = mk_relT (`I (HOLogic.dest_setT (fastype_of (nth Bs (i - 1)))));
-        val lsbisT = Library.foldr (op -->) (Ts, RT);
-      in
-        Term.list_comb (Const (nth lsbiss (i - 1), lsbisT), args)
-      end;
-
-    val sbis_lsbis_thm =
-      Goal.prove_sorry lthy [] []
-        (fold_rev Logic.all (As @ Bs @ ss)
-          (HOLogic.mk_Trueprop (mk_sbis As Bs ss (map (mk_lsbis As Bs ss) ks))))
-        (K (mk_sbis_lsbis_tac lthy lsbis_defs bis_Union_thm bis_cong_thm))
-      |> Thm.close_derivation;
-
-    val lsbis_incl_thms = map (fn i => sbis_lsbis_thm RS
-      (bis_def RS iffD1 RS conjunct1 RS mk_conjunctN n i)) ks;
-    val lsbisE_thms = map (fn i => (mk_specN 2 (sbis_lsbis_thm RS
-      (bis_def RS iffD1 RS conjunct2 RS mk_conjunctN n i))) RS mp) ks;
-
-    val incl_lsbis_thms =
-      let
-        fun mk_concl i R = HOLogic.mk_Trueprop (mk_leq R (mk_lsbis As Bs ss i));
-        val goals = map2 (fn i => fn R => fold_rev Logic.all (As @ Bs @ ss @ sRs)
-          (Logic.mk_implies (sbis_prem, mk_concl i R))) ks sRs;
-      in
-        map3 (fn goal => fn i => fn def => Goal.prove_sorry lthy [] [] goal
-          (K (mk_incl_lsbis_tac n i def)) |> Thm.close_derivation) goals ks lsbis_defs
-      end;
-
-    val equiv_lsbis_thms =
-      let
-        fun mk_concl i B = HOLogic.mk_Trueprop (mk_equiv B (mk_lsbis As Bs ss i));
-        val goals = map2 (fn i => fn B => fold_rev Logic.all (As @ Bs @ ss)
-          (Logic.mk_implies (coalg_prem, mk_concl i B))) ks Bs;
-      in
-        map3 (fn goal => fn l_incl => fn incl_l =>
-          Goal.prove_sorry lthy [] [] goal
-            (K (mk_equiv_lsbis_tac sbis_lsbis_thm l_incl incl_l
-              bis_Id_on_thm bis_converse_thm bis_O_thm))
-          |> Thm.close_derivation)
-        goals lsbis_incl_thms incl_lsbis_thms
-      end;
-
-    val timer = time (timer "Bisimulations");
-
-    (* bounds *)
-
-    val (lthy, sbd, sbdT,
-      sbd_card_order, sbd_Cinfinite, sbd_Card_order, set_sbdss) =
-      if n = 1
-      then (lthy, sum_bd, sum_bdT, bd_card_order, bd_Cinfinite, bd_Card_order, set_bdss)
-      else
-        let
-          val sbdT_bind = mk_internal_b sum_bdTN;
-
-          val ((sbdT_name, (sbdT_glob_info, sbdT_loc_info)), lthy) =
-            typedef (sbdT_bind, dead_params, NoSyn)
-              (HOLogic.mk_UNIV sum_bdT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
-
-          val sbdT = Type (sbdT_name, dead_params');
-          val Abs_sbdT = Const (#Abs_name sbdT_glob_info, sum_bdT --> sbdT);
-
-          val sbd_bind = mk_internal_b sum_bdN;
-          val sbd_name = Binding.name_of sbd_bind;
-          val sbd_def_bind = (Thm.def_binding sbd_bind, []);
-
-          val sbd_spec = HOLogic.mk_Trueprop
-            (HOLogic.mk_eq (Free (sbd_name, mk_relT (`I sbdT)), mk_dir_image sum_bd Abs_sbdT));
-
-          val ((sbd_free, (_, sbd_def_free)), (lthy, lthy_old)) =
-            lthy
-            |> Specification.definition (SOME (sbd_bind, NONE, NoSyn), (sbd_def_bind, sbd_spec))
-            ||> `Local_Theory.restore;
-
-          val phi = Proof_Context.export_morphism lthy_old lthy;
-
-          val sbd_def = Morphism.thm phi sbd_def_free;
-          val sbd = Const (fst (Term.dest_Const (Morphism.term phi sbd_free)), mk_relT (`I sbdT));
-
-          val Abs_sbdT_inj = mk_Abs_inj_thm (#Abs_inject sbdT_loc_info);
-          val Abs_sbdT_bij = mk_Abs_bij_thm lthy Abs_sbdT_inj (#Abs_cases sbdT_loc_info);
-
-          fun mk_sum_Cinfinite [thm] = thm
-            | mk_sum_Cinfinite (thm :: thms) =
-              @{thm Cinfinite_csum_strong} OF [thm, mk_sum_Cinfinite thms];
-
-          val sum_Cinfinite = mk_sum_Cinfinite bd_Cinfinites;
-          val sum_Card_order = sum_Cinfinite RS conjunct2;
-
-          fun mk_sum_card_order [thm] = thm
-            | mk_sum_card_order (thm :: thms) =
-              @{thm card_order_csum} OF [thm, mk_sum_card_order thms];
-
-          val sum_card_order = mk_sum_card_order bd_card_orders;
-
-          val sbd_ordIso = fold_thms lthy [sbd_def]
-            (@{thm dir_image} OF [Abs_sbdT_inj, sum_Card_order]);
-          val sbd_card_order =  fold_thms lthy [sbd_def]
-            (@{thm card_order_dir_image} OF [Abs_sbdT_bij, sum_card_order]);
-          val sbd_Cinfinite = @{thm Cinfinite_cong} OF [sbd_ordIso, sum_Cinfinite];
-          val sbd_Card_order = sbd_Cinfinite RS conjunct2;
-
-          fun mk_set_sbd i bd_Card_order bds =
-            map (fn thm => @{thm ordLeq_ordIso_trans} OF
-              [bd_Card_order RS mk_ordLeq_csum n i thm, sbd_ordIso]) bds;
-          val set_sbdss = map3 mk_set_sbd ks bd_Card_orders set_bdss;
-       in
-         (lthy, sbd, sbdT, sbd_card_order, sbd_Cinfinite, sbd_Card_order, set_sbdss)
-       end;
-
-    val sbdTs = replicate n sbdT;
-    val sum_sbd = Library.foldr1 (uncurry mk_csum) (replicate n sbd);
-    val sum_sbdT = mk_sumTN sbdTs;
-    val sum_sbd_listT = HOLogic.listT sum_sbdT;
-    val sum_sbd_list_setT = HOLogic.mk_setT sum_sbd_listT;
-    val bdTs = passiveAs @ replicate n sbdT;
-    val to_sbd_maps = map4 mk_map_of_bnf Dss Ass (replicate n bdTs) bnfs;
-    val bdFTs = mk_FTs bdTs;
-    val sbdFT = mk_sumTN bdFTs;
-    val treeT = HOLogic.mk_prodT (sum_sbd_list_setT, sum_sbd_listT --> sbdFT);
-    val treeQT = HOLogic.mk_setT treeT;
-    val treeTs = passiveAs @ replicate n treeT;
-    val treeQTs = passiveAs @ replicate n treeQT;
-    val treeFTs = mk_FTs treeTs;
-    val tree_maps = map4 mk_map_of_bnf Dss (replicate n bdTs) (replicate n treeTs) bnfs;
-    val final_maps = map4 mk_map_of_bnf Dss (replicate n treeTs) (replicate n treeQTs) bnfs;
-    val isNode_setss = mk_setss (passiveAs @ replicate n sbdT);
-
-    val root = HOLogic.mk_set sum_sbd_listT [HOLogic.mk_list sum_sbdT []];
-    val Zero = HOLogic.mk_tuple (map (fn U => absdummy U root) activeAs);
-    val Lev_recT = fastype_of Zero;
-    val LevT = Library.foldr (op -->) (sTs, HOLogic.natT --> Lev_recT);
-
-    val Nil = HOLogic.mk_tuple (map3 (fn i => fn z => fn z'=>
-      Term.absfree z' (mk_InN activeAs z i)) ks zs zs');
-    val rv_recT = fastype_of Nil;
-    val rvT = Library.foldr (op -->) (sTs, sum_sbd_listT --> rv_recT);
-
-    val (((((((((((sumx, sumx'), (kks, kks')), (kl, kl')), (kl_copy, kl'_copy)), (Kl, Kl')),
-      (lab, lab')), (Kl_lab, Kl_lab')), xs), (Lev_rec, Lev_rec')), (rv_rec, rv_rec')),
-      names_lthy) = names_lthy
-      |> yield_singleton (apfst (op ~~) oo mk_Frees' "sumx") sum_sbdT
-      ||>> mk_Frees' "k" sbdTs
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl") sum_sbd_list_setT
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "lab") (sum_sbd_listT --> sbdFT)
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl_lab") treeT
-      ||>> mk_Frees "x" bdFTs
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") Lev_recT
-      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") rv_recT;
-
-    val (k, k') = (hd kks, hd kks')
-
-    val timer = time (timer "Bounds");
-
-    (* tree coalgebra *)
-
-    val isNode_binds = mk_internal_bs isNodeN;
-    fun isNode_bind i = nth isNode_binds (i - 1);
-    val isNode_name = Binding.name_of o isNode_bind;
-    val isNode_def_bind = rpair [] o Thm.def_binding o isNode_bind;
-
-    val isNodeT =
-      Library.foldr (op -->) (map fastype_of (As @ [Kl, lab, kl]), HOLogic.boolT);
-
-    val Succs = map3 (fn i => fn k => fn k' =>
-      HOLogic.mk_Collect (fst k', snd k', HOLogic.mk_mem (mk_InN sbdTs k i, mk_Succ Kl kl)))
-      ks kks kks';
-
-    fun isNode_spec sets x i =
-      let
-        val (passive_sets, active_sets) = chop m (map (fn set => set $ x) sets);
-        val lhs = Term.list_comb (Free (isNode_name i, isNodeT), As @ [Kl, lab, kl]);
-        val rhs = list_exists_free [x]
-          (Library.foldr1 HOLogic.mk_conj (HOLogic.mk_eq (lab $ kl, mk_InN bdFTs x i) ::
-          map2 mk_leq passive_sets As @ map2 (curry HOLogic.mk_eq) active_sets Succs));
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((isNode_frees, (_, isNode_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map3 (fn i => fn x => fn sets => Specification.definition
-        (SOME (isNode_bind i, NONE, NoSyn), (isNode_def_bind i, isNode_spec sets x i)))
-        ks xs isNode_setss
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val isNode_defs = map (Morphism.thm phi) isNode_def_frees;
-    val isNodes = map (fst o Term.dest_Const o Morphism.term phi) isNode_frees;
-
-    fun mk_isNode As kl i =
-      Term.list_comb (Const (nth isNodes (i - 1), isNodeT), As @ [Kl, lab, kl]);
-
-    val isTree =
-      let
-        val empty = HOLogic.mk_mem (HOLogic.mk_list sum_sbdT [], Kl);
-        val Field = mk_leq Kl (mk_Field (mk_clists sum_sbd));
-        val prefCl = mk_prefCl Kl;
-
-        val tree = mk_Ball Kl (Term.absfree kl'
-          (HOLogic.mk_conj
-            (Library.foldr1 HOLogic.mk_disj (map (mk_isNode As kl) ks),
-            Library.foldr1 HOLogic.mk_conj (map4 (fn Succ => fn i => fn k => fn k' =>
-              mk_Ball Succ (Term.absfree k' (mk_isNode As
-                (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i])) i)))
-            Succs ks kks kks'))));
-
-        val undef = list_all_free [kl] (HOLogic.mk_imp
-          (HOLogic.mk_not (HOLogic.mk_mem (kl, Kl)),
-          HOLogic.mk_eq (lab $ kl, mk_undefined sbdFT)));
-      in
-        Library.foldr1 HOLogic.mk_conj [empty, Field, prefCl, tree, undef]
-      end;
-
-    val carT_binds = mk_internal_bs carTN;
-    fun carT_bind i = nth carT_binds (i - 1);
-    val carT_name = Binding.name_of o carT_bind;
-    val carT_def_bind = rpair [] o Thm.def_binding o carT_bind;
-
-    fun carT_spec i =
-      let
-        val carTT = Library.foldr (op -->) (ATs, HOLogic.mk_setT treeT);
-
-        val lhs = Term.list_comb (Free (carT_name i, carTT), As);
-        val rhs = HOLogic.mk_Collect (fst Kl_lab', snd Kl_lab', list_exists_free [Kl, lab]
-          (HOLogic.mk_conj (HOLogic.mk_eq (Kl_lab, HOLogic.mk_prod (Kl, lab)),
-            HOLogic.mk_conj (isTree, mk_isNode As (HOLogic.mk_list sum_sbdT []) i))));
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((carT_frees, (_, carT_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map (fn i => Specification.definition
-        (SOME (carT_bind i, NONE, NoSyn), (carT_def_bind i, carT_spec i))) ks
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val carT_defs = map (Morphism.thm phi) carT_def_frees;
-    val carTs = map (fst o Term.dest_Const o Morphism.term phi) carT_frees;
-
-    fun mk_carT As i = Term.list_comb
-      (Const (nth carTs (i - 1),
-         Library.foldr (op -->) (map fastype_of As, HOLogic.mk_setT treeT)), As);
-
-    val strT_binds = mk_internal_bs strTN;
-    fun strT_bind i = nth strT_binds (i - 1);
-    val strT_name = Binding.name_of o strT_bind;
-    val strT_def_bind = rpair [] o Thm.def_binding o strT_bind;
-
-    fun strT_spec mapFT FT i =
-      let
-        val strTT = treeT --> FT;
-
-        fun mk_f i k k' =
-          let val in_k = mk_InN sbdTs k i;
-          in Term.absfree k' (HOLogic.mk_prod (mk_Shift Kl in_k, mk_shift lab in_k)) end;
-
-        val f = Term.list_comb (mapFT, passive_ids @ map3 mk_f ks kks kks');
-        val (fTs1, fTs2) = apsnd tl (chop (i - 1) (map (fn T => T --> FT) bdFTs));
-        val fs = map mk_undefined fTs1 @ (f :: map mk_undefined fTs2);
-        val lhs = Free (strT_name i, strTT);
-        val rhs = HOLogic.mk_split (Term.absfree Kl' (Term.absfree lab'
-          (mk_sum_caseN fs $ (lab $ HOLogic.mk_list sum_sbdT []))));
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((strT_frees, (_, strT_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map3 (fn i => fn mapFT => fn FT => Specification.definition
-        (SOME (strT_bind i, NONE, NoSyn), (strT_def_bind i, strT_spec mapFT FT i)))
-        ks tree_maps treeFTs
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val strT_defs = map ((fn def => trans OF [def RS fun_cong, @{thm prod.cases}]) o
-      Morphism.thm phi) strT_def_frees;
-    val strTs = map (fst o Term.dest_Const o Morphism.term phi) strT_frees;
-
-    fun mk_strT FT i = Const (nth strTs (i - 1), treeT --> FT);
-
-    val carTAs = map (mk_carT As) ks;
-    val strTAs = map2 mk_strT treeFTs ks;
-
-    val coalgT_thm =
-      Goal.prove_sorry lthy [] []
-        (fold_rev Logic.all As (HOLogic.mk_Trueprop (mk_coalg As carTAs strTAs)))
-        (mk_coalgT_tac m (coalg_def :: isNode_defs @ carT_defs) strT_defs set_mapss)
-      |> Thm.close_derivation;
-
-    val timer = time (timer "Tree coalgebra");
-
-    fun mk_to_sbd s x i i' =
-      mk_toCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
-    fun mk_from_sbd s x i i' =
-      mk_fromCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
-
-    fun mk_to_sbd_thmss thm = map (map (fn set_sbd =>
-      thm OF [set_sbd, sbd_Card_order]) o drop m) set_sbdss;
-
-    val to_sbd_inj_thmss = mk_to_sbd_thmss @{thm toCard_inj};
-    val to_sbd_thmss = mk_to_sbd_thmss @{thm toCard};
-    val from_to_sbd_thmss = mk_to_sbd_thmss @{thm fromCard_toCard};
-
-    val Lev_bind = mk_internal_b LevN;
-    val Lev_name = Binding.name_of Lev_bind;
-    val Lev_def_bind = rpair [] (Thm.def_binding Lev_bind);
-
-    val Lev_spec =
-      let
-        fun mk_Suc i s setsAs a a' =
-          let
-            val sets = drop m setsAs;
-            fun mk_set i' set b =
-              let
-                val Cons = HOLogic.mk_eq (kl_copy,
-                  mk_Cons (mk_InN sbdTs (mk_to_sbd s a i i' $ b) i') kl)
-                val b_set = HOLogic.mk_mem (b, set $ (s $ a));
-                val kl_rec = HOLogic.mk_mem (kl, mk_nthN n Lev_rec i' $ b);
-              in
-                HOLogic.mk_Collect (fst kl'_copy, snd kl'_copy, list_exists_free [b, kl]
-                  (HOLogic.mk_conj (Cons, HOLogic.mk_conj (b_set, kl_rec))))
-              end;
-          in
-            Term.absfree a' (Library.foldl1 mk_union (map3 mk_set ks sets zs_copy))
-          end;
-
-        val Suc = Term.absdummy HOLogic.natT (Term.absfree Lev_rec'
-          (HOLogic.mk_tuple (map5 mk_Suc ks ss setssAs zs zs')));
-
-        val lhs = Term.list_comb (Free (Lev_name, LevT), ss);
-        val rhs = mk_nat_rec Zero Suc;
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((Lev_free, (_, Lev_def_free)), (lthy, lthy_old)) =
-      lthy
-      |> Specification.definition (SOME (Lev_bind, NONE, NoSyn), (Lev_def_bind, Lev_spec))
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val Lev_def = Morphism.thm phi Lev_def_free;
-    val Lev = fst (Term.dest_Const (Morphism.term phi Lev_free));
-
-    fun mk_Lev ss nat i =
-      let
-        val Ts = map fastype_of ss;
-        val LevT = Library.foldr (op -->) (Ts, HOLogic.natT -->
-          HOLogic.mk_tupleT (map (fn U => domain_type U --> sum_sbd_list_setT) Ts));
-      in
-        mk_nthN n (Term.list_comb (Const (Lev, LevT), ss) $ nat) i
-      end;
-
-    val Lev_0s = flat (mk_rec_simps n @{thm nat_rec_0} [Lev_def]);
-    val Lev_Sucs = flat (mk_rec_simps n @{thm nat_rec_Suc} [Lev_def]);
-
-    val rv_bind = mk_internal_b rvN;
-    val rv_name = Binding.name_of rv_bind;
-    val rv_def_bind = rpair [] (Thm.def_binding rv_bind);
-
-    val rv_spec =
-      let
-        fun mk_Cons i s b b' =
-          let
-            fun mk_case i' =
-              Term.absfree k' (mk_nthN n rv_rec i' $ (mk_from_sbd s b i i' $ k));
-          in
-            Term.absfree b' (mk_sum_caseN (map mk_case ks) $ sumx)
-          end;
-
-        val Cons = Term.absfree sumx' (Term.absdummy sum_sbd_listT (Term.absfree rv_rec'
-          (HOLogic.mk_tuple (map4 mk_Cons ks ss zs zs'))));
-
-        val lhs = Term.list_comb (Free (rv_name, rvT), ss);
-        val rhs = mk_list_rec Nil Cons;
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((rv_free, (_, rv_def_free)), (lthy, lthy_old)) =
-      lthy
-      |> Specification.definition (SOME (rv_bind, NONE, NoSyn), (rv_def_bind, rv_spec))
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val rv_def = Morphism.thm phi rv_def_free;
-    val rv = fst (Term.dest_Const (Morphism.term phi rv_free));
-
-    fun mk_rv ss kl i =
-      let
-        val Ts = map fastype_of ss;
-        val As = map domain_type Ts;
-        val rvT = Library.foldr (op -->) (Ts, fastype_of kl -->
-          HOLogic.mk_tupleT (map (fn U => U --> mk_sumTN As) As));
-      in
-        mk_nthN n (Term.list_comb (Const (rv, rvT), ss) $ kl) i
-      end;
-
-    val rv_Nils = flat (mk_rec_simps n @{thm list_rec_Nil} [rv_def]);
-    val rv_Conss = flat (mk_rec_simps n @{thm list_rec_Cons} [rv_def]);
-
-    val beh_binds = mk_internal_bs behN;
-    fun beh_bind i = nth beh_binds (i - 1);
-    val beh_name = Binding.name_of o beh_bind;
-    val beh_def_bind = rpair [] o Thm.def_binding o beh_bind;
-
-    fun beh_spec i z =
-      let
-        val mk_behT = Library.foldr (op -->) (map fastype_of (ss @ [z]), treeT);
-
-        fun mk_case i to_sbd_map s k k' =
-          Term.absfree k' (mk_InN bdFTs
-            (Term.list_comb (to_sbd_map, passive_ids @ map (mk_to_sbd s k i) ks) $ (s $ k)) i);
-
-        val Lab = Term.absfree kl' (mk_If
-          (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))
-          (mk_sum_caseN (map5 mk_case ks to_sbd_maps ss zs zs') $ (mk_rv ss kl i $ z))
-          (mk_undefined sbdFT));
-
-        val lhs = Term.list_comb (Free (beh_name i, mk_behT), ss) $ z;
-        val rhs = HOLogic.mk_prod (mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
-          (Term.absfree nat' (mk_Lev ss nat i $ z)), Lab);
-      in
-        mk_Trueprop_eq (lhs, rhs)
-      end;
-
-    val ((beh_frees, (_, beh_def_frees)), (lthy, lthy_old)) =
-      lthy
-      |> fold_map2 (fn i => fn z => Specification.definition
-        (SOME (beh_bind i, NONE, NoSyn), (beh_def_bind i, beh_spec i z))) ks zs
-      |>> apsnd split_list o split_list
-      ||> `Local_Theory.restore;
-
-    val phi = Proof_Context.export_morphism lthy_old lthy;
-
-    val beh_defs = map (Morphism.thm phi) beh_def_frees;
-    val behs = map (fst o Term.dest_Const o Morphism.term phi) beh_frees;
-
-    fun mk_beh ss i =
-      let
-        val Ts = map fastype_of ss;
-        val behT = Library.foldr (op -->) (Ts, nth activeAs (i - 1) --> treeT);
-      in
-        Term.list_comb (Const (nth behs (i - 1), behT), ss)
-      end;
-
-    val Lev_sbd_thms =
-      let
-        fun mk_conjunct i z = mk_leq (mk_Lev ss nat i $ z) (mk_Field (mk_clists sum_sbd));
-        val goal = list_all_free zs
-          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
-
-        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
-
-        val Lev_sbd = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
-            (K (mk_Lev_sbd_tac lthy cts Lev_0s Lev_Sucs to_sbd_thmss))
-          |> Thm.close_derivation);
-
-        val Lev_sbd' = mk_specN n Lev_sbd;
-      in
-        map (fn i => Lev_sbd' RS mk_conjunctN n i) ks
-      end;
-
-    val (length_Lev_thms, length_Lev'_thms) =
-      let
-        fun mk_conjunct i z = HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
-          HOLogic.mk_eq (mk_size kl, nat));
-        val goal = list_all_free (kl :: zs)
-          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
-
-        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
-
-        val length_Lev = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
-            (K (mk_length_Lev_tac lthy cts Lev_0s Lev_Sucs))
-          |> Thm.close_derivation);
-
-        val length_Lev' = mk_specN (n + 1) length_Lev;
-        val length_Levs = map (fn i => length_Lev' RS mk_conjunctN n i RS mp) ks;
-
-        fun mk_goal i z = fold_rev Logic.all (z :: kl :: nat :: ss) (Logic.mk_implies
-            (HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z)),
-            HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))));
-        val goals = map2 mk_goal ks zs;
-
-        val length_Levs' = map2 (fn goal => fn length_Lev =>
-          Goal.prove_sorry lthy [] [] goal (K (mk_length_Lev'_tac length_Lev))
-          |> Thm.close_derivation) goals length_Levs;
-      in
-        (length_Levs, length_Levs')
-      end;
-
-    val prefCl_Lev_thms =
-      let
-        fun mk_conjunct i z = HOLogic.mk_imp
-          (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), mk_prefixeq kl_copy kl),
-          HOLogic.mk_mem (kl_copy, mk_Lev ss (mk_size kl_copy) i $ z));
-        val goal = list_all_free (kl :: kl_copy :: zs)
-          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
-
-        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
-
-        val prefCl_Lev = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
-            (K (mk_prefCl_Lev_tac lthy cts Lev_0s Lev_Sucs)))
-          |> Thm.close_derivation;
-
-        val prefCl_Lev' = mk_specN (n + 2) prefCl_Lev;
-      in
-        map (fn i => prefCl_Lev' RS mk_conjunctN n i RS mp) ks
-      end;
-
-    val rv_last_thmss =
-      let
-        fun mk_conjunct i z i' z_copy = list_exists_free [z_copy]
-          (HOLogic.mk_eq
-            (mk_rv ss (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i'])) i $ z,
-            mk_InN activeAs z_copy i'));
-        val goal = list_all_free (k :: zs)
-          (Library.foldr1 HOLogic.mk_conj (map2 (fn i => fn z =>
-            Library.foldr1 HOLogic.mk_conj
-              (map2 (mk_conjunct i z) ks zs_copy)) ks zs));
-
-        val cTs = [SOME (certifyT lthy sum_sbdT)];
-        val cts = map (SOME o certify lthy) [Term.absfree kl' goal, kl];
-
-        val rv_last = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
-            (K (mk_rv_last_tac cTs cts rv_Nils rv_Conss)))
-          |> Thm.close_derivation;
-
-        val rv_last' = mk_specN (n + 1) rv_last;
-      in
-        map (fn i => map (fn i' => rv_last' RS mk_conjunctN n i RS mk_conjunctN n i') ks) ks
-      end;
-
-    val set_rv_Lev_thmsss = if m = 0 then replicate n (replicate n []) else
-      let
-        fun mk_case s sets z z_free = Term.absfree z_free (Library.foldr1 HOLogic.mk_conj
-          (map2 (fn set => fn A => mk_leq (set $ (s $ z)) A) (take m sets) As));
-
-        fun mk_conjunct i z B = HOLogic.mk_imp
-          (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), HOLogic.mk_mem (z, B)),
-          mk_sum_caseN (map4 mk_case ss setssAs zs zs') $ (mk_rv ss kl i $ z));
-
-        val goal = list_all_free (kl :: zs)
-          (Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct ks zs Bs));
-
-        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
-
-        val set_rv_Lev = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] []
-            (Logic.mk_implies (coalg_prem, HOLogic.mk_Trueprop goal))
-            (K (mk_set_rv_Lev_tac lthy m cts Lev_0s Lev_Sucs rv_Nils rv_Conss
-              coalg_set_thmss from_to_sbd_thmss)))
-          |> Thm.close_derivation;
-
-        val set_rv_Lev' = mk_specN (n + 1) set_rv_Lev;
-      in
-        map (fn i => map (fn i' =>
-          split_conj_thm (if n = 1 then set_rv_Lev' RS mk_conjunctN n i RS mp
-            else set_rv_Lev' RS mk_conjunctN n i RS mp RSN
-              (2, @{thm sum_case_weak_cong} RS iffD1) RS
-              (mk_sum_casesN n i' RS iffD1))) ks) ks
-      end;
-
-    val set_Lev_thmsss =
-      let
-        fun mk_conjunct i z =
-          let
-            fun mk_conjunct' i' sets s z' =
-              let
-                fun mk_conjunct'' i'' set z'' = HOLogic.mk_imp
-                  (HOLogic.mk_mem (z'', set $ (s $ z')),
-                    HOLogic.mk_mem (mk_append (kl,
-                      HOLogic.mk_list sum_sbdT [mk_InN sbdTs (mk_to_sbd s z' i' i'' $ z'') i'']),
-                      mk_Lev ss (HOLogic.mk_Suc nat) i $ z));
-              in
-                HOLogic.mk_imp (HOLogic.mk_eq (mk_rv ss kl i $ z, mk_InN activeAs z' i'),
-                  (Library.foldr1 HOLogic.mk_conj (map3 mk_conjunct'' ks (drop m sets) zs_copy2)))
-              end;
-          in
-            HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
-              Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct' ks setssAs ss zs_copy))
-          end;
-
-        val goal = list_all_free (kl :: zs @ zs_copy @ zs_copy2)
-          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
-
-        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
-
-        val set_Lev = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
-            (K (mk_set_Lev_tac lthy cts Lev_0s Lev_Sucs rv_Nils rv_Conss from_to_sbd_thmss)))
-          |> Thm.close_derivation;
-
-        val set_Lev' = mk_specN (3 * n + 1) set_Lev;
-      in
-        map (fn i => map (fn i' => map (fn i'' => set_Lev' RS
-          mk_conjunctN n i RS mp RS
-          mk_conjunctN n i' RS mp RS
-          mk_conjunctN n i'' RS mp) ks) ks) ks
-      end;
-
-    val set_image_Lev_thmsss =
-      let
-        fun mk_conjunct i z =
-          let
-            fun mk_conjunct' i' sets =
-              let
-                fun mk_conjunct'' i'' set s z'' = HOLogic.mk_imp
-                  (HOLogic.mk_eq (mk_rv ss kl i $ z, mk_InN activeAs z'' i''),
-                  HOLogic.mk_mem (k, mk_image (mk_to_sbd s z'' i'' i') $ (set $ (s $ z''))));
-              in
-                HOLogic.mk_imp (HOLogic.mk_mem
-                  (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i']),
-                    mk_Lev ss (HOLogic.mk_Suc nat) i $ z),
-                  (Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct'' ks sets ss zs_copy)))
-              end;
-          in
-            HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
-              Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct' ks (drop m setssAs')))
-          end;
-
-        val goal = list_all_free (kl :: k :: zs @ zs_copy)
-          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
-
-        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
-
-        val set_image_Lev = singleton (Proof_Context.export names_lthy lthy)
-          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
-            (K (mk_set_image_Lev_tac lthy cts Lev_0s Lev_Sucs rv_Nils rv_Conss
-              from_to_sbd_thmss to_sbd_inj_thmss)))
-          |> Thm.close_derivation;
-
-        val set_image_Lev' = mk_specN (2 * n + 2) set_image_Lev;
-      in
-        map (fn i => map (fn i' => map (fn i'' => set_image_Lev' RS
-          mk_conjunctN n i RS mp RS
-          mk_conjunctN n i'' RS mp RS
-          mk_conjunctN n i' RS mp) ks) ks) ks
-      end;
-
-    val mor_beh_thm =
-      Goal.prove_sorry lthy [] []
-        (fold_rev Logic.all (As @ Bs @ ss) (Logic.mk_implies (coalg_prem,
-          HOLogic.mk_Trueprop (mk_mor Bs ss carTAs strTAs (map (mk_beh ss) ks)))))
-        (mk_mor_beh_tac m mor_def mor_cong_thm
-          beh_defs carT_defs strT_defs isNode_defs
-          to_sbd_inj_thmss from_to_sbd_thmss Lev_0s Lev_Sucs rv_Nils rv_Conss Lev_sbd_thms
-          length_Lev_thms length_Lev'_thms prefCl_Lev_thms rv_last_thmss
-          set_rv_Lev_thmsss set_Lev_thmsss set_image_Lev_thmsss
-          set_mapss coalg_set_thmss map_comp_id_thms map_cong0s map_arg_cong_thms)
-      |> Thm.close_derivation;
-
-    val timer = time (timer "Behavioral morphism");
-
-    fun mk_LSBIS As i = mk_lsbis As (map (mk_carT As) ks) strTAs i;
-    fun mk_car_final As i =
-      mk_quotient (mk_carT As i) (mk_LSBIS As i);
-    fun mk_str_final As i =
-      mk_univ (HOLogic.mk_comp (Term.list_comb (nth final_maps (i - 1),
-        passive_ids @ map (mk_proj o mk_LSBIS As) ks), nth strTAs (i - 1)));
-
-    val car_finalAs = map (mk_car_final As) ks;
-    val str_finalAs = map (mk_str_final As) ks;
-    val car_finals = map (mk_car_final passive_UNIVs) ks;
-    val str_finals = map (mk_str_final passive_UNIVs) ks;
-
-    val coalgT_set_thmss = map (map (fn thm => coalgT_thm RS thm)) coalg_set_thmss;
-    val equiv_LSBIS_thms = map (fn thm => coalgT_thm RS thm) equiv_lsbis_thms;
-
-    val congruent_str_final_thms =
-      let
-        fun mk_goal R final_map strT =
-          fold_rev Logic.all As (HOLogic.mk_Trueprop
-            (mk_congruent R (HOLogic.mk_comp
-              (Term.list_comb (final_map, passive_ids @ map (mk_proj o mk_LSBIS As) ks), strT))));
-
-        val goals = map3 mk_goal (map (mk_LSBIS As) ks) final_maps strTAs;
-      in
-        map4 (fn goal => fn lsbisE => fn map_comp_id => fn map_cong0 =>
-          Goal.prove_sorry lthy [] [] goal
-            (K (mk_congruent_str_final_tac m lsbisE map_comp_id map_cong0 equiv_LSBIS_thms))
-          |> Thm.close_derivation)
-        goals lsbisE_thms map_comp_id_thms map_cong0s
-      end;
-
-    val coalg_final_thm = Goal.prove_sorry lthy [] [] (fold_rev Logic.all As
-      (HOLogic.mk_Trueprop (mk_coalg As car_finalAs str_finalAs)))
-      (K (mk_coalg_final_tac m coalg_def congruent_str_final_thms equiv_LSBIS_thms
-        set_mapss coalgT_set_thmss))
-      |> Thm.close_derivation;
-
-    val mor_T_final_thm = Goal.prove_sorry lthy [] [] (fold_rev Logic.all As
-      (HOLogic.mk_Trueprop (mk_mor carTAs strTAs car_finalAs str_finalAs
-        (map (mk_proj o mk_LSBIS As) ks))))
-      (K (mk_mor_T_final_tac mor_def congruent_str_final_thms equiv_LSBIS_thms))
-      |> Thm.close_derivation;
-
-    val mor_final_thm = mor_comp_thm OF [mor_beh_thm, mor_T_final_thm];
-    val in_car_final_thms = map (fn mor_image' => mor_image' OF
-      [tcoalg_thm RS mor_final_thm, UNIV_I]) mor_image'_thms;
-
-    val timer = time (timer "Final coalgebra");
-
-    val ((T_names, (T_glob_infos, T_loc_infos)), lthy) =
-      lthy
-      |> fold_map4 (fn b => fn mx => fn car_final => fn in_car_final =>
-        typedef (Binding.conceal b, params, mx) car_final NONE
-          (EVERY' [rtac exI, rtac in_car_final] 1)) bs mixfixes car_finals in_car_final_thms
-      |>> apsnd split_list o split_list;
-
-    val Ts = map (fn name => Type (name, params')) T_names;
-    fun mk_Ts passive = map (Term.typ_subst_atomic (passiveAs ~~ passive)) Ts;
-    val Ts' = mk_Ts passiveBs;
-    val Rep_Ts = map2 (fn info => fn T => Const (#Rep_name info, T --> treeQT)) T_glob_infos Ts;
-    val Abs_Ts = map2 (fn info => fn T => Const (#Abs_name info, treeQT --> T)) T_glob_infos Ts;
-
-    val Reps = map #Rep T_loc_infos;
-    val Rep_injects = map #Rep_inject T_loc_infos;
-    val Abs_inverses = map #Abs_inverse T_loc_infos;
-
-    val timer = time (timer "THE TYPEDEFs & Rep/Abs thms");
-
-    val UNIVs = map HOLogic.mk_UNIV Ts;
-    val FTs = mk_FTs (passiveAs @ Ts);
-    val FTs' = mk_FTs (passiveBs @ Ts);
-    val prodTs = map (HOLogic.mk_prodT o `I) Ts;
-    val prodFTs = mk_FTs (passiveAs @ prodTs);
-    val FTs_setss = mk_setss (passiveAs @ Ts);
-    val prodFT_setss = mk_setss (passiveAs @ prodTs);
-    val map_FTs = map2 (fn Ds => mk_map_of_bnf Ds treeQTs (passiveAs @ Ts)) Dss bnfs;
-    val map_FT_nths = map2 (fn Ds =>
-      mk_map_of_bnf Ds (passiveAs @ prodTs) (passiveAs @ Ts)) Dss bnfs;
-    val fstsTs = map fst_const prodTs;
-    val sndsTs = map snd_const prodTs;
-    val dtorTs = map2 (curry op -->) Ts FTs;
-    val ctorTs = map2 (curry op -->) FTs Ts;
-    val unfold_fTs = map2 (curry op -->) activeAs Ts;
-    val corec_sTs = map (Term.typ_subst_atomic (activeBs ~~ Ts)) sum_sTs;
-    val corec_maps = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_Inls;
-    val corec_maps_rev = map (Term.subst_atomic_types (activeBs ~~ Ts)) map_Inls_rev;
-    val corec_Inls = map (Term.subst_atomic_types (activeBs ~~ Ts)) Inls;
-    val corec_UNIVs = map2 (HOLogic.mk_UNIV oo curry mk_sumT) Ts activeAs;
-
-    val (((((((((((((Jzs, Jzs'), Jz's), Jzs_copy), Jz's_copy), Jzs1), Jzs2),
-      FJzs), TRs), unfold_fs), corec_ss), phis), dtor_set_induct_phiss),
-      names_lthy) = names_lthy
-      |> mk_Frees' "z" Ts
-      ||>> mk_Frees "y" Ts'
-      ||>> mk_Frees "z'" Ts
-      ||>> mk_Frees "y'" Ts'
-      ||>> mk_Frees "z1" Ts
-      ||>> mk_Frees "z2" Ts
-      ||>> mk_Frees "x" prodFTs
-      ||>> mk_Frees "r" (map (mk_relT o `I) Ts)
-      ||>> mk_Frees "f" unfold_fTs
-      ||>> mk_Frees "s" corec_sTs
-      ||>> mk_Frees "P" (map2 mk_pred2T Ts Ts)
-      ||>> mk_Freess "P" (map (fn A => map (mk_pred2T A) Ts) passiveAs);
-
-    fun dtor_bind i = nth external_bs (i - 1) |> Binding.prefix_name (dtorN ^ "_");
-    val dtor_name = Binding.name_of o dtor_bind;
-    val dtor_def_bind = rpair [] o Binding.conceal o Thm.def_binding o dtor_bind;