moved BNF files to 'HOL'
authorblanchet
Mon Jan 20 18:24:56 2014 +0100 (2014-01-20)
changeset 550584e700eb471d4
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
     1.1 --- a/src/HOL/BNF/BNF.thy	Mon Jan 20 18:24:55 2014 +0100
     1.2 +++ b/src/HOL/BNF/BNF.thy	Mon Jan 20 18:24:56 2014 +0100
     1.3 @@ -10,7 +10,7 @@
     1.4  header {* Bounded Natural Functors for (Co)datatypes *}
     1.5  
     1.6  theory BNF
     1.7 -imports Countable_Set_Type BNF_LFP BNF_GFP BNF_Decl
     1.8 +imports Countable_Set_Type BNF_Decl
     1.9  begin
    1.10  
    1.11  hide_const (open) image2 image2p vimage2p Gr Grp collect fsts snds setl setr 
     2.1 --- a/src/HOL/BNF/BNF_Comp.thy	Mon Jan 20 18:24:55 2014 +0100
     2.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3 @@ -1,76 +0,0 @@
     2.4 -(*  Title:      HOL/BNF/BNF_Comp.thy
     2.5 -    Author:     Dmitriy Traytel, TU Muenchen
     2.6 -    Copyright   2012
     2.7 -
     2.8 -Composition of bounded natural functors.
     2.9 -*)
    2.10 -
    2.11 -header {* Composition of Bounded Natural Functors *}
    2.12 -
    2.13 -theory BNF_Comp
    2.14 -imports Basic_BNFs
    2.15 -begin
    2.16 -
    2.17 -lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
    2.18 -by (rule ext) simp
    2.19 -
    2.20 -lemma Union_natural: "Union o image (image f) = image f o Union"
    2.21 -by (rule ext) (auto simp only: o_apply)
    2.22 -
    2.23 -lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
    2.24 -by (unfold o_assoc)
    2.25 -
    2.26 -lemma comp_single_set_bd:
    2.27 -  assumes fbd_Card_order: "Card_order fbd" and
    2.28 -    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
    2.29 -    gset_bd: "\<And>x. |gset x| \<le>o gbd"
    2.30 -  shows "|\<Union>(fset ` gset x)| \<le>o gbd *c fbd"
    2.31 -apply (subst sym[OF SUP_def])
    2.32 -apply (rule ordLeq_transitive)
    2.33 -apply (rule card_of_UNION_Sigma)
    2.34 -apply (subst SIGMA_CSUM)
    2.35 -apply (rule ordLeq_transitive)
    2.36 -apply (rule card_of_Csum_Times')
    2.37 -apply (rule fbd_Card_order)
    2.38 -apply (rule ballI)
    2.39 -apply (rule fset_bd)
    2.40 -apply (rule ordLeq_transitive)
    2.41 -apply (rule cprod_mono1)
    2.42 -apply (rule gset_bd)
    2.43 -apply (rule ordIso_imp_ordLeq)
    2.44 -apply (rule ordIso_refl)
    2.45 -apply (rule Card_order_cprod)
    2.46 -done
    2.47 -
    2.48 -lemma Union_image_insert: "\<Union>(f ` insert a B) = f a \<union> \<Union>(f ` B)"
    2.49 -by simp
    2.50 -
    2.51 -lemma Union_image_empty: "A \<union> \<Union>(f ` {}) = A"
    2.52 -by simp
    2.53 -
    2.54 -lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
    2.55 -by (rule ext) (auto simp add: collect_def)
    2.56 -
    2.57 -lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
    2.58 -by blast
    2.59 -
    2.60 -lemma UN_image_subset: "\<Union>(f ` g x) \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
    2.61 -by blast
    2.62 -
    2.63 -lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>((\<lambda>f. f x) ` X)| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
    2.64 -by (unfold o_apply collect_def SUP_def)
    2.65 -
    2.66 -lemma wpull_cong:
    2.67 -"\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
    2.68 -by simp
    2.69 -
    2.70 -lemma Grp_fst_snd: "(Grp (Collect (split R)) fst)^--1 OO Grp (Collect (split R)) snd = R"
    2.71 -unfolding Grp_def fun_eq_iff relcompp.simps by auto
    2.72 -
    2.73 -lemma OO_Grp_cong: "A = B \<Longrightarrow> (Grp A f)^--1 OO Grp A g = (Grp B f)^--1 OO Grp B g"
    2.74 -by simp
    2.75 -
    2.76 -ML_file "Tools/bnf_comp_tactics.ML"
    2.77 -ML_file "Tools/bnf_comp.ML"
    2.78 -
    2.79 -end
     3.1 --- a/src/HOL/BNF/BNF_Def.thy	Mon Jan 20 18:24:55 2014 +0100
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,163 +0,0 @@
     3.4 -(*  Title:      HOL/BNF/BNF_Def.thy
     3.5 -    Author:     Dmitriy Traytel, TU Muenchen
     3.6 -    Copyright   2012
     3.7 -
     3.8 -Definition of bounded natural functors.
     3.9 -*)
    3.10 -
    3.11 -header {* Definition of Bounded Natural Functors *}
    3.12 -
    3.13 -theory BNF_Def
    3.14 -imports BNF_Util
    3.15 -   (*FIXME: register fundef_cong attribute in an interpretation to remove this dependency*)
    3.16 -  FunDef
    3.17 -keywords
    3.18 -  "print_bnfs" :: diag and
    3.19 -  "bnf" :: thy_goal
    3.20 -begin
    3.21 -
    3.22 -lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
    3.23 -  by (rule ext) (auto simp only: o_apply collect_def)
    3.24 -
    3.25 -definition convol ("<_ , _>") where
    3.26 -"<f , g> \<equiv> %a. (f a, g a)"
    3.27 -
    3.28 -lemma fst_convol:
    3.29 -"fst o <f , g> = f"
    3.30 -apply(rule ext)
    3.31 -unfolding convol_def by simp
    3.32 -
    3.33 -lemma snd_convol:
    3.34 -"snd o <f , g> = g"
    3.35 -apply(rule ext)
    3.36 -unfolding convol_def by simp
    3.37 -
    3.38 -lemma convol_mem_GrpI:
    3.39 -"x \<in> A \<Longrightarrow> <id , g> x \<in> (Collect (split (Grp A g)))"
    3.40 -unfolding convol_def Grp_def by auto
    3.41 -
    3.42 -definition csquare where
    3.43 -"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
    3.44 -
    3.45 -lemma eq_alt: "op = = Grp UNIV id"
    3.46 -unfolding Grp_def by auto
    3.47 -
    3.48 -lemma leq_conversepI: "R = op = \<Longrightarrow> R \<le> R^--1"
    3.49 -  by auto
    3.50 -
    3.51 -lemma leq_OOI: "R = op = \<Longrightarrow> R \<le> R OO R"
    3.52 -  by auto
    3.53 -
    3.54 -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)"
    3.55 -  unfolding Grp_def by auto
    3.56 -
    3.57 -lemma Grp_UNIV_id: "f = id \<Longrightarrow> (Grp UNIV f)^--1 OO Grp UNIV f = Grp UNIV f"
    3.58 -unfolding Grp_def by auto
    3.59 -
    3.60 -lemma Grp_UNIV_idI: "x = y \<Longrightarrow> Grp UNIV id x y"
    3.61 -unfolding Grp_def by auto
    3.62 -
    3.63 -lemma Grp_mono: "A \<le> B \<Longrightarrow> Grp A f \<le> Grp B f"
    3.64 -unfolding Grp_def by auto
    3.65 -
    3.66 -lemma GrpI: "\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> Grp A f x y"
    3.67 -unfolding Grp_def by auto
    3.68 -
    3.69 -lemma GrpE: "Grp A f x y \<Longrightarrow> (\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
    3.70 -unfolding Grp_def by auto
    3.71 -
    3.72 -lemma Collect_split_Grp_eqD: "z \<in> Collect (split (Grp A f)) \<Longrightarrow> (f \<circ> fst) z = snd z"
    3.73 -unfolding Grp_def o_def by auto
    3.74 -
    3.75 -lemma Collect_split_Grp_inD: "z \<in> Collect (split (Grp A f)) \<Longrightarrow> fst z \<in> A"
    3.76 -unfolding Grp_def o_def by auto
    3.77 -
    3.78 -definition "pick_middlep P Q a c = (SOME b. P a b \<and> Q b c)"
    3.79 -
    3.80 -lemma pick_middlep:
    3.81 -"(P OO Q) a c \<Longrightarrow> P a (pick_middlep P Q a c) \<and> Q (pick_middlep P Q a c) c"
    3.82 -unfolding pick_middlep_def apply(rule someI_ex) by auto
    3.83 -
    3.84 -definition fstOp where "fstOp P Q ac = (fst ac, pick_middlep P Q (fst ac) (snd ac))"
    3.85 -definition sndOp where "sndOp P Q ac = (pick_middlep P Q (fst ac) (snd ac), (snd ac))"
    3.86 -
    3.87 -lemma fstOp_in: "ac \<in> Collect (split (P OO Q)) \<Longrightarrow> fstOp P Q ac \<in> Collect (split P)"
    3.88 -unfolding fstOp_def mem_Collect_eq
    3.89 -by (subst (asm) surjective_pairing, unfold prod.cases) (erule pick_middlep[THEN conjunct1])
    3.90 -
    3.91 -lemma fst_fstOp: "fst bc = (fst \<circ> fstOp P Q) bc"
    3.92 -unfolding comp_def fstOp_def by simp
    3.93 -
    3.94 -lemma snd_sndOp: "snd bc = (snd \<circ> sndOp P Q) bc"
    3.95 -unfolding comp_def sndOp_def by simp
    3.96 -
    3.97 -lemma sndOp_in: "ac \<in> Collect (split (P OO Q)) \<Longrightarrow> sndOp P Q ac \<in> Collect (split Q)"
    3.98 -unfolding sndOp_def mem_Collect_eq
    3.99 -by (subst (asm) surjective_pairing, unfold prod.cases) (erule pick_middlep[THEN conjunct2])
   3.100 -
   3.101 -lemma csquare_fstOp_sndOp:
   3.102 -"csquare (Collect (split (P OO Q))) snd fst (fstOp P Q) (sndOp P Q)"
   3.103 -unfolding csquare_def fstOp_def sndOp_def using pick_middlep by simp
   3.104 -
   3.105 -lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
   3.106 -by (simp split: prod.split)
   3.107 -
   3.108 -lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
   3.109 -by (simp split: prod.split)
   3.110 -
   3.111 -lemma flip_pred: "A \<subseteq> Collect (split (R ^--1)) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> Collect (split R)"
   3.112 -by auto
   3.113 -
   3.114 -lemma Collect_split_mono: "A \<le> B \<Longrightarrow> Collect (split A) \<subseteq> Collect (split B)"
   3.115 -  by auto
   3.116 -
   3.117 -lemma Collect_split_mono_strong: 
   3.118 -  "\<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>
   3.119 -  A \<subseteq> Collect (split Q)"
   3.120 -  by fastforce
   3.121 -
   3.122 -lemma predicate2_eqD: "A = B \<Longrightarrow> A a b \<longleftrightarrow> B a b"
   3.123 -by metis
   3.124 -
   3.125 -lemma sum_case_o_inj:
   3.126 -"sum_case f g \<circ> Inl = f"
   3.127 -"sum_case f g \<circ> Inr = g"
   3.128 -by auto
   3.129 -
   3.130 -lemma card_order_csum_cone_cexp_def:
   3.131 -  "card_order r \<Longrightarrow> ( |A1| +c cone) ^c r = |Func UNIV (Inl ` A1 \<union> {Inr ()})|"
   3.132 -  unfolding cexp_def cone_def Field_csum Field_card_of by (auto dest: Field_card_order)
   3.133 -
   3.134 -lemma If_the_inv_into_in_Func:
   3.135 -  "\<lbrakk>inj_on g C; C \<subseteq> B \<union> {x}\<rbrakk> \<Longrightarrow>
   3.136 -  (\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) \<in> Func UNIV (B \<union> {x})"
   3.137 -unfolding Func_def by (auto dest: the_inv_into_into)
   3.138 -
   3.139 -lemma If_the_inv_into_f_f:
   3.140 -  "\<lbrakk>i \<in> C; inj_on g C\<rbrakk> \<Longrightarrow>
   3.141 -  ((\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) o g) i = id i"
   3.142 -unfolding Func_def by (auto elim: the_inv_into_f_f)
   3.143 -
   3.144 -definition vimage2p where
   3.145 -  "vimage2p f g R = (\<lambda>x y. R (f x) (g y))"
   3.146 -
   3.147 -lemma vimage2pI: "R (f x) (g y) \<Longrightarrow> vimage2p f g R x y"
   3.148 -  unfolding vimage2p_def by -
   3.149 -
   3.150 -lemma fun_rel_iff_leq_vimage2p: "(fun_rel R S) f g = (R \<le> vimage2p f g S)"
   3.151 -  unfolding fun_rel_def vimage2p_def by auto
   3.152 -
   3.153 -lemma convol_image_vimage2p: "<f o fst, g o snd> ` Collect (split (vimage2p f g R)) \<subseteq> Collect (split R)"
   3.154 -  unfolding vimage2p_def convol_def by auto
   3.155 -
   3.156 -lemma vimage2p_Grp: "vimage2p f g P = Grp UNIV f OO P OO (Grp UNIV g)\<inverse>\<inverse>"
   3.157 -  unfolding vimage2p_def Grp_def by auto
   3.158 -
   3.159 -(*FIXME: duplicates lemma from Record.thy*)
   3.160 -lemma o_eq_dest_lhs: "a o b = c \<Longrightarrow> a (b v) = c v"
   3.161 -  by clarsimp
   3.162 -
   3.163 -ML_file "Tools/bnf_def_tactics.ML"
   3.164 -ML_file "Tools/bnf_def.ML"
   3.165 -
   3.166 -end
     4.1 --- a/src/HOL/BNF/BNF_FP_Base.thy	Mon Jan 20 18:24:55 2014 +0100
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,170 +0,0 @@
     4.4 -(*  Title:      HOL/BNF/BNF_FP_Base.thy
     4.5 -    Author:     Lorenz Panny, TU Muenchen
     4.6 -    Author:     Dmitriy Traytel, TU Muenchen
     4.7 -    Author:     Jasmin Blanchette, TU Muenchen
     4.8 -    Copyright   2012, 2013
     4.9 -
    4.10 -Shared fixed point operations on bounded natural functors, including
    4.11 -*)
    4.12 -
    4.13 -header {* Shared Fixed Point Operations on Bounded Natural Functors *}
    4.14 -
    4.15 -theory BNF_FP_Base
    4.16 -imports BNF_Comp Ctr_Sugar
    4.17 -begin
    4.18 -
    4.19 -lemma mp_conj: "(P \<longrightarrow> Q) \<and> R \<Longrightarrow> P \<Longrightarrow> R \<and> Q"
    4.20 -by auto
    4.21 -
    4.22 -lemma eq_sym_Unity_conv: "(x = (() = ())) = x"
    4.23 -by blast
    4.24 -
    4.25 -lemma unit_case_Unity: "(case u of () \<Rightarrow> f) = f"
    4.26 -by (cases u) (hypsubst, rule unit.cases)
    4.27 -
    4.28 -lemma prod_case_Pair_iden: "(case p of (x, y) \<Rightarrow> (x, y)) = p"
    4.29 -by simp
    4.30 -
    4.31 -lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
    4.32 -by simp
    4.33 -
    4.34 -lemma prod_all_impI: "(\<And>x y. P (x, y) \<Longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
    4.35 -by clarify
    4.36 -
    4.37 -lemma prod_all_impI_step: "(\<And>x. \<forall>y. P (x, y) \<longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
    4.38 -by auto
    4.39 -
    4.40 -lemma pointfree_idE: "f \<circ> g = id \<Longrightarrow> f (g x) = x"
    4.41 -unfolding o_def fun_eq_iff by simp
    4.42 -
    4.43 -lemma o_bij:
    4.44 -  assumes gf: "g \<circ> f = id" and fg: "f \<circ> g = id"
    4.45 -  shows "bij f"
    4.46 -unfolding bij_def inj_on_def surj_def proof safe
    4.47 -  fix a1 a2 assume "f a1 = f a2"
    4.48 -  hence "g ( f a1) = g (f a2)" by simp
    4.49 -  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
    4.50 -next
    4.51 -  fix b
    4.52 -  have "b = f (g b)"
    4.53 -  using fg unfolding fun_eq_iff by simp
    4.54 -  thus "EX a. b = f a" by blast
    4.55 -qed
    4.56 -
    4.57 -lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
    4.58 -
    4.59 -lemma sum_case_step:
    4.60 -"sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
    4.61 -"sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
    4.62 -by auto
    4.63 -
    4.64 -lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
    4.65 -by simp
    4.66 -
    4.67 -lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
    4.68 -by blast
    4.69 -
    4.70 -lemma obj_sumE_f:
    4.71 -"\<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"
    4.72 -by (rule allI) (metis sumE)
    4.73 -
    4.74 -lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
    4.75 -by (cases s) auto
    4.76 -
    4.77 -lemma sum_case_if:
    4.78 -"sum_case f g (if p then Inl x else Inr y) = (if p then f x else g y)"
    4.79 -by simp
    4.80 -
    4.81 -lemma mem_UN_compreh_eq: "(z : \<Union>{y. \<exists>x\<in>A. y = F x}) = (\<exists>x\<in>A. z : F x)"
    4.82 -by blast
    4.83 -
    4.84 -lemma UN_compreh_eq_eq:
    4.85 -"\<Union>{y. \<exists>x\<in>A. y = {}} = {}"
    4.86 -"\<Union>{y. \<exists>x\<in>A. y = {x}} = A"
    4.87 -by blast+
    4.88 -
    4.89 -lemma Inl_Inr_False: "(Inl x = Inr y) = False"
    4.90 -by simp
    4.91 -
    4.92 -lemma prod_set_simps:
    4.93 -"fsts (x, y) = {x}"
    4.94 -"snds (x, y) = {y}"
    4.95 -unfolding fsts_def snds_def by simp+
    4.96 -
    4.97 -lemma sum_set_simps:
    4.98 -"setl (Inl x) = {x}"
    4.99 -"setl (Inr x) = {}"
   4.100 -"setr (Inl x) = {}"
   4.101 -"setr (Inr x) = {x}"
   4.102 -unfolding sum_set_defs by simp+
   4.103 -
   4.104 -lemma prod_rel_simp:
   4.105 -"prod_rel P Q (x, y) (x', y') \<longleftrightarrow> P x x' \<and> Q y y'"
   4.106 -unfolding prod_rel_def by simp
   4.107 -
   4.108 -lemma sum_rel_simps:
   4.109 -"sum_rel P Q (Inl x) (Inl x') \<longleftrightarrow> P x x'"
   4.110 -"sum_rel P Q (Inr y) (Inr y') \<longleftrightarrow> Q y y'"
   4.111 -"sum_rel P Q (Inl x) (Inr y') \<longleftrightarrow> False"
   4.112 -"sum_rel P Q (Inr y) (Inl x') \<longleftrightarrow> False"
   4.113 -unfolding sum_rel_def by simp+
   4.114 -
   4.115 -lemma spec2: "\<forall>x y. P x y \<Longrightarrow> P x y"
   4.116 -by blast
   4.117 -
   4.118 -lemma rewriteR_comp_comp: "\<lbrakk>g o h = r\<rbrakk> \<Longrightarrow> f o g o h = f o r"
   4.119 -  unfolding o_def fun_eq_iff by auto
   4.120 -
   4.121 -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"
   4.122 -  unfolding o_def fun_eq_iff by auto
   4.123 -
   4.124 -lemma rewriteL_comp_comp: "\<lbrakk>f o g = l\<rbrakk> \<Longrightarrow> f o (g o h) = l o h"
   4.125 -  unfolding o_def fun_eq_iff by auto
   4.126 -
   4.127 -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"
   4.128 -  unfolding o_def fun_eq_iff by auto
   4.129 -
   4.130 -lemma convol_o: "<f, g> o h = <f o h, g o h>"
   4.131 -  unfolding convol_def by auto
   4.132 -
   4.133 -lemma map_pair_o_convol: "map_pair h1 h2 o <f, g> = <h1 o f, h2 o g>"
   4.134 -  unfolding convol_def by auto
   4.135 -
   4.136 -lemma map_pair_o_convol_id: "(map_pair f id \<circ> <id , g>) x = <id \<circ> f , g> x"
   4.137 -  unfolding map_pair_o_convol id_o o_id ..
   4.138 -
   4.139 -lemma o_sum_case: "h o sum_case f g = sum_case (h o f) (h o g)"
   4.140 -  unfolding o_def by (auto split: sum.splits)
   4.141 -
   4.142 -lemma sum_case_o_sum_map: "sum_case f g o sum_map h1 h2 = sum_case (f o h1) (g o h2)"
   4.143 -  unfolding o_def by (auto split: sum.splits)
   4.144 -
   4.145 -lemma sum_case_o_sum_map_id: "(sum_case id g o sum_map f id) x = sum_case (f o id) g x"
   4.146 -  unfolding sum_case_o_sum_map id_o o_id ..
   4.147 -
   4.148 -lemma fun_rel_def_butlast:
   4.149 -  "(fun_rel R (fun_rel S T)) f g = (\<forall>x y. R x y \<longrightarrow> (fun_rel S T) (f x) (g y))"
   4.150 -  unfolding fun_rel_def ..
   4.151 -
   4.152 -lemma subst_eq_imp: "(\<forall>a b. a = b \<longrightarrow> P a b) \<equiv> (\<forall>a. P a a)"
   4.153 -  by auto
   4.154 -
   4.155 -lemma eq_subset: "op = \<le> (\<lambda>a b. P a b \<or> a = b)"
   4.156 -  by auto
   4.157 -
   4.158 -lemma eq_le_Grp_id_iff: "(op = \<le> Grp (Collect R) id) = (All R)"
   4.159 -  unfolding Grp_def id_apply by blast
   4.160 -
   4.161 -lemma Grp_id_mono_subst: "(\<And>x y. Grp P id x y \<Longrightarrow> Grp Q id (f x) (f y)) \<equiv>
   4.162 -   (\<And>x. x \<in> P \<Longrightarrow> f x \<in> Q)"
   4.163 -  unfolding Grp_def by rule auto
   4.164 -
   4.165 -ML_file "Tools/bnf_fp_util.ML"
   4.166 -ML_file "Tools/bnf_fp_def_sugar_tactics.ML"
   4.167 -ML_file "Tools/bnf_fp_def_sugar.ML"
   4.168 -ML_file "Tools/bnf_fp_n2m_tactics.ML"
   4.169 -ML_file "Tools/bnf_fp_n2m.ML"
   4.170 -ML_file "Tools/bnf_fp_n2m_sugar.ML"
   4.171 -ML_file "Tools/bnf_fp_rec_sugar_util.ML"
   4.172 -
   4.173 -end
     5.1 --- a/src/HOL/BNF/BNF_GFP.thy	Mon Jan 20 18:24:55 2014 +0100
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,356 +0,0 @@
     5.4 -(*  Title:      HOL/BNF/BNF_GFP.thy
     5.5 -    Author:     Dmitriy Traytel, TU Muenchen
     5.6 -    Copyright   2012
     5.7 -
     5.8 -Greatest fixed point operation on bounded natural functors.
     5.9 -*)
    5.10 -
    5.11 -header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
    5.12 -
    5.13 -theory BNF_GFP
    5.14 -imports BNF_FP_Base
    5.15 -keywords
    5.16 -  "codatatype" :: thy_decl and
    5.17 -  "primcorecursive" :: thy_goal and
    5.18 -  "primcorec" :: thy_decl
    5.19 -begin
    5.20 -
    5.21 -setup {*
    5.22 -Sign.const_alias @{binding proj} @{const_name Equiv_Relations.proj}
    5.23 -*}
    5.24 -
    5.25 -lemma not_TrueE: "\<not> True \<Longrightarrow> P"
    5.26 -by (erule notE, rule TrueI)
    5.27 -
    5.28 -lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
    5.29 -by fast
    5.30 -
    5.31 -lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
    5.32 -by (auto split: sum.splits)
    5.33 -
    5.34 -lemma sum_case_expand_Inr': "f o Inl = g \<Longrightarrow> h = f o Inr \<longleftrightarrow> sum_case g h = f"
    5.35 -apply rule
    5.36 - apply (rule ext, force split: sum.split)
    5.37 -by (rule ext, metis sum_case_o_inj(2))
    5.38 -
    5.39 -lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
    5.40 -by fast
    5.41 -
    5.42 -lemma equiv_proj:
    5.43 -  assumes e: "equiv A R" and "z \<in> R"
    5.44 -  shows "(proj R o fst) z = (proj R o snd) z"
    5.45 -proof -
    5.46 -  from assms(2) have z: "(fst z, snd z) \<in> R" by auto
    5.47 -  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"
    5.48 -    unfolding equiv_def sym_def trans_def by blast+
    5.49 -  then show ?thesis unfolding proj_def[abs_def] by auto
    5.50 -qed
    5.51 -
    5.52 -(* Operators: *)
    5.53 -definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
    5.54 -
    5.55 -lemma Id_onD: "(a, b) \<in> Id_on A \<Longrightarrow> a = b"
    5.56 -unfolding Id_on_def by simp
    5.57 -
    5.58 -lemma Id_onD': "x \<in> Id_on A \<Longrightarrow> fst x = snd x"
    5.59 -unfolding Id_on_def by auto
    5.60 -
    5.61 -lemma Id_on_fst: "x \<in> Id_on A \<Longrightarrow> fst x \<in> A"
    5.62 -unfolding Id_on_def by auto
    5.63 -
    5.64 -lemma Id_on_UNIV: "Id_on UNIV = Id"
    5.65 -unfolding Id_on_def by auto
    5.66 -
    5.67 -lemma Id_on_Comp: "Id_on A = Id_on A O Id_on A"
    5.68 -unfolding Id_on_def by auto
    5.69 -
    5.70 -lemma Id_on_Gr: "Id_on A = Gr A id"
    5.71 -unfolding Id_on_def Gr_def by auto
    5.72 -
    5.73 -lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
    5.74 -unfolding image2_def by auto
    5.75 -
    5.76 -lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
    5.77 -by auto
    5.78 -
    5.79 -lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
    5.80 -unfolding image2_def Gr_def by auto
    5.81 -
    5.82 -lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
    5.83 -unfolding Gr_def by simp
    5.84 -
    5.85 -lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
    5.86 -unfolding Gr_def by simp
    5.87 -
    5.88 -lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
    5.89 -unfolding Gr_def by auto
    5.90 -
    5.91 -lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
    5.92 -by blast
    5.93 -
    5.94 -lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
    5.95 -by blast
    5.96 -
    5.97 -lemma in_rel_Collect_split_eq: "in_rel (Collect (split X)) = X"
    5.98 -unfolding fun_eq_iff by auto
    5.99 -
   5.100 -lemma Collect_split_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (split (in_rel Y))"
   5.101 -by auto
   5.102 -
   5.103 -lemma Collect_split_in_rel_leE: "X \<subseteq> Collect (split (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
   5.104 -by force
   5.105 -
   5.106 -lemma Collect_split_in_relI: "x \<in> X \<Longrightarrow> x \<in> Collect (split (in_rel X))"
   5.107 -by auto
   5.108 -
   5.109 -lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
   5.110 -unfolding fun_eq_iff by auto
   5.111 -
   5.112 -lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
   5.113 -unfolding fun_eq_iff by auto
   5.114 -
   5.115 -lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
   5.116 -unfolding Gr_def Grp_def fun_eq_iff by auto
   5.117 -
   5.118 -lemma in_rel_Id_on_UNIV: "in_rel (Id_on UNIV) = op ="
   5.119 -unfolding fun_eq_iff by auto
   5.120 -
   5.121 -definition relImage where
   5.122 -"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
   5.123 -
   5.124 -definition relInvImage where
   5.125 -"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
   5.126 -
   5.127 -lemma relImage_Gr:
   5.128 -"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
   5.129 -unfolding relImage_def Gr_def relcomp_def by auto
   5.130 -
   5.131 -lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
   5.132 -unfolding Gr_def relcomp_def image_def relInvImage_def by auto
   5.133 -
   5.134 -lemma relImage_mono:
   5.135 -"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
   5.136 -unfolding relImage_def by auto
   5.137 -
   5.138 -lemma relInvImage_mono:
   5.139 -"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
   5.140 -unfolding relInvImage_def by auto
   5.141 -
   5.142 -lemma relInvImage_Id_on:
   5.143 -"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
   5.144 -unfolding relInvImage_def Id_on_def by auto
   5.145 -
   5.146 -lemma relInvImage_UNIV_relImage:
   5.147 -"R \<subseteq> relInvImage UNIV (relImage R f) f"
   5.148 -unfolding relInvImage_def relImage_def by auto
   5.149 -
   5.150 -lemma relImage_proj:
   5.151 -assumes "equiv A R"
   5.152 -shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
   5.153 -unfolding relImage_def Id_on_def
   5.154 -using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
   5.155 -by (auto simp: proj_preserves)
   5.156 -
   5.157 -lemma relImage_relInvImage:
   5.158 -assumes "R \<subseteq> f ` A <*> f ` A"
   5.159 -shows "relImage (relInvImage A R f) f = R"
   5.160 -using assms unfolding relImage_def relInvImage_def by fast
   5.161 -
   5.162 -lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
   5.163 -by simp
   5.164 -
   5.165 -lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
   5.166 -by simp
   5.167 -
   5.168 -lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
   5.169 -by simp
   5.170 -
   5.171 -lemma image_convolD: "\<lbrakk>(a, b) \<in> <f, g> ` X\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> X \<and> a = f x \<and> b = g x"
   5.172 -unfolding convol_def by auto
   5.173 -
   5.174 -(*Extended Sublist*)
   5.175 -
   5.176 -definition clists where "clists r = |lists (Field r)|"
   5.177 -
   5.178 -definition prefCl where
   5.179 -  "prefCl Kl = (\<forall> kl1 kl2. prefixeq kl1 kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
   5.180 -definition PrefCl where
   5.181 -  "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> prefixeq kl' kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
   5.182 -
   5.183 -lemma prefCl_UN:
   5.184 -  "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
   5.185 -unfolding prefCl_def PrefCl_def by fastforce
   5.186 -
   5.187 -definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
   5.188 -definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
   5.189 -definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
   5.190 -
   5.191 -lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
   5.192 -unfolding Shift_def Succ_def by simp
   5.193 -
   5.194 -lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
   5.195 -unfolding Shift_def clists_def Field_card_of by auto
   5.196 -
   5.197 -lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
   5.198 -unfolding prefCl_def Shift_def
   5.199 -proof safe
   5.200 -  fix kl1 kl2
   5.201 -  assume "\<forall>kl1 kl2. prefixeq kl1 kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
   5.202 -    "prefixeq kl1 kl2" "k # kl2 \<in> Kl"
   5.203 -  thus "k # kl1 \<in> Kl" using Cons_prefixeq_Cons[of k kl1 k kl2] by blast
   5.204 -qed
   5.205 -
   5.206 -lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
   5.207 -unfolding Shift_def by simp
   5.208 -
   5.209 -lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
   5.210 -unfolding Succ_def by simp
   5.211 -
   5.212 -lemmas SuccE = SuccD[elim_format]
   5.213 -
   5.214 -lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
   5.215 -unfolding Succ_def by simp
   5.216 -
   5.217 -lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
   5.218 -unfolding Shift_def by simp
   5.219 -
   5.220 -lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
   5.221 -unfolding Succ_def Shift_def by auto
   5.222 -
   5.223 -lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
   5.224 -unfolding clists_def Field_card_of by auto
   5.225 -
   5.226 -lemma Cons_clists:
   5.227 -  "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
   5.228 -unfolding clists_def Field_card_of by auto
   5.229 -
   5.230 -lemma length_Cons: "length (x # xs) = Suc (length xs)"
   5.231 -by simp
   5.232 -
   5.233 -lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
   5.234 -by simp
   5.235 -
   5.236 -(*injection into the field of a cardinal*)
   5.237 -definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
   5.238 -definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
   5.239 -
   5.240 -lemma ex_toCard_pred:
   5.241 -"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
   5.242 -unfolding toCard_pred_def
   5.243 -using card_of_ordLeq[of A "Field r"]
   5.244 -      ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
   5.245 -by blast
   5.246 -
   5.247 -lemma toCard_pred_toCard:
   5.248 -  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
   5.249 -unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
   5.250 -
   5.251 -lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
   5.252 -  toCard A r x = toCard A r y \<longleftrightarrow> x = y"
   5.253 -using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
   5.254 -
   5.255 -lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
   5.256 -using toCard_pred_toCard unfolding toCard_pred_def by blast
   5.257 -
   5.258 -definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
   5.259 -
   5.260 -lemma fromCard_toCard:
   5.261 -"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
   5.262 -unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
   5.263 -
   5.264 -lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
   5.265 -unfolding Field_card_of csum_def by auto
   5.266 -
   5.267 -lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
   5.268 -unfolding Field_card_of csum_def by auto
   5.269 -
   5.270 -lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
   5.271 -by auto
   5.272 -
   5.273 -lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
   5.274 -by auto
   5.275 -
   5.276 -lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
   5.277 -by auto
   5.278 -
   5.279 -lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
   5.280 -by auto
   5.281 -
   5.282 -lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
   5.283 -by simp
   5.284 -
   5.285 -lemma Collect_splitD: "x \<in> Collect (split A) \<Longrightarrow> A (fst x) (snd x)"
   5.286 -by auto
   5.287 -
   5.288 -definition image2p where
   5.289 -  "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"
   5.290 -
   5.291 -lemma image2pI: "R x y \<Longrightarrow> (image2p f g R) (f x) (g y)"
   5.292 -  unfolding image2p_def by blast
   5.293 -
   5.294 -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"
   5.295 -  unfolding image2p_def by blast
   5.296 -
   5.297 -lemma fun_rel_iff_geq_image2p: "(fun_rel R S) f g = (image2p f g R \<le> S)"
   5.298 -  unfolding fun_rel_def image2p_def by auto
   5.299 -
   5.300 -lemma fun_rel_image2p: "(fun_rel R (image2p f g R)) f g"
   5.301 -  unfolding fun_rel_def image2p_def by auto
   5.302 -
   5.303 -
   5.304 -subsection {* Equivalence relations, quotients, and Hilbert's choice *}
   5.305 -
   5.306 -lemma equiv_Eps_in:
   5.307 -"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
   5.308 -apply (rule someI2_ex)
   5.309 -using in_quotient_imp_non_empty by blast
   5.310 -
   5.311 -lemma equiv_Eps_preserves:
   5.312 -assumes ECH: "equiv A r" and X: "X \<in> A//r"
   5.313 -shows "Eps (%x. x \<in> X) \<in> A"
   5.314 -apply (rule in_mono[rule_format])
   5.315 - using assms apply (rule in_quotient_imp_subset)
   5.316 -by (rule equiv_Eps_in) (rule assms)+
   5.317 -
   5.318 -lemma proj_Eps:
   5.319 -assumes "equiv A r" and "X \<in> A//r"
   5.320 -shows "proj r (Eps (%x. x \<in> X)) = X"
   5.321 -unfolding proj_def proof auto
   5.322 -  fix x assume x: "x \<in> X"
   5.323 -  thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
   5.324 -next
   5.325 -  fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
   5.326 -  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
   5.327 -qed
   5.328 -
   5.329 -definition univ where "univ f X == f (Eps (%x. x \<in> X))"
   5.330 -
   5.331 -lemma univ_commute:
   5.332 -assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
   5.333 -shows "(univ f) (proj r x) = f x"
   5.334 -unfolding univ_def proof -
   5.335 -  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
   5.336 -  hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
   5.337 -  moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
   5.338 -  ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
   5.339 -  thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
   5.340 -qed
   5.341 -
   5.342 -lemma univ_preserves:
   5.343 -assumes ECH: "equiv A r" and RES: "f respects r" and
   5.344 -        PRES: "\<forall> x \<in> A. f x \<in> B"
   5.345 -shows "\<forall> X \<in> A//r. univ f X \<in> B"
   5.346 -proof
   5.347 -  fix X assume "X \<in> A//r"
   5.348 -  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
   5.349 -  hence "univ f X = f x" using assms univ_commute by fastforce
   5.350 -  thus "univ f X \<in> B" using x PRES by simp
   5.351 -qed
   5.352 -
   5.353 -ML_file "Tools/bnf_gfp_rec_sugar_tactics.ML"
   5.354 -ML_file "Tools/bnf_gfp_rec_sugar.ML"
   5.355 -ML_file "Tools/bnf_gfp_util.ML"
   5.356 -ML_file "Tools/bnf_gfp_tactics.ML"
   5.357 -ML_file "Tools/bnf_gfp.ML"
   5.358 -
   5.359 -end
     6.1 --- a/src/HOL/BNF/BNF_LFP.thy	Mon Jan 20 18:24:55 2014 +0100
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,243 +0,0 @@
     6.4 -(*  Title:      HOL/BNF/BNF_LFP.thy
     6.5 -    Author:     Dmitriy Traytel, TU Muenchen
     6.6 -    Author:     Lorenz Panny, TU Muenchen
     6.7 -    Author:     Jasmin Blanchette, TU Muenchen
     6.8 -    Copyright   2012, 2013
     6.9 -
    6.10 -Least fixed point operation on bounded natural functors.
    6.11 -*)
    6.12 -
    6.13 -header {* Least Fixed Point Operation on Bounded Natural Functors *}
    6.14 -
    6.15 -theory BNF_LFP
    6.16 -imports BNF_FP_Base
    6.17 -keywords
    6.18 -  "datatype_new" :: thy_decl and
    6.19 -  "datatype_new_compat" :: thy_decl and
    6.20 -  "primrec_new" :: thy_decl
    6.21 -begin
    6.22 -
    6.23 -lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
    6.24 -by blast
    6.25 -
    6.26 -lemma image_Collect_subsetI:
    6.27 -  "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
    6.28 -by blast
    6.29 -
    6.30 -lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
    6.31 -by auto
    6.32 -
    6.33 -lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
    6.34 -by auto
    6.35 -
    6.36 -lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> underS R j"
    6.37 -unfolding underS_def by simp
    6.38 -
    6.39 -lemma underS_E: "i \<in> underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
    6.40 -unfolding underS_def by simp
    6.41 -
    6.42 -lemma underS_Field: "i \<in> underS R j \<Longrightarrow> i \<in> Field R"
    6.43 -unfolding underS_def Field_def by auto
    6.44 -
    6.45 -lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
    6.46 -unfolding Field_def by auto
    6.47 -
    6.48 -lemma fst_convol': "fst (<f, g> x) = f x"
    6.49 -using fst_convol unfolding convol_def by simp
    6.50 -
    6.51 -lemma snd_convol': "snd (<f, g> x) = g x"
    6.52 -using snd_convol unfolding convol_def by simp
    6.53 -
    6.54 -lemma convol_expand_snd: "fst o f = g \<Longrightarrow>  <g, snd o f> = f"
    6.55 -unfolding convol_def by auto
    6.56 -
    6.57 -lemma convol_expand_snd': "(fst o f = g) \<Longrightarrow> (h = snd o f) \<longleftrightarrow> (<g, h> = f)"
    6.58 -  by (metis convol_expand_snd snd_convol)
    6.59 -
    6.60 -definition inver where
    6.61 -  "inver g f A = (ALL a : A. g (f a) = a)"
    6.62 -
    6.63 -lemma bij_betw_iff_ex:
    6.64 -  "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
    6.65 -proof (rule iffI)
    6.66 -  assume ?L
    6.67 -  hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
    6.68 -  let ?phi = "% b a. a : A \<and> f a = b"
    6.69 -  have "ALL b : B. EX a. ?phi b a" using f by blast
    6.70 -  then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
    6.71 -    using bchoice[of B ?phi] by blast
    6.72 -  hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
    6.73 -  have gf: "inver g f A" unfolding inver_def
    6.74 -    by (metis (no_types) gg imageI[of _ A f] the_inv_into_f_f[OF inj_f])
    6.75 -  moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
    6.76 -  moreover have "A \<le> g ` B"
    6.77 -  proof safe
    6.78 -    fix a assume a: "a : A"
    6.79 -    hence "f a : B" using f by auto
    6.80 -    moreover have "a = g (f a)" using a gf unfolding inver_def by auto
    6.81 -    ultimately show "a : g ` B" by blast
    6.82 -  qed
    6.83 -  ultimately show ?R by blast
    6.84 -next
    6.85 -  assume ?R
    6.86 -  then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
    6.87 -  show ?L unfolding bij_betw_def
    6.88 -  proof safe
    6.89 -    show "inj_on f A" unfolding inj_on_def
    6.90 -    proof safe
    6.91 -      fix a1 a2 assume a: "a1 : A"  "a2 : A" and "f a1 = f a2"
    6.92 -      hence "g (f a1) = g (f a2)" by simp
    6.93 -      thus "a1 = a2" using a g unfolding inver_def by simp
    6.94 -    qed
    6.95 -  next
    6.96 -    fix a assume "a : A"
    6.97 -    then obtain b where b: "b : B" and a: "a = g b" using g by blast
    6.98 -    hence "b = f (g b)" using g unfolding inver_def by auto
    6.99 -    thus "f a : B" unfolding a using b by simp
   6.100 -  next
   6.101 -    fix b assume "b : B"
   6.102 -    hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
   6.103 -    thus "b : f ` A" by auto
   6.104 -  qed
   6.105 -qed
   6.106 -
   6.107 -lemma bij_betw_ex_weakE:
   6.108 -  "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
   6.109 -by (auto simp only: bij_betw_iff_ex)
   6.110 -
   6.111 -lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
   6.112 -unfolding inver_def by auto (rule rev_image_eqI, auto)
   6.113 -
   6.114 -lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
   6.115 -unfolding inver_def by auto
   6.116 -
   6.117 -lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
   6.118 -unfolding inver_def by simp
   6.119 -
   6.120 -lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
   6.121 -unfolding bij_betw_def by auto
   6.122 -
   6.123 -lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
   6.124 -unfolding bij_betw_def by auto
   6.125 -
   6.126 -lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
   6.127 -unfolding inver_def by auto
   6.128 -
   6.129 -lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
   6.130 -unfolding bij_betw_def inver_def by auto
   6.131 -
   6.132 -lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
   6.133 -unfolding bij_betw_def inver_def by auto
   6.134 -
   6.135 -lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
   6.136 -by (drule bij_betw_imageE, unfold bij_betw_iff_ex) blast
   6.137 -
   6.138 -lemma bij_betwI':
   6.139 -  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
   6.140 -    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
   6.141 -    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
   6.142 -unfolding bij_betw_def inj_on_def by blast
   6.143 -
   6.144 -lemma surj_fun_eq:
   6.145 -  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
   6.146 -  shows "g1 = g2"
   6.147 -proof (rule ext)
   6.148 -  fix y
   6.149 -  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
   6.150 -  thus "g1 y = g2 y" using eq_on by simp
   6.151 -qed
   6.152 -
   6.153 -lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
   6.154 -unfolding wo_rel_def card_order_on_def by blast
   6.155 -
   6.156 -lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
   6.157 -  \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
   6.158 -unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
   6.159 -
   6.160 -lemma Card_order_trans:
   6.161 -  "\<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"
   6.162 -unfolding card_order_on_def well_order_on_def linear_order_on_def
   6.163 -  partial_order_on_def preorder_on_def trans_def antisym_def by blast
   6.164 -
   6.165 -lemma Cinfinite_limit2:
   6.166 - assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
   6.167 - shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
   6.168 -proof -
   6.169 -  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
   6.170 -    unfolding card_order_on_def well_order_on_def linear_order_on_def
   6.171 -      partial_order_on_def preorder_on_def by auto
   6.172 -  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
   6.173 -    using Cinfinite_limit[OF x1 r] by blast
   6.174 -  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
   6.175 -    using Cinfinite_limit[OF x2 r] by blast
   6.176 -  show ?thesis
   6.177 -  proof (cases "y1 = y2")
   6.178 -    case True with y1 y2 show ?thesis by blast
   6.179 -  next
   6.180 -    case False
   6.181 -    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
   6.182 -      unfolding total_on_def by auto
   6.183 -    thus ?thesis
   6.184 -    proof
   6.185 -      assume *: "(y1, y2) \<in> r"
   6.186 -      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
   6.187 -      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
   6.188 -    next
   6.189 -      assume *: "(y2, y1) \<in> r"
   6.190 -      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
   6.191 -      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
   6.192 -    qed
   6.193 -  qed
   6.194 -qed
   6.195 -
   6.196 -lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
   6.197 - \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
   6.198 -proof (induct X rule: finite_induct)
   6.199 -  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
   6.200 -next
   6.201 -  case (insert x X)
   6.202 -  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
   6.203 -  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"
   6.204 -    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
   6.205 -  show ?case
   6.206 -    apply (intro bexI ballI)
   6.207 -    apply (erule insertE)
   6.208 -    apply hypsubst
   6.209 -    apply (rule z(2))
   6.210 -    using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
   6.211 -    apply blast
   6.212 -    apply (rule z(1))
   6.213 -    done
   6.214 -qed
   6.215 -
   6.216 -lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
   6.217 -by auto
   6.218 -
   6.219 -(*helps resolution*)
   6.220 -lemma well_order_induct_imp:
   6.221 -  "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>
   6.222 -     x \<in> Field r \<longrightarrow> P x"
   6.223 -by (erule wo_rel.well_order_induct)
   6.224 -
   6.225 -lemma meta_spec2:
   6.226 -  assumes "(\<And>x y. PROP P x y)"
   6.227 -  shows "PROP P x y"
   6.228 -by (rule `(\<And>x y. PROP P x y)`)
   6.229 -
   6.230 -lemma nchotomy_relcomppE:
   6.231 -  "\<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"
   6.232 -  by (metis relcompp.cases)
   6.233 -
   6.234 -lemma vimage2p_fun_rel: "(fun_rel (vimage2p f g R) R) f g"
   6.235 -  unfolding fun_rel_def vimage2p_def by auto
   6.236 -
   6.237 -lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
   6.238 -  unfolding vimage2p_def by auto
   6.239 -
   6.240 -ML_file "Tools/bnf_lfp_rec_sugar.ML"
   6.241 -ML_file "Tools/bnf_lfp_util.ML"
   6.242 -ML_file "Tools/bnf_lfp_tactics.ML"
   6.243 -ML_file "Tools/bnf_lfp.ML"
   6.244 -ML_file "Tools/bnf_lfp_compat.ML"
   6.245 -
   6.246 -end
     7.1 --- a/src/HOL/BNF/BNF_Util.thy	Mon Jan 20 18:24:55 2014 +0100
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,36 +0,0 @@
     7.4 -(*  Title:      HOL/BNF/BNF_Util.thy
     7.5 -    Author:     Dmitriy Traytel, TU Muenchen
     7.6 -    Author:     Jasmin Blanchette, TU Muenchen
     7.7 -    Copyright   2012
     7.8 -
     7.9 -Library for bounded natural functors.
    7.10 -*)
    7.11 -
    7.12 -header {* Library for Bounded Natural Functors *}
    7.13 -
    7.14 -theory BNF_Util
    7.15 -imports BNF_Cardinal_Arithmetic
    7.16 -  Transfer (*FIXME: define fun_rel here, reuse in Transfer once this theory is in HOL*)
    7.17 -begin
    7.18 -
    7.19 -definition collect where
    7.20 -"collect F x = (\<Union>f \<in> F. f x)"
    7.21 -
    7.22 -lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
    7.23 -by simp
    7.24 -
    7.25 -lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
    7.26 -by simp
    7.27 -
    7.28 -lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
    7.29 -unfolding bij_def inj_on_def by auto blast
    7.30 -
    7.31 -(* Operator: *)
    7.32 -definition "Gr A f = {(a, f a) | a. a \<in> A}"
    7.33 -
    7.34 -definition "Grp A f = (\<lambda>a b. b = f a \<and> a \<in> A)"
    7.35 -
    7.36 -ML_file "Tools/bnf_util.ML"
    7.37 -ML_file "Tools/bnf_tactics.ML"
    7.38 -
    7.39 -end
     8.1 --- a/src/HOL/BNF/Basic_BNFs.thy	Mon Jan 20 18:24:55 2014 +0100
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,204 +0,0 @@
     8.4 -(*  Title:      HOL/BNF/Basic_BNFs.thy
     8.5 -    Author:     Dmitriy Traytel, TU Muenchen
     8.6 -    Author:     Andrei Popescu, TU Muenchen
     8.7 -    Author:     Jasmin Blanchette, TU Muenchen
     8.8 -    Copyright   2012
     8.9 -
    8.10 -Registration of basic types as bounded natural functors.
    8.11 -*)
    8.12 -
    8.13 -header {* Registration of Basic Types as Bounded Natural Functors *}
    8.14 -
    8.15 -theory Basic_BNFs
    8.16 -imports BNF_Def
    8.17 -   (*FIXME: define relators here, reuse in Lifting_* once this theory is in HOL*)
    8.18 -  Lifting_Sum
    8.19 -  Lifting_Product
    8.20 -  Main
    8.21 -begin
    8.22 -
    8.23 -bnf ID: 'a
    8.24 -  map: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
    8.25 -  sets: "\<lambda>x. {x}"
    8.26 -  bd: natLeq
    8.27 -  rel: "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
    8.28 -apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
    8.29 -apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
    8.30 -apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
    8.31 -done
    8.32 -
    8.33 -bnf DEADID: 'a
    8.34 -  map: "id :: 'a \<Rightarrow> 'a"
    8.35 -  bd: "natLeq +c |UNIV :: 'a set|"
    8.36 -  rel: "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
    8.37 -by (auto simp add: Grp_def
    8.38 -  card_order_csum natLeq_card_order card_of_card_order_on
    8.39 -  cinfinite_csum natLeq_cinfinite)
    8.40 -
    8.41 -definition setl :: "'a + 'b \<Rightarrow> 'a set" where
    8.42 -"setl x = (case x of Inl z => {z} | _ => {})"
    8.43 -
    8.44 -definition setr :: "'a + 'b \<Rightarrow> 'b set" where
    8.45 -"setr x = (case x of Inr z => {z} | _ => {})"
    8.46 -
    8.47 -lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
    8.48 -
    8.49 -bnf "'a + 'b"
    8.50 -  map: sum_map
    8.51 -  sets: setl setr
    8.52 -  bd: natLeq
    8.53 -  wits: Inl Inr
    8.54 -  rel: sum_rel
    8.55 -proof -
    8.56 -  show "sum_map id id = id" by (rule sum_map.id)
    8.57 -next
    8.58 -  fix f1 :: "'o \<Rightarrow> 's" and f2 :: "'p \<Rightarrow> 't" and g1 :: "'s \<Rightarrow> 'q" and g2 :: "'t \<Rightarrow> 'r"
    8.59 -  show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
    8.60 -    by (rule sum_map.comp[symmetric])
    8.61 -next
    8.62 -  fix x and f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r" and g1 g2
    8.63 -  assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
    8.64 -         a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
    8.65 -  thus "sum_map f1 f2 x = sum_map g1 g2 x"
    8.66 -  proof (cases x)
    8.67 -    case Inl thus ?thesis using a1 by (clarsimp simp: setl_def)
    8.68 -  next
    8.69 -    case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
    8.70 -  qed
    8.71 -next
    8.72 -  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
    8.73 -  show "setl o sum_map f1 f2 = image f1 o setl"
    8.74 -    by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
    8.75 -next
    8.76 -  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
    8.77 -  show "setr o sum_map f1 f2 = image f2 o setr"
    8.78 -    by (rule ext, unfold o_apply) (simp add: setr_def split: sum.split)
    8.79 -next
    8.80 -  show "card_order natLeq" by (rule natLeq_card_order)
    8.81 -next
    8.82 -  show "cinfinite natLeq" by (rule natLeq_cinfinite)
    8.83 -next
    8.84 -  fix x :: "'o + 'p"
    8.85 -  show "|setl x| \<le>o natLeq"
    8.86 -    apply (rule ordLess_imp_ordLeq)
    8.87 -    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
    8.88 -    by (simp add: setl_def split: sum.split)
    8.89 -next
    8.90 -  fix x :: "'o + 'p"
    8.91 -  show "|setr x| \<le>o natLeq"
    8.92 -    apply (rule ordLess_imp_ordLeq)
    8.93 -    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
    8.94 -    by (simp add: setr_def split: sum.split)
    8.95 -next
    8.96 -  fix R1 R2 S1 S2
    8.97 -  show "sum_rel R1 R2 OO sum_rel S1 S2 \<le> sum_rel (R1 OO S1) (R2 OO S2)"
    8.98 -    by (auto simp: sum_rel_def split: sum.splits)
    8.99 -next
   8.100 -  fix R S
   8.101 -  show "sum_rel R S =
   8.102 -        (Grp {x. setl x \<subseteq> Collect (split R) \<and> setr x \<subseteq> Collect (split S)} (sum_map fst fst))\<inverse>\<inverse> OO
   8.103 -        Grp {x. setl x \<subseteq> Collect (split R) \<and> setr x \<subseteq> Collect (split S)} (sum_map snd snd)"
   8.104 -  unfolding setl_def setr_def sum_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
   8.105 -  by (fastforce split: sum.splits)
   8.106 -qed (auto simp: sum_set_defs)
   8.107 -
   8.108 -definition fsts :: "'a \<times> 'b \<Rightarrow> 'a set" where
   8.109 -"fsts x = {fst x}"
   8.110 -
   8.111 -definition snds :: "'a \<times> 'b \<Rightarrow> 'b set" where
   8.112 -"snds x = {snd x}"
   8.113 -
   8.114 -lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
   8.115 -
   8.116 -bnf "'a \<times> 'b"
   8.117 -  map: map_pair
   8.118 -  sets: fsts snds
   8.119 -  bd: natLeq
   8.120 -  rel: prod_rel
   8.121 -proof (unfold prod_set_defs)
   8.122 -  show "map_pair id id = id" by (rule map_pair.id)
   8.123 -next
   8.124 -  fix f1 f2 g1 g2
   8.125 -  show "map_pair (g1 o f1) (g2 o f2) = map_pair g1 g2 o map_pair f1 f2"
   8.126 -    by (rule map_pair.comp[symmetric])
   8.127 -next
   8.128 -  fix x f1 f2 g1 g2
   8.129 -  assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
   8.130 -  thus "map_pair f1 f2 x = map_pair g1 g2 x" by (cases x) simp
   8.131 -next
   8.132 -  fix f1 f2
   8.133 -  show "(\<lambda>x. {fst x}) o map_pair f1 f2 = image f1 o (\<lambda>x. {fst x})"
   8.134 -    by (rule ext, unfold o_apply) simp
   8.135 -next
   8.136 -  fix f1 f2
   8.137 -  show "(\<lambda>x. {snd x}) o map_pair f1 f2 = image f2 o (\<lambda>x. {snd x})"
   8.138 -    by (rule ext, unfold o_apply) simp
   8.139 -next
   8.140 -  show "card_order natLeq" by (rule natLeq_card_order)
   8.141 -next
   8.142 -  show "cinfinite natLeq" by (rule natLeq_cinfinite)
   8.143 -next
   8.144 -  fix x
   8.145 -  show "|{fst x}| \<le>o natLeq"
   8.146 -    by (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq finite.emptyI finite_insert)
   8.147 -next
   8.148 -  fix x
   8.149 -  show "|{snd x}| \<le>o natLeq"
   8.150 -    by (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq finite.emptyI finite_insert)
   8.151 -next
   8.152 -  fix R1 R2 S1 S2
   8.153 -  show "prod_rel R1 R2 OO prod_rel S1 S2 \<le> prod_rel (R1 OO S1) (R2 OO S2)" by auto
   8.154 -next
   8.155 -  fix R S
   8.156 -  show "prod_rel R S =
   8.157 -        (Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair fst fst))\<inverse>\<inverse> OO
   8.158 -        Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair snd snd)"
   8.159 -  unfolding prod_set_defs prod_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
   8.160 -  by auto
   8.161 -qed
   8.162 -
   8.163 -bnf "'a \<Rightarrow> 'b"
   8.164 -  map: "op \<circ>"
   8.165 -  sets: range
   8.166 -  bd: "natLeq +c |UNIV :: 'a set|"
   8.167 -  rel: "fun_rel op ="
   8.168 -proof
   8.169 -  fix f show "id \<circ> f = id f" by simp
   8.170 -next
   8.171 -  fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
   8.172 -  unfolding comp_def[abs_def] ..
   8.173 -next
   8.174 -  fix x f g
   8.175 -  assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
   8.176 -  thus "f \<circ> x = g \<circ> x" by auto
   8.177 -next
   8.178 -  fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
   8.179 -  unfolding image_def comp_def[abs_def] by auto
   8.180 -next
   8.181 -  show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
   8.182 -  apply (rule card_order_csum)
   8.183 -  apply (rule natLeq_card_order)
   8.184 -  by (rule card_of_card_order_on)
   8.185 -(*  *)
   8.186 -  show "cinfinite (natLeq +c ?U)"
   8.187 -    apply (rule cinfinite_csum)
   8.188 -    apply (rule disjI1)
   8.189 -    by (rule natLeq_cinfinite)
   8.190 -next
   8.191 -  fix f :: "'d => 'a"
   8.192 -  have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
   8.193 -  also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
   8.194 -  finally show "|range f| \<le>o natLeq +c ?U" .
   8.195 -next
   8.196 -  fix R S
   8.197 -  show "fun_rel op = R OO fun_rel op = S \<le> fun_rel op = (R OO S)" by (auto simp: fun_rel_def)
   8.198 -next
   8.199 -  fix R
   8.200 -  show "fun_rel op = R =
   8.201 -        (Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> fst))\<inverse>\<inverse> OO
   8.202 -         Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> snd)"
   8.203 -  unfolding fun_rel_def Grp_def fun_eq_iff relcompp.simps conversep.simps  subset_iff image_iff
   8.204 -  by auto (force, metis (no_types) pair_collapse)
   8.205 -qed
   8.206 -
   8.207 -end
     9.1 --- a/src/HOL/BNF/Tools/bnf_comp.ML	Mon Jan 20 18:24:55 2014 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,704 +0,0 @@
     9.4 -(*  Title:      HOL/BNF/Tools/bnf_comp.ML
     9.5 -    Author:     Dmitriy Traytel, TU Muenchen
     9.6 -    Author:     Jasmin Blanchette, TU Muenchen
     9.7 -    Copyright   2012
     9.8 -
     9.9 -Composition of bounded natural functors.
    9.10 -*)
    9.11 -
    9.12 -signature BNF_COMP =
    9.13 -sig
    9.14 -  val ID_bnf: BNF_Def.bnf
    9.15 -  val DEADID_bnf: BNF_Def.bnf
    9.16 -
    9.17 -  type unfold_set
    9.18 -  val empty_unfolds: unfold_set
    9.19 -
    9.20 -  exception BAD_DEAD of typ * typ
    9.21 -
    9.22 -  val bnf_of_typ: BNF_Def.const_policy -> (binding -> binding) ->
    9.23 -    ((string * sort) list list -> (string * sort) list) -> (string * sort) list -> typ ->
    9.24 -    unfold_set * Proof.context ->
    9.25 -    (BNF_Def.bnf * (typ list * typ list)) * (unfold_set * Proof.context)
    9.26 -  val default_comp_sort: (string * sort) list list -> (string * sort) list
    9.27 -  val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
    9.28 -    (''a list list -> ''a list) -> BNF_Def.bnf list -> unfold_set -> Proof.context ->
    9.29 -    (int list list * ''a list) * (BNF_Def.bnf list * (unfold_set * Proof.context))
    9.30 -  val seal_bnf: (binding -> binding) -> unfold_set -> binding -> typ list -> BNF_Def.bnf ->
    9.31 -    Proof.context -> (BNF_Def.bnf * typ list) * local_theory
    9.32 -end;
    9.33 -
    9.34 -structure BNF_Comp : BNF_COMP =
    9.35 -struct
    9.36 -
    9.37 -open BNF_Def
    9.38 -open BNF_Util
    9.39 -open BNF_Tactics
    9.40 -open BNF_Comp_Tactics
    9.41 -
    9.42 -val ID_bnf = the (bnf_of @{context} "Basic_BNFs.ID");
    9.43 -val DEADID_bnf = the (bnf_of @{context} "Basic_BNFs.DEADID");
    9.44 -
    9.45 -(* TODO: Replace by "BNF_Defs.defs list" *)
    9.46 -type unfold_set = {
    9.47 -  map_unfolds: thm list,
    9.48 -  set_unfoldss: thm list list,
    9.49 -  rel_unfolds: thm list
    9.50 -};
    9.51 -
    9.52 -val empty_unfolds = {map_unfolds = [], set_unfoldss = [], rel_unfolds = []};
    9.53 -
    9.54 -fun add_to_thms thms new = thms |> not (Thm.is_reflexive new) ? insert Thm.eq_thm new;
    9.55 -fun adds_to_thms thms news = insert (eq_set Thm.eq_thm) (no_reflexive news) thms;
    9.56 -
    9.57 -fun add_to_unfolds map sets rel
    9.58 -  {map_unfolds, set_unfoldss, rel_unfolds} =
    9.59 -  {map_unfolds = add_to_thms map_unfolds map,
    9.60 -    set_unfoldss = adds_to_thms set_unfoldss sets,
    9.61 -    rel_unfolds = add_to_thms rel_unfolds rel};
    9.62 -
    9.63 -fun add_bnf_to_unfolds bnf =
    9.64 -  add_to_unfolds (map_def_of_bnf bnf) (set_defs_of_bnf bnf) (rel_def_of_bnf bnf);
    9.65 -
    9.66 -val bdTN = "bdT";
    9.67 -
    9.68 -fun mk_killN n = "_kill" ^ string_of_int n;
    9.69 -fun mk_liftN n = "_lift" ^ string_of_int n;
    9.70 -fun mk_permuteN src dest =
    9.71 -  "_permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest);
    9.72 -
    9.73 -(*copied from Envir.expand_term_free*)
    9.74 -fun expand_term_const defs =
    9.75 -  let
    9.76 -    val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
    9.77 -    val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
    9.78 -  in Envir.expand_term get end;
    9.79 -
    9.80 -fun clean_compose_bnf const_policy qualify b outer inners (unfold_set, lthy) =
    9.81 -  let
    9.82 -    val olive = live_of_bnf outer;
    9.83 -    val onwits = nwits_of_bnf outer;
    9.84 -    val odead = dead_of_bnf outer;
    9.85 -    val inner = hd inners;
    9.86 -    val ilive = live_of_bnf inner;
    9.87 -    val ideads = map dead_of_bnf inners;
    9.88 -    val inwitss = map nwits_of_bnf inners;
    9.89 -
    9.90 -    (* TODO: check olive = length inners > 0,
    9.91 -                   forall inner from inners. ilive = live,
    9.92 -                   forall inner from inners. idead = dead  *)
    9.93 -
    9.94 -    val (oDs, lthy1) = apfst (map TFree)
    9.95 -      (Variable.invent_types (replicate odead HOLogic.typeS) lthy);
    9.96 -    val (Dss, lthy2) = apfst (map (map TFree))
    9.97 -        (fold_map Variable.invent_types (map (fn n => replicate n HOLogic.typeS) ideads) lthy1);
    9.98 -    val (Ass, lthy3) = apfst (replicate ilive o map TFree)
    9.99 -      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy2);
   9.100 -    val As = if ilive > 0 then hd Ass else [];
   9.101 -    val Ass_repl = replicate olive As;
   9.102 -    val (Bs, _(*lthy4*)) = apfst (map TFree)
   9.103 -      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy3);
   9.104 -    val Bss_repl = replicate olive Bs;
   9.105 -
   9.106 -    val ((((fs', Qs'), Asets), xs), _(*names_lthy*)) = lthy
   9.107 -      |> apfst snd o mk_Frees' "f" (map2 (curry op -->) As Bs)
   9.108 -      ||>> apfst snd o mk_Frees' "Q" (map2 mk_pred2T As Bs)
   9.109 -      ||>> mk_Frees "A" (map HOLogic.mk_setT As)
   9.110 -      ||>> mk_Frees "x" As;
   9.111 -
   9.112 -    val CAs = map3 mk_T_of_bnf Dss Ass_repl inners;
   9.113 -    val CCA = mk_T_of_bnf oDs CAs outer;
   9.114 -    val CBs = map3 mk_T_of_bnf Dss Bss_repl inners;
   9.115 -    val outer_sets = mk_sets_of_bnf (replicate olive oDs) (replicate olive CAs) outer;
   9.116 -    val inner_setss = map3 mk_sets_of_bnf (map (replicate ilive) Dss) (replicate olive Ass) inners;
   9.117 -    val inner_bds = map3 mk_bd_of_bnf Dss Ass_repl inners;
   9.118 -    val outer_bd = mk_bd_of_bnf oDs CAs outer;
   9.119 -
   9.120 -    (*%f1 ... fn. outer.map (inner_1.map f1 ... fn) ... (inner_m.map f1 ... fn)*)
   9.121 -    val mapx = fold_rev Term.abs fs'
   9.122 -      (Term.list_comb (mk_map_of_bnf oDs CAs CBs outer,
   9.123 -        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
   9.124 -          mk_map_of_bnf Ds As Bs) Dss inners));
   9.125 -    (*%Q1 ... Qn. outer.rel (inner_1.rel Q1 ... Qn) ... (inner_m.rel Q1 ... Qn)*)
   9.126 -    val rel = fold_rev Term.abs Qs'
   9.127 -      (Term.list_comb (mk_rel_of_bnf oDs CAs CBs outer,
   9.128 -        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
   9.129 -          mk_rel_of_bnf Ds As Bs) Dss inners));
   9.130 -
   9.131 -    (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
   9.132 -    (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
   9.133 -    fun mk_set i =
   9.134 -      let
   9.135 -        val (setTs, T) = `(replicate olive o HOLogic.mk_setT) (nth As i);
   9.136 -        val outer_set = mk_collect
   9.137 -          (mk_sets_of_bnf (replicate olive oDs) (replicate olive setTs) outer)
   9.138 -          (mk_T_of_bnf oDs setTs outer --> HOLogic.mk_setT T);
   9.139 -        val inner_sets = map (fn sets => nth sets i) inner_setss;
   9.140 -        val outer_map = mk_map_of_bnf oDs CAs setTs outer;
   9.141 -        val map_inner_sets = Term.list_comb (outer_map, inner_sets);
   9.142 -        val collect_image = mk_collect
   9.143 -          (map2 (fn f => fn set => HOLogic.mk_comp (mk_image f, set)) inner_sets outer_sets)
   9.144 -          (CCA --> HOLogic.mk_setT T);
   9.145 -      in
   9.146 -        (Library.foldl1 HOLogic.mk_comp [mk_Union T, outer_set, map_inner_sets],
   9.147 -        HOLogic.mk_comp (mk_Union T, collect_image))
   9.148 -      end;
   9.149 -
   9.150 -    val (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
   9.151 -
   9.152 -    (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
   9.153 -    val bd = mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd;
   9.154 -
   9.155 -    fun map_id0_tac _ =
   9.156 -      mk_comp_map_id0_tac (map_id0_of_bnf outer) (map_cong0_of_bnf outer)
   9.157 -        (map map_id0_of_bnf inners);
   9.158 -
   9.159 -    fun map_comp0_tac _ =
   9.160 -      mk_comp_map_comp0_tac (map_comp0_of_bnf outer) (map_cong0_of_bnf outer)
   9.161 -        (map map_comp0_of_bnf inners);
   9.162 -
   9.163 -    fun mk_single_set_map0_tac i _ =
   9.164 -      mk_comp_set_map0_tac (map_comp0_of_bnf outer) (map_cong0_of_bnf outer)
   9.165 -        (collect_set_map_of_bnf outer)
   9.166 -        (map ((fn thms => nth thms i) o set_map0_of_bnf) inners);
   9.167 -
   9.168 -    val set_map0_tacs = map mk_single_set_map0_tac (0 upto ilive - 1);
   9.169 -
   9.170 -    fun bd_card_order_tac _ =
   9.171 -      mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
   9.172 -
   9.173 -    fun bd_cinfinite_tac _ =
   9.174 -      mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
   9.175 -
   9.176 -    val set_alt_thms =
   9.177 -      if Config.get lthy quick_and_dirty then
   9.178 -        []
   9.179 -      else
   9.180 -        map (fn goal =>
   9.181 -          Goal.prove_sorry lthy [] [] goal
   9.182 -            (fn {context = ctxt, prems = _} =>
   9.183 -              mk_comp_set_alt_tac ctxt (collect_set_map_of_bnf outer))
   9.184 -          |> Thm.close_derivation)
   9.185 -        (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) sets sets_alt);
   9.186 -
   9.187 -    fun map_cong0_tac _ =
   9.188 -      mk_comp_map_cong0_tac set_alt_thms (map_cong0_of_bnf outer) (map map_cong0_of_bnf inners);
   9.189 -
   9.190 -    val set_bd_tacs =
   9.191 -      if Config.get lthy quick_and_dirty then
   9.192 -        replicate ilive (K all_tac)
   9.193 -      else
   9.194 -        let
   9.195 -          val outer_set_bds = set_bd_of_bnf outer;
   9.196 -          val inner_set_bdss = map set_bd_of_bnf inners;
   9.197 -          val inner_bd_Card_orders = map bd_Card_order_of_bnf inners;
   9.198 -          fun single_set_bd_thm i j =
   9.199 -            @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
   9.200 -              nth outer_set_bds j]
   9.201 -          val single_set_bd_thmss =
   9.202 -            map ((fn f => map f (0 upto olive - 1)) o single_set_bd_thm) (0 upto ilive - 1);
   9.203 -        in
   9.204 -          map2 (fn set_alt => fn single_set_bds => fn {context = ctxt, prems = _} =>
   9.205 -            mk_comp_set_bd_tac ctxt set_alt single_set_bds)
   9.206 -          set_alt_thms single_set_bd_thmss
   9.207 -        end;
   9.208 -
   9.209 -    val in_alt_thm =
   9.210 -      let
   9.211 -        val inx = mk_in Asets sets CCA;
   9.212 -        val in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
   9.213 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   9.214 -      in
   9.215 -        Goal.prove_sorry lthy [] [] goal
   9.216 -          (fn {context = ctxt, prems = _} => mk_comp_in_alt_tac ctxt set_alt_thms)
   9.217 -        |> Thm.close_derivation
   9.218 -      end;
   9.219 -
   9.220 -    fun le_rel_OO_tac _ = mk_le_rel_OO_tac (le_rel_OO_of_bnf outer) (rel_mono_of_bnf outer)
   9.221 -      (map le_rel_OO_of_bnf inners);
   9.222 -
   9.223 -    fun rel_OO_Grp_tac _ =
   9.224 -      let
   9.225 -        val outer_rel_Grp = rel_Grp_of_bnf outer RS sym;
   9.226 -        val outer_rel_cong = rel_cong_of_bnf outer;
   9.227 -        val thm =
   9.228 -          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
   9.229 -             trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
   9.230 -               [trans OF [outer_rel_Grp RS @{thm arg_cong[of _ _ conversep]},
   9.231 -                 rel_conversep_of_bnf outer RS sym], outer_rel_Grp],
   9.232 -               trans OF [rel_OO_of_bnf outer RS sym, outer_rel_cong OF
   9.233 -                 (map (fn bnf => rel_OO_Grp_of_bnf bnf RS sym) inners)]]] RS sym)
   9.234 -          (*|> unfold_thms lthy (rel_def_of_bnf outer :: map rel_def_of_bnf inners)*);
   9.235 -      in
   9.236 -        rtac thm 1
   9.237 -      end;
   9.238 -
   9.239 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   9.240 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   9.241 -
   9.242 -    val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
   9.243 -
   9.244 -    val inner_witss = map (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)))
   9.245 -      (map3 (fn Ds => fn n => mk_wits_of_bnf (replicate n Ds) (replicate n As))
   9.246 -        Dss inwitss inners);
   9.247 -
   9.248 -    val inner_witsss = map (map (nth inner_witss) o fst) outer_wits;
   9.249 -
   9.250 -    val wits = (inner_witsss, (map (single o snd) outer_wits))
   9.251 -      |-> map2 (fold (map_product (fn iwit => fn owit => owit $ iwit)))
   9.252 -      |> flat
   9.253 -      |> map (`(fn t => Term.add_frees t []))
   9.254 -      |> minimize_wits
   9.255 -      |> map (fn (frees, t) => fold absfree frees t);
   9.256 -
   9.257 -    fun wit_tac {context = ctxt, prems = _} =
   9.258 -      mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_map_of_bnf outer)
   9.259 -        (maps wit_thms_of_bnf inners);
   9.260 -
   9.261 -    val (bnf', lthy') =
   9.262 -      bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
   9.263 -        Binding.empty [] ((((((b, CCA), mapx), sets), bd), wits), SOME rel) lthy;
   9.264 -  in
   9.265 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   9.266 -  end;
   9.267 -
   9.268 -(* Killing live variables *)
   9.269 -
   9.270 -fun kill_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
   9.271 -  let
   9.272 -    val b = Binding.suffix_name (mk_killN n) (name_of_bnf bnf);
   9.273 -    val live = live_of_bnf bnf;
   9.274 -    val dead = dead_of_bnf bnf;
   9.275 -    val nwits = nwits_of_bnf bnf;
   9.276 -
   9.277 -    (* TODO: check 0 < n <= live *)
   9.278 -
   9.279 -    val (Ds, lthy1) = apfst (map TFree)
   9.280 -      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
   9.281 -    val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
   9.282 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
   9.283 -    val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
   9.284 -      (Variable.invent_types (replicate (live - n) HOLogic.typeS) lthy2);
   9.285 -
   9.286 -    val ((Asets, lives), _(*names_lthy*)) = lthy
   9.287 -      |> mk_Frees "A" (map HOLogic.mk_setT (drop n As))
   9.288 -      ||>> mk_Frees "x" (drop n As);
   9.289 -    val xs = map (fn T => HOLogic.choice_const T $ absdummy T @{term True}) killedAs @ lives;
   9.290 -
   9.291 -    val T = mk_T_of_bnf Ds As bnf;
   9.292 -
   9.293 -    (*bnf.map id ... id*)
   9.294 -    val mapx = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
   9.295 -    (*bnf.rel (op =) ... (op =)*)
   9.296 -    val rel = Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, map HOLogic.eq_const killedAs);
   9.297 -
   9.298 -    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   9.299 -    val sets = drop n bnf_sets;
   9.300 -
   9.301 -    (*(|UNIV :: A1 set| +c ... +c |UNIV :: An set|) *c bnf.bd*)
   9.302 -    val bnf_bd = mk_bd_of_bnf Ds As bnf;
   9.303 -    val bd = mk_cprod
   9.304 -      (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
   9.305 -
   9.306 -    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   9.307 -    fun map_comp0_tac {context = ctxt, prems = _} =
   9.308 -      unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
   9.309 -      rtac refl 1;
   9.310 -    fun map_cong0_tac {context = ctxt, prems = _} =
   9.311 -      mk_kill_map_cong0_tac ctxt n (live - n) (map_cong0_of_bnf bnf);
   9.312 -    val set_map0_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_map0_of_bnf bnf));
   9.313 -    fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
   9.314 -    fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
   9.315 -    val set_bd_tacs =
   9.316 -      map (fn thm => fn _ => mk_kill_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
   9.317 -        (drop n (set_bd_of_bnf bnf));
   9.318 -
   9.319 -    val in_alt_thm =
   9.320 -      let
   9.321 -        val inx = mk_in Asets sets T;
   9.322 -        val in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
   9.323 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   9.324 -      in
   9.325 -        Goal.prove_sorry lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
   9.326 -      end;
   9.327 -
   9.328 -    fun le_rel_OO_tac {context = ctxt, prems = _} =
   9.329 -      EVERY' [rtac @{thm ord_le_eq_trans}, rtac (le_rel_OO_of_bnf bnf)] 1 THEN
   9.330 -      unfold_thms_tac ctxt @{thms eq_OO} THEN rtac refl 1;
   9.331 -
   9.332 -    fun rel_OO_Grp_tac _ =
   9.333 -      let
   9.334 -        val rel_Grp = rel_Grp_of_bnf bnf RS sym
   9.335 -        val thm =
   9.336 -          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
   9.337 -            trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
   9.338 -              [trans OF [rel_Grp RS @{thm arg_cong[of _ _ conversep]},
   9.339 -                rel_conversep_of_bnf bnf RS sym], rel_Grp],
   9.340 -              trans OF [rel_OO_of_bnf bnf RS sym, rel_cong_of_bnf bnf OF
   9.341 -                (replicate n @{thm trans[OF Grp_UNIV_id[OF refl] eq_alt[symmetric]]} @
   9.342 -                 replicate (live - n) @{thm Grp_fst_snd})]]] RS sym);
   9.343 -      in
   9.344 -        rtac thm 1
   9.345 -      end;
   9.346 -
   9.347 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   9.348 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   9.349 -
   9.350 -    val bnf_wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
   9.351 -
   9.352 -    val wits = map (fn t => fold absfree (Term.add_frees t []) t)
   9.353 -      (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) bnf_wits);
   9.354 -
   9.355 -    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
   9.356 -
   9.357 -    val (bnf', lthy') =
   9.358 -      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME (killedAs @ Ds)) Binding.empty
   9.359 -        Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   9.360 -  in
   9.361 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   9.362 -  end;
   9.363 -
   9.364 -(* Adding dummy live variables *)
   9.365 -
   9.366 -fun lift_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
   9.367 -  let
   9.368 -    val b = Binding.suffix_name (mk_liftN n) (name_of_bnf bnf);
   9.369 -    val live = live_of_bnf bnf;
   9.370 -    val dead = dead_of_bnf bnf;
   9.371 -    val nwits = nwits_of_bnf bnf;
   9.372 -
   9.373 -    (* TODO: check 0 < n *)
   9.374 -
   9.375 -    val (Ds, lthy1) = apfst (map TFree)
   9.376 -      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
   9.377 -    val ((newAs, As), lthy2) = apfst (chop n o map TFree)
   9.378 -      (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy1);
   9.379 -    val ((newBs, Bs), _(*lthy3*)) = apfst (chop n o map TFree)
   9.380 -      (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy2);
   9.381 -
   9.382 -    val (Asets, _(*names_lthy*)) = lthy
   9.383 -      |> mk_Frees "A" (map HOLogic.mk_setT (newAs @ As));
   9.384 -
   9.385 -    val T = mk_T_of_bnf Ds As bnf;
   9.386 -
   9.387 -    (*%f1 ... fn. bnf.map*)
   9.388 -    val mapx =
   9.389 -      fold_rev Term.absdummy (map2 (curry op -->) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
   9.390 -    (*%Q1 ... Qn. bnf.rel*)
   9.391 -    val rel = fold_rev Term.absdummy (map2 mk_pred2T newAs newBs) (mk_rel_of_bnf Ds As Bs bnf);
   9.392 -
   9.393 -    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   9.394 -    val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
   9.395 -
   9.396 -    val bd = mk_bd_of_bnf Ds As bnf;
   9.397 -
   9.398 -    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   9.399 -    fun map_comp0_tac {context = ctxt, prems = _} =
   9.400 -      unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
   9.401 -      rtac refl 1;
   9.402 -    fun map_cong0_tac {context = ctxt, prems = _} =
   9.403 -      rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   9.404 -    val set_map0_tacs =
   9.405 -      if Config.get lthy quick_and_dirty then
   9.406 -        replicate (n + live) (K all_tac)
   9.407 -      else
   9.408 -        replicate n (K empty_natural_tac) @
   9.409 -        map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf);
   9.410 -    fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
   9.411 -    fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
   9.412 -    val set_bd_tacs =
   9.413 -      if Config.get lthy quick_and_dirty then
   9.414 -        replicate (n + live) (K all_tac)
   9.415 -      else
   9.416 -        replicate n (K (mk_lift_set_bd_tac (bd_Card_order_of_bnf bnf))) @
   9.417 -        (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
   9.418 -
   9.419 -    val in_alt_thm =
   9.420 -      let
   9.421 -        val inx = mk_in Asets sets T;
   9.422 -        val in_alt = mk_in (drop n Asets) bnf_sets T;
   9.423 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   9.424 -      in
   9.425 -        Goal.prove_sorry lthy [] [] goal (K lift_in_alt_tac) |> Thm.close_derivation
   9.426 -      end;
   9.427 -
   9.428 -    fun le_rel_OO_tac _ = rtac (le_rel_OO_of_bnf bnf) 1;
   9.429 -
   9.430 -    fun rel_OO_Grp_tac _ = mk_simple_rel_OO_Grp_tac (rel_OO_Grp_of_bnf bnf) in_alt_thm;
   9.431 -
   9.432 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   9.433 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   9.434 -
   9.435 -    val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   9.436 -
   9.437 -    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
   9.438 -
   9.439 -    val (bnf', lthy') =
   9.440 -      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
   9.441 -        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   9.442 -  in
   9.443 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   9.444 -  end;
   9.445 -
   9.446 -(* Changing the order of live variables *)
   9.447 -
   9.448 -fun permute_bnf qualify src dest bnf (unfold_set, lthy) =
   9.449 -  if src = dest then (bnf, (unfold_set, lthy)) else
   9.450 -  let
   9.451 -    val b = Binding.suffix_name (mk_permuteN src dest) (name_of_bnf bnf);
   9.452 -    val live = live_of_bnf bnf;
   9.453 -    val dead = dead_of_bnf bnf;
   9.454 -    val nwits = nwits_of_bnf bnf;
   9.455 -    fun permute xs = permute_like (op =) src dest xs;
   9.456 -    fun unpermute xs = permute_like (op =) dest src xs;
   9.457 -
   9.458 -    val (Ds, lthy1) = apfst (map TFree)
   9.459 -      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
   9.460 -    val (As, lthy2) = apfst (map TFree)
   9.461 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
   9.462 -    val (Bs, _(*lthy3*)) = apfst (map TFree)
   9.463 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy2);
   9.464 -
   9.465 -    val (Asets, _(*names_lthy*)) = lthy
   9.466 -      |> mk_Frees "A" (map HOLogic.mk_setT (permute As));
   9.467 -
   9.468 -    val T = mk_T_of_bnf Ds As bnf;
   9.469 -
   9.470 -    (*%f(1) ... f(n). bnf.map f\<sigma>(1) ... f\<sigma>(n)*)
   9.471 -    val mapx = fold_rev Term.absdummy (permute (map2 (curry op -->) As Bs))
   9.472 -      (Term.list_comb (mk_map_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
   9.473 -    (*%Q(1) ... Q(n). bnf.rel Q\<sigma>(1) ... Q\<sigma>(n)*)
   9.474 -    val rel = fold_rev Term.absdummy (permute (map2 mk_pred2T As Bs))
   9.475 -      (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
   9.476 -
   9.477 -    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   9.478 -    val sets = permute bnf_sets;
   9.479 -
   9.480 -    val bd = mk_bd_of_bnf Ds As bnf;
   9.481 -
   9.482 -    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   9.483 -    fun map_comp0_tac _ = rtac (map_comp0_of_bnf bnf) 1;
   9.484 -    fun map_cong0_tac {context = ctxt, prems = _} =
   9.485 -      rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   9.486 -    val set_map0_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf));
   9.487 -    fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
   9.488 -    fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
   9.489 -    val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
   9.490 -
   9.491 -    val in_alt_thm =
   9.492 -      let
   9.493 -        val inx = mk_in Asets sets T;
   9.494 -        val in_alt = mk_in (unpermute Asets) bnf_sets T;
   9.495 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   9.496 -      in
   9.497 -        Goal.prove_sorry lthy [] [] goal (K (mk_permute_in_alt_tac src dest))
   9.498 -        |> Thm.close_derivation
   9.499 -      end;
   9.500 -
   9.501 -    fun le_rel_OO_tac _ = rtac (le_rel_OO_of_bnf bnf) 1;
   9.502 -
   9.503 -    fun rel_OO_Grp_tac _ = mk_simple_rel_OO_Grp_tac (rel_OO_Grp_of_bnf bnf) in_alt_thm;
   9.504 -
   9.505 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   9.506 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   9.507 -
   9.508 -    val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   9.509 -
   9.510 -    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
   9.511 -
   9.512 -    val (bnf', lthy') =
   9.513 -      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
   9.514 -        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   9.515 -  in
   9.516 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   9.517 -  end;
   9.518 -
   9.519 -(* Composition pipeline *)
   9.520 -
   9.521 -fun permute_and_kill qualify n src dest bnf =
   9.522 -  bnf
   9.523 -  |> permute_bnf qualify src dest
   9.524 -  #> uncurry (kill_bnf qualify n);
   9.525 -
   9.526 -fun lift_and_permute qualify n src dest bnf =
   9.527 -  bnf
   9.528 -  |> lift_bnf qualify n
   9.529 -  #> uncurry (permute_bnf qualify src dest);
   9.530 -
   9.531 -fun normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy =
   9.532 -  let
   9.533 -    val before_kill_src = map (fn As => 0 upto (length As - 1)) Ass;
   9.534 -    val kill_poss = map (find_indices op = Ds) Ass;
   9.535 -    val live_poss = map2 (subtract op =) kill_poss before_kill_src;
   9.536 -    val before_kill_dest = map2 append kill_poss live_poss;
   9.537 -    val kill_ns = map length kill_poss;
   9.538 -    val (inners', (unfold_set', lthy')) =
   9.539 -      fold_map5 (fn i => permute_and_kill (qualify i))
   9.540 -        (if length bnfs = 1 then [0] else (1 upto length bnfs))
   9.541 -        kill_ns before_kill_src before_kill_dest bnfs (unfold_set, lthy);
   9.542 -
   9.543 -    val Ass' = map2 (map o nth) Ass live_poss;
   9.544 -    val As = sort Ass';
   9.545 -    val after_lift_dest = replicate (length Ass') (0 upto (length As - 1));
   9.546 -    val old_poss = map (map (fn x => find_index (fn y => x = y) As)) Ass';
   9.547 -    val new_poss = map2 (subtract op =) old_poss after_lift_dest;
   9.548 -    val after_lift_src = map2 append new_poss old_poss;
   9.549 -    val lift_ns = map (fn xs => length As - length xs) Ass';
   9.550 -  in
   9.551 -    ((kill_poss, As), fold_map5 (fn i => lift_and_permute (qualify i))
   9.552 -      (if length bnfs = 1 then [0] else (1 upto length bnfs))
   9.553 -      lift_ns after_lift_src after_lift_dest inners' (unfold_set', lthy'))
   9.554 -  end;
   9.555 -
   9.556 -fun default_comp_sort Ass =
   9.557 -  Library.sort (Term_Ord.typ_ord o pairself TFree) (fold (fold (insert (op =))) Ass []);
   9.558 -
   9.559 -fun compose_bnf const_policy qualify sort outer inners oDs Dss tfreess (unfold_set, lthy) =
   9.560 -  let
   9.561 -    val b = name_of_bnf outer;
   9.562 -
   9.563 -    val Ass = map (map Term.dest_TFree) tfreess;
   9.564 -    val Ds = fold (fold Term.add_tfreesT) (oDs :: Dss) [];
   9.565 -
   9.566 -    val ((kill_poss, As), (inners', (unfold_set', lthy'))) =
   9.567 -      normalize_bnfs qualify Ass Ds sort inners unfold_set lthy;
   9.568 -
   9.569 -    val Ds = oDs @ flat (map3 (append oo map o nth) tfreess kill_poss Dss);
   9.570 -    val As = map TFree As;
   9.571 -  in
   9.572 -    apfst (rpair (Ds, As))
   9.573 -      (clean_compose_bnf const_policy (qualify 0) b outer inners' (unfold_set', lthy'))
   9.574 -  end;
   9.575 -
   9.576 -(* Hide the type of the bound (optimization) and unfold the definitions (nicer to the user) *)
   9.577 -
   9.578 -fun seal_bnf qualify (unfold_set : unfold_set) b Ds bnf lthy =
   9.579 -  let
   9.580 -    val live = live_of_bnf bnf;
   9.581 -    val nwits = nwits_of_bnf bnf;
   9.582 -
   9.583 -    val (As, lthy1) = apfst (map TFree)
   9.584 -      (Variable.invent_types (replicate live HOLogic.typeS) (fold Variable.declare_typ Ds lthy));
   9.585 -    val (Bs, _) = apfst (map TFree)
   9.586 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
   9.587 -
   9.588 -    val map_unfolds = #map_unfolds unfold_set;
   9.589 -    val set_unfoldss = #set_unfoldss unfold_set;
   9.590 -    val rel_unfolds = #rel_unfolds unfold_set;
   9.591 -
   9.592 -    val expand_maps =
   9.593 -      fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) map_unfolds);
   9.594 -    val expand_sets =
   9.595 -      fold expand_term_const (map (map (Logic.dest_equals o Thm.prop_of)) set_unfoldss);
   9.596 -    val expand_rels =
   9.597 -      fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) rel_unfolds);
   9.598 -    fun unfold_maps ctxt = fold (unfold_thms ctxt o single) map_unfolds;
   9.599 -    fun unfold_sets ctxt = fold (unfold_thms ctxt) set_unfoldss;
   9.600 -    fun unfold_rels ctxt = unfold_thms ctxt rel_unfolds;
   9.601 -    fun unfold_all ctxt = unfold_sets ctxt o unfold_maps ctxt o unfold_rels ctxt;
   9.602 -    val bnf_map = expand_maps (mk_map_of_bnf Ds As Bs bnf);
   9.603 -    val bnf_sets = map (expand_maps o expand_sets)
   9.604 -      (mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf);
   9.605 -    val bnf_bd = mk_bd_of_bnf Ds As bnf;
   9.606 -    val bnf_rel = expand_rels (mk_rel_of_bnf Ds As Bs bnf);
   9.607 -    val T = mk_T_of_bnf Ds As bnf;
   9.608 -
   9.609 -    (*bd should only depend on dead type variables!*)
   9.610 -    val bd_repT = fst (dest_relT (fastype_of bnf_bd));
   9.611 -    val bdT_bind = qualify (Binding.suffix_name ("_" ^ bdTN) b);
   9.612 -    val params = fold Term.add_tfreesT Ds [];
   9.613 -    val deads = map TFree params;
   9.614 -
   9.615 -    val ((bdT_name, (bdT_glob_info, bdT_loc_info)), lthy) =
   9.616 -      typedef (bdT_bind, params, NoSyn)
   9.617 -        (HOLogic.mk_UNIV bd_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
   9.618 -
   9.619 -    val bnf_bd' = mk_dir_image bnf_bd
   9.620 -      (Const (#Abs_name bdT_glob_info, bd_repT --> Type (bdT_name, deads)))
   9.621 -
   9.622 -    val Abs_bdT_inj = mk_Abs_inj_thm (#Abs_inject bdT_loc_info);
   9.623 -    val Abs_bdT_bij = mk_Abs_bij_thm lthy Abs_bdT_inj (#Abs_cases bdT_loc_info);
   9.624 -
   9.625 -    val bd_ordIso = @{thm dir_image} OF [Abs_bdT_inj, bd_Card_order_of_bnf bnf];
   9.626 -    val bd_card_order =
   9.627 -      @{thm card_order_dir_image} OF [Abs_bdT_bij, bd_card_order_of_bnf bnf];
   9.628 -    val bd_cinfinite =
   9.629 -      (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
   9.630 -
   9.631 -    val set_bds =
   9.632 -      map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
   9.633 -
   9.634 -    fun mk_tac thm {context = ctxt, prems = _} =
   9.635 -      (rtac (unfold_all ctxt thm) THEN'
   9.636 -      SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
   9.637 -
   9.638 -    val tacs = zip_axioms (mk_tac (map_id0_of_bnf bnf)) (mk_tac (map_comp0_of_bnf bnf))
   9.639 -      (mk_tac (map_cong0_of_bnf bnf)) (map mk_tac (set_map0_of_bnf bnf))
   9.640 -      (K (rtac bd_card_order 1)) (K (rtac bd_cinfinite 1)) (map mk_tac set_bds)
   9.641 -      (mk_tac (le_rel_OO_of_bnf bnf))
   9.642 -      (mk_tac (rel_OO_Grp_of_bnf bnf));
   9.643 -
   9.644 -    val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   9.645 -
   9.646 -    fun wit_tac {context = ctxt, prems = _} =
   9.647 -      mk_simple_wit_tac (map (unfold_all ctxt) (wit_thms_of_bnf bnf));
   9.648 -
   9.649 -    val (bnf', lthy') =
   9.650 -      bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
   9.651 -        Binding.empty Binding.empty []
   9.652 -        ((((((b, T), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
   9.653 -  in
   9.654 -    ((bnf', deads), lthy')
   9.655 -  end;
   9.656 -
   9.657 -exception BAD_DEAD of typ * typ;
   9.658 -
   9.659 -fun bnf_of_typ _ _ _ _ (T as TFree _) accum = ((ID_bnf, ([], [T])), accum)
   9.660 -  | bnf_of_typ _ _ _ _ (TVar _) _ = error "Unexpected schematic variable"
   9.661 -  | bnf_of_typ const_policy qualify' sort Xs (T as Type (C, Ts)) (unfold_set, lthy) =
   9.662 -    let
   9.663 -      fun check_bad_dead ((_, (deads, _)), _) =
   9.664 -        let val Ds = fold Term.add_tfreesT deads [] in
   9.665 -          (case Library.inter (op =) Ds Xs of [] => ()
   9.666 -           | X :: _ => raise BAD_DEAD (TFree X, T))
   9.667 -        end;
   9.668 -
   9.669 -      val tfrees = Term.add_tfreesT T [];
   9.670 -      val bnf_opt = if null tfrees then NONE else bnf_of lthy C;
   9.671 -    in
   9.672 -      (case bnf_opt of
   9.673 -        NONE => ((DEADID_bnf, ([T], [])), (unfold_set, lthy))
   9.674 -      | SOME bnf =>
   9.675 -        if forall (can Term.dest_TFree) Ts andalso length Ts = length tfrees then
   9.676 -          let
   9.677 -            val T' = T_of_bnf bnf;
   9.678 -            val deads = deads_of_bnf bnf;
   9.679 -            val lives = lives_of_bnf bnf;
   9.680 -            val tvars' = Term.add_tvarsT T' [];
   9.681 -            val deads_lives =
   9.682 -              pairself (map (Term.typ_subst_TVars (map fst tvars' ~~ map TFree tfrees)))
   9.683 -                (deads, lives);
   9.684 -          in ((bnf, deads_lives), (unfold_set, lthy)) end
   9.685 -        else
   9.686 -          let
   9.687 -            val name = Long_Name.base_name C;
   9.688 -            fun qualify i =
   9.689 -              let val namei = name ^ nonzero_string_of_int i;
   9.690 -              in qualify' o Binding.qualify true namei end;
   9.691 -            val odead = dead_of_bnf bnf;
   9.692 -            val olive = live_of_bnf bnf;
   9.693 -            val oDs_pos = find_indices op = [TFree ("dead", [])] (snd (Term.dest_Type
   9.694 -              (mk_T_of_bnf (replicate odead (TFree ("dead", []))) (replicate olive dummyT) bnf)));
   9.695 -            val oDs = map (nth Ts) oDs_pos;
   9.696 -            val Ts' = map (nth Ts) (subtract (op =) oDs_pos (0 upto length Ts - 1));
   9.697 -            val ((inners, (Dss, Ass)), (unfold_set', lthy')) =
   9.698 -              apfst (apsnd split_list o split_list)
   9.699 -                (fold_map2 (fn i => bnf_of_typ Smart_Inline (qualify i) sort Xs)
   9.700 -                (if length Ts' = 1 then [0] else (1 upto length Ts')) Ts' (unfold_set, lthy));
   9.701 -          in
   9.702 -            compose_bnf const_policy qualify sort bnf inners oDs Dss Ass (unfold_set', lthy')
   9.703 -          end)
   9.704 -      |> tap check_bad_dead
   9.705 -    end;
   9.706 -
   9.707 -end;
    10.1 --- a/src/HOL/BNF/Tools/bnf_comp_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,252 +0,0 @@
    10.4 -(*  Title:      HOL/BNF/Tools/bnf_comp_tactics.ML
    10.5 -    Author:     Dmitriy Traytel, TU Muenchen
    10.6 -    Author:     Jasmin Blanchette, TU Muenchen
    10.7 -    Copyright   2012
    10.8 -
    10.9 -Tactics for composition of bounded natural functors.
   10.10 -*)
   10.11 -
   10.12 -signature BNF_COMP_TACTICS =
   10.13 -sig
   10.14 -  val mk_comp_bd_card_order_tac: thm list -> thm -> tactic
   10.15 -  val mk_comp_bd_cinfinite_tac: thm -> thm -> tactic
   10.16 -  val mk_comp_in_alt_tac: Proof.context -> thm list -> tactic
   10.17 -  val mk_comp_map_comp0_tac: thm -> thm -> thm list -> tactic
   10.18 -  val mk_comp_map_cong0_tac: thm list -> thm -> thm list -> tactic
   10.19 -  val mk_comp_map_id0_tac: thm -> thm -> thm list -> tactic
   10.20 -  val mk_comp_set_alt_tac: Proof.context -> thm -> tactic
   10.21 -  val mk_comp_set_bd_tac: Proof.context -> thm -> thm list -> tactic
   10.22 -  val mk_comp_set_map0_tac: thm -> thm -> thm -> thm list -> tactic
   10.23 -  val mk_comp_wit_tac: Proof.context -> thm list -> thm -> thm list -> tactic
   10.24 -
   10.25 -  val mk_kill_bd_card_order_tac: int -> thm -> tactic
   10.26 -  val mk_kill_bd_cinfinite_tac: thm -> tactic
   10.27 -  val kill_in_alt_tac: tactic
   10.28 -  val mk_kill_map_cong0_tac: Proof.context -> int -> int -> thm -> tactic
   10.29 -  val mk_kill_set_bd_tac: thm -> thm -> tactic
   10.30 -
   10.31 -  val empty_natural_tac: tactic
   10.32 -  val lift_in_alt_tac: tactic
   10.33 -  val mk_lift_set_bd_tac: thm -> tactic
   10.34 -
   10.35 -  val mk_permute_in_alt_tac: ''a list -> ''a list -> tactic
   10.36 -
   10.37 -  val mk_le_rel_OO_tac: thm -> thm -> thm list -> tactic
   10.38 -  val mk_simple_rel_OO_Grp_tac: thm -> thm -> tactic
   10.39 -  val mk_simple_wit_tac: thm list -> tactic
   10.40 -end;
   10.41 -
   10.42 -structure BNF_Comp_Tactics : BNF_COMP_TACTICS =
   10.43 -struct
   10.44 -
   10.45 -open BNF_Util
   10.46 -open BNF_Tactics
   10.47 -
   10.48 -val Cnotzero_UNIV = @{thm Cnotzero_UNIV};
   10.49 -val arg_cong_Union = @{thm arg_cong[of _ _ Union]};
   10.50 -val csum_Cnotzero1 = @{thm csum_Cnotzero1};
   10.51 -val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
   10.52 -val trans_image_cong_o_apply = @{thm trans[OF image_cong[OF o_apply refl]]};
   10.53 -val trans_o_apply = @{thm trans[OF o_apply]};
   10.54 -
   10.55 -
   10.56 -
   10.57 -(* Composition *)
   10.58 -
   10.59 -fun mk_comp_set_alt_tac ctxt collect_set_map =
   10.60 -  unfold_thms_tac ctxt @{thms sym[OF o_assoc]} THEN
   10.61 -  unfold_thms_tac ctxt [collect_set_map RS sym] THEN
   10.62 -  rtac refl 1;
   10.63 -
   10.64 -fun mk_comp_map_id0_tac Gmap_id0 Gmap_cong0 map_id0s =
   10.65 -  EVERY' ([rtac ext, rtac (Gmap_cong0 RS trans)] @
   10.66 -    map (fn thm => rtac (thm RS fun_cong)) map_id0s @ [rtac (Gmap_id0 RS fun_cong)]) 1;
   10.67 -
   10.68 -fun mk_comp_map_comp0_tac Gmap_comp0 Gmap_cong0 map_comp0s =
   10.69 -  EVERY' ([rtac ext, rtac sym, rtac trans_o_apply,
   10.70 -    rtac (Gmap_comp0 RS sym RS o_eq_dest_lhs RS trans), rtac Gmap_cong0] @
   10.71 -    map (fn thm => rtac (thm RS sym RS fun_cong)) map_comp0s) 1;
   10.72 -
   10.73 -fun mk_comp_set_map0_tac Gmap_comp0 Gmap_cong0 Gset_map0 set_map0s =
   10.74 -  EVERY' ([rtac ext] @
   10.75 -    replicate 3 (rtac trans_o_apply) @
   10.76 -    [rtac (arg_cong_Union RS trans),
   10.77 -     rtac (@{thm arg_cong2[of _ _ _ _ collect, OF refl]} RS trans),
   10.78 -     rtac (Gmap_comp0 RS sym RS o_eq_dest_lhs RS trans),
   10.79 -     rtac Gmap_cong0] @
   10.80 -     map (fn thm => rtac (thm RS fun_cong)) set_map0s @
   10.81 -     [rtac (Gset_map0 RS o_eq_dest_lhs), rtac sym, rtac trans_o_apply,
   10.82 -     rtac trans_image_cong_o_apply, rtac trans_image_cong_o_apply,
   10.83 -     rtac (@{thm image_cong} OF [Gset_map0 RS o_eq_dest_lhs RS arg_cong_Union, refl] RS trans),
   10.84 -     rtac @{thm trans[OF comp_eq_dest[OF Union_natural[symmetric]]]}, rtac arg_cong_Union,
   10.85 -     rtac @{thm trans[OF o_eq_dest_lhs[OF image_o_collect[symmetric]]]},
   10.86 -     rtac @{thm fun_cong[OF arg_cong[of _ _ collect]]}] @
   10.87 -     [REPEAT_DETERM_N (length set_map0s) o EVERY' [rtac @{thm trans[OF image_insert]},
   10.88 -        rtac @{thm arg_cong2[of _ _ _ _ insert]}, rtac ext, rtac trans_o_apply,
   10.89 -        rtac trans_image_cong_o_apply, rtac @{thm trans[OF image_image]},
   10.90 -        rtac @{thm sym[OF trans[OF o_apply]]}, rtac @{thm image_cong[OF refl o_apply]}],
   10.91 -     rtac @{thm image_empty}]) 1;
   10.92 -
   10.93 -fun mk_comp_map_cong0_tac comp_set_alts map_cong0 map_cong0s =
   10.94 -  let
   10.95 -     val n = length comp_set_alts;
   10.96 -  in
   10.97 -    (if n = 0 then rtac refl 1
   10.98 -    else rtac map_cong0 1 THEN
   10.99 -      EVERY' (map_index (fn (i, map_cong0) =>
  10.100 -        rtac map_cong0 THEN' EVERY' (map_index (fn (k, set_alt) =>
  10.101 -          EVERY' [select_prem_tac n (dtac @{thm meta_spec}) (k + 1), etac meta_mp,
  10.102 -            rtac (equalityD2 RS set_mp), rtac (set_alt RS fun_cong RS trans),
  10.103 -            rtac trans_o_apply, rtac (@{thm collect_def} RS arg_cong_Union),
  10.104 -            rtac @{thm UnionI}, rtac @{thm UN_I}, REPEAT_DETERM_N i o rtac @{thm insertI2},
  10.105 -            rtac @{thm insertI1}, rtac (o_apply RS equalityD2 RS set_mp),
  10.106 -            etac @{thm imageI}, atac])
  10.107 -          comp_set_alts))
  10.108 -      map_cong0s) 1)
  10.109 -  end;
  10.110 -
  10.111 -fun mk_comp_bd_card_order_tac Fbd_card_orders Gbd_card_order =
  10.112 -  let
  10.113 -    val (card_orders, last_card_order) = split_last Fbd_card_orders;
  10.114 -    fun gen_before thm = rtac @{thm card_order_csum} THEN' rtac thm;
  10.115 -  in
  10.116 -    (rtac @{thm card_order_cprod} THEN'
  10.117 -    WRAP' gen_before (K (K all_tac)) card_orders (rtac last_card_order) THEN'
  10.118 -    rtac Gbd_card_order) 1
  10.119 -  end;
  10.120 -
  10.121 -fun mk_comp_bd_cinfinite_tac Fbd_cinfinite Gbd_cinfinite =
  10.122 -  (rtac @{thm cinfinite_cprod} THEN'
  10.123 -   ((K (TRY ((rtac @{thm cinfinite_csum} THEN' rtac disjI1) 1)) THEN'
  10.124 -     ((rtac @{thm cinfinite_csum} THEN' rtac disjI1 THEN' rtac Fbd_cinfinite) ORELSE'
  10.125 -      rtac Fbd_cinfinite)) ORELSE'
  10.126 -    rtac Fbd_cinfinite) THEN'
  10.127 -   rtac Gbd_cinfinite) 1;
  10.128 -
  10.129 -fun mk_comp_set_bd_tac ctxt comp_set_alt Gset_Fset_bds =
  10.130 -  let
  10.131 -    val (bds, last_bd) = split_last Gset_Fset_bds;
  10.132 -    fun gen_before bd =
  10.133 -      rtac ctrans THEN' rtac @{thm Un_csum} THEN'
  10.134 -      rtac ctrans THEN' rtac @{thm csum_mono} THEN'
  10.135 -      rtac bd;
  10.136 -    fun gen_after _ = rtac @{thm ordIso_imp_ordLeq} THEN' rtac @{thm cprod_csum_distrib1};
  10.137 -  in
  10.138 -    unfold_thms_tac ctxt [comp_set_alt] THEN
  10.139 -    rtac @{thm comp_set_bd_Union_o_collect} 1 THEN
  10.140 -    unfold_thms_tac ctxt @{thms Union_image_insert Union_image_empty Union_Un_distrib o_apply} THEN
  10.141 -    (rtac ctrans THEN'
  10.142 -     WRAP' gen_before gen_after bds (rtac last_bd) THEN'
  10.143 -     rtac @{thm ordIso_imp_ordLeq} THEN'
  10.144 -     rtac @{thm cprod_com}) 1
  10.145 -  end;
  10.146 -
  10.147 -val comp_in_alt_thms = @{thms o_apply collect_def SUP_def image_insert image_empty Union_insert
  10.148 -  Union_empty Un_empty_right Union_Un_distrib Un_subset_iff conj_subset_def UN_image_subset
  10.149 -  conj_assoc};
  10.150 -
  10.151 -fun mk_comp_in_alt_tac ctxt comp_set_alts =
  10.152 -  unfold_thms_tac ctxt (comp_set_alts @ comp_in_alt_thms) THEN
  10.153 -  unfold_thms_tac ctxt @{thms set_eq_subset} THEN
  10.154 -  rtac conjI 1 THEN
  10.155 -  REPEAT_DETERM (
  10.156 -    rtac @{thm subsetI} 1 THEN
  10.157 -    unfold_thms_tac ctxt @{thms mem_Collect_eq Ball_def} THEN
  10.158 -    (REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
  10.159 -     REPEAT_DETERM (CHANGED ((
  10.160 -       (rtac conjI THEN' (atac ORELSE' rtac subset_UNIV)) ORELSE'
  10.161 -       atac ORELSE'
  10.162 -       (rtac subset_UNIV)) 1)) ORELSE rtac subset_UNIV 1));
  10.163 -
  10.164 -val comp_wit_thms = @{thms Union_empty_conv o_apply collect_def SUP_def
  10.165 -  Union_image_insert Union_image_empty};
  10.166 -
  10.167 -fun mk_comp_wit_tac ctxt Gwit_thms collect_set_map Fwit_thms =
  10.168 -  ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
  10.169 -  unfold_thms_tac ctxt (collect_set_map :: comp_wit_thms) THEN
  10.170 -  REPEAT_DETERM ((atac ORELSE'
  10.171 -    REPEAT_DETERM o eresolve_tac @{thms UnionE UnE} THEN'
  10.172 -    etac imageE THEN' TRY o dresolve_tac Gwit_thms THEN'
  10.173 -    (etac FalseE ORELSE'
  10.174 -    hyp_subst_tac ctxt THEN'
  10.175 -    dresolve_tac Fwit_thms THEN'
  10.176 -    (etac FalseE ORELSE' atac))) 1);
  10.177 -
  10.178 -
  10.179 -
  10.180 -(* Kill operation *)
  10.181 -
  10.182 -fun mk_kill_map_cong0_tac ctxt n m map_cong0 =
  10.183 -  (rtac map_cong0 THEN' EVERY' (replicate n (rtac refl)) THEN'
  10.184 -    EVERY' (replicate m (Goal.assume_rule_tac ctxt))) 1;
  10.185 -
  10.186 -fun mk_kill_bd_card_order_tac n bd_card_order =
  10.187 -  (rtac @{thm card_order_cprod} THEN'
  10.188 -  K (REPEAT_DETERM_N (n - 1)
  10.189 -    ((rtac @{thm card_order_csum} THEN'
  10.190 -    rtac @{thm card_of_card_order_on}) 1)) THEN'
  10.191 -  rtac @{thm card_of_card_order_on} THEN'
  10.192 -  rtac bd_card_order) 1;
  10.193 -
  10.194 -fun mk_kill_bd_cinfinite_tac bd_Cinfinite =
  10.195 -  (rtac @{thm cinfinite_cprod2} THEN'
  10.196 -  TRY o rtac csum_Cnotzero1 THEN'
  10.197 -  rtac Cnotzero_UNIV THEN'
  10.198 -  rtac bd_Cinfinite) 1;
  10.199 -
  10.200 -fun mk_kill_set_bd_tac bd_Card_order set_bd =
  10.201 -  (rtac ctrans THEN'
  10.202 -  rtac set_bd THEN'
  10.203 -  rtac @{thm ordLeq_cprod2} THEN'
  10.204 -  TRY o rtac csum_Cnotzero1 THEN'
  10.205 -  rtac Cnotzero_UNIV THEN'
  10.206 -  rtac bd_Card_order) 1
  10.207 -
  10.208 -val kill_in_alt_tac =
  10.209 -  ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
  10.210 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
  10.211 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
  10.212 -    rtac conjI THEN' rtac subset_UNIV) 1)) THEN
  10.213 -  (rtac subset_UNIV ORELSE' atac) 1 THEN
  10.214 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
  10.215 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1))) ORELSE
  10.216 -  ((rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
  10.217 -    REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac subset_UNIV 1));
  10.218 -
  10.219 -
  10.220 -
  10.221 -(* Lift operation *)
  10.222 -
  10.223 -val empty_natural_tac = rtac @{thm empty_natural} 1;
  10.224 -
  10.225 -fun mk_lift_set_bd_tac bd_Card_order = (rtac @{thm Card_order_empty} THEN' rtac bd_Card_order) 1;
  10.226 -
  10.227 -val lift_in_alt_tac =
  10.228 -  ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
  10.229 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
  10.230 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1)) THEN
  10.231 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
  10.232 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
  10.233 -    rtac conjI THEN' rtac @{thm empty_subsetI}) 1)) THEN
  10.234 -  (rtac @{thm empty_subsetI} ORELSE' atac) 1) ORELSE
  10.235 -  ((rtac sym THEN' rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
  10.236 -    REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac @{thm empty_subsetI} 1));
  10.237 -
  10.238 -
  10.239 -
  10.240 -(* Permute operation *)
  10.241 -
  10.242 -fun mk_permute_in_alt_tac src dest =
  10.243 -  (rtac @{thm Collect_cong} THEN'
  10.244 -  mk_rotate_eq_tac (rtac refl) trans @{thm conj_assoc} @{thm conj_commute} @{thm conj_cong}
  10.245 -    dest src) 1;
  10.246 -
  10.247 -fun mk_le_rel_OO_tac outer_le_rel_OO outer_rel_mono inner_le_rel_OOs =
  10.248 -  EVERY' (map rtac (@{thm order_trans} :: outer_le_rel_OO :: outer_rel_mono :: inner_le_rel_OOs)) 1;
  10.249 -
  10.250 -fun mk_simple_rel_OO_Grp_tac rel_OO_Grp in_alt_thm =
  10.251 -  rtac (trans OF [rel_OO_Grp, in_alt_thm RS @{thm OO_Grp_cong} RS sym]) 1;
  10.252 -
  10.253 -fun mk_simple_wit_tac wit_thms = ALLGOALS (atac ORELSE' eresolve_tac (@{thm emptyE} :: wit_thms));
  10.254 -
  10.255 -end;
    11.1 --- a/src/HOL/BNF/Tools/bnf_def.ML	Mon Jan 20 18:24:55 2014 +0100
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,1393 +0,0 @@
    11.4 -(*  Title:      HOL/BNF/Tools/bnf_def.ML
    11.5 -    Author:     Dmitriy Traytel, TU Muenchen
    11.6 -    Author:     Jasmin Blanchette, TU Muenchen
    11.7 -    Copyright   2012
    11.8 -
    11.9 -Definition of bounded natural functors.
   11.10 -*)
   11.11 -
   11.12 -signature BNF_DEF =
   11.13 -sig
   11.14 -  type bnf
   11.15 -  type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
   11.16 -
   11.17 -  val morph_bnf: morphism -> bnf -> bnf
   11.18 -  val eq_bnf: bnf * bnf -> bool
   11.19 -  val bnf_of: Proof.context -> string -> bnf option
   11.20 -  val register_bnf: string -> (bnf * local_theory) -> (bnf * local_theory)
   11.21 -
   11.22 -  val name_of_bnf: bnf -> binding
   11.23 -  val T_of_bnf: bnf -> typ
   11.24 -  val live_of_bnf: bnf -> int
   11.25 -  val lives_of_bnf: bnf -> typ list
   11.26 -  val dead_of_bnf: bnf -> int
   11.27 -  val deads_of_bnf: bnf -> typ list
   11.28 -  val nwits_of_bnf: bnf -> int
   11.29 -
   11.30 -  val mapN: string
   11.31 -  val relN: string
   11.32 -  val setN: string
   11.33 -  val mk_setN: int -> string
   11.34 -  val mk_witN: int -> string
   11.35 -
   11.36 -  val map_of_bnf: bnf -> term
   11.37 -  val sets_of_bnf: bnf -> term list
   11.38 -  val rel_of_bnf: bnf -> term
   11.39 -
   11.40 -  val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
   11.41 -  val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
   11.42 -  val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
   11.43 -  val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
   11.44 -  val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
   11.45 -  val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
   11.46 -
   11.47 -  val bd_Card_order_of_bnf: bnf -> thm
   11.48 -  val bd_Cinfinite_of_bnf: bnf -> thm
   11.49 -  val bd_Cnotzero_of_bnf: bnf -> thm
   11.50 -  val bd_card_order_of_bnf: bnf -> thm
   11.51 -  val bd_cinfinite_of_bnf: bnf -> thm
   11.52 -  val collect_set_map_of_bnf: bnf -> thm
   11.53 -  val in_bd_of_bnf: bnf -> thm
   11.54 -  val in_cong_of_bnf: bnf -> thm
   11.55 -  val in_mono_of_bnf: bnf -> thm
   11.56 -  val in_rel_of_bnf: bnf -> thm
   11.57 -  val map_comp0_of_bnf: bnf -> thm
   11.58 -  val map_comp_of_bnf: bnf -> thm
   11.59 -  val map_cong0_of_bnf: bnf -> thm
   11.60 -  val map_cong_of_bnf: bnf -> thm
   11.61 -  val map_def_of_bnf: bnf -> thm
   11.62 -  val map_id0_of_bnf: bnf -> thm
   11.63 -  val map_id_of_bnf: bnf -> thm
   11.64 -  val map_transfer_of_bnf: bnf -> thm
   11.65 -  val le_rel_OO_of_bnf: bnf -> thm
   11.66 -  val rel_def_of_bnf: bnf -> thm
   11.67 -  val rel_Grp_of_bnf: bnf -> thm
   11.68 -  val rel_OO_of_bnf: bnf -> thm
   11.69 -  val rel_OO_Grp_of_bnf: bnf -> thm
   11.70 -  val rel_cong_of_bnf: bnf -> thm
   11.71 -  val rel_conversep_of_bnf: bnf -> thm
   11.72 -  val rel_mono_of_bnf: bnf -> thm
   11.73 -  val rel_mono_strong_of_bnf: bnf -> thm
   11.74 -  val rel_eq_of_bnf: bnf -> thm
   11.75 -  val rel_flip_of_bnf: bnf -> thm
   11.76 -  val set_bd_of_bnf: bnf -> thm list
   11.77 -  val set_defs_of_bnf: bnf -> thm list
   11.78 -  val set_map0_of_bnf: bnf -> thm list
   11.79 -  val set_map_of_bnf: bnf -> thm list
   11.80 -  val wit_thms_of_bnf: bnf -> thm list
   11.81 -  val wit_thmss_of_bnf: bnf -> thm list list
   11.82 -
   11.83 -  val mk_map: int -> typ list -> typ list -> term -> term
   11.84 -  val mk_rel: int -> typ list -> typ list -> term -> term
   11.85 -  val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
   11.86 -  val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
   11.87 -  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   11.88 -  val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
   11.89 -    'a list
   11.90 -
   11.91 -  val mk_witness: int list * term -> thm list -> nonemptiness_witness
   11.92 -  val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
   11.93 -  val wits_of_bnf: bnf -> nonemptiness_witness list
   11.94 -
   11.95 -  val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
   11.96 -
   11.97 -  datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
   11.98 -  datatype fact_policy = Dont_Note | Note_Some | Note_All
   11.99 -
  11.100 -  val bnf_note_all: bool Config.T
  11.101 -  val bnf_timing: bool Config.T
  11.102 -  val user_policy: fact_policy -> Proof.context -> fact_policy
  11.103 -  val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> Proof.context ->
  11.104 -    Proof.context
  11.105 -
  11.106 -  val print_bnfs: Proof.context -> unit
  11.107 -  val prepare_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
  11.108 -    (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> typ list option ->
  11.109 -    binding -> binding -> binding list ->
  11.110 -    (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
  11.111 -    string * term list *
  11.112 -    ((thm list -> {context: Proof.context, prems: thm list} -> tactic) option * term list list) *
  11.113 -    ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
  11.114 -    local_theory * thm list
  11.115 -
  11.116 -  val define_bnf_consts: const_policy -> fact_policy -> typ list option ->
  11.117 -    binding -> binding -> binding list ->
  11.118 -    (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
  11.119 -      ((typ list * typ list * typ list * typ) *
  11.120 -       (term * term list * term * (int list * term) list * term) *
  11.121 -       (thm * thm list * thm * thm list * thm) *
  11.122 -       ((typ list -> typ list -> typ list -> term) *
  11.123 -        (typ list -> typ list -> term -> term) *
  11.124 -        (typ list -> typ list -> typ -> typ) *
  11.125 -        (typ list -> typ list -> typ list -> term) *
  11.126 -        (typ list -> typ list -> typ list -> term))) * local_theory
  11.127 -
  11.128 -  val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
  11.129 -    ({prems: thm list, context: Proof.context} -> tactic) list ->
  11.130 -    ({prems: thm list, context: Proof.context} -> tactic) -> typ list option -> binding ->
  11.131 -    binding -> binding list ->
  11.132 -    (((((binding * typ) * term) * term list) * term) * term list) * term option ->
  11.133 -    local_theory -> bnf * local_theory
  11.134 -end;
  11.135 -
  11.136 -structure BNF_Def : BNF_DEF =
  11.137 -struct
  11.138 -
  11.139 -open BNF_Util
  11.140 -open BNF_Tactics
  11.141 -open BNF_Def_Tactics
  11.142 -
  11.143 -val fundefcong_attrs = @{attributes [fundef_cong]};
  11.144 -
  11.145 -type axioms = {
  11.146 -  map_id0: thm,
  11.147 -  map_comp0: thm,
  11.148 -  map_cong0: thm,
  11.149 -  set_map0: thm list,
  11.150 -  bd_card_order: thm,
  11.151 -  bd_cinfinite: thm,
  11.152 -  set_bd: thm list,
  11.153 -  le_rel_OO: thm,
  11.154 -  rel_OO_Grp: thm
  11.155 -};
  11.156 -
  11.157 -fun mk_axioms' ((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel) =
  11.158 -  {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
  11.159 -   bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel};
  11.160 -
  11.161 -fun dest_cons [] = raise List.Empty
  11.162 -  | dest_cons (x :: xs) = (x, xs);
  11.163 -
  11.164 -fun mk_axioms n thms = thms
  11.165 -  |> map the_single
  11.166 -  |> dest_cons
  11.167 -  ||>> dest_cons
  11.168 -  ||>> dest_cons
  11.169 -  ||>> chop n
  11.170 -  ||>> dest_cons
  11.171 -  ||>> dest_cons
  11.172 -  ||>> chop n
  11.173 -  ||>> dest_cons
  11.174 -  ||> the_single
  11.175 -  |> mk_axioms';
  11.176 -
  11.177 -fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel =
  11.178 -  [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel];
  11.179 -
  11.180 -fun dest_axioms {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
  11.181 -  le_rel_OO, rel_OO_Grp} =
  11.182 -  zip_axioms map_id0 map_comp0 map_cong0 set_map0 bd_card_order bd_cinfinite set_bd le_rel_OO
  11.183 -    rel_OO_Grp;
  11.184 -
  11.185 -fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
  11.186 -  le_rel_OO, rel_OO_Grp} =
  11.187 -  {map_id0 = f map_id0,
  11.188 -    map_comp0 = f map_comp0,
  11.189 -    map_cong0 = f map_cong0,
  11.190 -    set_map0 = map f set_map0,
  11.191 -    bd_card_order = f bd_card_order,
  11.192 -    bd_cinfinite = f bd_cinfinite,
  11.193 -    set_bd = map f set_bd,
  11.194 -    le_rel_OO = f le_rel_OO,
  11.195 -    rel_OO_Grp = f rel_OO_Grp};
  11.196 -
  11.197 -val morph_axioms = map_axioms o Morphism.thm;
  11.198 -
  11.199 -type defs = {
  11.200 -  map_def: thm,
  11.201 -  set_defs: thm list,
  11.202 -  rel_def: thm
  11.203 -}
  11.204 -
  11.205 -fun mk_defs map sets rel = {map_def = map, set_defs = sets, rel_def = rel};
  11.206 -
  11.207 -fun map_defs f {map_def, set_defs, rel_def} =
  11.208 -  {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def};
  11.209 -
  11.210 -val morph_defs = map_defs o Morphism.thm;
  11.211 -
  11.212 -type facts = {
  11.213 -  bd_Card_order: thm,
  11.214 -  bd_Cinfinite: thm,
  11.215 -  bd_Cnotzero: thm,
  11.216 -  collect_set_map: thm lazy,
  11.217 -  in_bd: thm lazy,
  11.218 -  in_cong: thm lazy,
  11.219 -  in_mono: thm lazy,
  11.220 -  in_rel: thm lazy,
  11.221 -  map_comp: thm lazy,
  11.222 -  map_cong: thm lazy,
  11.223 -  map_id: thm lazy,
  11.224 -  map_transfer: thm lazy,
  11.225 -  rel_eq: thm lazy,
  11.226 -  rel_flip: thm lazy,
  11.227 -  set_map: thm lazy list,
  11.228 -  rel_cong: thm lazy,
  11.229 -  rel_mono: thm lazy,
  11.230 -  rel_mono_strong: thm lazy,
  11.231 -  rel_Grp: thm lazy,
  11.232 -  rel_conversep: thm lazy,
  11.233 -  rel_OO: thm lazy
  11.234 -};
  11.235 -
  11.236 -fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
  11.237 -    map_comp map_cong map_id map_transfer rel_eq rel_flip set_map rel_cong rel_mono
  11.238 -    rel_mono_strong rel_Grp rel_conversep rel_OO = {
  11.239 -  bd_Card_order = bd_Card_order,
  11.240 -  bd_Cinfinite = bd_Cinfinite,
  11.241 -  bd_Cnotzero = bd_Cnotzero,
  11.242 -  collect_set_map = collect_set_map,
  11.243 -  in_bd = in_bd,
  11.244 -  in_cong = in_cong,
  11.245 -  in_mono = in_mono,
  11.246 -  in_rel = in_rel,
  11.247 -  map_comp = map_comp,
  11.248 -  map_cong = map_cong,
  11.249 -  map_id = map_id,
  11.250 -  map_transfer = map_transfer,
  11.251 -  rel_eq = rel_eq,
  11.252 -  rel_flip = rel_flip,
  11.253 -  set_map = set_map,
  11.254 -  rel_cong = rel_cong,
  11.255 -  rel_mono = rel_mono,
  11.256 -  rel_mono_strong = rel_mono_strong,
  11.257 -  rel_Grp = rel_Grp,
  11.258 -  rel_conversep = rel_conversep,
  11.259 -  rel_OO = rel_OO};
  11.260 -
  11.261 -fun map_facts f {
  11.262 -  bd_Card_order,
  11.263 -  bd_Cinfinite,
  11.264 -  bd_Cnotzero,
  11.265 -  collect_set_map,
  11.266 -  in_bd,
  11.267 -  in_cong,
  11.268 -  in_mono,
  11.269 -  in_rel,
  11.270 -  map_comp,
  11.271 -  map_cong,
  11.272 -  map_id,
  11.273 -  map_transfer,
  11.274 -  rel_eq,
  11.275 -  rel_flip,
  11.276 -  set_map,
  11.277 -  rel_cong,
  11.278 -  rel_mono,
  11.279 -  rel_mono_strong,
  11.280 -  rel_Grp,
  11.281 -  rel_conversep,
  11.282 -  rel_OO} =
  11.283 -  {bd_Card_order = f bd_Card_order,
  11.284 -    bd_Cinfinite = f bd_Cinfinite,
  11.285 -    bd_Cnotzero = f bd_Cnotzero,
  11.286 -    collect_set_map = Lazy.map f collect_set_map,
  11.287 -    in_bd = Lazy.map f in_bd,
  11.288 -    in_cong = Lazy.map f in_cong,
  11.289 -    in_mono = Lazy.map f in_mono,
  11.290 -    in_rel = Lazy.map f in_rel,
  11.291 -    map_comp = Lazy.map f map_comp,
  11.292 -    map_cong = Lazy.map f map_cong,
  11.293 -    map_id = Lazy.map f map_id,
  11.294 -    map_transfer = Lazy.map f map_transfer,
  11.295 -    rel_eq = Lazy.map f rel_eq,
  11.296 -    rel_flip = Lazy.map f rel_flip,
  11.297 -    set_map = map (Lazy.map f) set_map,
  11.298 -    rel_cong = Lazy.map f rel_cong,
  11.299 -    rel_mono = Lazy.map f rel_mono,
  11.300 -    rel_mono_strong = Lazy.map f rel_mono_strong,
  11.301 -    rel_Grp = Lazy.map f rel_Grp,
  11.302 -    rel_conversep = Lazy.map f rel_conversep,
  11.303 -    rel_OO = Lazy.map f rel_OO};
  11.304 -
  11.305 -val morph_facts = map_facts o Morphism.thm;
  11.306 -
  11.307 -type nonemptiness_witness = {
  11.308 -  I: int list,
  11.309 -  wit: term,
  11.310 -  prop: thm list
  11.311 -};
  11.312 -
  11.313 -fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
  11.314 -fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
  11.315 -fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
  11.316 -
  11.317 -datatype bnf = BNF of {
  11.318 -  name: binding,
  11.319 -  T: typ,
  11.320 -  live: int,
  11.321 -  lives: typ list, (*source type variables of map*)
  11.322 -  lives': typ list, (*target type variables of map*)
  11.323 -  dead: int,
  11.324 -  deads: typ list,
  11.325 -  map: term,
  11.326 -  sets: term list,
  11.327 -  bd: term,
  11.328 -  axioms: axioms,
  11.329 -  defs: defs,
  11.330 -  facts: facts,
  11.331 -  nwits: int,
  11.332 -  wits: nonemptiness_witness list,
  11.333 -  rel: term
  11.334 -};
  11.335 -
  11.336 -(* getters *)
  11.337 -
  11.338 -fun rep_bnf (BNF bnf) = bnf;
  11.339 -val name_of_bnf = #name o rep_bnf;
  11.340 -val T_of_bnf = #T o rep_bnf;
  11.341 -fun mk_T_of_bnf Ds Ts bnf =
  11.342 -  let val bnf_rep = rep_bnf bnf
  11.343 -  in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
  11.344 -val live_of_bnf = #live o rep_bnf;
  11.345 -val lives_of_bnf = #lives o rep_bnf;
  11.346 -val dead_of_bnf = #dead o rep_bnf;
  11.347 -val deads_of_bnf = #deads o rep_bnf;
  11.348 -val axioms_of_bnf = #axioms o rep_bnf;
  11.349 -val facts_of_bnf = #facts o rep_bnf;
  11.350 -val nwits_of_bnf = #nwits o rep_bnf;
  11.351 -val wits_of_bnf = #wits o rep_bnf;
  11.352 -
  11.353 -fun flatten_type_args_of_bnf bnf dead_x xs =
  11.354 -  let
  11.355 -    val Type (_, Ts) = T_of_bnf bnf;
  11.356 -    val lives = lives_of_bnf bnf;
  11.357 -    val deads = deads_of_bnf bnf;
  11.358 -  in
  11.359 -    permute_like (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs)
  11.360 -  end;
  11.361 -
  11.362 -(*terms*)
  11.363 -val map_of_bnf = #map o rep_bnf;
  11.364 -val sets_of_bnf = #sets o rep_bnf;
  11.365 -fun mk_map_of_bnf Ds Ts Us bnf =
  11.366 -  let val bnf_rep = rep_bnf bnf;
  11.367 -  in
  11.368 -    Term.subst_atomic_types
  11.369 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
  11.370 -  end;
  11.371 -fun mk_sets_of_bnf Dss Tss bnf =
  11.372 -  let val bnf_rep = rep_bnf bnf;
  11.373 -  in
  11.374 -    map2 (fn (Ds, Ts) => Term.subst_atomic_types
  11.375 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
  11.376 -  end;
  11.377 -val bd_of_bnf = #bd o rep_bnf;
  11.378 -fun mk_bd_of_bnf Ds Ts bnf =
  11.379 -  let val bnf_rep = rep_bnf bnf;
  11.380 -  in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
  11.381 -fun mk_wits_of_bnf Dss Tss bnf =
  11.382 -  let
  11.383 -    val bnf_rep = rep_bnf bnf;
  11.384 -    val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
  11.385 -  in
  11.386 -    map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
  11.387 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
  11.388 -  end;
  11.389 -val rel_of_bnf = #rel o rep_bnf;
  11.390 -fun mk_rel_of_bnf Ds Ts Us bnf =
  11.391 -  let val bnf_rep = rep_bnf bnf;
  11.392 -  in
  11.393 -    Term.subst_atomic_types
  11.394 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
  11.395 -  end;
  11.396 -
  11.397 -(*thms*)
  11.398 -val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
  11.399 -val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
  11.400 -val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
  11.401 -val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
  11.402 -val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
  11.403 -val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
  11.404 -val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf;
  11.405 -val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
  11.406 -val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
  11.407 -val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
  11.408 -val map_def_of_bnf = #map_def o #defs o rep_bnf;
  11.409 -val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
  11.410 -val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
  11.411 -val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
  11.412 -val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
  11.413 -val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
  11.414 -val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
  11.415 -val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
  11.416 -val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
  11.417 -val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
  11.418 -val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
  11.419 -val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
  11.420 -val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
  11.421 -val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
  11.422 -val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
  11.423 -val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
  11.424 -val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
  11.425 -val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
  11.426 -val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
  11.427 -val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
  11.428 -val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
  11.429 -val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
  11.430 -val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
  11.431 -val wit_thms_of_bnf = maps #prop o wits_of_bnf;
  11.432 -val wit_thmss_of_bnf = map #prop o wits_of_bnf;
  11.433 -
  11.434 -fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel =
  11.435 -  BNF {name = name, T = T,
  11.436 -       live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
  11.437 -       map = map, sets = sets, bd = bd,
  11.438 -       axioms = axioms, defs = defs, facts = facts,
  11.439 -       nwits = length wits, wits = wits, rel = rel};
  11.440 -
  11.441 -fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
  11.442 -  dead = dead, deads = deads, map = map, sets = sets, bd = bd,
  11.443 -  axioms = axioms, defs = defs, facts = facts,
  11.444 -  nwits = nwits, wits = wits, rel = rel}) =
  11.445 -  BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
  11.446 -    live = live, lives = List.map (Morphism.typ phi) lives,
  11.447 -    lives' = List.map (Morphism.typ phi) lives',
  11.448 -    dead = dead, deads = List.map (Morphism.typ phi) deads,
  11.449 -    map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
  11.450 -    bd = Morphism.term phi bd,
  11.451 -    axioms = morph_axioms phi axioms,
  11.452 -    defs = morph_defs phi defs,
  11.453 -    facts = morph_facts phi facts,
  11.454 -    nwits = nwits,
  11.455 -    wits = List.map (morph_witness phi) wits,
  11.456 -    rel = Morphism.term phi rel};
  11.457 -
  11.458 -fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
  11.459 -  BNF {T = T2, live = live2, dead = dead2, ...}) =
  11.460 -  Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
  11.461 -
  11.462 -structure Data = Generic_Data
  11.463 -(
  11.464 -  type T = bnf Symtab.table;
  11.465 -  val empty = Symtab.empty;
  11.466 -  val extend = I;
  11.467 -  val merge = Symtab.merge eq_bnf;
  11.468 -);
  11.469 -
  11.470 -fun bnf_of ctxt =
  11.471 -  Symtab.lookup (Data.get (Context.Proof ctxt))
  11.472 -  #> Option.map (morph_bnf (Morphism.transfer_morphism (Proof_Context.theory_of ctxt)));
  11.473 -
  11.474 -
  11.475 -(* Utilities *)
  11.476 -
  11.477 -fun normalize_set insts instA set =
  11.478 -  let
  11.479 -    val (T, T') = dest_funT (fastype_of set);
  11.480 -    val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
  11.481 -    val params = Term.add_tvar_namesT T [];
  11.482 -  in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
  11.483 -
  11.484 -fun normalize_rel ctxt instTs instA instB rel =
  11.485 -  let
  11.486 -    val thy = Proof_Context.theory_of ctxt;
  11.487 -    val tyenv =
  11.488 -      Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
  11.489 -        Vartab.empty;
  11.490 -  in Envir.subst_term (tyenv, Vartab.empty) rel end
  11.491 -  handle Type.TYPE_MATCH => error "Bad relator";
  11.492 -
  11.493 -fun normalize_wit insts CA As wit =
  11.494 -  let
  11.495 -    fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
  11.496 -        if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
  11.497 -      | strip_param x = x;
  11.498 -    val (Ts, T) = strip_param ([], fastype_of wit);
  11.499 -    val subst = Term.add_tvar_namesT T [] ~~ insts;
  11.500 -    fun find y = find_index (fn x => x = y) As;
  11.501 -  in
  11.502 -    (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
  11.503 -  end;
  11.504 -
  11.505 -fun minimize_wits wits =
  11.506 - let
  11.507 -   fun minimize done [] = done
  11.508 -     | minimize done ((I, wit) :: todo) =
  11.509 -       if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
  11.510 -       then minimize done todo
  11.511 -       else minimize ((I, wit) :: done) todo;
  11.512 - in minimize [] wits end;
  11.513 -
  11.514 -fun mk_map live Ts Us t =
  11.515 -  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
  11.516 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
  11.517 -  end;
  11.518 -
  11.519 -fun mk_rel live Ts Us t =
  11.520 -  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
  11.521 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
  11.522 -  end;
  11.523 -
  11.524 -fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
  11.525 -  let
  11.526 -    fun build (TU as (T, U)) =
  11.527 -      if T = U then
  11.528 -        const T
  11.529 -      else
  11.530 -        (case TU of
  11.531 -          (Type (s, Ts), Type (s', Us)) =>
  11.532 -          if s = s' then
  11.533 -            let
  11.534 -              val bnf = the (bnf_of ctxt s);
  11.535 -              val live = live_of_bnf bnf;
  11.536 -              val mapx = mk live Ts Us (of_bnf bnf);
  11.537 -              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
  11.538 -            in Term.list_comb (mapx, map build TUs') end
  11.539 -          else
  11.540 -            build_simple TU
  11.541 -        | _ => build_simple TU);
  11.542 -  in build end;
  11.543 -
  11.544 -val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
  11.545 -val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
  11.546 -
  11.547 -fun map_flattened_map_args ctxt s map_args fs =
  11.548 -  let
  11.549 -    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
  11.550 -    val flat_fs' = map_args flat_fs;
  11.551 -  in
  11.552 -    permute_like (op aconv) flat_fs fs flat_fs'
  11.553 -  end;
  11.554 -
  11.555 -
  11.556 -(* Names *)
  11.557 -
  11.558 -val mapN = "map";
  11.559 -val setN = "set";
  11.560 -fun mk_setN i = setN ^ nonzero_string_of_int i;
  11.561 -val bdN = "bd";
  11.562 -val witN = "wit";
  11.563 -fun mk_witN i = witN ^ nonzero_string_of_int i;
  11.564 -val relN = "rel";
  11.565 -
  11.566 -val bd_card_orderN = "bd_card_order";
  11.567 -val bd_cinfiniteN = "bd_cinfinite";
  11.568 -val bd_Card_orderN = "bd_Card_order";
  11.569 -val bd_CinfiniteN = "bd_Cinfinite";
  11.570 -val bd_CnotzeroN = "bd_Cnotzero";
  11.571 -val collect_set_mapN = "collect_set_map";
  11.572 -val in_bdN = "in_bd";
  11.573 -val in_monoN = "in_mono";
  11.574 -val in_relN = "in_rel";
  11.575 -val map_id0N = "map_id0";
  11.576 -val map_idN = "map_id";
  11.577 -val map_comp0N = "map_comp0";
  11.578 -val map_compN = "map_comp";
  11.579 -val map_cong0N = "map_cong0";
  11.580 -val map_congN = "map_cong";
  11.581 -val map_transferN = "map_transfer";
  11.582 -val rel_eqN = "rel_eq";
  11.583 -val rel_flipN = "rel_flip";
  11.584 -val set_map0N = "set_map0";
  11.585 -val set_mapN = "set_map";
  11.586 -val set_bdN = "set_bd";
  11.587 -val rel_GrpN = "rel_Grp";
  11.588 -val rel_conversepN = "rel_conversep";
  11.589 -val rel_monoN = "rel_mono"
  11.590 -val rel_mono_strongN = "rel_mono_strong"
  11.591 -val rel_comppN = "rel_compp";
  11.592 -val rel_compp_GrpN = "rel_compp_Grp";
  11.593 -
  11.594 -datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
  11.595 -
  11.596 -datatype fact_policy = Dont_Note | Note_Some | Note_All;
  11.597 -
  11.598 -val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
  11.599 -val bnf_timing = Attrib.setup_config_bool @{binding bnf_timing} (K false);
  11.600 -
  11.601 -fun user_policy policy ctxt = if Config.get ctxt bnf_note_all then Note_All else policy;
  11.602 -
  11.603 -val smart_max_inline_size = 25; (*FUDGE*)
  11.604 -
  11.605 -fun note_bnf_thms fact_policy qualify' bnf_b bnf =
  11.606 -  let
  11.607 -    val axioms = axioms_of_bnf bnf;
  11.608 -    val facts = facts_of_bnf bnf;
  11.609 -    val wits = wits_of_bnf bnf;
  11.610 -    val qualify =
  11.611 -      let val (_, qs, _) = Binding.dest bnf_b;
  11.612 -      in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify' end;
  11.613 -  in
  11.614 -    (if fact_policy = Note_All then
  11.615 -      let
  11.616 -        val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
  11.617 -        val notes =
  11.618 -          [(bd_card_orderN, [#bd_card_order axioms]),
  11.619 -            (bd_cinfiniteN, [#bd_cinfinite axioms]),
  11.620 -            (bd_Card_orderN, [#bd_Card_order facts]),
  11.621 -            (bd_CinfiniteN, [#bd_Cinfinite facts]),
  11.622 -            (bd_CnotzeroN, [#bd_Cnotzero facts]),
  11.623 -            (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
  11.624 -            (in_bdN, [Lazy.force (#in_bd facts)]),
  11.625 -            (in_monoN, [Lazy.force (#in_mono facts)]),
  11.626 -            (in_relN, [Lazy.force (#in_rel facts)]),
  11.627 -            (map_comp0N, [#map_comp0 axioms]),
  11.628 -            (map_id0N, [#map_id0 axioms]),
  11.629 -            (map_transferN, [Lazy.force (#map_transfer facts)]),
  11.630 -            (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)]),
  11.631 -            (set_map0N, #set_map0 axioms),
  11.632 -            (set_bdN, #set_bd axioms)] @
  11.633 -            (witNs ~~ wit_thmss_of_bnf bnf)
  11.634 -            |> map (fn (thmN, thms) =>
  11.635 -              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []),
  11.636 -              [(thms, [])]));
  11.637 -        in
  11.638 -          Local_Theory.notes notes #> snd
  11.639 -        end
  11.640 -      else
  11.641 -        I)
  11.642 -    #> (if fact_policy <> Dont_Note then
  11.643 -        let
  11.644 -          val notes =
  11.645 -            [(map_compN, [Lazy.force (#map_comp facts)], []),
  11.646 -            (map_cong0N, [#map_cong0 axioms], []),
  11.647 -            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
  11.648 -            (map_idN, [Lazy.force (#map_id facts)], []),
  11.649 -            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
  11.650 -            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
  11.651 -            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
  11.652 -            (rel_eqN, [Lazy.force (#rel_eq facts)], []),
  11.653 -            (rel_flipN, [Lazy.force (#rel_flip facts)], []),
  11.654 -            (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
  11.655 -            (rel_monoN, [Lazy.force (#rel_mono facts)], []),
  11.656 -            (set_mapN, map Lazy.force (#set_map facts), [])]
  11.657 -            |> filter_out (null o #2)
  11.658 -            |> map (fn (thmN, thms, attrs) =>
  11.659 -              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)),
  11.660 -                attrs), [(thms, [])]));
  11.661 -        in
  11.662 -          Local_Theory.notes notes #> snd
  11.663 -        end
  11.664 -      else
  11.665 -        I)
  11.666 -  end;
  11.667 -
  11.668 -
  11.669 -(* Define new BNFs *)
  11.670 -
  11.671 -fun define_bnf_consts const_policy fact_policy Ds_opt map_b rel_b set_bs
  11.672 -  ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy =
  11.673 -  let
  11.674 -    val live = length set_rhss;
  11.675 -
  11.676 -    val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
  11.677 -
  11.678 -    fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
  11.679 -
  11.680 -    fun maybe_define user_specified (b, rhs) lthy =
  11.681 -      let
  11.682 -        val inline =
  11.683 -          (user_specified orelse fact_policy = Dont_Note) andalso
  11.684 -          (case const_policy of
  11.685 -            Dont_Inline => false
  11.686 -          | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
  11.687 -          | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
  11.688 -          | Do_Inline => true)
  11.689 -      in
  11.690 -        if inline then
  11.691 -          ((rhs, Drule.reflexive_thm), lthy)
  11.692 -        else
  11.693 -          let val b = b () in
  11.694 -            apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
  11.695 -              lthy)
  11.696 -          end
  11.697 -      end;
  11.698 -
  11.699 -    fun maybe_restore lthy_old lthy =
  11.700 -      lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
  11.701 -
  11.702 -    val map_bind_def =
  11.703 -      (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
  11.704 -         map_rhs);
  11.705 -    val set_binds_defs =
  11.706 -      let
  11.707 -        fun set_name i get_b =
  11.708 -          (case try (nth set_bs) (i - 1) of
  11.709 -            SOME b => if Binding.is_empty b then get_b else K b
  11.710 -          | NONE => get_b) #> def_qualify;
  11.711 -        val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
  11.712 -          else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
  11.713 -      in bs ~~ set_rhss end;
  11.714 -    val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
  11.715 -
  11.716 -    val ((((bnf_map_term, raw_map_def),
  11.717 -      (bnf_set_terms, raw_set_defs)),
  11.718 -      (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
  11.719 -        no_defs_lthy
  11.720 -        |> maybe_define true map_bind_def
  11.721 -        ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
  11.722 -        ||>> maybe_define true bd_bind_def
  11.723 -        ||> `(maybe_restore no_defs_lthy);
  11.724 -
  11.725 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  11.726 -
  11.727 -
  11.728 -    val bnf_map_def = Morphism.thm phi raw_map_def;
  11.729 -    val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
  11.730 -    val bnf_bd_def = Morphism.thm phi raw_bd_def;
  11.731 -
  11.732 -    val bnf_map = Morphism.term phi bnf_map_term;
  11.733 -
  11.734 -    (*TODO: handle errors*)
  11.735 -    (*simple shape analysis of a map function*)
  11.736 -    val ((alphas, betas), (Calpha, _)) =
  11.737 -      fastype_of bnf_map
  11.738 -      |> strip_typeN live
  11.739 -      |>> map_split dest_funT
  11.740 -      ||> dest_funT
  11.741 -      handle TYPE _ => error "Bad map function";
  11.742 -
  11.743 -    val Calpha_params = map TVar (Term.add_tvarsT Calpha []);
  11.744 -
  11.745 -    val bnf_T = Morphism.typ phi T_rhs;
  11.746 -    val bad_args = Term.add_tfreesT bnf_T [];
  11.747 -    val _ = if null bad_args then () else error ("Locally fixed type arguments " ^
  11.748 -      commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
  11.749 -
  11.750 -    val bnf_sets =
  11.751 -      map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms);
  11.752 -    val bnf_bd =
  11.753 -      Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params)
  11.754 -        (Morphism.term phi bnf_bd_term);
  11.755 -
  11.756 -    (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
  11.757 -    val deads = (case Ds_opt of
  11.758 -      NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
  11.759 -    | SOME Ds => map (Morphism.typ phi) Ds);
  11.760 -
  11.761 -    (*TODO: further checks of type of bnf_map*)
  11.762 -    (*TODO: check types of bnf_sets*)
  11.763 -    (*TODO: check type of bnf_bd*)
  11.764 -    (*TODO: check type of bnf_rel*)
  11.765 -
  11.766 -    fun mk_bnf_map Ds As' Bs' =
  11.767 -      Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
  11.768 -    fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
  11.769 -    fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
  11.770 -
  11.771 -    val (((As, Bs), Ds), names_lthy) = lthy
  11.772 -      |> mk_TFrees live
  11.773 -      ||>> mk_TFrees live
  11.774 -      ||>> mk_TFrees (length deads);
  11.775 -    val RTs = map2 (curry HOLogic.mk_prodT) As Bs;
  11.776 -    val pred2RTs = map2 mk_pred2T As Bs;
  11.777 -    val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst
  11.778 -    val CA = mk_bnf_T Ds As Calpha;
  11.779 -    val CR = mk_bnf_T Ds RTs Calpha;
  11.780 -    val setRs =
  11.781 -      map3 (fn R => fn T => fn U =>
  11.782 -          HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split R) Rs As Bs;
  11.783 -
  11.784 -    (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
  11.785 -      Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
  11.786 -    val OO_Grp =
  11.787 -      let
  11.788 -        val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
  11.789 -        val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
  11.790 -        val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR;
  11.791 -      in
  11.792 -        mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2)
  11.793 -        |> fold_rev Term.absfree Rs'
  11.794 -      end;
  11.795 -
  11.796 -    val rel_rhs = the_default OO_Grp rel_rhs_opt;
  11.797 -
  11.798 -    val rel_bind_def =
  11.799 -      (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
  11.800 -         rel_rhs);
  11.801 -
  11.802 -    val wit_rhss =
  11.803 -      if null wit_rhss then
  11.804 -        [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
  11.805 -          map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $
  11.806 -          Const (@{const_name undefined}, CA))]
  11.807 -      else wit_rhss;
  11.808 -    val nwits = length wit_rhss;
  11.809 -    val wit_binds_defs =
  11.810 -      let
  11.811 -        val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
  11.812 -          else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
  11.813 -      in bs ~~ wit_rhss end;
  11.814 -
  11.815 -    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  11.816 -      lthy
  11.817 -      |> maybe_define (is_some rel_rhs_opt) rel_bind_def
  11.818 -      ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
  11.819 -      ||> `(maybe_restore lthy);
  11.820 -
  11.821 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  11.822 -    val bnf_rel_def = Morphism.thm phi raw_rel_def;
  11.823 -    val bnf_rel = Morphism.term phi bnf_rel_term;
  11.824 -    fun mk_bnf_rel Ds As' Bs' =
  11.825 -      normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
  11.826 -        bnf_rel;
  11.827 -
  11.828 -    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  11.829 -    val bnf_wits =
  11.830 -      map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
  11.831 -
  11.832 -    fun mk_OO_Grp Ds' As' Bs' =
  11.833 -      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) OO_Grp;
  11.834 -  in
  11.835 -    (((alphas, betas, deads, Calpha),
  11.836 -     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
  11.837 -     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
  11.838 -     (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_OO_Grp)), lthy)
  11.839 -  end;
  11.840 -
  11.841 -fun prepare_def const_policy mk_fact_policy qualify prep_typ prep_term Ds_opt map_b rel_b set_bs
  11.842 -  ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
  11.843 -  no_defs_lthy =
  11.844 -  let
  11.845 -    val fact_policy = mk_fact_policy no_defs_lthy;
  11.846 -    val bnf_b = qualify raw_bnf_b;
  11.847 -    val live = length raw_sets;
  11.848 -
  11.849 -    val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
  11.850 -    val map_rhs = prep_term no_defs_lthy raw_map;
  11.851 -    val set_rhss = map (prep_term no_defs_lthy) raw_sets;
  11.852 -    val bd_rhs = prep_term no_defs_lthy raw_bd;
  11.853 -    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
  11.854 -    val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
  11.855 -
  11.856 -    fun err T =
  11.857 -      error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
  11.858 -        " as unnamed BNF");
  11.859 -
  11.860 -    val (bnf_b, key) =
  11.861 -      if Binding.eq_name (bnf_b, Binding.empty) then
  11.862 -        (case T_rhs of
  11.863 -          Type (C, Ts) => if forall (can dest_TFree) Ts
  11.864 -            then (Binding.qualified_name C, C) else err T_rhs
  11.865 -        | T => err T)
  11.866 -      else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
  11.867 -
  11.868 -    val (((alphas, betas, deads, Calpha),
  11.869 -     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
  11.870 -     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
  11.871 -     (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, mk_OO_Grp)), lthy) =
  11.872 -       define_bnf_consts const_policy fact_policy Ds_opt map_b rel_b set_bs
  11.873 -         ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy;
  11.874 -
  11.875 -    val dead = length deads;
  11.876 -
  11.877 -    val ((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), (Ts, T)) = lthy
  11.878 -      |> mk_TFrees live
  11.879 -      ||>> mk_TFrees live
  11.880 -      ||>> mk_TFrees live
  11.881 -      ||>> mk_TFrees dead
  11.882 -      ||>> mk_TFrees live
  11.883 -      ||>> mk_TFrees live
  11.884 -      ||> fst o mk_TFrees 1
  11.885 -      ||> the_single
  11.886 -      ||> `(replicate live);
  11.887 -
  11.888 -    val mk_bnf_map = mk_bnf_map_Ds Ds;
  11.889 -    val mk_bnf_t = mk_bnf_t_Ds Ds;
  11.890 -    val mk_bnf_T = mk_bnf_T_Ds Ds;
  11.891 -
  11.892 -    val pred2RTs = map2 mk_pred2T As' Bs';
  11.893 -    val pred2RTsAsCs = map2 mk_pred2T As' Cs;
  11.894 -    val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
  11.895 -    val pred2RT's = map2 mk_pred2T Bs' As';
  11.896 -    val self_pred2RTs = map2 mk_pred2T As' As';
  11.897 -    val transfer_domRTs = map2 mk_pred2T As' B1Ts;
  11.898 -    val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts;
  11.899 -
  11.900 -    val CA' = mk_bnf_T As' Calpha;
  11.901 -    val CB' = mk_bnf_T Bs' Calpha;
  11.902 -    val CC' = mk_bnf_T Cs Calpha;
  11.903 -    val CB1 = mk_bnf_T B1Ts Calpha;
  11.904 -    val CB2 = mk_bnf_T B2Ts Calpha;
  11.905 -
  11.906 -    val bnf_map_AsAs = mk_bnf_map As' As';
  11.907 -    val bnf_map_AsBs = mk_bnf_map As' Bs';
  11.908 -    val bnf_map_AsCs = mk_bnf_map As' Cs;
  11.909 -    val bnf_map_BsCs = mk_bnf_map Bs' Cs;
  11.910 -    val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
  11.911 -    val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
  11.912 -    val bnf_bd_As = mk_bnf_t As' bnf_bd;
  11.913 -    fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
  11.914 -
  11.915 -    val pre_names_lthy = lthy;
  11.916 -    val (((((((((((((((fs, gs), hs), x), y), zs), ys), As),
  11.917 -      As_copy), bs), Rs), Rs_copy), Ss),
  11.918 -      transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy
  11.919 -      |> mk_Frees "f" (map2 (curry op -->) As' Bs')
  11.920 -      ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs)
  11.921 -      ||>> mk_Frees "h" (map2 (curry op -->) As' Ts)
  11.922 -      ||>> yield_singleton (mk_Frees "x") CA'
  11.923 -      ||>> yield_singleton (mk_Frees "y") CB'
  11.924 -      ||>> mk_Frees "z" As'
  11.925 -      ||>> mk_Frees "y" Bs'
  11.926 -      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  11.927 -      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  11.928 -      ||>> mk_Frees "b" As'
  11.929 -      ||>> mk_Frees "R" pred2RTs
  11.930 -      ||>> mk_Frees "R" pred2RTs
  11.931 -      ||>> mk_Frees "S" pred2RTsBsCs
  11.932 -      ||>> mk_Frees "R" transfer_domRTs
  11.933 -      ||>> mk_Frees "S" transfer_ranRTs;
  11.934 -
  11.935 -    val fs_copy = map2 (retype_free o fastype_of) fs gs;
  11.936 -    val x_copy = retype_free CA' y;
  11.937 -
  11.938 -    val rel = mk_bnf_rel pred2RTs CA' CB';
  11.939 -    val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
  11.940 -    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  11.941 -
  11.942 -    val map_id0_goal =
  11.943 -      let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
  11.944 -        mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
  11.945 -      end;
  11.946 -
  11.947 -    val map_comp0_goal =
  11.948 -      let
  11.949 -        val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
  11.950 -        val comp_bnf_map_app = HOLogic.mk_comp
  11.951 -          (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs));
  11.952 -      in
  11.953 -        fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
  11.954 -      end;
  11.955 -
  11.956 -    fun mk_map_cong_prem x z set f f_copy =
  11.957 -      Logic.all z (Logic.mk_implies
  11.958 -        (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
  11.959 -        mk_Trueprop_eq (f $ z, f_copy $ z)));
  11.960 -
  11.961 -    val map_cong0_goal =
  11.962 -      let
  11.963 -        val prems = map4 (mk_map_cong_prem x) zs bnf_sets_As fs fs_copy;
  11.964 -        val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  11.965 -          Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
  11.966 -      in
  11.967 -        fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq))
  11.968 -      end;
  11.969 -
  11.970 -    val set_map0s_goal =
  11.971 -      let
  11.972 -        fun mk_goal setA setB f =
  11.973 -          let
  11.974 -            val set_comp_map =
  11.975 -              HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
  11.976 -            val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
  11.977 -          in
  11.978 -            fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
  11.979 -          end;
  11.980 -      in
  11.981 -        map3 mk_goal bnf_sets_As bnf_sets_Bs fs
  11.982 -      end;
  11.983 -
  11.984 -    val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
  11.985 -
  11.986 -    val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
  11.987 -
  11.988 -    val set_bds_goal =
  11.989 -      let
  11.990 -        fun mk_goal set =
  11.991 -          Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
  11.992 -      in
  11.993 -        map mk_goal bnf_sets_As
  11.994 -      end;
  11.995 -
  11.996 -    val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC';
  11.997 -    val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC';
  11.998 -    val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss);
  11.999 -    val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss));
 11.1000 -    val le_rel_OO_goal =
 11.1001 -      fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
 11.1002 -
 11.1003 -    val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
 11.1004 -      Term.list_comb (mk_OO_Grp Ds As' Bs', Rs)));
 11.1005 -
 11.1006 -    val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
 11.1007 -      card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal;
 11.1008 -
 11.1009 -    fun mk_wit_goals (I, wit) =
 11.1010 -      let
 11.1011 -        val xs = map (nth bs) I;
 11.1012 -        fun wit_goal i =
 11.1013 -          let
 11.1014 -            val z = nth zs i;
 11.1015 -            val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
 11.1016 -            val concl = HOLogic.mk_Trueprop
 11.1017 -              (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
 11.1018 -              else @{term False});
 11.1019 -          in
 11.1020 -            fold_rev Logic.all (z :: xs)
 11.1021 -              (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
 11.1022 -          end;
 11.1023 -      in
 11.1024 -        map wit_goal (0 upto live - 1)
 11.1025 -      end;
 11.1026 -
 11.1027 -    val triv_wit_tac = mk_trivial_wit_tac bnf_wit_defs;
 11.1028 -
 11.1029 -    val wit_goalss =
 11.1030 -      (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
 11.1031 -
 11.1032 -    fun after_qed mk_wit_thms thms lthy =
 11.1033 -      let
 11.1034 -        val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
 11.1035 -
 11.1036 -        val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
 11.1037 -        val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
 11.1038 -        val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
 11.1039 -
 11.1040 -        fun mk_collect_set_map () =
 11.1041 -          let
 11.1042 -            val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T;
 11.1043 -            val collect_map = HOLogic.mk_comp
 11.1044 -              (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
 11.1045 -              Term.list_comb (mk_bnf_map As' Ts, hs));
 11.1046 -            val image_collect = mk_collect
 11.1047 -              (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
 11.1048 -              defT;
 11.1049 -            (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
 11.1050 -            val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
 11.1051 -          in
 11.1052 -            Goal.prove_sorry lthy [] [] goal (K (mk_collect_set_map_tac (#set_map0 axioms)))
 11.1053 -            |> Thm.close_derivation
 11.1054 -          end;
 11.1055 -
 11.1056 -        val collect_set_map = Lazy.lazy mk_collect_set_map;
 11.1057 -
 11.1058 -        fun mk_in_mono () =
 11.1059 -          let
 11.1060 -            val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy;
 11.1061 -            val in_mono_goal =
 11.1062 -              fold_rev Logic.all (As @ As_copy)
 11.1063 -                (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
 11.1064 -                  (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
 11.1065 -          in
 11.1066 -            Goal.prove_sorry lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
 11.1067 -            |> Thm.close_derivation
 11.1068 -          end;
 11.1069 -
 11.1070 -        val in_mono = Lazy.lazy mk_in_mono;
 11.1071 -
 11.1072 -        fun mk_in_cong () =
 11.1073 -          let
 11.1074 -            val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
 11.1075 -            val in_cong_goal =
 11.1076 -              fold_rev Logic.all (As @ As_copy)
 11.1077 -                (Logic.list_implies (prems_cong,
 11.1078 -                  mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
 11.1079 -          in
 11.1080 -            Goal.prove_sorry lthy [] [] in_cong_goal
 11.1081 -              (K ((TRY o hyp_subst_tac lthy THEN' rtac refl) 1))
 11.1082 -            |> Thm.close_derivation
 11.1083 -          end;
 11.1084 -
 11.1085 -        val in_cong = Lazy.lazy mk_in_cong;
 11.1086 -
 11.1087 -        val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms));
 11.1088 -        val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms));
 11.1089 -
 11.1090 -        fun mk_map_cong () =
 11.1091 -          let
 11.1092 -            val prem0 = mk_Trueprop_eq (x, x_copy);
 11.1093 -            val prems = map4 (mk_map_cong_prem x_copy) zs bnf_sets_As fs fs_copy;
 11.1094 -            val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
 11.1095 -              Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
 11.1096 -            val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
 11.1097 -              (Logic.list_implies (prem0 :: prems, eq));
 11.1098 -          in
 11.1099 -            Goal.prove_sorry lthy [] [] goal (fn _ => mk_map_cong_tac lthy (#map_cong0 axioms))
 11.1100 -            |> Thm.close_derivation
 11.1101 -          end;
 11.1102 -
 11.1103 -        val map_cong = Lazy.lazy mk_map_cong;
 11.1104 -
 11.1105 -        val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
 11.1106 -
 11.1107 -        val wit_thms =
 11.1108 -          if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
 11.1109 -
 11.1110 -        fun mk_in_bd () =
 11.1111 -          let
 11.1112 -            val bdT = fst (dest_relT (fastype_of bnf_bd_As));
 11.1113 -            val bdTs = replicate live bdT;
 11.1114 -            val bd_bnfT = mk_bnf_T bdTs Calpha;
 11.1115 -            val surj_imp_ordLeq_inst = (if live = 0 then TrueI else
 11.1116 -              let
 11.1117 -                val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As';
 11.1118 -                val funTs = map (fn T => bdT --> T) ranTs;
 11.1119 -                val ran_bnfT = mk_bnf_T ranTs Calpha;
 11.1120 -                val (revTs, Ts) = `rev (bd_bnfT :: funTs);
 11.1121 -                val cTs = map (SOME o certifyT lthy) [ran_bnfT, Library.foldr1 HOLogic.mk_prodT Ts];
 11.1122 -                val tinst = fold (fn T => fn t => HOLogic.mk_split (Term.absdummy T t)) (tl revTs)
 11.1123 -                  (Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs,
 11.1124 -                    map Bound (live - 1 downto 0)) $ Bound live));
 11.1125 -                val cts = [NONE, SOME (certify lthy tinst)];
 11.1126 -              in
 11.1127 -                Drule.instantiate' cTs cts @{thm surj_imp_ordLeq}
 11.1128 -              end);
 11.1129 -            val bd = mk_cexp
 11.1130 -              (if live = 0 then ctwo
 11.1131 -                else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
 11.1132 -              (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT)));
 11.1133 -            val in_bd_goal =
 11.1134 -              fold_rev Logic.all As
 11.1135 -                (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd));
 11.1136 -          in
 11.1137 -            Goal.prove_sorry lthy [] [] in_bd_goal
 11.1138 -              (mk_in_bd_tac live surj_imp_ordLeq_inst
 11.1139 -                (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms)
 11.1140 -                (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms)
 11.1141 -                bd_Card_order bd_Cinfinite bd_Cnotzero)
 11.1142 -            |> Thm.close_derivation
 11.1143 -          end;
 11.1144 -
 11.1145 -        val in_bd = Lazy.lazy mk_in_bd;
 11.1146 -
 11.1147 -        val rel_OO_Grp = #rel_OO_Grp axioms;
 11.1148 -        val rel_OO_Grps = no_refl [rel_OO_Grp];
 11.1149 -
 11.1150 -        fun mk_rel_Grp () =
 11.1151 -          let
 11.1152 -            val lhs = Term.list_comb (rel, map2 mk_Grp As fs);
 11.1153 -            val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
 11.1154 -            val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
 11.1155 -          in
 11.1156 -            Goal.prove_sorry lthy [] [] goal
 11.1157 -              (mk_rel_Grp_tac rel_OO_Grps (#map_id0 axioms) (#map_cong0 axioms) (Lazy.force map_id)
 11.1158 -                (Lazy.force map_comp) (map Lazy.force set_map))
 11.1159 -            |> Thm.close_derivation
 11.1160 -          end;
 11.1161 -
 11.1162 -        val rel_Grp = Lazy.lazy mk_rel_Grp;
 11.1163 -
 11.1164 -        fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
 11.1165 -        fun mk_rel_concl f = HOLogic.mk_Trueprop
 11.1166 -          (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy)));
 11.1167 -
 11.1168 -        fun mk_rel_mono () =
 11.1169 -          let
 11.1170 -            val mono_prems = mk_rel_prems mk_leq;
 11.1171 -            val mono_concl = mk_rel_concl (uncurry mk_leq);
 11.1172 -          in
 11.1173 -            Goal.prove_sorry lthy [] []
 11.1174 -              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
 11.1175 -              (K (mk_rel_mono_tac rel_OO_Grps (Lazy.force in_mono)))
 11.1176 -            |> Thm.close_derivation
 11.1177 -          end;
 11.1178 -
 11.1179 -        fun mk_rel_cong () =
 11.1180 -          let
 11.1181 -            val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
 11.1182 -            val cong_concl = mk_rel_concl HOLogic.mk_eq;
 11.1183 -          in
 11.1184 -            Goal.prove_sorry lthy [] []
 11.1185 -              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
 11.1186 -              (fn _ => (TRY o hyp_subst_tac lthy THEN' rtac refl) 1)
 11.1187 -            |> Thm.close_derivation
 11.1188 -          end;
 11.1189 -
 11.1190 -        val rel_mono = Lazy.lazy mk_rel_mono;
 11.1191 -        val rel_cong = Lazy.lazy mk_rel_cong;
 11.1192 -
 11.1193 -        fun mk_rel_eq () =
 11.1194 -          Goal.prove_sorry lthy [] []
 11.1195 -            (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'),
 11.1196 -              HOLogic.eq_const CA'))
 11.1197 -            (K (mk_rel_eq_tac live (Lazy.force rel_Grp) (Lazy.force rel_cong) (#map_id0 axioms)))
 11.1198 -          |> Thm.close_derivation;
 11.1199 -
 11.1200 -        val rel_eq = Lazy.lazy mk_rel_eq;
 11.1201 -
 11.1202 -        fun mk_rel_conversep () =
 11.1203 -          let
 11.1204 -            val relBsAs = mk_bnf_rel pred2RT's CB' CA';
 11.1205 -            val lhs = Term.list_comb (relBsAs, map mk_conversep Rs);
 11.1206 -            val rhs = mk_conversep (Term.list_comb (rel, Rs));
 11.1207 -            val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs));
 11.1208 -            val le_thm = Goal.prove_sorry lthy [] [] le_goal
 11.1209 -              (mk_rel_conversep_le_tac rel_OO_Grps (Lazy.force rel_eq) (#map_cong0 axioms)
 11.1210 -                (Lazy.force map_comp) (map Lazy.force set_map))
 11.1211 -              |> Thm.close_derivation
 11.1212 -            val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
 11.1213 -          in
 11.1214 -            Goal.prove_sorry lthy [] [] goal
 11.1215 -              (K (mk_rel_conversep_tac le_thm (Lazy.force rel_mono)))
 11.1216 -            |> Thm.close_derivation
 11.1217 -          end;
 11.1218 -
 11.1219 -        val rel_conversep = Lazy.lazy mk_rel_conversep;
 11.1220 -
 11.1221 -        fun mk_rel_OO () =
 11.1222 -          Goal.prove_sorry lthy [] []
 11.1223 -            (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs)))
 11.1224 -            (mk_rel_OO_le_tac rel_OO_Grps (Lazy.force rel_eq) (#map_cong0 axioms)
 11.1225 -              (Lazy.force map_comp) (map Lazy.force set_map))
 11.1226 -          |> Thm.close_derivation
 11.1227 -          |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]);
 11.1228 -
 11.1229 -        val rel_OO = Lazy.lazy mk_rel_OO;
 11.1230 -
 11.1231 -        fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD};
 11.1232 -
 11.1233 -        val in_rel = Lazy.lazy mk_in_rel;
 11.1234 -
 11.1235 -        fun mk_rel_flip () =
 11.1236 -          let
 11.1237 -            val rel_conversep_thm = Lazy.force rel_conversep;
 11.1238 -            val cts = map (SOME o certify lthy) Rs;
 11.1239 -            val rel_conversep_thm' = cterm_instantiate_pos cts rel_conversep_thm;
 11.1240 -          in
 11.1241 -            unfold_thms lthy @{thms conversep_iff} (rel_conversep_thm' RS @{thm predicate2_eqD})
 11.1242 -            |> singleton (Proof_Context.export names_lthy pre_names_lthy)
 11.1243 -          end;
 11.1244 -
 11.1245 -        val rel_flip = Lazy.lazy mk_rel_flip;
 11.1246 -
 11.1247 -        fun mk_rel_mono_strong () =
 11.1248 -          let
 11.1249 -            fun mk_prem setA setB R S a b =
 11.1250 -              HOLogic.mk_Trueprop
 11.1251 -                (mk_Ball (setA $ x) (Term.absfree (dest_Free a)
 11.1252 -                  (mk_Ball (setB $ y) (Term.absfree (dest_Free b)
 11.1253 -                    (HOLogic.mk_imp (R $ a $ b, S $ a $ b))))));
 11.1254 -            val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) :: 
 11.1255 -              map6 mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys;
 11.1256 -            val concl = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs_copy) $ x $ y);
 11.1257 -          in
 11.1258 -            Goal.prove_sorry lthy [] []
 11.1259 -              (fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl)))
 11.1260 -              (mk_rel_mono_strong_tac (Lazy.force in_rel) (map Lazy.force set_map))
 11.1261 -            |> Thm.close_derivation
 11.1262 -          end;
 11.1263 -
 11.1264 -        val rel_mono_strong = Lazy.lazy mk_rel_mono_strong;
 11.1265 -
 11.1266 -        fun mk_map_transfer () =
 11.1267 -          let
 11.1268 -            val rels = map2 mk_fun_rel transfer_domRs transfer_ranRs;
 11.1269 -            val rel = mk_fun_rel
 11.1270 -              (Term.list_comb (mk_bnf_rel transfer_domRTs CA' CB1, transfer_domRs))
 11.1271 -              (Term.list_comb (mk_bnf_rel transfer_ranRTs CB' CB2, transfer_ranRs));
 11.1272 -            val concl = HOLogic.mk_Trueprop
 11.1273 -              (fold_rev mk_fun_rel rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts);
 11.1274 -          in
 11.1275 -            Goal.prove_sorry lthy [] []
 11.1276 -              (fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl)
 11.1277 -              (mk_map_transfer_tac (Lazy.force rel_mono) (Lazy.force in_rel)
 11.1278 -                (map Lazy.force set_map) (#map_cong0 axioms) (Lazy.force map_comp))
 11.1279 -            |> Thm.close_derivation
 11.1280 -          end;
 11.1281 -
 11.1282 -        val map_transfer = Lazy.lazy mk_map_transfer;
 11.1283 -
 11.1284 -        val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def;
 11.1285 -
 11.1286 -        val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong
 11.1287 -          in_mono in_rel map_comp map_cong map_id map_transfer rel_eq rel_flip set_map
 11.1288 -          rel_cong rel_mono rel_mono_strong rel_Grp rel_conversep rel_OO;
 11.1289 -
 11.1290 -        val wits = map2 mk_witness bnf_wits wit_thms;
 11.1291 -
 11.1292 -        val bnf_rel =
 11.1293 -          Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
 11.1294 -
 11.1295 -        val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms
 11.1296 -          defs facts wits bnf_rel;
 11.1297 -      in
 11.1298 -        (bnf, lthy |> note_bnf_thms fact_policy qualify bnf_b bnf)
 11.1299 -      end;
 11.1300 -
 11.1301 -    val one_step_defs =
 11.1302 -      no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def]);
 11.1303 -  in
 11.1304 -    (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
 11.1305 -  end;
 11.1306 -
 11.1307 -fun register_bnf key (bnf, lthy) =
 11.1308 -  (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
 11.1309 -    (fn phi => Data.map (Symtab.default (key, morph_bnf phi bnf))) lthy);
 11.1310 -
 11.1311 -fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
 11.1312 -  (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
 11.1313 -  let
 11.1314 -    fun mk_wits_tac set_maps =
 11.1315 -      K (TRYALL Goal.conjunction_tac) THEN'
 11.1316 -      (case triv_tac_opt of
 11.1317 -        SOME tac => tac set_maps
 11.1318 -      | NONE => fn {context = ctxt, prems} =>
 11.1319 -          unfold_thms_tac ctxt one_step_defs THEN wit_tac {context = ctxt, prems = prems});
 11.1320 -    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
 11.1321 -    fun mk_wit_thms set_maps =
 11.1322 -      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
 11.1323 -        |> Conjunction.elim_balanced (length wit_goals)
 11.1324 -        |> map2 (Conjunction.elim_balanced o length) wit_goalss
 11.1325 -        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
 11.1326 -  in
 11.1327 -    map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
 11.1328 -      goals (map (fn tac => fn {context = ctxt, prems} =>
 11.1329 -        unfold_thms_tac ctxt one_step_defs THEN tac {context = ctxt, prems = prems}) tacs)
 11.1330 -    |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
 11.1331 -  end) oo prepare_def const_policy fact_policy qualify (K I) (K I) Ds map_b rel_b set_bs;
 11.1332 -
 11.1333 -val bnf_cmd = (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
 11.1334 -  let
 11.1335 -    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
 11.1336 -    fun mk_triv_wit_thms tac set_maps =
 11.1337 -      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
 11.1338 -        (K (TRYALL Goal.conjunction_tac) THEN' tac set_maps)
 11.1339 -        |> Conjunction.elim_balanced (length wit_goals)
 11.1340 -        |> map2 (Conjunction.elim_balanced o length) wit_goalss
 11.1341 -        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
 11.1342 -    val (mk_wit_thms, nontriv_wit_goals) = 
 11.1343 -      (case triv_tac_opt of
 11.1344 -        NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
 11.1345 -      | SOME tac => (mk_triv_wit_thms tac, []));
 11.1346 -  in
 11.1347 -    Proof.unfolding ([[(defs, [])]])
 11.1348 -      (Proof.theorem NONE (snd o register_bnf key oo after_qed mk_wit_thms)
 11.1349 -        (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
 11.1350 -  end) oo prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_typ Syntax.read_term NONE
 11.1351 -    Binding.empty Binding.empty [];
 11.1352 -
 11.1353 -fun print_bnfs ctxt =
 11.1354 -  let
 11.1355 -    fun pretty_set sets i = Pretty.block
 11.1356 -      [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
 11.1357 -          Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
 11.1358 -
 11.1359 -    fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
 11.1360 -      live = live, lives = lives, dead = dead, deads = deads, ...}) =
 11.1361 -      Pretty.big_list
 11.1362 -        (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
 11.1363 -          Pretty.quote (Syntax.pretty_typ ctxt T)]))
 11.1364 -        ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
 11.1365 -            Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
 11.1366 -          Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
 11.1367 -            Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
 11.1368 -          Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
 11.1369 -            Pretty.quote (Syntax.pretty_term ctxt map)]] @
 11.1370 -          List.map (pretty_set sets) (0 upto length sets - 1) @
 11.1371 -          [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
 11.1372 -            Pretty.quote (Syntax.pretty_term ctxt bd)]]);
 11.1373 -  in
 11.1374 -    Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
 11.1375 -    |> Pretty.writeln
 11.1376 -  end;
 11.1377 -
 11.1378 -val _ =
 11.1379 -  Outer_Syntax.improper_command @{command_spec "print_bnfs"}
 11.1380 -    "print all bounded natural functors"
 11.1381 -    (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
 11.1382 -
 11.1383 -val _ =
 11.1384 -  Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
 11.1385 -    "register a type as a bounded natural functor"
 11.1386 -    (parse_opt_binding_colon -- Parse.typ --|
 11.1387 -       (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
 11.1388 -       (Scan.option ((Parse.reserved "sets" -- @{keyword ":"}) |--
 11.1389 -         Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) >> the_default []) --|
 11.1390 -       (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
 11.1391 -       (Scan.option ((Parse.reserved "wits" -- @{keyword ":"}) |--
 11.1392 -         Scan.repeat1 (Scan.unless (Parse.reserved "rel") Parse.term)) >> the_default []) --
 11.1393 -       Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term)
 11.1394 -       >> bnf_cmd);
 11.1395 -
 11.1396 -end;
    12.1 --- a/src/HOL/BNF/Tools/bnf_def_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,284 +0,0 @@
    12.4 -(*  Title:      HOL/BNF/Tools/bnf_def_tactics.ML
    12.5 -    Author:     Dmitriy Traytel, TU Muenchen
    12.6 -    Author:     Jasmin Blanchette, TU Muenchen
    12.7 -    Copyright   2012
    12.8 -
    12.9 -Tactics for definition of bounded natural functors.
   12.10 -*)
   12.11 -
   12.12 -signature BNF_DEF_TACTICS =
   12.13 -sig
   12.14 -  val mk_collect_set_map_tac: thm list -> tactic
   12.15 -  val mk_map_id: thm -> thm
   12.16 -  val mk_map_comp: thm -> thm
   12.17 -  val mk_map_cong_tac: Proof.context -> thm -> tactic
   12.18 -  val mk_in_mono_tac: int -> tactic
   12.19 -  val mk_set_map: thm -> thm
   12.20 -
   12.21 -  val mk_rel_Grp_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
   12.22 -    {prems: thm list, context: Proof.context} -> tactic
   12.23 -  val mk_rel_eq_tac: int -> thm -> thm -> thm -> tactic
   12.24 -  val mk_rel_OO_le_tac: thm list -> thm -> thm -> thm -> thm list ->
   12.25 -    {prems: thm list, context: Proof.context} -> tactic
   12.26 -  val mk_rel_conversep_tac: thm -> thm -> tactic
   12.27 -  val mk_rel_conversep_le_tac: thm list -> thm -> thm -> thm -> thm list ->
   12.28 -    {prems: thm list, context: Proof.context} -> tactic
   12.29 -  val mk_rel_mono_tac: thm list -> thm -> tactic
   12.30 -  val mk_rel_mono_strong_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
   12.31 -
   12.32 -  val mk_map_transfer_tac: thm -> thm -> thm list -> thm -> thm ->
   12.33 -    {prems: thm list, context: Proof.context} -> tactic
   12.34 -
   12.35 -  val mk_in_bd_tac: int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm ->
   12.36 -    thm -> {prems: thm list, context: Proof.context} -> tactic
   12.37 -
   12.38 -  val mk_trivial_wit_tac: thm list -> thm list -> {prems: thm list, context: Proof.context} ->
   12.39 -    tactic
   12.40 -end;
   12.41 -
   12.42 -structure BNF_Def_Tactics : BNF_DEF_TACTICS =
   12.43 -struct
   12.44 -
   12.45 -open BNF_Util
   12.46 -open BNF_Tactics
   12.47 -
   12.48 -val ord_eq_le_trans = @{thm ord_eq_le_trans};
   12.49 -val ord_le_eq_trans = @{thm ord_le_eq_trans};
   12.50 -val conversep_shift = @{thm conversep_le_swap} RS iffD1;
   12.51 -
   12.52 -fun mk_map_id id = mk_trans (fun_cong OF [id]) @{thm id_apply};
   12.53 -fun mk_map_comp comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
   12.54 -fun mk_map_cong_tac ctxt cong0 =
   12.55 -  (hyp_subst_tac ctxt THEN' rtac cong0 THEN'
   12.56 -   REPEAT_DETERM o (dtac meta_spec THEN' etac meta_mp THEN' atac)) 1;
   12.57 -fun mk_set_map set_map0 = set_map0 RS @{thm comp_eq_dest};
   12.58 -fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
   12.59 -  else (rtac subsetI THEN'
   12.60 -  rtac CollectI) 1 THEN
   12.61 -  REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
   12.62 -  REPEAT_DETERM_N (n - 1)
   12.63 -    ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
   12.64 -  (etac subset_trans THEN' atac) 1;
   12.65 -
   12.66 -fun mk_collect_set_map_tac set_map0s =
   12.67 -  (rtac (@{thm collect_o} RS trans) THEN' rtac @{thm arg_cong[of _ _ collect]} THEN'
   12.68 -  EVERY' (map (fn set_map0 =>
   12.69 -    rtac (mk_trans @{thm image_insert} @{thm arg_cong2[of _ _ _ _ insert]}) THEN'
   12.70 -    rtac set_map0) set_map0s) THEN'
   12.71 -  rtac @{thm image_empty}) 1;
   12.72 -
   12.73 -fun mk_rel_Grp_tac rel_OO_Grps map_id0 map_cong0 map_id map_comp set_maps
   12.74 -  {context = ctxt, prems = _} =
   12.75 -  let
   12.76 -    val n = length set_maps;
   12.77 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac (hd rel_OO_Grps RS trans);
   12.78 -  in
   12.79 -    if null set_maps then
   12.80 -      unfold_thms_tac ctxt ((map_id0 RS @{thm Grp_UNIV_id}) :: rel_OO_Grps) THEN
   12.81 -      rtac @{thm Grp_UNIV_idI[OF refl]} 1
   12.82 -    else
   12.83 -      EVERY' [rel_OO_Grps_tac, rtac @{thm antisym}, rtac @{thm predicate2I},
   12.84 -        REPEAT_DETERM o
   12.85 -          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
   12.86 -        hyp_subst_tac ctxt, rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0,
   12.87 -        REPEAT_DETERM_N n o EVERY' [rtac @{thm Collect_split_Grp_eqD}, etac @{thm set_mp}, atac],
   12.88 -        rtac CollectI,
   12.89 -        CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
   12.90 -          rtac @{thm image_subsetI}, rtac @{thm Collect_split_Grp_inD}, etac @{thm set_mp}, atac])
   12.91 -        set_maps,
   12.92 -        rtac @{thm predicate2I}, REPEAT_DETERM o eresolve_tac [@{thm GrpE}, exE, conjE],
   12.93 -        hyp_subst_tac ctxt,
   12.94 -        rtac @{thm relcomppI}, rtac @{thm conversepI},
   12.95 -        EVERY' (map2 (fn convol => fn map_id0 =>
   12.96 -          EVERY' [rtac @{thm GrpI}, rtac (box_equals OF [map_cong0, map_comp RS sym, map_id0]),
   12.97 -            REPEAT_DETERM_N n o rtac (convol RS fun_cong),
   12.98 -            REPEAT_DETERM o eresolve_tac [CollectE, conjE],
   12.99 -            rtac CollectI,
  12.100 -            CONJ_WRAP' (fn thm =>
  12.101 -              EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
  12.102 -                rtac @{thm convol_mem_GrpI}, etac set_mp, atac])
  12.103 -            set_maps])
  12.104 -          @{thms fst_convol snd_convol} [map_id, refl])] 1
  12.105 -  end;
  12.106 -
  12.107 -fun mk_rel_eq_tac n rel_Grp rel_cong map_id0 =
  12.108 -  (EVERY' (rtac (rel_cong RS trans) :: replicate n (rtac @{thm eq_alt})) THEN'
  12.109 -  rtac (rel_Grp RSN (2, @{thm box_equals[OF _ sym sym[OF eq_alt]]})) THEN'
  12.110 -  (if n = 0 then rtac refl
  12.111 -  else EVERY' [rtac @{thm arg_cong2[of _ _ _ _ "Grp"]},
  12.112 -    rtac @{thm equalityI}, rtac subset_UNIV, rtac subsetI, rtac CollectI,
  12.113 -    CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto n), rtac map_id0])) 1;
  12.114 -
  12.115 -fun mk_rel_mono_tac rel_OO_Grps in_mono =
  12.116 -  let
  12.117 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
  12.118 -      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
  12.119 -        rtac (hd rel_OO_Grps RS sym RSN (2, ord_le_eq_trans));
  12.120 -  in
  12.121 -    EVERY' [rel_OO_Grps_tac, rtac @{thm relcompp_mono}, rtac @{thm iffD2[OF conversep_mono]},
  12.122 -      rtac @{thm Grp_mono}, rtac in_mono, REPEAT_DETERM o etac @{thm Collect_split_mono},
  12.123 -      rtac @{thm Grp_mono}, rtac in_mono, REPEAT_DETERM o etac @{thm Collect_split_mono}] 1
  12.124 -  end;
  12.125 -
  12.126 -fun mk_rel_conversep_le_tac rel_OO_Grps rel_eq map_cong0 map_comp set_maps
  12.127 -  {context = ctxt, prems = _} =
  12.128 -  let
  12.129 -    val n = length set_maps;
  12.130 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
  12.131 -      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
  12.132 -        rtac (hd rel_OO_Grps RS sym RS @{thm arg_cong[of _ _ conversep]} RSN (2, ord_le_eq_trans));
  12.133 -  in
  12.134 -    if null set_maps then rtac (rel_eq RS @{thm leq_conversepI}) 1
  12.135 -    else
  12.136 -      EVERY' [rel_OO_Grps_tac, rtac @{thm predicate2I},
  12.137 -        REPEAT_DETERM o
  12.138 -          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
  12.139 -        hyp_subst_tac ctxt, rtac @{thm conversepI}, rtac @{thm relcomppI}, rtac @{thm conversepI},
  12.140 -        EVERY' (map (fn thm => EVERY' [rtac @{thm GrpI}, rtac sym, rtac trans,
  12.141 -          rtac map_cong0, REPEAT_DETERM_N n o rtac thm,
  12.142 -          rtac (map_comp RS sym), rtac CollectI,
  12.143 -          CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
  12.144 -            etac @{thm flip_pred}]) set_maps]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
  12.145 -  end;
  12.146 -
  12.147 -fun mk_rel_conversep_tac le_conversep rel_mono =
  12.148 -  EVERY' [rtac @{thm antisym}, rtac le_conversep, rtac @{thm xt1(6)}, rtac conversep_shift,
  12.149 -    rtac le_conversep, rtac @{thm iffD2[OF conversep_mono]}, rtac rel_mono,
  12.150 -    REPEAT_DETERM o rtac @{thm eq_refl[OF sym[OF conversep_conversep]]}] 1;
  12.151 -
  12.152 -fun mk_rel_OO_le_tac rel_OO_Grps rel_eq map_cong0 map_comp set_maps
  12.153 -  {context = ctxt, prems = _} =
  12.154 -  let
  12.155 -    val n = length set_maps;
  12.156 -    fun in_tac nthO_in = rtac CollectI THEN'
  12.157 -        CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
  12.158 -          rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_maps;
  12.159 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
  12.160 -      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
  12.161 -        rtac (@{thm arg_cong2[of _ _ _ _ "op OO"]} OF (replicate 2 (hd rel_OO_Grps RS sym)) RSN
  12.162 -          (2, ord_le_eq_trans));
  12.163 -  in
  12.164 -    if null set_maps then rtac (rel_eq RS @{thm leq_OOI}) 1
  12.165 -    else
  12.166 -      EVERY' [rel_OO_Grps_tac, rtac @{thm predicate2I},
  12.167 -        REPEAT_DETERM o
  12.168 -          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
  12.169 -        hyp_subst_tac ctxt,
  12.170 -        rtac @{thm relcomppI}, rtac @{thm relcomppI}, rtac @{thm conversepI}, rtac @{thm GrpI},
  12.171 -        rtac trans, rtac map_comp, rtac sym, rtac map_cong0,
  12.172 -        REPEAT_DETERM_N n o rtac @{thm fst_fstOp},
  12.173 -        in_tac @{thm fstOp_in},
  12.174 -        rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0,
  12.175 -        REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, 
  12.176 -          rtac ballE, rtac subst,
  12.177 -          rtac @{thm csquare_def}, rtac @{thm csquare_fstOp_sndOp}, atac, etac notE,
  12.178 -          etac set_mp, atac],
  12.179 -        in_tac @{thm fstOp_in},
  12.180 -        rtac @{thm relcomppI}, rtac @{thm conversepI}, rtac @{thm GrpI},
  12.181 -        rtac trans, rtac map_comp, rtac map_cong0,
  12.182 -        REPEAT_DETERM_N n o rtac o_apply,
  12.183 -        in_tac @{thm sndOp_in},
  12.184 -        rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac sym, rtac map_cong0,
  12.185 -        REPEAT_DETERM_N n o rtac @{thm snd_sndOp},
  12.186 -        in_tac @{thm sndOp_in}] 1
  12.187 -  end;
  12.188 -
  12.189 -fun mk_rel_mono_strong_tac in_rel set_maps {context = ctxt, prems = _} =
  12.190 -  if null set_maps then atac 1
  12.191 -  else
  12.192 -    unfold_tac ctxt [in_rel] THEN
  12.193 -    REPEAT_DETERM (eresolve_tac [exE, CollectE, conjE] 1) THEN
  12.194 -    hyp_subst_tac ctxt 1 THEN
  12.195 -    unfold_tac ctxt set_maps THEN
  12.196 -    EVERY' [rtac exI, rtac @{thm conjI[OF CollectI conjI[OF refl refl]]},
  12.197 -      CONJ_WRAP' (K (etac @{thm Collect_split_mono_strong} THEN' atac)) set_maps] 1;
  12.198 -
  12.199 -fun mk_map_transfer_tac rel_mono in_rel set_maps map_cong0 map_comp
  12.200 -  {context = ctxt, prems = _} =
  12.201 -  let
  12.202 -    val n = length set_maps;
  12.203 -    val in_tac = if n = 0 then rtac UNIV_I else
  12.204 -      rtac CollectI THEN' CONJ_WRAP' (fn thm =>
  12.205 -        etac (thm RS
  12.206 -          @{thm ord_eq_le_trans[OF _ subset_trans[OF image_mono convol_image_vimage2p]]}))
  12.207 -      set_maps;
  12.208 -  in
  12.209 -    REPEAT_DETERM_N n (HEADGOAL (rtac @{thm fun_relI})) THEN
  12.210 -    unfold_thms_tac ctxt @{thms fun_rel_iff_leq_vimage2p} THEN
  12.211 -    HEADGOAL (EVERY' [rtac @{thm order_trans}, rtac rel_mono, REPEAT_DETERM_N n o atac,
  12.212 -      rtac @{thm predicate2I}, dtac (in_rel RS iffD1),
  12.213 -      REPEAT_DETERM o eresolve_tac [exE, CollectE, conjE], hyp_subst_tac ctxt,
  12.214 -      rtac @{thm vimage2pI}, rtac (in_rel RS iffD2), rtac exI, rtac conjI, in_tac,
  12.215 -      rtac conjI,
  12.216 -      EVERY' (map (fn convol =>
  12.217 -        rtac (box_equals OF [map_cong0, map_comp RS sym, map_comp RS sym]) THEN'
  12.218 -        REPEAT_DETERM_N n o rtac (convol RS fun_cong)) @{thms fst_convol snd_convol})])
  12.219 -  end;
  12.220 -
  12.221 -fun mk_in_bd_tac live surj_imp_ordLeq_inst map_comp map_id map_cong0 set_maps set_bds
  12.222 -  bd_card_order bd_Card_order bd_Cinfinite bd_Cnotzero {context = ctxt, prems = _} =
  12.223 -  if live = 0 then
  12.224 -    rtac @{thm ordLeq_transitive[OF ordLeq_csum2[OF card_of_Card_order]
  12.225 -      ordLeq_cexp2[OF ordLeq_refl[OF Card_order_ctwo] Card_order_csum]]} 1
  12.226 -  else
  12.227 -    let
  12.228 -      val bd'_Cinfinite = bd_Cinfinite RS @{thm Cinfinite_csum1};
  12.229 -      val inserts =
  12.230 -        map (fn set_bd => 
  12.231 -          iffD2 OF [@{thm card_of_ordLeq}, @{thm ordLeq_ordIso_trans} OF
  12.232 -            [set_bd, bd_Card_order RS @{thm card_of_Field_ordIso} RS @{thm ordIso_symmetric}]])
  12.233 -        set_bds;        
  12.234 -    in
  12.235 -      EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac @{thm cprod_cinfinite_bound},
  12.236 -        rtac (ctrans OF @{thms ordLeq_csum2 ordLeq_cexp2}), rtac @{thm card_of_Card_order},
  12.237 -        rtac @{thm ordLeq_csum2}, rtac @{thm Card_order_ctwo}, rtac @{thm Card_order_csum},
  12.238 -        rtac @{thm ordIso_ordLeq_trans}, rtac @{thm cexp_cong1},
  12.239 -        if live = 1 then rtac @{thm ordIso_refl[OF Card_order_csum]}
  12.240 -        else
  12.241 -          REPEAT_DETERM_N (live - 2) o rtac @{thm ordIso_transitive[OF csum_cong2]} THEN'
  12.242 -          REPEAT_DETERM_N (live - 1) o rtac @{thm csum_csum},
  12.243 -        rtac bd_Card_order, rtac (@{thm cexp_mono2_Cnotzero} RS ctrans), rtac @{thm ordLeq_csum1},
  12.244 -        rtac bd_Card_order, rtac @{thm Card_order_csum}, rtac bd_Cnotzero,
  12.245 -        rtac @{thm csum_Cfinite_cexp_Cinfinite},
  12.246 -        rtac (if live = 1 then @{thm card_of_Card_order} else @{thm Card_order_csum}),
  12.247 -        CONJ_WRAP_GEN' (rtac @{thm Cfinite_csum}) (K (rtac @{thm Cfinite_cone})) set_maps,
  12.248 -        rtac bd'_Cinfinite, rtac @{thm card_of_Card_order},
  12.249 -        rtac @{thm Card_order_cexp}, rtac @{thm Cinfinite_cexp}, rtac @{thm ordLeq_csum2},
  12.250 -        rtac @{thm Card_order_ctwo}, rtac bd'_Cinfinite,
  12.251 -        rtac (Drule.rotate_prems 1 (@{thm cprod_mono2} RSN (2, ctrans))),
  12.252 -        REPEAT_DETERM_N (live - 1) o
  12.253 -          (rtac (bd_Cinfinite RS @{thm cprod_cexp_csum_cexp_Cinfinite} RSN (2, ctrans)) THEN'
  12.254 -           rtac @{thm ordLeq_ordIso_trans[OF cprod_mono2 ordIso_symmetric[OF cprod_cexp]]}),
  12.255 -        rtac @{thm ordLeq_refl[OF Card_order_cexp]}] 1 THEN
  12.256 -      unfold_thms_tac ctxt [bd_card_order RS @{thm card_order_csum_cone_cexp_def}] THEN
  12.257 -      unfold_thms_tac ctxt @{thms cprod_def Field_card_of} THEN
  12.258 -      EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac surj_imp_ordLeq_inst, rtac subsetI,
  12.259 -        Method.insert_tac inserts, REPEAT_DETERM o dtac meta_spec,
  12.260 -        REPEAT_DETERM o eresolve_tac [exE, Tactic.make_elim conjunct1], etac CollectE,
  12.261 -        if live = 1 then K all_tac
  12.262 -        else REPEAT_DETERM_N (live - 2) o (etac conjE THEN' rotate_tac ~1) THEN' etac conjE,
  12.263 -        rtac (Drule.rotate_prems 1 @{thm image_eqI}), rtac @{thm SigmaI}, rtac @{thm UNIV_I},
  12.264 -        CONJ_WRAP_GEN' (rtac @{thm SigmaI})
  12.265 -          (K (etac @{thm If_the_inv_into_in_Func} THEN' atac)) set_maps,
  12.266 -        rtac sym,
  12.267 -        rtac (Drule.rotate_prems 1
  12.268 -           ((box_equals OF [map_cong0 OF replicate live @{thm If_the_inv_into_f_f},
  12.269 -             map_comp RS sym, map_id]) RSN (2, trans))),
  12.270 -        REPEAT_DETERM_N (2 * live) o atac,
  12.271 -        REPEAT_DETERM_N live o rtac (@{thm prod.cases} RS trans),
  12.272 -        rtac refl,
  12.273 -        rtac @{thm surj_imp_ordLeq}, rtac subsetI, rtac (Drule.rotate_prems 1 @{thm image_eqI}),
  12.274 -        REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
  12.275 -        CONJ_WRAP' (fn thm =>
  12.276 -          rtac (thm RS ord_eq_le_trans) THEN' etac @{thm subset_trans[OF image_mono Un_upper1]})
  12.277 -        set_maps,
  12.278 -        rtac sym,
  12.279 -        rtac (box_equals OF [map_cong0 OF replicate live @{thm fun_cong[OF sum_case_o_inj(1)]},
  12.280 -           map_comp RS sym, map_id])] 1
  12.281 -  end;
  12.282 -
  12.283 -fun mk_trivial_wit_tac wit_defs set_maps {context = ctxt, prems = _} =
  12.284 -  unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm =>
  12.285 -    dtac (thm RS equalityD1 RS set_mp) THEN' etac imageE THEN' atac) set_maps)) THEN ALLGOALS atac;
  12.286 -
  12.287 -end;
    13.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Mon Jan 20 18:24:55 2014 +0100
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,1523 +0,0 @@
    13.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_def_sugar.ML
    13.5 -    Author:     Jasmin Blanchette, TU Muenchen
    13.6 -    Copyright   2012, 2013
    13.7 -
    13.8 -Sugared datatype and codatatype constructions.
    13.9 -*)
   13.10 -
   13.11 -signature BNF_FP_DEF_SUGAR =
   13.12 -sig
   13.13 -  type fp_sugar =
   13.14 -    {T: typ,
   13.15 -     fp: BNF_FP_Util.fp_kind,
   13.16 -     index: int,
   13.17 -     pre_bnfs: BNF_Def.bnf list,
   13.18 -     nested_bnfs: BNF_Def.bnf list,
   13.19 -     nesting_bnfs: BNF_Def.bnf list,
   13.20 -     fp_res: BNF_FP_Util.fp_result,
   13.21 -     ctr_defss: thm list list,
   13.22 -     ctr_sugars: Ctr_Sugar.ctr_sugar list,
   13.23 -     co_iterss: term list list,
   13.24 -     mapss: thm list list,
   13.25 -     co_inducts: thm list,
   13.26 -     co_iter_thmsss: thm list list list,
   13.27 -     disc_co_itersss: thm list list list,
   13.28 -     sel_co_iterssss: thm list list list list};
   13.29 -
   13.30 -  val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
   13.31 -  val eq_fp_sugar: fp_sugar * fp_sugar -> bool
   13.32 -  val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar
   13.33 -  val transfer_fp_sugar: Proof.context -> fp_sugar -> fp_sugar
   13.34 -  val fp_sugar_of: Proof.context -> string -> fp_sugar option
   13.35 -  val fp_sugars_of: Proof.context -> fp_sugar list
   13.36 -
   13.37 -  val co_induct_of: 'a list -> 'a
   13.38 -  val strong_co_induct_of: 'a list -> 'a
   13.39 -
   13.40 -  val tvar_subst: theory -> typ list -> typ list -> ((string * int) * typ) list
   13.41 -  val exists_subtype_in: typ list -> typ -> bool
   13.42 -  val flat_rec_arg_args: 'a list list -> 'a list
   13.43 -  val flat_corec_preds_predsss_gettersss: 'a list -> 'a list list list -> 'a list list list ->
   13.44 -    'a list
   13.45 -  val mk_co_iter: theory -> BNF_FP_Util.fp_kind -> typ -> typ list -> term -> term
   13.46 -  val nesty_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list
   13.47 -
   13.48 -  type lfp_sugar_thms =
   13.49 -    (thm list * thm * Args.src list)
   13.50 -    * (thm list list * thm list list * Args.src list)
   13.51 -
   13.52 -  val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms
   13.53 -  val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms
   13.54 -
   13.55 -  type gfp_sugar_thms =
   13.56 -    ((thm list * thm) list * Args.src list)
   13.57 -    * (thm list list * thm list list * Args.src list)
   13.58 -    * (thm list list * thm list list * Args.src list)
   13.59 -    * (thm list list * thm list list * Args.src list)
   13.60 -    * (thm list list list * thm list list list * Args.src list)
   13.61 -
   13.62 -  val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms
   13.63 -  val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms
   13.64 -
   13.65 -  val mk_co_iters_prelims: BNF_FP_Util.fp_kind -> typ list list list -> typ list -> typ list ->
   13.66 -    int list -> int list list -> term list list -> Proof.context ->
   13.67 -    (term list list
   13.68 -     * (typ list list * typ list list list list * term list list
   13.69 -        * term list list list list) list option
   13.70 -     * (string * term list * term list list
   13.71 -        * ((term list list * term list list list) * (typ list * typ list list)) list) option)
   13.72 -    * Proof.context
   13.73 -  val mk_iter_fun_arg_types: typ list list list -> int list -> int list list -> term ->
   13.74 -    typ list list list list
   13.75 -  val mk_coiter_fun_arg_types: typ list list list -> typ list -> int list -> term ->
   13.76 -    typ list list
   13.77 -    * (typ list list list list * typ list list list * typ list list list list * typ list)
   13.78 -  val define_iters: string list ->
   13.79 -    (typ list list * typ list list list list * term list list * term list list list list) list ->
   13.80 -    (string -> binding) -> typ list -> typ list -> term list -> Proof.context ->
   13.81 -    (term list * thm list) * Proof.context
   13.82 -  val define_coiters: string list -> string * term list * term list list
   13.83 -    * ((term list list * term list list list) * (typ list * typ list list)) list ->
   13.84 -    (string -> binding) -> typ list -> typ list -> term list -> Proof.context ->
   13.85 -    (term list * thm list) * Proof.context
   13.86 -  val derive_induct_iters_thms_for_types: BNF_Def.bnf list ->
   13.87 -    (typ list list * typ list list list list * term list list * term list list list list) list ->
   13.88 -    thm -> thm list list -> BNF_Def.bnf list -> BNF_Def.bnf list -> typ list -> typ list ->
   13.89 -    typ list -> typ list list list -> term list list -> thm list list -> term list list ->
   13.90 -    thm list list -> local_theory -> lfp_sugar_thms
   13.91 -  val derive_coinduct_coiters_thms_for_types: BNF_Def.bnf list ->
   13.92 -    string * term list * term list list * ((term list list * term list list list)
   13.93 -      * (typ list * typ list list)) list ->
   13.94 -    thm -> thm list -> thm list -> thm list list -> BNF_Def.bnf list -> typ list -> typ list ->
   13.95 -    typ list -> typ list list list -> int list list -> int list list -> int list -> thm list list ->
   13.96 -    Ctr_Sugar.ctr_sugar list -> term list list -> thm list list -> (thm list -> thm list) ->
   13.97 -    local_theory -> gfp_sugar_thms
   13.98 -  val co_datatypes: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
   13.99 -      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
  13.100 -      BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
  13.101 -    (bool * (bool * bool)) * (((((binding * (typ * sort)) list * binding) * (binding * binding))
  13.102 -      * mixfix) * ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
  13.103 -        mixfix) list) list ->
  13.104 -    local_theory -> local_theory
  13.105 -  val parse_co_datatype_cmd: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
  13.106 -      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
  13.107 -      BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
  13.108 -    (local_theory -> local_theory) parser
  13.109 -end;
  13.110 -
  13.111 -structure BNF_FP_Def_Sugar : BNF_FP_DEF_SUGAR =
  13.112 -struct
  13.113 -
  13.114 -open Ctr_Sugar
  13.115 -open BNF_Util
  13.116 -open BNF_Comp
  13.117 -open BNF_Def
  13.118 -open BNF_FP_Util
  13.119 -open BNF_FP_Def_Sugar_Tactics
  13.120 -
  13.121 -val EqN = "Eq_";
  13.122 -
  13.123 -type fp_sugar =
  13.124 -  {T: typ,
  13.125 -   fp: fp_kind,
  13.126 -   index: int,
  13.127 -   pre_bnfs: bnf list,
  13.128 -   nested_bnfs: bnf list,
  13.129 -   nesting_bnfs: bnf list,
  13.130 -   fp_res: fp_result,
  13.131 -   ctr_defss: thm list list,
  13.132 -   ctr_sugars: ctr_sugar list,
  13.133 -   co_iterss: term list list,
  13.134 -   mapss: thm list list,
  13.135 -   co_inducts: thm list,
  13.136 -   co_iter_thmsss: thm list list list,
  13.137 -   disc_co_itersss: thm list list list,
  13.138 -   sel_co_iterssss: thm list list list list};
  13.139 -
  13.140 -fun of_fp_sugar f (fp_sugar as ({index, ...}: fp_sugar)) = nth (f fp_sugar) index;
  13.141 -
  13.142 -fun eq_fp_sugar ({T = T1, fp = fp1, index = index1, fp_res = fp_res1, ...} : fp_sugar,
  13.143 -    {T = T2, fp = fp2, index = index2, fp_res = fp_res2, ...} : fp_sugar) =
  13.144 -  T1 = T2 andalso fp1 = fp2 andalso index1 = index2 andalso eq_fp_result (fp_res1, fp_res2);
  13.145 -
  13.146 -fun morph_fp_sugar phi ({T, fp, index, pre_bnfs, nested_bnfs, nesting_bnfs, fp_res, ctr_defss,
  13.147 -    ctr_sugars, co_iterss, mapss, co_inducts, co_iter_thmsss, disc_co_itersss, sel_co_iterssss}
  13.148 -    : fp_sugar) =
  13.149 -  {T = Morphism.typ phi T, fp = fp, index = index, pre_bnfs = map (morph_bnf phi) pre_bnfs,
  13.150 -    nested_bnfs = map (morph_bnf phi) nested_bnfs, nesting_bnfs = map (morph_bnf phi) nesting_bnfs,
  13.151 -   fp_res = morph_fp_result phi fp_res,
  13.152 -   ctr_defss = map (map (Morphism.thm phi)) ctr_defss,
  13.153 -   ctr_sugars = map (morph_ctr_sugar phi) ctr_sugars,
  13.154 -   co_iterss = map (map (Morphism.term phi)) co_iterss,
  13.155 -   mapss = map (map (Morphism.thm phi)) mapss,
  13.156 -   co_inducts = map (Morphism.thm phi) co_inducts,
  13.157 -   co_iter_thmsss = map (map (map (Morphism.thm phi))) co_iter_thmsss,
  13.158 -   disc_co_itersss = map (map (map (Morphism.thm phi))) disc_co_itersss,
  13.159 -   sel_co_iterssss = map (map (map (map (Morphism.thm phi)))) sel_co_iterssss};
  13.160 -
  13.161 -val transfer_fp_sugar =
  13.162 -  morph_fp_sugar o Morphism.transfer_morphism o Proof_Context.theory_of;
  13.163 -
  13.164 -structure Data = Generic_Data
  13.165 -(
  13.166 -  type T = fp_sugar Symtab.table;
  13.167 -  val empty = Symtab.empty;
  13.168 -  val extend = I;
  13.169 -  val merge = Symtab.merge eq_fp_sugar;
  13.170 -);
  13.171 -
  13.172 -fun fp_sugar_of ctxt =
  13.173 -  Symtab.lookup (Data.get (Context.Proof ctxt))
  13.174 -  #> Option.map (transfer_fp_sugar ctxt);
  13.175 -
  13.176 -fun fp_sugars_of ctxt =
  13.177 -  Symtab.fold (cons o transfer_fp_sugar ctxt o snd) (Data.get (Context.Proof ctxt)) [];
  13.178 -
  13.179 -fun co_induct_of (i :: _) = i;
  13.180 -fun strong_co_induct_of [_, s] = s;
  13.181 -
  13.182 -(* TODO: register "sum" and "prod" as datatypes to enable N2M reduction for them *)
  13.183 -
  13.184 -fun register_fp_sugar key fp_sugar =
  13.185 -  Local_Theory.declaration {syntax = false, pervasive = true}
  13.186 -    (fn phi => Data.map (Symtab.default (key, morph_fp_sugar phi fp_sugar)));
  13.187 -
  13.188 -fun register_fp_sugars fp pre_bnfs nested_bnfs nesting_bnfs (fp_res as {Ts, ...}) ctr_defss
  13.189 -    ctr_sugars co_iterss mapss co_inducts co_iter_thmsss disc_co_itersss sel_co_iterssss lthy =
  13.190 -  (0, lthy)
  13.191 -  |> fold (fn T as Type (s, _) => fn (kk, lthy) => (kk + 1,
  13.192 -    register_fp_sugar s {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs,
  13.193 -        nested_bnfs = nested_bnfs, nesting_bnfs = nesting_bnfs, fp_res = fp_res,
  13.194 -        ctr_defss = ctr_defss, ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss,
  13.195 -        co_inducts = co_inducts, co_iter_thmsss = co_iter_thmsss, disc_co_itersss = disc_co_itersss,
  13.196 -        sel_co_iterssss = sel_co_iterssss}
  13.197 -      lthy)) Ts
  13.198 -  |> snd;
  13.199 -
  13.200 -(* This function could produce clashes in contrived examples (e.g., "x.A", "x.x_A", "y.A"). *)
  13.201 -fun quasi_unambiguous_case_names names =
  13.202 -  let
  13.203 -    val ps = map (`Long_Name.base_name) names;
  13.204 -    val dups = Library.duplicates (op =) (map fst ps);
  13.205 -    fun underscore s =
  13.206 -      let val ss = space_explode Long_Name.separator s in
  13.207 -        space_implode "_" (drop (length ss - 2) ss)
  13.208 -      end;
  13.209 -  in
  13.210 -    map (fn (base, full) => if member (op =) dups base then underscore full else base) ps
  13.211 -  end;
  13.212 -
  13.213 -val id_def = @{thm id_def};
  13.214 -val mp_conj = @{thm mp_conj};
  13.215 -
  13.216 -val nitpicksimp_attrs = @{attributes [nitpick_simp]};
  13.217 -val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
  13.218 -val simp_attrs = @{attributes [simp]};
  13.219 -
  13.220 -fun tvar_subst thy Ts Us =
  13.221 -  Vartab.fold (cons o apsnd snd) (fold (Sign.typ_match thy) (Ts ~~ Us) Vartab.empty) [];
  13.222 -
  13.223 -val exists_subtype_in = Term.exists_subtype o member (op =);
  13.224 -
  13.225 -val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs));
  13.226 -
  13.227 -fun flat_rec_arg_args xss =
  13.228 -  (* FIXME (once the old datatype package is phased out): The first line below gives the preferred
  13.229 -     order. The second line is for compatibility with the old datatype package. *)
  13.230 -(*
  13.231 -  flat xss
  13.232 -*)
  13.233 -  map hd xss @ maps tl xss;
  13.234 -
  13.235 -fun flat_corec_predss_getterss qss fss = maps (op @) (qss ~~ fss);
  13.236 -
  13.237 -fun flat_corec_preds_predsss_gettersss [] [qss] [fss] = flat_corec_predss_getterss qss fss
  13.238 -  | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
  13.239 -    p :: flat_corec_predss_getterss qss fss @ flat_corec_preds_predsss_gettersss ps qsss fsss;
  13.240 -
  13.241 -fun mk_tupled_fun x f xs =
  13.242 -  if xs = [x] then f else HOLogic.tupled_lambda x (Term.list_comb (f, xs));
  13.243 -
  13.244 -fun mk_uncurried2_fun f xss =
  13.245 -  mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat_rec_arg_args xss);
  13.246 -
  13.247 -fun mk_flip (x, Type (_, [T1, Type (_, [T2, T3])])) =
  13.248 -  Abs ("x", T1, Abs ("y", T2, Var (x, T2 --> T1 --> T3) $ Bound 0 $ Bound 1));
  13.249 -
  13.250 -fun flip_rels lthy n thm =
  13.251 -  let
  13.252 -    val Rs = Term.add_vars (prop_of thm) [];
  13.253 -    val Rs' = rev (drop (length Rs - n) Rs);
  13.254 -    val cRs = map (fn f => (certify lthy (Var f), certify lthy (mk_flip f))) Rs';
  13.255 -  in
  13.256 -    Drule.cterm_instantiate cRs thm
  13.257 -  end;
  13.258 -
  13.259 -fun mk_ctor_or_dtor get_T Ts t =
  13.260 -  let val Type (_, Ts0) = get_T (fastype_of t) in
  13.261 -    Term.subst_atomic_types (Ts0 ~~ Ts) t
  13.262 -  end;
  13.263 -
  13.264 -val mk_ctor = mk_ctor_or_dtor range_type;
  13.265 -val mk_dtor = mk_ctor_or_dtor domain_type;
  13.266 -
  13.267 -fun mk_co_iter thy fp fpT Cs t =
  13.268 -  let
  13.269 -    val (f_Cs, Type (_, [prebody, body])) = strip_fun_type (fastype_of t);
  13.270 -    val fpT0 = fp_case fp prebody body;
  13.271 -    val Cs0 = distinct (op =) (map (fp_case fp body_type domain_type) f_Cs);
  13.272 -    val rho = tvar_subst thy (fpT0 :: Cs0) (fpT :: Cs);
  13.273 -  in
  13.274 -    Term.subst_TVars rho t
  13.275 -  end;
  13.276 -
  13.277 -fun mk_co_iters thy fp fpTs Cs ts0 =
  13.278 -  let
  13.279 -    val nn = length fpTs;
  13.280 -    val (fpTs0, Cs0) =
  13.281 -      map ((fp = Greatest_FP ? swap) o dest_funT o snd o strip_typeN nn o fastype_of) ts0
  13.282 -      |> split_list;
  13.283 -    val rho = tvar_subst thy (fpTs0 @ Cs0) (fpTs @ Cs);
  13.284 -  in
  13.285 -    map (Term.subst_TVars rho) ts0
  13.286 -  end;
  13.287 -
  13.288 -val mk_fp_iter_fun_types = binder_fun_types o fastype_of;
  13.289 -
  13.290 -fun unzip_recT (Type (@{type_name prod}, _)) T = [T]
  13.291 -  | unzip_recT _ (Type (@{type_name prod}, Ts)) = Ts
  13.292 -  | unzip_recT _ T = [T];
  13.293 -
  13.294 -fun unzip_corecT (Type (@{type_name sum}, _)) T = [T]
  13.295 -  | unzip_corecT _ (Type (@{type_name sum}, Ts)) = Ts
  13.296 -  | unzip_corecT _ T = [T];
  13.297 -
  13.298 -fun liveness_of_fp_bnf n bnf =
  13.299 -  (case T_of_bnf bnf of
  13.300 -    Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts
  13.301 -  | _ => replicate n false);
  13.302 -
  13.303 -fun cannot_merge_types () = error "Mutually recursive types must have the same type parameters";
  13.304 -
  13.305 -fun merge_type_arg T T' = if T = T' then T else cannot_merge_types ();
  13.306 -
  13.307 -fun merge_type_args (As, As') =
  13.308 -  if length As = length As' then map2 merge_type_arg As As' else cannot_merge_types ();
  13.309 -
  13.310 -fun reassoc_conjs thm =
  13.311 -  reassoc_conjs (thm RS @{thm conj_assoc[THEN iffD1]})
  13.312 -  handle THM _ => thm;
  13.313 -
  13.314 -fun type_args_named_constrained_of ((((ncAs, _), _), _), _) = ncAs;
  13.315 -fun type_binding_of ((((_, b), _), _), _) = b;
  13.316 -fun map_binding_of (((_, (b, _)), _), _) = b;
  13.317 -fun rel_binding_of (((_, (_, b)), _), _) = b;
  13.318 -fun mixfix_of ((_, mx), _) = mx;
  13.319 -fun ctr_specs_of (_, ctr_specs) = ctr_specs;
  13.320 -
  13.321 -fun disc_of ((((disc, _), _), _), _) = disc;
  13.322 -fun ctr_of ((((_, ctr), _), _), _) = ctr;
  13.323 -fun args_of (((_, args), _), _) = args;
  13.324 -fun defaults_of ((_, ds), _) = ds;
  13.325 -fun ctr_mixfix_of (_, mx) = mx;
  13.326 -
  13.327 -fun add_nesty_bnf_names Us =
  13.328 -  let
  13.329 -    fun add (Type (s, Ts)) ss =
  13.330 -        let val (needs, ss') = fold_map add Ts ss in
  13.331 -          if exists I needs then (true, insert (op =) s ss') else (false, ss')
  13.332 -        end
  13.333 -      | add T ss = (member (op =) Us T, ss);
  13.334 -  in snd oo add end;
  13.335 -
  13.336 -fun nesty_bnfs ctxt ctr_Tsss Us =
  13.337 -  map_filter (bnf_of ctxt) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_Tsss []);
  13.338 -
  13.339 -fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p;
  13.340 -
  13.341 -type lfp_sugar_thms =
  13.342 -  (thm list * thm * Args.src list)
  13.343 -  * (thm list list * thm list list * Args.src list)
  13.344 -
  13.345 -fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (foldss, recss, iter_attrs)) =
  13.346 -  ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs),
  13.347 -   (map (map (Morphism.thm phi)) foldss, map (map (Morphism.thm phi)) recss, iter_attrs));
  13.348 -
  13.349 -val transfer_lfp_sugar_thms =
  13.350 -  morph_lfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of;
  13.351 -
  13.352 -type gfp_sugar_thms =
  13.353 -  ((thm list * thm) list * Args.src list)
  13.354 -  * (thm list list * thm list list * Args.src list)
  13.355 -  * (thm list list * thm list list * Args.src list)
  13.356 -  * (thm list list * thm list list * Args.src list)
  13.357 -  * (thm list list list * thm list list list * Args.src list);
  13.358 -
  13.359 -fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs),
  13.360 -    (unfoldss, corecss, coiter_attrs), (disc_unfoldss, disc_corecss, disc_iter_attrs),
  13.361 -    (disc_unfold_iffss, disc_corec_iffss, disc_iter_iff_attrs),
  13.362 -    (sel_unfoldsss, sel_corecsss, sel_iter_attrs)) =
  13.363 -  ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs,
  13.364 -    coinduct_attrs),
  13.365 -   (map (map (Morphism.thm phi)) unfoldss, map (map (Morphism.thm phi)) corecss, coiter_attrs),
  13.366 -   (map (map (Morphism.thm phi)) disc_unfoldss, map (map (Morphism.thm phi)) disc_corecss,
  13.367 -    disc_iter_attrs),
  13.368 -   (map (map (Morphism.thm phi)) disc_unfold_iffss, map (map (Morphism.thm phi)) disc_corec_iffss,
  13.369 -    disc_iter_iff_attrs),
  13.370 -   (map (map (map (Morphism.thm phi))) sel_unfoldsss,
  13.371 -    map (map (map (Morphism.thm phi))) sel_corecsss, sel_iter_attrs));
  13.372 -
  13.373 -val transfer_gfp_sugar_thms =
  13.374 -  morph_gfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of;
  13.375 -
  13.376 -fun mk_iter_fun_arg_types0 n ms = map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type;
  13.377 -
  13.378 -fun mk_iter_fun_arg_types ctr_Tsss ns mss =
  13.379 -  mk_fp_iter_fun_types
  13.380 -  #> map3 mk_iter_fun_arg_types0 ns mss
  13.381 -  #> map2 (map2 (map2 unzip_recT)) ctr_Tsss;
  13.382 -
  13.383 -fun mk_iters_args_types ctr_Tsss Cs ns mss ctor_iter_fun_Tss lthy =
  13.384 -  let
  13.385 -    val Css = map2 replicate ns Cs;
  13.386 -    val y_Tsss = map3 mk_iter_fun_arg_types0 ns mss (map un_fold_of ctor_iter_fun_Tss);
  13.387 -    val g_Tss = map2 (fn C => map (fn y_Ts => y_Ts ---> C)) Cs y_Tsss;
  13.388 -
  13.389 -    val ((gss, ysss), lthy) =
  13.390 -      lthy
  13.391 -      |> mk_Freess "f" g_Tss
  13.392 -      ||>> mk_Freesss "x" y_Tsss;
  13.393 -
  13.394 -    val y_Tssss = map (map (map single)) y_Tsss;
  13.395 -    val yssss = map (map (map single)) ysss;
  13.396 -
  13.397 -    val z_Tssss =
  13.398 -      map4 (fn n => fn ms => fn ctr_Tss => fn ctor_iter_fun_Ts =>
  13.399 -          map3 (fn m => fn ctr_Ts => fn ctor_iter_fun_T =>
  13.400 -              map2 unzip_recT ctr_Ts (dest_tupleT m ctor_iter_fun_T))
  13.401 -            ms ctr_Tss (dest_sumTN_balanced n (domain_type (co_rec_of ctor_iter_fun_Ts))))
  13.402 -        ns mss ctr_Tsss ctor_iter_fun_Tss;
  13.403 -
  13.404 -    val z_Tsss' = map (map flat_rec_arg_args) z_Tssss;
  13.405 -    val h_Tss = map2 (map2 (curry (op --->))) z_Tsss' Css;
  13.406 -
  13.407 -    val hss = map2 (map2 retype_free) h_Tss gss;
  13.408 -    val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
  13.409 -    val (zssss_tl, lthy) =
  13.410 -      lthy
  13.411 -      |> mk_Freessss "y" (map (map (map tl)) z_Tssss);
  13.412 -    val zssss = map2 (map2 (map2 cons)) zssss_hd zssss_tl;
  13.413 -  in
  13.414 -    ([(g_Tss, y_Tssss, gss, yssss), (h_Tss, z_Tssss, hss, zssss)], lthy)
  13.415 -  end;
  13.416 -
  13.417 -fun mk_coiter_fun_arg_types0 ctr_Tsss Cs ns fun_Ts =
  13.418 -  let
  13.419 -    (*avoid "'a itself" arguments in coiterators*)
  13.420 -    fun repair_arity [[]] = [[@{typ unit}]]
  13.421 -      | repair_arity Tss = Tss;
  13.422 -
  13.423 -    val ctr_Tsss' = map repair_arity ctr_Tsss;
  13.424 -    val f_sum_prod_Ts = map range_type fun_Ts;
  13.425 -    val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
  13.426 -    val f_Tsss = map2 (map2 (dest_tupleT o length)) ctr_Tsss' f_prod_Tss;
  13.427 -    val f_Tssss = map3 (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT)))
  13.428 -      Cs ctr_Tsss' f_Tsss;
  13.429 -    val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) f_Tssss;
  13.430 -  in
  13.431 -    (q_Tssss, f_Tsss, f_Tssss, f_sum_prod_Ts)
  13.432 -  end;
  13.433 -
  13.434 -fun mk_coiter_p_pred_types Cs ns = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs;
  13.435 -
  13.436 -fun mk_coiter_fun_arg_types ctr_Tsss Cs ns dtor_coiter =
  13.437 -  (mk_coiter_p_pred_types Cs ns,
  13.438 -   mk_fp_iter_fun_types dtor_coiter |> mk_coiter_fun_arg_types0 ctr_Tsss Cs ns);
  13.439 -
  13.440 -fun mk_coiters_args_types ctr_Tsss Cs ns dtor_coiter_fun_Tss lthy =
  13.441 -  let
  13.442 -    val p_Tss = mk_coiter_p_pred_types Cs ns;
  13.443 -
  13.444 -    fun mk_types get_Ts =
  13.445 -      let
  13.446 -        val fun_Ts = map get_Ts dtor_coiter_fun_Tss;
  13.447 -        val (q_Tssss, f_Tsss, f_Tssss, f_sum_prod_Ts) = mk_coiter_fun_arg_types0 ctr_Tsss Cs ns fun_Ts;
  13.448 -        val pf_Tss = map3 flat_corec_preds_predsss_gettersss p_Tss q_Tssss f_Tssss;
  13.449 -      in
  13.450 -        (q_Tssss, f_Tsss, f_Tssss, (f_sum_prod_Ts, pf_Tss))
  13.451 -      end;
  13.452 -
  13.453 -    val (r_Tssss, g_Tsss, g_Tssss, unfold_types) = mk_types un_fold_of;
  13.454 -    val (s_Tssss, h_Tsss, h_Tssss, corec_types) = mk_types co_rec_of;
  13.455 -
  13.456 -    val ((((Free (z, _), cs), pss), gssss), lthy) =
  13.457 -      lthy
  13.458 -      |> yield_singleton (mk_Frees "z") dummyT
  13.459 -      ||>> mk_Frees "a" Cs
  13.460 -      ||>> mk_Freess "p" p_Tss
  13.461 -      ||>> mk_Freessss "g" g_Tssss;
  13.462 -    val rssss = map (map (map (fn [] => []))) r_Tssss;
  13.463 -
  13.464 -    val hssss_hd = map2 (map2 (map2 (fn T :: _ => fn [g] => retype_free T g))) h_Tssss gssss;
  13.465 -    val ((sssss, hssss_tl), lthy) =
  13.466 -      lthy
  13.467 -      |> mk_Freessss "q" s_Tssss
  13.468 -      ||>> mk_Freessss "h" (map (map (map tl)) h_Tssss);
  13.469 -    val hssss = map2 (map2 (map2 cons)) hssss_hd hssss_tl;
  13.470 -
  13.471 -    val cpss = map2 (map o rapp) cs pss;
  13.472 -
  13.473 -    fun build_sum_inj mk_inj = build_map lthy (uncurry mk_inj o dest_sumT o snd);
  13.474 -
  13.475 -    fun build_dtor_coiter_arg _ [] [cf] = cf
  13.476 -      | build_dtor_coiter_arg T [cq] [cf, cf'] =
  13.477 -        mk_If cq (build_sum_inj Inl_const (fastype_of cf, T) $ cf)
  13.478 -          (build_sum_inj Inr_const (fastype_of cf', T) $ cf');
  13.479 -
  13.480 -    fun mk_args qssss fssss f_Tsss =
  13.481 -      let
  13.482 -        val pfss = map3 flat_corec_preds_predsss_gettersss pss qssss fssss;
  13.483 -        val cqssss = map2 (map o map o map o rapp) cs qssss;
  13.484 -        val cfssss = map2 (map o map o map o rapp) cs fssss;
  13.485 -        val cqfsss = map3 (map3 (map3 build_dtor_coiter_arg)) f_Tsss cqssss cfssss;
  13.486 -      in (pfss, cqfsss) end;
  13.487 -
  13.488 -    val unfold_args = mk_args rssss gssss g_Tsss;
  13.489 -    val corec_args = mk_args sssss hssss h_Tsss;
  13.490 -  in
  13.491 -    ((z, cs, cpss, [(unfold_args, unfold_types), (corec_args, corec_types)]), lthy)
  13.492 -  end;
  13.493 -
  13.494 -fun mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy =
  13.495 -  let
  13.496 -    val thy = Proof_Context.theory_of lthy;
  13.497 -
  13.498 -    val (xtor_co_iter_fun_Tss, xtor_co_iterss) =
  13.499 -      map (mk_co_iters thy fp fpTs Cs #> `(mk_fp_iter_fun_types o hd)) (transpose xtor_co_iterss0)
  13.500 -      |> apsnd transpose o apfst transpose o split_list;
  13.501 -
  13.502 -    val ((iters_args_types, coiters_args_types), lthy') =
  13.503 -      if fp = Least_FP then
  13.504 -        mk_iters_args_types ctr_Tsss Cs ns mss xtor_co_iter_fun_Tss lthy |>> (rpair NONE o SOME)
  13.505 -      else
  13.506 -        mk_coiters_args_types ctr_Tsss Cs ns xtor_co_iter_fun_Tss lthy |>> (pair NONE o SOME)
  13.507 -  in
  13.508 -    ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy')
  13.509 -  end;
  13.510 -
  13.511 -fun mk_preds_getterss_join c cps sum_prod_T cqfss =
  13.512 -  let val n = length cqfss in
  13.513 -    Term.lambda c (mk_IfN sum_prod_T cps
  13.514 -      (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)))
  13.515 -  end;
  13.516 -
  13.517 -fun define_co_iters fp fpT Cs binding_specs lthy0 =
  13.518 -  let
  13.519 -    val thy = Proof_Context.theory_of lthy0;
  13.520 -
  13.521 -    val maybe_conceal_def_binding = Thm.def_binding
  13.522 -      #> Config.get lthy0 bnf_note_all = false ? Binding.conceal;
  13.523 -
  13.524 -    val ((csts, defs), (lthy', lthy)) = lthy0
  13.525 -      |> apfst split_list o fold_map (fn (b, rhs) =>
  13.526 -        Local_Theory.define ((b, NoSyn), ((maybe_conceal_def_binding b, []), rhs))
  13.527 -        #>> apsnd snd) binding_specs
  13.528 -      ||> `Local_Theory.restore;
  13.529 -
  13.530 -    val phi = Proof_Context.export_morphism lthy lthy';
  13.531 -
  13.532 -    val csts' = map (mk_co_iter thy fp fpT Cs o Morphism.term phi) csts;
  13.533 -    val defs' = map (Morphism.thm phi) defs;
  13.534 -  in
  13.535 -    ((csts', defs'), lthy')
  13.536 -  end;
  13.537 -
  13.538 -fun define_iters iterNs iter_args_typess' mk_binding fpTs Cs ctor_iters lthy =
  13.539 -  let
  13.540 -    val nn = length fpTs;
  13.541 -
  13.542 -    val fpT_to_C as Type (_, [fpT, _]) = snd (strip_typeN nn (fastype_of (hd ctor_iters)));
  13.543 -
  13.544 -    fun generate_iter pre (_, _, fss, xssss) ctor_iter =
  13.545 -      (mk_binding pre,
  13.546 -       fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_iter,
  13.547 -         map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss)));
  13.548 -  in
  13.549 -    define_co_iters Least_FP fpT Cs (map3 generate_iter iterNs iter_args_typess' ctor_iters) lthy
  13.550 -  end;
  13.551 -
  13.552 -fun define_coiters coiterNs (_, cs, cpss, coiter_args_typess') mk_binding fpTs Cs dtor_coiters
  13.553 -    lthy =
  13.554 -  let
  13.555 -    val nn = length fpTs;
  13.556 -
  13.557 -    val C_to_fpT as Type (_, [_, fpT]) = snd (strip_typeN nn (fastype_of (hd dtor_coiters)));
  13.558 -
  13.559 -    fun generate_coiter pre ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
  13.560 -      (mk_binding pre,
  13.561 -       fold_rev (fold_rev Term.lambda) pfss (Term.list_comb (dtor_coiter,
  13.562 -         map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss)));
  13.563 -  in
  13.564 -    define_co_iters Greatest_FP fpT Cs
  13.565 -      (map3 generate_coiter coiterNs coiter_args_typess' dtor_coiters) lthy
  13.566 -  end;
  13.567 -
  13.568 -fun derive_induct_iters_thms_for_types pre_bnfs [fold_args_types, rec_args_types] ctor_induct
  13.569 -    ctor_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss iterss iter_defss
  13.570 -    lthy =
  13.571 -  let
  13.572 -    val iterss' = transpose iterss;
  13.573 -    val iter_defss' = transpose iter_defss;
  13.574 -
  13.575 -    val [folds, recs] = iterss';
  13.576 -    val [fold_defs, rec_defs] = iter_defss';
  13.577 -
  13.578 -    val ctr_Tsss = map (map (binder_types o fastype_of)) ctrss;
  13.579 -
  13.580 -    val nn = length pre_bnfs;
  13.581 -    val ns = map length ctr_Tsss;
  13.582 -    val mss = map (map length) ctr_Tsss;
  13.583 -
  13.584 -    val pre_map_defs = map map_def_of_bnf pre_bnfs;
  13.585 -    val pre_set_defss = map set_defs_of_bnf pre_bnfs;
  13.586 -    val nesting_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nesting_bnfs;
  13.587 -    val nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs;
  13.588 -    val nested_set_maps = maps set_map_of_bnf nested_bnfs;
  13.589 -
  13.590 -    val fp_b_names = map base_name_of_typ fpTs;
  13.591 -
  13.592 -    val ((((ps, ps'), xsss), us'), names_lthy) =
  13.593 -      lthy
  13.594 -      |> mk_Frees' "P" (map mk_pred1T fpTs)
  13.595 -      ||>> mk_Freesss "x" ctr_Tsss
  13.596 -      ||>> Variable.variant_fixes fp_b_names;
  13.597 -
  13.598 -    val us = map2 (curry Free) us' fpTs;
  13.599 -
  13.600 -    fun mk_sets_nested bnf =
  13.601 -      let
  13.602 -        val Type (T_name, Us) = T_of_bnf bnf;
  13.603 -        val lives = lives_of_bnf bnf;
  13.604 -        val sets = sets_of_bnf bnf;
  13.605 -        fun mk_set U =
  13.606 -          (case find_index (curry (op =) U) lives of
  13.607 -            ~1 => Term.dummy
  13.608 -          | i => nth sets i);
  13.609 -      in
  13.610 -        (T_name, map mk_set Us)
  13.611 -      end;
  13.612 -
  13.613 -    val setss_nested = map mk_sets_nested nested_bnfs;
  13.614 -
  13.615 -    val (induct_thms, induct_thm) =
  13.616 -      let
  13.617 -        fun mk_set Ts t =
  13.618 -          let val Type (_, Ts0) = domain_type (fastype_of t) in
  13.619 -            Term.subst_atomic_types (Ts0 ~~ Ts) t
  13.620 -          end;
  13.621 -
  13.622 -        fun mk_raw_prem_prems _ (x as Free (_, Type _)) (X as TFree _) =
  13.623 -            [([], (find_index (curry (op =) X) Xs + 1, x))]
  13.624 -          | mk_raw_prem_prems names_lthy (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) =
  13.625 -            (case AList.lookup (op =) setss_nested T_name of
  13.626 -              NONE => []
  13.627 -            | SOME raw_sets0 =>
  13.628 -              let
  13.629 -                val (Xs_Ts, (Ts, raw_sets)) =
  13.630 -                  filter (exists_subtype_in Xs o fst) (Xs_Ts0 ~~ (Ts0 ~~ raw_sets0))
  13.631 -                  |> split_list ||> split_list;
  13.632 -                val sets = map (mk_set Ts0) raw_sets;
  13.633 -                val (ys, names_lthy') = names_lthy |> mk_Frees s Ts;
  13.634 -                val xysets = map (pair x) (ys ~~ sets);
  13.635 -                val ppremss = map2 (mk_raw_prem_prems names_lthy') ys Xs_Ts;
  13.636 -              in
  13.637 -                flat (map2 (map o apfst o cons) xysets ppremss)
  13.638 -              end)
  13.639 -          | mk_raw_prem_prems _ _ _ = [];
  13.640 -
  13.641 -        fun close_prem_prem xs t =
  13.642 -          fold_rev Logic.all (map Free (drop (nn + length xs)
  13.643 -            (rev (Term.add_frees t (map dest_Free xs @ ps'))))) t;
  13.644 -
  13.645 -        fun mk_prem_prem xs (xysets, (j, x)) =
  13.646 -          close_prem_prem xs (Logic.list_implies (map (fn (x', (y, set)) =>
  13.647 -              HOLogic.mk_Trueprop (HOLogic.mk_mem (y, set $ x'))) xysets,
  13.648 -            HOLogic.mk_Trueprop (nth ps (j - 1) $ x)));
  13.649 -
  13.650 -        fun mk_raw_prem phi ctr ctr_Ts ctrXs_Ts =
  13.651 -          let
  13.652 -            val (xs, names_lthy') = names_lthy |> mk_Frees "x" ctr_Ts;
  13.653 -            val pprems = flat (map2 (mk_raw_prem_prems names_lthy') xs ctrXs_Ts);
  13.654 -          in (xs, pprems, HOLogic.mk_Trueprop (phi $ Term.list_comb (ctr, xs))) end;
  13.655 -
  13.656 -        fun mk_prem (xs, raw_pprems, concl) =
  13.657 -          fold_rev Logic.all xs (Logic.list_implies (map (mk_prem_prem xs) raw_pprems, concl));
  13.658 -
  13.659 -        val raw_premss = map4 (map3 o mk_raw_prem) ps ctrss ctr_Tsss ctrXs_Tsss;
  13.660 -
  13.661 -        val goal =
  13.662 -          Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
  13.663 -            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)));
  13.664 -
  13.665 -        val kksss = map (map (map (fst o snd) o #2)) raw_premss;
  13.666 -
  13.667 -        val ctor_induct' = ctor_induct OF (map mk_sumEN_tupled_balanced mss);
  13.668 -
  13.669 -        val thm =
  13.670 -          Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
  13.671 -            mk_induct_tac ctxt nn ns mss kksss (flat ctr_defss) ctor_induct' nested_set_maps
  13.672 -              pre_set_defss)
  13.673 -          |> singleton (Proof_Context.export names_lthy lthy)
  13.674 -          |> Thm.close_derivation;
  13.675 -      in
  13.676 -        `(conj_dests nn) thm
  13.677 -      end;
  13.678 -
  13.679 -    val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss);
  13.680 -    val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases));
  13.681 -
  13.682 -    val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss;
  13.683 -
  13.684 -    fun mk_iter_thmss (_, x_Tssss, fss, _) iters iter_defs ctor_iter_thms =
  13.685 -      let
  13.686 -        val fiters = map (lists_bmoc fss) iters;
  13.687 -
  13.688 -        fun mk_goal fss fiter xctr f xs fxs =
  13.689 -          fold_rev (fold_rev Logic.all) (xs :: fss)
  13.690 -            (mk_Trueprop_eq (fiter $ xctr, Term.list_comb (f, fxs)));
  13.691 -
  13.692 -        fun maybe_tick (T, U) u f =
  13.693 -          if try (fst o HOLogic.dest_prodT) U = SOME T then
  13.694 -            Term.lambda u (HOLogic.mk_prod (u, f $ u))
  13.695 -          else
  13.696 -            f;
  13.697 -
  13.698 -        fun build_iter (x as Free (_, T)) U =
  13.699 -          if T = U then
  13.700 -            x
  13.701 -          else
  13.702 -            build_map lthy (indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs
  13.703 -              (fn kk => fn TU => maybe_tick TU (nth us kk) (nth fiters kk))) (T, U) $ x;
  13.704 -
  13.705 -        val fxsss = map2 (map2 (flat_rec_arg_args oo map2 (map o build_iter))) xsss x_Tssss;
  13.706 -
  13.707 -        val goalss = map5 (map4 o mk_goal fss) fiters xctrss fss xsss fxsss;
  13.708 -
  13.709 -        val tacss =
  13.710 -          map2 (map o mk_iter_tac pre_map_defs (nested_map_idents @ nesting_map_idents) iter_defs)
  13.711 -            ctor_iter_thms ctr_defss;
  13.712 -
  13.713 -        fun prove goal tac =
  13.714 -          Goal.prove_sorry lthy [] [] goal (tac o #context)
  13.715 -          |> Thm.close_derivation;
  13.716 -      in
  13.717 -        map2 (map2 prove) goalss tacss
  13.718 -      end;
  13.719 -
  13.720 -    val fold_thmss = mk_iter_thmss fold_args_types folds fold_defs (map un_fold_of ctor_iter_thmss);
  13.721 -    val rec_thmss = mk_iter_thmss rec_args_types recs rec_defs (map co_rec_of ctor_iter_thmss);
  13.722 -  in
  13.723 -    ((induct_thms, induct_thm, [induct_case_names_attr]),
  13.724 -     (fold_thmss, rec_thmss, code_nitpicksimp_attrs @ simp_attrs))
  13.725 -  end;
  13.726 -
  13.727 -fun derive_coinduct_coiters_thms_for_types pre_bnfs (z, cs, cpss,
  13.728 -      coiters_args_types as [((pgss, crgsss), _), ((phss, cshsss), _)])
  13.729 -    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss
  13.730 -    mss ns ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
  13.731 -  let
  13.732 -    fun mk_ctor_dtor_coiter_thm dtor_inject dtor_ctor coiter =
  13.733 -      iffD1 OF [dtor_inject, trans OF [coiter, dtor_ctor RS sym]];
  13.734 -
  13.735 -    val ctor_dtor_coiter_thmss =
  13.736 -      map3 (map oo mk_ctor_dtor_coiter_thm) dtor_injects dtor_ctors dtor_coiter_thmss;
  13.737 -
  13.738 -    val coiterss' = transpose coiterss;
  13.739 -    val coiter_defss' = transpose coiter_defss;
  13.740 -
  13.741 -    val [unfold_defs, corec_defs] = coiter_defss';
  13.742 -
  13.743 -    val nn = length pre_bnfs;
  13.744 -
  13.745 -    val pre_map_defs = map map_def_of_bnf pre_bnfs;
  13.746 -    val pre_rel_defs = map rel_def_of_bnf pre_bnfs;
  13.747 -    val nesting_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nesting_bnfs;
  13.748 -    val nesting_rel_eqs = map rel_eq_of_bnf nesting_bnfs;
  13.749 -
  13.750 -    val fp_b_names = map base_name_of_typ fpTs;
  13.751 -
  13.752 -    val ctrss = map #ctrs ctr_sugars;
  13.753 -    val discss = map #discs ctr_sugars;
  13.754 -    val selsss = map #selss ctr_sugars;
  13.755 -    val exhausts = map #exhaust ctr_sugars;
  13.756 -    val disc_thmsss = map #disc_thmss ctr_sugars;
  13.757 -    val discIss = map #discIs ctr_sugars;
  13.758 -    val sel_thmsss = map #sel_thmss ctr_sugars;
  13.759 -
  13.760 -    val (((rs, us'), vs'), names_lthy) =
  13.761 -      lthy
  13.762 -      |> mk_Frees "R" (map (fn T => mk_pred2T T T) fpTs)
  13.763 -      ||>> Variable.variant_fixes fp_b_names
  13.764 -      ||>> Variable.variant_fixes (map (suffix "'") fp_b_names);
  13.765 -
  13.766 -    val us = map2 (curry Free) us' fpTs;
  13.767 -    val udiscss = map2 (map o rapp) us discss;
  13.768 -    val uselsss = map2 (map o map o rapp) us selsss;
  13.769 -
  13.770 -    val vs = map2 (curry Free) vs' fpTs;
  13.771 -    val vdiscss = map2 (map o rapp) vs discss;
  13.772 -    val vselsss = map2 (map o map o rapp) vs selsss;
  13.773 -
  13.774 -    val coinduct_thms_pairs =
  13.775 -      let
  13.776 -        val uvrs = map3 (fn r => fn u => fn v => r $ u $ v) rs us vs;
  13.777 -        val uv_eqs = map2 (curry HOLogic.mk_eq) us vs;
  13.778 -        val strong_rs =
  13.779 -          map4 (fn u => fn v => fn uvr => fn uv_eq =>
  13.780 -            fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs;
  13.781 -
  13.782 -        fun build_the_rel rs' T Xs_T =
  13.783 -          build_rel lthy (fn (_, X) => nth rs' (find_index (curry (op =) X) Xs)) (T, Xs_T)
  13.784 -          |> Term.subst_atomic_types (Xs ~~ fpTs);
  13.785 -
  13.786 -        fun build_rel_app rs' usel vsel Xs_T =
  13.787 -          fold rapp [usel, vsel] (build_the_rel rs' (fastype_of usel) Xs_T);
  13.788 -
  13.789 -        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels ctrXs_Ts =
  13.790 -          (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @
  13.791 -          (if null usels then
  13.792 -             []
  13.793 -           else
  13.794 -             [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc],
  13.795 -                Library.foldr1 HOLogic.mk_conj (map3 (build_rel_app rs') usels vsels ctrXs_Ts))]);
  13.796 -
  13.797 -        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss =
  13.798 -          Library.foldr1 HOLogic.mk_conj (flat (map6 (mk_prem_ctr_concls rs' n)
  13.799 -            (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss))
  13.800 -          handle List.Empty => @{term True};
  13.801 -
  13.802 -        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss =
  13.803 -          fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr,
  13.804 -            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss)));
  13.805 -
  13.806 -        val concl =
  13.807 -          HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
  13.808 -            (map3 (fn uvr => fn u => fn v => HOLogic.mk_imp (uvr, HOLogic.mk_eq (u, v)))
  13.809 -               uvrs us vs));
  13.810 -
  13.811 -        fun mk_goal rs' =
  13.812 -          Logic.list_implies (map9 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss
  13.813 -            ctrXs_Tsss, concl);
  13.814 -
  13.815 -        val goals = map mk_goal [rs, strong_rs];
  13.816 -
  13.817 -        fun prove dtor_coinduct' goal =
  13.818 -          Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
  13.819 -            mk_coinduct_tac ctxt nesting_rel_eqs nn ns dtor_coinduct' pre_rel_defs dtor_ctors
  13.820 -              exhausts ctr_defss disc_thmsss sel_thmsss)
  13.821 -          |> singleton (Proof_Context.export names_lthy lthy)
  13.822 -          |> Thm.close_derivation;
  13.823 -
  13.824 -        fun postproc nn thm =
  13.825 -          Thm.permute_prems 0 nn
  13.826 -            (if nn = 1 then thm RS mp else funpow nn (fn thm => reassoc_conjs (thm RS mp_conj)) thm)
  13.827 -          |> Drule.zero_var_indexes
  13.828 -          |> `(conj_dests nn);
  13.829 -
  13.830 -        val rel_eqs = map rel_eq_of_bnf pre_bnfs;
  13.831 -        val rel_monos = map rel_mono_of_bnf pre_bnfs;
  13.832 -        val dtor_coinducts =
  13.833 -          [dtor_coinduct, mk_strong_coinduct_thm dtor_coinduct rel_eqs rel_monos lthy];
  13.834 -      in
  13.835 -        map2 (postproc nn oo prove) dtor_coinducts goals
  13.836 -      end;
  13.837 -
  13.838 -    fun mk_coinduct_concls ms discs ctrs =
  13.839 -      let
  13.840 -        fun mk_disc_concl disc = [name_of_disc disc];
  13.841 -        fun mk_ctr_concl 0 _ = []
  13.842 -          | mk_ctr_concl _ ctor = [name_of_ctr ctor];
  13.843 -        val disc_concls = map mk_disc_concl (fst (split_last discs)) @ [[]];
  13.844 -        val ctr_concls = map2 mk_ctr_concl ms ctrs;
  13.845 -      in
  13.846 -        flat (map2 append disc_concls ctr_concls)
  13.847 -      end;
  13.848 -
  13.849 -    val coinduct_cases = quasi_unambiguous_case_names (map (prefix EqN) fp_b_names);
  13.850 -    val coinduct_conclss =
  13.851 -      map3 (quasi_unambiguous_case_names ooo mk_coinduct_concls) mss discss ctrss;
  13.852 -
  13.853 -    fun mk_maybe_not pos = not pos ? HOLogic.mk_not;
  13.854 -
  13.855 -    val fcoiterss' as [gunfolds, hcorecs] =
  13.856 -      map2 (fn (pfss, _) => map (lists_bmoc pfss)) (map fst coiters_args_types) coiterss';
  13.857 -
  13.858 -    val (unfold_thmss, corec_thmss) =
  13.859 -      let
  13.860 -        fun mk_goal pfss c cps fcoiter n k ctr m cfs' =
  13.861 -          fold_rev (fold_rev Logic.all) ([c] :: pfss)
  13.862 -            (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps,
  13.863 -               mk_Trueprop_eq (fcoiter $ c, Term.list_comb (ctr, take m cfs'))));
  13.864 -
  13.865 -        fun mk_U maybe_mk_sumT =
  13.866 -          typ_subst_nonatomic (map2 (fn C => fn fpT => (maybe_mk_sumT fpT C, fpT)) Cs fpTs);
  13.867 -
  13.868 -        fun tack z_name (c, u) f =
  13.869 -          let val z = Free (z_name, mk_sumT (fastype_of u, fastype_of c)) in
  13.870 -            Term.lambda z (mk_sum_case (Term.lambda u u, Term.lambda c (f $ c)) $ z)
  13.871 -          end;
  13.872 -
  13.873 -        fun build_coiter fcoiters maybe_mk_sumT maybe_tack cqf =
  13.874 -          let val T = fastype_of cqf in
  13.875 -            if exists_subtype_in Cs T then
  13.876 -              let val U = mk_U maybe_mk_sumT T in
  13.877 -                build_map lthy (indexify snd fpTs (fn kk => fn _ =>
  13.878 -                  maybe_tack (nth cs kk, nth us kk) (nth fcoiters kk))) (T, U) $ cqf
  13.879 -              end
  13.880 -            else
  13.881 -              cqf
  13.882 -          end;
  13.883 -
  13.884 -        val crgsss' = map (map (map (build_coiter (un_fold_of fcoiterss') (K I) (K I)))) crgsss;
  13.885 -        val cshsss' = map (map (map (build_coiter (co_rec_of fcoiterss') (curry mk_sumT) (tack z))))
  13.886 -          cshsss;
  13.887 -
  13.888 -        val unfold_goalss = map8 (map4 oooo mk_goal pgss) cs cpss gunfolds ns kss ctrss mss crgsss';
  13.889 -        val corec_goalss = map8 (map4 oooo mk_goal phss) cs cpss hcorecs ns kss ctrss mss cshsss';
  13.890 -
  13.891 -        val unfold_tacss =
  13.892 -          map3 (map oo mk_coiter_tac unfold_defs nesting_map_idents)
  13.893 -            (map un_fold_of ctor_dtor_coiter_thmss) pre_map_defs ctr_defss;
  13.894 -        val corec_tacss =
  13.895 -          map3 (map oo mk_coiter_tac corec_defs nesting_map_idents)
  13.896 -            (map co_rec_of ctor_dtor_coiter_thmss) pre_map_defs ctr_defss;
  13.897 -
  13.898 -        fun prove goal tac =
  13.899 -          Goal.prove_sorry lthy [] [] goal (tac o #context)
  13.900 -          |> Thm.close_derivation;
  13.901 -
  13.902 -        val unfold_thmss = map2 (map2 prove) unfold_goalss unfold_tacss;
  13.903 -        val corec_thmss =
  13.904 -          map2 (map2 prove) corec_goalss corec_tacss
  13.905 -          |> map (map (unfold_thms lthy @{thms sum_case_if}));
  13.906 -      in
  13.907 -        (unfold_thmss, corec_thmss)
  13.908 -      end;
  13.909 -
  13.910 -    val (disc_unfold_iff_thmss, disc_corec_iff_thmss) =
  13.911 -      let
  13.912 -        fun mk_goal c cps fcoiter n k disc =
  13.913 -          mk_Trueprop_eq (disc $ (fcoiter $ c),
  13.914 -            if n = 1 then @{const True}
  13.915 -            else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps));
  13.916 -
  13.917 -        val unfold_goalss = map6 (map2 oooo mk_goal) cs cpss gunfolds ns kss discss;
  13.918 -        val corec_goalss = map6 (map2 oooo mk_goal) cs cpss hcorecs ns kss discss;
  13.919 -
  13.920 -        fun mk_case_split' cp = Drule.instantiate' [] [SOME (certify lthy cp)] @{thm case_split};
  13.921 -
  13.922 -        val case_splitss' = map (map mk_case_split') cpss;
  13.923 -
  13.924 -        val unfold_tacss =
  13.925 -          map3 (map oo mk_disc_coiter_iff_tac) case_splitss' unfold_thmss disc_thmsss;
  13.926 -        val corec_tacss =
  13.927 -          map3 (map oo mk_disc_coiter_iff_tac) case_splitss' corec_thmss disc_thmsss;
  13.928 -
  13.929 -        fun prove goal tac =
  13.930 -          Goal.prove_sorry lthy [] [] goal (tac o #context)
  13.931 -          |> singleton export_args
  13.932 -          |> singleton (Proof_Context.export names_lthy lthy)
  13.933 -          |> Thm.close_derivation;
  13.934 -
  13.935 -        fun proves [_] [_] = []
  13.936 -          | proves goals tacs = map2 prove goals tacs;
  13.937 -      in
  13.938 -        (map2 proves unfold_goalss unfold_tacss, map2 proves corec_goalss corec_tacss)
  13.939 -      end;
  13.940 -
  13.941 -    fun mk_disc_coiter_thms coiters discIs = map (op RS) (coiters ~~ discIs);
  13.942 -
  13.943 -    val disc_unfold_thmss = map2 mk_disc_coiter_thms unfold_thmss discIss;
  13.944 -    val disc_corec_thmss = map2 mk_disc_coiter_thms corec_thmss discIss;
  13.945 -
  13.946 -    fun mk_sel_coiter_thm coiter_thm sel sel_thm =
  13.947 -      let
  13.948 -        val (domT, ranT) = dest_funT (fastype_of sel);
  13.949 -        val arg_cong' =
  13.950 -          Drule.instantiate' (map (SOME o certifyT lthy) [domT, ranT])
  13.951 -            [NONE, NONE, SOME (certify lthy sel)] arg_cong
  13.952 -          |> Thm.varifyT_global;
  13.953 -        val sel_thm' = sel_thm RSN (2, trans);
  13.954 -      in
  13.955 -        coiter_thm RS arg_cong' RS sel_thm'
  13.956 -      end;
  13.957 -
  13.958 -    fun mk_sel_coiter_thms coiter_thmss =
  13.959 -      map3 (map3 (map2 o mk_sel_coiter_thm)) coiter_thmss selsss sel_thmsss;
  13.960 -
  13.961 -    val sel_unfold_thmsss = mk_sel_coiter_thms unfold_thmss;
  13.962 -    val sel_corec_thmsss = mk_sel_coiter_thms corec_thmss;
  13.963 -
  13.964 -    val coinduct_consumes_attr = Attrib.internal (K (Rule_Cases.consumes nn));
  13.965 -    val coinduct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names coinduct_cases));
  13.966 -    val coinduct_case_concl_attrs =
  13.967 -      map2 (fn casex => fn concls =>
  13.968 -          Attrib.internal (K (Rule_Cases.case_conclusion (casex, concls))))
  13.969 -        coinduct_cases coinduct_conclss;
  13.970 -    val coinduct_case_attrs =
  13.971 -      coinduct_consumes_attr :: coinduct_case_names_attr :: coinduct_case_concl_attrs;
  13.972 -  in
  13.973 -    ((coinduct_thms_pairs, coinduct_case_attrs),
  13.974 -     (unfold_thmss, corec_thmss, code_nitpicksimp_attrs),
  13.975 -     (disc_unfold_thmss, disc_corec_thmss, []),
  13.976 -     (disc_unfold_iff_thmss, disc_corec_iff_thmss, simp_attrs),
  13.977 -     (sel_unfold_thmsss, sel_corec_thmsss, simp_attrs))
  13.978 -  end;
  13.979 -
  13.980 -fun define_co_datatypes prepare_constraint prepare_typ prepare_term fp construct_fp
  13.981 -    (wrap_opts as (no_discs_sels, (_, rep_compat)), specs) no_defs_lthy0 =
  13.982 -  let
  13.983 -    (* TODO: sanity checks on arguments *)
  13.984 -
  13.985 -    val _ = if fp = Greatest_FP andalso no_discs_sels then
  13.986 -        error "Cannot define codatatypes without discriminators and selectors"
  13.987 -      else
  13.988 -        ();
  13.989 -
  13.990 -    fun qualify mandatory fp_b_name =
  13.991 -      Binding.qualify mandatory fp_b_name o (rep_compat ? Binding.qualify false rep_compat_prefix);
  13.992 -
  13.993 -    val nn = length specs;
  13.994 -    val fp_bs = map type_binding_of specs;
  13.995 -    val fp_b_names = map Binding.name_of fp_bs;
  13.996 -    val fp_common_name = mk_common_name fp_b_names;
  13.997 -    val map_bs = map map_binding_of specs;
  13.998 -    val rel_bs = map rel_binding_of specs;
  13.999 -
 13.1000 -    fun prepare_type_arg (_, (ty, c)) =
 13.1001 -      let val TFree (s, _) = prepare_typ no_defs_lthy0 ty in
 13.1002 -        TFree (s, prepare_constraint no_defs_lthy0 c)
 13.1003 -      end;
 13.1004 -
 13.1005 -    val Ass0 = map (map prepare_type_arg o type_args_named_constrained_of) specs;
 13.1006 -    val unsorted_Ass0 = map (map (resort_tfree HOLogic.typeS)) Ass0;
 13.1007 -    val unsorted_As = Library.foldr1 merge_type_args unsorted_Ass0;
 13.1008 -    val num_As = length unsorted_As;
 13.1009 -    val set_bss = map (map fst o type_args_named_constrained_of) specs;
 13.1010 -
 13.1011 -    val (((Bs0, Cs), Xs), no_defs_lthy) =
 13.1012 -      no_defs_lthy0
 13.1013 -      |> fold (Variable.declare_typ o resort_tfree dummyS) unsorted_As
 13.1014 -      |> mk_TFrees num_As
 13.1015 -      ||>> mk_TFrees nn
 13.1016 -      ||>> variant_tfrees fp_b_names;
 13.1017 -
 13.1018 -    fun add_fake_type spec = Typedecl.basic_typedecl (type_binding_of spec, num_As, mixfix_of spec);
 13.1019 -
 13.1020 -    val (fake_T_names, fake_lthy) = fold_map add_fake_type specs no_defs_lthy0;
 13.1021 -
 13.1022 -    val qsoty = quote o Syntax.string_of_typ fake_lthy;
 13.1023 -
 13.1024 -    val _ = (case Library.duplicates (op =) unsorted_As of [] => ()
 13.1025 -      | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^
 13.1026 -          "datatype specification"));
 13.1027 -
 13.1028 -    val bad_args =
 13.1029 -      map (Logic.type_map (singleton (Variable.polymorphic no_defs_lthy0))) unsorted_As
 13.1030 -      |> filter_out Term.is_TVar;
 13.1031 -    val _ = null bad_args orelse
 13.1032 -      error ("Locally fixed type argument " ^ qsoty (hd bad_args) ^ " in " ^ co_prefix fp ^
 13.1033 -        "datatype specification");
 13.1034 -
 13.1035 -    val mixfixes = map mixfix_of specs;
 13.1036 -
 13.1037 -    val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => ()
 13.1038 -      | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
 13.1039 -
 13.1040 -    val ctr_specss = map ctr_specs_of specs;
 13.1041 -
 13.1042 -    val disc_bindingss = map (map disc_of) ctr_specss;
 13.1043 -    val ctr_bindingss =
 13.1044 -      map2 (fn fp_b_name => map (qualify false fp_b_name o ctr_of)) fp_b_names ctr_specss;
 13.1045 -    val ctr_argsss = map (map args_of) ctr_specss;
 13.1046 -    val ctr_mixfixess = map (map ctr_mixfix_of) ctr_specss;
 13.1047 -
 13.1048 -    val sel_bindingsss = map (map (map fst)) ctr_argsss;
 13.1049 -    val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss;
 13.1050 -    val raw_sel_defaultsss = map (map defaults_of) ctr_specss;
 13.1051 -
 13.1052 -    val (As :: _) :: fake_ctr_Tsss =
 13.1053 -      burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0);
 13.1054 -    val As' = map dest_TFree As;
 13.1055 -
 13.1056 -    val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss [];
 13.1057 -    val _ = (case subtract (op =) As' rhs_As' of [] => ()
 13.1058 -      | extras => error ("Extra type variables on right-hand side: " ^
 13.1059 -          commas (map (qsoty o TFree) extras)));
 13.1060 -
 13.1061 -    val fake_Ts = map (fn s => Type (s, As)) fake_T_names;
 13.1062 -
 13.1063 -    fun eq_fpT_check (T as Type (s, Ts)) (T' as Type (s', Ts')) =
 13.1064 -        s = s' andalso (Ts = Ts' orelse
 13.1065 -          error ("Wrong type arguments in " ^ co_prefix fp ^ "recursive type " ^ qsoty T ^
 13.1066 -            " (expected " ^ qsoty T' ^ ")"))
 13.1067 -      | eq_fpT_check _ _ = false;
 13.1068 -
 13.1069 -    fun freeze_fp (T as Type (s, Ts)) =
 13.1070 -        (case find_index (eq_fpT_check T) fake_Ts of
 13.1071 -          ~1 => Type (s, map freeze_fp Ts)
 13.1072 -        | kk => nth Xs kk)
 13.1073 -      | freeze_fp T = T;
 13.1074 -
 13.1075 -    val unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fake_Ts);
 13.1076 -
 13.1077 -    val ctrXs_Tsss = map (map (map freeze_fp)) fake_ctr_Tsss;
 13.1078 -    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
 13.1079 -
 13.1080 -    val fp_eqs =
 13.1081 -      map dest_TFree Xs ~~ map (Term.typ_subst_atomic (As ~~ unsorted_As)) ctrXs_sum_prod_Ts;
 13.1082 -
 13.1083 -    val rhsXs_As' = fold (fold (fold Term.add_tfreesT)) ctrXs_Tsss [];
 13.1084 -    val _ = (case subtract (op =) rhsXs_As' As' of [] => ()
 13.1085 -      | extras => List.app (fn extra => warning ("Unused type variable on right-hand side of " ^
 13.1086 -          co_prefix fp ^ "datatype definition: " ^ qsoty (TFree extra))) extras);
 13.1087 -
 13.1088 -    val (pre_bnfs, (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, ctors = ctors0, dtors = dtors0,
 13.1089 -           xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects,
 13.1090 -           dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms, xtor_co_iter_thmss, ...},
 13.1091 -           lthy)) =
 13.1092 -      fp_bnf (construct_fp mixfixes map_bs rel_bs set_bss) fp_bs (map dest_TFree unsorted_As) fp_eqs
 13.1093 -        no_defs_lthy0
 13.1094 -      handle BAD_DEAD (X, X_backdrop) =>
 13.1095 -        (case X_backdrop of
 13.1096 -          Type (bad_tc, _) =>
 13.1097 -          let
 13.1098 -            val fake_T = qsoty (unfreeze_fp X);
 13.1099 -            val fake_T_backdrop = qsoty (unfreeze_fp X_backdrop);
 13.1100 -            fun register_hint () =
 13.1101 -              "\nUse the " ^ quote (fst (fst @{command_spec "bnf"})) ^ " command to register " ^
 13.1102 -              quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \
 13.1103 -              \it";
 13.1104 -          in
 13.1105 -            if is_some (bnf_of no_defs_lthy bad_tc) orelse
 13.1106 -               is_some (fp_sugar_of no_defs_lthy bad_tc) then
 13.1107 -              error ("Inadmissible " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
 13.1108 -                " in type expression " ^ fake_T_backdrop)
 13.1109 -            else if is_some (Datatype_Data.get_info (Proof_Context.theory_of no_defs_lthy)
 13.1110 -                bad_tc) then
 13.1111 -              error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
 13.1112 -                " via the old-style datatype " ^ quote bad_tc ^ " in type expression " ^
 13.1113 -                fake_T_backdrop ^ register_hint ())
 13.1114 -            else
 13.1115 -              error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
 13.1116 -                " via type constructor " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^
 13.1117 -                register_hint ())
 13.1118 -          end);
 13.1119 -
 13.1120 -    val time = time lthy;
 13.1121 -    val timer = time (Timer.startRealTimer ());
 13.1122 -
 13.1123 -    val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
 13.1124 -    val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
 13.1125 -
 13.1126 -    val pre_map_defs = map map_def_of_bnf pre_bnfs;
 13.1127 -    val pre_set_defss = map set_defs_of_bnf pre_bnfs;
 13.1128 -    val pre_rel_defs = map rel_def_of_bnf pre_bnfs;
 13.1129 -    val nesting_set_maps = maps set_map_of_bnf nesting_bnfs;
 13.1130 -    val nested_set_maps = maps set_map_of_bnf nested_bnfs;
 13.1131 -
 13.1132 -    val live = live_of_bnf any_fp_bnf;
 13.1133 -    val _ =
 13.1134 -      if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs) then
 13.1135 -        warning "Map function and relator names ignored"
 13.1136 -      else
 13.1137 -        ();
 13.1138 -
 13.1139 -    val Bs =
 13.1140 -      map3 (fn alive => fn A as TFree (_, S) => fn B => if alive then resort_tfree S B else A)
 13.1141 -        (liveness_of_fp_bnf num_As any_fp_bnf) As Bs0;
 13.1142 -
 13.1143 -    val B_ify = Term.typ_subst_atomic (As ~~ Bs);
 13.1144 -
 13.1145 -    val ctors = map (mk_ctor As) ctors0;
 13.1146 -    val dtors = map (mk_dtor As) dtors0;
 13.1147 -
 13.1148 -    val fpTs = map (domain_type o fastype_of) dtors;
 13.1149 -
 13.1150 -    fun massage_simple_notes base =
 13.1151 -      filter_out (null o #2)
 13.1152 -      #> map (fn (thmN, thms, attrs) =>
 13.1153 -        ((qualify true base (Binding.name thmN), attrs), [(thms, [])]));
 13.1154 -
 13.1155 -    val massage_multi_notes =
 13.1156 -      maps (fn (thmN, thmss, attrs) =>
 13.1157 -        map3 (fn fp_b_name => fn Type (T_name, _) => fn thms =>
 13.1158 -            ((qualify true fp_b_name (Binding.name thmN), attrs T_name), [(thms, [])]))
 13.1159 -          fp_b_names fpTs thmss)
 13.1160 -      #> filter_out (null o fst o hd o snd);
 13.1161 -
 13.1162 -    val ctr_Tsss = map (map (map (Term.typ_subst_atomic (Xs ~~ fpTs)))) ctrXs_Tsss;
 13.1163 -    val ns = map length ctr_Tsss;
 13.1164 -    val kss = map (fn n => 1 upto n) ns;
 13.1165 -    val mss = map (map length) ctr_Tsss;
 13.1166 -
 13.1167 -    val ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy') =
 13.1168 -      mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
 13.1169 -
 13.1170 -    fun define_ctrs_dtrs_for_type (((((((((((((((((((((((fp_bnf, fp_b), fpT), ctor), dtor),
 13.1171 -            xtor_co_iters), ctor_dtor), dtor_ctor), ctor_inject), pre_map_def), pre_set_defs),
 13.1172 -          pre_rel_def), fp_map_thm), fp_set_thms), fp_rel_thm), n), ks), ms), ctr_bindings),
 13.1173 -        ctr_mixfixes), ctr_Tss), disc_bindings), sel_bindingss), raw_sel_defaultss) no_defs_lthy =
 13.1174 -      let
 13.1175 -        val fp_b_name = Binding.name_of fp_b;
 13.1176 -
 13.1177 -        val dtorT = domain_type (fastype_of ctor);
 13.1178 -        val ctr_prod_Ts = map HOLogic.mk_tupleT ctr_Tss;
 13.1179 -        val ctr_sum_prod_T = mk_sumTN_balanced ctr_prod_Ts;
 13.1180 -
 13.1181 -        val ((((w, xss), yss), u'), names_lthy) =
 13.1182 -          no_defs_lthy
 13.1183 -          |> yield_singleton (mk_Frees "w") dtorT
 13.1184 -          ||>> mk_Freess "x" ctr_Tss
 13.1185 -          ||>> mk_Freess "y" (map (map B_ify) ctr_Tss)
 13.1186 -          ||>> yield_singleton Variable.variant_fixes fp_b_name;
 13.1187 -
 13.1188 -        val u = Free (u', fpT);
 13.1189 -
 13.1190 -        val tuple_xs = map HOLogic.mk_tuple xss;
 13.1191 -        val tuple_ys = map HOLogic.mk_tuple yss;
 13.1192 -
 13.1193 -        val ctr_rhss =
 13.1194 -          map3 (fn k => fn xs => fn tuple_x => fold_rev Term.lambda xs (ctor $
 13.1195 -            mk_InN_balanced ctr_sum_prod_T n tuple_x k)) ks xss tuple_xs;
 13.1196 -
 13.1197 -        val maybe_conceal_def_binding = Thm.def_binding
 13.1198 -          #> Config.get no_defs_lthy bnf_note_all = false ? Binding.conceal;
 13.1199 -
 13.1200 -        val ((raw_ctrs, raw_ctr_defs), (lthy', lthy)) = no_defs_lthy
 13.1201 -          |> apfst split_list o fold_map3 (fn b => fn mx => fn rhs =>
 13.1202 -              Local_Theory.define ((b, mx), ((maybe_conceal_def_binding b, []), rhs)) #>> apsnd snd)
 13.1203 -            ctr_bindings ctr_mixfixes ctr_rhss
 13.1204 -          ||> `Local_Theory.restore;
 13.1205 -
 13.1206 -        val phi = Proof_Context.export_morphism lthy lthy';
 13.1207 -
 13.1208 -        val ctr_defs = map (Morphism.thm phi) raw_ctr_defs;
 13.1209 -        val ctr_defs' =
 13.1210 -          map2 (fn m => fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) ms ctr_defs;
 13.1211 -
 13.1212 -        val ctrs0 = map (Morphism.term phi) raw_ctrs;
 13.1213 -        val ctrs = map (mk_ctr As) ctrs0;
 13.1214 -
 13.1215 -        fun wrap_ctrs lthy =
 13.1216 -          let
 13.1217 -            fun exhaust_tac {context = ctxt, prems = _} =
 13.1218 -              let
 13.1219 -                val ctor_iff_dtor_thm =
 13.1220 -                  let
 13.1221 -                    val goal =
 13.1222 -                      fold_rev Logic.all [w, u]
 13.1223 -                        (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w)));
 13.1224 -                  in
 13.1225 -                    Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
 13.1226 -                      mk_ctor_iff_dtor_tac ctxt (map (SOME o certifyT lthy) [dtorT, fpT])
 13.1227 -                        (certify lthy ctor) (certify lthy dtor) ctor_dtor dtor_ctor)
 13.1228 -                    |> Thm.close_derivation
 13.1229 -                    |> Morphism.thm phi
 13.1230 -                  end;
 13.1231 -
 13.1232 -                val sumEN_thm' =
 13.1233 -                  unfold_thms lthy @{thms unit_all_eq1}
 13.1234 -                    (Drule.instantiate' (map (SOME o certifyT lthy) ctr_prod_Ts) []
 13.1235 -                       (mk_sumEN_balanced n))
 13.1236 -                  |> Morphism.thm phi;
 13.1237 -              in
 13.1238 -                mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'
 13.1239 -              end;
 13.1240 -
 13.1241 -            val inject_tacss =
 13.1242 -              map2 (fn 0 => K [] | _ => fn ctr_def => [fn {context = ctxt, ...} =>
 13.1243 -                mk_inject_tac ctxt ctr_def ctor_inject]) ms ctr_defs;
 13.1244 -
 13.1245 -            val half_distinct_tacss =
 13.1246 -              map (map (fn (def, def') => fn {context = ctxt, ...} =>
 13.1247 -                mk_half_distinct_tac ctxt ctor_inject [def, def'])) (mk_half_pairss (`I ctr_defs));
 13.1248 -
 13.1249 -            val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss;
 13.1250 -
 13.1251 -            val sel_defaultss = map (map (apsnd (prepare_term lthy))) raw_sel_defaultss
 13.1252 -          in
 13.1253 -            wrap_free_constructors tacss (((wrap_opts, ctrs0), standard_binding), (disc_bindings,
 13.1254 -              (sel_bindingss, sel_defaultss))) lthy
 13.1255 -          end;
 13.1256 -
 13.1257 -        fun derive_maps_sets_rels (ctr_sugar, lthy) =
 13.1258 -          if live = 0 then
 13.1259 -            ((([], [], [], []), ctr_sugar), lthy)
 13.1260 -          else
 13.1261 -            let
 13.1262 -              val rel_flip = rel_flip_of_bnf fp_bnf;
 13.1263 -              val nones = replicate live NONE;
 13.1264 -
 13.1265 -              val ctor_cong =
 13.1266 -                if fp = Least_FP then
 13.1267 -                  Drule.dummy_thm
 13.1268 -                else
 13.1269 -                  let val ctor' = mk_ctor Bs ctor in
 13.1270 -                    cterm_instantiate_pos [NONE, NONE, SOME (certify lthy ctor')] arg_cong
 13.1271 -                  end;
 13.1272 -
 13.1273 -              fun mk_cIn ify =
 13.1274 -                certify lthy o (fp = Greatest_FP ? curry (op $) (map_types ify ctor)) oo
 13.1275 -                mk_InN_balanced (ify ctr_sum_prod_T) n;
 13.1276 -
 13.1277 -              val cxIns = map2 (mk_cIn I) tuple_xs ks;
 13.1278 -              val cyIns = map2 (mk_cIn B_ify) tuple_ys ks;
 13.1279 -
 13.1280 -              fun mk_map_thm ctr_def' cxIn =
 13.1281 -                fold_thms lthy [ctr_def']
 13.1282 -                  (unfold_thms lthy (pre_map_def ::
 13.1283 -                       (if fp = Least_FP then [] else [ctor_dtor, dtor_ctor]) @ sum_prod_thms_map)
 13.1284 -                     (cterm_instantiate_pos (nones @ [SOME cxIn])
 13.1285 -                        (if fp = Least_FP then fp_map_thm else fp_map_thm RS ctor_cong)))
 13.1286 -                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
 13.1287 -
 13.1288 -              fun mk_set_thm fp_set_thm ctr_def' cxIn =
 13.1289 -                fold_thms lthy [ctr_def']
 13.1290 -                  (unfold_thms lthy (pre_set_defs @ nested_set_maps @ nesting_set_maps @
 13.1291 -                       (if fp = Least_FP then [] else [dtor_ctor]) @ sum_prod_thms_set)
 13.1292 -                     (cterm_instantiate_pos [SOME cxIn] fp_set_thm))
 13.1293 -                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
 13.1294 -
 13.1295 -              fun mk_set_thms fp_set_thm = map2 (mk_set_thm fp_set_thm) ctr_defs' cxIns;
 13.1296 -
 13.1297 -              val map_thms = map2 mk_map_thm ctr_defs' cxIns;
 13.1298 -              val set_thmss = map mk_set_thms fp_set_thms;
 13.1299 -
 13.1300 -              val rel_infos = (ctr_defs' ~~ cxIns, ctr_defs' ~~ cyIns);
 13.1301 -
 13.1302 -              fun mk_rel_thm postproc ctr_defs' cxIn cyIn =
 13.1303 -                fold_thms lthy ctr_defs'
 13.1304 -                  (unfold_thms lthy (@{thm Inl_Inr_False} :: pre_rel_def ::
 13.1305 -                       (if fp = Least_FP then [] else [dtor_ctor]) @ sum_prod_thms_rel)
 13.1306 -                     (cterm_instantiate_pos (nones @ [SOME cxIn, SOME cyIn]) fp_rel_thm))
 13.1307 -                |> postproc
 13.1308 -                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
 13.1309 -
 13.1310 -              fun mk_rel_inject_thm ((ctr_def', cxIn), (_, cyIn)) =
 13.1311 -                mk_rel_thm (unfold_thms lthy @{thms eq_sym_Unity_conv}) [ctr_def'] cxIn cyIn;
 13.1312 -
 13.1313 -              val rel_inject_thms = map mk_rel_inject_thm (op ~~ rel_infos);
 13.1314 -
 13.1315 -              fun mk_half_rel_distinct_thm ((xctr_def', cxIn), (yctr_def', cyIn)) =
 13.1316 -                mk_rel_thm (fn thm => thm RS @{thm eq_False[THEN iffD1]}) [xctr_def', yctr_def']
 13.1317 -                  cxIn cyIn;
 13.1318 -
 13.1319 -              fun mk_other_half_rel_distinct_thm thm =
 13.1320 -                flip_rels lthy live thm
 13.1321 -                RS (rel_flip RS sym RS @{thm arg_cong[of _ _ Not]} RS iffD2);
 13.1322 -
 13.1323 -              val half_rel_distinct_thmss =
 13.1324 -                map (map mk_half_rel_distinct_thm) (mk_half_pairss rel_infos);
 13.1325 -              val other_half_rel_distinct_thmss =
 13.1326 -                map (map mk_other_half_rel_distinct_thm) half_rel_distinct_thmss;
 13.1327 -              val (rel_distinct_thms, _) =
 13.1328 -                join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss;
 13.1329 -
 13.1330 -              val anonymous_notes =
 13.1331 -                [(map (fn th => th RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms,
 13.1332 -                  code_nitpicksimp_attrs),
 13.1333 -                 (map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th)
 13.1334 -                    rel_inject_thms ms, code_nitpicksimp_attrs)]
 13.1335 -                |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
 13.1336 -
 13.1337 -              val notes =
 13.1338 -                [(mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs),
 13.1339 -                 (rel_distinctN, rel_distinct_thms, simp_attrs),
 13.1340 -                 (rel_injectN, rel_inject_thms, simp_attrs),
 13.1341 -                 (setN, flat set_thmss, code_nitpicksimp_attrs @ simp_attrs)]
 13.1342 -                |> massage_simple_notes fp_b_name;
 13.1343 -            in
 13.1344 -              (((map_thms, rel_inject_thms, rel_distinct_thms, set_thmss), ctr_sugar),
 13.1345 -               lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd)
 13.1346 -            end;
 13.1347 -
 13.1348 -        fun mk_binding pre = qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b);
 13.1349 -
 13.1350 -        fun massage_res (((maps_sets_rels, ctr_sugar), co_iter_res), lthy) =
 13.1351 -          (((maps_sets_rels, (ctrs, xss, ctr_defs, ctr_sugar)), co_iter_res), lthy);
 13.1352 -      in
 13.1353 -        (wrap_ctrs
 13.1354 -         #> derive_maps_sets_rels
 13.1355 -         ##>>
 13.1356 -           (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
 13.1357 -            else define_coiters [unfoldN, corecN] (the coiters_args_types))
 13.1358 -             mk_binding fpTs Cs xtor_co_iters
 13.1359 -         #> massage_res, lthy')
 13.1360 -      end;
 13.1361 -
 13.1362 -    fun wrap_types_etc (wrap_types_etcs, lthy) =
 13.1363 -      fold_map I wrap_types_etcs lthy
 13.1364 -      |>> apsnd split_list o apfst (apsnd split_list4 o apfst split_list4 o split_list)
 13.1365 -        o split_list;
 13.1366 -
 13.1367 -    fun mk_simp_thms ({injects, distincts, case_thms, ...} : ctr_sugar) un_folds co_recs
 13.1368 -        mapsx rel_injects rel_distincts setss =
 13.1369 -      injects @ distincts @ case_thms @ co_recs @ un_folds @ mapsx @ rel_injects @ rel_distincts
 13.1370 -      @ flat setss;
 13.1371 -
 13.1372 -    fun derive_note_induct_iters_thms_for_types
 13.1373 -        ((((mapss, rel_injects, rel_distincts, setss), (ctrss, _, ctr_defss, ctr_sugars)),
 13.1374 -          (iterss, iter_defss)), lthy) =
 13.1375 -      let
 13.1376 -        val ((induct_thms, induct_thm, induct_attrs), (fold_thmss, rec_thmss, iter_attrs)) =
 13.1377 -          derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
 13.1378 -            xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss iterss
 13.1379 -            iter_defss lthy;
 13.1380 -
 13.1381 -        val induct_type_attr = Attrib.internal o K o Induct.induct_type;
 13.1382 -
 13.1383 -        val simp_thmss =
 13.1384 -          map7 mk_simp_thms ctr_sugars fold_thmss rec_thmss mapss rel_injects rel_distincts setss;
 13.1385 -
 13.1386 -        val common_notes =
 13.1387 -          (if nn > 1 then [(inductN, [induct_thm], induct_attrs)] else [])
 13.1388 -          |> massage_simple_notes fp_common_name;
 13.1389 -
 13.1390 -        val notes =
 13.1391 -          [(foldN, fold_thmss, K iter_attrs),
 13.1392 -           (inductN, map single induct_thms, fn T_name => induct_attrs @ [induct_type_attr T_name]),
 13.1393 -           (recN, rec_thmss, K iter_attrs),
 13.1394 -           (simpsN, simp_thmss, K [])]
 13.1395 -          |> massage_multi_notes;
 13.1396 -      in
 13.1397 -        lthy
 13.1398 -        |> Local_Theory.notes (common_notes @ notes) |> snd
 13.1399 -        |> register_fp_sugars Least_FP pre_bnfs nested_bnfs nesting_bnfs fp_res ctr_defss ctr_sugars
 13.1400 -          iterss mapss [induct_thm] (transpose [fold_thmss, rec_thmss]) [] []
 13.1401 -      end;
 13.1402 -
 13.1403 -    fun derive_note_coinduct_coiters_thms_for_types
 13.1404 -        ((((mapss, rel_injects, rel_distincts, setss), (_, _, ctr_defss, ctr_sugars)),
 13.1405 -          (coiterss, coiter_defss)), lthy) =
 13.1406 -      let
 13.1407 -        val (([(coinduct_thms, coinduct_thm), (strong_coinduct_thms, strong_coinduct_thm)],
 13.1408 -              coinduct_attrs),
 13.1409 -             (unfold_thmss, corec_thmss, coiter_attrs),
 13.1410 -             (disc_unfold_thmss, disc_corec_thmss, disc_coiter_attrs),
 13.1411 -             (disc_unfold_iff_thmss, disc_corec_iff_thmss, disc_coiter_iff_attrs),
 13.1412 -             (sel_unfold_thmsss, sel_corec_thmsss, sel_coiter_attrs)) =
 13.1413 -          derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
 13.1414 -            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns
 13.1415 -            ctr_defss ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy)
 13.1416 -            lthy;
 13.1417 -
 13.1418 -        val sel_unfold_thmss = map flat sel_unfold_thmsss;
 13.1419 -        val sel_corec_thmss = map flat sel_corec_thmsss;
 13.1420 -
 13.1421 -        val coinduct_type_attr = Attrib.internal o K o Induct.coinduct_type;
 13.1422 -
 13.1423 -        val flat_coiter_thms = append oo append;
 13.1424 -
 13.1425 -        val simp_thmss =
 13.1426 -          map7 mk_simp_thms ctr_sugars
 13.1427 -            (map3 flat_coiter_thms disc_unfold_thmss disc_unfold_iff_thmss sel_unfold_thmss)
 13.1428 -            (map3 flat_coiter_thms disc_corec_thmss disc_corec_iff_thmss sel_corec_thmss)
 13.1429 -            mapss rel_injects rel_distincts setss;
 13.1430 -
 13.1431 -        val common_notes =
 13.1432 -          (if nn > 1 then
 13.1433 -             [(coinductN, [coinduct_thm], coinduct_attrs),
 13.1434 -              (strong_coinductN, [strong_coinduct_thm], coinduct_attrs)]
 13.1435 -           else
 13.1436 -             [])
 13.1437 -          |> massage_simple_notes fp_common_name;
 13.1438 -
 13.1439 -        val notes =
 13.1440 -          [(coinductN, map single coinduct_thms,
 13.1441 -            fn T_name => coinduct_attrs @ [coinduct_type_attr T_name]),
 13.1442 -           (corecN, corec_thmss, K coiter_attrs),
 13.1443 -           (disc_corecN, disc_corec_thmss, K disc_coiter_attrs),
 13.1444 -           (disc_corec_iffN, disc_corec_iff_thmss, K disc_coiter_iff_attrs),
 13.1445 -           (disc_unfoldN, disc_unfold_thmss, K disc_coiter_attrs),
 13.1446 -           (disc_unfold_iffN, disc_unfold_iff_thmss, K disc_coiter_iff_attrs),
 13.1447 -           (sel_corecN, sel_corec_thmss, K sel_coiter_attrs),
 13.1448 -           (sel_unfoldN, sel_unfold_thmss, K sel_coiter_attrs),
 13.1449 -           (simpsN, simp_thmss, K []),
 13.1450 -           (strong_coinductN, map single strong_coinduct_thms, K coinduct_attrs),
 13.1451 -           (unfoldN, unfold_thmss, K coiter_attrs)]
 13.1452 -          |> massage_multi_notes;
 13.1453 -
 13.1454 -        fun is_codatatype (Type (s, _)) =
 13.1455 -            (case fp_sugar_of lthy s of SOME {fp = Greatest_FP, ...} => true | _ => false)
 13.1456 -          | is_codatatype _ = false;
 13.1457 -
 13.1458 -        val nitpick_supported = forall (is_codatatype o T_of_bnf) nested_bnfs;
 13.1459 -
 13.1460 -        fun register_nitpick fpT ({ctrs, casex, ...} : ctr_sugar) =
 13.1461 -          Nitpick_HOL.register_codatatype fpT (fst (dest_Const casex))
 13.1462 -            (map (dest_Const o mk_ctr As) ctrs)
 13.1463 -          |> Generic_Target.theory_declaration;
 13.1464 -      in
 13.1465 -        lthy
 13.1466 -        |> Local_Theory.notes (common_notes @ notes) |> snd
 13.1467 -        |> register_fp_sugars Greatest_FP pre_bnfs nested_bnfs nesting_bnfs fp_res ctr_defss
 13.1468 -          ctr_sugars coiterss mapss [coinduct_thm, strong_coinduct_thm]
 13.1469 -          (transpose [unfold_thmss, corec_thmss]) (transpose [disc_unfold_thmss, disc_corec_thmss])
 13.1470 -          (transpose [sel_unfold_thmsss, sel_corec_thmsss])
 13.1471 -        |> nitpick_supported ? fold2 register_nitpick fpTs ctr_sugars
 13.1472 -      end;
 13.1473 -
 13.1474 -    val lthy'' = lthy'
 13.1475 -      |> fold_map define_ctrs_dtrs_for_type (fp_bnfs ~~ fp_bs ~~ fpTs ~~ ctors ~~ dtors ~~
 13.1476 -        xtor_co_iterss ~~ ctor_dtors ~~ dtor_ctors ~~ ctor_injects ~~ pre_map_defs ~~
 13.1477 -        pre_set_defss ~~ pre_rel_defs ~~ xtor_map_thms ~~ xtor_set_thmss ~~ xtor_rel_thms ~~ ns ~~
 13.1478 -        kss ~~ mss ~~ ctr_bindingss ~~ ctr_mixfixess ~~ ctr_Tsss ~~ disc_bindingss ~~
 13.1479 -        sel_bindingsss ~~ raw_sel_defaultsss)
 13.1480 -      |> wrap_types_etc
 13.1481 -      |> fp_case fp derive_note_induct_iters_thms_for_types
 13.1482 -           derive_note_coinduct_coiters_thms_for_types;
 13.1483 -
 13.1484 -    val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^
 13.1485 -      co_prefix fp ^ "datatype"));
 13.1486 -  in
 13.1487 -    timer; lthy''
 13.1488 -  end;
 13.1489 -
 13.1490 -fun co_datatypes x = define_co_datatypes (K I) (K I) (K I) x;
 13.1491 -
 13.1492 -fun co_datatype_cmd x =
 13.1493 -  define_co_datatypes Typedecl.read_constraint Syntax.parse_typ Syntax.parse_term x;
 13.1494 -
 13.1495 -val parse_ctr_arg =
 13.1496 -  @{keyword "("} |-- parse_binding_colon -- Parse.typ --| @{keyword ")"} ||
 13.1497 -  (Parse.typ >> pair Binding.empty);
 13.1498 -
 13.1499 -val parse_defaults =
 13.1500 -  @{keyword "("} |-- Parse.reserved "defaults" |-- Scan.repeat parse_bound_term --| @{keyword ")"};
 13.1501 -
 13.1502 -val parse_type_arg_constrained =
 13.1503 -  Parse.type_ident -- Scan.option (@{keyword "::"} |-- Parse.!!! Parse.sort);
 13.1504 -
 13.1505 -val parse_type_arg_named_constrained = parse_opt_binding_colon -- parse_type_arg_constrained;
 13.1506 -
 13.1507 -(*FIXME: use parse_type_args_named_constrained from BNF_Util and thus 
 13.1508 -  allow users to kill certain arguments of a (co)datatype*)
 13.1509 -val parse_type_args_named_constrained =
 13.1510 -  parse_type_arg_constrained >> (single o pair Binding.empty) ||
 13.1511 -  @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
 13.1512 -  Scan.succeed [];
 13.1513 -
 13.1514 -val parse_ctr_spec =
 13.1515 -  parse_opt_binding_colon -- parse_binding -- Scan.repeat parse_ctr_arg --
 13.1516 -  Scan.optional parse_defaults [] -- Parse.opt_mixfix;
 13.1517 -
 13.1518 -val parse_spec =
 13.1519 -  parse_type_args_named_constrained -- parse_binding -- parse_map_rel_bindings --
 13.1520 -  Parse.opt_mixfix -- (@{keyword "="} |-- Parse.enum1 "|" parse_ctr_spec);
 13.1521 -
 13.1522 -val parse_co_datatype = parse_wrap_free_constructors_options -- Parse.and_list1 parse_spec;
 13.1523 -
 13.1524 -fun parse_co_datatype_cmd fp construct_fp = parse_co_datatype >> co_datatype_cmd fp construct_fp;
 13.1525 -
 13.1526 -end;
    14.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,181 +0,0 @@
    14.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML
    14.5 -    Author:     Jasmin Blanchette, TU Muenchen
    14.6 -    Copyright   2012
    14.7 -
    14.8 -Tactics for datatype and codatatype sugar.
    14.9 -*)
   14.10 -
   14.11 -signature BNF_FP_DEF_SUGAR_TACTICS =
   14.12 -sig
   14.13 -  val sum_prod_thms_map: thm list
   14.14 -  val sum_prod_thms_set: thm list
   14.15 -  val sum_prod_thms_rel: thm list
   14.16 -
   14.17 -  val mk_coinduct_tac: Proof.context -> thm list -> int -> int list -> thm -> thm list ->
   14.18 -    thm list -> thm list -> thm list list -> thm list list list -> thm list list list -> tactic
   14.19 -  val mk_coiter_tac: thm list -> thm list -> thm -> thm -> thm -> Proof.context -> tactic
   14.20 -  val mk_ctor_iff_dtor_tac: Proof.context -> ctyp option list -> cterm -> cterm -> thm -> thm ->
   14.21 -    tactic
   14.22 -  val mk_disc_coiter_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic
   14.23 -  val mk_exhaust_tac: Proof.context -> int -> thm list -> thm -> thm -> tactic
   14.24 -  val mk_half_distinct_tac: Proof.context -> thm -> thm list -> tactic
   14.25 -  val mk_induct_tac: Proof.context -> int -> int list -> int list list -> int list list list ->
   14.26 -    thm list -> thm -> thm list -> thm list list -> tactic
   14.27 -  val mk_inject_tac: Proof.context -> thm -> thm -> tactic
   14.28 -  val mk_iter_tac: thm list -> thm list -> thm list -> thm -> thm -> Proof.context -> tactic
   14.29 -end;
   14.30 -
   14.31 -structure BNF_FP_Def_Sugar_Tactics : BNF_FP_DEF_SUGAR_TACTICS =
   14.32 -struct
   14.33 -
   14.34 -open BNF_Tactics
   14.35 -open BNF_Util
   14.36 -open BNF_FP_Util
   14.37 -
   14.38 -val basic_simp_thms = @{thms simp_thms(7,8,12,14,22,24)};
   14.39 -val more_simp_thms = basic_simp_thms @ @{thms simp_thms(11,15,16,21)};
   14.40 -
   14.41 -val sum_prod_thms_map = @{thms id_apply map_pair_simp prod.cases sum.cases sum_map.simps};
   14.42 -val sum_prod_thms_set0 =
   14.43 -  @{thms SUP_empty Sup_empty Sup_insert UN_insert Un_empty_left Un_empty_right Un_iff
   14.44 -      Union_Un_distrib collect_def[abs_def] image_def o_apply map_pair_simp
   14.45 -      mem_Collect_eq mem_UN_compreh_eq prod_set_simps sum_map.simps sum_set_simps};
   14.46 -val sum_prod_thms_set = @{thms UN_compreh_eq_eq} @ sum_prod_thms_set0;
   14.47 -val sum_prod_thms_rel = @{thms prod_rel_simp sum_rel_simps id_apply};
   14.48 -
   14.49 -fun hhf_concl_conv cv ctxt ct =
   14.50 -  (case Thm.term_of ct of
   14.51 -    Const (@{const_name all}, _) $ Abs _ =>
   14.52 -    Conv.arg_conv (Conv.abs_conv (hhf_concl_conv cv o snd) ctxt) ct
   14.53 -  | _ => Conv.concl_conv ~1 cv ct);
   14.54 -
   14.55 -fun co_induct_inst_as_projs ctxt k thm =
   14.56 -  let
   14.57 -    val fs = Term.add_vars (prop_of thm) []
   14.58 -      |> filter (fn (_, Type (@{type_name fun}, [_, T'])) => T' <> HOLogic.boolT | _ => false);
   14.59 -    fun mk_cfp (f as (_, T)) =
   14.60 -      (certify ctxt (Var f), certify ctxt (mk_proj T (num_binder_types T) k));
   14.61 -    val cfps = map mk_cfp fs;
   14.62 -  in
   14.63 -    Drule.cterm_instantiate cfps thm
   14.64 -  end;
   14.65 -
   14.66 -val co_induct_inst_as_projs_tac = PRIMITIVE oo co_induct_inst_as_projs;
   14.67 -
   14.68 -fun mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor sumEN' =
   14.69 -  unfold_thms_tac ctxt (ctor_iff_dtor :: ctr_defs) THEN HEADGOAL (rtac sumEN') THEN
   14.70 -  unfold_thms_tac ctxt @{thms split_paired_all} THEN
   14.71 -  HEADGOAL (EVERY' (maps (fn k => [select_prem_tac n (rotate_tac 1) k,
   14.72 -    REPEAT_DETERM o dtac meta_spec, etac meta_mp, atac]) (1 upto n)));
   14.73 -
   14.74 -fun mk_ctor_iff_dtor_tac ctxt cTs cctor cdtor ctor_dtor dtor_ctor =
   14.75 -  HEADGOAL (rtac iffI THEN'
   14.76 -    EVERY' (map3 (fn cTs => fn cx => fn th =>
   14.77 -      dtac (Drule.instantiate' cTs [NONE, NONE, SOME cx] arg_cong) THEN'
   14.78 -      SELECT_GOAL (unfold_thms_tac ctxt [th]) THEN'
   14.79 -      atac) [rev cTs, cTs] [cdtor, cctor] [dtor_ctor, ctor_dtor]));
   14.80 -
   14.81 -fun mk_half_distinct_tac ctxt ctor_inject ctr_defs =
   14.82 -  unfold_thms_tac ctxt (ctor_inject :: @{thms sum.inject} @ ctr_defs) THEN
   14.83 -  HEADGOAL (rtac @{thm sum.distinct(1)});
   14.84 -
   14.85 -fun mk_inject_tac ctxt ctr_def ctor_inject =
   14.86 -  unfold_thms_tac ctxt [ctr_def] THEN HEADGOAL (rtac (ctor_inject RS ssubst)) THEN
   14.87 -  unfold_thms_tac ctxt @{thms sum.inject Pair_eq conj_assoc} THEN HEADGOAL (rtac refl);
   14.88 -
   14.89 -val iter_unfold_thms =
   14.90 -  @{thms comp_def convol_def fst_conv id_def prod_case_Pair_iden snd_conv
   14.91 -      split_conv unit_case_Unity} @ sum_prod_thms_map;
   14.92 -
   14.93 -fun mk_iter_tac pre_map_defs map_idents iter_defs ctor_iter ctr_def ctxt =
   14.94 -  unfold_thms_tac ctxt (ctr_def :: ctor_iter :: iter_defs @ pre_map_defs @ map_idents @
   14.95 -    iter_unfold_thms) THEN HEADGOAL (rtac refl);
   14.96 -
   14.97 -val coiter_unfold_thms = @{thms id_def} @ sum_prod_thms_map;
   14.98 -val ss_if_True_False = simpset_of (ss_only @{thms if_True if_False} @{context});
   14.99 -
  14.100 -fun mk_coiter_tac coiter_defs map_idents ctor_dtor_coiter pre_map_def ctr_def ctxt =
  14.101 -  unfold_thms_tac ctxt (ctr_def :: coiter_defs) THEN
  14.102 -  HEADGOAL (rtac (ctor_dtor_coiter RS trans) THEN'
  14.103 -    asm_simp_tac (put_simpset ss_if_True_False ctxt)) THEN_MAYBE
  14.104 -  (unfold_thms_tac ctxt (pre_map_def :: map_idents @ coiter_unfold_thms) THEN
  14.105 -   HEADGOAL (rtac refl ORELSE' rtac (@{thm unit_eq} RS arg_cong)));
  14.106 -
  14.107 -fun mk_disc_coiter_iff_tac case_splits' coiters discs ctxt =
  14.108 -  EVERY (map3 (fn case_split_tac => fn coiter_thm => fn disc =>
  14.109 -      HEADGOAL case_split_tac THEN unfold_thms_tac ctxt [coiter_thm] THEN
  14.110 -      HEADGOAL (asm_simp_tac (ss_only basic_simp_thms ctxt)) THEN
  14.111 -      (if is_refl disc then all_tac else HEADGOAL (rtac disc)))
  14.112 -    (map rtac case_splits' @ [K all_tac]) coiters discs);
  14.113 -
  14.114 -fun solve_prem_prem_tac ctxt =
  14.115 -  REPEAT o (eresolve_tac @{thms bexE rev_bexI} ORELSE' rtac @{thm rev_bexI[OF UNIV_I]} ORELSE'
  14.116 -    hyp_subst_tac ctxt ORELSE' resolve_tac @{thms disjI1 disjI2}) THEN'
  14.117 -  (rtac refl ORELSE' atac ORELSE' rtac @{thm singletonI});
  14.118 -
  14.119 -fun mk_induct_leverage_prem_prems_tac ctxt nn kks set_maps pre_set_defs =
  14.120 -  HEADGOAL (EVERY' (maps (fn kk => [select_prem_tac nn (dtac meta_spec) kk, etac meta_mp,
  14.121 -    SELECT_GOAL (unfold_thms_tac ctxt (pre_set_defs @ set_maps @ sum_prod_thms_set0)),
  14.122 -    solve_prem_prem_tac ctxt]) (rev kks)));
  14.123 -
  14.124 -fun mk_induct_discharge_prem_tac ctxt nn n set_maps pre_set_defs m k kks =
  14.125 -  let val r = length kks in
  14.126 -    HEADGOAL (EVERY' [select_prem_tac n (rotate_tac 1) k, rotate_tac ~1, hyp_subst_tac ctxt,
  14.127 -      REPEAT_DETERM_N m o (dtac meta_spec THEN' rotate_tac ~1)]) THEN
  14.128 -    EVERY [REPEAT_DETERM_N r
  14.129 -        (HEADGOAL (rotate_tac ~1 THEN' dtac meta_mp THEN' rotate_tac 1) THEN prefer_tac 2),
  14.130 -      if r > 0 then ALLGOALS (Goal.norm_hhf_tac ctxt) else all_tac, HEADGOAL atac,
  14.131 -      mk_induct_leverage_prem_prems_tac ctxt nn kks set_maps pre_set_defs]
  14.132 -  end;
  14.133 -
  14.134 -fun mk_induct_tac ctxt nn ns mss kkss ctr_defs ctor_induct' set_maps pre_set_defss =
  14.135 -  let val n = Integer.sum ns in
  14.136 -    unfold_thms_tac ctxt ctr_defs THEN HEADGOAL (rtac ctor_induct') THEN
  14.137 -    co_induct_inst_as_projs_tac ctxt 0 THEN
  14.138 -    EVERY (map4 (EVERY oooo map3 o mk_induct_discharge_prem_tac ctxt nn n set_maps) pre_set_defss
  14.139 -      mss (unflat mss (1 upto n)) kkss)
  14.140 -  end;
  14.141 -
  14.142 -fun mk_coinduct_same_ctr_tac ctxt rel_eqs pre_rel_def dtor_ctor ctr_def discs sels =
  14.143 -  hyp_subst_tac ctxt THEN'
  14.144 -  CONVERSION (hhf_concl_conv
  14.145 -    (Conv.top_conv (K (Conv.try_conv (Conv.rewr_conv ctr_def))) ctxt) ctxt) THEN'
  14.146 -  SELECT_GOAL (unfold_thms_tac ctxt (pre_rel_def :: dtor_ctor :: sels)) THEN'
  14.147 -  SELECT_GOAL (unfold_thms_tac ctxt (pre_rel_def :: dtor_ctor :: sels @ sum_prod_thms_rel)) THEN'
  14.148 -  (atac ORELSE' REPEAT o etac conjE THEN'
  14.149 -     full_simp_tac
  14.150 -       (ss_only (@{thm prod.inject} :: no_refl discs @ rel_eqs @ more_simp_thms) ctxt) THEN'
  14.151 -     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN'
  14.152 -     REPEAT o (resolve_tac [refl, conjI] ORELSE' atac));
  14.153 -
  14.154 -fun mk_coinduct_distinct_ctrs_tac ctxt discs discs' =
  14.155 -  let
  14.156 -    val discs'' = map (perhaps (try (fn th => th RS @{thm notnotD}))) (discs @ discs')
  14.157 -      |> distinct Thm.eq_thm_prop;
  14.158 -  in
  14.159 -    hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
  14.160 -    full_simp_tac (ss_only (refl :: no_refl discs'' @ basic_simp_thms) ctxt)
  14.161 -  end;
  14.162 -
  14.163 -fun mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn kk n pre_rel_def dtor_ctor exhaust ctr_defs
  14.164 -    discss selss =
  14.165 -  let val ks = 1 upto n in
  14.166 -    EVERY' ([rtac allI, rtac allI, rtac impI, select_prem_tac nn (dtac meta_spec) kk,
  14.167 -        dtac meta_spec, dtac meta_mp, atac, rtac exhaust, K (co_induct_inst_as_projs_tac ctxt 0),
  14.168 -        hyp_subst_tac ctxt] @
  14.169 -      map4 (fn k => fn ctr_def => fn discs => fn sels =>
  14.170 -        EVERY' ([rtac exhaust, K (co_induct_inst_as_projs_tac ctxt 1)] @
  14.171 -          map2 (fn k' => fn discs' =>
  14.172 -            if k' = k then
  14.173 -              mk_coinduct_same_ctr_tac ctxt rel_eqs' pre_rel_def dtor_ctor ctr_def discs sels
  14.174 -            else
  14.175 -              mk_coinduct_distinct_ctrs_tac ctxt discs discs') ks discss)) ks ctr_defs discss selss)
  14.176 -  end;
  14.177 -
  14.178 -fun mk_coinduct_tac ctxt rel_eqs' nn ns dtor_coinduct' pre_rel_defs dtor_ctors exhausts ctr_defss
  14.179 -    discsss selsss =
  14.180 -  HEADGOAL (rtac dtor_coinduct' THEN'
  14.181 -    EVERY' (map8 (mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn)
  14.182 -      (1 upto nn) ns pre_rel_defs dtor_ctors exhausts ctr_defss discsss selsss));
  14.183 -
  14.184 -end;
    15.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m.ML	Mon Jan 20 18:24:55 2014 +0100
    15.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.3 @@ -1,378 +0,0 @@
    15.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_n2m.ML
    15.5 -    Author:     Dmitriy Traytel, TU Muenchen
    15.6 -    Copyright   2013
    15.7 -
    15.8 -Flattening of nested to mutual (co)recursion.
    15.9 -*)
   15.10 -
   15.11 -signature BNF_FP_N2M =
   15.12 -sig
   15.13 -  val construct_mutualized_fp: BNF_FP_Util.fp_kind  -> typ list -> BNF_FP_Def_Sugar.fp_sugar list ->
   15.14 -    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
   15.15 -    local_theory -> BNF_FP_Util.fp_result * local_theory
   15.16 -end;
   15.17 -
   15.18 -structure BNF_FP_N2M : BNF_FP_N2M =
   15.19 -struct
   15.20 -
   15.21 -open BNF_Def
   15.22 -open BNF_Util
   15.23 -open BNF_FP_Util
   15.24 -open BNF_FP_Def_Sugar
   15.25 -open BNF_Tactics
   15.26 -open BNF_FP_N2M_Tactics
   15.27 -
   15.28 -fun force_typ ctxt T =
   15.29 -  map_types Type_Infer.paramify_vars
   15.30 -  #> Type.constraint T
   15.31 -  #> Syntax.check_term ctxt
   15.32 -  #> singleton (Variable.polymorphic ctxt);
   15.33 -
   15.34 -fun mk_prod_map f g =
   15.35 -  let
   15.36 -    val ((fAT, fBT), fT) = `dest_funT (fastype_of f);
   15.37 -    val ((gAT, gBT), gT) = `dest_funT (fastype_of g);
   15.38 -  in
   15.39 -    Const (@{const_name map_pair},
   15.40 -      fT --> gT --> HOLogic.mk_prodT (fAT, gAT) --> HOLogic.mk_prodT (fBT, gBT)) $ f $ g
   15.41 -  end;
   15.42 -
   15.43 -fun mk_sum_map f g =
   15.44 -  let
   15.45 -    val ((fAT, fBT), fT) = `dest_funT (fastype_of f);
   15.46 -    val ((gAT, gBT), gT) = `dest_funT (fastype_of g);
   15.47 -  in
   15.48 -    Const (@{const_name sum_map}, fT --> gT --> mk_sumT (fAT, gAT) --> mk_sumT (fBT, gBT)) $ f $ g
   15.49 -  end;
   15.50 -
   15.51 -fun construct_mutualized_fp fp fpTs fp_sugars bs resBs (resDs, Dss) bnfs lthy =
   15.52 -  let
   15.53 -    fun steal get = map (of_fp_sugar (get o #fp_res)) fp_sugars;
   15.54 -
   15.55 -    val n = length bnfs;
   15.56 -    val deads = fold (union (op =)) Dss resDs;
   15.57 -    val As = subtract (op =) deads (map TFree resBs);
   15.58 -    val names_lthy = fold Variable.declare_typ (As @ deads) lthy;
   15.59 -    val m = length As;
   15.60 -    val live = m + n;
   15.61 -    val ((Xs, Bs), names_lthy) = names_lthy
   15.62 -      |> mk_TFrees n
   15.63 -      ||>> mk_TFrees m;
   15.64 -    val allAs = As @ Xs;
   15.65 -    val phiTs = map2 mk_pred2T As Bs;
   15.66 -    val theta = As ~~ Bs;
   15.67 -    val fpTs' = map (Term.typ_subst_atomic theta) fpTs;
   15.68 -    val pre_phiTs = map2 mk_pred2T fpTs fpTs';
   15.69 -
   15.70 -    fun mk_co_algT T U = fp_case fp (T --> U) (U --> T);
   15.71 -    fun co_swap pair = fp_case fp I swap pair;
   15.72 -    val dest_co_algT = co_swap o dest_funT;
   15.73 -    val co_alg_argT = fp_case fp range_type domain_type;
   15.74 -    val co_alg_funT = fp_case fp domain_type range_type;
   15.75 -    val mk_co_product = curry (fp_case fp mk_convol mk_sum_case);
   15.76 -    val mk_map_co_product = fp_case fp mk_prod_map mk_sum_map;
   15.77 -    val co_proj1_const = fp_case fp (fst_const o fst) (uncurry Inl_const o dest_sumT o snd);
   15.78 -    val mk_co_productT = curry (fp_case fp HOLogic.mk_prodT mk_sumT);
   15.79 -    val dest_co_productT = fp_case fp HOLogic.dest_prodT dest_sumT;
   15.80 -
   15.81 -    val ((ctors, dtors), (xtor's, xtors)) =
   15.82 -      let
   15.83 -        val ctors = map2 (force_typ names_lthy o (fn T => dummyT --> T)) fpTs (steal #ctors);
   15.84 -        val dtors = map2 (force_typ names_lthy o (fn T => T --> dummyT)) fpTs (steal #dtors);
   15.85 -      in
   15.86 -        ((ctors, dtors), `(map (Term.subst_atomic_types theta)) (fp_case fp ctors dtors))
   15.87 -      end;
   15.88 -
   15.89 -    val xTs = map (domain_type o fastype_of) xtors;
   15.90 -    val yTs = map (domain_type o fastype_of) xtor's;
   15.91 -
   15.92 -    val (((((phis, phis'), pre_phis), xs), ys), names_lthy) = names_lthy
   15.93 -      |> mk_Frees' "R" phiTs
   15.94 -      ||>> mk_Frees "S" pre_phiTs
   15.95 -      ||>> mk_Frees "x" xTs
   15.96 -      ||>> mk_Frees "y" yTs;
   15.97 -
   15.98 -    val fp_bnfs = steal #bnfs;
   15.99 -    val pre_bnfs = map (of_fp_sugar #pre_bnfs) fp_sugars;
  15.100 -    val pre_bnfss = map #pre_bnfs fp_sugars;
  15.101 -    val nesty_bnfss = map (fn sugar => #nested_bnfs sugar @ #nesting_bnfs sugar) fp_sugars;
  15.102 -    val fp_nesty_bnfss = fp_bnfs :: nesty_bnfss;
  15.103 -    val fp_nesty_bnfs = distinct eq_bnf (flat fp_nesty_bnfss);
  15.104 -
  15.105 -    val rels =
  15.106 -      let
  15.107 -        fun find_rel T As Bs = fp_nesty_bnfss
  15.108 -          |> map (filter_out (curry eq_bnf BNF_Comp.DEADID_bnf))
  15.109 -          |> get_first (find_first (fn bnf => Type.could_unify (T_of_bnf bnf, T)))
  15.110 -          |> Option.map (fn bnf =>
  15.111 -            let val live = live_of_bnf bnf;
  15.112 -            in (mk_rel live As Bs (rel_of_bnf bnf), live) end)
  15.113 -          |> the_default (HOLogic.eq_const T, 0);
  15.114 -
  15.115 -        fun mk_rel (T as Type (_, Ts)) (Type (_, Us)) =
  15.116 -              let
  15.117 -                val (rel, live) = find_rel T Ts Us;
  15.118 -                val (Ts', Us') = fastype_of rel |> strip_typeN live |> fst |> map_split dest_pred2T;
  15.119 -                val rels = map2 mk_rel Ts' Us';
  15.120 -              in
  15.121 -                Term.list_comb (rel, rels)
  15.122 -              end
  15.123 -          | mk_rel (T as TFree _) _ = (nth phis (find_index (curry op = T) As)
  15.124 -              handle General.Subscript => HOLogic.eq_const T)
  15.125 -          | mk_rel _ _ = raise Fail "fpTs contains schematic type variables";
  15.126 -      in
  15.127 -        map2 (fold_rev Term.absfree phis' oo mk_rel) fpTs fpTs'
  15.128 -      end;
  15.129 -
  15.130 -    val pre_rels = map2 (fn Ds => mk_rel_of_bnf Ds (As @ fpTs) (Bs @ fpTs')) Dss bnfs;
  15.131 -
  15.132 -    val rel_unfoldss = map (maps (fn bnf => no_refl [rel_def_of_bnf bnf])) pre_bnfss;
  15.133 -    val rel_xtor_co_inducts = steal (split_conj_thm o #rel_xtor_co_induct_thm)
  15.134 -      |> map2 (fn unfs => unfold_thms lthy (id_apply :: unfs)) rel_unfoldss;
  15.135 -
  15.136 -    val rel_defs = map rel_def_of_bnf bnfs;
  15.137 -    val rel_monos = map rel_mono_of_bnf bnfs;
  15.138 -
  15.139 -    val rel_xtor_co_induct_thm =
  15.140 -      mk_rel_xtor_co_induct_thm fp pre_rels pre_phis rels phis xs ys xtors xtor's
  15.141 -        (mk_rel_xtor_co_induct_tactic fp rel_xtor_co_inducts rel_defs rel_monos) lthy;
  15.142 -
  15.143 -    val rel_eqs = no_refl (map rel_eq_of_bnf fp_nesty_bnfs);
  15.144 -    val map_id0s = no_refl (map map_id0_of_bnf bnfs);
  15.145 -
  15.146 -    val xtor_co_induct_thm =
  15.147 -      (case fp of
  15.148 -        Least_FP =>
  15.149 -          let
  15.150 -            val (Ps, names_lthy) = names_lthy
  15.151 -              |> mk_Frees "P" (map (fn T => T --> HOLogic.boolT) fpTs);
  15.152 -            fun mk_Grp_id P =
  15.153 -              let val T = domain_type (fastype_of P);
  15.154 -              in mk_Grp (HOLogic.Collect_const T $ P) (HOLogic.id_const T) end;
  15.155 -            val cts = map (SOME o certify lthy) (map HOLogic.eq_const As @ map mk_Grp_id Ps);
  15.156 -          in
  15.157 -            cterm_instantiate_pos cts rel_xtor_co_induct_thm
  15.158 -            |> singleton (Proof_Context.export names_lthy lthy)
  15.159 -            |> unfold_thms lthy (@{thms eq_le_Grp_id_iff all_simps(1,2)[symmetric]} @ rel_eqs)
  15.160 -            |> funpow n (fn thm => thm RS spec)
  15.161 -            |> unfold_thms lthy (@{thm eq_alt} :: map rel_Grp_of_bnf bnfs @ map_id0s)
  15.162 -            |> unfold_thms lthy @{thms Grp_id_mono_subst eqTrueI[OF subset_UNIV] simp_thms(22)}
  15.163 -            |> unfold_thms lthy @{thms subset_iff mem_Collect_eq
  15.164 -               atomize_conjL[symmetric] atomize_all[symmetric] atomize_imp[symmetric]}
  15.165 -            |> unfold_thms lthy (maps set_defs_of_bnf bnfs)
  15.166 -          end
  15.167 -      | Greatest_FP =>
  15.168 -          let
  15.169 -            val cts = NONE :: map (SOME o certify lthy) (map HOLogic.eq_const As);
  15.170 -          in
  15.171 -            cterm_instantiate_pos cts rel_xtor_co_induct_thm
  15.172 -            |> unfold_thms lthy (@{thms le_fun_def le_bool_def all_simps(1,2)[symmetric]} @ rel_eqs)
  15.173 -            |> funpow (2 * n) (fn thm => thm RS spec)
  15.174 -            |> Conv.fconv_rule (Object_Logic.atomize lthy)
  15.175 -            |> funpow n (fn thm => thm RS mp)
  15.176 -          end);
  15.177 -
  15.178 -    val fold_preTs = map2 (fn Ds => mk_T_of_bnf Ds allAs) Dss bnfs;
  15.179 -    val fold_pre_deads_only_Ts = map2 (fn Ds => mk_T_of_bnf Ds (replicate live dummyT)) Dss bnfs;
  15.180 -    val rec_theta = Xs ~~ map2 mk_co_productT fpTs Xs;
  15.181 -    val rec_preTs = map (Term.typ_subst_atomic rec_theta) fold_preTs;
  15.182 -
  15.183 -    val fold_strTs = map2 mk_co_algT fold_preTs Xs;
  15.184 -    val rec_strTs = map2 mk_co_algT rec_preTs Xs;
  15.185 -    val resTs = map2 mk_co_algT fpTs Xs;
  15.186 -
  15.187 -    val (((fold_strs, fold_strs'), (rec_strs, rec_strs')), names_lthy) = names_lthy
  15.188 -      |> mk_Frees' "s" fold_strTs
  15.189 -      ||>> mk_Frees' "s" rec_strTs;
  15.190 -
  15.191 -    val co_iters = steal #xtor_co_iterss;
  15.192 -    val ns = map (length o #pre_bnfs) fp_sugars;
  15.193 -    fun substT rho (Type (@{type_name "fun"}, [T, U])) = substT rho T --> substT rho U
  15.194 -      | substT rho (Type (s, Ts)) = Type (s, map (typ_subst_nonatomic rho) Ts)
  15.195 -      | substT _ T = T;
  15.196 -    fun force_iter is_rec i TU TU_rec raw_iters =
  15.197 -      let
  15.198 -        val approx_fold = un_fold_of raw_iters
  15.199 -          |> force_typ names_lthy
  15.200 -            (replicate (nth ns i) dummyT ---> (if is_rec then TU_rec else TU));
  15.201 -        val TUs = binder_fun_types (Term.typ_subst_atomic (Xs ~~ fpTs) (fastype_of approx_fold));
  15.202 -        val js = find_indices Type.could_unify
  15.203 -          TUs (map (Term.typ_subst_atomic (Xs ~~ fpTs)) fold_strTs);
  15.204 -        val Tpats = map (fn j => mk_co_algT (nth fold_pre_deads_only_Ts j) (nth Xs j)) js;
  15.205 -        val iter = raw_iters |> (if is_rec then co_rec_of else un_fold_of);
  15.206 -      in
  15.207 -        force_typ names_lthy (Tpats ---> TU) iter
  15.208 -      end;
  15.209 -
  15.210 -    fun mk_iter b_opt is_rec iters lthy TU =
  15.211 -      let
  15.212 -        val x = co_alg_argT TU;
  15.213 -        val i = find_index (fn T => x = T) Xs;
  15.214 -        val TUiter =
  15.215 -          (case find_first (fn f => body_fun_type (fastype_of f) = TU) iters of
  15.216 -            NONE => nth co_iters i
  15.217 -              |> force_iter is_rec i
  15.218 -                (TU |> (is_none b_opt andalso not is_rec) ? substT (fpTs ~~ Xs))
  15.219 -                (TU |> (is_none b_opt) ? substT (map2 mk_co_productT fpTs Xs ~~ Xs))
  15.220 -          | SOME f => f);
  15.221 -        val TUs = binder_fun_types (fastype_of TUiter);
  15.222 -        val iter_preTs = if is_rec then rec_preTs else fold_preTs;
  15.223 -        val iter_strs = if is_rec then rec_strs else fold_strs;
  15.224 -        fun mk_s TU' =
  15.225 -          let
  15.226 -            val i = find_index (fn T => co_alg_argT TU' = T) Xs;
  15.227 -            val sF = co_alg_funT TU';
  15.228 -            val F = nth iter_preTs i;
  15.229 -            val s = nth iter_strs i;
  15.230 -          in
  15.231 -            (if sF = F then s
  15.232 -            else
  15.233 -              let
  15.234 -                val smapT = replicate live dummyT ---> mk_co_algT sF F;
  15.235 -                fun hidden_to_unit t =
  15.236 -                  Term.subst_TVars (map (rpair HOLogic.unitT) (Term.add_tvar_names t [])) t;
  15.237 -                val smap = map_of_bnf (nth bnfs i)
  15.238 -                  |> force_typ names_lthy smapT
  15.239 -                  |> hidden_to_unit;
  15.240 -                val smap_argTs = strip_typeN live (fastype_of smap) |> fst;
  15.241 -                fun mk_smap_arg TU =
  15.242 -                  (if domain_type TU = range_type TU then
  15.243 -                    HOLogic.id_const (domain_type TU)
  15.244 -                  else if is_rec then
  15.245 -                    let
  15.246 -                      val (TY, (U, X)) = TU |> dest_co_algT ||> dest_co_productT;
  15.247 -                      val T = mk_co_algT TY U;
  15.248 -                    in
  15.249 -                      (case try (force_typ lthy T o build_map lthy co_proj1_const o dest_funT) T of
  15.250 -                        SOME f => mk_co_product f
  15.251 -                          (fst (fst (mk_iter NONE is_rec iters lthy (mk_co_algT TY X))))
  15.252 -                      | NONE => mk_map_co_product
  15.253 -                          (build_map lthy co_proj1_const
  15.254 -                            (dest_funT (mk_co_algT (dest_co_productT TY |> fst) U)))
  15.255 -                          (HOLogic.id_const X))
  15.256 -                    end
  15.257 -                  else
  15.258 -                    fst (fst (mk_iter NONE is_rec iters lthy TU)))
  15.259 -                val smap_args = map mk_smap_arg smap_argTs;
  15.260 -              in
  15.261 -                HOLogic.mk_comp (co_swap (s, Term.list_comb (smap, smap_args)))
  15.262 -              end)
  15.263 -          end;
  15.264 -        val t = Term.list_comb (TUiter, map mk_s TUs);
  15.265 -      in
  15.266 -        (case b_opt of
  15.267 -          NONE => ((t, Drule.dummy_thm), lthy)
  15.268 -        | SOME b => Local_Theory.define ((b, NoSyn), ((Binding.conceal (Thm.def_binding b), []),
  15.269 -            fold_rev Term.absfree (if is_rec then rec_strs' else fold_strs') t)) lthy |>> apsnd snd)
  15.270 -      end;
  15.271 -
  15.272 -    fun mk_iters is_rec name lthy =
  15.273 -      fold2 (fn TU => fn b => fn ((iters, defs), lthy) =>
  15.274 -        mk_iter (SOME b) is_rec iters lthy TU |>> (fn (f, d) => (f :: iters, d :: defs)))
  15.275 -      resTs (map (Binding.suffix_name ("_" ^ name)) bs) (([], []), lthy)
  15.276 -      |>> apfst rev o apsnd rev;
  15.277 -    val foldN = fp_case fp ctor_foldN dtor_unfoldN;
  15.278 -    val recN = fp_case fp ctor_recN dtor_corecN;
  15.279 -    val (((raw_un_folds, raw_un_fold_defs), (raw_co_recs, raw_co_rec_defs)), (lthy, raw_lthy)) =
  15.280 -      lthy
  15.281 -      |> mk_iters false foldN
  15.282 -      ||>> mk_iters true recN
  15.283 -      ||> `Local_Theory.restore;
  15.284 -
  15.285 -    val phi = Proof_Context.export_morphism raw_lthy lthy;
  15.286 -
  15.287 -    val un_folds = map (Morphism.term phi) raw_un_folds;
  15.288 -    val co_recs = map (Morphism.term phi) raw_co_recs;
  15.289 -
  15.290 -    val (xtor_un_fold_thms, xtor_co_rec_thms) =
  15.291 -      let
  15.292 -        val folds = map (fn f => Term.list_comb (f, fold_strs)) raw_un_folds;
  15.293 -        val recs = map (fn r => Term.list_comb (r, rec_strs)) raw_co_recs;
  15.294 -        val fold_mapTs = co_swap (As @ fpTs, As @ Xs);
  15.295 -        val rec_mapTs = co_swap (As @ fpTs, As @ map2 mk_co_productT fpTs Xs);
  15.296 -        val pre_fold_maps =
  15.297 -          map2 (fn Ds => fn bnf =>
  15.298 -            Term.list_comb (uncurry (mk_map_of_bnf Ds) fold_mapTs bnf,
  15.299 -              map HOLogic.id_const As @ folds))
  15.300 -          Dss bnfs;
  15.301 -        val pre_rec_maps =
  15.302 -          map2 (fn Ds => fn bnf =>
  15.303 -            Term.list_comb (uncurry (mk_map_of_bnf Ds) rec_mapTs bnf,
  15.304 -              map HOLogic.id_const As @ map2 (mk_co_product o HOLogic.id_const) fpTs recs))
  15.305 -          Dss bnfs;
  15.306 -
  15.307 -        fun mk_goals f xtor s smap =
  15.308 -          ((f, xtor), (s, smap))
  15.309 -          |> pairself (HOLogic.mk_comp o co_swap)
  15.310 -          |> HOLogic.mk_eq;
  15.311 -
  15.312 -        val fold_goals = map4 mk_goals folds xtors fold_strs pre_fold_maps
  15.313 -        val rec_goals = map4 mk_goals recs xtors rec_strs pre_rec_maps;
  15.314 -
  15.315 -        fun mk_thms ss goals tac =
  15.316 -          Library.foldr1 HOLogic.mk_conj goals
  15.317 -          |> HOLogic.mk_Trueprop
  15.318 -          |> fold_rev Logic.all ss
  15.319 -          |> (fn goal => Goal.prove_sorry raw_lthy [] [] goal tac)
  15.320 -          |> Thm.close_derivation
  15.321 -          |> Morphism.thm phi
  15.322 -          |> split_conj_thm
  15.323 -          |> map (fn thm => thm RS @{thm comp_eq_dest});
  15.324 -
  15.325 -        val pre_map_defs = no_refl (map map_def_of_bnf bnfs);
  15.326 -        val fp_pre_map_defs = no_refl (map map_def_of_bnf pre_bnfs);
  15.327 -
  15.328 -        val map_unfoldss = map (maps (fn bnf => no_refl [map_def_of_bnf bnf])) pre_bnfss;
  15.329 -        val unfold_map = map2 (fn unfs => unfold_thms lthy (id_apply :: unfs)) map_unfoldss;
  15.330 -
  15.331 -        val fp_xtor_co_iterss = steal #xtor_co_iter_thmss;
  15.332 -        val fp_xtor_un_folds = map (mk_pointfree lthy o un_fold_of) fp_xtor_co_iterss |> unfold_map;
  15.333 -        val fp_xtor_co_recs = map (mk_pointfree lthy o co_rec_of) fp_xtor_co_iterss |> unfold_map;
  15.334 -
  15.335 -        val fp_co_iter_o_mapss = steal #xtor_co_iter_o_map_thmss;
  15.336 -        val fp_fold_o_maps = map un_fold_of fp_co_iter_o_mapss |> unfold_map;
  15.337 -        val fp_rec_o_maps = map co_rec_of fp_co_iter_o_mapss |> unfold_map;
  15.338 -        val fold_thms = fp_case fp @{thm o_assoc[symmetric]} @{thm o_assoc} ::
  15.339 -          @{thms id_apply o_apply o_id id_o map_pair.comp map_pair.id sum_map.comp sum_map.id};
  15.340 -        val rec_thms = fold_thms @ fp_case fp
  15.341 -          @{thms fst_convol map_pair_o_convol convol_o}
  15.342 -          @{thms sum_case_o_inj(1) sum_case_o_sum_map o_sum_case};
  15.343 -        val map_thms = no_refl (maps (fn bnf =>
  15.344 -          [map_comp0_of_bnf bnf RS sym, map_id0_of_bnf bnf]) fp_nesty_bnfs);
  15.345 -
  15.346 -        fun mk_tac defs o_map_thms xtor_thms thms {context = ctxt, prems = _} =
  15.347 -          unfold_thms_tac ctxt
  15.348 -            (flat [thms, defs, pre_map_defs, fp_pre_map_defs, xtor_thms, o_map_thms, map_thms]) THEN
  15.349 -          CONJ_WRAP (K (HEADGOAL (rtac refl))) bnfs;
  15.350 -
  15.351 -        val fold_tac = mk_tac raw_un_fold_defs fp_fold_o_maps fp_xtor_un_folds fold_thms;
  15.352 -        val rec_tac = mk_tac raw_co_rec_defs fp_rec_o_maps fp_xtor_co_recs rec_thms;
  15.353 -      in
  15.354 -        (mk_thms fold_strs fold_goals fold_tac, mk_thms rec_strs rec_goals rec_tac)
  15.355 -      end;
  15.356 -
  15.357 -    (* These results are half broken. This is deliberate. We care only about those fields that are
  15.358 -       used by "primrec_new", "primcorecursive", and "datatype_new_compat". *)
  15.359 -    val fp_res =
  15.360 -      ({Ts = fpTs,
  15.361 -        bnfs = steal #bnfs,
  15.362 -        dtors = dtors,
  15.363 -        ctors = ctors,
  15.364 -        xtor_co_iterss = transpose [un_folds, co_recs],
  15.365 -        xtor_co_induct = xtor_co_induct_thm,
  15.366 -        dtor_ctors = steal #dtor_ctors (*too general types*),
  15.367 -        ctor_dtors = steal #ctor_dtors (*too general types*),
  15.368 -        ctor_injects = steal #ctor_injects (*too general types*),
  15.369 -        dtor_injects = steal #dtor_injects (*too general types*),
  15.370 -        xtor_map_thms = steal #xtor_map_thms (*too general types and terms*),
  15.371 -        xtor_set_thmss = steal #xtor_set_thmss (*too general types and terms*),
  15.372 -        xtor_rel_thms = steal #xtor_rel_thms (*too general types and terms*),
  15.373 -        xtor_co_iter_thmss = transpose [xtor_un_fold_thms, xtor_co_rec_thms],
  15.374 -        xtor_co_iter_o_map_thmss = steal #xtor_co_iter_o_map_thmss (*theorem about old constant*),
  15.375 -        rel_xtor_co_induct_thm = rel_xtor_co_induct_thm}
  15.376 -       |> morph_fp_result (Morphism.term_morphism "BNF" (singleton (Variable.polymorphic lthy))));
  15.377 -  in
  15.378 -    (fp_res, lthy)
  15.379 -  end;
  15.380 -
  15.381 -end;
    16.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML	Mon Jan 20 18:24:55 2014 +0100
    16.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.3 @@ -1,394 +0,0 @@
    16.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_n2m_sugar.ML
    16.5 -    Author:     Jasmin Blanchette, TU Muenchen
    16.6 -    Copyright   2013
    16.7 -
    16.8 -Suggared flattening of nested to mutual (co)recursion.
    16.9 -*)
   16.10 -
   16.11 -signature BNF_FP_N2M_SUGAR =
   16.12 -sig
   16.13 -  val unfold_let: term -> term
   16.14 -  val dest_map: Proof.context -> string -> term -> term * term list
   16.15 -
   16.16 -  val mutualize_fp_sugars: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
   16.17 -    term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> local_theory ->
   16.18 -    (BNF_FP_Def_Sugar.fp_sugar list
   16.19 -     * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
   16.20 -    * local_theory
   16.21 -  val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list ->
   16.22 -    term list list list
   16.23 -  val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
   16.24 -    (term * term list list) list list -> local_theory ->
   16.25 -    (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list
   16.26 -     * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
   16.27 -    * local_theory
   16.28 -end;
   16.29 -
   16.30 -structure BNF_FP_N2M_Sugar : BNF_FP_N2M_SUGAR =
   16.31 -struct
   16.32 -
   16.33 -open Ctr_Sugar
   16.34 -open BNF_Util
   16.35 -open BNF_Def
   16.36 -open BNF_FP_Util
   16.37 -open BNF_FP_Def_Sugar
   16.38 -open BNF_FP_N2M
   16.39 -
   16.40 -val n2mN = "n2m_"
   16.41 -
   16.42 -type n2m_sugar = fp_sugar list * (lfp_sugar_thms option * gfp_sugar_thms option);
   16.43 -
   16.44 -structure Data = Generic_Data
   16.45 -(
   16.46 -  type T = n2m_sugar Typtab.table;
   16.47 -  val empty = Typtab.empty;
   16.48 -  val extend = I;
   16.49 -  val merge = Typtab.merge (eq_fst (eq_list eq_fp_sugar));
   16.50 -);
   16.51 -
   16.52 -fun morph_n2m_sugar phi (fp_sugars, (lfp_sugar_thms_opt, gfp_sugar_thms_opt)) =
   16.53 -  (map (morph_fp_sugar phi) fp_sugars,
   16.54 -   (Option.map (morph_lfp_sugar_thms phi) lfp_sugar_thms_opt,
   16.55 -    Option.map (morph_gfp_sugar_thms phi) gfp_sugar_thms_opt));
   16.56 -
   16.57 -val transfer_n2m_sugar =
   16.58 -  morph_n2m_sugar o Morphism.transfer_morphism o Proof_Context.theory_of;
   16.59 -
   16.60 -fun n2m_sugar_of ctxt =
   16.61 -  Typtab.lookup (Data.get (Context.Proof ctxt))
   16.62 -  #> Option.map (transfer_n2m_sugar ctxt);
   16.63 -
   16.64 -fun register_n2m_sugar key n2m_sugar =
   16.65 -  Local_Theory.declaration {syntax = false, pervasive = false}
   16.66 -    (fn phi => Data.map (Typtab.default (key, morph_n2m_sugar phi n2m_sugar)));
   16.67 -
   16.68 -fun unfold_let (Const (@{const_name Let}, _) $ arg1 $ arg2) = unfold_let (betapply (arg2, arg1))
   16.69 -  | unfold_let (Const (@{const_name prod_case}, _) $ t) =
   16.70 -    (case unfold_let t of
   16.71 -      t' as Abs (s1, T1, Abs (s2, T2, _)) =>
   16.72 -      let val v = Var ((s1 ^ s2, Term.maxidx_of_term t' + 1), HOLogic.mk_prodT (T1, T2)) in
   16.73 -        lambda v (incr_boundvars 1 (betapplys (t', [HOLogic.mk_fst v, HOLogic.mk_snd v])))
   16.74 -      end
   16.75 -    | _ => t)
   16.76 -  | unfold_let (t $ u) = betapply (unfold_let t, unfold_let u)
   16.77 -  | unfold_let (Abs (s, T, t)) = Abs (s, T, unfold_let t)
   16.78 -  | unfold_let t = t;
   16.79 -
   16.80 -fun mk_map_pattern ctxt s =
   16.81 -  let
   16.82 -    val bnf = the (bnf_of ctxt s);
   16.83 -    val mapx = map_of_bnf bnf;
   16.84 -    val live = live_of_bnf bnf;
   16.85 -    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
   16.86 -    val fs = map_index (fn (i, T) => Var (("?f", i), T)) f_Ts;
   16.87 -  in
   16.88 -    (mapx, betapplys (mapx, fs))
   16.89 -  end;
   16.90 -
   16.91 -fun dest_map ctxt s call =
   16.92 -  let
   16.93 -    val (map0, pat) = mk_map_pattern ctxt s;
   16.94 -    val (_, tenv) = fo_match ctxt call pat;
   16.95 -  in
   16.96 -    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
   16.97 -  end;
   16.98 -
   16.99 -fun dest_abs_or_applied_map _ _ (Abs (_, _, t)) = (Term.dummy, [t])
  16.100 -  | dest_abs_or_applied_map ctxt s (t1 $ _) = dest_map ctxt s t1;
  16.101 -
  16.102 -fun map_partition f xs =
  16.103 -  fold_rev (fn x => fn (ys, (good, bad)) =>
  16.104 -      case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad)))
  16.105 -    xs ([], ([], []));
  16.106 -
  16.107 -fun key_of_fp_eqs fp fpTs fp_eqs =
  16.108 -  Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs);
  16.109 -
  16.110 -(* TODO: test with sort constraints on As *)
  16.111 -fun mutualize_fp_sugars fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
  16.112 -  let
  16.113 -    val thy = Proof_Context.theory_of no_defs_lthy0;
  16.114 -
  16.115 -    val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
  16.116 -
  16.117 -    fun incompatible_calls t1 t2 =
  16.118 -      error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
  16.119 -    fun nested_self_call t =
  16.120 -      error ("Unsupported nested self-call " ^ qsotm t);
  16.121 -
  16.122 -    val b_names = map Binding.name_of bs;
  16.123 -    val fp_b_names = map base_name_of_typ fpTs;
  16.124 -
  16.125 -    val nn = length fpTs;
  16.126 -
  16.127 -    fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
  16.128 -      let
  16.129 -        val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
  16.130 -        val phi = Morphism.term_morphism "BNF" (Term.subst_TVars rho);
  16.131 -      in
  16.132 -        morph_ctr_sugar phi (nth ctr_sugars index)
  16.133 -      end;
  16.134 -
  16.135 -    val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
  16.136 -    val mapss = map (of_fp_sugar #mapss) fp_sugars0;
  16.137 -    val ctr_sugars = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
  16.138 -
  16.139 -    val ctrss = map #ctrs ctr_sugars;
  16.140 -    val ctr_Tss = map (map fastype_of) ctrss;
  16.141 -
  16.142 -    val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
  16.143 -    val As = map TFree As';
  16.144 -
  16.145 -    val ((Cs, Xs), no_defs_lthy) =
  16.146 -      no_defs_lthy0
  16.147 -      |> fold Variable.declare_typ As
  16.148 -      |> mk_TFrees nn
  16.149 -      ||>> variant_tfrees fp_b_names;
  16.150 -
  16.151 -    fun check_call_dead live_call call =
  16.152 -      if null (get_indices call) then () else incompatible_calls live_call call;
  16.153 -
  16.154 -    fun freeze_fpTs_simple (T as Type (s, Ts)) =
  16.155 -        (case find_index (curry (op =) T) fpTs of
  16.156 -          ~1 => Type (s, map freeze_fpTs_simple Ts)
  16.157 -        | kk => nth Xs kk)
  16.158 -      | freeze_fpTs_simple T = T;
  16.159 -
  16.160 -    fun freeze_fpTs_map (fpT as Type (_, Ts')) (callss, (live_call :: _, dead_calls))
  16.161 -        (T as Type (s, Ts)) =
  16.162 -      if Ts' = Ts then
  16.163 -        nested_self_call live_call
  16.164 -      else
  16.165 -        (List.app (check_call_dead live_call) dead_calls;
  16.166 -         Type (s, map2 (freeze_fpTs fpT) (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
  16.167 -           (transpose callss)) Ts))
  16.168 -    and freeze_fpTs fpT calls (T as Type (s, _)) =
  16.169 -        (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of
  16.170 -          ([], _) =>
  16.171 -          (case map_partition (try (snd o dest_abs_or_applied_map no_defs_lthy s)) calls of
  16.172 -            ([], _) => freeze_fpTs_simple T
  16.173 -          | callsp => freeze_fpTs_map fpT callsp T)
  16.174 -        | callsp => freeze_fpTs_map fpT callsp T)
  16.175 -      | freeze_fpTs _ _ T = T;
  16.176 -
  16.177 -    val ctr_Tsss = map (map binder_types) ctr_Tss;
  16.178 -    val ctrXs_Tsss = map3 (map2 o map2 o freeze_fpTs) fpTs callssss ctr_Tsss;
  16.179 -    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
  16.180 -    val ctr_Ts = map (body_type o hd) ctr_Tss;
  16.181 -
  16.182 -    val ns = map length ctr_Tsss;
  16.183 -    val kss = map (fn n => 1 upto n) ns;
  16.184 -    val mss = map (map length) ctr_Tsss;
  16.185 -
  16.186 -    val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
  16.187 -    val key = key_of_fp_eqs fp fpTs fp_eqs;
  16.188 -  in
  16.189 -    (case n2m_sugar_of no_defs_lthy key of
  16.190 -      SOME n2m_sugar => (n2m_sugar, no_defs_lthy)
  16.191 -    | NONE =>
  16.192 -      let
  16.193 -        val base_fp_names = Name.variant_list [] fp_b_names;
  16.194 -        val fp_bs = map2 (fn b_name => fn base_fp_name =>
  16.195 -            Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
  16.196 -          b_names base_fp_names;
  16.197 -
  16.198 -        val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_injects,
  16.199 -               dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
  16.200 -          fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
  16.201 -
  16.202 -        val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
  16.203 -        val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
  16.204 -
  16.205 -        val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
  16.206 -          mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
  16.207 -
  16.208 -        fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
  16.209 -
  16.210 -        val ((co_iterss, co_iter_defss), lthy) =
  16.211 -          fold_map2 (fn b =>
  16.212 -            (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
  16.213 -             else define_coiters [unfoldN, corecN] (the coiters_args_types))
  16.214 -              (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
  16.215 -          |>> split_list;
  16.216 -
  16.217 -        val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
  16.218 -              sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
  16.219 -          if fp = Least_FP then
  16.220 -            derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
  16.221 -              xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
  16.222 -              co_iterss co_iter_defss lthy
  16.223 -            |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
  16.224 -              ([induct], fold_thmss, rec_thmss, [], [], [], []))
  16.225 -            ||> (fn info => (SOME info, NONE))
  16.226 -          else
  16.227 -            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  16.228 -              dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss
  16.229 -              ns ctr_defss ctr_sugars co_iterss co_iter_defss
  16.230 -              (Proof_Context.export lthy no_defs_lthy) lthy
  16.231 -            |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
  16.232 -                    (disc_unfold_thmss, disc_corec_thmss, _), _,
  16.233 -                    (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
  16.234 -              (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
  16.235 -               disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
  16.236 -            ||> (fn info => (NONE, SOME info));
  16.237 -
  16.238 -        val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
  16.239 -
  16.240 -        fun mk_target_fp_sugar (kk, T) =
  16.241 -          {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
  16.242 -           nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
  16.243 -           ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
  16.244 -           co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
  16.245 -           disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
  16.246 -           sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
  16.247 -          |> morph_fp_sugar phi;
  16.248 -
  16.249 -        val n2m_sugar = (map_index mk_target_fp_sugar fpTs, fp_sugar_thms);
  16.250 -      in
  16.251 -        (n2m_sugar, lthy |> register_n2m_sugar key n2m_sugar)
  16.252 -      end)
  16.253 -  end;
  16.254 -
  16.255 -fun indexify_callsss fp_sugar callsss =
  16.256 -  let
  16.257 -    val {ctrs, ...} = of_fp_sugar #ctr_sugars fp_sugar;
  16.258 -    fun indexify_ctr ctr =
  16.259 -      (case AList.lookup Term.aconv_untyped callsss ctr of
  16.260 -        NONE => replicate (num_binder_types (fastype_of ctr)) []
  16.261 -      | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss);
  16.262 -  in
  16.263 -    map indexify_ctr ctrs
  16.264 -  end;
  16.265 -
  16.266 -fun retypargs tyargs (Type (s, _)) = Type (s, tyargs);
  16.267 -
  16.268 -fun fold_subtype_pairs f (T as Type (s, Ts), U as Type (s', Us)) =
  16.269 -    f (T, U) #> (if s = s' then fold (fold_subtype_pairs f) (Ts ~~ Us) else I)
  16.270 -  | fold_subtype_pairs f TU = f TU;
  16.271 -
  16.272 -fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy =
  16.273 -  let
  16.274 -    val qsoty = quote o Syntax.string_of_typ lthy;
  16.275 -    val qsotys = space_implode " or " o map qsoty;
  16.276 -
  16.277 -    fun duplicate_datatype T = error (qsoty T ^ " is not mutually recursive with itself");
  16.278 -    fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
  16.279 -    fun not_co_datatype (T as Type (s, _)) =
  16.280 -        if fp = Least_FP andalso
  16.281 -           is_some (Datatype_Data.get_info (Proof_Context.theory_of lthy) s) then
  16.282 -          error (qsoty T ^ " is not a new-style datatype (cf. \"datatype_new\")")
  16.283 -        else
  16.284 -          not_co_datatype0 T
  16.285 -      | not_co_datatype T = not_co_datatype0 T;
  16.286 -    fun not_mutually_nested_rec Ts1 Ts2 =
  16.287 -      error (qsotys Ts1 ^ " is neither mutually recursive with " ^ qsotys Ts2 ^
  16.288 -        " nor nested recursive via " ^ qsotys Ts2);
  16.289 -
  16.290 -    val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
  16.291 -
  16.292 -    val perm_actual_Ts =
  16.293 -      sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
  16.294 -
  16.295 -    fun the_ctrs_of (Type (s, Ts)) = map (mk_ctr Ts) (#ctrs (the (ctr_sugar_of lthy s)));
  16.296 -
  16.297 -    fun the_fp_sugar_of (T as Type (T_name, _)) =
  16.298 -      (case fp_sugar_of lthy T_name of
  16.299 -        SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
  16.300 -      | NONE => not_co_datatype T);
  16.301 -
  16.302 -    fun gen_rhss_in gen_Ts rho subTs =
  16.303 -      let
  16.304 -        fun maybe_insert (T, Type (_, gen_tyargs)) =
  16.305 -            if member (op =) subTs T then insert (op =) gen_tyargs else I
  16.306 -          | maybe_insert _ = I;
  16.307 -
  16.308 -        val ctrs = maps the_ctrs_of gen_Ts;
  16.309 -        val gen_ctr_Ts = maps (binder_types o fastype_of) ctrs;
  16.310 -        val ctr_Ts = map (Term.typ_subst_atomic rho) gen_ctr_Ts;
  16.311 -      in
  16.312 -        fold (fold_subtype_pairs maybe_insert) (ctr_Ts ~~ gen_ctr_Ts) []
  16.313 -      end;
  16.314 -
  16.315 -    fun gather_types _ _ num_groups seen gen_seen [] = (num_groups, seen, gen_seen)
  16.316 -      | gather_types lthy rho num_groups seen gen_seen ((T as Type (_, tyargs)) :: Ts) =
  16.317 -        let
  16.318 -          val {fp_res = {Ts = mutual_Ts0, ...}, ...} = the_fp_sugar_of T;
  16.319 -          val mutual_Ts = map (retypargs tyargs) mutual_Ts0;
  16.320 -
  16.321 -          val _ = seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
  16.322 -            not_mutually_nested_rec mutual_Ts seen;
  16.323 -
  16.324 -          fun fresh_tyargs () =
  16.325 -            let
  16.326 -              (* The name "'z" is unlikely to clash with the context, yielding more cache hits. *)
  16.327 -              val (gen_tyargs, lthy') =
  16.328 -                variant_tfrees (replicate (length tyargs) "z") lthy
  16.329 -                |>> map Logic.varifyT_global;
  16.330 -              val rho' = (gen_tyargs ~~ tyargs) @ rho;
  16.331 -            in
  16.332 -              (rho', gen_tyargs, gen_seen, lthy')
  16.333 -            end;
  16.334 -
  16.335 -          val (rho', gen_tyargs, gen_seen', lthy') =
  16.336 -            if exists (exists_subtype_in seen) mutual_Ts then
  16.337 -              (case gen_rhss_in gen_seen rho mutual_Ts of
  16.338 -                [] => fresh_tyargs ()
  16.339 -              | gen_tyargs :: gen_tyargss_tl =>
  16.340 -                let
  16.341 -                  val unify_pairs = split_list (maps (curry (op ~~) gen_tyargs) gen_tyargss_tl);
  16.342 -                  val mgu = Type.raw_unifys unify_pairs Vartab.empty;
  16.343 -                  val gen_tyargs' = map (Envir.subst_type mgu) gen_tyargs;
  16.344 -                  val gen_seen' = map (Envir.subst_type mgu) gen_seen;
  16.345 -                in
  16.346 -                  (rho, gen_tyargs', gen_seen', lthy)
  16.347 -                end)
  16.348 -            else
  16.349 -              fresh_tyargs ();
  16.350 -
  16.351 -          val gen_mutual_Ts = map (retypargs gen_tyargs) mutual_Ts0;
  16.352 -          val Ts' = filter_out (member (op =) mutual_Ts) Ts;
  16.353 -        in
  16.354 -          gather_types lthy' rho' (num_groups + 1) (seen @ mutual_Ts) (gen_seen' @ gen_mutual_Ts)
  16.355 -            Ts'
  16.356 -        end
  16.357 -      | gather_types _ _ _ _ _ (T :: _) = not_co_datatype T;
  16.358 -
  16.359 -    val (num_groups, perm_Ts, perm_gen_Ts) = gather_types lthy [] 0 [] [] perm_actual_Ts;
  16.360 -    val perm_frozen_gen_Ts = map Logic.unvarifyT_global perm_gen_Ts;
  16.361 -
  16.362 -    val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
  16.363 -    val Ts = actual_Ts @ missing_Ts;
  16.364 -
  16.365 -    val nn = length Ts;
  16.366 -    val kks = 0 upto nn - 1;
  16.367 -
  16.368 -    val callssss0 = pad_list [] nn actual_callssss0;
  16.369 -
  16.370 -    val common_name = mk_common_name (map Binding.name_of actual_bs);
  16.371 -    val bs = pad_list (Binding.name common_name) nn actual_bs;
  16.372 -
  16.373 -    fun permute xs = permute_like (op =) Ts perm_Ts xs;
  16.374 -    fun unpermute perm_xs = permute_like (op =) perm_Ts Ts perm_xs;
  16.375 -
  16.376 -    val perm_bs = permute bs;
  16.377 -    val perm_kks = permute kks;
  16.378 -    val perm_callssss0 = permute callssss0;
  16.379 -    val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts;
  16.380 -
  16.381 -    val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0;
  16.382 -
  16.383 -    val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices;
  16.384 -
  16.385 -    val ((perm_fp_sugars, fp_sugar_thms), lthy) =
  16.386 -      if num_groups > 1 then
  16.387 -        mutualize_fp_sugars fp perm_bs perm_frozen_gen_Ts get_perm_indices perm_callssss
  16.388 -          perm_fp_sugars0 lthy
  16.389 -      else
  16.390 -        ((perm_fp_sugars0, (NONE, NONE)), lthy);
  16.391 -
  16.392 -    val fp_sugars = unpermute perm_fp_sugars;
  16.393 -  in
  16.394 -    ((missing_Ts, perm_kks, fp_sugars, fp_sugar_thms), lthy)
  16.395 -  end;
  16.396 -
  16.397 -end;
    17.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m_tactics.ML	Mon Jan 20 18:24:55 2014 +0100
    17.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.3 @@ -1,41 +0,0 @@
    17.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_n2m_tactics.ML
    17.5 -    Author:     Dmitriy Traytel, TU Muenchen
    17.6 -    Copyright   2013
    17.7 -
    17.8 -Tactics for mutualization of nested (co)datatypes.
    17.9 -*)
   17.10 -
   17.11 -signature BNF_FP_N2M_TACTICS =
   17.12 -sig
   17.13 -  val mk_rel_xtor_co_induct_tactic: BNF_FP_Util.fp_kind -> thm list -> thm list -> thm list ->
   17.14 -    {prems: thm list, context: Proof.context} -> tactic
   17.15 -end;
   17.16 -
   17.17 -structure BNF_FP_N2M_Tactics : BNF_FP_N2M_TACTICS =
   17.18 -struct
   17.19 -
   17.20 -open BNF_Util
   17.21 -open BNF_FP_Util
   17.22 -
   17.23 -fun mk_rel_xtor_co_induct_tactic fp co_inducts rel_defs rel_monos
   17.24 -  {context = ctxt, prems = raw_C_IHs} =
   17.25 -  let
   17.26 -    val unfolds = map (fn def => unfold_thms ctxt (id_apply :: no_reflexive [def])) rel_defs;
   17.27 -    val folded_C_IHs = map (fn thm => thm RS @{thm spec2} RS mp) raw_C_IHs;
   17.28 -    val C_IHs = map2 (curry op |>) folded_C_IHs unfolds;
   17.29 -    val C_IH_monos =
   17.30 -      map3 (fn C_IH => fn mono => fn unfold =>
   17.31 -        (mono RSN (2, @{thm rev_predicate2D}), C_IH)
   17.32 -        |> fp = Greatest_FP ? swap
   17.33 -        |> op RS
   17.34 -        |> unfold)
   17.35 -      folded_C_IHs rel_monos unfolds;
   17.36 -  in
   17.37 -    HEADGOAL (CONJ_WRAP_GEN' (rtac @{thm context_conjI})
   17.38 -      (fn thm => rtac thm THEN_ALL_NEW (rotate_tac ~1 THEN'
   17.39 -         REPEAT_ALL_NEW (FIRST' [eresolve_tac C_IHs, eresolve_tac C_IH_monos,
   17.40 -           rtac @{thm order_refl}, atac, resolve_tac co_inducts])))
   17.41 -    co_inducts)
   17.42 -  end;
   17.43 -
   17.44 -end;
    18.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML	Mon Jan 20 18:24:55 2014 +0100
    18.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.3 @@ -1,67 +0,0 @@
    18.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML
    18.5 -    Author:     Lorenz Panny, TU Muenchen
    18.6 -    Author:     Jasmin Blanchette, TU Muenchen
    18.7 -    Copyright   2013
    18.8 -
    18.9 -Library for recursor and corecursor sugar.
   18.10 -*)
   18.11 -
   18.12 -signature BNF_FP_REC_SUGAR_UTIL =
   18.13 -sig
   18.14 -  val indexed: 'a list -> int -> int list * int
   18.15 -  val indexedd: 'a list list -> int -> int list list * int
   18.16 -  val indexeddd: 'a list list list -> int -> int list list list * int
   18.17 -  val indexedddd: 'a list list list list -> int -> int list list list list * int
   18.18 -  val find_index_eq: ''a list -> ''a -> int
   18.19 -  val finds: ('a * 'b -> bool) -> 'a list -> 'b list -> ('a * 'b list) list * 'b list
   18.20 -
   18.21 -  val drop_all: term -> term
   18.22 -
   18.23 -  val mk_partial_compN: int -> typ -> term -> term
   18.24 -  val mk_partial_comp: typ -> typ -> term -> term
   18.25 -  val mk_compN: int -> typ list -> term * term -> term
   18.26 -  val mk_comp: typ list -> term * term -> term
   18.27 -
   18.28 -  val get_indices: ((binding * typ) * 'a) list -> term -> int list
   18.29 -end;
   18.30 -
   18.31 -structure BNF_FP_Rec_Sugar_Util : BNF_FP_REC_SUGAR_UTIL =
   18.32 -struct
   18.33 -
   18.34 -fun indexe _ h = (h, h + 1);
   18.35 -fun indexed xs = fold_map indexe xs;
   18.36 -fun indexedd xss = fold_map indexed xss;
   18.37 -fun indexeddd xsss = fold_map indexedd xsss;
   18.38 -fun indexedddd xssss = fold_map indexeddd xssss;
   18.39 -
   18.40 -fun find_index_eq hs h = find_index (curry (op =) h) hs;
   18.41 -
   18.42 -fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
   18.43 -
   18.44 -fun drop_all t =
   18.45 -  subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
   18.46 -    strip_qnt_body @{const_name all} t);
   18.47 -
   18.48 -fun mk_partial_comp gT fT g =
   18.49 -  let val T = domain_type fT --> range_type gT in
   18.50 -    Const (@{const_name Fun.comp}, gT --> fT --> T) $ g
   18.51 -  end;
   18.52 -
   18.53 -fun mk_partial_compN 0 _ g = g
   18.54 -  | mk_partial_compN n fT g =
   18.55 -    let val g' = mk_partial_compN (n - 1) (range_type fT) g in
   18.56 -      mk_partial_comp (fastype_of g') fT g'
   18.57 -    end;
   18.58 -
   18.59 -fun mk_compN n bound_Ts (g, f) =
   18.60 -  let val typof = curry fastype_of1 bound_Ts in
   18.61 -    mk_partial_compN n (typof f) g $ f
   18.62 -  end;
   18.63 -
   18.64 -val mk_comp = mk_compN 1;
   18.65 -
   18.66 -fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
   18.67 -  |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
   18.68 -  |> map_filter I;
   18.69 -
   18.70 -end;
    19.1 --- a/src/HOL/BNF/Tools/bnf_fp_util.ML	Mon Jan 20 18:24:55 2014 +0100
    19.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.3 @@ -1,635 +0,0 @@
    19.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_util.ML
    19.5 -    Author:     Dmitriy Traytel, TU Muenchen
    19.6 -    Author:     Jasmin Blanchette, TU Muenchen
    19.7 -    Copyright   2012, 2013
    19.8 -
    19.9 -Shared library for the datatype and codatatype constructions.
   19.10 -*)
   19.11 -
   19.12 -signature BNF_FP_UTIL =
   19.13 -sig
   19.14 -  datatype fp_kind = Least_FP | Greatest_FP
   19.15 -  val fp_case: fp_kind -> 'a -> 'a -> 'a
   19.16 -
   19.17 -  type fp_result =
   19.18 -    {Ts: typ list,
   19.19 -     bnfs: BNF_Def.bnf list,
   19.20 -     ctors: term list,
   19.21 -     dtors: term list,
   19.22 -     xtor_co_iterss: term list list,
   19.23 -     xtor_co_induct: thm,
   19.24 -     dtor_ctors: thm list,
   19.25 -     ctor_dtors: thm list,
   19.26 -     ctor_injects: thm list,
   19.27 -     dtor_injects: thm list,
   19.28 -     xtor_map_thms: thm list,
   19.29 -     xtor_set_thmss: thm list list,
   19.30 -     xtor_rel_thms: thm list,
   19.31 -     xtor_co_iter_thmss: thm list list,
   19.32 -     xtor_co_iter_o_map_thmss: thm list list,
   19.33 -     rel_xtor_co_induct_thm: thm}
   19.34 -
   19.35 -  val morph_fp_result: morphism -> fp_result -> fp_result
   19.36 -  val eq_fp_result: fp_result * fp_result -> bool
   19.37 -  val un_fold_of: 'a list -> 'a
   19.38 -  val co_rec_of: 'a list -> 'a
   19.39 -
   19.40 -  val time: Proof.context -> Timer.real_timer -> string -> Timer.real_timer
   19.41 -
   19.42 -  val IITN: string
   19.43 -  val LevN: string
   19.44 -  val algN: string
   19.45 -  val behN: string
   19.46 -  val bisN: string
   19.47 -  val carTN: string
   19.48 -  val caseN: string
   19.49 -  val coN: string
   19.50 -  val coinductN: string
   19.51 -  val corecN: string
   19.52 -  val ctorN: string
   19.53 -  val ctor_dtorN: string
   19.54 -  val ctor_exhaustN: string
   19.55 -  val ctor_induct2N: string
   19.56 -  val ctor_inductN: string
   19.57 -  val ctor_injectN: string
   19.58 -  val ctor_foldN: string
   19.59 -  val ctor_fold_o_mapN: string
   19.60 -  val ctor_fold_transferN: string
   19.61 -  val ctor_fold_uniqueN: string
   19.62 -  val ctor_mapN: string
   19.63 -  val ctor_map_uniqueN: string
   19.64 -  val ctor_recN: string
   19.65 -  val ctor_rec_o_mapN: string
   19.66 -  val ctor_rec_uniqueN: string
   19.67 -  val ctor_relN: string
   19.68 -  val ctor_set_inclN: string
   19.69 -  val ctor_set_set_inclN: string
   19.70 -  val disc_unfoldN: string
   19.71 -  val disc_unfold_iffN: string
   19.72 -  val disc_corecN: string
   19.73 -  val disc_corec_iffN: string
   19.74 -  val dtorN: string
   19.75 -  val dtor_coinductN: string
   19.76 -  val dtor_corecN: string
   19.77 -  val dtor_corec_o_mapN: string
   19.78 -  val dtor_corec_uniqueN: string
   19.79 -  val dtor_ctorN: string
   19.80 -  val dtor_exhaustN: string
   19.81 -  val dtor_injectN: string
   19.82 -  val dtor_mapN: string
   19.83 -  val dtor_map_coinductN: string
   19.84 -  val dtor_map_strong_coinductN: string
   19.85 -  val dtor_map_uniqueN: string
   19.86 -  val dtor_relN: string
   19.87 -  val dtor_set_inclN: string
   19.88 -  val dtor_set_set_inclN: string
   19.89 -  val dtor_strong_coinductN: string
   19.90 -  val dtor_unfoldN: string
   19.91 -  val dtor_unfold_o_mapN: string
   19.92 -  val dtor_unfold_transferN: string
   19.93 -  val dtor_unfold_uniqueN: string
   19.94 -  val exhaustN: string
   19.95 -  val foldN: string
   19.96 -  val hsetN: string
   19.97 -  val hset_recN: string
   19.98 -  val inductN: string
   19.99 -  val injectN: string
  19.100 -  val isNodeN: string
  19.101 -  val lsbisN: string
  19.102 -  val mapN: string
  19.103 -  val map_uniqueN: string
  19.104 -  val min_algN: string
  19.105 -  val morN: string
  19.106 -  val nchotomyN: string
  19.107 -  val recN: string
  19.108 -  val rel_coinductN: string
  19.109 -  val rel_inductN: string
  19.110 -  val rel_injectN: string
  19.111 -  val rel_distinctN: string
  19.112 -  val rvN: string
  19.113 -  val sel_corecN: string
  19.114 -  val set_inclN: string
  19.115 -  val set_set_inclN: string
  19.116 -  val sel_unfoldN: string
  19.117 -  val setN: string
  19.118 -  val simpsN: string
  19.119 -  val strTN: string
  19.120 -  val str_initN: string
  19.121 -  val strong_coinductN: string
  19.122 -  val sum_bdN: string
  19.123 -  val sum_bdTN: string
  19.124 -  val unfoldN: string
  19.125 -  val uniqueN: string
  19.126 -
  19.127 -  (* TODO: Don't index set facts. Isabelle packages traditionally generate uniform names. *)
  19.128 -  val mk_ctor_setN: int -> string
  19.129 -  val mk_dtor_setN: int -> string
  19.130 -  val mk_dtor_set_inductN: int -> string
  19.131 -  val mk_set_inductN: int -> string
  19.132 -
  19.133 -  val co_prefix: fp_kind -> string
  19.134 -
  19.135 -  val base_name_of_typ: typ -> string
  19.136 -  val mk_common_name: string list -> string
  19.137 -
  19.138 -  val split_conj_thm: thm -> thm list
  19.139 -  val split_conj_prems: int -> thm -> thm
  19.140 -
  19.141 -  val mk_sumTN: typ list -> typ
  19.142 -  val mk_sumTN_balanced: typ list -> typ
  19.143 -
  19.144 -  val mk_proj: typ -> int -> int -> term
  19.145 -
  19.146 -  val mk_convol: term * term -> term
  19.147 -
  19.148 -  val Inl_const: typ -> typ -> term
  19.149 -  val Inr_const: typ -> typ -> term
  19.150 -
  19.151 -  val mk_Inl: typ -> term -> term
  19.152 -  val mk_Inr: typ -> term -> term
  19.153 -  val mk_InN: typ list -> term -> int -> term
  19.154 -  val mk_InN_balanced: typ -> int -> term -> int -> term
  19.155 -  val mk_sum_case: term * term -> term
  19.156 -  val mk_sum_caseN: term list -> term
  19.157 -  val mk_sum_caseN_balanced: term list -> term
  19.158 -
  19.159 -  val dest_sumT: typ -> typ * typ
  19.160 -  val dest_sumTN: int -> typ -> typ list
  19.161 -  val dest_sumTN_balanced: int -> typ -> typ list
  19.162 -  val dest_tupleT: int -> typ -> typ list
  19.163 -
  19.164 -  val If_const: typ -> term
  19.165 -
  19.166 -  val mk_Field: term -> term
  19.167 -  val mk_If: term -> term -> term -> term
  19.168 -  val mk_union: term * term -> term
  19.169 -
  19.170 -  val mk_sumEN: int -> thm
  19.171 -  val mk_sumEN_balanced: int -> thm
  19.172 -  val mk_sumEN_tupled_balanced: int list -> thm
  19.173 -  val mk_sum_casesN: int -> int -> thm
  19.174 -  val mk_sum_casesN_balanced: int -> int -> thm
  19.175 -
  19.176 -  val fixpoint: ('a * 'a -> bool) -> ('a list -> 'a list) -> 'a list -> 'a list
  19.177 -
  19.178 -  val mk_rel_xtor_co_induct_thm: fp_kind -> term list -> term list -> term list -> term list ->
  19.179 -    term list -> term list -> term list -> term list ->
  19.180 -    ({prems: thm list, context: Proof.context} -> tactic) -> Proof.context -> thm
  19.181 -  val mk_un_fold_transfer_thms: fp_kind -> term list -> term list -> term list -> term list ->
  19.182 -    term list -> term list -> ({prems: thm list, context: Proof.context} -> tactic) ->
  19.183 -    Proof.context -> thm list
  19.184 -  val mk_xtor_un_fold_o_map_thms: fp_kind -> bool -> int -> thm -> thm list -> thm list ->
  19.185 -    thm list -> thm list -> thm list
  19.186 -
  19.187 -  val mk_strong_coinduct_thm: thm -> thm list -> thm list -> Proof.context -> thm
  19.188 -
  19.189 -  val fp_bnf: (binding list -> (string * sort) list -> typ list * typ list list ->
  19.190 -      BNF_Def.bnf list -> local_theory -> 'a) ->
  19.191 -    binding list -> (string * sort) list -> ((string * sort) * typ) list -> local_theory ->
  19.192 -    BNF_Def.bnf list * 'a
  19.193 -end;
  19.194 -
  19.195 -structure BNF_FP_Util : BNF_FP_UTIL =
  19.196 -struct
  19.197 -
  19.198 -open BNF_Comp
  19.199 -open BNF_Def
  19.200 -open BNF_Util
  19.201 -
  19.202 -datatype fp_kind = Least_FP | Greatest_FP;
  19.203 -
  19.204 -fun fp_case Least_FP l _ = l
  19.205 -  | fp_case Greatest_FP _ g = g;
  19.206 -
  19.207 -type fp_result =
  19.208 -  {Ts: typ list,
  19.209 -   bnfs: BNF_Def.bnf list,
  19.210 -   ctors: term list,
  19.211 -   dtors: term list,
  19.212 -   xtor_co_iterss: term list list,
  19.213 -   xtor_co_induct: thm,
  19.214 -   dtor_ctors: thm list,
  19.215 -   ctor_dtors: thm list,
  19.216 -   ctor_injects: thm list,
  19.217 -   dtor_injects: thm list,
  19.218 -   xtor_map_thms: thm list,
  19.219 -   xtor_set_thmss: thm list list,
  19.220 -   xtor_rel_thms: thm list,
  19.221 -   xtor_co_iter_thmss: thm list list,
  19.222 -   xtor_co_iter_o_map_thmss: thm list list,
  19.223 -   rel_xtor_co_induct_thm: thm};
  19.224 -
  19.225 -fun morph_fp_result phi {Ts, bnfs, ctors, dtors, xtor_co_iterss, xtor_co_induct, dtor_ctors,
  19.226 -    ctor_dtors, ctor_injects, dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms,
  19.227 -    xtor_co_iter_thmss, xtor_co_iter_o_map_thmss, rel_xtor_co_induct_thm} =
  19.228 -  {Ts = map (Morphism.typ phi) Ts,
  19.229 -   bnfs = map (morph_bnf phi) bnfs,
  19.230 -   ctors = map (Morphism.term phi) ctors,
  19.231 -   dtors = map (Morphism.term phi) dtors,
  19.232 -   xtor_co_iterss = map (map (Morphism.term phi)) xtor_co_iterss,
  19.233 -   xtor_co_induct = Morphism.thm phi xtor_co_induct,
  19.234 -   dtor_ctors = map (Morphism.thm phi) dtor_ctors,
  19.235 -   ctor_dtors = map (Morphism.thm phi) ctor_dtors,
  19.236 -   ctor_injects = map (Morphism.thm phi) ctor_injects,
  19.237 -   dtor_injects = map (Morphism.thm phi) dtor_injects,
  19.238 -   xtor_map_thms = map (Morphism.thm phi) xtor_map_thms,
  19.239 -   xtor_set_thmss = map (map (Morphism.thm phi)) xtor_set_thmss,
  19.240 -   xtor_rel_thms = map (Morphism.thm phi) xtor_rel_thms,
  19.241 -   xtor_co_iter_thmss = map (map (Morphism.thm phi)) xtor_co_iter_thmss,
  19.242 -   xtor_co_iter_o_map_thmss = map (map (Morphism.thm phi)) xtor_co_iter_o_map_thmss,
  19.243 -   rel_xtor_co_induct_thm = Morphism.thm phi rel_xtor_co_induct_thm};
  19.244 -
  19.245 -fun eq_fp_result ({bnfs = bnfs1, ...} : fp_result, {bnfs = bnfs2, ...} : fp_result) =
  19.246 -  eq_list eq_bnf (bnfs1, bnfs2);
  19.247 -
  19.248 -fun un_fold_of [f, _] = f;
  19.249 -fun co_rec_of [_, r] = r;
  19.250 -
  19.251 -
  19.252 -fun time ctxt timer msg = (if Config.get ctxt bnf_timing
  19.253 -  then warning (msg ^ ": " ^ ATP_Util.string_of_time (Timer.checkRealTimer timer))
  19.254 -  else (); Timer.startRealTimer ());
  19.255 -
  19.256 -val preN = "pre_"
  19.257 -val rawN = "raw_"
  19.258 -
  19.259 -val coN = "co"
  19.260 -val unN = "un"
  19.261 -val algN = "alg"
  19.262 -val IITN = "IITN"
  19.263 -val foldN = "fold"
  19.264 -val unfoldN = unN ^ foldN
  19.265 -val uniqueN = "_unique"
  19.266 -val transferN = "_transfer"
  19.267 -val simpsN = "simps"
  19.268 -val ctorN = "ctor"
  19.269 -val dtorN = "dtor"
  19.270 -val ctor_foldN = ctorN ^ "_" ^ foldN
  19.271 -val dtor_unfoldN = dtorN ^ "_" ^ unfoldN
  19.272 -val ctor_fold_uniqueN = ctor_foldN ^ uniqueN
  19.273 -val ctor_fold_o_mapN = ctor_foldN ^ "_o_" ^ mapN
  19.274 -val dtor_unfold_uniqueN = dtor_unfoldN ^ uniqueN
  19.275 -val dtor_unfold_o_mapN = dtor_unfoldN ^ "_o_" ^ mapN
  19.276 -val ctor_fold_transferN = ctor_foldN ^ transferN
  19.277 -val dtor_unfold_transferN = dtor_unfoldN ^ transferN
  19.278 -val ctor_mapN = ctorN ^ "_" ^ mapN
  19.279 -val dtor_mapN = dtorN ^ "_" ^ mapN
  19.280 -val map_uniqueN = mapN ^ uniqueN
  19.281 -val ctor_map_uniqueN = ctorN ^ "_" ^ map_uniqueN
  19.282 -val dtor_map_uniqueN = dtorN ^ "_" ^ map_uniqueN
  19.283 -val min_algN = "min_alg"
  19.284 -val morN = "mor"
  19.285 -val bisN = "bis"
  19.286 -val lsbisN = "lsbis"
  19.287 -val sum_bdTN = "sbdT"
  19.288 -val sum_bdN = "sbd"
  19.289 -val carTN = "carT"
  19.290 -val strTN = "strT"
  19.291 -val isNodeN = "isNode"
  19.292 -val LevN = "Lev"
  19.293 -val rvN = "recover"
  19.294 -val behN = "beh"
  19.295 -val setN = "set"
  19.296 -val mk_ctor_setN = prefix (ctorN ^ "_") o mk_setN
  19.297 -val mk_dtor_setN = prefix (dtorN ^ "_") o mk_setN
  19.298 -fun mk_set_inductN i = mk_setN i ^ "_induct"
  19.299 -val mk_dtor_set_inductN = prefix (dtorN ^ "_") o mk_set_inductN
  19.300 -
  19.301 -val str_initN = "str_init"
  19.302 -val recN = "rec"
  19.303 -val corecN = coN ^ recN
  19.304 -val ctor_recN = ctorN ^ "_" ^ recN
  19.305 -val ctor_rec_o_mapN = ctor_recN ^ "_o_" ^ mapN
  19.306 -val ctor_rec_uniqueN = ctor_recN ^ uniqueN
  19.307 -val dtor_corecN = dtorN ^ "_" ^ corecN
  19.308 -val dtor_corec_o_mapN = dtor_corecN ^ "_o_" ^ mapN
  19.309 -val dtor_corec_uniqueN = dtor_corecN ^ uniqueN
  19.310 -
  19.311 -val ctor_dtorN = ctorN ^ "_" ^ dtorN
  19.312 -val dtor_ctorN = dtorN ^ "_" ^ ctorN
  19.313 -val nchotomyN = "nchotomy"
  19.314 -val injectN = "inject"
  19.315 -val exhaustN = "exhaust"
  19.316 -val ctor_injectN = ctorN ^ "_" ^ injectN
  19.317 -val ctor_exhaustN = ctorN ^ "_" ^ exhaustN
  19.318 -val dtor_injectN = dtorN ^ "_" ^ injectN
  19.319 -val dtor_exhaustN = dtorN ^ "_" ^ exhaustN
  19.320 -val ctor_relN = ctorN ^ "_" ^ relN
  19.321 -val dtor_relN = dtorN ^ "_" ^ relN
  19.322 -val inductN = "induct"
  19.323 -val coinductN = coN ^ inductN
  19.324 -val ctor_inductN = ctorN ^ "_" ^ inductN
  19.325 -val ctor_induct2N = ctor_inductN ^ "2"
  19.326 -val dtor_map_coinductN = dtor_mapN ^ "_" ^ coinductN
  19.327 -val dtor_coinductN = dtorN ^ "_" ^ coinductN
  19.328 -val strong_coinductN = "strong_" ^ coinductN
  19.329 -val dtor_map_strong_coinductN = dtor_mapN ^ "_" ^ strong_coinductN
  19.330 -val dtor_strong_coinductN = dtorN ^ "_" ^ strong_coinductN
  19.331 -val hsetN = "Hset"
  19.332 -val hset_recN = hsetN ^ "_rec"
  19.333 -val set_inclN = "set_incl"
  19.334 -val ctor_set_inclN = ctorN ^ "_" ^ set_inclN
  19.335 -val dtor_set_inclN = dtorN ^ "_" ^ set_inclN
  19.336 -val set_set_inclN = "set_set_incl"
  19.337 -val ctor_set_set_inclN = ctorN ^ "_" ^ set_set_inclN
  19.338 -val dtor_set_set_inclN = dtorN ^ "_" ^ set_set_inclN
  19.339 -
  19.340 -val caseN = "case"
  19.341 -val discN = "disc"
  19.342 -val disc_unfoldN = discN ^ "_" ^ unfoldN
  19.343 -val disc_corecN = discN ^ "_" ^ corecN
  19.344 -val iffN = "_iff"
  19.345 -val disc_unfold_iffN = discN ^ "_" ^ unfoldN ^ iffN
  19.346 -val disc_corec_iffN = discN ^ "_" ^ corecN ^ iffN
  19.347 -val distinctN = "distinct"
  19.348 -val rel_distinctN = relN ^ "_" ^ distinctN
  19.349 -val injectN = "inject"
  19.350 -val rel_injectN = relN ^ "_" ^ injectN
  19.351 -val rel_coinductN = relN ^ "_" ^ coinductN
  19.352 -val rel_inductN = relN ^ "_" ^ inductN
  19.353 -val selN = "sel"
  19.354 -val sel_unfoldN = selN ^ "_" ^ unfoldN
  19.355 -val sel_corecN = selN ^ "_" ^ corecN
  19.356 -
  19.357 -fun co_prefix fp = (if fp = Greatest_FP then "co" else "");
  19.358 -
  19.359 -fun add_components_of_typ (Type (s, Ts)) =
  19.360 -    cons (Long_Name.base_name s) #> fold_rev add_components_of_typ Ts
  19.361 -  | add_components_of_typ _ = I;
  19.362 -
  19.363 -fun base_name_of_typ T = space_implode "_" (add_components_of_typ T []);
  19.364 -
  19.365 -val mk_common_name = space_implode "_";
  19.366 -
  19.367 -fun dest_sumT (Type (@{type_name sum}, [T, T'])) = (T, T');
  19.368 -
  19.369 -fun dest_sumTN 1 T = [T]
  19.370 -  | dest_sumTN n (Type (@{type_name sum}, [T, T'])) = T :: dest_sumTN (n - 1) T';
  19.371 -
  19.372 -val dest_sumTN_balanced = Balanced_Tree.dest dest_sumT;
  19.373 -
  19.374 -(* TODO: move something like this to "HOLogic"? *)
  19.375 -fun dest_tupleT 0 @{typ unit} = []
  19.376 -  | dest_tupleT 1 T = [T]
  19.377 -  | dest_tupleT n (Type (@{type_name prod}, [T, T'])) = T :: dest_tupleT (n - 1) T';
  19.378 -
  19.379 -val mk_sumTN = Library.foldr1 mk_sumT;
  19.380 -val mk_sumTN_balanced = Balanced_Tree.make mk_sumT;
  19.381 -
  19.382 -fun mk_proj T n k =
  19.383 -  let val (binders, _) = strip_typeN n T in
  19.384 -    fold_rev (fn T => fn t => Abs (Name.uu, T, t)) binders (Bound (n - k - 1))
  19.385 -  end;
  19.386 -
  19.387 -fun mk_convol (f, g) =
  19.388 -  let
  19.389 -    val (fU, fTU) = `range_type (fastype_of f);
  19.390 -    val ((gT, gU), gTU) = `dest_funT (fastype_of g);
  19.391 -    val convolT = fTU --> gTU --> gT --> HOLogic.mk_prodT (fU, gU);
  19.392 -  in Const (@{const_name convol}, convolT) $ f $ g end;
  19.393 -
  19.394 -fun Inl_const LT RT = Const (@{const_name Inl}, LT --> mk_sumT (LT, RT));
  19.395 -fun mk_Inl RT t = Inl_const (fastype_of t) RT $ t;
  19.396 -
  19.397 -fun Inr_const LT RT = Const (@{const_name Inr}, RT --> mk_sumT (LT, RT));
  19.398 -fun mk_Inr LT t = Inr_const LT (fastype_of t) $ t;
  19.399 -
  19.400 -fun mk_InN [_] t 1 = t
  19.401 -  | mk_InN (_ :: Ts) t 1 = mk_Inl (mk_sumTN Ts) t
  19.402 -  | mk_InN (LT :: Ts) t m = mk_Inr LT (mk_InN Ts t (m - 1))
  19.403 -  | mk_InN Ts t _ = raise (TYPE ("mk_InN", Ts, [t]));
  19.404 -
  19.405 -fun mk_InN_balanced sum_T n t k =
  19.406 -  let
  19.407 -    fun repair_types T (Const (s as @{const_name Inl}, _) $ t) = repair_inj_types T s fst t
  19.408 -      | repair_types T (Const (s as @{const_name Inr}, _) $ t) = repair_inj_types T s snd t
  19.409 -      | repair_types _ t = t
  19.410 -    and repair_inj_types T s get t =
  19.411 -      let val T' = get (dest_sumT T) in
  19.412 -        Const (s, T' --> T) $ repair_types T' t
  19.413 -      end;
  19.414 -  in
  19.415 -    Balanced_Tree.access {left = mk_Inl dummyT, right = mk_Inr dummyT, init = t} n k
  19.416 -    |> repair_types sum_T
  19.417 -  end;
  19.418 -
  19.419 -fun mk_sum_case (f, g) =
  19.420 -  let
  19.421 -    val fT = fastype_of f;
  19.422 -    val gT = fastype_of g;
  19.423 -  in
  19.424 -    Const (@{const_name sum_case},
  19.425 -      fT --> gT --> mk_sumT (domain_type fT, domain_type gT) --> range_type fT) $ f $ g
  19.426 -  end;
  19.427 -
  19.428 -val mk_sum_caseN = Library.foldr1 mk_sum_case;
  19.429 -val mk_sum_caseN_balanced = Balanced_Tree.make mk_sum_case;
  19.430 -
  19.431 -fun If_const T = Const (@{const_name If}, HOLogic.boolT --> T --> T --> T);
  19.432 -fun mk_If p t f = let val T = fastype_of t in If_const T $ p $ t $ f end;
  19.433 -
  19.434 -fun mk_Field r =
  19.435 -  let val T = fst (dest_relT (fastype_of r));
  19.436 -  in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
  19.437 -
  19.438 -val mk_union = HOLogic.mk_binop @{const_name sup};
  19.439 -
  19.440 -(*dangerous; use with monotonic, converging functions only!*)
  19.441 -fun fixpoint eq f X = if subset eq (f X, X) then X else fixpoint eq f (f X);
  19.442 -
  19.443 -(* stolen from "~~/src/HOL/Tools/Datatype/datatype_aux.ML" *)
  19.444 -fun split_conj_thm th =
  19.445 -  ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
  19.446 -
  19.447 -fun split_conj_prems limit th =
  19.448 -  let
  19.449 -    fun split n i th =
  19.450 -      if i = n then th else split n (i + 1) (conjI RSN (i, th)) handle THM _ => th;
  19.451 -  in split limit 1 th end;
  19.452 -
  19.453 -fun mk_sumEN 1 = @{thm one_pointE}
  19.454 -  | mk_sumEN 2 = @{thm sumE}
  19.455 -  | mk_sumEN n =
  19.456 -    (fold (fn i => fn thm => @{thm obj_sumE_f} RSN (i, thm)) (2 upto n - 1) @{thm obj_sumE}) OF
  19.457 -      replicate n (impI RS allI);
  19.458 -
  19.459 -fun mk_obj_sumEN_balanced n =
  19.460 -  Balanced_Tree.make (fn (thm1, thm2) => thm1 RSN (1, thm2 RSN (2, @{thm obj_sumE_f})))
  19.461 -    (replicate n asm_rl);
  19.462 -
  19.463 -fun mk_sumEN_balanced' n all_impIs = mk_obj_sumEN_balanced n OF all_impIs RS @{thm obj_one_pointE};
  19.464 -
  19.465 -fun mk_sumEN_balanced 1 = @{thm one_pointE} (*optimization*)
  19.466 -  | mk_sumEN_balanced 2 = @{thm sumE} (*optimization*)
  19.467 -  | mk_sumEN_balanced n = mk_sumEN_balanced' n (replicate n (impI RS allI));
  19.468 -
  19.469 -fun mk_tupled_allIN 0 = @{thm unit_all_impI}
  19.470 -  | mk_tupled_allIN 1 = @{thm impI[THEN allI]}
  19.471 -  | mk_tupled_allIN 2 = @{thm prod_all_impI} (*optimization*)
  19.472 -  | mk_tupled_allIN n = mk_tupled_allIN (n - 1) RS @{thm prod_all_impI_step};
  19.473 -
  19.474 -fun mk_sumEN_tupled_balanced ms =
  19.475 -  let val n = length ms in
  19.476 -    if forall (curry op = 1) ms then mk_sumEN_balanced n
  19.477 -    else mk_sumEN_balanced' n (map mk_tupled_allIN ms)
  19.478 -  end;
  19.479 -
  19.480 -fun mk_sum_casesN 1 1 = refl
  19.481 -  | mk_sum_casesN _ 1 = @{thm sum.cases(1)}
  19.482 -  | mk_sum_casesN 2 2 = @{thm sum.cases(2)}
  19.483 -  | mk_sum_casesN n k = trans OF [@{thm sum_case_step(2)}, mk_sum_casesN (n - 1) (k - 1)];
  19.484 -
  19.485 -fun mk_sum_step base step thm =
  19.486 -  if Thm.eq_thm_prop (thm, refl) then base else trans OF [step, thm];
  19.487 -
  19.488 -fun mk_sum_casesN_balanced 1 1 = refl
  19.489 -  | mk_sum_casesN_balanced n k =
  19.490 -    Balanced_Tree.access {left = mk_sum_step @{thm sum.cases(1)} @{thm sum_case_step(1)},
  19.491 -      right = mk_sum_step @{thm sum.cases(2)} @{thm sum_case_step(2)}, init = refl} n k;
  19.492 -
  19.493 -fun mk_rel_xtor_co_induct_thm fp pre_rels pre_phis rels phis xs ys xtors xtor's tac lthy =
  19.494 -  let
  19.495 -    val pre_relphis = map (fn rel => Term.list_comb (rel, phis @ pre_phis)) pre_rels;
  19.496 -    val relphis = map (fn rel => Term.list_comb (rel, phis)) rels;
  19.497 -    fun mk_xtor fp' xtor x = if fp = fp' then xtor $ x else x;
  19.498 -    val dtor = mk_xtor Greatest_FP;
  19.499 -    val ctor = mk_xtor Least_FP;
  19.500 -    fun flip f x y = if fp = Greatest_FP then f y x else f x y;
  19.501 -
  19.502 -    fun mk_prem pre_relphi phi x y xtor xtor' =
  19.503 -      HOLogic.mk_Trueprop (list_all_free [x, y] (flip (curry HOLogic.mk_imp)
  19.504 -        (pre_relphi $ (dtor xtor x) $ (dtor xtor' y)) (phi $ (ctor xtor x) $ (ctor xtor' y))));
  19.505 -    val prems = map6 mk_prem pre_relphis pre_phis xs ys xtors xtor's;
  19.506 -
  19.507 -    val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
  19.508 -      (map2 (flip mk_leq) relphis pre_phis));
  19.509 -  in
  19.510 -    Goal.prove_sorry lthy (map (fst o dest_Free) (phis @ pre_phis)) prems concl tac
  19.511 -    |> Thm.close_derivation
  19.512 -    |> (fn thm => thm OF (replicate (length pre_rels) @{thm allI[OF allI[OF impI]]}))
  19.513 -  end;
  19.514 -
  19.515 -fun mk_un_fold_transfer_thms fp pre_rels pre_phis rels phis un_folds un_folds' tac lthy =
  19.516 -  let
  19.517 -    val pre_relphis = map (fn rel => Term.list_comb (rel, phis @ pre_phis)) pre_rels;
  19.518 -    val relphis = map (fn rel => Term.list_comb (rel, phis)) rels;
  19.519 -    fun flip f x y = if fp = Greatest_FP then f y x else f x y;
  19.520 -
  19.521 -    val arg_rels = map2 (flip mk_fun_rel) pre_relphis pre_phis;
  19.522 -    fun mk_transfer relphi pre_phi un_fold un_fold' =
  19.523 -      fold_rev mk_fun_rel arg_rels (flip mk_fun_rel relphi pre_phi) $ un_fold $ un_fold';
  19.524 -    val transfers = map4 mk_transfer relphis pre_phis un_folds un_folds';
  19.525 -
  19.526 -    val goal = fold_rev Logic.all (phis @ pre_phis)
  19.527 -      (HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj transfers));
  19.528 -  in
  19.529 -    Goal.prove_sorry lthy [] [] goal tac
  19.530 -    |> Thm.close_derivation
  19.531 -    |> split_conj_thm
  19.532 -  end;
  19.533 -
  19.534 -fun mk_xtor_un_fold_o_map_thms fp is_rec m un_fold_unique xtor_maps xtor_un_folds sym_map_comps
  19.535 -    map_cong0s =
  19.536 -  let
  19.537 -    val n = length sym_map_comps;
  19.538 -    val rewrite_comp_comp2 = fp_case fp @{thm rewriteR_comp_comp2} @{thm rewriteL_comp_comp2};
  19.539 -    val rewrite_comp_comp = fp_case fp @{thm rewriteR_comp_comp} @{thm rewriteL_comp_comp};
  19.540 -    val map_cong_passive_args1 = replicate m (fp_case fp @{thm id_o} @{thm o_id} RS fun_cong);
  19.541 -    val map_cong_active_args1 = replicate n (if is_rec
  19.542 -      then fp_case fp @{thm convol_o} @{thm o_sum_case} RS fun_cong
  19.543 -      else refl);
  19.544 -    val map_cong_passive_args2 = replicate m (fp_case fp @{thm o_id} @{thm id_o} RS fun_cong);
  19.545 -    val map_cong_active_args2 = replicate n (if is_rec
  19.546 -      then fp_case fp @{thm map_pair_o_convol_id} @{thm sum_case_o_sum_map_id}
  19.547 -      else fp_case fp @{thm id_o} @{thm o_id} RS fun_cong);
  19.548 -    fun mk_map_congs passive active = map (fn thm => thm OF (passive @ active) RS ext) map_cong0s;
  19.549 -    val map_cong1s = mk_map_congs map_cong_passive_args1 map_cong_active_args1;
  19.550 -    val map_cong2s = mk_map_congs map_cong_passive_args2 map_cong_active_args2;
  19.551 -    
  19.552 -    fun mk_rewrites map_congs = map2 (fn sym_map_comp => fn map_cong =>
  19.553 -      mk_trans sym_map_comp map_cong RS rewrite_comp_comp) sym_map_comps map_congs;
  19.554 -    val rewrite1s = mk_rewrites map_cong1s;
  19.555 -    val rewrite2s = mk_rewrites map_cong2s;
  19.556 -    val unique_prems =
  19.557 -      map4 (fn xtor_map => fn un_fold => fn rewrite1 => fn rewrite2 =>
  19.558 -        mk_trans (rewrite_comp_comp2 OF [xtor_map, un_fold])
  19.559 -          (mk_trans rewrite1 (mk_sym rewrite2)))
  19.560 -      xtor_maps xtor_un_folds rewrite1s rewrite2s;
  19.561 -  in
  19.562 -    split_conj_thm (un_fold_unique OF map (fp_case fp I mk_sym) unique_prems)
  19.563 -  end;
  19.564 -
  19.565 -fun mk_strong_coinduct_thm coind rel_eqs rel_monos ctxt =
  19.566 -  let
  19.567 -    val n = Thm.nprems_of coind;
  19.568 -    val m = Thm.nprems_of (hd rel_monos) - n;
  19.569 -    fun mk_inst phi = (phi, mk_union (phi, HOLogic.eq_const (fst (dest_pred2T (fastype_of phi)))))
  19.570 -      |> pairself (certify ctxt);
  19.571 -    val insts = Term.add_vars (Thm.prop_of coind) [] |> rev |> take n |> map (mk_inst o Var);
  19.572 -    fun mk_unfold rel_eq rel_mono =
  19.573 -      let
  19.574 -        val eq = iffD2 OF [rel_eq RS @{thm predicate2_eqD}, refl];
  19.575 -        val mono = rel_mono OF (replicate m @{thm order_refl} @ replicate n @{thm eq_subset});
  19.576 -      in eq RS (mono RS @{thm predicate2D}) RS @{thm eqTrueI} end;
  19.577 -    val unfolds = map2 mk_unfold rel_eqs rel_monos @ @{thms sup_fun_def sup_bool_def
  19.578 -      imp_disjL all_conj_distrib subst_eq_imp simp_thms(18,21,35)};
  19.579 -  in
  19.580 -    Thm.instantiate ([], insts) coind
  19.581 -    |> unfold_thms ctxt unfolds
  19.582 -  end;
  19.583 -
  19.584 -fun fp_bnf construct_fp bs resBs fp_eqs lthy =
  19.585 -  let
  19.586 -    val time = time lthy;
  19.587 -    val timer = time (Timer.startRealTimer ());
  19.588 -    val (Xs, rhsXs) = split_list fp_eqs;
  19.589 -
  19.590 -    (* FIXME: because of "@ Xs", the output could contain type variables that are not in the
  19.591 -       input; also, "fp_sort" should put the "resBs" first and in the order in which they appear *)
  19.592 -    fun fp_sort Ass =
  19.593 -      subtract (op =) Xs (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs) @ Xs;
  19.594 -
  19.595 -    fun raw_qualify base_b =
  19.596 -      let val (_, qs, n) = Binding.dest base_b;
  19.597 -      in
  19.598 -        Binding.prefix_name rawN
  19.599 -        #> fold_rev (fn (s, mand) => Binding.qualify mand s) (qs @ [(n, true)])
  19.600 -        #> Binding.conceal
  19.601 -      end;
  19.602 -
  19.603 -    val ((bnfs, (deadss, livess)), (unfold_set, lthy)) = apfst (apsnd split_list o split_list)
  19.604 -      (fold_map2 (fn b => bnf_of_typ Smart_Inline (raw_qualify b) fp_sort Xs) bs rhsXs
  19.605 -        (empty_unfolds, lthy));
  19.606 -
  19.607 -    fun norm_qualify i = Binding.qualify true (Binding.name_of (nth bs (Int.max (0, i - 1))))
  19.608 -      #> Binding.conceal;
  19.609 -
  19.610 -    val Ass = map (map dest_TFree) livess;
  19.611 -    val resDs = fold (subtract (op =)) Ass resBs;
  19.612 -    val Ds = fold (fold Term.add_tfreesT) deadss [];
  19.613 -
  19.614 -    val timer = time (timer "Construction of BNFs");
  19.615 -
  19.616 -    val ((kill_poss, _), (bnfs', (unfold_set', lthy'))) =
  19.617 -      normalize_bnfs norm_qualify Ass Ds fp_sort bnfs unfold_set lthy;
  19.618 -
  19.619 -    val Dss = map3 (append oo map o nth) livess kill_poss deadss;
  19.620 -
  19.621 -    fun pre_qualify b = Binding.qualify false (Binding.name_of b)
  19.622 -      #> Config.get lthy' bnf_note_all = false ? Binding.conceal;
  19.623 -
  19.624 -    val ((pre_bnfs, deadss), lthy'') =
  19.625 -      fold_map3 (fn b => seal_bnf (pre_qualify b) unfold_set' (Binding.prefix_name preN b))
  19.626 -        bs Dss bnfs' lthy'
  19.627 -      |>> split_list;
  19.628 -
  19.629 -    val timer = time (timer "Normalization & sealing of BNFs");
  19.630 -
  19.631 -    val res = construct_fp bs resBs (map TFree resDs, deadss) pre_bnfs lthy'';
  19.632 -
  19.633 -    val timer = time (timer "FP construction in total");
  19.634 -  in
  19.635 -    timer; (pre_bnfs, res)
  19.636 -  end;
  19.637 -
  19.638 -end;
    20.1 --- a/src/HOL/BNF/Tools/bnf_gfp.ML	Mon Jan 20 18:24:55 2014 +0100
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,2827 +0,0 @@
    20.4 -(*  Title:      HOL/BNF/Tools/bnf_gfp.ML
    20.5 -    Author:     Dmitriy Traytel, TU Muenchen
    20.6 -    Author:     Andrei Popescu, TU Muenchen
    20.7 -    Author:     Jasmin Blanchette, TU Muenchen
    20.8 -    Copyright   2012
    20.9 -
   20.10 -Codatatype construction.
   20.11 -*)
   20.12 -
   20.13 -signature BNF_GFP =
   20.14 -sig
   20.15 -  val construct_gfp: mixfix list -> binding list -> binding list -> binding list list ->
   20.16 -    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
   20.17 -    local_theory -> BNF_FP_Util.fp_result * local_theory
   20.18 -end;
   20.19 -
   20.20 -structure BNF_GFP : BNF_GFP =
   20.21 -struct
   20.22 -
   20.23 -open BNF_Def
   20.24 -open BNF_Util
   20.25 -open BNF_Tactics
   20.26 -open BNF_Comp
   20.27 -open BNF_FP_Util
   20.28 -open BNF_FP_Def_Sugar
   20.29 -open BNF_GFP_Rec_Sugar
   20.30 -open BNF_GFP_Util
   20.31 -open BNF_GFP_Tactics
   20.32 -
   20.33 -datatype wit_tree = Wit_Leaf of int | Wit_Node of (int * int * int list) * wit_tree list;
   20.34 -
   20.35 -fun mk_tree_args (I, T) (I', Ts) = (sort_distinct int_ord (I @ I'), T :: Ts);
   20.36 -
   20.37 -fun finish Iss m seen i (nwit, I) =
   20.38 -  let
   20.39 -    val treess = map (fn j =>
   20.40 -        if j < m orelse member (op =) seen j then [([j], Wit_Leaf j)]
   20.41 -        else
   20.42 -          map_index (finish Iss m (insert (op =) j seen) j) (nth Iss (j - m))
   20.43 -          |> flat
   20.44 -          |> minimize_wits)
   20.45 -      I;
   20.46 -  in
   20.47 -    map (fn (I, t) => (I, Wit_Node ((i - m, nwit, filter (fn i => i < m) I), t)))
   20.48 -      (fold_rev (map_product mk_tree_args) treess [([], [])])
   20.49 -    |> minimize_wits
   20.50 -  end;
   20.51 -
   20.52 -fun tree_to_ctor_wit vars _ _ (Wit_Leaf j) = ([j], nth vars j)
   20.53 -  | tree_to_ctor_wit vars ctors witss (Wit_Node ((i, nwit, I), subtrees)) =
   20.54 -     (I, nth ctors i $ (Term.list_comb (snd (nth (nth witss i) nwit),
   20.55 -       map (snd o tree_to_ctor_wit vars ctors witss) subtrees)));
   20.56 -
   20.57 -fun tree_to_coind_wits _ (Wit_Leaf _) = []
   20.58 -  | tree_to_coind_wits lwitss (Wit_Node ((i, nwit, I), subtrees)) =
   20.59 -     ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
   20.60 -
   20.61 -(*all BNFs have the same lives*)
   20.62 -fun construct_gfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs lthy =
   20.63 -  let
   20.64 -    val time = time lthy;
   20.65 -    val timer = time (Timer.startRealTimer ());
   20.66 -
   20.67 -    val live = live_of_bnf (hd bnfs);
   20.68 -    val n = length bnfs; (*active*)
   20.69 -    val ks = 1 upto n;
   20.70 -    val m = live - n; (*passive, if 0 don't generate a new BNF*)
   20.71 -    val ls = 1 upto m;
   20.72 -
   20.73 -    val note_all = Config.get lthy bnf_note_all;
   20.74 -    val b_names = map Binding.name_of bs;
   20.75 -    val b_name = mk_common_name b_names;
   20.76 -    val b = Binding.name b_name;
   20.77 -    val mk_internal_b = Binding.name #> Binding.prefix true b_name #> Binding.conceal;
   20.78 -    fun mk_internal_bs name =
   20.79 -      map (fn b =>
   20.80 -        Binding.prefix true b_name (Binding.prefix_name (name ^ "_") b) |> Binding.conceal) bs;
   20.81 -    val external_bs = map2 (Binding.prefix false) b_names bs
   20.82 -      |> note_all = false ? map Binding.conceal;
   20.83 -
   20.84 -    (* TODO: check if m, n, etc., are sane *)
   20.85 -
   20.86 -    val deads = fold (union (op =)) Dss resDs;
   20.87 -    val names_lthy = fold Variable.declare_typ deads lthy;
   20.88 -    val passives = map fst (subtract (op = o apsnd TFree) deads resBs);
   20.89 -
   20.90 -    (* tvars *)
   20.91 -    val ((((((passiveAs, activeAs), passiveBs), activeBs), passiveCs), activeCs), idxT) = names_lthy
   20.92 -      |> variant_tfrees passives
   20.93 -      ||>> mk_TFrees n
   20.94 -      ||>> variant_tfrees passives
   20.95 -      ||>> mk_TFrees n
   20.96 -      ||>> mk_TFrees m
   20.97 -      ||>> mk_TFrees n
   20.98 -      ||> fst o mk_TFrees 1
   20.99 -      ||> the_single;
  20.100 -
  20.101 -    val allAs = passiveAs @ activeAs;
  20.102 -    val allBs' = passiveBs @ activeBs;
  20.103 -    val Ass = replicate n allAs;
  20.104 -    val allBs = passiveAs @ activeBs;
  20.105 -    val Bss = replicate n allBs;
  20.106 -    val allCs = passiveAs @ activeCs;
  20.107 -    val allCs' = passiveBs @ activeCs;
  20.108 -    val Css' = replicate n allCs';
  20.109 -
  20.110 -    (* types *)
  20.111 -    val dead_poss =
  20.112 -      map (fn x => if member (op =) deads (TFree x) then SOME (TFree x) else NONE) resBs;
  20.113 -    fun mk_param NONE passive = (hd passive, tl passive)
  20.114 -      | mk_param (SOME a) passive = (a, passive);
  20.115 -    val mk_params = fold_map mk_param dead_poss #> fst;
  20.116 -
  20.117 -    fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
  20.118 -    val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
  20.119 -    val (dead_params, dead_params') = `(map Term.dest_TFree) (subtract (op =) passiveAs params');
  20.120 -    val FTsAs = mk_FTs allAs;
  20.121 -    val FTsBs = mk_FTs allBs;
  20.122 -    val FTsCs = mk_FTs allCs;
  20.123 -    val ATs = map HOLogic.mk_setT passiveAs;
  20.124 -    val BTs = map HOLogic.mk_setT activeAs;
  20.125 -    val B'Ts = map HOLogic.mk_setT activeBs;
  20.126 -    val B''Ts = map HOLogic.mk_setT activeCs;
  20.127 -    val sTs = map2 (fn T => fn U => T --> U) activeAs FTsAs;
  20.128 -    val s'Ts = map2 (fn T => fn U => T --> U) activeBs FTsBs;
  20.129 -    val s''Ts = map2 (fn T => fn U => T --> U) activeCs FTsCs;
  20.130 -    val fTs = map2 (fn T => fn U => T --> U) activeAs activeBs;
  20.131 -    val self_fTs = map (fn T => T --> T) activeAs;
  20.132 -    val gTs = map2 (fn T => fn U => T --> U) activeBs activeCs;
  20.133 -    val all_gTs = map2 (fn T => fn U => T --> U) allBs allCs';
  20.134 -    val RTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeBs;
  20.135 -    val sRTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeAs;
  20.136 -    val R'Ts = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeBs activeCs;
  20.137 -    val setsRTs = map HOLogic.mk_setT sRTs;
  20.138 -    val setRTs = map HOLogic.mk_setT RTs;
  20.139 -    val all_sbisT = HOLogic.mk_tupleT setsRTs;
  20.140 -    val setR'Ts = map HOLogic.mk_setT R'Ts;
  20.141 -    val FRTs = mk_FTs (passiveAs @ RTs);
  20.142 -    val sumBsAs = map2 (curry mk_sumT) activeBs activeAs;
  20.143 -    val sumFTs = mk_FTs (passiveAs @ sumBsAs);
  20.144 -    val sum_sTs = map2 (fn T => fn U => T --> U) activeAs sumFTs;
  20.145 -
  20.146 -    (* terms *)
  20.147 -    val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
  20.148 -    val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
  20.149 -    val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
  20.150 -    val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
  20.151 -    val map_Inls = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ sumBsAs)) bnfs;
  20.152 -    val map_Inls_rev = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ sumBsAs)) Bss bnfs;
  20.153 -    val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Ass bnfs;
  20.154 -    val map_snds = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Bss bnfs;
  20.155 -    fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
  20.156 -      (map (replicate live) (replicate n Ts)) bnfs;
  20.157 -    val setssAs = mk_setss allAs;
  20.158 -    val setssAs' = transpose setssAs;
  20.159 -    val bis_setss = mk_setss (passiveAs @ RTs);
  20.160 -    val relsAsBs = map4 mk_rel_of_bnf Dss Ass Bss bnfs;
  20.161 -    val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
  20.162 -    val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
  20.163 -    val sum_bdT = fst (dest_relT (fastype_of sum_bd));
  20.164 -
  20.165 -    val emptys = map (fn T => HOLogic.mk_set T []) passiveAs;
  20.166 -    val Zeros = map (fn empty =>